{ Facilis 0.20                                      file: FACILIS.PAS    }
{$R+}
program Facilis;

 { based on the Pascal S compiler of Niklaus Wirth,
      as modified by R.E. Berry }

 { adapted for the IBMPC by John R. Naleszkiewicz }

 { extensions by Anthony M. Marcy }

const
  version = 0.20;
  nkw  =  35;     { no. of key words }
  alng =  10;     { no. of significant chars in identifiers }
  llng = 121;     { input line legnth }
  emax =  38;     { max exponent of real numbers }
  emin = -38;     { min exponent }
  kmax =  11;     { max no. of significant digits }
  tmax = 300;     { size of table }
  bmax =  30;     { size of block-table }
  amax =  30;     { size of array-table }
  c2max=  50;     { size of real constant table }
  csmax=  30;     { max no. of cases }
  cmax =8000;     { size of code }
  lmax =   7;     { maximum level }
  ermax=  61;     { max error no. }
  omax =  255;    { highest order code }
  xmax =  32767;  { maximum array bound }
  nmax =  32767;  { maximum integer }
  lineleng  =   80; {output line length }
  stacksize = 2000;

type
  symbol =
   (intcon,realcon,charcon,stringcon,
    notsy,plus,minus,times,idiv,rdiv,imod,andsy,orsy,insy,
    eql,neq,gtr,geq,lss,leq,
    lparent,rparent,lbrack,rbrack,comma,semicolon,period,twodots,
    colon,becomes,constsy,typesy,varsy,funcsy,nilsy,
    procsy,filesy,arraysy,recordsy,packedsy,setsy,programsy,labelsy,ident,
    withsy,beginsy,ifsy,casesy,repeatsy,whilesy,forsy,gotosy,
    endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,thensy);

  index  = -xmax..+xmax;
  alfa   = packed array [1..alng] of char;
  object = (konstant,vvariable,type1,prozedure,funktion);
  types  = (notyp,ints,reals,bools,chars,strngs,arrays,records);
  symset = set of symbol;
  typset = set of types;
  strng  = string[20];
  order  = packed record
             f: 0..omax;
             x: 0..lmax;
             y: -nmax..+nmax;
           end ;

var
  ch    : char;            { last character read from source program}
  rnum  : real;            { real number from insymbol }
  i,j   : integer;
  inum  : integer;         { integer from insymbol }
  sleng : integer;         { string length }
  cc    : integer;         { character counter }
  lc    : integer;         { program location counter }
  ll    : integer;         { length of current line }
  errpos: integer;
  nul   : integer;         { seg of null string }
  t,a,b,c1,c2: integer; { indices to tables}
  skipflag, stackdump, prtables   : boolean;

  sy      : symbol;        { last symbol read by insymbol }
  errs    : set of 0..ermax;
  id      : alfa;          { identifier from insymbol }
  progname: alfa;
  stantyps: typset;
  constbegsys,typebegsys,blockbegsys,facbegsys,statbegsys: symset;

  line       : array [1..llng] of char;
  key        : array [1..nkw] of alfa;
  ksy        : array [1..nkw] of symbol;
  sps        : array ['!'..'~'] of symbol;
  display    : array [0 .. lmax] of integer;

  tab:     array [0 .. tmax] of     { identifier table }
             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 }
             record
               inxtyp, eltyp: types;
               elref, low, high, elsize, size: index
             end ;

  btab:    array [1 .. bmax] of     { block-table }
             record
               last, lastpar, psize, vsize: index
             end ;

  spnt,tpnt: ^char;
  rconst:  array [1 .. c2max] of real;

  code  :  array [0 .. cmax] of order;
  opcode: byte;
       x: byte;      { operand }
       y: integer;   { operand }
      pc: integer;   { program counter }

  psin, psout, prr, prd: text;
  inf, outf, tempstr: strng;

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] := 'real numbr'; 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    '; msg[59] :='comma     ';
       msg[60] := 'idx string'; msg[61] :='too big   ';

       writeln(psout); writeln(psout,' key words');
       k:=0;
       while errs <> [] do begin
         while not (k in errs) do k := k+1;
         writeln(psout,k,'  ',msg[k]);
         errs := errs - [k]
       end
     end { errormsg } ;

procedure fatal(n: integer);

