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 .

You are viewing proxied material from sdfeu.org. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.