[^S@ADMPTW<>!?dvz] PicoSearch [Site-Map -> Matematik -> Pascal-S -> 1975-Wirth(TP)]

Pascal-S

Blaise Pascal
Program Pascals;     (*1.6.75*)
(*        N. Wirth,  E.T.H.
          Clausiusstr.55   CH-8006 Zurich    *)
(* Omskrevet til TurboPascal v.4.0. 
          B. Nielsen                         *)

Label
  99;
Const
  nkw  =        27;     (* no. of key words                         *)
  alng =        10;     (* no. of significant chars in identifiers  *)
  llng =       120;     (* input line length                        *)
  emax =       322;     (* max exponent of real numbers             *)
  emin =      -292;     (* min exponent                             *)
  kmax =        15;     (* max no. of significant digits            *) 
  tmax =       100;     (* size of table                            *)
  bmax =        20;     (* size of block-table                      *)
  amax =        30;     (* size of array-table                      *)
  c2max =       20;     (* size of real constant table              *)
  csmax =       30;     (* max no. of cases                         *)
  cmax =       850;     (* size of code                             *)
  lmax =         7;     (* maximum level                            *)
  smax =       600;     (* size of string-table                     *)
  ermax =       58;     (* max error no.                            *)
  omax =        63;     (* highest order code                       *)
  xmax =      1000;     (* 131071 2**17 - 1                         *)
  nmax =     32767;     (* 281474976710655 2**48-1                  *)
  lineleng   = 136;     (* output line length                       *) 
  linelimit  = 200;
  stacksize = 1500;

Type 
  xstring = string(.255.);
  symbol = (intcon,realcon,charcon,stringsy,
            notsy,plus,minus,times,idiv,rdiv,imod,andsy,orsy,
            eql,neq,gtr,geq,lss,leq,
            lparent,rparent,lbrack,rbrack,comma,semicolon,period,
            colon,becomes,constsy,typesy,varsy,functionsy,
            proceduresy,arraysy,recordsy,programsy,ident,
            beginsy,ifsy,casesy,repeatsy,whilesy,forsy,
            endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,thensy);

  index  = -xmax .. +xmax;
  alfa   = Packed Array (.1..alng.) of char;
  object = (konstant,variable,type1,prozedure,funktion);
  types  = (notyp,ints,reals,bools,chars,arrays,records);
  symset = set of symbol;
  typset = set of types;
  item   = Record
             typ: types; ref: index;
           End;
  order  = Packed Record
             f: -omax..+omax;
             x: -lmax..+lmax;
             y: -nmax..+nmax;
           End;

Var
  InputFile: Text;
  sy: symbol;          (*last symbol read by insymbol*)
  id: alfa;            (*identifier from insymbol*)
  inum: integer;       (*integer from insymbol*)   
  rnum: real;          (*real number from insymbol*)
  sleng: integer;      (*string length*)
  ch: char;            (*last character read from source program*)
  line: Array (.1..llng.) of char;
  cc: integer;         (*character count*)
  lc: integer;         (*program location counter*)
  ll: integer;         (*length of current line*)
  errs: set of 0..ermax;
  errpos: integer;
  progname: alfa;
  iflag, oflag: boolean;
  constbegsys,typebegsys,blockbegsys,facbegsys,statbegsys: symset;
  key: Array (.1..nkw.) of alfa;
  ksy: Array (.1..nkw.) of symbol;
  sps: Array (.char.) of symbol;  (*special symbols*)
  xname: xstring;

  t,a,b,sx,c1,c2: integer;  (*indices to tables*)
  stantyps: typset;
  display: Array (.0 .. lmax.) of integer;

  tab:     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:    Array  (.1..amax.) of      (*array-table*)
             Packed Record
               inxtyp, eltyp: types;
               elref, low, high, elsize, size: index;
             End;
  btab:    Array  (.1..bmax.) of      (*block-table*)
             Packed Record
               last, lastpar, psize, vsize: index;
             End;
  stab:    Packed Array (.0..smax.) of char;  (*string table*)
  rconst:  Array (.1 .. c2max.) of real;
  kode:    Array (.0 .. cmax.) of order;
  
