{ Pascal-S from N Wirth's paper 'Pascal-S: a subset and its implementation'
  which is most easily found in the book 'Pascal: the language and its
  implementation' edited by Barron. You might also like to look at
  'Principles of concurrent programming' by Ben-Ari (the first edition)
  which contains a munged version of Pascal-S that supports some
  concurrency.}

{ This version of Pascal-S was originally fetched from csvax.cs.caltech.edu
  where it lived in directory /jan. I believe that it was set up by Jan van
  de Snepscheut. I don't know anything else about its provenance. I modified
  the program to suit Turbo Pascal version 5.5 as detailed in the next
  comment. Jan's fixes to the published program are detailed in the comment
  after that.

                             Adrian Johnstone, 22 March 1995
                             adrian@dcs.rhbnc.ac.uk
}

{For Turbo Pascal:
   changed string to sstring
   changed halt to hhalt
   changed getch to read from infile instead of stdin and added file assign
   statements to mainline routine.
   removed label 99:
   changed 'goto 99' to halt;
   added chr(10) and chr(13) to list of throw-aways in getsym
}


{ line 295 (counting from 1 starting at program PascalS) is
                                  gen1(mulc, ttab[t].size); gen0(add)
  whereas the version printed in the book accidentally reads
                                  gen1(mulc, ttab[t].size)
  the present version also implements boolean negation

  the procedure funcdeclaration in the version printed in the book is
  erroneous. The first line on page 376 in the book should read
                                  if lev>1 then dx:=-1
  the last line of the procedure should read
        gen1(exit,itab[f].resultadr-dx); lev:=lev-1; dx:=odx
}

program PascalS(infile, output);

const cxmax  = 2000;     { size of code array }
      amax   = 16383;    { maximum address }

type  opcode = (add, neg, mul, divd, remd, div2, rem2, eqli, neqi, lssi,
                leqi, gtri, geqi, dupl, swap, andb, orb,
                load, stor, hhalt, wri, wrc, wrl, rdi, rdc, rdl, eol,
                ldc, ldla, ldl, ldg, stl, stg, move, copy, addc, mulc,
                jump, jumpz, call, adjs, sets, exit);
      instr  = record case op: opcode of
                 add, neg, mul, divd, remd, div2, rem2, eqli, neqi, lssi,
                 leqi, gtri, geqi, dupl, swap, andb, orb,
                 load, stor, hhalt, wri, wrc, wrl, rdi, rdc, rdl, eol:
                        ();
                 ldc, ldla, ldl, ldg, stl, stg, move, copy, addc, mulc,
                 jump, jumpz, call, adjs, sets, exit:
                        (a: integer)
               end;

var code: array [0..cxmax] of instr;
    m   : array [0..amax] of integer;
    infile: text;

procedure compile;

const imax   = 100;     { length of identifier table }
      tmax   = 100;     { length of type table }
      lmax   = 10;      { maximum level }
      al     = 10;      { length of identifiers }
      fabs   = 0;       { standard functions }
      fsqr   = 1; fodd   = 2; fchr    = 3;
      ford   = 4; fwrite = 5; fwriteln= 6;
      fread  = 7; freadln= 8; feoln   = 9;
      { standard types }
      intip  = 1; booltip= 2; chartip = 3;

type symbol = (ident, number, sstring, plus, minus, star, lbrack, rbrack,
               colon, eql, neq, lss, leq, gtr, geq, lparen, rparen, comma, 
               semicolon, period, becomes,
               beginsym, endsym, ifsym, thensym, elsesym, whilesym, dosym,
               casesym, repeatsym, untilsym, forsym, tosym, downtosym,
               notsym, divsym, modsym, andsym, orsym, constsym, varsym,
               typesym, arraysym, ofsym, recordsym, progsym, funcsym,
               procsym);
     idkind = (konst, varbl, field, tipe, funkt);
     tpkind = (simple, arrays, records);
     alfa   = packed array [1..al] of char;

