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

did I break something?

Browse Source
This commit is contained in:
Danny Yoo 2011-06-08 18:15:24 -04:00
parent 3cdf1bfbb1
commit f483d9b687
3 changed files with 31 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
js-assembler/package.rkt
View File

@ -38,6 +38,9 @@
(define (wrap-source src)
src)
;; package: Source (path -> boolean) output-port -> void ;; package: Source (path -> boolean) output-port -> void
@ -55,7 +58,8 @@
#:output-port op) #:output-port op)
(define packaging-configuration (define packaging-configuration
(make-Configuration (make-Configuration
wrap-source
should-follow? should-follow?
;; on ;; on
@ -95,8 +99,11 @@
(define (write-runtime op) (define (write-runtime op)
(let ([packaging-configuration (let ([packaging-configuration
(make-Configuration (make-Configuration
wrap-source
;; should-follow-children? ;; should-follow-children?
(lambda (src p) #t) (lambda (src) #t)
;; on ;; on
(lambda (src ast stmts) (lambda (src ast stmts)
(assemble/write-invoke stmts op) (assemble/write-invoke stmts op)
@ -160,7 +167,7 @@ EOF
(define (get-code source-code) (define (get-code source-code)
(let ([buffer (open-output-string)]) (let ([buffer (open-output-string)])
(package source-code (package source-code
#:should-follow-children? (lambda (src p) #t) #:should-follow-children? (lambda (src) #t)
#:output-port buffer) #:output-port buffer)
(compress (compress
(get-output-string buffer)))) (get-output-string buffer))))
@ -178,7 +185,7 @@ EOF
;; write-standalone-code: source output-port -> void ;; write-standalone-code: source output-port -> void
(define (write-standalone-code source-code op) (define (write-standalone-code source-code op)
(package-anonymous source-code (package-anonymous source-code
#:should-follow-children? (lambda (src p) #t) #:should-follow-children? (lambda (src) #t)
#:output-port op) #:output-port op)
(fprintf op "()(plt.runtime.currentMachine, function() {}, function() {}, {});\n")) (fprintf op "()(plt.runtime.currentMachine, function() {}, function() {}, {});\n"))

12
make/make-structs.rkt
View File

@ -13,7 +13,8 @@
(define-type Source (U StatementsSource (define-type Source (U StatementsSource
MainModuleSource MainModuleSource
ModuleSource ModuleSource
SexpSource)) SexpSource
UninterpretedSource))
(define-struct: StatementsSource ([stmts : (Listof Statement)]) (define-struct: StatementsSource ([stmts : (Listof Statement)])
#:transparent) #:transparent)
@ -23,10 +24,14 @@
#:transparent) #:transparent)
(define-struct: SexpSource ([sexp : Any]) (define-struct: SexpSource ([sexp : Any])
#:transparent) #:transparent)
(define-struct: UninterpretedSource ([datum : Any])
#:transparent)
(define-struct: Configuration (define-struct: Configuration
([should-follow-children? : (Source Path -> Boolean)] ([wrap-source : (Source -> Source)]
[should-follow-children? : (Source -> Boolean)]
[on-module-statements : (Source [on-module-statements : (Source
(U Expression #f) (U Expression #f)
(Listof Statement) (Listof Statement)
@ -40,7 +45,8 @@
(define debug-configuration (define debug-configuration
(make-Configuration (make-Configuration
(lambda (src p) #t) (lambda (src) src)
(lambda (src) #t)
(lambda (src ast stmt) (lambda (src ast stmt)
(when (and ast (expression-module-path ast)) (when (and ast (expression-module-path ast))
(printf "debug build configuration: visiting ~s\n" (printf "debug build configuration: visiting ~s\n"

19
make/make.rkt
View File

@ -41,6 +41,9 @@
[(StatementsSource? a-source) [(StatementsSource? a-source)
(values #f (StatementsSource-stmts a-source))] (values #f (StatementsSource-stmts a-source))]
[(UninterpretedSource? a-source)
(values #f '())]
[(MainModuleSource? a-source) [(MainModuleSource? a-source)
(let-values ([(ast stmts) (let-values ([(ast stmts)
(get-ast-and-statements (MainModuleSource-source a-source))]) (get-ast-and-statements (MainModuleSource-source a-source))])
@ -96,7 +99,8 @@
((inst new-seteq Symbol))]) ((inst new-seteq Symbol))])
(match config (match config
[(struct Configuration (should-follow-children? [(struct Configuration (wrap-source
should-follow-children?
on-module-statements on-module-statements
after-module-statements after-module-statements
after-last)) after-last))
@ -112,6 +116,8 @@
(cond (cond
[(eq? ast #f) [(eq? ast #f)
empty] empty]
#;[(not (should-follow-children? this-source))
empty]
[else [else
;; FIXME: the logic here is wrong. ;; FIXME: the logic here is wrong.
;; Needs to check should-follow-children before continuing here. ;; Needs to check should-follow-children before continuing here.
@ -120,14 +126,11 @@
(foldl (lambda: ([mp : ModuleLocator] (foldl (lambda: ([mp : ModuleLocator]
[acc : (Listof Source)]) [acc : (Listof Source)])
(let ([rp [ModuleLocator-real-path mp]]) (let ([rp [ModuleLocator-real-path mp]])
(cond [((current-kernel-module-locator?) (cond [((current-kernel-module-locator?)
mp) mp)
acc] acc]
[(and (path? rp) [(path? rp)
(should-follow-children? this-source rp) (cons (make-ModuleSource rp) acc)]
(cons (make-ModuleSource rp)
acc))]
[else [else
acc]))) acc])))
'() '()
@ -148,9 +151,9 @@
[(ast stmts) [(ast stmts)
(get-ast-and-statements this-source)]) (get-ast-and-statements this-source)])
(on-module-statements this-source ast stmts) (on-module-statements this-source ast stmts)
(loop (append (collect-new-dependencies this-source ast) (loop (append (map wrap-source (collect-new-dependencies this-source ast))
(rest sources))) (rest sources)))
(after-module-statements this-source ast stmts))]))) (after-module-statements this-source ast stmts))])))
(follow-dependencies sources)]))) (follow-dependencies (map wrap-source sources))])))