[Guile-commits] 23/99: Compile cps $prompt form to javascript

[Christopher Allan Webber]

cwebber pushed a commit to branch compile-to-js-merge
in repository guile.

commit 5827ad4f035bba20756373e1ce1292d8cb18f98e
Author: Ian Price <ianprice90@googlemail.com>
AuthorDate: Mon Jun 15 23:18:16 2015 +0100

    Compile cps $prompt form to javascript
---
 module/language/cps/compile-js.scm           |  8 +++-
 module/language/js-il.scm                    |  4 ++
 module/language/js-il/compile-javascript.scm |  9 ++++
 module/language/js-il/runtime.js             | 72 +++++++++++++++++++++++++---
 4 files changed, 85 insertions(+), 8 deletions(-)

diff --git a/module/language/cps/compile-js.scm 
b/module/language/cps/compile-js.scm
index 8bffa97..e990d1f 100644
--- a/module/language/cps/compile-js.scm
+++ b/module/language/cps/compile-js.scm
@@ -1,6 +1,7 @@
 (define-module (language cps compile-js)
   #:use-module (language cps)
-  #:use-module (language js-il)
+  #:use-module ((language js-il)
+                #:renamer (lambda (x) (if (eqv? x 'make-prompt) 'make-prompt* 
x)))
   #:use-module (ice-9 match)
   #:export (compile-js))
 
@@ -106,6 +107,11 @@
      (make-continue label (map make-id (cons* proc k args))))
     (($ $values values)
      (make-continue k (map make-id values)))
+    (($ $prompt escape? tag handler)
+     (make-seq
+      (list
+       (make-prompt* escape? tag handler)
+       (make-continue k '()))))
     (_
      (make-continue k (list (compile-exp* exp))))))
 
diff --git a/module/language/js-il.scm b/module/language/js-il.scm
index 3415cd9..ae5932c 100644
--- a/module/language/js-il.scm
+++ b/module/language/js-il.scm
@@ -17,6 +17,8 @@
             make-branch branch
             make-return return
             make-id id
+            make-seq seq
+            make-prompt prompt
             ))
 
 ;; Copied from (language cps)
@@ -64,6 +66,8 @@
 (define-js-type branch test consequence alternate)
 (define-js-type id name)
 (define-js-type return val)
+(define-js-type seq body)
+(define-js-type prompt escape? tag handler)
 
 (define (unparse-js exp)
   (match exp
diff --git a/module/language/js-il/compile-javascript.scm 
b/module/language/js-il/compile-javascript.scm
index 27f91ad..05327c7 100644
--- a/module/language/js-il/compile-javascript.scm
+++ b/module/language/js-il/compile-javascript.scm
@@ -155,6 +155,15 @@
       (make-call (make-refine *scheme* (make-const "Closure"))
                  (list (name->id label) (make-const nfree)))))
 
+    (($ il:prompt escape? tag handler)
+     ;; never a tailcall
+     (make-call (make-refine (make-refine *scheme* (make-const "primitives"))
+                             (make-const "prompt"))
+                (list (compile-const escape?) (name->id tag) (name->id 
handler))))
+
+    (($ il:seq body)
+     (make-block (map compile-exp body)))
+
     (($ il:id name)
      (name->id name))))
 
diff --git a/module/language/js-il/runtime.js b/module/language/js-il/runtime.js
index d0aff57..319c432 100644
--- a/module/language/js-il/runtime.js
+++ b/module/language/js-il/runtime.js
@@ -5,6 +5,7 @@ var scheme = {
     env : {},
     cache: [],
     builtins: [],
+    dynstack : [],
     // TODO: placeholders
     FALSE : false,
     TRUE : true,
@@ -283,22 +284,55 @@ scheme.primitives["resolve"] = function (sym, is_bound) {
 scheme.initial_cont = function (x) { return x; };
 scheme.primitives.return = function (x) { return x; };
 scheme.is_true = function (obj) {
-    return !(obj == scheme.FALSE || obj == scheme.NIL);
+    return !(obj === scheme.FALSE || obj === scheme.NIL);
 };
 
+// Builtins
+var apply = function(self, k, f, arg) {
+    return f.fun(f.freevars, k, arg);
+};
+
+var values = function(self, k, arg) {
+
+    return k(arg);
+};
+
+var abort_to_prompt = function(self, k, prompt, arg) {
+
+    var idx = find_prompt(prompt);
+    var spec = scheme.dynstack[idx];
+
+    var kont = undefined; // actual value doesn't matter
+
+    if (!scheme.is_true(spec[1])) {
+        // TODO: handle multivalue continations
+        // compare with callcc
+        var f = function (self, k2, val) {
+            return k(val);
+        };
+        kont = new scheme.Closure(f, 0);
+    };
+
+    unwind(idx);
+
+    var handler = spec[2];
+
+    return handler(kont, arg);
+};
+
+var call_with_values = not_implemented_yet;
+
 var callcc = function (self, k, closure) {
     var f = function (self, k2, val) {
         return k(val);
     };
     return closure.fun(closure, k, new scheme.Closure(f, 0));
 };
+scheme.builtins[0] = new scheme.Closure(apply, 0);
+scheme.builtins[1] = new scheme.Closure(values, 0);
+scheme.builtins[2] = new scheme.Closure(abort_to_prompt, 0);
+scheme.builtins[3] = new scheme.Closure(call_with_values, 0);
 scheme.builtins[4] = new scheme.Closure(callcc, 0);
-// #define FOR_EACH_VM_BUILTIN(M) \
-//   M(apply, APPLY, 2, 0, 1) \
-//   M(values, VALUES, 0, 0, 1) \
-//   M(abort_to_prompt, ABORT_TO_PROMPT, 1, 0, 1) \
-//   M(call_with_values, CALL_WITH_VALUES, 2, 0, 0) \
-//   M(call_with_current_continuation, CALL_WITH_CURRENT_CONTINUATION, 1, 0, 0)
 
 // Structs
 scheme.primitives["struct?"] = not_implemented_yet;
@@ -331,3 +365,27 @@ scheme.primitives["variable?"] = not_implemented_yet;
 // Dynamic Wind
 scheme.primitives["wind"] = not_implemented_yet;
 scheme.primitives["unwind"] = not_implemented_yet;
+
+// Misc
+scheme.primitives["prompt"] = function(escape_only, tag, handler){
+    scheme.dynstack.unshift([tag, escape_only, handler]);
+};
+
+var unwind = function (idx) {
+    // TODO: call winders
+    scheme.dynstack = scheme.dynstack.slice(idx+1);
+};
+
+var find_prompt = function(prompt) {
+    var eq = scheme.primitives["eq?"];
+    function test(x){
+        return scheme.is_true(eq(x,prompt)) || 
scheme.is_true(eq(x,scheme.TRUE));
+    };
+    for (idx in scheme.dynstack) {
+        if (test(scheme.dynstack[idx][0])) {
+            return idx;
+        };
+    };
+    // FIXME: should error
+    return undefined;
+};