commit 6e824bcec28a8f7297d540bc37626b2d3393610a
parent 3d7213bccab0e1b78d0826030faf1b495f5da6ca
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Sat, 20 Jul 2024 19:31:58 +0300
Fixing badly copied eval-sequence. Also:
- Better debug print procedures.
- More tests.
Diffstat:
3 files changed, 128 insertions(+), 76 deletions(-)
diff --git a/sicp/solutions/chapter-4/original-repl.scm b/sicp/solutions/chapter-4/original-repl.scm
@@ -24,8 +24,6 @@
)
(begin
- (define *debug* #f)
-
(define (make-environment vars vals)
(extend-environment vars
vals
@@ -36,61 +34,60 @@
;;; 4.1.1
(define (eval exp env)
- (when *debug* (pp (list 'eval exp)))
- (cond
- ((self-evaluating? exp)
- (when *debug* (pp (list 'self-evaluating exp)))
- exp)
- ((variable? exp)
- (when *debug* (pp (list 'variable exp
- 'env env)))
- (let ((value (lookup-variable-value exp env)))
- (when *debug* (pp (list 'value value)))
- value))
- ((quoted? exp)
- (when *debug* (pp (list 'quoted exp)))
- (text-of-quotation exp))
- ((definition? exp)
- (when *debug* (pp (list 'definition exp)))
- (eval-definition exp env))
- ((if? exp)
- (when *debug* (pp (list 'if exp)))
- (eval-if exp env))
- ((lambda? exp)
- (when *debug* (pp (list 'lambda exp)))
- (make-procedure
- (lambda-parameters exp)
- (lambda-body exp)
- env))
- ((begin? exp)
- (when *debug* (pp (list 'begin exp)))
- (eval-sequence
- (begin-actions exp)
- env))
- ((cond? exp)
- (when *debug* (pp (list 'cond exp)))
- (eval (cond->if exp) env))
- ((application? exp)
- (when *debug* (pp (list 'application exp)))
- (apply (eval (operator exp)
- env)
- (list-of-values (operands exp)
- env)))
- (else
- (error "Unknown expression type -- EVAL" exp))))
+ (pp (list 'eval exp))
+ (dp)
+ (define eval-result
+ (cond ((self-evaluating? exp)
+ exp)
+ ((variable? exp)
+ (lookup-variable-value exp env))
+ ((quoted? exp)
+ (text-of-quotation exp))
+ ((assignment? exp)
+ (eval-assignment exp env))
+ ((definition? exp)
+ (eval-definition exp env))
+ ((if? exp)
+ (eval-if exp env))
+ ((lambda? exp)
+ (make-procedure
+ (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence
+ (begin-actions exp)
+ env))
+ ((cond? exp)
+ (eval (cond->if exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values
+ (operands exp)
+ env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+ (dpp `(eval-result ,eval-result))
+ (dp)
+ eval-result)
(define (apply procedure arguments)
- (cond
- ((primitive-procedure? procedure)
- (apply-primitive-procedure procedure arguments))
- ((compound-procedure? procedure)
- (eval-sequence
- (procedure-body procedure)
- (extend-environment
- (procedure-parameters procedure)
- arguments
- (procedure-environment procedure))))
- (else (error "Unknown procedure type -- APPLY" procedure))))
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters
+ procedure)
+ arguments
+ (procedure-environment
+ procedure))))
+ (else
+ (error "Unknown procedure type -- APPLY"
+ procedure))))
;;; Conditionals:
@@ -103,9 +100,12 @@
(define (eval-sequence exps env)
- (cond
- ((last-exp? exps)
- (eval (first-exp exps) env))))
+ (cond ((last-exp? exps)
+ (eval (first-exp exps) env))
+ (else
+ (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps)
+ env))))
;;; Assignments and definitions
@@ -119,12 +119,13 @@
'ok)
(define (eval-definition exp env)
- (when *debug* (dp (list 'eval-definition exp)))
+ (dp `(eval-definition ,exp))
+ (dp)
(let ((def-var (definition-variable exp))
(def-val (definition-value exp)))
- (when *debug*
- (dp (list 'definition-variable def-var))
- (dp (list 'definition-value def-val)))
+ (dp `(definition-variable ,def-var))
+ (dp `(definition-value ,def-val))
+ (dp)
(define-variable!
(definition-variable exp)
(eval (definition-value exp) env)
@@ -167,9 +168,9 @@
(else
(let ((formal-parameters (scheme:cxr:cdadr exp))
(body (cddr exp)))
- (when *debug*
- (dp (list 'formal-parameters formal-parameters))
- (dp (list 'body body)))
+ (dp `(formal-parameters ,formal-parameters))
+ (dp `(body ,body))
+ (dp)
(make-lambda formal-parameters
body)))))
@@ -178,7 +179,7 @@
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body)
(let ((our-lambda `(lambda ,parameters ,@body)))
- (when *debug* (dp (list 'our-lambda our-lambda)))
+ (dp `(our-lambda ,our-lambda))
our-lambda))
(define (if? exp) (tagged-list? exp 'if))
@@ -274,7 +275,8 @@
(set-car! vals val))
(else (scan (cdr vars)
(cdr vals)))))
- (when *debug* (dp (frame-values frame)))
+ (dpp `(frame-values ,(frame-values frame)))
+ (dp)
(scan (frame-variables frame)
(frame-values frame))))
@@ -303,16 +305,18 @@
(define (lookup-variable-value var env)
(define (env-loop env)
- (dp `(env ,env))
+ (dpp `(env ,env))
(dp)
(define (scan vars vals)
- (pp `(vars ,vars vals ,vals))
+ (dpp `(vars ,vars vals ,vals))
(dp)
(cond ((null? vars)
(env-loop
(enclosing-environment env)))
((eq? var (car vars))
- (dp (car vals)))
+ (dpp `(car-of-vals ,(car vals)))
+ (dp)
+ (car vals))
(else (scan (cdr vars)
(cdr vals)))))
(cond
@@ -423,7 +427,7 @@
(when *debug* (pp proc))
proc))
(else
- (pp object))))
+ (pretty-print object))))
(define (main args)
(match args
@@ -447,7 +451,8 @@
y)))))
the-global-environment)
- (when *debug* (dp (list 'starting-with-the-global-environment: the-global-environment)))
+ (dp (list 'starting-with-the-global-environment: the-global-environment))
+ (dp)
(driver-loop))
(define (run-internal-tests)
diff --git a/sicp/tests/chapter-4/original-repl-tests.scm b/sicp/tests/chapter-4/original-repl-tests.scm
@@ -5,6 +5,8 @@
(sicp utils))
(begin
+ (set! *debug* #t)
+
(test-begin "original-repl-tests")
(test-group "internal-tests"
@@ -13,10 +15,39 @@
(test-equal 1
(repl:eval 1 '()))
+ (test-equal '()
+ (repl:eval '(quote ()) '()))
+
(test-equal 1
(repl:eval '(+ -1 2)
(repl:extend-environment
'(+)
`((primitive ,+))
(repl:setup-environment))))
+
+ (test-equal 1
+ (repl:eval '(begin
+ (+ -1 2))
+ (repl:extend-environment '(+)
+ `((primitive ,+))
+ (repl:setup-environment))))
+
+ ;; XXX: Not implemented yet!
+ (test-error 1
+ (repl:eval '(let ((a -1)
+ (b 2))
+ (+ a b))
+ (repl:extend-environment '(+)
+ `((primitive ,+))
+ (repl:setup-environment))))
+
+ (test-equal 1
+ (repl:eval '(begin
+ (define a -1)
+ (define b 2)
+ (+ a b))
+ (repl:extend-environment '(+)
+ `((primitive ,+))
+ (repl:setup-environment))))
+
(test-end "original-repl-tests")))
diff --git a/sicp/utils.scm b/sicp/utils.scm
@@ -6,8 +6,10 @@
(srfi srfi-19))
(export
+ *debug*
accumulate
dp
+ dpp
enumerate-interval
filter
flatmap
@@ -15,13 +17,27 @@
)
(begin
+ (define *debug* #f)
+
(define nil '())
(define (dp . x)
- (if (null? x)
- (newline)
- (begin (write (car x)) (newline) (car x))))
- (define (pp x) (pretty-print x) x)
+ "Debug Print."
+ (when *debug*
+ (if (null? x)
+ (newline)
+ (begin (write (car x))
+ (newline)
+ (car x)))))
+
+ (define (dpp x)
+ "Debug Pretty Print."
+ (when *debug*
+ (pretty-print x)
+ x))
+
+ (define (pp x)
+ (pretty-print x))
(define (filter predicate sequence)
;; From 2.2.3 Sequences as Conventional Interfaces
