Implement till 4.11

ex-4_01-xx.scm

@@ -235,19 +235,128 @@
 (define (while-predicate exp) (cadr exp))
 (define (while-body exp) (cddr exp))
 
-(define (while->combination exp)
+(define (eval-while exp env)
   (let ((body (while-body exp))
         (predicate (while-predicate exp)))
-  (if (not (true? predicate))
+  (if (true? (eval predicate env))
     '()
-    (list
+    (begin
       (sequence->exp body)
-      (cons 'while
-            (cons predicate
-                  body))))))
+      (eval-while exp env)))))
 
-(display "while: ")
-(display (while->combination '(while (lambda () #t) (display "one"))))
+(display "while: [done]\n")
 
-(display "\nex-4.10\n")
+(display "\nex-4.10 - alternative-syntax\n")
+
+; I am not going to reimplement everything, but we can easily see, that all we
+; need to change is the operator and operands procedures, and the selectors for
+; the specific procedure. I use an alternative if-syntax as an example.
+
+; new syntax : (<if-true> if <predicate> else <if-false>)
+
+; (define (operator exp) (cadr exp))
+; (define (operands exp) (cons (car exp) (cddddr exp)))
+; (define (if? exp) (eq (cadr exp) 'if))
+; (define (if-predicate exp) (caddr exp))
+; (define (if-consequent exp) (car exp))
+; (define (if-alternative exp) (caddddr exp))
+
+(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 (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)))
+
+(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 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 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)
+
+(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-env env var)
+  (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))))
+  (env-loop env))
+
+(display (find-pair-env env-2 'd))
+(newline)
+
+(display "\nex-4.13\n")
+
+; (display "\nex-4.14\n")
 

misc/evaluator.scm

@@ -159,4 +159,77 @@
                      (sequence->exp (cond-actions first))
                      (expand-clauses rest))))))
 
+(define (true? x)
+  (not (eq? x false)))
+(define (false? x)
+  (eq? x false))
+
+(define (make-procedure parameters body env)
+  (list 'procedure parameters body env))
+(define (compound-procedure? p)
+  (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+
+(define (make-frame variables values)
+  (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+  (set-car! frame (cons var (car frame)))
+  (set-cdr! frame (cons val (cdr frame))))
+
+(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))))
+
+(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 vars vals)
+      (cond ((null? vars)
+             (env-loop (enclosing-environment env)))
+            ((eq? var (car vars))
+             (set-car! vals val))
+            (else (scan (cdr vars) (cdr vals)))))
+    (if (eq? env the-empty-environment)
+        (error "Unbound variable -- SET!" var)
+        (let ((frame (first-frame env)))
+          (scan (frame-variables frame)
+                (frame-values frame)))))
+  (env-loop env))
+
+(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))))
+
 'evaluator-loaded