Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FACILIS2.ZIP/FACILIS.PAS

Pascal/Delphi Source File | 1980-01-01 | 25.3 KB | 935 lines

{ Facilis 0.31                                      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.31;
  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 symbol 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   = 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  = record
             f: 0..omax;
             x: 0..lmax;
             y: integer;
           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;

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] := 'type      '; 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] := '          '; 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] := 'bad number'; 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] :='          ';
       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;

  begin
    sbuff := sbuff + 'E';
    nextch;
    if (ch = '+') or (ch = '-')
    then begin
      sbuff := sbuff + ch; nextch;
      end;
    if not ((ch>='0') and (ch<='9'))
    then error(40)
    else repeat
        sbuff := sbuff + ch;
        nextch;
      until not ((ch>='0') and (ch<='9'));
  end;

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 upcase(ch) in ['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; sbuff := '';
      repeat
        sbuff := sbuff + ch;
        k := k+1;
        nextch
      until not ((ch>='0') and (ch<='9'));
      val(sbuff,inum,j);

      if ch = '.'
      then begin
        nextch;
        if ch = '.'
        then begin
          ch := dotdot; sy := intcon;
          if j <> 0 then begin
            error(21); inum := 0; k := 0
            end;
          end
        else begin
          sy := realcon; sbuff := sbuff + '.'; e := 0;
          while (ch>='0') and (ch<='9') do
          begin
            e := e-1;
            sbuff := sbuff + ch;
            nextch
          end;
          if e = 0 then error(40);
          if ((ch = 'e') or (ch = 'E')) then readscale;
          val(sbuff,rnum,j);
          if j <> 0 then error(21);
          end
        end
      else if ((ch = 'e') or (ch = 'E'))
        then begin
          sy := realcon;
          readscale;
          val(sbuff,rnum,j);
          if j <> 0 then error(21);
        end
      else begin
        sy := intcon;
        if j <> 0 then begin
          error(21); inum := 0
          end;
        end;
      if upcase(ch) in ['A'..'Z']
      then error(40);
    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;

'$':
    begin { hex }
      nextch;
      k := 0; sbuff := '$';
      while upcase(ch) in ['0'..'9','A'..'F'] do begin
        k := k+1;
        sbuff := sbuff + ch;
        nextch; end;
      if (k = 0) or (upcase(ch) in ['G'..'Z']) then error(40)
      else if k > 4 then error(21)
      else val(sbuff,inum,j);
      sy := intcon;
    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 }

overlay procedure initialize;

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;      ksy[ 6] := idiv;
  ksy[ 7] := dosy;         ksy[ 8] := downtosy;
  ksy[ 9] := elsesy;       ksy[10] := endsy;
  ksy[11] := filesy;       ksy[12] := forsy;
  ksy[13] := funcsy;       ksy[14] := gotosy;
  ksy[15] := ifsy;         ksy[16] := insy;
  ksy[17] := labelsy;      ksy[18] := imod;
  ksy[19] := nilsy;        ksy[20] := notsy;
  ksy[21] := ofsy;         ksy[22] := orsy;
  ksy[23] := packedsy;     ksy[24] := procsy;
  ksy[25] := programsy;    ksy[26] := recordsy;
  ksy[27] := repeatsy;     ksy[28] := setsy;
  ksy[29] := thensy;       ksy[30] := tosy;
  ksy[31] := typesy;       ksy[32] := untilsy;
  ksy[33] := varsy;        ksy[34] := whilesy;
  ksy[35] := withsy;

  sps['+'] := plus;        sps['-'] := minus;
  sps['*'] := times;       sps['/'] := rdiv;
  sps[')'] := rparent;
  sps['='] := eql;         sps[','] := comma;
  sps['['] := lbrack;      sps[']'] := rbrack;
  sps['~'] := notsy;       sps['&'] := andsy;
  sps[';'] := semicolon;   sps['|'] := orsy;
end { setup } ;

procedure enterids;

