SICP/ex-4_11-xx.scm

(load "util.scm")
(load "misc/evaluator.scm")

(display "\nex-4.11 - alternative-frame-implementation\n")

; Test implementation from book.
(define env-0 the-empty-environment)
(define env-1 (extend-environment '(a b) '(1 2) env-0))
(define env-2 (extend-environment '(c d) '(3 4) env-1))

(assert (lookup-variable-value 'b env-2) 2)
(set-variable-value! 'b 42 env-2)
(assert (lookup-variable-value 'b env-2) 42)
(define-variable! 'e 5 env-2)
(assert (lookup-variable-value 'e env-2) 5)

(define (make-frame variables values)
  (map cons variables values))
(define (frame-variables frame) (map car frame))
(define (frame-values frame) (map cdr frame))
(define (add-binding-to-frame! var val frame)
  (if (null? (cdr frame))
    (set-cdr! frame (cons (cons var val) '()))
    (add-binding-to-frame! var val (cdr frame))))

(define frame-var car)
(define frame-val cdr)

(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 frame)
      (cond ((null? frame)
             (env-loop (enclosing-environment env)))
            ((eq? var (frame-var (car frame)))
             (set-cdr! (car frame) val))
            (else (scan (cdr frame)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable -- SET!" var)
        (let ((frame (first-frame env)))
          (scan frame))))
  (env-loop env))

(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (define (scan frame)
      (cond ((null? frame)
             (add-binding-to-frame! var val (first-frame env)))
            ((eq? var (frame-var (car frame)))
             (set-cdr! (car frame) val))
            (else (scan (cdr frame)))))
    (scan frame)))

(define env-0 the-empty-environment)
(define env-1 (extend-environment '(a b) '(1 2) env-0))
(define env-2 (extend-environment '(c d) '(3 4) env-1))

(assert (lookup-variable-value 'b env-2) 2)
(set-variable-value! 'b 42 env-2)
(assert (lookup-variable-value 'b env-2) 42)
(define-variable! 'e 5 env-2)
(assert (lookup-variable-value 'e env-2) 5)

(display "\nex-4.12 - abstract-traversal\n")

(define (find-pair-frame var frame)
  (assoc var frame))

(define (find-pair-env var env)
  (define (env-loop env)
    (if (eq? env the-empty-environment)
      #f
      (let ((pair (assoc var (first-frame env))))
        (if (pair? pair)
          pair
          (env-loop (enclosing-environment env))))))
  (env-loop env))

(define (lookup-variable-value var env)
  (let ((pair (find-pair-env var env)))
    (if (eq? pair #f)
      (error "Unbound variable" var)
      (frame-val pair))))

(define (set-variable-value! var val env)
  (let ((pair (find-pair-env var env)))
    (if (pair? pair)
      (set-cdr! pair val)
      '())))

(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (let ((pair (assoc var frame)))
      (if (pair? pair)
        (set-cdr! pair val)
        (add-binding-to-frame! var val frame)))))

(define env-0 the-empty-environment)
(define env-1 (extend-environment '(a b) '(1 2) env-0))
(define env-2 (extend-environment '(c d) '(3 4) env-1))

(assert (find-pair-env 'd env-2) (cons 'd 4))
(assert (lookup-variable-value 'b env-2) 2)
(set-variable-value! 'b 42 env-2)
(assert (lookup-variable-value 'b env-2) 42)
(define-variable! 'e 5 env-2)
(assert (lookup-variable-value 'e env-2) 5)

(display "\nex-4.13 - make-unbound!\n")

; It seems like the reason for removing a binding is when one wants get access
; to the same symbol in an outer environment. Therefore, we implement
; make-unbound! so that it only deletes the symbol from the first frame in
; which it is defined.

(define (frame-without-var var frame)
  (cond
    ((null? frame) '())
    ((eq? var (frame-var (car frame))) (cdr frame))
    (else (cons (car frame) (frame-without-var var (cdr frame))))))

(define (make-unbound-first! var env)
  (let ((len (length (first-frame env))))
    (set-car! env (frame-without-var var (first-frame env)))
    (if (= len (length (first-frame env)))
      #f
      #t)))

(assert (make-unbound-first! 'd env-2) #t)
(assert (make-unbound-first! 'e env-2) #t)
(assert (make-unbound-first! 'b env-2) #f)
(assert (make-unbound-first! 'c env-2) #t)
(assert (first-frame env-2) '())

(define (make-unbound! var env)
  (define (loop env)
    (if (eq? env the-empty-environment)
      #f
      (if (make-unbound-first! var env)
        #t
        (loop (enclosing-environment env)))))
  (loop env))

(define env-0 the-empty-environment)
(define env-1 (extend-environment '(a b) '(1 2) env-0))
(define env-2 (extend-environment '(c d) '(3 4) env-1))
(define env-3 (extend-environment '(a b) '(3 6) env-2))

(assert (lookup-variable-value 'b env-3) 6)
(assert (make-unbound! 'b env-3) #t)
(assert (lookup-variable-value 'b env-3) 2)
(assert (make-unbound! 'b env-3) #t)
(assert (make-unbound! 'b env-3) #f)

(display "\nex-4.14\n")