Index

SEMCD Machine

Werner Kluge's SEMCD machine is an abstract machine for the evaluation of the nameless λ-calculus. The Λ-terms can be evaluated with either a normal order or a applicative order reduction strategy until weak head normal form, i.e. the machine is weakly normalising.

SEMCD Machine Configuration

A machine configuration consists of four components:

The C stack holds the Λ-term that is being evaluated. Applications are deconstructed on this stack and depending on the reduction strategy either the arguments are pushed back onto the C stack for evaluation (applicative order) or moved directly to the E stack (normal order).

The environment stack, E, works in a similar fashion to the nested environments used in programming languages. Each argument is stored on E, either as part of a suspension which is an environment and term pair (in the normal order case), or as a single value (in the applicative order case). This mechanism implements a delayed substitution - when the argument variable is found in C, the environment is searched for the correct value or suspension.

When executing the term in the C stack, the machine needs to keep track of its progress. Application constructor symbols are pushed onto the M stack to acheive this. These constructors give the machine enough information to determine how to process the argument and operator in the C stack.

Finally, the dump, D, is used to store a continuation which tells the machine what to do when it has completed execution of the C stack.

SEMCD Machine Transition Rules

The SEMCD machine is an example of a transition system. The transition relation between configurations is →. It is defined by the rules given below.

The following conventions are used:

Rules

The rules are given in the order in which they are to be tried. As soon as one rule is found to be applicable it is used and all other rules discarded. This gives rules a certain priority which is needed as the transition system without them is not monogenic.

