learning-sicp

commit 3d7213bccab0e1b78d0826030faf1b495f5da6ca
parent 8978894f0dbf87ac414fd70911405156379eacc0
Author: Yuval Langer <yuval.langer@gmail.com>
Date:   Sat, 20 Jul 2024 13:22:03 +0300

Original repl now runs primitive functions.  Also add tests and update debug print (dp).

Diffstat:
M
sicp/solutions/chapter-4/original-repl.scm
 | 
58
++++++++++++++++++++++++++++++++++++++++++++++++----------
A
sicp/tests/chapter-4/original-repl-tests.scm
 | 
22
++++++++++++++++++++++
M
sicp/utils.scm
 | 
5
++++-

3 files changed, 74 insertions(+), 11 deletions(-)
diff --git a/sicp/solutions/chapter-4/original-repl.scm b/sicp/solutions/chapter-4/original-repl.scm
@@ -1,19 +1,36 @@
 (define-library (sicp solutions chapter-4 original-repl)
-  (export main eval)
-  (import (rename (scheme base) (apply scheme:base:apply))
-          (prefix (scheme cxr) scheme:cxr:)
-          (prefix (scheme read) scheme:read:)
-          (prefix (scheme write) scheme:write:)
+  (export
+   eval
+   main
 
-          (srfi srfi-9)
+   run-internal-tests
 
-          (ice-9 match)
+   make-environment
+   setup-environment
+   extend-environment
+   )
+  (import
+   (rename (scheme base) (apply scheme:base:apply))
+   (prefix (scheme cxr) scheme:cxr:)
+   (prefix (scheme read) scheme:read:)
+   (prefix (scheme write) scheme:write:)
 
-          (sicp utils))
+   (srfi srfi-9)
+   (srfi srfi-64)
+
+   (ice-9 match)
+
+   (sicp utils)
+   )
 
   (begin
     (define *debug* #f)
 
+    (define (make-environment vars vals)
+      (extend-environment vars
+                          vals
+                          the-empty-environment))
+
 ;;; Start:
 
 ;;; 4.1.1
@@ -286,12 +303,16 @@
 
     (define (lookup-variable-value var env)
       (define (env-loop env)
+        (dp `(env ,env))
+        (dp)
         (define (scan vars vals)
+          (pp `(vars ,vars vals ,vals))
+          (dp)
           (cond ((null? vars)
                  (env-loop
                   (enclosing-environment env)))
                 ((eq? var (car vars))
-                 (car vals))
+                 (dp (car vals)))
                 (else (scan (cdr vars)
                             (cdr vals)))))
         (cond
@@ -331,7 +352,6 @@
 
 ;;; 4.1.4
 
-
     (define (setup-environment)
       (let* ((primitive-procedures
               `((car ,car)
@@ -429,4 +449,22 @@
 
       (when *debug* (dp (list 'starting-with-the-global-environment: the-global-environment)))
       (driver-loop))
+
+    (define (run-internal-tests)
+      (test-eq 1
+        (lookup-variable-value 'a
+                               (extend-environment '(a +)
+                                                   `(1 ,+)
+                                                   the-empty-environment)))
+      (test-eq 1
+        (lookup-variable-value 'a
+                               (extend-environment '(+ a)
+                                                   `(,+ 1)
+                                                   the-empty-environment)))
+      (test-eq +
+        (lookup-variable-value '+
+                               (extend-environment '(a +)
+                                                   `(1 ,+)
+                                                   the-empty-environment))))
+
     ))
diff --git a/sicp/tests/chapter-4/original-repl-tests.scm b/sicp/tests/chapter-4/original-repl-tests.scm
@@ -0,0 +1,22 @@
+(define-library (sicp tests chapter-4 original-repl-tests)
+  (import (scheme base)
+          (srfi srfi-64)
+          (prefix (sicp solutions chapter-4 original-repl) repl:)
+          (sicp utils))
+
+  (begin
+    (test-begin "original-repl-tests")
+
+    (test-group "internal-tests"
+      (repl:run-internal-tests))
+
+    (test-equal 1
+      (repl:eval 1 '()))
+
+    (test-equal 1
+      (repl:eval '(+ -1 2)
+                 (repl:extend-environment
+                  '(+)
+                  `((primitive ,+))
+                  (repl:setup-environment))))
+    (test-end "original-repl-tests")))
diff --git a/sicp/utils.scm b/sicp/utils.scm
@@ -17,7 +17,10 @@
   (begin
     (define nil '())
 
-    (define (dp x) (write x) (newline) x)
+    (define (dp . x)
+      (if (null? x)
+          (newline)
+          (begin (write (car x)) (newline) (car x))))
     (define (pp x) (pretty-print x) x)
 
     (define (filter predicate sequence)