Oakland CPM Archive/oakcpm.iso/sigm/vol162/compile.pas

Pascal/Delphi Source File | 1984-04-29 | 33.4 KB | 1,941 lines

{$S+}  {recursion on}

{$K1} {$K2} {$K7} {$K12} {$K13} {$K14}  { reduce symbol table space }

module compiler;

{$I global.inc}

var
   sy:    external symbol;        {last symbol read by insymbol}
   id:    external alfa;            {identifier from insymbol}
   inum: external integer;        {integer from insymbol}
   rnum: external real;            {real number from insymbol}
   sleng: external integer;        {string length}
   ch:  external char;            {last character read from source program}
   line: external array
      [1.. llng] of char;
   cc:    external integer;        {character counter}
   lc:  external integer;        {program location counter}
   ll:    external integer;        {length of current line}
   errs: external set of er;
   errpos: external integer;
   progname: external  alfa;
   skipflag: external  boolean;
   constbegsys, typebegsys, blockbegsys, facbegsys, statbegsys: external symset;
   key: external array
      [1.. nkw] of alfa;
   ksy: external array
      [1.. nkw] of symbol;
   sps: external array
      [char]    of symbol;        {special aymbols}
   t, a, b, sx, c1, c2: external integer;    {indices to tables}
   stantyps: external typset;
   display: external array
      [0.. lmax] of integer;        {identifier table}
   tab: external array
      [0.. tmax] of             {identifier table}
   packed record
          name: alfa;
          link: index;
          obj: object;
          typ: types;
          ref: index;
          normal: boolean;
          lev: 0.. lmax;
          adr: integer;
       end;
   atab: external  array
      [1.. amax] of             {array table}
   packed record
          inxtyp, eltyp: types;
          elref, low, high,    elsize,    size: index;
       end;
   btab: external array
      [1..bmax] of             {block-table}
   packed record
          last, lastpar, psize, vsize: index
       end;
   stab: external  packed array
      [0.. smax] of char;        {string table}
   code: external array
      [0.. cmax] of order;
   tabchar  : char;            {holds tab char for scanner }

procedure abort;
{ return to CP/M }

