Lambda the Ultimate

Awesome - I definitely would not have found that book if you had not recommended it :D

This is OT, but I think it might be helpful for people to find out about the book if you could give it a nice review - http://www.amazon.com/Abstract-Computing-Machines-Werner-Kluge/dp/3540211462/ref=sr_1_1?ie=UTF8&qid=1346088681&sr=8-1&keywords=abstract+computing+machines . Maybe there's also a social media site for bringing visibility to these types of books? Be great for the author to see some more sales for his hard work!

Mr. Kluge seems to be retired. I am reading this, which seems to summarize some of his work.

Reading the paper turns out to be a puzzling experience.

Bootstrapping the Hi compiler, I needed a lambda expression reducer. I looked at SECD, found it too complex, and implemented a reduction machine which employs a single stack.

No idea what I did, how it relates to SECD, but it was sufficient to bootstrap. I hoped that by reading the paper I would gain some insight into what I did, but still have no idea.

When selfcompiling the code, I switched to a combinator reduction machine in which I compile all combinators to C code.

No idea what I did, how it relates to the G-machine, or the PABC machine, but it is sufficient to self compile all code. I hoped that by reading the paper I would gain some insight into what I did, but I still have no idea.

Clueless really, but it seems that the solution space for lambda reducers is that big that you can roll out your own, and still have no idea what you're doing.

Then again, this paper ends with the comment: "Both the fn secd-machine and the fn se(m)cd-machine have been tested with the same set of about 25 example λ-expressions, all of which include in various contexts unapplied abstractions that require η-extension. Both machines have been found to reduce these expressions correctly to full normal forms. Of course, this is no proof that they work correctly for all Λ-expressions but it raises the level of confidence considerably." I guess most people are handwavingly trying to understand these machines.

Thanks for pointing me towards such an interesting book.

Out of interest, how did you go about implementing the machines?

I implemented the machines in my own little lisp dialect - basically scheme with exceptions.

Here's the B machine with a compiler to give you an idea of what an implementation of one of the book's machines might look like (he gives enough detail for you to build your own). When given the input

(lambda (x) ((lambda (y) y)(lambda (z) z)))

it gives the output

((LAM . 2) (VAR . 0))

which is basically

(lambda (x z) z)

which means that it beta reduced under the lambda, i.e., the B machine is fully normalising.

;;; -*- mode:lisp -*-
;;; b.edea
;;; Copyright (c) 2010 Barry Watson
;;;
;;; Berkling's graph reducing instruction machine, a.k.a.
;;; the B-machine.
;;;
;;; An implementation of Berkling's machine as described
;;; in Werner Kluge's book "Abstract Computing Machines,
;;; A Lambda Calculus Perspective".
;;;

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

;******************************************************
;***                                                ***
;*                 Basic library funcs                *
;***                                                ***
;******************************************************
;;;
;;; 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)

;******************************************************
;***                                                ***
;*         Machine state manipulation funcs           *
;*                                                    *
;* The B machine is a 7-tuple:                        *
;*                                                    *
;* E   : Holds the environment * ULC pair             *
;* F   : Forward code.                                *
;* B   : Backwards code.                              *
;* S   : Stack.                                       *
;* H   : Heap.                                        *
;* D   : Dump.                                        *
;* dir : Direction of execution.                      *
;*                                                    *
;***                                                ***
;******************************************************
;;; Predicate to test for an empty stack.
(set! B-empty-stack-p null)

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

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

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

;;; What an empty stack looks like.
(set! B-empty-stack nil)

;;; Other empties
(set! B-empty-code nil)
(set! B-empty-heap nil)
(set! B-empty-dump nil)
(set! B-empty-environment 
      (lambda ()
	(B-make-E nil 0)))

;;;
;;; We need this to build an initial state -
;;; a fresh one every time it is called. 
;;;
(set! B-empty-state 
      (lambda ()
	(list (B-empty-environment)
	      B-empty-code
	      B-empty-code
	      B-empty-stack
	      B-empty-heap
	      B-empty-dump
	      B-forward-direction)))
      
;;;
;;; Getter and setter for E which is the
;;; first element of the machine state.
;;;
(set! B-get-E car)

(set! B-set-E 
      (lambda (state new-E)
	(rplaca state new-E)
	state))

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

(set! B-set-F 
      (lambda (state new-F)
	(rplaca (cdr state) new-F)
	state))

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

