|
|
The (lazy) λ calculus interpreter consists of
a simple parser,
execution routines (eval, force)
and a few supporting routines.
The functional language has a simple grammar
and parsing it is quite easy;
a parser is included in an appendix.
The lexical symbols and syntactic types are used
throughout the interpreter.
{lexical items}
symbol = (word, numeral, empty{ () }, nilsy, charliteral, truesy, falsesy,
open, close, sqopen, sqclose, curlopen, curlclose,
letsy, recsy, insy, comma, colon,
ifsy, thensy, elsesy, lambdasy, dot,
quote,
conssy,
orsy, andsy,
eq, ne, lt, le, gt, ge,
plus, minus, times, over,
nullsy, hdsy, tlsy, notsy,
eofsy
);
{ Lexical Types. }
The syntactic types define a parse tree.
The interpreter walks this tree executing a program.
tree = ^ node;
SyntaxClass = ( ident, intcon, boolcon, charcon, emptycon, nilcon,
lambdaexp, application, unexp, binexp, ifexp, block,
declist, decln
);
node = record case tag :SyntaxClass of
ident :( id :alfa );
intcon :( n:integer );
boolcon :( b:boolean );
charcon :( ch:char );
emptycon, nilcon:();
lambdaexp :( fparam, body :tree );
application :( fun, aparam :tree );
unexp :( unopr :symbol; unarg :tree );
binexp :( binopr:symbol; left, right :tree );
ifexp :( e1, e2, e3 :tree );
block :( decs, exp :tree );
declist :( recursive:boolean; hd, tl :tree );
decln :( name: alfa; val:tree )
end;
{ Syntactic Types. }
This section describes an interpreter for the functional language.
It employs an implementation of normal-order evaluation known
as call by need evaluation.
The interpreter evaluates an expression (program) represented by
a parse tree and produces and prints a value.
Expressions and values are quite separate kinds of things.
There are integer, boolean and other simple values.
Evaluating a function abstraction produces a function value.
A function value contains some code (an expression)
and an environment to execute the code in.
An environment is a list of bindings of names to values.
When a name is used its value is found in the environment.
Being a lazy interpreter,
there is a deferred value for expressions that have been put-off
until later.
A deferred value has not yet been evaluated.
It consists of an expression to be evaluated and an environment to
evaluate it in if need be.
type Env = ^ Binding;
Value = ^ValNode;
Binding = record id :alfa; v:Value; next:Env end;
ValueClass = (intval, boolval, charval, emptyval,
listval, nilval, funcval, deferval);
ValNode = record case tag :ValueClass of
intval: (n :integer );
boolval:(b :boolean );
charval:(ch:char );
nilval, emptyval:();
listval:(hd, tl :Value);
funcval, deferval:( e:tree; r:Env )
end;
{ Environment and Value Types. }
Execution is driven by output.
The interpreter turns the input expression into a deferred value
and has it printed.
procedure execute(prog:tree);
#include "lazy.type.P"
var evals, envcells, conscells :integer; { statistics }
LastId :alfa; { debugging}
Answer :Value;
procedure error( m:alfa );
begin writeln; writeln('Error: ', m, ' LastId=', LastId);
goto 99 {error abort}
end;
#include "lazy.mkval.P" { Make various Values }
function eval( x:tree; rho:Env ):Value; forward;
procedure force( v:Value ); forward;
#include "lazy.env.P" { manipulate Environment }
#include "lazy.D.P" { Execute Declarations }
#include "lazy.apply.P" { Apply a Function }
#include "lazy.U.P" { Execute Unary Operators }
#include "lazy.O.P" { Execute Binary Operators }
#include "lazy.eval.P" { eval and force an Expression }
#include "lazy.show.P" { Output Values }
begin{execute}
evals := 0; envcells := 0; conscells := 0; {zero counters}
LastId := '-start- ';
Answer := defer(prog, {Env=}nil);
ShowValue(Answer); { Execution is print driven }
writeln; write( evals, ' evals');
write( envcells, ' env cells used, ');
writeln( conscells, ' cells used')
end{execute};
{ Shell of Interpreter for Functional Language. }
{ - L. Allison 9/2007 }
{Do not remove: Lazy.p, Strict.p, lazy.*.P, strict.*.P, lex.*.P, & syntax.*.P }
{ are released under Gnu `copyleft' General Public Licence (GPL) }
The print routine prints the various kinds of value.
Note that printing a list is recursive.
A deferred value must be forced or
turned into a non-deferred value before it can be printed.
procedure ShowValue( v:Value );
begin with v^ do
case tag of
intval: write( n:1 );
boolval: write( b );
charval: write( ch );
emptyval:write( '()' );
nilval: write('nil');
listval: begin write('('); ShowValue(hd); writeln('::'); {flush buffer}
ShowValue(tl); write(')')
end;
funcval: write('function');
deferval:begin force(v); ShowValue(v) end { evaluation is o/p driven }
end
end {ShowValue};
{ Output Values. }
Expressions are evaluated by force and by eval.
Being part of a lazy interpreter,
eval does as little work as possible.
In particular, the components of a list, the head and the tail,
are not evaluated but are deferred.
The head and tail are only evaluated further if they are printed
or if some strict operator, eg. +, is applied to them.
When eval returns a structure, only the top most node
is guaranteed not to be deferred;
substructures may be deferred.
This condition is known as weak head normal form.
Note that force overwrites a deferred value with the evaluated value.
This is efficient because values can be shared,
particularly in recursive structures and when parameters are passed.
Overwriting ensures that a value is only evaluated once.
Functions O and U execute binary and unary operators
respectively (see appendix).
function eval { (x:tree; rho:Env) :Value forwarded };
{ eval :Exp -> Env -> Value Note: evaluates an Expression and returns a Value}
{POST: result tag is not deferval, weak head normal form}
var func, switch :Value;
begin case x^.tag of
ident: eval:=applyenv(rho, x^.id);
intcon: eval:=mkint(x^.n);
boolcon: eval:=mkbool(x^.b);
charcon: eval:=mkchar(x^.ch);
nilcon: eval:=mkvalue(nilval);
emptycon: eval:=mkvalue(emptyval);
lambdaexp: eval:=mkfunc(x, rho);
application:
begin func := eval(x^.fun, rho);
if func^.tag=funcval then
eval:=apply(func, defer(x^.aparam, rho))
else error('apply ~fn ')
end;
unexp: eval:=U(x^.unopr, eval(x^.unarg, rho));
binexp: if x^.binopr=conssy then { cons should not eval its params }
eval:=O(x^.binopr, defer(x^.left,rho),
defer(x^.right,rho))
else eval:=O(x^.binopr, eval(x^.left,rho), {others strict}
eval(x^.right,rho));
ifexp:
begin switch:=eval(x^.e1, rho);
if switch^.tag=boolval then
if switch^.b then eval:=eval(x^.e2, rho)
else eval:=eval(x^.e3, rho)
else error('if ~bool ')
end;
block: eval:=eval( x^.exp, D(x^.decs, rho))
end {case}
; evals := evals + 1 { statistics }
end {eval};
procedure force { ( v :Value ) forwarded } ;
var fv :Value;
begin if v^.tag=deferval then
begin fv := eval( v^.e, v^.r ); v^ := fv^ {overwrite} end
end;
{ Evaluate an Expression. }
{ - L. Allison 9/2007 }
{Do not remove: Lazy.p, Strict.p, lazy.*.P, strict.*.P, lex.*.P, & syntax.*.P }
{ are released under Gnu `copyleft' General Public Licence (GPL) }
Bind adds a new binding to the environment.
It is called during the processing of declarations
and of function application.
Applyenv returns a variable's value.
It is only called by eval so it forces the variable's value.
function bind( x:alfa; val:Value; r:Env ):Env; { :Ide -> Value -> Env -> Env }
var p:Env;
begin new(p); envcells:=envcells+1;
with p^ do begin id:=x; v:=val; next:=r end;
bind:=p
end {bind};
function applyenv( r:Env; x:alfa ):Value; { :Env -> Ide -> Value }
begin LastId := x; {debugging}
if r=nil then error('undec id ')
else if r^.id=x then
begin force( r^.v ); {only called from eval}
applyenv := r^.v
end
else applyenv := applyenv( r^.next, x )
end {applyenv};
{ Build and Search Environment. }
A function is applied by
binding the actual parameter value to the formal parameter name
to form a new environment.
The body of the function is evaluated in this new environment.
Some type-checking is done to ensure that
it really is a function that is being applied.
If the formal parameter is empty `( )' a check
is made that the actual parameter is also empty.
function apply( fn, ap :Value ):Value; { apply a function fn to param ap }
{ apply : (Value->Value) -> Value -> Value }
begin if fn^.e^.fparam^.tag = emptycon then { (L().e)ap }
begin force(ap);
if ap^.tag = emptyval then apply := eval(fn^.e^.body, fn^.r)
else error('L().e exp ')
end
else apply := eval(fn^.e^.body, bind(fn^.e^.fparam^.id, ap, fn^.r))
end {apply};
{ Apply a Function to a Parameter. }
A declaration is processed much like a function application
(recall that `let x=e in f' is
equivalent to `(λ x.f)e')
and the declared name is bound to the defining value.
Note that this value is deferred.
If a group of declarations is recursive,
the environment used contains them also,
otherwise the enclosing environment is used.
function D( decs:tree; rho:Env ):Env; { D :Decs -> Env -> Env }
var localrho :Env;
function D2( decs :tree; local, global :Env ):Env;
begin if decs=nil then D2:=global
else D2:=bind(decs^.hd^.name, defer(decs^.hd^.val,local),
D2(decs^.tl, local, global))
end;
begin if decs=nil then D:=rho
else
begin if decs^.recursive then
begin localrho:=bind('-dummy----', nil, rho);
localrho^.next:=D2( decs, localrho, rho );
D:=localrho
end
else D:=D2( decs, rho, rho )
end
end {D};
{ Execute Declarations. }
A strict (eager, non-lazy) version of the interpreter
also exists and the two share many components.
For differences, see the
strict interpreter.
- Extend the functional language parser to permit
[a, b, c, ..., x] as a shorthand for a::b::c::...::x::nil
and to allow "string" as shorthand for a list of characters
['s','t','r','i','n','g'].
- Add a where clause to the language.
-
let [rec] <decs> in <Exp> = <Exp> where [rec] <decs>
-- LA 9/2007
{System dependent:} procedure setlinebuffering; external;
program functional(input, output);
label 99; {error failure; stop}
type alfa = packed array [1..10] of char;
#include "lex.type.P" {Lexical Types}
#include "syntax.type.P" {Syntactic Types}
var prog:tree;
#include "syntax.print.P" {Print a Parse Tree}
#include "syntax.P" {The Parser}
#include "lazy.exec.P" {The Interpreter}
begin setlinebuffering; {System dependent}
prog:=parser;
writeln; writeln(' --- end of parsing --- ');
printtree(prog); writeln; writeln(' --- running --- ');
execute(prog);
99:writeln; writeln(' --- finished --- ')
end.
{ Lazy Functional Language Interpreter, Main Program. }
{ L. Allison 9/2007 }
{Do not remove: Lazy.p, Strict.p, lazy.*.P, strict.*.P, lex.*.P, & syntax.*.P }
{ are released under Gnu `copyleft' General Public Licence (GPL) }
Main Program for Functional Language System.
Routines necessary to complete
the parser and interpreter follow.
procedure getch;
const tab = 9;
begin if eof then begin ch:='.'; theword:=' ' end
else {not eof} if eoln then
begin readln; writeln; ch:=' ';
lineno:=lineno+1; write(lineno:3, ': ')
end
else begin {not eof and not eoln} read(ch); write(ch);
if ord(ch)=tab then ch:=' '
end
end{getch};
procedure insymbol;
const blank=' ';
var len:integer;
begin repeat while ch=' ' do getch;
if ch='{' then { comment }
begin repeat getch
until (ch='}') or eof;
getch
end
until not( ch in [' ', '{'] );
if eof then sy:=eofsy
else if ch in ['a'..'z', 'A'..'Z'] then {xyz}
begin theword:=blank;
len:=0;
while ch in ['a'..'z', 'A'..'Z', '0'..'9'] do
begin len:=len+1;
if len<=10 then theword[len] := ch;
getch
end; {not ch in ['a'..'z', '0'..'9']}
if theword='hd ' then sy:=hdsy {not efficient}
else if theword='tl ' then sy:=tlsy
else if theword='lambda ' then sy:=lambdasy
else if theword='if ' then sy:=ifsy
else if theword='then ' then sy:=thensy
else if theword='else ' then sy:=elsesy
else if theword='let ' then sy:=letsy
else if theword='in ' then sy:=insy
else if theword='rec ' then sy:=recsy
else if theword='or ' then sy:=orsy
else if theword='and ' then sy:=andsy
else if theword='not ' then sy:=notsy
else if theword='nil ' then sy:=nilsy
else if theword='null ' then sy:=nullsy
else if theword='true ' then sy:=truesy
else if theword='false ' then sy:=falsesy
else sy:=word
end{alphanums}
else if ch in ['0'..'9'] then {123}
begin theint:=0;
while ch in ['0'..'9'] do
begin theint:=theint*10+ord(ch)-ord('0'); getch
end;
sy:=numeral
end
else if ch='''' then
begin getch;
theword:=blank; theword[1]:=ch; getch;
if ch='''' then { 'z' charliteral}
begin getch; sy:=charliteral end
else error('char lit ')
end
else if ch in ['=', '<', '>', '+', '-', '*', '/',
'.', ',', ':', '(', ')', '[', ']', '"' ] then
case ch of
'<': begin getch;
if ch='=' then begin getch; sy:=le end
else if ch='>' then begin getch; sy:=ne end
else sy:=lt
end;
'>': begin getch;
if ch='=' then begin getch; sy:=ge end
else sy:=gt
end;
'(': begin getch;
if ch=')' then begin getch; sy:=empty end
else sy:=open
end;
':': begin getch;
if ch=':' then begin getch; sy:=conssy end
else sy:=colon
end;
'=', '+', '-', '*', '/', '.', ',',
')', '[', ']', '"':
begin case ch of
'+': sy:=plus;
'-': sy:=minus;
'=': sy:=eq;
'*': sy:=times;
'/': sy:=over;
'.': sy:=dot;
',': sy:=comma;
'(': sy:=open; ')': sy:=close;
'[': sy:=sqopen; ']': sy:=sqclose;
'"': sy:=quote
end{case};
getch
end
end{case}
else error('bad symbol')
end{insymbol};
{ Lexical Analysis. }
{ - L. Allison 9/2007 }
{Do not remove: Lazy.p, Strict.p, lazy.*.P, strict.*.P, lex.*.P, & syntax.*.P }
{ are released under Gnu `copyleft' General Public Licence (GPL) }
function parser:tree;
const applicpriority=7;
var lineno :integer; { state vars for parser}
ch:char; sy:symbol; theword:alfa; theint:integer;
oprpriority:array[symbol]of integer;
startsexp, unoprs, binoprs, rightassoc :set of symbol;
sym :symbol;
function newnode(k:SyntaxClass):tree;
var p:tree;
begin new(p); p^.tag:=k; newnode:=p end;
procedure error(m:alfa);
begin writeln;
writeln('error:', m, ' lineno=', lineno:1,
' ch=<', ch, '>(', ord(ch):1, ') sy=', ord(sy):1,
' last word=<', theword, '>');
writeln; write('skip :');
while not eof do
if eoln then begin readln; writeln; write('skip :') end
else begin read(ch); write(ch) end;
goto 99 {error abort}
end{error};
#include "lex.insym.P" {Lexical Analysis Routines}
procedure check(s:symbol; m:alfa);
begin if sy=s then insymbol else error(m) end;
function syis(s:symbol):boolean;
begin if sy=s then begin syis:=true; insymbol end else syis:=false end;
function expression:tree; { --- parse an expression --- }
function param:tree;
var p:tree;
begin if sy=word then { lambda x .... }
begin p:=newnode(ident);
p^.id:=theword
end
else if sy=empty then { lambda () ... }
p:=newnode(emptycon)
else error('f param ');
insymbol;
param:=p
end;
function pdecs:tree; { [rec] , , ... in exp }
var d:tree;
isrec:boolean;
function cons( isrec:boolean; h,t:tree):tree;
var p:tree;
begin p:=newnode(declist); p^.recursive:=isrec;
p^.hd:=h; p^.tl:=t; cons:=p
end;
function pdeclist(isrec:boolean) :tree; { ,, ... }
var d:tree;
function pdec:tree; { = }
var d:tree;
begin if sy=word then
begin d:=newnode(decln);
d^.name:=theword; insymbol; check(eq,'= expected');
d^.val :=expression
end
else error('dec, no id');
pdec:=d
end{pdec};
begin {pdeclist dec, dec, ..., dec }
d:=pdec;
if syis(comma) then pdeclist:=cons(isrec,d,pdeclist(isrec))
else pdeclist:=cons(isrec,d,nil)
end{pdeclist};
begin {pdecs}
isrec:=syis(recsy); { [rec] pdeclist in exp }
d:=newnode(block);
d^.decs:=pdeclist(isrec);
check(insy, 'in expectd');
d^.exp := expression;
pdecs := d
end{pdecs};
function exp(priority:integer):tree;
var e, a :tree;
begin {exp}
if priority < applicpriority then
begin e := exp( priority+1 );
if (sy in binoprs*rightassoc)and(oprpriority[sy]=priority) then
begin a:=e; e:=newnode(binexp);
e^.binopr:=sy; insymbol;
e^.left:=a; e^.right:=exp(priority)
end
else
while (sy in binoprs-rightassoc)and(oprpriority[sy]=priority) do
begin a:=e; e:=newnode(binexp);
e^.binopr:=sy; insymbol;
e^.left:=a; e^.right:= exp(priority+1)
end
end
else if priority=applicpriority then {application f g h x}
begin e:=exp(priority+1);
while sy in startsexp - binoprs do {need () in f(-3)}
begin a:=e; e:=newnode(application);
e^.fun:=a; e^.aparam:=exp(priority+1)
end
end
else {operands}if sy in unoprs then
begin e:=newnode(unexp);
e^.unopr:=sy; insymbol;
e^.unarg:=exp(priority)
end
else if sy in startsexp then case sy of
word: begin e:=newnode(ident); e^.id:=theword; insymbol end;
numeral:begin e:=newnode(intcon); e^.n:=theint; insymbol end;
charliteral:begin e:=newnode(charcon); e^.ch:=theword[1]; insymbol end;
empty: begin insymbol; e:=newnode(emptycon) end;
nilsy: begin insymbol; e:=newnode(nilcon) end;
truesy: begin e:=newnode(boolcon); e^.b:=true; insymbol end;
falsesy:begin e:=newnode(boolcon); e^.b:=false; insymbol end;
open: begin insymbol; e:=expression; check(close,') expected') end;
letsy: begin insymbol; e:=pdecs end;
ifsy:begin insymbol; e:=newnode(ifexp);
e^.e1:=expression; check(thensy,'no then ');
e^.e2:=expression; check(elsesy,'no else ');
e^.e3:=expression
end;
lambdasy:begin insymbol; e:=newnode(lambdaexp);
e^.fparam:=param; check(dot,'. expected');
e^.body:=expression
end;
end{case}
else error('bad opernd');
exp:=e
end {exp};
begin{expression}
expression:=exp({priority=}1)
end{expression};
begin {parser}
unoprs := [minus, hdsy, tlsy, nullsy, notsy];
binoprs := [conssy..over];
rightassoc := [conssy];
startsexp := unoprs + [word..falsesy, open, letsy, ifsy, lambdasy];
for sym:=word to eofsy do oprpriority[sym]:=0;
oprpriority[conssy]:=1;
oprpriority[orsy]:=2; oprpriority[andsy]:=3;
for sym:=eq to ge do oprpriority[sym]:=4;
oprpriority[plus]:=5; oprpriority[minus]:=5;
oprpriority[times]:=6; oprpriority[over]:=6;
lineno := 1;
writeln(' Simple Functional Language L.A. Monash Comp Sci 10/2/87');
write(lineno:3, ': ');
ch:=' '; theword := '-start----'; theint:=maxint; insymbol;
parser := expression; {a program is a single expression}
check(eofsy, 'prog+junk ');
writeln
end{parser};
{ Parser for Functional Language. }
{ - L. Allison 9/2007 }
{Do not remove: Lazy.p, Strict.p, lazy.*.P, strict.*.P, lex.*.P, & syntax.*.P }
{ are released under Gnu `copyleft' General Public Licence (GPL) }
function mkvalue(t:ValueClass):Value;
var p:Value;
begin new(p); p^.tag:=t; mkvalue:=p
end;
function mkint(nn:integer):Value;
var p:Value;
begin new(p); p^.tag:=intval; p^.n:=nn; mkint:=p
end;
function mkbool(bb:boolean):Value;
var p:Value;
begin new(p); p^.tag:=boolval; p^.b:=bb; mkbool:=p
end;
function mkchar( cc:char ):Value;
var p:Value;
begin new(p); p^.tag:=charval; p^.ch:=cc; mkchar:=p
end;
function mkfunc( code:tree; rho:Env ):Value;
var p:Value;
begin new(p); with p^ do begin tag:=funcval; e:=code; r:=rho end; mkfunc:=p
end;
function defer(x:tree; rho:Env):Value; {form closure}
var p:Value;
begin new(p); with p^ do begin tag:=deferval; e:=x; r:=rho end; defer:=p
end {defer};
function cons( h, t :Value ):Value;
var p :Value;
begin new(p); with p^ do begin tag:=listval; hd:=h; tl:=t end; cons:=p
;conscells := conscells + 1 {statistics}
end;
{ Make Various Values. }
function U( opr:symbol; v:Value ):Value; { U :Value -> Value }
{PRE: v^.tag <> deferval}
begin case opr of
minus: if v^.tag=intval then U:=mkint(-v^.n)
else error('- non int ');
notsy: if v^.tag=boolval then U:=mkbool(not v^.b)
else error('not ~bool ');
hdsy: if v^.tag=listval then
begin force(v^.hd); U:=v^.hd end
else error('hd ~list ');
tlsy: if v^.tag=listval then
begin force(v^.tl); U:=v^.tl end
else error('tl ~list ');
nullsy:if v^.tag=listval then U:=mkbool(false)
else if v^.tag=nilval then U:=mkbool(true)
else error('null ~list')
end
end {U};
{ Execute Unary Operators }
function O( opr:symbol; v1, v2 :Value ):Value; { O :Value^2 -> Value }
var abs1, abs2, intAns :integer; boolAns :boolean;
begin case opr of
eq, ne, lt, le, gt, ge:
begin if [v1^.tag] * [v2^.tag] * [intval, boolval, charval] <> [] then
case v1^.tag of
intval: begin abs1:=v1^.n; abs2:=v2^.n end;
boolval: begin abs1:=ord(v1^.b); abs2:=ord(v2^.b) end;
charval: begin abs1:=ord(v1^.ch); abs2:=ord(v2^.ch) end
end
else error('rel ops ');
case opr of
eq: boolAns:=abs1= abs2; ne: boolAns:=abs1<>abs2;
le: boolAns:=abs1<=abs2; lt: boolAns:=abs1< abs2;
ge: boolAns:=abs1>=abs2; gt: boolAns:=abs1> abs2
end;
O:=mkbool(boolAns)
end;
plus, minus, times, over:
begin if [v1^.tag, v2^.tag] = [intval] then
case opr of
plus: intAns:=v1^.n + v2^.n;
minus: intAns:=v1^.n - v2^.n;
times: intAns:=v1^.n * v2^.n;
over: intAns:=v1^.n div v2^.n
end
else error('arith opr ');
O:=mkint(intAns)
end;
andsy, orsy:
begin if [v1^.tag, v2^.tag] = [boolval] then
case opr of
andsy: boolAns:=v1^.b and v2^.b;
orsy: boolAns:=v1^.b or v2^.b
end
else error('bool opr ');
O:=mkbool(boolAns)
end;
conssy: { deferred params } O:=cons(v1, v2)
end
end {O};
{ Execute Binary Operators. }
{ - L. Allison 9/2007 }
{Do not remove: Lazy.p, Strict.p, lazy.*.P, strict.*.P, lex.*.P, & syntax.*.P }
{ are released under Gnu `copyleft' General Public Licence (GPL) }
A strict (eager, non-lazy) version of the interpreter
also exists and the two share many components.
For differences, see the
strict interpreter.
|
|