From f60931f80e2c027e3ae39c896641eacd26200728 Mon Sep 17 00:00:00 2001
From: Felix Martin <mail@felixm.de>
Date: Sun, 11 Apr 2021 13:50:56 -0400
Subject: [PATCH] Implement 5.30; on to last section; let's go!

---
 ex-5_23-30.scm               | 28 ++++++++++++++++++++++++++--
 misc/sicp-eceval-support.scm | 31 ++++++++++++++++++++++++++++---
 misc/sicp-eceval.scm         | 18 +++++++++++++-----
 3 files changed, 67 insertions(+), 10 deletions(-)

diff --git a/ex-5_23-30.scm b/ex-5_23-30.scm
index 492a19d..3cad023 100644
--- a/ex-5_23-30.scm
+++ b/ex-5_23-30.scm
@@ -158,14 +158,38 @@
 
 (display "\nex-5.30 - error-handling\n")
 
+; a
 (set-register-contents! eceval 'exp
   '(begin
      (define (foo x) x)
      (foo a)))
 (start eceval)
 (newline)
-(assert (get-register-contents eceval 'val) 'unbound-variable-error))
+(assert (get-register-contents eceval 'val) 'error-unbound-variable))
+
+; b
+(define (check-apply-division args)
+  (cond
+    ((not (= (length args) 2)) 'error-div-wrong-number-of-args)
+    ((= (cadr args) 0) 'error-div-by-zero)
+    (else 'ok)))
+
+(set-register-contents! eceval 'exp
+  '(begin
+     (/ 1 0)))
+(start eceval)
 (newline)
+(assert (get-register-contents eceval 'val) 'error-div-by-zero)
 
-;; CONTINUE HERE
+(define (check-apply-car args)
+  (cond
+    ((not (pair? (car args))) 'error-car-no-pair)
+    (else 'ok)))
+
+(set-register-contents! eceval 'exp
+  '(begin
+     (car 3)))
+(start eceval)
+(newline)
+(assert (get-register-contents eceval 'val) 'error-car-no-pair)
 
diff --git a/misc/sicp-eceval-support.scm b/misc/sicp-eceval-support.scm
index 4ef707b..c849050 100644
--- a/misc/sicp-eceval-support.scm
+++ b/misc/sicp-eceval-support.scm
@@ -185,10 +185,32 @@
 
 (define apply-in-underlying-scheme apply)
 
+(define (check-apply-primitive proc args)
+  (cond
+    ((eq? proc /) (check-apply-division args))
+    ((eq? proc car) (check-apply-car args))
+    (else 'ok)))
+
+(define (apply-primitive-error? val)
+  (eq? (car val) 'error))
+
+(define (apply-primitive-result val) (cadr val))
+
+(define (apply-primitive-procedure-safe proc args)
+  (let ((code (check-apply-primitive
+                (primitive-implementation proc)
+                args)))
+    (if (eq? code 'ok)
+      (list 'ok
+            (apply-in-underlying-scheme
+              (primitive-implementation proc)
+              args))
+      (list 'error code))))
+
 (define (apply-primitive-procedure proc args)
   (apply-in-underlying-scheme
-   (primitive-implementation proc) args))
-
+    (primitive-implementation proc)
+    args))
 
 (define (prompt-for-input string)
   (newline) (newline) (display string) (newline))
@@ -203,7 +225,7 @@
                      (procedure-body object)
                      '<procedure-env>))
       (display object)))
-
+
 ;;; Simulation of new machine operations needed by
 ;;;  eceval machine (not used by compiled code)
 
@@ -312,5 +334,8 @@
 
    ;;5.30
    (list 'unbound-variable? unbound-variable?)
+   (list 'apply-primitive-procedure-safe apply-primitive-procedure-safe)
+   (list 'apply-primitive-result apply-primitive-result)
+   (list 'apply-primitive-error? apply-primitive-error?)
 
    ))
diff --git a/misc/sicp-eceval.scm b/misc/sicp-eceval.scm
index bab0713..f291be8 100644
--- a/misc/sicp-eceval.scm
+++ b/misc/sicp-eceval.scm
@@ -36,8 +36,12 @@ unknown-procedure-type
   (assign val (const unknown-procedure-type-error))
   (goto (label signal-error))
 
-unbound-variable-error
-  (assign val (const unbound-variable-error))
+error-unbound-variable
+  (assign val (const error-unbound-variable))
+  (goto (label signal-error))
+
+apply-primitive-error
+  (assign val (op apply-primitive-result) (reg val))
   (goto (label signal-error))
 
 signal-error
@@ -74,10 +78,9 @@ ev-self-eval
   (assign val (reg exp))
   (goto (reg continue))
 ev-variable
-  ;(perform (op user-print) (reg exp))
   (assign val (op lookup-variable-value) (reg exp) (reg env))
   (test (op unbound-variable?) (reg val))
-  (branch (label unbound-variable-error))
+  (branch (label error-unbound-variable))
   (goto (reg continue))
 ev-quoted
   (assign val (op text-of-quotation) (reg exp))
@@ -137,9 +140,14 @@ apply-dispatch
   (goto (label unknown-procedure-type))
 
 primitive-apply
-  (assign val (op apply-primitive-procedure)
+  (assign val (op apply-primitive-procedure-safe)
               (reg proc)
               (reg argl))
+  ;(perform (op user-print) (reg val))
+  ;(perform (op newline))
+  (test (op apply-primitive-error?) (reg val))
+  (branch (label apply-primitive-error))
+  (assign val (op apply-primitive-result) (reg val))
   (restore continue)
   (goto (reg continue))