Implement till 4.13
parent
ce4bf6c579
commit
0042f1773f
|
|
@ -263,141 +263,3 @@
|
|||
|
||||
(display "[done]\n")
|
||||
|
||||
(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")
|
||||
|
||||
; XXX: work in progress
|
||||
|
||||
(define (make-unbound-frame! var frame)
|
||||
(if (null? frame)
|
||||
#f
|
||||
(if (eq? var (frame-var (car frame)))
|
||||
(begin
|
||||
(set-car! frame (cadr frame))
|
||||
(set-cdr! frame (cddr frame)))
|
||||
(make-unbound-frame! var (cdr frame)))))
|
||||
|
||||
(display (first-frame env-2)) (newline)
|
||||
(make-unbound-frame! 'e (first-frame env-2))
|
||||
(display (first-frame env-2)) (newline)
|
||||
|
||||
(display "\nex-4.14\n")
|
||||
|
||||
|
|
@ -0,0 +1,171 @@
|
|||
(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")
|
||||
|
||||
|
||||
Loading…
Reference in New Issue