Strict Interpreter

It is a useful exercise to compare the lazy interpreter with the strict interpreter. The two share many components, particularly the lexical and syntax analysers. Other parts differ in small but subtle ways.

Evaluation is print driven in the lazy interpreter but not so in the strict interpreter.

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');
      end
end {ShowValue};

{ Output Values. }

-- there is no option to deal with "deferred" values.

Apply here assumes that a parameter of a function has already been fully evaluated (and so does not need to force it):

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 }
            if ap^.tag = emptyval then apply := eval(fn^.e^.body, fn^.r)
            else error('L().e exp ')
      else apply := eval(fn^.e^.body, bind(fn^.e^.fparam^.id, ap, fn^.r))
end {apply};

{ Apply a Function to a Parameter. }

In the strict interpreter, eval fully evaluates a parameter before passing it to an operator or a function:

function eval { (x:tree; rho:Env) :Value   forwarded };
{ eval :Exp -> Env -> Value  Note: evaluates an Expression and returns a Value}
   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, eval(x^.aparam, rho))
                  else error('apply ~fn ')
            end;
         unexp:   eval:=U(x^.unopr, eval(x^.unarg, rho));
         binexp: eval:=O(x^.binopr, eval(x^.left,rho),         {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};

{ Evaluate an Expression Strictly. }

{Do not remove: Lazy.p, Strict.p, lazy.*.P, strict.*.P, lex.*.P, & syntax.*.P }
{ are released under Gnu `copyleft' General Public Licence (GPL)              }
{ - L. Allison, 2007 }

And exec prints an evaluated expression, rather than a deferred one.

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;

#include "strict.env.P"     { manipulate Environment }
#include "strict.D.P"       { Execute Declarations }
#include "strict.apply.P"   { Apply a Function }
#include "strict.U.P"       { Execute Unary Operators }
#include "lazy.O.P"       { Execute Binary Operators }
#include "strict.eval.P"    { eval an Expression }
#include "strict.show.P"    { Output Values }

begin{execute}
     evals := 0; envcells := 0; conscells := 0; {zero counters}
     LastId   := '-start-   ';
   ShowValue(eval(prog, {Env=}nil));  { Execution }
     writeln; write( evals, ' evals');
     write( envcells, ' env cells used, ');
     writeln( conscells, ' cells used')
end{execute};

{ Shell of Interpreter for Strict Functional Language. }

{Do not remove: Lazy.p, Strict.p, lazy.*.P, strict.*.P, lex.*.P, & syntax.*.P }
{ are released under Gnu `copyleft' General Public Licence (GPL)              }
{ - L. Allison, 2007 }

In processing a declaration in the strict interpreter, an identifier is bound to the value resulting from evaluating the right hand side of the declartion:

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, eval(decs^.hd^.val,local), {strict}
                       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 Strictly. }

All expressions have been evaluated before passing them to operators, so there is no need for any operator to force them.

function U( opr:symbol; v:Value ):Value;    { U :Value -> Value }
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
                U:=v^.hd
             else error('hd ~list  ');
      tlsy:  if v^.tag=listval then
                U:=v^.tl
             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 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
            applyenv := r^.v
      else applyenv := applyenv( r^.next, x )
end {applyenv};

{ Build and Search Environment. }