Tiny-Pascal & People's Pascal
Ronald Praver
If you do, do you have any of the documentation or source laying
around?
Bill Fahle
in the text of them, written in pascal. Of course, this requires
bootstrapping to get to a target machine. I found the following from
Amazon.com that sort of remind me of those books, but I can't be sure:
Practical Compiling with Pascal-S, by Michael Rees
Programming Language Translation: A Practical Approach
One of these might have been the one I used as a reference to write a
small-Pascal compiler for the Commodore-64 way back when. I found the
books in my university library; they're probably out of print by
now. What relation any of this has to Tiny-Pascal, I have no idea, but
I seem to have conflated all these ideas together in my memory of the
early eighties. I've never heard of People's Pascal.
Sammy Mitchell
>Does anyone remember these compilers from way back, about 1979..1980?
>If you do, do you have any of the documentation or source laying
>around?
I found this reference - perhaps it will help?
Chung Kin-Man and Yuen H (1978): A "Tiny" Pascal Compiler, Byte Magazine,
Byte Publications Inc., Petersborough N.H., USA, Volume 3, Numbers 9, 10,
11, September, October, November 1978.
A Johnstone
for Pascal-S from Wirth's 1970's paper. Many people have built systems around
this program. You can also get it from my ftp server:
ftp://ftp.cs.rhbnc.ac.uk/pub/compilers/pascals.pas
This version is set up to compile with Turbo-C. A word of warning to
people using the original paper: Wirth uses an array of keywords in
alphabetical order that is searched using a binary search. The
character collation sequence on the CDC6600 is not the same as for
ASCII, so the table needs reordering so that DO comes before DOWNTO
(on CDC space > W).
[A whole Pascal compiler in one mail message? Who could resist! -John]
-- Pascal-S follows --
{ 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 Baron. You migtht 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
adr...@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;
gen1(addc, ad)
end end;
procedure addressvar(ref: integer);
begin with itab[ref] do
begin address(vlevel, vadr); if refpar then gen0(load) end
end;
procedure mustbe(x, y: integer);
begin if x<>y then
if (ttab[x].kind=arrays) and (ttab[y].kind=arrays) and
(ttab[x].low=ttab[y].low) and (ttab[x].high=ttab[y].high)
then mustbe(ttab[x].elemtip, ttab[y].elemtip)
else error(107)
end;
procedure expression(var x: integer);
forward;
procedure selector(var t: integer; var ref: integer);
var j, x: integer;
begin t:= itab[ref].tip; getsym;
if sym in [period, lbrack] then begin
addressvar(ref); ref:= 0;
while sym in [period, lbrack] do
case sym of
period : begin if ttab[t].kind<>records then error(108);
getsym; check(ident);
j:= ttab[t].fields; itab[0].name:= id;
while itab[j].name<>id do j:= itab[j].link;
if j=0 then error(109);
gen1(addc, itab[j].offset);
t:= itab[j].tip; getsym
end;
lbrack : begin repeat if ttab[t].kind<>arrays then error(110);
getsym; expression(x); mustbe(intip, x);
gen1(addc, -ttab[t].low);
t:= ttab[t].elemtip;
gen1(mulc, ttab[t].size); gen0(add)
until sym<>comma;
skip(rbrack)
end end end end;
procedure varpar(var t: integer);
var j: integer;
begin check(ident); j:= position; selector(t, j);
if j<>0 then addressvar(j)
end;
procedure standfct(n: integer);
var x, l: integer;
begin case n of
fabs: begin skip(lparen); expression(x); mustbe(intip, x);
gen0(dupl); gen1(ldc, 0); gen0(lssi);
l:= codelabel; gen1(jumpz, 0); gen0(neg);
code[l].a:= codelabel;
skip(rparen)
end;
fsqr: begin skip(lparen); expression(x); mustbe(intip, x);
gen0(dupl); gen0(mul); skip(rparen)
end;
fodd: begin skip(lparen); expression(x); mustbe(intip, x);
gen0(rem2); skip(rparen)
end;
fchr: begin skip(lparen); expression(x); mustbe(intip, x);
skip(rparen)
end;
ford: begin skip(lparen); expression(x); mustbe(chartip, x);
skip(rparen)
end;
fwrite, fwriteln:
begin if n=fwrite then check(lparen);
if sym=lparen then begin
repeat getsym;
if sym=sstring then begin
for x:= 1 to slen do begin
gen1(ldc, ord(str[x]));
gen0(wrc)
end;
getsym
end else begin
expression(x);
if sym=colon then begin
mustbe(intip, x); getsym;
expression(x); mustbe(intip,x);
gen0(wri)
end else if x=intip then begin
gen1(ldc, 8); gen0(wri)
end else if x=chartip then
gen0(wrc)
else
error(111)
end
until sym<>comma;
skip(rparen)
end;
if n=fwriteln then gen0(wrl)
end;
fread, freadln:
begin if n=fread then check(lparen);
if sym=lparen then begin
repeat getsym; varpar(x);
if x=intip then gen0(rdi) else
if x=chartip then gen0(rdc)
else error(112)
until sym<>comma;
skip(rparen)
end;
if n=freadln then gen0(rdl)
end;
feoln: gen0(eol)
end end;
procedure funcall(i: integer);
var d, p, x: integer;
begin getsym;
with itab[i] do
if flevel<0 then
standfct(fadr)
else begin
if tip<>0 then gen1(ldc, 0); p:= i; d:= dx;
if sym=lparen then begin
repeat getsym;
if p=lastpar then error(113); p:= p+1;
if itab[p].refpar then
varpar(x)
else begin
expression(x);
if ttab[x].kind<>simple then gen1(copy, ttab[x].size)
end;
mustbe(itab[p].tip, x)
until sym<>comma;
skip(rparen)
end;
if p<>lastpar then error(114);
if flevel<>0 then address(flevel, 0);
gen1(call, fadr); dx:= d
end end;
procedure factor(var t: integer);
var i: integer;
begin if sym=ident then begin
i:= position; t:= itab[i].tip;
case itab[i].kind of
konst: begin getsym; gen1(ldc, itab[i].val) end;
varbl: begin selector(t, i);
if i<>0 then addressvar(i);
if ttab[t].kind=simple then gen0(load)
end;
funkt: if t=0 then error(115) else funcall(i);
tipe : error(116)
end
end else if sym=number then begin
gen1(ldc, num); t:= intip; getsym
end else if (sym=sstring) and (slen=1) then begin
gen1(ldc, ord(str[1])); t:= chartip; getsym
end else if sym=lparen then begin
getsym; expression(t); skip(rparen)
end else if sym=notsym then begin
getsym; factor(t); mustbe(booltip, t); gen0(neg); gen1(addc, 1)
end else
error(117)
end;
procedure term(var x: integer);
var y: integer;
begin factor(x);
while sym in [andsym, star, divsym, modsym] do begin
if sym=andsym then mustbe(booltip, x) else mustbe(intip, x);
case sym of
star : begin getsym; factor(y); gen0(mul) end;
divsym: begin getsym; factor(y); gen0(divd) end;
modsym: begin getsym; factor(y); gen0(remd) end;
andsym: begin getsym; factor(y); gen0(andb) end
end;
mustbe(x, y)
end end;
procedure simplexpression(var x: integer);
var y: integer;
begin if sym=plus then begin
getsym; term(x); mustbe(intip, x)
end else if sym=minus then begin
getsym; term(x); mustbe(intip, x); gen0(neg)
end else
term(x);
while sym in [orsym, plus, minus] do begin
if sym=orsym then mustbe(booltip, x) else mustbe(intip, x);
case sym of
plus : begin getsym; term(y); gen0(add) end;
minus: begin getsym; term(y); gen0(neg); gen0(add) end;
orsym: begin getsym; term(y); gen0(orb) end
end;
mustbe(x, y)
end end;
procedure expression{var x: integer};
var op: symbol; y: integer;
begin simplexpression(x);
if sym in [eql, neq, lss, leq, gtr, geq] then begin
if ttab[x].kind<>simple then error(118);
op:= sym; getsym; simplexpression(y); mustbe(x, y);
case op of
eql: gen0(eqli);
neq: gen0(neqi);
lss: gen0(lssi);
leq: gen0(leqi);
gtr: gen0(gtri);
geq: gen0(geqi)
end;
x:= booltip
end end;
procedure statement;
var i, j, t, x: integer;
begin if sym=ident then begin
i:= position;
with itab[i] do
case kind of
varbl: begin selector(t, i); skip(becomes);
expression(x); mustbe(t, x);
if i=0 then gen0(swap)
else addressvar(i);
if ttab[t].kind=simple
then gen0(stor)
else gen1(move, ttab[t].size)
end;
funkt: if tip=0 then
funcall(i)
else begin
if not inside then error(119);
getsym; skip(becomes);
expression(x); mustbe(tip, x);
address(flevel+1, resultadr);
gen0(stor)
end;
konst, field, tipe: error(120)
end
end else if sym=ifsym then begin
getsym; expression(t); mustbe(booltip, t); skip(thensym);
i:= codelabel; gen1(jumpz, 0); statement;
if sym=elsesym then begin
getsym; j:= codelabel; gen1(jump, 0);
code[i].a:= codelabel; i:= j; statement
end;
code[i].a:= codelabel
end else if sym=whilesym then begin
getsym; i:= codelabel; expression(t); mustbe(booltip, t);
skip(dosym); j:= codelabel; gen1(jumpz, 0);
statement; gen1(jump, i);
code[j].a:= codelabel
end else if sym=repeatsym then begin
i:= codelabel;
repeat getsym; statement until sym<>semicolon;
skip(untilsym); expression(t); mustbe(booltip, t);
gen1(jumpz, i)
end else if sym=beginsym then begin
repeat getsym; statement until sym<>semicolon;
skip(endsym)
end end;
procedure block(l: integer);
forward;
procedure constant(var c, t: integer);
var i, s: integer;
begin if (sym=sstring) and (slen=1) then begin
c:= ord(str[1]); t:= chartip
end else begin
if sym=plus then begin getsym; s:= +1 end else
if sym=minus then begin getsym; s:= -1 end
else s:= 0;
if sym=ident then begin
i:= position;
if itab[i].kind<>konst then error(121);
c:= itab[i].val; t:= itab[i].tip
end else if sym=number then begin
c:= num; t:= intip
end else
error(122);
if s<>0 then begin mustbe(t, intip); c:= c*s end
end;
getsym
end;
procedure constdeclaration;
var a: alfa; t, c: integer;
begin a:= id; getsym; skip(eql); constant(c, t);
skip(semicolon); enter(a, konst, t); itab[ix].val:= c
end;
procedure typ(var t: integer);
var i, j, sz, ft: integer;
procedure arraytyp(var t: integer);
var x: integer;
begin with ttab[t] do begin
kind:= arrays; getsym; constant(low, x); mustbe(intip, x);
skip(colon); constant(high, x); mustbe(intip, x);
if low>high then error(123);
if sym=comma then
arraytyp(elemtip)
else begin
skip(rbrack); skip(ofsym); typ(elemtip)
end;
size:= (high-low+1)*ttab[elemtip].size
end end;
begin if sym=ident then begin
i:= position; if itab[i].kind<>tipe then error(124);
t:= itab[i].tip; getsym
end else begin
if tx=tmax then error(125); tx:= tx+1; t:= tx;
if sym=arraysym then begin
getsym; check(lbrack); arraytyp(t)
end else begin
skip(recordsym);
if lev=lmax then error(126); lev:= lev+1;
namelist[lev]:= 0; check(ident); sz:= 0;
repeat enter(id, field, 0); i:= ix; getsym;
while sym=comma do begin
getsym; check(ident); enter(id, field, 0);
getsym
end;
j:= ix; skip(colon); typ(ft);
repeat itab[i].tip:= ft; itab[i].offset:= sz;
sz:= sz+ttab[ft].size; i:= i+1
until i>j;
if sym=semicolon then getsym else check(endsym)
until sym<>ident;
ttab[t].size:= sz; ttab[t].kind:= records;
ttab[t].fields:= namelist[lev]; lev:= lev-1;
skip(endsym)
end end end;
procedure typedeclaration;
var a: alfa; t: integer;
begin a:= id; getsym; skip(eql); typ(t); skip(semicolon);
enter(a, tipe, t)
end;
procedure vardeclaration;
var p, q, t: integer;
begin enter(id, varbl, 0); p:= ix; getsym;
while sym=comma do begin
getsym; check(ident); enter(id, varbl, 0); getsym
end;
q:= ix; skip(colon); typ(t); skip(semicolon);
repeat with itab[p] do begin
vlevel:= lev; dx:= dx-ttab[t].size; tip:= t;
vadr:= dx; refpar:= false
end;
p:= p+1
until p>q
end;
procedure funcdeclaration(isf: boolean);
var f, p, ps, odx: integer;
procedure paramlist;
var r: boolean; t: integer;
begin if sym=varsym then begin r:= true; getsym end else r:= false;
check(ident); p:= ix; enter(id, varbl, 0); getsym;
while sym=comma do begin
getsym; check(ident); enter(id, varbl, 0); getsym
end;
skip(colon); check(ident); typ(t);
while p<ix do begin
p:= p+1; itab[p].tip:= t; itab[p].refpar:= r;
if r then ps:= ps+1 else ps:= ps+ttab[t].size
end end;
begin getsym; check(ident); enter(id, funkt, 0); getsym; f:= ix;
itab[f].flevel:= lev; itab[f].fadr:= codelabel; gen1(jump, 0);
if lev=lmax then error(127); lev:= lev+1; namelist[lev]:= 0;
ps:= 1; odx:= dx;
if sym=lparen then begin
repeat getsym; paramlist until sym<>semicolon;
skip(rparen)
end;
if lev>1 then dx:= -1
else dx:= 0;
itab[f].resultadr:= ps; p:= f;
while p<ix do begin
p:= p+1;
with itab[p] do begin
if refpar then ps:= ps-1 else ps:= ps-ttab[tip].size;
vlevel:= lev; vadr:= ps
end end;
if isf then begin
skip(colon); check(ident); typ(itab[f].tip);
if ttab[itab[f].tip].kind<>simple then error(128)
end;
skip(semicolon);
itab[f].lastpar:= ix; itab[f].inside:= true;
block(itab[f].fadr);
itab[f].inside:= false;
gen1(exit, itab[f].resultadr-dx);
lev:= lev-1; dx:= odx;
skip(semicolon)
end;
procedure block{l: integer};
var d, odx, oix: integer;
begin odx:= dx; oix:= ix;
if sym=constsym then begin
getsym; check(ident);
repeat constdeclaration until sym<>ident
end;
if sym=typesym then begin
getsym; check(ident);
repeat typedeclaration until sym<>ident
end;
if sym=varsym then begin
getsym; check(ident);
repeat vardeclaration until sym<>ident
end;
while sym in [funcsym, procsym] do funcdeclaration(sym=funcsym);
if l+1=codelabel then cx:= cx-1 else code[l].a:= codelabel;
if lev=0 then
gen1(sets, dx)
else begin
d:= dx-odx; dx:= odx; gen1(adjs, d)
end;
statement;
if lev<>0 then gen1(adjs, odx-dx); ix:= oix
end;
procedure listcode;
var i: integer;
begin for i:= 0 to cx-1 do begin
write(i, ' : ');
case code[i].op of
add : writeln('add');
neg : writeln('neg');
mul : writeln('mul');
divd : writeln('divd');
remd : writeln('remd');
div2 : writeln('div2');
rem2 : writeln('rem2');
eqli : writeln('eqli');
neqi : writeln('neqi');
lssi : writeln('lssi');
leqi : writeln('leqi');
gtri : writeln('gtri');
geqi : writeln('geqi');
dupl : writeln('dupl');
swap : writeln('swap');
andb : writeln('andb');
orb : writeln('orb');
load : writeln('load');
stor : writeln('stor');
hhalt : writeln('hhalt');
wri : writeln('wri');
wrc : writeln('wrc');
wrl : writeln('wrl');
rdi : writeln('rdi');
rdc : writeln('rdc');
rdl : writeln('rdl');
eol : writeln('eol');
ldc : writeln('ldc ', code[i].a);
ldla : writeln('ldla ', code[i].a);
ldl : writeln('ldl ', code[i].a);
ldg : writeln('ldg ', code[i].a);
stl : writeln('stl ', code[i].a);
stg : writeln('stg ', code[i].a);
move : writeln('move ', code[i].a);
copy : writeln('copy ', code[i].a);
addc : writeln('addc ', code[i].a);
mulc : writeln('mulc ', code[i].a);
jump : writeln('jump ', code[i].a);
jumpz: writeln('jumpz ', code[i].a);
call : writeln('call ', code[i].a);
adjs : writeln('adjs ', code[i].a);
sets : writeln('sets ', code[i].a);
exit : writeln('exit ', code[i].a)
end end end;
begin { compile }
word[beginsym ]:= 'begin '; word[endsym ]:= 'end ';
word[ifsym ]:= 'if '; word[thensym ]:= 'then ';
word[elsesym ]:= 'else '; word[whilesym ]:= 'while ';
word[dosym ]:= 'do '; word[casesym ]:= 'case ';
word[repeatsym]:= 'repeat '; word[untilsym ]:= 'until ';
word[forsym ]:= 'for '; word[tosym ]:= 'to ';
word[downtosym]:= 'downto '; word[notsym ]:= 'not ';
word[divsym ]:= 'div '; word[modsym ]:= 'mod ';
word[andsym ]:= 'and '; word[orsym ]:= 'or ';
word[constsym ]:= 'const '; word[varsym ]:= 'var ';
word[typesym ]:= 'type '; word[arraysym ]:= 'array ';
word[ofsym ]:= 'of '; word[recordsym]:= 'record ';
word[progsym ]:= 'program '; word[funcsym ]:= 'function ';
word[procsym ]:= 'procedure ';
ttab[intip].size:= 1; ttab[intip].kind:= simple;
ttab[chartip].size:= 1; ttab[chartip].kind:= simple;
ttab[booltip].size:= 1; ttab[booltip].kind:= simple;
tx:= 3; namelist[-1]:= 0; lev:= -1; ix:= 0;
enter('false ', konst, booltip); itab[ix].val:= ord(false);
enter('true ', konst, booltip); itab[ix].val:= ord(true);
enter('maxint ', konst, intip); itab[ix].val:= 32767;
enter('integer ', tipe, intip);
enter('char ', tipe, chartip);
enter('boolean ', tipe, booltip);
enter('abs ', funkt, intip);
itab[ix].flevel:= -1; itab[ix].fadr:= fabs; itab[ix].inside:= false;
enter('sqr ', funkt, intip);
itab[ix].flevel:= -1; itab[ix].fadr:= fsqr; itab[ix].inside:= false;
enter('odd ', funkt, booltip);
itab[ix].flevel:= -1; itab[ix].fadr:= fodd; itab[ix].inside:= false;
enter('chr ', funkt, chartip);
itab[ix].flevel:= -1; itab[ix].fadr:= fchr; itab[ix].inside:= false;
enter('ord ', funkt, intip);
itab[ix].flevel:= -1; itab[ix].fadr:= ford; itab[ix].inside:= false;
enter('write ', funkt, 0);
itab[ix].flevel:= -1; itab[ix].fadr:= fwrite;
enter('writeln ', funkt, 0);
itab[ix].flevel:= -1; itab[ix].fadr:= fwriteln;
enter('read ', funkt, 0);
itab[ix].flevel:= -1; itab[ix].fadr:= fread;
enter('readln ', funkt, 0);
itab[ix].flevel:= -1; itab[ix].fadr:= freadln;
enter('eoln ', funkt, booltip);
itab[ix].flevel:= -1; itab[ix].fadr:= feoln; itab[ix].inside:= false;
namelist[0]:= 0; lev:= 0; cc:= 0; ll:= 0; getch; getsym;
labeled:= true; cx:= 0; dx:= amax+1;
skip(progsym); skip(ident); check(lparen);
repeat getsym; check(ident);
if (id<>'input ') and (id<>'output ') then error(129);
getsym
until sym<>comma;
skip(rparen); skip(semicolon); gen1(jump, 0); block(0); gen0(hhalt);
check(period);
listcode
end;
procedure interpret;
var pc, sp, j, k, n: integer; i: instr; c: char; h: boolean;
begin pc:= 0; h:= false;
repeat i:= code[pc]; pc:= pc+1;
case i.op of
add : begin m[sp+1]:= m[sp+1]+m[sp]; sp:= sp+1 end;
neg : m[sp]:= -m[sp];
mul : begin m[sp+1]:= m[sp+1]*m[sp]; sp:= sp+1 end;
divd : begin m[sp+1]:= m[sp+1] div m[sp]; sp:= sp+1 end;
remd : begin m[sp+1]:= m[sp+1] mod m[sp]; sp:= sp+1 end;
div2 : m[sp]:= m[sp] div 2;
rem2 : m[sp]:= m[sp] mod 2;
eqli : begin m[sp+1]:= ord(m[sp+1]=m[sp]); sp:= sp+1 end;
neqi : begin m[sp+1]:= ord(m[sp+1]<>m[sp]); sp:= sp+1 end;
lssi : begin m[sp+1]:= ord(m[sp+1]<m[sp]); sp:= sp+1 end;
leqi : begin m[sp+1]:= ord(m[sp+1]<=m[sp]); sp:= sp+1 end;
gtri : begin m[sp+1]:= ord(m[sp+1]>m[sp]); sp:= sp+1 end;
geqi : begin m[sp+1]:= ord(m[sp+1]>=m[sp]); sp:= sp+1 end;
dupl : begin sp:= sp-1; m[sp]:= m[sp+1] end;
swap : begin k:= m[sp]; m[sp]:= m[sp+1]; m[sp+1]:= k end;
andb : begin if m[sp]=0 then m[sp+1]:= 0; sp:= sp+1 end;
orb : begin if m[sp]=1 then m[sp+1]:= 1; sp:= sp+1 end;
load : m[sp]:= m[m[sp]];
stor : begin m[m[sp]]:= m[sp+1]; sp:= sp+2 end;
hhalt: h:= true;
wri : begin write(output, m[sp+1]: m[sp]); sp:= sp+2 end;
wrc : begin write(output, chr(m[sp])); sp:= sp+1 end;
wrl : writeln(output);
rdi : begin read(input, m[m[sp]]); sp:= sp+1 end;
rdc : begin read(input, c); m[m[sp]]:= ord(c); sp:= sp+1 end;
rdl : readln(input);
eol : begin sp:= sp-1; m[sp]:= ord(eoln(input)) end;
ldc : begin sp:= sp-1; m[sp]:= i.a end;
ldla : begin sp:= sp-1; m[sp]:= sp+1+i.a end;
ldl : begin sp:= sp-1; m[sp]:= m[sp+1+i.a] end;
ldg : begin sp:= sp-1; m[sp]:= m[i.a] end;
stl : begin m[sp+i.a]:= m[sp]; sp:= sp+1 end;
stg : begin m[i.a]:= m[sp]; sp:= sp+1 end;
move : begin k:= m[sp]; j:= m[sp+1]; sp:= sp+2; n:= i.a;
repeat n:= n-1; m[k+n]:= m[j+n] until n=0
end;
copy : begin j:= m[sp]; n:= i.a; sp:= sp-n+1;
repeat n:= n-1; m[sp+n]:= m[j+n] until n=0
end;
addc : m[sp]:= m[sp]+i.a;
mulc : m[sp]:= m[sp]*i.a;
jump : pc:= i.a;
jumpz: begin if m[sp]=0 then pc:= i.a; sp:= sp+1 end;
call : begin sp:= sp-1; m[sp]:= pc; pc:= i.a end;
adjs : sp:= sp+i.a;
sets : sp:= i.a;
exit : begin pc:= m[sp]; sp:= sp+i.a end;
end
until h
end;
begin
assign(infile, 'test.pas');
reset(infile);
compile;
interpret;
end.
-- Dr Adrian Johnstone, Senior Lecturer in Computing, Computer Science Dep,
Royal Holloway, University of London, Egham, Surrey, TW20 0EX, England.
Email a.joh...@rhbnc.ac.uk Tel:+44(0)1784 443425 Fax:+44(0)1784 439786
Peter Zechmeister
all about data structures needed for such, check out the book:
"Algorithms + Data Structures = Programs" by Nicklaus Wirth (Prentice-Hall)
It teaches the concepts of language parsing, ending in a simple
compiler/interpreter.
I've used this as a jumping off point for a "Tiny Pascal" compiler for
an 8080 micro (many years ago of course!). Source avaliable on request
(written in PASCAL 6000).
Peter Zechmeister - zech...@gold.tc.umn.edu - A University of
Minnesota Alumnus
Juergen Kahrs
> [A whole Pascal compiler in one mail message? Who could resist! -John]
The P4 compiler (full Pascal, not a subset) is also available online:
http://www.cwi.nl/~steven/pascal.html
| Pascal Implementation: A Book and Sources
|
| Included here is the Pascal source of a public-domain Pascal
| compiler and interpreter, the P4 compiler and interpreter.
| It is coded entirely in Pascal, and produces a high-level
| so-called intermediate code as output. The program 'pint'
| is an assembler and interpreter for this language.
|
| The entire compiler and interpreter is documented in the book:
|
| Pascal Implementation: The P4 Compiler and Interpreter,
| by Steven Pemberton and Martin Daniels, Ellis Horwood,
| ISBN: 0-13-653-0311 (also available in Japanese).
|
| It was distributed by John Wiley in other countries,
| but now that Prentice Hall has taken over Ellis Horwood,
| that will have changed.
|
| Steven Pemberton is contactable by email as Steven.P...@cwi.nl.
| He did not write the compiler, only documented it in the book.
One or two years ago, he wrote in an email that he had started
scanning the whole book to make it available online, but this has
never happened. When I asked him again, he did not answer.
Several other implementations are available here:
http://www.threedee.com/jcm/psystem/index.html
Did you know that Wirth designed and implemented some languages
before Pascal ? "Euler" is one of them, but this link seems to
be broken:
http://www.toc-press.com/freesoftware.htm
Perhaps you remember Algol:
http://www.angelfire.com/biz/rhaminisys/algol60.html
--
Juergen Kahrs Tel. 0421 249 666
Millstaetter Strasse 15 Tel. 0421 457 2819
D 28359 Bremen Fax 0421 457 3578
____________ http://home.t-online.de/home/Juergen.Kahrs/ _______________