begin
  enter('          ', vvariable, notyp, 0);  { sentinel }
  enter('false     ', konstant, bools, 0);
  enter('true      ', konstant, bools, 1);
  enter('maxint    ', konstant, ints, 32767);
  enter('real      ', type1, reals, 1);
  enter('char      ', type1, chars, 1);
  enter('boolean   ', type1, bools, 1);
  enter('integer   ', type1, ints , 1);
  enter('string    ', type1, strngs,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('maxavail  ', funktion, ints, 19);
  enter('length    ', funktion, ints, 20);
  enter('copy      ', funktion, strngs, 23);
  enter('pos       ', funktion, ints, 26);
  enter('str       ', funktion, strngs, 33);
  enter('val       ', funktion, ints, 35);
  enter('rval      ', funktion, reals, 37);
  enter('keypressed', funktion, bools, 39);
  enter('random    ', funktion, ints, 40);
  enter('upcase    ', funktion, chars, 42);
  enter('inkey     ', funktion, strngs, 47);
  enter('wherex    ', funktion, ints, 48);
  enter('wherey    ', funktion, ints, 49);   {next: 54}
  enter('read      ', prozedure, notyp, 1);
  enter('readln    ', prozedure, notyp, 2);
  enter('write     ', prozedure, notyp, 3);
  enter('writeln   ', prozedure, notyp, 4);
  enter('halt      ', prozedure, notyp, 5);
  enter('randomize ', prozedure, notyp, 6);
  enter('clrscr    ', prozedure, notyp, 7);
  enter('gotoxy    ', prozedure, notyp, 8);
  enter('textcolor ', prozedure, notyp, 9);
  enter('delay     ', prozedure, notyp, 10);
  enter('textbackgr', prozedure, notyp, 11);
  enter('sound     ', prozedure, notyp, 12);
  enter('nosound   ', prozedure, notyp, 13);
  enter('          ', prozedure, notyp, 0);
end;  { enterids }

procedure startup;

var
  exists: boolean;
  inf,outf,tempstr: strng;
  commandline: string[127] absolute cseg:$80;
  params: string[127];
  default: byte;

  procedure chkinf;
  begin
    inf := stupcase(inf);
    if pos('.',inf) = 0
    then inf := inf + '.PAS';
    assign(psin,inf);
    {$I-} reset(psin) {$I+} ;
    exists := (ioresult = 0);
    if pos(':',inf) = 0
    then inf := chr(default+65) + ':' + inf;
    if not exists
    then writeln('File ', inf, ' not found');
  end;

  procedure chkoutf;
  begin
    outf := stupcase(outf);
    assign(psout,outf);
    {$I-} rewrite(psout) {$I+} ;
    exists := (ioresult = 0);
    if pos(':',outf) = 0
    then outf := chr(default+65) + ':' + outf;
    if not exists
    then writeln('can''t open file ',outf);
  end;

begin
  inf := ''; outf := ''; params := commandline;
  Inline(
     $B4/$19                    { MOV AH,=$19 }
    /$CD/$21                    { INT =$21   ; determine default drive }
    /$88/$86/default );         { MOV [BP]default,AL }
  while (params <> '') and (params[1] = ' ') do
    delete(params,1,1);
  if params <> ''
  then begin                                       { command line parameters }
    while (params <> '') and (params[1] <> ' ') do begin
      inf := inf + params[1];
      delete(params,1,1); end;
    chkinf;
    if not exists then begin
      commandline := '';
      startup; end
    else begin
      writeln('Source file: ',inf);
      while (params <> '') and (params[1] = ' ') do
        delete(params,1,1);
      if params <> ''
      then while (params <> '') and (params[1] <> ' ') do begin
        outf := outf + params[1];
        delete(params,1,1); end
      else outf := copy(inf,1,pos('.',inf)) + 'LST';
      chkoutf;
      if not exists then begin
        commandline := '';
        startup; end
      else writeln('Listing file: ',outf);
      end;
    end
  else begin                                        { prompt for filenames }
    repeat
      write('  Source file [.PAS] ? '); readln(inf);
      chkinf;
    until exists;

    tempstr := copy(inf,1,pos('.',inf)) + 'LST';
    repeat
      repeat
        write('  Listing file [',tempstr,'] ? ');
        readln(outf); outf := stupcase(outf);
      until inf <> outf;
      if outf = '' then outf := tempstr;
      chkoutf;
    until exists;
    end;
  writeln;
end;  { startup }

begin    { initialize }
  writeln('                    Facilis   version ', version:4:2);
  writeln;

  constbegsys := [plus,minus,intcon,realcon,charcon,stringcon,ident];
  typebegsys  := [ident,arraysy,recordsy];
  blockbegsys := [constsy,typesy,varsy,procsy,funcsy,beginsy];
  facbegsys   := [intcon,realcon,charcon,stringcon,ident,lparent,notsy];
  statbegsys  := [beginsy,ifsy,whilesy,repeatsy,forsy,casesy];
  stantyps    := [notyp,ints,reals,bools,chars,strngs];

  assign(prd,'trm:');
  reset(prd);
  assign(prr,'con:');
  rewrite(prr);

  getmem(spnt,16);
  if ofs(spnt^) <> 0 then begin
    freemem(spnt,16); getmem(spnt,8);
    getmem(spnt,16); end;
  nul := seg(spnt^);
  memw[nul:0] := 0; memw[nul:2] := 0;

  setup;
  startup;
  enterids;
end;  { initialize }

procedure block;

begin
  blockov(fsys,isfun,level)
end;

begin { main }

      lc := 0;             ll := 0;
      cc := 0;             ch := ' ';
  errpos := 0;           errs := [];

         t := -1;                 a := 0;
         b :=  1;
        c2 :=  0;        display[0] := 1;
  skipflag := false;        prtables:= false;
  stackdump:= false;

  initialize;

  insymbol;
  if sy <> programsy
  then error(3)
  else begin
    insymbol;
    if sy <> ident
    then error(2)
    else begin
      progname := id;
      insymbol;
      if sy = lparent
      then begin
        repeat
          insymbol;
          if sy<> ident
          then error(2)
          else insymbol
        until sy <> comma;
        if sy = rparent then insymbol else error(4);
      end
    end
  end ;

  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(131);  { halt }

  if prtables then printtables;
  if errs=[]
  then interpret
  else begin
    writeln(psout);
    writeln(psout,'compiled with errors');
    writeln(psout);
    errormsg;
  end;

  writeln(psout);

  close(psout);
  close(prr)

end.