219 lines
7.6 KiB
Racket
219 lines
7.6 KiB
Racket
#lang sicp
|
|
|
|
(#%require racket/trace)
|
|
|
|
(#%provide lookup-variable-value
|
|
set-variable-value!
|
|
define-variable!
|
|
make-unbound-variable!
|
|
extend-environment
|
|
setup-environment)
|
|
|
|
(define (enclosing-environment env) (cdr env))
|
|
|
|
(define (first-frame env) (car env))
|
|
|
|
(define the-empty-environment '())
|
|
|
|
;; Exercise 4.11: change the frame representation to be a list of
|
|
;; pairs rather than a pair of lists.
|
|
;; Frame is a headed list whose car is *frame*. Its cdr is the first
|
|
;; backbone pair. Each of these pairs has car of the pair (var val)
|
|
;; and cdr of the next backbone pair. A headed list is used so that
|
|
;; new elements can be inserted while keeping the frame (i.e. the
|
|
;; first pair).
|
|
(define (make-frame variables values)
|
|
(cons '*frame*
|
|
(map cons variables values)))
|
|
|
|
(define (frame-bindings frame) (cdr frame))
|
|
(define (first-frame-binding frame) (cadr frame))
|
|
(define (rest-frame-bindings frame) (cddr frame))
|
|
(define (frame-variable frame-binding) (car frame-binding))
|
|
(define (frame-value frame-binding) (cdr frame-binding))
|
|
(define (frame-variables frame)
|
|
(map frame-variable (frame-bindings frame)))
|
|
(define (frame-values frame)
|
|
(map frame-value (frame-bindings frame)))
|
|
(define (set-frame-value! frame-binding val)
|
|
(set-cdr! frame-binding val))
|
|
|
|
;; Assume frame is a headed list (i.e. the actual list of backbone
|
|
;; pairs is (cdr frame)). To add a binding, create a backbone pair
|
|
;; whose car is the new binding pair and whose cdr is the first
|
|
;; existing backbone pair.
|
|
(define (add-binding-to-frame! var val frame)
|
|
(let ((binding-pair (cons var val))
|
|
(backbone-pairs (cdr frame)))
|
|
(set-cdr! frame
|
|
(cons binding-pair
|
|
backbone-pairs))))
|
|
|
|
;; Unbind the frame binding immediately following the first one
|
|
(define (remove-next-frame-binding! frame-bindings)
|
|
(set-cdr! frame-bindings
|
|
(cddr frame-bindings)))
|
|
|
|
(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))))
|
|
|
|
;; Apply a procedure to a matching variable binding. Applies
|
|
;; var-match-proc when the current binding matches the variable.
|
|
;; Applies frame-end-proc if we get to the end of the first frame
|
|
;; without a match. If this is #f, then the search is continued in
|
|
;; subsequent frames. Applies empty-env-proc to var if we get to the
|
|
;; end of the environment.
|
|
(define (apply-to-var var
|
|
var-pred
|
|
var-match-proc
|
|
frame-end-proc
|
|
empty-env-proc
|
|
env)
|
|
(define (env-loop env)
|
|
(define (scan frame-bindings)
|
|
(cond ((null? frame-bindings)
|
|
;; If we have run out of frame bindings in this frame, we
|
|
;; can either go to then next frame in the environment or
|
|
;; run a procedure on the frame
|
|
(if frame-end-proc
|
|
(frame-end-proc (first-frame env))
|
|
(env-loop (enclosing-environment env))))
|
|
((var-pred var frame-bindings)
|
|
(var-match-proc
|
|
frame-bindings))
|
|
(else (scan (cdr frame-bindings)))))
|
|
(if (eq? env the-empty-environment)
|
|
(if empty-env-proc
|
|
(empty-env-proc var)
|
|
(error "Empty env -- APPLY-TO-VAR" var))
|
|
(let ((frame (first-frame env)))
|
|
(scan frame))))
|
|
(env-loop env))
|
|
|
|
;; This is a bit messy: the predicate needs to check that the binding
|
|
;; is actually a pair or is the head of the list (ie just a symbol *frame*).
|
|
(define (this-frame-binding-eq? var frame-bindings)
|
|
(and (pair? (car frame-bindings))
|
|
(eq? var (frame-variable (car frame-bindings)))))
|
|
(define (next-frame-binding-eq? var frame-bindings)
|
|
(and (pair? (cdr frame-bindings))
|
|
(eq? var (frame-variable (cadr frame-bindings)))))
|
|
|
|
(define (lookup-variable-value var env)
|
|
(let ((val (apply-to-var var
|
|
this-frame-binding-eq?
|
|
(lambda (frame-bindings)
|
|
(frame-value (car frame-bindings)))
|
|
#f
|
|
(lambda (var)
|
|
(error "Variable not in environment: LOOKUP-VARIABLE-VALUE" var))
|
|
env)))
|
|
(if (eq? val '*unassigned*)
|
|
(error "Variable unassigned: LOOKUP-VARIABLE-VALUE" var)
|
|
val)))
|
|
|
|
(define (set-variable-value! var val env)
|
|
(apply-to-var var
|
|
this-frame-binding-eq?
|
|
(lambda (frame-bindings)
|
|
(set-frame-value! (car frame-bindings) val))
|
|
#f
|
|
(lambda (var)
|
|
(error "Variable not in environment: SET-VARIABLE-VALUE!" var))
|
|
env))
|
|
|
|
(define (define-variable! var val env)
|
|
(apply-to-var var
|
|
this-frame-binding-eq?
|
|
(lambda (frame-bindings)
|
|
(set-frame-value! (car frame-bindings) val))
|
|
(lambda (frame)
|
|
(add-binding-to-frame! var val frame))
|
|
#f
|
|
env))
|
|
|
|
;; Exercise 4.13
|
|
;; Unbinding a variable: make-unbound-variable! should just search in
|
|
;; the current frame of the environment, as the alternative is too
|
|
;; destructive: it would affect previously formed procedures that were
|
|
;; built when the variable was bound. This is going to need a new
|
|
;; variable match predicate, as removing an element from a linked list
|
|
;; must be done from the previous element. So, we'll need to check
|
|
;; the next element in the list, and if it matches, then unlink the
|
|
;; next element.
|
|
(define (make-unbound-variable! var env)
|
|
(apply-to-var var
|
|
next-frame-binding-eq?
|
|
(lambda (frame-bindings)
|
|
(remove-next-frame-binding! frame-bindings))
|
|
(lambda (frame)
|
|
(error "No binding of variable in current frame" var))
|
|
#f
|
|
env))
|
|
|
|
(define primitive-procedures
|
|
(list (list 'car car)
|
|
(list 'cdr cdr)
|
|
(list 'cadr cadr)
|
|
(list 'caddr caddr)
|
|
(list 'cons cons)
|
|
(list 'null? null?)
|
|
(list 'list list)
|
|
(list 'reverse reverse)
|
|
(list 'append append)
|
|
(list 'memq memq)
|
|
(list 'memv memv)
|
|
(list 'member member)
|
|
(list 'not not)
|
|
(list '= =)
|
|
(list '+ +)
|
|
(list '* *)
|
|
(list '- -)
|
|
(list '/ /)
|
|
(list '< <)
|
|
(list '> >)
|
|
(list '+ +)
|
|
(list '- -)
|
|
(list '* *)
|
|
(list '= =)
|
|
(list '> >)
|
|
(list '>= >=)
|
|
(list '<= <=)
|
|
(list 'abs abs)
|
|
(list 'max max)
|
|
(list 'remainder remainder)
|
|
(list 'integer? integer?)
|
|
(list 'sqrt sqrt)
|
|
(list 'eq? eq?)
|
|
(list 'assq assq)
|
|
(list 'equal? equal?)
|
|
(list 'newline newline)
|
|
(list 'display display)
|
|
))
|
|
|
|
(define (primitive-procedure-names)
|
|
(map car
|
|
primitive-procedures))
|
|
|
|
(define (primitive-procedure-objects)
|
|
(map (lambda (proc) (list 'primitive (cadr proc)))
|
|
primitive-procedures))
|
|
|
|
(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 the-global-environment (setup-environment))
|
|
|