From 5902b43652ba64d532eb4d52d17fb2394c0542fd Mon Sep 17 00:00:00 2001 From: Felix Martin Date: Wed, 7 Apr 2021 22:14:42 -0400 Subject: [PATCH] Work on 5.25 --- misc/sicp-eceval.scm | 54 ++++++++++++++++++++++---- misc/sicp-leval.scm | 92 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 138 insertions(+), 8 deletions(-) create mode 100644 misc/sicp-leval.scm diff --git a/misc/sicp-eceval.scm b/misc/sicp-eceval.scm index b3126e1..ced4ac4 100644 --- a/misc/sicp-eceval.scm +++ b/misc/sicp-eceval.scm @@ -13,6 +13,7 @@ ;: (start eceval) (load "misc/sicp-eceval-support.scm") +(load "misc/sicp-leval.scm") ;; To restart, can do just ;: (start eceval) @@ -92,6 +93,11 @@ (list 'cond? cond?) (list 'let->combination let->combination) (list 'let? let?) + + ;;5.25 + (list 'delay-it delay-it) + (list 'thunk? thunk?) + )) (define eceval @@ -176,30 +182,62 @@ ev-appl-did-operator (test (op no-operands?) (reg unev)) (branch (label apply-dispatch)) (save proc) -ev-appl-operand-loop + + (test (op primitive-procedure?) (reg proc)) + (branch (label ev-appl-operand-loop-force)) + (test (op compound-procedure?) (reg proc)) + (branch (label ev-appl-operand-loop-delay)) + +ev-appl-operand-loop-force (save argl) (assign exp (op first-operand) (reg unev)) (test (op last-operand?) (reg unev)) - (branch (label ev-appl-last-arg)) + (branch (label ev-appl-last-arg-force)) (save env) (save unev) - (assign continue (label ev-appl-accumulate-arg)) + (assign continue (label ev-appl-accumulate-arg-force)) (goto (label eval-dispatch)) -ev-appl-accumulate-arg +ev-appl-accumulate-arg-force (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 ev-appl-operand-loop-force)) +ev-appl-last-arg-force + (assign continue (label ev-appl-accum-last-arg-force)) (goto (label eval-dispatch)) -ev-appl-accum-last-arg +ev-appl-accum-last-arg-force (restore argl) (assign argl (op adjoin-arg) (reg val) (reg argl)) (restore proc) (goto (label apply-dispatch)) + +ev-appl-operand-loop-delay + (save argl) + (assign exp (op first-operand) (reg unev)) + (test (op last-operand?) (reg unev)) + (branch (label ev-appl-last-arg-delay)) + (save env) + (save unev) + (assign continue (label ev-appl-accumulate-arg-delay)) + (goto (label eval-dispatch)) +ev-appl-accumulate-arg-delay + (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-delay)) +ev-appl-last-arg-delay + (assign continue (label ev-appl-accum-last-arg-delay)) + (goto (label eval-dispatch)) +ev-appl-accum-last-arg-delay + (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)) diff --git a/misc/sicp-leval.scm b/misc/sicp-leval.scm new file mode 100644 index 0000000..607cac3 --- /dev/null +++ b/misc/sicp-leval.scm @@ -0,0 +1,92 @@ +;;;;LAZY EVALUATOR FROM SECTION 4.2 OF +;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS + +;;;;Matches code in ch4.scm +;;;; Also includes enlarged primitive-procedures list + +;;;;This file can be loaded into Scheme as a whole. +;;;;**NOTE**This file loads the metacircular evaluator of +;;;; sections 4.1.1-4.1.4, since it uses the expression representation, +;;;; environment representation, etc. +;;;; You may need to change the (load ...) expression to work in your +;;;; version of Scheme. +;;;;**WARNING: Don't load mceval twice (or you'll lose the primitives +;;;; interface, due to renamings of apply). + +;;;;Then you can initialize and start the evaluator by evaluating +;;;; the two lines at the end of the file ch4-mceval.scm +;;;; (setting up the global environment and starting the driver loop). + + +;;;; To run without memoization, reload the first version of force-it below + + +;;**implementation-dependent loading of evaluator file +;;Note: It is loaded first so that the section 4.2 definition +;; of eval overrides the definition from 4.1.1 + +;;;SECTION 4.2.2 + +;;; Modifying the evaluator + +(define (actual-value exp env) + (force-it (eval exp env))) + +(define (list-of-arg-values exps env) + (if (no-operands? exps) + '() + (cons (actual-value (first-operand exps) env) + (list-of-arg-values (rest-operands exps) + env)))) + +(define (list-of-delayed-args exps env) + (if (no-operands? exps) + '() + (cons (delay-it (first-operand exps) env) + (list-of-delayed-args (rest-operands exps) + env)))) + +(define (eval-if exp env) + (if (true? (actual-value (if-predicate exp) env)) + (eval (if-consequent exp) env) + (eval (if-alternative exp) env))) + +(define (force-it obj) + (if (thunk? obj) + (actual-value (thunk-exp obj) (thunk-env obj)) + obj)) + +;; thunks + +(define (delay-it exp env) + (list 'thunk exp env)) + +(define (thunk? obj) + (and (pair? obj) + (= (length obj) 3) + (tagged-list? obj 'thunk))) + +(define (thunk-exp thunk) (cadr thunk)) +(define (thunk-env thunk) (caddr thunk)) + +;; "thunk" that has been forced and is storing its (memoized) value +(define (evaluated-thunk? obj) + (tagged-list? obj 'evaluated-thunk)) + +(define (thunk-value evaluated-thunk) (cadr evaluated-thunk)) + +;; memoizing version of force-it +(define (force-it obj) + (cond ((thunk? obj) + (let ((result (actual-value + (thunk-exp obj) + (thunk-env obj)))) + (set-car! obj 'evaluated-thunk) + (set-car! (cdr obj) result) ; replace exp with its value + (set-cdr! (cdr obj) '()) ; forget unneeded env + result)) + ((evaluated-thunk? obj) + (thunk-value obj)) + (else obj))) + +'LAZY-EVALUATOR-LOADED