summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ps03_evalapply/bnewbold_interp.scm141
-rw-r--r--ps03_evalapply/bnewbold_ps3.txt38
-rw-r--r--ps03_evalapply/general-procedures.scm141
-rw-r--r--ps03_evalapply/ghelper.scm102
-rw-r--r--ps03_evalapply/interp.scm131
-rw-r--r--ps03_evalapply/kons.scm12
-rw-r--r--ps03_evalapply/load-general.scm17
-rw-r--r--ps03_evalapply/load.scm13
-rw-r--r--ps03_evalapply/ps.txt317
-rw-r--r--ps03_evalapply/repl.scm48
-rw-r--r--ps03_evalapply/rtdata.scm88
-rw-r--r--ps03_evalapply/syntax.scm188
-rw-r--r--ps03_evalapply/utils.scm17
13 files changed, 1253 insertions, 0 deletions
diff --git a/ps03_evalapply/bnewbold_interp.scm b/ps03_evalapply/bnewbold_interp.scm
new file mode 100644
index 0000000..67bcad1
--- /dev/null
+++ b/ps03_evalapply/bnewbold_interp.scm
@@ -0,0 +1,141 @@
+(declare (usual-integrations eval apply))
+
+(define (default-eval expression environment)
+ (cond ((application? expression)
+ (apply (eval (operator expression) environment)
+ (operands expression)
+ environment))
+ (else
+ (error "Unknown expression type" expression))))
+
+(define (default-apply procedure operands calling-environment)
+ (error "Unknown procedure type" procedure))
+
+
+
+(define eval
+ (make-generic-operator 2 default-eval))
+
+(defhandler eval
+ (lambda (expression environment) expression)
+ self-evaluating?)
+
+(defhandler eval lookup-variable-value variable?)
+
+(defhandler eval
+ (lambda (expression environment)
+ (text-of-quotation expression))
+ quoted?)
+
+(defhandler eval
+ (lambda (expression environment)
+ (make-compound-procedure
+ (lambda-parameters expression)
+ (lambda-body expression)
+ environment))
+ lambda?)
+
+(defhandler eval
+ (lambda (expression environment)
+ (if (eval (if-predicate expression) environment)
+ (eval (if-consequent expression) environment)
+ (eval (if-alternative expression) environment)))
+ if?)
+
+(defhandler eval
+ (lambda (expression environment)
+ (eval (cond->if expression) environment))
+ cond?)
+
+(defhandler eval
+ (lambda (expression environment)
+ (eval (let->combination expression) environment))
+ let?)
+
+(defhandler eval
+ (lambda (expression environment)
+ (evaluate-sequence (begin-actions expression)
+ environment))
+ begin?)
+
+(define (evaluate-sequence actions environment)
+ (cond ((null? actions)
+ (error "Empty sequence"))
+ ((null? (rest-exps actions))
+ (eval (first-exp actions) environment))
+ (else
+ (eval (first-exp actions) environment)
+ (evaluate-sequence (rest-exps actions) environment))))
+
+(defhandler eval
+ (lambda (expression environment)
+ (define-variable! (definition-variable expression)
+ (eval (definition-value expression) environment)
+ environment)
+ (definition-variable expression))
+ definition?)
+
+(defhandler eval
+ (lambda (expression environment)
+ (set-variable-value! (assignment-variable expression)
+ (eval (assignment-value expression) environment)
+ environment))
+ assignment?)
+
+(define apply
+ (make-generic-operator 3 default-apply))
+
+(defhandler apply
+ (lambda (procedure operands calling-environment)
+ (apply-primitive-procedure procedure
+ (evaluate-list operands calling-environment)))
+ strict-primitive-procedure?)
+
+(define (evaluate-list operands calling-environment)
+ (cond ((null? operands) '())
+ ((null? (rest-operands operands))
+ (list (eval (first-operand operands)
+ calling-environment)))
+ (else
+ (cons (eval (first-operand operands)
+ calling-environment)
+ (evaluate-list (rest-operands operands)
+ calling-environment)))))
+
+(defhandler apply
+ (lambda (procedure operands calling-environment)
+ (if (not (= (length (procedure-parameters procedure))
+ (length operands)))
+ (error "Wrong number of operands supplied"))
+ (let ((arguments
+ (map (lambda (parameter operand)
+ (evaluate-procedure-operand parameter
+ operand
+ calling-environment))
+ (procedure-parameters procedure)
+ operands)))
+ (eval (procedure-body procedure)
+ (extend-environment
+ (map procedure-parameter-name
+ (procedure-parameters procedure))
+ arguments
+ (procedure-environment procedure)))))
+ compound-procedure?)
+
+(defhandler apply
+ (lambda (proc-vector operands calling-environment)
+ (vector-map
+ (lambda (proc) (apply proc
+ operands
+ calling-environment))
+ proc-vector))
+ vector?)
+
+(define evaluate-procedure-operand
+ (make-generic-operator 3
+ (lambda (parameter operand environment)
+ (eval operand environment))))
+
+(define procedure-parameter-name
+ (make-generic-operator 1 (lambda (x) x)))
+
diff --git a/ps03_evalapply/bnewbold_ps3.txt b/ps03_evalapply/bnewbold_ps3.txt
new file mode 100644
index 0000000..3d80a95
--- /dev/null
+++ b/ps03_evalapply/bnewbold_ps3.txt
@@ -0,0 +1,38 @@
+;;; 6.945 Problem Set #3
+;;; 02/25/2009
+;;; Bryan Newbold <bnewbold@mit.edu>
+
+
+Problem 3.1
+------------------------
+(shouldn't be too hard, handling vectors of procedures as procedures)
+
+
+Problem 3.2
+------------------------
+(use tagged variable symbols?)
+(use tagged function symbols?)
+
+Problem 3.3
+------------------------
+a.
+(description)
+
+b.
+(description...?)
+
+
+Problem 3.4
+------------------------
+a.
+(non-memoizing: generation of random lists? generators? streams?)
+
+b.
+(not sure)
+
+c.
+(not sure)
+
+Problem 3.5
+------------------------
+(ahhh! open ended project!)
diff --git a/ps03_evalapply/general-procedures.scm b/ps03_evalapply/general-procedures.scm
new file mode 100644
index 0000000..2412500
--- /dev/null
+++ b/ps03_evalapply/general-procedures.scm
@@ -0,0 +1,141 @@
+;;; Modifications to provide for general procedures.
+
+;;; Syntax extension: allow decorated parameter names.
+
+(defhandler procedure-parameter-name car pair?)
+
+
+;;; run-time-data extension
+
+(define (delay expression environment)
+ (vector 'delayed expression environment))
+
+(define (delay-memo expression environment)
+ (vector 'delayed-memo expression environment))
+
+(define (delayed? x)
+ (and (vector? x)
+ (eq? (vector-ref x 0) 'delayed)))
+
+(define (delayed-memo? x)
+ (and (vector? x)
+ (eq? (vector-ref x 0) 'delayed-memo)))
+
+(define (deferred? x)
+ (or (delayed? x) (delayed-memo? x)))
+
+(define (undelayed-memo? x)
+ (and (vector? x)
+ (eq? (vector-ref x 0) 'undelayed-memo)))
+
+(define (delayed-expression x)
+ (vector-ref x 1))
+
+(define (delayed-environment x)
+ (vector-ref x 2))
+
+
+(define (undelay-memo! x value)
+ (vector-set! x 0 'undelayed-memo)
+ (vector-set! x 1 value)
+ (vector-set! x 2 the-empty-environment))
+
+(define (undelayed-value x)
+ (vector-ref x 1))
+
+;;; Evaluator extension -- change to IF:
+;;; Must have actual predicate value to proceed from IF.
+
+(defhandler eval
+ (lambda (expression environment)
+ (if (undelay!
+ (eval (if-predicate expression) environment))
+ (eval (if-consequent expression) environment)
+ (eval (if-alternative expression) environment)))
+ if?)
+
+
+;;; Apply extension:
+;;; Must have actual procedure to apply it.
+
+(defhandler apply
+ (lambda (procedure operands calling-environment)
+ (apply (undelay! procedure)
+ operands
+ calling-environment))
+ deferred?)
+
+
+;;; Must have values of arguments for strict primitives.
+
+(define (evaluate-list operands calling-environment)
+ (cond ((null? operands) '())
+ ((null? (rest-operands operands))
+ (list (undelay! (eval (first-operand operands)
+ calling-environment))))
+ (else
+ (cons (undelay! (eval (first-operand operands)
+ calling-environment))
+ (evaluate-list (rest-operands operands)
+ calling-environment)))))
+
+
+(defhandler evaluate-procedure-operand
+ (lambda (parameter operand environment)
+ (delay operand environment))
+ lazy?)
+
+(defhandler evaluate-procedure-operand
+ (lambda (parameter operand environment)
+ (delay-memo operand environment))
+ lazy-memo?)
+
+(define undelay!
+ (make-generic-operator 1 (lambda (x) x)))
+
+(defhandler undelay!
+ (lambda (object)
+ (undelay! (eval (delayed-expression object)
+ (delayed-environment object))))
+ delayed?)
+
+(defhandler undelay!
+ (lambda (object)
+ (let ((value
+ (undelay! (eval (delayed-expression object)
+ (delayed-environment object)))))
+ (undelay-memo! object value)
+ value))
+ delayed-memo?)
+
+(defhandler undelay!
+ undelayed-value
+ undelayed-memo?)
+
+
+;;; For printing output
+
+(defhandler write
+ (compose write undelay!)
+ deferred?)
+
+(defhandler write-line
+ (compose write-line undelay!)
+ deferred?)
+
+(defhandler pp
+ (compose pp undelay!)
+ deferred?)
+
+
+(defhandler write
+ (compose write undelayed-value)
+ undelayed-memo?)
+
+(defhandler write-line
+ (compose write-line undelayed-value)
+ undelayed-memo?)
+
+(defhandler pp
+ (compose pp undelayed-value)
+ undelayed-memo?)
diff --git a/ps03_evalapply/ghelper.scm b/ps03_evalapply/ghelper.scm
new file mode 100644
index 0000000..7b8613d
--- /dev/null
+++ b/ps03_evalapply/ghelper.scm
@@ -0,0 +1,102 @@
+;;;; Most General Generic-Operator Dispatch
+
+(declare (usual-integrations))
+
+;;; Generic-operator dispatch is implemented here by a discrimination
+;;; list, where the arguments passed to the operator are examined by
+;;; predicates that are supplied at the point of attachment of a
+;;; handler (by ASSIGN-OPERATION).
+
+;;; To be the correct branch all arguments must be accepted by
+;;; the branch predicates, so this makes it necessary to
+;;; backtrack to find another branch where the first argument
+;;; is accepted if the second argument is rejected. Here
+;;; backtracking is implemented by OR.
+
+(define (make-generic-operator arity default-operation)
+ (let ((record (make-operator-record arity)))
+
+ (define (operator . arguments)
+ (if (not (= (length arguments) arity))
+ (error:wrong-number-of-arguments operator arity arguments))
+ (let ((succeed
+ (lambda (handler)
+ (apply handler arguments))))
+ (let per-arg
+ ((tree (operator-record-tree record))
+ (args arguments)
+ (fail
+ (lambda ()
+ (error:no-applicable-methods operator arguments))))
+ (let per-pred ((tree tree) (fail fail))
+ (cond ((pair? tree)
+ (if ((caar tree) (car args))
+ (if (pair? (cdr args))
+ (per-arg (cdar tree)
+ (cdr args)
+ (lambda ()
+ (per-pred (cdr tree) fail)))
+ (succeed (cdar tree)))
+ (per-pred (cdr tree) fail)))
+ ((null? tree)
+ (fail))
+ (else
+ (succeed tree)))))))
+
+ (hash-table/put! *generic-operator-table* operator record)
+ (if default-operation
+ (assign-operation operator default-operation))
+ operator))
+
+(define *generic-operator-table*
+ (make-eq-hash-table))
+
+(define (make-operator-record arity) (cons arity '()))
+(define (operator-record-arity record) (car record))
+(define (operator-record-tree record) (cdr record))
+(define (set-operator-record-tree! record tree) (set-cdr! record tree))
+
+(define (assign-operation operator handler . argument-predicates)
+ (let ((record
+ (let ((record (hash-table/get *generic-operator-table* operator #f))
+ (arity (length argument-predicates)))
+ (if record
+ (begin
+ (if (not (<= arity (operator-record-arity record)))
+ (error "Incorrect operator arity:" operator))
+ record)
+ (let ((record (make-operator-record arity)))
+ (hash-table/put! *generic-operator-table* operator record)
+ record)))))
+ (set-operator-record-tree! record
+ (bind-in-tree argument-predicates
+ handler
+ (operator-record-tree record))))
+ operator)
+
+(define defhandler assign-operation)
+
+(define (bind-in-tree keys handler tree)
+ (let loop ((keys keys) (tree tree))
+ (if (pair? keys)
+ (let find-key ((tree* tree))
+ (if (pair? tree*)
+ (if (eq? (caar tree*) (car keys))
+ (begin
+ (set-cdr! (car tree*)
+ (loop (cdr keys) (cdar tree*)))
+ tree)
+ (find-key (cdr tree*)))
+ (cons (cons (car keys)
+ (loop (cdr keys) '()))
+ tree)))
+ (if (pair? tree)
+ (let ((p (last-pair tree)))
+ (if (not (null? (cdr p)))
+ (warn "Replacing a handler:" (cdr p) handler))
+ (set-cdr! p handler)
+ tree)
+ (begin
+ (if (not (null? tree))
+ (warn "Replacing top-level handler:" tree handler))
+ handler))))) \ No newline at end of file
diff --git a/ps03_evalapply/interp.scm b/ps03_evalapply/interp.scm
new file mode 100644
index 0000000..f16ad8b
--- /dev/null
+++ b/ps03_evalapply/interp.scm
@@ -0,0 +1,131 @@
+(declare (usual-integrations eval apply))
+
+(define (default-eval expression environment)
+ (cond ((application? expression)
+ (apply (eval (operator expression) environment)
+ (operands expression)
+ environment))
+ (else
+ (error "Unknown expression type" expression))))
+
+(define (default-apply procedure operands calling-environment)
+ (error "Unknown procedure type" procedure))
+
+
+
+(define eval
+ (make-generic-operator 2 default-eval))
+
+(defhandler eval
+ (lambda (expression environment) expression)
+ self-evaluating?)
+
+(defhandler eval lookup-variable-value variable?)
+
+(defhandler eval
+ (lambda (expression environment)
+ (text-of-quotation expression))
+ quoted?)
+
+(defhandler eval
+ (lambda (expression environment)
+ (make-compound-procedure
+ (lambda-parameters expression)
+ (lambda-body expression)
+ environment))
+ lambda?)
+
+(defhandler eval
+ (lambda (expression environment)
+ (if (eval (if-predicate expression) environment)
+ (eval (if-consequent expression) environment)
+ (eval (if-alternative expression) environment)))
+ if?)
+
+(defhandler eval
+ (lambda (expression environment)
+ (eval (cond->if expression) environment))
+ cond?)
+
+(defhandler eval
+ (lambda (expression environment)
+ (eval (let->combination expression) environment))
+ let?)
+
+(defhandler eval
+ (lambda (expression environment)
+ (evaluate-sequence (begin-actions expression)
+ environment))
+ begin?)
+
+(define (evaluate-sequence actions environment)
+ (cond ((null? actions)
+ (error "Empty sequence"))
+ ((null? (rest-exps actions))
+ (eval (first-exp actions) environment))
+ (else
+ (eval (first-exp actions) environment)
+ (evaluate-sequence (rest-exps actions) environment))))
+
+(defhandler eval
+ (lambda (expression environment)
+ (define-variable! (definition-variable expression)
+ (eval (definition-value expression) environment)
+ environment)
+ (definition-variable expression))
+ definition?)
+
+(defhandler eval
+ (lambda (expression environment)
+ (set-variable-value! (assignment-variable expression)
+ (eval (assignment-value expression) environment)
+ environment))
+ assignment?)
+
+(define apply
+ (make-generic-operator 3 default-apply))
+
+(defhandler apply
+ (lambda (procedure operands calling-environment)
+ (apply-primitive-procedure procedure
+ (evaluate-list operands calling-environment)))
+ strict-primitive-procedure?)
+
+(define (evaluate-list operands calling-environment)
+ (cond ((null? operands) '())
+ ((null? (rest-operands operands))
+ (list (eval (first-operand operands)
+ calling-environment)))
+ (else
+ (cons (eval (first-operand operands)
+ calling-environment)
+ (evaluate-list (rest-operands operands)
+ calling-environment)))))
+
+(defhandler apply
+ (lambda (procedure operands calling-environment)
+ (if (not (= (length (procedure-parameters procedure))
+ (length operands)))
+ (error "Wrong number of operands supplied"))
+ (let ((arguments
+ (map (lambda (parameter operand)
+ (evaluate-procedure-operand parameter
+ operand
+ calling-environment))
+ (procedure-parameters procedure)
+ operands)))
+ (eval (procedure-body procedure)
+ (extend-environment
+ (map procedure-parameter-name
+ (procedure-parameters procedure))
+ arguments
+ (procedure-environment procedure)))))
+ compound-procedure?)
+
+(define evaluate-procedure-operand
+ (make-generic-operator 3
+ (lambda (parameter operand environment)
+ (eval operand environment))))
+
+(define procedure-parameter-name
+ (make-generic-operator 1 (lambda (x) x)))
diff --git a/ps03_evalapply/kons.scm b/ps03_evalapply/kons.scm
new file mode 100644
index 0000000..4fc7b73
--- /dev/null
+++ b/ps03_evalapply/kons.scm
@@ -0,0 +1,12 @@
+;;; A valuable special form -- the nonstrict version of CONS:
+
+(define (kons? exp)
+ (and (pair? exp)
+ (eq? (car exp) 'kons)))
+
+(defhandler eval
+ (lambda (expression environment)
+ (cons (delay-memo (cadr expression) environment)
+ (delay-memo (caddr expression) environment)))
+ kons?)
+
diff --git a/ps03_evalapply/load-general.scm b/ps03_evalapply/load-general.scm
new file mode 100644
index 0000000..569aeba
--- /dev/null
+++ b/ps03_evalapply/load-general.scm
@@ -0,0 +1,17 @@
+(load "utils" user-initial-environment)
+(load "ghelper" user-initial-environment)
+(load "syntax" user-initial-environment)
+(load "rtdata" user-initial-environment)
+
+
+(define generic-evaluation-environment
+ (extend-top-level-environment user-initial-environment))
+
+(load "interp" generic-evaluation-environment)
+(load "repl" generic-evaluation-environment)
+
+;;; This allows nonstrict definitions.
+(load "general-procedures" generic-evaluation-environment)
+(load "kons" generic-evaluation-environment)
+
+(ge generic-evaluation-environment) \ No newline at end of file
diff --git a/ps03_evalapply/load.scm b/ps03_evalapply/load.scm
new file mode 100644
index 0000000..ebca908
--- /dev/null
+++ b/ps03_evalapply/load.scm
@@ -0,0 +1,13 @@
+(load "utils" user-initial-environment)
+(load "ghelper" user-initial-environment)
+(load "syntax" user-initial-environment)
+(load "rtdata" user-initial-environment)
+
+
+(define generic-evaluation-environment
+ (extend-top-level-environment user-initial-environment))
+
+(load "bnewbold_interp" generic-evaluation-environment)
+(load "repl" generic-evaluation-environment)
+
+(ge generic-evaluation-environment)
diff --git a/ps03_evalapply/ps.txt b/ps03_evalapply/ps.txt
new file mode 100644
index 0000000..389affa
--- /dev/null
+++ b/ps03_evalapply/ps.txt
@@ -0,0 +1,317 @@
+
+
+ MASSACHVSETTS INSTITVTE OF TECHNOLOGY
+ Department of Electrical Engineering and Computer Science
+
+ 6.945 Spring 2009
+ Problem Set 3
+
+ Issued: Wed. 18 Feb. 2009 Due: Wed. 25 Feb. 2009
+
+Reading:
+ SICP, From Chapter 4: 4.1 and 4.2; (pp. 359--411)
+ en.wikipedia.org/wiki/Evaluation_strategy
+ www.cs.indiana.edu/cgi-bin/techreports/TRNNN.cgi?trnum=TR44
+
+Code: load.scm, utils.scm, ghelper.scm,
+ syntax.scm, rtdata.scm, interp.scm, repl.scm
+ general-procedures.scm
+ code is on the class web page... no reason to kill more trees.
+
+
+Evaluators for Extended Scheme
+
+You will be working with an evaluator system for an extended version
+of Scheme similar to the ones described in SICP, Chapter 4. Without a
+good understanding of how the evaluator is structured it is very easy
+to become confused between the programs that the evaluator is
+interpreting, the procedures that implement the evaluator itself, and
+Scheme procedures called by the evaluator. You will need to study
+Chapter 4 through subsection 4.2.2 carefully in order to do this
+assignment.
+
+The interpreters in the code that we will work with in this problem
+set are built on the generic operations infrastructure we developed in
+the last problem set. (Actually, there is a small change: we specify
+a handler with "defhandler" as an alias for "assign-operation". Also,
+we allow handlers to be specified without declaring all of the
+arguments, avoiding the need for "any?".) Indeed, in these
+interpreters, unlike the ones in SICP, EVAL and APPLY are generic
+operations! That means that we may easily extend the types of
+expressons (by adding new handlers to EVAL) and the types of
+procedures (by adding new handlers to APPLY).
+
+Before beginning work on this problem set you should carefully read
+the code in interp.scm. Also, look at the difference between the
+ghelper.scm in this problem set and the ghelper.scm in the previous
+set.
+
+ Using the generic interpreter
+
+Download the supplied code to a fresh directory in your computer.
+Get a fresh Scheme system, and load the file load.scm:
+
+ (load "<your-code-directory>/load")
+
+Initialize the evaluator:
+
+ (init)
+
+You will get a prompt:
+
+ eval>
+
+You can enter an expression at the prompt:
+
+ eval> (define cube (lambda (x) (* x x x)))
+ cube
+
+ eval> (cube 3)
+ 27
+
+The evaluator code we supplied does not have an error system of its
+own, so it reverts to the underlying Scheme error system. (Maybe an
+interesting little project? It is worth understanding how to make
+exception-handling systems!) If you get an error, clear the error
+with two control Cs and then continue the evaluator with "(go)" at the
+Scheme. If you redo "(init)" you will lose the definition of cube,
+because a new environment will be made.
+
+ eval> (cube a)
+ ;Unbound variable a
+ ;Quit!
+
+ (go)
+
+ eval> (cube 4)
+ 64
+
+ eval> (define (fib n)
+ (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
+ fib
+
+ eval> (fib 10)
+ 55
+
+You can always get out of the generic evaluator and get back to the
+underlying Scheme system by quitting (with two control Cs).
+
+-------------
+Problem 3.1: Warmup
+
+In mathematical text a common abuse of notation is to identify a
+tuple of functions with a function that returns a tuple of values.
+For example, (written in Lisp prefix form)
+
+ If (cos 0.6) ==> 0.8253356149096783
+ and (sin 0.6) ==> 0.5646424733950354
+
+ then we expect
+
+ ((vector cos sin) 0.6) ==> #(0.8253356149096783 0.5646424733950354)
+
+This requires that an extension to APPLY so it can handle Scheme
+vectors as a kind of function. Make this extension; demonstrate it;
+show that it interoperates with more conventional code.
+-------------
+
+
+-------------
+Problem 3.2: Unbound-variable handling
+
+In Lisps, including Scheme, attempting to evaluate an unbound symbol
+is an unbound-variable error. However, in some algebraic processes it
+is sensible to allow an unbound symbol to be a self-evaluating object.
+For example, if we generically extend arithmetic to build algebraic
+expressions with symbolic values, it is sometimes useful to allow the
+following:
+
+(+ (* 2 3) (* 4 5)) ==> 26
+
+(+ (* a 3) (* 4 5)) ==> (+ (* a 3) 20)
+
+In this case, the symbol "a" is unbound and self-evaluating. The
+operators "*" and "+" are extended to just build expressions when
+their arguments are not reducible to numbers.
+
+Make generic extensions to +, *, -, /, and to EVAL, to allow this kind
+of behavior.
+
+Also augment APPLY to allow literal functions, known only by their
+names:
+
+(+ (f 3) (* 4 5)) ==> (+ (f 3) 20)
+
+These extensions to EVAL and APPLY are generally dangerous, because
+they hide real unbound-variable errors. Make them contingent on the
+value of a user-settable variable: ALLOW-SELF-EVALUATING-SYMBOLS.
+-------------
+
+Much more powerful extensions are available once we accept generic
+operations at this level. For example, we can allow procedures to
+have both strict and non-strict arguments.
+
+ If you don't know what we are talking about here please read
+ the article: http://en.wikipedia.org/wiki/Evaluation_strategy.
+
+If you load the file general-procedures.scm into the underlying
+Scheme, after loading (with '(load "load")') the generic interpreter,
+you will find that there are extensions that allow us to define
+procedures with some formal parameters asking for the matching
+arguments to be lazy (or lazy and memoized). Other undecorated
+parameters take their arguments strictly. These extensions make it
+relatively easy to play otherwise painful games. For example, we may
+define the UNLESS conditional as an ordinary procedure:
+
+ ;Quit!
+
+ (load "general-procedures" generic-evaluation-environment)
+ ;Loading "general-procedures.scm"...
+ ;Warning: Replacing top-level handler
+ ;... done
+ ;Value: #[compound-procedure 17 operator]
+
+
+ (go)
+
+ eval> (define unless
+ (lambda (condition (usual lazy) (exception lazy))
+ (if condition exception usual)))
+
+We may use the usual define abbreviations (see syntax.scm):
+
+ eval> (define (unless condition (usual lazy) (exception lazy))
+ (if condition exception usual))
+ unless
+
+ eval> (define (ffib n)
+ (unless (< n 2)
+ (+ (ffib (- n 1)) (ffib (- n 2)))
+ n))
+ ffib
+
+ eval> (ffib 10)
+ 55
+
+Notice that UNLESS is declared to be strict in its first argument (the
+predicate) but nonstrict in the alternatives: neither alternative will
+be evaluated until it is necessary.
+
+Additionally, if we include the file kons.scm we get a special form
+that is the non-strict memoized version of CONS. This immediately
+gives us the power of infinite streams:
+
+ ;Quit!
+
+ (load "kons" generic-evaluation-environment)
+ ;Loading "kons.scm"... done
+ ;Value: #[compound-procedure 19 operator]
+
+ (go)
+
+ eval> (define (add-streams s1 s2)
+ (kons (+ (car s1) (car s2))
+ (add-streams (cdr s1) (cdr s2))))
+ add-streams
+
+ eval> (define (ref-stream stream n)
+ (if (= n 0)
+ (car stream)
+ (ref-stream (cdr stream) (- n 1))))
+ ref-stream
+
+ eval> (define fibs
+ (kons 0
+ (kons 1
+ (add-streams (cdr fibs) fibs))))
+ fibs
+
+ eval> (ref-stream fibs 10)
+ 55
+
+ eval> (ref-stream fibs 20)
+ 6765
+
+ eval> (ref-stream fibs 30)
+ 832040
+
+ eval> (ref-stream fibs 40)
+ 102334155
+
+
+-------------
+Problem 3.3: Streams
+
+a. The non-strict procedure KONS adds great power to the system.
+Notice that there is no need to make CAR or CDR different to obtain
+the use of streams. In a short paragraph explain why KONS is almost
+sufficient. It may be instructive to read an ancient paper by
+Friedman and Wise:
+ www.cs.indiana.edu/cgi-bin/techreports/TRNNN.cgi?trnum=TR44
+
+b. Unfortunately, the addition of KONS does not, in itself, solve all
+stream problems. For example, the difficulty alluded to in SICP
+section 4.2.3 (p. 411) does not automatically dissipate. If we make
+the following definitions:
+
+ (define (map-stream proc items)
+ (kons (proc (car items))
+ (map-stream proc (cdr items))))
+
+ (define (scale-stream items factor)
+ (map-stream (lambda (x) (* x factor))
+ items))
+
+ (define (integral integrand initial-value dt)
+ (define int
+ (kons initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+ (define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map-stream f y))
+ y)
+
+and then we try:
+
+ (ref-stream (solve (lambda (x) x) 1 0.001) 1000)
+
+we will get an error (try it!). Why? Explain the error. What other
+declarations should be made in these stream-procedure definitions to
+fix all such errors?
+-------------
+
+
+-------------
+Problem 3.4: Why not?
+
+a. The KONS special form is equivalent to a CONS with both arguments
+lazy and memoized. If the arguments were not memoized the computation
+(ref-stream fibs 40) in Problem 3.3a above would take a very long
+time. Is there ever any advantage to not memoizing? When might it
+matter?
+
+b. Why, given that CONS is a strict procedure imported from Scheme,
+could we not have defined KONS simply as:
+
+ (define (kons (a lazy memo) (d lazy memo))
+ (cons a d))
+?
+
+c. More generally, the Lisp community has avoided changing CONS to be
+KONS, as recommended by Friedman and Wise. What potentially serious
+problems are avoided by using CONS rather than KONS? Assume that we
+do not care about small constant factors in performance.
+-------------
+
+
+-------------
+Problem 3.5: Your turn
+
+Invent some fun, interesting construct that can easily be implemented
+using generic EVAL/APPLY that would be rather painful without that
+kind of generic support. Show us the construct, the implementation,
+and some illustrative examples. Enjoy!
+-------------
diff --git a/ps03_evalapply/repl.scm b/ps03_evalapply/repl.scm
new file mode 100644
index 0000000..94a0500
--- /dev/null
+++ b/ps03_evalapply/repl.scm
@@ -0,0 +1,48 @@
+(declare (usual-integrations write write-line pp eval))
+
+(define write
+ (make-generic-operator 1
+ (access write user-initial-environment)))
+
+(define write-line
+ (make-generic-operator 1
+ (access write-line user-initial-environment)))
+
+(define pp
+ (make-generic-operator 1
+ (access pp user-initial-environment)))
+
+(define (procedure-printable-representation procedure)
+ `(compound-procedure
+ ,(procedure-parameters procedure)
+ ,(procedure-body procedure)
+ <procedure-environment>))
+
+(defhandler write
+ (compose write procedure-printable-representation)
+ compound-procedure?)
+
+(defhandler write-line
+ (compose write-line procedure-printable-representation)
+ compound-procedure?)
+
+(defhandler pp
+ (compose pp procedure-printable-representation)
+ compound-procedure?)
+
+
+ (define (read) (prompt-for-command-expression "eval> "))
+
+(define the-global-environment)
+
+(define (init)
+ (set! the-global-environment
+ (extend-environment '() '() the-empty-environment))
+ (repl))
+
+(define (repl)
+ (let ((input (read)))
+ (write-line (eval input the-global-environment))
+ (repl)))
+
+(define go repl)
diff --git a/ps03_evalapply/rtdata.scm b/ps03_evalapply/rtdata.scm
new file mode 100644
index 0000000..dad3d7a
--- /dev/null
+++ b/ps03_evalapply/rtdata.scm
@@ -0,0 +1,88 @@
+;;; -*- Mode:Scheme -*-
+
+(declare (usual-integrations))
+
+(define the-unspecified-value (list 'the-unspecified-value))
+
+(define (true? x)
+ (if x true false))
+
+(define (false? x)
+ (if x false true))
+
+;;; Primitive procedures are inherited from Scheme.
+
+(define strict-primitive-procedure? procedure?)
+(define apply-primitive-procedure apply)
+
+
+;;; Compound procedures
+
+(define (make-compound-procedure vars bproc env)
+ (vector 'compound-procedure vars bproc env))
+
+(define (compound-procedure? obj)
+ (and (vector? obj)
+ (eq? (vector-ref obj 0) 'compound-procedure)))
+
+(define (procedure-parameters p) (vector-ref p 1))
+(define (procedure-body p) (vector-ref p 2))
+(define (procedure-environment p) (vector-ref p 3))
+
+;;; An ENVIRONMENT is a chain of FRAMES, made of vectors.
+
+(define (extend-environment variables values base-environment)
+ (if (fix:= (length variables) (length values))
+ (vector variables values base-environment)
+ (if (fix:< (length variables) (length values))
+ (error "Too many arguments supplied" variables values)
+ (error "Too few arguments supplied" variables values))))
+
+(define (environment-variables env) (vector-ref env 0))
+(define (environment-values env) (vector-ref env 1))
+(define (environment-parent env) (vector-ref env 2))
+
+(define the-empty-environment '())
+
+(define (lookup-variable-value var env)
+ (let plp ((env env))
+ (if (eq? env the-empty-environment)
+ (lookup-scheme-value var)
+ (let scan
+ ((vars (vector-ref env 0))
+ (vals (vector-ref env 1)))
+ (cond ((null? vars) (plp (vector-ref env 2)))
+ ((eq? var (car vars)) (car vals))
+ (else (scan (cdr vars) (cdr vals))))))))
+
+;;; Extension to make underlying Scheme values available to interpreter
+
+(define (lookup-scheme-value var)
+ (lexical-reference generic-evaluation-environment var))
+
+(define (define-variable! var val env)
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- DEFINE" var) ;should not happen.
+ (let scan
+ ((vars (vector-ref env 0))
+ (vals (vector-ref env 1)))
+ (cond ((null? vars)
+ (vector-set! env 0 (cons var (vector-ref env 0)))
+ (vector-set! env 1 (cons val (vector-ref env 1))))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else
+ (scan (cdr vars) (cdr vals)))))))
+
+(define (set-variable-value! var val env)
+ (let plp ((env env))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let scan
+ ((vars (vector-ref env 0))
+ (vals (vector-ref env 1)))
+ (cond ((null? vars) (plp (vector-ref env 2)))
+ ((eq? var (car vars)) (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals))))))))
+
+
diff --git a/ps03_evalapply/syntax.scm b/ps03_evalapply/syntax.scm
new file mode 100644
index 0000000..7c058e4
--- /dev/null
+++ b/ps03_evalapply/syntax.scm
@@ -0,0 +1,188 @@
+;;; -*- Mode:Scheme; Base:10 -*-
+
+(declare (usual-integrations))
+
+;;; Self-evaluating entities
+
+(define (self-evaluating? exp)
+ (or (number? exp)
+ (eq? exp #t)
+ (eq? exp #f)
+ (string? exp))) ; Our prompt (viz., "EVAL==> ") is a string.
+
+;;; Variables
+
+(define (variable? exp) (symbol? exp))
+
+(define (same-variable? var1 var2) (eq? var1 var2)) ;; Nice abstraction
+
+;;; Special forms (in general)
+
+(define (tagged-list? exp tag)
+ (and (pair? exp)
+ (eq? (car exp) tag)))
+
+;;; Quotations
+
+(define (quoted? exp) (tagged-list? exp 'quote))
+
+(define (text-of-quotation quot) (cadr quot))
+
+;;; Assignment--- SET!
+
+(define (assignment? exp) (tagged-list? exp 'set!))
+
+(define (assignment-variable assn) (cadr assn))
+(define (assignment-value assn) (caddr assn))
+
+;;; Definitions
+
+(define (definition? exp) (tagged-list? exp 'define))
+
+(define (definition-variable defn)
+ (if (variable? (cadr defn)) ;; (DEFINE foo ...)
+ (cadr defn)
+ (caadr defn))) ;; (DEFINE (foo ...) ...)
+
+(define (definition-value defn)
+ (if (variable? (cadr defn)) ;; (DEFINE foo ...)
+ (caddr defn)
+ (cons 'lambda ;; (DEFINE (foo p...) b...)
+ (cons (cdadr defn) ;; = (DEFINE foo
+ (cddr defn))))) ;; (LAMBDA (p...) b...))
+
+;;; LAMBDA expressions
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters lambda-exp) (cadr lambda-exp))
+(define (lambda-body lambda-exp)
+ (let ((full-body (cddr lambda-exp)))
+ (sequence->begin full-body)))
+
+
+(define declaration? pair?)
+
+(define (parameter-name var-decl)
+ (if (pair? var-decl)
+ (car var-decl)
+ var-decl))
+
+(define (lazy? var-decl)
+ (and (pair? var-decl)
+ (memq 'lazy (cdr var-decl))
+ (not (memq 'memo (cdr var-decl)))))
+
+(define (lazy-memo? var-decl)
+ (and (pair? var-decl)
+ (memq 'lazy (cdr var-decl))
+ (memq 'memo (cdr var-decl))))
+
+(define (sequence->begin seq)
+ (cond ((null? seq) seq)
+ ((null? (cdr seq)) (car seq))
+ ((begin? (car seq)) seq)
+ (else (make-begin seq))))
+
+(define (make-begin exp) (cons 'begin exp))
+
+;;; If conditionals
+
+(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)
+ 'the-unspecified-value))
+
+(define (make-if pred conseq alternative)
+ (list 'IF pred conseq alternative))
+
+
+;;; COND Conditionals
+
+(define (cond? exp) (tagged-list? exp 'cond))
+
+(define (clauses cndl) (cdr cndl))
+(define (no-clauses? clauses) (null? clauses))
+(define (first-clause clauses) (car clauses))
+(define (rest-clauses clauses) (cdr clauses))
+(define (else-clause? clause) (eq? (predicate clause) 'else))
+
+(define (predicate clause) (car clause))
+
+(define (actions clause)
+ (sequence->begin (cdr clause)))
+
+(define (cond->if cond-exp)
+ (define (expand clauses)
+ (cond ((no-clauses? clauses)
+ (list 'error "COND: no values matched"))
+ ((else-clause? (car clauses))
+ (if (no-clauses? (cdr clauses))
+ (actions (car clauses))
+ (error "else clause isn't last -- INTERP" exp)))
+ (else
+ (make-if (predicate (car clauses))
+ (actions (car clauses))
+ (expand (cdr clauses))))))
+ (expand (clauses cond-exp)))
+
+
+;;; BEGIN expressions (a.k.a. sequences)
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions begin-exp) (cdr begin-exp))
+
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define no-more-exps? null?) ; for non-tail-recursive vers.
+
+;;; LET expressions
+
+(define (let? exp) (tagged-list? exp 'let))
+(define (let-bound-variables let-exp)
+ (map car (cadr let-exp)))
+(define (let-values let-exp) (map cadr (cadr let-exp)))
+(define (let-body let-exp) (sequence->begin (cddr let-exp)))
+(define (let->combination let-exp)
+ (let ((names (let-bound-variables let-exp))
+ (values (let-values let-exp))
+ (body (let-body let-exp)))
+ (cons (list 'LAMBDA names body)
+ values)))
+
+;;; Procedure applications -- NO-ARGS? and LAST-OPERAND? added
+
+(define (application? exp)
+ (pair? exp))
+
+(define (no-args? exp) ;; Added for tail recursion
+ (and (pair? exp)
+ (null? (cdr exp))))
+
+(define (args-application? exp) ;; Changed from 5.2.1
+ (and (pair? exp)
+ (not (null? (cdr exp)))))
+
+
+(define (operator app) (car app))
+(define (operands app) (cdr app))
+
+(define (last-operand? args) ;; Added for tail recursion
+ (null? (cdr args)))
+
+(define (no-operands? args) (null? args))
+(define (first-operand args) (car args))
+(define (rest-operands args) (cdr args))
+
+;;; Another special form that will be needed later.
+
+(define (amb? exp)
+ (and (pair? exp) (eq? (car exp) 'amb)))
+
+(define (permanent-assignment? exp) (tagged-list? exp 'set!!))
diff --git a/ps03_evalapply/utils.scm b/ps03_evalapply/utils.scm
new file mode 100644
index 0000000..cac9281
--- /dev/null
+++ b/ps03_evalapply/utils.scm
@@ -0,0 +1,17 @@
+(declare (usual-integrations))
+
+
+(define (identity x) x)
+
+(define (any? x) #t)
+
+
+(define ((compose f g) x) (f (g x)))
+
+
+;;; This is to keep the Scheme printer from going into an infinite
+;;; loop if you try to print a circular data structure, such as an
+;;; environment
+
+(set! *unparser-list-depth-limit* 10)
+(set! *unparser-list-breadth-limit* 10)