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"
"sets.rkt"
"compile.rkt"
"typed-parse.rkt"
racket/list)
(provide call/cc-label
make-call/cc-code)
(provide get-bootstrapping-code)
@ -66,3 +68,44 @@
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-PopControlFrame)
,(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])
compile-procedure-call
append-instruction-sequences
current-defined-name
adjust-target-depth)

5
expression-structs.rkt
View File

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

14
package.rkt
View File

@ -18,12 +18,6 @@
;; 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 (make-call/cc-code))))
;; The runtime code
(call-with-input-file* runtime.js
(lambda (ip)
@ -31,6 +25,14 @@
(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 = ")
(assemble/write-invoke (compile (parse source-code)
'val

21
runtime.js
View File

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

16
simulator-primitives.rkt
View File

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

4
simulator.rkt
View File

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

20
test-assemble.rkt
View File

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