## λ Calculus Interpreter (Lazy).

 LA home Computing FP  λ-calculus   Intro.   Examples   Syntax   Interp.(L)   Interp.(S)   Interp.(L)    #Parser    #Exec.    #Ex.    #Appndx Also see:   Prolog

The (lazy) λ calculus interpreter consists of a simple parser, execution routines (eval, force) and a few supporting routines.

### Parser.

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. }

```

### Execution.

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}

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-   ';
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.

### Exercises

1. 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'].

2. Add a where clause to the language.
let [rec] <decs> in <Exp> = <Exp> where [rec] <decs>
-- LA 9/2007

### Appendix.

```
{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
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}

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
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}

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.