const
dbg = 0;
al=7; ll=40; txmax=50;
nul=0; ident=1; number=2;
plus=3; minus=4; times=5;
slash=6; oddsym=7; eql=8;
neq=9; lss=10; leq=11;
gtr=12; geq=13; lparen=14;
rparen=15; comma=16; semicolon=17;
period=18; becomes=19; beginsym=20;
endsym=21; ifsym=22; thensym=23;
whilesym=24; dosym=25;
constsym=27; varsym=28;
elsesym=30; repeatsym=31;
untilsym=32; writesym = 33;
constant=1; variable=2;
lit=1; lod=3; sto=4;
jmp=7; jpc=8;
add=21; sub=22; mul=23;
divcmd=24; eqlcmd=28; neqcmd=29;
lsscmd=30; leqcmd=31;
gtrcmd=32; geqcmd=33;
deccmd=34; chrcmd=35;
scrrow=$d6; flags=$02b1;
xreg=$02b3; yreg=$02b4;
clrscrline=$e9ff;
putrowcol=$e50a;
var line:array [ll] of char ;
id:array [al] of char ;
cc:integer ; ch:char ;
sym: integer ; num: integer ;
tabn: array [txmax] of integer ;
tabk: array [txmax] of integer ;
tabv: array [txmax] of integer ;
tx,lx,dx: integer ;
err: integer ;
procedure error(n);
 begin
  if err = 0 then
   begin
    write ("# ");
    case n of
     5: writeln ("; oder , erwartet");
     9: writeln (". erwartet");
     11: writeln ("bezeichner unbekannt");
     12: writeln ("zuweisung zu konstante");
     13: writeln (":= erwartet");
     16: writeln ("then erwartet");
     17: writeln ("; oder end erwartet");
     18: writeln ("do erwartet");
     20: writeln ("vergleichssymbol erwartet");
     22: writeln ("schliessende klammer fehlt");
     23: writeln ("falsches symbol am faktor-ende");
     24: writeln ("until erwartet");
     30: writeln ("zahl zu gross")
    end
   end ;
  err := err + 1;
 end ;
procedure getch;
 var row: integer ;
 begin
  if (line[cc] = 13) or (cc = ll) then
   begin
    cc:= 0;
    row := memc [scrrow];
    write (chr (19));
    memc [xreg] := 0;
    call (clrscrline);
    write (chr (19));
    read (line);
    memc [xreg] := row;
    memc [yreg] := 0;
    memc [flags] := 0;
    call (putrowcol);
    ch:= 32;
   end
  else
   begin
    ch := line[cc];
    cc := cc + 1;
   end ;
 end ;
function getsum;
 var i,sum: integer ;
 begin
  sum := 0;
  for i:= 0 to al - 1 do
   if id[i] >= 65 then
    sum := sum + id[i] - 64;
  getsum:= sum;
 end ;
procedure getsym;
 var k,q: integer ;
 begin
  sym := nul;
  while ch = 32 do
   getch;
  if (ch >= 65) and (ch <=90) then
   begin
    k := 0;
    repeat
     if k < al then
      begin
       id[k] := ch;
       k := k + 1;
      end ;
     getch;
    until (ch < 65) or (ch > 90);
    if k < al then
     repeat
      id[k] := 32;
      k := k + 1;
     until k = al;
    q:= getsum;
    if q = 37 then
     sym := beginsym
    else if q = 23 then
     sym := endsym
    else if q = 15 then
     sym := ifsym
    else if q = 47 then
     sym := thensym
    else if q = 57 then
     sym := whilesym
    else if q = 19 then
     sym := dosym
    else if q = 71 then
     sym := constsym
    else if q = 41 then
     if id[0] = 69 then
      sym := elsesym
     else
      sym := varsym
    else if q = 65 then
     sym := repeatsym
    else if q = 76 then
     sym := untilsym
    else if q = 75 then
     sym := writesym
    else
    sym := ident;
   end
  else if (ch >= 48) and (ch <= 57) then
   begin
    num := 0;
    sym := number;
    repeat
     num := num * 10 + (ch - 48);
     getch;
    until (ch < 48) or (ch > 57);
    if num > 65535 then
     begin
      error(30);
      num := 0;
     end
   end
  else if ch = 58 then
  begin
   getch;
   if ch = 61 then
    begin
     sym := becomes;
     getch;
    end
  end
  else if ch = 60 then
   begin
    getch;
    if ch = 62 then
     begin
      sym := neq;
      getch;
     end
    else if ch = 61 then
     begin
      sym := leq;
      getch;
     end
    else
     sym := lss;
   end
  else if ch = 62 then
   begin
    getch;
    if ch = 61 then
     begin
      sym := geq;
      getch;
     end
    else
     sym := gtr;
   end
  else if ch = 43 then
   begin
    sym := plus;
    getch;
   end
  else if ch = 45 then
   begin
    sym := minus;
    getch;
   end
  else if ch = 42 then
   begin
    sym := times;
    getch;
   end
  else if ch = 47 then
   begin
    sym := slash;
    getch;
   end
  else if ch = 44 then
   begin
    sym := comma;
    getch;
   end
  else if ch = 59 then
   begin
    sym := semicolon;
    getch;
   end
  else if ch = 40 then
   begin
    sym := lparen;
    getch;
   end
  else if ch = 41 then
   begin
    sym := rparen;
    getch;
   end
  else if ch = 61 then
   begin
    sym := eql;
    getch;
   end
  else if ch = 46 then
   sym := period;
  if dbg then writeln ("sym:",sym);
 end ;
