{ Facilis 0.20                                   file: BLOCK.PAS      }

overlay procedure blockov(fsys: symset; isfun: boolean; level: integer);

type   item = record
                typ: types; ref: index; temp: boolean
              end;
     conrec = record case tp: types of
                       ints,chars,bools: (i:integer);
                       reals: (r: real)
                     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: integer);

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

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

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

  procedure testsemicolon;

  begin
    if sy = semicolon
    then insymbol
    else begin
      error(14);
      if sy in [comma,colon] then insymbol
    end ;
    test([ident]+blockbegsys, fsys, 6)
  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(1)
      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 tabel }
  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(0);
    loc := j
  end  { loc } ;

  procedure entervariable;

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

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

  var    x, sign: integer;
  begin
    c.tp := notyp; c.i := 0;
    test(constbegsys, fsys, 50);
    if sy in constbegsys
    then begin
      if sy = charcon
      then begin
        c.tp := chars; c.i := inum;
        insymbol
      end else
      if sy = stringcon
      then begin
        c.tp := strngs;
        c.i := seg(spnt^);
        insymbol
      end else begin
        sign := 0;
        if sy in [plus,minus]
        then begin
          if sy = minus then sign := -1 else sign := 1;
          insymbol
        end ;
        if sy = ident
        then begin
          x := loc(id);
          if x <> 0
          then if tab[x].obj <> konstant
               then error(25)
               else begin
                 c.tp := tab[x].typ;
                 if c.tp in [ints,reals] then
                   if sign=0 then sign := 1;
                 if c.tp = reals
                 then c.r := sign*rconst[tab[x].adr]
                 else if c.tp = ints
                 then c.i := sign*tab[x].adr
                 else begin
                   if sign<>0 then error(33);
                   c.i := tab[x].adr
                 end
               end ;
          insymbol
        end else begin
          if sign=0 then sign := 1;
          if sy = intcon
            then begin
              c.tp := ints; c.i := sign*inum;
              insymbol
            end else if sy = realcon
                     then begin
                       c.tp := reals; c.r := sign*rnum;
                       insymbol
                     end else skip(fsys,50)
        end
      end;
      test(fsys,[], 6)
    end
  end  { constant } ;

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

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

    procedure arraytyp(var aref,arsz: integer);

    var    eltp: types;
           low, high: conrec;
           elrf, elsz: integer;
    begin
      constant([twodots,rbrack,rparent,ofsy]+fsys, low);
      if low.tp in [reals,strngs]
      then  begin
        error(27);
        low.tp := ints; low.i := 0
      end ;
      if sy = twodots then insymbol else error(13);
      constant([rbrack,comma,rparent,ofsy]+fsys, high);
      if high.tp <> low.tp
      then begin
        error(27); 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 begin
          error(12);
          if sy = rparent then insymbol
        end ;
        if sy = ofsy then insymbol else error(8);
        typ(fsys,eltp,elrf,elsz)
      end ;

      with atab[aref] do
      begin
        arsz := (high-low+1)*elsz; size := arsz;
        if arsz > stacksize then error(61);
        eltyp := eltp; elref := elrf; elsize := elsz
      end ;
    end  {arraytyp } ;

  begin  { typ }
    tp := notyp; rf := 0; sz := 0;
    test(typebegsys,fsys, 10);
    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(29)
               else begin
                 tp := typ; rf := ref; sz := adr;
                 if tp = notyp then error(30)
               end ;
        insymbol;
        if (tp=strngs) and (sy=lbrack)
        then begin
          insymbol;
          constant([rbrack]+fsys,dummy);
          if sy=rbrack then insymbol else error(12);
        end;
      end else if sy = arraysy
               then begin
                 insymbol;
                 if sy = lbrack
                 then insymbol
                 else begin
                   error(11);
                   if sy = lparent
                   then insymbol
                 end ;
                 tp := arrays; arraytyp(rf,sz)
               end else begin  { records }
                 insymbol;
                 enterblock;
                 tp := records; rf := b;
                 if level = lmax then fatal(5);
                 level := level+1; display[level] := b; offset := 0;
                 while not (sy in fsys-[semicolon,comma,ident]+[endsy]) do
                 begin  { field section }
                   if sy = ident
                   then begin
                     t0 := t; entervariable;
                     while sy = comma do
                     begin
                       insymbol; entervariable;
                     end ;
                     if sy = colon then insymbol else error(5);
                     t1 := t;
                     typ(fsys+[semicolon,endsy,comma,ident],eltp,elrf,elsz);
                     while t0 < t1 do
                     begin
                       t0 := t0+1;
                       with tab[t0] do
                       begin
                         typ := eltp;
                         ref := elrf;   normal := true;
                         adr := offset; offset := offset + elsz
                       end
                     end
                   end ; {sy = ident}
                   if sy <> endsy
                   then begin
                     if sy = semicolon
                     then insymbol
                     else begin
                       error(14);
                       if sy = comma then insymbol
                     end ;
                     test([ident,endsy,semicolon], fsys, 6)
                   end
                 end ; {field section}

                 btab[rf].vsize := offset; sz := offset;
                 if sz > stacksize then error(61);
                 btab[rf].psize := 0;
                 insymbol; level := level-1
               end ; {records}
      test(fsys, [], 6)
    end
  end  { typ } ;

  procedure parameterlist;      { formal parameter list }

  var    tp    : types;
         valpar: boolean;
         rf,sz, x, t0: integer;
  begin
    insymbol;
    tp := notyp; rf := 0; sz := 0;
    test([ident, varsy], fsys+[rparent], 7);
    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(2)
        else begin
          x := loc(id); insymbol;
          if x <> 0
          then with tab[x] do
               if obj <> type1
               then error(29)
               else begin
                 tp := typ;   rf := ref;
                 if valpar then sz := adr else sz := 1
               end ;
          end ;
        test([semicolon,rparent], [comma,ident]+fsys, 14)
      end else error(5);
      while t0 < t do
      begin
        t0 := t0+1;
        with tab[t0] do
        begin
          typ := tp; ref := rf;
          adr := dx; lev := level;
          normal := valpar;
          dx := dx + sz
        end
      end ;
      if sy <> rparent
      then begin
        if sy = semicolon
        then insymbol
        else begin
          error(14);
          if sy = comma then insymbol
        end ;
        test([ident,varsy], [rparent]+fsys, 6)
      end
    end  { while } ;

    if sy = rparent
    then begin
      insymbol;
      test([semicolon,colon], fsys, 6)
    end else error(4)
  end  { parameterlist } ;

  procedure     constdec;

  var    c: conrec;
  begin
    insymbol;
    test([ident], blockbegsys, 2);
    while sy = ident do
    begin
      enter(id,konstant); insymbol;
      if sy = eql
      then insymbol
      else begin
        error(16);
        if sy = becomes then insymbol
      end ;
      constant([semicolon,comma,ident]+fsys,c);
      tab[t].typ := c.tp;
      tab[t].ref := 0;
      if c.tp = reals
      then begin
        enterreal(c.r); tab[t].adr := c1
      end else tab[t].adr := c.i;
      testsemicolon
    end
  end  { constdec } ;

  procedure typedeclaration;

  var    tp: types;
         rf, sz, t1: integer;
  begin
    insymbol;
    test([ident], blockbegsys, 2);
    while sy = ident do
    begin
      enter(id,type1);
      t1 := t; insymbol;
      if sy = eql
      then insymbol
      else begin
        error(16);
        if sy = becomes then insymbol
      end ;
      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 variabledeclaration;

  var    tp: types;
         t0, t1, rf, sz: integer;
  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(5);
      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  { variabledeclaration } ;

  procedure procdeclaration;

  var    isfun: boolean;
  begin
    isfun := sy = funcsy;
    insymbol;
    if sy <> ident
    then begin
      error(2); 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(14);
    emit(132+ord(isfun))     { exit }
  end  { procdeclaration } ;

  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  { sy in [lparent, lbrack, period] }
      repeat
        if sy = period
        then begin
          insymbol;   { field selector }
          if sy <> ident
          then error(2)
          else begin
            if v.typ <> records
            then error(31)
            else begin  {search field identifier }
              j := btab[v.ref].last;
              tab[0].name := id;
              while tab[j].name <> id do j := tab[j].link;
              if j = 0 then error(0);
              v.typ := tab[j].typ;
              v.ref := tab[j].ref;
              a := tab[j].adr;
              if a <> 0 then emit1(9,a)
            end ;
            insymbol
          end
        end else begin  { array selector }
          if sy <> lbrack then error(11);
          if v.typ=strngs then begin
            insymbol;
            expression(fsys+[rbrack],x);
            if x.typ<>ints then error(34) else emit(165);
            v.typ := chars
          end else
          repeat
            insymbol;
            expression(fsys+[comma,rbrack], x);
            if v.typ <> arrays
            then error(28)
            else begin
              a := v.ref;
              if atab[a].inxtyp <> x.typ
              then error(26)
              else if atab[a].elsize = 1
                   then emit1(20,a)
                   else emit1(21,a);
              v.typ := atab[a].eltyp;
              v.ref := atab[a].elref
            end
          until sy <> comma;

          if sy = rbrack
          then insymbol
          else begin
            error(12);
            if sy = rparent then insymbol
          end
        end
      until not (sy in [lbrack,lparent,period]);

      test (fsys, [], 6)
    end  { selector } ;

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

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

    begin
      emit1(18,i);   { mark stack }
      lastp := btab[tab[i].ref].lastpar;
      cp := i;
      if sy = lparent
      then begin  { actual parameter list }
        repeat
          insymbol;
          if cp >= lastp
          then error(39)
          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(36)
                else if x.typ = arrays
                     then emit1(22,atab[x.ref].size)
                else if x.typ = records
                     then emit1(22,btab[x.ref].vsize)
                else if x.typ = strngs
                     then if x.temp then emit(173)
                                    else emit(172)
              end else if (x.typ=ints) and (tab[cp].typ=reals)
                       then emit1(26,0)
                       else if x.typ<>notyp then error(36);
            end else begin  { var parameter }
              if sy <> ident
              then error(2)
              else begin
                k := loc(id);
                insymbol;
                if k <> 0
                then begin
                  if tab[k].obj <> vvariable then error(37);
                  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 in [lbrack,lparent,period]
                  then begin
                    if x.typ=strngs then error(60);
                    selector(fsys+[comma,colon,rparent], x);
                  end;
                  if (x.typ<>tab[cp].typ) or (x.ref<>tab[cp].ref)
                  then error(36)
                end
              end
            end {var parameter}
          end ;
          test([comma,rparent], fsys, 6)
        until sy <> comma;

        if sy = rparent then insymbol else error(4)
      end ;

      if cp < lastp then error(39);  { 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>reals) or (b>reals)
      then begin
        error(33);
        resulttype := notyp
      end else if (a=notyp) or (b=notyp)
               then resulttype := notyp
               else if a=ints
                    then if b=ints
                         then resulttype := ints
                         else begin
                           resulttype := reals; emit1(26,1)
                         end
                    else begin
                      resulttype := reals;
                      if b=ints then emit1(26,0)
                    end
    end   { resulttype } ;

    procedure expression {fsys:symset; var x:item};

    var    y :item;
           op:symbol;
           t :integer;

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

      var    y :item;
             op:symbol;
             t :integer;

        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;

            procedure standfct(n: integer);

            var    ts: typset;

            begin { standard function no. n }
            if n=19
            then emit1(8,n)
            else begin
              if sy = lparent
              then insymbol
              else error(9);
              if (n < 17) or (n > 19)
              then begin
                expression(fsys+[comma,rparent],x);

                case n of

 { abs,sqr }    0,2: begin
                       ts := [ints,reals];
                       tab[i].typ := x.typ;
                       if x.typ = reals then n := n+1
                     end;

 { odd,chr }    4,5: ts := [ints];

 { ord }          6: ts := [ints,bools,chars];

 { succ,pred }  7,8: begin
                       ts := [ints,bools,chars];
                       tab[i].typ := x.typ
                     end;

 { round,trunc } 9,10,11,12,13,14,15,16:
 { sin,cos,... }     begin
                       ts := [ints,reals];
                       if x.typ = ints then emit1(26,0)
                     end;

 { length }      20: begin
                       ts := [strngs,chars];
                       if x.temp then n := n+1;
                       if x.typ = chars then n := n+2
                     end;

 { copy }        23: begin
                       ts := [strngs,chars];
                       if x.typ = chars then n := n+2
                         else if x.temp then n := n+1;
                       test([comma], [comma,rparent]+fsys, 59);
                       if sy = comma then begin
                         insymbol;
                         expression(fsys+[comma,rparent],y);
                         if y.typ <> ints
                           then if y.typ <> notyp then error(34);
                         test