moving the bootstrapping primitives code (like call/cc) into bootstrapped-primitives.rkt. About to implement map as well.

bootstrapped-primitives.rkt

@@ -0,0 +1,68 @@
+#lang typed/racket/base
+(require "expression-structs.rkt"
+         "lexical-structs.rkt"
+         "il-structs.rkt"
+         "lexical-env.rkt"
+         "helpers.rkt"
+         "find-toplevel-variables.rkt"
+         "sets.rkt"
+         "compile.rkt"
+         racket/list)
+
+(provide call/cc-label
+         make-call/cc-code)
+
+
+
+;; The primitive code necessary to do call/cc
+
+(: call/cc-label Symbol)
+(define call/cc-label 'callCCEntry)
+(define call/cc-closure-entry 'callCCClosureEntry)
+
+
+;; (call/cc f)
+;; Tail-calls f, providing it a special object that knows how to do the low-level
+;; manipulation of the environment and control stack.
+(define (make-call/cc-code)
+  (statements
+   (append-instruction-sequences
+    (make-instruction-sequence 
+     `(,call/cc-label
+       ;; Precondition: the environment holds the f function that we want to jump into.
+       
+       ;; First, move f to the proc register
+       ,(make-AssignImmediateStatement 'proc (make-EnvLexicalReference 0 #f))
+       
+       ;; Next, capture the envrionment and the current continuation closure,.
+       ,(make-PushEnvironment 2 #f)
+       ,(make-AssignPrimOpStatement (make-EnvLexicalReference 0 #f) 
+                                    (make-CaptureControl 0))
+       ,(make-AssignPrimOpStatement (make-EnvLexicalReference 1 #f)
+                                    ;; When capturing, skip over f and the two slots we just added.
+                                    (make-CaptureEnvironment 3))
+       ,(make-AssignPrimOpStatement (adjust-target-depth (make-EnvLexicalReference 0 #f) 2)
+                                    (make-MakeCompiledProcedure call/cc-closure-entry
+                                                                1 ;; the continuation consumes a single value
+                                                                (list (make-EnvLexicalReference 0 #f)
+                                                                      (make-EnvLexicalReference 1 #f))
+                                                                'call/cc))
+       ,(make-PopEnvironment 2 0)))
+    
+    ;; Finally, do a tail call into f.
+    (compile-procedure-call '()
+                            (extend-lexical-environment/placeholders '() 1)
+                            1 
+                            'val
+                            'return)
+    
+    ;; The code for the continuation coe follows.  It's supposed to
+    ;; abandon the current continuation, initialize the control and environment, and then jump.
+    (make-instruction-sequence `(,call/cc-closure-entry
+                                 ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
+                                 ,(make-PerformStatement (make-InstallClosureValues!))
+                                 ,(make-PerformStatement (make-RestoreControl!))
+                                 ,(make-PerformStatement (make-RestoreEnvironment!))
+                                 ,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
+                                 ,(make-PopControlFrame)
+                                 ,(make-GotoStatement (make-Reg 'proc)))))))

compile.rkt

@@ -12,9 +12,7 @@
 (provide (rename-out [-compile compile])
          compile-procedure-call
          append-instruction-sequences
-         
+         adjust-target-depth)
-         call/cc-label
-         make-call/cc-code)
 
 
 (: current-defined-name (Parameterof (U Symbol False)))
@@ -32,10 +30,7 @@
                          exp)
                (list)
                target 
-               linkage)
+               linkage)))))
-      (make-instruction-sequence `(,(make-GotoStatement (make-Label end))))
-      (make-call/cc-code)
-      end))))
 
 
 
@@ -652,61 +647,3 @@
       (error 'ensure-natural "Not a natural: ~s\n" n)))
 
 
-
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-;; The primitive code necessary to do call/cc
-
-(: call/cc-label Symbol)
-(define call/cc-label 'callCCEntry)
-(define call/cc-closure-entry 'callCCClosureEntry)
-
-
-;; (call/cc f)
-;; Tail-calls f, providing it a special object that knows how to do the low-level
-;; manipulation of the environment and control stack.
-(define (make-call/cc-code)
-  (append-instruction-sequences
-   (make-instruction-sequence 
-    `(,call/cc-label
-      ;; Precondition: the environment holds the f function that we want to jump into.
-      
-      ;; First, move f to the proc register
-      ,(make-AssignImmediateStatement 'proc (make-EnvLexicalReference 0 #f))
-      
-      ;; Next, capture the envrionment and the current continuation closure,.
-      ,(make-PushEnvironment 2 #f)
-      ,(make-AssignPrimOpStatement (make-EnvLexicalReference 0 #f) 
-                                   (make-CaptureControl 0))
-      ,(make-AssignPrimOpStatement (make-EnvLexicalReference 1 #f)
-                                   ;; When capturing, skip over f and the two slots we just added.
-                                   (make-CaptureEnvironment 3))
-      ,(make-AssignPrimOpStatement (adjust-target-depth (make-EnvLexicalReference 0 #f) 2)
-                                   (make-MakeCompiledProcedure call/cc-closure-entry
-                                                               1 ;; the continuation consumes a single value
-                                                               (list (make-EnvLexicalReference 0 #f)
-                                                                     (make-EnvLexicalReference 1 #f))
-                                                               (current-defined-name)))
-      ,(make-PopEnvironment 2 0)))
-                                   
-   ;; Finally, do a tail call into f.
-   (compile-procedure-call '()
-                           (extend-lexical-environment/placeholders '() 1)
-                           1 
-                           'val
-                           'return)
-   
-   ;; The code for the continuation coe follows.  It's supposed to
-   ;; abandon the current continuation, initialize the control and environment, and then jump.
-   (make-instruction-sequence `(,call/cc-closure-entry
-                                ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
-                                ,(make-PerformStatement (make-InstallClosureValues!))
-                                ,(make-PerformStatement (make-RestoreControl!))
-                                ,(make-PerformStatement (make-RestoreEnvironment!))
-                                ,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
-                                ,(make-PopControlFrame)
-                                ,(make-GotoStatement (make-Reg 'proc))))))

package.rkt

@@ -4,6 +4,7 @@
          "assemble.rkt"
          "typed-parse.rkt"
          "il-structs.rkt"
+         "bootstrapped-primitives.rkt"
          racket/runtime-path
          racket/port)
 
@@ -21,8 +22,7 @@
   (for-each (lambda (code)
               (displayln code op))
             (map assemble-basic-block 
-                 (fracture (statements 
+                 (fracture (make-call/cc-code))))
-                            (make-call/cc-code)))))
 
   ;; The runtime code
   (call-with-input-file* runtime.js

simulator-primitives.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 (require "simulator-structs.rkt"
          "compile.rkt"
+         "bootstrapped-primitives.rkt"
          racket/math
          (for-syntax racket/base))
 

simulator.rkt

@@ -7,6 +7,7 @@
 
 (require "il-structs.rkt"
          "simulator-structs.rkt"
+         "bootstrapped-primitives.rkt"
          racket/list
          racket/match
          (for-syntax racket/base))
@@ -30,15 +31,27 @@
 
 (: new-machine ((Listof Statement) -> machine))
 (define (new-machine program-text)
-  (let: ([m : machine (make-machine (make-undefined) (make-undefined) '() '() 0 (list->vector program-text) 0
+  (let*: ([after-bootstrapping : Symbol (make-label 'afterBootstrapping)]
-                                    ((inst make-hash Symbol Natural)))])
+          [program-text : (Listof Statement)
-        (let: loop : Void ([i : Natural 0])
+                        (append `(,(make-GotoStatement (make-Label after-bootstrapping)))
-              (when (< i (vector-length (machine-text m)))
+                                (make-call/cc-code)
-                (let: ([stmt : Statement (vector-ref (machine-text m) i)])
+                                `(,after-bootstrapping)
-                      (when (symbol? stmt)
+                                program-text)])
-                        (hash-set! (machine-jump-table m) stmt i))
+         (let: ([m : machine (make-machine (make-undefined)
-                      (loop (add1 i)))))
+                                           (make-undefined)
-        m))
+                                           '() 
+                                           '()
+                                           0 
+                                           (list->vector program-text) 
+                                           0
+                                           ((inst make-hash Symbol Natural)))])
+               (let: loop : Void ([i : Natural 0])
+                     (when (< i (vector-length (machine-text m)))
+                       (let: ([stmt : Statement (vector-ref (machine-text m) i)])
+                             (when (symbol? stmt)
+                               (hash-set! (machine-jump-table m) stmt i))
+                             (loop (add1 i)))))
+               m)))
 
 
 

test-assemble.rkt

@@ -5,6 +5,7 @@
          "parse.rkt"
          "il-structs.rkt"
          "compile.rkt"
+         "bootstrapped-primitives.rkt"
          racket/port
          racket/promise
          racket/runtime-path)
@@ -45,8 +46,7 @@
                               
                                 ;; The support code for call/cc
                               (string-join (map assemble-basic-block 
-                                                (fracture (statements 
+                                                (fracture (make-call/cc-code)))
-                                                           (make-call/cc-code))))
                                            "\n")
                               
                               runtime
@@ -70,8 +70,7 @@
                             
                             (display
                              (string-join (map assemble-basic-block 
-                                                (fracture (statements 
+                                                (fracture (make-call/cc-code)))
-                                                           (make-call/cc-code))))
                                            "\n")
                              op)
                             

test-browser-evaluate.rkt

@@ -20,7 +20,6 @@
                                      #'stx)))
              (printf " ok (~a milliseconds)\n" (evaluated-t result))))))]))
 
-#|
 (test '(begin (define (f x) 
                 (if (= x 0)
                     0
@@ -142,7 +141,7 @@
          (displayln (tak 18 12 6)))
         "7\n")
 
-|#
 
-(test (read (open-input-file "tests/conform/program1.sch"))
+
+#;(test (read (open-input-file "tests/conform/program0.sch"))
       (port->string (open-input-file "tests/conform/expected0.txt")))