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

req-for-syntax repairs

Browse Source 
svn: r1288
This commit is contained in:
Matthew Flatt 2005-11-11 21:28:22 +00:00
parent aa0692e7cd
commit c198298d25
2 changed files with 52 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/compiler/private/driver.ss
View File

@ -638,20 +638,22 @@
[_else (void)])) [_else (void)]))
;;----------------------------------------------------------------------- ;;-----------------------------------------------------------------------
;; ensure that no `module' expression is inside a `begin' ;; ensure that no `module', `require', or `require-for-syntax'
;; ;; expression is inside a `begin'
(letrec ([needs-split? (letrec ([needs-split?
(lambda (stx saw-begin?) (lambda (stx saw-begin?)
(syntax-case stx (begin module) (syntax-case stx (begin module require require-for-syntax)
[(module . _) saw-begin?] [(module . _) saw-begin?]
[(require . _) saw-begin?]
[(require-for-syntax . _) saw-begin?]
[(begin . e) [(begin . e)
(ormap (lambda (x) (needs-split? x #t)) (ormap (lambda (x) (needs-split? x #t))
(syntax->list #'e))] (syntax->list #'e))]
[_else #f]))] [_else #f]))]
[split [split
(lambda (stx) (lambda (stx)
(syntax-case stx (begin module) (syntax-case stx (begin)
[(begin . e) [(begin . e)
(apply append (map split (syntax->list #'e)))] (apply append (map split (syntax->list #'e)))]
[_else (list stx)]))]) [_else (list stx)]))])
@ -674,23 +676,24 @@
(let ([core-thunk (let ([core-thunk
(lambda () (lambda ()
(let ([sources+bytecodes+magics (parameterize ([current-namespace elaborate-namespace]
(map (lambda (src) [current-load-relative-directory input-directory])
(let-values ([(src bytecode magic-sym) (let ([sources+bytecodes+magics
(top-level-to-core src (map (lambda (src)
#`'#,zodiac:global-lookup-id (let-values ([(src bytecode magic-sym)
#`'#,zodiac:global-assign-id (top-level-to-core src
#`'#,zodiac:safe-vector-ref-id #`'#,zodiac:global-lookup-id
#`'#,zodiac:global-prepare-id)]) #`'#,zodiac:global-assign-id
(list (zodiac:syntax->zodiac src) #`'#,zodiac:safe-vector-ref-id
bytecode magic-sym))) #`'#,zodiac:global-prepare-id)])
(block-source s:file-block))]) (list (zodiac:syntax->zodiac src)
(set-block-source! s:file-block (map car sources+bytecodes+magics)) bytecode magic-sym)))
(set-block-bytecodes! s:file-block (block-source s:file-block))])
(parameterize ([current-namespace elaborate-namespace]) (set-block-source! s:file-block (map car sources+bytecodes+magics))
(set-block-bytecodes! s:file-block
(map compile (map compile
(map cadr sources+bytecodes+magics)))) (map cadr sources+bytecodes+magics)))
(set-block-magics! s:file-block (map caddr sources+bytecodes+magics))))]) (set-block-magics! s:file-block (map caddr sources+bytecodes+magics)))))])
(verbose-time core-thunk)) (verbose-time core-thunk))
;;----------------------------------------------------------------------- ;;-----------------------------------------------------------------------

31
collects/compiler/private/to-core.ss
View File

@ -6,6 +6,11 @@
(provide top-level-to-core) (provide top-level-to-core)
;; `module', `require', and `require-for-syntax' declarations must
;; not be embedded in a `begin' sequence. For `require' and
;; `require-for-syntax', it's a timing issue. For `module', it's
;; because the transformation can only handle a single `module'
;; declaration.
(define (top-level-to-core stx lookup-stx set-stx safe-vector-ref-stx extract-stx) (define (top-level-to-core stx lookup-stx set-stx safe-vector-ref-stx extract-stx)
(syntax-case stx (module begin) (syntax-case stx (module begin)
[(module m lang (plain-module-begin decl ...)) [(module m lang (plain-module-begin decl ...))
@ -154,7 +159,17 @@
(filter is-run-time? decls))] (filter is-run-time? decls))]
[ct-rhs #`((let ([magic (car (cons '#,magic-sym 2))]) [ct-rhs #`((let ([magic (car (cons '#,magic-sym 2))])
(if (symbol? magic) (if (symbol? magic)
(lambda (x) (make-vector #,(length decls) void)) (lambda (x) (vector
#,@(map (lambda (stx)
(syntax-case stx ()
[(def (id) . _)
#'void]
[(def (id ...) . _)
(with-syntax ([(v ...) (map (lambda (x) #f)
(syntax->list #'(id ...)))])
#`(lambda () (values v ...)))]))
(filter (lambda (x) (not (is-run-time? x))) decls))))
(car magic))) (car magic)))
(vector #,@(vars-sequence ct-vars)))] (vector #,@(vars-sequence ct-vars)))]
[rt-rhs #`((cdr '#,magic-sym) (vector #,@(vars-sequence rt-vars)))] [rt-rhs #`((cdr '#,magic-sym) (vector #,@(vars-sequence rt-vars)))]
@ -184,7 +199,15 @@
(lambda (#,run-time) (lambda (#,run-time)
#,@(extract-vars rt-vars run-time extract-stx) #,@(extract-vars rt-vars run-time extract-stx)
(vector #,@rt-converted))) (vector #,@rt-converted)))
#`(;; Lift define-for-values binding to front, so they can be referenced #`(;; Lift require and require-for-syntaxes to the front, so they're ready for
;; variable references
#,@(filter (lambda (decl)
(syntax-case decl (require require-for-syntax)
[(require . _) #t]
[(require-for-syntax . _) #t]
[_else #f]))
decls)
;; Lift define-for-values binding to front, so they can be referenced
;; in compile-time definition ;; in compile-time definition
#,@(let ([ids (apply #,@(let ([ids (apply
append append
@ -212,9 +235,9 @@
[(provide . _) [(provide . _)
(car decls)] (car decls)]
[(require . _) [(require . _)
(car decls)] #'(void)]
[(require-for-syntax . _) [(require-for-syntax . _)
(car decls)] #'(void)]
[(require-for-template . _) [(require-for-template . _)
(car decls)] (car decls)]
[(define-values (id ...) rhs) [(define-values (id ...) rhs)