start eval

3 files changed, 142 insertions, 13 deletions

diff --git a/cps.scm b/cps.scm
index 59888b3..e0f5daf 100644
--- a/cps.scm
+++ b/cps.scm
@@ -145,7 +145,7 @@
                                      '(kont+γ↑ γ↓)
                                      (cps-apply 'proc
                                                 'kont+γ↑
-                                                '__κ0
+                                                '__unwind
                                                 'γ↓)))))
 
 (define (core->cps form)
@@ -171,7 +171,7 @@
                (cps-expr (core->cps
                           expr-part
                           cons*-metakont
-                          '__κ0))
+                          '__unwind))
                (cons*-expr (cps-apply
                             'cons*
                             (list new-prompt kont new-metakont)
@@ -194,7 +194,7 @@
                (cps-expr (core->cps
                           expr-part
                           in-middle-sub-cont
-                          '__κ0))
+                          '__unwind))
                (in-middle-expr (cps-apply
                                 'in-middle
                                 (list sub-cont-reified
@@ -280,3 +280,107 @@
       (else (error "invalid core form" form))))
   (core->cps form '() '__toplevel))
 
+(define (empty-map)
+  (mapping (make-default-comparator)))
+
+(define (formal-set-many mapping keys vals)
+  ;; KEYS is either an improper list or a proper list of symbols: it is
+  ;; the formals that are being bound.
+  ;; 
+  ;; If KEYS is a proper list, then it must have the same length as VALS.
+  ;; 
+  ;; If KEYS is an improper list, then the amount of elements in VALS must
+  ;; be greater than or equal to the amount of elements in the proper part
+  ;; of KEYS.
+  (cond
+    ((and (null? keys) (null? vals)) mapping)
+    ((symbol? keys)
+     (mapping-set mapping keys vals))
+    ((or (null? keys) (null? vals)) (error "unbalanced" mapping keys vals))
+    (else (formal-set-many (mapping-set mapping (car keys) (car vals))
+                           (cdr keys)
+                           (cdr vals)))))
+
+(define prompt? integer?)
+
+(define (eval-cps dynenv lexenv tmpenv expr)
+  (define envs
+    (mapping-union tmpenv lexenv dynenv))
+  (define (throw-error msg . others)
+    (apply error msg dynenv lexenv tmpenv expr others))
+  (define (lookup key)
+    (mapping-ref envs key
+                 (cut throw-error "invalid key")))
+  (define (eval-simple expr)
+    (cond
+      ((symbol? expr) (lookup expr))
+      (else expr)))
+  (define (eval-args expr)
+    (if (symbol? expr)
+        (lookup expr)
+        (map eval-simple expr)))
+  (define (return args)
+    (values args dynenv lexenv tmpenv))
+  (define (unwind-metacontinuation args metakont)
+    (cond-thunk
+      (receive-ct (head metakont) (pair=> metakont)
+        (cond
+          ((prompt? head)
+           (unwind-metacontinuation args metakont))
+          ((cps-kappa? head)
+           (eval-kont args metakont head))
+          (else (throw-error "invalid in metakont" metakont))))
+      (when-ct (null? metakont)
+        (return args))
+      (else (error "invalid metakont" metakont))))
+  (define (eval-kont kont args metakont)
+    (cond-thunk
+      (receive-ct (new-metakont formal cps-cmd) (cps-kappa=> kont)
+        (eval-cps dynenv lexenv
+                  (formal-set-many tmpenv
+                                   (cons new-metakont formal)
+                                   (cons metakont args))
+                  cps-cmd))
+      (when-ct (eq? kont '__toplevel)
+        (return args))
+      (when-ct (eq? kont '__unwind)
+        (unwind-metacontinuation metakont kont))
+      (else (throw-error "unknown continuation" kont))))
+  (define (eval-fun proc args metakont kont)
+    (cond-thunk
+      (receive-ct (formal metakont-formal kont-formal body)
+                  (cps-closure=> proc)
+        (eval-cps dynenv
+                  (formal-set-many (empty-map)
+                                   formal
+                                   args)
+                  (formal-set-many (empty-map)
+                                   (list metakont-formal kont-formal)
+                                   (list metakont kont))
+                  body))
+      (when-ct (procedure? proc)
+        (apply proc metakont kont args))
+      (else (throw-error "invalid procedure" proc))))
+  (cond-thunk
+    (receive-ct (args metakont kont) (cps-apply-kont=> expr)
+      (eval-kont kont
+                 (eval-args args)
+                 (eval-simple metakont)))
+    (receive-ct (proc args metakont kont) (cps-apply=> expr)
+      (eval-fun (eval-simple proc)
+                (eval-args args)
+                (eval-simple metakont)
+                (eval-simple kont)))
+    (receive-ct (conditional on-true on-false metakont kont)
+                (cps-if=> expr)
+      (let ((conditional (lookup conditional))
+            (metakont (eval-simple metakont))
+            (kont (eval-simple kont)))
+        (eval-kont (if conditional on-true on-false)
+                   metakont
+                   kont)))
+    (else (throw-error "unknown command" expr))))
+
+(define (eval-core expr)
+  (eval-cps (empty-map) (empty-map) (empty-map)
+            (core->cps expr)))
diff --git a/gamma-scheme.cps.sld b/gamma-scheme.cps.sld
index eee119d..48e5f77 100644
--- a/gamma-scheme.cps.sld
+++ b/gamma-scheme.cps.sld
@@ -9,13 +9,18 @@
   (import (scheme base)
           (scheme write)
           (mcgoron cond-thunk)
-          (mcgoron cond-thunk values))
-  (export cps-kappa cps-kappa=>
-          cps-closure cps-closure=>
+          (mcgoron cond-thunk values)
+          (srfi 26)
+          (srfi 146)
+          (srfi 128))
+  (export cps-kappa cps-kappa=> cps-kappa?
+          cps-closure cps-closure=> cps-closure?
           cps-apply-kont cps-apply-kont=>
           cps-apply cps-apply=>
           cps-if cps-if=>
           core->cps
           cps->sexpr
-          cps:with-sub-kont)
+          cps:with-sub-kont
+          eval-cps
+          eval-core)
   (include "cps.scm"))
diff --git a/test.scm b/test.scm
index 7f7547f..197b5d0 100644
--- a/test.scm
+++ b/test.scm
@@ -9,7 +9,7 @@
   (write (cps->sexpr (core->cps x)))
   (newline))
 
-(test-group "atomic objects"
+(test-group "atomic object syntax"
   (test "constant"
         '(pass (5) () __toplevel)
         (cps->sexpr (core->cps 5)))
@@ -29,7 +29,7 @@
         '(pass ((quote (quote #f))) () __toplevel)
         (cps->sexpr (core->cps '''#f))))
 
-(test-group "function application"
+(test-group "function application syntax"
   (test "thunk"
         '(apply x () () __toplevel)
         (cps->sexpr (core->cps '(x))))
@@ -64,7 +64,7 @@
                                                           __toplevel)))))))
         (cps->sexpr (core->cps '(f (t1) (t2) (t3))))))
 
-(test-group "lambdas"
+(test-group "lambda syntax"
   (test "identity"
         '(pass (lambda ((__γ1 __κ2) (x)) (pass (x) __γ1 __κ2)) () __toplevel)
         (cps->sexpr (core->cps '(lambda (x) x))))
@@ -75,7 +75,7 @@
                       (apply __v2 (y) __γ1 __toplevel)))
         (cps->sexpr (core->cps '((lambda (x) x) y)))))
 
-(test-group "if"
+(test-group "if syntax"
   (test "if #t"
         '(pass (y) () __toplevel)
         (cps->sexpr (core->cps '(if #t y z))))
@@ -104,13 +104,33 @@
                (kappa (__p1) __γ2
                       (apply cons* (__p1 __toplevel __γ2) __γ2
                              (kappa (__γ3) ignored
-                                    (pass (y) __γ3 __κ0)))))
+                                    (pass (y) __γ3 __unwind)))))
         (cps->sexpr (core->cps '(push-prompt x y))))
   (test "push-sub-continuation"
         '(pass (x) ()
                (kappa __γ1 __γ2
                       (apply in-middle (__γ1 __toplevel __γ2) __γ2
                              (kappa (__γ3) ignored
-                                    (pass (y) __γ3 __κ0)))))
+                                    (pass (y) __γ3 __unwind)))))
         (cps->sexpr (core->cps '(push-sub-continuation x y)))))
 
+(define (e1 expr)
+  (let-values (((v . rest) (eval-core expr)))
+    v))
+
+(test-group "atom eval"
+  (test "constant"
+        '(5)
+        (e1 5))
+  (test "quote"
+        '('x)
+        (e1 ''x))
+  (test "multiple quotes on a symbol"
+        '('''x)
+        (e1 ''''x))
+  (test "quoted constant"
+        '(#f)
+        (e1 ''#f))
+  (test "multiple quotes on a constant"
+        '(''#f)
+        (e1 '''#f)))