suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

temporarily broke package

Browse Source
This commit is contained in:
dyoo 2011-03-15 15:18:26 -04:00
parent b14631a40f
commit fc723832c8
8 changed files with 84 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
bootstrapped-primitives.rkt
View File

@ -7,10 +7,12 @@
"find-toplevel-variables.rkt" "find-toplevel-variables.rkt"
"sets.rkt" "sets.rkt"
"compile.rkt" "compile.rkt"
"typed-parse.rkt"
racket/list) racket/list)
(provide call/cc-label
make-call/cc-code)
(provide get-bootstrapping-code)
@ -66,3 +68,44 @@
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel)) ,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-PopControlFrame) ,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))))) ,(make-GotoStatement (make-Reg 'proc)))))))
(: make-bootstrapped-primitive-code (Symbol Any -> (Listof Statement)))
(define (make-bootstrapped-primitive-code name src)
(parameterize ([current-defined-name name])
(append
(compile (parse src) (make-PrimitivesReference name) 'next)
;; Remove the prefix after the Primitives assignment.
`(,(make-PopEnvironment 1 0)))))
(: get-bootstrapping-code (-> (Listof Statement)))
(define (get-bootstrapping-code)
(append
(make-bootstrapped-primitive-code 'double
'(lambda (x)
(* x x)))
(make-bootstrapped-primitive-code 'map
'(letrec ([map (lambda (f l)
(if (null? l)
null
(cons (f (car l))
(map f (cdr l)))))])
map))
;; The call/cc code is special:
(let ([after-call/cc-code (make-label 'afterCallCCImplementation)])
(append
`(,(make-AssignPrimOpStatement (make-PrimitivesReference 'call/cc)
(make-MakeCompiledProcedure call/cc-label 1 '() 'call/cc))
,(make-AssignPrimOpStatement (make-PrimitivesReference 'call-with-current-continuation)
(make-MakeCompiledProcedure call/cc-label 1 '() 'call/cc))
,(make-GotoStatement (make-Label after-call/cc-code)))
(make-call/cc-code)
`(,after-call/cc-code)))))

1
compile.rkt
View File

@ -12,6 +12,7 @@
(provide (rename-out [-compile compile]) (provide (rename-out [-compile compile])
compile-procedure-call compile-procedure-call
append-instruction-sequences append-instruction-sequences
current-defined-name
adjust-target-depth) adjust-target-depth)

5
expression-structs.rkt
View File

@ -37,11 +37,6 @@
#:transparent) #:transparent)
#;(define-struct: Letrec ([names : (Listof Symbol)]
[procs : (Listof Lam)]
[body : ExpressionCore]))
(: last-exp? ((Listof Expression) -> Boolean)) (: last-exp? ((Listof Expression) -> Boolean))
(define (last-exp? seq) (define (last-exp? seq)
(null? (cdr seq))) (null? (cdr seq)))

14
package.rkt
View File

@ -18,12 +18,6 @@
;; package: s-expression output-port -> void ;; package: s-expression output-port -> void
(define (package source-code op) (define (package source-code op)
;; The support code for call/cc
(for-each (lambda (code)
(displayln code op))
(map assemble-basic-block
(fracture (make-call/cc-code))))
;; The runtime code ;; The runtime code
(call-with-input-file* runtime.js (call-with-input-file* runtime.js
(lambda (ip) (lambda (ip)
@ -31,6 +25,14 @@
(newline op) (newline op)
;; The support code for call/cc
(for-each (lambda (code)
(displayln code op))
(map assemble-basic-block
(fracture (get-bootstrapping-code))))
(newline op)
(fprintf op "var invoke = ") (fprintf op "var invoke = ")
(assemble/write-invoke (compile (parse source-code) (assemble/write-invoke (compile (parse source-code)
'val 'val

21
runtime.js
View File

@ -292,16 +292,17 @@ var Primitives = (function() {
} }
} }
return true; return true;
}, }
'call/cc': new Closure(callCCEntry, // ,
1, // 'call/cc': new Closure(callCCEntry,
[], // 1,
"call/cc"), // [],
'call-with-current-continuation': new Closure(callCCEntry, // "call/cc"),
1, // 'call-with-current-continuation': new Closure(callCCEntry,
[], // 1,
"call-with-current-continuation") // [],
// "call-with-current-continuation")
}; };
})(); })();

16
simulator-primitives.rkt
View File

@ -45,12 +45,12 @@
(make-undefined)] (make-undefined)]
)))))])) )))))]))
(define call/cc ;(define call/cc
(make-closure call/cc-label ; (make-closure call/cc-label
1 ; 1
'() ; '()
'call/cc)) ; 'call/cc))
(define call-with-current-continuation call/cc) ;(define call-with-current-continuation call/cc)
(define e (exp 1)) (define e (exp 1))
@ -154,7 +154,7 @@
symbol?) symbol?)
#:constants (null pi e #:constants (null pi e
call/cc #;call/cc
call-with-current-continuation))) #;call-with-current-continuation)))

4
simulator.rkt
View File

@ -41,9 +41,7 @@
(let*: ([after-bootstrapping : Symbol (make-label 'afterBootstrapping)] (let*: ([after-bootstrapping : Symbol (make-label 'afterBootstrapping)]
[program-text : (Listof Statement) [program-text : (Listof Statement)
(cond [with-bootstrapping-code? (cond [with-bootstrapping-code?
(append `(,(make-GotoStatement (make-Label after-bootstrapping))) (append (get-bootstrapping-code)
(make-call/cc-code)
`(,after-bootstrapping)
program-text)] program-text)]
[else [else
program-text])]) program-text])])

20
test-assemble.rkt
View File

@ -44,15 +44,15 @@
(string-append (string-append
"(function() { " "(function() { "
;; The support code for call/cc
(string-join (map assemble-basic-block
(fracture (make-call/cc-code)))
"\n")
runtime runtime
;; The support code for call/cc
"return function(success, fail, params){" snippet (string-join (map assemble-basic-block
(fracture (get-bootstrapping-code)))
"\n")
"return function(success, fail, params){"
snippet
(format "success(String(~a)); };" inspector) (format "success(String(~a)); };" inspector)
"});")]) "});")])
(displayln snippet) (displayln snippet)
@ -68,14 +68,14 @@
(display "(function() { " op) (display "(function() { " op)
(display runtime op)
(display (display
(string-join (map assemble-basic-block (string-join (map assemble-basic-block
(fracture (make-call/cc-code))) (fracture (get-bootstrapping-code)))
"\n") "\n")
op) op)
(display runtime op)
(display "var myInvoke = " op) (display "var myInvoke = " op)
(assemble/write-invoke a-statement op) (assemble/write-invoke a-statement op)
(display ";" op) (display ";" op)