From 32b43220bf6916aa0c946a1ee0275ddcd5f95f57 Mon Sep 17 00:00:00 2001
From: Felix Martin <mail@felixm.de>
Date: Fri, 22 Jan 2021 11:05:51 -0500
Subject: [PATCH] Implement till 4.15

---
 ex-4_11-xx.scm     | 51 ++++++++++++++++++++++++++++++++++-
 misc/evaluator.scm | 67 +++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 116 insertions(+), 2 deletions(-)

diff --git a/ex-4_11-xx.scm b/ex-4_11-xx.scm
index 6fa6a55..591b7f6 100644
--- a/ex-4_11-xx.scm
+++ b/ex-4_11-xx.scm
@@ -166,6 +166,55 @@
 (assert (make-unbound! 'b env-3) #t)
 (assert (make-unbound! 'b env-3) #f)
 
-(display "\nex-4.14\n")
+(display "\nex-4.14 - map\n")
 
+; Louis's implementation of map will not work because the evaluator will
+; evaluate the lambda expression into a procedure list. The Scheme interpreter
+; does not know how to evaluate that list. Hence, the operation fails.
 
+(display "[answered]\n")
+
+(display "\nex-4.15 - halts?\n")
+
+(define (run-forever) (run-forever))
+
+(define (try p)
+  (if (halts? p p)
+      (run-forever)
+      'halted))
+
+; Suppose (try try) runs forever then halts? evaluates to wrong and try returns
+; halt. That is a contradiction. Suppose (try try) halts. Then halts? evaluates
+; to true and try runs forever; again a contradiction. Therefore, a general
+; procedure halts? cannot exist.
+
+(display "[answered]\n")
+
+(display "\nex-4.16\n")
+
+(define (lookup-variable-value var env)
+  (let ((pair (find-pair-env var env)))
+    (if (eq? pair #f)
+      (error "Unbound variable" var)
+      (let ((value (frame-val pair)))
+        (if (eq? value '*unassigned*)
+          (error "Unassigned variable" var)
+          value)))))
+
+(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 *unassigned*) env-1))
+
+(define (scan-out-defines body)
+  (cond
+    ((null? body) '())
+    ((definition? (car body)) (cons (car body) (scan-out-defines (cdr body))))
+    (else (scan-out-defines (cdr body)))))
+
+(define body '((define x 3)
+               (if #t 1 2)
+               (define b 2)))
+
+(display (scan-out-defines body)) (newline)
+
+(display "\nex-4.17\n")
diff --git a/misc/evaluator.scm b/misc/evaluator.scm
index 3ed177c..7a3f7ce 100644
--- a/misc/evaluator.scm
+++ b/misc/evaluator.scm
@@ -18,6 +18,8 @@
         (else
          (error "Unknown expression type -- EVAL" exp))))
 
+(define apply-in-underlying-scheme apply)
+
 (define (apply procedure arguments)
   (cond ((primitive-procedure? procedure)
          (apply-primitive-procedure procedure arguments))
@@ -232,4 +234,67 @@
     (scan (frame-variables frame)
           (frame-values frame))))
 
-'evaluator-loaded
+(define (primitive-procedure-objects)
+  (map (lambda (proc) (list 'primitive (cadr proc)))
+       primitive-procedures))
+
+(define primitive-procedures
+  (list (list 'car car)
+        (list 'cdr cdr)
+        (list 'cons cons)
+        (list 'null? null?)
+        (list 'display display)
+        ;;<more primitives>
+        ))
+
+(define (primitive-procedure-names)
+  (map car
+       primitive-procedures))
+
+(define (setup-environment)
+  (let ((initial-env
+         (extend-environment (primitive-procedure-names)
+                             (primitive-procedure-objects)
+                             the-empty-environment)))
+    (define-variable! 'true true initial-env)
+    (define-variable! 'false false initial-env)
+    initial-env))
+(define the-global-environment (setup-environment))
+
+(define (primitive-procedure? proc)
+  (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+
+(define (apply-primitive-procedure proc args)
+  (apply-in-underlying-scheme
+   (primitive-implementation proc) args))
+
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+
+(define (driver-loop)
+  (prompt-for-input input-prompt)
+  (let ((input (read)))
+    (let ((output (eval input the-global-environment)))
+      (announce-output output-prompt)
+      (user-print output)))
+  (driver-loop))
+
+(define (prompt-for-input string)
+  (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+  (newline) (display string) (newline))
+
+(define (user-print object)
+  (if (compound-procedure? object)
+      (display (list 'compound-procedure
+                     (procedure-parameters object)
+                     (procedure-body object)
+                     '<procedure-env>))
+      (display object)))
+
+(define the-global-environment (setup-environment))
+
+; (driver-loop)