sicp/mceval/environment.rkt

#lang sicp

(#%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 'cons cons)
        (list 'null? null?)
        (list '= =)
        (list '+ +)
        (list '* *)
        (list '- -)
        (list '/ /)
        (list '< <)
        (list '> >)
;;      more primitives
        ))

(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))