simplify translation of quote

3 files changed, 28 insertions, 36 deletions

diff --git a/cps.scm b/cps.scm
index d89e1a6..e717d7f 100644
--- a/cps.scm
+++ b/cps.scm
@@ -21,9 +21,32 @@
  | All continuations can take multiple values.
  |#
 
+;;; Handling objects that can be evaluated in one step. These are
+;;; 1) quotes
+;;; 2) symbols (look up in environment)
+;;; 3) self evaluating objects (booleans, numbers, etc.)
+
+(define (quote=> x)
+  (cond-values
+    (after ((let (pair=> x) => (head tail))
+           (when (eq? head 'quote))
+           (on-fail! (error "invalid quote" x))
+           (let (length=> tail 1) => (form)))
+      form)))
+
 (define (self-evaluating? form)
-  (or (number? form) (string? form) (null? form) (vector? form)
-      (boolean? form) (bytevector? form) (symbol? 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)))
+
+(define (atomic-evaluating? form)
+  (or (self-evaluating? form) (symbol? form)))
+
+;;; Compound CPS objects
 
 (define-record-type/destructor <cps-kappa>
   (cps-kappa metakont formal cps-cmd)
@@ -63,14 +86,6 @@
   (metakont %apply:metakont)
   (kont %apply:kont))
 
-(define-record-type/destructor <cps-quote>
-  (cps-quote form metakont kont)
-  cps-quote?
-  cps-quote=>
-  (form %quote:form)
-  (metakont %quote:metakont)
-  (kont %quote:kont))
-
 (define-record-type/destructor <cps-if>
   (cps-if conditional on-true on-false metakont kont)
   cps-if?
@@ -94,8 +109,6 @@
                          (cps->sexpr to-pass)
                          to-pass)))
         `(pass ,to-pass ,metakont ,(cps->sexpr kont))))
-    (after ((let (cps-quote=> form) => (form metakont kont)))
-      `(pass (quote ,form) ,metakont ,(cps->sexpr kont)))
     (after ((let (cps-apply=> form) => (proc formal metakont kont)))
       `(apply ,proc ,formal ,metakont ,(cps->sexpr kont)))
     (after ((let (cps-if=> form)
@@ -121,22 +134,6 @@
                                                 '__κ0
                                                 'γ↓)))))
 
-(define (quote=> x)
-  (cond-values
-    (after ((let (pair=> x) => (head tail))
-           (when (eq? head 'quote))
-           (on-fail! (error "invalid quote" x))
-           (let (length=> tail 1) => (form)))
-      form)))
-
-(define (constant-convertible-to-boolean? x)
-  (cond-thunk
-    (when-ct (self-evaluating? x)
-      x)
-    (after ((let (quote=> x) => (form)))
-      #t)
-    (else #f)))
-
 (define (core->cps form)
   (define gensym
     (let ((x 0))
@@ -147,7 +144,7 @@
                                        (number->string x))))))
   (define (core->cps form metakont kont)
     (cond-thunk
-      (when-ct (self-evaluating? form)
+      (when-ct (atomic-evaluating? form)
         (cps-apply-kont (list form) metakont kont))
       ;; (push-prompt e e)
       (after ((let (pair=> form) => (head tail))
@@ -182,9 +179,6 @@
                      (cps-kappa sub-cont-from-eval
                                 sub-cont-reified
                                 cps-expr))))
-      ;; (quote data)
-      (after ((let (quote=> form) => (form)))
-        (cps-quote form metakont kont))
       ;; (lambda formal expr)
       (after ((let (pair=> form) => (head tail))
               (when (eq? head 'lambda))
@@ -202,7 +196,7 @@
               (when (eq? head 'if))
               (on-fail! (error "invalid if" form))
               (let (length=> tail 3) => (the-cond on-true on-false)))
-        (if (constant-convertible-to-boolean? the-cond)
+        (if (self-evaluating? the-cond)
             (if the-cond
                 (core->cps on-true metakont kont)
                 (core->cps on-false metakont kont))
@@ -232,7 +226,7 @@
           (cond-thunk
             (after ((let (pair=> to-do) => (expr to-do)))
               (cond
-                ((self-evaluating? expr)
+                ((atomic-evaluating? expr)
                  (compile (cons expr build-call) to-do metakont))
                 (else
                  (let ((new-metakont (gensym "γ"))
diff --git a/gamma-scheme.cps.sld b/gamma-scheme.cps.sld
index 4d46f23..eee119d 100644
--- a/gamma-scheme.cps.sld
+++ b/gamma-scheme.cps.sld
@@ -14,7 +14,6 @@
           cps-closure cps-closure=>
           cps-apply-kont cps-apply-kont=>
           cps-apply cps-apply=>
-          cps-quote cps-quote=>
           cps-if cps-if=>
           core->cps
           cps->sexpr
diff --git a/test.scm b/test.scm
index 4595f2b..3db9478 100644
--- a/test.scm
+++ b/test.scm
@@ -41,4 +41,3 @@
              (kappa (__v2) __γ1
                     (apply __v2 (y) __γ1 __toplevel)))
       (cps->sexpr (core->cps '((lambda (x) x) y))))
-