program UDC( input, output);
const
    maxchrln = 256; (max chars in line)
    maxsymln = 256; [max symbols in a line)
    maxstkht = 256; [max exp stack height)
    maxref = 99; [max vec ref)
type
    chrbuffer = array [1..maxchrln] of char; [char buffer)
    lextype = (VEC, [vec var token)
        LPAREN, [left bracket token)
        LBR, [left brace token)
        IF, [if token)
        RPAREN, [right bracket token)
        RBR, [right brace token)
        THEN, [then token)
        ELSE, [else token)
        EOC, [end -of -input token)
        ASSIG, [assignment token)
        QM, [query token)
        MAX, [maximum token)
        MIN, [minimum token)
        TTPO, ['to -the -power -of' token)
        MOD, [modulo token)
        MULT, [multiply token)
        DIV, [division token)
        PLUS, [addition token)
        LT, [less -than token)
        LE, [less -or -equal -to token)
        GT, [greater -than token)
        EQ, [equal -to token)
        GE, [greater -or -equal -to token)
        AND, [logical -and token)
        OR, [logical -or token)
        MINUS, [subtraction token)
        UNMINUS, [unary minus token)
        NOT, [logical -not token)
        VAR, [var token)
        NUM, [num token)
        UNDEF, (undef -value token)
        BUENDSYM, [exp -end dummy token)
        OPBASE, [non -reducible -op token)
        ERR, [unrecognised symbol token)
        IFACTIONS); [then -else clause dummy token)
    lexst = -7..32; [lex analysis table states)
    accst = 0..34; [lex analysis accept states)
    dataptr = ^ datalocation; [parse -tree cell struc def}
    datalocation = 
        record
            ich, rch: dataptr; [cell sub tree ptrs)
            lex: lextype; [token's lex value)
            sem: integer [token's sem value)
        end;
var
    opset: set of lextype; [op set)
    binopset: set of lextype; [binary op set)
    unopset: set of lextype; [unary op set)
    lexsttbl: array [lexst, char] of lexst; [lex state table array)
    lexsymtbl: array [accst] of lextype; [lex symbol table array)
    opranktbl: array [lextype] of integer; [op prec table array)
    tokenb: chrbuffer; [encountered token buffer)
    charb: chrbuffer; [incomplete token buffer)
    cpos: integer; [end of char buffer mkr)
    tpos: integer; [end of token buffer mkr)
    x: char; [next char read)
    cs: lexst; [current lex state)
    tokencode: lexst; [lex code for token in tokenb}
    tokenstoretop: integer; [end of token store mkr}
    ipstore: chrbuffer; [command store)
    tokenstore: array [1..rnaxsymln} of (command store)
        record
            lex: lextype; (lex val field)
            sem: integer (sem val field)
        end;
    tempptr: dataptr; (temp ptr}
vartbl: array [0. .25] of dataptr;
(var table)
[end of command store mkr}
    ipstoretop: integer;
vectbl: array [0. .25, 0. .rnaxref] of dataptr;(vec var table)
(single command line]
scomm: boolean;
(silent mode]
sprom: boolean;
procedure CheckArgs;
(checks for program call arguments to suppress prompting and nice
printing)
begin
if argc > 1 then
sprom
(if arguments present]
(facilitate silent mode]
:= true
else
(facilitate verbose mode]
sprom : false
end; ( CheckArgs )
procedure VarTbilnit;
(sets all variables and vector variables to point to cells defining
undefined values)
var
i: char;
j: integer;
cellptr: dataptr;
begin
for i := 'a' to 'z'
new(cellptr);
cellptr .lex :
cellptr .sem :=
cellptr .ich :=
cellptr .rch :=
vartbl[ord(i)
-
(loop var]
(loop var]
(general cell]
do begin
tJNDEF;
0;
nil;
nil;
ord('a')]
(for all vars]
(make new cell)
(set to undef]
(set default sem val]
(no left branch)
(no right branch)
cellptr(var point to cell]
end;
'A' to 'Z' do
for i :
for j := 0 to maxref do begin
new(cellptr);
cellptr lex : UNDEF;
0;
cellptr.sem :
nil;
cellptr ich :
ceilptr .rch := nil;
vectbi [ord ( i)
ord ('A') ' j
(for all vec var]
(for all vec refs)
(make new cell)
(set to undef]
(set default sen val]
(no left branch]
(no right branch]
.
-
end;
:
cellptr
(var points to cell]
end
( VarTbllnit )
procedure MakeOpRankTbl;
(set precedences of operators]
begin
0;
opranktbl{UNMINUS] :
0;
opranktbl[NOT] :
1;
opranktbl[TTPO] :
2;
:
opranktbl[MULTJ
2;
:
opranktbl[MOD]
opranktbl[DIVJ : 2;
opranktbl[MINUS] := 3;
3;
opranktbl[PLUS] :
opranktbl[MAX] := 4;
opranktbl[MIN] := 4;
5;
opranktbl{LE] :
(unary minus
strongest
bind)opranktbl[LT]
5;
opranktbl{EQ] :
5;
opranktbl[GT]
5;
opranktbl[GE] :
5;
opranktbl[AND] :
6;
opranktbl[OR] :
7;
opranktbl{BUENDSYM]
8;
opranktbl[OPBASE] :
9
end; ( MakeOpRankTbiL )
(or weakest bind)
(dummy op to force redn)
(dummy op to halt redn}
procedure MakeLexStateTbl;
(set non -error states in lexical analysis transition table, all other
entries are zero, set by default, zero state is error state, negative
state represents incomplete token, positive state represents complete
acceptable token)
beg in
lexsttbl[ -l,
lexsttbl[ -l,
lexsttbl[ -1,
lexsttbl[ -l,
lexsttbl[ -l,
lexsttbl[ -l,
lexsttbl[ -l,
lexsttbl[ -l,
lexsttbl[ -IL,
lexsttbl[ -l,
lexsttblL[ -l,
lexsttbl[ -l,
lexsttbl[ -l,
lexsttblL[ -l,
lexsttbl[ -l,
lexsttbl[ -l,
lexsttbl{ -1,
lexsttbl[ -l,
lexsttbl[ -l,
lexsttbl{ -l,
lexsttbl[ -l,
lexsttbl[ -l,
lexsttbl[ -l,
lexsttbl[ -l,
lexsttbl[ -l,
lexsttbl[ -l,
ILexsttb1[ -1,
lexsttbl[ -l,
lexsttbl[ -IL,
lexsttbl[ -l,
lexsttbl[ -1,
lexsttblL[ -l,
lexsttbl[ -l,
lexsttbl[ -l,
lexsttbl{ -1,
lexsttbl[ -l,
lexsttbl{ -l,
lexsttbl[ -l,
lexsttbl[ -1,
lexsttbl[ -l,
lexsttbl[ -l,
lexsttbl[ -l,
lexsttbl[ -l,
lexsttbl[ -l,
lexsttbl[ -l,
lexsttbl[ -1,
lexsttbl[ -l,
lexsttbl{ -1,
lexsttbl[ -l,
']
'A']
'B' ]
'C']
'D' I
'E' I
'F']
'G' ]
'H']
'I']
'J' ]
'K' I
'L' ]
'M' ]
'N' I
'0']
'P 1
'Q' I
'P.']
'S I
'T' ]
'U' ]
'V']
'WI J
'X']
'Y' ]
'Z' ]
1;
-2;
-2;
:
-2;
:
-2;
-2;
:
-2;
:
-2;
:= -2;
-2;
:
-2;
-2;
:
-2;
:
-2;
-2;
:
-2;
-2;
:
-2;
:
:
-2;
:
-2;
-2;
:
-2;
:
:= -2;
-2;
-2;
:
-2;
:
-2;
:
'%']
'&' I
'
( ' ]
'
) ' I
*]
'+1
'-'
]
'/']
Q ]
'1']
'2']
'3']
'4']
'5']
'6']
'7']
'8']
'9']
'<' ]
'=' ]
:
:
:
:
:
:
:
:
:
:
:
:
:
:
I :
:
'?' ] :
'>'
2;
3;
4;
5;
6;
7;
8;
9;
10;
10;
10;
10;
10;
10;
10;
10;
10;
10;
11;
12;
13;
14;
( f(state,chr)=state )lexsttbl[ -1,
lexsttbl[9,
lexsttbl[ -l,
lexsttbl[ -7,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl{ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl{ -1,
lexsttbl[ -1,
lexsttblL[ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl{ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl[ -1,
lexsttbl[ -2,
lexsttbl[11,
lexsttbl[12,
lexsttbl[13,
lexsttbl[27,
lexsttbl[28,
lexsttbl[ -3,
lexsttblL[ -4,
lexsttbl[29,
lexsttbl[ -5,
lexsttbl[ -6,
lexsttbl[10,
lexsttbl[10,
lexsttbl[10,
lexsttbl[10,
lexsttbiL[10,
'@ I
15;
16;
'\' I
'\'] :
'/' I
tIJ
-7;
:
17;
:= 18;
'a' I
b I :
c I
'd']
'e' ]
f]
'g' ]
'h']
'i']
i]
'k' I
'1']
'rn I
fl']
'o' I
'Pl I
I
'ri
'q'
Is']
It']
'U']
'v']
'w']
'xi
'y'
I
'z' ]
'[' ]
'I
')' ]
'
'(']
'=1
1=1]
1=1]
f]
'h' I
'e'
In' ]
'1']
'si
'e' I
'0']
'1']
'2']
'3']
'4']
lexsttbl[10, '5']
lexsttbl[10, '6']
lexsttbl[10, '7']
lexsttbl[10, '8']
lexsttbl[10, '9']
end; [ MakeLexStateTbl
19;
19;
19;
:
19;
29;
19;
19;
19;
:
:
27;
19;
:
19;
19;
:
19;
:
19;
:
19;
19;
:
19;
:
19;
:
19;
28;
:
19;
:
19;
:
19;
:= 19;
19;
:
19;
20;
:
21;
:
22;
23;
:
24;
:
25;
:
:
26;
:
30;
-3;
:
-4;
:
31;
-5;
-6;
:
32;
:
10;
:
10;
10;
10;
:
10;
:
10;
:
:
10;
10;
:
10;
:
:
10
)
procedure MakeLexSymTbl;
(set up acceptcode to token name converter
begin
lexsymtbl[0]
lexsyrntblL[1]
lexsyrntbl[2]
lexsymtbl[3]
lexsymtbl[4]
:
:
:
ERR;
NOT;
MOD;
AND;
LPAREN;
table)
(accept
state 0 is err
token)lexsymtbl[5] : RPAREN;
lexsymtbl[6] : MULT;
lexsymtbl[7] : PLUS;
lexsymtbl[8] : MINUS;
lexsymtbl[9] : DIV;
lexsymtbl[1O] : NUM;
lexsymtbl[llJ := LT;
lexsymtbl[12] : ASSIG;
lexsymtbl[13] : CT;
lexsymtbl[14] : QM;
lexsymtbl[15] : UNDEF;
lexsymtbl[16] : MAX;
lexsymtb]j17] : MIN;
lexsymtbl[18] : TTPO;
lexsymtbl[19] := VAR;
iLexsymtbl[27] : VAR;
lexsymtbl[28] : VAR;
lexsymtbl[29] : VAR;
lexsymtbl[20] := LBR;
lexsymtbl[21] := OR;
lexsymtbl[22] := RER;
lexsymtbl[23] : VEC;
lexsymtbl[24] : LE;
lexsymtbl[25] : EQ;
lexsymtbl[26] : GE;
lexsymtbl[30} := IF;
lexsymtbl[31] := THEN;
lexsymtbl[32] := ELSE;
lexsymtbl[33} := EOC;
lexsymtbl[34] := UNMINUS
end; [ MakeLexSymTbl }
procedure Getlp;
[procedure to transfer the input to a character store, performing some
preliminary filtering of meta -characters)
var
cc: char;
passcc: boolean;
i: integer;
[current char read)
[true if cc is to be stored)
[initn loop var)
begin
for i :
1 to maxchrln do
[clear input store)
ipstore[i] :
ipstoretop := 0;
[mit end -of -store mkr}
cc :
';
[mit cc)
while (cc <> ; ) and not eoln do begin [on current command)
passcc : true;
[default setting)
read(cc);
if cc = ':' then begin
readln;
passcc :
end;
if cc
=
';'
false
then
passcc : false;
if cc =
then
passcc : false;
if cc =
then
passcc : false;
if passcc = true then begin
ipstoretop := ipstoretop + 1;
ipstore[ipstoretop] : cc
end
end;
if cc
';'
scomm
:
then
false
[get cc)
[if cc=line -connector then-)
[facilitate subsequent-)
[reading from next line)
[facilitate storage)
[suppression of command-)
[separators, spaces and-)
[tabs)
[if cc is to
[move mkr}
[store cc)
be
stored)
[if cc=command separator)
[facilitate prompt suppress)else
scomm
(facilitate prompt printing)
[if at end -of -line then read-)
[subsequent ip from next in)
true;
if eoln then
readin
end; [ Getlp }
procedure SaveToken(code: accst);
[puts lexical and semantic value of current token into store. code is
the last +ve state the lexical analyser was in)
var
i: integer;
[loop var)
begin
[move token store mkr)
tokenstoretop
tokenstoretop + 1;
0;
[store default sen val)
tokenstore[tokenstoretop].sem
tokenstore[tokenstoretop].lex := lexsymtbl[code];
[store lex val)
if code = 10 then begin
[if token is num-)
i
0;
[calculate numeric val-)
(from ascii codes of digit-)
repeat
i
i + 1;
tokenstore{tokenstoretop] .sem
tokenstore[tokenstoretop].sem
until tokenb[i + 1] =
[chars)
10 + ord(tokenb[i])
*
-
ord('O')
end;
if (code
=
19) or (code
=
27) or (code
=
28) or (code
=
29) then
[if token is var)
tokenstore[tokenstoretopj.sem := ord(tokenb[l])
ord(a');
(store pos of var in alphabet)
if code = 23 then
[if token is vec)
:=
tokenstore{tokenstoretop].sem
ord(tokenb[lJ)
ord('A')
[store pos of vec in alphabet)
-
-
end;
[
SaveToken
)
procedure LexAnalyse;
[convert string of characters in ipstore to tokens, calculating their
semantic values for particular tokens)
var
temp: lextype;
ipstoreptr: integer;
j: integer;
begin
tokenstoretop : 0;
ipstoreptr : 0;
[temp var)
[chars from ipstore mkr}
[mit loop var)
[reset token store ptr}
[mit ipstore mkr)
repeat
for j :
1 to maxchrln do begin
tokenb[j] :
charb[j]
[clear char buffers)
end;
cpos
0;
:
tpos :
0;
cs := -1;
[mit end -of -buffer mkrs}
[set initial state)
0;
(set initial tokencode)
tokencode :
while (ipstoreptr < ipstoretop) and (Cs <> 0) do begin
[while not eof and not error)
ipstoreptr := ipstoreptr + 1;
[get next char from ipstore)
x := ipstore[ipstoreptr];
[store x in char buffer)
cpos : cpos + 1;
charb[cposJ :
[make state transition)
cs : lexsttbl[cs, xj;
if cs > 0 then begin
[if accept state)
[record state)
tokencode := cs;
[transfer contents of charb)
for j : 1 to cpos do
tokenb{j + tpos] : charb[j];[to tokenb}
tpos := tpos + cpos;
cpos :
0
end
end;
if tpos
[if error state)
0 then begin
ipstoreptr :
ipstoreptr
cpos;
[transfer all token excess chars from charb to ipstore}
[record error code)
tokencode := 0;
ipstoreptr : ipstoreptr + 1
=
-
end else
ipstoreptr := ipstoreptr
cpos;
[transfer all token excess chars from charb to ipstore)
if (tokencode = 8) and (tokenstoretop > 0) then begin
[if token is minus and not first token in store)
[if previous token is var or undef or num)
temp := tokenstore{tokenstoretopj.lex;
if (temp = VAR) or (temp = UNDEF') or (temp = NUM) or
(temp = RPAREN) or (temp = RBR) then
[store minus)
SaveToken(8)
else
[store unary minus)
SaveToken(34)
end else
[store token)
SaveToken(tokencode)
until ipstoreptr >= ipstoretop;
[until all chars used)
[store end -of -input token)
SaveToken(33)
end; ( LexAnalyse )
-
procedure Parse;
[constructs a parse tree for the expression formed from the tokens in
tokenstore and takes action according to instructions for assignment or
query)
label
[goto for bad parse)
1;
type
errortype
=
[token err encountered)
[expected symbol not present)
(BADSYM,
BADSKIP,
BADSTACK,
[bad stack states for complete expression)
UNEXPECTED,
[token encountered in inappropriate context)
[invalid first token)
[attempted zero division)
[var involved in circ def)
[stacks not reducible)
[invalid vec ref)
[vector ref undef)
BADSTART,
DIVZERO,
CIRDEF,
BADEND,
INVEEF,
UDVECREF);
var
vecrefptr, queryptr: dataptr;
varcode,
vecvarass ig,
varassig: integer;
tokenstoreptr: integer;
symlex: lextype;
symsem: integer;
[general ptrs)
[var for circ defn check)
[vec ref)
[vec var code)
[token store mkr)
[lex val of token)
[sem val of token)
procedure Error(errorcode: errortype);
[produces appropriate error messages and prematurely ends
begin
case errorcode of
BADEND:
writeln('incomplete expression');
DIVZERO:
writeln('zero division');
parse)CIEDEF:
writeln(circular definition');
BADSYM:
writeln( 'unknown symbol' );
BADSKIP:
writeln('missing symbol');
BADSTACK:
writeln('invalid expression');
UNEXPECTED:
writeln('unexpected symbol');
BADSTART:
writeln('invalid statement');
tJDVECREF:
writeln('undefined array index');
INVREF:
writeln('invalid array index')
end;
end;
[resume program after parse)
goto 1
[ Error )
procedure Traverse(T: dataptr);
(traverses a tree given the root T, printing the expression
represented in infix)
begin
if T
nil then
[if empty tree)
[no action (return))
null
else begin
if ((T.lex in opset) or (T".lex = IF)) and (T.sem = 1) then
[if brackets flag set)
(print left bracket)
write( 'C
);
if T .lex = IF' then begin
[if root is if)
[print if)
write( 'if ) ;
(traverse condition branch)
Traverse(T.lch);
(print then)
write( 'then );
[traverse then clause)
Traverse(T.rch.lch);
(print else)
write( 'else );
[traverse else clause)
Traverse(T.rch.rch)
end;
if T' lex in binopset then begin[if root is binary op)
[traverse left branch)
Traverse(T.lch);
[print appropriate symbol)
case T lex of
=
'
'
'
'
.
MAX:
write( '/\
'
MIN:
write('\/ ');
TTPO:
write(
'
'
MOD:
write('% ');
MULT:
write(* f);
DIV:
write('/ ');
PLUS:
write('+ ');
LT:
write('< ');
LE:
write('<
');
GT:
write('> ');
EQ:
write(
'==
'
)
GE:
write('>= ');AND:
write('& ');
OR:
write('j ');
MINUS:
write('- ')
end;
Traverse(T.rch)
[traverse right branch)
end;
if T.iex in unopset then begin [if root is unary op)
case T lex of
[print appropriate symbol)
.
UNMINUS:
write( '-);
NOT:
write(
[traverse left branch only)
end;
Traverse(T
end;
if T
.
iex
.
ich)
[if root is num)
[print sem val}
[if root is var)
NUM then
=
write(T'.sem:O,' ');
if T
lex
VAR then
=
write(chr(ord('a') + T.sem),'
if T .lex
UNDEF then
=
write('@ ');
if T.lex = VEC then begin
write(chr(ord( 'A') + T .sem)
Traverse(T".lch);
write(') ')
end;
if ((T.lex in opset) or (T.lex
write(
)
'
)
');
[print letter)
[if root is undef)
[print undef symbol)
[if root is vec)
'
’
[print ( and letter)
[traverse ref branch)
[print closing bracket)
IF)) and (T'.sem = 1)
[if brackets flag set)
[print right bracket)
=
then
end
end; [ Traverse )
function SDV(T: dataptr): boolean;
[traverse a tree given root T to see if any variables encountered
have the same variable code as the 1 whose variable code is set to
var code)
var
[true for circ def)
redexp: boolean;
begin
redexp := false;
if T lex in binopset then
if SDV(T .lch) or SDV(T
[default setting)
[if root is binary op)
.
redexp := true;
if T .lex in unopset then
if SDV(T" ich) then
redexp := true;
if (T'. lex = UNDEF) or (T
.
rch) then
[if left or right branch has circ def)
[this branch has circ defn)
[if root is unary op)
[if left branch has circ def)
[this branch has circ defn)
.
.
lex
=
NUM)
then
[if root is undef or num)
redexp := false;
[this branch hasn't circ def)
if T lex
VAR then
[if root is var)
if varcode = -(T.sem + 1) then [if var code
varcode)
redexp := true
[this branch has circ defn}
=
=
else
SDV(vartbl[T".sem]);
[check this var's defn}
VEC then
[if root is vec)
redexp :
if T .lex =
if varcode
=
T
.sem
*
(maxref + 1) + T.ich.sem then
[if var code = varcode}redexp :
(this branch has circ defn)
true
else
redexp := SDV(vectbi.[T.sem, T'.lch'.sem]);
(check this vec's defn)
if T .lex = IF then
[if root is if)
redexp := SDV(T'.lch) or SDV(T.rch'.lch) or SDV(T.rch.rch);
(check all sub -branches)
SDV :
redexp
(return result)
end; ( SDV )
function Eval(T: dataptr): dataptr;
[by recursive evaluation of subtrees this procedure reduces a tree
whose root is T to a single cell containing a number or an undefined
value)
var
condptr, thenptr, elseptr, redtreeptr, redlchptr,
redrchptr: dataptr;
[general ptrs)
begin
new(redtreeptr);
(make new cell)
if T lex = VAR then
[if root is var)
redtreeptr :
Eval(vartbl[T.sem]);
(evaluate this var's defn)
if T'.lex = UNDEF then
(if root is undef)
(T reduces to this cell)
redtreeptr := T;
if T" .lex = NIJM then
(if root is num)
(T reduces to this cell)
redtreeptr := T;
if T lex = VEC then
(if root is vec)
redtreeptr := Eval(vectbl[T.sem, T'.lch.sem]);
(evaluate this vec's defn)
if T.lex in unopset then begin
(if root is unary op)
redlchptr := Eval(T'.lch);
(evaiuate left branch)
if redlchptr. lex = UNDEF then begin
(if left branch is undef)
redtreeptr
(T is undef)
lex := UNDEF;
redtreeptr .sem :
0;
redtreeptr lch := nil;
redtreeptr .rch := nil
end else begin
case T lex of
(if root is)
.
.
.
UNMINUS:
(perform appropriate op on sem val)
redtreeptr.sem :
-redlchptr.sem;
NOT:
if redlchptr
.
sem
redtreeptr'
.
0 then
(if subtree is 0)
sem : 1
(T points to 1)
=
else
redtreeptr".sem
:
0
(T points
to
0)
end;
redtreeptr'.lex
:= NiJM;
(set remaining cell features)
redtreeptr
lch :
nil;
redtreeptr.rch := nil
.
end
end;
if T .lex in binopset then begin
redlchptr := Eval(T.lch);
redrchptr := Eval(T.rch);
if (redlchptr.lex
=
(if root is binary op)
(evaluate left branch)
[evaluate right branch)
UNDEF) or (redrchptr" lex = UNDEF) then
begin
[if either branches reduce to undefined values)
[T is undef)
:= UNDEF;
[set default sem val)
redtreeptr.sem := 0;
redtreeptr' .lex[no left branch)
[no right branch)
redtreeptr.lch : nil;
redtreeptr rch := nil
end else begin
case T .lex of
[if
root
is)
MAX:
[set T to point to max val of reduced subtrees}
if redlchptr sem > redrchptr sem then
redtreeptr
sen := redlchptr sem
else
redtreeptr" sen : redrchptr' sem;
.
.
MIN:
[set T to point to min val of reduced
if redichptr" sem < redrchptr sen then
redtreeptr
sem := redlchptr sen
else
redtreeptr'.sem := redrchptr.sem;
subtrees}
.
.
[set
[checking
TTPO:
T to point to left val to the power of the right
redtreeptr.sem := trunc(exp(redrchptr.sem *
val)
ln(redlchptr.sem)));
MOD:
for zero modulus, set T to point to left val modulLo right val)
if redrchptr
sem = 0 then
Error(DIVZERO)
else
redtreeptr sen := redlchptr' sen mod
sem;
redrchptr
MULT:
[set T to point to product of ILeft and right valLs}
redtreeptr sem := redlchptr sen *
redrchptr sem;
DIV:
[checking for zero division, set T to point to
quotient of left and right vals)
if redrchptr" sem
0 then
Error (DIVZERO)
else
redtreeptr.sen := trunc(redlchptr.sen /
redrchptr sem)
PLUS:
[set T to point to sum of left and right vals)
redtreeptr.sem := redlchptr.sem +
redrchptr' sem;
MINUS:
[set T to point to difference of left and right vals)
redtreeptr .sem := redlchptr .sem
redrchptr sem;
LT:
[set T to point to 1 if left val < right val else 0)
if redlchptr
sen < redrchptr sem then
redtreeptr .sem := 1
else
0;
redtreeptr.sem :
LE:
[set T to point to 1 if left val < right val else 0)
if red1chptr
sen <= redrchptr sen then
redtreeptr" sen := 1
else
redtreeptr' .sem : 0;
.
.
.
.
.
-
.
EQ:
right val else 0)
redrchptr' sem then
if red1chptr
sem
sem := 1
redtreeptr
else
0;
redtreeptr.sem :
[set
.
GE:
if left val
T to point to 1
=
=
.T to point to 1 if left val >= right val else 0)
sen > redrchptr sem then
if redlchptr
redtreeptr" sen := 1
else
redtreeptr'.sem : 0;
(set
.
GT:
T to point to 1 if left val > right val else 0)
sen then
if redlchptr sen > redrchptr
redtreeptr.sem := 1
else
0;
redtreeptr .sem :
[set
.
.
[set
(set
AND:
T to point to 1
if left val and right val non -zero else
if (redlchptr .sem <> 0) and
(redrchptr.sem <> 0) then
1
redtreeptr .sem :
else
0;
redtreeptr.sem :
OR:
T to point to IL if left val or right val non -zero else
if (redlchptr' .sem <> 0) or
(redrchptr" .sern <> 0) then
1
redtreeptr'.sem :
0)
0)
else
redtreeptr".sem
:
0
end;
redtreeptr.lex := NUM;
redtreeptr lch := nil;
redtreeptr rch := nil
.
.
[set remaining cell features)
[no left branch)
[no right branch)
end
end;
[if root is if)
if T.lex = IF then begin
[evaluate condition branch)
condptr := Eval(T'.lch);
if condpLr
lex = UNDEF then begin
[if condition branch undef)
[T is undef)
redtreeptr .lex := UNDEF;
[set default sen val)
redtreeptr .sem := 0;
[no left branch)
redtreeptr .lch := nil;
[no right branch)
redtreeptr .rch := nil
end else if condptr' sem <> 0 then begin
[if condition branch non -zero)
thenptr := Eval(T.rch.lch);[evaluate then clause)
if thenptr .lex = IJNDEF then beginfif then clause undef}
redtreeptr .lex : UNDEF;
fT is undef)
[set default sem val)
redtreeptr sem := 0;
redtreeptr lch := nil; [no left branch)
[no right branch)
redtreeptr rch := nil
end else begin
redtreeptr" lex : NUM;
[set T to point to reduced then clause)
thenptr.sem;
redtreeptr.sem :
.
.
.
.
redtreeptr ich := nil;
redtreeptr .rch := nil
[set sem val)
[no left branch)
[no right branch)
end
end else begin
Eval(T.rch.rch);
elseptr :
[evaluate else clause)
UNDEF then begin
(if else clause undef)
redtreeptr lex := UNDEF;
[T id undef)
[set default sen val)
redtreeptr .sem := 0;
redtreeptr .lch := nil; [no left branch)
[no right branch)
redtreeptr rch := nil
if elseptr
.
lex
=
.end else begin
redtreeptr.lex
(set
NUM;
T to point to reduced else
clause)
redtreeptr" .sem := elseptr.sem;
(set sem val)
redtreeptr' .lch := nil; (no left branch)
(no right branch)
nil
redtreeptr.rch
end
end
end;
Eval :
end;
[return va]j
redtreeptr
[Eval}
procedure GetToken;
(sets symlex and symsem to lexical and semantic values of next token
in token store)
begin
tokenstoreptr :
tokenstoreptr + 1; [advance store ptr}
symlex :
tokenstore[tokenstoreptr].lex;
(get lex vaiL)
symsern := tokenstore[tokenstoreptr].sem;
[get sem val)
f if err
if symlex = ERR then
Error(BADSYM)
end; [ GetToken )
token
encountered)
[error)
procedure BackSym;
[moves store pointer back one symbol.. this is necessary if there is a
switch in parsing techniques and the subsequent parsing procedure
has to read the symbol again)
begin
tokenstoreptr := tokenstoreptr
end; [ BackSym )
-
1
[move
store ptr back
procedure PassSym(passme: lextype);
[skips over the next token if it is the same as the token
begin
GetToken;
if symiLex <> passme then
Error(BADSKIP)
end; [ PassSym )
1)
passme)
[get next token)
[if next token not passme)
[error)
function BottomUp: dataptr;
forward;
[forward reference for bottom up parsing function)
function TopDown: dataptr;
[returns the root of a forthcoming expression parsed in a top -down
manner)
var
celillptr, temp: dataptr;
begin
GetToken;
case symlex of
[general ptrs)
[get next token)
[if token is)
VEC:
begin
new(cellptr);
[make new cell)
cellptr' sem := symsem; [set cell fields)
.
VEC;
cellptr.lex :
cellptr'.lch := Eval(BottomUp);
[left branch set to subsequent
exp)if cellptr lch. lex = UNDEF then[if ref undef)
(error)
Error(UDVECREF);
if (cellptr lch .sem>maxref) or
(cellptr .lch .sem<O) then
Error(INVREF);
(no right branch)
cellptr .rch := nil;
[skip over right bracket)
PassSym(RPAREN);
(return root of new cell)
TopDown := cellptr
.
end;
LPAREN:
begin
(root set to subsequent exp}
if (temp".lex in opset) or (temp'.lex = IF) then
(set brackets flag)
temp .sem := 1;
temp := BottomUp;
TopDown
ternp;
PassSym(RPAREN)
(return root)
(skip over right bracket)
end;
LBR:
begin
TopDown := Eval(BottomUp);
(root set to evaluated subsequent
exp)
(skip over right brace)
PassSym(RBR)
end;
IF:
begin
(make new cell)
new(cellptr);
(set lex field)
cellptr lex := IF;
cellptr lch : BottomUp;
(get condition exp)
(set sen field)
0;
cellptr .sem :
(skip over then)
PassSym(THEN);
(make actions cell)
new(cellptr.rch);
IFACTIONS;
cellptr .rch .lex :=
(set lex field)
0; (set sen field)
cellptr .rch .sem :
cellptr rch .lch :
BottomUp;
[get then exp)
[skip over else)
PassSym(ELSE);
cellptr .rch .rch := BottomUp;
[get else exp}
(return val)
TopDown :
cellptr
end;
end
end; [ TopDown }
function BottomUp;
[returns the root of the following expression parsed in a bottom -up
manner)
var
exitst: boolean;
(true if
next
token suggests end of
exp)
opstack: array [1. .maxstkht] of lextype;
(op stack)
exstack: array [1. .maxstkht] of dataptr;
opstacktop,
exstacktop: integer;
cellptr: dataptr;
(op stack)
(op stack top mkr)
fexp stack top rnkr)
(general ptr)
procedure Reduce;
[combines expressions on expression stack with operator on
operator stack and places the result on the expression stack)
var
redexp,
[ptr
to combined
exp)[ptr to first exp off stack)
[ptr to second exp off stack)
[first op off stack)
expl,
exp2: dataptr;
op: lextype;
begin
op : opstack[opstacktop]; [pop op stack)
1;
opstacktop : opstacktop
[make new cell)
new(redexp);
if op in unopset then begin [if op is unary op)
if exstacktop<l then
[if insufficient num of exps on exp stack)
-
Error(BADEND)
expl := exstack{exstacktop]
;[pop exp stack)
1;
exstacktop :
exstacktop
redexp ich : expi;
[set left branch to point to popped exp)
[no right branch)
redexp .rch :
nil;
[set lex field)
redexp' lex := op;
[no sem val)
redexp .sem := 0
end else begin
if exstacktop<2 then
[if insufficient num of exps on exp stack)
Error(BADEND);
expl := exstack[exstacktop];
[pop exp stack)
exstacktop := exstacktop
1;
exp2 :
exstack[exstacktop3;
[pop exp stack)
1;
exstacktop := exstacktop
redexp .lch := exp2;
[set left branch to second popped exp)
redexp rch := expii;
[set right branch to first popped exp}
[set lex field)
redexp .lex := op;
[no sem val)
redexp .sem :
0
-
.
-
-
.
end;
exstacktop := exstacktop + 1;
[push new exp)
exstack[exstacktop]
end; [ Reduce )
:= redexp
begin
exstacktop := 0;
opstack[ll : OPBASE;
[clear exp stack)
[push irreducible
token on op
stack)
1;
opstacktop :
false;
exitst :
[default procedure exit status)
repeat
GetToken;
case symlex of
[get next token)
[if next token is)
NOT, TTPO, MOD, MULT, DIV1 PLUS,
LE, EQ, GT, MAX, MIN, GE, AND,
OR, UNMINTJS, MINUS:
[op
LT,
list)
begin
while opranktbl[symlex} >
opranktbl[opstack[opstacktop] I do
[while of higher prec than op on opstack)
Reduce;
[reduce stack)
opstacktop := opstacktop + 1;
[push
opstack[opstacktop]
next
:= symlex
token)
end;
VAR,
NtJM, UNDEF:
begin
new(cellptr);
[make new cell)cellptr .lex symlex;
cellptr .sem : symsem;
(insert token lex val)
[insert token sem val)
cellptr.lch := nil;[no left branch)
cellptr.rch := nil;[no right branch)
exstacktop
exstacktop + 1;
exstack[exstacktopl
cellptr
[push this cell)
end;
VEC, LPAREN, LBR,
IF:
[top down left delimiters)
begin
[move back 1 token)
BackSym;
exstacktop : exstacktop + 1;
exstack[exstacktop] := TopDown
[push subsequent top -down exp)
end;
RPAREN,
RBR,
THEN,
EOC,
ELSE:[bottoni up right delimiters)
begin
BackSym;
syrulex: =BUENDSYM;
(move back
1
token)
(facilitate total stack reduction)
while opranktbl[symlex] >
opranktbl[opstack[opstacktop] ] do
[do total stack reduction)
Reduce;
(facilitate proc finish)
exitst := true
end;
ASSIG, QM:
(inappropriate symbols)
(error)
Error(UNEXPECTED)
end
until exitst = true;
(until proc finish facilitate)
if (exstacktop = 1) and (opstacktop = 1) then
(if stack in good state)
BottomUp := exstack[exstacktop]
(return ptr to final expression)
else Error(BADSTACK);
(error)
end; [ BottomUp }
begin
tokenstoreptr := 0;
[mit token store ptr)
(get first token)
[if first token)
GetToken;
case symlex of
VAR:
begin
varassig := symsem;
PassSym(ASSIG);
tempptr := BottoinUp;
varcode :
-(varassig +
if SDV(tetnpptr) then
Error(CIRDEF)
else
vartbl[varassig]
(record var to be assigned to)
(skip over assignment sign)
(get exp assigned)
1); (compute var code)
(if circ def}
(error)
:= tempptr
[make assignment)
end;
QM:
begin
(get exp queried)
queryptr := BottomUp;
if queryptr
lex = VAR then (if exp is single var)
queryptr := vartbl[queryptr'.sem];
(reset expt that assigned to the var)
if queryptr .lex = VEC then [if exp is single vec)
queryptr := vectbl[queryptr.sem, queryptr'.1ch'.sem];
(reset exp to that assigned to the vec)
Traverse(queryptr);
writeln
end;
[traverse the given exp}VEC:
begin
[record vec to be assigned to)
vecvarassig := symsem;
Eval(BottomUp);[get ref)
vecrefptr
if vecrefptr. lex = TJNDEF then
[if not numeric ref}
[error)
Error(UDVECREF);
if (vecrefptr.sem>rnaxref) or (vecrefptf'.sem<O) then
Error(INVREF);
PassSym(RPAREN);
PassSym(ASSIG);
tempptr :
BottomUp;
varcode
vecvarassig
if SDV(ternpptr) then
Error(CIRDEF)
[skip over right bracket)
[skip over assignment sign)
[get exp assigned)
*
(maxref + 1) + vecrefptr .sem;
[compute var code)
[if circ def)
[error)
else
vectbl[vecvarassig, vecrefptr.sem]
:
tempptr
[make assignment)
end;
LPAREN, LBR, IF, RPAP.EN, RBR, THEN, ELSE,
EOC, ASSIG, MAX, MIN, TTPO, MOD, MULT,
DIV, PLUS, LT, LE, EQ, GT, GE,
[inappropriate first
AND, OR, MINUS, NUM, NOT, UNDEF:
tokens)
[error)
Error(BADSTART)
end;
PassSym(EOC);
[skip over
end -of -input)
1:
end;
[landing place for bad parse)
null
[ Parse )
procedure mit;
[does all initialisation
processes)
begin
CheckArgs;
if sprom = false then
write( 'UDC> ');
[check for call arguments)
[if nor silent mode)
[give prompt)
[set up var tables)
VarTbllnit;
MakeLexStateTbl;
(set up lex ana tysis transition table)
[set up token code table)
(def me op precedences)
(def me op set)
[define binary ops}
[define unary ops}
MakeLexSymTbl;
MakeOpRankTbl;
[MAX. .NOT;
opset :
[MAX. .MINUS];
binopset :
[UNMINUS. .NOT]
unopset :
end; ( mit )
begin
mit;
while not eof do begin
(do initn)
(while there is input)
[get command line)
[if not blank)
[perform lex analysis)
(perform parse)
Getlp;
if ipstoretop > 0 then begin
LexAnalyse;
Parse
end;
if (scomm
=
true) and (sprom
write(UDC> ')
end;
if sprom = false then
writein
=
false) then
[if single command and not silent mode)
[give prompt)
[if
[produce blank line
end.
not silent
mode)
to clear the escape
symbol)