var ch: char;                   { last character read }
    cc: integer;                { character count }
    ll: integer;                { line length }
    line: array [1..81] of char;{ present input line }
    sym: symbol;                { last symbol read }
    id: alfa;                   { last identifier read }
    num: integer;               { last number read }
    str: array [1..80] of char; { last string read }
    slen: integer;              { length of last string }
    word: array [beginsym..procsym] of alfa;
    cx: integer;                { code index }
    lev: integer;               { procedure nesting level }
    dx: integer;                { offset in stack }
    labeled: boolean;           { next instruction has label }
    namelist: array [-1..lmax] of integer;
    ix, tx: integer;            { indices in tables }
    itab: array [0..imax] of    { identifier table }
            record name: alfa; link: integer; tip: integer;
              case kind: idkind of
                konst: (val: integer);
                varbl: (vlevel, vadr: integer; refpar: boolean);
                field: (offset: integer);
                tipe : ();
                funkt: (flevel, fadr, lastpar, resultadr: integer;
                           inside: boolean)
            end;
    ttab: array [1..tmax] of    { type table }
            record size: integer;
              case kind: tpkind of
                simple : ();
                arrays : (low, high, elemtip: integer);
                records: (fields: integer)
            end;

procedure error(n: integer);
  var i: integer;
begin for i:= 1 to ll do write(line[i]); writeln;
      for i:= 1 to cc-2 do write(' '); writeln('^');
      writeln('error ', n:1, ' detected');
      halt; { Turbo Pascal exit routine }
end;

procedure getch;
begin if cc=ll then begin
          if eof(infile) then error(100); ll:= 0; cc:= 0;
          while not eoln(infile) do begin ll:= ll+1; read(infile, line[ll]) end;
          ll:= ll+1; read(infile, line[ll])
      end;
      cc:= cc+1; ch:= line[cc]
end;

procedure getsym;
  var k: integer; s: symbol; strend: boolean;