(set! B-set-B 
      (lambda (state new-B)
	(rplaca (cdr (cdr state)) new-B)
	state))

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

(set! B-set-S 
      (lambda (state new-S)
	(rplaca (cdr (cdr (cdr state))) new-S)
	state))

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

(set! B-set-H 
      (lambda (state new-H)
	(rplaca (cdr (cdr (cdr (cdr state)))) new-H)
	state))

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

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

;;;
;;; Getter and setter for dir which is the
;;; seventh element of the machine state.
;;;
(set! B-get-dir
      (lambda (state)
	(car (cdr (cdr (cdr (cdr (cdr (cdr state)))))))))

(set! B-set-dir 
      (lambda (state new-dir)
	(rplaca (cdr (cdr (cdr (cdr (cdr (cdr state)))))) new-dir)
	state))

;;;
;;; The E register data type. This is a pair
;;; (env * ulc). "ulc" is the unapplied lambda count.
;;;  B-make-E    : the constructor
;;;  B-get-E-env : a deconstructor
;;;  B-get-E-ulc : a deconstructor
;;;
;;; E can also be "irrelevent".
;;;
(set! B-make-E 
      (lambda (env ulc)
	(list 'B-E 
	      env 
	      ulc)))

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

(set! B-get-E-env 
      (lambda (v)
	(car (cdr v))))

(set! B-get-E-ulc 
      (lambda (v)
	(car (cdr (cdr v)))))

(set! B-irrelevent (cons 'B 'irrelevent))

(set! B-irrelevent-p 
      (lambda (v)
	(eq v B-irrelevent)))

;;;
;;; The machine direction is either forward, backward,
;;; or done
;;;
(set! B-forward-direction (cons 'B 'forward-direction))

(set! B-forward-direction-p 
      (lambda (v)
	(eq v B-forward-direction)))

(set! B-backward-direction (cons 'B 'backward-direction))

(set! B-backward-direction-p 
      (lambda (v)
	(eq v B-backward-direction)))

(set! B-done-direction (cons 'B 'done-direction))

(set! B-done-direction-p 
      (lambda (v)
	(eq v B-done-direction)))

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

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

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

(set! B-get-suspension-tail 
      (lambda (v)
	(car (cdr (cdr v)))))

;;;
;;; The frame data type. This is a 4-tuple
;;; (n * u * env * entries).
;;;  B-make-frame        : the constructor
;;;  B-frame-p           : recogniser predicate
;;;  B-get-frame-n       : a deconstructor
;;;  B-get-frame-u       : a deconstructor
;;;  B-get-frame-env     : a deconstructor
;;;  B-get-frame-entries : a deconstructor

;;;
(set! B-make-frame 
      (lambda (n u env entries)
	(list 'B-frame
	      n
	      u
	      env
	      entries)))

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

(set! B-get-frame-n
      (lambda (v)
	(car (cdr v))))

(set! B-get-frame-u 
      (lambda (v)
	(car (cdr (cdr v)))))

(set! B-get-frame-env 
      (lambda (v)
	(car (cdr (cdr (cdr v))))))

(set! B-get-frame-entries 
      (lambda (v)
	(car (cdr (cdr (cdr (cdr v)))))))