begin
  inline("JMP/ $00/ $00)
end;

procedure errormsg;

   var
      k: er;
      msg: array
      [er] of alfa;

   begin
      msg[erid] :=  'identifier';
      msg[ertyp] := 'type      ';
      msg[erkey] := 'keyword   ';
      msg[erpun] := 'punctuatio';
      msg[erpar] := 'parameter ';
      msg[ernf] :=  'not found ';
      msg[erdup] := 'duplicate ';
      msg[erch] :=  'character ';
      msg[ersh] :=  'too short ';
      msg[erln] :=  'too long  ';
      writeln('compilation errors');
      writeln;
      writeln('key words');
      for k :=    erid to    erln do
      if k in errs then
         writeln(ord(k), ' ', msg[k])
   end    {errormsg};


procedure endskip;

   begin {underline skips part of input}
      while errpos < cc do
      begin
         write('-');
         errpos := errpos +    1
      end;
      skipflag    := false
   end    {endskip};


procedure nextch;

{read    next character;    process    line end}

   begin
      if cc = ll
      then
      begin
         if    eof(input) then
        begin
           writeln;
           writeln('program incomplete');
           errormsg;
           {goto    99}
           abort;
        end;
         if    errpos <> 0 then
        begin
           if skipflag then
              endskip;
           writeln;
           errpos := 0
        end;
         write(lc: 5, ' ');
         ll    := 0;
          cc    := 0;
         while not eoln(input) do
        begin
           ll := ll + 1;
           read(ch);
           write(ch);
           line[ll] := ch
        end;
         writeln;
         ll    := ll +    1;
         read(line[ll]);
      end;
      cc := cc    + 1;
      ch := line[cc];
   end    {nextch};


procedure error(n: er);

   begin
      if errpos = 0 then
      write('****');
      if cc > errpos then
      begin
         write(' ':    cc - errpos, '^', ord(n): 2);
         errpos := cc + 3;
         errs := errs + [n]
      end
   end    {error};


procedure fatal(n: integer);

   var
      msg: array
      [1..6] of alfa;

   begin
      writeln;
      errormsg;
      msg[1]    := 'identifier';
      msg[2]    := 'procedures';
      msg[3]    := 'string    ';
      msg[4]    := 'arrays    ';
      msg[5]    := 'level     ';
      msg[6]    := 'code      ';
      writeln('compiler table for ', msg[n],    ' is too small');
      { goto 99;  terminate compilation}
      abort;
   end    {fatal};


procedure insymbol;

{reads next symbol}

   label
      1, 2, 3;

   var
      i, j, k,    e: integer;

   begin {insymbol}
   1: while ch    in [' ',tabchar] do
      nextch;
      case ch of
       'a', 'b', 'c', 'd', 'e', 'f',    'g', 'h', 'i', 'j', 'k', 'l', 'm'
         , 'n', 'o', 'p', 'q', 'r',    's', 't', 'u', 'v', 'w', 'x', 'y'
         , 'z':
         begin {identifier    or wordsymbol}
        k := 0;
        id := '         ';
        repeat
           if k    < alng then
              begin
             k := k    + 1;
             id[k] := ch
              end;
           nextch
        until not (ch in [
        'a' .. 'z', '0'    .. '9']);
        i := 1;
        j := nkw;        {binary search}
        repeat
           k :=    (i + j)    div 2;
           if id <= key[k] then
              j    := k - 1;
           if id >= key[k] then
              i    := k + 1
        until i    > j;
        if i - 1 > j
        then
           sy := ksy[k]
        else
           sy := ident
         end;
      '0', '1', '2', '3', '4', '5',    '6', '7', '8', '9':
         begin {number}
        k := 0;
        inum :=    0;
        sy := intcon;
        repeat
           inum    := inum    * 10 + ord(ch) - ord('0');
           k :=    k + 1;
           nextch
        until not (ch in [
        '0' .. '9']);
        if (k >    kmax) or (inum > nmax) then
           begin
              error(erln);
              inum := 0;
              k    := 0
           end;
         end;
      ':' {, col}:
         begin
        nextch;        {mod mh}
        if ch =    '='
        then
           begin
              sy := becomes;
              nextch
           end
        else
           sy := colon
         end;
      '<':
         begin
        nextch;
        if ch =    '='
        then
           begin
              sy := leq;
              nextch
           end
        else
           if ch = '>'
           then
              begin
             sy := neq;
             nextch
              end
           else
              sy := lss
         end;
      '>':
         begin
        nextch;
        if ch =    '='
        then
           begin
              sy := geq;
              nextch
           end
        else
           sy := gtr
         end;
      '.':
         begin
        nextch;
        if ch =    '.'
        then
           begin
              sy := colon;
              nextch
           end
        else
           if ch = ')'
           then
              begin
             sy := rbrack;
             nextch
              end
           else
              sy := period
         end;
       '''':
         begin
        k := 0;
         2:    nextch;
        if ch =    '''' then
           begin
              nextch;
              if ch <> '''' then
             goto 3
           end;
        if sx +    k = smax then
           fatal(3);
        stab[sx + k] := ch;
        k := k + 1;
        if cc =    1
        then
           begin {end of line}
              k    := 0;
           end
        else
           goto    2;
         3:    if k = 1
        then
           begin
              sy := charcon;
              inum := ord(stab[sx])
           end
        else
           if k    = 0
           then
              begin
             error(ersh);
             sy := charcon;
             inum := 0
              end
           else
              begin
             sy := string;
             inum := sx;
             sleng := k;
             sx := sx + k
              end
         end;
      '(':
         begin
        nextch;
        if ch =    '.'
        then
           begin
              sy := lbrack;
              nextch
           end
        else
           if ch <> '*'
           then
              sy := lparent
           else
              begin {comment}
             nextch;
             repeat
                while ch <>    '*' do
                   nextch;
                nextch
             until ch = ')';
             nextch;
             goto 1
              end
         end;
      '+', '-', '*', ')', '=', ',',    ';','[',']' :
         begin
        sy := sps[ch];
        nextch
         end;
      '$', '!', '@', '^', '?',
     {'""',}
           '&', '/','\' :
         begin
        error(erch);
        nextch;
        goto 1
         end
      end
   end    {insymbol};


procedure enterstandardids(x0: alfa; x1: object; x2: types; x3: integer);

   begin
      t := t +    1;
{enter standard identifier}
      with tab[t] do
      begin
         name := x0;
         link := t - 1;
         obj := x1;
         typ := x2;
         ref := 0;
         normal := true;
         lev := 0;
         adr := x3
      end
   end    {enter};


procedure enterarray(tp: types; l, h: integer);

   begin
      if l > h    then
      error(ertyp);
      if (abs(l) > xmax) or (abs(h) > xmax) then
      begin
         error(ertyp);
         l := 0;
         h := 0;
      end;
      if a = amax
      then
      fatal(4)
      else
      begin
         a := a + 1;
         with atab[a] do
        begin
           inxtyp := tp;
           low := l;
           high    := h
        end
      end {enterarray};
   end    {enterarray};

{fix mh}


procedure enterblock;

   begin
      if b = bmax
      then
      fatal(2)
      else
      begin
         b := b + 1;
         btab[b].last := 0;
         btab[b].lastpar := 0
      end
   end    {enterblock};


procedure emit(fct: integer);

   begin
      if lc = cmax then
      fatal(6);
      code[lc].f := fct;
      lc := lc    + 1;
   end    {emit};


procedure emit1(fct, b: integer);

   begin
      if lc = cmax then
      fatal(6);
      with code[lc] do
      begin
         f := fct;
         y := b
      end;
      lc := lc    + 1;
   end    {emit1};


procedure emit2(fct, a, b: integer);

   begin
      if lc = cmax then
      fatal(6);
      with code[lc] do
      begin
         f := fct;
         x := a;
         y := b
      end;
      lc := lc    + 1;
   end    {emit2};


procedure block(fsys: symset; isfun: boolean; level: integer);

   type
      conrec =    record
           tp: types;
           i: integer
        end;

   var
      dx: integer;    {data    allocation index}
      prt: integer;    {t-index of this procedure}
      prb: integer;    {b-index of this procedure}
      x: integer;


   procedure skip(fsys: symset; n: er);

      begin
      error(n);
      skipflag := true;
      while    not (sy    in fsys) do
         insymbol;
      if skipflag then
         endskip;
      end {skip};


   procedure test(s1, s2: symset; n: er);

      begin
      if not (sy in    s1) then
         skip(s1 + s2, n)
      end {test};


   procedure testsemicolon;

      begin
      if sy    = semicolon
      then
         insymbol
      else
         error(erpun);
      test([ident] + blockbegsys,    fsys, erkey);
      end {testsemicolon};


    procedure  enter(id:    alfa; k: object);

      var
      j, l:    integer;

      begin
      if t = tmax
      then
         fatal(1)
      else
         begin
        tab[0].name := id;
        j := btab[display[level]].last;
        l := j;
        while tab[j].name <> id do
           j :=    tab[j].link;
        if j <>    0
        then
           error(erdup)
        else
           begin
              t    := t + 1;
              with tab[t] do
             begin
                name := id;
                link := l;
                obj    := k;
                typ    := notyp;
                ref    := 0;
                lev    := level;
                adr    := 0
             end;
              btab[display[level]].last := t
           end
         end
      end {enter};


   function loc(id: alfa): integer;

      var
      i, j:    integer;    {locate id in    table}

      begin
      i := level;
      tab[0].name    := id;    {sentinel}
      repeat
         j := btab[display[i]].last;
         while tab[j].name <> id do
        j := tab[j].link;
         i := i - 1;
      until    (i < 0)    or (j <> 0);
      if j = 0 then
         error(ernf);
      loc := j
      end {loc};


   procedure entervariable;

      begin
      if sy    = ident
      then
         begin
        enter(id, variable);
        insymbol
         end
      else
         error(erid)
      end {entervariable};


   procedure constant(fsys: symset; var c: conrec);

      var
      x, sign: integer;

      begin
      c.tp := notyp;
      c.i := 0;
      test(constbegsys, fsys, erkey);
      if sy    in constbegsys
      then
         begin
        if sy =    charcon
        then
           begin
              c.tp := chars;
              c.i := inum;
              insymbol
           end
        else
           begin
              sign := 1;
              if sy in [plus, minus] then
             begin
                if sy = minus then
                   sign := - 1;
                insymbol
             end;
              if sy = ident
              then
             begin
                x := loc(id);
                if x <> 0 then
                   if tab[x].obj <> konstant
                   then
                  error(ertyp)
                   else
                  begin
                     c.tp := tab[x].typ;
                     c.i := sign * tab[x].adr
                  end;
                insymbol
             end
              else
             if sy = intcon
             then
                begin
                   c.tp := ints;
                   c.i := sign * inum;
                   insymbol
                end
             else
                skip(fsys, erkey)
           end;
        test(fsys, [], erkey);
         end
      end {constant};


   procedure typ(fsys:    symset;    var tp:    types; var rf, sz: integer);

      var
      x: integer;
      eltp:    types;
      elrf:    integer;
      elsz,    offset,    t0, t1:    integer;


      procedure arraytyp(var aref, arsz: integer);

      var
         eltp: types;
         low, high:    conrec;
         elrf, elsz: integer;

      begin
         constant([colon, rbrack, ofsy] +    fsys, low);
         if    sy = colon
         then
        insymbol
         else
        error(erpun);
         constant([rbrack,    comma, ofsy] +    fsys, high);
         if    high.tp    <> low.tp then
        begin
           error(ertyp);
           high.i := low.i
        end;
         enterarray(low.tp,    low.i, high.i);
         aref := a;
         if    sy = comma
         then
        begin
           insymbol;
           eltp    := arrays;
           arraytyp(elrf, elsz)
        end
         else
        begin
           if sy = rbrack
           then
              insymbol
           else
              error(erpun);
           if sy = ofsy
           then
              insymbol
           else
              error(erkey);
           typ(fsys, eltp, elrf, elsz)
        end;
         with atab[aref] do
        begin
           arsz    := (high - low + 1) * elsz;
           size    := arsz;
           eltyp := eltp;
           elref := elrf;
           elsize := elsz
        end;
      end {arraytyp};


      begin {typ}
      tp :=    notyp;
      rf :=    0;
      sz :=    0;
      test(typebegsys, fsys, erid);
      if sy    in typebegsys
      then
         begin
        if sy =    ident
        then
           begin
              x    := loc(id);
              if x <> 0    then
             with tab[x] do
                if obj <> type1
                then
                   error(ertyp)
                else
                   begin
                  tp :=    typ;
                  rf :=    ref;
                  sz :=    adr;
                  if tp    = notyp    then
                     error(ertyp)
                   end;
              insymbol
           end
        else
           if sy = arraysy
           then
              begin
             insymbol;
             if sy = lbrack
             then
                insymbol
             else
                error(erpun);
             tp := arrays;
             arraytyp(rf, sz)
              end
           else
              test(fsys, [], erkey);
         end
      end {typ};


   procedure parameterlist;    {formal parameter list}

      var
      tp: types;
      rf, sz, x, t0: integer;
      valpar: boolean;

      begin
      insymbol;
      tp :=    notyp;
      rf :=    0;
      sz :=    0;
      test([ident,    varsy], fsys +    [rparent], erpar);
      while    sy in [ident, varsy] do
         begin
        if sy <> varsy
        then
           valpar := true
        else
           begin
              insymbol;
              valpar :=    false
           end;
        t0 := t;
        entervariable;
        while sy = comma do
           begin
              insymbol;
              entervariable;
           end;
        if sy =    colon
        then
           begin
              insymbol;
              if sy <> ident
              then
             error(erid)
              else
             begin
                x := loc(id);
                insymbol;
                if x <> 0 then
                   with tab[x] do
                  if obj <> type1
                  then
                     error(ertyp)
                  else
                     begin
                    tp := typ;
                    rf := ref;
                    if valpar
                    then
                       sz := adr
                    else
                       sz := 1
                     end;
             end;
              test([semicolon,    rparent], [comma, ident] +
             fsys, erpun)
           end
        else
           error(erpun);
        while t0 < t do
           begin
              t0 := t0 + 1;
              with tab[t0] do
             begin
                typ    := tp;
                ref    := rf;
                normal := valpar;
                adr    := dx;
                lev    := level;
                dx := dx + sz
             end
           end;
        if sy <> rparent then
           begin
              if sy = semicolon
              then
             insymbol
              else
             error(erpun);
              test([ident, varsy], [rparent] + fsys, erkey);
           end
         end;
      if sy    = rparent
      then
         begin
        insymbol;
        test([semicolon, colon], fsys, erkey);
         end
      else
         error(erpun)
      end {parameterlist};


   procedure constdeclaration;

      var
      c: conrec;

      begin
      insymbol;
      test([ident], blockbegsys, erid);
      while    sy = ident do
         begin
        enter(id, konstant);
        insymbol;
        if sy =    eql
        then
           insymbol
        else
           error(erpun);
        constant([semicolon, comma, ident] + fsys, c);
        tab[t].typ :=    c.tp;
        tab[t].ref :=    0;
        tab[t].adr :=    c.i;
        testsemicolon
         end
      end {constdeclaration};


   procedure typedeclaration;

      var
      tp: types;
      rf, sz, t1: integer;

      begin
      insymbol;
      test([ident], blockbegsys, erid);
      while    sy = ident do
         begin
        enter(id, type1);
        t1 := t;
        insymbol;
        if sy =    eql
        then
           insymbol
        else
           error(erpun);
        typ([semicolon, comma,    ident]    + fsys,    tp, rf,    sz);
        with tab[t1] do
           begin
              typ := tp;
              ref := rf;
              adr := sz
           end;
        testsemicolon
         end
      end {typedeclaration};


   procedure vardeclaration;

      var
      t0, t1, rf, sz: integer;
      tp: types;

      begin
      insymbol;
      while    sy = ident do
         begin
        t0 := t;
        entervariable;
        while sy = comma do
           begin
              insymbol;
              entervariable;
           end;
        if sy =    colon
        then
           insymbol
        else
           error(erpun);
        t1 := t;
        typ([semicolon, comma,    ident]    + fsys,    tp, rf,    sz);
        while t0 < t1 do
           begin
              t0 := t0 + 1;
              with tab[t0] do
             begin
                typ    := tp;
                ref    := rf;
                lev    := level;
                adr    := dx;
                normal := true;
                dx := dx + sz
             end
           end;
        testsemicolon
         end
      end {variab|edeclaration};


   procedure procdeclaration;

      var
      isfun: boolean;

      begin
      isfun    := sy =    functionsy;
      insymbol;
      if sy    <> ident then
         begin
        error(erid);
        id := '         ';
         end;
      if isfun
      then
         enter(id, funktion)
      else
         enter(id, prozedure);
      tab[t].normal := true;
      insymbol;
      block([semicolon] +    fsys, isfun, level + 1);
      if sy    = semicolon
      then
         insymbol
      else
         error(erpun);
      emit(32 + ord(isfun))    {exit}
      end {proceduredeclaration};



   procedure statement(fsys: symset);

      var
      i: integer;
      x: item;


      procedure expression(fsys: symset; var x: item);
      forward;


      procedure selector(fsys:    symset;    var v: item);

      var
         x:    item;
         a,    j: integer;

      begin
         if    sy <> lbrack then
        error(ertyp);
         repeat
        insymbol;
        expression(fsys    + [comma, rbrack], x);
        if v.typ <> arrays
        then
           error(ertyp)
        else
           begin
              a    := v.ref;
              if atab[a].inxtyp <> x.typ
              then
             error(ertyp)
              else
             emit1(21, a);
              v.typ := atab[a].eltyp;
              v.ref := atab[a].elref
           end
         until sy <> comma;
         if    sy = rbrack
         then
        insymbol
         else
        error(erpun);
         test(fsys,    [], erkey);
      end {selector};


      procedure call(fsys: symset; i: integer);

      var
         x:    item;
         lastp, cp,    k: integer;

      begin
         emit1(18, i);        {markstack}
         lastp := btab[tab[i].ref].lastpar;
         cp    := i;
         if    sy = lparent
         then
        begin             {actual parameter list}
           repeat
              insymbol;
              if cp >= lastp
              then
             error(erpar)
              else
             begin
                cp := cp + 1;
                if tab[cp].normal
                then
                   begin     {value parameter}
                  expression(fsys + [comma, colon,
                     rparent],    x);
                  if x.typ = tab[cp].typ
                  then
                     begin
                    if x.ref <> tab[cp].ref
                    then
                       error(ertyp)
                    else
                       if x.typ = arrays then
                          emit1(22,    atab[x.ref].
                         size)
                     end
                  else
                     if    x.typ <> notyp then
                    error(ertyp);
                   end
                else
                   begin     {variable    parameter}
                  if sy    <> ident
                  then
                     error(erid)
                  else
                     begin
                    k := loc(id);
                    insymbol;
                    if k <>    0
                    then
                       begin
                          if tab[k].obj <> variable
                          then
                         error(erpar);
                          x.typ := tab[k].typ;
                          x.ref := tab[k].ref;
                          if tab[k].normal
                          then
                         emit2(0, tab[k].lev,
                            tab[k].adr)
                          else
                         emit2(1, tab[k].lev,
                            tab[k].adr);
                          if sy = lbrack then
                         selector(fsys + [comma,
                            colon, rparent], x);
                          if (x.typ    <> tab[cp].typ)
                         or (x.ref <> tab[cp].
                         ref)
                          then
                         error(ertyp)
                       end
                     end
                   end
             end;
              test([comma, rparent], fsys, erkey);
           until sy <> comma;
           if sy = rparent
           then
              insymbol
           else
              error(erpun)
        end;
         if    cp < lastp then
        error(erpar);        {too few actual parameters}
         emit1(19, btab[tab[i].ref].psize - 1);
         if    tab[i].lev < level then
        emit2(3, tab[i].lev, level)
      end {call};


      function    resulttype(a, b: types): types;

      begin
         if    (a > ints) or (b > ints)
         then
        begin
           error(ertyp);
           resulttype := notyp
        end
         else
        if (a =    notyp) or (b = notyp)
        then
           resulttype := notyp
        else
           resulttype := ints
      end {resulttyp};


      procedure expression;

      var
         y:    item;
         op: symbol;


      procedure simpleexpression(fsys: symset; var x: item);

         var
        y: item;
        op: symbol;


         procedure term(fsys: symset; var x: item);

        var
           y: item;
           op: symbol;
           ts: typset;


        procedure factor(fsys: symset; var x: item);

           var
              i, f: integer;

           begin {factor}
              x.typ := notyp;
              x.ref := 0;
              test(facbegsys, fsys, erpun);
              while sy in facbegsys do
             begin
                if sy = ident
                then
                   begin
                  i := loc(id);
                  insymbol;
                  with tab[i]    do
                     case obj of
                    konstant:
                       begin
                          x.typ := typ;
                          x.ref := 0;
                          emit1(24,    adr)
                       end;
                    variable:
                       begin
                          x.typ := typ;
                          x.ref := ref;
                          if sy = lbrack
                          then
                         begin
                            if normal
                            then
                               f := 0
                            else
                               f := 1;
                            emit2(f, lev, adr);
                            selector(fsys, x);
                            if x.typ in    stantyps
                            then
                               emit(34)
                         end
                          else
                         begin
                            if x.typ in    stantyps
                            then
                               if normal
                               then
                              f := 1
                               else
                              f := 2
                            else
                               if normal
                               then
                              f := 0
                               else
                              f := 1;
                            emit2(f, lev, adr)
                         end
                       end;
                    type1, prozedure:
                       error(ertyp);
                    funktion:
                       begin
                          x.typ := typ;
                          if lev <>    0
                          then
                         call(fsys, i)
                          else
                         emit1(8, adr)
                       end
                     end {case, with}
                   end
                else
                   if sy in    [charcon, intcon]
                   then
                  begin
                     if    sy = charcon
                     then
                    x.typ := chars
                     else
                    x.typ := ints;
                     emit1(24, inum);
                     x.ref := 0;
                     insymbol
                  end
                   else
                  if sy    = lparent
                  then
                     begin
                    insymbol;
                    expression(fsys    + [rparent], x);
                    if sy =    rparent
                    then
                       insymbol
                    else
                       error(erpun)
                     end
                  else
                     if    sy = notsy then
                    begin
                       insymbol;
                       factor(fsys,    x);
                       if x.typ = bools
                       then
                          emit(35)
                       else
                          if x.typ <> notyp    then
                         error(ertyp)
                    end;
                test(fsys, facbegsys, erkey);
             end {while}
           end {factor};


        begin {term}
           factor(fsys + [times, idiv,    imod, andsy], x);
           while sy in [times,    idiv, imod, andsy] do
              begin
             op := sy;
             insymbol;
             factor(fsys + [times,    idiv, imod, andsy], y);
             if op = times
             then
                begin
                   x.typ :=    resulttype(x.typ, y.typ);
                   if x.typ    = ints then
                  emit(57)
                end
             else
                if op = andsy
                then
                   begin
                  if (x.typ = bools) and (y.typ    = bools)
                  then
                     emit(56)
                  else
                     begin
                    if (x.typ <> notyp) and    (y.typ <>
                       notyp)
                    then
                       error(ertyp);
                    x.typ := notyp
                     end
                   end
                else
                   begin {op in[idiv, imod]}
                  if (x.typ = ints) and    (y.typ = ints)
                  then
                     if    op = idiv
                     then
                    emit(58)
                     else
                    emit(59)
                  else
                     begin
                    if (x.typ <> notyp) and    (y.typ <>
                       notyp)
                    then
                       error(ertyp);
                    x.typ := notyp
                     end
                   end
              end
        end {term};


         begin {simpleexpression}
        if sy in [plus, minus]
        then
           begin
              op := sy;
              insymbol;
              term(fsys    + [plus, minus], x);
              if x.typ > ints
              then
             error(ertyp)
              else
             if op = minus then
                emit(36)
           end
        else
           term(fsys + [plus, minus, orsy], x);
        while sy in [plus, minus, orsy] do
           begin
              op := sy;
              insymbol;
              term(fsys    + [plus, minus, orsy], y);
              if op = orsy
              then
             begin
                if (x.typ =    bools) and (y.typ = bools)
                then
                   emit(51)
                else
                   begin
                  if (x.typ <> notyp) and (y.typ <> notyp)
                  then
                     error(ertyp);
                  x.typ    := notyp
                   end
             end
              else
             begin
                x.typ := resulttype(x.typ, y.typ);
                if x.typ = ints then
                   if op = plus
                   then
                  emit(52)
                   else
                  emit(53)
             end
           end
         end {simpleexpression};


      begin    {expression};
         simpleexpression(fsys + [eql, neq, lss, leq, gtr,    geq], x);
         if    sy in [eql, neq, lss, leq, gtr, geq]
         then
        begin
           op := sy;
           insymbol;
           simpleexpression(fsys, y);
           if (x.typ in    [notyp, ints, bools, chars]) and (x.typ
              =    y.typ)
           then
              case op of
             eql:
                emit(45);
             neq:
                emit(46);
             lss:
                emit(47);
             leq:
                emit(48);
             gtr:
                emit(49);
             geq:
                emit(50);
              end
           else
              error(ertyp);
           x.typ := bools
        end
      end {expression};


      procedure assignment(lv,    ad: integer);

      var
         x,    y: item;
         f:    integer;        {tab[i]. obj in [variable,prozedure]}

      begin
         x.typ := tab[i].typ;
         x.ref := tab[i].ref;
         if    tab[i].normal
         then
        f := 0
         else
        f := 1;
         emit2(f, lv, ad);
         if    sy = lbrack then
        selector([becomes, eql] + fsys, x);
         if    sy = becomes
         then
        insymbol
         else
        error(erpun);
         expression(fsys, y);
         if    x.typ =    y.typ
         then
        if x.typ in stantyps
        then
           emit(38)
        else
           if x.ref <> y.ref
           then
              error(ertyp)
           else
              if x.typ = arrays
              then
             emit1(23, atab[x.ref].size)
              else
             error(ertyp)
      end {assignment};


      procedure compoundstatement;

      begin
         insymbol;
         statement([semicolon, endsy] + fsys);
         while sy in [semicolon] + statbegsys do
        begin
           if sy = semicolon
           then
              insymbol
           else
              error(erpun);
           statement([semicolon, endsy] + fsys)
        end;
         if    sy = endsy
         then
        insymbol
         else
        error(erkey)
      end {compoundstatement};


      procedure ifstatement;

      var
         x:    item;
         lc1, lc2: integer;

      begin
         insymbol;
         expression(fsys + [thensy, dosy], x);
         if    not (x.typ in [bools, notyp])    then
        error(ertyp);
         lc1 := lc;
         emit(11);        {jmpc}
         if    sy = thensy
         then
        insymbol
         else
        error(erkey);
         statement(fsys + [elsesy]);
         if    sy = elsesy
         then
        begin
           insymbol;
           lc2 := lc;
           emit(10);
           code[lc1].y := lc;
           statement(fsys);
           code[lc2].y := lc
        end
         else
        code[lc1].y := lc
      end {ifstatement};


      procedure repeatstatement;

      var
         x:    item;
         lc1: integer;

      begin
         lc1 := lc;
         insymbol;
         statement([semicolon, untilsy] +    fsys);
         while sy in [semicolon] + statbegsys do
        begin
           if sy = semicolon
           then
              insymbol
           else
              error(erpun);
           statement([semicolon, untilsy] + fsys)
        end;
         if    sy = untilsy
         then
        begin
           insymbol;
           expression(fsys, x);
           if not (x.typ in [bools, notyp]) then
              error(ertyp);
           emit1(11, lc1)
        end
         else
        error(erkey)
      end {repeatstatement};


      procedure whilestatement;

      var
         x:    item;
         lc1, lc2: integer;

      begin
         insymbol;
         lc1 := lc;
         expression(fsys + [dosy], x);
         if    not (x.typ in [bools, notyp])    then
        error(ertyp);
         lc2 := lc;
         emit(11);
         if    sy = dosy
         then
        insymbol
         else
        error(erkey);
         statement(fsys);
         emit1(10, lc1);
         code[lc2].y := lc
      end {whilestatement};


      procedure forstatement;

      var
         cvt: types;
         x:    item;
         i,    lc1, lc2: integer;

      begin
         insymbol;
         if    sy = ident
         then
        begin
           i :=    loc(id);
           insymbol;
           if i    = 0 then
              cvt := tab[i].typ;
           if tab[i].obj = variable
           then
              begin
             cvt :=    tab[i].typ;
             if not    tab[i].normal
             then
                error(ertyp)
             else
                emit2(0, tab[i].lev, tab[i].adr);
             if not    (cvt in    [notyp, ints, bools, chars])
             then
                error(ertyp)
              end
           else
              begin
             error(ertyp);
             cvt :=    ints
              end
        end
         else
        skip([becomes,    tosy, dosy] + fsys, erid);
         if    sy = becomes
         then
        begin
           insymbol;
           expression([tosy, dosy] + fsys, x);
           if x.typ <> cvt then
              error(ertyp);
        end
         else
        skip([tosy, dosy] + fsys, erpun);
         if    sy = tosy
         then
        begin
           insymbol;
           expression([dosy] + fsys, x);
           if x.typ <> cvt then
              error(ertyp)
        end
         else
        skip([dosy] +    fsys, erkey);
         lc1 := lc;
         emit(14);
         if    sy = dosy
         then
        insymbol
         else
        error(erkey);
         lc2 := lc;
         statement(fsys);
         emit1(15, lc2);
         code[lc1].y := lc
      end {forstatement};


      procedure standproc(n: integer);

      var
         i,    f: integer;
         x,    y: item;

      begin
         case n of
        1, 2:
           begin {read}
              if sy = lparent
              then
             begin
                repeat
                   insymbol;
                   if sy <>    ident
                   then
                  error(erid)
                   else
                  begin
                     i := loc(id);
                     insymbol;
                     if    i <> 0
                     then
                    if tab[i].obj    <> variable
                    then
                       error(ertyp)
                    else
                       begin
                          x.typ := tab[i].typ;
                          x.ref := tab[i].ref;
                          if tab[i].normal
                          then
                         f := 0
                          else
                         f := 1;
                          emit2(f, tab[i].lev,
                            tab[i].adr);
                          if sy = lbrack then
                         selector(fsys + [comma,
                            rparent], x);
                          if x.typ in [ints, chars,
                         notyp]
                          then
                         emit1(27, ord(x.typ))
                          else
                         error(ertyp)
                       end
                  end;
                   test([comma, rparent],    fsys, erkey)
                until sy <>    comma;
                if sy = rparent
                then
                   insymbol
                else
                   error(erpun)
             end;
              if n = 2 then
             emit(62)
           end;
        3, 4:
           begin {write}
              if sy = lparent
              then
             begin
                repeat
                   insymbol;
                   if sy = string
                   then
                  begin
                     emit1(24, sleng);
                     emit1(28, inum);
                     insymbol
                  end
                   else
                  begin
                     expression(fsys + [comma,    colon,
                    rparent], x);
                     if    not (x.typ in stantyps)    then
                    error(ertyp);
                     emit1(29, ord(x.typ))
                  end
                until sy <>    comma;
                if sy = rparent
                then
                   insymbol
                else
                   error(erpun)
             end;
              if n = 4 then
             emit(63)
           end;
        5, 6: {wait, signal}
           if sy <> lparent
           then
              error(erpun)
           else
              begin
             insymbol;
             if sy <> ident
             then
                error(erid)
             else
                begin
                   i := loc(id);
                   insymbol;
                   if i <> 0
                   then
                  if tab[i].obj <> variable
                  then
                     error(ertyp)
                  else
                     begin
                    x.typ := tab[i].typ;
                    x.ref := tab[i].ref;
                    if tab[i].normal
                    then
                       f :=    0
                    else
                       f :=    1;
                    emit2(f, tab[i].lev, tab[i].
                       adr);
                    if sy =    lbrack then
                       selector(fsys + [rparent],    x
                          );
                    if x.typ = ints
                    then
                       emit(n + 1)
                    else
                       error(ertyp)
                     end
                end;
             if sy = rparent
             then
                insymbol
             else
                error(erpun)
              end;
         end {case}
      end {standproc};


      begin {statement}
      if sy    in statbegsys +    [ident]
      then
         case sy of
        ident:
           begin
              i    := loc(id);
              insymbol;
              if i <> 0
              then
             case tab[i].obj of
                konstant, type1:
                   error(ertyp);
                variable:
                   assignment(tab[i].lev,    tab[i].adr);
                prozedure:
                   if tab[i].lev <> 0
                   then
                  call(fsys, i)
                   else
                  standproc(tab[i].adr);
                funktion:
                   if tab[i].ref = display[level]
                   then
                  assignment(tab[i].lev + 1, 0)
                   else
                  error(ertyp)
             end
           end;
        beginsy:
           if id = 'cobegin   '
           then
              begin
             emit(4);
             compoundstatement;
             emit(5)
              end
           else
              compoundstatement;
        ifsy:
           ifstatement;
        whilesy:
           whilestatement;
        repeatsy:
           repeatstatement;
        forsy:
           forstatement;
         end;
      test(fsys, [], erpun)
      end {statement};


   begin {block}
      tabchar := chr(9);
      dx := 5;
      prt := t;
      if level    > lmax then
      fatal(5);
      test([lparent, colon, semicolon], fsys, erpun);
      enterblock;
      display[level]    := b;
      prb := b;
      tab[prt].typ := notyp;
      tab[prt].ref := prb;
      if (sy =    lparent) and (level > 1) then
      parameterlist;
      btab[prb].lastpar := t;
      btab[prb].psize := dx;
      if isfun
      then
      if sy    = colon
      then
         begin
        insymbol;    {function type}
        if sy =    ident
        then
           begin
              x    := loc(id);
              insymbol;
              if x <> 0    then
             if tab[x].obj <> type1
             then
                error(ertyp)
             else
                if tab[x].typ in stantyps
                then
                   tab[prt].typ := tab[x].typ
                else
                   error(ertyp)
           end
        else
           skip([semicolon] +    fsys, erid)
         end
      else
         error(erpun);
      if sy = semicolon
      then
      insymbol
      else
      error(erpun);
      repeat
      if sy    = constsy then
         constdeclaration;
      if sy    = typesy then
         typedeclaration;
      if sy    = varsy    then
         vardeclaration;
      btab[prb].vsize := dx;
      while    sy in [proceduresy, functionsy] do
         procdeclaration;
      test([beginsy], blockbegsys    + statbegsys, erkey)
      until sy    in statbegsys;
      tab[prt].adr := lc;
      insymbol;
      statement([semicolon, endsy] +    fsys);
      while sy    in [semicolon] + statbegsys do
      begin
         if    sy = semicolon
         then
        insymbol
         else
        error(erpun);
         statement([semicolon, endsy] + fsys)
      end;
      if sy = endsy
      then
      insymbol
      else
      error(erkey);
      test(fsys + [period], [], erkey);
   end    {block};

modend.