Answer 5.31 and add SICP code for chapter 5

misc/ch5-compiler.scm

@@ -0,0 +1,380 @@
+;;;;COMPILER FROM SECTION 5.5 OF
+;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
+
+;;;;Matches code in ch5.scm
+
+;;;;This file can be loaded into Scheme as a whole.
+;;;;**NOTE**This file loads the metacircular evaluator's syntax procedures
+;;;;  from section 4.1.2
+;;;;  You may need to change the (load ...) expression to work in your
+;;;;  version of Scheme.
+
+;;;;Then you can compile Scheme programs as shown in section 5.5.5
+
+;;**implementation-dependent loading of syntax procedures
+(load "ch5-syntax.scm")			;section 4.1.2 syntax procedures
+
+
+;;;SECTION 5.5.1
+
+(define (compile exp target linkage)
+  (cond ((self-evaluating? exp)
+         (compile-self-evaluating exp target linkage))
+        ((quoted? exp) (compile-quoted exp target linkage))
+        ((variable? exp)
+         (compile-variable exp target linkage))
+        ((assignment? exp)
+         (compile-assignment exp target linkage))
+        ((definition? exp)
+         (compile-definition exp target linkage))
+        ((if? exp) (compile-if exp target linkage))
+        ((lambda? exp) (compile-lambda exp target linkage))
+        ((begin? exp)
+         (compile-sequence (begin-actions exp)
+                           target
+                           linkage))
+        ((cond? exp) (compile (cond->if exp) target linkage))
+        ((application? exp)
+         (compile-application exp target linkage))
+        (else
+         (error "Unknown expression type -- COMPILE" exp))))
+
+
+(define (make-instruction-sequence needs modifies statements)
+  (list needs modifies statements))
+
+(define (empty-instruction-sequence)
+  (make-instruction-sequence '() '() '()))
+
+
+;;;SECTION 5.5.2
+
+;;;linkage code
+
+(define (compile-linkage linkage)
+  (cond ((eq? linkage 'return)
+         (make-instruction-sequence '(continue) '()
+          '((goto (reg continue)))))
+        ((eq? linkage 'next)
+         (empty-instruction-sequence))
+        (else
+         (make-instruction-sequence '() '()
+          `((goto (label ,linkage)))))))
+
+(define (end-with-linkage linkage instruction-sequence)
+  (preserving '(continue)
+   instruction-sequence
+   (compile-linkage linkage)))
+
+
+;;;simple expressions
+
+(define (compile-self-evaluating exp target linkage)
+  (end-with-linkage linkage
+   (make-instruction-sequence '() (list target)
+    `((assign ,target (const ,exp))))))
+
+(define (compile-quoted exp target linkage)
+  (end-with-linkage linkage
+   (make-instruction-sequence '() (list target)
+    `((assign ,target (const ,(text-of-quotation exp)))))))
+
+(define (compile-variable exp target linkage)
+  (end-with-linkage linkage
+   (make-instruction-sequence '(env) (list target)
+    `((assign ,target
+              (op lookup-variable-value)
+              (const ,exp)
+              (reg env))))))
+
+(define (compile-assignment exp target linkage)
+  (let ((var (assignment-variable exp))
+        (get-value-code
+         (compile (assignment-value exp) 'val 'next)))
+    (end-with-linkage linkage
+     (preserving '(env)
+      get-value-code
+      (make-instruction-sequence '(env val) (list target)
+       `((perform (op set-variable-value!)
+                  (const ,var)
+                  (reg val)
+                  (reg env))
+         (assign ,target (const ok))))))))
+
+(define (compile-definition exp target linkage)
+  (let ((var (definition-variable exp))
+        (get-value-code
+         (compile (definition-value exp) 'val 'next)))
+    (end-with-linkage linkage
+     (preserving '(env)
+      get-value-code
+      (make-instruction-sequence '(env val) (list target)
+       `((perform (op define-variable!)
+                  (const ,var)
+                  (reg val)
+                  (reg env))
+         (assign ,target (const ok))))))))
+
+
+;;;conditional expressions
+
+;;;labels (from footnote)
+(define label-counter 0)
+
+(define (new-label-number)
+  (set! label-counter (+ 1 label-counter))
+  label-counter)
+
+(define (make-label name)
+  (string->symbol
+    (string-append (symbol->string name)
+                   (number->string (new-label-number)))))
+;; end of footnote
+
+(define (compile-if exp target linkage)
+  (let ((t-branch (make-label 'true-branch))
+        (f-branch (make-label 'false-branch))
+        (after-if (make-label 'after-if)))
+    (let ((consequent-linkage
+           (if (eq? linkage 'next) after-if linkage)))
+      (let ((p-code (compile (if-predicate exp) 'val 'next))
+            (c-code
+             (compile
+              (if-consequent exp) target consequent-linkage))
+            (a-code
+             (compile (if-alternative exp) target linkage)))
+        (preserving '(env continue)
+         p-code
+         (append-instruction-sequences
+          (make-instruction-sequence '(val) '()
+           `((test (op false?) (reg val))
+             (branch (label ,f-branch))))
+          (parallel-instruction-sequences
+           (append-instruction-sequences t-branch c-code)
+           (append-instruction-sequences f-branch a-code))
+          after-if))))))
+
+;;; sequences
+
+(define (compile-sequence seq target linkage)
+  (if (last-exp? seq)
+      (compile (first-exp seq) target linkage)
+      (preserving '(env continue)
+       (compile (first-exp seq) target 'next)
+       (compile-sequence (rest-exps seq) target linkage))))
+
+;;;lambda expressions
+
+(define (compile-lambda exp target linkage)
+  (let ((proc-entry (make-label 'entry))
+        (after-lambda (make-label 'after-lambda)))
+    (let ((lambda-linkage
+           (if (eq? linkage 'next) after-lambda linkage)))
+      (append-instruction-sequences
+       (tack-on-instruction-sequence
+        (end-with-linkage lambda-linkage
+         (make-instruction-sequence '(env) (list target)
+          `((assign ,target
+                    (op make-compiled-procedure)
+                    (label ,proc-entry)
+                    (reg env)))))
+        (compile-lambda-body exp proc-entry))
+       after-lambda))))
+
+(define (compile-lambda-body exp proc-entry)
+  (let ((formals (lambda-parameters exp)))
+    (append-instruction-sequences
+     (make-instruction-sequence '(env proc argl) '(env)
+      `(,proc-entry
+        (assign env (op compiled-procedure-env) (reg proc))
+        (assign env
+                (op extend-environment)
+                (const ,formals)
+                (reg argl)
+                (reg env))))
+     (compile-sequence (lambda-body exp) 'val 'return))))
+
+
+;;;SECTION 5.5.3
+
+;;;combinations
+
+(define (compile-application exp target linkage)
+  (let ((proc-code (compile (operator exp) 'proc 'next))
+        (operand-codes
+         (map (lambda (operand) (compile operand 'val 'next))
+              (operands exp))))
+    (preserving '(env continue)
+     proc-code
+     (preserving '(proc continue)
+      (construct-arglist operand-codes)
+      (compile-procedure-call target linkage)))))
+
+(define (construct-arglist operand-codes)
+  (let ((operand-codes (reverse operand-codes)))
+    (if (null? operand-codes)
+        (make-instruction-sequence '() '(argl)
+         '((assign argl (const ()))))
+        (let ((code-to-get-last-arg
+               (append-instruction-sequences
+                (car operand-codes)
+                (make-instruction-sequence '(val) '(argl)
+                 '((assign argl (op list) (reg val)))))))
+          (if (null? (cdr operand-codes))
+              code-to-get-last-arg
+              (preserving '(env)
+               code-to-get-last-arg
+               (code-to-get-rest-args
+                (cdr operand-codes))))))))
+
+(define (code-to-get-rest-args operand-codes)
+  (let ((code-for-next-arg
+         (preserving '(argl)
+          (car operand-codes)
+          (make-instruction-sequence '(val argl) '(argl)
+           '((assign argl
+              (op cons) (reg val) (reg argl)))))))
+    (if (null? (cdr operand-codes))
+        code-for-next-arg
+        (preserving '(env)
+         code-for-next-arg
+         (code-to-get-rest-args (cdr operand-codes))))))
+
+;;;applying procedures
+
+(define (compile-procedure-call target linkage)
+  (let ((primitive-branch (make-label 'primitive-branch))
+        (compiled-branch (make-label 'compiled-branch))
+        (after-call (make-label 'after-call)))
+    (let ((compiled-linkage
+           (if (eq? linkage 'next) after-call linkage)))
+      (append-instruction-sequences
+       (make-instruction-sequence '(proc) '()
+        `((test (op primitive-procedure?) (reg proc))
+          (branch (label ,primitive-branch))))
+       (parallel-instruction-sequences
+        (append-instruction-sequences
+         compiled-branch
+         (compile-proc-appl target compiled-linkage))
+        (append-instruction-sequences
+         primitive-branch
+         (end-with-linkage linkage
+          (make-instruction-sequence '(proc argl)
+                                     (list target)
+           `((assign ,target
+                     (op apply-primitive-procedure)
+                     (reg proc)
+                     (reg argl)))))))
+       after-call))))
+
+;;;applying compiled procedures
+
+(define (compile-proc-appl target linkage)
+  (cond ((and (eq? target 'val) (not (eq? linkage 'return)))
+         (make-instruction-sequence '(proc) all-regs
+           `((assign continue (label ,linkage))
+             (assign val (op compiled-procedure-entry)
+                         (reg proc))
+             (goto (reg val)))))
+        ((and (not (eq? target 'val))
+              (not (eq? linkage 'return)))
+         (let ((proc-return (make-label 'proc-return)))
+           (make-instruction-sequence '(proc) all-regs
+            `((assign continue (label ,proc-return))
+              (assign val (op compiled-procedure-entry)
+                          (reg proc))
+              (goto (reg val))
+              ,proc-return
+              (assign ,target (reg val))
+              (goto (label ,linkage))))))
+        ((and (eq? target 'val) (eq? linkage 'return))
+         (make-instruction-sequence '(proc continue) all-regs
+          '((assign val (op compiled-procedure-entry)
+                        (reg proc))
+            (goto (reg val)))))
+        ((and (not (eq? target 'val)) (eq? linkage 'return))
+         (error "return linkage, target not val -- COMPILE"
+                target))))
+
+;; footnote
+(define all-regs '(env proc val argl continue))
+
+
+;;;SECTION 5.5.4
+
+(define (registers-needed s)
+  (if (symbol? s) '() (car s)))
+
+(define (registers-modified s)
+  (if (symbol? s) '() (cadr s)))
+
+(define (statements s)
+  (if (symbol? s) (list s) (caddr s)))
+
+(define (needs-register? seq reg)
+  (memq reg (registers-needed seq)))
+
+(define (modifies-register? seq reg)
+  (memq reg (registers-modified seq)))
+
+
+(define (append-instruction-sequences . seqs)
+  (define (append-2-sequences seq1 seq2)
+    (make-instruction-sequence
+     (list-union (registers-needed seq1)
+                 (list-difference (registers-needed seq2)
+                                  (registers-modified seq1)))
+     (list-union (registers-modified seq1)
+                 (registers-modified seq2))
+     (append (statements seq1) (statements seq2))))
+  (define (append-seq-list seqs)
+    (if (null? seqs)
+        (empty-instruction-sequence)
+        (append-2-sequences (car seqs)
+                            (append-seq-list (cdr seqs)))))
+  (append-seq-list seqs))
+
+(define (list-union s1 s2)
+  (cond ((null? s1) s2)
+        ((memq (car s1) s2) (list-union (cdr s1) s2))
+        (else (cons (car s1) (list-union (cdr s1) s2)))))
+
+(define (list-difference s1 s2)
+  (cond ((null? s1) '())
+        ((memq (car s1) s2) (list-difference (cdr s1) s2))
+        (else (cons (car s1)
+                    (list-difference (cdr s1) s2)))))
+
+(define (preserving regs seq1 seq2)
+  (if (null? regs)
+      (append-instruction-sequences seq1 seq2)
+      (let ((first-reg (car regs)))
+        (if (and (needs-register? seq2 first-reg)
+                 (modifies-register? seq1 first-reg))
+            (preserving (cdr regs)
+             (make-instruction-sequence
+              (list-union (list first-reg)
+                          (registers-needed seq1))
+              (list-difference (registers-modified seq1)
+                               (list first-reg))
+              (append `((save ,first-reg))
+                      (statements seq1)
+                      `((restore ,first-reg))))
+             seq2)
+            (preserving (cdr regs) seq1 seq2)))))
+
+(define (tack-on-instruction-sequence seq body-seq)
+  (make-instruction-sequence
+   (registers-needed seq)
+   (registers-modified seq)
+   (append (statements seq) (statements body-seq))))
+
+(define (parallel-instruction-sequences seq1 seq2)
+  (make-instruction-sequence
+   (list-union (registers-needed seq1)
+               (registers-needed seq2))
+   (list-union (registers-modified seq1)
+               (registers-modified seq2))
+   (append (statements seq1) (statements seq2))))
+
+'(COMPILER LOADED)

misc/ch5-eceval-compiler.scm

@@ -0,0 +1,370 @@
+;;;;EXPLICIT-CONTROL EVALUATOR FROM SECTION 5.4 OF
+;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
+;;;; MODIFIED TO SUPPORT COMPILED CODE (AS IN SECTION 5.5.7)
+
+;;;;Changes to basic evaluator machine are
+;;;; (1) some new eceval controller code for the driver and apply-dispatch;
+;;;; (2) some additional machine operations from;
+;;;; (3) support for compiled code to call interpreted code (exercise 5.47) --
+;;;;     (new register and 1 new instruction at start)
+;;;; (4) new startup aid start-eceval
+
+;; Explicit-control evaluator.
+;; To use it, load "load-eceval-compiler.scm", which loads this file and the
+;;  support it needs (including the register-machine simulator)
+
+;; To start, can use compile-and-go as in section 5.5.7
+;;  or start-eceval as in the section 5.5.7 footnote.
+
+;; To resume the machine without reinitializing the global environment
+;; if you have somehow interrupted out of the machine back to Scheme, do
+
+;: (set-register-contents! eceval 'flag false)
+;: (start eceval)
+
+;;;;;;;;
+
+;; any old value to create the variable so that
+;;  compile-and-go and/or start-eceval can set! it.
+(define the-global-environment '())
+
+;;; Interfacing compiled code with eceval machine
+;;; From section 5.5.7
+(define (start-eceval)
+  (set! the-global-environment (setup-environment))
+  (set-register-contents! eceval 'flag false)
+  (start eceval))
+
+;; Modification of section 4.1.4 procedure
+;; **replaces version in syntax file
+(define (user-print object)
+  (cond ((compound-procedure? object)
+         (display (list 'compound-procedure
+                        (procedure-parameters object)
+                        (procedure-body object)
+                        '<procedure-env>)))
+        ((compiled-procedure? object)
+         (display '<compiled-procedure>))
+        (else (display object))))
+
+(define (compile-and-go expression)
+  (let ((instructions
+         (assemble (statements
+                    (compile expression 'val 'return))
+                   eceval)))
+    (set! the-global-environment (setup-environment))
+    (set-register-contents! eceval 'val instructions)
+    (set-register-contents! eceval 'flag true)
+    (start eceval)))
+
+;;**NB. To [not] monitor stack operations, comment in/[out] the line after
+;; print-result in the machine controller below
+;;**Also choose the desired make-stack version in regsim.scm
+
+(define eceval-operations
+  (list
+   ;;primitive Scheme operations
+   (list 'read read)			;used by eceval
+
+   ;;used by compiled code
+   (list 'list list)
+   (list 'cons cons)
+
+   ;;operations in syntax.scm
+   (list 'self-evaluating? self-evaluating?)
+   (list 'quoted? quoted?)
+   (list 'text-of-quotation text-of-quotation)
+   (list 'variable? variable?)
+   (list 'assignment? assignment?)
+   (list 'assignment-variable assignment-variable)
+   (list 'assignment-value assignment-value)
+   (list 'definition? definition?)
+   (list 'definition-variable definition-variable)
+   (list 'definition-value definition-value)
+   (list 'lambda? lambda?)
+   (list 'lambda-parameters lambda-parameters)
+   (list 'lambda-body lambda-body)
+   (list 'if? if?)
+   (list 'if-predicate if-predicate)
+   (list 'if-consequent if-consequent)
+   (list 'if-alternative if-alternative)
+   (list 'begin? begin?)
+   (list 'begin-actions begin-actions)
+   (list 'last-exp? last-exp?)
+   (list 'first-exp first-exp)
+   (list 'rest-exps rest-exps)
+   (list 'application? application?)
+   (list 'operator operator)
+   (list 'operands operands)
+   (list 'no-operands? no-operands?)
+   (list 'first-operand first-operand)
+   (list 'rest-operands rest-operands)
+
+   ;;operations in eceval-support.scm
+   (list 'true? true?)
+   (list 'false? false?)		;for compiled code
+   (list 'make-procedure make-procedure)
+   (list 'compound-procedure? compound-procedure?)
+   (list 'procedure-parameters procedure-parameters)
+   (list 'procedure-body procedure-body)
+   (list 'procedure-environment procedure-environment)
+   (list 'extend-environment extend-environment)
+   (list 'lookup-variable-value lookup-variable-value)
+   (list 'set-variable-value! set-variable-value!)
+   (list 'define-variable! define-variable!)
+   (list 'primitive-procedure? primitive-procedure?)
+   (list 'apply-primitive-procedure apply-primitive-procedure)
+   (list 'prompt-for-input prompt-for-input)
+   (list 'announce-output announce-output)
+   (list 'user-print user-print)
+   (list 'empty-arglist empty-arglist)
+   (list 'adjoin-arg adjoin-arg)
+   (list 'last-operand? last-operand?)
+   (list 'no-more-exps? no-more-exps?)	;for non-tail-recursive machine
+   (list 'get-global-environment get-global-environment)
+
+   ;;for compiled code (also in eceval-support.scm)
+   (list 'make-compiled-procedure make-compiled-procedure)
+   (list 'compiled-procedure? compiled-procedure?)
+   (list 'compiled-procedure-entry compiled-procedure-entry)
+   (list 'compiled-procedure-env compiled-procedure-env)
+   ))
+
+(define eceval
+  (make-machine
+   '(exp env val proc argl continue unev
+	 compapp			;*for compiled to call interpreted
+	 )
+   eceval-operations
+  '(
+;;SECTION 5.4.4, as modified in 5.5.7
+;;*for compiled to call interpreted (from exercise 5.47)
+  (assign compapp (label compound-apply))
+;;*next instruction supports entry from compiler (from section 5.5.7)
+  (branch (label external-entry))
+read-eval-print-loop
+  (perform (op initialize-stack))
+  (perform
+   (op prompt-for-input) (const ";;; EC-Eval input:"))
+  (assign exp (op read))
+  (assign env (op get-global-environment))
+  (assign continue (label print-result))
+  (goto (label eval-dispatch))
+print-result
+;;**following instruction optional -- if use it, need monitored stack
+  (perform (op print-stack-statistics))
+  (perform
+   (op announce-output) (const ";;; EC-Eval value:"))
+  (perform (op user-print) (reg val))
+  (goto (label read-eval-print-loop))
+
+;;*support for entry from compiler (from section 5.5.7)
+external-entry
+  (perform (op initialize-stack))
+  (assign env (op get-global-environment))
+  (assign continue (label print-result))
+  (goto (reg val))
+
+unknown-expression-type
+  (assign val (const unknown-expression-type-error))
+  (goto (label signal-error))
+
+unknown-procedure-type
+  (restore continue)
+  (assign val (const unknown-procedure-type-error))
+  (goto (label signal-error))
+
+signal-error
+  (perform (op user-print) (reg val))
+  (goto (label read-eval-print-loop))
+
+;;SECTION 5.4.1
+eval-dispatch
+  (test (op self-evaluating?) (reg exp))
+  (branch (label ev-self-eval))
+  (test (op variable?) (reg exp))
+  (branch (label ev-variable))
+  (test (op quoted?) (reg exp))
+  (branch (label ev-quoted))
+  (test (op assignment?) (reg exp))
+  (branch (label ev-assignment))
+  (test (op definition?) (reg exp))
+  (branch (label ev-definition))
+  (test (op if?) (reg exp))
+  (branch (label ev-if))
+  (test (op lambda?) (reg exp))
+  (branch (label ev-lambda))
+  (test (op begin?) (reg exp))
+  (branch (label ev-begin))
+  (test (op application?) (reg exp))
+  (branch (label ev-application))
+  (goto (label unknown-expression-type))
+
+ev-self-eval
+  (assign val (reg exp))
+  (goto (reg continue))
+ev-variable
+  (assign val (op lookup-variable-value) (reg exp) (reg env))
+  (goto (reg continue))
+ev-quoted
+  (assign val (op text-of-quotation) (reg exp))
+  (goto (reg continue))
+ev-lambda
+  (assign unev (op lambda-parameters) (reg exp))
+  (assign exp (op lambda-body) (reg exp))
+  (assign val (op make-procedure)
+              (reg unev) (reg exp) (reg env))
+  (goto (reg continue))
+
+ev-application
+  (save continue)
+  (save env)
+  (assign unev (op operands) (reg exp))
+  (save unev)
+  (assign exp (op operator) (reg exp))
+  (assign continue (label ev-appl-did-operator))
+  (goto (label eval-dispatch))
+ev-appl-did-operator
+  (restore unev)
+  (restore env)
+  (assign argl (op empty-arglist))
+  (assign proc (reg val))
+  (test (op no-operands?) (reg unev))
+  (branch (label apply-dispatch))
+  (save proc)
+ev-appl-operand-loop
+  (save argl)
+  (assign exp (op first-operand) (reg unev))
+  (test (op last-operand?) (reg unev))
+  (branch (label ev-appl-last-arg))
+  (save env)
+  (save unev)
+  (assign continue (label ev-appl-accumulate-arg))
+  (goto (label eval-dispatch))
+ev-appl-accumulate-arg
+  (restore unev)
+  (restore env)
+  (restore argl)
+  (assign argl (op adjoin-arg) (reg val) (reg argl))
+  (assign unev (op rest-operands) (reg unev))
+  (goto (label ev-appl-operand-loop))
+ev-appl-last-arg
+  (assign continue (label ev-appl-accum-last-arg))
+  (goto (label eval-dispatch))
+ev-appl-accum-last-arg
+  (restore argl)
+  (assign argl (op adjoin-arg) (reg val) (reg argl))
+  (restore proc)
+  (goto (label apply-dispatch))
+apply-dispatch
+  (test (op primitive-procedure?) (reg proc))
+  (branch (label primitive-apply))
+  (test (op compound-procedure?) (reg proc))  
+  (branch (label compound-apply))
+;;*next added to call compiled code from evaluator (section 5.5.7)
+  (test (op compiled-procedure?) (reg proc))  
+  (branch (label compiled-apply))
+  (goto (label unknown-procedure-type))
+
+;;*next added to call compiled code from evaluator (section 5.5.7)
+compiled-apply
+  (restore continue)
+  (assign val (op compiled-procedure-entry) (reg proc))
+  (goto (reg val))
+
+primitive-apply
+  (assign val (op apply-primitive-procedure)
+              (reg proc)
+              (reg argl))
+  (restore continue)
+  (goto (reg continue))
+
+compound-apply
+  (assign unev (op procedure-parameters) (reg proc))
+  (assign env (op procedure-environment) (reg proc))
+  (assign env (op extend-environment)
+              (reg unev) (reg argl) (reg env))
+  (assign unev (op procedure-body) (reg proc))
+  (goto (label ev-sequence))
+
+;;;SECTION 5.4.2
+ev-begin
+  (assign unev (op begin-actions) (reg exp))
+  (save continue)
+  (goto (label ev-sequence))
+
+ev-sequence
+  (assign exp (op first-exp) (reg unev))
+  (test (op last-exp?) (reg unev))
+  (branch (label ev-sequence-last-exp))
+  (save unev)
+  (save env)
+  (assign continue (label ev-sequence-continue))
+  (goto (label eval-dispatch))
+ev-sequence-continue
+  (restore env)
+  (restore unev)
+  (assign unev (op rest-exps) (reg unev))
+  (goto (label ev-sequence))
+ev-sequence-last-exp
+  (restore continue)
+  (goto (label eval-dispatch))
+
+;;;SECTION 5.4.3
+
+ev-if
+  (save exp)
+  (save env)
+  (save continue)
+  (assign continue (label ev-if-decide))
+  (assign exp (op if-predicate) (reg exp))
+  (goto (label eval-dispatch))
+ev-if-decide
+  (restore continue)
+  (restore env)
+  (restore exp)
+  (test (op true?) (reg val))
+  (branch (label ev-if-consequent))
+ev-if-alternative
+  (assign exp (op if-alternative) (reg exp))
+  (goto (label eval-dispatch))
+ev-if-consequent
+  (assign exp (op if-consequent) (reg exp))
+  (goto (label eval-dispatch))
+
+ev-assignment
+  (assign unev (op assignment-variable) (reg exp))
+  (save unev)
+  (assign exp (op assignment-value) (reg exp))
+  (save env)
+  (save continue)
+  (assign continue (label ev-assignment-1))
+  (goto (label eval-dispatch))
+ev-assignment-1
+  (restore continue)
+  (restore env)
+  (restore unev)
+  (perform
+   (op set-variable-value!) (reg unev) (reg val) (reg env))
+  (assign val (const ok))
+  (goto (reg continue))
+
+ev-definition
+  (assign unev (op definition-variable) (reg exp))
+  (save unev)
+  (assign exp (op definition-value) (reg exp))
+  (save env)
+  (save continue)
+  (assign continue (label ev-definition-1))
+  (goto (label eval-dispatch))
+ev-definition-1
+  (restore continue)
+  (restore env)
+  (restore unev)
+  (perform
+   (op define-variable!) (reg unev) (reg val) (reg env))
+  (assign val (const ok))
+  (goto (reg continue))
+   )))
+
+'(EXPLICIT CONTROL EVALUATOR FOR COMPILER LOADED)

misc/ch5-syntax.scm

@@ -0,0 +1,120 @@
+;;;;SCHEME SYNTAX FROM SECTION 4.1.2 OF STRUCTURE AND INTERPRETATION OF
+;;;  COMPUTER PROGRAMS, TO SUPPORT CHAPTER 5
+;;;;Loaded by compiler.scm (for use by compiler), and by eceval-support.scm
+;;;; (for simulation of eceval machine operations)
+
+(define (self-evaluating? exp)
+  (cond ((number? exp) true)
+        ((string? exp) true)
+        (else false)))
+
+
+(define (quoted? exp)
+  (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+
+(define (tagged-list? exp tag)
+  (if (pair? exp)
+      (eq? (car exp) tag)
+      false))
+
+
+(define (variable? exp) (symbol? exp))
+
+(define (assignment? exp)
+  (tagged-list? exp 'set!))
+
+(define (assignment-variable exp) (cadr exp))
+
+(define (assignment-value exp) (caddr exp))
+
+
+(define (definition? exp)
+  (tagged-list? exp 'define))
+
+(define (definition-variable exp)
+  (if (symbol? (cadr exp))
+      (cadr exp)
+      (caadr exp)))
+
+(define (definition-value exp)
+  (if (symbol? (cadr exp))
+      (caddr exp)
+      (make-lambda (cdadr exp)
+                   (cddr exp))))
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+
+(define (make-lambda parameters body)
+  (cons 'lambda (cons parameters body)))
+
+(define (if? exp) (tagged-list? exp 'if))
+
+(define (if-predicate exp) (cadr exp))
+
+(define (if-consequent exp) (caddr exp))
+
+(define (if-alternative exp)
+  (if (not (null? (cdddr exp)))
+      (cadddr exp)
+      'false))
+
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;;;**following needed only to implement COND as derived expression,
+;;; not needed by eceval machine in text.  But used by compiler
+
+;; from 4.1.2
+(define (make-if predicate consequent alternative)
+  (list 'if predicate consequent alternative))
+
+
+(define (sequence->exp seq)
+  (cond ((null? seq) seq)
+        ((last-exp? seq) (first-exp seq))
+        (else (make-begin seq))))
+
+(define (make-begin seq) (cons 'begin seq))
+
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+  (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+
+(define (cond->if exp)
+  (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+  (if (null? clauses)
+      'false                          ; no else clause
+      (let ((first (car clauses))
+            (rest (cdr clauses)))
+        (if (cond-else-clause? first)
+            (if (null? rest)
+                (sequence->exp (cond-actions first))
+                (error "ELSE clause isn't last -- COND->IF"
+                       clauses))
+            (make-if (cond-predicate first)
+                     (sequence->exp (cond-actions first))
+                     (expand-clauses rest))))))
+;; end of Cond support