Elementary Semantics Expressed in Pascal
See L. Allison, A Practical Introduction to Denotational Semantics, CUP, Cambridge Computer Science Texts V23, 1986.
These semantics are for a "pure" imperative language where side-effects are impossible in expressions.
Note function EE and
function CC in particular.
program ch5(input, output);
label 99;
type {lexical objects}
alfa = packed array [1..10] of char;
symbol = (plussy, minussy, timessy, oversy,
eqsy, nesy, ltsy, lesy, gtsy, gesy,
ident, numeral,
ifsy, thensy, elsesy, whilesy, dosy,
beginsy, endsy, skipsy,
semisy, becomessy, open, close, stopsy);
{syntactic domains}
exptype = (bexp, uexp, varr, int);
opr = (plus, minus, times, over,
eq, ne, lt, le, gt, ge, neg);
cmdtype = (assign, semi, ifstat, whiles, skip);
exp = ^ enode;
enode = record case tag:exptype of
bexp :(o:opr; left, right:exp);
uexp :(u:opr; son:exp);
varr :(id:alfa);
int :(i:integer);
end;
cmd = ^ cnode;
cnode = record case tag:cmdtype of
assign :(id:alfa; e:exp);
semi :(left,right:cmd);
ifstat :(b:exp; gtrue,gfalse:cmd);
whiles :(bw:exp; g:cmd);
skip :()
end;
{semantic domains}
Values = integer;
State = ^ avar;
avar = record ident:alfa;
v:Values;
next:State
end;
var lineno:integer;
ch : char {current character};
sy : symbol {current symbol class};
word : alfa {current keyword, identifier or operator};
n : integer {value of current numeral};
{------------------------------------------------------------lexical-----}
procedure error(a:alfa);
begin writeln;
writeln(' error:', a,' ch=[' ,ch, '] word=[' ,word,'] n=',n:1);
goto 99
end;
function nextch:char;
var ch:char;
begin if eof then error('prem'' eof ')
else if eoln then
begin readln; writeln;
lineno:=lineno+1; write(lineno:4,':');
nextch:=' '
end
else begin read(ch); write(ch); nextch:=ch
end
end;
procedure insymbol;
var l:integer; ch2:char;
begin while ch=' ' do ch:=nextch;
if ch in ['a'..'z','A'..'Z'] then
begin l:=0; word:=' ';
while ch in ['a'..'z','A'..'Z','0'..'9'] do
begin l:=l+1;
if l <= 10 then word[l]:=ch;
ch:=nextch
end;
if word = 'begin ' then sy:=beginsy
else if word = 'end ' then sy:=endsy
else if word = 'if ' then sy:=ifsy
else if word = 'then ' then sy:=thensy
else if word = 'else ' then sy:=elsesy
else if word = 'while ' then sy:=whilesy
else if word = 'do ' then sy:=dosy
else if word = 'skip ' then sy:=skipsy
else sy:= ident
end
else if ch in ['0'..'9'] then
begin n:=0;
while ch in ['0'..'9'] do
begin n:=n*10+ord(ch)-ord('0');
ch:=nextch
end;
sy:=numeral
end
else if ch in ['+', '-', '*', '/', '=', '(', ')', ';', '.'] then
begin case ch of
'+': sy:=plussy;
'-': sy:=minussy;
'*': sy:=timessy;
'/': sy:=oversy;
'=': sy:=eqsy;
'(': sy:=open;
')': sy:=close;
';': sy:=semisy;
'.': sy:=stopsy
end;
ch:=nextch
end
else if ch in ['<' , '>', ':'] then
begin ch2:=ch; ch:=nextch;
case ch2 of
'<' : if ch='=' then sy:=lesy
else if ch='>' then sy:=nesy else sy:=ltsy;
'>': if ch='=' then sy:=gesy else sy:=gtsy;
':': if ch='=' then sy:=becomessy
else error('no = in :=')
end;
if sy in [lesy,nesy,gesy,becomessy] then ch:=nextch
end else error('insymbol ')
end {insymbol};
procedure check(s:symbol; chs:alfa);
var m:alfa;
begin if sy=s then insymbol
else begin m:='chck( )';
m[6]:=chs[1]; m[7]:=chs[2]; m[8]:=chs[3];
m[9]:=chs[4]; error(m)
end end;
function nextsymis(s:symbol):boolean;
begin nextsymis:=true;
if sy=s then insymbol else nextsymis:=false
end;
function consexp(t:exptype; f:opr; e1,e2:exp):exp;
var e:exp;
begin new(e); consexp:=e;
with e^ do
begin tag := t; o:=f;{hope pc doesn't check}
left:=e1; right:=e2
end end;
function conscmd(t:cmdtype; ctrle:exp; g1,g2:cmd):cmd;
var c:cmd;
begin new(c); conscmd:=c;
with c^ do
begin tag:=t;
case t of
assign: error('cons cmd ');
semi: begin left:=g1; right:=g2 end;
ifstat: begin b:=ctrle; gtrue:=g1; gfalse:=g2 end;
whiles: begin bw:=ctrle;g:=g1 end;
skip:
end end end;
{-----------------------------------------------------parser--------------}
function parser:cmd;
function pexp:exp;
var e:exp; o:opr;
function pexp1:exp;
var e:exp; o:opr;
function pexp2:exp;
var e:exp; o:opr;
function pexp3:exp;
var e:exp;
begin if sy=open then
begin insymbol;
e:=pexp;
check(close, ') ')
end
else if sy=minussy then
begin insymbol;
e:=consexp(uexp, neg, pexp3, nil)
end
else if sy=ident then
begin new(e);
with e^ do
begin tag:=varr; id:=word
end;
insymbol
end
else if sy=numeral then
begin new(e);
with e^ do
begin tag:=int; i:=n
end;
insymbol
end
else error('pexp3 ');
pexp3:=e
end {pexp3};
begin {pexp2}
e:=pexp3;
while sy in [timessy,oversy] do
begin if sy=timessy then o:=times
else o:=over;
insymbol;
e:=consexp(bexp, o, e, pexp3)
end;
pexp2:=e
end {pexp2};
begin {pexp1}
e:=pexp2;
while sy in [plussy,minussy] do
begin if sy=plussy then o:=plus
else o:=minus;
insymbol;
e:=consexp(bexp, o, e, pexp2)
end;
pexp1:=e
end {pexp1};
begin {pexp}
e:=pexp1;
if sy in [eqsy .. gesy] then
begin case sy of
eqsy: o:=eq; nesy: o:=ne;
ltsy: o:=lt; lesy: o:=le;
gtsy: o:=gt; gesy: o:=ge
end;
insymbol;
e:=consexp(bexp, o, e, pexp1)
end;
pexp:=e
end {pexp};
function pcmd:cmd;
var c:cmd;
x:alfa;
function ifcmd:cmd;
var e:exp; g1:cmd;
begin e:=pexp;
check(thensy, 'then '); g1:=pcmd;
check(elsesy, 'else ');
ifcmd:=conscmd(ifstat,e,g1,pcmd)
end {ifcmd};
function whilecmd:cmd;
var e:exp;
begin e:=pexp; check(dosy, 'do ');
whilecmd:=conscmd(whiles, e, pcmd,nil)
end;
begin if sy=ident then
begin x:=word;
insymbol; check(becomessy, ':= ');
new(c);
with c^ do {x:=rhs}
begin tag:=assign; id:=x; e:=pexp
end
end
else if nextsymis(ifsy) then
c:=ifcmd
else if nextsymis(whilesy) then
c:=whilecmd
else if nextsymis(beginsy) then
begin c:=pcmd;
while nextsymis(semisy) do
c:=conscmd(semi, nil, c, pcmd);
check(endsy, 'end ')
end
else if nextsymis(skipsy) then
c:=conscmd(skip, nil,nil,nil)
else error('parse cmd ');
pcmd := c
end {pcmd};
begin {parser}
parser:=pcmd;
if sy <> stopsy then error('no . ')
end {parser};
{-------------------------------------------------------------semantics--}
procedure display(s:State);
begin if s=nil then writeln(' finish')
else begin writeln(s^.ident,'=',s^.v:3); display(s^.next)
end end;
function undefined:Values;
{not a function in the semantics; a fn here to get side-effect of stop}
begin undefined:=0 {else pc complains}; error('run:undef ') end;
function update(s:State; id:alfa; val:Values):State;
{ : State x Ide x Values -> State }
var p:State;
begin new(p); p^.next:=s; update:=p;
p^.ident:=id; p^.v:=val
end;
function applyState(s:State; id:alfa):Values;
begin if s=nil then applyState:=undefined
else if s^.ident = id then applyState:=s^.v
else applyState:=applyState(s^.next, id)
end;
function EE(e:exp; s:State):Values; {: exp x State -> Values }
function OO(o:opr; v1, v2 :Values):Values;
begin case o of
plus: OO:=v1+v2;
minus:OO:=v1-v2;
times:OO:=v1*v2;
over: OO:=v1 div v2;
eq: OO:=ord(v1=v2);
ne: OO:=ord(v1 <> v2);
lt: OO:=ord(v1 < v2);
le: OO:=ord(v1 <= v2);
gt: OO:=ord(v1 > v2);
ge: OO:=ord(v1 >= v2)
end {case}
end {OO};
begin {EE}
case e^.tag of
varr: EE:=applyState(s, e^.id);
int: EE:=e^.i;
uexp: EE:= - EE(e^.son, s) {- only unary op};
bexp: EE:= OO( e^.o, EE(e^.left, s), EE(e^.right,s))
end {case}
end {EE};
function CC(g:cmd; s:State):State; {: cmd x State -> State}
begin {Main interpreter routine}
case g^.tag of
assign: CC:=update(s, g^.id, EE(g^.e, s));
semi: CC:=CC(g^.right, CC(g^.left, s));
ifstat: if EE(g^.b,s)=1 then CC:=CC(g^.gtrue,s)
else CC:=CC(g^.gfalse,s);
whiles: if EE(g^.bw,s)=1 then CC:=CC(g, CC(g^.g,s))
else CC:=s;
skip: CC:=s
end {case}
end {CC};
{-----------------------------------------------------------------main---}
begin
writeln(' A Simple Language, L.Allison U.W.A.');
lineno:=1; write(lineno:4, ':');
word:='-starting-'; n:=0; ch:=nextch; insymbol;
display( CC(parser, {startState=}nil ) );
99: {fin}
end.