procedure enter(kind);
 begin
  tx:= tx + 1;
  (* if tx > txmax then *)
  tabn[tx] := getsum;
  tabk[tx] := kind;
  case kind of
   constant: tabv[tx] := num;
   variable: begin
    tabv[tx] := dx;
    dx := dx + 1;
   end
  end
 end ;
function position;
 var i,sum: integer ;
 begin
  sum := getsum;
  tabn[0] := sum;
  i := tx;
  while tabn[i] <> sum do
   i := i - 1;
  position := i;
 end ;
procedure gen(fct, arg);
 begin
  write ("  ");
  case fct of
   lit: writeln ("+lit ", arg);
   lod: writeln ("+lod var", arg);
   sto: writeln ("+sto var", arg);
   jmp: writeln ("jmp lbl", arg);
   jpc: writeln ("+jpc lbl", arg);
   add: writeln ("jsr add");
   sub: writeln ("jsr sub");
   mul: writeln ("jsr mul");
   divcmd: writeln ("jsr div");
   eqlcmd: writeln ("jsr eql");
   neqcmd: writeln ("jsr neq");
   lsscmd: writeln ("jsr lss");
   leqcmd: writeln ("jsr leq");
   gtrcmd: writeln ("jsr gtr");
   geqcmd: writeln ("jsr geq");
   deccmd: writeln ("jsr outdec");
   chrcmd: writeln ("jsr outchr")
  end ;
 end ;
function getlx;
 begin
  lx := lx + 1;
  getlx := lx - 1;
 end ;
procedure lbl(no);
 begin
  writeln ("lbl", no);
 end ;
procedure constdecl;
 begin
  if sym = ident then
   begin
    getsym;
    if sym = eql then
     begin
      getsym;
      if sym = number then
       begin
        enter(constant);
        getsym;
       end
     end
   end
 end ;
procedure vardecl;
 begin
  if sym = ident then
   begin
    enter(variable);
    getsym;
   end
 end ;
procedure expression;
 var addop: integer ;
 procedure factor;
  var i: integer ;
  begin
   if dbg then writeln ("factor");
   if sym = ident then
    begin
     i := position;
     if i = 0 then
      error(11);
     case tabk[i] of
      constant: gen(lit, tabv[i]);
      variable: gen(lod, tabv[i])
     end ;
     getsym;
    end
   else if sym = number then
    begin
     if num > 65535 then
      begin
       error(30);
       num := 0;
      end ;
     gen(lit, num);
     getsym;
    end
   else if sym = lparen then
    begin
     getsym;
     expression;
     if sym <> rparen then
      error(22);
     getsym;
    end
   else
    error(23);
  end ;
 procedure term;
 var mulop: integer ;
  begin
   if dbg then writeln ("term");
   factor;
   while (sym = times) or (sym = slash) do
    begin
     mulop := sym;
     getsym;
     factor;
     if mulop = times then
      gen(mul, 0)
     else
      gen(divcmd, 0);
    end ;
  end ;
 begin
  if dbg then writeln ("expression");
  term;
  while (sym = plus) or (sym = minus) do
   begin
    addop := sym;
    getsym;
    term;
    if addop = plus then
     gen(add, 0)
    else
     gen(sub, 0);
   end ;
 end ;
