Category : Pascal Source Code
Archive   : FACILIS.ZIP
Filename : 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.10;
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= 60; { 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;

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';

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 case ch of

'0','1','2','3','4','5','6','7','8','9':
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;

':' :
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
sy := sps[ch]; nextch
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; 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('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('read ', prozedure, notyp, 1);
enter('readln ', prozedure, notyp, 2);
enter('write ', prozedure, notyp, 3);
enter('writeln ', prozedure, notyp, 4);
enter(' ', prozedure, notyp, 0);
end; { enterids }

procedure startup;

var
exists: boolean;

begin
writeln(' Facilis version ', version:4:2);
writeln;
repeat
write(' Source input file [.PAS] ? '); readln(inf);
inf := stupcase(inf);
if pos('.',inf) = 0
then inf := inf + '.PAS';
assign(psin,inf);
{$I-} reset(psin) {$I+} ;
exists := (ioresult = 0);
if not exists
then writeln('File ', inf, ' not found');
until exists;

tempstr := copy(inf,1,pos('.',inf)) + 'LST';
repeat
repeat
write('Source listing file [',tempstr,'] ? ');
readln(outf); outf := stupcase(outf);
until inf <> outf;
if outf = ''
then outf := tempstr;
assign(psout,outf);
{$I-} rewrite(psout) {$I+} ;
exists := (ioresult = 0);
if not exists
then writeln('can''t open file ',outf);
until exists;
end; { startup }

begin { main }

setup;

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];

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

writeln;
startup;

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

insymbol;

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

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;

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 ;

enterids;
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.