(*Function sin(r: real): real; Begin sin:=0 End;                *)
(*Function cos(r: real): real; Begin End;                       *)
(*Function ln(r: real): real; Begin ln:=0 End;                  *)
(*Function sqrt(r: real): real; Begin sqrt:=0 End;              *)
(*Function exp(r: real): real; Begin exp:=0 End;                *)
(*Function eos(Var t: text): boolean; Begin eos:=eof(t) End;    *)
(*Function arctan(r: real): real; Begin arctan:=0 End;          *)

  Procedure errormsg;
  Var
    k:   integer;
    msg: Array (.0..ermax.) of alfa;
  Begin
    msg(. 0.) := 'undef id  '; msg(. 1.) := 'multi def ';
    msg(. 2.) := 'identifier'; msg(. 3.) := 'program   ';
    msg(. 4.) := ')         '; msg(. 5.) := ':         ';
    msg(. 6.) := 'syntax    '; msg(. 7.) := 'ident, var';
    msg(. 8.) := 'of        '; msg(. 9.) := '(         ';
    msg(.10.) := 'id, array '; msg(.11.) := '[         ';
    msg(.12.) := ']         '; msg(.13.) := '..        ';
    msg(.14.) := ';         '; msg(.15.) := 'func. type';
    msg(.16.) := '=         '; msg(.17.) := 'boolean   ';
    msg(.18.) := 'convar typ'; msg(.19.) := 'type      ';
    msg(.20.) := 'prog.param'; msg(.21.) := 'too big   ';
    msg(.22.) := '.         '; msg(.23.) := 'typ (case)';
    msg(.24.) := 'character '; msg(.25.) := 'const id  ';
    msg(.26.) := 'index type'; msg(.27.) := 'indexbound';
    msg(.28.) := 'no array  '; msg(.29.) := 'type id   ';
    msg(.30.) := 'undef type'; msg(.31.) := 'no record ';
    msg(.32.) := 'boole type'; msg(.33.) := 'arith type';
    msg(.34.) := 'integer   '; msg(.35.) := 'types     ';
    msg(.36.) := 'param type'; msg(.37.) := 'variab id ';
    msg(.38.) := 'string    '; msg(.39.) := 'no.of pars';
    msg(.40.) := 'type      '; msg(.41.) := 'type      ';
    msg(.42.) := 'real type '; msg(.43.) := 'integer   ';
    msg(.44.) := 'var, const'; msg(.45.) := 'var, proc ';
    msg(.46.) := 'types (:=)'; msg(.47.) := 'typ (case)';
    msg(.48.) := 'type      '; msg(.49.) := 'store ovfl';
    msg(.50.) := 'constant  '; msg(.51.) := ':=        ';
    msg(.52.) := 'then      '; msg(.53.) := 'until     ';
    msg(.54.) := 'do        '; msg(.55.) := 'to downto ';
    msg(.56.) := 'begin     '; msg(.57.) := 'end       ';
    msg(.58.) := 'factor    ';
    k := 0;
    WriteLn;
    WriteLn(' key words');
    While errs <> (..) do
    Begin
      While not (k in errs) do
        k := k+1;
      WriteLn(k,'  ',msg(.k.));
      errs := errs - (.k.)
    End
  End (* errormsg*) ;

  Procedure nextch;   (*read next character; process line end*)
  Begin
    If cc = ll Then
    Begin
      If eof(InputFile) Then
      Begin
        WriteLn;
        WriteLn(' program incomplete');
        errormsg; (* goto 99;*)
        Halt
      End;
      If errpos <> 0 Then
      Begin 
        WriteLn;
        errpos := 0
      End;
      Write(lc:5, '  ');
      ll := 0; 
      cc := 0;
      While not eoln(InputFile) do
      Begin
        ll := ll+1; 
        read(InputFile,ch); 
        Write(ch); 
        line(.ll.) := ch
      End;
      WriteLn;
      readln(InputFile); 
      ll:=ll+1; 
      line(.ll.):=' ';
    End;
    cc := cc+1;
    ch := line(.cc.);
  End (*nextch*) ;

  Procedure Error(n: integer);
  Begin
    If errpos = 0 Then
      Write(' ****');
    If cc > errpos Then
    Begin
      Write(' ': cc-errpos, '^', n:2);
      errpos := cc+3;
      errs := errs + (.n.)
    End
  End (*Error*) ;

  Procedure fatal(n: integer);
  Var
    msg: Array (.1..7.) of alfa;
  Begin
    WriteLn;
    errormsg;
    msg(. 1.) := 'identifier'; msg(. 2.) := 'procedures';
    msg(. 3.) := 'reals     '; msg(. 4.) := 'arrays    ';
    msg(. 5.) := 'levels    '; msg(. 6.) := 'code      ';
    msg(. 7.) := 'strings   ';
    WriteLn(' compiler table for ', msg(.n.), ' is too small');
    (* goto 99 *) halt    (* terminate compilation*)
  End (*fatal*);

  Procedure insymbol;           (*reads next symbol*)
  label
    1,2,3;
  Var
    i,j,k,e: integer;
  
    Procedure readscale;
    Var
      s, sign: integer;
    Begin
      nextch;
      sign := 1;
      s := 0;
      If ch = '+' Then
        nextch
      Else
        If ch = '-' Then
        Begin
          nextch;
          sign := -1
        End;
      While ch in (.'0'..'9'.) do
      Begin
        s := 10*s + ord(ch) - ord('0');
        nextch
      End ;
      e := s*sign + e
    End (*readscale*) ;
  
    Procedure adjustscale;
    Var
      s: integer;
      d,t: real;
    Begin
      If k+e > emax Then
        Error(21)
      Else
        If k+e < emin Then
          rnum := 0
        Else
        Begin
          s := abs(e);
          t := 1.0;
          d := 10.0;
          Repeat
            While not odd(s) do
            Begin
              s := s div 2;
              d := sqr(d)
            End ;
            s := s-1;
            t := d*t
          Until s = 0;
          If e >= 0 Then
            rnum := rnum*t
          Else
            rnum := rnum/t
        End
    End (*adjustscale*) ;
  
  Begin (*insymbol*) 
  1:While ch = ' ' do
      nextch;
    If ch in (.'a'..'z'.) Then
    Begin (*word*)  
      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;         (*binary search*)
      j := nkw;
      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
    Else
    If ch in (.'0'..'9'.) Then
    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(21);
        inum := 0;
        k := 0
      End ;     
      If ch = '.' Then
      Begin
        nextch;
        If ch = '.' Then
          ch := ':' 
        Else
        Begin
          sy := realcon;
          rnum := inum;
          e := 0;
          While ch in (.'0'..'9'.) do
          Begin
            e := e-1;
            rnum := 10.0*rnum + (ord(ch) - ord('0'));
            nextch
          End ;
          If ch = 'e' Then
            readscale;
          If e <> 0 Then
            adjustscale
        End
      End
      Else
        If ch = 'e' Then
        Begin
          sy := realcon;
          rnum := inum;
          e := 0;
          readscale;
          If e <> 0 Then
            adjustscale
        End 
    End
    Else
    Case ch of
     ':' : Begin
             nextch;
             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
               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(7);
             stab(.sx+k.) := ch;
             k := k+1;
             If cc = 1 Then (*end of line*) 
               k := 0
             Else
               goto 2;
         3:  If k = 1 Then
             Begin
               sy := charcon; 
               inum := ord(stab(.sx.))
             End
             Else
               If k = 0 Then
               Begin
                 Error(38);
                 sy := charcon;
                 inum := 0
               End
               Else
               Begin
                 sy := stringsy;
                 inum := sx;
                 sleng := k;
                 sx := sx+k
               End
           End ;
     '(' : Begin
             nextch;
             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;
    Else (*otherwise*)
           Begin 
             Error(24);
             nextch;
             goto 1
           End;
    End;
  End (*insymbol*) ;

  Procedure enter(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(27);
    If (abs(l)>xmax) or (abs(h)>xmax) Then
    Begin
      Error(27);
      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
  End (*enterarray*) ;

  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 enterreal(x: real);
  Begin
    If c2 = c2max-1 Then
      fatal(3)
    Else
    Begin
      rconst(.c2+1.) := x;
      c1 := 1;
      While rconst(.c1.) <> x do
        c1 := c1+1;
      If c1>c2 Then
        c2 := c1
    End
  End (*enterreal*) ;

  Procedure emit(fct: integer);
  Begin
    If lc = cmax Then
      fatal(6);
    kode(.lc.).f := fct;
    lc := lc+1
  End (*emit*) ;

  Procedure emit1(fct,b: integer);
  Begin 
    If lc = cmax Then
      fatal(6);
    With kode(.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 kode(.lc.) do
    Begin
      f := fct;
      x := a;
      y := b
    End ;
    lc := lc+1
  End (*emit2*) ;

  Procedure printtables;
  Var
    i: integer;
    o: order;
  Begin
    WriteLn;
    WriteLn('identifiers           link  obj  typ  ref  nrm  lev  adr');
    for i := btab(.1.).last +1 to t do
      With tab(.i.) do
        WriteLn(i:10,' ',name:10,link:5, ord(obj):5, ord(typ):5, ref:5,
                ord(normal):5, lev:5, adr:5);
    WriteLn;
    WriteLn('blocks     last lpar psze vsze');
    for i := 1 to b do
      With btab(.i.) do
        WriteLn(i:10, last:5, lastpar:5, psize:5, vsize:5);
    WriteLn;
    WriteLn('arrays     xtyp etyp eref  low high elsz size');
    for i := 1 to a do
      With atab(.i.) do
        WriteLn(i:10, ord(inxtyp):5, ord(eltyp):5,
                elref:5, low:5, high:5, elsize:5, size:5);
    WriteLn;
    WriteLn('code:');
    for i := 0 to lc-1 do
    Begin
      If i mod 5 = 0 Then
      Begin
        WriteLn;
        Write(i:5)
      End;
      o := kode(.i.); Write(o.f:5);
      If o.f < 31 Then
        If o.f < 4 Then
          Write(o.x:2, o.y:5)
        Else
          Write(o.y:7)
      Else Write('       ');
      Write(',')             
    End ;
    WriteLn
  End (*printtables*) ;

  Procedure block(fsys: symset; isfun: boolean; level: integer);
  Type
    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);
      While not (sy in fsys) do
        insymbol
    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 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(0);
      loc := j
    End (*loc*) ;
     
    Procedure entervariable;
    Begin
      If sy = ident Then
      Begin
        enter(id,variable);
        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
        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(25) 
              Else
              Begin
                c.tp := tab[x].typ;
                If c.tp = reals Then 
                  c.r := sign*rconst[tab[x].adr]
                Else
                  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
              If sy = realcon Then
              Begin
                c.tp := reals;
                c.r := sign*rnum;
                insymbol
               End
               Else
                 skip(fsys,50)                   
        End;
        test(fsys, [], 6)
      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,rparent,ofsy]+fsys, low);
        If low.tp = reals Then
        Begin
          Error(27);
          low.tp := ints;
          low.i := 0
        End;
        If sy = colon 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;
          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
        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 sy <> 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 ;
              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 ;
            btab[rf].vsize := offset; sz := offset;
            btab[rf].psize := 0; insymbol; level := level-1
          End ;
          test(fsys, [], 6)
        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], 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;
              normal := valpar; adr := dx; lev := level;
              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 constantdeclaration;
    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 (*constantdeclaration*) ;
        
    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
      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(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 = functionsy;
      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(32+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);
            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)
                        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 (*variable parameter*)
                      If sy <> ident Then Error(2) Else
                      Begin k := loc(id); insymbol;
                        If k <> 0 Then
                        Begin If tab[k].obj <> variable 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
                             selector(fsys+[comma,colon,rparent], x);
                          If (x.typ<>tab[cp].typ) or (x.ref<>tab[cp].ref)
                          Then Error(36)
                        End
                      End
                    End
                  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;
      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;
                     
              Procedure standfct(n: integer);
              var ts: typset;
              Begin (*standard function no. n*)
                If sy = lparent Then
                  insymbol
                Else
                  Error(9);
                If n < 17 Then
                Begin
                  expression(fsys+[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:  ts := [chars];
       (*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 ;
                            End ;
                            If x.typ in ts Then emit1(8,n) Else
                            If x.typ <> notyp Then Error(48);
                          End Else
       (*eof,eoln*)       Begin (*n in [17,18]*)
                            If sy <> ident Then Error(2) Else
                          If id <> 'input     ' Then Error(0) Else insymbol;
                          
                            emit1(8,n);
                          End;
                        x.typ := tab[i].typ;
                        If sy = rparent Then insymbol Else Error(4)
              End (*standfct*) ;
                     
            Begin (*factor*) x.typ := notyp; x.ref := 0;
                     test(facbegsys, fsys, 58);
                     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;
                                 If x.typ = reals Then
                                   emit1(25,adr) Else
                                   emit1(24,adr)
                               End ;
                      variable: Begin x.typ := typ; x.ref := ref;
                                 If sy in [lbrack,lparent,period] 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(44);
                     funktion: Begin x.typ := typ;
                                 If lev <> 0 Then call(fsys, i)
                                       Else standfct(adr)
                               End
                           End (*case,with*)
                         End Else
                         If sy in [charcon,intcon,realcon] Then
                          Begin
                            If sy = realcon Then
                            Begin x.typ := reals; enterreal(rnum);
                              emit1(25, c1)
                            End Else
                            Begin If sy = charcon Then x.typ := chars
                                                  Else x.typ := ints;
                              emit1(24, inum)
                            End ;
                            x.ref := 0; insymbol
                          End Else
                         If sy = lparent Then
                          Begin insymbol; expression(fsys+[rparent], x);
                            If sy = rparent Then insymbol Else Error(4)
                          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(32)
                          End ;
                         test(fsys, facbegsys, 6)
                       End (*While*)
            End (*factor*) ;
                   
          Begin (*term*)
                   factor(fsys+[times,rdiv,idiv,imod,andsy], x);
                   While sy in [times,rdiv,idiv,imod,andsy] do
                     Begin op := sy; insymbol;
                       factor(fsys+[times,rdiv,idiv,imod,andsy], y);
                       If op = times Then
                       Begin x.typ := resulttype(x.typ, y.typ);
                          case x.typ of
                           notyp: ;
                           ints : emit(57);
                           reals: emit(60);
                         End
                       End Else
                       If op = rdiv Then
                       Begin
                         If x.typ = ints Then
                           Begin emit1(26,1); x.typ := reals
                           End ;
                         If y.typ = ints Then
                           Begin emit1(26,0); y.typ := reals
                           End ;
                         If (x.typ = reals) and  (y.typ=reals) Then
                           emit(61) Else
                           Begin If (x.typ<>notyp) and (y.typ<>notyp) Then
                                   Error(33);
                                 x.typ := notyp
                           End
                       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(32);
                                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(34);
                                 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 > reals Then Error(33) 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(32);
                               x.typ := notyp
                          End
                      End Else
                      Begin x.typ := resulttype(x.typ, y.typ);
                        case x.typ of
                          notyp: ;
                          ints : If op = plus Then emit(52)
                                          Else emit(53);
                          reals: If op = plus Then emit(54)
                                          Else emit(55)
                        End
                      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
                   Begin If x.typ = ints Then
                           Begin x.typ := reals; emit1(26,1)
                           End Else
                         If y.typ = ints Then
                           Begin y.typ := reals; emit1(26,0)
                           End ;
                     If (x.typ=reals) and (y.typ=reals) Then
                       case op of
                         eql: emit(39);
                         neq: emit(40);
                         lss: emit(41);
                         leq: emit(42);
                         gtr: emit(43);
                         geq: emit(44);
                       End
                     Else Error(35)
                   End ;
                   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 in [lbrack,lparent,period] Then
                 selector([becomes,eql]+fsys, x);
              If sy = becomes Then insymbol Else
                Begin Error(51); If sy = eql Then insymbol
                End;
              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(46) Else
                If x.typ = arrays Then emit1(23, atab[x.ref].size)
                                  Else emit1(23, btab[x.ref].vsize)
              Else
              If (x.typ=reals) and (y.typ=ints) Then
                Begin emit1(26,0); emit(38)
                End Else
                If (x.typ<>notyp) and (y.typ<>notyp) Then Error(46)
      End (*assignment*) ;
            
      Procedure compoundstatement;
      Begin insymbol;
              statement([semicolon,endsy]+fsys);
              While sy in [semicolon]+statbegsys do
              Begin If sy = semicolon Then insymbol Else Error(14);
                statement([semicolon,endsy]+fsys)
              End ;
              If sy = endsy Then insymbol Else Error(57)
      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(17);
              lc1 := lc; emit(11);  (*jmpc*)
              If sy = thensy Then insymbol Else
                Begin Error(52); If sy = dosy Then insymbol
                End;
              statement(fsys+[elsesy]);
              If sy = elsesy Then
                Begin insymbol; lc2 := lc; emit(10);
                  kode[lc1].y := lc; statement(fsys); kode[lc2].y := lc
                End
              Else kode[lc1].y := lc
      End (*ifstatement*) ;
            
      Procedure casestatement;
      var
        x: item;
        i,j,k,lc1: integer;
        casetab: array [1..csmax] of
                   packed record val, lc: index End;
        exittab: array [1..csmax] of integer;
               
        Procedure caselabel;
        var lab: conrec; k: integer;
        Begin constant(fsys+[comma,colon], lab);
                If lab.tp <> x.typ Then Error(47) Else
                If i = csmax Then fatal(6) Else
                  Begin i := i+1; k := 0;
                    casetab[i].val := lab.i; casetab[i].lc := lc;
                    Repeat k := k+1 until casetab[k].val = lab.i;
                    If k < 1 Then Error(1);   (*multiple definition*)
                  End
        End (*caselabel*) ;
              
        Procedure onecase;
        Begin If sy in constbegsys Then
                Begin caselabel;
                  While sy = comma do
                    Begin insymbol; caselabel
                    End ;
                  If sy = colon Then insymbol Else Error(5);
                  statement([semicolon,endsy]+fsys);
                  j := j+1; exittab[j] := lc; emit(10)
                End
        End (*onecase*) ;
              
      Begin insymbol; i := 0; j := 0;
              expression(fsys+[ofsy,comma,colon], x);
              If not (x.typ in [ints,bools,chars,notyp]) Then Error(23);
              lc1 := lc; emit(12);  (*jmpx*)
              If sy = ofsy Then insymbol Else Error(8);
              onecase;
              While sy = semicolon do
                Begin insymbol; onecase
                End;
              kode[lc1].y := lc;
              for k := 1 to i do
                Begin emit1(13,casetab[k].val); emit1(13,casetab[k].lc)
                End ;
              emit1(10,0);
              for k := 1 to j do kode[exittab[k]].y := lc;
              If sy = endsy Then insymbol Else Error(57)
      End (*casestatement*) ;
            
      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(14);
          statement([semicolon,untilsy]+fsys)
        End ;
        If sy = untilsy Then
        Begin
          insymbol;
          expression(fsys, x);
          If not (x.typ in [bools, notyp]) Then
            Error(17);
          emit1(11,lc1)
        End
        Else
          Error(53)
      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(17);
        lc2 := lc;
        emit(11);
        If sy = dosy Then
          insymbol
        Else
          Error(54);
        statement(fsys);
        emit1(10,lc1);
        kode[lc2].y := lc
      End (*whilestatement*) ;
            
      Procedure forstatement;
      var
        cvt: types;
        x: item;
        i,f,lc1,lc2: integer;
      Begin
        insymbol;
        If sy = ident Then
        Begin
          i := loc(id);
          insymbol;
          If i = 0 Then
            cvt := ints
          Else
            If tab[i].obj = variable Then
            Begin
              cvt := tab[i].typ;
              emit2(0, tab[i].lev, tab[i].adr);
              If not (cvt in [notyp,ints,bools,chars]) Then
                Error(18)
            End
            Else
            Begin
              Error(37);
              cvt := ints
            End
        End
        Else
          skip([becomes,tosy,downtosy,dosy]+fsys, 2);
        If sy = becomes Then
        Begin
          insymbol;
          expression([tosy,downtosy,dosy]+fsys, x);
          If x.typ <> cvt Then
            Error(19)
        End
        Else
          skip([tosy,downtosy,dosy]+fsys, 51);
        f := 14;
        If sy in [tosy, downtosy] Then
        Begin
          If sy = downtosy Then
            f := 16;
          insymbol;
          expression([dosy]+fsys, x);
          If x.typ <> cvt Then
            Error(19)
        End
        Else
          skip([dosy]+fsys, 55);
        lc1 := lc; emit(f);
        If sy = dosy Then insymbol Else Error(54);
        lc2 := lc; statement(fsys);
        emit1(f+1,lc2); kode[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 not iflag Then
                  Begin Error(20); iflag := true
                  End;
                If sy = lparent Then 
                Begin
                  Repeat insymbol;
                    If sy <> ident Then Error(2) Else
                    Begin i := loc(id); insymbol;
                      If i <> 0  Then
                      If tab[i].obj <> variable Then Error(37) 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 in [lbrack,lparent,period] Then
                          selector(fsys+[comma,rparent], x);
                        If x.typ in [ints,reals,chars,notyp] Then
                          emit1(27, ord(x.typ)) Else Error(40)
                      End
                    End ;
                    test([comma,rparent],fsys, 6);
                  until sy <> comma;
                  If sy = rparent Then insymbol Else Error(4)
                End ;
                If n = 2 Then emit(62)
              End;
         3,4: Begin (*write*)
                If sy = lparent Then 
                Begin
                  Repeat insymbol;
                    If sy = stringsy 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(41);
                      If sy = colon Then
                      Begin insymbol;
                        expression(fsys+[comma,colon,rparent], y);
                        If y.typ <> ints Then Error(43);
                        If sy = colon Then
                        Begin If x.typ <> reals Then Error(42);
                          insymbol; expression(fsys+[comma,rparent], y);
                          If y.typ <> ints Then Error(43);
                          emit(37)
                        End
                        Else emit1(30, ord(x.typ))
                      End
                      Else emit1(29,ord(x.typ))
                    End
                   until sy <> comma;
                  If sy = rparent Then insymbol Else Error(4)
                End ;
                If n = 4 Then emit(63)
              End;
              End;
      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(45);
                               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(45)
                             End
                           End ;
                 Beginsy:  compoundstatement;
                 ifsy:     ifstatement;
                 casesy:   casestatement;
                 whilesy:  whilestatement;
                 repeatsy: repeatstatement;
                 forsy:    forstatement;
               End;
             test(fsys, [], 14)  
    End (*statement*) ;  
                 
  Begin (*block*)
    dx := 5;
    prt := t;
    If level > lmax Then
      fatal(5);
    test([lparent,colon,semicolon], fsys, 7);
    enterblock;
    display[level] := b;
    prb := b;
    tab[prt].typ := notyp;
    tab[prt].ref := prb;
    If sy = lparent 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(29)
            Else
              If tab[x].typ in stantyps Then
                tab[prt].typ := tab[x].typ
              Else
                Error(15)
        End
        Else
          skip([semicolon]+fsys, 2)
      End
      Else
        Error(5);
    If sy = semicolon Then
      insymbol
    Else
      Error(14);
    Repeat
      If sy = constsy Then
        constantdeclaration;
      If sy = typesy Then
        typedeclaration;
      If sy = varsy Then
        variabledeclaration;
      btab[prb].vsize := dx;
      While sy in [proceduresy,functionsy] do
        procdeclaration;
      test([beginsy], blockbegsys+statbegsys, 56)
    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(14);
      statement([semicolon,endsy]+fsys)
    End;
    If sy = endsy Then
      insymbol
    Else
      Error(57);
    test(fsys+[period], [], 6)
  End (*block*) ;

  Procedure interpret;
  (*global code, tab, btab*)
  Var
    ir: order;      (*instruction buffer*)
    pc: integer;    (*program counter*)
    ps: (run,fin,caschk,divchk,inxchk,stkchk,linchk,
         lngchk,redchk);
    t:  integer;    (*top stack index*)
    b:  integer;    (*base index*)
    lncnt, ocnt, blkcnt, chrcnt: integer;     (*counters*)
    h1,h2,h3,h4: integer;
    fld: Array (.1..4.) of integer;     (*default field widths*)

    display: Array (.1..lmax.) of integer;
    s: Array (.1..stacksize.) of     (*blockmark:              *)
         Record Case types of        (*   s(.b+0.) = fct result  *)
           ints:  (i: integer);      (*   s(.b+1.) = return adr  *)
           reals: (r: real);         (*   s(.b+2.) = static link *)
           bools: (b: boolean);      (*   s(.b+3.) = dynamic link*)
           chars: (c: char)          (*   s(.b+4.) = table index *)
         End;

  Begin (*interpret*)
    s(.1.).i := 0;
    s(.2.).i := 0;
    s(.3.).i := -1;
    s(.4.).i := btab(.1.).last;
    b := 0;
    display(.1.) := 0;
    t := btab(.2.).vsize - 1;
    pc := tab(.s(.4.).i.).adr;
    ps:=run;
    lncnt := 0;
    ocnt := 0;
    chrcnt := 0;
    fld(.1.) := 10;
    fld(.2.) := 22;
    fld(.3.) := 10;
    fld(.4.) := 1;
    Repeat
      ir := kode(.pc.);
      pc := pc+1;
      ocnt := ocnt + 1;
      Case ir.f of
       0: Begin (*load address*) 
            t := t+1;
            If t > stacksize Then
              ps := stkchk
            Else
              s(.t.).i := display(.ir.x.) + ir.y
          End;
       1: Begin (*load value*) 
            t := t+1;
            If t > stacksize Then
              ps := stkchk
            Else
              s(.t.) := s(.display(.ir.x.) + ir.y.)
          End;
       2: Begin (*load indirect*)
            t := t+1;
            If t > stacksize Then
              ps := stkchk
            Else
              s(.t.) := s(.s(.display(.ir.x.) + ir.y.).i.)
          End;
       3: Begin (*update display*)
            h1 := ir.y; 
            h2 := ir.x;
            h3 := b;
            Repeat
              display(.h1.) := h3;
              h1 := h1-1;
              h3:= s(.h3+2.).i
            Until h1 = h2
          End;
       8: Case ir.y of
           0: s(.t.).i := abs(s(.t.).i);
           1: s(.t.).r := abs(s(.t.).r);
           2: s(.t.).i := sqr(s(.t.).i);
           3: s(.t.).r := sqr(s(.t.).r);
           4: s(.t.).b := odd(s(.t.).i);
           5: (* s(.t.).c := chr(s(.t.).i); *)
              If (s(.t.).i < 0) or (s(.t.).i > 63) Then
                ps := inxchk;
           6: (* s(.t.).i := ord(s(.t.).c) *);
           7: s(.t.).c := succ(s(.t.).c);
           8: s(.t.).c := pred(s(.t.).c);
           9: s(.t.).i := round(s(.t.).r);
          10: s(.t.).i := trunc(s(.t.).r);
          11: s(.t.).r := sin(s(.t.).r);
          12: s(.t.).r := cos(s(.t.).r);
          13: s(.t.).r := exp(s(.t.).r);
          14: s(.t.).r := ln(s(.t.).r);
          15: s(.t.).r := sqrt(s(.t.).r);
          16: s(.t.).r := arctan(s(.t.).r);
          17: Begin t:= t+1;
                If t > stacksize Then
                  ps := stkchk
                Else
                  s(.t.).b := eof(InputFile)
              End ;
          18: Begin
                t:= t+1;
                If t > stacksize Then
                  ps := stkchk
                Else
                  s(.t.).b := eoln(InputFile)
              End ;
          End ;
       9: s(.t.).i := s(.t.).i + ir.y;    (*offset*)
      10: pc := ir.y;   (*jump*)
      11: Begin (*conditional jump*)
            If not s(.t.).b Then
              pc := ir.y;
            t := t-1
          End;
      12: Begin (*switch*)
            h1 := s(.t.).i;
            t := t-1;
            h2 := ir.y;
            h3 := 0;
            Repeat
              If kode(.h2.).f <> 13 Then
              Begin
                h3 := 1;
                ps := caschk;
              End
              Else
                If kode(.h2.).y = h1 Then
                Begin
                  h3 := 1;
                  pc := kode(.h2+1.).y
                End
                Else
                  h2 := h2 + 2
            Until h3 <> 0
          End;
      14: Begin (*for1up*)
            h1 := s(.t-1.).i;
            If h1 <= s(.t.).i Then
              s(.s(.t-2.).i.).i := h1
            Else
            Begin
              t := t-3;
              pc := ir.y
            End
          End;
      15: Begin (*for2up*) 
            h2 := s(.t-2.).i;
            h1:= s(.h2.).i + 1;
            If h1 <= s(.t.).i Then
            Begin
              s(.h2.).i := h1;
              pc := ir.y
            End
            Else
              t := t-3;
          End;
      16: Begin (*for1down*)
            h1 := s(.t-1.).i;
            If h1 >= s(.t.).i Then
              s(.s(.t-2.).i.).i := h1
            Else
            Begin
              pc := ir.y;
              t := t-3
            End
          End;
      17: Begin (*for2down*)
            h2 := s(.t-2.).i;
            h1:= s(.h2.).i - 1;
            If h1 >= s(.t.).i Then
            Begin
              s(.h2.).i := h1;
              pc := ir.y
            End
            Else
              t := t-3;
          End;
      18: Begin (*mark stack*)
            h1 := btab(.tab(.ir.y.).ref.).vsize;
            If t+h1 > stacksize Then
              ps := stkchk 
            Else
            Begin
              t := t+5;
              s(.t-1.).i := h1-1;
              s(.t.).i := ir.y
            End
          End;
      19: Begin (*call*)
            h1 := t - ir.y;        (*h1 points to base*)
            h2 := s(.h1+4.).i;     (*h2 points to tab*)
            h3 := tab(.h2.).lev;
            display(.h3+1.) := h1;
            h4 := s(.h1+3.).i + h1;
            s(.h1+1.).i := pc;
            s(.h1+2.).i := display(.h3.);
            s(.h1+3.).i := b;
            for h3 := t+1 to h4 do
              s(.h3.).i := 0;
            b := h1;
            t := h4;
            pc := tab(.h2.).adr
          End;
      20: Begin (*index1*)
            h1 := ir.y;      (*h1 points to atab*)
            h2 := atab(.h1.).low;
            h3 := s(.t.).i;
            If h3 < h2 Then
              ps := inxchk
            Else
              If h3 > atab(.h1.).high Then
                ps := inxchk
              Else
              Begin
                t := t-1;
                s(.t.).i := s(.t.).i + (h3-h2)
              End
          End;
      21: Begin (*index*)
            h1 := ir.y;      (*h1 points to atab*)
            h2 := atab(.h1.).low;
            h3 := s(.t.).i;
            If h3 < h2 Then
              ps := inxchk
            Else
              If h3 > atab(.h1.).high Then
                ps := inxchk
              Else
              Begin
                t := t-1;
                s(.t.).i := s(.t.).i + (h3-h2)*atab(.h1.).elsize
              End
          End;
      22: Begin (*load block*)
            h1 := s(.t.).i;
            t := t-1;
            h2 := ir.y + t;
            If h2 > stacksize Then
              ps := stkchk
            Else
              While t < h2 do
              Begin
                t := t+1;
                s(.t.) := s(.h1.);
                h1 := h1+1
              End
          End ;
      23: Begin (*copy block*)
            h1 := s(.t-1.).i;
            h2 := s(.t.).i;
            h3 := h1 + ir.y;
            While h1 < h3 do
            Begin
              s(.h1.) := s(.h2.);
              h1 := h1+1;
              h2 := h2+1
            End;
            t := t-2
          End ;
      24: Begin (*literal*)
            t := t+1;
            If t > stacksize Then
              ps := stkchk
            Else
              s(.t.).i := ir.y
          End ;
      25: Begin (*load real*)
            t := t+1;
            If t > stacksize Then
              ps := stkchk
            Else
              s(.t.).r := rconst(.ir.y.)
          End ;
      26: Begin (*float*) 
            h1 := t - ir.y;
            s(.h1.).r := s(.h1.).i
          End ;
      27: Begin (*read*)
            If eof(InputFile) Then
              ps := redchk
            Else
              Case ir.y of
               1: read(InputFile,s(.s(.t.).i.).i);
               2: read(InputFile,s(.s(.t.).i.).r);
               4: read(InputFile,s(.s(.t.).i.).c);
              End ;
            t := t-1
          End ;
      28: Begin (*write string*)
            h1 := s(.t.).i;
            h2 := ir.y;
            t := t-1;
            chrcnt := chrcnt+h1;
            If chrcnt > lineleng Then
              ps := lngchk;
            Repeat
              Write(stab(.h2.));
              h1 := h1-1;
              h2:= h2+1
            Until h1 = 0
          End ;
      29: Begin (*write1*)
            chrcnt := chrcnt + fld(.ir.y.);
            If chrcnt > lineleng Then
              ps := lngchk
            Else
              Case ir.y of
               1: Write(s(.t.).i: fld(.1.));
               2: Write(s(.t.).r: fld(.2.));
               3: Write(s(.t.).b: fld(.3.));
               4: Write(s(.t.).c);
              End ;
            t := t-1
          End;
      30: Begin (*write2*)
            chrcnt := chrcnt + s(.t.).i;
            If chrcnt > lineleng Then
              ps := lngchk
            Else
              Case ir.y of
               1: Write(s(.t-1.).i: s(.t.).i);
               2: Write(s(.t-1.).r: s(.t.).i);
               3: Write(s(.t-1.).b: s(.t.).i);
               4: Write(s(.t-1.).c: s(.t.).i);
              End ;
            t := t-2
          End;
      31: ps := fin;
      32: Begin (*exit procedure*)
            t := b-1;
            pc := s(.b+1.).i;
            b := s(.b+3.).i
          End;
      33: Begin (*exit function*)
            t := b;
            pc := s(.b+1.).i;
            b := s(.b+3.).i
          End;
      34: s(.t.) := s(.s(.t.).i.);
      35: s(.t.).b := not s(.t.).b;
      36: s(.t.).i := - s(.t.).i;
      37: Begin
            chrcnt := chrcnt + s(.t-1.).i;
            If chrcnt > lineleng Then
              ps := lngchk
            Else
              Write(s(.t-2.).r: s(.t-1.).i: s(.t.).i);
            t := t-3
          End;
      38: Begin (*store*)
            s(.s(.t-1.).i.) := s(.t.);
            t := t-2
          End;
      39: Begin
            t := t-1;
            s(.t.).b := s(.t.).r = s(.t+1.).r
          End ;
      40: Begin
            t := t-1;
            s(.t.).b := s(.t.).r <> s(.t+1.).r
          End ;
      41: Begin
            t := t-1;
            s(.t.).b := s(.t.).r < s(.t+1.).r
          End ;
      42: Begin
            t := t-1;
            s(.t.).b := s(.t.).r <= s(.t+1.).r
          End ;
      43: Begin
            t := t-1;
            s(.t.).b := s(.t.).r > s(.t+1.).r
          End ;
      44: Begin
            t := t-1;
            s(.t.).b := s(.t.).r >= s(.t+1.).r
          End ;
      45: Begin
            t := t-1;
            s(.t.).b := s(.t.).i = s(.t+1.).i
          End ;
      46: Begin
            t := t-1;
            s(.t.).b := s(.t.).i <> s(.t+1.).i
          End ;
      47: Begin
            t := t-1;
            s(.t.).b := s(.t.).i < s(.t+1.).i
          End ;
      48: Begin
            t := t-1;
            s(.t.).b := s(.t.).i <= s(.t+1.).i
          End ;
      49: Begin
            t := t-1;
            s(.t.).b := s(.t.).i > s(.t+1.).i
          End ;
      50: Begin
            t := t-1;
            s(.t.).b := s(.t.).i >= s(.t+1.).i
          End ;
      51: Begin
            t := t-1;
            s(.t.).b := s(.t.).b or s(.t+1.).b
          End ;
      52: Begin
            t := t-1;
            s(.t.).i := s(.t.).i + s(.t+1.).i
          End;
      53: Begin
            t := t-1;
            s(.t.).i := s(.t.).i - s(.t+1.).i
          End;
      54: Begin
            t := t-1;
            s(.t.).r := s(.t.).r + s(.t+1.).r
          End;
      55: Begin
            t := t-1;
            s(.t.).r := s(.t.).r - s(.t+1.).r
          End;
      56: Begin
            t := t-1;
            s(.t.).b := s(.t.).b and s(.t+1.).b
          End ;
      57: Begin
            t := t-1;
            s(.t.).i := s(.t.).i * s(.t+1.).i
          End;
      58: Begin
            t := t-1;
            If s(.t+1.).i = 0 Then
              ps := divchk
            Else
              s(.t.).i := s(.t.).i div s(.t+1.).i
          End;
      59: Begin
            t := t-1;
            If s(.t+1.).i = 0 Then
              ps := divchk
            Else
              s(.t.).i := s(.t.).i mod s(.t+1.).i
          End;
      60: Begin 
            t := t-1;
            s(.t.).r := s(.t.).r * s(.t+1.).r
          End;
      61: Begin
            t := t-1;
            s(.t.).r := s(.t.).r / s(.t+1.).r
          End;
      62: If eof(InputFile) Then
            ps := redchk
          Else
            readln(InputFile);
      63: Begin
            WriteLn;
            lncnt := lncnt + 1;
            chrcnt := 0;
            If lncnt > linelimit Then
              ps := linchk
          End
      End (*case*) ;
    Until ps <> run;

    If ps <> fin Then
    Begin
      WriteLn;
      WriteLn;
      Write('halt at', pc:5, ' because of ');
      Case ps of
        caschk: WriteLn('undefined case');
        divchk: WriteLn('division by 0');
        inxchk: WriteLn('invalid index');
        stkchk: WriteLn('storage overflow');
        linchk: WriteLn('too much output');
        lngchk: WriteLn('line too long');
        redchk: WriteLn('reading past end of file');
      End;
      h1 := b; blkcnt := 10;   (*post mortem dump*)
      Repeat
        WriteLn;
        blkcnt := blkcnt - 1;
        If blkcnt = 0 Then
          h1 := 0; h2 := s(.h1+4.).i;
        If h1<>0 Then
          WriteLn(' ',tab(.h2.).name, ' called at ', s(.h1+1.).i: 5);
        h2 := btab(.tab(.h2.).ref.).last;
        While h2 <> 0 do
          With tab(.h2.) do
          Begin
            If obj = variable Then
              If typ in stantyps Then
              Begin
                Write('    ', name, ' = ');
                If normal Then
                  h3 := h1+adr
                Else
                  h3 := s(.h1+adr.).i;
                Case typ of
                  ints:  WriteLn(s(.h3.).i:10);
                  reals: WriteLn(s(.h3.).r);
                  bools: WriteLn(s(.h3.).b:10);
                  chars: WriteLn(s(.h3.).c:10);
                End
              End ;
            h2 := link
          End;
          h1 := s(.h1+3.).i
      Until h1 < 0;
    End ;
    WriteLn;
    WriteLn(ocnt:10, ' steps')
  End (*interpret*) ;

Var
  Ok: Boolean;
Begin
  Ok:= False;
  If paramcount >= 1 Then
  Begin
    assign(InputFile,ParamStr(1));
  (*$I-*)
    reset(InputFile);
  (*$I+*)
    Ok:= IoResult = 0
  End;
  While Not Ok Do
  Begin
    WriteLn;   (* main program *)
    Write('source code on file ? ');
    readln(xname);
    assign(InputFile,xname);
  (*$I-*)
    reset(InputFile);
  (*$I+*)
    Ok:= IoResult = 0
  End;
  key(. 1.) := 'and       '; key(. 2.) := 'array     ';
  key(. 3.) := 'begin     '; key(. 4.) := 'case      ';
  key(. 5.) := 'const     '; key(. 6.) := 'div       ';
  key(. 7.) := 'do        '; key(. 8.) := 'downto    ';
  key(. 9.) := 'else      '; key(.10.) := 'end       ';
  key(.11.) := 'for       '; key(.12.) := 'function  ';
  key(.13.) := 'if        '; key(.14.) := 'mod       ';
  key(.15.) := 'not       '; key(.16.) := 'of        ';
  key(.17.) := 'or        '; key(.18.) := 'procedure ';
  key(.19.) := 'program   '; key(.20.) := 'record    ';
  key(.21.) := 'repeat    '; key(.22.) := 'then      ';
  key(.23.) := 'to        '; key(.24.) := 'type      ';
  key(.25.) := 'until     '; key(.26.) := 'var       ';
  key(.27.) := 'while     ';
  ksy(. 1.) := andsy;        ksy(. 2.) := arraysy;
  ksy(. 3.) := beginsy;      ksy(. 4.) := casesy;
  ksy(. 5.) := constsy;      ksy(. 6.) := idiv;
  ksy(. 7.) := dosy;         ksy(. 8.) := downtosy;
  ksy(. 9.) := elsesy;       ksy(.10.) := endsy;
  ksy(.11.) := forsy;        ksy(.12.) := functionsy;
  ksy(.13.) := ifsy;         ksy(.14.) := imod;
  ksy(.15.) := notsy;        ksy(.16.) := ofsy;
  ksy(.17.) := orsy;         ksy(.18.) := proceduresy;
  ksy(.19.) := programsy;    ksy(.20.) := recordsy;
  ksy(.21.) := repeatsy;     ksy(.22.) := thensy;
  ksy(.23.) := tosy;         ksy(.24.) := typesy;
  ksy(.25.) := untilsy;      ksy(.26.) := varsy;
  ksy(.27.) := whilesy;
  sps(.'+'.) := plus;        sps(.'-'.) := minus;
  sps(.'*'.) := times;       sps(.'/'.) := rdiv;
  sps(.'('.) := lparent;     sps(.')'.) := rparent;
  sps(.'='.) := eql;         sps(.','.) := comma;
  sps(.'['.) := lbrack;      sps(.']'.) := rbrack;
  sps(.'#'.) := neq;         sps(.'&'.) := andsy;
  sps(.';'.) := semicolon;
  constbegsys := (.plus,minus,intcon,realcon,charcon,ident.);
  typebegsys :=  (.ident,arraysy,recordsy.);
  blockbegsys := (.constsy,typesy,varsy,proceduresy,
                   functionsy,beginsy.);
  facbegsys :=   (.intcon,realcon,charcon,ident,lparent,notsy.);
  statbegsys :=  (.beginsy,ifsy,whilesy,repeatsy,forsy,casesy.);
  stantyps :=    (.notyp,ints,reals,bools,chars.);
  lc := 0;
  ll:=0;
  cc := 0;
  ch := ' ';
  errpos := 0;
  errs := (..);
  insymbol;
  t := -1;
  a := 0;
  b := 1;
  sx := 0;
  c2 := 0;
  display(.0.) := 1; 
  iflag := false;
  oflag := false;
  If sy <> programsy Then
    Error(3)
  Else
  Begin
    insymbol;
    If sy <> ident Then
      Error(2)
    Else
    Begin
      progname := id;
      insymbol;
      If sy <> lparent Then
        Error(9)
      Else
        Repeat
          insymbol;
          If sy <> ident Then
            Error(2)
          Else
          Begin
            If id = 'input     ' Then
              iflag := true
            Else
              If id = 'output    ' Then
                oflag := true
              Else
                Error(0);
            insymbol
          End
        Until sy <> comma;
      If sy = rparent Then
        insymbol
      Else
        Error(4);
      If not oflag Then
        Error(20)
    End
  End;
  enter('          ', variable, notyp, 0);  (*sentinel*)
  enter('false     ', konstant, bools, 0);              
  enter('true      ', konstant, bools, 1);              
  enter('real      ', type1, reals, 1);              
  enter('char      ', type1, chars, 1);              
  enter('boolean   ', type1, bools, 1);              
  enter('integer   ', type1, ints , 1);              
  enter('abs       ', funktion, reals,0);              
  enter('sqr       ', funktion, reals,2);              
  enter('odd       ', funktion, bools,4);              
  enter('chr       ', funktion, chars,5);              
  enter('ord       ', funktion, ints ,6);              
  enter('succ      ', funktion, chars,7);              
  enter('pred      ', funktion, chars,8);              
  enter('round     ', funktion, ints ,9);              
  enter('trunc     ', funktion, ints ,10);              
  enter('sin       ', funktion, reals, 11);              
  enter('cos       ', funktion, reals, 12);              
  enter('exp       ', funktion, reals, 13);              
  enter('ln        ', funktion, reals, 14);              
  enter('sqrt      ', funktion, reals, 15);              
  enter('arctan    ', funktion, reals, 16);              
  enter('eof       ', funktion, bools, 17);
  enter('eoln      ', funktion, bools, 18);              
  enter('read      ', prozedure, notyp, 1);              
  enter('readln    ', prozedure, notyp, 2);              
  enter('write     ', prozedure, notyp, 3);              
  enter('writeln   ', prozedure, notyp, 4);              
  enter('          ', prozedure, notyp, 0);
  With btab(.1.) do 
  Begin
    last := t;
    lastpar := 1;
    psize := 0; 
    vsize := 0;
  End;
  Block(blockbegsys+statbegsys, false, 1);
  If sy <> period Then
    Error(22);
  Emit(31);  (*halt*)
  If btab(.2.).vsize > stacksize Then
    Error(49);
  If progname = 'test0     ' Then
    PrintTables;
  
  If errs = (..) Then
  Begin
    If iflag Then
    Begin
      WriteLn('input data on file ? ');
      Reset(InputFile);
      Read(xname);
      Assign(InputFile,xname);
      Reset(InputFile);
      If eof(InputFile) Then
        WriteLn(' input data missing')
      Else
      Begin
        WriteLn(' (bof)'); (*copy input data*)
        While not eof(InputFile) do
        Begin
          Write(' ');
          While not eoln(InputFile) do
          Begin
            Read(InputFile,ch);
            Write(ch)
          End;
          WriteLn;
          readln(InputFile)
        End;
        Assign(InputFile,xname);
        Reset(InputFile);
      End
    End;
    WriteLn(' (eof)');
    Interpret
  End
  Else
    ErrorMsg;
99:   
End.

246 IconJanuary 9, 2007. Birger Nielsen, bnielsen@daimi.au.dk, drinker of tea.
This document: http://www.246.dk/pascals4.html