;******************************************************
;***                                                ***
;*                                                    *
;*                   Instructions                     *
;*   AP p                                             *
;*   LAM n                                            *
;*   VAR i                                            *
;*   RTHNF p (internal)                               *
;*                                                    *
;***                                                ***
;******************************************************
;;;
;;; The ap instruction.
;;;  B-make-ap-instruction         : the constructor
;;;  B-ap-instruction-p            : recogniser predicate
;;;  B-get-ap-instruction-operand  : the deconstructor
;;;
(set! B-make-ap-instruction 
      (lambda (operand)
	(cons 'ap operand)))

(set! B-ap-instruction-p 
      (lambda (v)
	(and (consp v)
	     (eq (car v) 
		 'ap))))

(set! B-get-ap-instruction-operand cdr)

;;;
;;; The lam instruction.
;;;  B-make-lam-instruction         : the constructor
;;;  B-lam-instruction-p            : recogniser predicate
;;;  B-get-lam-instruction-operand  : the deconstructor
;;;
(set! B-make-lam-instruction 
      (lambda (operand)
	(cons 'lam operand)))

(set! B-lam-instruction-p 
      (lambda (v)
	(and (consp v)
	     (eq (car v) 
		 'lam))))

(set! B-get-lam-instruction-operand cdr)

;;;
;;; The var instruction.
;;;  B-make-var-instruction         : the constructor
;;;  B-var-instruction-p            : recogniser predicate
;;;  B-get-var-instruction-operand  : the deconstructor
;;;
(set! B-make-var-instruction 
      (lambda (operand)
	(cons 'var operand)))

(set! B-var-instruction-p 
      (lambda (v)
	(and (consp v)
	     (eq (car v) 
		 'var))))

(set! B-get-var-instruction-operand cdr)

;;;
;;; The rthnf instruction.
;;;  B-make-rthnf-instruction         : the constructor
;;;  B-rthnf-instruction-p            : recogniser predicate
;;;  B-get-rthnf-instruction-operand  : the deconstructor
;;;
(set! B-make-rthnf-instruction 
      (lambda (operand)
	(cons 'rthnf  operand)))

(set! B-rthnf-instruction-p 
      (lambda (v)
	(and (consp v)
	     (eq (car v) 
		 'rthnf))))

(set! B-get-rthnf-instruction-operand cdr)

;;;
;;; Get the nth element of a list.
;;;
(set! B-nth 
      (lambda (lst n)
	(cond ((null lst) nil)
	      ((= 0 n) (car lst))
	      (t (B-nth (cdr lst) (- n 1))))))

;;;
;;; Frame lookup
;;;
(set! B-lookup 
      (lambda (i env)
	(cond ((null env) (signal-exception t (list "Bad De Bruijn index")))
	      ((not (B-frame-p env)) (signal-exception t (list "Not a frame" env)))
	      ((> i (B-get-frame-n env)) (B-lookup (- i (B-get-frame-n env)) (B-get-frame-env env)))
	      (t (B-nth (B-get-frame-entries env) i)))))
	

;;;
;;; Build a list from n down to m, e.g., (n n-1 n-2 .... m+1 m)
;;;
(set! B-from-downto
      (lambda (from downto)
	(cond ((= from downto) (cons downto nil))
	      (t (cons from (B-from-downto (- from 1) downto))))))

(set! B-susp-to-code 
      (lambda (susp code)
	(rplaca susp (car code))
	(rplacd susp (cdr code))))

;******************************************************
;***                                                ***
;*              The transition function               *
;*                                                    *
;* The heart of the machine.                          *
;*	  	                                      *
;***                                                ***
;******************************************************
(set! B-transition 
      (lambda (state)
	(if *B-debug*
	    (begin
	     (print '===============)
	     (print (B-get-E state))
	     (print (B-get-F state))
	     (print (B-get-B state))
	     (print (B-get-S state))
	     (print (B-get-H state))
	     (print (B-get-D state))
	     (print (B-get-dir state))))
	(cond 	  
	  ;;;
          ;;; State 1 - make a suspension from a tail going down 
	  ;;;
	  ((and (B-forward-direction-p (B-get-dir state))  
		(consp (B-get-F state))
		(consp (car (B-get-F state)))
		(B-ap-instruction-p (car (B-get-F state))))
	   (if *B-debug* (print 'state1))
	   (let* ((p (B-get-ap-instruction-operand (car (B-get-F state))))
		  (pp (B-make-suspension (B-get-E state) p)))
	     (B-set-F state (cdr (B-get-F state)))
	     (B-set-B state (cons (B-make-ap-instruction pp)(B-get-B state))))
	   (B-transition state))

	  ;;;
          ;;; State 2a - make a suspension from a tail going down 
	  ;;;
	  ((and (B-forward-direction-p (B-get-dir state))  
		(consp (B-get-F state))
		(consp (car (B-get-F state)))
		(B-lam-instruction-p (car (B-get-F state)))
		(> (B-get-lam-instruction-operand (car (B-get-F state))) 0)
		(consp (B-get-B state))
		(B-ap-instruction-p (car (B-get-B state))))
	   (if *B-debug* (print 'state2a))
	   (let ((n (B-get-lam-instruction-operand (car (B-get-F state))))
		 (pp (B-get-lam-instruction-operand (car (B-get-B state)))))
	     (B-set-F state (cdr (B-get-F state)))
	     (B-set-F state (cons (B-make-lam-instruction (- n 1)) (B-get-F state)))
	     (B-set-B state (cdr (B-get-B state)))
	     (B-set-S state (cons pp (B-get-S state))))
	   (B-transition state))

	  ;;;
          ;;; State 2b - make a environment frame from the stack 
	  ;;;
	  ((and (B-forward-direction-p (B-get-dir state))  
		(consp (B-get-F state))
		(consp (car (B-get-F state)))
		(B-lam-instruction-p (car (B-get-F state)))
		(= (B-get-lam-instruction-operand (car (B-get-F state))) 0))
	   (if *B-debug* (print 'state2b))
	   (let* ((m (length (B-get-S state)))
		  (p (B-get-E-env (B-get-E state)))
		  (u (B-get-E-ulc (B-get-E state)))
		  (pp (B-make-frame m u p (B-get-S state)))
		  (new-E (B-make-E pp u)))
	     (B-set-F state (cdr (B-get-F state)))
	     (B-set-E state new-E)
	     (B-set-S state B-empty-stack))
	   (B-transition state))

	  ;;;
          ;;; State 3a - initialise an eta extension 
	  ;;;
	  ((and (B-forward-direction-p (B-get-dir state))  
		(consp (B-get-F state))
		(consp (car (B-get-F state)))
		(B-lam-instruction-p (car (B-get-F state)))
		(null (B-get-B state)))
	   (if *B-debug* (print 'state3a))
	   (B-set-B state (cons (B-make-lam-instruction 0) (B-get-B state)))
	   (B-transition state))

	  ;;;
          ;;; State 3b - eta extension 
	  ;;;
	  ((and (B-forward-direction-p (B-get-dir state))  
		(consp (B-get-F state))
		(consp (car (B-get-F state)))
		(B-lam-instruction-p (car (B-get-F state)))
		(consp (B-get-B state))
		(B-lam-instruction-p (car (B-get-B state)))
		(null (cdr (B-get-B state))))
	   (if *B-debug* (print 'state3b))
	   (let ((new-n (- (cdar (B-get-F state)) 1))
		 (new-m (+ 1 (cdar (B-get-B state))))
		 (new-u (+ 1 (B-get-E-ulc (B-get-E state)))))
	     (B-set-E state (B-make-E (B-get-E-env (B-get-E state))
				      new-u))
	     (B-set-F state (cdr (B-get-F state)))
	     (B-set-F state (cons (B-make-lam-instruction new-n) (B-get-F state)))
	     (B-set-B state (cdr (B-get-B state)))
	     (B-set-B state (cons (B-make-lam-instruction new-m) (B-get-B state)))
	     (B-set-S state (cons new-u (B-get-S state))))
	   (B-transition state))

	  ;;;
          ;;; State 5a  
	  ;;;
	  ((and (B-forward-direction-p (B-get-dir state))  
		(consp (B-get-F state))
		(consp (car (B-get-F state)))
		(B-var-instruction-p (car (B-get-F state)))
		(not (numberp (B-lookup (B-get-var-instruction-operand (car (B-get-F state))) 
					(B-get-E-env (B-get-E state))))))
	   ;;;
	   ;;; (cdr F) doesn't have to be null in this implementation. A var is the last instr
	   ;;; so we can have all the instr in one list, e.g. (foo)(var)(foo).
	   ;;;
	   (if *B-debug* (print 'state5a))
	   (let ((pp (B-lookup (B-get-var-instruction-operand (car (B-get-F state))) (B-get-E-env (B-get-E state)))))
	     (B-set-F state nil)
	     (B-set-F state (cons (B-make-rthnf-instruction pp)(B-get-F state))))
	   (B-transition state))

	  ;;;
          ;;; State 5b  
	  ;;;
	  ((and (B-forward-direction-p (B-get-dir state))  
		(consp (B-get-F state))
		(consp (car (B-get-F state)))
		(B-rthnf-instruction-p (car (B-get-F state)))
		(not (B-suspension-p (B-get-rthnf-instruction-operand (car (B-get-F state)))))
		(null (cdr (B-get-F state))))
	   (if *B-debug* (print 'state5b))
	   (let ((pp (B-get-rthnf-instruction-operand (car (B-get-F state)))))
	     (B-set-F state pp))
	   (B-transition state))

	  ;;;
          ;;; State 5c  
	  ;;;
	  ;;; A suspension of a suspension
	  ;;;
	  ((and (B-forward-direction-p (B-get-dir state))  
		(consp (B-get-F state))
		(consp (car (B-get-F state)))
		(B-rthnf-instruction-p (car (B-get-F state)))
		(null (cdr (B-get-F state)))
		(B-suspension-p (B-get-rthnf-instruction-operand (car (B-get-F state))))
		(B-suspension-p (B-get-suspension-tail (B-get-rthnf-instruction-operand (car (B-get-F state))))))
	   (if *B-debug* (print 'state5c))
	   (let* ((u (B-get-E-ulc (B-get-E state)))
		  (pp (cdar (B-get-F state)))
		  (p-prime-e (B-get-E-env (B-get-suspension-env pp)))
		  (u-prime (B-get-E-ulc (B-get-suspension-env pp)))
		  (p-prime-t (B-get-suspension-tail pp))
		  (new-E (B-make-E p-prime-e u-prime))
		  (new-dump (list 'h u pp (cons (B-make-rthnf-instruction pp) nil) (B-get-B state) (B-get-D state))))
	     (B-set-E state new-E)
	     (B-set-F state (cons (B-make-rthnf-instruction p-prime-t) nil))
	     (B-set-B state nil)
	     (B-set-D state new-dump))
	   (B-transition state))
 
	  ;;;
          ;;; State 5d  
	  ;;;
          ;;; Pretty much 5c but a suspension of code
	  ;;;
	  ((and (B-forward-direction-p (B-get-dir state))  
		(consp (B-get-F state))
		(consp (car (B-get-F state)))
		(B-rthnf-instruction-p (car (B-get-F state)))
		(null (cdr (B-get-F state)))
		(B-suspension-p (B-get-rthnf-instruction-operand (car (B-get-F state))))
		(not (B-suspension-p (B-get-suspension-tail (B-get-rthnf-instruction-operand (car (B-get-F state)))))))
	   (if *B-debug* (print 'state5d))
	   (let* ((u (B-get-E-ulc (B-get-E state)))
		  (pp (B-get-rthnf-instruction-operand (car (B-get-F state))))
		  (p-prime-e (B-get-E-env (B-get-suspension-env pp)))
		  (u-prime (B-get-E-ulc (B-get-suspension-env pp)))
		  (p-prime-t (B-get-suspension-tail pp))
		  (new-E (B-make-E p-prime-e u-prime))
		  (new-dump (list 'h u pp (cons (B-make-rthnf-instruction pp) nil) (B-get-B state) (B-get-D state))))
	     (B-set-E state new-E)
	     (B-set-F state p-prime-t)
	     (B-set-B state nil)
	     (B-set-D state new-dump))
	   (B-transition state))

	  ;;;
          ;;; State 6
	  ;;;
	  ((and (B-forward-direction-p (B-get-dir state))  
		(consp (B-get-F state))
		(consp (car (B-get-F state)))
		(B-var-instruction-p (car (B-get-F state)))		
		(numberp (B-lookup (B-get-var-instruction-operand (car (B-get-F state))) (B-get-E-env (B-get-E state)))))
	   (if *B-debug* (print 'state6))
	   (let* ((i (cdar (B-get-F state)))
		  (u (B-get-E-ulc (B-get-E state)))
		  (u-prime (B-lookup i (B-get-E-env (B-get-E state)))))
	     (B-set-F state (cons (B-make-var-instruction (- u u-prime)) nil))
	     (B-set-dir state B-backward-direction))
	   (B-transition state))

	  ;;;
          ;;; State 7  
	  ;;;
	  ((and (B-backward-direction-p (B-get-dir state))  
		(consp (B-get-F state))
		(consp (B-get-B state))
		(B-lam-instruction-p (car (B-get-B state)))
		(consp (B-get-D state))
		(eq (B-nth (B-get-D state) 0) 't)
		(B-suspension-p (B-nth (B-get-D state) 1)))
	   (if *B-debug* (print 'state7))
	   (B-susp-to-code (B-nth (B-get-D state) 1) (cons (car (B-get-B state)) (B-get-F state)))
	   (B-set-F state (cons (B-make-ap-instruction (B-nth (B-get-D state) 1)) (B-nth (B-get-D state) 2)))
	   (B-set-B state (B-nth (B-get-D state) 3))
	   (B-set-D state (B-nth (B-get-D state) 4))
	   (B-transition state))

	  ;;;
          ;;; State 7  
	  ;;;
	  ((and (B-backward-direction-p (B-get-dir state))  
		(consp (B-get-F state))
		(null (B-get-B state))
		(consp (B-get-D state))
		(eq (B-nth (B-get-D state) 0) 't)
		(B-suspension-p (B-nth (B-get-D state) 1)))
	   (if *B-debug* (print 'state7Barry))	   
	   (B-susp-to-code (B-nth (B-get-D state) 1) (cons (car (B-get-B state)) (B-get-F state)))
	   (B-set-F state (cons (B-make-ap-instruction (B-nth (B-get-D state) 1)) (B-nth (B-get-D state) 2)))
	   (B-set-B state (B-nth (B-get-D state) 3))
	   (B-set-D state (B-nth (B-get-D state) 4))
	   (B-transition state))


	  ;;;
          ;;; State 8a  
	  ;;;
	  ((and (B-backward-direction-p (B-get-dir state))  
		(consp (B-get-F state))
		(consp (B-get-B state))
		(B-lam-instruction-p (car (B-get-B state)))
		(consp (B-get-D state))
		(eq (B-nth (B-get-D state) 0) 'h)
		(eq (caar (B-nth (B-get-D state) 3)) 'rthnf))
	   (if *B-debug* (print 'state8a))
	   (let* ((pe0 nil)
		  (n (B-get-lam-instruction-operand (car (B-get-B state))))
		  (u (B-nth  (B-get-D state) 1))
		  (per (B-make-frame u u pe0 (B-from-downto u 0)))) ;;; was downto 1!!
	     (B-susp-to-code (B-nth (B-get-D state) 2) (cons (B-make-lam-instruction n) (B-get-F state)))
	     (B-set-E state (B-make-E per u))
	     (B-set-F state (cons (B-make-rthnf-instruction (B-nth (B-get-D state) 2)) nil))
	     (B-set-B state (B-nth (B-get-D state) 4))
	     (B-set-D state (B-nth (B-get-D state) 5))
	     (B-set-dir state B-forward-direction))
	   (B-transition state))

	  ;;;
          ;;; State 8b  
	  ;;;
	  ((and (B-backward-direction-p (B-get-dir state))  
		(consp (B-get-F state))
		(B-ap-instruction-p (car (B-get-F state)))
		(consp (B-get-D state)))
	   (if *B-debug* (print 'state8b))
	   (let ((pp (B-get-ap-instruction-operand (car (B-get-F state)))))
	     (B-set-F state (cons (B-make-ap-instruction pp) B-get-F state))
	     (B-set-B state (cdr (B-get-B state))))
	   (B-transition state))

	  ;;;
          ;;; State 9  
	  ;;;
	  ((and (B-backward-direction-p (B-get-dir state))  
		(consp (B-get-B state))
		(B-ap-instruction-p (car (B-get-B state)))
		(B-suspension-p (B-get-ap-instruction-operand (car (B-get-B state)))))
	   (if *B-debug* (print 'state9))
	   (let* ((psus (B-get-ap-instruction-operand (car (B-get-B state))))
		  (pe-prime (B-get-E-env (B-get-suspension-env psus)))
		  (u-prime (B-get-E-ulc (B-get-suspension-env psus)))
		  (pt-prime (B-get-suspension-tail psus))
		  (new-E (B-make-E pe-prime u-prime))
		  (new-F pt-prime)
		  (new-B nil)
		  (new-D (list 't psus (B-get-F state) (cdr (B-get-B state)) (B-get-D state)))
		  (new-dir B-forward-direction))
	     (B-set-E state new-E)
	     (B-set-F state new-F)
	     (B-set-B state new-B)
	     (B-set-D state new-D)
	     (B-set-dir state new-dir))
	   (B-transition state))

	  ;;;
          ;;; State 10  
	  ;;;
	  ((and (B-backward-direction-p (B-get-dir state))  
		(consp (B-get-B state))
		(B-lam-instruction-p (car (B-get-B state)))
		(consp (B-get-F state))
		(null (B-get-D state)))
	   (if *B-debug* (print 'state10))
	   ;;; done!
	   (cons (car (B-get-B state))(B-get-F state)))

	  ;;;
	  ;;; Otherwise, we've got a problem
	  ;;;
	  (t (signal-exception t 
			       (list 
				"No transition possible" 
				state))))))


;;;
;;; This looks monsterous but actually it is quite fine.
;;; The greek letters are because it was designed and debugged
;;; with pencil and paper before it got anywhere near the compiler.
;;;
;;; pi    - program terms
;;; rho   - compiler environment
;;; sigma - label names/numbers
;;; gamma - code 
;;; kappa - continuation
;;;
(set! B-compile 
      (lambda (pi rho sigma kappa)
	(if (atom pi) 
	    (if (symbolp pi) 
		(kappa rho sigma (list (cons 'var (rho pi))))
		(signal-exception t (list "invalid input" pi)))
	    (if (eq (car pi) 'lambda) 
		(B-compile (caddr pi)
			   (B-foldright B-extend-rho rho (cadr pi))
			   sigma
			   (lambda (rho-prime sigma-prime gamma-prime)
			     (kappa rho-prime 
				    sigma-prime 
				    (append (list (cons 'lam (length (cadr pi))))
						  gamma-prime))))
		(B-compile (car pi) 
			   rho 
			   (+ 1 sigma)  
			   (lambda (rho-prime sigma-prime gamma-prime)
			     (B-compile (cadr pi) 
					rho-prime 
					sigma-prime 
					(lambda (rho-prime-prime sigma-prime-prime gamma-prime-prime)
					  (kappa rho-prime-prime 
						 sigma-prime-prime 
						 (append (list (cons 'ap sigma))
						       (append gamma-prime
							     (append (list (cons 'label sigma))
								     gamma-prime-prime))))))))))))
											
;;;
;;; The empty environment p0
;;;
(set! B-rho0 
      (lambda (x)
	(signal-exception t (list "No such variable" x))))

;;;
;;; B-extend-rho
;;;
(set! B-extend-rho 
      (lambda (nu rho)
	(lambda (nu-prime)
	  (if (eq nu nu-prime)
	      0
	      (+ 1 (rho nu-prime))))))

;;;
;;; sigma0
;;;
(set! B-sigma0 0)

;;;
;;; kappa0 the initial continuation
;;;
(set! B-kappa0
      (lambda (rho sigma gamma)
	(print "done")
	(print gamma)))

;;;
;;; foldright
;;;
(set! B-foldright 
      (lambda (f e lst)
	(if (null lst) 
	    e
	    (f (car lst) (B-foldright f e (cdr lst))))))

;;;
;;; Are the two arguments equal?
;;;
(set! B-equal 
      (lambda (a b)
	(cond ((numberp a) (and (numberp b) (= a b)))
	      ((atom a) (and (atom b) (eq a b)))
	      ((consp a) (and (consp b) (B-equal (car a) (car b)) (B-equal (cdr a) (cdr b))))
	      (t nil))))

;;;
;;; A normal assoc which is used when we want to 
;;; find the code associated with a label.
;;;
(set! B-assoc
      (lambda (elmt lst)
	(cond ((null lst) nil)
	      ((B-equal elmt (car lst)) (cdr lst))
	      (t (B-assoc elmt (cdr lst))))))

;;;
;;; Link up the APs to the LABELs
;;; This is done with some list surgery so the cdr of the AP points to the
;;; code of the the operand.
;;;
(set! B-link 
      (lambda (instructions)
	(if (null instructions) 
	    nil
	  (begin (if (B-ap-instruction-p (car instructions))
		     (begin (rplacd (car instructions)
				    (B-assoc (cons 'label (cdar instructions))
					     instructions))))
		 (B-link (cdr instructions))))))

;;;
;;; The driver for compilation.
;;;
(set! B-translate
      (lambda (input)
	(B-compile input 
		   B-rho0 
		   B-sigma0
		   (lambda (rho sigma gamma)
		     (B-link gamma)
		     (B-cleanup gamma)
		     gamma))))
	
;;;
;;; Remove the LABEL instructions - again more list surgery.
;;;
(set! B-cleanup 
      (lambda (instructions)
	(cond ((null instructions) instructions)
	      ((eq (caar instructions) 'label) (B-cleanup (cdr instructions)))
	      (t (rplacd instructions (B-cleanup (cdr instructions)))))))

;;;
;;; Get some input, compile it, reduce it, then print it.
;;;
(set! B-toplevel 
      (lambda ()
	(print 'ok>)
	(let ((state (B-empty-state)))
	  (B-set-F state (B-translate (read)))
	  (print (B-transition state)))))

Thanks for going to so much trouble - that's really helpful, and it'll keep me out of mischief for a bit... :-)