unquote self evaluating objects

1 files changed, 49 insertions, 33 deletions

diff --git a/cps.scm b/cps.scm
index e717d7f..7db7dc0 100644
--- a/cps.scm
+++ b/cps.scm
@@ -35,16 +35,30 @@
       form)))
 
 (define (self-evaluating? form)
-  (cond-thunk
-    (when-ct (or (number? form) (string? form) (null? form) (vector? form)
-                 (boolean? form) (bytevector? form))
-      #t)
-    (after ((let (quote=> form) => (form)))
-      #t)
-    (else #f)))
+  (or (number? form) (string? form) (null? form) (vector? form)
+      (boolean? form) (bytevector? form)))
 
-(define (atomic-evaluating? form)
-  (or (self-evaluating? form) (symbol? form)))
+(define (constant=> form)
+  ;; If `form` is either self evaluating, or is a quote of something
+  ;; that is constantly evaluating, return the self evaluated object.
+  (cond-values
+    (when-ct (self-evaluating? form)
+      form)
+    (after ((let (quote=> form) => (form))
+            (when (self-evaluating? form)))
+      form)
+    (after ((let (quote=> form) => _))
+      form)))
+
+(define (simple-evaluate=> form)
+  ;; If `form` can be evaluated at this time, return `form` evaluated.
+  ;; If `form` can be evaluated in one step (lookup the value in the
+  ;; scope), then return the symbol.
+  (cond-values
+    (after ((let (constant=> form) => (form)))
+      form)
+    (when-ct (symbol? form)
+      form)))
 
 ;;; Compound CPS objects
 
@@ -144,7 +158,7 @@
                                        (number->string x))))))
   (define (core->cps form metakont kont)
     (cond-thunk
-      (when-ct (atomic-evaluating? form)
+      (after ((let (simple-evaluate=> form) => (form)))
         (cps-apply-kont (list form) metakont kont))
       ;; (push-prompt e e)
       (after ((let (pair=> form) => (head tail))
@@ -196,28 +210,30 @@
               (when (eq? head 'if))
               (on-fail! (error "invalid if" form))
               (let (length=> tail 3) => (the-cond on-true on-false)))
-        (if (self-evaluating? the-cond)
+        (cond-thunk
+          (after ((let (constant=> the-cond) => (the-cond)))
             (if the-cond
                 (core->cps on-true metakont kont)
-                (core->cps on-false metakont kont))
-            (let* ((metakont-cond (gensym "γ"))
-                   (kont-each (gensym "κ"))
-                   (cond-evaled (gensym "v"))
-                   (branch (lambda (expr)
-                             (cps-kappa metakont-cond
-                                        kont-each
-                                        (core->cps expr
-                                                   metakont-cond
-                                                   kont-each)))))
-              (core->cps the-cond
-                         metakont
-                         (cps-kappa metakont-cond
-                                    cond-evaled
-                                    (cps-if cond-evaled
-                                            (branch on-true)
-                                            (branch on-false)
-                                            metakont-cond
-                                            kont-each))))))
+                (core->cps on-false metakont kont)))
+          (else
+           (let* ((metakont-cond (gensym "γ"))
+                  (kont-each (gensym "κ"))
+                  (cond-evaled (gensym "v"))
+                  (branch (lambda (expr)
+                            (cps-kappa metakont-cond
+                                       kont-each
+                                       (core->cps expr
+                                                  metakont-cond
+                                                  kont-each)))))
+             (core->cps the-cond
+                        metakont
+                        (cps-kappa metakont-cond
+                                   cond-evaled
+                                   (cps-if cond-evaled
+                                           (branch on-true)
+                                           (branch on-false)
+                                           metakont-cond
+                                           kont-each)))))))
       ;; (e e ...)
       (after ((when (pair? form)))
         (let compile ((build-call '())
@@ -225,9 +241,9 @@
                       (metakont metakont))
           (cond-thunk
             (after ((let (pair=> to-do) => (expr to-do)))
-              (cond
-                ((atomic-evaluating? expr)
-                 (compile (cons expr build-call) to-do metakont))
+              (cond-thunk
+                (after ((let (simple-evaluate=> expr) => (expr)))
+                  (compile (cons expr build-call) to-do metakont))
                 (else
                  (let ((new-metakont (gensym "γ"))
                        (new-formal (gensym "v")))