1a ⟨S, E, [], [db(i)|C], D⟩ → ⟨[e|S], E, [], C, D⟩ where e=lookup(i,E)
1b ⟨S, E, [ap(i)|M], [db(j)|C], D⟩ → ⟨[e|S], E, [ap(i-1)|M], C, D⟩ where i>0, e=lookup(j,E)
1c ⟨S, E, [], [var(v)|C], D⟩ → ⟨[var(v)|S], E, [], C, D⟩
1d ⟨S, E, [ap(i)|M], [var(v)|C], D⟩ → ⟨[var(v)|S], E, [ap(i-1)|M], C, D⟩ where i>0
3 ⟨S, E, [@(2)|M], [c|C], D⟩ → ⟨[susp(E,c)|S], E, [@(1)|M], C, D⟩
2a ⟨S, E, M, [@'(e1,e2)|C], D⟩ → ⟨S, E, [@'(2)|M], [e2,e1|C], D⟩
2b ⟨S, E, M, [@(e1,e2)|C], D⟩ → ⟨S, E, [@(2)|M], [e2,e1|C], D⟩
4a ⟨S, E, [], [Λ(e)|C], D⟩ → ⟨[susp(E,Λ(e))|S], E, [], C, D⟩
4b ⟨S, E, [ap(i)|M], [Λ(e)|C], D⟩ → ⟨[susp(E,Λ(e))|S], E, [ap(i-1)|M], C, D⟩ where i>0
5a ⟨[susp(E',Λ(e1)),e2|S], E, [ap(0)], C, D⟩ → ⟨S, [e2|E'], [], [e1], (E, [], C, D)⟩
5b ⟨[susp(E',Λ(e1)),e2|S], E, [ap(0),ap(i)|M], C, D⟩ → ⟨S, [e2|E'], [], [e1], (E, [ap(i-1)|M], C, D)⟩ where i>0
6 ⟨[susp(E', e)|S], E, M, C, D⟩ → ⟨S, E', [], [e], (E, M, C, D)⟩ where e=irredicible_ap(e1,e2)
7a ⟨[e1,e2|S], E, [@'(0)], C, D⟩ → ⟨[irreducible_@'(e2,e1)|S], E, [], C, D⟩
7b ⟨[e1,e2|S], E, [@'(0),ap(i)|M], C, D⟩ → ⟨[irreducible_@'(e2,e1)|S], E, [ap(i-1)|M], C, D⟩
8a ⟨[e1,e2|S], E, [@(0)], C, D⟩ → ⟨[irreducible_@(e1,e2)|S], E, [], C, D⟩
8b ⟨[e1,e2|S], E, [@'(0),ap(i)|M], C, D⟩ → ⟨[irreducible_@(e1,e2)|S], E, [ap(i-1)|M], C, D⟩
9 ⟨S, E, [], [], (E', M', C', D')⟩ → ⟨S, E', M', C', D'⟩

A closer look at the rules follows:

1a. Move environment entries to the stack.

1a ⟨S, E, [], [db(i)|C], D⟩ → ⟨[e|S], E, [], C, D⟩ where e=lookup(i,E)

If we have a de Bruijn number on C and M is empty, then look up the variable in E and push the found value onto S.

1b. Move environment entries to the stack.

1b ⟨S, E, [ap(i)|M], [db(j)|C], D⟩ → ⟨[e|S], E, [ap(i-1)|M], C, D⟩ where i>0, e=lookup(j,E)

If we have a de Bruijn number on C and M is not empty (it contains a numbered applicator), then look up the variable in E and push the found value onto S then decrement the applicator.

1c. Move variables to the stack.

1c ⟨S, E, [], [var(v)|C], D⟩ → ⟨[var(v)|S], E, [], C, D⟩

If we have an unbound variable on C and M is empty, then push the variable onto S.

1d. Move variables to the stack.

1d ⟨S, E, [ap(i)|M], [var(v)|C], D⟩ → ⟨[var(v)|S], E, [ap(i-1)|M], C, D⟩ where i>0

If we have an unbound variable on C and a numbered applicator on M, then push the variable onto S and decrement the applicator.

3. Make a suspension for the operand to a normal order application.

3 ⟨S, E, [@(2)|M], [c|C], D⟩ → ⟨[susp(E,c)|S], E, [@(1)|M], C, D⟩

Build the argument suspension, push it onto S then decrement the index of the normal order applicator on M, i.e., set it to 1. Why has this been placed above 2a and 2b? Try this to see why: 

      
	(normal-apply (lambda x z) ((lambda w (w w)) (lambda w (w w))))

2a. Split applications into their components.

2a ⟨S, E, M, [@'(e1,e2)|C], D⟩ → ⟨S, E, [@'(2)|M], [e2,e1|C], D⟩

If we have an applicative applicator on top of C, then pop it off C and push a numbered applicative order applicator onto M with index 2.

2b. Split applications into their components.

2b ⟨S, E, M, [@(e1,e2)|C], D⟩ → ⟨S, E, [@(2)|M], [e2,e1|C], D⟩

If we have a normal applicator on top of C, then pop it off C and push a numbered normal order applicator onto M with index 2.

4a. Create a suspension for an abstraction.

4a ⟨S, E, [], [Λ(e)|C], D⟩ → ⟨[susp(E,Λ(e))|S], E, [], C, D⟩

If M is empty and we have an abstraction on top of C, then create a suspension and push it onto S.

4b. Create a suspension for an abstraction.

4b ⟨S, E, [ap(i)|M], [Λ(e)|C], D⟩ → ⟨[susp(E,Λ(e))|S], E, [ap(i-1)|M], C, D⟩ where i>0

If the top of M is an applicator and the top of C is an abstraction, then create a suspension, push this suspension onto S, and decrement the applicator index.

5a. Naive beta reduction.

5a ⟨[susp(E',Λ(e1)),e2|S], E, [ap(0)], C, D⟩ → ⟨S, [e2|E'], [], [e1], (E, [], C, D)⟩

If there is a suspension then an argument on top of S and a single applicator with index 0 on M, then do the reduction, push the continuation onto D, pop M, set E and C to the contents of the suspension and add the argument to E.

5b. Naive beta reduction.

5b ⟨[susp(E',Λ(e1)),e2|S], E, [ap(0),ap(i)|M], C, D⟩ → ⟨S, [e2|E'], [], [e1], (E, [ap(i-1)|M], C, D)⟩ where i>0

If there is a suspension then an argument on top of S, and two applicators on M (the top one having index 0), then do the reduction, push the continuation onto D, pop M and decrement the applicator which is now on top on M, set E and C to the contents of the suspension and add the argument to E.

6. Operand suspensions.

6 ⟨[susp(E', e)|S], E, M, C, D⟩ → ⟨S, E', [], [e], (E, M, C, D)⟩ where e=irredicible_ap(e1,e2)

Take the suspension on top of S and evaluate it.

7a. Irreducible applicative applications.

7a ⟨[e1,e2|S], E, [@'(0)], C, D⟩ → ⟨[irreducible_@'(e2,e1)|S], E, [], C, D⟩

If the top of M is a single applicative applicator of index 0, then the top of the S cannot be reduced so it must be an irreducible application. Build such a irreducible application and remove the top applicator on M.

7b. Irreducible applicative applications.

7b ⟨[e1,e2|S], E, [@'(0),ap(i)|M], C, D⟩ → ⟨[irreducible_@'(e2,e1)|S], E, [ap(i-1)|M], C, D⟩

If the top of M is a single applicative applicator of index 0 with an applicator under it, then the top of the S cannot be reduced so it must be an irreducible application. Build such a irreducible application and remove the top applicator on M and decrement the new top applicator.

8a. Irreducible normal applications.

8a ⟨[e1,e2|S], E, [@(0)], C, D⟩ → ⟨[irreducible_@(e1,e2)|S], E, [], C, D⟩

If the top of M is a single normal applicator of index 0, then the top of the S cannot be reduced so it must be an irreducible application. Build such a irreducible application and remove the top applicator on M.

8b. Irreducible normal applications.

8b ⟨[e1,e2|S], E, [@(0),ap(i)|M], C, D⟩ → ⟨[irreducible_@(e1,e2)|S], E, [ap(i-1)|M], C, D⟩

If the top of M is a single anormal applicator of index 0 with an applicator under it, then the top of the S cannot be reduced so it must be an irreducible application. Build such a irreducible application and remove the top applicator on M and decrement the new top applicator.

9. Continue.

9. ⟨S, E, [], [], (E', M', C', D')⟩ → ⟨S, E', M', C', D'⟩

The code stack, C, is empty so we retrieve the continuation from D and continue from there.

Implementation

The following is an implementation of the SEMCD machine and a compiler which generates machine instructions. The code is written in my own dialect of Lisp but it should be easy to port this to Lisp or Scheme.

Global Switches

There is only one global switch which is used to turn debug trace messages on or off. 

;;;
;;; 	This is a switch which will turn on debug printouts showing the state of the machine.
;;;
(set! *semcd-debug* nil)

Basic Library

These are simple but useful functions not specific to the SEMCD machine. 

;;;   
;;;	Return the parameters as a list.
;;;
(set! list 
      (lambda lst lst))

;;;
;;; Predicate to test for the empty list.
;;;
(set! null 
      (lambda (lst) 
	(eq nil lst)))

;;;
;;; The empty list will also be considered to be the 
;;; value "false". So, we can have (not B) = (null B).
;;;
(set! not null)

Environment

The run-time environment is a list of values. This list is searched with SEMCD-lookup and it is extended with SEMCD-extend-env. 

	
(set! SEMCD-lookup 
      (lambda (i env)
	(if (= 0 i)
	    (car env)
	    (SEMCD-lookup (- i 1) (cdr env)))))

(set! SEMCD-extend-env cons)

Machine Stack Manipulation

The rest of the code will use the following functions to manipulate the machine stacks. 

	
;;; Predicate to test for an empty stack.
(set! SEMCD-empty-stack-p null)

;;; Push an element onto a stack.
(set! SEMCD-stack-push cons)

;;; Remove the element at the top of the stack
(set! SEMCD-stack-remove-top cdr)

;;; Retrieve the element at the top of the stack.
(set! SEMCD-stack-top car)

Code

The code is just a list of instructions: (Instr1 Instr2 Instr3 .... InstrN)

Each instruction is an expression tree which is described by the following constructor grammar where v is a variable, and i is an integer. 

t ::= (SEMCD-variable v)
   |   (SEMCD-de-bruijn i)
   |   (SEMCD-lambda t)
   |   (SEMCD-normal-applicator t t)
   |   (SEMCD-applicative-applicator t t)
   |   (SEMCD-suspension t)
   |   (SEMCD-irreducible-application t t)

The numbered applicators are used internally and they control the preorder transversal of the terms of the form (SEMCD-normal-applicator t t) and (SEMCD-applicative-applicator t t). These are only found on the M stack. 

;;; Retrieve the next instruction from the code stream.
(set! SEMCD-next-instruction car)

;;; Remove the next instruction from the code stream.
;;; You could see this as "incrementing" an instruction
;;; pointer.
(set! SEMCD-remove-instruction cdr)

Machine State

A machine configuration, or state, looks like this: (S E M C D)

Getter and setter functions are provided to construct and deconstruct a machine state. 

;;;
;;; We need this constant to build an initial state. 
;;;
(set! SEMCD-empty-state (list nil nil nil nil nil))

;;;
;;; Getter and setter for S (stack) which is the
;;; first element of the machine state.
;;;
(set! SEMCD-get-S car)

(set! SEMCD-set-S 
      (lambda (state new-S)
	(rplaca state new-S)
	state))

;;;
;;; Getter and setter for E (environment) which is the
;;; second element of the machine state.
;;;
(set! SEMCD-get-E
      (lambda (state)
	(car (cdr state))))

(set! SEMCD-set-E 
      (lambda (state new-E)
	(rplaca (cdr state) new-E)
	state))

;;;
;;; Getter and setter for M (applicator store) which is the
;;; third element of the machine state.
;;;
(set! SEMCD-get-M 
      (lambda (state)
	(car (cdr (cdr state)))))

(set! SEMCD-set-M 
      (lambda (state new-M)
	(rplaca (cdr (cdr state)) new-M)
	state))

;;;
;;; Getter and setter for C (code) which is the
;;; fourth element of the machine state.
;;;
(set! SEMCD-get-C 
      (lambda (state)
	(car (cdr (cdr (cdr state))))))

(set! SEMCD-set-C 
      (lambda (state new-C)
	(rplaca (cdr (cdr (cdr state))) new-C)
	state))

;;;
;;; Getter and setter for D (dump) which is the
;;; fifth element of the machine state.
;;;
(set! SEMCD-get-D 
      (lambda (state)
	(car (cdr (cdr (cdr (cdr state)))))))

(set! SEMCD-set-D 
      (lambda (state new-D)
	(rplaca (cdr (cdr (cdr (cdr state)))) new-D)
	state))

Data Types

The various data types and their constructors, recognisers, and destructors are given here: 

;;;
;;; The variable data type.
;;;  SEMCD-make-variable : the constructor
;;;  SEMCD-variable-p    : recogniser predicate
;;;  SEMCD-get-variable  : the deconstructor
;;;
(set! SEMCD-make-variable 
      (lambda (v)
	(cons 'SEMCD-variable v)))

(set! SEMCD-variable-p 
      (lambda (v)
	(and (consp v)
	     (eq (car v) 
		 'SEMCD-variable))))

(set! SEMCD-get-variable cdr)

;;;
;;; The deBruijn number data type.
;;;  SEMCD-make-de-bruijn : the constructor
;;;  SEMCD-de-bruijn-p    : recogniser predicate
;;;  SEMCD-get-de-bruijn  : the deconstructor
;;;
;;; A de Bruijn number is a bound variable reference.
;;; The number is the address of the variable which is
;;; an index into the run time environment.
;;;
(set! SEMCD-make-de-bruijn 
      (lambda (v)
	(cons 'SEMCD-de-bruijn v)))

(set! SEMCD-de-bruijn-p 
      (lambda (v)
	(and (consp v)
	     (eq (car v) 
		 'SEMCD-de-bruijn))))

(set! SEMCD-get-de-bruijn cdr)

;;;
;;; Some constants that can be compared with
;;; eq
;;;
(set! SEMCD-applicative-applicator 
      (cons "applicative" "applicator"))

(set! SEMCD-normal-applicator 
      (cons "normal" "applicator"))

;;;
;;; The normal-applicator data type.
;;;  SEMCD-make-normal-applicator         : the constructor
;;;  SEMCD-normal-applicator-p            : recogniser predicate
;;;  SEMCD-get-normal-applicator-operand  : a deconstructor
;;;  SEMCD-get-normal-applicator-operator : a deconstructor
;;;
(set! SEMCD-make-normal-applicator 
      (lambda (operator operand)
	(list SEMCD-normal-applicator 
	      operator 
	      operand)))

(set! SEMCD-normal-applicator-p 
      (lambda (v)
	(and (consp v)
	     (eq (car v) 
		 SEMCD-normal-applicator))))

(set! SEMCD-get-normal-applicator-operator
      (lambda (v)
	(car (cdr v))))

(set! SEMCD-get-normal-applicator-operand
      (lambda (v)
	(car (cdr (cdr v)))))
;;;
;;; The applicative-applicator data type.
;;;  SEMCD-make-applicative-applicator         : the constructor
;;;  SEMCD-applicative-applicator              : recogniser predicate
;;;  SEMCD-get-applicative-applicator-operator : a deconstructor
;;;  SEMCD-get-applicative-applicator-operand  : a deconstructor
;;;
(set! SEMCD-make-applicative-applicator 
      (lambda (operator operand)
	(list SEMCD-applicative-applicator 
	      operator 
	      operand)))

(set! SEMCD-applicative-applicator-p 
      (lambda (v)
	(and (consp v)
	     (eq (car v) 
		 SEMCD-applicative-applicator))))

(set! SEMCD-get-applicative-applicator-operator
      (lambda (v)
	(car (cdr v))))

(set! SEMCD-get-applicative-applicator-operand
      (lambda (v)
	(car (cdr (cdr v)))))

;;;
;;; A helper function.
;;;
(set! SEMCD-applicator-p 
      (lambda (v)
	(or (SEMCD-normal-applicator-p v)
	    (SEMCD-applicative-applicator-p v))))

;;;
;;; The numbered applicator data type. This is a pair
;;; (applicator * number).
;;;  SEMCD-make-numbered-applicator           : the constructor
;;;  SEMCD-numbered-applicator-p              : recogniser predicate
;;;  SEMCD-get-numbered-applicator-applicator : a deconstructor
;;;  SEMCD-get-numbered-applicator-number     : a deconstructor
;;;
(set! SEMCD-make-numbered-applicator cons)

(set! SEMCD-numbered-applicator-p 
      (lambda (v)
	(and (consp v)
	     (let ((type 
		    (SEMCD-get-numbered-applicator-applicator v)))
	       (or 
		(eq type SEMCD-applicative-applicator)
		(eq type SEMCD-normal-applicator))))))

(set! SEMCD-get-numbered-applicator-applicator car)

(set! SEMCD-get-numbered-applicator-number cdr)

;;;
;;; The anonymous lambda data type.
;;;  SEMCD-make-lambda : the constructor
;;;  SEMCD-lambda-p    : recogniser predicate
;;;  SEMCD-get-lambda  : the deconstructor
;;;
(set! SEMCD-make-lambda 
      (lambda (exp)
	(cons 'SEMCD-lambda exp)))

(set! SEMCD-lambda-p 
      (lambda (v)
	(and (consp v)
	     (eq (car v) 
		 'SEMCD-lambda))))

(set! SEMCD-get-lambda-exp cdr)

;;;
;;; The suspension data type. This is a pair
;;; (env * exp).
;;;  SEMCD-make-suspension    : the constructor
;;;  SEMCD-suspension-p       : recogniser predicate
;;;  SEMCD-get-suspension-env : a deconstructor
;;;  SEMCD-get-suspension-exp : a deconstructor
;;;
(set! SEMCD-make-suspension 
      (lambda (env exp)
	(list 'SEMCD-suspension 
	      env 
	      exp)))

(set! SEMCD-suspension-p 
      (lambda (v)
	(and (consp v)
	     (eq (car v) 
		 'SEMCD-suspension))))

(set! SEMCD-get-suspension-env 
      (lambda (v)
	(car (cdr v))))

(set! SEMCD-get-suspension-exp 
      (lambda (v)
	(car (cdr (cdr v)))))


;;;
;;; The irreducible applicator data type.
;;;  SEMCD-make-irreducible-applicator : the constructor
;;;  SEMCD-irreducible-applicaton-p    : recogniser predicate
;;;
(set! SEMCD-make-irreducible-application 
      (lambda (app operator operand)
	(list 'SEMCD-irreducible-application 
	      app 
	      operator 
	      operand)))

(set! SEMCD-irreducible-application-p 
      (lambda (v)
	(and (consp v)
	     (eq (car v) 
		 'SEMCD-irreducible-application))))

The transition function

Here we have the transition function which drives the SEMCD machine. The transitions are defined in the errata to the book "Abstract Computing Machines" by Werner Kluge (Springer). This is a pretty faithful implementation using a tail recursive function which just recurses/loops until it cannot transition any more. This will happen when the machine stacks E, M, C, and D are empty, or, if no transition can be made and E, M, C, or D are not empty which is an error.

Some rules (1c & 1d) have been added by myself. Rule 3 has its priority raised above rules 2a & 2b so that we can handle normal order applications which have applications as their operands. Should rules 2a or 2b be tried before rule 3 then you'll see that the operand gets evaluated which is NOT what you want! 

;;;
;;; See the transition function for the reasons the
;;; "handle" functions are called.
;;;
(set! SEMCD-handle-1a 
      (lambda (state)
	(if *semcd-debug* (print "state 1a"))
	(SEMCD-set-S state 
		     (SEMCD-stack-push 
		      (SEMCD-lookup 
		       (SEMCD-get-de-bruijn 
			(SEMCD-next-instruction 
			 (SEMCD-get-C state)))
		       (SEMCD-get-E state))
		      (SEMCD-get-S state)))
            ;;; remove the instruction
	(SEMCD-set-C state 
		     (SEMCD-remove-instruction 
		      (SEMCD-get-C state)))
            ;;; continue execution
	(SEMCD-transition state)))

(set! SEMCD-handle-1b
      (lambda (state)
	(if *semcd-debug* (print "state 1b"))
	   ;;; push the lookup result onto S
	(SEMCD-set-S state
		     (SEMCD-stack-push 
		      (SEMCD-lookup 
		       (SEMCD-get-de-bruijn 
			(SEMCD-next-instruction 
			 (SEMCD-get-C state)))
		       (SEMCD-get-E state))
		      (SEMCD-get-S state)))
	   ;;; decrement the applicator
	(let ((app (SEMCD-stack-top
		    (SEMCD-get-M state))))
	  (SEMCD-set-M state 
		       (SEMCD-stack-remove-top 
			(SEMCD-get-M state)))
	  (SEMCD-set-M state
		       (SEMCD-stack-push 
			(SEMCD-make-numbered-applicator  
			 (SEMCD-get-numbered-applicator-applicator app)
			 (- 
			  (SEMCD-get-numbered-applicator-number app)
			  1))
			(SEMCD-get-M state))))
	   ;;; remove the instruction
	(SEMCD-set-C state 
		     (SEMCD-remove-instruction 
		      (SEMCD-get-C state)))
           ;;; continue execution
	(SEMCD-transition state)))

(set! SEMCD-handle-1c
      (lambda (state)
	(if *semcd-debug* (print "state 1c"))
            ;;; push
	(SEMCD-set-S state 
		     (SEMCD-stack-push 
		      (SEMCD-next-instruction 
		       (SEMCD-get-C state))
		      (SEMCD-get-S state)))
	    ;;; remove the instruction
	(SEMCD-set-C state
		     (SEMCD-remove-instruction 
		      (SEMCD-get-C state)))
            ;;; continue execution
	(SEMCD-transition state)))

(set! SEMCD-handle-1d
      (lambda (state)
	(if *semcd-debug* (print "state 1d"))
	   ;;; push
	(SEMCD-set-S state
		     (SEMCD-stack-push 
		      (SEMCD-next-instruction 
		       (SEMCD-get-C state))
		      (SEMCD-get-S state)))
	   ;;; decrement the applicator
	(let ((app (SEMCD-stack-top 
		    (SEMCD-get-M state))))
	  (SEMCD-set-M state 
		       (SEMCD-stack-remove-top 
			(SEMCD-get-M state)))
	  (SEMCD-set-M state 
		       (SEMCD-stack-push 
			(SEMCD-make-numbered-applicator  
			 (SEMCD-get-numbered-applicator-applicator app)
			 (- 
			  (SEMCD-get-numbered-applicator-number app) 
			  1))
			(SEMCD-get-M state))))
	   ;;; remove the instruction
	(SEMCD-set-C state 
		     (SEMCD-remove-instruction 
		      (SEMCD-get-C state)))
           ;;; continue execution
	(SEMCD-transition state)))
	  	  
(set! SEMCD-handle-2a 
      (lambda (state)
	(if *semcd-debug* (print "state 2a"))	
	(let ((instr (SEMCD-next-instruction 
		      (SEMCD-get-C state))))
	
	  (SEMCD-set-C state 
		       (SEMCD-remove-instruction 
			(SEMCD-get-C state)))

	  (SEMCD-set-C state
		       (SEMCD-stack-push 
			(SEMCD-get-applicative-applicator-operator instr)
			(SEMCD-get-C state)))

	  (SEMCD-set-C state
		       (SEMCD-stack-push 
			(SEMCD-get-applicative-applicator-operand instr)
			(SEMCD-get-C state))))
	
	(SEMCD-set-M state 
		     (SEMCD-stack-push 
		      (SEMCD-make-numbered-applicator  
		       SEMCD-applicative-applicator
		       2)
		       (SEMCD-get-M state)))
	
        ;;; continue execution
	(SEMCD-transition state)))

(set! SEMCD-handle-2b
      (lambda (state)
	(if *semcd-debug* (print "state 2b"))	   
	(let ((instr (SEMCD-next-instruction 
		      (SEMCD-get-C state))))
	
	  (SEMCD-set-C state 
		       (SEMCD-remove-instruction 
			(SEMCD-get-C state)))

	  (SEMCD-set-C state
		       (SEMCD-stack-push 
			(SEMCD-get-normal-applicator-operator instr)
			(SEMCD-get-C state)))

	  (SEMCD-set-C state
		       (SEMCD-stack-push 
			(SEMCD-get-normal-applicator-operand instr)
			(SEMCD-get-C state))))
	
	(SEMCD-set-M state 
		     (SEMCD-stack-push 
		      (SEMCD-make-numbered-applicator  
		       SEMCD-normal-applicator
		       2)
		       (SEMCD-get-M state)))
	
        ;;; continue execution
	(SEMCD-transition state)))

(set! SEMCD-handle-3 
      (lambda (state)
	(if *semcd-debug* (print "state 3"))
	   ;;; remove the numbered applicator
	(SEMCD-set-M state 
		     (SEMCD-stack-remove-top 
		      (SEMCD-get-M state)))
	   ;;; add the numbered applicator to M
	(SEMCD-set-M state 
		     (SEMCD-stack-push 
		      (SEMCD-make-numbered-applicator  
		       SEMCD-normal-applicator
		       1)
		      (SEMCD-get-M state)))
	   ;;; push the suspension made from the top of C
	(SEMCD-set-S state 
		     (SEMCD-stack-push 
		      (SEMCD-make-suspension
		       (SEMCD-get-E state)
		       (SEMCD-next-instruction 
			(SEMCD-get-C state)))
		      (SEMCD-get-S state)))	   
	   ;;; setup the next instruction
	(SEMCD-set-C state 
		     (SEMCD-remove-instruction 
		      (SEMCD-get-C state)))
           ;;; continue execution
	(SEMCD-transition state)))
      
(set! SEMCD-handle-4a 
      (lambda (state)
	(if *semcd-debug* (print "state 4a"))	   
	(SEMCD-set-S state 
		     (SEMCD-stack-push 
		      (SEMCD-make-suspension
		       (SEMCD-get-E state)
		       (SEMCD-next-instruction 
			(SEMCD-get-C state)))
		      (SEMCD-get-S state)))
	   ;;; setup the next instruction
	(SEMCD-set-C state 
		     (SEMCD-remove-instruction 
		      (SEMCD-get-C state)))
           ;;; continue execution
	(SEMCD-transition state)))

(set! SEMCD-handle-4b
      (lambda (state)
	(if *semcd-debug* (print "state 4b"))
	(SEMCD-set-S state 
		     (SEMCD-stack-push 
		      (SEMCD-make-suspension
		       (SEMCD-get-E state)
		       (SEMCD-next-instruction 
			(SEMCD-get-C state)))
		      (SEMCD-get-S state)))	   
	   ;;; decrement the applicator
	(let ((app (SEMCD-stack-top 
		    (SEMCD-get-M state))))
	  (SEMCD-set-M state 
		       (SEMCD-stack-remove-top 
			(SEMCD-get-M state)))
	  (SEMCD-set-M state 
		       (SEMCD-stack-push 
			(SEMCD-make-numbered-applicator  
			 (SEMCD-get-numbered-applicator-applicator app)
			 (- 
			  (SEMCD-get-numbered-applicator-number app) 
			  1))
			(SEMCD-get-M state))))	   
	   ;;; setup the next instruction
	(SEMCD-set-C state 
		     (SEMCD-remove-instruction 
		      (SEMCD-get-C state)))
           ;;; continue execution
	(SEMCD-transition state)))

(set! SEMCD-handle-5ab
      (lambda (state)
	(if *semcd-debug* (print "state 5a/b"))
	(let ((ebody nil)
	      (env nil)
	      (earg nil))
	     ;;; the closure is on the top of S
	  (set! ebody (SEMCD-get-lambda-exp 
		       (SEMCD-get-suspension-exp 
			(SEMCD-stack-top 
			 (SEMCD-get-S state)))))
	  (set! env (SEMCD-get-suspension-env 
		     (SEMCD-stack-top 
		      (SEMCD-get-S state))))
	  (SEMCD-set-S state 
		       (SEMCD-stack-remove-top 
			(SEMCD-get-S state)))
	     ;;; the argument was under the closure
	  (set! earg (SEMCD-stack-top 
		      (SEMCD-get-S state)))
	  (SEMCD-set-S state 
		       (SEMCD-stack-remove-top 
			(SEMCD-get-S state)))
	     ;;; pop the applicator with index 0
	  (SEMCD-set-M state 
		       (SEMCD-stack-remove-top 
			(SEMCD-get-M state)))
	     ;;; decrement any applicator which is on top of M
	  (if (and (SEMCD-numbered-applicator-p 
		    (SEMCD-stack-top 
		     (SEMCD-get-M state)))
		   (> (SEMCD-get-numbered-applicator-number 
		       (SEMCD-stack-top 
			(SEMCD-get-M state))) 
		      0))
	      (let ((app (SEMCD-stack-top (SEMCD-get-M state))))
		(SEMCD-set-M state 
			     (SEMCD-stack-remove-top 
			      (SEMCD-get-M state)))
		(SEMCD-set-M state 
			     (SEMCD-stack-push 
			      (SEMCD-make-numbered-applicator  
			       (SEMCD-get-numbered-applicator-applicator app)
			       (- 
				(SEMCD-get-numbered-applicator-number app) 
				1))
			      (SEMCD-get-M state)))))
	     ;;; push the continuation on to D
	  (SEMCD-set-D state 
		       (SEMCD-stack-push 
			(list 
			 (SEMCD-get-E state)
			 (SEMCD-get-M state)
			 (SEMCD-get-C state)
			 (SEMCD-get-D state))
			(SEMCD-get-D state)))
	     ;;; set E to the continuation environment.
	  (SEMCD-set-E state 
		       env)
	     ;;; add the argument on to the front of E
	  (SEMCD-set-E state 
		       (SEMCD-stack-push earg 
					 (SEMCD-get-E state)))
	     ;;; clear M 
	  (SEMCD-set-M state nil)
	     ;;; set C to the closure code
	  (SEMCD-set-C state (SEMCD-stack-push ebody nil)))
	   ;;; continue execution with the closure code
	(SEMCD-transition state)))


(set! SEMCD-handle-6
      (lambda (state)
	(if *semcd-debug* (print "state 6"))
	(let ((exp nil)
	      (env nil))
	  (set! exp (SEMCD-get-suspension-exp 
		     (SEMCD-stack-top 
		      (SEMCD-get-S state))))
	  (set! env (SEMCD-get-suspension-env 
		     (SEMCD-stack-top 
		      (SEMCD-get-S state))))
	  (SEMCD-set-S state 
		       (SEMCD-stack-remove-top 
			(SEMCD-get-S state)))
	  
	  (SEMCD-set-D state 
		       (SEMCD-stack-push 
			(list 
			 (SEMCD-get-E state)
			 (SEMCD-get-M state)
			 (SEMCD-get-C state)
			 (SEMCD-get-D state))
			(SEMCD-get-D state)))			     
	  (SEMCD-set-E state env)
	  (SEMCD-set-M state nil)
	  (SEMCD-set-C state exp))			     
           ;;; continue execution
	(SEMCD-transition state)))

(set! SEMCD-handle-7ab 
      (lambda (state)
	(if *semcd-debug* (print "state 7a/b"))
	   ;;; On S we see operator then operand.
	(let ((operator nil)
	      (operand nil))
	  (set! operator (SEMCD-stack-top 
			  (SEMCD-get-S state)))
	  (SEMCD-set-S state
		       (SEMCD-stack-remove-top 
			(SEMCD-get-S state)))
	  (set! operand (SEMCD-stack-top 
			 (SEMCD-get-S state)))
	  (SEMCD-set-S state
		       (SEMCD-stack-remove-top 
			(SEMCD-get-S state)))
	     ;;; make then push the 
             ;;; irreducible application onto S
	  (SEMCD-set-S state
		       (SEMCD-stack-push 
			(SEMCD-make-irreducible-application 
			 (SEMCD-stack-top 
			  (SEMCD-get-M state))
			 operator
			 operand)
			(SEMCD-get-S state))) )
	   ;;; pop the applicator off M
	(SEMCD-set-M state
		     (SEMCD-stack-remove-top 
		      (SEMCD-get-M state)))
	   ;;; decrement the index of any applicate under the one
	   ;;; we just popped off M
	(if (and (SEMCD-numbered-applicator-p 
		  (SEMCD-stack-top 
		   (SEMCD-get-M state)))
		 (> (SEMCD-get-numbered-applicator-number
		     (SEMCD-stack-top 
		      (SEMCD-get-M state))) 
		    0))
	    (let ((app (SEMCD-stack-top (SEMCD-get-M state))))
	      (SEMCD-set-M state
			   (SEMCD-stack-remove-top 
			    (SEMCD-get-M state)))
	      (SEMCD-set-M state
			   (SEMCD-stack-push 
			    (SEMCD-make-numbered-applicator  
			     (SEMCD-get-numbered-applicator-applicator app)
			     (-
			      (SEMCD-get-numbered-applicator-number app)
			      1))
			    (SEMCD-get-M state)))))
           ;;; continue execution
	(SEMCD-transition state)))

(set! SEMCD-handle-8ab 
      (lambda (state)	
	(if *semcd-debug* (print "state 8a/b"))
	   ;;; operator on top of operand
	(let ((operator nil)
	      (operand nil))
	  (set! operator (SEMCD-stack-top 
			  (SEMCD-get-S state)))
	  (SEMCD-set-S state
		       (SEMCD-stack-remove-top 
			(SEMCD-get-S state)))
	  (set! operand (SEMCD-stack-top 
			 (SEMCD-get-S state)))
	  (SEMCD-set-S state 
		       (SEMCD-stack-remove-top 
			(SEMCD-get-S state)))
	  (SEMCD-set-S state 
		       (SEMCD-stack-push 
			(SEMCD-make-irreducible-application 
			 (SEMCD-stack-top 
			  (SEMCD-get-M state))
			 operator
			 operand)
			(SEMCD-get-S state))) )			     
	   ;;; pop the top applicator off M
	(SEMCD-set-M state 
		     (SEMCD-stack-remove-top 
		      (SEMCD-get-M state)))
	   ;;; decrement the index of any applicator underneath the
	   ;;; one we just popped off M
	(if (and (SEMCD-numbered-applicator-p 
		  (SEMCD-stack-top 
		   (SEMCD-get-M state)))
		 (eq SEMCD-normal-applicator 
		     (SEMCD-get-numbered-applicator-applicator 
		      (SEMCD-stack-top 
		       (SEMCD-get-M state))))
		 (> (SEMCD-get-numbered-applicator-number 
		     (SEMCD-stack-top 
		      (SEMCD-get-M state))) 
		    0))
	    (let ((app (SEMCD-stack-top 
			(SEMCD-get-M state))))
	      (SEMCD-set-M state
			   (SEMCD-stack-remove-top 
			    (SEMCD-get-M state)))
	      (SEMCD-set-M state
			   (SEMCD-stack-push 
			    (SEMCD-make-numbered-applicator  
			     (SEMCD-get-numbered-applicator-applicator app)
			     (- 
			      (SEMCD-get-numbered-applicator-number app) 
			      1))
			    (SEMCD-get-M state)))))	   
           ;;; continue execution
	(SEMCD-transition state)))

(set! SEMCD-handle-9
      (lambda (state)
	(if *semcd-debug* (print "state 9"))
	(SEMCD-set-E state 
		     (SEMCD-get-E 
		      (SEMCD-get-D state)))
	(SEMCD-set-M state 
		     (SEMCD-get-M
		      (SEMCD-get-D state)))
	(SEMCD-set-C state
		     (SEMCD-get-C
		      (SEMCD-get-D state)))
	(SEMCD-set-D state 
		     (SEMCD-get-D
		      (SEMCD-get-D state)))
           ;;; continue execution
	(SEMCD-transition state)))

;;;
;;; The heart of the machine.
;;;	  	        
(set! SEMCD-transition 
      (lambda (state)
	(if *semcd-debug*
	    (begin
	     (print '============)
	     (print (SEMCD-get-S state))
	     (print (SEMCD-get-E state))
	     (print (SEMCD-get-M state))
	     (print (SEMCD-get-C state))
	     (print (SEMCD-get-D state))))
	(cond 	  
	  ;;;
	  ;;; 1a. Move environment entries to the stack.
          ;;;
          ;;; We've got a de Bruijn number on C and M is
          ;;; empty. Let's lookup the variable in E and
          ;;; push the bound value onto S.
	  ;;;
	  ((and (SEMCD-empty-stack-p
		 (SEMCD-get-M state))
		(SEMCD-de-bruijn-p 
		 (SEMCD-next-instruction 
		  (SEMCD-get-C state))))
	   (SEMCD-handle-1a state))
	  
	  ;;;
	  ;;; 1b. Move environment entries to the stack.
          ;;;
          ;;; We've got a de Bruijn number on the code
          ;;; stack and M is not empty - it contains a 
          ;;; numbered applicator so let's lookup the
          ;;; variable address and push the bound value
          ;;; onto S then decrement the applicator.
	  ;;;
	  ((and (SEMCD-numbered-applicator-p 
		 (SEMCD-stack-top 
		  (SEMCD-get-M state)))
		(> (SEMCD-get-numbered-applicator-number 
		    (SEMCD-stack-top 
		     (SEMCD-get-M state))) 
		   0)
		(SEMCD-de-bruijn-p 
		 (SEMCD-next-instruction 
		  (SEMCD-get-C state))))
	   (SEMCD-handle-1b state))
	  	  
          ;;;
          ;;; 1c. Move vars to the stack
          ;;;
          ;;; We've got an unbound  variable on C and 
          ;;; M is empty. Just push the variable
	  ;;; onto S.
          ;;;
	  ((and (SEMCD-empty-stack-p
		 (SEMCD-get-M state))
		(SEMCD-variable-p 
		 (SEMCD-next-instruction 
		  (SEMCD-get-C state))))
	   (SEMCD-handle-1c state))
	  
	  ;;;
	  ;;; 1d. Move vars to the stack
	  ;;;
          ;;; We've got an unbound variable on C and 
          ;;; a numbered applicator (i > 0) on M. We'll
          ;;; push the variable onto S and decrement the
          ;;; applicator.
          ;;;
	  ((and (SEMCD-numbered-applicator-p 
		 (SEMCD-stack-top 
		  (SEMCD-get-M state)))
		(> (SEMCD-get-numbered-applicator-number 
		    (SEMCD-stack-top 
		     (SEMCD-get-M state))) 
		   0)
		(SEMCD-variable-p 
		 (SEMCD-next-instruction 
		  (SEMCD-get-C state))))
	   (SEMCD-handle-1d state))

	  ;;;
	  ;;; 3. make a suspension for the operand to a normal order application
	  ;;;
	  ;;; Build the argument suspension, push it onto S then decrement the
	  ;;; index of the normal order applicator on M, i.e., set it to 1.
	  ;;;
          ;;; Why has this been placed above 2a and 2b? Try this to see why:
	  ;;; (normal-apply (lambda x z) ((lambda w (w w)) (lambda w (w w)))) 
          
	  ((and (SEMCD-numbered-applicator-p (SEMCD-stack-top 
					      (SEMCD-get-M state)))
		(eq SEMCD-normal-applicator  
		    (SEMCD-get-numbered-applicator-applicator 
		     (SEMCD-stack-top 		   
		      (SEMCD-get-M state))))
		(= 2 (SEMCD-get-numbered-applicator-number 
		      (SEMCD-stack-top 
		       (SEMCD-get-M state)))))
	   (SEMCD-handle-3 state))
	  
          ;;;
          ;;; 2a. split applications into their components
	  ;;;
          ;;; We've got an applicative applicator on top of C.
          ;;; Pop it off C and push a numbered applicative order
	  ;;; applicator onto M with index 2.
	  ;;;
	  ((SEMCD-applicative-applicator-p (SEMCD-next-instruction 
					    (SEMCD-get-C state)))			   
	   (SEMCD-handle-2a state))

	  ;;;
          ;;; 2b. split applications into their components
	  ;;;
          ;;; We've got a normal applicator on top of C.
          ;;; Pop it off C and push a numbered normal order
	  ;;; applicator onto M with index 2.
	  ;;;
	  ((SEMCD-normal-applicator-p (SEMCD-next-instruction 
				       (SEMCD-get-C state)))			   
	   (SEMCD-handle-2b state))
	  
	  
	  ;;;
	  ;;; 4a. create a suspension for an abstraction
	  ;;;
	  ;;; M is empty and we've got a lamabda on top of C.
	  ;;; Create a closure and push it onto S.
	  ;;;
	  ((and (SEMCD-empty-stack-p (SEMCD-get-M state))
		(SEMCD-lambda-p (SEMCD-next-instruction 
				 (SEMCD-get-C state))))
	   (SEMCD-handle-4a state))
	  
	  ;;;
	  ;;; 4b. create a suspension for an abstraction
	  ;;;
	  ;;; The top of M is an applicator with index. 
	  ;;; The top of C is a lambda. Create a closure.
	  ;;; Push the closure onto S and decrement the 
	  ;;; applicator index.
	  ((and (SEMCD-numbered-applicator-p (SEMCD-stack-top 
					      (SEMCD-get-M state)))
		(> (SEMCD-get-numbered-applicator-number 
		    (SEMCD-stack-top 
		     (SEMCD-get-M state))) 
		   0)
		(SEMCD-lambda-p (SEMCD-next-instruction 
				 (SEMCD-get-C state))))
	   (SEMCD-handle-4b state))
	  
	  ;;;
	  ;;; 5a/b. implement naive beta reduction
	  ;;;
          ;;; There is a closure then an argument on top of S.
	  ;;; If there is a single applicator with index 0 on M,
	  ;;; Do the reduction. Push the continuation onto D.
	  ;;; Set E and C to the contents of the closure and 
	  ;;; add the argument to E. If there are two applicators
	  ;;; on M (the top one having index 0) then do the same as
	  ;;; in the case with one applicator on M but remember to 
	  ;;; decrement the applicator under it.
	  ;;;
	  ((and (SEMCD-suspension-p (SEMCD-stack-top 
				     (SEMCD-get-S state)))
		(SEMCD-lambda-p (SEMCD-get-suspension-exp 
				 (SEMCD-stack-top 
				  (SEMCD-get-S state))))
		(SEMCD-numbered-applicator-p (SEMCD-next-instruction 
					      (SEMCD-get-M state)))
		(= 0 
		   (SEMCD-get-numbered-applicator-number 
		    (SEMCD-next-instruction 
		     (SEMCD-get-M state)))))
	   (SEMCD-handle-5ab state))
	  
	  ;;;
	  ;;; 6. Operand closures
	  ;;;
          ;;; Take the closure on top of S and evaluate it. This was put on
	  ;;; S by step 3.
	  ;;;
	  ((and (SEMCD-suspension-p (SEMCD-stack-top 
				     (SEMCD-get-S state)))
		(SEMCD-irreducible-application-p (SEMCD-get-suspension-exp 
						  (SEMCD-stack-top 
						   (SEMCD-get-S state)))))
	   (SEMCD-handle-6 state))
	  
	  ;;;
	  ;;; 7a/b. irreducible applicative applications
	  ;;;
	  ;;; The top of M is either a single applicative applicator of index 0, or
	  ;;; an applicator of index 0 with an applicative applicator under it.
	  ;;; The top of the stack cannot be reduced so it must be an irreducible
	  ;;; application. So build it and remove the top applicator on M and
	  ;;; if there was an applicator under it, decrement its index.
	  ;;;
	  ((and (SEMCD-numbered-applicator-p 
		 (SEMCD-stack-top 
		  (SEMCD-get-M state)))
		(eq SEMCD-applicative-applicator
		    (SEMCD-get-numbered-applicator-applicator 
		     (SEMCD-stack-top 
		      (SEMCD-get-M state))))
		(= 0 
		   (SEMCD-get-numbered-applicator-number 
		    (SEMCD-stack-top 
		     (SEMCD-get-M state)))))
	   (SEMCD-handle-7ab state))

	  ;;;
	  ;;; 8a/b. irreducible normal applications
	  ;;;
	  ;;; The top of M is either a single normal applicator of index 0, or
	  ;;; an applicator of index 0 with an normal applicator under it.
	  ;;; The top of the stack cannot be reduced so it must be an irreducible
	  ;;; application. So build it and remove the top applicator on M and
	  ;;; if there was an applicator under it, decrement its index.
	  ;;;
	  ((and (SEMCD-numbered-applicator-p (SEMCD-stack-top 
					      (SEMCD-get-M state)))
		(eq SEMCD-normal-applicator 
		    (SEMCD-get-numbered-applicator-applicator 
		     (SEMCD-stack-top (SEMCD-get-M state))))
		(= 0 
		   (SEMCD-get-numbered-applicator-number 
		    (SEMCD-stack-top 
		     (SEMCD-get-M state)))))
	   (SEMCD-handle-8ab state))	

	  ;;;
	  ;;; 9. The code (C) is empty so we retrieve the 
          ;;; continuation from D and continue from there.
	  ;;;
	  ((and (SEMCD-empty-stack-p (SEMCD-get-M state))
		(SEMCD-empty-stack-p (SEMCD-get-C state))
		(not (SEMCD-empty-stack-p (SEMCD-get-D state))))
	   (SEMCD-handle-9 state))
	  
	  ;;;
	  ;;; Finish. E, M, C, and D are empty and the result
          ;;; of the computation is on the top of S.
	  ;;;
	  ((and (SEMCD-empty-stack-p (SEMCD-get-E state))
		(SEMCD-empty-stack-p (SEMCD-get-M state))
		(SEMCD-empty-stack-p (SEMCD-get-C state))
		(SEMCD-empty-stack-p (SEMCD-get-D state)))
	   (if *semcd-debug* (print "state FINISH"))
           ;;; return the result of the computation
	   (SEMCD-stack-top (SEMCD-get-S state)))
	  
	  ;;;
	  ;;; Otherwise, we've got an error!
	  ;;;
	  (t (signal-exception t 
			       (list 
				"No transition possible" 
				state))))))

Expression Compiler

The following functions will translate a λ-expression described by the following grammar where v is a variable and c is a constant (number, string, etc.) 

e ::= v
  |   c
  |   (e e)
  |   (normal-apply e e)
  |   (lambda v e)

into the input the SEMCD machine expects. The normal-apply symbol is used to tell the compiler to generate code to force a normal order application of the arguments, so ((lambda x x) (lambda y y)) is an applicative order application, and (normal-apply (lambda x x) (lambda y y)) is the normal order application of the same operator and argument. The compiler is an example of a simple recursive descent compiler. 

(set! SEMCD-compile-exp 
      (lambda (e rho)
	(if (atom e) 
	    (if (symbolp e) 
		(SEMCD-compile-variable e rho)
		(SEMCD-compile-quote e rho))
	    (cond ((eq (car e) 'lambda) 
		   (SEMCD-compile-lambda (cadr e) (caddr e) rho))
		  ((eq (car e) 'normal-apply) 
		   (SEMCD-compile-normal-application (cadr e) (caddr e) rho))
		  (t (SEMCD-compile-applicative-application (car e) (cadr e) rho))))))

;;;
;;; A variable will be either a de Bruijn number(/index/address) 
;;; if it is bound, or an unbound variable in the form
;;; (SEMCD-variable v).
;;;
(set! SEMCD-compile-variable 
      (lambda (v r)
	(let ((dbn (SEMCD-rho-lookup v r 0)))
	  (if dbn 
	      (SEMCD-make-de-bruijn dbn)
	      (SEMCD-make-variable v)))))

;;;
;;; In this sense "quote" is really those things that are
;;; "autoquote", i.e., numbers, strings, etc.
;;;
(set! SEMCD-compile-quote 
      (lambda (e r)
	e))

;;;
;;; To compile an abstraction we need to collect the
;;; argument variable and then use it to extend the 
;;; static environment which will be used to compile
;;; the abstraction body.
;;;
(set! SEMCD-compile-lambda 
      (lambda (name body rho)
	(if (not (symbolp name))
	    (signal-exception t 
			      (list "Oooops lambda param is not a symbol - " 
				    name))
	    (SEMCD-make-lambda 
	     (SEMCD-compile-exp body 
				(SEMCD-extend-rho name rho))))))

;;;
;;; Build an application. Simple stuff, just 
;;; build the node from the operator and 
;;; operand experessions.
;;;
(set! SEMCD-compile-applicative-application 
      (lambda (operator operand rho)
	(SEMCD-make-applicative-applicator
	 (SEMCD-compile-exp operator rho)
	 (SEMCD-compile-exp operand rho))))

;;;
;;; Pretty much the same as above only the
;;; constructor has been changed.
;;;
(set! SEMCD-compile-normal-application 
      (lambda (operator operand rho)
	(SEMCD-make-normal-applicator
	 (SEMCD-compile-exp operator rho)
	 (SEMCD-compile-exp operand rho))))

Static Environment

These functions are used by the expression compiler to help it generate de Bruijn numbers. The static environment is extended with SEMCD-extend-rho and SEMCD-rho-lookup is used to get the number/index/address. 

;;; 
;;; Search the environment for the given name.
;;; Return the name's index in the environment if
;;; it is to be found there, otherwise return nil.
;;; The function is written in accumulator passing
;;; tail recursive style in order to make it run
;;; in constant stack space. That's why the "number"
;;; is there.
;;;
(set! SEMCD-rho-lookup 
      (lambda (name rho number)
	(cond ((null rho) nil)
	      ((eq name (car rho)) number)
	      (t (SEMCD-rho-lookup name 
				   (cdr rho) 
				   (+ 1 number))))))
;;;
;;; Extend the static environment by adding a new name.
;;;
(set! SEMCD-extend-rho cons)

Top-level

Here we have a simple user interface for the compiler and SEMCD machine. We ask for input, collect it, compile it, then evaluate it with an initialised machine. 

(let ((state SEMCD-empty-state))
  (set! SEMCD-test 
	(lambda ()
	  (print 'ready>)
	  (SEMCD-set-S state nil)
	  (SEMCD-set-E state nil)
	  (SEMCD-set-M state nil)
	  (SEMCD-set-D state nil)
	  (SEMCD-set-C state 
		       (cons (SEMCD-compile-exp (read) 
						nil) 
			     nil))
	  (print (SEMCD-transition  state))
	  (SEMCD-test))))

;;; GO!!!!
(semcd-test)

Test

A test run is shown below 

	
READY>
(lambda x x)
(SEMCD-SUSPENSION NIL (SEMCD-LAMBDA SEMCD-DE-BRUIJN . 0))
READY>
((lambda x x) (lambda y y))
(SEMCD-SUSPENSION NIL (SEMCD-LAMBDA SEMCD-DE-BRUIJN . 0))
READY>
(lambda x (lambda y x))
(SEMCD-SUSPENSION NIL (SEMCD-LAMBDA SEMCD-LAMBDA SEMCD-DE-BRUIJN . 1))

References

W. Kluge. Abstract Computing Machines. A Lambda Calculus Perspective. Springer, 2005.

Index

Copyright © 2015 Barry Watson. All rights reserved.