From dfe91d23e61054530e4b29b06d88ddc758ed9e8c Mon Sep 17 00:00:00 2001
From: Danny Yoo <dyoo@cs.wpi.edu>
Date: Sat, 12 Mar 2011 03:46:15 -0500
Subject: [PATCH] kludging the call/cc code in

---
 assemble.rkt      |  9 ++++++++-
 package.rkt       | 11 +++++++++++
 runtime.js        | 42 +++++++++++++++++++++++-------------------
 test-all.rkt      |  3 +--
 test-assemble.rkt | 18 ++++++++++++++++++
 test-package.rkt  |  2 +-
 6 files changed, 62 insertions(+), 23 deletions(-)

diff --git a/assemble.rkt b/assemble.rkt
index dacb85b..4972eee 100644
--- a/assemble.rkt
+++ b/assemble.rkt
@@ -38,7 +38,14 @@ EOF
 ;; fracture: (listof stmt) -> (listof basic-block)
 (: fracture ((Listof Statement) -> (Listof BasicBlock)))
 (define (fracture stmts)
-  (let* ([first-block-label (make-label 'start)]
+  (let* ([first-block-label (if (and (not (empty? stmts))
+                                     (symbol? (first stmts)))
+                                (first stmts)
+                                (make-label 'start))]
+         [stmts (if (and (not (empty? stmts))
+                                     (symbol? (first stmts)))
+                    (rest stmts)
+                    stmts)]
          [jump-targets 
           (cons first-block-label (collect-general-jump-targets stmts))])
     (let: loop : (Listof BasicBlock)
diff --git a/package.rkt b/package.rkt
index 87cc027..83aba0d 100644
--- a/package.rkt
+++ b/package.rkt
@@ -16,10 +16,21 @@
 
 ;; package: s-expression output-port -> void
 (define (package source-code op)
+
+  ;; The support code for call/cc
+  (for-each (lambda (code)
+              (displayln code op))
+            (map assemble-basic-block 
+                 (fracture (statements 
+                            (make-call/cc-code)))))
+
+  ;; The runtime code
   (call-with-input-file* runtime.js
     (lambda (ip)
       (copy-port ip op)))
+  
   (newline op)
+  
   (fprintf op "var invoke = ")
   (assemble/write-invoke (compile (parse source-code)
                                   'val
diff --git a/runtime.js b/runtime.js
index 0d5e3b8..474133d 100644
--- a/runtime.js
+++ b/runtime.js
@@ -10,6 +10,24 @@
 
 // No error trapping at the moment.
 
+
+var Frame = function(label, proc) {
+    this.label = label;
+    this.proc = proc;
+};
+
+
+// A closure consists of its free variables as well as a label
+// into its text segment.
+var Closure = function(label, arity, closedVals, displayName) {
+    this.label = label;
+    this.arity = arity;
+    this.closedVals = closedVals;
+    this.displayName = displayName;
+};
+
+
+
 var Primitives = (function() {
     var NULL = [];
     return {
@@ -128,30 +146,16 @@ var Primitives = (function() {
 	    var firstArg = MACHINE.env[MACHINE.env.length-1];
 	    return firstArg - 1;
 	}
-// 	,
-// 	'call/cc': new Closure(callCCEntry,
-// 			       1,
-// 			       [],
-// 			       "call/cc")
+ 	,
+ 	'call/cc': new Closure(callCCEntry,
+ 			       1,
+ 			       [],
+ 			       "call/cc")
 
     };
 })();
 
 
-var Frame = function(label, proc) {
-    this.label = label;
-    this.proc = proc;
-};
-
-
-// A closure consists of its free variables as well as a label
-// into its text segment.
-var Closure = function(label, arity, closedVals, displayName) {
-    this.label = label;
-    this.arity = arity;
-    this.closedVals = closedVals;
-    this.displayName = displayName;
-};
 
 
 // // adaptToJs: closure -> (array (X -> void) -> void)
diff --git a/test-all.rkt b/test-all.rkt
index fc1fd6e..28c68ae 100644
--- a/test-all.rkt
+++ b/test-all.rkt
@@ -5,5 +5,4 @@
          "test-compiler.rkt"
          "test-assemble.rkt"
          "test-browser-evaluate.rkt"
-         "test-package.rkt"
-         )
\ No newline at end of file
+         "test-package.rkt")
\ No newline at end of file
diff --git a/test-assemble.rkt b/test-assemble.rkt
index 1a52431..f1411c9 100644
--- a/test-assemble.rkt
+++ b/test-assemble.rkt
@@ -4,6 +4,7 @@
          "browser-evaluate.rkt"
          "parse.rkt"
          "il-structs.rkt"
+         "compile.rkt"
          racket/port
          racket/promise
          racket/runtime-path)
@@ -41,7 +42,16 @@
                             [code
                              (string-append
                               "(function() { "
+                              
+                                ;; The support code for call/cc
+                              (string-join (map assemble-basic-block 
+                                                (fracture (statements 
+                                                           (make-call/cc-code))))
+                                           "\n")
+                              
                               runtime
+                              
+                              
                               "return function(success, fail, params){" snippet
                               (format "success(String(~a)); };" inspector)
                               "});")])
@@ -57,6 +67,14 @@
                                  [inspector (cdr a-statement+inspector)])
                             
                             (display "(function() { " op)
+                            
+                            (display
+                             (string-join (map assemble-basic-block 
+                                                (fracture (statements 
+                                                           (make-call/cc-code))))
+                                           "\n")
+                             op)
+                            
                             (display runtime op)
                             
                             (display "var myInvoke = " op)
diff --git a/test-package.rkt b/test-package.rkt
index 6db0597..ad9d57f 100644
--- a/test-package.rkt
+++ b/test-package.rkt
@@ -3,7 +3,7 @@
 (require "package.rkt")
 
 (define (test s-exp)
-  (package s-exp (current-output-port)))
+  (package s-exp (open-output-string) #;(current-output-port)))
 
 
 (test '(define (factorial n)