Permalink
Browse files

ch4

  • Loading branch information...
1 parent 67a3934 commit 2275fc37a59a541fcef573ce6f12db64575ac435 @nslobodin committed Aug 30, 2012
Showing with 76 additions and 3 deletions.
  1. +63 −0 ch4/ex4-16.scm
  2. +1 −1 ch4/ex4-6.scm
  3. +9 −0 ch4/test-suite-4-16.scm
  4. +3 −2 ch4/test_interpreter.scm
View
@@ -0,0 +1,63 @@
+;; Example 4.16
+
+;; Merged to interpreter.
+
+;; Needed stuff from the interpreter
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ #f))
+
+(define (make-begin seq) (cons 'begin seq))
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp)
+ (cddr exp))))
+
+;; Desired function
+
+(define (scan-out-defines proc-body)
+ (define (iter body vars exps)
+ (if (or (null? body) (not (definition? (car body))))
+ (list vars exps body)
+ (iter (cdr body)
+ (cons (definition-variable (car body)) vars)
+ (cons (definition-value (car body)) exps))))
+ (let ((scan-res (iter proc-body '() '())))
+ (let ((vars (car scan-res))
+ (exps (cadr scan-res))
+ (rest-body (caddr scan-res)))
+ (list (list 'let
+ (map (lambda (var) (list var ''*unassigned*)) vars)
+ (make-begin (append (map (lambda (var exp) (list 'set! var exp)) vars exps)
+ rest-body)))))))
+
+;; Test
+
+(define t '(lambda (x)
+ (define u (+ 2 2))
+ (define v (+ 3 3))
+ (define (square x)
+ (* x x))
+ (+ u v)
+ (+ u u u)))
+
+(scan-out-defines (lambda-body t))
+
+;; install into make-procedure
+;; installing into getter is bad idea
View
@@ -26,7 +26,7 @@
(define (let-exps exp)
(if (null? exp)
'()
- (cons (cadar exp) (let-vars (cdr exp)))))
+ (cons (cadar exp) (let-exps (cdr exp)))))
(define (let->combination exp)
(cons (make-lambda (let-vars (let-vars-and-exps exp)) (let-body exp))
View
@@ -0,0 +1,9 @@
+(define (test)
+ (define u (+ 2 2))
+ (define v (+ 3 3))
+ (define (square x)
+ (* x x))
+
+ (+ u u)
+ (+ v (square u) u))
+(test)
View
@@ -173,7 +173,7 @@
(define (let-exps exp)
(if (null? exp)
'()
- (cons (cadar exp) (let-vars (cdr exp)))))
+ (cons (cadar exp) (let-exps (cdr exp)))))
(define (let->combination exp)
(cons (make-lambda (let-vars (let-vars-and-exps exp)) (let-body exp))
(let-exps (let-vars-and-exps exp))))
@@ -281,6 +281,8 @@
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
+ ((eq? (car vars) '*unassigned)
+ (error "Unassigned variable -- LOOKUP" var))
((eq? var (car vars))
(car vals))
(else (scan (cdr vars) (cdr vals)))))
@@ -373,7 +375,6 @@
(newline) (display string) (newline))
(define (user-print object)
- ;(display the-global-environment))
(if (compound-procedure? object)
(display (list 'compound-procedure
(procedure-parameters object)

0 comments on commit 2275fc3

Please sign in to comment.