Add files provided with the book
Just in case they become unavailable later.
This commit is contained in:
parent
1d4447ad2b
commit
9eb77c7e02
|
|
@ -0,0 +1,167 @@
|
|||
;;; EXAMPLES OF TESTING CODE (IN MIT SCHEME)
|
||||
;;; FROM CHAPTER 2 OF STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
|
||||
|
||||
|
||||
;;;SECTION 2.4.1
|
||||
|
||||
;; Ben's rectangular
|
||||
|
||||
(define z1 (make-from-real-imag 1 1))
|
||||
;Value: z1
|
||||
|
||||
(real-part z1)
|
||||
;Value: 1
|
||||
(imag-part z1)
|
||||
;Value: 1
|
||||
(magnitude z1)
|
||||
;Value: 1.4142135623730951
|
||||
(angle z1)
|
||||
;Value: .7853981633974483
|
||||
(* 4 (angle z1))
|
||||
;Value: 3.141592653589793
|
||||
(define z2 (make-from-mag-ang 1.4142135623730951 .7853981633974483))
|
||||
;Value: z2
|
||||
|
||||
(real-part z2)
|
||||
;Value: 1.
|
||||
(imag-part z2)
|
||||
;Value: 1.
|
||||
|
||||
z1
|
||||
;Value 10: (1 . 1)
|
||||
|
||||
z2
|
||||
;Value 14: (1. . 1.)
|
||||
|
||||
(add-complex z1 z2)
|
||||
;Value 16: (2. . 2.)
|
||||
|
||||
(sub-complex z1 z2)
|
||||
;Value 17: (0. . 0.)
|
||||
|
||||
|
||||
;; Alyssa's polar
|
||||
|
||||
(define z1 (make-from-real-imag 1 1))
|
||||
;Value: z1
|
||||
|
||||
(real-part z1)
|
||||
;Value: 1.
|
||||
|
||||
(imag-part z1)
|
||||
;Value: 1.
|
||||
|
||||
(magnitude z1)
|
||||
;Value: 1.4142135623730951
|
||||
|
||||
(angle z1)
|
||||
;Value: .7853981633974483
|
||||
|
||||
(* 4 (angle z1))
|
||||
;Value: 3.141592653589793
|
||||
|
||||
(define z2 (make-from-mag-ang 1.4142135623730951 .7853981633974483))
|
||||
;Value: z2
|
||||
|
||||
(real-part z2)
|
||||
;Value: 1.
|
||||
|
||||
(imag-part z2)
|
||||
;Value: 1.
|
||||
|
||||
z1
|
||||
;Value 12: (1.4142135623730951 . .7853981633974483)
|
||||
|
||||
z2
|
||||
;Value 13: (1.4142135623730951 . .7853981633974483)
|
||||
|
||||
(mul-complex z1 z2)
|
||||
;Value 18: (2.0000000000000004 . 1.5707963267948966)
|
||||
|
||||
(div-complex z1 z2)
|
||||
;Value 19: (1. . 0.)
|
||||
|
||||
;;;SECTION 2.4.2
|
||||
|
||||
(define z1 (make-from-real-imag 1 1))
|
||||
;Value: z1
|
||||
|
||||
z1
|
||||
;Value 20: (rectangular 1 . 1)
|
||||
(real-part z1)
|
||||
;Value: 1
|
||||
(imag-part z1)
|
||||
;Value: 1
|
||||
(magnitude z1)
|
||||
;Value: 1.4142135623730951
|
||||
(angle z1)
|
||||
;Value: .7853981633974483
|
||||
|
||||
(define z2 (make-from-mag-ang 1.4142135623730951 .7853981633974483))
|
||||
;Value: z2
|
||||
|
||||
z2
|
||||
;Value 22: (polar 1.4142135623730951 . .7853981633974483)
|
||||
|
||||
(magnitude z2)
|
||||
;Value: 1.4142135623730951
|
||||
(angle z2)
|
||||
;Value: .7853981633974483
|
||||
(real-part z2)
|
||||
;Value: 1.
|
||||
(imag-part z2)
|
||||
;Value: 1.
|
||||
|
||||
z1
|
||||
;Value 20: (rectangular 1 . 1)
|
||||
z2
|
||||
;Value 22: (polar 1.4142135623730951 . .7853981633974483)
|
||||
|
||||
(add-complex z1 z2)
|
||||
;Value 23: (rectangular 2. . 2.)
|
||||
(sub-complex z1 z2)
|
||||
;Value 24: (rectangular 0. . 0.)
|
||||
(mul-complex z1 z2)
|
||||
;Value 25: (polar 2.0000000000000004 . 1.5707963267948966)
|
||||
(div-complex z1 z2)
|
||||
;Value 26: (polar 1. . 0.)
|
||||
|
||||
;;;SECTION 2.5.2
|
||||
|
||||
(define z1 (make-complex-from-real-imag 1 1))
|
||||
|
||||
;; Before coercion mechanism
|
||||
|
||||
(add z1 (make-scheme-number 3))
|
||||
;Value 1: (complex rectangular 4 . 1)
|
||||
|
||||
(add (make-scheme-number 3) z1)
|
||||
;No method for the given types (add (scheme-number complex))
|
||||
|
||||
|
||||
;; With coercion mechanism
|
||||
|
||||
(add z1 (make-scheme-number 3))
|
||||
;Value 6: (complex rectangular 4 . 1)
|
||||
|
||||
(add (make-scheme-number 3) z1)
|
||||
;Value 7: (complex rectangular 4 . 1)
|
||||
|
||||
;;;SECTION 2.5.3
|
||||
|
||||
(define a (make-polynomial 'x '((5 1) (4 2) (2 3) (1 -2) (0 -5))))
|
||||
|
||||
a
|
||||
;Value 3: (polynomial x (5 1) (4 2) (2 3) (1 -2) (0 -5))
|
||||
|
||||
(add a a)
|
||||
;Value 4: (polynomial x (5 2) (4 4) (2 6) (1 -4) (0 -10))
|
||||
|
||||
(define b (make-polynomial 'x '((100 1) (2 2) (0 1))))
|
||||
|
||||
b
|
||||
;Value 5: (polynomial x (100 1) (2 2) (0 1))
|
||||
|
||||
(mul b b)
|
||||
;Value 6: (polynomial x (200 1) (102 4) (100 2) (4 4) (2 4) (0 1))
|
||||
|
||||
|
|
@ -0,0 +1,295 @@
|
|||
;;;;AMB EVALUATOR FROM SECTION 4.3 OF
|
||||
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
|
||||
|
||||
;;;;Matches code in ch4.scm.
|
||||
;;;; To run the sample programs and exercises, code below also includes
|
||||
;;;; -- enlarged primitive-procedures list
|
||||
;;;; -- support for Let (as noted in footnote 56, p.428)
|
||||
|
||||
;;;;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).
|
||||
;;;;In the driver loop, do
|
||||
;(define (require p)
|
||||
; (if (not p) (amb)))
|
||||
|
||||
|
||||
;;**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
|
||||
(load "ch4-mceval.scm")
|
||||
|
||||
|
||||
|
||||
;;;Code from SECTION 4.3.3, modified as needed to run it
|
||||
|
||||
(define (amb? exp) (tagged-list? exp 'amb))
|
||||
(define (amb-choices exp) (cdr exp))
|
||||
|
||||
;; analyze from 4.1.6, with clause from 4.3.3 added
|
||||
;; and also support for Let
|
||||
(define (analyze exp)
|
||||
(cond ((self-evaluating? exp)
|
||||
(analyze-self-evaluating exp))
|
||||
((quoted? exp) (analyze-quoted exp))
|
||||
((variable? exp) (analyze-variable exp))
|
||||
((assignment? exp) (analyze-assignment exp))
|
||||
((definition? exp) (analyze-definition exp))
|
||||
((if? exp) (analyze-if exp))
|
||||
((lambda? exp) (analyze-lambda exp))
|
||||
((begin? exp) (analyze-sequence (begin-actions exp)))
|
||||
((cond? exp) (analyze (cond->if exp)))
|
||||
((let? exp) (analyze (let->combination exp))) ;**
|
||||
((amb? exp) (analyze-amb exp)) ;**
|
||||
((application? exp) (analyze-application exp))
|
||||
(else
|
||||
(error "Unknown expression type -- ANALYZE" exp))))
|
||||
|
||||
(define (ambeval exp env succeed fail)
|
||||
((analyze exp) env succeed fail))
|
||||
|
||||
;;;Simple expressions
|
||||
|
||||
(define (analyze-self-evaluating exp)
|
||||
(lambda (env succeed fail)
|
||||
(succeed exp fail)))
|
||||
|
||||
(define (analyze-quoted exp)
|
||||
(let ((qval (text-of-quotation exp)))
|
||||
(lambda (env succeed fail)
|
||||
(succeed qval fail))))
|
||||
|
||||
(define (analyze-variable exp)
|
||||
(lambda (env succeed fail)
|
||||
(succeed (lookup-variable-value exp env)
|
||||
fail)))
|
||||
|
||||
(define (analyze-lambda exp)
|
||||
(let ((vars (lambda-parameters exp))
|
||||
(bproc (analyze-sequence (lambda-body exp))))
|
||||
(lambda (env succeed fail)
|
||||
(succeed (make-procedure vars bproc env)
|
||||
fail))))
|
||||
|
||||
;;;Conditionals and sequences
|
||||
|
||||
(define (analyze-if exp)
|
||||
(let ((pproc (analyze (if-predicate exp)))
|
||||
(cproc (analyze (if-consequent exp)))
|
||||
(aproc (analyze (if-alternative exp))))
|
||||
(lambda (env succeed fail)
|
||||
(pproc env
|
||||
;; success continuation for evaluating the predicate
|
||||
;; to obtain pred-value
|
||||
(lambda (pred-value fail2)
|
||||
(if (true? pred-value)
|
||||
(cproc env succeed fail2)
|
||||
(aproc env succeed fail2)))
|
||||
;; failure continuation for evaluating the predicate
|
||||
fail))))
|
||||
|
||||
(define (analyze-sequence exps)
|
||||
(define (sequentially a b)
|
||||
(lambda (env succeed fail)
|
||||
(a env
|
||||
;; success continuation for calling a
|
||||
(lambda (a-value fail2)
|
||||
(b env succeed fail2))
|
||||
;; failure continuation for calling a
|
||||
fail)))
|
||||
(define (loop first-proc rest-procs)
|
||||
(if (null? rest-procs)
|
||||
first-proc
|
||||
(loop (sequentially first-proc (car rest-procs))
|
||||
(cdr rest-procs))))
|
||||
(let ((procs (map analyze exps)))
|
||||
(if (null? procs)
|
||||
(error "Empty sequence -- ANALYZE"))
|
||||
(loop (car procs) (cdr procs))))
|
||||
|
||||
;;;Definitions and assignments
|
||||
|
||||
(define (analyze-definition exp)
|
||||
(let ((var (definition-variable exp))
|
||||
(vproc (analyze (definition-value exp))))
|
||||
(lambda (env succeed fail)
|
||||
(vproc env
|
||||
(lambda (val fail2)
|
||||
(define-variable! var val env)
|
||||
(succeed 'ok fail2))
|
||||
fail))))
|
||||
|
||||
(define (analyze-assignment exp)
|
||||
(let ((var (assignment-variable exp))
|
||||
(vproc (analyze (assignment-value exp))))
|
||||
(lambda (env succeed fail)
|
||||
(vproc env
|
||||
(lambda (val fail2) ; *1*
|
||||
(let ((old-value
|
||||
(lookup-variable-value var env)))
|
||||
(set-variable-value! var val env)
|
||||
(succeed 'ok
|
||||
(lambda () ; *2*
|
||||
(set-variable-value! var
|
||||
old-value
|
||||
env)
|
||||
(fail2)))))
|
||||
fail))))
|
||||
|
||||
;;;Procedure applications
|
||||
|
||||
(define (analyze-application exp)
|
||||
(let ((fproc (analyze (operator exp)))
|
||||
(aprocs (map analyze (operands exp))))
|
||||
(lambda (env succeed fail)
|
||||
(fproc env
|
||||
(lambda (proc fail2)
|
||||
(get-args aprocs
|
||||
env
|
||||
(lambda (args fail3)
|
||||
(execute-application
|
||||
proc args succeed fail3))
|
||||
fail2))
|
||||
fail))))
|
||||
|
||||
(define (get-args aprocs env succeed fail)
|
||||
(if (null? aprocs)
|
||||
(succeed '() fail)
|
||||
((car aprocs) env
|
||||
;; success continuation for this aproc
|
||||
(lambda (arg fail2)
|
||||
(get-args (cdr aprocs)
|
||||
env
|
||||
;; success continuation for recursive
|
||||
;; call to get-args
|
||||
(lambda (args fail3)
|
||||
(succeed (cons arg args)
|
||||
fail3))
|
||||
fail2))
|
||||
fail)))
|
||||
|
||||
(define (execute-application proc args succeed fail)
|
||||
(cond ((primitive-procedure? proc)
|
||||
(succeed (apply-primitive-procedure proc args)
|
||||
fail))
|
||||
((compound-procedure? proc)
|
||||
((procedure-body proc)
|
||||
(extend-environment (procedure-parameters proc)
|
||||
args
|
||||
(procedure-environment proc))
|
||||
succeed
|
||||
fail))
|
||||
(else
|
||||
(error
|
||||
"Unknown procedure type -- EXECUTE-APPLICATION"
|
||||
proc))))
|
||||
|
||||
;;;amb expressions
|
||||
|
||||
(define (analyze-amb exp)
|
||||
(let ((cprocs (map analyze (amb-choices exp))))
|
||||
(lambda (env succeed fail)
|
||||
(define (try-next choices)
|
||||
(if (null? choices)
|
||||
(fail)
|
||||
((car choices) env
|
||||
succeed
|
||||
(lambda ()
|
||||
(try-next (cdr choices))))))
|
||||
(try-next cprocs))))
|
||||
|
||||
;;;Driver loop
|
||||
|
||||
(define input-prompt ";;; Amb-Eval input:")
|
||||
(define output-prompt ";;; Amb-Eval value:")
|
||||
|
||||
(define (driver-loop)
|
||||
(define (internal-loop try-again)
|
||||
(prompt-for-input input-prompt)
|
||||
(let ((input (read)))
|
||||
(if (eq? input 'try-again)
|
||||
(try-again)
|
||||
(begin
|
||||
(newline)
|
||||
(display ";;; Starting a new problem ")
|
||||
(ambeval input
|
||||
the-global-environment
|
||||
;; ambeval success
|
||||
(lambda (val next-alternative)
|
||||
(announce-output output-prompt)
|
||||
(user-print val)
|
||||
(internal-loop next-alternative))
|
||||
;; ambeval failure
|
||||
(lambda ()
|
||||
(announce-output
|
||||
";;; There are no more values of")
|
||||
(user-print input)
|
||||
(driver-loop)))))))
|
||||
(internal-loop
|
||||
(lambda ()
|
||||
(newline)
|
||||
(display ";;; There is no current problem")
|
||||
(driver-loop))))
|
||||
|
||||
|
||||
|
||||
;;; Support for Let (as noted in footnote 56, p.428)
|
||||
|
||||
(define (let? exp) (tagged-list? exp 'let))
|
||||
(define (let-bindings exp) (cadr exp))
|
||||
(define (let-body exp) (cddr exp))
|
||||
|
||||
(define (let-var binding) (car binding))
|
||||
(define (let-val binding) (cadr binding))
|
||||
|
||||
(define (make-combination operator operands) (cons operator operands))
|
||||
|
||||
(define (let->combination exp)
|
||||
;;make-combination defined in earlier exercise
|
||||
(let ((bindings (let-bindings exp)))
|
||||
(make-combination (make-lambda (map let-var bindings)
|
||||
(let-body exp))
|
||||
(map let-val bindings))))
|
||||
|
||||
|
||||
|
||||
;; A longer list of primitives -- suitable for running everything in 4.3
|
||||
;; Overrides the list in ch4-mceval.scm
|
||||
;; Has Not to support Require; various stuff for code in text (including
|
||||
;; support for Prime?); integer? and sqrt for exercise code;
|
||||
;; eq? for ex. solution
|
||||
|
||||
(define primitive-procedures
|
||||
(list (list 'car car)
|
||||
(list 'cdr cdr)
|
||||
(list 'cons cons)
|
||||
(list 'null? null?)
|
||||
(list 'list list)
|
||||
(list 'memq memq)
|
||||
(list 'member member)
|
||||
(list 'not not)
|
||||
(list '+ +)
|
||||
(list '- -)
|
||||
(list '* *)
|
||||
(list '= =)
|
||||
(list '> >)
|
||||
(list '>= >=)
|
||||
(list 'abs abs)
|
||||
(list 'remainder remainder)
|
||||
(list 'integer? integer?)
|
||||
(list 'sqrt sqrt)
|
||||
(list 'eq? eq?)
|
||||
;; more primitives
|
||||
))
|
||||
|
||||
|
||||
'AMB-EVALUATOR-LOADED
|
||||
|
|
@ -0,0 +1,117 @@
|
|||
;;;;METACIRCULAR EVALUATOR THAT SEPARATES ANALYSIS FROM EXECUTION
|
||||
;;;; FROM SECTION 4.1.7 OF STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
|
||||
|
||||
;;;;Matches code in ch4.scm
|
||||
|
||||
;;;;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).
|
||||
|
||||
|
||||
;;**implementation-dependent loading of evaluator file
|
||||
;;Note: It is loaded first so that the section 4.1.7 definition
|
||||
;; of eval overrides the definition from 4.1.1
|
||||
(load "ch4-mceval.scm")
|
||||
|
||||
;;;SECTION 4.1.7
|
||||
|
||||
(define (eval exp env)
|
||||
((analyze exp) env))
|
||||
|
||||
(define (analyze exp)
|
||||
(cond ((self-evaluating? exp)
|
||||
(analyze-self-evaluating exp))
|
||||
((quoted? exp) (analyze-quoted exp))
|
||||
((variable? exp) (analyze-variable exp))
|
||||
((assignment? exp) (analyze-assignment exp))
|
||||
((definition? exp) (analyze-definition exp))
|
||||
((if? exp) (analyze-if exp))
|
||||
((lambda? exp) (analyze-lambda exp))
|
||||
((begin? exp) (analyze-sequence (begin-actions exp)))
|
||||
((cond? exp) (analyze (cond->if exp)))
|
||||
((application? exp) (analyze-application exp))
|
||||
(else
|
||||
(error "Unknown expression type -- ANALYZE" exp))))
|
||||
|
||||
(define (analyze-self-evaluating exp)
|
||||
(lambda (env) exp))
|
||||
|
||||
(define (analyze-quoted exp)
|
||||
(let ((qval (text-of-quotation exp)))
|
||||
(lambda (env) qval)))
|
||||
|
||||
(define (analyze-variable exp)
|
||||
(lambda (env) (lookup-variable-value exp env)))
|
||||
|
||||
(define (analyze-assignment exp)
|
||||
(let ((var (assignment-variable exp))
|
||||
(vproc (analyze (assignment-value exp))))
|
||||
(lambda (env)
|
||||
(set-variable-value! var (vproc env) env)
|
||||
'ok)))
|
||||
|
||||
(define (analyze-definition exp)
|
||||
(let ((var (definition-variable exp))
|
||||
(vproc (analyze (definition-value exp))))
|
||||
(lambda (env)
|
||||
(define-variable! var (vproc env) env)
|
||||
'ok)))
|
||||
|
||||
(define (analyze-if exp)
|
||||
(let ((pproc (analyze (if-predicate exp)))
|
||||
(cproc (analyze (if-consequent exp)))
|
||||
(aproc (analyze (if-alternative exp))))
|
||||
(lambda (env)
|
||||
(if (true? (pproc env))
|
||||
(cproc env)
|
||||
(aproc env)))))
|
||||
|
||||
(define (analyze-lambda exp)
|
||||
(let ((vars (lambda-parameters exp))
|
||||
(bproc (analyze-sequence (lambda-body exp))))
|
||||
(lambda (env) (make-procedure vars bproc env))))
|
||||
|
||||
(define (analyze-sequence exps)
|
||||
(define (sequentially proc1 proc2)
|
||||
(lambda (env) (proc1 env) (proc2 env)))
|
||||
(define (loop first-proc rest-procs)
|
||||
(if (null? rest-procs)
|
||||
first-proc
|
||||
(loop (sequentially first-proc (car rest-procs))
|
||||
(cdr rest-procs))))
|
||||
(let ((procs (map analyze exps)))
|
||||
(if (null? procs)
|
||||
(error "Empty sequence -- ANALYZE"))
|
||||
(loop (car procs) (cdr procs))))
|
||||
|
||||
(define (analyze-application exp)
|
||||
(let ((fproc (analyze (operator exp)))
|
||||
(aprocs (map analyze (operands exp))))
|
||||
(lambda (env)
|
||||
(execute-application (fproc env)
|
||||
(map (lambda (aproc) (aproc env))
|
||||
aprocs)))))
|
||||
|
||||
(define (execute-application proc args)
|
||||
(cond ((primitive-procedure? proc)
|
||||
(apply-primitive-procedure proc args))
|
||||
((compound-procedure? proc)
|
||||
((procedure-body proc)
|
||||
(extend-environment (procedure-parameters proc)
|
||||
args
|
||||
(procedure-environment proc))))
|
||||
(else
|
||||
(error
|
||||
"Unknown procedure type -- EXECUTE-APPLICATION"
|
||||
proc))))
|
||||
|
||||
'ANALYZING-METACIRCULAR-EVALUATOR-LOADED
|
||||
|
|
@ -0,0 +1,168 @@
|
|||
;;;;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
|
||||
(load "ch4-mceval.scm")
|
||||
|
||||
|
||||
;;;SECTION 4.2.2
|
||||
|
||||
;;; Modifying the evaluator
|
||||
|
||||
(define (eval exp env)
|
||||
(cond ((self-evaluating? exp) exp)
|
||||
((variable? exp) (lookup-variable-value exp env))
|
||||
((quoted? exp) (text-of-quotation exp))
|
||||
((assignment? exp) (eval-assignment exp env))
|
||||
((definition? exp) (eval-definition exp env))
|
||||
((if? exp) (eval-if exp env))
|
||||
((lambda? exp)
|
||||
(make-procedure (lambda-parameters exp)
|
||||
(lambda-body exp)
|
||||
env))
|
||||
((begin? exp)
|
||||
(eval-sequence (begin-actions exp) env))
|
||||
((cond? exp) (eval (cond->if exp) env))
|
||||
((application? exp) ; clause from book
|
||||
(apply (actual-value (operator exp) env)
|
||||
(operands exp)
|
||||
env))
|
||||
(else
|
||||
(error "Unknown expression type -- EVAL" exp))))
|
||||
|
||||
(define (actual-value exp env)
|
||||
(force-it (eval exp env)))
|
||||
|
||||
(define (apply procedure arguments env)
|
||||
(cond ((primitive-procedure? procedure)
|
||||
(apply-primitive-procedure
|
||||
procedure
|
||||
(list-of-arg-values arguments env))) ; changed
|
||||
((compound-procedure? procedure)
|
||||
(eval-sequence
|
||||
(procedure-body procedure)
|
||||
(extend-environment
|
||||
(procedure-parameters procedure)
|
||||
(list-of-delayed-args arguments env) ; changed
|
||||
(procedure-environment procedure))))
|
||||
(else
|
||||
(error
|
||||
"Unknown procedure type -- APPLY" procedure))))
|
||||
|
||||
(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 input-prompt ";;; L-Eval input:")
|
||||
(define output-prompt ";;; L-Eval value:")
|
||||
|
||||
(define (driver-loop)
|
||||
(prompt-for-input input-prompt)
|
||||
(let ((input (read)))
|
||||
(let ((output
|
||||
(actual-value input the-global-environment)))
|
||||
(announce-output output-prompt)
|
||||
(user-print output)))
|
||||
(driver-loop))
|
||||
|
||||
|
||||
;;; Representing thunks
|
||||
|
||||
;; non-memoizing version of force-it
|
||||
|
||||
(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)
|
||||
(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)))
|
||||
|
||||
|
||||
;; A longer list of primitives -- suitable for running everything in 4.2
|
||||
;; Overrides the list in ch4-mceval.scm
|
||||
|
||||
(define primitive-procedures
|
||||
(list (list 'car car)
|
||||
(list 'cdr cdr)
|
||||
(list 'cons cons)
|
||||
(list 'null? null?)
|
||||
(list 'list list)
|
||||
(list '+ +)
|
||||
(list '- -)
|
||||
(list '* *)
|
||||
(list '/ /)
|
||||
(list '= =)
|
||||
(list 'newline newline)
|
||||
(list 'display display)
|
||||
;; more primitives
|
||||
))
|
||||
|
||||
'LAZY-EVALUATOR-LOADED
|
||||
|
|
@ -0,0 +1,357 @@
|
|||
;;;;METACIRCULAR EVALUATOR FROM CHAPTER 4 (SECTIONS 4.1.1-4.1.4) of
|
||||
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
|
||||
|
||||
;;;;Matches code in ch4.scm
|
||||
|
||||
;;;;This file can be loaded into Scheme as a whole.
|
||||
;;;;Then you can initialize and start the evaluator by evaluating
|
||||
;;;; the two commented-out lines at the end of the file (setting up the
|
||||
;;;; global environment and starting the driver loop).
|
||||
|
||||
;;;;**WARNING: Don't load this file twice (or you'll lose the primitives
|
||||
;;;; interface, due to renamings of apply).
|
||||
|
||||
;;;from section 4.1.4 -- must precede def of metacircular apply
|
||||
(define apply-in-underlying-scheme apply)
|
||||
|
||||
;;;SECTION 4.1.1
|
||||
|
||||
(define (eval exp env)
|
||||
(cond ((self-evaluating? exp) exp)
|
||||
((variable? exp) (lookup-variable-value exp env))
|
||||
((quoted? exp) (text-of-quotation exp))
|
||||
((assignment? exp) (eval-assignment exp env))
|
||||
((definition? exp) (eval-definition exp env))
|
||||
((if? exp) (eval-if exp env))
|
||||
((lambda? exp)
|
||||
(make-procedure (lambda-parameters exp)
|
||||
(lambda-body exp)
|
||||
env))
|
||||
((begin? exp)
|
||||
(eval-sequence (begin-actions exp) env))
|
||||
((cond? exp) (eval (cond->if exp) env))
|
||||
((application? exp)
|
||||
(apply (eval (operator exp) env)
|
||||
(list-of-values (operands exp) env)))
|
||||
(else
|
||||
(error "Unknown expression type -- EVAL" exp))))
|
||||
|
||||
(define (apply procedure arguments)
|
||||
(cond ((primitive-procedure? procedure)
|
||||
(apply-primitive-procedure procedure arguments))
|
||||
((compound-procedure? procedure)
|
||||
(eval-sequence
|
||||
(procedure-body procedure)
|
||||
(extend-environment
|
||||
(procedure-parameters procedure)
|
||||
arguments
|
||||
(procedure-environment procedure))))
|
||||
(else
|
||||
(error
|
||||
"Unknown procedure type -- APPLY" procedure))))
|
||||
|
||||
|
||||
(define (list-of-values exps env)
|
||||
(if (no-operands? exps)
|
||||
'()
|
||||
(cons (eval (first-operand exps) env)
|
||||
(list-of-values (rest-operands exps) env))))
|
||||
|
||||
(define (eval-if exp env)
|
||||
(if (true? (eval (if-predicate exp) env))
|
||||
(eval (if-consequent exp) env)
|
||||
(eval (if-alternative exp) env)))
|
||||
|
||||
(define (eval-sequence exps env)
|
||||
(cond ((last-exp? exps) (eval (first-exp exps) env))
|
||||
(else (eval (first-exp exps) env)
|
||||
(eval-sequence (rest-exps exps) env))))
|
||||
|
||||
(define (eval-assignment exp env)
|
||||
(set-variable-value! (assignment-variable exp)
|
||||
(eval (assignment-value exp) env)
|
||||
env)
|
||||
'ok)
|
||||
|
||||
(define (eval-definition exp env)
|
||||
(define-variable! (definition-variable exp)
|
||||
(eval (definition-value exp) env)
|
||||
env)
|
||||
'ok)
|
||||
|
||||
;;;SECTION 4.1.2
|
||||
|
||||
(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 (make-if predicate consequent alternative)
|
||||
(list 'if predicate consequent alternative))
|
||||
|
||||
|
||||
(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 (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 (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))
|
||||
|
||||
|
||||
(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))))))
|
||||
|
||||
;;;SECTION 4.1.3
|
||||
|
||||
(define (true? x)
|
||||
(not (eq? x false)))
|
||||
|
||||
(define (false? x)
|
||||
(eq? x false))
|
||||
|
||||
|
||||
(define (make-procedure parameters body env)
|
||||
(list 'procedure parameters body env))
|
||||
|
||||
(define (compound-procedure? p)
|
||||
(tagged-list? p 'procedure))
|
||||
|
||||
|
||||
(define (procedure-parameters p) (cadr p))
|
||||
(define (procedure-body p) (caddr p))
|
||||
(define (procedure-environment p) (cadddr p))
|
||||
|
||||
|
||||
(define (enclosing-environment env) (cdr env))
|
||||
|
||||
(define (first-frame env) (car env))
|
||||
|
||||
(define the-empty-environment '())
|
||||
|
||||
(define (make-frame variables values)
|
||||
(cons variables values))
|
||||
|
||||
(define (frame-variables frame) (car frame))
|
||||
(define (frame-values frame) (cdr frame))
|
||||
|
||||
(define (add-binding-to-frame! var val frame)
|
||||
(set-car! frame (cons var (car frame)))
|
||||
(set-cdr! frame (cons val (cdr frame))))
|
||||
|
||||
(define (extend-environment vars vals base-env)
|
||||
(if (= (length vars) (length vals))
|
||||
(cons (make-frame vars vals) base-env)
|
||||
(if (< (length vars) (length vals))
|
||||
(error "Too many arguments supplied" vars vals)
|
||||
(error "Too few arguments supplied" vars vals))))
|
||||
|
||||
(define (lookup-variable-value var env)
|
||||
(define (env-loop env)
|
||||
(define (scan vars vals)
|
||||
(cond ((null? vars)
|
||||
(env-loop (enclosing-environment env)))
|
||||
((eq? var (car vars))
|
||||
(car vals))
|
||||
(else (scan (cdr vars) (cdr vals)))))
|
||||
(if (eq? env the-empty-environment)
|
||||
(error "Unbound variable" var)
|
||||
(let ((frame (first-frame env)))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame)))))
|
||||
(env-loop env))
|
||||
|
||||
(define (set-variable-value! var val env)
|
||||
(define (env-loop env)
|
||||
(define (scan vars vals)
|
||||
(cond ((null? vars)
|
||||
(env-loop (enclosing-environment env)))
|
||||
((eq? var (car vars))
|
||||
(set-car! vals val))
|
||||
(else (scan (cdr vars) (cdr vals)))))
|
||||
(if (eq? env the-empty-environment)
|
||||
(error "Unbound variable -- SET!" var)
|
||||
(let ((frame (first-frame env)))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame)))))
|
||||
(env-loop env))
|
||||
|
||||
(define (define-variable! var val env)
|
||||
(let ((frame (first-frame env)))
|
||||
(define (scan vars vals)
|
||||
(cond ((null? vars)
|
||||
(add-binding-to-frame! var val frame))
|
||||
((eq? var (car vars))
|
||||
(set-car! vals val))
|
||||
(else (scan (cdr vars) (cdr vals)))))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame))))
|
||||
|
||||
;;;SECTION 4.1.4
|
||||
|
||||
(define (setup-environment)
|
||||
(let ((initial-env
|
||||
(extend-environment (primitive-procedure-names)
|
||||
(primitive-procedure-objects)
|
||||
the-empty-environment)))
|
||||
(define-variable! 'true true initial-env)
|
||||
(define-variable! 'false false initial-env)
|
||||
initial-env))
|
||||
|
||||
;[do later] (define the-global-environment (setup-environment))
|
||||
|
||||
(define (primitive-procedure? proc)
|
||||
(tagged-list? proc 'primitive))
|
||||
|
||||
(define (primitive-implementation proc) (cadr proc))
|
||||
|
||||
(define primitive-procedures
|
||||
(list (list 'car car)
|
||||
(list 'cdr cdr)
|
||||
(list 'cons cons)
|
||||
(list 'null? null?)
|
||||
;; more primitives
|
||||
))
|
||||
|
||||
(define (primitive-procedure-names)
|
||||
(map car
|
||||
primitive-procedures))
|
||||
|
||||
(define (primitive-procedure-objects)
|
||||
(map (lambda (proc) (list 'primitive (cadr proc)))
|
||||
primitive-procedures))
|
||||
|
||||
;[moved to start of file] (define apply-in-underlying-scheme apply)
|
||||
|
||||
(define (apply-primitive-procedure proc args)
|
||||
(apply-in-underlying-scheme
|
||||
(primitive-implementation proc) args))
|
||||
|
||||
|
||||
|
||||
(define input-prompt ";;; M-Eval input:")
|
||||
(define output-prompt ";;; M-Eval value:")
|
||||
|
||||
(define (driver-loop)
|
||||
(prompt-for-input input-prompt)
|
||||
(let ((input (read)))
|
||||
(let ((output (eval input the-global-environment)))
|
||||
(announce-output output-prompt)
|
||||
(user-print output)))
|
||||
(driver-loop))
|
||||
|
||||
(define (prompt-for-input string)
|
||||
(newline) (newline) (display string) (newline))
|
||||
|
||||
(define (announce-output string)
|
||||
(newline) (display string) (newline))
|
||||
|
||||
(define (user-print object)
|
||||
(if (compound-procedure? object)
|
||||
(display (list 'compound-procedure
|
||||
(procedure-parameters object)
|
||||
(procedure-body object)
|
||||
'<procedure-env>))
|
||||
(display object)))
|
||||
|
||||
;;;Following are commented out so as not to be evaluated when
|
||||
;;; the file is loaded.
|
||||
;;(define the-global-environment (setup-environment))
|
||||
;;(driver-loop)
|
||||
|
||||
'METACIRCULAR-EVALUATOR-LOADED
|
||||
|
|
@ -0,0 +1,653 @@
|
|||
;;;;QUERY SYSTEM FROM SECTION 4.4.4 OF
|
||||
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
|
||||
|
||||
;;;;Matches code in ch4.scm
|
||||
;;;;Includes:
|
||||
;;;; -- supporting code from 4.1, chapter 3, and instructor's manual
|
||||
;;;; -- data base from Section 4.4.1 -- see microshaft-data-base below
|
||||
|
||||
;;;;This file can be loaded into Scheme as a whole.
|
||||
;;;;In order to run the query system, the Scheme must support streams.
|
||||
|
||||
;;;;NB. PUT's are commented out and no top-level table is set up.
|
||||
;;;;Instead use initialize-data-base (from manual), supplied in this file.
|
||||
|
||||
|
||||
;;;SECTION 4.4.4.1
|
||||
;;;The Driver Loop and Instantiation
|
||||
|
||||
(define input-prompt ";;; Query input:")
|
||||
(define output-prompt ";;; Query results:")
|
||||
|
||||
(define (query-driver-loop)
|
||||
(prompt-for-input input-prompt)
|
||||
(let ((q (query-syntax-process (read))))
|
||||
(cond ((assertion-to-be-added? q)
|
||||
(add-rule-or-assertion! (add-assertion-body q))
|
||||
(newline)
|
||||
(display "Assertion added to data base.")
|
||||
(query-driver-loop))
|
||||
(else
|
||||
(newline)
|
||||
(display output-prompt)
|
||||
;; [extra newline at end] (announce-output output-prompt)
|
||||
(display-stream
|
||||
(stream-map
|
||||
(lambda (frame)
|
||||
(instantiate q
|
||||
frame
|
||||
(lambda (v f)
|
||||
(contract-question-mark v))))
|
||||
(qeval q (singleton-stream '()))))
|
||||
(query-driver-loop)))))
|
||||
|
||||
(define (instantiate exp frame unbound-var-handler)
|
||||
(define (copy exp)
|
||||
(cond ((var? exp)
|
||||
(let ((binding (binding-in-frame exp frame)))
|
||||
(if binding
|
||||
(copy (binding-value binding))
|
||||
(unbound-var-handler exp frame))))
|
||||
((pair? exp)
|
||||
(cons (copy (car exp)) (copy (cdr exp))))
|
||||
(else exp)))
|
||||
(copy exp))
|
||||
|
||||
|
||||
;;;SECTION 4.4.4.2
|
||||
;;;The Evaluator
|
||||
|
||||
(define (qeval query frame-stream)
|
||||
(let ((qproc (get (type query) 'qeval)))
|
||||
(if qproc
|
||||
(qproc (contents query) frame-stream)
|
||||
(simple-query query frame-stream))))
|
||||
|
||||
;;;Simple queries
|
||||
|
||||
(define (simple-query query-pattern frame-stream)
|
||||
(stream-flatmap
|
||||
(lambda (frame)
|
||||
(stream-append-delayed
|
||||
(find-assertions query-pattern frame)
|
||||
(delay (apply-rules query-pattern frame))))
|
||||
frame-stream))
|
||||
|
||||
;;;Compound queries
|
||||
|
||||
(define (conjoin conjuncts frame-stream)
|
||||
(if (empty-conjunction? conjuncts)
|
||||
frame-stream
|
||||
(conjoin (rest-conjuncts conjuncts)
|
||||
(qeval (first-conjunct conjuncts)
|
||||
frame-stream))))
|
||||
|
||||
;;(put 'and 'qeval conjoin)
|
||||
|
||||
|
||||
(define (disjoin disjuncts frame-stream)
|
||||
(if (empty-disjunction? disjuncts)
|
||||
the-empty-stream
|
||||
(interleave-delayed
|
||||
(qeval (first-disjunct disjuncts) frame-stream)
|
||||
(delay (disjoin (rest-disjuncts disjuncts)
|
||||
frame-stream)))))
|
||||
|
||||
;;(put 'or 'qeval disjoin)
|
||||
|
||||
;;;Filters
|
||||
|
||||
(define (negate operands frame-stream)
|
||||
(stream-flatmap
|
||||
(lambda (frame)
|
||||
(if (stream-null? (qeval (negated-query operands)
|
||||
(singleton-stream frame)))
|
||||
(singleton-stream frame)
|
||||
the-empty-stream))
|
||||
frame-stream))
|
||||
|
||||
;;(put 'not 'qeval negate)
|
||||
|
||||
(define (lisp-value call frame-stream)
|
||||
(stream-flatmap
|
||||
(lambda (frame)
|
||||
(if (execute
|
||||
(instantiate
|
||||
call
|
||||
frame
|
||||
(lambda (v f)
|
||||
(error "Unknown pat var -- LISP-VALUE" v))))
|
||||
(singleton-stream frame)
|
||||
the-empty-stream))
|
||||
frame-stream))
|
||||
|
||||
;;(put 'lisp-value 'qeval lisp-value)
|
||||
|
||||
(define (execute exp)
|
||||
(apply (eval (predicate exp) user-initial-environment)
|
||||
(args exp)))
|
||||
|
||||
(define (always-true ignore frame-stream) frame-stream)
|
||||
|
||||
;;(put 'always-true 'qeval always-true)
|
||||
|
||||
;;;SECTION 4.4.4.3
|
||||
;;;Finding Assertions by Pattern Matching
|
||||
|
||||
(define (find-assertions pattern frame)
|
||||
(stream-flatmap (lambda (datum)
|
||||
(check-an-assertion datum pattern frame))
|
||||
(fetch-assertions pattern frame)))
|
||||
|
||||
(define (check-an-assertion assertion query-pat query-frame)
|
||||
(let ((match-result
|
||||
(pattern-match query-pat assertion query-frame)))
|
||||
(if (eq? match-result 'failed)
|
||||
the-empty-stream
|
||||
(singleton-stream match-result))))
|
||||
|
||||
(define (pattern-match pat dat frame)
|
||||
(cond ((eq? frame 'failed) 'failed)
|
||||
((equal? pat dat) frame)
|
||||
((var? pat) (extend-if-consistent pat dat frame))
|
||||
((and (pair? pat) (pair? dat))
|
||||
(pattern-match (cdr pat)
|
||||
(cdr dat)
|
||||
(pattern-match (car pat)
|
||||
(car dat)
|
||||
frame)))
|
||||
(else 'failed)))
|
||||
|
||||
(define (extend-if-consistent var dat frame)
|
||||
(let ((binding (binding-in-frame var frame)))
|
||||
(if binding
|
||||
(pattern-match (binding-value binding) dat frame)
|
||||
(extend var dat frame))))
|
||||
|
||||
;;;SECTION 4.4.4.4
|
||||
;;;Rules and Unification
|
||||
|
||||
(define (apply-rules pattern frame)
|
||||
(stream-flatmap (lambda (rule)
|
||||
(apply-a-rule rule pattern frame))
|
||||
(fetch-rules pattern frame)))
|
||||
|
||||
(define (apply-a-rule rule query-pattern query-frame)
|
||||
(let ((clean-rule (rename-variables-in rule)))
|
||||
(let ((unify-result
|
||||
(unify-match query-pattern
|
||||
(conclusion clean-rule)
|
||||
query-frame)))
|
||||
(if (eq? unify-result 'failed)
|
||||
the-empty-stream
|
||||
(qeval (rule-body clean-rule)
|
||||
(singleton-stream unify-result))))))
|
||||
|
||||
(define (rename-variables-in rule)
|
||||
(let ((rule-application-id (new-rule-application-id)))
|
||||
(define (tree-walk exp)
|
||||
(cond ((var? exp)
|
||||
(make-new-variable exp rule-application-id))
|
||||
((pair? exp)
|
||||
(cons (tree-walk (car exp))
|
||||
(tree-walk (cdr exp))))
|
||||
(else exp)))
|
||||
(tree-walk rule)))
|
||||
|
||||
(define (unify-match p1 p2 frame)
|
||||
(cond ((eq? frame 'failed) 'failed)
|
||||
((equal? p1 p2) frame)
|
||||
((var? p1) (extend-if-possible p1 p2 frame))
|
||||
((var? p2) (extend-if-possible p2 p1 frame)) ; {\em ; ***}
|
||||
((and (pair? p1) (pair? p2))
|
||||
(unify-match (cdr p1)
|
||||
(cdr p2)
|
||||
(unify-match (car p1)
|
||||
(car p2)
|
||||
frame)))
|
||||
(else 'failed)))
|
||||
|
||||
(define (extend-if-possible var val frame)
|
||||
(let ((binding (binding-in-frame var frame)))
|
||||
(cond (binding
|
||||
(unify-match
|
||||
(binding-value binding) val frame))
|
||||
((var? val) ; {\em ; ***}
|
||||
(let ((binding (binding-in-frame val frame)))
|
||||
(if binding
|
||||
(unify-match
|
||||
var (binding-value binding) frame)
|
||||
(extend var val frame))))
|
||||
((depends-on? val var frame) ; {\em ; ***}
|
||||
'failed)
|
||||
(else (extend var val frame)))))
|
||||
|
||||
(define (depends-on? exp var frame)
|
||||
(define (tree-walk e)
|
||||
(cond ((var? e)
|
||||
(if (equal? var e)
|
||||
true
|
||||
(let ((b (binding-in-frame e frame)))
|
||||
(if b
|
||||
(tree-walk (binding-value b))
|
||||
false))))
|
||||
((pair? e)
|
||||
(or (tree-walk (car e))
|
||||
(tree-walk (cdr e))))
|
||||
(else false)))
|
||||
(tree-walk exp))
|
||||
|
||||
;;;SECTION 4.4.4.5
|
||||
;;;Maintaining the Data Base
|
||||
|
||||
(define THE-ASSERTIONS the-empty-stream)
|
||||
|
||||
(define (fetch-assertions pattern frame)
|
||||
(if (use-index? pattern)
|
||||
(get-indexed-assertions pattern)
|
||||
(get-all-assertions)))
|
||||
|
||||
(define (get-all-assertions) THE-ASSERTIONS)
|
||||
|
||||
(define (get-indexed-assertions pattern)
|
||||
(get-stream (index-key-of pattern) 'assertion-stream))
|
||||
|
||||
(define (get-stream key1 key2)
|
||||
(let ((s (get key1 key2)))
|
||||
(if s s the-empty-stream)))
|
||||
|
||||
(define THE-RULES the-empty-stream)
|
||||
|
||||
(define (fetch-rules pattern frame)
|
||||
(if (use-index? pattern)
|
||||
(get-indexed-rules pattern)
|
||||
(get-all-rules)))
|
||||
|
||||
(define (get-all-rules) THE-RULES)
|
||||
|
||||
(define (get-indexed-rules pattern)
|
||||
(stream-append
|
||||
(get-stream (index-key-of pattern) 'rule-stream)
|
||||
(get-stream '? 'rule-stream)))
|
||||
|
||||
(define (add-rule-or-assertion! assertion)
|
||||
(if (rule? assertion)
|
||||
(add-rule! assertion)
|
||||
(add-assertion! assertion)))
|
||||
|
||||
(define (add-assertion! assertion)
|
||||
(store-assertion-in-index assertion)
|
||||
(let ((old-assertions THE-ASSERTIONS))
|
||||
(set! THE-ASSERTIONS
|
||||
(cons-stream assertion old-assertions))
|
||||
'ok))
|
||||
|
||||
(define (add-rule! rule)
|
||||
(store-rule-in-index rule)
|
||||
(let ((old-rules THE-RULES))
|
||||
(set! THE-RULES (cons-stream rule old-rules))
|
||||
'ok))
|
||||
|
||||
(define (store-assertion-in-index assertion)
|
||||
(if (indexable? assertion)
|
||||
(let ((key (index-key-of assertion)))
|
||||
(let ((current-assertion-stream
|
||||
(get-stream key 'assertion-stream)))
|
||||
(put key
|
||||
'assertion-stream
|
||||
(cons-stream assertion
|
||||
current-assertion-stream))))))
|
||||
|
||||
(define (store-rule-in-index rule)
|
||||
(let ((pattern (conclusion rule)))
|
||||
(if (indexable? pattern)
|
||||
(let ((key (index-key-of pattern)))
|
||||
(let ((current-rule-stream
|
||||
(get-stream key 'rule-stream)))
|
||||
(put key
|
||||
'rule-stream
|
||||
(cons-stream rule
|
||||
current-rule-stream)))))))
|
||||
|
||||
(define (indexable? pat)
|
||||
(or (constant-symbol? (car pat))
|
||||
(var? (car pat))))
|
||||
|
||||
(define (index-key-of pat)
|
||||
(let ((key (car pat)))
|
||||
(if (var? key) '? key)))
|
||||
|
||||
(define (use-index? pat)
|
||||
(constant-symbol? (car pat)))
|
||||
|
||||
;;;SECTION 4.4.4.6
|
||||
;;;Stream operations
|
||||
|
||||
(define (stream-append-delayed s1 delayed-s2)
|
||||
(if (stream-null? s1)
|
||||
(force delayed-s2)
|
||||
(cons-stream
|
||||
(stream-car s1)
|
||||
(stream-append-delayed (stream-cdr s1) delayed-s2))))
|
||||
|
||||
(define (interleave-delayed s1 delayed-s2)
|
||||
(if (stream-null? s1)
|
||||
(force delayed-s2)
|
||||
(cons-stream
|
||||
(stream-car s1)
|
||||
(interleave-delayed (force delayed-s2)
|
||||
(delay (stream-cdr s1))))))
|
||||
|
||||
(define (stream-flatmap proc s)
|
||||
(flatten-stream (stream-map proc s)))
|
||||
|
||||
(define (flatten-stream stream)
|
||||
(if (stream-null? stream)
|
||||
the-empty-stream
|
||||
(interleave-delayed
|
||||
(stream-car stream)
|
||||
(delay (flatten-stream (stream-cdr stream))))))
|
||||
|
||||
|
||||
(define (singleton-stream x)
|
||||
(cons-stream x the-empty-stream))
|
||||
|
||||
|
||||
;;;SECTION 4.4.4.7
|
||||
;;;Query syntax procedures
|
||||
|
||||
(define (type exp)
|
||||
(if (pair? exp)
|
||||
(car exp)
|
||||
(error "Unknown expression TYPE" exp)))
|
||||
|
||||
(define (contents exp)
|
||||
(if (pair? exp)
|
||||
(cdr exp)
|
||||
(error "Unknown expression CONTENTS" exp)))
|
||||
|
||||
(define (assertion-to-be-added? exp)
|
||||
(eq? (type exp) 'assert!))
|
||||
|
||||
(define (add-assertion-body exp)
|
||||
(car (contents exp)))
|
||||
|
||||
(define (empty-conjunction? exps) (null? exps))
|
||||
(define (first-conjunct exps) (car exps))
|
||||
(define (rest-conjuncts exps) (cdr exps))
|
||||
|
||||
(define (empty-disjunction? exps) (null? exps))
|
||||
(define (first-disjunct exps) (car exps))
|
||||
(define (rest-disjuncts exps) (cdr exps))
|
||||
|
||||
(define (negated-query exps) (car exps))
|
||||
|
||||
(define (predicate exps) (car exps))
|
||||
(define (args exps) (cdr exps))
|
||||
|
||||
|
||||
(define (rule? statement)
|
||||
(tagged-list? statement 'rule))
|
||||
|
||||
(define (conclusion rule) (cadr rule))
|
||||
|
||||
(define (rule-body rule)
|
||||
(if (null? (cddr rule))
|
||||
'(always-true)
|
||||
(caddr rule)))
|
||||
|
||||
(define (query-syntax-process exp)
|
||||
(map-over-symbols expand-question-mark exp))
|
||||
|
||||
(define (map-over-symbols proc exp)
|
||||
(cond ((pair? exp)
|
||||
(cons (map-over-symbols proc (car exp))
|
||||
(map-over-symbols proc (cdr exp))))
|
||||
((symbol? exp) (proc exp))
|
||||
(else exp)))
|
||||
|
||||
(define (expand-question-mark symbol)
|
||||
(let ((chars (symbol->string symbol)))
|
||||
(if (string=? (substring chars 0 1) "?")
|
||||
(list '?
|
||||
(string->symbol
|
||||
(substring chars 1 (string-length chars))))
|
||||
symbol)))
|
||||
|
||||
(define (var? exp)
|
||||
(tagged-list? exp '?))
|
||||
|
||||
(define (constant-symbol? exp) (symbol? exp))
|
||||
|
||||
(define rule-counter 0)
|
||||
|
||||
(define (new-rule-application-id)
|
||||
(set! rule-counter (+ 1 rule-counter))
|
||||
rule-counter)
|
||||
|
||||
(define (make-new-variable var rule-application-id)
|
||||
(cons '? (cons rule-application-id (cdr var))))
|
||||
|
||||
(define (contract-question-mark variable)
|
||||
(string->symbol
|
||||
(string-append "?"
|
||||
(if (number? (cadr variable))
|
||||
(string-append (symbol->string (caddr variable))
|
||||
"-"
|
||||
(number->string (cadr variable)))
|
||||
(symbol->string (cadr variable))))))
|
||||
|
||||
|
||||
;;;SECTION 4.4.4.8
|
||||
;;;Frames and bindings
|
||||
(define (make-binding variable value)
|
||||
(cons variable value))
|
||||
|
||||
(define (binding-variable binding)
|
||||
(car binding))
|
||||
|
||||
(define (binding-value binding)
|
||||
(cdr binding))
|
||||
|
||||
|
||||
(define (binding-in-frame variable frame)
|
||||
(assoc variable frame))
|
||||
|
||||
(define (extend variable value frame)
|
||||
(cons (make-binding variable value) frame))
|
||||
|
||||
|
||||
;;;;From Section 4.1
|
||||
|
||||
(define (tagged-list? exp tag)
|
||||
(if (pair? exp)
|
||||
(eq? (car exp) tag)
|
||||
false))
|
||||
|
||||
(define (prompt-for-input string)
|
||||
(newline) (newline) (display string) (newline))
|
||||
|
||||
|
||||
;;;;Stream support from Chapter 3
|
||||
|
||||
(define (stream-map proc s)
|
||||
(if (stream-null? s)
|
||||
the-empty-stream
|
||||
(cons-stream (proc (stream-car s))
|
||||
(stream-map proc (stream-cdr s)))))
|
||||
|
||||
(define (stream-for-each proc s)
|
||||
(if (stream-null? s)
|
||||
'done
|
||||
(begin (proc (stream-car s))
|
||||
(stream-for-each proc (stream-cdr s)))))
|
||||
|
||||
(define (display-stream s)
|
||||
(stream-for-each display-line s))
|
||||
(define (display-line x)
|
||||
(newline)
|
||||
(display x))
|
||||
|
||||
(define (stream-filter pred stream)
|
||||
(cond ((stream-null? stream) the-empty-stream)
|
||||
((pred (stream-car stream))
|
||||
(cons-stream (stream-car stream)
|
||||
(stream-filter pred
|
||||
(stream-cdr stream))))
|
||||
(else (stream-filter pred (stream-cdr stream)))))
|
||||
|
||||
(define (stream-append s1 s2)
|
||||
(if (stream-null? s1)
|
||||
s2
|
||||
(cons-stream (stream-car s1)
|
||||
(stream-append (stream-cdr s1) s2))))
|
||||
|
||||
(define (interleave s1 s2)
|
||||
(if (stream-null? s1)
|
||||
s2
|
||||
(cons-stream (stream-car s1)
|
||||
(interleave s2 (stream-cdr s1)))))
|
||||
|
||||
;;;;Table support from Chapter 3, Section 3.3.3 (local tables)
|
||||
|
||||
(define (make-table)
|
||||
(let ((local-table (list '*table*)))
|
||||
(define (lookup key-1 key-2)
|
||||
(let ((subtable (assoc key-1 (cdr local-table))))
|
||||
(if subtable
|
||||
(let ((record (assoc key-2 (cdr subtable))))
|
||||
(if record
|
||||
(cdr record)
|
||||
false))
|
||||
false)))
|
||||
(define (insert! key-1 key-2 value)
|
||||
(let ((subtable (assoc key-1 (cdr local-table))))
|
||||
(if subtable
|
||||
(let ((record (assoc key-2 (cdr subtable))))
|
||||
(if record
|
||||
(set-cdr! record value)
|
||||
(set-cdr! subtable
|
||||
(cons (cons key-2 value)
|
||||
(cdr subtable)))))
|
||||
(set-cdr! local-table
|
||||
(cons (list key-1
|
||||
(cons key-2 value))
|
||||
(cdr local-table)))))
|
||||
'ok)
|
||||
(define (dispatch m)
|
||||
(cond ((eq? m 'lookup-proc) lookup)
|
||||
((eq? m 'insert-proc!) insert!)
|
||||
(else (error "Unknown operation -- TABLE" m))))
|
||||
dispatch))
|
||||
|
||||
;;;; From instructor's manual
|
||||
|
||||
(define get '())
|
||||
|
||||
(define put '())
|
||||
|
||||
(define (initialize-data-base rules-and-assertions)
|
||||
(define (deal-out r-and-a rules assertions)
|
||||
(cond ((null? r-and-a)
|
||||
(set! THE-ASSERTIONS (list->stream assertions))
|
||||
(set! THE-RULES (list->stream rules))
|
||||
'done)
|
||||
(else
|
||||
(let ((s (query-syntax-process (car r-and-a))))
|
||||
(cond ((rule? s)
|
||||
(store-rule-in-index s)
|
||||
(deal-out (cdr r-and-a)
|
||||
(cons s rules)
|
||||
assertions))
|
||||
(else
|
||||
(store-assertion-in-index s)
|
||||
(deal-out (cdr r-and-a)
|
||||
rules
|
||||
(cons s assertions))))))))
|
||||
(let ((operation-table (make-table)))
|
||||
(set! get (operation-table 'lookup-proc))
|
||||
(set! put (operation-table 'insert-proc!)))
|
||||
(put 'and 'qeval conjoin)
|
||||
(put 'or 'qeval disjoin)
|
||||
(put 'not 'qeval negate)
|
||||
(put 'lisp-value 'qeval lisp-value)
|
||||
(put 'always-true 'qeval always-true)
|
||||
(deal-out rules-and-assertions '() '()))
|
||||
|
||||
;; Do following to reinit the data base from microshaft-data-base
|
||||
;; in Scheme (not in the query driver loop)
|
||||
;; (initialize-data-base microshaft-data-base)
|
||||
|
||||
(define microshaft-data-base
|
||||
'(
|
||||
;; from section 4.4.1
|
||||
(address (Bitdiddle Ben) (Slumerville (Ridge Road) 10))
|
||||
(job (Bitdiddle Ben) (computer wizard))
|
||||
(salary (Bitdiddle Ben) 60000)
|
||||
|
||||
(address (Hacker Alyssa P) (Cambridge (Mass Ave) 78))
|
||||
(job (Hacker Alyssa P) (computer programmer))
|
||||
(salary (Hacker Alyssa P) 40000)
|
||||
(supervisor (Hacker Alyssa P) (Bitdiddle Ben))
|
||||
|
||||
(address (Fect Cy D) (Cambridge (Ames Street) 3))
|
||||
(job (Fect Cy D) (computer programmer))
|
||||
(salary (Fect Cy D) 35000)
|
||||
(supervisor (Fect Cy D) (Bitdiddle Ben))
|
||||
|
||||
(address (Tweakit Lem E) (Boston (Bay State Road) 22))
|
||||
(job (Tweakit Lem E) (computer technician))
|
||||
(salary (Tweakit Lem E) 25000)
|
||||
(supervisor (Tweakit Lem E) (Bitdiddle Ben))
|
||||
|
||||
(address (Reasoner Louis) (Slumerville (Pine Tree Road) 80))
|
||||
(job (Reasoner Louis) (computer programmer trainee))
|
||||
(salary (Reasoner Louis) 30000)
|
||||
(supervisor (Reasoner Louis) (Hacker Alyssa P))
|
||||
|
||||
(supervisor (Bitdiddle Ben) (Warbucks Oliver))
|
||||
|
||||
(address (Warbucks Oliver) (Swellesley (Top Heap Road)))
|
||||
(job (Warbucks Oliver) (administration big wheel))
|
||||
(salary (Warbucks Oliver) 150000)
|
||||
|
||||
(address (Scrooge Eben) (Weston (Shady Lane) 10))
|
||||
(job (Scrooge Eben) (accounting chief accountant))
|
||||
(salary (Scrooge Eben) 75000)
|
||||
(supervisor (Scrooge Eben) (Warbucks Oliver))
|
||||
|
||||
(address (Cratchet Robert) (Allston (N Harvard Street) 16))
|
||||
(job (Cratchet Robert) (accounting scrivener))
|
||||
(salary (Cratchet Robert) 18000)
|
||||
(supervisor (Cratchet Robert) (Scrooge Eben))
|
||||
|
||||
(address (Aull DeWitt) (Slumerville (Onion Square) 5))
|
||||
(job (Aull DeWitt) (administration secretary))
|
||||
(salary (Aull DeWitt) 25000)
|
||||
(supervisor (Aull DeWitt) (Warbucks Oliver))
|
||||
|
||||
(can-do-job (computer wizard) (computer programmer))
|
||||
(can-do-job (computer wizard) (computer technician))
|
||||
|
||||
(can-do-job (computer programmer)
|
||||
(computer programmer trainee))
|
||||
|
||||
(can-do-job (administration secretary)
|
||||
(administration big wheel))
|
||||
|
||||
(rule (lives-near ?person-1 ?person-2)
|
||||
(and (address ?person-1 (?town . ?rest-1))
|
||||
(address ?person-2 (?town . ?rest-2))
|
||||
(not (same ?person-1 ?person-2))))
|
||||
|
||||
(rule (same ?x ?x))
|
||||
|
||||
(rule (wheel ?person)
|
||||
(and (supervisor ?middle-manager ?person)
|
||||
(supervisor ?x ?middle-manager)))
|
||||
|
||||
(rule (outranked-by ?staff-person ?boss)
|
||||
(or (supervisor ?staff-person ?boss)
|
||||
(and (supervisor ?staff-person ?middle-manager)
|
||||
(outranked-by ?middle-manager ?boss))))
|
||||
))
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -0,0 +1,187 @@
|
|||
;;;;SIMULATION OF ECEVAL MACHINE OPERATIONS --
|
||||
;;;;loaded by load-eceval.scm and by load-eceval-compiler.scm
|
||||
|
||||
;;;;FIRST A LOT FROM 4.1.2-4.1.4
|
||||
|
||||
(load "ch5-syntax.scm"); ;section 4.1.2 syntax procedures
|
||||
|
||||
;;;SECTION 4.1.3
|
||||
;;; operations used by compiled code and eceval except as noted
|
||||
|
||||
(define (true? x)
|
||||
(not (eq? x false)))
|
||||
|
||||
;;* not used by eceval itself -- used by compiled code when that
|
||||
;; is run in the eceval machine
|
||||
(define (false? x)
|
||||
(eq? x false))
|
||||
|
||||
;;following compound-procedure operations not used by compiled code
|
||||
(define (make-procedure parameters body env)
|
||||
(list 'procedure parameters body env))
|
||||
|
||||
(define (compound-procedure? p)
|
||||
(tagged-list? p 'procedure))
|
||||
|
||||
(define (procedure-parameters p) (cadr p))
|
||||
(define (procedure-body p) (caddr p))
|
||||
(define (procedure-environment p) (cadddr p))
|
||||
;;(end of compound procedures)
|
||||
|
||||
|
||||
(define (enclosing-environment env) (cdr env))
|
||||
|
||||
(define (first-frame env) (car env))
|
||||
|
||||
(define the-empty-environment '())
|
||||
|
||||
(define (make-frame variables values)
|
||||
(cons variables values))
|
||||
|
||||
(define (frame-variables frame) (car frame))
|
||||
(define (frame-values frame) (cdr frame))
|
||||
|
||||
(define (add-binding-to-frame! var val frame)
|
||||
(set-car! frame (cons var (car frame)))
|
||||
(set-cdr! frame (cons val (cdr frame))))
|
||||
|
||||
(define (extend-environment vars vals base-env)
|
||||
(if (= (length vars) (length vals))
|
||||
(cons (make-frame vars vals) base-env)
|
||||
(if (< (length vars) (length vals))
|
||||
(error "Too many arguments supplied" vars vals)
|
||||
(error "Too few arguments supplied" vars vals))))
|
||||
|
||||
|
||||
(define (lookup-variable-value var env)
|
||||
(define (env-loop env)
|
||||
(define (scan vars vals)
|
||||
(cond ((null? vars)
|
||||
(env-loop (enclosing-environment env)))
|
||||
((eq? var (car vars))
|
||||
(car vals))
|
||||
(else (scan (cdr vars) (cdr vals)))))
|
||||
(if (eq? env the-empty-environment)
|
||||
(error "Unbound variable" var)
|
||||
(let ((frame (first-frame env)))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame)))))
|
||||
(env-loop env))
|
||||
|
||||
(define (set-variable-value! var val env)
|
||||
(define (env-loop env)
|
||||
(define (scan vars vals)
|
||||
(cond ((null? vars)
|
||||
(env-loop (enclosing-environment env)))
|
||||
((eq? var (car vars))
|
||||
(set-car! vals val))
|
||||
(else (scan (cdr vars) (cdr vals)))))
|
||||
(if (eq? env the-empty-environment)
|
||||
(error "Unbound variable -- SET!" var)
|
||||
(let ((frame (first-frame env)))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame)))))
|
||||
(env-loop env))
|
||||
|
||||
(define (define-variable! var val env)
|
||||
(let ((frame (first-frame env)))
|
||||
(define (scan vars vals)
|
||||
(cond ((null? vars)
|
||||
(add-binding-to-frame! var val frame))
|
||||
((eq? var (car vars))
|
||||
(set-car! vals val))
|
||||
(else (scan (cdr vars) (cdr vals)))))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame))))
|
||||
|
||||
|
||||
;;;SECTION 4.1.4
|
||||
|
||||
(define (setup-environment)
|
||||
(let ((initial-env
|
||||
(extend-environment (primitive-procedure-names)
|
||||
(primitive-procedure-objects)
|
||||
the-empty-environment)))
|
||||
(define-variable! 'true true initial-env)
|
||||
(define-variable! 'false false initial-env)
|
||||
initial-env))
|
||||
|
||||
(define (primitive-procedure? proc)
|
||||
(tagged-list? proc 'primitive))
|
||||
|
||||
(define (primitive-implementation proc) (cadr proc))
|
||||
|
||||
(define primitive-procedures
|
||||
(list (list 'car car)
|
||||
(list 'cdr cdr)
|
||||
(list 'cons cons)
|
||||
(list 'null? null?)
|
||||
;;above from book -- here are some more
|
||||
(list '+ +)
|
||||
(list '- -)
|
||||
(list '* *)
|
||||
(list '= =)
|
||||
(list '/ /)
|
||||
(list '> >)
|
||||
(list '< <)
|
||||
))
|
||||
|
||||
(define (primitive-procedure-names)
|
||||
(map car
|
||||
primitive-procedures))
|
||||
|
||||
(define (primitive-procedure-objects)
|
||||
(map (lambda (proc) (list 'primitive (cadr proc)))
|
||||
primitive-procedures))
|
||||
|
||||
(define apply-in-underlying-scheme apply)
|
||||
|
||||
(define (apply-primitive-procedure proc args)
|
||||
(apply-in-underlying-scheme
|
||||
(primitive-implementation proc) args))
|
||||
|
||||
|
||||
(define (prompt-for-input string)
|
||||
(newline) (newline) (display string) (newline))
|
||||
|
||||
(define (announce-output string)
|
||||
(newline) (display string) (newline))
|
||||
|
||||
(define (user-print object)
|
||||
(if (compound-procedure? object)
|
||||
(display (list 'compound-procedure
|
||||
(procedure-parameters object)
|
||||
(procedure-body object)
|
||||
'<procedure-env>))
|
||||
(display object)))
|
||||
|
||||
;;; Simulation of new machine operations needed by
|
||||
;;; eceval machine (not used by compiled code)
|
||||
|
||||
;;; From section 5.4.1 footnote
|
||||
(define (empty-arglist) '())
|
||||
(define (adjoin-arg arg arglist)
|
||||
(append arglist (list arg)))
|
||||
(define (last-operand? ops)
|
||||
(null? (cdr ops)))
|
||||
|
||||
;;; From section 5.4.2 footnote, for non-tail-recursive sequences
|
||||
(define (no-more-exps? seq) (null? seq))
|
||||
|
||||
;;; From section 5.4.4 footnote
|
||||
(define (get-global-environment)
|
||||
the-global-environment)
|
||||
;; will do following when ready to run, not when load this file
|
||||
;;(define the-global-environment (setup-environment))
|
||||
|
||||
|
||||
;;; Simulation of new machine operations needed for compiled code
|
||||
;;; and eceval/compiler interface (not used by plain eceval machine)
|
||||
;;; From section 5.5.2 footnote
|
||||
(define (make-compiled-procedure entry env)
|
||||
(list 'compiled-procedure entry env))
|
||||
(define (compiled-procedure? proc)
|
||||
(tagged-list? proc 'compiled-procedure))
|
||||
(define (compiled-procedure-entry c-proc) (cadr c-proc))
|
||||
(define (compiled-procedure-env c-proc) (caddr c-proc))
|
||||
|
||||
|
|
@ -0,0 +1,298 @@
|
|||
;;;;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 eceval)
|
||||
|
||||
;; To restart, can do just
|
||||
;: (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)
|
||||
|
||||
;;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 '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))
|
||||
)
|
||||
|
||||
(define eceval
|
||||
(make-machine
|
||||
'(exp env val proc argl continue unev)
|
||||
eceval-operations
|
||||
'(
|
||||
;;SECTION 5.4.4
|
||||
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))
|
||||
|
||||
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))
|
||||
(goto (label unknown-procedure-type))
|
||||
|
||||
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 LOADED)
|
||||
|
|
@ -0,0 +1,407 @@
|
|||
;;;;REGISTER-MACHINE SIMULATOR FROM SECTION 5.2 OF
|
||||
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
|
||||
|
||||
;;;;Matches code in ch5.scm
|
||||
|
||||
;;;;This file can be loaded into Scheme as a whole.
|
||||
;;;;Then you can define and simulate machines as shown in section 5.2
|
||||
|
||||
;;;**NB** there are two versions of make-stack below.
|
||||
;;; Choose the monitored or unmonitored one by reordering them to put the
|
||||
;;; one you want last, or by commenting one of them out.
|
||||
;;; Also, comment in/out the print-stack-statistics op in make-new-machine
|
||||
;;; To find this stack code below, look for comments with **
|
||||
|
||||
|
||||
(define (make-machine register-names ops controller-text)
|
||||
(let ((machine (make-new-machine)))
|
||||
(for-each (lambda (register-name)
|
||||
((machine 'allocate-register) register-name))
|
||||
register-names)
|
||||
((machine 'install-operations) ops)
|
||||
((machine 'install-instruction-sequence)
|
||||
(assemble controller-text machine))
|
||||
machine))
|
||||
|
||||
(define (make-register name)
|
||||
(let ((contents '*unassigned*))
|
||||
(define (dispatch message)
|
||||
(cond ((eq? message 'get) contents)
|
||||
((eq? message 'set)
|
||||
(lambda (value) (set! contents value)))
|
||||
(else
|
||||
(error "Unknown request -- REGISTER" message))))
|
||||
dispatch))
|
||||
|
||||
(define (get-contents register)
|
||||
(register 'get))
|
||||
|
||||
(define (set-contents! register value)
|
||||
((register 'set) value))
|
||||
|
||||
;;**original (unmonitored) version from section 5.2.1
|
||||
(define (make-stack)
|
||||
(let ((s '()))
|
||||
(define (push x)
|
||||
(set! s (cons x s)))
|
||||
(define (pop)
|
||||
(if (null? s)
|
||||
(error "Empty stack -- POP")
|
||||
(let ((top (car s)))
|
||||
(set! s (cdr s))
|
||||
top)))
|
||||
(define (initialize)
|
||||
(set! s '())
|
||||
'done)
|
||||
(define (dispatch message)
|
||||
(cond ((eq? message 'push) push)
|
||||
((eq? message 'pop) (pop))
|
||||
((eq? message 'initialize) (initialize))
|
||||
(else (error "Unknown request -- STACK"
|
||||
message))))
|
||||
dispatch))
|
||||
|
||||
(define (pop stack)
|
||||
(stack 'pop))
|
||||
|
||||
(define (push stack value)
|
||||
((stack 'push) value))
|
||||
|
||||
;;**monitored version from section 5.2.4
|
||||
(define (make-stack)
|
||||
(let ((s '())
|
||||
(number-pushes 0)
|
||||
(max-depth 0)
|
||||
(current-depth 0))
|
||||
(define (push x)
|
||||
(set! s (cons x s))
|
||||
(set! number-pushes (+ 1 number-pushes))
|
||||
(set! current-depth (+ 1 current-depth))
|
||||
(set! max-depth (max current-depth max-depth)))
|
||||
(define (pop)
|
||||
(if (null? s)
|
||||
(error "Empty stack -- POP")
|
||||
(let ((top (car s)))
|
||||
(set! s (cdr s))
|
||||
(set! current-depth (- current-depth 1))
|
||||
top)))
|
||||
(define (initialize)
|
||||
(set! s '())
|
||||
(set! number-pushes 0)
|
||||
(set! max-depth 0)
|
||||
(set! current-depth 0)
|
||||
'done)
|
||||
(define (print-statistics)
|
||||
(newline)
|
||||
(display (list 'total-pushes '= number-pushes
|
||||
'maximum-depth '= max-depth)))
|
||||
(define (dispatch message)
|
||||
(cond ((eq? message 'push) push)
|
||||
((eq? message 'pop) (pop))
|
||||
((eq? message 'initialize) (initialize))
|
||||
((eq? message 'print-statistics)
|
||||
(print-statistics))
|
||||
(else
|
||||
(error "Unknown request -- STACK" message))))
|
||||
dispatch))
|
||||
|
||||
(define (make-new-machine)
|
||||
(let ((pc (make-register 'pc))
|
||||
(flag (make-register 'flag))
|
||||
(stack (make-stack))
|
||||
(the-instruction-sequence '()))
|
||||
(let ((the-ops
|
||||
(list (list 'initialize-stack
|
||||
(lambda () (stack 'initialize)))
|
||||
;;**next for monitored stack (as in section 5.2.4)
|
||||
;; -- comment out if not wanted
|
||||
(list 'print-stack-statistics
|
||||
(lambda () (stack 'print-statistics)))))
|
||||
(register-table
|
||||
(list (list 'pc pc) (list 'flag flag))))
|
||||
(define (allocate-register name)
|
||||
(if (assoc name register-table)
|
||||
(error "Multiply defined register: " name)
|
||||
(set! register-table
|
||||
(cons (list name (make-register name))
|
||||
register-table)))
|
||||
'register-allocated)
|
||||
(define (lookup-register name)
|
||||
(let ((val (assoc name register-table)))
|
||||
(if val
|
||||
(cadr val)
|
||||
(error "Unknown register:" name))))
|
||||
(define (execute)
|
||||
(let ((insts (get-contents pc)))
|
||||
(if (null? insts)
|
||||
'done
|
||||
(begin
|
||||
((instruction-execution-proc (car insts)))
|
||||
(execute)))))
|
||||
(define (dispatch message)
|
||||
(cond ((eq? message 'start)
|
||||
(set-contents! pc the-instruction-sequence)
|
||||
(execute))
|
||||
((eq? message 'install-instruction-sequence)
|
||||
(lambda (seq) (set! the-instruction-sequence seq)))
|
||||
((eq? message 'allocate-register) allocate-register)
|
||||
((eq? message 'get-register) lookup-register)
|
||||
((eq? message 'install-operations)
|
||||
(lambda (ops) (set! the-ops (append the-ops ops))))
|
||||
((eq? message 'stack) stack)
|
||||
((eq? message 'operations) the-ops)
|
||||
(else (error "Unknown request -- MACHINE" message))))
|
||||
dispatch)))
|
||||
|
||||
|
||||
(define (start machine)
|
||||
(machine 'start))
|
||||
|
||||
(define (get-register-contents machine register-name)
|
||||
(get-contents (get-register machine register-name)))
|
||||
|
||||
(define (set-register-contents! machine register-name value)
|
||||
(set-contents! (get-register machine register-name) value)
|
||||
'done)
|
||||
|
||||
(define (get-register machine reg-name)
|
||||
((machine 'get-register) reg-name))
|
||||
|
||||
(define (assemble controller-text machine)
|
||||
(extract-labels controller-text
|
||||
(lambda (insts labels)
|
||||
(update-insts! insts labels machine)
|
||||
insts)))
|
||||
|
||||
(define (extract-labels text receive)
|
||||
(if (null? text)
|
||||
(receive '() '())
|
||||
(extract-labels (cdr text)
|
||||
(lambda (insts labels)
|
||||
(let ((next-inst (car text)))
|
||||
(if (symbol? next-inst)
|
||||
(receive insts
|
||||
(cons (make-label-entry next-inst
|
||||
insts)
|
||||
labels))
|
||||
(receive (cons (make-instruction next-inst)
|
||||
insts)
|
||||
labels)))))))
|
||||
|
||||
(define (update-insts! insts labels machine)
|
||||
(let ((pc (get-register machine 'pc))
|
||||
(flag (get-register machine 'flag))
|
||||
(stack (machine 'stack))
|
||||
(ops (machine 'operations)))
|
||||
(for-each
|
||||
(lambda (inst)
|
||||
(set-instruction-execution-proc!
|
||||
inst
|
||||
(make-execution-procedure
|
||||
(instruction-text inst) labels machine
|
||||
pc flag stack ops)))
|
||||
insts)))
|
||||
|
||||
(define (make-instruction text)
|
||||
(cons text '()))
|
||||
|
||||
(define (instruction-text inst)
|
||||
(car inst))
|
||||
|
||||
(define (instruction-execution-proc inst)
|
||||
(cdr inst))
|
||||
|
||||
(define (set-instruction-execution-proc! inst proc)
|
||||
(set-cdr! inst proc))
|
||||
|
||||
(define (make-label-entry label-name insts)
|
||||
(cons label-name insts))
|
||||
|
||||
(define (lookup-label labels label-name)
|
||||
(let ((val (assoc label-name labels)))
|
||||
(if val
|
||||
(cdr val)
|
||||
(error "Undefined label -- ASSEMBLE" label-name))))
|
||||
|
||||
|
||||
(define (make-execution-procedure inst labels machine
|
||||
pc flag stack ops)
|
||||
(cond ((eq? (car inst) 'assign)
|
||||
(make-assign inst machine labels ops pc))
|
||||
((eq? (car inst) 'test)
|
||||
(make-test inst machine labels ops flag pc))
|
||||
((eq? (car inst) 'branch)
|
||||
(make-branch inst machine labels flag pc))
|
||||
((eq? (car inst) 'goto)
|
||||
(make-goto inst machine labels pc))
|
||||
((eq? (car inst) 'save)
|
||||
(make-save inst machine stack pc))
|
||||
((eq? (car inst) 'restore)
|
||||
(make-restore inst machine stack pc))
|
||||
((eq? (car inst) 'perform)
|
||||
(make-perform inst machine labels ops pc))
|
||||
(else (error "Unknown instruction type -- ASSEMBLE"
|
||||
inst))))
|
||||
|
||||
|
||||
(define (make-assign inst machine labels operations pc)
|
||||
(let ((target
|
||||
(get-register machine (assign-reg-name inst)))
|
||||
(value-exp (assign-value-exp inst)))
|
||||
(let ((value-proc
|
||||
(if (operation-exp? value-exp)
|
||||
(make-operation-exp
|
||||
value-exp machine labels operations)
|
||||
(make-primitive-exp
|
||||
(car value-exp) machine labels))))
|
||||
(lambda () ; execution procedure for assign
|
||||
(set-contents! target (value-proc))
|
||||
(advance-pc pc)))))
|
||||
|
||||
(define (assign-reg-name assign-instruction)
|
||||
(cadr assign-instruction))
|
||||
|
||||
(define (assign-value-exp assign-instruction)
|
||||
(cddr assign-instruction))
|
||||
|
||||
(define (advance-pc pc)
|
||||
(set-contents! pc (cdr (get-contents pc))))
|
||||
|
||||
(define (make-test inst machine labels operations flag pc)
|
||||
(let ((condition (test-condition inst)))
|
||||
(if (operation-exp? condition)
|
||||
(let ((condition-proc
|
||||
(make-operation-exp
|
||||
condition machine labels operations)))
|
||||
(lambda ()
|
||||
(set-contents! flag (condition-proc))
|
||||
(advance-pc pc)))
|
||||
(error "Bad TEST instruction -- ASSEMBLE" inst))))
|
||||
|
||||
(define (test-condition test-instruction)
|
||||
(cdr test-instruction))
|
||||
|
||||
|
||||
(define (make-branch inst machine labels flag pc)
|
||||
(let ((dest (branch-dest inst)))
|
||||
(if (label-exp? dest)
|
||||
(let ((insts
|
||||
(lookup-label labels (label-exp-label dest))))
|
||||
(lambda ()
|
||||
(if (get-contents flag)
|
||||
(set-contents! pc insts)
|
||||
(advance-pc pc))))
|
||||
(error "Bad BRANCH instruction -- ASSEMBLE" inst))))
|
||||
|
||||
(define (branch-dest branch-instruction)
|
||||
(cadr branch-instruction))
|
||||
|
||||
|
||||
(define (make-goto inst machine labels pc)
|
||||
(let ((dest (goto-dest inst)))
|
||||
(cond ((label-exp? dest)
|
||||
(let ((insts
|
||||
(lookup-label labels
|
||||
(label-exp-label dest))))
|
||||
(lambda () (set-contents! pc insts))))
|
||||
((register-exp? dest)
|
||||
(let ((reg
|
||||
(get-register machine
|
||||
(register-exp-reg dest))))
|
||||
(lambda ()
|
||||
(set-contents! pc (get-contents reg)))))
|
||||
(else (error "Bad GOTO instruction -- ASSEMBLE"
|
||||
inst)))))
|
||||
|
||||
(define (goto-dest goto-instruction)
|
||||
(cadr goto-instruction))
|
||||
|
||||
(define (make-save inst machine stack pc)
|
||||
(let ((reg (get-register machine
|
||||
(stack-inst-reg-name inst))))
|
||||
(lambda ()
|
||||
(push stack (get-contents reg))
|
||||
(advance-pc pc))))
|
||||
|
||||
(define (make-restore inst machine stack pc)
|
||||
(let ((reg (get-register machine
|
||||
(stack-inst-reg-name inst))))
|
||||
(lambda ()
|
||||
(set-contents! reg (pop stack))
|
||||
(advance-pc pc))))
|
||||
|
||||
(define (stack-inst-reg-name stack-instruction)
|
||||
(cadr stack-instruction))
|
||||
|
||||
(define (make-perform inst machine labels operations pc)
|
||||
(let ((action (perform-action inst)))
|
||||
(if (operation-exp? action)
|
||||
(let ((action-proc
|
||||
(make-operation-exp
|
||||
action machine labels operations)))
|
||||
(lambda ()
|
||||
(action-proc)
|
||||
(advance-pc pc)))
|
||||
(error "Bad PERFORM instruction -- ASSEMBLE" inst))))
|
||||
|
||||
(define (perform-action inst) (cdr inst))
|
||||
|
||||
(define (make-primitive-exp exp machine labels)
|
||||
(cond ((constant-exp? exp)
|
||||
(let ((c (constant-exp-value exp)))
|
||||
(lambda () c)))
|
||||
((label-exp? exp)
|
||||
(let ((insts
|
||||
(lookup-label labels
|
||||
(label-exp-label exp))))
|
||||
(lambda () insts)))
|
||||
((register-exp? exp)
|
||||
(let ((r (get-register machine
|
||||
(register-exp-reg exp))))
|
||||
(lambda () (get-contents r))))
|
||||
(else
|
||||
(error "Unknown expression type -- ASSEMBLE" exp))))
|
||||
|
||||
(define (register-exp? exp) (tagged-list? exp 'reg))
|
||||
|
||||
(define (register-exp-reg exp) (cadr exp))
|
||||
|
||||
(define (constant-exp? exp) (tagged-list? exp 'const))
|
||||
|
||||
(define (constant-exp-value exp) (cadr exp))
|
||||
|
||||
(define (label-exp? exp) (tagged-list? exp 'label))
|
||||
|
||||
(define (label-exp-label exp) (cadr exp))
|
||||
|
||||
|
||||
(define (make-operation-exp exp machine labels operations)
|
||||
(let ((op (lookup-prim (operation-exp-op exp) operations))
|
||||
(aprocs
|
||||
(map (lambda (e)
|
||||
(make-primitive-exp e machine labels))
|
||||
(operation-exp-operands exp))))
|
||||
(lambda ()
|
||||
(apply op (map (lambda (p) (p)) aprocs)))))
|
||||
|
||||
(define (operation-exp? exp)
|
||||
(and (pair? exp) (tagged-list? (car exp) 'op)))
|
||||
(define (operation-exp-op operation-exp)
|
||||
(cadr (car operation-exp)))
|
||||
(define (operation-exp-operands operation-exp)
|
||||
(cdr operation-exp))
|
||||
|
||||
|
||||
(define (lookup-prim symbol operations)
|
||||
(let ((val (assoc symbol operations)))
|
||||
(if val
|
||||
(cadr val)
|
||||
(error "Unknown operation -- ASSEMBLE" symbol))))
|
||||
|
||||
;; from 4.1
|
||||
(define (tagged-list? exp tag)
|
||||
(if (pair? exp)
|
||||
(eq? (car exp) tag)
|
||||
false))
|
||||
|
||||
'(REGISTER SIMULATOR LOADED)
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
;;;; LOADS THE EXPLICIT-CONTROL EVALUATOR FROM SECTION 5.4 OF
|
||||
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS, WITH
|
||||
;;;; ALL THE SUPPORTING CODE IT NEEDS IN ORDER TO RUN.
|
||||
|
||||
;;;;This is like load-eceval.scm except that it loads the version
|
||||
;;;; of eceval that interfaces with compiled code
|
||||
;;;;It doesn't load the compiler itself -- loading the compiler is up to you.
|
||||
|
||||
;;;; **NB** The actual "load" calls are implementation dependent.
|
||||
|
||||
(load "ch5-regsim") ;reg machine simulator
|
||||
|
||||
;; **NB** next file contains another "load"
|
||||
(load "ch5-eceval-support") ;simulation of machine operations
|
||||
|
||||
;;**NB** eceval-compiler *must* be loaded after eceval-support,
|
||||
;; so that the version of user-print in eceval-compiler will override
|
||||
;; the version in eceval-support
|
||||
(load "ch5-eceval-compiler") ;eceval itself
|
||||
;and interface to compiled code
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
;;;; LOADS THE EXPLICIT-CONTROL EVALUATOR FROM SECTION 5.4 OF
|
||||
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS, WITH
|
||||
;;;; ALL THE SUPPORTING CODE IT NEEDS IN ORDER TO RUN.
|
||||
|
||||
;;;; **NB** The actual "load" calls are implementation dependent.
|
||||
|
||||
(load "ch5-regsim") ;reg machine simulator
|
||||
|
||||
;; **NB** next file contains another "load"
|
||||
(load "ch5-eceval-support") ;simulation of machine operations
|
||||
|
||||
(load "ch5-eceval") ;eceval itself
|
||||
Loading…
Reference in New Issue