felixm
/
SICP
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Implement 4.12 and fix some prior issues

main
Felix Martin 2021-01-21 15:21:14 -05:00
parent 4e1a51f5a0
commit ce4bf6c579
1 changed files with 68 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
ex-4_01-xx.scm
View File

@ -273,13 +273,17 @@
(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)
(set-car! frame (cons (cons 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)
@ -315,14 +319,13 @@
(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))))
(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))
@ -331,32 +334,70 @@
(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 frame var)
; (display "FIND-PAIR-FRAME ") (display frame) (newline)
(define (frame-loop frame)
(cond
((null? frame) 'pair-not-found)
((eq? var (frame-var (car frame))) (car frame))
(else (frame-loop (cdr frame)))))
(frame-loop frame))
(define (find-pair-frame var frame)
(assoc var frame))
(define (find-pair-env env var)
(define (find-pair-env var env)
(define (env-loop env)
(if (eq? env the-empty-environment)
'pair-not-found
(let ((pair (find-pair-frame (first-frame env) var)))
(if (eq? pair 'pair-not-found)
(env-loop (enclosing-environment env))
pair))))
#f
(let ((pair (assoc var (first-frame env))))
(if (pair? pair)
pair
(env-loop (enclosing-environment env))))))
(env-loop env))
(display (find-pair-env env-2 'd))
(newline)
(define (lookup-variable-value var env)
(let ((pair (find-pair-env var env)))
(if (eq? pair #f)
(error "Unbound variable" var)
(frame-val pair))))
(display "\nex-4.13\n")
(define (set-variable-value! var val env)
(let ((pair (find-pair-env var env)))
(if (pair? pair)
(set-cdr! pair val)
'())))
; (display "\nex-4.14\n")
(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")