Implement 5.30; on to last section; let's go!

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?)
 
    ))

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))