This file comprises the LEX, YACC and Pascal source of the table-driven P
compiler/interpreter and a makefile separated by asterisks.
Copyright (c) P.C.Capon & P.J.Jinks 1988
May be copied for educational purposes only, with the copyright notice
attached.
Note: The standard version of YACC distributed with UNIX will not generate any
error recovery code. Instead, the P compiler will generate an error message
and halt at the first error. If you require proper error recovery, you are
recommended to use the version of YACC written at Warwick University by Julia
Dain which supports error recovery (or some similar variant of YACC).
Try:
Julia A. Dain
Dept. of Computer Science
University of Warwick
Coventry CV4 7AL
U.K.
*******************************************************************************
PFLAGS= -L -C -g
YFLAGS= -d -v
CFLAGS = -g
tablel.o: tabley.y tablel.l
make y.tab.h
lex tablel.l
cc -g -c lex.yy.c
rm lex.yy.c
mv lex.yy.o tablel.o
tablep.o: tablep.p
pc $(PFLAGS) -c tablep.p
y.tab.h tabley.o: tabley.y
yacc -v -d tabley.y
cc -c y.tab.c
rm y.tab.c
mv y.tab.o tabley.o
tablep: tablep.p tablel.l tabley.y
make tablep.o tabley.o tablel.o
pc -o tablep tablel.o tabley.o tablep.o
*******************************************************************************
%{
/* Copyright (c) P.C.Capon & P.J.Jinks 1988 */
/* May be copied for educational purposes only, with the copyright notice */
/* attached. */
typedef union
{ int constval;
char idval;
char addval;
char mulval;
char relval;
} lexemevaltype;
#include "y.tab.h"
#define add 0
#define sub 1
#define mul 0
#define divd 1
#define eq 0
#define ne 1
#define gt 2
#define lt 3
#define ge 4
#define le 5
%}
alphanumeric [A-Za-z0-9]
%START DONE
%%
<DONE>(.|\n) { return (0); }
[ \t\n] { ; }
"{"[^}]*"}" { ; }
"VAR" { return (varlexeme); }
"BEGIN" { return (beginlexeme); }
"END" { return (endlexeme); }
"WRITE" { return (writelexeme); }
"IF" { return (iflexeme); }
"WHILE" { return (whilelexeme); }
"THEN" { return (thenlexeme); }
"DO" { return (dolexeme); }
"READ" { return (readlexeme); }
[A-Z] { yylval.lexemeval.idval = yytext[0]; return (identifier); }
[A-Z]{alphanumeric}+|[a-z]{alphanumeric}* {
ylerror ("illegal identifier");
yylval.lexemeval.idval = ' '; return (identifier); }
[0-9] { yylval.lexemeval.constval = yytext[0]-'0'; return (constant); }
[0-9][0-9]+ { ylerror ("illegal constant");
yylval.lexemeval.constval = 0; return (constant); }
";" { return (semicolon); }
"." { BEGIN DONE; return (dot); }
"," { return (comma); }
":=" { return (assign); }
"(" { return (lbracket); }
")" { return (rbracket); }
"+" { yylval.lexemeval.addval = add; return (addop); }
"-" { yylval.lexemeval.addval = sub; return (addop); }
"*" { yylval.lexemeval.mulval = mul; return (mulop); }
"/" { yylval.lexemeval.mulval = divd; return (mulop); }
"<" { yylval.lexemeval.relval = lt; return (relop); }
"<=" { yylval.lexemeval.relval = le; return (relop); }
"<>" { yylval.lexemeval.relval = ne; return (relop); }
">" { yylval.lexemeval.relval = gt; return (relop); }
">=" { yylval.lexemeval.relval = ge; return (relop); }
"=" { yylval.lexemeval.relval = eq; return (relop); }
. { ylerror ("unknown character"); return (unknown); }
%%
/* variables */
extern int yyleng, yylineno;
extern char yytext[];
extern char /* boolean */ errors;
extern YYSTYPE yyval;
/* procedure */ yyerror (s)
char *s;
{
printf("line %d: %s\n", yylineno, s);
/* %d means print the next parameter as an integer,
%s means print it as a character string,
\n means newline */
errors = 1; /* true */
}
/* procedure */ ylerror (s)
char *s;
{
printf("line %d: %s '%s'\n", yylineno, s, yytext);
errors = 1; /* true */
}
/* function */ YYSTYPE* yyerrlval ()
{
static YYSTYPE dummy;
dummy.lexemeval.constval= 1;
errors = 1; /* true */
return &dummy;
}
/* function */ struct nodetype* callparse (ok)
int *ok;
{
*ok = yyparse();
return yyval.tree;
}
/* function */ int makelexeme (lex)
int lex;
{
return lex - 257; /* converts yacc type to pascal type */
}
******************************************************************************
%{
/* Copyright (c) P.C.Capon & P.J.Jinks 1988 */
/* May be copied for educational purposes only, with the copyright notice */
/* attached. */
#define NULL 0
#define prognode 0
#define blocknode 1
#define assignnode 2
#define writenode 3
#define ifnode 4
#define whilenode 5
#define expnode 6
#define lexemenode 7
#define nullexemeval 0
typedef struct nodetype
{ struct nodetype *next; int serial;
char nodecase;
union
{ struct {struct nodetype *pidlist} prognodetype;
struct {struct nodetype *contents, *lastb} blocknodetype;
struct {struct nodetype *pexp, *petc, *lasts} statementnodestype;
struct {struct nodetype *lexp, *operator, *rexp} expnodetype;
struct {char lexeme; int lexemeval} lexemenodetype;
} nodevariants;
} nodetype;
typedef union
{ int constval;
char idval;
char addval;
char mulval;
char relval;
} lexemevaltype;
/* function */ extern nodetype* makelexemenode ();
/* function */ extern nodetype* makenode ();
/* function */ extern int makelexeme ();
/* procedure */ extern dumptree ();
/* function */ extern nodetype* startlist ();
/* function */ extern nodetype* makelist ();
%}
%start program
%union {
lexemevaltype lexemeval;
struct nodetype *tree;
}
%token <lexemeval> dot constant identifier comma assign semicolon
%token <lexemeval> lbracket rbracket addop mulop relop beginlexeme
%token <lexemeval> readlexeme writelexeme iflexeme thenlexeme whilelexeme
%token <lexemeval> dolexeme varlexeme endlexeme unknown
%type <tree> program phead idlist ids block blocks statement comparison
%type <tree> expression term factor
%%
program : phead block dot
{$$ = makenode ($2, prognode, $1, NULL, NULL);}
;
phead : varlexeme idlist
{$$ = $2;}
|{$$ = NULL;}
;
idlist : ids semicolon
{$$ = $1;}
;
ids : identifier
{$$ = makelexemenode(NULL, makelexeme(identifier), $1);}
| ids comma identifier
{$$ = makelexemenode($1, makelexeme(identifier), $3);
/* list backward, see blocks */}
;
block : statement
{$$ = $1;}
| beginlexeme blocks endlexeme
{$$ = makenode (NULL, blocknode, $2, NULL, NULL);}
;
blocks : block
{$$ = startlist ($1);}
| blocks semicolon block
{$$ = makelist ($1, $3);}
;
statement : identifier assign expression
{$$ = makenode(NULL, assignnode, $3,
makelexemenode(NULL,makelexeme(identifier),$1), NULL);}
| writelexeme lbracket expression rbracket
{$$ = makenode (NULL, writenode, $3, NULL, NULL);}
| iflexeme comparison thenlexeme block
{$$ = makenode (NULL, ifnode, $2, $4, NULL);}
| whilelexeme comparison dolexeme block
{$$ = makenode (NULL, whilenode, $2, $4, NULL);}
|{$$ = NULL;}
;
comparison : expression relop expression
{$$ = makenode(NULL, expnode, $1,
makelexemenode(NULL,makelexeme(relop),$2), $3);}
;
expression : term
{$$ = $1;}
| expression addop term
{$$ = makenode(NULL, expnode, $1,
makelexemenode(NULL,makelexeme(addop),$2), $3);}
;
term : factor
{$$ = $1;}
| term mulop factor
{$$ = makenode(NULL, expnode, $1,
makelexemenode(NULL,makelexeme(mulop),$2), $3);}
;
factor : identifier
{$$ = makelexemenode(NULL,makelexeme(identifier),$1);}
| constant
{$$ = makelexemenode(NULL,makelexeme(constant),$1);}
| readlexeme
{$$ = makelexemenode(NULL,makelexeme(readlexeme), nullexemeval);}
| lbracket expression rbracket
{$$ = $2;}
;
%%
extern YYSTYPE *yyerrlval();
******************************************************************************
program pcompiler (input, output);
{Copyright (c) P.C.Capon & P.J.Jinks 1988}
{may be copied for educational purposes only,}
{with the copyright notice attached.}
label 999;
const
trace = false;
{ consts from recursive descent compiler ----------------------------------- }
namechars = 6;
nulop = 0;
readproc = 1; writeproc = 2; {call operands}
stack = 1; unstack = 2; nooperand = 3; {special operands}
maxcode = 500;
maxstack = 100;
maxvar = 26;
type
{ types from recursive descent compiler ------------------------------------ }
lexemetype = (dot, constant, identifier, comma, assign,
semicolon, lbracket, rbracket, addop, mulop, relop,
beginlexeme, readlexeme, writelexeme, iflexeme,
thenlexeme, whilelexeme, dolexeme, varlexeme,
endlexeme, unknown);
nametype = packed array [1..namechars] of char;
addvaltype = (add, sub);
mulvaltype = (mul, divd);
relvaltype = (eq, ne, gt, lt, ge, le);
lexemevaltype = record
case lexemetype of
constant: (constval: integer);
identifier: (idval: char);
addop: (addval: addvaltype);
mulop: (mulval: mulvaltype);
relop: (relval: relvaltype);
end;
functiontype = (accload, accstore, stackaccload, accplus,
accminus, minusacc, acctimes, accdiv, divacc,
stop, call, acccompare, br,
breq, brne, brlt, brle, brge, brgt);
optypetype = (specialop, constop, varop, labelop);
calltype = readproc..writeproc;
mode = specialop .. varop;
data = integer;
address = 0..maxcode;
inst = record
case funct: functiontype of
accload, accstore, stackaccload, accplus, accminus, minusacc,
acctimes, accdiv, divacc, acccompare:
(accmode: mode; accval: data);
br, breq, brne, brlt, brle, brge, brgt:
(brval: address);
call: (callval: calltype);
stop: ();
end;
{ -------------------------------------------------------------------------- }
nodecasetype = (prognode, blocknode, assignnode, writenode, ifnode,
whilenode, expnode, lexemenode);
pnode = ^nodetype;
nodetype = record
next: pnode;
serial: integer;
case nodecase: nodecasetype of
prognode : (pidlist: pnode); {block in next}
blocknode : (contents, lastb: pnode); {last used only to build tree}
assignnode,
writenode,
ifnode,
whilenode : (pexp, petc, lasts: pnode);
{assign: etc=var, if/while: etc=block, write: etc=unused}
expnode : (lexp, operator, rexp: pnode);
{ for expression and comparison - doesn't use next }
lexemenode: (lexeme: lexemetype; lexemeval: lexemevaltype);
{ for operator, constant, identifier, read
- doesn't use next except for identifiers in idlist }
end;
var
nextserial, ok: integer;
tree: pnode;
{ vars from recursive descent compiler-------------------------------------- }
errors: boolean;
lexeme: lexemetype;
lexemeval: lexemevaltype;
lexemes: array [lexemetype] of nametype;
variables: array['A'..'Z'] of -1..maxint;
{-1=undefined, 0=not used, >0=address}
nextvariable: 1..maxint; {address of next variable declared}
accinuse: boolean;
codepos: 0..maxint; {position to plant next piece of code}
forwardadd, reverseadd: array [addvaltype] of functiontype;
forwardmul, reversemul: array [mulvaltype] of functiontype;
normalskip, reverseskip: array [relvaltype] of functiontype;
fnnames: array [functiontype] of nametype;
store: array [address] of inst;
branchset: set of br..brgt;
machinestack: array [0..maxstack] of data;
pc: -1..maxcode;
acc: data;
sf: -1..maxstack;
stoprun: boolean;
vars: array [1..maxvar] of
record
defined: boolean;
varval: data;
end;
{ interface to lex & yacc -------------------------------------------------- }
function yywrap: integer;
begin
yywrap := 1;
end;
function callparse (var ok: integer): pnode; external c;
function makelexemenode (pnext: pnode; plexeme: lexemetype;
plexemeval: lexemevaltype): pnode;
var
tnode: pnode;
begin
new (tnode);
with tnode^ do begin
serial := nextserial;
nextserial := nextserial + 1;
nodecase := lexemenode;
lexeme := plexeme;
lexemeval := plexemeval;
next := pnext;
end;
makelexemenode := tnode;
end;
procedure dumptree (tree: pnode; level: integer); forward;
function makenode (pnext: pnode; pnodecase: nodecasetype;
lnode, cnode, rnode: pnode): pnode;
var
tnode: pnode;
begin
new (tnode);
with tnode^ do begin
serial := nextserial;
nextserial := nextserial + 1;
nodecase := pnodecase;
next := pnext;
case pnodecase of
prognode :pidlist := lnode;
blocknode :begin contents := lnode; lastb := nil; end;
assignnode,
writenode,
ifnode,
whilenode :begin pexp := lnode; petc := cnode; lasts := nil; end;
expnode :begin lexp := lnode; operator := cnode; rexp := rnode; end;
end;
end;
makenode := tnode;
end;
function startlist (head: pnode): pnode;
begin
if trace then
writeln ('startlist');
startlist := head;
if head <> nil then
if head^.nodecase = blocknode then
head^.lastb := head
else
head^.lasts := head;
if trace then begin
dumptree (head, 1);
writeln;
end;
end;
function makelist (head, item: pnode): pnode;
begin
if trace then
writeln ('makelist');
if head = nil then
makelist := startlist (item)
else if item = nil then
makelist := head
else begin
makelist := head;
if head^.nodecase = blocknode then begin
head^.lastb^.next := item;
head^.lastb := item;
end else begin
head^.lasts^.next := item;
head^.lasts := item;
end;
end;
if trace then begin
dumptree (head, 1);
dumptree (item, 1);
writeln;
end;
end;
{ -------------------------------------------------------------------------- }
procedure dumptree {tree: pnode; level: integer};
const
spaces = 4;
begin
{writeln(ord(tree));}
while tree <> nil do with tree^ do begin
{ insert ord in next line for standard pascal }
write ('node:', serial:5, {ord (}nodecase{)}:15);
case nodecase of
prognode :
begin
writeln;
write (' ':level+spaces, 'pidlist: ');
dumptree (pidlist, level+spaces);
end;
blocknode :
begin
writeln;
write (' ':level+spaces, 'contents:');
dumptree (contents, level+spaces);
write (' ':level+spaces, 'lastb:');
if lastb <> nil then
writeln (lastb^.serial:5)
else
writeln (' nil');
end;
assignnode,
writenode,
ifnode,
whilenode :
begin
writeln;
write (' ':level+spaces, 'pexp: ');
dumptree (pexp, level+spaces);
write (' ':level+spaces, 'petc: ');
dumptree (petc, level+spaces);
write (' ':level+spaces, 'lasts:');
if lasts <> nil then
writeln (lasts^.serial:5)
else
writeln (' nil');
end;
expnode :
begin
writeln;
write (' ':level+spaces, 'lexp: ');
dumptree (lexp, level+spaces);
write (' ':level+spaces, 'operator:');
dumptree (operator, level+spaces);
write (' ':level+spaces, 'rexp: ');
dumptree (rexp, level+spaces);
end;
lexemenode:
begin
write(lexemes[lexeme]:namechars+1);
if lexeme in [constant, identifier, addop, mulop, relop] then
case lexeme of
constant: writeln (lexemeval.constval:5);
identifier: writeln (lexemeval.idval:5);
{ insert ord's in next 3 lines for standard pascal }
addop: writeln ({ord (}lexemeval.addval{)}:5);
mulop: writeln ({ord (}lexemeval.mulval{)}:5);
relop: writeln ({ord (}lexemeval.relval{)}:5);
end
else
writeln;
end;
end;
write (' ':level, 'next: ');
tree := next;
end;
writeln ('end of list');
end;
{procedures etc from cmb-----------------------------------------------------}
procedure listaline (pos: address);
begin
with store[pos] do begin
write (pos:3,' : ',fnnames[funct],' ');
case funct of
accload,accstore,stackaccload,accplus,accminus,minusacc,acctimes,
accdiv,divacc,acccompare:
case accmode of
varop :write ('variable ', accval:1);
constop :write ('constant ', accval:1);
specialop:
case accval of
stack :write ('stack ');
unstack :write ('unstack ');
nooperand:;
end;
end;
br, brne, breq, brlt, brle, brge, brgt:
write (brval :1);
call:
if callval = readproc then
write ('read')
else if callval = writeproc then
write ('write')
else
write (callval :3);
stop:;
end;
end;
writeln;
end;
procedure listing;
var i: address;
begin
writeln ;
writeln ('assembly listing of compiled code');
writeln ('=================================');
writeln ;
for i := 0 to codepos - 1 do
listaline (i);
writeln;
end;
procedure error (n :integer);
begin
case n of
8 : writeln('variable already declared');
9 : writeln('variable not declared');
10 : writeln('code overflow');
end;
errors := true;
end;
procedure declid (idval: char);
begin
if variables[idval] > 0 then
error(8) {variable already declared}
else begin
variables[idval] := nextvariable;
nextvariable := nextvariable + 1;
end;
end;
procedure checkid (idval: char);
begin
if variables[idval] = 0 then begin
error(9); {variable not declared}
variables[idval] := -1;
{ to stop further error messages }
end;
end;
procedure plant(fn: functiontype; optype: optypetype; opval: integer);
begin
if codepos >= maxcode then begin
error (10);
codepos := 0; {not very satisfactory, but adequate}
end;
with store [codepos] do begin
funct := fn;
case optype of
specialop:
begin
accmode := specialop;
accval := opval;
end;
labelop:
if fn = call then
callval := opval
else
brval := opval;
constop:
begin
accval := opval;
accmode := constop;
end;
varop:
begin
accval := opval;
accmode := varop;
end;
end;
write ('plant ');
listaline (codepos);
codepos := codepos + 1;
end;
end;
procedure plantforwardlabel(pos: integer);
begin
writeln('label: used from ', pos);
store[pos].brval := codepos;
end;
function saveforwardlabel: integer;
begin
writeln('label used');
saveforwardlabel := codepos;
end;
function savelabel: integer;
begin
writeln('label:');
savelabel := codepos;
end;
procedure plantaccload (optype: optypetype; opval: integer);
begin
if optype <> specialop then
if accinuse then
plant (stackaccload, optype, opval)
else
plant (accload, optype, opval);
accinuse := true;
end;
procedure runerror (message : packed array [lo..hi: integer] of char);
var i : integer;
begin
writeln;
write ('*** runtime error - ');
for i := lo to hi do
write (message [i]);
writeln (' at address ',pc:1,' ***');
writeln;
for i := 1 to maxvar do
if vars[i].defined then
writeln ('variable ',i:2,' = ',vars[i].varval:1);
writeln;
writeln ('accumulator = ',acc:1);
writeln;
writeln ('stack front = ', sf);
for i := 0 to sf do
writeln ('stack item ', i, ' =', machinestack [i]);
goto 999;
end;
procedure push (d : data);
begin
if sf = maxstack then
runerror ('stack overflow');
sf := sf + 1;
machinestack [sf] := d;
end;
function pop : data;
begin
if sf = -1 then
runerror ('stack underflow');
pop := machinestack [sf];
sf := sf - 1;
end;
function getop : data;
begin
with store [pc] do
case accmode of
specialop:
if accval = unstack then
getop := pop
else
runerror ('illegal operand');
constop: getop := accval;
varop:
if vars[accval].defined then
getop := vars[accval].varval
else
runerror ('undefined variable');
end; { case }
end;
procedure interpret; { a single instruction }
var operand : data;
begin
pc := pc + 1;
with store[pc] do begin
case funct of
accload:
acc := getop;
stackaccload:
begin
push (acc);
acc := getop;
end;
accplus:
acc := acc + getop;
accminus:
acc := acc - getop;
minusacc:
acc := getop - acc;
acctimes:
acc := acc * getop;
accdiv:
begin
operand := getop;
if operand = 0 then
runerror ('division by zero');
acc := acc div operand;
end;
divacc:
begin
if acc = 0 then
runerror ('division by zero');
acc := getop div acc;
end;
accstore:
with store[pc] do
case accmode of
constop:
runerror('illegal operand');
varop:
with vars [accval] do begin
defined := true;
varval := acc;
end;
specialop:
if accval = stack then
push (acc)
else
runerror ('illegal operand');
end;
acccompare:
begin
operand := getop;
if acc = operand then
branchset := [br, breq]
else
branchset := [br, brne];
if acc < operand then
branchset := branchset + [brlt]
else
branchset := branchset + [brge];
if acc <= operand then
branchset := branchset + [brle]
else
branchset := branchset + [brgt];
end;
br, brne, breq, brle, brlt, brgt, brge:
if funct in branchset then
pc := brval - 1;
call:
if callval = readproc then
read (acc)
else if callval = writeproc then
writeln (pop:1)
else
runerror ('illegal call operand');
stop:
stoprun := true;
end; { case }
end; { with }
end; { interpret }
{ -------------------------------------------------------------------------- }
procedure init;
var
i: 0..maxvar;
ch : char;
begin
lexemes[unknown] := '? ';
lexemes[constant] := 'digit ';
lexemes[identifier] := 'name ';
lexemes[comma] := ', ';
lexemes[dot] := '. ';
lexemes[assign] := ':= ';
lexemes[semicolon] := '; ';
lexemes[lbracket] := '( ';
lexemes[rbracket] := ') ';
lexemes[addop] := '+or- ';
lexemes[mulop] := '*or/ ';
lexemes[relop] := '<=> ';
lexemes[beginlexeme] := 'BEGIN ';
lexemes[readlexeme] := 'READ ';
lexemes[writelexeme] := 'WRITE ';
lexemes[iflexeme] := 'IF ';
lexemes[thenlexeme] := 'THEN ';
lexemes[whilelexeme] := 'WHILE ';
lexemes[dolexeme] := 'DO ';
lexemes[varlexeme] := 'VAR ';
lexemes[endlexeme] := 'END ';
errors := false;
nextvariable := 1;
for ch := 'A' to 'Z' do
variables[ch] := 0;
codepos := 0;
forwardadd[add] := accplus;
forwardadd[sub] := accminus;
reverseadd[add] := accplus;
reverseadd[sub] := minusacc;
forwardmul[mul] := acctimes;
forwardmul[divd] := accdiv;
reversemul[mul] := acctimes;
reversemul[divd] := divacc;
normalskip[eq] := brne;
normalskip[ne] := breq;
normalskip[gt] := brle;
normalskip[lt] := brge;
normalskip[ge] := brlt;
normalskip[le] := brgt;
reverseskip[eq] := brne;
reverseskip[ne] := breq;
reverseskip[gt] := brge;
reverseskip[lt] := brle;
reverseskip[ge] := brgt;
reverseskip[le] := brlt;
fnnames[accload] := 'acc= ';
fnnames[accstore] := 'acc=> ';
fnnames[stackaccload] := '<acc= ';
fnnames[accplus] := 'acc+ ';
fnnames[accminus] := 'acc- ';
fnnames[minusacc] := '-acc ';
fnnames[acctimes] := 'acc* ';
fnnames[accdiv] := 'acc/ ';
fnnames[divacc] := '/acc ';
fnnames[call] := 'call ';
fnnames[acccompare] := 'accom ';
fnnames[br] := 'br ';
fnnames[breq] := 'breq ';
fnnames[brne] := 'brne ';
fnnames[brlt] := 'brlt ';
fnnames[brle] := 'brle ';
fnnames[brge] := 'brge ';
fnnames[brgt] := 'brgt ';
fnnames[stop] := 'stop ';
pc := -1;
acc := 0;
sf := -1;
branchset := [br];
for i := 1 to maxvar do
vars [i].defined := false;
stoprun := false;
end;
procedure reverseactionunstack (action: pnode; var iflabel: integer);
begin
with action^ do
case lexeme of
identifier, constant, readlexeme:
writeln ('operator expected in reverseactionunstack');
mulop:
plant(reversemul[lexemeval.mulval], specialop, unstack);
addop:
plant(reverseadd[lexemeval.addval], specialop, unstack);
relop:
begin
plant(acccompare, specialop, unstack);
iflabel := saveforwardlabel;
plant(reverseskip[lexemeval.relval], labelop, nulop);
end
end;
end;
procedure forwardaction (action: pnode; optype: optypetype;
opval: integer; var iflabel: integer);
begin
case action^.lexeme of
identifier, constant, readlexeme:
writeln ('operator expected in forwardaction');
mulop:
plant(forwardmul[action^.lexemeval.mulval], optype, opval);
addop:
plant(forwardadd[action^.lexemeval.addval], optype, opval);
relop:
begin
plant(acccompare, optype, opval);
iflabel := saveforwardlabel;
plant(normalskip[action^.lexemeval.relval], labelop, nulop);
end;
end;
end;
procedure plantexpression (tree, action: pnode; var iflabel: integer);
{ action = nil means acc := tree, <> nil means acc := acc 'action' tree }
var
optype: optypetype;
opval: integer;
begin
if tree <> nil then with tree^ do
case nodecase of
prognode, blocknode, assignnode, writenode, ifnode, whilenode:
writeln ('non-expression node in plantexpression');
expnode:
begin
{ stack acc if loaded, load acc with tree }
plantexpression (lexp, nil, iflabel);
plantexpression (rexp, operator, iflabel);
if action <> nil then { perform action }
reverseactionunstack (action, iflabel);
end;
lexemenode:
begin
case lexeme of
mulop, addop, relop:
writeln ('operand expected in plantexpression');
identifier:
begin
checkid (lexemeval.idval);
optype := varop;
opval := variables[lexemeval.idval]
end;
constant:
begin
optype := constop;
opval := lexemeval.constval;
end;
readlexeme:
begin
if accinuse then
plant(accstore, specialop, stack);
plant(call, labelop, readproc);
optype := specialop;
opval := unstack;
end;
end;
if action = nil then begin { load acc with operand }
if optype <> specialop then { i.e. not already 'read' }
plantaccload (optype, opval);
end
else { perform action }
if optype = specialop then { i.e. just stacked & read into acc }
reverseactionunstack (action, iflabel)
else
forwardaction (action, optype, opval, iflabel);
accinuse := true;
end;
end;
end;
procedure planttree (tree: pnode);
var
dummy, iflabel, whilelabel: integer;
idlist: pnode;
begin
while tree <> nil do with tree^ do begin
case nodecase of
prognode:
begin
idlist := pidlist;
while idlist <> nil do with idlist^ do begin
if nodecase <> lexemenode then
writeln ('lexeme expected in idlist')
else if lexeme <> identifier then
writeln ('identifier expected in idlist')
else
declid (lexemeval.idval);
idlist := next;
end;
end;
blocknode:
planttree (contents);
assignnode:
begin
accinuse := false;
plantexpression (pexp, nil, dummy);
checkid (petc^.lexemeval.idval);
plant (accstore, varop, variables[petc^.lexemeval.idval]);
end;
writenode:
begin
accinuse := false;
plantexpression (pexp, nil, dummy);
plant (accstore, specialop, stack);
plant (call, labelop, writeproc);
end;
ifnode:
begin
accinuse := false;
plantexpression (pexp, nil, iflabel);
planttree (petc);
plantforwardlabel (iflabel);
end;
whilenode:
begin
whilelabel := savelabel;
accinuse := false;
plantexpression (pexp, nil, iflabel);
planttree (petc);
plant (br, labelop, whilelabel);
plantforwardlabel (iflabel);
end;
expnode, lexemenode:
writeln ('expressions and lexemes not expected in planttree');
end;
tree := next;
end;
end;
begin { main body }
init;
nextserial := 1;
tree := callparse (ok);
errors := errors or (ok <> 0);
if errors then
writeln ('errors in syntactic analysis')
else begin
write (' tree: ');
dumptree (tree, 1);
writeln;
planttree (tree);
plant (stop, specialop, nooperand);
writeln;
if not errors then begin
listing;
repeat
interpret;
until stoprun;
end;
end;
999:
writeln;
end.