procedure condition;
 var relop: integer ;
 begin
  if dbg then writeln ("condition");
  expression;
  case sym of
   eql, neq, lss, leq, gtr, geq:
    begin
     relop := sym;
     getsym;
     expression;
     case relop of
      eql: gen(eqlcmd, 0);
      neq: gen(neqcmd, 0);
      lss: gen(lsscmd, 0);
      leq: gen(leqcmd, 0);
      gtr: gen(gtrcmd, 0);
      geq: gen(geqcmd, 0)
     end
    end
   else
    begin
     error(20);
     getsym;
    end
   end ;
 end ;
procedure statement;
 var i,lx0,lx1: integer ;
 begin
  if dbg then writeln ("statement");
  if sym = ident then
   begin
    i:= position;
    if i = 0 then
     error(11);
    if tabk[i] <> variable then
     begin
      error(12);
      i:= 0;
     end ;
    getsym;
    if sym <> becomes then
     error(13);
    getsym;
    expression;
    if i <> 0 then
     gen(sto, tabv[i]);
   end
  else if sym = ifsym then
   begin
    writeln ("; if");
    lx0 := getlx;
    lx1 := getlx;
    getsym;
    condition;
    if sym <> thensym then
     error(16);
    getsym;
    gen(jpc, lx0);
    writeln ("; then");
    statement;
    if sym = elsesym then
     begin
      gen(jmp, lx1);
      writeln ("; else");
      lbl(lx0);
      getsym;
      statement;
      writeln ("; endif");
      lbl(lx1);
     end
    else
     begin
      writeln ("; endif");
      lbl(lx0);
     end
   end
  else if sym = beginsym then
   begin
    getsym;
    statement;
    while sym = semicolon do
     begin
      getsym;
      statement;
     end ;
    if sym <> endsym then
     error(17);
    getsym;
   end
  else if sym = whilesym then
   begin
    writeln ("; while");
    lx0 := getlx;
    lx1 := getlx;
    lbl(lx0);
    getsym;
    condition;
    if sym <> dosym then
     error(19);
    getsym;
    gen(jpc, lx1);
    writeln ("; do");
    statement;
    gen(jmp, lx0);
    writeln ("; endwhile");
    lbl(lx1);
   end
  else if sym = repeatsym then
   begin
    writeln ("; repeat");
    lx0 := getlx;
    lbl(lx0);
    getsym;
    statement;
    while sym = semicolon do
     begin
      getsym;
      statement;
     end ;
    if sym <> untilsym then
     error(24);
    writeln ("; until");
    getsym;
    condition;
    gen(jpc, lx0);
    writeln ("; endrepeat");
   end
  else if sym = writesym then
   begin
    writeln ("; write");
    getsym;
    expression;
    gen(deccmd, 0);
    while sym = comma do
     begin
      gen(lit, 32);
      gen(chrcmd, 0);
      getsym;
      expression;
      gen(deccmd, 0);
     end ;
    gen(lit, 13);
    gen(chrcmd, 0);
    writeln ("; endwrite");
   end ;
 end ;
procedure block;
 begin
  if dbg then writeln ("block");
  if sym = constsym then
   begin
    getsym;
    constdecl;
    while sym = comma do
     begin
      getsym;
      constdecl;
     end ;
    if sym <> semicolon then
     error(5);
    getsym;
   end ;
  if sym = varsym then
   begin
    getsym;
    vardecl;
    while sym = comma do
     begin
      getsym;
      vardecl;
     end ;
    if sym <> semicolon then
     error(5);
    getsym;
   end ;
  statement;
 end ;
procedure dump;
 var i: integer ;
 begin
  for i:= 0 to tx do
   writeln (tabn[i],":",tabk[i],":",tabv[i]);
 end ;
begin
cc:= 0; ch:= 32;
line[cc] := 13;
sym := nul; num := 0;
tx:= 0; tabn[0]:= 0;
tabk[0] := 0; tabv[0] := 0;
lx:= 1; dx:= 1;
err := 0;
writeln (chr (147));
getsym;
block;
if sym <> period then
 error(9);
if err = 0 then dump;
end .