sicp-ex-5.25

<< Previous exercise (5.24) | Index | Next exercise (5.26) >>

aos

My solution can be found here: https://github.com/aos/SICP/blob/master/exercises/ch5/4/ex-25.ss


revc

  
  
 ;;;;EXPLICIT-CONTROL EVALUATOR FROM SECTION 5.4 OF 
 ;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS 
  
 ;;;;Matches code in ch5.scm 
  
 ;;; To use it 
 ;;; -- load "load-eceval.scm", which loads this file and the 
 ;;;    support it needs (including the register-machine simulator) 
  
 ;;; -- To initialize and start the machine, do 
  
 ;; (define the-global-environment (setup-environment)) 
  
 ;; (start ecleval) 
  
 ;; To restart, can do just 
 ;: (start ecleval) 
 ;;;;;;;;;; 
  
  
 ;;**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 ecleval-operations 
   (list 
    ;;primitive Scheme operations 
    (list 'read read) 
  
    ;;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) 
    ;; support cond 
    (list 'cond? cond?) 
    (list 'cond->if cond->if) 
  
    ;;operations in eceval-support.scm 
    (list 'true? true?) 
    (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) 
     
    ;; the operations of thunk  
    (list 'delay-it delay-it) 
    (list 'thunk? thunk?) 
    (list 'evaluated-thunk? evaluated-thunk?) 
    (list 'thunk-exp thunk-exp) 
    (list 'thunk-env thunk-env) 
    (list 'thunk-value thunk-value) 
    (list 'set-car! set-car!) 
    (list 'set-cdr! set-cdr!) 
    (list 'cdr cdr) 
    (list 'car car) 
    (list 'pretty-print pretty-print) 
    (list 'display display) 
    ) 
    ) 
  
 (define ecleval 
   (make-machine 
    '(exp env val proc argl continue unev) 
    ecleval-operations 
   '( 
 ;;SECTION 5.4.4 
 read-eval-print-loop 
   (perform (op initialize-stack)) 
   (perform 
    (op prompt-for-input) (const ";;; LAZY-Eval input:")) 
   (assign exp (op read)) 
   (assign env (op get-global-environment)) 
   (assign continue (label print-result)) 
   (goto (label actual-value))           ;** 
 print-result 
 ;;**following instruction optional -- if use it, need monitored stack 
   (perform (op print-stack-statistics)) 
   (perform 
    (op announce-output) (const ";;; LAZY-Eval value:")) 
   (perform (op user-print) (reg val)) 
   (goto (label read-eval-print-loop)) 
  
 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 cond?) (reg exp)) 
   (branch (label ev-cond)) 
   (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)) 
   ;; (perform (op pretty-print) (reg continue)) ;TEST 
   (assign val (op make-procedure) 
           (reg unev) (reg exp) (reg env)) 
   ;; (perform (op pretty-print) (reg continue)) ;TEST 
   (goto (reg continue)) 
  
 ev-application                          ;EMPTY OPERANDS TODO 
   (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 actual-value))           ;** 
    
 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)) 
    
   (test (op compound-procedure?) (reg proc))   
   (branch (label compound-loop))        ;** 
      
   (save proc) 
   (test (op primitive-procedure?) (reg proc)) 
   (branch (label primitive-loop))       ;** 
  
   (restore proc) 
   (goto (label unknown-procedure-type)) 
  
 ;;; ** 
 primitive-loop 
  
   (save argl) 
    
   (assign exp (op first-operand) (reg unev)) 
    
   (test (op last-operand?) (reg unev)) 
   (branch (label primitive-last-arg)) 
    
   (save env) 
   (save unev) 
   (assign continue (label primitive-accumulate-arg)) 
   (goto (label actual-value)) 
  
 primitive-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 primitive-loop)) 
    
 primitive-last-arg 
   (assign continue (label primitive-accum-last-arg)) 
   (goto (label actual-value)) 
    
 primitive-accum-last-arg 
   (restore argl) 
   (assign argl (op adjoin-arg) (reg val) (reg argl)) 
   (restore proc) 
   (goto (label primitive-apply)) 
  
 primitive-apply 
   (assign val (op apply-primitive-procedure) 
               (reg proc) 
               (reg argl)) 
   (restore continue) 
   (goto (reg continue)) 
  
 ;;;** 
 compound-loop 
   (assign exp (op first-operand) (reg unev)) 
   (test (op last-operand?) (reg unev)) 
   (branch (label compound-accum-last-arg)) 
    
 compound-accumulate-arg 
   (assign val (op delay-it) (reg exp) (reg env)) ;** 
   (assign argl (op adjoin-arg) (reg val) (reg argl)) 
   (assign unev (op rest-operands) (reg unev)) 
   (goto (label compound-loop)) 
    
 compound-accum-last-arg 
   (assign val (op delay-it) (reg exp) (reg env)) ;** 
   (assign argl (op adjoin-arg) (reg val) (reg argl)) 
   (goto (label compound-apply)) 
    
 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)) 
  
 apply-dispatch 
   (test (op primitive-procedure?) (reg proc)) 
   (branch (label primitive-apply)) 
   (test (op compound-procedure?) (reg proc))   
   (branch (label compound-apply)) 
   (goto (label unknown-procedure-type)) 
 actual-value 
   (save continue) 
   (assign continue (label after-eval)) 
   (goto (label eval-dispatch)) 
    
 after-eval 
   (assign continue (label after-force)) 
   (goto (label force-it)) 
  
 after-force 
   (restore continue) 
   (goto (reg continue)) 
  
 force-it 
   (test (op thunk?) (reg val)) 
   (branch (label ev-thunk)) 
  
   (test (op evaluated-thunk?) (reg val)) 
   (branch (label ev-evaluated-thunk)) 
  
   (goto (reg continue)) 
  
 ev-thunk 
   (save continue) 
   (save val) 
    
   (assign env (op thunk-env) (reg val)) 
   (assign exp (op thunk-exp) (reg val)) 
   (assign continue (label after-thunk)) 
   (goto (label actual-value)) 
  
 after-thunk 
   ;; the register exp stores the thunk  
   (restore exp) 
   (restore continue) 
   (perform (op set-car!) (reg exp) (const evaluated-thunk)) 
   (assign exp (op cdr) (reg exp)) 
   (perform (op set-car!) (reg exp) (reg val)) 
   (perform (op set-cdr!) (reg exp) (const ())) 
   (goto (reg continue)) 
  
 ev-evaluated-thunk 
   (assign val (op thunk-value) (reg val)) 
   (goto (reg continue)) 
  
 ;;;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)) 
  
  
   ;;; Exercise 5.23 
 ev-cond 
   (assign exp (op cond->if) (reg exp)) 
   (goto (label eval-dispatch)) 
 ))) 
  
 '(EXPLICIT CONTROL LAZY EVALUATOR LOADED) 
  
  
 ;;;;;;;;;;;;;;;;;;;;;;;;;; 
 ;;;;;;;;;;test;;;;;;;;;;;; 
 ;;;;;;;;;;;;;;;;;;;;;;;;;; 
  
 ;;The procedures that prepare for the test 
 (define (cons x y) 
          (lambda (m) (m x y))) 
  
 (define (car z) 
          (z (lambda (p q) p))) 
  
 (define (cdr z) 
          (z (lambda (p q) q))) 
                   
  
 (define (list-ref items n) 
          (if (= n 0) 
              (car items) 
              (list-ref (cdr items) (- n 1)))) 
                   
 (define (map proc items) 
          (if (null? items) 
              '() 
              (cons (proc (car items)) 
                    (map proc (cdr items))))) 
                     
 (define (scale-list items factor) 
          (map (lambda (x) (* x factor)) 
               items)) 
  
 (define (add-lists list1 list2) 
          (cond ((null? list1) list2) 
                ((null? list2) list1) 
                (else (cons (+ (car list1) (car list2)) 
                            (add-lists (cdr list1) (cdr list2)))))) 
                             
 (define ones (cons 1 ones)) 
  
 (define integers (cons 1 (add-lists ones integers))) 
  
 (define (f) 1) 
  
 (define (g x y) (+ x y)) 
  
 ;;;;;;;;;;;;;;;;;;;;;; the test results 
  
 ;;; LAZY-Eval input: 
 (f) 
  
 (total-pushes = 5 maximum-depth = 5) 
 ;;; LAZY-Eval value: 
 1 
  
 ;;; LAZY-Eval input: 
 (g 1 2) 
  
 (total-pushes = 22 maximum-depth = 10) 
 ;;; LAZY-Eval value: 
 3 
  
 ;;; LAZY-Eval input: 
 (list-ref integers 20) 
  
 (total-pushes = 3833 maximum-depth = 217) 
 ;;; LAZY-Eval value: 
 21 
  
 ;;; LAZY-Eval input: 
 (list-ref integers 20) 
  
 (total-pushes = 1166 maximum-depth = 211) 
 ;;; LAZY-Eval value: 
 21 
  
 ;;; LAZY-Eval input: 
  (car integers) 
  
 (total-pushes = 22 maximum-depth = 8) 
 ;;; LAZY-Eval value: 
 1 
  
 ;;; LAZY-Eval input: 
  (car (cdr integers)) 
  
 (total-pushes = 43 maximum-depth = 15) 
 ;;; LAZY-Eval value: 
 2 
  
 ;;; LAZY-Eval input: 
  (+ 1 1) 
  
 (total-pushes = 12 maximum-depth = 7) 
 ;;; LAZY-Eval value: 
 2 
  
 ;;; LAZY-Eval input: 
 (+) 
  
 (total-pushes = 5 maximum-depth = 5) 
 ;;; LAZY-Eval value: 
 0 
  
 ;;; LAZY-Eval input: 
  (+ 1 1 1 1) 
  
 (total-pushes = 20 maximum-depth = 7) 
 ;;; LAZY-Eval value: 
 4 
  
 ;;; LAZY-Eval input: 
  (g 2 3) 
  
 (total-pushes = 22 maximum-depth = 10) 
 ;;; LAZY-Eval value: 
 5

closeparen

We can avoid duplicating the whole structure of list-of-arg-values and list-of-delayed-values by borrowing the "proc" register to switch between actual-value and delay-it mode, depending on whether this is a primitive or compound procedure.

Solution expressed here as a diff from 5.24. 

 ;; Parse error: Spurious closing paren found
--- 5.24.scm    2023-05-11 22:49:45.000000000 -0700
+++ 5.25.scm    2023-05-14 13:05:19.000000000 -0700
@@ -26,6 +26,7 @@
 (load "ch5-syntax.scm")
 (load "ch5-eceval-support.scm")

+;; let support
 (define (let? exp) (tagged-list? exp 'let))
 (define (let-bindings exp) (cadr exp))
 (define (let-body exp) (caddr exp))
@@ -38,6 +39,21 @@
     (make-lambda (bindings->names (let-bindings exp)) (list (let-body exp)))
     (bindings->values (let-bindings exp))))

+;; thunk support
+
+(define (delay-it exp env)
+    (list 'thunk exp env))
+
+(define (thunk? obj)
+    (tagged-list? obj 'thunk))
+
+(define (thunk-exp thunk)
+    (cadr thunk))
+
+(define (thunk-env thunk)
+    (caddr thunk))
+
+

 (define eceval-operations
   (list
@@ -108,6 +124,11 @@
    (list 'cdr cdr)
    (list 'sequence->exp sequence->exp)

+   (list 'delay-it delay-it)
+   (list 'thunk? thunk?)
+   (list 'thunk-exp thunk-exp)
+   (list 'thunk-env thunk-env)
+
    (list 'let? let?)
    (list 'let->lambda let->lambda)
    ))
@@ -125,7 +146,7 @@
   (assign exp (op read))
   (assign env (op get-global-environment))
   (assign continue (label print-result))
-  (goto (label eval-dispatch))
+  (goto (label ev-actual-value))
 print-result
 ;;**following instruction optional -- if use it, need monitored stack
   (perform (op print-stack-statistics))
@@ -147,6 +168,32 @@
   (perform (op user-print) (reg val))
   (goto (label read-eval-print-loop))

+;; caller must set up exp and env. does a normal eval, but then
+;; forces the result if it's a thunk
+ev-actual-value
+  (save continue)
+  (save exp)
+  (save env)
+  (assign continue (label ev-force-it))
+  (goto (label eval-dispatch))
+ev-force-it
+  (test (op thunk?) (reg val))
+  (branch (label ev-force-thunk))
+  (goto (label ev-actual-value-done))
+ev-force-thunk
+  (assign exp (op thunk-exp) (reg val))
+  (assign env (op thunk-env) (reg val))
+  (assign continue (label ev-actual-value-done))
+  (goto (label ev-actual-value))
+ev-actual-value-done
+  (restore env)
+  (restore exp)
+  (restore continue)
+  (goto (reg continue))
+ev-delay-it
+  (assign val (op delay-it) (reg exp) (reg env))
+  (goto (reg continue))
+
 ;;SECTION 5.4.1
 eval-dispatch
   (test (op self-evaluating?) (reg exp))
@@ -196,7 +243,7 @@
   (save unev)
   (assign exp (op operator) (reg exp))
   (assign continue (label ev-appl-did-operator))
-  (goto (label eval-dispatch))
+  (goto (label ev-actual-value))
 ev-appl-did-operator
   (restore unev)
   (restore env)
@@ -205,6 +252,16 @@
   (test (op no-operands?) (reg unev))
   (branch (label apply-dispatch))
   (save proc)
+ev-maybe-delay
+  ;; we need to either force or delay the arguments. rather than duplicating instructions,
+  ;; we will store which one to do in "proc". Proc is saved for us above.
+  (test (op compound-procedure?) (reg proc))
+  (branch (label ev-set-delay))
+  (assign proc (label ev-actual-value))
+  (goto (label ev-appl-operand-loop))
+ev-set-delay
+  (assign proc (label ev-delay-it))
+  (goto (label ev-appl-operand-loop))
 ev-appl-operand-loop
   (save argl)
   (assign exp (op first-operand) (reg unev))
@@ -213,8 +270,10 @@
   (save env)
   (save unev)
   (assign continue (label ev-appl-accumulate-arg))
-  (goto (label eval-dispatch))
+  (save proc)
+  (goto (reg proc)) ;; use the flag we set earlier
 ev-appl-accumulate-arg
+  (restore proc)
   (restore unev)
   (restore env)
   (restore argl)
@@ -282,7 +341,7 @@
   (save continue)
   (assign continue (label ev-if-decide))
   (assign exp (op if-predicate) (reg exp))
-  (goto (label eval-dispatch))
+  (goto (label ev-actual-value))
 ev-if-decide
   (restore continue)
   (restore env)
@@ -371,17 +430,16 @@

 (define the-global-environment (setup-environment))
 ;(eceval 'trace-on)
-;((eceval 'set-breakpoint) 'ev-cond-do 4)
-; (set-register-trace! eceval 'exp #t)
-; (set-register-trace! eceval 'unev #t)
+;((eceval 'set-breakpoint) 'ev-actual-value-done 3)
+;(set-register-trace! eceval 'exp #t)
+
 (start eceval)

-(define (f a b)
-  (let ((x a) (y b))
-    (cond ((> x y) 'first)
-          ((< x y) 'second)
-          (else 'neither))))
-
-(f 5 7)
-(f 7 5)
-(f 5 5)
\ No newline at end of file
+(define (unless test usual exceptional)
+    (if test exceptional usual))
+
+(define (divide-unless a b)
+    (unless (= b 0) (/ a b) 'bullshit))
+
+(divide-unless 15 5)
+(divide-unless 3 0)

thanhnguyen2187

I wrote the solution with detailed explanation here: https://nguyenhuythanh.com/posts/sicp-5.25/


Last modified : 2023-06-22 05:29:25
WiLiKi 0.5-tekili-7 running on Gauche 0.9