Appendix

(  # Semantic Interpreter, Dept. Computer Science U.W.A.  1983 #

   # L. Allison,  Programming Denotational Semantics II        #
   #   The Computer Journal, V28, No5, pp480-486, 1985         #

 mode alfa = [1:10] char;
 proc eq = (alfa x,y)bool:
    (loc bool b:=true; loc int i := lwb x;
    while b and i <= upb x do
       b:=x[i]=y[i]; i+:=1
    od;
    b
   );

 mode node = struct( ref node s1, s2, s3, ref alfa op, int i);
 mode tree = ref node;

# error and input routines omitted #

#--------------------------------------------------------------------#
                                                            # syntax #
proc program = tree:
begin
   # parse a program, body omitted #
end # program #;

#--------------------------------------------------------------------#
                                                        # semantics #
 mode value = int, location = int;
 mode anscell = struct(value v, ref anscell next);
 mode answer  = ref anscell;
 mode store = proc(location)value,
       env   = proc(alfa)location;
 mode cont  = proc(store)answer,
       kont  = proc(value,store)answer;
 mode pnv   = proc(alfa,cont,store)answer;
 mode dcont = proc(env,pnv,store)answer;

 value unbound = -max int, undefined value = -(max int -1);
 proc display = (answer s)void:
   if s isnt nil then
      print((newline, v of s)); display(next of s)
   fi;
 proc new = (store s)location:
 ( loc location l := 1;
   while s(l) /= unbound do
      l +:= 1
   od;
   l
 );


 # cc: cmd->(env x pnv)->cont->store->answer #
 proc cc = (tree cmd, env e, pnv p, cont c, store s)answer:
 begin


 # dd:dec->(env x pnv)->dcont->store->answer #
 proc dd = (tree dec, env e, pnv p, dcont dc, store s) answer:
 begin
   env new env = (alfa id) location:
      if  eq(op of dec,  id)  then  new(s)
      else e(id)
      fi;

   pnv new pnv = (alfa id, cont ret addr, store s)answer:
      if eq(id, op of s1 of dec) then
         cc( s2 of dec, e, new pnv #recursion!#, ret addr, s)
      else  p(id, ret addr, s)
      fi;

   dcont other decs = (env e, pnv p, store s)answer:
      dd(s2 of dec, e, p, dc, s);

   if dec is nil then dc(e, p, s)
   elif eq(op of dec, "var       ") then
      dd(s1 of dec, e, p, dc, s)
   elif eq(op of dec, "proc      ") then
      dc(e, new pnv, s)
   elif eq(op of dec, ",         ") then # dec1, dec2,  #
      dd( s1 of dec, e, p, other decs, s)
   else # var id #
      store new s = (location l)value:
         if l=new(s) then undefined value
         else s(l)
         fi;
      dc( new env, p, new s )
   fi
 end # dd #;


 # ee : exp->(env x pnv)->kont->store->answer #
 proc ee = (tree exp, env e, pnv p, kont k, store s)answer:
 begin
   kont rhs = (value v1, store s)answer:
    ( kont operator = (value v2, store s)answer:
         k((alfa opr = op of exp;
           if eq(opr,"=         ") then
               if v1=v2 then 1 else 0 fi
           elif eq(opr,"<>        ") then
               if v1/=v2 then 1 else 0 fi
           elif eq(opr,"<         ") then
               if v1<v2 then 1 else 0 fi
           elif eq(opr,"<=        ") then
               if v1<=v2 then 1 else 0 fi
           elif eq(opr,">         ") then
               if v1>v2 then 1 else 0 fi
           elif eq(opr,">=        ") then
               if v1>=v2 then 1 else 0 fi
           elif eq(opr,"+         ") then v1+v2
           elif eq(opr,"-         ") then v1-v2
           elif eq(opr,"*         ") then v1*v2
           else error(" undef operator in ee"); skip
           fi),
           s
          );

      ee(s2 of exp, e, p, operator, s)
    ) # rhs # ;

   if eq(op of exp, "-integer  ") then
      k(i of exp, s)
   elif (op of exp)[1]>="a" and (op of exp)[1]<="z"  then
      value v = s( e( op of exp ) );
      if v=undefined value then error(" undefined variable");skip
      else  k( v, s)
      fi
   else
      ee(s1 of exp, e, p, rhs, s)
   fi
 end # of ee #;

 # the body of cc(cmd,env,pnv,cont,store)answer #
   dcont stat part = (env e, pnv p, store s)answer:
      cc(s2 of cmd, e, p, c, s);

   kont cond = (value v, store s)answer:
      cc(if v=1 then s2 of cmd else s3 of cmd fi, e, p, c, s);

   cont again = (store s)answer:cc(cmd,e,p,c,s);
   kont loop  = (value v, store s)answer:
      if v=1 then cc(s2 of cmd, e, p, again, s) else c(s) fi;

   cont s2c = (store s)answer: cc(s2 of cmd, e, p, c, s);

   kont update = (value v, store s)answer:
      c( (location l)value:
               if l = e(op of s1 of cmd) then v else s(l) fi
       );

   kont do i o = (value v, store s)answer:
      heap anscell := (v, c(s));

   if cmd is nil then c(s)
   elif eq(op of cmd, "begin     ") then
      cc(s1 of cmd, e, p, c, s)
   elif eq(op of cmd, ";         ") then
      if eq(op of s1 of cmd, "var       ")
         or eq(op of s1 of cmd, "proc      ") then #dec; stats#
         dd(s1 of cmd, e, p, stat part, s)
      else  #  stat; statlist #
         cc(s1 of cmd, e, p, s2c, s)
      fi
   elif eq(op of cmd, "if        ") then
      ee(s1 of cmd, e, p, cond, s)
   elif eq(op of cmd, "while     ") then
      ee(s1 of cmd, e, p, loop, s)
   elif eq(op of cmd, ":=        ") then
      ee(s2 of cmd, e, p, update, s)
   elif eq(op of cmd, "output    ") then
      ee(s1 of cmd, e, p, do i o, s)
   else # identifier :  call on a proc #
      p(op of cmd, c, s)
   fi
 end # of cc #;
 #--------------------------------------------------------------------#

   display( cc( program ,
            (alfa id)location:(error(" undeclared id"); skip),
            (alfa id, cont ra, store s)answer:
               (error(" undeclared proc"); skip),
            (store s)answer:nil,
            (location l)value:unbound   ))
)

Also see [more (click)].