start eval

1 files changed, 107 insertions, 3 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)))