var    msg: array [1..8] of alfa;
begin
  writeln(psout); errormsg;

  msg[ 1] := 'identifier'; msg[ 2] := 'procedures';
  msg[ 3] := 'reals     '; msg[ 4] := 'arrays    ';
  msg[ 5] := 'levels    '; msg[ 6] := 'code      ';
  msg[ 7] := 'strings   '; msg[ 8] := 'input line';

  writeln(psout,' compiler table for ', msg[n], ' is too small');
  close(psout); halt       {terminate compilation}
end { fatal } ;

function stupcase(st: strng): strng;

var i: integer;

begin
  for i := 1 to length(st) do
    st[i] := upcase(st[i]);
  stupcase := st
end;  { stupcase }

procedure endskip;

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

procedure nextch;   { read next character; process line end }

begin
  if cc = ll
  then begin
    if eof(psin)
    then begin
      writeln(psout);
      writeln(psout,' program incomplete');
      errormsg;
      close(psout); halt;     { abort }
    end ;
    if errpos <> 0
    then begin
      if skipflag then endskip;
      writeln(psout);
      errpos := 0
    end ;
    write(psout,lc:5, '  ');
    ll := 0; cc := 0;
    while not eoln(psin) do
    begin
      if ll > llng-2 then fatal(8);
      read(psin,ch);
      if ch <> chr(10) then begin
        if ord(ch) < 32 then ch := ' ';
        write(psout,ch);
        ll := ll+1;
        line[ll] := ch
      end
    end ;
    ll := ll+1; line[ll] := ' ';
    read(psin,ch); writeln(psout);
  end ;
  cc := cc+1; ch := line[cc];
end { nextch } ;

procedure error(n: integer);

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

procedure insymbol;           { reads next symbol }

const dotdot = #31;
label  1,2,3 ;
var    i,j,k,e: integer;
       sbuff: string[132];

  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 ;
    if not ((ch>='0') and (ch<='9'))
    then error(40)
    else repeat
           s := 10*s + ord(ch)-ord('0');
           nextch
         until not ((ch>='0') and (ch<='9'));
    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 } ;

procedure options;

  procedure switch(var b: boolean);

  begin
    b:=ch='+';
    if not b
    then if not (ch='-')
         then  begin
           error(6);
           while (ch<>'*') and (ch<>',') and (ch<>'}') do nextch;
         end
         else nextch
    else nextch
  end { switch } ;

  begin      {options}
    repeat
      nextch;
      if (ch <> '*') and (ch <> '}')
      then begin
        if ((ch='t') or (ch='T'))
        then begin
          nextch; switch(prtables)
        end else if ((ch='s') or (ch='S'))
                 then begin
                   nextch; switch(stackdump)
                 end
      end
    until ch<>','
  end  { options } ;

begin    { insymbol }