begin while ch in [' ', chr(9), chr(13), chr(10)] do getch;
      if ch in ['a'..'z', 'A'..'Z'] then begin
          k:= 0;
          repeat if k<>al then begin k:= k+1; id[k]:= ch end;
                 getch
          until not (ch in ['a'..'z', 'A'..'Z', '0'..'9']);
          while k<>al do begin k:= k+1; id[k]:= ' ' end;
          sym:= ident;
          for s:= beginsym to procsym do if word[s]=id then sym:= s
      end else if ch in ['0'..'9'] then begin
          num:= 0; sym:= number;
          repeat num:= num*10 + (ord(ch)-ord('0'));
                 getch
          until not (ch in ['0'..'9'])
      end else if ch=':' then begin
          getch;
          if ch='=' then begin getch; sym:= becomes end
                    else sym:= colon
      end else if ch='>' then begin
          getch;
          if ch='=' then begin getch; sym:= geq end
                    else sym:= gtr
      end else if ch='<' then begin
          getch;
          if ch='=' then begin getch; sym:= leq end else
          if ch='>' then begin getch; sym:= neq end
                    else sym:= lss
      end else if ch='.' then begin
          getch;
          if ch='.' then begin getch; sym:= colon end
                    else sym:= period
      end else if ch='''' then begin
          slen:= 0; strend:= false; sym:= sstring;
          repeat if cc=ll then error(101); getch;
                 if ch='''' then begin
                     getch;
                     if ch='''' then begin
                         slen:= slen+1; str[slen]:= ch
                     end else
                         strend:= true
                 end else begin
                     slen:= slen+1; str[slen]:= ch
                 end
          until strend;
          if slen=0 then error(102)
      end
      else if ch='+' then begin getch; sym:= plus end
      else if ch='-' then begin getch; sym:= minus end
      else if ch='*' then begin getch; sym:= star end
      else if ch='(' then begin getch; sym:= lparen end
      else if ch=')' then begin getch; sym:= rparen end
      else if ch='[' then begin getch; sym:= lbrack end
      else if ch=']' then begin getch; sym:= rbrack end
      else if ch='=' then begin getch; sym:= eql end
      else if ch=',' then begin getch; sym:= comma end
      else if ch=';' then begin getch; sym:= semicolon end
      else if ch='{'
      then begin repeat getch until ch='}';
                 getch; getsym
           end
      else error(103)
end;

procedure check(s: symbol);
begin if sym<>s then error(ord(s)) end;

procedure skip(s: symbol);
begin check(s); getsym end;

procedure enter(id: alfa; k: idkind; t: integer);
  var j: integer;
begin if ix=imax then error(104); ix:= ix+1;
      itab[0].name:= id; j:= namelist[lev];
      while itab[j].name<>id do j:= itab[j].link;
      if j<>0 then error(105);
      with itab[ix] do begin
        name:= id; link:= namelist[lev]; tip:= t; kind:= k
      end;
      namelist[lev]:= ix
end;

function position: integer;
  var i, j: integer;
begin itab[0].name:= id; i:= lev;
      repeat j:= namelist[i];
             while itab[j].name<>id do j:= itab[j].link;
             i:= i-1
      until (i<-1) or (j<>0);
      if j=0 then error(106); position:= j
end;

procedure gen(i: instr);
begin case i.op of
        dupl, eol, ldc, ldla, ldl, ldg:
          dx:= dx-1;
        neg, div2, rem2, swap, load, hhalt, wrl, rdl,
        addc, mulc, jump, call, sets, exit:
          ;
        add, mul, divd, remd, eqli, neqi, lssi, leqi, gtri,
        geqi, andb, orb, wrc, rdi, rdc, stl, stg, jumpz:
          dx:= dx+1;
        stor, wri, move:
          dx:= dx+2;
        copy:
          dx:= dx-i.a+1;
        adjs:
          dx:= dx+i.a
      end;
      if not (((i.op in [addc, adjs]) and (i.a=0)) or
              ((i.op=mulc) and (i.a=1))) then
      if labeled then begin
          code[cx]:= i; cx:= cx+1; labeled:= false
      end else if (code[cx-1].op=ldc) and (i.op=add) then
          code[cx-1].op:= addc
      else if (code[cx-1].op=ldc) and (i.op=mul) then
          code[cx-1].op:= mulc
      else if (code[cx-1].op=ldc) and (i.op=neg) then
          code[cx-1].a:= -code[cx-1].a
      else if (code[cx-1].op=ldc) and (code[cx-1].a=2) and (i.op=divd) then
          code[cx-1].op:= div2
      else if (code[cx-1].op=ldc) and (code[cx-1].a=2) and (i.op=remd) then
          code[cx-1].op:= rem2
      else if (code[cx-1].op=ldc) and (i.op=stor) then
          code[cx-1].op:= stg
      else if (code[cx-1].op=ldc) and (i.op=load) then
          code[cx-1].op:= ldg
      else if (code[cx-1].op=ldla) and (i.op=stor) then
          code[cx-1].op:= stl
      else if (code[cx-1].op=ldla) and (i.op=load) then
          code[cx-1].op:= ldl
      else begin
          code[cx]:= i; cx:= cx+1
end   end;

procedure gen0(op: opcode);
  var i: instr;
begin i.op:= op; gen(i) end;

procedure gen1(op: opcode; a: integer);
  var i: instr;
begin i.op:= op; i.a:= a; gen(i) end;

function codelabel: integer;
begin codelabel:= cx; labeled:= true end;

procedure address(lv, ad: integer);
begin if lv=0 then
          gen1(ldc, ad)
      else if lv=lev then
          gen1(ldla, ad-dx)
      else begin
          gen1(ldl, -dx);
          while lv+1<>lev do begin gen0(load); lv:= lv+1 end;