Implement 5.24

ex-5_23-xx.scm

@@ -27,7 +27,16 @@
 (assert (get-register-contents eceval 'val) 9)
 
 
-(display "\nex-5.24 \n")
+(display "\nex-5.24 - cond-special-form\n")
+
+(set-register-contents! eceval 'exp
+  '(cond
+     ((= 2 1) 0)
+     ((= 2 3) 1)
+     ((= 0 4) 2)
+     (else (* 2 5))))
+(start eceval)
+(assert (get-register-contents eceval 'val) 10)
 
 
 (display "\nex-5.25\n")

misc/sicp-eceval-support.scm

@@ -98,6 +98,7 @@
 ;;; cond-support
 (define (cond? exp) (tagged-list? exp 'cond))
 (define (cond-clauses exp) (cdr exp))
+(define (cond-first-clause exp) (car exp))
 (define (cond-else-clause? clause)
   (eq? (cond-predicate clause) 'else))
 (define (cond-predicate clause) (car clause))

misc/sicp-eceval.scm

@@ -26,64 +26,72 @@
 (define eceval-operations
   (list
    ;;primitive Scheme operations
+   (list 'display display)
+   (list 'newline newline)
    (list 'read read)
 
    ;;operations in syntax.scm
-   (list 'self-evaluating? self-evaluating?)
+   (list 'application? application?)
+   (list 'assignment-value assignment-value)
+   (list 'assignment-variable assignment-variable)
+   (list 'assignment? assignment?)
+   (list 'begin-actions begin-actions)
+   (list 'begin? begin?)
+   (list 'definition-value definition-value)
+   (list 'definition-variable definition-variable)
+   (list 'definition? definition?)
+   (list 'first-exp first-exp)
+   (list 'first-operand first-operand)
+   (list 'if-alternative if-alternative)
+   (list 'if-consequent if-consequent)
+   (list 'if-predicate if-predicate)
+   (list 'if? if?)
+   (list 'lambda-body lambda-body)
+   (list 'lambda-parameters lambda-parameters)
+   (list 'lambda? lambda?)
+   (list 'last-exp? last-exp?)
+   (list 'no-operands? no-operands?)
+   (list 'operands operands)
+   (list 'operator operator)
    (list 'quoted? quoted?)
+   (list 'rest-exps rest-exps)
+   (list 'rest-operands rest-operands)
+   (list 'self-evaluating? self-evaluating?)
    (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 'adjoin-arg adjoin-arg)
-   (list 'make-procedure make-procedure)
+   (list 'announce-output announce-output)
+   (list 'apply-primitive-procedure apply-primitive-procedure)
    (list 'compound-procedure? compound-procedure?)
-   (list 'procedure-parameters procedure-parameters)
+   (list 'define-variable! define-variable!)
+   (list 'empty-arglist empty-arglist)
+   (list 'extend-environment extend-environment)
+   (list 'get-global-environment get-global-environment))
+   (list 'last-operand? last-operand?)
+   (list 'lookup-variable-value lookup-variable-value)
+   (list 'make-procedure make-procedure)
+   (list 'no-more-exps? no-more-exps?)	;for non-tail-recursive machine
+   (list 'primitive-procedure? primitive-procedure?)
    (list 'procedure-body procedure-body)
    (list 'procedure-environment procedure-environment)
-   (list 'extend-environment extend-environment)
+   (list 'procedure-parameters procedure-parameters)
-   (list 'lookup-variable-value lookup-variable-value)
-   (list 'set-variable-value! set-variable-value!)
-   ;;5.23
-   (list 'cond? cond?)
-   (list 'cond->if cond->if)
-   (list 'let? let?)
-   (list 'let->combination let->combination)
-   (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 'set-variable-value! set-variable-value!)
+   (list 'true? true?)
    (list 'user-print user-print)
-   (list 'empty-arglist empty-arglist)
+
-   (list 'adjoin-arg adjoin-arg)
+   ;;5.23
-   (list 'last-operand? last-operand?)
+   (list 'cond->if cond->if)
-   (list 'no-more-exps? no-more-exps?)	;for non-tail-recursive machine
+   (list 'cond-actions cond-actions)
-   (list 'get-global-environment get-global-environment))
+   (list 'cond-clauses cond-clauses)
+   (list 'cond-else-clause? cond-else-clause?)
+   (list 'cond-first-clause cond-first-clause)
+   (list 'cond-predicate cond-predicate)
+   (list 'cond? cond?)
+   (list 'let->combination let->combination)
+   (list 'let? let?)
    )
 
 (define eceval
@@ -238,10 +246,33 @@ ev-sequence-last-exp
   (goto (label eval-dispatch))
 
 ;;; ex-5.23
-ev-cond
+ev-cond-transform
   (assign exp (op cond->if) (reg exp))
   (goto (label eval-dispatch))
 
+;;; ex-5.24
+ev-cond
+  (save continue)
+  (assign unev (op cond-clauses) (reg exp))      ; unev contains all clauses
+ev-cond-loop
+  (assign exp (op cond-first-clause) (reg unev)) ; exp contains first clause
+  (test (op cond-else-clause?) (reg exp))        ; test for else-clause
+  (branch (label ev-cond-done))
+  (assign continue (label ev-cond-decide))
+  (save unev)
+  (assign exp (op cond-predicate) (reg exp))     ; exp contains first predicate
+  (goto (label eval-dispatch))                   ; eval predicate
+ev-cond-decide
+  (restore unev)
+  (test (op true?) (reg val))                    ; test if predicate is true
+  (branch (label ev-cond-done))
+  (assign unev (op cond-clauses) (reg unev))     ; unev contains remainging clauses
+  (goto (label ev-cond-loop))
+ev-cond-done
+  (restore continue)
+  (assign exp (op cond-first-clause) (reg unev)) ; exp contains true clause
+  (goto (label ev-begin))
+
 ev-let
   (assign exp (op let->combination) (reg exp))
   (goto (label eval-dispatch))