1: while ch = ' ' do nextch;

  if ch in ['a'..'z','A'..'Z']
  then begin { identifier or wordsymbol }
      k := 0; id := '          ';
      if ch in ['A'..'Z'] then ch := chr(ord(ch)+32);
      repeat
        if k < alng
        then begin
          k := k+1; id[k] := ch
        end ;
        nextch;
        if ch in ['A'..'Z'] then ch := chr(ord(ch)+32)
      until not ( (ch in ['a'..'z']) or (ch in ['0'..'9'])
                  or (ch='_') );
      i := 1; j:= nkw;    { binary search }
      repeat
        k := (i+j) div 2;
        if id <= key[k] then j := k-1;
        if id >= key[k] then i := k+1
      until i > j;
      if i-1 > j then sy := ksy[k] else sy := ident
    end

  else if ch in ['+','-','*','/',')','=',',','[',']',';','&','|','~']
  then begin
      sy := sps[ch]; nextch
    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>='0') and (ch<='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 := dotdot
        else begin
          sy := realcon; rnum := inum; e := 0;
          while (ch>='0') and (ch<='9') do
          begin
            e := e-1;
            rnum := 10.0*rnum + (ord(ch)-ord('0'));
            nextch
          end ;
          if e = 0 then error(40);
          if ((ch = 'e') or (ch = 'E')) then readscale;
          if e <> 0 then adjustscale
        end
      end else
        if ((ch = 'e') or (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 := twodots; nextch
      end else sy := period
    end;

dotdot:
    begin
      sy := twodots; nextch
    end;

'''' :
    begin
      sbuff := '';
 2:   nextch;
      if ch = ''''
      then  begin
        nextch;
        if ch <> '''' then goto 3
      end ;
      if length(sbuff) < 132
      then sbuff := sbuff + ch
      else error(38);
      if cc = 1
      then error(38)  { end of line }
      else goto 2;

 3:   if length(sbuff) = 1
      then begin
        sy := charcon; inum := ord(sbuff[1])
      end else begin
        sy := stringcon;
        sleng := length(sbuff);
        if sleng=0
        then spnt := ptr(nul,0)
        else begin
          getmem(spnt,((sleng+3) div 16 +1)*16);
          k := seg(spnt^);
          memw[k:0] := sleng;
          memw[k:2] := 0;
          move(sbuff[1],mem[k:4],sleng);
        end;
      end
    end;

'(' :
    begin
      nextch;
      if ch <> '*'
      then sy := lparent
      else begin { comment }
        nextch;
        if ch='$' then options;
        repeat
          while ch <>  '*' do nextch;
          nextch
        until ch = ')';
        nextch; goto 1
      end
    end;

'{' :
    begin { comment }
      nextch;
      if ch='$' then options;
      while ch <> '}' do nextch;
      nextch; goto 1
    end;

  else nextch; error(24); goto 1

  end {case}
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);
  code[lc].f := fct; lc := lc+1
end { emit } ;

procedure emit1(fct,b: integer);

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

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

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

procedure printtables;

var    i:integer;
       o: order;

begin
  writeln(psout); writeln(psout); writeln(psout);
  writeln(psout,'   identifiers link  obj  typ  ref  nrm  lev  adr');
  writeln(psout);
  for i := btab[1].last to t do
    with tab[i] do
      writeln(psout,i,' ',name,link:5, ord(obj):5, ord(typ):5, ref:5,
              ord(normal):5, lev:5, adr:5);

  writeln(psout); writeln(psout); writeln(psout);
  writeln(psout,'blocks    last lpar psze vsze');
  writeln(psout);
  for i := 1 to b do
    with btab[i] do
      writeln(psout,i:4, last:9, lastpar:5, psize:5, vsize:5);

  writeln(psout); writeln(psout); writeln(psout);
  writeln(psout,'arrays    xtyp etyp eref  low high elsz size');
  writeln(psout);

  for i := 1 to a do
    with atab[i] do
      writeln(psout,i:4, ord(inxtyp):9, ord(eltyp):5,
              elref:5, low:5, high:5, elsize:5, size:5);

  writeln(psout); writeln(psout); writeln(psout);
  writeln(psout,' code:'); writeln(psout);

  for i:=0 to lc-1 do
  begin
    write(psout); write(psout,i:5);
    o := code[i]; write(psout,o.f:5);
    if o.f < 100
    then if o.f<4
         then write(psout,o.x:2, o.y:5)
         else write(psout,o.y:7)
    else write(psout,'       ');
    writeln(psout,',')
  end;
  writeln(psout);
  writeln(psout,'Starting address is ',tab[btab[1].last].adr:5)

end { printtables };

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

{$I BLOCK.PAS }

{$I INTERPRT.PAS }

procedure block;

begin
  blockov(fsys,isfun,level)
end;

procedure setup;

begin
  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] := 'file      '; key[12] := 'for       ';
  key[13] := 'function  '; key[14] := 'goto      ';
  key[15] := 'if        '; key[16] := 'in        ';
  key[17] := 'label     '; key[18] := 'mod       ';
  key[19] := 'nil       '; key[20] := 'not       ';
  key[21] := 'of        '; key[22] := 'or        ';
  key[23] := 'packed    '; key[24] := 'procedure ';
  key[25] := 'program   '; key[26] := 'record    ';
  key[27] := 'repeat    '; key[28] := 'set       ';
  key[29] := 'then      '; key[30] := 'to        ';
  key[31] := 'type      '; key[32] := 'until     ';
  key[33] := 'var       '; key[34] := 'while     ';
  key[35] := 'with      ';
  ksy[ 1] := andsy;        ksy[ 2] := arraysy;
  ksy[ 3] := beginsy;      ksy[ 4] := casesy;
  ksy[ 5] := constsy;  &nb