diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 903e6843ef..053ad00fb9 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -164,16 +164,20 @@ (define (decompile-module mod-form stack stx-ht) (match mod-form - [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported + [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported max-let-depth dummy lang-info internal-context)) (let-values ([(globs defns) (decompile-prefix prefix stx-ht)] [(stack) (append '(#%modvars) stack)] [(closed) (make-hasheq)]) `(module ,name .... ,@defns - ,@(map (lambda (form) - (decompile-form form globs stack closed stx-ht)) - syntax-body) + ,@(for/list ([b (in-list syntax-bodies)]) + (let loop ([n (sub1 (car b))]) + (if (zero? n) + (cons 'begin + (for/list ([form (in-list (cdr b))]) + (decompile-form form globs stack closed stx-ht))) + (list 'begin-for-syntax (loop (sub1 n)))))) ,@(map (lambda (form) (decompile-form form globs stack closed stx-ht)) body)))] @@ -190,18 +194,19 @@ (list-ref/protect (glob-desc-vars globs) pos 'def-vals)])) ids) ,(decompile-expr rhs globs stack closed))] - [(struct def-syntaxes (ids rhs prefix max-let-depth)) + [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) `(define-syntaxes ,ids ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) `(let () ,@defns ,(decompile-form rhs globs '(#%globals) closed stx-ht))))] - [(struct def-for-syntax (ids rhs prefix max-let-depth)) - `(define-values-for-syntax ,ids - ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) - `(let () + [(struct seq-for-syntax (exprs prefix max-let-depth dummy)) + `(begin-for-syntax + ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) + `(let () ,@defns - ,(decompile-form rhs globs '(#%globals) closed stx-ht))))] + ,@(for/list ([rhs (in-list exprs)]) + (decompile-form rhs globs '(#%globals) closed stx-ht)))))] [(struct seq (forms)) `(begin ,@(map (lambda (form) (decompile-form form globs stack closed stx-ht)) diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index 1118214a8e..f212b66081 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -64,7 +64,7 @@ (build-graph! new-lhs rhs)] [(? def-syntaxes?) (error 'build-graph "Doesn't handle syntax")] - [(? def-for-syntax?) + [(? seq-for-syntax?) (error 'build-graph "Doesn't handle syntax")] [(struct req (reqs dummy)) (build-graph! lhs dummy)] @@ -197,7 +197,7 @@ #f)] [(? def-syntaxes?) (error 'gc-tls "Doesn't handle syntax")] - [(? def-for-syntax?) + [(? seq-for-syntax?) (error 'gc-tls "Doesn't handle syntax")] [(struct req (reqs dummy)) (make-req reqs (update dummy))] diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index 5c63e6d22b..6e57f5962c 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -108,7 +108,8 @@ (define (merge-module max-let-depth top-prefix mod-form) (match mod-form - [(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-body unexported mod-max-let-depth dummy lang-info internal-context)) + [(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-bodies + unexported mod-max-let-depth dummy lang-info internal-context)) (define toplevel-offset (length (prefix-toplevels top-prefix))) (define topsyntax-offset (length (prefix-stxs top-prefix))) (define lift-offset (prefix-num-lifts top-prefix)) diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index b9d7a8eb79..c37f82ceea 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -112,7 +112,8 @@ (define (nodep-module mod-form phase) (match mod-form - [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported max-let-depth dummy lang-info internal-context)) + [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies + unexported max-let-depth dummy lang-info internal-context)) (define new-prefix prefix) ; Cache all the mpi paths (for-each (match-lambda @@ -127,7 +128,7 @@ (append (requires->modlist requires phase) (if (and phase (zero? phase)) (begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now - (list (make-mod name srcname self-modidx new-prefix provides requires body empty + (list (make-mod name srcname self-modidx new-prefix provides requires body syntax-bodies empty unexported max-let-depth dummy lang-info internal-context))) (begin (log-debug (format "[~S] Dropping module @ ~S" name phase)) empty))))] diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/collects/compiler/demodularizer/update-toplevels.rkt index 90a7b8f2c2..15584bb5d3 100644 --- a/collects/compiler/demodularizer/update-toplevels.rkt +++ b/collects/compiler/demodularizer/update-toplevels.rkt @@ -10,7 +10,7 @@ (update rhs))] [(? def-syntaxes?) (error 'increment "Doesn't handle syntax")] - [(? def-for-syntax?) + [(? seq-for-syntax?) (error 'increment "Doesn't handle syntax")] [(struct req (reqs dummy)) (make-req reqs (update dummy))] diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index e435a97080..22f5d5b95e 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -158,7 +158,7 @@ (define quote-syntax-type-num 14) (define define-values-type-num 15) (define define-syntaxes-type-num 16) -(define define-for-syntax-type-num 17) +(define begin-for-syntax-type-num 17) (define set-bang-type-num 18) (define boxenv-type-num 19) (define begin0-sequence-type-num 20) @@ -256,8 +256,6 @@ (define BITS_PER_MZSHORT 32) -(define *dummy* #f) - (define (int->bytes x) (integer->integer-bytes x 4 @@ -522,21 +520,20 @@ (out-marshaled define-values-type-num (list->vector (cons (protect-quote rhs) ids)) out)] - [(struct def-syntaxes (ids rhs prefix max-let-depth)) + [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) (out-marshaled define-syntaxes-type-num (list->vector (list* (protect-quote rhs) prefix max-let-depth - *dummy* + dummy ids)) out)] - [(struct def-for-syntax (ids rhs prefix max-let-depth)) - (out-marshaled define-for-syntax-type-num - (list->vector (list* (protect-quote rhs) - prefix - max-let-depth - *dummy* - ids)) + [(struct seq-for-syntax (rhs prefix max-let-depth dummy)) + (out-marshaled begin-for-syntax-type-num + (vector (map protect-quote rhs) + prefix + max-let-depth + dummy) out)] [(struct beg0 (forms)) (out-marshaled begin0-sequence-type-num (map protect-quote forms) out)] @@ -825,7 +822,7 @@ (define (out-module mod-form out) (match mod-form - [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported + [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported max-let-depth dummy lang-info internal-context)) (let* ([lookup-req (lambda (phase) (let ([a (assq phase requires)]) @@ -844,6 +841,11 @@ (if (ormap values p) (list->vector p) #f)))))] + [extract-unexported + (lambda (phase) + (let ([a (assq phase unexported)]) + (and a + (cdr a))))] [list->vector/#f (lambda (default l) (if (andmap (lambda (x) (equal? x default)) l) #f @@ -861,45 +863,54 @@ [l (cons (lookup-req 1) l)] ; et-requires [l (cons (lookup-req 0) l)] ; requires [l (cons (list->vector body) l)] - [l (cons (list->vector - (for/list ([i (in-list syntax-body)]) - (define (maybe-one l) ;; a single symbol is ok - (if (and (pair? l) (null? (cdr l))) - (car l) - l)) - (match i - [(struct def-syntaxes (ids rhs prefix max-let-depth)) - (vector (maybe-one ids) rhs max-let-depth prefix #f)] - [(struct def-for-syntax (ids rhs prefix max-let-depth)) - (vector (maybe-one ids) rhs max-let-depth prefix #t)]))) - l)] + [l (append (reverse + (for/list ([b (in-list syntax-bodies)]) + (for/vector ([i (in-list (cdr b))]) + (define (maybe-one l) ;; a single symbol is ok + (if (and (pair? l) (null? (cdr l))) + (car l) + l)) + (match i + [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) + (vector (maybe-one ids) rhs max-let-depth prefix #f)] + [(struct seq-for-syntax ((list rhs) prefix max-let-depth dummy)) + (vector #f rhs max-let-depth prefix #t)])))) + l)] [l (append (apply append (map (lambda (l) - (let ([phase (car l)] - [all (append (cadr l) (caddr l))]) - (list phase - (list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p))) - all)) - (list->vector/#f #f (map (lambda (p) - (if (eq? (provided-nom-src p) - (provided-src p)) - #f ; #f means "same as src" - (provided-nom-src p))) - all)) - (list->vector (map provided-src-name all)) - (list->vector (map provided-src all)) - (list->vector (map provided-name all)) - (length (cadr l)) - (length all)))) + (let* ([phase (car l)] + [all (append (cadr l) (caddr l))] + [protects (extract-protects phase)] + [unexported (extract-unexported phase)]) + (append + (list phase) + (if (and (not protects) + (not unexported)) + (list (void)) + (let ([unexported (or unexported + '(() ()))]) + (list (list->vector (cadr unexported)) + (length (cadr unexported)) + (list->vector (car unexported)) + (length (car unexported)) + protects))) + (list (list->vector/#f 0 (map provided-src-phase all)) + (list->vector/#f #f (map (lambda (p) + (if (eq? (provided-nom-src p) + (provided-src p)) + #f ; #f means "same as src" + (provided-nom-src p))) + all)) + (list->vector (map provided-src-name all)) + (list->vector (map provided-src all)) + (list->vector (map provided-name all)) + (length (cadr l)) + (length all))))) provides)) l)] [l (cons (length provides) l)] ; number of provide sets - [l (cons (extract-protects 0) l)] ; protects - [l (cons (extract-protects 1) l)] ; et protects - [l (list* (list->vector (car unexported)) (length (car unexported)) l)] ; indirect-provides - [l (list* (list->vector (cadr unexported)) (length (cadr unexported)) l)] ; indirect-syntax-provides - [l (list* (list->vector (caddr unexported)) (length (caddr unexported)) l)] ; indirect-et-provides + [l (cons (add1 (length syntax-bodies)) l)] [l (cons prefix l)] [l (cons dummy l)] [l (cons max-let-depth l)] diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 3c559ec62b..468c27fe21 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -181,19 +181,19 @@ (cdr (vector->list v)) (vector-ref v 0))) -; XXX Allocates unnessary list -(define (read-define-syntaxes mk v) - (mk (list-tail (vector->list v) 4) - (vector-ref v 0) - (vector-ref v 1) - (vector-ref v 2) - #;(vector-ref v 3))) - (define (read-define-syntax v) - (read-define-syntaxes make-def-syntaxes v)) + (make-def-syntaxes (list-tail (vector->list v) 4) + (vector-ref v 0) + (vector-ref v 1) + (vector-ref v 2) + (vector-ref v 3))) -(define (read-define-for-syntax v) - (read-define-syntaxes make-def-for-syntax v)) +(define (read-begin-for-syntax v) + (make-seq-for-syntax + (vector-ref v 0) + (vector-ref v 1) + (vector-ref v 2) + (vector-ref v 3))) (define (read-set! v) (make-assign (cadr v) (cddr v) (car v))) @@ -225,50 +225,65 @@ (lambda _ #t) (lambda _ #t))))) +(define (split-phase-data rest n) + (let loop ([n n] [rest rest] [phase-accum null]) + (cond + [(zero? n) + (values (reverse phase-accum) rest)] + [else + (let ([maybe-indirect (list-ref rest 1)]) + (if (void? maybe-indirect) + ;; no indirect or protect info: + (loop (sub1 n) + (list-tail rest 9) + (cons (take rest 9) phase-accum)) + ;; has indirect or protect info: + (loop (sub1 n) + (list-tail rest (+ 5 8)) + (cons (take rest (+ 5 8)) phase-accum))))]))) + (define (read-module v) (match v [`(,name ,srcname ,self-modidx ,lang-info ,functional? ,et-functional? ,rename ,max-let-depth ,dummy - ,prefix - ,indirect-et-provides ,num-indirect-et-provides - ,indirect-syntax-provides ,num-indirect-syntax-provides - ,indirect-provides ,num-indirect-provides - ,protects ,et-protects + ,prefix ,num-phases ,provide-phase-count . ,rest) - (let ([phase-data (take rest (* 8 provide-phase-count))]) - (match (list-tail rest (* 8 provide-phase-count)) - [`(,syntax-body ,body - ,requires ,syntax-requires ,template-requires ,label-requires - ,more-requires-count . ,more-requires) + (let*-values ([(phase-data rest-module) (split-phase-data rest provide-phase-count)] + [(bodies rest-module) (values (take rest-module num-phases) + (drop rest-module num-phases))]) + (match rest-module + [`(,requires ,syntax-requires ,template-requires ,label-requires + ,more-requires-count . ,more-requires) (make-mod name srcname self-modidx - prefix (let loop ([l phase-data]) - (if (null? l) - null - (let ([num-vars (list-ref l 6)] - [ps (for/list ([name (in-vector (list-ref l 5))] - [src (in-vector (list-ref l 4))] - [src-name (in-vector (list-ref l 3))] - [nom-src (or (list-ref l 2) - (in-cycle (in-value #f)))] - [src-phase (or (list-ref l 1) - (in-cycle (in-value #f)))] - [protected? (or (case (car l) - [(0) protects] - [(1) et-protects] - [else #f]) - (in-cycle (in-value #f)))]) - (make-provided name src src-name - (or nom-src src) - (if src-phase 1 0) - protected?))]) - (if (null? ps) - (loop (list-tail l 8)) - (cons - (list - (car l) - (take ps num-vars) - (drop ps num-vars)) - (loop (list-tail l 8))))))) + prefix + ;; provides: + (for/list ([l (in-list phase-data)]) + (let* ([phase (list-ref l 0)] + [has-info? (not (void? (list-ref l 1)))] + [delta (if has-info? 5 1)] + [num-vars (list-ref l (+ delta 6))] + [num-all (list-ref l (+ delta 7))] + [ps (for/list ([name (in-vector (list-ref l (+ delta 5)))] + [src (in-vector (list-ref l (+ delta 4)))] + [src-name (in-vector (list-ref l (+ delta 3)))] + [nom-src (or (list-ref l (+ delta 2)) + (in-cycle (in-value #f)))] + [src-phase (or (list-ref l (+ delta 1)) + (in-cycle (in-value 0)))] + [protected? (cond + [(or (not has-info?) + (not (list-ref l 5))) + (in-cycle (in-value #f))] + [else (list-ref l 5)])]) + (make-provided name src src-name + (or nom-src src) + src-phase + protected?))]) + (list + phase + (take ps num-vars) + (drop ps num-vars)))) + ;; requires: (list* (cons 0 requires) (cons 1 syntax-requires) @@ -276,20 +291,34 @@ (cons #f label-requires) (for/list ([(phase reqs) (in-list* more-requires 2)]) (cons phase reqs))) - (vector->list body) - (map (lambda (sb) - (match sb - [(? def-syntaxes?) sb] - [(? def-for-syntax?) sb] - [`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?) - ((if for-stx? - make-def-for-syntax - make-def-syntaxes) - (if (list? ids) ids (list ids)) expr prefix max-let-depth)])) - (vector->list syntax-body)) - (list (vector->list indirect-provides) - (vector->list indirect-syntax-provides) - (vector->list indirect-et-provides)) + ;; body: + (vector->list (last bodies)) + ;; syntax-bodies: add phase to each list, break apart + (for/list ([b (cdr (reverse bodies))] + [i (in-naturals 1)]) + (cons i + (for/list ([sb (in-vector b)]) + (match sb + [`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?) + (if for-stx? + (make-seq-for-syntax (list expr) prefix max-let-depth #f) + (make-def-syntaxes + (if (list? ids) ids (list ids)) expr prefix max-let-depth #f))] + [else (error 'zo-parse "bad phase ~a body element: ~e" i sb)])))) + ;; unexported: + (for/list ([l (in-list phase-data)] + #:when (not (void? (list-ref l 1)))) + (let* ([phase (list-ref l 0)] + [indirect-syntax + ;; could check: (list-ref l 2) should be size of vector: + (list-ref l 1)] + [indirect + ;; could check: (list-ref l 4) should be size of vector: + (list-ref l 3)]) + (list + phase + (vector->list indirect) + (vector->list indirect-syntax)))) max-let-depth dummy lang-info @@ -313,7 +342,7 @@ [(14) 'quote-syntax-type] [(15) 'define-values-type] [(16) 'define-syntaxes-type] - [(17) 'define-for-syntax-type] + [(17) 'begin-for-syntax-type] [(18) 'set-bang-type] [(19) 'boxenv-type] [(20) 'begin0-sequence-type] @@ -350,7 +379,7 @@ (cons 'free-id-info-type read-free-id-info) (cons 'define-values-type read-define-values) (cons 'define-syntaxes-type read-define-syntax) - (cons 'define-for-syntax-type read-define-for-syntax) + (cons 'begin-for-syntax-type read-begin-for-syntax) (cons 'set-bang-type read-set!) (cons 'boxenv-type read-boxenv) (cons 'require-form-type read-require) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 86c8052a15..d1ed02537d 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -80,7 +80,7 @@ [src (or/c module-path-index? #f)] [src-name symbol?] [nom-src any/c] ; should be (or/c module-path-index? #f) - [src-phase (or/c 0 1)] + [src-phase exact-nonnegative-integer?] [protected? boolean?])) (define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?] @@ -89,18 +89,19 @@ [ready? boolean?])) ; access binding via prefix array (which is on stack) (define-form-struct (seq form) ([forms (listof (or/c form? any/c))])) ; `begin' +(define-form-struct (seq-for-syntax form) ([forms (listof (or/c form? any/c))] ; `begin-for-syntax' + [prefix prefix?] + [max-let-depth exact-nonnegative-integer?] + [dummy (or/c toplevel? #f)])) ;; Definitions (top level or within module): -(define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? +(define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] [rhs (or/c expr? seq? any/c)])) -(define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? +(define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] [rhs (or/c expr? seq? any/c)] [prefix prefix?] - [max-let-depth exact-nonnegative-integer?])) -(define-form-struct (def-for-syntax form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? - [rhs (or/c expr? seq? any/c)] - [prefix prefix?] - [max-let-depth exact-nonnegative-integer?])) + [max-let-depth exact-nonnegative-integer?] + [dummy (or/c toplevel? #f)])) (define-form-struct (mod form) ([name symbol?] [srcname symbol?] @@ -111,10 +112,12 @@ (listof provided?)))] [requires (listof (cons/c (or/c exact-integer? #f) (listof module-path-index?)))] - [body (listof (or/c form? any/c))] - [syntax-body (listof (or/c def-syntaxes? def-for-syntax?))] - [unexported (list/c (listof symbol?) (listof symbol?) - (listof symbol?))] + [body (listof (or/c form? any/c))] + [syntax-bodies (listof (cons/c exact-positive-integer? + (listof (or/c def-syntaxes? seq-for-syntax?))))] + [unexported (listof (list/c exact-nonnegative-integer? + (listof symbol?) + (listof symbol?)))] [max-let-depth exact-nonnegative-integer?] [dummy toplevel?] [lang-info (or/c #f (vector/c module-path? symbol? any/c))] diff --git a/collects/deinprogramm/signature/module-begin.rkt b/collects/deinprogramm/signature/module-begin.rkt index 20c05553f8..ddcba39e81 100644 --- a/collects/deinprogramm/signature/module-begin.rkt +++ b/collects/deinprogramm/signature/module-begin.rkt @@ -174,7 +174,7 @@ ;; Lift out certain forms to make them visible to the module ;; expander: (syntax-case e2 (#%require #%provide - define-syntaxes define-values-for-syntax define-values begin + define-syntaxes begin-for-syntax define-values begin define-record-procedures define-record-procedures-2 define-record-procedures-parametric define-record-procedures-parametric-2 define-contract :) @@ -184,7 +184,7 @@ #`(begin #,e2 (frm e3s #,e1s #,def-ids))) ((define-syntaxes (id ...) . _) #`(begin #,e2 (frm e3s #,e1s (id ... . #,def-ids)))) - ((define-values-for-syntax . _) + ((begin-for-syntax . _) #`(begin #,e2 (frm e3s #,e1s #,def-ids))) ((begin b1 ...) (syntax-track-origin diff --git a/collects/drracket/private/syncheck/contract-traversal.rkt b/collects/drracket/private/syncheck/contract-traversal.rkt index 4c7e473826..095c90c71d 100644 --- a/collects/drracket/private/syncheck/contract-traversal.rkt +++ b/collects/drracket/private/syncheck/contract-traversal.rkt @@ -109,7 +109,7 @@ (call-give-up)] [(define-syntaxes (id ...) expr) (call-give-up)] - [(define-values-for-syntax (id ...) expr) + [(begin-for-syntax (id ...) expr) (call-give-up)] [(#%require rspec ...) (call-give-up)] diff --git a/collects/errortrace/stacktrace.rkt b/collects/errortrace/stacktrace.rkt index 0a616764ef..3db268756b 100644 --- a/collects/errortrace/stacktrace.rkt +++ b/collects/errortrace/stacktrace.rkt @@ -377,17 +377,15 @@ expr (rebuild disarmed-expr (list (cons #'rhs marked)))))] - [(define-values-for-syntax (name ...) rhs) + [(begin-for-syntax . exprs) top? - (let ([marked (with-mark expr - (annotate-named - (one-name (syntax (name ...))) - (syntax rhs) - (add1 phase)))]) - (rearm - expr - (rebuild disarmed-expr (list (cons #'rhs marked)))))] - + (rearm + expr + (annotate-seq disarmed-expr + (syntax exprs) + annotate-top + (add1 phase)))] + [(module name init-import mb) (syntax-case (disarm #'mb) () [(__plain-module-begin body ...) diff --git a/collects/gui-debugger/annotator.rkt b/collects/gui-debugger/annotator.rkt index cc96b2afc6..af0f87fb15 100644 --- a/collects/gui-debugger/annotator.rkt +++ b/collects/gui-debugger/annotator.rkt @@ -203,9 +203,8 @@ ] [(define-syntaxes (var ...) expr) stx] - [(define-values-for-syntax (var ...) expr) - ;; define-values-for-syntax's RHS is compile time, so treat it - ;; like define-syntaxes + [(begin-for-syntax . exprs) + ;; compile time, so treat it like define-syntaxes stx] [(begin . top-level-exprs) (quasisyntax/loc stx (begin #,@(map (lambda (expr) diff --git a/collects/lang/private/teach-module-begin.rkt b/collects/lang/private/teach-module-begin.rkt index 2741142f3e..22addf011d 100644 --- a/collects/lang/private/teach-module-begin.rkt +++ b/collects/lang/private/teach-module-begin.rkt @@ -180,7 +180,7 @@ ;; Lift out certain forms to make them visible to the module ;; expander: (syntax-case e2 (#%require #%provide - define-syntaxes define-values-for-syntax define-values begin + define-syntaxes begin-for-syntax define-values begin define-signature :) ((#%require . __) #`(begin #,e2 (frm e3s #,e1s #,def-ids))) @@ -188,7 +188,7 @@ #`(begin #,e2 (frm e3s #,e1s #,def-ids))) ((define-syntaxes (id ...) . _) #`(begin #,e2 (frm e3s #,e1s (id ... . #,def-ids)))) - ((define-values-for-syntax . _) + ((begin-for-syntax . _) #`(begin #,e2 (frm e3s #,e1s #,def-ids))) ((begin b1 ...) (syntax-track-origin diff --git a/collects/macro-debugger/model/trace.rkt b/collects/macro-debugger/model/trace.rkt index 527494b87d..db358c36a0 100644 --- a/collects/macro-debugger/model/trace.rkt +++ b/collects/macro-debugger/model/trace.rkt @@ -152,7 +152,7 @@ (eval/compile stx)] [(define-syntaxes . _) (eval/compile stx)] - [(define-values-for-syntax . _) + [(begin-for-syntax . _) (eval/compile stx)] [(define-values (id ...) . _) (with-syntax ([defvals (stx-car stx)] diff --git a/collects/mzlib/include.rkt b/collects/mzlib/include.rkt index 356f3260b1..350efea469 100644 --- a/collects/mzlib/include.rkt +++ b/collects/mzlib/include.rkt @@ -20,7 +20,10 @@ fn)) (string->path s))] [(-build-path elem ...) - (module-or-top-identifier=? #'-build-path build-path-stx) + (begin + (collect-garbage) + (module-identifier=? #'-build-path build-path-stx) + (module-or-top-identifier=? #'-build-path build-path-stx)) (let ([l (syntax-object->datum (syntax (elem ...)))]) (when (null? l) (raise-syntax-error diff --git a/collects/r6rs/main.rkt b/collects/r6rs/main.rkt index d4dd0dcb13..b5cc3f3a60 100644 --- a/collects/r6rs/main.rkt +++ b/collects/r6rs/main.rkt @@ -161,7 +161,7 @@ FIXME: (free-identifier=? id #'def))) (list #'define-values #'define-syntaxes - #'define-values-for-syntax)) + #'begin-for-syntax)) #`(begin #,a (library-body/defns . more))] [(#%require . _) ;; We allow `require' mixed with definitions, because it @@ -268,9 +268,8 @@ FIXME: (hash-set! table (syntax-e id) (cons (cons id phase) l))))))]) - (let-values ([(ids for-syntax-ids) (syntax-local-module-defined-identifiers)]) - (for-each (map-id 0) ids) - (for-each (map-id 1) for-syntax-ids)) + (for ([(phase ids) (in-hash (syntax-local-module-defined-identifiers))]) + (for-each (map-id phase) ids)) (for-each (lambda (l) (if (car l) (for-each (map-id (car l)) (cdr l)) diff --git a/collects/racket/private/define.rkt b/collects/racket/private/define.rkt index 9c955c88f3..8df9e8050d 100644 --- a/collects/racket/private/define.rkt +++ b/collects/racket/private/define.rkt @@ -7,7 +7,22 @@ "letstx-scheme.rkt" "stxcase-scheme.rkt" "stx.rkt" "qqstx.rkt" "norm-define.rkt")) - (#%provide define define-syntax define-for-syntax begin-for-syntax) + (#%provide define + define-syntax + define-values-for-syntax + define-for-syntax) + + (define-syntaxes (define-values-for-syntax) + (lambda (stx) + (syntax-case stx () + [(_ (id ...) expr) + (begin + (for-each (lambda (x) + (unless (identifier? x) + (raise-syntax-error #f "not an identifier" x stx))) + (syntax->list #'(id ...))) + #'(begin-for-syntax + (define-values (id ...) expr)))]))) (define-syntaxes (define define-syntax define-for-syntax) (let ([go @@ -18,64 +33,4 @@ (#,define-values-stx (#,id) #,rhs))))]) (values (lambda (stx) (go #'define-values stx)) (lambda (stx) (go #'define-syntaxes stx)) - (lambda (stx) (go #'define-values-for-syntax stx))))) - - (define-syntaxes (begin-for-syntax) - (lambda (stx) - (let ([ctx (syntax-local-context)]) - (unless (memq ctx '(module module-begin top-level)) - (raise-syntax-error #f "allowed only at the top-level or a module top-level" stx)) - (syntax-case stx () - [(_) #'(begin)] - [(_ elem) - (not (eq? ctx 'module-begin)) - (let ([e (local-transformer-expand/capture-lifts - #'elem - ctx - (syntax->list - #'(begin - define-values - define-syntaxes - define-values-for-syntax - set! - let-values - let*-values - letrec-values - lambda - case-lambda - if - quote - letrec-syntaxes+values - fluid-let-syntax - with-continuation-mark - #%expression - #%variable-reference - #%app - #%top - #%provide - #%require)))]) - (syntax-case* e (begin define-values define-syntaxes require require-for-template) - free-transformer-identifier=? - [(begin (begin v ...)) - #'(begin-for-syntax v ...)] - [(begin (define-values (id ...) expr)) - #'(define-values-for-syntax (id ...) expr)] - [(begin (require v ...)) - #'(require (for-syntax v ...))] - [(begin (define-syntaxes (id ...) expr)) - (raise-syntax-error - #f - "syntax definitions not allowed within begin-for-syntax" - #'elem)] - [(begin other) - #'(define-values-for-syntax () (begin other (values)))] - [(begin v ...) - #'(begin-for-syntax v ...)]))] - [(_ elem ...) - ;; We split up the elems so that someone else can - ;; worry about the fact that properly expanding the second - ;; things might depend somehow on the first thing. - ;; This also avoids a problem when `begin-for-syntax' is the - ;; only thing in a module body, and `module' has to expand - ;; it looking for #%module-begin. - (syntax/loc stx (begin (begin-for-syntax elem) ...))]))))) + (lambda (stx) (go #'define-values-for-syntax stx)))))) diff --git a/collects/racket/private/modbeg.rkt b/collects/racket/private/modbeg.rkt index d4930d049b..4169926c30 100644 --- a/collects/racket/private/modbeg.rkt +++ b/collects/racket/private/modbeg.rkt @@ -61,7 +61,7 @@ begin begin0 set! with-continuation-mark if #%app #%expression - define-values define-syntaxes define-values-for-syntax + define-values define-syntaxes begin-for-syntax module #%module-begin #%require #%provide @@ -98,7 +98,7 @@ (free-identifier=? i a)) (syntax->list (quote-syntax - (define-values define-syntaxes define-values-for-syntax + (define-values define-syntaxes begin-for-syntax module #%module-begin #%require #%provide)))) diff --git a/collects/racket/private/old-rp.rkt b/collects/racket/private/old-rp.rkt index 74f15547f2..14b78db0c5 100644 --- a/collects/racket/private/old-rp.rkt +++ b/collects/racket/private/old-rp.rkt @@ -5,28 +5,29 @@ (#%provide require require-for-syntax require-for-template require-for-label provide provide-for-syntax provide-for-label) - (define-values-for-syntax (rebuild-elem) - (lambda (stx elem sub pos loop ids) - ;; For sub-forms, we loop and reconstruct: - (for-each (lambda (id) - (unless (identifier? id) - (raise-syntax-error - #f - "expected an identifier" - stx - id))) - (syntax->list ids)) - (let rloop ([elem elem][pos pos]) - (if (syntax? elem) - (datum->syntax elem - (rloop (syntax-e elem) pos) - elem - elem) - (if (zero? pos) - (cons (loop (car elem)) - (cdr elem)) - (cons (car elem) - (rloop (cdr elem) (sub1 pos)))))))) + (begin-for-syntax + (define-values (rebuild-elem) + (lambda (stx elem sub pos loop ids) + ;; For sub-forms, we loop and reconstruct: + (for-each (lambda (id) + (unless (identifier? id) + (raise-syntax-error + #f + "expected an identifier" + stx + id))) + (syntax->list ids)) + (let rloop ([elem elem][pos pos]) + (if (syntax? elem) + (datum->syntax elem + (rloop (syntax-e elem) pos) + elem + elem) + (if (zero? pos) + (cons (loop (car elem)) + (cdr elem)) + (cons (car elem) + (rloop (cdr elem) (sub1 pos))))))))) (define-syntaxes (require require-for-syntax require-for-template require-for-label) diff --git a/collects/racket/private/reqprov.rkt b/collects/racket/private/reqprov.rkt index fa01fb7792..03a6eee8f2 100644 --- a/collects/racket/private/reqprov.rkt +++ b/collects/racket/private/reqprov.rkt @@ -636,36 +636,41 @@ (lambda (stx modes) (syntax-case stx () [(_) - (let-values ([(ids stx-ids) (syntax-local-module-defined-identifiers)] - [(same-ctx?) (lambda (free-identifier=?) - (lambda (id) - (free-identifier=? id - (datum->syntax - stx - (syntax-e id)))))]) - (append - (if (memq 1 modes) - (map (lambda (id) - (make-export id (syntax-e id) 1 #f stx)) - (filter (same-ctx? free-transformer-identifier=?) - stx-ids)) - null) - (if (or (null? modes) - (memq 0 modes)) - (map (lambda (id) - (make-export id (syntax-e id) 0 #f stx)) - (filter (lambda (id) - (and ((same-ctx? free-identifier=?) id) - (let-values ([(v id) (syntax-local-value/immediate - id - (lambda () (values #f #f)))]) - (not - (and (rename-transformer? v) - (syntax-property - (rename-transformer-target v) - 'not-provide-all-defined)))))) - ids)) - null)))])))) + (let* ([ht (syntax-local-module-defined-identifiers)] + [same-ctx? (lambda (free-identifier=?) + (lambda (id) + (free-identifier=? id + (datum->syntax + stx + (syntax-e id)))))] + [modes (if (null? modes) + '(0) + modes)]) + (apply + append + (map (lambda (mode) + (let* ([phase (and mode (+ mode (syntax-local-phase-level)))] + [same-ctx-in-phase? + (same-ctx? + (cond + [(eq? mode 0) free-identifier=?] + [(eq? mode 1) free-transformer-identifier=?] + [else (lambda (a b) + (free-identifier=? a b phase))]))]) + (map (lambda (id) + (make-export id (syntax-e id) mode #f stx)) + (filter (lambda (id) + (and (same-ctx-in-phase? id) + (let-values ([(v id) (syntax-local-value/immediate + id + (lambda () (values #f #f)))]) + (not + (and (rename-transformer? v) + (syntax-property + (rename-transformer-target v) + 'not-provide-all-defined)))))) + (hash-ref ht phase null))))) + modes)))])))) (define-syntax all-from-out (make-provide-transformer @@ -815,7 +820,7 @@ (equal? '(0) modes)) (raise-syntax-error #f - "allowed only for phase level 0" + "allowed only for relative phase level 0" stx)) (syntax-case stx () [(_ id) @@ -848,13 +853,14 @@ null] [else (cons (car ids) (loop (cdr ids)))]))))] ;; FIXME: we're building a list of all imports on every expansion - ;; of `syntax-out'. That could become expensive if `syntax-out' is + ;; of `struct-out'. That could become expensive if `struct-out' is ;; used a lot. - [avail-ids (append (let-values ([(ids _) (syntax-local-module-defined-identifiers)]) - ids) + [avail-ids (append (hash-ref (syntax-local-module-defined-identifiers) + (syntax-local-phase-level) + null) (let ([idss (syntax-local-module-required-identifiers #f #t)]) (if idss - (let ([a (assoc 0 idss)]) + (let ([a (assoc (syntax-local-phase-level) idss)]) (if a (cdr a) null)) diff --git a/collects/racket/private/stxcase-scheme.rkt b/collects/racket/private/stxcase-scheme.rkt index 5cc44492ba..a3b707b91c 100644 --- a/collects/racket/private/stxcase-scheme.rkt +++ b/collects/racket/private/stxcase-scheme.rkt @@ -25,16 +25,17 @@ names) #f))) - (define-values-for-syntax (check-sr-rules) - (lambda (stx kws) - (for-each (lambda (id) - (unless (identifier? id) - (raise-syntax-error - #f - "pattern must start with an identifier, found something else" - stx - id))) - (syntax->list kws)))) + (begin-for-syntax + (define-values (check-sr-rules) + (lambda (stx kws) + (for-each (lambda (id) + (unless (identifier? id) + (raise-syntax-error + #f + "pattern must start with an identifier, found something else" + stx + id))) + (syntax->list kws))))) ;; From Dybvig, mostly: (-define-syntax syntax-rules diff --git a/collects/scribble/doclang.rkt b/collects/scribble/doclang.rkt index 3d6ce9b7cd..1acbea935f 100644 --- a/collects/scribble/doclang.rkt +++ b/collects/scribble/doclang.rkt @@ -54,7 +54,7 @@ provide define-values define-syntaxes - define-values-for-syntax + begin-for-syntax #%require #%provide)))) #`(begin #,expanded (doc-begin m-id post-process exprs . body))] diff --git a/collects/scribble/private/lp.rkt b/collects/scribble/private/lp.rkt index ac8a10f61d..a565a293bd 100644 --- a/collects/scribble/private/lp.rkt +++ b/collects/scribble/private/lp.rkt @@ -50,7 +50,6 @@ [(rest ...) (if n #`((subscript #,(format "~a" n))) #`())]) - #`(begin (require (for-label for-label-mod ... ...)) #,@(if n diff --git a/collects/scribble/text/syntax-utils.rkt b/collects/scribble/text/syntax-utils.rkt index 794ea84b0b..16c249b3d1 100644 --- a/collects/scribble/text/syntax-utils.rkt +++ b/collects/scribble/text/syntax-utils.rkt @@ -7,7 +7,7 @@ (begin-for-syntax (define definition-ids ; ids that don't require forcing - (syntax->list #'(define-values define-syntaxes define-values-for-syntax + (syntax->list #'(define-values define-syntaxes begin-for-syntax require provide #%require #%provide))) (define stoplist (append definition-ids (kernel-form-identifier-list))) (define (definition-id? id) diff --git a/collects/scribblings/guide/proc-macros.scrbl b/collects/scribblings/guide/proc-macros.scrbl index b01ba6bb3f..fe251289f3 100644 --- a/collects/scribblings/guide/proc-macros.scrbl +++ b/collects/scribblings/guide/proc-macros.scrbl @@ -352,19 +352,20 @@ make all of these modes treat code consistently, Racket separates the binding spaces for different phases. To define a @racket[check-ids] function that can be referenced at -compile time, use @racket[define-for-syntax]: +compile time, use @racket[begin-for-syntax]: @racketblock/eval[ #:eval check-eval -(define-for-syntax (check-ids stx forms) - (for-each - (lambda (form) - (unless (identifier? form) - (raise-syntax-error #f - "not an identifier" - stx - form))) - (syntax->list forms))) +(begin-for-syntax + (define (check-ids stx forms) + (for-each + (lambda (form) + (unless (identifier? form) + (raise-syntax-error #f + "not an identifier" + stx + form))) + (syntax->list forms)))) ] With this for-syntax definition, then @racket[swap] works: @@ -446,6 +447,7 @@ the right-hand side of the inner @racket[define-syntax] is in the 2}. To import @racket[syntax-case] into that phase level, you would have to use @racket[(require (for-syntax (for-syntax racket/base)))] or, equivalently, @racket[(require (for-meta 2 racket/base))]. For example, + @codeblock|{ #lang racket/base (require ;; This provides the bindings for the definition diff --git a/collects/scribblings/raco/zo-struct.scrbl b/collects/scribblings/raco/zo-struct.scrbl index 1840367273..a08ebf4522 100644 --- a/collects/scribblings/raco/zo-struct.scrbl +++ b/collects/scribblings/raco/zo-struct.scrbl @@ -106,26 +106,28 @@ structures that are produced by @racket[zo-parse] and consumed by @defstruct+[(def-syntaxes form) ([ids (listof symbol?)] [rhs (or/c expr? seq? any/c)] [prefix prefix?] - [max-let-depth exact-nonnegative-integer?])] -@defstruct+[(def-for-syntax form) - ([ids (listof toplevel?)] - [rhs (or/c expr? seq? any/c)] + [max-let-depth exact-nonnegative-integer?] + [dummy (or/c toplevel? #f)])] +@defstruct+[(seq-for-syntax form) + ([forms (listof (or/c form? any/c))] [prefix prefix?] - [max-let-depth exact-nonnegative-integer?])] + [max-let-depth exact-nonnegative-integer?] + [dummy (or/c toplevel? #f)])] )]{ Represents a @racket[define-syntaxes] or - @racket[define-values-for-syntax] form. The @racket[rhs] expression - has its own @racket[prefix], which is pushed before evaluating - @racket[rhs]; the stack is restored after obtaining the result values. + @racket[begin-for-syntax] form. The @racket[rhs] expression or set of + @racket[forms] forms has its own @racket[prefix], which is pushed before evaluating + @racket[rhs] or the @racket[forms]; the stack is restored after obtaining the result values. The @racket[max-let-depth] field indicates the maximum size of the stack that will be created by @racket[rhs] (not counting - @racket[prefix]).} + @racket[prefix]). The @racket[dummy] variable is used to access the enclosing + namespace.} @defstruct+[(req form) ([reqs stx?] [dummy toplevel?])]{ Represents a top-level @racket[#%require] form (but not one in a @racket[module] form) with a sequence of specifications @racket[reqs]. - The @racket[dummy] variable is used to access to the top-level + The @racket[dummy] variable is used to access the top-level namespace.} @defstruct+[(seq form) ([forms (listof (or/c form? any/c))])]{ @@ -155,17 +157,17 @@ structures that are produced by @racket[zo-parse] and consumed by [requires (listof (cons/c (or/c exact-integer? #f) (listof module-path-index?)))] [body (listof (or/c form? any/c))] - [syntax-body (listof (or/c def-syntaxes? def-for-syntax?))] - [unexported (list/c (listof symbol?) - (listof symbol?) - (listof symbol?))] + [syntax-bodies (listof (cons/c exact-positive-integer? + (listof (or/c def-syntaxes? + seq-for-syntax?))))] + [unexported (listof (list/c exact-nonnegative-integer? + (listof symbol?) + (listof symbol?)))] [max-let-depth exact-nonnegative-integer?] [dummy toplevel?] [lang-info (or/c #f (vector/c module-path? symbol? any/c))] [internal-context (or/c #f #t stx?)])]{ - Represents a @racket[module] declaration. The @racket[body] forms use - @racket[prefix], rather than any prefix in place for the module - declaration itself (and each @racket[syntax-body] has its own prefix). + Represents a @racket[module] declaration. The @racket[provides] and @racket[requires] lists are each an association list from phases to exports or imports. In the case of @@ -173,15 +175,21 @@ structures that are produced by @racket[zo-parse] and consumed by variables, and another for exported syntax. In the case of @racket[requires], each phase maps to a list of imported module paths. - The @racket[body] field contains the module's run-time code, and - @racket[syntax-body] contains the module's compile-time code. After - each form in @racket[body] or @racket[syntax-body] is evaluated, the - stack is restored to its depth from before evaluating the form. + The @racket[body] field contains the module's run-time (i.e., phase + 0) code. The @racket[syntax-bodies] list has a list of forms for + each higher phase in the module body; the phases are in order + starting with phase 1. The @racket[body] forms use @racket[prefix], + rather than any prefix in place for the module declaration itself, + while members of lists in @racket[syntax-bodies] have their own + prefixes. After each form in @racket[body] or @racket[syntax-bodies] + is evaluated, the stack is restored to its depth from before + evaluating the form. - The @racket[unexported] list contains lists of symbols for unexported - definitions that can be accessed through macro expansion. The first - list is phase-0 variables, the second is phase-0 syntax, and the last - is phase-1 variables. + The @racket[unexported] list contains lists of symbols for + unexported definitions that can be accessed through macro expansion + and that are implemented through the forms in @racket[body] and + @racket[syntax-bodies]. Each list in @racket[unexported] starts + with a phase level. The @racket[max-let-depth] field indicates the maximum stack depth created by @racket[body] forms (not counting the @racket[prefix] @@ -202,8 +210,8 @@ structures that are produced by @racket[zo-parse] and consumed by ([name symbol?] [src (or/c module-path-index? #f)] [src-name symbol?] - [nom-mod (or/c module-path-index? #f)] - [src-phase (or/c 0 1)] + [nom-src (or/c module-path-index? #f)] + [src-phase exact-nonnegative-integer?] [protected? boolean?])]{ Describes an individual provided identifier within a @racket[mod] instance.} diff --git a/collects/scribblings/reference/eval-model.scrbl b/collects/scribblings/reference/eval-model.scrbl index 84e8433380..2e8550449f 100644 --- a/collects/scribblings/reference/eval-model.scrbl +++ b/collects/scribblings/reference/eval-model.scrbl @@ -556,15 +556,18 @@ effect on further program parsing, as described in @secref["intro-binding"]. Within a module, some definitions are shifted by a phase already; the -@racket[define-for-syntax] form is like @racket[define], but it -defines a variable at relative @tech{phase} 1, instead of relative -@tech{phase} 0. Thus, if the module is @tech{instantiate}d at phase 1, -the variables for @racket[define-for-syntax] are created at phase 2, +@racket[begin-for-syntax] form is similar to @racket[begin], but it +shifts expressions and definitions by a relative @tech{phase} 1. +Thus, if the module is @tech{instantiate}d at phase 1, +the variables defined with @racket[begin-for-syntax] are created at phase 2, and so on. Moreover, this relative phase acts as another layer of -prefixing, so that a @racket[define] of @racket[x] and a -@racket[define-for-syntax] of @racket[x] can co-exist in a module -without colliding. Again, the higher phases are mainly related to -program parsing, instead of normal evaluation. +prefixing, so that a @racket[define] of @racket[x] and a +@racket[begin-for-syntax]-wrapped +@racket[define] of @racket[x] can co-exist in a module +without colliding. A @racket[begin-for-syntax] form can be nested +within a @racket[begin-for-syntax] form, in which case definitions and +expressions are in relative @tech{phase} 2, and so on. Higher phases are +mainly related to program parsing, instead of normal evaluation. If a module @tech{instantiate}d at @tech{phase} @math{n} @racket[require]s another module, then the @racket[require]d module is @@ -588,7 +591,7 @@ module forms (see @secref["mod-parse"]), and are, again, conceptually distinguished by prefixes. Top-level variables can exist in multiple phases in the same way as -within modules. For example, @racket[define-for-syntax] creates a +within modules. For example, @racket[define] within @racket[begin-for-syntax] creates a @tech{phase} 1 variable. Furthermore, reflective operations like @racket[make-base-namespace] and @racket[eval] provide access to top-level variables in higher @tech{phases}, while module diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 0da27eea60..efbdd493a1 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -473,8 +473,9 @@ to a top-level definition. A compile-time expression in a @racket[letrec-syntaxes+values] or @racket[define-syntaxes] binding is lifted to a @racket[let] wrapper around the corresponding right-hand side of the binding. A compile-time expression within -@racket[begin-for-syntax] is lifted to a @racket[define-for-syntax] -declaration just before the requesting expression. +@racket[begin-for-syntax] is lifted to a @racket[define] +declaration just before the requesting expression within the +@racket[begin-for-syntax]. Other syntactic forms can capture lifts by using @racket[local-expand/capture-lifts] or @@ -524,9 +525,8 @@ then the @exnraise[exn:fail:contract].} Lifts a @racket[#%require] form corresponding to @racket[raw-require-spec] (either as a @tech{syntax object} or datum) -to the top-level or to the top of the module currently being expanded, -wrapping it with @racket[for-meta] if the current expansion context is -not @tech{phase level} 0. +to the top-level or to the top of the module currently being expanded + or to an enclosing @racket[begin-for-syntax].. The resulting syntax object is the same as @racket[stx], except that a fresh @tech{syntax mark} is added. The same @tech{syntax mark} is @@ -551,7 +551,7 @@ by the macro expander can prevent access to the new imports. Lifts a @racket[#%provide] form corresponding to @racket[raw-provide-spec-stx] to the top of the module currently being -expanded. +expanded or to an enclosing @racket[begin-for-syntax]. @transform-time[] If the current expression being transformed is not within a @racket[module] form, or if it is not a run-time expression, @@ -732,20 +732,20 @@ Returns @racket[#t] while a @tech{provide transformer} is running (see @racket[#%provide] is expanded, @racket[#f] otherwise.} -@defproc[(syntax-local-module-defined-identifiers) - (values (listof identifier?) (listof identifier?))]{ +@defproc[(syntax-local-module-defined-identifiers) (and/c hash? immutable?)]{ Can be called only while @racket[syntax-local-transforming-module-provides?] returns @racket[#t]. -It returns two lists of identifiers corresponding to all definitions +It returns a hash table mapping a @tech{phase-level} number (such as +@racket[0]) to a list of all definitions at that @tech{phase level} within the module being expanded. This information is used for implementing @racket[provide] sub-forms like @racket[all-defined-out]. -The first result list corresponds to @tech{phase} 0 (i.e., normal) -definitions, and the second corresponds to @tech{phase} -1 (i.e., -for-syntax) definitions.} +Beware that the @tech{phase-level} keys are absolute relative to the +enclosing module, and not relative to the current transformer phase +level as reported by @racket[syntax-local-phase-level].} @defproc[(syntax-local-module-required-identifiers @@ -769,7 +769,11 @@ with a @racket[phase-level] shift, of all shifts if When an identifier is renamed on import, the result association list includes the identifier by its internal name. Use @racket[identifier-binding] to obtain more information about the -identifier.} +identifier. + +Beware that the @tech{phase-level} keys are absolute relative to the +enclosing module, and not relative to the current transformer phase +level as reported by @racket[syntax-local-phase-level].} @deftogether[( @defthing[prop:liberal-define-context struct-type-property?] diff --git a/collects/scribblings/reference/syntax-model.scrbl b/collects/scribblings/reference/syntax-model.scrbl index 24f768dba4..0c0aa42eb5 100644 --- a/collects/scribblings/reference/syntax-model.scrbl +++ b/collects/scribblings/reference/syntax-model.scrbl @@ -11,19 +11,19 @@ The syntax of a Racket program is defined by @itemize[ - @item{a @deftech{read} phase that processes a character stream into a + @item{a @deftech{read} pass that processes a character stream into a @tech{syntax object}; and} - @item{an @deftech{expand} phase that processes a syntax object to + @item{an @deftech{expand} pass that processes a syntax object to produce one that is fully parsed.} ] -For details on the @tech{read} phase, see @secref["reader"]. Source +For details on the @tech{read} pass, see @secref["reader"]. Source code is normally read in @racket[read-syntax] mode, which produces a @tech{syntax object}. -The @tech{expand} phase recursively processes a @tech{syntax object} +The @tech{expand} pass recursively processes a @tech{syntax object} to produce a complete @tech{parse} of the program. @tech{Binding} information in a @tech{syntax object} drives the @tech{expansion} process, and when the @tech{expansion} process encounters a @@ -186,7 +186,7 @@ the binding (according to @racket[free-identifier=?]) matters.} @racketgrammar*[ #:literals (#%expression module #%plain-module-begin begin #%provide - define-values define-syntaxes define-values-for-syntax + define-values define-syntaxes begin-for-syntax #%require #%plain-lambda case-lambda if begin begin0 let-values letrec-values set! quote-syntax quote with-continuation-mark @@ -196,13 +196,14 @@ the binding (according to @racket[free-identifier=?]) matters.} (module id name-id (#%plain-module-begin module-level-form ...)) - (begin top-level-form ...)] + (begin top-level-form ...) + (begin-for-syntax top-level-form ...)] [module-level-form general-top-level-form - (#%provide raw-provide-spec ...)] + (#%provide raw-provide-spec ...) + (begin-for-syntax module-level-form ...)] [general-top-level-form expr (define-values (id ...) expr) (define-syntaxes (id ...) expr) - (define-values-for-syntax (id ...) expr) (#%require raw-require-spec ...)] [expr id (#%plain-lambda formals expr ...+) @@ -243,15 +244,14 @@ binding to the @racket[#%plain-lambda] of the syntactic-form names refer to the bindings defined in @secref["syntax"]. -Only @tech{phase levels} 0 and 1 are relevant for the parse of a -program (though the @racket[_datum] in a @racket[quote-syntax] form -preserves its information for all @tech{phase level}s). In particular, -the relevant @tech{phase level} is 0, except for the @racket[_expr]s -in a @racket[define-syntax], @racket[define-syntaxes], -@racket[define-for-syntax], or @racket[define-values-for-syntax] form, -in which case the relevant @tech{phase level} is 1 (for which -comparisons are made using @racket[free-transformer-identifier=?] -instead of @racket[free-identifier=?]). +In a fully expanded program for a namespace whose @tech{base phase} is +0, the relevant @tech{phase level} for a binding in the program is +@math{N} if the bindings has @math{N} surrounding +@racket[begin-for-syntax] and @racket[define-syntaxes] forms---not +counting any @racket[begin-for-syntax] forms that wrap a +@racket[module] form for the body of the @racket[module]. The +@racket[_datum] in a @racket[quote-syntax] form, however, always +preserves its information for all @tech{phase level}s. In addition to the grammar above, @racket[letrec-syntaxes+values] can appear in a fully local-expanded expression, as can @@ -427,11 +427,13 @@ core syntactic forms are encountered: at @tech{phase level} 0 (i.e., the @tech{base environment} is extended).} - @item{When a @racket[define-for-syntax] or - @racket[define-values-for-syntax] form is encountered at the - top level or module level, bindings are introduced as for - @racket[define-values], but at @tech{phase level} 1 (i.e., the - @tech{transformer environment} is extended).} + @item{When a @racket[begin-for-syntax] form is encountered at the top + level or module level, bindings are introduced as for + @racket[define-values] and @racket[define-syntaxes], but at + @tech{phase level} 1 (i.e., the @tech{transformer environment} + is extended). More generally, @racket[begin-for-syntax] forms + can be nested, an each @racket[begin-for-syntax] shifts its + body definition by one @tech{phase level}.} @item{When a @racket[let-values] form is encountered, the body of the @racket[let-values] form is extended (by creating new @@ -578,11 +580,11 @@ to its handling of @racket[define-syntaxes]. A level @math{n} (not just 0), in which case the expression for the @tech{transformer binding} is expanded at @tech{phase level} @math{n+1}. -The expression in a @racket[define-for-syntax] or -@racket[define-values-for-syntax] form is expanded and evaluated in -the same way as for @racket[syntax]. However, the introduced binding -is a variable binding at @tech{phase level} 1 (not a @tech{transformer -binding} at @tech{phase level} 0). +The expressions in a @racket[begin-for-syntax] form are expanded and +evaluated in the same way as for @racket[define-syntaxes]. However, +any introduced bindings from definition within +@racket[begin-for-syntax] are at @tech{phase level} 1 (not a +@tech{transformer binding} at @tech{phase level} 0). @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @subsection[#:tag "partial-expansion"]{Partial Expansion} @@ -654,10 +656,10 @@ the @racket[letrec-syntaxes+values] form. A @racket[require] form not only introduces @tech{bindings} at expansion time, but also @deftech{visits} the referenced module when -it is encountered by the expander. That is, the expander -instantiates any @racket[define-for-syntax]ed variables defined -in the module, and also evaluates all expressions for -@racket[define-syntaxes] @tech{transformer bindings}. +it is encountered by the expander. That is, the expander instantiates +any variables defined in the module within @racket[begin-for-syntax], +and it also evaluates all expressions for @racket[define-syntaxes] +@tech{transformer bindings}. Module @tech{visits} propagate through @racket[require]s in the same way as module @tech{instantiation}. Moreover, when a module is @@ -673,8 +675,8 @@ implicitly @tech{visit}ed. Thus, when the expander encounters @tech{instantiate}s the required module at @tech{phase} 1, in addition to adding bindings at @tech{phase level} 1 (i.e., the @tech{transformer environment}). Similarly, the expander immediately -evaluates any @racket[define-values-for-syntax] form that it -encounters. +evaluates any form that it encounters within +@racket[begin-for-syntax]. @tech{Phases} beyond 0 are @tech{visit}ed on demand. For example, when the right-hand side of a @tech{phase}-0 @racket[let-syntax] is to diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 2f1245f317..3ec647c7d6 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -152,18 +152,26 @@ action depends on the shape of the form: out into the module's body and immediately processed in place of the @racket[begin].} - @item{If it is a @racket[define-syntaxes] or - @racket[define-values-for-syntax] form, then the right-hand side is + @item{If it is a @racket[define-syntaxes] form, then the right-hand side is evaluated (in @tech{phase} 1), and the binding is immediately installed for further partial expansion within the module. Evaluation of the right-hand side is @racket[parameterize]d to set @racket[current-namespace] as in @racket[let-syntax].} - @item{If the form is a @racket[require] form, bindings are introduced + @item{If it is a @racket[begin-for-syntax] form, then the body is + expanded (in @tech{phase} 1) and evaluated. Expansion within a + @racket[begin-for-syntax] form proceeds with the same + partial-expansion process as for a @racket[module] body, but in a + higher @tech{phase}, and saving all @racket[#%provide] forms for all + phases until the end of the @racket[module]'s expansion. Evaluation + of the body is @racket[parameterize]d to set + @racket[current-namespace] as in @racket[let-syntax].} + + @item{If the form is a @racket[#%require] form, bindings are introduced immediately, and the imported modules are @tech{instantiate}d or @tech{visit}ed as appropriate.} - @item{If the form is a @racket[provide] form, then it is recorded for + @item{If the form is a @racket[#%provide] form, then it is recorded for processing after the rest of the body.} @item{If the form is a @racket[define-values] form, then the binding @@ -177,7 +185,9 @@ action depends on the shape of the form: After all @racket[form]s have been partially expanded this way, then the remaining expression forms (including those on the right-hand side -of a definition) are expanded in an expression context. +of a definition) are expanded in an expression context. Finally, +@racket[#%provide] forms are processed in the order in which they +appear (independent of @tech{phase}) in the expanded module. The scope of all imported identifiers covers the entire module body, as does the scope of any identifier defined within the module body. @@ -707,7 +717,10 @@ A @racket[provide-spec] indicates one or more bindings to provide. For each exported binding, the external name is a symbol that can be different from the symbolic form of the identifier that is bound within the module. Also, each export is drawn from a particular -@tech{phase level} and exported at the same @tech{phase level}. +@tech{phase level} and exported at the same @tech{phase level}; by +default, the relevant phase level is the number of +@racket[begin-for-syntax] forms that enclose the @racket[provide] +form. The syntax of @racket[provide-spec] can be extended via @racket[define-provide-syntax], but the pre-defined forms are as @@ -733,7 +746,7 @@ follows. @racket[make-rename-transformer] for more information.} @defsubform[(all-defined-out)]{ Exports all identifiers that are - defined at @tech{phase level} 0 or @tech{phase level} 1 within the + defined at the relevant @tech{phase level} within the exporting module, and that have the same lexical context as the @racket[(all-defined-out)] form, excluding bindings to @tech{rename transformers} where the target identifier has the @@ -776,7 +789,7 @@ follows. @defsubform[(rename-out [orig-id export-id] ...)]{ Exports each @racket[orig-id], which must be @tech{bound} within the module at - @tech{phase level} 0. The symbolic name for each export is + the relevant @tech{phase level}. The symbolic name for each export is @racket[export-id] instead @racket[orig-d]. @defexamples[#:eval (syntax-eval) @@ -821,8 +834,8 @@ follows. @defsubform[(struct-out id)]{Exports the bindings associated with a structure type @racket[id]. Typically, @racket[id] is bound with @racket[(struct id ....)]; more generally, @racket[id] must have a - @tech{transformer binding} of structure-type information at - @tech{phase level} 0; see @secref["structinfo"]. Furthermore, for + @tech{transformer binding} of structure-type information at the relevant + @tech{phase level}; see @secref["structinfo"]. Furthermore, for each identifier mentioned in the structure-type information, the enclosing module must define or import one identifier that is @racket[free-identifier=?]. If the structure-type information @@ -877,17 +890,21 @@ follows. @specsubform[#:literals (for-meta) (for-meta phase-level provide-spec ...)]{ Like the union of the - @racket[provide-spec]s, but adjusted to apply to @tech{phase level} - specified by @racket[phase-level] (where @racket[#f] corresponds to the - @tech{label phase level}). In particular, an @racket[_id] or @racket[rename-out] form as - a @racket[provide-spec] refers to a binding at @racket[phase-level], an - @racket[all-defined-out] exports only @racket[phase-level] - definitions, and an @racket[all-from-out] exports bindings - imported with a shift by @racket[phase-level]. + @racket[provide-spec]s, but adjusted to apply to the @tech{phase + level} specified by @racket[phase-level] relative to the current + phase level (where @racket[#f] corresponds to the @tech{label phase + level}). In particular, an @racket[_id] or @racket[rename-out] form + as a @racket[provide-spec] refers to a binding at + @racket[phase-level] relative to the current level, an + @racket[all-defined-out] exports only definitions at + @racket[phase-level] relative to the current phase level, and an + @racket[all-from-out] exports bindings imported with a shift by + @racket[phase-level]. @examples[#:eval (syntax-eval) (module nest racket - (define-for-syntax eggs 2) + (begin-for-syntax + (define eggs 2)) (define chickens 3) (provide (for-syntax eggs) chickens)) @@ -905,7 +922,8 @@ follows. chickens)) (module nest2 racket - (define-for-syntax eggs 2) + (begin-for-syntax + (define eggs 2)) (provide (for-syntax eggs))) (require (for-meta 2 racket/base) (for-syntax 'nest2)) @@ -2138,9 +2156,9 @@ a @racket[define-syntaxes] form introduces local bindings. Like @racket[define], except that the binding is at @tech{phase level} 1 instead of @tech{phase level} 0 relative to its context. The expression for the binding is also at @tech{phase level} 1. (See -@secref["id-model"] for information on @tech{phase levels}.) -Evaluation of @racket[expr] side is @racket[parameterize]d to set -@racket[current-namespace] as in @racket[let-syntax]. +@secref["id-model"] for information on @tech{phase levels}.) The form +is a shorthand for @racket[(begin-for-syntax (define id expr))] or +@racket[(begin-for-syntax (define (head args) body ...+))]. Within a module, bindings introduced by @racket[define-for-syntax] must appear before their uses or in the same @@ -2275,18 +2293,24 @@ in tail position only if no @racket[body]s are present. @defform[(begin-for-syntax form ...)]{ -Allowed only in a @tech{top-level context} or @tech{module context}. -Each @racket[form] is partially expanded (see -@secref["partial-expansion"]) to determine one of the following -classifications: +Allowed only in a @tech{top-level context} or @tech{module context}, +shifts the @tech{phase level} of each @racket[form] by one: @itemize[ - @item{@racket[define] or @racket[define-values] form: converted to - a @racket[define-values-for-syntax] form.} + @item{expressions reference bindings at a @tech{phase level} one + greater than in the context of the @racket[begin-for-syntax] + form;} - @item{@racket[require] form: content is wrapped with - @racket[for-syntax].} + @item{@racket[define], @racket[define-values], + @racket[define-syntax], and @racket[define-syntaxes] forms bind + at a @tech{phase level} one greater than in the context of the + @racket[begin-for-syntax] form;} + + @item{in @racket[require] and @racket[provide] forms, the default + @tech{phase level} is greater, which is roughly like wrapping + the content of the @racket[require] form with + @racket[for-syntax];} @item{expression form @racket[_expr]: converted to @racket[(define-values-for-syntax () (begin _expr (values)))], which @@ -2296,6 +2320,12 @@ classifications: ] +See also @racket[module] for information about expansion order and +partial expansion for @racket[begin-for-syntax] within a module +context. Evaluation of an @racket[expr] within +@racket[begin-for-syntax] is @racket[parameterize]d to set +@racket[current-namespace] as in @racket[let-syntax]. + } @;------------------------------------------------------------------------ diff --git a/collects/syntax/kerncase.rkt b/collects/syntax/kerncase.rkt index a561fd9ba4..6a8f44cd62 100644 --- a/collects/syntax/kerncase.rkt +++ b/collects/syntax/kerncase.rkt @@ -21,7 +21,7 @@ begin begin0 set! with-continuation-mark if #%plain-app #%expression - define-values define-syntaxes define-values-for-syntax + define-values define-syntaxes begin-for-syntax module #%plain-module-begin #%require #%provide @@ -78,7 +78,7 @@ begin0 define-values define-syntaxes - define-values-for-syntax + begin-for-syntax set! let-values letrec-values diff --git a/collects/tests/compiler/zo.rkt b/collects/tests/compiler/zo.rkt new file mode 100644 index 0000000000..84b3bd6951 --- /dev/null +++ b/collects/tests/compiler/zo.rkt @@ -0,0 +1,40 @@ +#lang racket/base +(require racket/pretty + compiler/zo-parse + compiler/zo-marshal + compiler/decompile) + +(define ex-mod1 + '(module m racket + (begin-for-syntax + (define fs 10) + (list fs)) + (define-syntax (m stx) + #'10) + (m) + (begin-for-syntax + (list fs)))) + +(define ex-mod2 + '(module m racket + (define t 8) + (define s 10) + (provide t (protect-out s)))) + +(define (check ex-mod) + (let ([c (parameterize ([current-namespace (make-base-namespace)]) + (compile ex-mod))]) + (let ([o (open-output-bytes)]) + (write c o) + (let ([p (zo-parse (open-input-bytes (get-output-bytes o)))]) + (let ([b (zo-marshal p)]) + (let ([p2 (zo-parse (open-input-bytes b))] + [to-string (lambda (p) + (let ([o (open-output-bytes)]) + (print p o) + (get-output-string o)))]) + (unless (equal? (to-string p) (to-string p2)) + (error 'zo "failed on example: ~e" ex-mod)))))))) + +(check ex-mod1) +(check ex-mod2) diff --git a/collects/tests/racket/module.rktl b/collects/tests/racket/module.rktl index f17c36a7bd..b8e99d6352 100644 --- a/collects/tests/racket/module.rktl +++ b/collects/tests/racket/module.rktl @@ -194,6 +194,40 @@ (eval `(require 'f)) (test (list* 'd 'b finished) values l))))) +(let* ([n (make-base-namespace)] + [l null] + [here (lambda (v) + (set! l (cons v l)))]) + (parameterize ([current-namespace n]) + (eval `(module a racket/base + (require (for-syntax racket/base) + (for-meta 2 racket/base)) + (define a 1) + (define-syntax (a-macro stx) #'-1) + (begin-for-syntax + (,here 'pma)) + (begin-for-syntax + (,here 'ma) + (define a-meta 10) + (define-syntax (a-meta-macro stx) #'-1) + (begin-for-syntax + (define a-meta-meta 100) + (,here 'mma))) + (,here 'a) + (provide a a-macro (for-syntax a-meta-macro)))) + (test '(ma mma pma) values l) + (set! l null) + (dynamic-require ''a #f) + (test '(a) values l) + (eval `10) + (test '(a) values l) + (dynamic-require ''a 0) ; => 'a is available... + (eval `10) + (test '(ma pma a) values l) + (eval '(begin-for-syntax)) ; triggers phase-1 visit => phase-2 instantiate + (test '(mma ma pma a) values l) + (void))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Check redundant import and re-provide diff --git a/collects/typed-racket/base-env/base-env.rkt b/collects/typed-racket/base-env/base-env.rkt index 8c4d4a2ead..d80eae8855 100644 --- a/collects/typed-racket/base-env/base-env.rkt +++ b/collects/typed-racket/base-env/base-env.rkt @@ -1293,7 +1293,7 @@ [syntax-local-make-delta-introducer (-> (-Syntax Sym) (-> (-Syntax Sym) (-Syntax Sym)))] [syntax-local-transforming-module-provides? (-> B)] -[syntax-local-module-defined-identifiers (-> (-values (list (-Syntax Sym) (-Syntax Sym))))] +[syntax-local-module-defined-identifiers (-> (-HT (Un B -Int) (-lst (-Syntax Sym))))] [syntax-local-module-required-identifiers (-> (-opt -Module-Path) (Un B -Int) (-lst (-pair (-opt -Int) (-lst (-Syntax Sym)))))] ;Section 11.5 diff --git a/collects/typed-racket/typecheck/tc-toplevel.rkt b/collects/typed-racket/typecheck/tc-toplevel.rkt index 4d991585e2..d388f711ad 100644 --- a/collects/typed-racket/typecheck/tc-toplevel.rkt +++ b/collects/typed-racket/typecheck/tc-toplevel.rkt @@ -187,7 +187,7 @@ [(#%require . _) (void)] [(#%provide . _) (void)] [(define-syntaxes . _) (void)] - [(define-values-for-syntax . _) (void)] + [(begin-for-syntax . _) (void)] ;; FIXME - we no longer need these special cases ;; these forms are handled in pass1 diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index 1724ad7830..9f1649fb30 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -1,3 +1,14 @@ +Version 5.1.3.7 +Generalized begin-with-syntax to allow phase-N definitions, + both variable and syntax, within a module for all N >= 0; + removed define-values-for-syntax from fully expanded forms; + added begin-with-syntax to fully expanded forms +Changed syntax-local-module-defined-identifiers to return + a table for all phases instead of just two values +compiler/zo-structs: removed def-for-syntax, added + seq-for-syntax, changed some mod fields, added field to + def-syntaxes + Version 5.1.3.4 Add support for the collection links file, including (find-system-path 'links-file) and the raco link command diff --git a/src/racket/include/schthread.h b/src/racket/include/schthread.h index a5186c5235..48047efb84 100644 --- a/src/racket/include/schthread.h +++ b/src/racket/include/schthread.h @@ -150,7 +150,7 @@ typedef struct Thread_Local_Variables { struct Scheme_Object *cached_mod_beg_stx_; struct Scheme_Object *cached_dv_stx_; struct Scheme_Object *cached_ds_stx_; - struct Scheme_Object *cached_dvs_stx_; + struct Scheme_Object *cached_bfs_stx_; int cached_stx_phase_; struct Scheme_Object *cwv_stx_; int cwv_stx_phase_; @@ -488,7 +488,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define cached_mod_beg_stx XOA (scheme_get_thread_local_variables()->cached_mod_beg_stx_) #define cached_dv_stx XOA (scheme_get_thread_local_variables()->cached_dv_stx_) #define cached_ds_stx XOA (scheme_get_thread_local_variables()->cached_ds_stx_) -#define cached_dvs_stx XOA (scheme_get_thread_local_variables()->cached_dvs_stx_) +#define cached_bfs_stx XOA (scheme_get_thread_local_variables()->cached_bfs_stx_) #define cached_stx_phase XOA (scheme_get_thread_local_variables()->cached_stx_phase_) #define cwv_stx XOA (scheme_get_thread_local_variables()->cwv_stx_) #define cwv_stx_phase XOA (scheme_get_thread_local_variables()->cwv_stx_phase_) diff --git a/src/racket/src/compenv.c b/src/racket/src/compenv.c index 9544fb0b56..0505864fde 100644 --- a/src/racket/src/compenv.c +++ b/src/racket/src/compenv.c @@ -1883,7 +1883,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, /* Try syntax table: */ if (modname) { - val = scheme_module_syntax(modname, env->genv, find_id); + val = scheme_module_syntax(modname, env->genv, find_id, SCHEME_INT_VAL(mod_defn_phase)); if (val && !(flags & SCHEME_NO_CERT_CHECKS)) scheme_check_accessible_in_module(genv, env->insp, in_modidx, find_id, src_find_id, NULL, NULL, rename_insp, diff --git a/src/racket/src/compile.c b/src/racket/src/compile.c index 8648ae2cb0..b015547653 100644 --- a/src/racket/src/compile.c +++ b/src/racket/src/compile.c @@ -108,8 +108,8 @@ static Scheme_Object *quote_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env * static Scheme_Object *quote_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); static Scheme_Object *define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); static Scheme_Object *define_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *define_for_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *define_for_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *begin_for_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *begin_for_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); static Scheme_Object *letrec_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); static Scheme_Object *letrec_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); @@ -273,9 +273,9 @@ void scheme_init_compile (Scheme_Env *env) quote_syntax_expand), env); scheme_add_global_keyword("define-syntaxes", scheme_define_syntaxes_syntax, env); - scheme_add_global_keyword("define-values-for-syntax", - scheme_make_compiled_syntax(define_for_syntaxes_syntax, - define_for_syntaxes_expand), + scheme_add_global_keyword("begin-for-syntax", + scheme_make_compiled_syntax(begin_for_syntax_syntax, + begin_for_syntax_expand), env); scheme_add_global_keyword("letrec-syntaxes+values", scheme_make_compiled_syntax(letrec_syntaxes_syntax, @@ -3135,7 +3135,7 @@ single_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info form_name = SCHEME_STX_CAR(form); if (simplify && (erec[drec].depth == -1)) { - /* FIXME: this needs EXPAND_OBSERVE callbacks. */ + /* FIXME [Ryan?]: this needs EXPAND_OBSERVE callbacks? */ expr = scheme_stx_track(expr, form, form_name); SCHEME_EXPAND_OBSERVE_TAG(erec[drec].observer,expr); return expr; @@ -3224,6 +3224,19 @@ quote_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Inf /* define-syntaxes */ /**********************************************************************/ +static void prep_exp_env_compile_rec(Scheme_Compile_Info *rec, int drec) +{ + rec[0].comp = 1; + rec[0].dont_mark_local_use = 0; + rec[0].resolve_module_ids = 0; + rec[0].value_name = NULL; + rec[0].observer = NULL; + rec[0].pre_unwrapped = 0; + rec[0].testing_constantness = 0; + rec[0].env_already = 0; + rec[0].comp_flags = rec[drec].comp_flags; +} + static Scheme_Object *stx_val(Scheme_Object *name, Scheme_Object *_env) { Scheme_Env *env = (Scheme_Env *)_env; @@ -3233,7 +3246,7 @@ static Scheme_Object *stx_val(Scheme_Object *name, Scheme_Object *_env) static Scheme_Object * do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, int for_stx) + Scheme_Compile_Info *rec, int drec) { Scheme_Object *names, *code, *dummy; Scheme_Object *val, *vec; @@ -3248,27 +3261,13 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, scheme_prepare_exp_env(env->genv); scheme_prepare_compile_env(env->genv->exp_env); - if (!for_stx) - names = scheme_named_map_1(NULL, stx_val, names, (Scheme_Object *)env->genv); + names = scheme_named_map_1(NULL, stx_val, names, (Scheme_Object *)env->genv); exp_env = scheme_new_comp_env(env->genv->exp_env, env->insp, 0); dummy = scheme_make_environment_dummy(env); - - rec1.comp = 1; - rec1.dont_mark_local_use = 0; - rec1.resolve_module_ids = 0; - rec1.value_name = NULL; - rec1.observer = NULL; - rec1.pre_unwrapped = 0; - rec1.testing_constantness = 0; - rec1.env_already = 0; - rec1.comp_flags = rec[drec].comp_flags; - if (for_stx) { - names = defn_targets_syntax(names, exp_env, &rec1, 0); - scheme_compile_rec_done_local(&rec1, 0); - } + prep_exp_env_compile_rec(&rec1, 0); val = scheme_compile_expr_lift_to_let(code, exp_env, &rec1, 0); @@ -3278,7 +3277,7 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, SCHEME_VEC_ELS(vec)[2] = names; SCHEME_VEC_ELS(vec)[3] = val; - vec->type = (for_stx ? scheme_define_for_syntax_type : scheme_define_syntaxes_type); + vec->type = scheme_define_syntaxes_type; scheme_merge_undefineds(exp_env, env); @@ -3289,14 +3288,7 @@ static Scheme_Object * define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) { - return do_define_syntaxes_syntax(form, env, rec, drec, 0); -} - -static Scheme_Object * -define_for_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return do_define_syntaxes_syntax(form, env, rec, drec, 1); + return do_define_syntaxes_syntax(form, env, rec, drec); } static Scheme_Object * @@ -3328,9 +3320,91 @@ define_syntaxes_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Ex } static Scheme_Object * -define_for_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +begin_for_syntax_expand(Scheme_Object *orig_form, Scheme_Comp_Env *in_env, Scheme_Expand_Info *rec, int drec) { - return define_syntaxes_expand(form, env, erec, drec); + Scheme_Expand_Info recs[1]; + Scheme_Object *form, *context_key, *l, *fn, *vec, *dummy; + Scheme_Comp_Env *env; + + /* FIXME [Ryan?]: */ + /* SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(erec[drec].observer); */ + + form = orig_form; + + if (!scheme_is_toplevel(in_env)) + scheme_wrong_syntax(NULL, NULL, form, "illegal use (not at top-level)"); + + (void)check_form(form, form); + + scheme_prepare_exp_env(in_env->genv); + scheme_prepare_compile_env(in_env->genv->exp_env); + + if (rec[drec].comp) + env = scheme_new_comp_env(in_env->genv->exp_env, in_env->insp, 0); + else + env = scheme_new_expand_env(in_env->genv->exp_env, in_env->insp, 0); + + if (rec[drec].comp) + dummy = scheme_make_environment_dummy(in_env); + else + dummy = NULL; + + context_key = scheme_generate_lifts_key(); + + l = SCHEME_STX_CDR(form); + form = scheme_null; + + while (1) { + scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), + scheme_false, scheme_false, scheme_null, scheme_false); + + if (rec[drec].comp) { + scheme_init_compile_recs(rec, drec, recs, 1); + prep_exp_env_compile_rec(recs, 0); + l = scheme_compile_list(l, env, recs, 0); + } else { + scheme_init_expand_recs(rec, drec, recs, 1); + l = scheme_expand_list(l, env, recs, 0); + } + + if (SCHEME_NULLP(form)) + form = l; + else + form = scheme_append(l, form); + + l = scheme_frame_get_lifts(env); + if (SCHEME_NULLP(l)) { + /* No lifts */ + if (rec[drec].comp) + scheme_merge_compile_recs(rec, drec, NULL, 1); /* fix this if merge changes to do something */ + break; + } else { + /* We have lifts: */ + /* FIXME [Ryan?]: need some expand-observe callback here? */ + } + } + + if (rec[drec].comp) { + vec = scheme_make_vector(4, NULL); + SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->prefix; + SCHEME_VEC_ELS(vec)[1] = dummy; + SCHEME_VEC_ELS(vec)[2] = form; + vec->type = scheme_begin_for_syntax_type; + + return vec; + } else { + fn = SCHEME_STX_CAR(orig_form); + return scheme_datum_to_syntax(cons(fn, form), + orig_form, orig_form, + 0, 2); + } +} + +static Scheme_Object * +begin_for_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec) +{ + return begin_for_syntax_expand(form, env, rec, drec); } Scheme_Object *scheme_make_environment_dummy(Scheme_Comp_Env *env) @@ -4325,7 +4399,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, #if 1 if (!SCHEME_STXP(form)) - scheme_signal_error("not syntax"); + scheme_signal_error("internal error: not syntax"); #endif if (rec[drec].comp) { @@ -4338,7 +4412,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, var = SCHEME_STX_VAL(form); if (scheme_stx_has_empty_wraps(form) && same_effective_env(SCHEME_PTR2_VAL(var), env)) { - /* FIXME: this needs EXPAND_OBSERVE callbacks. */ + /* FIXME [Ryan?]: this needs EXPAND_OBSERVE callbacks. */ form = scheme_stx_track(SCHEME_PTR1_VAL(var), form, form); if (!rec[drec].comp && (rec[drec].depth != -1)) { /* Already fully expanded. */ diff --git a/src/racket/src/cstartup.inc b/src/racket/src/cstartup.inc index 52767c1fdb..af411a6375 100644 --- a/src/racket/src/cstartup.inc +++ b/src/racket/src/cstartup.inc @@ -1,26 +1,26 @@ { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,54,0,0,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,51,0,0,0,1,0,0,10,0,13,0,22, -0,26,0,31,0,38,0,51,0,58,0,63,0,68,0,72,0,79,0,82,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,51,0,0,0,1,0,0,10,0,13,0,17, +0,22,0,29,0,42,0,49,0,54,0,59,0,63,0,70,0,73,0,82,0, 85,0,91,0,105,0,119,0,122,0,128,0,132,0,134,0,145,0,147,0,161, 0,168,0,190,0,192,0,206,0,17,1,46,1,57,1,68,1,93,1,126,1, 159,1,218,1,17,2,95,2,150,2,155,2,175,2,68,3,88,3,140,3,206, -3,95,4,237,4,34,5,45,5,124,5,0,0,69,7,0,0,69,35,37,109, -105,110,45,115,116,120,29,11,11,68,104,101,114,101,45,115,116,120,63,108,101, -116,64,99,111,110,100,66,117,110,108,101,115,115,72,112,97,114,97,109,101,116, -101,114,105,122,101,66,100,101,102,105,110,101,64,119,104,101,110,64,108,101,116, -42,63,97,110,100,66,108,101,116,114,101,99,62,111,114,29,11,11,65,113,117, +3,95,4,237,4,34,5,45,5,124,5,0,0,83,7,0,0,69,35,37,109, +105,110,45,115,116,120,29,11,11,63,108,101,116,64,99,111,110,100,66,117,110, +108,101,115,115,72,112,97,114,97,109,101,116,101,114,105,122,101,66,100,101,102, +105,110,101,64,119,104,101,110,64,108,101,116,42,63,97,110,100,66,108,101,116, +114,101,99,62,111,114,68,104,101,114,101,45,115,116,120,29,11,11,65,113,117, 111,116,101,29,94,2,15,68,35,37,107,101,114,110,101,108,11,29,94,2,15, 68,35,37,112,97,114,97,109,122,11,62,105,102,65,98,101,103,105,110,63,115, 116,120,61,115,70,108,101,116,45,118,97,108,117,101,115,61,120,73,108,101,116, 114,101,99,45,118,97,108,117,101,115,66,108,97,109,98,100,97,1,20,112,97, 114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,61,118,73, -100,101,102,105,110,101,45,118,97,108,117,101,115,97,36,11,8,240,126,76,0, -0,95,159,2,17,36,36,159,2,16,36,36,159,2,16,36,36,16,20,2,4, -2,2,2,6,2,2,2,8,2,2,2,7,2,2,2,9,2,2,2,10,2, -2,2,11,2,2,2,5,2,2,2,12,2,2,2,13,2,2,97,37,11,8, -240,126,76,0,0,93,159,2,16,36,37,16,2,2,3,161,2,2,37,2,3, -2,2,2,3,96,11,11,8,240,126,76,0,0,16,0,96,38,11,8,240,126, +100,101,102,105,110,101,45,118,97,108,117,101,115,97,36,11,8,240,83,76,0, +0,95,159,2,17,36,36,159,2,16,36,36,159,2,16,36,36,16,20,2,3, +2,2,2,5,2,2,2,7,2,2,2,6,2,2,2,8,2,2,2,9,2, +2,2,10,2,2,2,4,2,2,2,11,2,2,2,12,2,2,97,37,11,8, +240,83,76,0,0,93,159,2,16,36,37,16,2,2,13,161,2,2,37,2,13, +2,2,2,13,96,38,11,8,240,83,76,0,0,16,0,96,11,11,8,240,83, 76,0,0,16,0,18,98,64,104,101,114,101,13,16,5,36,2,14,2,2,11, 11,8,32,8,31,8,30,8,29,27,248,22,155,4,195,249,22,148,4,80,158, 39,36,251,22,83,2,18,248,22,98,199,12,249,22,73,2,19,248,22,100,201, @@ -28,16 +28,16 @@ 98,199,249,22,73,2,19,248,22,100,201,12,27,248,22,75,248,22,155,4,196, 28,248,22,81,193,20,14,159,37,36,37,28,248,22,81,248,22,75,194,248,22, 74,193,249,22,148,4,80,158,39,36,251,22,83,2,18,248,22,74,199,249,22, -73,2,11,248,22,75,201,11,18,100,10,13,16,5,36,2,14,2,2,11,11, +73,2,10,248,22,75,201,11,18,100,10,13,16,5,36,2,14,2,2,11,11, 8,32,8,31,8,30,8,29,16,4,11,11,2,20,3,1,8,101,110,118,49, -52,56,48,57,16,4,11,11,2,21,3,1,8,101,110,118,49,52,56,49,48, +52,55,51,57,16,4,11,11,2,21,3,1,8,101,110,118,49,52,55,52,48, 27,248,22,75,248,22,155,4,196,28,248,22,81,193,20,14,159,37,36,37,28, 248,22,81,248,22,75,194,248,22,74,193,249,22,148,4,80,158,39,36,250,22, 83,2,22,248,22,83,249,22,83,248,22,83,2,23,248,22,74,201,251,22,83, -2,18,2,23,2,23,249,22,73,2,13,248,22,75,204,18,100,11,13,16,5, +2,18,2,23,2,23,249,22,73,2,12,248,22,75,204,18,100,11,13,16,5, 36,2,14,2,2,11,11,8,32,8,31,8,30,8,29,16,4,11,11,2,20, -3,1,8,101,110,118,49,52,56,49,50,16,4,11,11,2,21,3,1,8,101, -110,118,49,52,56,49,51,248,22,155,4,193,27,248,22,155,4,194,249,22,73, +3,1,8,101,110,118,49,52,55,52,50,16,4,11,11,2,21,3,1,8,101, +110,118,49,52,55,52,51,248,22,155,4,193,27,248,22,155,4,194,249,22,73, 248,22,83,248,22,74,196,248,22,75,195,27,248,22,75,248,22,155,4,23,197, 1,249,22,148,4,80,158,39,36,28,248,22,58,248,22,149,4,248,22,74,23, 198,2,27,249,22,2,32,0,88,163,8,36,37,43,11,9,222,33,40,248,22, @@ -51,7 +51,7 @@ 163,8,36,37,47,11,9,222,33,43,248,22,155,4,248,22,74,201,248,22,75, 198,27,248,22,75,248,22,155,4,196,27,248,22,155,4,248,22,74,195,249,22, 148,4,80,158,40,36,28,248,22,81,195,250,22,84,2,22,9,248,22,75,199, -250,22,83,2,4,248,22,83,248,22,74,199,250,22,84,2,10,248,22,75,201, +250,22,83,2,3,248,22,83,248,22,74,199,250,22,84,2,9,248,22,75,201, 248,22,75,202,27,248,22,75,248,22,155,4,23,197,1,27,249,22,1,22,87, 249,22,2,22,155,4,248,22,155,4,248,22,74,199,248,22,174,4,249,22,148, 4,80,158,41,36,251,22,83,1,22,119,105,116,104,45,99,111,110,116,105,110, @@ -62,43 +62,44 @@ 75,204,27,248,22,75,248,22,155,4,196,28,248,22,81,193,20,14,159,37,36, 37,249,22,148,4,80,158,39,36,27,248,22,155,4,248,22,74,197,28,249,22, 140,9,62,61,62,248,22,149,4,248,22,98,196,250,22,83,2,22,248,22,83, -249,22,83,21,93,2,27,248,22,74,199,250,22,84,2,5,249,22,83,2,27, +249,22,83,21,93,2,27,248,22,74,199,250,22,84,2,4,249,22,83,2,27, 249,22,83,248,22,107,203,2,27,248,22,75,202,251,22,83,2,18,28,249,22, 140,9,248,22,149,4,248,22,74,200,64,101,108,115,101,10,248,22,74,197,250, -22,84,2,22,9,248,22,75,200,249,22,73,2,5,248,22,75,202,99,13,16, +22,84,2,22,9,248,22,75,200,249,22,73,2,4,248,22,75,202,99,13,16, 5,36,2,14,2,2,11,11,8,32,8,31,8,30,8,29,16,4,11,11,2, -20,3,1,8,101,110,118,49,52,56,51,53,16,4,11,11,2,21,3,1,8, -101,110,118,49,52,56,51,54,18,158,94,10,64,118,111,105,100,8,48,27,248, +20,3,1,8,101,110,118,49,52,55,54,53,16,4,11,11,2,21,3,1,8, +101,110,118,49,52,55,54,54,18,158,94,10,64,118,111,105,100,8,48,27,248, 22,75,248,22,155,4,196,249,22,148,4,80,158,39,36,28,248,22,58,248,22, 149,4,248,22,74,197,250,22,83,2,28,248,22,83,248,22,74,199,248,22,98, 198,27,248,22,149,4,248,22,74,197,250,22,83,2,28,248,22,83,248,22,74, 197,250,22,84,2,25,248,22,75,199,248,22,75,202,159,36,20,112,159,36,16, -1,11,16,0,20,26,142,2,1,2,1,2,2,11,11,11,10,36,80,158,36, -36,20,112,159,36,16,0,16,0,16,1,2,3,37,16,0,36,16,0,36,11, -11,39,36,11,11,16,10,2,4,2,5,2,6,2,7,2,8,2,9,2,10, -2,11,2,12,2,13,16,10,11,11,11,11,11,11,11,11,11,11,16,10,2, -4,2,5,2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,36,46, -37,11,11,16,0,16,0,16,0,36,36,11,11,11,16,0,16,0,16,0,36, -36,16,11,16,5,2,3,20,14,159,36,36,36,36,20,112,159,36,16,0,16, -1,33,33,10,16,5,2,6,88,163,8,36,37,53,37,9,223,0,33,34,36, -20,112,159,36,16,1,2,3,16,0,11,16,5,2,9,88,163,8,36,37,53, -37,9,223,0,33,35,36,20,112,159,36,16,1,2,3,16,0,11,16,5,2, -11,88,163,8,36,37,53,37,9,223,0,33,36,36,20,112,159,36,16,1,2, -3,16,1,33,37,11,16,5,2,13,88,163,8,36,37,56,37,9,223,0,33, -38,36,20,112,159,36,16,1,2,3,16,1,33,39,11,16,5,2,4,88,163, -8,36,37,58,37,9,223,0,33,42,36,20,112,159,36,16,1,2,3,16,0, -11,16,5,2,12,88,163,8,36,37,53,37,9,223,0,33,44,36,20,112,159, -36,16,1,2,3,16,0,11,16,5,2,10,88,163,8,36,37,54,37,9,223, -0,33,45,36,20,112,159,36,16,1,2,3,16,0,11,16,5,2,7,88,163, -8,36,37,56,37,9,223,0,33,46,36,20,112,159,36,16,1,2,3,16,0, -11,16,5,2,5,88,163,8,36,37,58,37,9,223,0,33,47,36,20,112,159, -36,16,1,2,3,16,1,33,49,11,16,5,2,8,88,163,8,36,37,54,37, -9,223,0,33,50,36,20,112,159,36,16,1,2,3,16,0,11,16,0,94,2, -16,2,17,93,2,16,9,9,36,0}; - EVAL_ONE_SIZED_STR((char *)expr, 2004); +1,11,16,0,20,26,146,2,1,2,1,2,2,11,11,11,10,36,80,158,36, +36,20,112,159,36,16,0,16,0,38,39,36,16,0,36,16,0,36,11,11,11, +16,10,2,3,2,4,2,5,2,6,2,7,2,8,2,9,2,10,2,11,2, +12,16,10,11,11,11,11,11,11,11,11,11,11,16,10,2,3,2,4,2,5, +2,6,2,7,2,8,2,9,2,10,2,11,2,12,36,46,37,16,0,36,16, +1,2,13,37,11,11,11,16,0,16,0,16,0,36,36,11,12,11,11,16,0, +16,0,16,0,36,36,16,11,16,5,11,20,15,16,2,20,14,159,36,36,37, +80,158,36,36,36,20,112,159,36,16,1,2,13,16,1,33,33,10,16,5,2, +5,88,163,8,36,37,53,37,9,223,0,33,34,36,20,112,159,36,16,1,2, +13,16,0,11,16,5,2,8,88,163,8,36,37,53,37,9,223,0,33,35,36, +20,112,159,36,16,1,2,13,16,0,11,16,5,2,10,88,163,8,36,37,53, +37,9,223,0,33,36,36,20,112,159,36,16,1,2,13,16,1,33,37,11,16, +5,2,12,88,163,8,36,37,56,37,9,223,0,33,38,36,20,112,159,36,16, +1,2,13,16,1,33,39,11,16,5,2,3,88,163,8,36,37,58,37,9,223, +0,33,42,36,20,112,159,36,16,1,2,13,16,0,11,16,5,2,11,88,163, +8,36,37,53,37,9,223,0,33,44,36,20,112,159,36,16,1,2,13,16,0, +11,16,5,2,9,88,163,8,36,37,54,37,9,223,0,33,45,36,20,112,159, +36,16,1,2,13,16,0,11,16,5,2,6,88,163,8,36,37,56,37,9,223, +0,33,46,36,20,112,159,36,16,1,2,13,16,0,11,16,5,2,4,88,163, +8,36,37,58,37,9,223,0,33,47,36,20,112,159,36,16,1,2,13,16,1, +33,49,11,16,5,2,7,88,163,8,36,37,54,37,9,223,0,33,50,36,20, +112,159,36,16,1,2,13,16,0,11,16,0,94,2,16,2,17,93,2,16,9, +9,36,0}; + EVAL_ONE_SIZED_STR((char *)expr, 2018); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,54,0,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,109,0,0,0,1,0,0,8,0,21,0,26, 0,43,0,65,0,94,0,109,0,127,0,143,0,157,0,179,0,195,0,212,0, 234,0,245,0,251,0,4,1,11,1,18,1,30,1,46,1,70,1,102,1,120, @@ -110,7 +111,7 @@ 15,17,23,17,129,17,192,17,194,17,50,18,110,18,115,18,238,18,249,18,129, 19,139,19,62,21,84,21,93,21,86,22,104,22,118,22,77,23,96,23,34,26, 154,30,68,31,213,31,198,32,180,33,187,33,12,34,95,34,180,34,206,34,79, -35,0,0,180,39,0,0,67,35,37,117,116,105,108,115,72,112,97,116,104,45, +35,0,0,177,39,0,0,67,35,37,117,116,105,108,115,72,112,97,116,104,45, 115,116,114,105,110,103,63,64,98,115,98,115,76,110,111,114,109,97,108,45,99, 97,115,101,45,112,97,116,104,1,20,102,105,110,100,45,101,120,101,99,117,116, 97,98,108,101,45,112,97,116,104,1,27,112,97,116,104,45,108,105,115,116,45, @@ -369,7 +370,7 @@ 22,157,2,195,88,163,8,36,38,48,11,9,223,3,33,88,28,197,86,94,20, 18,159,11,80,158,42,47,193,20,18,159,11,80,158,42,48,196,86,94,20,18, 159,11,80,158,42,53,193,20,18,159,11,80,158,42,54,196,193,28,193,80,158, -38,47,80,158,38,53,248,22,8,88,163,8,32,37,8,40,8,240,0,188,23, +38,47,80,158,38,53,248,22,9,88,163,8,32,37,8,40,8,240,0,188,23, 0,9,224,1,2,33,89,0,7,35,114,120,34,47,43,34,28,248,22,130,7, 23,195,2,27,249,22,138,15,2,91,196,28,192,28,249,22,184,3,248,22,97, 195,248,22,174,3,248,22,133,7,198,249,22,7,250,22,152,7,199,36,248,22, @@ -541,7 +542,7 @@ 28,23,194,2,23,194,1,86,94,23,194,1,36,249,22,185,5,23,199,1,20, 20,95,88,163,8,36,36,48,11,9,224,4,2,33,107,23,195,1,23,197,1, 27,248,22,170,5,23,195,1,248,80,159,39,8,31,39,193,159,36,20,112,159, -36,16,1,11,16,0,20,26,142,2,1,2,1,29,11,11,11,11,11,10,43, +36,16,1,11,16,0,20,26,141,2,1,2,1,29,11,11,11,11,11,10,43, 80,158,36,36,20,112,159,40,16,28,2,2,2,3,2,4,2,5,2,6,2, 7,2,8,2,9,2,10,2,11,2,12,2,13,2,14,2,15,30,2,18,76, 102,105,110,100,45,108,105,110,107,115,45,112,97,116,104,33,4,30,2,19,1, @@ -549,58 +550,58 @@ 6,30,2,19,1,23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,101, 114,105,122,97,116,105,111,110,3,2,20,2,21,2,22,30,2,18,1,21,101, 120,99,101,112,116,105,111,110,45,104,97,110,100,108,101,114,45,107,101,121,2, -2,23,2,24,2,25,2,26,2,27,2,28,2,29,16,0,16,0,36,16,0, +2,23,2,24,2,25,2,26,2,27,2,28,2,29,16,0,37,39,36,16,0, 36,16,12,2,8,2,7,2,3,2,24,2,22,2,20,2,15,2,21,2,23, -2,13,2,12,2,14,48,11,11,39,36,11,11,16,12,2,11,2,9,2,29, -2,10,2,5,2,28,2,27,2,4,2,26,2,6,2,25,2,2,16,12,11, -11,11,11,11,11,11,11,11,11,11,11,16,12,2,11,2,9,2,29,2,10, -2,5,2,28,2,27,2,4,2,26,2,6,2,25,2,2,48,48,37,11,11, -16,0,16,0,16,0,36,36,11,11,11,16,0,16,0,16,0,36,36,16,0, -16,28,20,15,16,2,88,163,8,36,37,51,16,2,8,240,0,128,0,0,8, -240,1,128,0,0,2,30,223,0,33,50,80,159,36,8,31,39,20,15,16,2, -88,163,8,36,37,56,16,2,44,8,240,0,64,0,0,2,30,223,0,33,51, -80,159,36,8,30,39,20,15,16,2,88,163,8,36,37,51,16,2,44,8,128, -128,2,30,223,0,33,52,80,159,36,8,29,39,20,15,16,2,88,163,8,36, -37,51,16,2,44,8,128,64,2,30,223,0,33,53,80,159,36,8,28,39,20, -15,16,2,32,0,88,163,36,37,45,11,2,2,222,33,54,80,159,36,36,37, -20,15,16,2,249,22,132,7,7,92,7,92,80,159,36,37,37,20,15,16,2, -88,163,36,37,54,38,2,4,223,0,33,55,80,159,36,38,37,20,15,16,2, -20,25,96,2,5,88,163,8,36,39,8,24,52,9,223,0,33,62,88,163,36, -38,47,44,9,223,0,33,63,88,163,36,37,46,44,9,223,0,33,64,80,159, -36,39,37,20,15,16,2,27,248,22,132,15,248,22,144,8,27,28,249,22,140, -9,247,22,152,8,2,32,6,1,1,59,6,1,1,58,250,22,178,7,6,14, -14,40,91,94,126,97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1, -88,163,8,36,38,48,11,2,6,223,0,33,68,80,159,36,40,37,20,15,16, -2,32,0,88,163,8,36,38,50,11,2,7,222,33,69,80,159,36,41,37,20, -15,16,2,32,0,88,163,8,36,39,51,11,2,8,222,33,71,80,159,36,42, -37,20,15,16,2,88,163,45,38,51,8,128,4,2,9,223,0,33,74,80,159, -36,43,37,20,15,16,2,88,163,45,39,52,8,128,4,2,11,223,0,33,77, -80,159,36,45,37,20,15,16,2,248,22,188,14,70,108,105,110,107,115,45,102, -105,108,101,80,159,36,46,37,20,15,16,2,247,22,133,2,80,158,36,47,20, -15,16,2,2,78,80,158,36,48,20,15,16,2,248,80,159,37,50,37,88,163, -36,36,49,8,240,8,128,1,0,9,223,1,33,79,80,159,36,49,37,20,15, -16,2,247,22,133,2,80,158,36,53,20,15,16,2,2,78,80,158,36,54,20, -15,16,2,88,163,36,37,44,8,240,0,188,23,0,2,22,223,0,33,90,80, -159,36,55,37,20,15,16,2,88,163,36,38,56,8,240,0,0,32,0,2,23, -223,0,33,92,80,159,36,57,37,20,15,16,2,88,163,36,41,8,24,8,240, -0,32,40,0,2,10,223,0,33,99,80,159,36,44,37,20,15,16,2,32,0, -88,163,36,39,50,11,2,24,222,33,100,80,159,36,58,37,20,15,16,2,32, -0,88,163,36,38,53,11,2,25,222,33,101,80,159,36,59,37,20,15,16,2, -32,0,88,163,36,38,54,11,2,26,222,33,102,80,159,36,8,24,37,20,15, -16,2,32,0,88,163,36,37,44,11,2,27,222,33,103,80,159,36,8,25,37, -20,15,16,2,20,25,96,2,28,88,163,36,36,53,16,2,52,8,128,64,9, -223,0,33,104,88,163,36,37,54,16,2,52,8,128,128,9,223,0,33,105,88, -163,36,38,55,16,2,52,8,240,0,64,0,0,9,223,0,33,106,80,159,36, -8,26,37,20,15,16,2,88,163,8,36,39,54,16,2,44,8,240,0,128,0, -0,2,29,223,0,33,108,80,159,36,8,27,37,95,29,94,2,16,68,35,37, -107,101,114,110,101,108,11,29,94,2,16,69,35,37,109,105,110,45,115,116,120, -11,2,18,9,9,9,36,0}; - EVAL_ONE_SIZED_STR((char *)expr, 10423); +2,13,2,12,2,14,48,11,11,11,16,12,2,11,2,9,2,29,2,10,2, +5,2,28,2,27,2,4,2,26,2,6,2,25,2,2,16,12,11,11,11,11, +11,11,11,11,11,11,11,11,16,12,2,11,2,9,2,29,2,10,2,5,2, +28,2,27,2,4,2,26,2,6,2,25,2,2,48,48,37,12,11,11,16,0, +16,0,16,0,36,36,11,12,11,11,16,0,16,0,16,0,36,36,16,28,20, +15,16,2,88,163,8,36,37,51,16,2,8,240,0,128,0,0,8,240,1,128, +0,0,2,30,223,0,33,50,80,159,36,8,31,39,20,15,16,2,88,163,8, +36,37,56,16,2,44,8,240,0,64,0,0,2,30,223,0,33,51,80,159,36, +8,30,39,20,15,16,2,88,163,8,36,37,51,16,2,44,8,128,128,2,30, +223,0,33,52,80,159,36,8,29,39,20,15,16,2,88,163,8,36,37,51,16, +2,44,8,128,64,2,30,223,0,33,53,80,159,36,8,28,39,20,15,16,2, +32,0,88,163,36,37,45,11,2,2,222,33,54,80,159,36,36,37,20,15,16, +2,249,22,132,7,7,92,7,92,80,159,36,37,37,20,15,16,2,88,163,36, +37,54,38,2,4,223,0,33,55,80,159,36,38,37,20,15,16,2,20,25,96, +2,5,88,163,8,36,39,8,24,52,9,223,0,33,62,88,163,36,38,47,44, +9,223,0,33,63,88,163,36,37,46,44,9,223,0,33,64,80,159,36,39,37, +20,15,16,2,27,248,22,132,15,248,22,144,8,27,28,249,22,140,9,247,22, +152,8,2,32,6,1,1,59,6,1,1,58,250,22,178,7,6,14,14,40,91, +94,126,97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,88,163,8, +36,38,48,11,2,6,223,0,33,68,80,159,36,40,37,20,15,16,2,32,0, +88,163,8,36,38,50,11,2,7,222,33,69,80,159,36,41,37,20,15,16,2, +32,0,88,163,8,36,39,51,11,2,8,222,33,71,80,159,36,42,37,20,15, +16,2,88,163,45,38,51,8,128,4,2,9,223,0,33,74,80,159,36,43,37, +20,15,16,2,88,163,45,39,52,8,128,4,2,11,223,0,33,77,80,159,36, +45,37,20,15,16,2,248,22,188,14,70,108,105,110,107,115,45,102,105,108,101, +80,159,36,46,37,20,15,16,2,247,22,133,2,80,158,36,47,20,15,16,2, +2,78,80,158,36,48,20,15,16,2,248,80,159,37,50,37,88,163,36,36,49, +8,240,8,128,1,0,9,223,1,33,79,80,159,36,49,37,20,15,16,2,247, +22,133,2,80,158,36,53,20,15,16,2,2,78,80,158,36,54,20,15,16,2, +88,163,36,37,44,8,240,0,188,23,0,2,22,223,0,33,90,80,159,36,55, +37,20,15,16,2,88,163,36,38,56,8,240,0,0,32,0,2,23,223,0,33, +92,80,159,36,57,37,20,15,16,2,88,163,36,41,8,24,8,240,0,32,40, +0,2,10,223,0,33,99,80,159,36,44,37,20,15,16,2,32,0,88,163,36, +39,50,11,2,24,222,33,100,80,159,36,58,37,20,15,16,2,32,0,88,163, +36,38,53,11,2,25,222,33,101,80,159,36,59,37,20,15,16,2,32,0,88, +163,36,38,54,11,2,26,222,33,102,80,159,36,8,24,37,20,15,16,2,32, +0,88,163,36,37,44,11,2,27,222,33,103,80,159,36,8,25,37,20,15,16, +2,20,25,96,2,28,88,163,36,36,53,16,2,52,8,128,64,9,223,0,33, +104,88,163,36,37,54,16,2,52,8,128,128,9,223,0,33,105,88,163,36,38, +55,16,2,52,8,240,0,64,0,0,9,223,0,33,106,80,159,36,8,26,37, +20,15,16,2,88,163,8,36,39,54,16,2,44,8,240,0,128,0,0,2,29, +223,0,33,108,80,159,36,8,27,37,95,29,94,2,16,68,35,37,107,101,114, +110,101,108,11,29,94,2,16,69,35,37,109,105,110,45,115,116,120,11,2,18, +9,9,9,36,0}; + EVAL_ONE_SIZED_STR((char *)expr, 10420); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,54,0,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,12,0,0,0,1,0,0,15,0,40,0,57, -0,75,0,97,0,120,0,140,0,162,0,169,0,176,0,183,0,0,0,178,1, +0,75,0,97,0,120,0,140,0,162,0,169,0,176,0,183,0,0,0,175,1, 0,0,74,35,37,112,108,97,99,101,45,115,116,114,117,99,116,1,23,115,116, 114,117,99,116,58,84,72,45,112,108,97,99,101,45,99,104,97,110,110,101,108, 76,84,72,45,112,108,97,99,101,45,99,104,97,110,110,101,108,77,84,72,45, @@ -610,29 +611,29 @@ 112,108,97,99,101,45,99,104,97,110,110,101,108,45,105,110,1,20,84,72,45, 112,108,97,99,101,45,99,104,97,110,110,101,108,45,111,117,116,249,80,158,38, 39,195,36,249,80,158,38,39,195,36,249,80,158,38,39,195,37,159,36,20,112, -159,36,16,1,11,16,0,20,26,142,2,1,2,1,29,11,11,11,11,11,10, +159,36,16,1,11,16,0,20,26,141,2,1,2,1,29,11,11,11,11,11,10, 45,80,158,36,36,20,112,159,36,16,7,2,2,2,3,2,4,2,5,2,6, -2,7,2,8,16,0,16,0,36,16,0,36,16,2,2,5,2,6,38,11,11, -39,36,11,11,16,5,2,3,2,7,2,8,2,4,2,2,16,5,11,11,11, -11,11,16,5,2,3,2,7,2,8,2,4,2,2,41,41,37,11,11,16,0, -16,0,16,0,36,36,11,11,11,16,0,16,0,16,0,36,36,16,0,16,2, -20,15,16,6,253,22,176,10,2,3,11,38,36,11,248,22,83,249,22,73,22, -164,10,88,163,36,37,45,44,9,223,9,33,9,80,159,36,36,37,80,159,36, -37,37,80,159,36,38,37,80,159,36,39,37,80,159,36,40,37,20,15,16,3, -249,22,7,88,163,36,37,45,44,9,223,2,33,10,88,163,36,37,45,44,9, -223,2,33,11,80,159,36,41,37,80,159,36,42,37,93,29,94,65,113,117,111, -116,101,68,35,37,107,101,114,110,101,108,11,9,9,9,36,0}; - EVAL_ONE_SIZED_STR((char *)expr, 499); +2,7,2,8,16,0,37,39,36,16,0,36,16,2,2,5,2,6,38,11,11, +11,16,5,2,3,2,7,2,8,2,4,2,2,16,5,11,11,11,11,11,16, +5,2,3,2,7,2,8,2,4,2,2,41,41,37,12,11,11,16,0,16,0, +16,0,36,36,11,12,11,11,16,0,16,0,16,0,36,36,16,2,20,15,16, +6,253,22,176,10,2,3,11,38,36,11,248,22,83,249,22,73,22,164,10,88, +163,36,37,45,44,9,223,9,33,9,80,159,36,36,37,80,159,36,37,37,80, +159,36,38,37,80,159,36,39,37,80,159,36,40,37,20,15,16,3,249,22,7, +88,163,36,37,45,44,9,223,2,33,10,88,163,36,37,45,44,9,223,2,33, +11,80,159,36,41,37,80,159,36,42,37,93,29,94,65,113,117,111,116,101,68, +35,37,107,101,114,110,101,108,11,9,9,9,36,0}; + EVAL_ONE_SIZED_STR((char *)expr, 496); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,54,0,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,65,0,0,0,1,0,0,7,0,18,0,45, 0,51,0,64,0,73,0,80,0,102,0,124,0,150,0,158,0,170,0,185,0, 201,0,219,0,239,0,251,0,11,1,34,1,46,1,77,1,84,1,89,1,94, 1,99,1,104,1,109,1,118,1,123,1,127,1,135,1,144,1,152,1,213,1, 60,2,81,2,102,2,132,2,162,2,220,2,22,3,71,3,120,3,54,9,105, 9,168,9,187,9,201,9,103,10,116,10,250,10,36,12,159,12,165,12,179,12, -206,12,226,12,30,13,117,13,119,13,188,13,16,20,69,20,93,20,0,0,185, +206,12,226,12,30,13,117,13,119,13,188,13,16,20,69,20,93,20,0,0,182, 23,0,0,66,35,37,98,111,111,116,70,100,108,108,45,115,117,102,102,105,120, 1,25,100,101,102,97,117,108,116,45,108,111,97,100,47,117,115,101,45,99,111, 109,112,105,108,101,100,65,113,117,111,116,101,29,94,2,4,67,35,37,117,116, @@ -882,7 +883,7 @@ 22,178,4,80,159,37,54,38,248,22,158,5,80,159,37,37,39,248,22,181,13, 80,159,37,42,39,20,18,159,11,80,158,36,53,248,80,159,37,8,25,37,249, 22,27,11,80,159,39,55,37,159,36,20,112,159,36,16,1,11,16,0,20,26, -142,2,1,2,1,29,11,11,11,11,11,10,38,80,158,36,36,20,112,159,40, +141,2,1,2,1,29,11,11,11,11,11,10,38,80,158,36,36,20,112,159,40, 16,26,2,2,2,3,30,2,5,72,112,97,116,104,45,115,116,114,105,110,103, 63,11,30,2,5,75,112,97,116,104,45,97,100,100,45,115,117,102,102,105,120, 8,30,2,7,2,8,6,30,2,7,1,23,101,120,116,101,110,100,45,112,97, @@ -892,59 +893,59 @@ 45,115,117,102,102,105,120,10,30,2,5,73,102,105,110,100,45,99,111,108,45, 102,105,108,101,3,30,2,5,76,110,111,114,109,97,108,45,99,97,115,101,45, 112,97,116,104,7,2,23,2,24,30,2,22,74,114,101,112,97,114,97,109,101, -116,101,114,105,122,101,7,16,0,16,0,36,16,0,36,16,14,2,15,2,16, +116,101,114,105,122,101,7,16,0,37,39,36,16,0,36,16,14,2,15,2,16, 2,10,2,12,2,17,2,18,2,11,2,3,2,9,2,2,2,13,2,14,2, -19,2,21,50,11,11,39,36,11,11,16,3,2,23,2,20,2,24,16,3,11, -11,11,16,3,2,23,2,20,2,24,39,39,37,11,11,16,0,16,0,16,0, -36,36,11,11,11,16,0,16,0,16,0,36,36,16,0,16,21,20,15,16,2, -88,163,36,37,45,8,128,128,9,223,0,33,32,80,159,36,8,29,39,20,15, -16,2,88,163,8,36,37,45,8,240,0,0,1,0,9,223,0,33,33,80,159, -36,8,28,39,20,15,16,2,88,163,36,37,49,8,240,0,0,16,0,72,112, -97,116,104,45,115,115,45,62,114,107,116,223,0,33,34,80,159,36,8,27,39, -20,15,16,2,88,163,36,37,49,8,240,0,192,0,0,67,103,101,116,45,100, -105,114,223,0,33,35,80,159,36,8,26,39,20,15,16,2,248,22,152,8,69, -115,111,45,115,117,102,102,105,120,80,159,36,36,37,20,15,16,2,88,163,36, -38,8,38,8,61,2,3,223,0,33,44,80,159,36,37,37,20,15,16,2,32, -0,88,163,8,36,37,42,11,2,9,222,192,80,159,36,42,37,20,15,16,2, -247,22,136,2,80,159,36,43,37,20,15,16,2,8,128,8,80,159,36,44,37, -20,15,16,2,249,22,156,8,8,128,8,11,80,159,36,45,37,20,15,16,2, -88,163,8,36,37,50,8,128,8,2,13,223,0,33,45,80,159,36,46,37,20, -15,16,2,88,163,8,36,38,55,8,128,8,2,14,223,0,33,46,80,159,36, -47,37,20,15,16,2,247,22,69,80,159,36,48,37,20,15,16,2,248,22,18, -74,109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159,36,49,37,20, -15,16,2,11,80,158,36,50,20,15,16,2,11,80,158,36,51,20,15,16,2, -32,0,88,163,36,38,8,25,11,2,19,222,33,52,80,159,36,52,37,20,15, -16,2,11,80,158,36,53,20,15,16,2,27,11,20,19,158,36,90,159,37,10, -89,161,37,36,10,20,25,96,2,21,88,163,8,36,37,51,8,128,2,9,224, -2,1,33,53,88,163,36,39,49,11,9,223,0,33,54,88,163,36,40,8,38, -16,2,8,176,218,8,187,241,9,224,2,1,33,62,207,80,159,36,54,37,20, -15,16,2,88,163,36,36,45,8,240,66,0,14,2,2,23,223,0,33,63,80, -159,36,59,37,20,15,16,2,88,163,8,36,36,45,8,240,0,0,10,2,2, -24,223,0,33,64,80,159,36,8,24,37,96,29,94,2,4,68,35,37,107,101, -114,110,101,108,11,29,94,2,4,69,35,37,109,105,110,45,115,116,120,11,2, -5,2,22,9,9,9,36,0}; - EVAL_ONE_SIZED_STR((char *)expr, 6244); +19,2,21,50,11,11,11,16,3,2,23,2,20,2,24,16,3,11,11,11,16, +3,2,23,2,20,2,24,39,39,37,12,11,11,16,0,16,0,16,0,36,36, +11,12,11,11,16,0,16,0,16,0,36,36,16,21,20,15,16,2,88,163,36, +37,45,8,128,128,9,223,0,33,32,80,159,36,8,29,39,20,15,16,2,88, +163,8,36,37,45,8,240,0,0,1,0,9,223,0,33,33,80,159,36,8,28, +39,20,15,16,2,88,163,36,37,49,8,240,0,0,16,0,72,112,97,116,104, +45,115,115,45,62,114,107,116,223,0,33,34,80,159,36,8,27,39,20,15,16, +2,88,163,36,37,49,8,240,0,192,0,0,67,103,101,116,45,100,105,114,223, +0,33,35,80,159,36,8,26,39,20,15,16,2,248,22,152,8,69,115,111,45, +115,117,102,102,105,120,80,159,36,36,37,20,15,16,2,88,163,36,38,8,38, +8,61,2,3,223,0,33,44,80,159,36,37,37,20,15,16,2,32,0,88,163, +8,36,37,42,11,2,9,222,192,80,159,36,42,37,20,15,16,2,247,22,136, +2,80,159,36,43,37,20,15,16,2,8,128,8,80,159,36,44,37,20,15,16, +2,249,22,156,8,8,128,8,11,80,159,36,45,37,20,15,16,2,88,163,8, +36,37,50,8,128,8,2,13,223,0,33,45,80,159,36,46,37,20,15,16,2, +88,163,8,36,38,55,8,128,8,2,14,223,0,33,46,80,159,36,47,37,20, +15,16,2,247,22,69,80,159,36,48,37,20,15,16,2,248,22,18,74,109,111, +100,117,108,101,45,108,111,97,100,105,110,103,80,159,36,49,37,20,15,16,2, +11,80,158,36,50,20,15,16,2,11,80,158,36,51,20,15,16,2,32,0,88, +163,36,38,8,25,11,2,19,222,33,52,80,159,36,52,37,20,15,16,2,11, +80,158,36,53,20,15,16,2,27,11,20,19,158,36,90,159,37,10,89,161,37, +36,10,20,25,96,2,21,88,163,8,36,37,51,8,128,2,9,224,2,1,33, +53,88,163,36,39,49,11,9,223,0,33,54,88,163,36,40,8,38,16,2,8, +176,218,8,187,241,9,224,2,1,33,62,207,80,159,36,54,37,20,15,16,2, +88,163,36,36,45,8,240,66,0,14,2,2,23,223,0,33,63,80,159,36,59, +37,20,15,16,2,88,163,8,36,36,45,8,240,0,0,10,2,2,24,223,0, +33,64,80,159,36,8,24,37,96,29,94,2,4,68,35,37,107,101,114,110,101, +108,11,29,94,2,4,69,35,37,109,105,110,45,115,116,120,11,2,5,2,22, +9,9,9,36,0}; + EVAL_ONE_SIZED_STR((char *)expr, 6241); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,54,0,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,11,0,0,0,1,0,0,10,0,16,0,29, -0,44,0,58,0,78,0,90,0,104,0,118,0,170,0,0,0,97,1,0,0, +0,44,0,58,0,78,0,90,0,104,0,118,0,170,0,0,0,94,1,0,0, 69,35,37,98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2,67, 35,37,117,116,105,108,115,11,29,94,2,2,69,35,37,110,101,116,119,111,114, 107,11,29,94,2,2,68,35,37,112,97,114,97,109,122,11,29,94,2,2,74, 35,37,112,108,97,99,101,45,115,116,114,117,99,116,11,29,94,2,2,66,35, 37,98,111,111,116,11,29,94,2,2,68,35,37,101,120,112,111,98,115,11,29, -94,2,2,68,35,37,107,101,114,110,101,108,11,97,36,11,8,240,56,78,0, +94,2,2,68,35,37,107,101,114,110,101,108,11,97,36,11,8,240,11,78,0, 0,100,159,2,3,36,36,159,2,4,36,36,159,2,5,36,36,159,2,6,36, 36,159,2,7,36,36,159,2,8,36,36,159,2,9,36,36,159,2,9,36,36, -16,0,159,36,20,112,159,36,16,1,11,16,0,20,26,142,2,1,2,1,29, +16,0,159,36,20,112,159,36,16,1,11,16,0,20,26,141,2,1,2,1,29, 11,11,11,11,11,18,96,11,46,46,46,36,80,158,36,36,20,112,159,36,16, -0,16,0,16,0,36,16,0,36,16,0,36,11,11,39,36,11,11,16,0,16, -0,16,0,36,36,37,11,11,16,0,16,0,16,0,36,36,11,11,11,16,0, -16,0,16,0,36,36,16,0,16,0,104,2,9,2,8,29,94,2,2,69,35, -37,102,111,114,101,105,103,110,11,29,94,2,2,68,35,37,117,110,115,97,102, -101,11,29,94,2,2,69,35,37,102,108,102,120,110,117,109,11,2,7,2,6, -2,5,2,4,2,3,29,94,2,2,67,35,37,112,108,97,99,101,11,29,94, -2,2,69,35,37,102,117,116,117,114,101,115,11,9,9,9,36,0}; - EVAL_ONE_SIZED_STR((char *)expr, 416); +0,16,0,37,39,36,16,0,36,16,0,36,11,11,11,16,0,16,0,16,0, +36,36,37,12,11,11,16,0,16,0,16,0,36,36,11,12,11,11,16,0,16, +0,16,0,36,36,16,0,104,2,9,2,8,29,94,2,2,69,35,37,102,111, +114,101,105,103,110,11,29,94,2,2,68,35,37,117,110,115,97,102,101,11,29, +94,2,2,69,35,37,102,108,102,120,110,117,109,11,2,7,2,6,2,5,2, +4,2,3,29,94,2,2,67,35,37,112,108,97,99,101,11,29,94,2,2,69, +35,37,102,117,116,117,114,101,115,11,9,9,9,36,0}; + EVAL_ONE_SIZED_STR((char *)expr, 413); } diff --git a/src/racket/src/env.c b/src/racket/src/env.c index 6dd71fbf8b..2a2681b85c 100644 --- a/src/racket/src/env.c +++ b/src/racket/src/env.c @@ -502,20 +502,22 @@ static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thr return env; } +#ifdef MZ_USE_PLACES Scheme_Env *scheme_place_instance_init(void *stack_base, struct NewGC *parent_gc, intptr_t memory_limit) { Scheme_Env *env; -#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES) +# if defined(MZ_PRECISE_GC) int *signal_fd; GC_construct_child_gc(parent_gc, memory_limit); -#endif +# endif env = place_instance_init(stack_base, 0); -#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES) +# if defined(MZ_PRECISE_GC) signal_fd = scheme_get_signal_handle(); GC_set_put_external_event_fd(signal_fd); -#endif +# endif scheme_set_can_break(1); return env; } +#endif static void force_more_closed(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data) { @@ -835,6 +837,7 @@ scheme_new_module_env(Scheme_Env *env, Scheme_Module *m, int new_exp_module_tree scheme_prepare_label_env(env); menv->label_env = env->label_env; + menv->instance_env = env; if (new_exp_module_tree) { Scheme_Object *p; @@ -886,6 +889,7 @@ void scheme_prepare_exp_env(Scheme_Env *env) env->exp_env = eenv; eenv->template_env = env; eenv->label_env = env->label_env; + eenv->instance_env = env->instance_env; scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL); eenv->rename_set = env->rename_set; @@ -929,6 +933,7 @@ void scheme_prepare_template_env(Scheme_Env *env) env->template_env = eenv; eenv->exp_env = env; eenv->label_env = env->label_env; + eenv->instance_env = env->instance_env; if (env->disallow_unbound) eenv->disallow_unbound = env->disallow_unbound; @@ -962,6 +967,7 @@ void scheme_prepare_label_env(Scheme_Env *env) lenv->exp_env = lenv; lenv->label_env = lenv; lenv->template_env = lenv; + lenv->instance_env = env->instance_env; } } @@ -981,7 +987,9 @@ Scheme_Env *scheme_copy_module_env(Scheme_Env *menv, Scheme_Env *ns, Scheme_Obje menv2->module_registry = ns->module_registry; menv2->insp = menv->insp; - if (menv->phase < clone_phase) + menv2->instance_env = menv2; + + if (menv->phase < clone_phase) menv2->syntax = menv->syntax; else { bucket_table = scheme_make_bucket_table(7, SCHEME_hash_ptr); @@ -992,11 +1000,21 @@ Scheme_Env *scheme_copy_module_env(Scheme_Env *menv, Scheme_Env *ns, Scheme_Obje menv2->mod_phase = menv->mod_phase; menv2->link_midx = menv->link_midx; if (menv->phase <= clone_phase) { - menv2->running = menv->running; menv2->ran = menv->ran; } - if (menv->phase < clone_phase) - menv2->et_running = menv->et_running; + if (menv->mod_phase == 0) { + char *running; + int amt; + running = (char *)scheme_malloc_atomic(menv->module->num_phases); + menv2->running = running; + memset(running, 0, menv->module->num_phases); + amt = (clone_phase - menv->phase) + 1; + if (amt > 0) { + if (amt > menv->module->num_phases) + amt = menv->module->num_phases; + memcpy(running, menv->running, amt); + } + } menv2->require_names = menv->require_names; menv2->et_require_names = menv->et_require_names; @@ -2299,18 +2317,12 @@ local_module_exports(int argc, Scheme_Object *argv[]) static Scheme_Object * local_module_definitions(int argc, Scheme_Object *argv[]) { - Scheme_Object *a[2]; - if (!scheme_current_thread->current_local_env || !scheme_current_thread->current_local_bindings) scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-module-defined-identifiers: not currently transforming module provides"); - a[0] = SCHEME_CDR(scheme_current_thread->current_local_bindings); - a[1] = SCHEME_CDR(a[0]); - a[0] = SCHEME_CAR(a[0]); - - return scheme_values(2, a); + return SCHEME_CDR(scheme_current_thread->current_local_bindings); } static Scheme_Object * diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index aa59ea2e20..7217d9b06f 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -1669,10 +1669,7 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, save_runstack = scheme_push_prefix(dm_env->exp_env, rp, NULL, NULL, 1, 1, NULL, scheme_false); vals = scheme_eval_linked_expr_multi_with_dynamic_state(vals_expr, dyn_state); - if (defmacro == 2) - dm_env = NULL; - else - scheme_pop_prefix(save_runstack); + scheme_pop_prefix(save_runstack); } else { vals = _scheme_eval_linked_expr_multi(vals_expr); dm_env = NULL; @@ -1782,16 +1779,13 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, } else name = NULL; - if (defmacro > 1) - scheme_pop_prefix(save_runstack); - { const char *symname; symname = (show_any ? scheme_symbol_name(name) : ""); scheme_wrong_return_arity((defmacro - ? (dm_env ? "define-syntaxes" : "define-values-for-syntax") + ? "define-syntaxes" : "define-values"), i, g, (g == 1) ? (Scheme_Object **)vals : scheme_current_thread->ku.multiple.array, @@ -2034,7 +2028,7 @@ static Scheme_Object *splice_execute(Scheme_Object *data) } } -static Scheme_Object *do_define_syntaxes_execute(Scheme_Object *expr, Scheme_Env *dm_env, int for_stx); +static Scheme_Object *do_define_syntaxes_execute(Scheme_Object *expr, Scheme_Env *dm_env); static void *define_syntaxes_execute_k(void) { @@ -2043,11 +2037,11 @@ static void *define_syntaxes_execute_k(void) Scheme_Env *dm_env = (Scheme_Env *)p->ku.k.p2; p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; - return do_define_syntaxes_execute(form, dm_env, p->ku.k.i1); + return do_define_syntaxes_execute(form, dm_env); } static Scheme_Object * -do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env, int for_stx) +do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env) { Scheme_Thread *p = scheme_current_thread; Resolve_Prefix *rp; @@ -2068,7 +2062,6 @@ do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env, int for_stx) dm_env = scheme_environment_from_dummy(dummy); } p->ku.k.p2 = (Scheme_Object *)dm_env; - p->ku.k.i1 = for_stx; return (Scheme_Object *)scheme_enlarge_runstack(depth, define_syntaxes_execute_k); } @@ -2095,24 +2088,40 @@ do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env, int for_stx) scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, scheme_false, dm_env, dm_env->link_midx); - result = define_execute_with_dynamic_state(form, 4, for_stx ? 2 : 1, rp, dm_env, &dyn_state); + if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_syntaxes_type)) { + result = define_execute_with_dynamic_state(form, 4, 1, rp, dm_env, &dyn_state); + } else { + Scheme_Object **save_runstack; + + form = SCHEME_VEC_ELS(form)[0]; + + save_runstack = scheme_push_prefix(dm_env->exp_env, rp, NULL, NULL, 1, 1, NULL, scheme_false); + + while (!SCHEME_NULLP(form)) { + (void)scheme_eval_linked_expr_multi_with_dynamic_state(SCHEME_CAR(form), &dyn_state); + form = SCHEME_CDR(form); + } + + scheme_pop_prefix(save_runstack); + } + scheme_pop_continuation_frame(&cframe); - return result; + return scheme_void; } } static Scheme_Object * define_syntaxes_execute(Scheme_Object *form) { - return do_define_syntaxes_execute(form, NULL, 0); + return do_define_syntaxes_execute(form, NULL); } static Scheme_Object * -define_for_syntaxes_execute(Scheme_Object *form) +begin_for_syntax_execute(Scheme_Object *form) { - return do_define_syntaxes_execute(form, NULL, 1); + return do_define_syntaxes_execute(form, NULL); } /*========================================================================*/ @@ -3444,10 +3453,10 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, v = define_syntaxes_execute(obj); break; } - case scheme_define_for_syntax_type: + case scheme_begin_for_syntax_type: { UPDATE_THREAD_RSPTR(); - v = define_for_syntaxes_execute(obj); + v = begin_for_syntax_execute(obj); break; } case scheme_set_bang_type: @@ -5179,7 +5188,7 @@ Scheme_Object *scheme_eval_clone(Scheme_Object *expr) return scheme_module_eval_clone(expr); break; case scheme_define_syntaxes_type: - case scheme_define_for_syntax_type: + case scheme_begin_for_syntax_type: return scheme_syntaxes_eval_clone(expr); default: return expr; diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index 37f6b37087..a22dd19585 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -119,7 +119,7 @@ THREAD_LOCAL_DECL(static Scheme_Object *cached_mod_stx); THREAD_LOCAL_DECL(static Scheme_Object *cached_mod_beg_stx); THREAD_LOCAL_DECL(static Scheme_Object *cached_dv_stx); THREAD_LOCAL_DECL(static Scheme_Object *cached_ds_stx); -THREAD_LOCAL_DECL(static Scheme_Object *cached_dvs_stx); +THREAD_LOCAL_DECL(static Scheme_Object *cached_bfs_stx); THREAD_LOCAL_DECL(static int cached_stx_phase); THREAD_LOCAL_DECL(static Scheme_Cont *offstack_cont); THREAD_LOCAL_DECL(static Scheme_Overflow *offstack_overflow); @@ -624,7 +624,7 @@ scheme_init_fun_places() REGISTER_SO(cached_mod_beg_stx); REGISTER_SO(cached_dv_stx); REGISTER_SO(cached_ds_stx); - REGISTER_SO(cached_dvs_stx); + REGISTER_SO(cached_bfs_stx); REGISTER_SO(offstack_cont); REGISTER_SO(offstack_overflow); } @@ -1550,7 +1550,7 @@ cert_with_specials(Scheme_Object *code, /* Arms (insp) or re-arms (old_stx) taints. */ { Scheme_Object *prop; - int next_cadr_deflt = 0; + int next_cadr_deflt = 0, phase_delta = 0; #ifdef DO_STACK_CHECK { @@ -1609,7 +1609,7 @@ cert_with_specials(Scheme_Object *code, name = scheme_stx_taint_disarm(code, NULL); name = SCHEME_STX_CAR(name); if (SCHEME_STX_SYMBOLP(name)) { - Scheme_Object *beg_stx, *mod_stx, *mod_beg_stx, *dv_stx, *ds_stx, *dvs_stx; + Scheme_Object *beg_stx, *mod_stx, *mod_beg_stx, *dv_stx, *ds_stx, *bfs_stx; if (!phase) { mod_stx = scheme_module_stx; @@ -1617,14 +1617,14 @@ cert_with_specials(Scheme_Object *code, mod_beg_stx = scheme_module_begin_stx; dv_stx = scheme_define_values_stx; ds_stx = scheme_define_syntaxes_stx; - dvs_stx = scheme_define_for_syntaxes_stx; + bfs_stx = scheme_begin_for_syntax_stx; } else if (phase == cached_stx_phase) { beg_stx = cached_beg_stx; mod_stx = cached_mod_stx; mod_beg_stx = cached_mod_beg_stx; dv_stx = cached_dv_stx; ds_stx = cached_ds_stx; - dvs_stx = cached_dvs_stx; + bfs_stx = cached_bfs_stx; } else { Scheme_Object *sr; sr = scheme_sys_wraps_phase(scheme_make_integer(phase)); @@ -1638,14 +1638,14 @@ cert_with_specials(Scheme_Object *code, sr, 0, 0); ds_stx = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_define_syntaxes_stx), scheme_false, sr, 0, 0); - dvs_stx = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_define_for_syntaxes_stx), scheme_false, + bfs_stx = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_begin_for_syntax_stx), scheme_false, sr, 0, 0); cached_beg_stx = beg_stx; cached_mod_stx = mod_stx; cached_mod_beg_stx = mod_beg_stx; cached_dv_stx = dv_stx; cached_ds_stx = ds_stx; - cached_dvs_stx = dvs_stx; + cached_bfs_stx = bfs_stx; cached_stx_phase = phase; } @@ -1654,9 +1654,12 @@ cert_with_specials(Scheme_Object *code, || scheme_stx_module_eq(mod_beg_stx, name, phase)) { trans = 1; next_cadr_deflt = 0; + } else if (scheme_stx_module_eq(bfs_stx, name, phase)) { + trans = 1; + next_cadr_deflt = 0; + phase_delta = 1; } else if (scheme_stx_module_eq(dv_stx, name, phase) - || scheme_stx_module_eq(ds_stx, name, phase) - || scheme_stx_module_eq(dvs_stx, name, phase)) { + || scheme_stx_module_eq(ds_stx, name, phase)) { trans = 1; next_cadr_deflt = 1; } @@ -1676,9 +1679,9 @@ cert_with_specials(Scheme_Object *code, Scheme_Object *a, *d, *v; a = SCHEME_STX_CAR(code); - a = cert_with_specials(a, insp, old_stx, phase, cadr_deflt, 0); + a = cert_with_specials(a, insp, old_stx, phase + phase_delta, cadr_deflt, 0); d = SCHEME_STX_CDR(code); - d = cert_with_specials(d, insp, old_stx, phase, 1, next_cadr_deflt); + d = cert_with_specials(d, insp, old_stx, phase + phase_delta, 1, next_cadr_deflt); v = scheme_make_pair(a, d); diff --git a/src/racket/src/jit.c b/src/racket/src/jit.c index 77ae9e551c..239a5f3b09 100644 --- a/src/racket/src/jit.c +++ b/src/racket/src/jit.c @@ -2364,7 +2364,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w case scheme_splice_sequence_type: case scheme_define_values_type: case scheme_define_syntaxes_type: - case scheme_define_for_syntax_type: + case scheme_begin_for_syntax_type: case scheme_require_form_type: case scheme_module_type: { diff --git a/src/racket/src/jitprep.c b/src/racket/src/jitprep.c index 594e6ca729..a335ae94d9 100644 --- a/src/racket/src/jitprep.c +++ b/src/racket/src/jitprep.c @@ -483,7 +483,7 @@ static Scheme_Object *define_syntaxes_jit(Scheme_Object *expr) return do_define_syntaxes_clone(expr, 1); } -static Scheme_Object *define_for_syntaxes_jit(Scheme_Object *expr) +static Scheme_Object *begin_for_syntax_jit(Scheme_Object *expr) { return do_define_syntaxes_clone(expr, 1); } @@ -583,8 +583,8 @@ Scheme_Object *scheme_jit_expr(Scheme_Object *expr) return define_values_jit(expr); case scheme_define_syntaxes_type: return define_syntaxes_jit(expr); - case scheme_define_for_syntax_type: - return define_for_syntaxes_jit(expr); + case scheme_begin_for_syntax_type: + return begin_for_syntax_jit(expr); case scheme_set_bang_type: return set_jit(expr); case scheme_boxenv_type: @@ -622,9 +622,26 @@ static Scheme_Object *do_define_syntaxes_clone(Scheme_Object *expr, int jit) rhs = SCHEME_VEC_ELS(expr)[0]; #ifdef MZ_USE_JIT - if (jit) - naya = scheme_jit_expr(rhs); - else + if (jit) { + if (SAME_TYPE(SCHEME_TYPE(expr), scheme_define_syntaxes_type)) + naya = scheme_jit_expr(rhs); + else { + int changed = 0; + Scheme_Object *a, *l = rhs; + naya = scheme_null; + while (!SCHEME_NULLP(l)) { + a = scheme_jit_expr(SCHEME_CAR(l)); + if (!SAME_OBJ(a, SCHEME_CAR(l))) + changed = 1; + naya = scheme_make_pair(a, naya); + l = SCHEME_CDR(l); + } + if (changed) + naya = scheme_reverse(naya); + else + naya = rhs; + } + } else #endif naya = rhs; diff --git a/src/racket/src/marshal.c b/src/racket/src/marshal.c index e042ffcdb9..c389cbe8d7 100644 --- a/src/racket/src/marshal.c +++ b/src/racket/src/marshal.c @@ -45,8 +45,8 @@ static Scheme_Object *read_define_values(Scheme_Object *obj); static Scheme_Object *write_define_values(Scheme_Object *obj); static Scheme_Object *read_define_syntaxes(Scheme_Object *obj); static Scheme_Object *write_define_syntaxes(Scheme_Object *obj); -static Scheme_Object *read_define_for_syntax(Scheme_Object *obj); -static Scheme_Object *write_define_for_syntax(Scheme_Object *obj); +static Scheme_Object *read_begin_for_syntax(Scheme_Object *obj); +static Scheme_Object *write_begin_for_syntax(Scheme_Object *obj); static Scheme_Object *read_set_bang(Scheme_Object *obj); static Scheme_Object *write_set_bang(Scheme_Object *obj); static Scheme_Object *read_boxenv(Scheme_Object *obj); @@ -125,8 +125,8 @@ void scheme_init_marshal(Scheme_Env *env) scheme_install_type_reader(scheme_define_values_type, read_define_values); scheme_install_type_writer(scheme_define_syntaxes_type, write_define_syntaxes); scheme_install_type_reader(scheme_define_syntaxes_type, read_define_syntaxes); - scheme_install_type_writer(scheme_define_for_syntax_type, write_define_for_syntax); - scheme_install_type_reader(scheme_define_for_syntax_type, read_define_for_syntax); + scheme_install_type_writer(scheme_begin_for_syntax_type, write_begin_for_syntax); + scheme_install_type_reader(scheme_begin_for_syntax_type, read_begin_for_syntax); scheme_install_type_writer(scheme_set_bang_type, write_set_bang); scheme_install_type_reader(scheme_set_bang_type, read_set_bang); scheme_install_type_writer(scheme_boxenv_type, write_boxenv); @@ -407,16 +407,16 @@ static Scheme_Object *write_define_syntaxes(Scheme_Object *obj) return write_define_values(obj); } -static Scheme_Object *read_define_for_syntax(Scheme_Object *obj) +static Scheme_Object *read_begin_for_syntax(Scheme_Object *obj) { if (!SCHEME_VECTORP(obj)) return NULL; obj = scheme_clone_vector(obj, 0, 0); - obj->type = scheme_define_for_syntax_type; + obj->type = scheme_begin_for_syntax_type; return obj; } -static Scheme_Object *write_define_for_syntax(Scheme_Object *obj) +static Scheme_Object *write_begin_for_syntax(Scheme_Object *obj) { return write_define_values(obj); } @@ -1125,8 +1125,8 @@ static Scheme_Object *write_module(Scheme_Object *obj) { Scheme_Module *m = (Scheme_Module *)obj; Scheme_Module_Phase_Exports *pt; - Scheme_Object *l, *v; - int i, k, count, cnt; + Scheme_Object *l, *v, *phase; + int i, j, k, count, cnt; l = scheme_null; cnt = 0; @@ -1147,22 +1147,27 @@ static Scheme_Object *write_module(Scheme_Object *obj) l = cons(m->et_requires, l); l = cons(m->requires, l); - l = cons(m->body, l); - l = cons(m->et_body, l); + for (j = 0; j < m->num_phases; j++) { + l = cons(m->bodies[j], l); + } cnt = 0; for (k = -3; k < (m->me->other_phases ? m->me->other_phases->size : 0); k++) { switch (k) { case -3: + phase = scheme_make_integer(-1); pt = m->me->dt; break; case -2: + phase = scheme_make_integer(1); pt = m->me->et; break; case -1: + phase = scheme_make_integer(0); pt = m->me->rt; break; default: + phase = m->me->other_phases->keys[k]; pt = (Scheme_Module_Phase_Exports *)m->me->other_phases->vals[k]; } @@ -1203,76 +1208,58 @@ static Scheme_Object *write_module(Scheme_Object *obj) if (pt->provide_src_phases) { v = scheme_make_vector(count, NULL); for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = (pt->provide_src_phases[i] ? scheme_true : scheme_false); + SCHEME_VEC_ELS(v)[i] = scheme_make_integer(pt->provide_src_phases[i]); } } else v = scheme_false; l = cons(v, l); + if ((SCHEME_INT_VAL(phase) >= 0) && (SCHEME_INT_VAL(phase) < m->num_phases)) { + Scheme_Module_Export_Info *exp_info = m->exp_infos[SCHEME_INT_VAL(phase)]; + + if (exp_info) { + v = scheme_false; + + if (exp_info->provide_protects) { + for (i = 0; i < count; i++) { + if (exp_info->provide_protects[i]) + break; + } + if (i < count) { + v = scheme_make_vector(count, NULL); + for (i = 0; i < count; i++) { + SCHEME_VEC_ELS(v)[i] = (exp_info->provide_protects[i] ? scheme_true : scheme_false); + } + } + } + l = cons(v, l); + + count = exp_info->num_indirect_provides; + l = cons(scheme_make_integer(count), l); + v = scheme_make_vector(count, NULL); + for (i = 0; i < count; i++) { + SCHEME_VEC_ELS(v)[i] = exp_info->indirect_provides[i]; + } + l = cons(v, l); + + count = exp_info->num_indirect_syntax_provides; + l = cons(scheme_make_integer(count), l); + v = scheme_make_vector(count, NULL); + for (i = 0; i < count; i++) { + SCHEME_VEC_ELS(v)[i] = exp_info->indirect_syntax_provides[i]; + } + l = cons(v, l); + } else + l = cons(scheme_void, l); + } else + l = cons(scheme_void, l); + l = cons(pt->phase_index, l); cnt++; } } - l = cons(scheme_make_integer(cnt), l); - - count = m->me->rt->num_provides; - if (m->provide_protects) { - for (i = 0; i < count; i++) { - if (m->provide_protects[i]) - break; - } - if (i < count) { - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = (m->provide_protects[i] ? scheme_true : scheme_false); - } - } else - v = scheme_false; - l = cons(v, l); - } else - l = cons(scheme_false, l); - - count = m->me->et->num_provides; - if (m->et_provide_protects) { - for (i = 0; i < count; i++) { - if (m->et_provide_protects[i]) - break; - } - if (i < count) { - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = (m->et_provide_protects[i] ? scheme_true : scheme_false); - } - } else - v = scheme_false; - l = cons(v, l); - } else - l = cons(scheme_false, l); - - count = m->num_indirect_provides; - l = cons(scheme_make_integer(count), l); - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = m->indirect_provides[i]; - } - l = cons(v, l); - - count = m->num_indirect_syntax_provides; - l = cons(scheme_make_integer(count), l); - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = m->indirect_syntax_provides[i]; - } - l = cons(v, l); - - count = m->num_indirect_et_provides; - l = cons(scheme_make_integer(count), l); - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = m->et_indirect_provides[i]; - } - l = cons(v, l); + l = cons(scheme_make_integer(m->num_phases), l); l = cons((Scheme_Object *)m->prefix, l); l = cons(m->dummy, l); @@ -1318,12 +1305,14 @@ static int check_requires_ok(Scheme_Object *l) static Scheme_Object *read_module(Scheme_Object *obj) { Scheme_Module *m; - Scheme_Object *ie, *nie; - Scheme_Object *eesp, *esp, *esn, *esph, *es, *esnom, *e, *nve, *ne, **v; + Scheme_Object *ie, *nie, **bodies; + Scheme_Object *esp, *esn, *esph, *es, *esnom, *e, *nve, *ne, **v; Scheme_Module_Exports *me; Scheme_Module_Phase_Exports *pt; - char *ps, *sps; - int i, count, cnt; + Scheme_Module_Export_Info **exp_infos, *exp_info; + char *ps; + int *sps; + int i, j, count, cnt; m = MALLOC_ONE_TAGGED(Scheme_Module); m->so.type = scheme_module_type; @@ -1387,67 +1376,21 @@ static Scheme_Object *read_module(Scheme_Object *obj) obj = SCHEME_CDR(obj); if (!SCHEME_PAIRP(obj)) return_NULL(); - ie = SCHEME_CAR(obj); + cnt = SCHEME_INT_VAL(SCHEME_CAR(obj)); obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return_NULL(); - nie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - count = SCHEME_INT_VAL(nie); + if (cnt < 1) return_NULL(); - if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(ie)[i]; + m->num_phases = cnt; + exp_infos = MALLOC_N(Scheme_Module_Export_Info *, cnt); + while (cnt--) { + exp_info = MALLOC_ONE_RT(Scheme_Module_Export_Info); + SET_REQUIRED_TAG(exp_info->type = scheme_rt_export_info); + exp_infos[cnt] = exp_info; } - m->et_indirect_provides = v; - m->num_indirect_et_provides = count; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - ie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - nie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); + m->exp_infos = exp_infos; + cnt = m->num_phases; - count = SCHEME_INT_VAL(nie); - - if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(ie)[i]; - } - m->indirect_syntax_provides = v; - m->num_indirect_syntax_provides = count; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - ie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - nie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - count = SCHEME_INT_VAL(nie); - - if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(ie)[i]; - } - m->indirect_provides = v; - m->num_indirect_provides = count; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - eesp = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - esp = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return_NULL(); cnt = SCHEME_INT_VAL(SCHEME_CAR(obj)); obj = SCHEME_CDR(obj); @@ -1482,6 +1425,67 @@ static Scheme_Object *read_module(Scheme_Object *obj) scheme_hash_set(me->other_phases, phase, (Scheme_Object *)pt); } + if (!SCHEME_PAIRP(obj)) return_NULL(); + ie = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + if (SCHEME_VOIDP(ie)) { + /* no exp_infos entry */ + count = -1; + } else { + if (!SCHEME_INTP(phase) || (SCHEME_INT_VAL(phase) < 0) + || (SCHEME_INT_VAL(phase) >= m->num_phases)) + return_NULL(); + exp_info = m->exp_infos[SCHEME_INT_VAL(phase)]; + + if (!SCHEME_PAIRP(obj)) return_NULL(); + nie = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + count = SCHEME_INT_VAL(nie); + if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); + v = MALLOC_N(Scheme_Object *, count); + for (i = 0; i < count; i++) { + v[i] = SCHEME_VEC_ELS(ie)[i]; + } + exp_info->indirect_syntax_provides = v; + exp_info->num_indirect_syntax_provides = count; + + if (!SCHEME_PAIRP(obj)) return_NULL(); + ie = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + nie = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + count = SCHEME_INT_VAL(nie); + + if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); + v = MALLOC_N(Scheme_Object *, count); + for (i = 0; i < count; i++) { + v[i] = SCHEME_VEC_ELS(ie)[i]; + } + exp_info->indirect_provides = v; + exp_info->num_indirect_provides = count; + + if (!SCHEME_PAIRP(obj)) return_NULL(); + esp = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (SCHEME_FALSEP(esp)) { + exp_info->provide_protects = NULL; + count = -1; + } else { + if (!SCHEME_VECTORP(esp)) return_NULL(); + count = SCHEME_VEC_SIZE(esp); + ps = MALLOC_N_ATOMIC(char, count); + for (i = 0; i < count; i++) { + ps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(esp)[i]); + } + exp_info->provide_protects = ps; + } + } + if (!SCHEME_PAIRP(obj)) return_NULL(); esph = SCHEME_CAR(obj); obj = SCHEME_CDR(obj); @@ -1510,6 +1514,8 @@ static Scheme_Object *read_module(Scheme_Object *obj) ne = SCHEME_CAR(obj); obj = SCHEME_CDR(obj); + if ((count != -1) && (SCHEME_INT_VAL(ne) != count)) return_NULL(); + count = SCHEME_INT_VAL(ne); pt->num_provides = count; pt->num_var_provides = SCHEME_INT_VAL(nve); @@ -1550,9 +1556,9 @@ static Scheme_Object *read_module(Scheme_Object *obj) sps = NULL; else { if (!SCHEME_VECTORP(esph) || (SCHEME_VEC_SIZE(esph) != count)) return_NULL(); - sps = MALLOC_N_ATOMIC(char, count); + sps = MALLOC_N_ATOMIC(int, count); for (i = 0; i < count; i++) { - sps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(esph)[i]); + sps[i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(esph)[i]); } } pt->provide_src_phases = sps; @@ -1560,55 +1566,40 @@ static Scheme_Object *read_module(Scheme_Object *obj) count = me->rt->num_provides; - if (SCHEME_FALSEP(esp)) { - m->provide_protects = NULL; - } else { - if (!SCHEME_VECTORP(esp) || (SCHEME_VEC_SIZE(esp) != count)) return_NULL(); - ps = MALLOC_N_ATOMIC(char, count); - for (i = 0; i < count; i++) { - ps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(esp)[i]); - } - m->provide_protects = ps; - } - - if (SCHEME_FALSEP(eesp)) { - m->et_provide_protects = NULL; - } else { - if (!SCHEME_VECTORP(eesp) || (SCHEME_VEC_SIZE(eesp) != count)) return_NULL(); - ps = MALLOC_N_ATOMIC(char, count); - for (i = 0; i < count; i++) { - ps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(eesp)[i]); - } - m->et_provide_protects = ps; - } - - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = SCHEME_CAR(obj); - if (!SCHEME_VECTORP(e)) return_NULL(); - m->et_body = e; - for (i = SCHEME_VEC_SIZE(e); i--; ) { - e = SCHEME_VEC_ELS(m->et_body)[i]; + bodies = MALLOC_N(Scheme_Object*, m->num_phases); + m->bodies = bodies; + for (j = m->num_phases; j--; ) { + if (!SCHEME_PAIRP(obj)) return_NULL(); + e = SCHEME_CAR(obj); if (!SCHEME_VECTORP(e)) return_NULL(); - /* SCHEME_VEC_ELS(e)[1] should be code */ - if (!SCHEME_INTP(SCHEME_VEC_ELS(e)[2])) return_NULL(); - if (!SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(e)[3]), scheme_resolve_prefix_type)) - return_NULL(); - e = SCHEME_VEC_ELS(e)[0]; - if (!SCHEME_SYMBOLP(e)) { - while (SCHEME_PAIRP(e)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(e))) return_NULL(); - e = SCHEME_CDR(e); + if (j) { + bodies[j] = e; + for (i = SCHEME_VEC_SIZE(e); i--; ) { + e = SCHEME_VEC_ELS(bodies[j])[i]; + if (!SCHEME_VECTORP(e)) return_NULL(); + if (SCHEME_VEC_SIZE(e) != 5) return_NULL(); + /* SCHEME_VEC_ELS(e)[1] should be code */ + if (!SCHEME_INTP(SCHEME_VEC_ELS(e)[2])) return_NULL(); + if (!SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(e)[3]), scheme_resolve_prefix_type)) + return_NULL(); + if (SCHEME_FALSEP(SCHEME_VEC_ELS(e)[0])) { + if (SCHEME_FALSEP(SCHEME_VEC_ELS(e)[4])) return_NULL(); + } else { + e = SCHEME_VEC_ELS(e)[0]; + if (!SCHEME_SYMBOLP(e)) { + while (SCHEME_PAIRP(e)) { + if (!SCHEME_SYMBOLP(SCHEME_CAR(e))) return_NULL(); + e = SCHEME_CDR(e); + } + if (!SCHEME_NULLP(e)) return_NULL(); + } + } } - if (!SCHEME_NULLP(e)) return_NULL(); + } else { + bodies[j] = e; } + obj = SCHEME_CDR(obj); } - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = SCHEME_CAR(obj); - if (!SCHEME_VECTORP(e)) return_NULL(); - m->body = e; - obj = SCHEME_CDR(obj); if (!SCHEME_PAIRP(obj)) return_NULL(); if (scheme_proper_list_length(SCHEME_CAR(obj)) < 0) return_NULL(); diff --git a/src/racket/src/module.c b/src/racket/src/module.c index e1a432fc6e..a90271aab6 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -90,16 +90,51 @@ static Scheme_Object *provide_expand(Scheme_Object *form, Scheme_Comp_Env *env, static Scheme_Module *module_load(Scheme_Object *modname, Scheme_Env *env, const char *who); static void run_module(Scheme_Env *menv, int set_ns); -static void run_module_exptime(Scheme_Env *menv, int set_ns); +static void run_module_exptime(Scheme_Env *menv, int phase); static void eval_exptime(Scheme_Object *names, int count, Scheme_Object *expr, Scheme_Env *genv, Scheme_Comp_Env *env, Resolve_Prefix *rp, int let_depth, int shift, - Scheme_Bucket_Table *syntax, int for_stx, + Scheme_Bucket_Table *syntax, int at_phase, Scheme_Object *free_id_rename_rn, Scheme_Object *insp); +typedef struct Module_Begin_Expand_State { + /* All pointers, because it's allocated with scheme_malloc(): */ + Scheme_Object *post_ex_rn_set; + Scheme_Hash_Table *tables; /* phase -> (vector toplevels requires syntaxes) */ + Scheme_Hash_Table *all_provided; /* phase -> table like `provided' */ + Scheme_Hash_Table *all_reprovided; /* phase -> list of (list modidx syntax except-name ...) */ + Scheme_Hash_Tree *all_defs; /* phase -> list of sxtid */ + Scheme_Hash_Table *all_defs_out; /* phase -> list of (cons protected? (stx-list except-name ...)) */ + int *all_simple_renames; + int *_num_phases; + Scheme_Object *saved_provides; /* list of (cons form phase) */ + Scheme_Hash_Table *modidx_cache; + Scheme_Object *redef_modname; +} Module_Begin_Expand_State; + +static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Expand_Info *rec, int drec, + Scheme_Compile_Expand_Info *erec, int derec, + int phase, Scheme_Object *body_lists, + Module_Begin_Expand_State *bxs); + +static Scheme_Object *expand_all_provides(Scheme_Object *form, + Scheme_Comp_Env *cenv, + Scheme_Compile_Expand_Info *rec, int drec, + Scheme_Object *self_modidx, + Module_Begin_Expand_State *bxs, + int keep_expanded); + +static Scheme_Object *fixup_expanded_provides(Scheme_Object *expanded_l, + Scheme_Object *expanded_provides, + int phase); + +static void check_formerly_unbound(Scheme_Object *unbounds, Scheme_Comp_Env *env); +static void install_stops(Scheme_Comp_Env *xenv, int phase, Scheme_Object **sv); + static Scheme_Object *scheme_sys_wraps_phase_worker(intptr_t p); #define cons scheme_make_pair @@ -153,7 +188,7 @@ READ_ONLY Scheme_Object *scheme_begin_stx; READ_ONLY Scheme_Object *scheme_define_values_stx; READ_ONLY Scheme_Object *scheme_define_syntaxes_stx; READ_ONLY Scheme_Object *scheme_top_stx; -READ_ONLY Scheme_Object *scheme_define_for_syntaxes_stx; +READ_ONLY Scheme_Object *scheme_begin_for_syntax_stx; READ_ONLY static Scheme_Object *modbeg_syntax; READ_ONLY static Scheme_Object *require_stx; READ_ONLY static Scheme_Object *provide_stx; @@ -209,7 +244,7 @@ typedef void (*Check_Func)(Scheme_Object *prnt_name, Scheme_Object *name, Scheme_Object *err_src, Scheme_Object *mark_src, Scheme_Object *to_phase, Scheme_Object *src_phase_index, Scheme_Object *nominal_export_phase); -static void parse_requires(Scheme_Object *form, +static void parse_requires(Scheme_Object *form, int at_phase, Scheme_Object *base_modidx, Scheme_Env *env, Scheme_Module *for_m, @@ -221,35 +256,37 @@ static void parse_requires(Scheme_Object *form, int *all_simple, Scheme_Hash_Table *modix_cache); static void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, + int at_phase, Scheme_Hash_Table *all_provided, Scheme_Hash_Table *all_reprovided, Scheme_Object *self_modidx, - Scheme_Object **_all_defs_out, - Scheme_Object **_et_all_defs_out, + Scheme_Hash_Table *all_defs_out, Scheme_Hash_Table *tables, - Scheme_Object *all_defs, Scheme_Object *all_et_defs, + Scheme_Hash_Tree *all_defs, Scheme_Comp_Env *cenv, Scheme_Compile_Info *rec, int drec, - Scheme_Object **_expanded); + Scheme_Object **_expanded, + Scheme_Object *begin_stx); static int compute_reprovides(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *all_reprovided, Scheme_Module *mod_for_requires, Scheme_Hash_Table *tables, Scheme_Env *genv, - Scheme_Object *all_rt_defs, Scheme_Object *all_rt_defs_out, - Scheme_Object *all_et_defs, Scheme_Object *all_et_defs_out, + int num_phases, + Scheme_Hash_Tree *all_defs, Scheme_Hash_Table *all_defs_out, const char *matching_form, Scheme_Object *all_mods, Scheme_Object *all_phases); -static char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, - Scheme_Module_Exports *me, - Scheme_Env *genv, - Scheme_Object *form, - char **_phase1_protects); +static void compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, + Scheme_Module_Exports *me, + Scheme_Env *genv, + Scheme_Object *form, + int num_phases, Scheme_Module_Export_Info **exp_infos); static Scheme_Object **compute_indirects(Scheme_Env *genv, Scheme_Module_Phase_Exports *pt, int *_count, int vars); static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx, - int eval_exp, int eval_run, intptr_t base_phase, Scheme_Object *cycle_list); + int eval_exp, int eval_run, intptr_t base_phase, Scheme_Object *cycle_list, + int not_new); static void eval_module_body(Scheme_Env *menv, Scheme_Env *env); static Scheme_Object *do_namespace_require(Scheme_Env *env, int argc, Scheme_Object *argv[], @@ -257,7 +294,7 @@ static Scheme_Object *do_namespace_require(Scheme_Env *env, int argc, Scheme_Obj static Scheme_Object *default_module_resolver(int argc, Scheme_Object **argv); -static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, char *exps, char *exets, +static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, char *exps, int *exets, Scheme_Object **exsnoms, int start, int count, int do_uninterned); @@ -396,12 +433,25 @@ void scheme_init_module_resolver(void) scheme_set_param(config, MZCONFIG_CURRENT_MODULE_NAME, scheme_false); } +static void add_exp_infos(Scheme_Module *m) +{ + Scheme_Module_Export_Info **exp_infos, *exp_info; + + exp_infos = MALLOC_N(Scheme_Module_Export_Info *, 1); + exp_info = MALLOC_ONE_RT(Scheme_Module_Export_Info); + SET_REQUIRED_TAG(exp_info->type = scheme_rt_export_info); + exp_infos[0] = exp_info; + m->exp_infos = exp_infos; + m->num_phases = 1; +} + void scheme_finish_kernel(Scheme_Env *env) { /* When this function is called, the initial namespace has all the primitive bindings for syntax and procedures. This function fills in the module wrapper for #%kernel. */ Scheme_Object *w; + char *running; REGISTER_SO(kernel); @@ -424,7 +474,7 @@ void scheme_finish_kernel(Scheme_Env *env) kernel->tt_requires = scheme_null; kernel->dt_requires = scheme_null; kernel->other_requires = NULL; - + add_exp_infos(kernel); { Scheme_Bucket_Table *ht; @@ -482,8 +532,10 @@ void scheme_finish_kernel(Scheme_Env *env) kernel->me->rt->num_var_provides = syntax_start; scheme_populate_pt_ht(kernel->me->rt); - env->running = 1; - env->et_running = 1; + running = (char *)scheme_malloc_atomic(2); + running[0] = 1; + running[1] = 1; + env->running = running; env->attached = 1; /* Since this is the first module rename, it's registered as @@ -509,7 +561,7 @@ void scheme_finish_kernel(Scheme_Env *env) REGISTER_SO(scheme_begin_stx); REGISTER_SO(scheme_define_values_stx); REGISTER_SO(scheme_define_syntaxes_stx); - REGISTER_SO(scheme_define_for_syntaxes_stx); + REGISTER_SO(scheme_begin_for_syntax_stx); REGISTER_SO(require_stx); REGISTER_SO(provide_stx); REGISTER_SO(set_stx); @@ -533,7 +585,7 @@ void scheme_finish_kernel(Scheme_Env *env) scheme_begin_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin"), scheme_false, w, 0, 0); scheme_define_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-values"), scheme_false, w, 0, 0); scheme_define_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-syntaxes"), scheme_false, w, 0, 0); - scheme_define_for_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-values-for-syntax"), scheme_false, w, 0, 0); + scheme_begin_for_syntax_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin-for-syntax"), scheme_false, w, 0, 0); require_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%require"), scheme_false, w, 0, 0); provide_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), scheme_false, w, 0, 0); set_stx = scheme_datum_to_syntax(scheme_intern_symbol("set!"), scheme_false, w, 0, 0); @@ -545,7 +597,6 @@ void scheme_finish_kernel(Scheme_Env *env) letrec_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("letrec-values"), scheme_false, w, 0, 0); if_stx = scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, w, 0, 0); begin0_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin0"), scheme_false, w, 0, 0); - set_stx = scheme_datum_to_syntax(scheme_intern_symbol("set!"), scheme_false, w, 0, 0); with_continuation_mark_stx = scheme_datum_to_syntax(scheme_intern_symbol("with-continuation-mark"), scheme_false, w, 0, 0); letrec_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("letrec-syntaxes+values"), scheme_false, w, 0, 0); var_ref_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%variable-reference"), scheme_false, w, 0, 0); @@ -774,7 +825,7 @@ void scheme_install_initial_module_set(Scheme_Env *env) /* Make sure module is running: */ m = (Scheme_Module *)scheme_hash_get(initial_modules_env->module_registry->loaded, a[1]); - start_module(m, initial_modules_env, 0, a[1], 0, 1, 0, scheme_null); + start_module(m, initial_modules_env, 0, a[1], 0, 1, 0, scheme_null, 0); namespace_attach_module(3, a); } @@ -994,7 +1045,7 @@ static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[], Scheme_Config *config; Scheme_Cont_Frame_Data cframe; - start_module(m, env, 0, modidx, 0, 1, base_phase, scheme_null); + start_module(m, env, 0, modidx, 0, 1, base_phase, scheme_null, 0); ns = scheme_make_namespace(0, NULL); a[0] = (Scheme_Object *)env; a[1] = srcm->modname; @@ -1032,8 +1083,8 @@ static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[], } if (i < count) { - if (srcm->provide_protects) - protected = srcm->provide_protects[i]; + if (srcm->exp_infos[0]->provide_protects) + protected = srcm->exp_infos[0]->provide_protects[i]; srcmname = (srcm->me->rt->provide_srcs ? srcm->me->rt->provide_srcs[i] : scheme_false); if (SCHEME_FALSEP(srcmname)) srcmname = srcm->modname; @@ -1047,27 +1098,28 @@ static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[], if (i == count) { if (indirect_ok) { /* Try indirect provides: */ + Scheme_Module_Export_Info *exp_info = m->exp_infos[0]; srcm = m; - count = srcm->num_indirect_provides; + count = exp_info->num_indirect_provides; if (position >= 0) { i = position; - if ((i < srcm->num_indirect_provides) - && (SCHEME_SYM_LEN(name) == SCHEME_SYM_LEN(srcm->indirect_provides[i])) - && !memcmp(SCHEME_SYM_VAL(name), SCHEME_SYM_VAL(srcm->indirect_provides[i]), SCHEME_SYM_LEN(name))) { - name = srcm->indirect_provides[i]; + if ((i < exp_info->num_indirect_provides) + && (SCHEME_SYM_LEN(name) == SCHEME_SYM_LEN(exp_info->indirect_provides[i])) + && !memcmp(SCHEME_SYM_VAL(name), SCHEME_SYM_VAL(exp_info->indirect_provides[i]), SCHEME_SYM_LEN(name))) { + name = exp_info->indirect_provides[i]; srcname = name; srcmname = srcm->modname; - if (srcm->provide_protects) - protected = srcm->provide_protects[i]; + if (exp_info->provide_protects) + protected = exp_info->provide_protects[i]; } else i = count; /* not found */ } else { for (i = 0; i < count; i++) { - if (SAME_OBJ(name, srcm->indirect_provides[i])) { + if (SAME_OBJ(name, exp_info->indirect_provides[i])) { srcname = name; srcmname = srcm->modname; - if (srcm->provide_protects) - protected = srcm->provide_protects[i]; + if (exp_info->provide_protects) + protected = exp_info->provide_protects[i]; break; } } @@ -1099,7 +1151,8 @@ static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[], ? 0 : 1), base_phase, - scheme_null); + scheme_null, + 0); if (SCHEME_SYMBOLP(name)) { Scheme_Bucket *b; @@ -1177,7 +1230,7 @@ static Scheme_Object *do_namespace_require(Scheme_Env *env, int argc, Scheme_Obj rns = scheme_make_module_rename_set(mzMOD_RENAME_TOPLEVEL, NULL, insp); - parse_requires(form, scheme_false, env, NULL, + parse_requires(form, env->phase, scheme_false, env, NULL, rns, NULL, NULL /* ck */, NULL /* data */, NULL, @@ -1692,8 +1745,9 @@ static Scheme_Object *do_namespace_attach_module(const char *who, int argc, Sche start_module(m2, from_env->label_env, 0, main_modidx, - 0, 0, from_env->phase, - scheme_null); + 0, 0, -1, + scheme_null, + 0); scheme_pop_continuation_frame(&cframe); @@ -2373,7 +2427,7 @@ static int do_add_simple_require_renames(Scheme_Object *rn, { int i, saw_mb, numvals; Scheme_Object **exs, **exss, **exsns, *midx, *info, *vec, *nml, *mark_src; - char *exets; + int *exets; int with_shared = 1; saw_mb = 0; @@ -2422,7 +2476,7 @@ static int do_add_simple_require_renames(Scheme_Object *rn, SCHEME_VEC_ELS(vec)[5] = orig_src; SCHEME_VEC_ELS(vec)[6] = mark_src; SCHEME_VEC_ELS(vec)[7] = (can_override ? scheme_true : scheme_false); - SCHEME_VEC_ELS(vec)[8] = exets ? scheme_make_integer(exets[i]) : scheme_false; + SCHEME_VEC_ELS(vec)[8] = exets ? scheme_make_integer(exets[i]) : scheme_make_integer(0); scheme_hash_set(required, exs[i], vec); } } @@ -2531,7 +2585,7 @@ static int add_simple_require_renames(Scheme_Object *orig_src, void scheme_prep_namespace_rename(Scheme_Env *menv) { scheme_prepare_exp_env(menv); - start_module(menv->module, menv, 0, NULL, -1, 1, menv->phase, scheme_null); + start_module(menv->module, menv, 0, NULL, -1, 1, menv->phase, scheme_null, 1); if (!menv->rename_set_ready) { if (menv->module->rn_stx) { @@ -2544,7 +2598,7 @@ void scheme_prep_namespace_rename(Scheme_Env *menv) /* Reconstruct renames based on defns and requires. This case is used only when it's easy to reconstruct: no renames, no for-syntax definitions, etc. */ - int i; + int i, j; Scheme_Module *im; Scheme_Object *l, *idx, *one_rn, *shift, *name; @@ -2559,19 +2613,20 @@ void scheme_prep_namespace_rename(Scheme_Env *menv) scheme_make_integer(0), NULL, 0); } } - /* Local, not provided: */ - for (i = 0; i < m->num_indirect_provides; i++) { - name = m->indirect_provides[i]; - scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0, - scheme_make_integer(0), NULL, 0); - } - for (i = 0; i < m->num_indirect_syntax_provides; i++) { - name = m->indirect_syntax_provides[i]; - scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0, - scheme_make_integer(0), NULL, 0); - } - - one_rn = scheme_get_module_rename_from_set(rns, scheme_make_integer(1), 1); + for (j = 0; j < m->num_phases; j++) { + Scheme_Module_Export_Info *exp_info = m->exp_infos[j]; + one_rn = scheme_get_module_rename_from_set(rns, scheme_make_integer(j), 1); + for (i = 0; i < exp_info->num_indirect_provides; i++) { + name = exp_info->indirect_provides[i]; + scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, j, + scheme_make_integer(j), NULL, 0); + } + for (i = 0; i < exp_info->num_indirect_syntax_provides; i++) { + name = exp_info->indirect_syntax_provides[i]; + scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, j, + scheme_make_integer(j), NULL, 0); + } + } /* Required: */ for (i = -4; i < (menv->other_require_names ? menv->other_require_names->size : 0); i++) { @@ -3108,7 +3163,7 @@ static Scheme_Object *module_export_protected_p(int argc, Scheme_Object **argv) count = m->me->rt->num_provides; for (i = 0; i < count; i++) { if (SAME_OBJ(name, m->me->rt->provides[i])) { - if (m->provide_protects && m->provide_protects[i]) + if (m->exp_infos[0]->provide_protects && m->exp_infos[0]->provide_protects[i]) return scheme_true; else return scheme_false; @@ -3445,15 +3500,22 @@ static int is_procedure_expression(Scheme_Object *e) static void setup_accessible_table(Scheme_Module *m) { - if (!m->accessible) { + if (!m->exp_infos[0]->accessible) { Scheme_Module_Phase_Exports *pt; int j; - for (j = 0; j < 2; j++) { + for (j = 0; j < m->num_phases; j++) { if (!j) pt = m->me->rt; - else + else if (j == 1) pt = m->me->et; + else { + if (m->me->other_phases) + pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(m->me->other_phases, + scheme_make_integer(j)); + else + pt = NULL; + } if (pt) { Scheme_Hash_Table *ht; @@ -3467,16 +3529,9 @@ static void setup_accessible_table(Scheme_Module *m) } } - if (j == 0) { - count = m->num_indirect_provides; - for (i = 0; i < count; i++) { - scheme_hash_set(ht, m->indirect_provides[i], scheme_make_integer(i + nvp)); - } - } else { - count = m->num_indirect_et_provides; - for (i = 0; i < count; i++) { - scheme_hash_set(ht, m->et_indirect_provides[i], scheme_make_integer(i + nvp)); - } + count = m->exp_infos[j]->num_indirect_provides; + for (i = 0; i < count; i++) { + scheme_hash_set(ht, m->exp_infos[j]->indirect_provides[i], scheme_make_integer(i + nvp)); } /* Add syntax as negative ids: */ @@ -3489,11 +3544,11 @@ static void setup_accessible_table(Scheme_Module *m) if (!j) { /* find constants: */ - int i, cnt = SCHEME_VEC_SIZE(m->body), k; + int i, cnt = SCHEME_VEC_SIZE(m->bodies[0]), k; Scheme_Object *form, *tl; for (i = 0; i < cnt; i++) { - form = SCHEME_VEC_ELS(m->body)[i]; + form = SCHEME_VEC_ELS(m->bodies[0])[i]; if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_values_type)) { for (k = SCHEME_VEC_SIZE(form); k-- > 1; ) { tl = SCHEME_VEC_ELS(form)[k]; @@ -3529,10 +3584,9 @@ static void setup_accessible_table(Scheme_Module *m) } } } + } - m->accessible = ht; - } else - m->et_accessible = ht; + m->exp_infos[j]->accessible = ht; } } } @@ -3542,10 +3596,7 @@ Scheme_Env *scheme_module_access(Scheme_Object *name, Scheme_Env *env, intptr_t { Scheme_Env *menv; - if (!rev_mod_phase) - menv = get_special_modenv(name); - else - menv = NULL; + menv = get_special_modenv(name); if (!menv) { Scheme_Object *chain; @@ -3633,7 +3684,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object symbol = scheme_tl_id_sym(env, symbol, NULL, 0, NULL, NULL); if (scheme_is_kernel_env(env) - || ((env->module->primitive && !env->module->provide_protects))) { + || ((env->module->primitive && !env->module->exp_infos[0]->provide_protects))) { if (want_pos) return scheme_make_integer(-1); else @@ -3671,12 +3722,9 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object int num_indirect_provides; Scheme_Object **indirect_provides; - if (env->mod_phase == 0) { - num_indirect_provides = env->module->num_indirect_provides; - indirect_provides = env->module->indirect_provides; - } else if (env->mod_phase == 1) { - num_indirect_provides = env->module->num_indirect_et_provides; - indirect_provides = env->module->et_indirect_provides; + if ((env->mod_phase >= 0) && (env->mod_phase < env->module->num_phases)) { + num_indirect_provides = env->module->exp_infos[env->mod_phase]->num_indirect_provides; + indirect_provides = env->module->exp_infos[env->mod_phase]->indirect_provides; } else { num_indirect_provides = 0; indirect_provides = NULL; @@ -3699,11 +3747,9 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object if ((position < pt->num_var_provides) && scheme_module_protected_wrt(env->insp, prot_insp)) { char *provide_protects; - - if (env->mod_phase == 0) - provide_protects = env->module->provide_protects; - else if (env->mod_phase == 0) - provide_protects = env->module->et_provide_protects; + + if ((env->mod_phase >= 0) && (env->mod_phase < env->module->num_phases)) + provide_protects = env->module->exp_infos[env->mod_phase]->provide_protects; else provide_protects = NULL; @@ -3728,10 +3774,8 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object } else { Scheme_Object *pos; - if (!env->mod_phase) - pos = scheme_hash_get(env->module->accessible, symbol); - else if (env->mod_phase == 1) - pos = scheme_hash_get(env->module->et_accessible, symbol); + if (env->mod_phase < env->module->num_phases) + pos = scheme_hash_get(env->module->exp_infos[env->mod_phase]->accessible, symbol); else pos = NULL; @@ -3757,10 +3801,8 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object if (pos) { char *provide_protects; - if (env->mod_phase == 0) - provide_protects = env->module->provide_protects; - else if (env->mod_phase == 1) - provide_protects = env->module->et_provide_protects; + if ((env->mod_phase >= 0) && (env->mod_phase < env->module->num_phases)) + provide_protects = env->module->exp_infos[env->mod_phase]->provide_protects; else provide_protects = NULL; @@ -3880,7 +3922,7 @@ int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Schem setup_accessible_table(m); - pos = scheme_hash_get(m->accessible, varname); + pos = scheme_hash_get(m->exp_infos[0]->accessible, varname); if (pos && (SCHEME_INT_VAL(pos) >= 0)) return SCHEME_INT_VAL(pos); @@ -3888,7 +3930,8 @@ int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Schem return -1; } -Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *name) +Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, + Scheme_Object *name, int mod_phase) { if (SAME_OBJ(modname, kernel_modname)) { Scheme_Env *kenv; @@ -3904,12 +3947,23 @@ Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Sch } else { Scheme_Env *menv; Scheme_Object *val; + int i; + + for (i = 0; i < mod_phase; i++) { + env = env->template_env; + if (!env) return NULL; + } menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), modname); - + if (!menv) return NULL; + for (i = 0; i < mod_phase; i++) { + menv = menv->exp_env; + if (!menv) return NULL; + } + if (SCHEME_STXP(name)) name = scheme_tl_id_sym(menv, name, NULL, 0, NULL, NULL); @@ -4002,27 +4056,27 @@ static Scheme_Object *add_start(Scheme_Object *v, int base_phase, int eval_exp, #if 0 static int indent = 0; # define show_indent(d) (indent += d) -static void show(const char *what, Scheme_Env *menv, int v1, int v2, int base_phase) +static void show(const char *what, Scheme_Env *menv, int v1, int v2, int ph, int base_phase) { if (menv->phase > 3) return; - if (1 || SCHEME_SYMBOLP(SCHEME_PTR_VAL(menv->module->modname))) - if (1 || SCHEME_SYM_VAL(SCHEME_PTR_VAL(menv->module->modname))[0] != '#') { + if (0 || SCHEME_SYMBOLP(SCHEME_PTR_VAL(menv->module->modname))) + if (0 || SCHEME_SYM_VAL(SCHEME_PTR_VAL(menv->module->modname))[0] != '#') { int i; for (i = 0; i < indent; i++) { fprintf(stderr, " "); } - fprintf(stderr, "%s \t%s @%ld/%d [%d/%d] %p\n", + fprintf(stderr, "%s \t%s @%ld+%d/%d [%d/%d] %p\n", what, scheme_write_to_string(menv->module->modname, NULL), - menv->phase, base_phase, v1, v2, menv->modchain); + menv->phase, ph, base_phase, v1, v2, menv->modchain); } } -static void show_done(const char *what, Scheme_Env *menv, int v1, int v2, int base_phase){ - show(what, menv, v1, v2, base_phase); +static void show_done(const char *what, Scheme_Env *menv, int v1, int v2, int i, int base_phase){ + show(what, menv, v1, v2, i, base_phase); } #else # define show_indent(d) /* nothing */ -# define show(w, m, v1, v2, bp) /* nothing */ -# define show_done(w, m, v1, v2, bp) /* nothing */ +# define show(w, m, v1, v2, i, bp) /* nothing */ +# define show_done(w, m, v1, v2, i, bp) /* nothing */ #endif static void compute_require_names(Scheme_Env *menv, Scheme_Object *phase, @@ -4115,7 +4169,8 @@ static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, menv->label_env, 0, midx, 0, 0, base_phase, - new_cycle_list); + new_cycle_list, + 0); } } @@ -4134,7 +4189,8 @@ static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, menv->template_env, 0, midx, eval_exp, eval_run, base_phase, - new_cycle_list); + new_cycle_list, + 0); } } @@ -4145,7 +4201,8 @@ static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, im = module_load(scheme_module_resolve(midx, 1), env, NULL); - start_module(im, env, 0, midx, eval_exp, eval_run, base_phase, new_cycle_list); + start_module(im, env, 0, midx, eval_exp, eval_run, base_phase, + new_cycle_list, 0); } scheme_prepare_exp_env(menv); @@ -4159,7 +4216,8 @@ static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, im = module_load(scheme_module_resolve(midx, 1), env, NULL); - start_module(im, menv->exp_env, 0, midx, eval_exp, eval_run, base_phase, new_cycle_list); + start_module(im, menv->exp_env, 0, midx, eval_exp, eval_run, base_phase, + new_cycle_list, 0); } } @@ -4193,7 +4251,8 @@ static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, menv2, 0, midx, eval_exp, eval_run, base_phase, - new_cycle_list); + new_cycle_list, + 0); } } else { compute_require_names(menv, phase, env, syntax_idx); @@ -4214,7 +4273,8 @@ static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, im = module_load(scheme_module_resolve(midx, 1), env, NULL); - start_module(im, menv2, 0, midx, eval_exp, eval_run, base_phase, new_cycle_list); + start_module(im, menv2, 0, midx, eval_exp, eval_run, base_phase, + new_cycle_list, 0); } } } @@ -4260,7 +4320,8 @@ void *scheme_module_start_finish(struct Start_Module_Args *a) return NULL; } -static Scheme_Env *instantiate_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx) +static Scheme_Env *instantiate_module(Scheme_Module *m, Scheme_Env *env, int restart, + Scheme_Object *syntax_idx, int not_new) { Scheme_Env *menv; @@ -4290,18 +4351,27 @@ static Scheme_Env *instantiate_module(Scheme_Module *m, Scheme_Env *env, int res Scheme_Object *insp; if (!menv) { + char *running; + + if (not_new) + scheme_signal_error("internal error: shouldn't instantiate module %s now", + scheme_write_to_string(m->modname, NULL)); + /* printf("new %ld %s\n", env->phase, SCHEME_SYM_VAL(m->modname)); */ menv = scheme_new_module_env(env, m, 0); scheme_hash_set(MODCHAIN_TABLE(env->modchain), m->modname, (Scheme_Object *)menv); - + + running = (char *)scheme_malloc_atomic(menv->module->num_phases); + menv->running = running; + memset(menv->running, 0, menv->module->num_phases); + menv->phase = env->phase; menv->link_midx = syntax_idx; } else { Scheme_Env *env2; menv->module = m; - menv->running = 0; - menv->et_running = 0; + memset(menv->running, 0, menv->module->num_phases); menv->ran = 0; menv->did_starts = NULL; @@ -4343,8 +4413,8 @@ static Scheme_Env *instantiate_module(Scheme_Module *m, Scheme_Env *env, int res scheme_add_to_table(menv->toplevel, (const char *)exsns[i], NULL, 0); } - count = m->num_indirect_provides; - exsns = m->indirect_provides; + count = m->exp_infos[0]->num_indirect_provides; + exsns = m->exp_infos[0]->indirect_provides; for (i = 0; i < count; i++) { scheme_add_to_table(menv->toplevel, (const char *)exsns[i], NULL, 0); } @@ -4355,122 +4425,128 @@ static Scheme_Env *instantiate_module(Scheme_Module *m, Scheme_Env *env, int res return menv; } -static void expstart_module(Scheme_Env *menv, Scheme_Env *env, int restart) +static void expstart_module(Scheme_Env *menv, Scheme_Env *env, int phase, int restart) { if (!restart) { - if (menv && menv->et_running) + if (menv && menv->running[phase]) return; } if (menv->module->primitive) return; - menv->et_running = 1; + menv->running[phase] = 1; if (scheme_starting_up) menv->attached = 1; /* protect initial modules from redefinition, etc. */ - run_module_exptime(menv, 0); + run_module_exptime(menv, phase); return; } -static void run_module_exptime(Scheme_Env *menv, int set_ns) +static void run_module_exptime(Scheme_Env *menv, int phase) { #ifdef MZ_USE_JIT - (void)scheme_module_exprun_start(menv, set_ns, scheme_make_pair(menv->module->modname, scheme_void)); + (void)scheme_module_exprun_start(menv, phase, scheme_make_pair(menv->module->modname, scheme_void)); #else - (void)scheme_module_exprun_finish(menv, set_ns); + (void)scheme_module_exprun_finish(menv, phase); #endif } -void *scheme_module_exprun_finish(Scheme_Env *menv, int set_ns) +void *scheme_module_exprun_finish(Scheme_Env *menv, int at_phase) { int let_depth, for_stx; Scheme_Object *names, *e; Resolve_Prefix *rp; Scheme_Comp_Env *rhs_env; - int i, cnt; + int i, cnt, len; Scheme_Env *exp_env; - Scheme_Bucket_Table *syntax, *for_stx_globals; - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - + Scheme_Bucket_Table *syntax; + if (menv->module->primitive) return NULL; - if (!SCHEME_VEC_SIZE(menv->module->et_body)) + if ((menv->module->num_phases <= at_phase) || (!SCHEME_VEC_SIZE(menv->module->bodies[at_phase]))) return NULL; - syntax = menv->syntax; - + for (i = 1; i < at_phase; i++) { + menv = menv->exp_env; + } exp_env = menv->exp_env; if (!exp_env) return NULL; - for_stx_globals = exp_env->toplevel; - - if (set_ns) { - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)menv); - - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - } + syntax = menv->syntax; rhs_env = scheme_new_comp_env(menv, menv->module->insp, SCHEME_TOPLEVEL_FRAME); - cnt = SCHEME_VEC_SIZE(menv->module->et_body); + cnt = SCHEME_VEC_SIZE(menv->module->bodies[at_phase]); for (i = 0; i < cnt; i++) { - e = SCHEME_VEC_ELS(menv->module->et_body)[i]; + e = SCHEME_VEC_ELS(menv->module->bodies[at_phase])[i]; names = SCHEME_VEC_ELS(e)[0]; let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); rp = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[3]; for_stx = SCHEME_TRUEP(SCHEME_VEC_ELS(e)[4]); e = SCHEME_VEC_ELS(e)[1]; - - if (SCHEME_SYMBOLP(names)) - names = scheme_make_pair(names, scheme_null); + + if (for_stx) { + names = NULL; + len = 0; + } else { + if (SCHEME_SYMBOLP(names)) + names = scheme_make_pair(names, scheme_null); + len = scheme_list_length(names); + } - eval_exptime(names, scheme_list_length(names), e, exp_env, rhs_env, - rp, let_depth, 1, (for_stx ? for_stx_globals : syntax), for_stx, + eval_exptime(names, len, e, exp_env, rhs_env, + rp, let_depth, 1, (for_stx ? NULL : syntax), at_phase, scheme_false, menv->module->insp); } - if (set_ns) { - scheme_pop_continuation_frame(&cframe); - } - return NULL; } static void do_start_module(Scheme_Module *m, Scheme_Env *menv, Scheme_Env *env, int restart) { if (m->primitive) { - menv->running = 1; + menv->running[0] = 1; menv->ran = 1; return; } - if (menv->running > 0) { + if (menv->running[0] > 0) { return; } - menv->running = 1; + menv->running[0] = 1; if (menv->module->prim_body) { Scheme_Invoke_Proc ivk = menv->module->prim_body; menv->ran = 1; - ivk(menv, menv->phase, menv->link_midx, m->body); + ivk(menv, menv->phase, menv->link_midx, m->bodies[0]); } else { eval_module_body(menv, env); } } -static void should_run_for_compile(Scheme_Env *menv) +static void should_run_for_compile(Scheme_Env *menv, int phase) { + if (menv->running[phase]) return; + + while (phase > 1) { + scheme_prepare_exp_env(menv); + menv = menv->exp_env; + phase--; + } + +#if 0 + if (!scheme_hash_get(MODCHAIN_TABLE(menv->instance_env->modchain), menv->module->modname)) + scheme_signal_error("internal error: inconsistent instance_env"); +#endif + + if (!menv->available_next[0]) { menv->available_next[0] = MODCHAIN_AVAIL(menv->modchain, 0); MODCHAIN_AVAIL(menv->modchain, 0) = (Scheme_Object *)menv; @@ -4483,12 +4559,17 @@ static void should_run_for_compile(Scheme_Env *menv) static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx, int eval_exp, int eval_run, intptr_t base_phase, - Scheme_Object *cycle_list) -/* eval_exp == -1 => make it ready, eval_exp == 1 => run exp-time, eval_exp = 0 => don't even make ready */ + Scheme_Object *cycle_list, int not_new) +/* Make an instance of module `m' in `env', which means that phase level 0 of module `m' + will be shifted to phase `env->phase'. + Let P=`base_phase'-`env->phase'. + - If `eval_run', then instantiate phase-level P of `m' (which is at `base_phase' in `env'). + - If `eval_exp' is -1, then (also) make its P+1 phase-level ready. + - If `eval_exp' is 1, then visit at phase P => run phase P+1. */ { Scheme_Env *menv; Scheme_Object *l, *new_cycle_list; - int prep_namespace = 0; + int prep_namespace = 0, i; if (is_builtin_modname(m->modname)) return; @@ -4503,16 +4584,16 @@ static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, new_cycle_list = scheme_make_pair(m->modname, cycle_list); - menv = instantiate_module(m, env, restart, syntax_idx); + menv = instantiate_module(m, env, restart, syntax_idx, not_new); check_phase(menv, env, 0); - show("chck", menv, eval_exp, eval_run, base_phase); + show("chck", menv, eval_exp, eval_run, 0, base_phase); if (did_start(menv->did_starts, base_phase, eval_exp, eval_run)) return; - show("strt", menv, eval_exp, eval_run, base_phase); + show("strt", menv, eval_exp, eval_run, 0, base_phase); show_indent(+1); { @@ -4530,41 +4611,48 @@ static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, } } - if (env->phase == base_phase) { - if (eval_exp) { - if (eval_exp > 0) { - show("exp=", menv, eval_exp, eval_run, base_phase); - expstart_module(menv, env, restart); + if (eval_run || eval_exp) { + for (i = menv->module->num_phases; i-- ; ) { + if (env->phase + i == base_phase) { + if (eval_exp) { + if (base_phase < menv->module->num_phases) { + if (eval_exp > 0) { + show("exp=", menv, eval_exp, eval_run, i, base_phase); + expstart_module(menv, env, i+1, restart); + } else { + should_run_for_compile(menv, i); + } + } + } + if (eval_run) { + show("run=", menv, eval_exp, eval_run, i, base_phase); + if (i == 0) + do_start_module(m, menv, env, restart); + else + expstart_module(menv, env, i, restart); + } + } else if (env->phase + i > base_phase) { + if (eval_exp) { + should_run_for_compile(menv, i); + if (eval_exp > 0) { + if (env->phase + i == base_phase + 1) { + show("run+", menv, eval_exp, eval_run, i, base_phase); + if (i == 0) + do_start_module(m, menv, env, restart); + else + expstart_module(menv, env, i, restart); + } + } + } } else { - should_run_for_compile(menv); - } - } - if (eval_run) { - show("run=", menv, eval_exp, eval_run, base_phase); - do_start_module(m, menv, env, restart); - } - } else if (env->phase < base_phase) { - if (env->phase == base_phase - 1) { - if (eval_run) { - show("run-", menv, eval_exp, eval_run, base_phase); - expstart_module(menv, env, restart); - } - } - } else { - /* env->phase > base_phase */ - if (eval_exp) { - should_run_for_compile(menv); - } - if (eval_exp > 0) { - if (env->phase == base_phase + 1) { - show("run+", menv, eval_exp, eval_run, base_phase); - do_start_module(m, menv, env, restart); + /* env->phase + i < base_phase */ } } + } show_indent(-1); - show_done("done", menv, eval_exp, eval_run, base_phase); + show_done("done", menv, eval_exp, eval_run, 0, base_phase); if (prep_namespace) scheme_prep_namespace_rename(menv); @@ -4601,9 +4689,9 @@ static void do_prepare_compile_env(Scheme_Env *env, int base_phase, int pos) menv = (Scheme_Env *)v; v = menv->available_next[pos]; menv->available_next[pos] = NULL; - start_module(menv->module, env, 0, + start_module(menv->module, menv->instance_env, 0, NULL, 1, 0, base_phase, - scheme_null); + scheme_null, 1); } if (need_lock) @@ -4711,7 +4799,7 @@ void *scheme_module_run_finish(Scheme_Env *menv, Scheme_Env *env) mz_jmp_buf newbuf, * volatile savebuf; LOG_RUN_DECLS; - menv->running = 1; + menv->running[0] = 1; menv->ran = 1; depth = m->max_let_depth + scheme_prefix_depth(m->prefix); @@ -4752,9 +4840,9 @@ void *scheme_module_run_finish(Scheme_Env *menv, Scheme_Env *env) scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); } - cnt = SCHEME_VEC_SIZE(m->body); + cnt = SCHEME_VEC_SIZE(m->bodies[0]); for (i = 0; i < cnt; i++) { - body = SCHEME_VEC_ELS(m->body)[i]; + body = SCHEME_VEC_ELS(m->bodies[0])[i]; if (needs_prompt(body)) { /* We need to push the prefix after the prompt is set, so restore the runstack and then add the prefix back. */ @@ -4826,6 +4914,7 @@ Scheme_Env *scheme_primitive_module(Scheme_Object *name, Scheme_Env *for_env) Scheme_Env *env; Scheme_Object *prefix, *insp, *src, *midx; Scheme_Config *config; + char *running; m = MALLOC_ONE_TAGGED(Scheme_Module); m->so.type = scheme_module_type; @@ -4880,6 +4969,11 @@ Scheme_Env *scheme_primitive_module(Scheme_Object *name, Scheme_Env *for_env) scheme_hash_set(for_env->module_registry->loaded, m->modname, (Scheme_Object *)m); + running = scheme_malloc_atomic(2); + running[0] = 0; + running[1] = 0; + env->running = running; + return env; } @@ -4891,6 +4985,9 @@ void scheme_finish_primitive_module(Scheme_Env *env) Scheme_Object **exs; int i, count; + if (!m->exp_infos) + add_exp_infos(m); + /* Provide all variables: */ count = 0; ht = env->toplevel; @@ -4918,7 +5015,7 @@ void scheme_finish_primitive_module(Scheme_Env *env) qsort_provides(exs, NULL, NULL, NULL, NULL, NULL, 0, count, 1); - env->running = 1; + env->running[0] = 1; } void scheme_protect_primitive_provide(Scheme_Env *env, Scheme_Object *name) @@ -4926,7 +5023,10 @@ void scheme_protect_primitive_provide(Scheme_Env *env, Scheme_Object *name) Scheme_Module *m = env->module; int i; - if (!m->provide_protects) { + if (!m->exp_infos) + add_exp_infos(m); + + if (!m->exp_infos[0]->provide_protects) { Scheme_Hash_Table *ht; char *exps; ht = scheme_make_hash_table(SCHEME_hash_ptr); @@ -4935,21 +5035,22 @@ void scheme_protect_primitive_provide(Scheme_Env *env, Scheme_Object *name) exps[i] = 0; scheme_hash_set(ht, m->me->rt->provides[i], scheme_make_integer(i)); } - m->provide_protects = exps; - m->accessible = ht; + add_exp_infos(m); + m->exp_infos[0]->provide_protects = exps; + m->exp_infos[0]->accessible = ht; } if (name) { for (i = m->me->rt->num_provides; i--; ) { if (SAME_OBJ(name, m->me->rt->provides[i])) { - m->provide_protects[i] = 1; + m->exp_infos[0]->provide_protects[i] = 1; break; } } } else { /* Protect all */ for (i = m->me->rt->num_provides; i--; ) { - m->provide_protects[i] = 1; + m->exp_infos[0]->provide_protects[i] = 1; } } } @@ -5052,7 +5153,7 @@ static void *eval_exptime_k(void) { Scheme_Thread *p = scheme_current_thread; Scheme_Object *names; - int count, for_stx; + int count, at_phase; Scheme_Object *expr; Scheme_Env *genv; Scheme_Comp_Env *comp_env; @@ -5072,7 +5173,7 @@ static void *eval_exptime_k(void) count = p->ku.k.i1; let_depth = p->ku.k.i2; shift = p->ku.k.i3; - for_stx = p->ku.k.i4; + at_phase = p->ku.k.i4; p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; @@ -5080,7 +5181,7 @@ static void *eval_exptime_k(void) p->ku.k.p4 = NULL; p->ku.k.p5 = NULL; - eval_exptime(names, count, expr, genv, comp_env, rp, let_depth, shift, syntax, for_stx, + eval_exptime(names, count, expr, genv, comp_env, rp, let_depth, shift, syntax, at_phase, free_id_rename_rn, insp); return NULL; @@ -5102,7 +5203,7 @@ static void eval_exptime(Scheme_Object *names, int count, Scheme_Env *genv, Scheme_Comp_Env *comp_env, Resolve_Prefix *rp, int let_depth, int shift, Scheme_Bucket_Table *syntax, - int for_stx, + int at_phase, Scheme_Object *free_id_rename_rn, Scheme_Object *insp) { @@ -5125,7 +5226,7 @@ static void eval_exptime(Scheme_Object *names, int count, p->ku.k.i1 = count; p->ku.k.i2 = let_depth; p->ku.k.i3 = shift; - p->ku.k.i4 = for_stx; + p->ku.k.i4 = at_phase; (void)scheme_enlarge_runstack(depth, eval_exptime_k); return; } @@ -5136,7 +5237,7 @@ static void eval_exptime(Scheme_Object *names, int count, save_runstack = scheme_push_prefix(genv, rp, (shift ? genv->module->me->src_modidx : NULL), (shift ? genv->link_midx : NULL), - 1, genv->phase, + at_phase, genv->phase, NULL, insp); if (is_simple_expr(expr)) { @@ -5162,74 +5263,70 @@ static void eval_exptime(Scheme_Object *names, int count, scheme_pop_prefix(save_runstack); } - if (SAME_OBJ(vals, SCHEME_MULTIPLE_VALUES)) { - g = scheme_current_thread->ku.multiple.count; - if (count == g) { - Scheme_Object **values; + if (names) { + if (SAME_OBJ(vals, SCHEME_MULTIPLE_VALUES)) { + g = scheme_current_thread->ku.multiple.count; + if (count == g) { + Scheme_Object **values; - values = scheme_current_thread->ku.multiple.array; - scheme_current_thread->ku.multiple.array = NULL; - if (SAME_OBJ(values, scheme_current_thread->values_buffer)) - scheme_current_thread->values_buffer = NULL; - for (i = 0; i < g; i++, names = SCHEME_CDR(names)) { - name = SCHEME_CAR(names); - - if (!for_stx) { - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - SCHEME_PTR_VAL(macro) = values[i]; + values = scheme_current_thread->ku.multiple.array; + scheme_current_thread->ku.multiple.array = NULL; + if (SAME_OBJ(values, scheme_current_thread->values_buffer)) + scheme_current_thread->values_buffer = NULL; + for (i = 0; i < g; i++, names = SCHEME_CDR(names)) { + name = SCHEME_CAR(names); + macro = scheme_alloc_small_object(); + macro->type = scheme_macro_type; + SCHEME_PTR_VAL(macro) = values[i]; + if (SCHEME_TRUEP(free_id_rename_rn) && scheme_is_binding_rename_transformer(values[i])) scheme_install_free_id_rename(name, scheme_rename_transformer_id(values[i]), free_id_rename_rn, scheme_make_integer(0)); - } else - macro = values[i]; - scheme_add_to_table(syntax, (const char *)name, macro, 0); + scheme_add_to_table(syntax, (const char *)name, macro, 0); + } + + return; } - - return; - } - } else if (SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names))) { - name = SCHEME_CAR(names); + } else if (SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names))) { + name = SCHEME_CAR(names); - if (!for_stx) { macro = scheme_alloc_small_object(); macro->type = scheme_macro_type; SCHEME_PTR_VAL(macro) = vals; - + if (SCHEME_TRUEP(free_id_rename_rn) && scheme_is_binding_rename_transformer(vals)) scheme_install_free_id_rename(name, scheme_rename_transformer_id(vals), free_id_rename_rn, scheme_make_integer(0)); - } else - macro = vals; - - scheme_add_to_table(syntax, (const char *)name, macro, 0); - return; - } else - g = 1; + scheme_add_to_table(syntax, (const char *)name, macro, 0); + + return; + } else + g = 1; - if (count) - name = SCHEME_CAR(names); - else - name = NULL; + if (count) + name = SCHEME_CAR(names); + else + name = NULL; - { - const char *symname; + { + const char *symname; - symname = (name ? scheme_symbol_name(name) : ""); + symname = (name ? scheme_symbol_name(name) : ""); - scheme_wrong_return_arity((for_stx ? "define-values-for-syntax" : "define-syntaxes"), - count, g, - (g == 1) ? (Scheme_Object **)vals : scheme_current_thread->ku.multiple.array, - "%s%s%s", - name ? "defining \"" : "0 names", - symname, - name ? ((count == 1) ? "\"" : "\", ...") : ""); - } + scheme_wrong_return_arity("define-syntaxes", + count, g, + (g == 1) ? (Scheme_Object **)vals : scheme_current_thread->ku.multiple.array, + "%s%s%s", + name ? "defining \"" : "0 names", + symname, + name ? ((count == 1) ? "\"" : "\", ...") : ""); + } + } } /**********************************************************************/ @@ -5326,7 +5423,10 @@ static Scheme_Object *do_module_execute(Scheme_Object *data, Scheme_Env *genv, i /* Replacing an already-running or already-syntaxing module? */ if (old_menv) { - start_module(m, env, 1, NULL, old_menv->et_running, old_menv->running, env->phase, scheme_null); + start_module(m, env, 1, NULL, + ((m->num_phases > 1) ? old_menv->running[1] : 0), + old_menv->running[0], + env->phase, scheme_null, 1); } return scheme_void; @@ -5422,26 +5522,39 @@ static Scheme_Object *jit_vector(Scheme_Object *orig_l, int in_vec, int jit) static Scheme_Object *do_module_clone(Scheme_Object *data, int jit) { Scheme_Module *m = (Scheme_Module *)data; - Scheme_Object *l1, *l2; + Scheme_Object *l1, **naya = NULL; + int j, i; Resolve_Prefix *rp; rp = scheme_prefix_eval_clone(m->prefix); - if (jit) - l1 = jit_vector(m->body, 0, jit); - else - l1 = m->body; - l2 = jit_vector(m->et_body, 1, jit); + for (j = m->num_phases; j--; ) { + if (!jit && !j) { + if (naya) + naya[0] = m->bodies[0]; + break; + } + l1 = jit_vector(m->bodies[j], j > 0, jit); + if (naya) + naya[j] = l1; + else if (!SAME_OBJ(l1, m->bodies[j])) { + naya = MALLOC_N(Scheme_Object*, m->num_phases); + for (i = m->num_phases; i-- > j; ) { + naya[i] = m->bodies[i]; + } + naya[j] = l1; + } + } - if (SAME_OBJ(l1, m->body) - && SAME_OBJ(l2, m->body) - && SAME_OBJ(rp, m->prefix)) - return data; + if (!naya) { + if (SAME_OBJ(rp, m->prefix)) + return data; + naya = m->bodies; + } m = MALLOC_ONE_TAGGED(Scheme_Module); memcpy(m, data, sizeof(Scheme_Module)); - m->body = l1; - m->et_body = l2; + m->bodies = naya; m->prefix = rp; return (Scheme_Object *)m; @@ -5571,7 +5684,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, /* load the module for the initial require */ iim = module_load(_module_resolve(iidx, m->ii_src, NULL, 1), menv, NULL); - start_module(iim, menv, 0, iidx, 1, 0, menv->phase, scheme_null); + start_module(iim, menv, 0, iidx, 1, 0, menv->phase, scheme_null, 0); { Scheme_Object *ins; @@ -5839,7 +5952,7 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, vec = scheme_hash_get(required, name); if (vec) { Scheme_Object *srcs; - char *fromsrc = NULL, *fromsrc_colon = ""; + char *fromsrc = NULL, *fromsrc_colon = "", *phase_expl; intptr_t fromsrclen = 0; if (same_resolved_modidx(SCHEME_VEC_ELS(vec)[1], modidx) @@ -5875,8 +5988,21 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, if (err_src) srcs = scheme_make_pair(err_src, srcs); + if (SCHEME_FALSEP(phase)) + phase_expl = " for label"; + else if (!SCHEME_INT_VAL(phase)) + phase_expl = ""; + else if (SCHEME_INT_VAL(phase) == 1) + phase_expl = " for syntax"; + else { + char buf[32]; + sprintf(buf, " for phase %" PRIxPTR, SCHEME_INT_VAL(phase)); + phase_expl = scheme_strdup(buf); + } + scheme_wrong_syntax_with_more_sources("module", prnt_name, err_src, srcs, - "identifier already imported from%s %t", + "identifier already imported%s from%s %t", + phase_expl, fromsrc_colon, fromsrc, fromsrclen); } } @@ -6018,7 +6144,7 @@ Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path, e = make_require_form(module_path, phase, mark); - parse_requires(e, base_modidx, env, for_m, + parse_requires(e, env->phase, base_modidx, env, for_m, rns, post_ex_rns, check_require_name, tables, redef_modname, @@ -6072,33 +6198,15 @@ static void flush_definitions(Scheme_Env *genv) static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec) { - Scheme_Object *form, *fm, *first, *last, *p, *rn_set, *rn, *exp_body, *et_rn, *self_modidx, *prev_p; - Scheme_Comp_Env *xenv, *cenv, *rhs_env; - Scheme_Hash_Table *et_required; /* just to avoid duplicates */ - Scheme_Hash_Table *required; /* name -> (vector nominal-modidx-list modidx srcname var? prntname) */ - /**/ /* first nominal-modidx goes with modidx, rest are for re-provides */ - Scheme_Hash_Table *provided; /* exname -> (cons locname-stx-or-sym protected?) */ - Scheme_Hash_Table *all_reprovided; /* phase -> list of (list modidx syntax except-name ...) */ - Scheme_Object *all_defs_out; /* list of (cons protected? (stx-list except-name ...)) */ - Scheme_Object *all_et_defs_out; - Scheme_Hash_Table *all_provided; /* phase -> table like `provided' */ - Scheme_Object *all_defs; /* list of stxid; this is almost redundant to the syntax and toplevel - tables, but it preserves the original name for exporting */ - Scheme_Object *all_et_defs; - Scheme_Object *post_ex_rn, *post_ex_et_rn; /* renames for ids introduced by expansion */ + int num_phases, *_num_phases, i, exicount, *all_simple_renames; + Scheme_Hash_Tree *all_defs; + Scheme_Hash_Table *tables, *all_defs_out, *all_provided, *all_reprovided, *modidx_cache; + Scheme_Module_Export_Info **exp_infos, *exp_info; + Scheme_Module_Phase_Exports *pt; Scheme_Object *post_ex_rn_set; /* phase -> post_ex_rn-like rename */ - Scheme_Hash_Table *tables; /* phase -> (vector toplevels requires syntaxes) */ - Scheme_Object *lift_data; - Scheme_Object **exis, **et_exis, **exsis; - Scheme_Object *lift_ctx; - Scheme_Object *lifted_reqs = scheme_null, *req_data, *unbounds = scheme_null; - int exicount, et_exicount, exsicount; - char *exps, *et_exps; - int *all_simple_renames; - int maybe_has_lifts = 0; - Scheme_Object *redef_modname; - Scheme_Object *observer; - Scheme_Hash_Table *modidx_cache; + Scheme_Object *form, *redef_modname, *rn_set, *observer, **exis, *body_lists; + Scheme_Env *genv; + Module_Begin_Expand_State *bxs; form = scheme_stx_taint_disarm(orig_form, NULL); @@ -6116,138 +6224,361 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env if (!scheme_hash_get(env->genv->module_registry->loaded, redef_modname)) redef_modname = NULL; - /* Expand each expression in form up to `begin', `define-values', `define-syntax', - `require', `provide', `#%app', etc. */ - xenv = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME - | SCHEME_MODULE_BEGIN_FRAME - | SCHEME_FOR_STOPS), - env); - { - Scheme_Object *stop; - stop = scheme_get_stop_expander(); - scheme_add_local_syntax(19, xenv); - scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv); - scheme_set_local_syntax(1, scheme_define_values_stx, stop, xenv); - scheme_set_local_syntax(2, scheme_define_syntaxes_stx, stop, xenv); - scheme_set_local_syntax(3, scheme_define_for_syntaxes_stx, stop, xenv); - scheme_set_local_syntax(4, require_stx, stop, xenv); - scheme_set_local_syntax(5, provide_stx, stop, xenv); - scheme_set_local_syntax(6, set_stx, stop, xenv); - scheme_set_local_syntax(7, app_stx, stop, xenv); - scheme_set_local_syntax(8, scheme_top_stx, stop, xenv); - scheme_set_local_syntax(9, lambda_stx, stop, xenv); - scheme_set_local_syntax(10, case_lambda_stx, stop, xenv); - scheme_set_local_syntax(11, let_values_stx, stop, xenv); - scheme_set_local_syntax(12, letrec_values_stx, stop, xenv); - scheme_set_local_syntax(13, if_stx, stop, xenv); - scheme_set_local_syntax(14, begin0_stx, stop, xenv); - scheme_set_local_syntax(15, with_continuation_mark_stx, stop, xenv); - scheme_set_local_syntax(16, letrec_syntaxes_stx, stop, xenv); - scheme_set_local_syntax(17, var_ref_stx, stop, xenv); - scheme_set_local_syntax(18, expression_stx, stop, xenv); - } + tables = scheme_make_hash_table_equal(); - first = scheme_null; - last = NULL; + modidx_cache = scheme_make_hash_table_equal(); rn_set = env->genv->rename_set; - rn = scheme_get_module_rename_from_set(rn_set, scheme_make_integer(0), 1); - et_rn = scheme_get_module_rename_from_set(rn_set, scheme_make_integer(1), 1); - - required = scheme_make_hash_table(SCHEME_hash_ptr); - et_required = scheme_make_hash_table(SCHEME_hash_ptr); - - tables = scheme_make_hash_table_equal(); - { - Scheme_Object *vec; - - vec = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->genv->toplevel; - SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)required; - SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)env->genv->syntax; - scheme_hash_set(tables, scheme_make_integer(0), vec); - - vec = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->genv->exp_env->toplevel; - SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)et_required; - SCHEME_VEC_ELS(vec)[2] = NULL; - scheme_hash_set(tables, scheme_make_integer(1), vec); - } - - /* Put initial requires into the table: - (This is redundant for the rename set, but we need to fill - the `all_requires' table, etc.) */ - modidx_cache = scheme_make_hash_table_equal(); - { - Scheme_Module *iim; - Scheme_Object *nmidx, *orig_src; - - /* stx src of original import: */ - orig_src = env->genv->module->ii_src; - if (!orig_src) - orig_src = scheme_false; - else if (!SCHEME_STXP(orig_src)) - orig_src = scheme_false; - - nmidx = SCHEME_CAR(env->genv->module->requires); - iim = module_load(scheme_module_resolve(nmidx, 1), env->genv, NULL); - - add_simple_require_renames(orig_src, rn_set, tables, - iim, nmidx, - scheme_make_integer(0), - NULL, 1); - - scheme_hash_set(modidx_cache, ((Scheme_Modidx *)nmidx)->path, nmidx); - } - { Scheme_Object *v; v = scheme_rename_to_stx(rn_set); env->genv->module->rn_stx = v; } - provided = scheme_make_hash_table(SCHEME_hash_ptr); all_provided = scheme_make_hash_table_equal(); - scheme_hash_set(all_provided, scheme_make_integer(0), (Scheme_Object *)provided); - all_reprovided = scheme_make_hash_table_equal(); + all_defs = scheme_make_hash_tree(1); + all_defs_out = scheme_make_hash_table_equal(); - all_defs_out = scheme_null; - all_et_defs_out = scheme_null; + post_ex_rn_set = scheme_make_module_rename_set(mzMOD_RENAME_MARKED, rn_set, env->genv->module->insp); - all_defs = scheme_null; - all_et_defs = scheme_null; + /* It's possible that #%module-begin expansion introduces + marked identifiers for definitions. */ + form = scheme_add_rename(form, post_ex_rn_set); - exp_body = scheme_null; + observer = rec[drec].observer; + SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, form); + + _num_phases = MALLOC_ONE_ATOMIC(int); + *_num_phases = 0; + + all_simple_renames = (int *)scheme_malloc_atomic(sizeof(int)); + *all_simple_renames = 1; + + bxs = scheme_malloc(sizeof(Module_Begin_Expand_State)); + bxs->post_ex_rn_set = post_ex_rn_set; + bxs->tables = tables; + bxs->all_provided = all_provided; + bxs->all_reprovided = all_reprovided; + bxs->all_defs = all_defs; + bxs->all_defs_out = all_defs_out; + bxs->all_simple_renames = all_simple_renames; + bxs->_num_phases = _num_phases; + bxs->saved_provides = scheme_null; + bxs->modidx_cache = modidx_cache; + bxs->redef_modname = redef_modname; + + body_lists = do_module_begin_at_phase(form, env, + rec, drec, + rec[drec].comp ? NULL : rec, drec, + 0, + scheme_null, + bxs); + num_phases = *_num_phases; + + /* Compute provides for re-provides and all-defs-out: */ + (void)compute_reprovides(all_provided, + all_reprovided, + env->genv->module, + tables, + env->genv, + num_phases, + bxs->all_defs, all_defs_out, + "require", NULL, NULL); + + exp_infos = MALLOC_N(Scheme_Module_Export_Info*, num_phases); + for (i = 0; i < num_phases; i++) { + exp_info = MALLOC_ONE_RT(Scheme_Module_Export_Info); + SET_REQUIRED_TAG(exp_info->type = scheme_rt_export_info); + exp_infos[i] = exp_info; + } + + /* Compute provide arrays */ + compute_provide_arrays(all_provided, tables, + env->genv->module->me, + env->genv, + form, + num_phases, exp_infos); + + /* Compute indirect provides (which is everything at the top-level): */ + genv = env->genv; + for (i = 0; i < num_phases; i++) { + switch (i) { + case 0: + pt = env->genv->module->me->rt; + break; + case 1: + pt = env->genv->module->me->et; + break; + default: + if (env->genv->module->me->other_phases) + pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(env->genv->module->me->other_phases, + scheme_make_integer(i)); + else + pt = NULL; + break; + } + if (pt) { + exis = compute_indirects(genv, pt, &exicount, 1); + exp_infos[i]->indirect_provides = exis; + exp_infos[i]->num_indirect_provides = exicount; + exis = compute_indirects(genv, pt, &exicount, 0); + exp_infos[i]->indirect_syntax_provides = exis; + exp_infos[i]->num_indirect_syntax_provides = exicount; + } + genv = genv->exp_env; + } + + if (rec[drec].comp || (rec[drec].depth != -2)) { + scheme_clean_dead_env(env->genv); + } + + if (!rec[drec].comp) { + Scheme_Module_Phase_Exports *rt = env->genv->module->me->rt; + int excount = rt->num_provides; + int exvcount = rt->num_var_provides; + Scheme_Object **exsns = rt->provide_src_names; + Scheme_Object **exs = rt->provides; + Scheme_Object **exss = rt->provide_srcs; + + /* Produce annotations (in the form of properties) + for module information: + 'module-variable-provides = '(item ...) + 'module-syntax-provides = '(item ...) + 'module-indirect-provides = '(id ...) + 'module-kernel-reprovide-hint = 'kernel-reexport + + item = name + | (ext-id . def-id) + | (modidx ext-id . def-id) + kernel-reexport = #f + | #t + | exclusion-id + */ + int j; + Scheme_Object *e, *a, *result; + + result = scheme_null; + + /* kernel re-export info (always #f): */ + result = scheme_make_pair(scheme_false, result); + + /* Indirect provides */ + a = scheme_null; + for (j = 0; j < exp_infos[0]->num_indirect_provides; j++) { + a = scheme_make_pair(exp_infos[0]->indirect_provides[j], a); + } + result = scheme_make_pair(a, result); + + /* add syntax and value exports: */ + for (j = 0; j < 2; j++) { + int top, i; + + e = scheme_null; + + if (!j) { + i = exvcount; + top = excount; + } else { + i = 0; + top = exvcount; + } + + for (; i < top; i++) { + if (SCHEME_FALSEP(exss[i]) + && SAME_OBJ(exs[i], exsns[i])) + a = exs[i]; + else { + a = scheme_make_pair(exs[i], exsns[i]); + if (!SCHEME_FALSEP(exss[i])) { + a = scheme_make_pair(exss[i], a); + } + } + e = scheme_make_pair(a, e); + } + result = scheme_make_pair(e, result); + } + + env->genv->module->hints = result; + } + + if (rec[drec].comp) { + Scheme_Object *a, **bodies; + + bodies = MALLOC_N(Scheme_Object*, num_phases); + for (i = 0; i < num_phases; i++) { + a = SCHEME_CAR(body_lists); + if (i > 0) a = scheme_reverse(a); + a = scheme_list_to_vector(a); + bodies[i] = a; + body_lists = SCHEME_CDR(body_lists); + } + env->genv->module->bodies = bodies; + env->genv->module->num_phases = num_phases; + + env->genv->module->exp_infos = exp_infos; + + if (!*all_simple_renames) { + /* No need to keep indirect syntax provides */ + for (i = 0; i < num_phases; i++) { + exp_infos[i]->indirect_syntax_provides = NULL; + exp_infos[i]->num_indirect_syntax_provides = 0; + } + } + + if (*all_simple_renames) { + env->genv->module->rn_stx = scheme_true; + } + + return (Scheme_Object *)env->genv->module; + } else { + Scheme_Object *p; + + if (rec[drec].depth == -2) { + /* This was a local expand. Flush definitions, because the body expand may start over. */ + flush_definitions(env->genv); + if (env->genv->exp_env) + flush_definitions(env->genv->exp_env); + } + + p = SCHEME_STX_CAR(form); + + return scheme_datum_to_syntax(cons(p, body_lists), orig_form, orig_form, 0, 2); + } +} + +#define DONE_MODFORM_KIND 0 +#define EXPR_MODFORM_KIND 1 +#define DEFN_MODFORM_KIND 2 +#define PROVIDE_MODFORM_KIND 3 +#define SAVED_MODFORM_KIND 4 + +static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Expand_Info *rec, int drec, + Scheme_Compile_Expand_Info *erec, int derec, + int phase, + Scheme_Object *body_lists, /* starts from phase + 1; null in expand mode */ + Module_Begin_Expand_State *bxs) +/* Result in expand mode is expressions in order. + Result in compile mode is a body_lists starting with `phase', + where a body_lists has each phase in order, with each list after the first in reverse order. + If both rec[drec].comp && erec, cons results. + If !rec[drec].comp, then erec is non-NULL. */ +{ + Scheme_Object *fm, *first, *last, *p, *rn_set, *rn, *exp_body, *self_modidx, *prev_p; + Scheme_Object *expanded_l; + Scheme_Comp_Env *xenv, *cenv, *rhs_env; + Scheme_Hash_Table *required; /* name -> (vector nominal-modidx-list modidx srcname var? prntname) + first nominal-modidx goes with modidx, rest are for re-provides */ + Scheme_Hash_Table *provided; /* exname -> (cons locname-stx-or-sym protected?) */ + Scheme_Object *all_rt_defs; /* list of stxid; this is almost redundant to the syntax and toplevel + tables, but it preserves the original name for exporting */ + Scheme_Hash_Tree *adt; + Scheme_Object *post_ex_rn; /* renames for ids introduced by expansion */ + Scheme_Object *lift_data; + Scheme_Object *lift_ctx; + Scheme_Object *lifted_reqs = scheme_null, *req_data, *unbounds = scheme_null; + int maybe_has_lifts = 0; + Scheme_Object *observer, *vec; + Scheme_Object *define_values_stx, *begin_stx, *define_syntaxes_stx, *begin_for_syntax_stx, *req_stx, *prov_stx, *sv[6]; + + if (*bxs->_num_phases < phase + 1) + *bxs->_num_phases = phase + 1; + + /* Expand each expression in form up to `begin', `define-values', `define-syntax', + `require', `provide', `#%app', etc. */ + xenv = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME + | SCHEME_MODULE_BEGIN_FRAME + | SCHEME_FOR_STOPS), + env); + + install_stops(xenv, phase, sv); + + define_values_stx = sv[0]; + begin_stx = sv[1]; + define_syntaxes_stx = sv[2]; + begin_for_syntax_stx = sv[3]; + req_stx = sv[4]; + prov_stx = sv[5]; + + first = scheme_null; + last = NULL; + + rn_set = env->genv->rename_set; + rn = scheme_get_module_rename_from_set(rn_set, scheme_make_integer(phase), 1); + + vec = scheme_hash_get(bxs->tables, scheme_make_integer(phase)); + if (!vec) { + required = scheme_make_hash_table(SCHEME_hash_ptr); + vec = scheme_make_vector(3, NULL); + SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->genv->toplevel; + SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)required; + SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)env->genv->syntax; + scheme_hash_set(bxs->tables, scheme_make_integer(phase), vec); + } else + required = (Scheme_Hash_Table *)SCHEME_VEC_ELS(vec)[1]; + + if (phase == 0) { + /* Put initial requires into the table: + (This is redundant for the rename set, but we need to fill + the `all_requires' table, etc.) */ + { + Scheme_Module *iim; + Scheme_Object *nmidx, *orig_src; + + /* stx src of original import: */ + orig_src = env->genv->module->ii_src; + if (!orig_src) + orig_src = scheme_false; + else if (!SCHEME_STXP(orig_src)) + orig_src = scheme_false; + + nmidx = SCHEME_CAR(env->genv->module->requires); + iim = module_load(scheme_module_resolve(nmidx, 1), env->genv, NULL); + + add_simple_require_renames(orig_src, rn_set, bxs->tables, + iim, nmidx, + scheme_make_integer(0), + NULL, 1); + + scheme_hash_set(bxs->modidx_cache, ((Scheme_Modidx *)nmidx)->path, nmidx); + } + } + + provided = (Scheme_Hash_Table *)scheme_hash_get(bxs->all_provided, scheme_make_integer(phase)); + if (!provided) { + provided = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(bxs->all_provided, scheme_make_integer(phase), (Scheme_Object *)provided); + } + + all_rt_defs = scheme_hash_tree_get(bxs->all_defs, scheme_make_integer(phase)); + if (!all_rt_defs) all_rt_defs = scheme_null; + + if (SCHEME_NULLP(body_lists)) + exp_body = scheme_null; + else { + exp_body = SCHEME_CAR(body_lists); + body_lists = SCHEME_CDR(body_lists); + } self_modidx = env->genv->module->self_modidx; - post_ex_rn_set = scheme_make_module_rename_set(mzMOD_RENAME_MARKED, rn_set, env->genv->module->insp); - post_ex_rn = scheme_get_module_rename_from_set(post_ex_rn_set, scheme_make_integer(0), 1); - post_ex_et_rn = scheme_get_module_rename_from_set(post_ex_rn_set, scheme_make_integer(1), 1); - env->genv->post_ex_rename_set = post_ex_rn_set; + post_ex_rn = scheme_get_module_rename_from_set(bxs->post_ex_rn_set, scheme_make_integer(phase), 1); + env->genv->post_ex_rename_set = bxs->post_ex_rn_set; /* For syntax-local-context, etc., in a d-s RHS: */ rhs_env = scheme_new_comp_env(env->genv, env->insp, SCHEME_TOPLEVEL_FRAME); observer = rec[drec].observer; - /* It's possible that #%module-begin expansion introduces - marked identifiers for definitions. */ - form = scheme_add_rename(form, post_ex_rn_set); - SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, form); - maybe_has_lifts = 0; lift_ctx = scheme_generate_lifts_key(); - all_simple_renames = (int *)scheme_malloc_atomic(sizeof(int)); - *all_simple_renames = 1; - req_data = package_require_data(self_modidx, env->genv, env->genv->module, - rn_set, post_ex_rn_set, - tables, - redef_modname, - all_simple_renames); + rn_set, bxs->post_ex_rn_set, + bxs->tables, + bxs->redef_modname, + bxs->all_simple_renames); /* Pass 1 */ @@ -6292,10 +6623,10 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env if (!SCHEME_NULLP(fst)) { /* Expansion lifted expressions, so add them to the front and try again. */ - *all_simple_renames = 0; + *bxs->all_simple_renames = 0; fm = SCHEME_STX_CDR(fm); - e = scheme_add_rename(e, post_ex_rn_set); - fm = scheme_named_map_1(NULL, add_a_rename, fm, post_ex_rn_set); + e = scheme_add_rename(e, bxs->post_ex_rn_set); + fm = scheme_named_map_1(NULL, add_a_rename, fm, bxs->post_ex_rn_set); fm = scheme_make_pair(e, fm); SCHEME_EXPAND_OBSERVE_RENAME_LIST(observer, fm); fm = scheme_append(fst, fm); @@ -6307,9 +6638,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env else fst = NULL; - if (fst && SCHEME_STX_SYMBOLP(fst) && scheme_stx_module_eq(scheme_begin_stx, fst, 0)) { + if (fst && SCHEME_STX_SYMBOLP(fst) && scheme_stx_module_eq(begin_stx, fst, phase)) { fm = SCHEME_STX_CDR(fm); - e = scheme_add_rename(e, post_ex_rn_set); + e = scheme_add_rename(e, bxs->post_ex_rn_set); SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e); fm = scheme_flatten_begin(e, fm); SCHEME_EXPAND_OBSERVE_SPLICE(observer, fm); @@ -6333,7 +6664,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env } if (!e) break; /* (begin) expansion at end */ - e = scheme_add_rename(e, post_ex_rn_set); + e = scheme_add_rename(e, bxs->post_ex_rn_set); SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e); @@ -6346,7 +6677,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env Scheme_Object *n; n = SCHEME_STX_CAR(e); - if (scheme_stx_module_eq(scheme_define_values_stx, fst, 0)) { + if (scheme_stx_module_eq(define_values_stx, fst, phase)) { /************ define-values *************/ Scheme_Object *vars, *val; @@ -6364,7 +6695,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env orig_name = name; /* Remember the original: */ - all_defs = scheme_make_pair(name, all_defs); + all_rt_defs = scheme_make_pair(name, all_rt_defs); name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL, NULL); @@ -6391,21 +6722,21 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env /* Add a renaming: */ if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) { - scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, 0); - *all_simple_renames = 0; + scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, phase, NULL, NULL, 0); + *bxs->all_simple_renames = 0; } else - scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, 0); + scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, phase, NULL, NULL, 0); vars = SCHEME_STX_CDR(vars); } SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); - kind = 2; - } else if (scheme_stx_module_eq(scheme_define_syntaxes_stx, fst, 0) - || scheme_stx_module_eq(scheme_define_for_syntaxes_stx, fst, 0)) { - /************ define-syntaxes & define-values-for-syntax *************/ + kind = DEFN_MODFORM_KIND; + } else if (scheme_stx_module_eq(define_syntaxes_stx, fst, phase) + || scheme_stx_module_eq(begin_for_syntax_stx, fst, phase)) { + /************ define-syntaxes & begin-for-syntax *************/ /* Define the macro: */ - Scheme_Compile_Info mrec; + Scheme_Compile_Info mrec, erec1; Scheme_Object *names, *l, *code, *m, *vec, *boundname; Resolve_Prefix *rp; Resolve_Info *ri; @@ -6416,79 +6747,80 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env int use_post_ex = 0; int max_let_depth; - for_stx = scheme_stx_module_eq(scheme_define_for_syntaxes_stx, fst, 0); - + for_stx = scheme_stx_module_eq(begin_for_syntax_stx, fst, phase); + SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(observer); - scheme_define_parse(e, &names, &code, 1, env, 1); + if (for_stx) { + if (scheme_stx_proper_list_length(e) < 0) + scheme_wrong_syntax(NULL, NULL, e, NULL); + code = e; + } else + scheme_define_parse(e, &names, &code, 1, env, 1); - if (SCHEME_STX_PAIRP(names) && SCHEME_STX_NULLP(SCHEME_STX_CDR(names))) - boundname = SCHEME_STX_CAR(names); - else - boundname = scheme_false; + if (!for_stx && SCHEME_STX_PAIRP(names) && SCHEME_STX_NULLP(SCHEME_STX_CDR(names))) + boundname = SCHEME_STX_CAR(names); + else + boundname = scheme_false; scheme_prepare_exp_env(env->genv); scheme_prepare_compile_env(env->genv->exp_env); eenv = scheme_new_comp_env(env->genv->exp_env, env->insp, 0); - scheme_frame_captures_lifts(eenv, NULL, NULL, scheme_false, scheme_false, - req_data, scheme_false); + if (!for_stx) + scheme_frame_captures_lifts(eenv, NULL, NULL, scheme_false, scheme_false, + req_data, scheme_false); - oenv = (for_stx ? eenv : env); + oenv = env; - for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - Scheme_Object *name, *orig_name; - name = SCHEME_STX_CAR(l); + if (!for_stx) { + for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { + Scheme_Object *name, *orig_name; + name = SCHEME_STX_CAR(l); - orig_name = name; + orig_name = name; - /* Remember the original: */ - if (!for_stx) - all_defs = scheme_make_pair(name, all_defs); - else - all_et_defs = scheme_make_pair(name, all_et_defs); + /* Remember the original: */ + all_rt_defs = scheme_make_pair(name, all_rt_defs); - name = scheme_tl_id_sym(oenv->genv, name, NULL, 2, NULL, NULL); + name = scheme_tl_id_sym(oenv->genv, name, NULL, 2, NULL, NULL); - if (scheme_lookup_in_table(oenv->genv->syntax, (const char *)name)) { - scheme_wrong_syntax("module", orig_name, e, - (for_stx - ? "duplicate for-syntax definition for identifier" - : "duplicate definition for identifier")); - return NULL; - } + if (scheme_lookup_in_table(oenv->genv->syntax, (const char *)name)) { + scheme_wrong_syntax("module", orig_name, e, + "duplicate definition for identifier"); + return NULL; + } - /* Check that it's not yet defined: */ - if (scheme_lookup_in_table(oenv->genv->toplevel, (const char *)name)) { - scheme_wrong_syntax("module", orig_name, e, - (for_stx - ? "duplicate for-syntax definition for identifier" - : "duplicate definition for identifier")); - return NULL; - } + /* Check that it's not yet defined: */ + if (scheme_lookup_in_table(oenv->genv->toplevel, (const char *)name)) { + scheme_wrong_syntax("module", orig_name, e, + "duplicate definition for identifier"); + return NULL; + } - /* Not required: */ - if (check_already_required(for_stx ? et_required : required, name)) { - scheme_wrong_syntax("module", orig_name, e, - (for_stx - ? "identifier is already imported for syntax" - : "identifier is already imported")); - return NULL; - } + /* Not required: */ + if (check_already_required(required, name)) { + scheme_wrong_syntax("module", orig_name, e, "identifier is already imported"); + return NULL; + } - if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) { - scheme_extend_module_rename(for_stx ? post_ex_et_rn : post_ex_rn, self_modidx, name, name, self_modidx, name, - for_stx ? 1 : 0, NULL, NULL, 0); - *all_simple_renames = 0; - use_post_ex = 1; - } else - scheme_extend_module_rename(for_stx ? et_rn : rn, self_modidx, name, name, self_modidx, name, - for_stx ? 1 : 0, NULL, NULL, 0); + if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) { + scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, + phase, NULL, NULL, 0); + *bxs->all_simple_renames = 0; + use_post_ex = 1; + } else + scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, + phase, NULL, NULL, 0); - count++; - } + count++; + } + } - names = scheme_named_map_1(NULL, stx_sym, names, (Scheme_Object *)oenv->genv); + if (for_stx) + names = NULL; + else + names = scheme_named_map_1(NULL, stx_sym, names, (Scheme_Object *)oenv->genv); mrec.comp = 1; mrec.dont_mark_local_use = 0; @@ -6499,21 +6831,50 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env mrec.env_already = 0; mrec.comp_flags = rec[drec].comp_flags; - if (!rec[drec].comp) { - Scheme_Expand_Info erec1; - erec1.comp = 0; - erec1.depth = -1; - erec1.value_name = boundname; + if (erec) { + erec1.comp = 0; + erec1.depth = -1; + erec1.value_name = boundname; erec1.observer = rec[drec].observer; erec1.pre_unwrapped = 0; erec1.env_already = 0; erec1.comp_flags = rec[drec].comp_flags; - SCHEME_EXPAND_OBSERVE_PHASE_UP(observer); - code = scheme_expand_expr_lift_to_let(code, eenv, &erec1, 0); - } - m = scheme_compile_expr_lift_to_let(code, eenv, &mrec, 0); + } - lifted_reqs = scheme_append(scheme_frame_get_require_lifts(eenv), lifted_reqs); + if (for_stx) { + adt = scheme_hash_tree_set(bxs->all_defs, scheme_make_integer(phase), all_rt_defs); + bxs->all_defs = adt; + if (erec) { + SCHEME_EXPAND_OBSERVE_PHASE_UP(observer); /* FIXME [Ryan?]? */ + /* We expand & compile the for-syntax code in one pass. */ + } + m = do_module_begin_at_phase(code, eenv, + &mrec, 0, + (erec ? &erec1 : NULL), 0, + phase + 1, body_lists, + bxs); + if (erec) { + code = SCHEME_STX_CAR(code); + code = scheme_make_pair(code, SCHEME_CAR(m)); + m = SCHEME_CDR(m); + } + if (rec[drec].comp) + body_lists = SCHEME_CDR(m); + m = SCHEME_CAR(m); + /* turn list of compiled expressions into a splice: */ + m = scheme_make_sequence_compilation(m, 0); + if (m->type == scheme_sequence_type) + m->type = scheme_splice_sequence_type; + } else { + if (erec) { + SCHEME_EXPAND_OBSERVE_PHASE_UP(observer); + code = scheme_expand_expr_lift_to_let(code, eenv, &erec1, 0); + } + m = scheme_compile_expr_lift_to_let(code, eenv, &mrec, 0); + } + + if (!for_stx) + lifted_reqs = scheme_append(scheme_frame_get_require_lifts(eenv), lifted_reqs); oi = scheme_optimize_info_create(); scheme_optimize_info_set_context(oi, (Scheme_Object *)env->genv->module); @@ -6533,9 +6894,11 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env /* Add code with names and lexical depth to exp-time body: */ vec = scheme_make_vector(5, NULL); - SCHEME_VEC_ELS(vec)[0] = ((SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names))) - ? SCHEME_CAR(names) - : names); + SCHEME_VEC_ELS(vec)[0] = (for_stx + ? scheme_false + : ((SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names))) + ? SCHEME_CAR(names) + : names)); SCHEME_VEC_ELS(vec)[1] = m; SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(max_let_depth); SCHEME_VEC_ELS(vec)[3] = (Scheme_Object *)rp; @@ -6551,52 +6914,59 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env rp = scheme_prefix_eval_clone(rp); eval_exptime(names, count, m, eenv->genv, rhs_env, rp, max_let_depth, 0, - (for_stx ? env->genv->exp_env->toplevel : env->genv->syntax), for_stx, + (for_stx ? env->genv->exp_env->toplevel : env->genv->syntax), + phase + 1, for_stx ? scheme_false : (use_post_ex ? post_ex_rn : rn), NULL); - if (rec[drec].comp) - e = NULL; - else { - m = SCHEME_STX_CDR(e); - m = SCHEME_STX_CAR(m); - m = scheme_make_pair(fst, - scheme_make_pair(m, scheme_make_pair(code, scheme_null))); + if (erec) { + if (for_stx) { + m = code; + } else { + m = SCHEME_STX_CDR(e); + m = SCHEME_STX_CAR(m); + m = scheme_make_pair(fst, + scheme_make_pair(m, scheme_make_pair(code, scheme_null))); + } e = scheme_datum_to_syntax(m, e, e, 0, 2); - } + } else + e = NULL; SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); - kind = 0; - } else if (scheme_stx_module_eq(require_stx, fst, 0)) { + + kind = DONE_MODFORM_KIND; + } else if (scheme_stx_module_eq(req_stx, fst, phase)) { /************ require *************/ SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE(observer); /* Adds requires to renamings and required modules to requires lists: */ - parse_requires(e, self_modidx, env->genv, env->genv->module, - rn_set, post_ex_rn_set, - check_require_name, tables, - redef_modname, + parse_requires(e, phase, self_modidx, env->genv, env->genv->module, + rn_set, bxs->post_ex_rn_set, + check_require_name, bxs->tables, + bxs->redef_modname, 0, 0, 1, - 1, 0, - all_simple_renames, modidx_cache); + 1, phase ? 1 : 0, + bxs->all_simple_renames, bxs->modidx_cache); - if (rec[drec].comp) + if (!erec) e = NULL; SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); - kind = 0; - } else if (scheme_stx_module_eq(provide_stx, fst, 0)) { + kind = DONE_MODFORM_KIND; + } else if (scheme_stx_module_eq(prov_stx, fst, phase)) { /************ provide *************/ - /* remember it for the second pass */ - kind = 3; - } else { - kind = 1; - } + /* remember it for pass 3 */ + p = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), + bxs->saved_provides); + bxs->saved_provides = p; + kind = PROVIDE_MODFORM_KIND; + } else + kind = EXPR_MODFORM_KIND; } else - kind = 1; + kind = EXPR_MODFORM_KIND; } else - kind = 1; + kind = EXPR_MODFORM_KIND; if (e) { p = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(kind)), scheme_null); @@ -6623,17 +6993,362 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env } /* first = a list of (cons semi-expanded-expression kind) */ - /* Bound names will not be re-bound at this point: */ - if (rec[drec].comp || (rec[drec].depth != -2)) { - scheme_seal_module_rename_set(rn_set, STX_SEAL_BOUND); - } - scheme_seal_module_rename_set(post_ex_rn_set, STX_SEAL_BOUND); + if (!phase) { + /* Bound names will not be re-bound at this point: */ + if (!erec || (erec[derec].depth != -2)) { + scheme_seal_module_rename_set(rn_set, STX_SEAL_BOUND); + } + scheme_seal_module_rename_set(bxs->post_ex_rn_set, STX_SEAL_BOUND); + + /* Check that all bindings used in phase-N expressions (for N >= 1) + were defined by now: */ + check_formerly_unbound(unbounds, env); + } + + /* Pass 2 */ + SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer); + + if (rec[drec].comp) { + /* Module and each `begin-for-syntax' group manages its own prefix: */ + cenv = scheme_new_comp_env(env->genv, env->insp, SCHEME_TOPLEVEL_FRAME); + } else + cenv = scheme_extend_as_toplevel(env); + + lift_data = scheme_make_vector(3, NULL); + SCHEME_VEC_ELS(lift_data)[0] = (Scheme_Object *)cenv; + SCHEME_VEC_ELS(lift_data)[1] = self_modidx; + SCHEME_VEC_ELS(lift_data)[2] = rn; + + maybe_has_lifts = 0; + + prev_p = NULL; + expanded_l = scheme_null; + for (p = first; !SCHEME_NULLP(p); ) { + Scheme_Object *e, *l, *ll; + int kind; + + e = SCHEME_CAR(p); + kind = SCHEME_INT_VAL(SCHEME_CDR(e)); + e = SCHEME_CAR(e); + + SCHEME_EXPAND_OBSERVE_NEXT(observer); + + if (kind == SAVED_MODFORM_KIND) { + expanded_l = scheme_make_pair(SCHEME_CDR(e), expanded_l); + SCHEME_CAR(p) = SCHEME_CAR(e); + prev_p = p; + p = SCHEME_CDR(p); + } else if (kind == PROVIDE_MODFORM_KIND) { + /* handle provides in the third pass */ + if (erec) + expanded_l = scheme_make_pair(e, expanded_l); + if (rec[drec].comp) { + if (!prev_p) + first = SCHEME_CDR(p); + else + SCHEME_CDR(prev_p) = SCHEME_CDR(p); + } + p = SCHEME_CDR(p); + } else if ((kind == EXPR_MODFORM_KIND) + || (kind == DEFN_MODFORM_KIND)) { + Scheme_Comp_Env *nenv; + + l = (maybe_has_lifts + ? scheme_frame_get_end_statement_lifts(cenv) + : scheme_null); + ll = (maybe_has_lifts + ? scheme_frame_get_provide_lifts(cenv) + : scheme_null); + scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx, req_data, ll); + maybe_has_lifts = 1; + + if (kind == DEFN_MODFORM_KIND) + nenv = cenv; + else + nenv = scheme_new_compilation_frame(0, 0, cenv); + + if (erec) { + Scheme_Expand_Info erec1; + scheme_init_expand_recs(rec, drec, &erec1, 1); + erec1.value_name = scheme_false; + e = scheme_expand_expr(e, nenv, &erec1, 0); + expanded_l = scheme_make_pair(e, expanded_l); + } + + if (rec[drec].comp) { + Scheme_Compile_Info crec1; + scheme_init_compile_recs(rec, drec, &crec1, 1); + crec1.resolve_module_ids = 0; + e = scheme_compile_expr(e, nenv, &crec1, 0); + } + + lifted_reqs = scheme_append(scheme_frame_get_require_lifts(cenv), lifted_reqs); + + l = scheme_frame_get_lifts(cenv); + if (SCHEME_NULLP(l)) { + /* No lifts - continue normally */ + SCHEME_CAR(p) = e; + prev_p = p; + p = SCHEME_CDR(p); + } else { + /* Lifts - insert them and try again */ + *bxs->all_simple_renames = 0; + SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, scheme_copy_list(l)); + if (erec) { + e = scheme_make_pair(scheme_make_pair(e, SCHEME_CAR(expanded_l)), + scheme_make_integer(4)); /* kept both expanded & maybe compiled */ + /* add back expanded at correct position later: */ + expanded_l = SCHEME_CDR(expanded_l); + } else + e = scheme_make_pair(e, scheme_make_integer(0)); /* don't re-compile/-expand */ + SCHEME_CAR(p) = e; + for (ll = l; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) { + e = scheme_make_pair(SCHEME_CAR(ll), scheme_make_integer(2)); + SCHEME_CAR(ll) = e; + } + p = scheme_append(l, p); + if (prev_p) { + SCHEME_CDR(prev_p) = p; + } else { + first = p; + } + } + } else { + if (erec) + expanded_l = scheme_make_pair(e, expanded_l); + SCHEME_CAR(p) = e; + prev_p = p; + p = SCHEME_CDR(p); + } + + /* If we're out of declarations, check for lifted-to-end: */ + if (SCHEME_NULLP(p) && maybe_has_lifts) { + int expr_cnt; + Scheme_Object *sp; + e = scheme_frame_get_provide_lifts(cenv); + e = scheme_reverse(e); + p = scheme_frame_get_end_statement_lifts(cenv); + p = scheme_reverse(p); + expr_cnt = scheme_list_length(p); + if (!SCHEME_NULLP(e)) + p = scheme_append(p, e); + SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, p); + for (ll = p; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) { + e = SCHEME_CAR(ll); + if (expr_cnt <= 0) { + sp = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), + bxs->saved_provides); + bxs->saved_provides = sp; + } + e = scheme_make_pair(e, ((expr_cnt > 0) + ? scheme_make_integer(EXPR_MODFORM_KIND) + : scheme_make_integer(PROVIDE_MODFORM_KIND))); + SCHEME_CAR(ll) = e; + expr_cnt--; + } + maybe_has_lifts = 0; + if (prev_p) { + SCHEME_CDR(prev_p) = p; + } else { + first = p; + } + } + } + if (erec) expanded_l = scheme_reverse(expanded_l); + + adt = scheme_hash_tree_set(bxs->all_defs, scheme_make_integer(phase), all_rt_defs); + bxs->all_defs = adt; + + /* Pass 3 */ + /* if at phase 0, expand provides for all phases */ + if (phase == 0) { + Scheme_Object *expanded_provides; + + expanded_provides = expand_all_provides(form, cenv, rec, drec, self_modidx, + bxs, !!erec); + + if (erec) { + expanded_provides = scheme_reverse(expanded_provides); + (void)fixup_expanded_provides(expanded_l, expanded_provides, 0); + } + } + + /* first = a list of compiled expressions */ + /* expanded_l = reversed list of expanded expressions */ + + /* If compiling, drop expressions that are constants: */ + if (rec[drec].comp) { + Scheme_Object *prev = NULL, *next; + for (p = first; !SCHEME_NULLP(p); p = next) { + next = SCHEME_CDR(p); + if (scheme_omittable_expr(SCHEME_CAR(p), -1, -1, 0, NULL, -1)) { + if (prev) + SCHEME_CDR(prev) = next; + else + first = next; + } else + prev = p; + } + } + + if (phase == 0) { + if (rec[drec].comp || (rec[drec].depth != -2)) { + scheme_seal_module_rename_set(rn_set, STX_SEAL_ALL); + } + scheme_seal_module_rename_set(bxs->post_ex_rn_set, STX_SEAL_ALL); + } + + adt = scheme_hash_tree_set(bxs->all_defs, scheme_make_integer(phase), all_rt_defs); + bxs->all_defs = adt; + + if (!phase) + env->genv->module->comp_prefix = cenv->prefix; + else + env->prefix = cenv->prefix; + + if (!SCHEME_NULLP(exp_body)) { + if (*bxs->_num_phases < phase + 2) + *bxs->_num_phases = phase + 2; + } + + if (erec) { + /* Add lifted requires */ + if (!SCHEME_NULLP(lifted_reqs)) { + lifted_reqs = scheme_reverse(lifted_reqs); + expanded_l = scheme_append(lifted_reqs, expanded_l); + } + } + + if (rec[drec].comp) { + body_lists = scheme_make_pair(first, scheme_make_pair(exp_body, body_lists)); + if (erec) + return scheme_make_pair(expanded_l, body_lists); + else + return body_lists; + } else + return expanded_l; +} + +static Scheme_Object *expand_all_provides(Scheme_Object *form, + Scheme_Comp_Env *cenv, + Scheme_Compile_Expand_Info *rec, int drec, + Scheme_Object *self_modidx, + Module_Begin_Expand_State *bxs, + int keep_expanded) +/* expands `#%provide's for all phases in a module that is otherwise + fully expanded; returns a list of expanded forms in reverse order, + if requested by `keep_expanded'. */ +{ + Scheme_Object *saved_provides; + Scheme_Object *observer, *expanded_provides = scheme_null; + int provide_phase; + Scheme_Object *e, *ex, *p_begin_stx, *fst; + Scheme_Comp_Env *pcenv; + + observer = rec[drec].observer; + + saved_provides = scheme_reverse(bxs->saved_provides); + while (!SCHEME_NULLP(saved_provides)) { + e = SCHEME_CAR(saved_provides); + provide_phase = SCHEME_INT_VAL(SCHEME_CDR(e)); + e = SCHEME_CAR(e); + + fst = SCHEME_STX_CAR(e); + + /* Expand and add provides to table: */ + + SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); + SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(observer); + + ex = e; + + if (provide_phase != 0) { + Scheme_Env *penv = cenv->genv; + int k; + for (k = 0; k < provide_phase; k++) { + penv = penv->exp_env; + } + if (rec[drec].comp) + pcenv = scheme_new_comp_env(penv, penv->insp, SCHEME_TOPLEVEL_FRAME); + else + pcenv = scheme_new_expand_env(penv, penv->insp, SCHEME_TOPLEVEL_FRAME); + p_begin_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin"), + scheme_false, + scheme_sys_wraps_phase_worker(provide_phase), + 0, 0); + } else { + pcenv = cenv; + p_begin_stx = scheme_begin_stx; + } + + parse_provides(form, fst, e, provide_phase, + bxs->all_provided, bxs->all_reprovided, + self_modidx, + bxs->all_defs_out, + bxs->tables, + bxs->all_defs, + pcenv, rec, drec, + &ex, + p_begin_stx); + + if (keep_expanded) + expanded_provides = scheme_make_pair(ex, expanded_provides); + + SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); + + saved_provides = SCHEME_CDR(saved_provides); + } + + return expanded_provides; +} + +static Scheme_Object *fixup_expanded_provides(Scheme_Object *expanded_l, + Scheme_Object *expanded_provides, + int phase) +/* mutates `expanded_l' to find `#%provide's (possibly nested in + `begin-for-syntax') and elace them with the ones in + `expanded_provides'. The provides in `expanded_l' and + `expanded_provides' are matched up by order. */ +{ + Scheme_Object *p, *e, *fst, *prov_stx, *begin_for_syntax_stx, *l; + + if (phase == 0) { + prov_stx = provide_stx; + begin_for_syntax_stx = scheme_begin_for_syntax_stx; + } else { + e = scheme_sys_wraps_phase_worker(phase); + begin_for_syntax_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin-for-syntax"), scheme_false, e, 0, 0); + prov_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), scheme_false, e, 0, 0); + } + + for (p = expanded_l; !SCHEME_NULLP(p); p = SCHEME_CDR(p)) { + e = SCHEME_CAR(p); + if (SCHEME_STX_PAIRP(e)) { + fst = SCHEME_STX_CAR(e); + if (scheme_stx_module_eq(prov_stx, fst, 0)) { + SCHEME_CAR(p) = SCHEME_CAR(expanded_provides); + expanded_provides = SCHEME_CDR(expanded_provides); + } else if (scheme_stx_module_eq(begin_for_syntax_stx, fst, 0)) { + l = scheme_flatten_syntax_list(e, NULL); + expanded_provides = fixup_expanded_provides(SCHEME_CDR(l), expanded_provides, phase + 1); + e = scheme_datum_to_syntax(l, e, e, 0, 2); + SCHEME_CAR(p) = e; + } + } + } + + return expanded_provides; +} + +static void check_formerly_unbound(Scheme_Object *unbounds, + Scheme_Comp_Env *env) +{ + Scheme_Object *stack = scheme_null, *lst, *p; + Scheme_Env *uenv = env->genv->exp_env; - /* Check that all bindings used in phase-N expressions (for N >= 1) - were defined by now: */ while (!SCHEME_NULLP(unbounds)) { - Scheme_Object *stack = scheme_null, *lst; - Scheme_Env *uenv = env->genv->exp_env; + stack = scheme_null; + uenv = env->genv->exp_env; lst = SCHEME_CAR(unbounds); while(1) { @@ -6664,337 +7379,82 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env } unbounds = SCHEME_CDR(unbounds); } + /* Disallow unbound variables from now on: */ - { - Scheme_Env *uenv = env->genv->exp_env; - while (uenv) { - uenv->disallow_unbound = 1; - uenv = uenv->exp_env; - } + uenv = env->genv->exp_env; + while (uenv) { + uenv->disallow_unbound = 1; + uenv = uenv->exp_env; } +} - /* Pass 2 */ - SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer); - - if (rec[drec].comp) { - /* Module manages its own prefix. That's how we get - multiple instantiation of a module with "dynamic linking". */ - cenv = scheme_new_comp_env(env->genv, env->insp, SCHEME_TOPLEVEL_FRAME); - } else - cenv = scheme_extend_as_toplevel(env); +static void install_stops(Scheme_Comp_Env *xenv, int phase, Scheme_Object **sv) +{ + Scheme_Object *stop, *w, *s; - lift_data = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(lift_data)[0] = (Scheme_Object *)cenv; - SCHEME_VEC_ELS(lift_data)[1] = self_modidx; - SCHEME_VEC_ELS(lift_data)[2] = rn; + stop = scheme_get_stop_expander(); - maybe_has_lifts = 0; + scheme_add_local_syntax(19, xenv); - prev_p = NULL; - for (p = first; !SCHEME_NULLP(p); ) { - Scheme_Object *e, *l, *ll; - int kind; - - e = SCHEME_CAR(p); - kind = SCHEME_INT_VAL(SCHEME_CDR(e)); - e = SCHEME_CAR(e); - - SCHEME_EXPAND_OBSERVE_NEXT(observer); - - if (kind == 3) { - Scheme_Object *fst; - - fst = SCHEME_STX_CAR(e); - - if (scheme_stx_module_eq(provide_stx, fst, 0)) { - /************ provide *************/ - /* Add provides to table: */ - Scheme_Object *ex; - - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); - SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(observer); - - ex = e; - - parse_provides(form, fst, e, - all_provided, all_reprovided, - self_modidx, - &all_defs_out, &all_et_defs_out, - tables, - all_defs, all_et_defs, cenv, rec, drec, - &ex); - - e = ex; - - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); - } - if (!rec[drec].comp) { - SCHEME_CAR(p) = e; - prev_p = p; - p = SCHEME_CDR(p); - } else { - p = SCHEME_CDR(p); - if (!prev_p) - first = p; - else - SCHEME_CDR(prev_p) = p; - } - } else if (kind) { - Scheme_Comp_Env *nenv; - - l = (maybe_has_lifts - ? scheme_frame_get_end_statement_lifts(cenv) - : scheme_null); - ll = (maybe_has_lifts - ? scheme_frame_get_provide_lifts(cenv) - : scheme_null); - scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx, req_data, ll); - maybe_has_lifts = 1; - - if (kind == 2) - nenv = cenv; - else - nenv = scheme_new_compilation_frame(0, 0, cenv); - - if (rec[drec].comp) { - Scheme_Compile_Info crec1; - scheme_init_compile_recs(rec, drec, &crec1, 1); - crec1.resolve_module_ids = 0; - e = scheme_compile_expr(e, nenv, &crec1, 0); - } else { - Scheme_Expand_Info erec1; - scheme_init_expand_recs(rec, drec, &erec1, 1); - erec1.value_name = scheme_false; - e = scheme_expand_expr(e, nenv, &erec1, 0); - } - - lifted_reqs = scheme_append(scheme_frame_get_require_lifts(cenv), lifted_reqs); - - l = scheme_frame_get_lifts(cenv); - if (SCHEME_NULLP(l)) { - /* No lifts - continue normally */ - SCHEME_CAR(p) = e; - prev_p = p; - p = SCHEME_CDR(p); - } else { - /* Lifts - insert them and try again */ - *all_simple_renames = 0; - SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, scheme_copy_list(l)); - e = scheme_make_pair(e, scheme_make_integer(0)); /* don't re-compile/-expand */ - SCHEME_CAR(p) = e; - for (ll = l; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) { - e = scheme_make_pair(SCHEME_CAR(ll), scheme_make_integer(2)); - SCHEME_CAR(ll) = e; - } - p = scheme_append(l, p); - if (prev_p) { - SCHEME_CDR(prev_p) = p; - } else { - first = p; - } - } - } else { - SCHEME_CAR(p) = e; - prev_p = p; - p = SCHEME_CDR(p); - } - - /* If we're out of declarations, check for lifted-to-end: */ - if (SCHEME_NULLP(p) && maybe_has_lifts) { - int expr_cnt; - e = scheme_frame_get_provide_lifts(cenv); - e = scheme_reverse(e); - p = scheme_frame_get_end_statement_lifts(cenv); - p = scheme_reverse(p); - expr_cnt = scheme_list_length(p); - if (!SCHEME_NULLP(e)) - p = scheme_append(p, e); - SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, p); - for (ll = p; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) { - e = scheme_make_pair(SCHEME_CAR(ll), (expr_cnt > 0) ? scheme_make_integer(1) : scheme_make_integer(3)); - SCHEME_CAR(ll) = e; - expr_cnt--; - } - maybe_has_lifts = 0; - if (prev_p) { - SCHEME_CDR(prev_p) = p; - } else { - first = p; - } - } - } - /* first = a list of expanded/compiled expressions */ - - /* If compiling, drop expressions that are constants: */ - if (rec[drec].comp) { - Scheme_Object *prev = NULL, *next; - for (p = first; !SCHEME_NULLP(p); p = next) { - next = SCHEME_CDR(p); - if (scheme_omittable_expr(SCHEME_CAR(p), -1, -1, 0, NULL, -1)) { - if (prev) - SCHEME_CDR(prev) = next; - else - first = next; - } else - prev = p; - } - } - - if (rec[drec].comp || (rec[drec].depth != -2)) { - scheme_seal_module_rename_set(rn_set, STX_SEAL_ALL); - } - scheme_seal_module_rename_set(post_ex_rn_set, STX_SEAL_ALL); - - /* Compute provides for re-provides and all-defs-out: */ - (void)compute_reprovides(all_provided, - all_reprovided, - env->genv->module, - tables, - env->genv, - all_defs, all_defs_out, - all_et_defs, all_et_defs_out, - "require", NULL, NULL); - - /* Compute provide arrays */ - exps = compute_provide_arrays(all_provided, tables, - env->genv->module->me, - env->genv, - form, &et_exps); - - /* Compute indirect provides (which is everything at the top-level): */ - exis = compute_indirects(env->genv, env->genv->module->me->rt, &exicount, 1); - exsis = compute_indirects(env->genv, env->genv->module->me->rt, &exsicount, 0); - et_exis = compute_indirects(env->genv->exp_env, env->genv->module->me->et, &et_exicount, 1); - - if (rec[drec].comp || (rec[drec].depth != -2)) { - scheme_clean_dead_env(env->genv); - } - - if (!rec[drec].comp) { - Scheme_Module_Phase_Exports *rt = env->genv->module->me->rt; - int excount = rt->num_provides; - int exvcount = rt->num_var_provides; - Scheme_Object **exsns = rt->provide_src_names; - Scheme_Object **exs = rt->provides; - Scheme_Object **exss = rt->provide_srcs; - - /* Produce annotations (in the form of properties) - for module information: - 'module-variable-provides = '(item ...) - 'module-syntax-provides = '(item ...) - 'module-indirect-provides = '(id ...) - 'module-kernel-reprovide-hint = 'kernel-reexport - - item = name - | (ext-id . def-id) - | (modidx ext-id . def-id) - kernel-reexport = #f - | #t - | exclusion-id - */ - int j; - Scheme_Object *e, *a, *result; - - result = scheme_null; - - /* kernel re-export info (always #f): */ - result = scheme_make_pair(scheme_false, result); - - /* Indirect provides */ - a = scheme_null; - for (j = 0; j < exicount; j++) { - a = scheme_make_pair(exis[j], a); - } - result = scheme_make_pair(a, result); - - /* add syntax and value exports: */ - for (j = 0; j < 2; j++) { - int top, i; - - e = scheme_null; - - if (!j) { - i = exvcount; - top = excount; - } else { - i = 0; - top = exvcount; - } - - for (; i < top; i++) { - if (SCHEME_FALSEP(exss[i]) - && SAME_OBJ(exs[i], exsns[i])) - a = exs[i]; - else { - a = scheme_make_pair(exs[i], exsns[i]); - if (!SCHEME_FALSEP(exss[i])) { - a = scheme_make_pair(exss[i], a); - } - } - e = scheme_make_pair(a, e); - } - result = scheme_make_pair(e, result); - } - - env->genv->module->hints = result; - } - - if (rec[drec].comp) { - Scheme_Object *exp_body_r = scheme_null; - - /* Reverse exp_body */ - while (!SCHEME_NULLP(exp_body)) { - exp_body_r = scheme_make_pair(SCHEME_CAR(exp_body), - exp_body_r); - exp_body = SCHEME_CDR(exp_body); - } - - first = scheme_list_to_vector(first); - env->genv->module->body = first; - exp_body_r = scheme_list_to_vector(exp_body_r); - env->genv->module->et_body = exp_body_r; - - env->genv->module->provide_protects = exps; - env->genv->module->et_provide_protects = et_exps; - - env->genv->module->indirect_provides = exis; - env->genv->module->num_indirect_provides = exicount; - - if (*all_simple_renames) { - env->genv->module->indirect_syntax_provides = exsis; - env->genv->module->num_indirect_syntax_provides = exsicount; - } else { - env->genv->module->indirect_syntax_provides = NULL; - env->genv->module->num_indirect_syntax_provides = 0; - } - - env->genv->module->et_indirect_provides = et_exis; - env->genv->module->num_indirect_et_provides = et_exicount; - - env->genv->module->comp_prefix = cenv->prefix; - - if (*all_simple_renames) { - env->genv->module->rn_stx = scheme_true; - } - - return (Scheme_Object *)env->genv->module; + if (phase == 0) { + scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv); + scheme_set_local_syntax(1, scheme_define_values_stx, stop, xenv); + scheme_set_local_syntax(2, scheme_define_syntaxes_stx, stop, xenv); + scheme_set_local_syntax(3, scheme_begin_for_syntax_stx, stop, xenv); + scheme_set_local_syntax(4, require_stx, stop, xenv); + scheme_set_local_syntax(5, provide_stx, stop, xenv); + scheme_set_local_syntax(6, set_stx, stop, xenv); + scheme_set_local_syntax(7, app_stx, stop, xenv); + scheme_set_local_syntax(8, scheme_top_stx, stop, xenv); + scheme_set_local_syntax(9, lambda_stx, stop, xenv); + scheme_set_local_syntax(10, case_lambda_stx, stop, xenv); + scheme_set_local_syntax(11, let_values_stx, stop, xenv); + scheme_set_local_syntax(12, letrec_values_stx, stop, xenv); + scheme_set_local_syntax(13, if_stx, stop, xenv); + scheme_set_local_syntax(14, begin0_stx, stop, xenv); + scheme_set_local_syntax(15, with_continuation_mark_stx, stop, xenv); + scheme_set_local_syntax(16, letrec_syntaxes_stx, stop, xenv); + scheme_set_local_syntax(17, var_ref_stx, stop, xenv); + scheme_set_local_syntax(18, expression_stx, stop, xenv); + sv[0] = scheme_define_values_stx; + sv[1] = scheme_begin_stx; + sv[2] = scheme_define_syntaxes_stx; + sv[3] = scheme_begin_for_syntax_stx; + sv[4] = require_stx; + sv[5] = provide_stx; } else { - if (rec[drec].depth == -2) { - /* This was a local expand. Flush definitions, because the body expand may start over. */ - flush_definitions(env->genv); - if (env->genv->exp_env) - flush_definitions(env->genv->exp_env); - } - - p = SCHEME_STX_CAR(form); - - /* Add lifted requires */ - if (!SCHEME_NULLP(lifted_reqs)) { - lifted_reqs = scheme_reverse(lifted_reqs); - first = scheme_append(lifted_reqs, first); - } - - return scheme_datum_to_syntax(cons(p, first), orig_form, orig_form, 0, 2); + w = scheme_sys_wraps_phase_worker(phase); + s = scheme_datum_to_syntax(scheme_intern_symbol("begin"), scheme_false, w, 0, 0); + sv[1] = s; + scheme_set_local_syntax(0, s, stop, xenv); + s = scheme_datum_to_syntax(scheme_intern_symbol("define-values"), scheme_false, w, 0, 0); + sv[0] = s; + scheme_set_local_syntax(1, s, stop, xenv); + s = scheme_datum_to_syntax(scheme_intern_symbol("define-syntaxes"), scheme_false, w, 0, 0); + sv[2] = s; + scheme_set_local_syntax(2, s, stop, xenv); + s = scheme_datum_to_syntax(scheme_intern_symbol("begin-for-syntax"), scheme_false, w, 0, 0); + sv[3] = s; + scheme_set_local_syntax(3, s, stop, xenv); + s = scheme_datum_to_syntax(scheme_intern_symbol("#%require"), scheme_false, w, 0, 0); + sv[4] = s; + scheme_set_local_syntax(4, s, stop, xenv); + s = scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), scheme_false, w, 0, 0); + sv[5] = s; + scheme_set_local_syntax(5, s, stop, xenv); + scheme_set_local_syntax(6, scheme_datum_to_syntax(scheme_intern_symbol("set!"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(7, scheme_datum_to_syntax(scheme_intern_symbol("#%app"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(8, scheme_datum_to_syntax(scheme_intern_symbol("#%top"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(9, scheme_datum_to_syntax(scheme_intern_symbol("lambda"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(10, scheme_datum_to_syntax(scheme_intern_symbol("case-lambda"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(11, scheme_datum_to_syntax(scheme_intern_symbol("let-values"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(12, scheme_datum_to_syntax(scheme_intern_symbol("letrec-values"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(13, scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(14, scheme_datum_to_syntax(scheme_intern_symbol("begin0"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(15, scheme_datum_to_syntax(scheme_intern_symbol("with-continuation-mark"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(16, scheme_datum_to_syntax(scheme_intern_symbol("letrec-syntaxes+values"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(17, scheme_datum_to_syntax(scheme_intern_symbol("#%variable-reference"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(18, scheme_datum_to_syntax(scheme_intern_symbol("#%expression"), scheme_false, w, 0, 0), stop, xenv); } } @@ -7033,8 +7493,8 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, Scheme_Module *mod_for_requires, Scheme_Hash_Table *tables, Scheme_Env *_genv, - Scheme_Object *all_rt_defs, Scheme_Object *all_rt_defs_out, - Scheme_Object *all_et_defs, Scheme_Object *all_et_defs_out, + int num_phases, + Scheme_Hash_Tree *all_defs, Scheme_Hash_Table *all_defs_out, const char *matching_form, Scheme_Object *all_mods, /* a phase list to use for all mods */ Scheme_Object *all_phases) /* a module-path list for all phases */ @@ -7043,7 +7503,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, Scheme_Object *reprovided, *tvec; int i, k, z; Scheme_Object *rx, *provided_list, *phase, *req_phase; - Scheme_Object *all_defs, *all_defs_out; + Scheme_Object *all_x_defs, *all_x_defs_out; Scheme_Env *genv; if (all_phases) { @@ -7289,27 +7749,20 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, } /* Do all-defined provides */ - for (z = 0; z < 2; z++) { - if (!z) { - all_defs = all_rt_defs; - all_defs_out = all_rt_defs_out; - provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, scheme_make_integer(0)); - phase = scheme_make_integer(0); - genv = _genv; - } else { - all_defs = all_et_defs; - all_defs_out = all_et_defs_out; - provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, scheme_make_integer(1)); - phase = scheme_make_integer(1); - genv = _genv->exp_env; - } - - if (all_defs_out) { - for (; !SCHEME_NULLP(all_defs_out); all_defs_out = SCHEME_CDR(all_defs_out)) { + genv = _genv; + for (z = 0; z < num_phases; z++) { + all_x_defs = scheme_hash_tree_get(all_defs, scheme_make_integer(z)); + if (!all_x_defs) all_x_defs = scheme_null; + all_x_defs_out = scheme_hash_get(all_defs_out, scheme_make_integer(z)); + provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, scheme_make_integer(z)); + phase = scheme_make_integer(z); + + if (all_x_defs_out) { + for (; !SCHEME_NULLP(all_x_defs_out); all_x_defs_out = SCHEME_CDR(all_x_defs_out)) { Scheme_Object *exns, *ree, *ree_kw, *exl, *name, *a, *adl, *exname, *pfx; int protected; - ree = SCHEME_CAR(all_defs_out); + ree = SCHEME_CAR(all_x_defs_out); protected = SCHEME_TRUEP(SCHEME_CDR(ree)); ree = SCHEME_CAR(ree); ree_kw = SCHEME_CAR(ree); @@ -7327,7 +7780,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, } } - for (adl = all_defs; SCHEME_PAIRP(adl); adl = SCHEME_CDR(adl)) { + for (adl = all_x_defs; SCHEME_PAIRP(adl); adl = SCHEME_CDR(adl)) { name = SCHEME_CAR(adl); exname = SCHEME_STX_SYM(name); name = scheme_tl_id_sym(genv, name, NULL, 0, NULL, NULL); @@ -7368,6 +7821,8 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, } } } + + genv = _genv->exp_env; } return 1; @@ -7489,7 +7944,8 @@ Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bind genv->module, tables, genv, - NULL, NULL, NULL, NULL, + 0, + NULL, NULL, NULL, all_mods, all_phases); @@ -7621,16 +8077,33 @@ static Scheme_Object *extract_free_id_name(Scheme_Object *name, return name; } -char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, - Scheme_Module_Exports *me, - Scheme_Env *genv, - Scheme_Object *form, - char **_phase1_protects) +static int lookup(Scheme_Env *genv, Scheme_Object *phase, int as_syntax, const char *name) +{ + int p; + + if (SCHEME_FALSEP(phase)) + return 0; + + p = SCHEME_INT_VAL(phase); + while (p--) { + genv = genv->exp_env; + if (!genv) return 0; + } + + return !!scheme_lookup_in_table((as_syntax ? genv->syntax : genv->toplevel), (const char *)name); +} + +void compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, + Scheme_Module_Exports *me, + Scheme_Env *genv, + Scheme_Object *form, + int num_phases, Scheme_Module_Export_Info **exp_infos) { int i, count, z, implicit; Scheme_Object **exs, **exsns, **exss, **exsnoms, *phase; Scheme_Hash_Table *provided, *required; - char *exps, *exets, *phase0_exps = NULL, *phase1_exps = NULL; + char *exps; + int *exets; int excount, exvcount; Scheme_Module_Phase_Exports *pt; Scheme_Object *implicit_src, *implicit_src_name, *implicit_mod_phase; @@ -7673,8 +8146,8 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table exss = MALLOC_N(Scheme_Object *, count); exsnoms = MALLOC_N(Scheme_Object *, count); exps = MALLOC_N_ATOMIC(char, count); - exets = MALLOC_N_ATOMIC(char, count); - memset(exets, 0, count); + exets = MALLOC_N_ATOMIC(int, count); + memset(exets, 0, count * sizeof(int)); /* Do non-syntax first. */ for (count = 0, i = provided->size; i--; ) { @@ -7693,25 +8166,18 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table if (!implicit && genv - && (SAME_OBJ(phase, scheme_make_integer(0)) - || SAME_OBJ(phase, scheme_make_integer(1))) - && scheme_lookup_in_table(SAME_OBJ(phase, scheme_make_integer(0)) - ? genv->toplevel - : genv->exp_env->toplevel, - (const char *)name)) { + && lookup(genv, phase, 0, (const char *)name)) { /* Defined locally */ exs[count] = provided->keys[i]; exsns[count] = name; exss[count] = scheme_false; /* means "self" */ exsnoms[count] = scheme_null; /* since "self" */ exps[count] = protected; - if (SAME_OBJ(phase, scheme_make_integer(1))) - exets[count] = 1; + exets[count] = SCHEME_INT_VAL(phase); count++; } else if (!implicit && genv - && SAME_OBJ(phase, scheme_make_integer(0)) - && scheme_lookup_in_table(genv->syntax, (const char *)name)) { + && lookup(genv, phase, 1, (const char *)name)) { /* Skip syntax for now. */ } else if (implicit) { /* Rename-transformer redirect; skip for now. */ @@ -7729,14 +8195,21 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table noms = adjust_for_rename(exs[count], SCHEME_VEC_ELS(v)[4], SCHEME_VEC_ELS(v)[0]); exsnoms[count] = noms; exps[count] = protected; - if (SAME_OBJ(SCHEME_VEC_ELS(v)[8], scheme_make_integer(1))) - exets[count] = 1; + exets[count] = SCHEME_INT_VAL(SCHEME_VEC_ELS(v)[8]); count++; } } else { /* Not defined! */ - scheme_wrong_syntax("module", prnt_name, form, "provided identifier not defined or imported"); + char buf[32], *phase_expl; + if (phase) { + sprintf(buf, " for phase %" PRIxPTR, SCHEME_INT_VAL(phase)); + phase_expl = scheme_strdup(buf); + } else + phase_expl = ""; + scheme_wrong_syntax("module", prnt_name, form, + "provided identifier not defined or imported%s", + phase_expl); } } } @@ -7759,14 +8232,14 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table if (!implicit && genv - && SAME_OBJ(phase, scheme_make_integer(0)) - && scheme_lookup_in_table(genv->syntax, (const char *)name)) { + && lookup(genv, phase, 1, (const char *)name)) { /* Defined locally */ exs[count] = provided->keys[i]; exsns[count] = name; exss[count] = scheme_false; /* means "self" */ exsnoms[count] = scheme_null; /* since "self" */ exps[count] = protected; + exets[count] = SCHEME_INT_VAL(phase); count++; } else if (implicit) { /* We record all free-id=?-based exports as syntax, even though they may be values. */ @@ -7828,27 +8301,38 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table pt->provide_nominal_srcs = exsnoms; pt->provide_src_phases = exets; - if (SAME_OBJ(phase, scheme_make_integer(0))) - phase0_exps = exps; - else if (SAME_OBJ(phase, scheme_make_integer(1))) - phase1_exps = exps; + /* Discard exps if all 0 */ + if (exps) { + for (i = 0; i < excount; i++) { + if (exps[i]) + break; + } + if (i >= excount) + exps = NULL; + } + + if (exps) { + if (SCHEME_TRUEP(phase)) { + if ((SCHEME_INT_VAL(phase) < 0) + || (SCHEME_INT_VAL(phase) >= num_phases)) + scheme_signal_error("internal error: bad phase for exports"); + exp_infos[SCHEME_INT_VAL(phase)]->provide_protects = exps; + } + } } } - - *_phase1_protects = phase1_exps; - - return phase0_exps; } /* Helper: */ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, - char *exps, char *exets, + char *exps, int *exets, Scheme_Object **exsnoms, int start, int count, int do_uninterned) { int i, j; Scheme_Object *tmp_ex, *tmp_exsn, *tmp_exs, *tmp_exsnom, *pivot; - char tmp_exp, tmp_exet; + char tmp_exp; + int tmp_exet; if (do_uninterned) { /* Look for uninterned and move to end: */ @@ -7961,9 +8445,9 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob } } -static Scheme_Object *expand_provide(Scheme_Object *e, +static Scheme_Object *expand_provide(Scheme_Object *e, int at_phase, Scheme_Hash_Table *tables, - Scheme_Object *all_defs, Scheme_Object *all_et_defs, + Scheme_Hash_Tree *all_defs, Scheme_Comp_Env *cenv, Scheme_Compile_Info *rec, int drec) { Scheme_Expand_Info erec1; @@ -7975,10 +8459,16 @@ static Scheme_Object *expand_provide(Scheme_Object *e, cenv); stop = scheme_get_stop_expander(); scheme_add_local_syntax(1, xenv); - scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv); + if (!at_phase) + scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv); + else + scheme_set_local_syntax(0, scheme_datum_to_syntax(scheme_intern_symbol("begin"), + scheme_false, + scheme_sys_wraps_phase_worker(at_phase), + 0, 0), + stop, xenv); - b = scheme_make_pair((Scheme_Object *)tables, - scheme_make_pair(all_defs, all_et_defs)); + b = scheme_make_pair((Scheme_Object *)tables, (Scheme_Object *)all_defs); scheme_current_thread->current_local_bindings = b; scheme_init_expand_recs(rec, drec, &erec1, 1); @@ -7993,20 +8483,21 @@ static Scheme_Object *expand_provide(Scheme_Object *e, } void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, + int at_phase, Scheme_Hash_Table *all_provided, Scheme_Hash_Table *all_reprovided, Scheme_Object *self_modidx, - Scheme_Object **_all_defs_out, - Scheme_Object **_et_all_defs_out, + Scheme_Hash_Table *all_defs_out, Scheme_Hash_Table *tables, - Scheme_Object *all_defs, Scheme_Object *all_et_defs, + Scheme_Hash_Tree *all_defs, Scheme_Comp_Env *cenv, Scheme_Compile_Info *rec, int drec, - Scheme_Object **_expanded) + Scheme_Object **_expanded, + Scheme_Object *begin_stx) { Scheme_Object *l, *rebuilt = scheme_null, *protect_stx = NULL; int protect_cnt = 0, mode_cnt = 0, expanded = 0; Scheme_Object *mode = scheme_make_integer(0), *mode_stx = NULL; - Scheme_Object *all_defs_out; + Scheme_Object *all_x_defs_out, *all_x_defs; Scheme_Hash_Table *provided; Scheme_Object *phase; @@ -8085,19 +8576,19 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, break; } - if (SAME_OBJ(mode, scheme_make_integer(0))) - all_defs_out = *_all_defs_out; - else if (SAME_OBJ(mode, scheme_make_integer(1))) - all_defs_out = *_et_all_defs_out; + if (SCHEME_FALSEP(mode)) + phase = mode; else - all_defs_out = NULL; + phase = scheme_bin_plus(mode, scheme_make_integer(at_phase)); - provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, mode); + all_x_defs_out = scheme_hash_get(all_defs_out, phase); + if (!all_x_defs_out) all_x_defs_out = scheme_null; + + provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, phase); if (!provided) { provided = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(all_provided, mode, (Scheme_Object *)provided); + scheme_hash_set(all_provided, phase, (Scheme_Object *)provided); } - phase = mode; if (SCHEME_STX_SYMBOLP(a)) { /* */ @@ -8125,7 +8616,9 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, return; } - p = expand_provide(p, tables, all_defs, all_et_defs, cenv, rec, drec); + all_x_defs = scheme_hash_tree_get(all_defs, mode); + if (!all_x_defs) all_x_defs = scheme_null; + p = expand_provide(p, at_phase, tables, all_defs, cenv, rec, drec); /* Check for '(begin datum ...) result: */ p = scheme_flatten_syntax_list(p, &islist); @@ -8136,7 +8629,7 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, else { rest = SCHEME_CAR(p); if (!SCHEME_STX_SYMBOLP(rest) - || !scheme_stx_module_eq(scheme_begin_stx, rest, 0)) { + || !scheme_stx_module_eq(begin_stx, rest, at_phase)) { p = NULL; } } @@ -8298,16 +8791,16 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, if (!SCHEME_STX_NULLP(rest)) scheme_wrong_syntax(NULL, a, e, "bad syntax"); - if (!all_defs_out) { + if (!all_x_defs_out) { scheme_wrong_syntax(NULL, a, e, "no definitions at phase level %V", mode); } - all_defs_out = scheme_make_pair(scheme_make_pair(scheme_make_pair(e, - scheme_make_pair(scheme_null, - scheme_false)), - protect_cnt ? scheme_true : scheme_false), - all_defs_out); + all_x_defs_out = scheme_make_pair(scheme_make_pair(scheme_make_pair(e, + scheme_make_pair(scheme_null, + scheme_false)), + protect_cnt ? scheme_true : scheme_false), + all_x_defs_out); } else if (SAME_OBJ(prefix_all_defined_symbol, SCHEME_STX_VAL(fst))) { /* (prefix-all-defined ) */ Scheme_Object *prefix; @@ -8325,16 +8818,16 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, } prefix = SCHEME_STX_VAL(prefix); - if (!all_defs_out) { + if (!all_x_defs_out) { scheme_wrong_syntax(NULL, a, e, "no definitions at phase level %V", mode); } - all_defs_out = scheme_make_pair(scheme_make_pair(scheme_make_pair(e, - scheme_make_pair(scheme_null, - prefix)), - protect_cnt ? scheme_true : scheme_false), - all_defs_out); + all_x_defs_out = scheme_make_pair(scheme_make_pair(scheme_make_pair(e, + scheme_make_pair(scheme_null, + prefix)), + protect_cnt ? scheme_true : scheme_false), + all_x_defs_out); } else if (SAME_OBJ(all_defined_except_symbol, SCHEME_STX_VAL(fst)) || SAME_OBJ(prefix_all_defined_except_symbol, SCHEME_STX_VAL(fst))) { /* ([prefix-]all-defined-except ...) */ @@ -8370,16 +8863,16 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, } } - if (!all_defs_out) { + if (!all_x_defs_out) { scheme_wrong_syntax(NULL, a, e, "no definitions at phase level %V", mode); } - all_defs_out = scheme_make_pair(scheme_make_pair(scheme_make_pair(e, - scheme_make_pair(exns, - prefix)), - protect_cnt ? scheme_true : scheme_false), - all_defs_out); + all_x_defs_out = scheme_make_pair(scheme_make_pair(scheme_make_pair(e, + scheme_make_pair(exns, + prefix)), + protect_cnt ? scheme_true : scheme_false), + all_x_defs_out); } else { scheme_wrong_syntax(NULL, a, e, NULL); } @@ -8409,10 +8902,8 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, if (protect_cnt) --protect_cnt; - if (SAME_OBJ(mode, scheme_make_integer(0))) - *_all_defs_out = all_defs_out; - else if (SAME_OBJ(mode, scheme_make_integer(1))) - *_et_all_defs_out = all_defs_out; + if (all_x_defs_out) + scheme_hash_set(all_defs_out, mode, all_x_defs_out); if (mode_cnt) { --mode_cnt; @@ -8501,7 +8992,7 @@ Scheme_Object *scheme_module_exported_list(Scheme_Object *modpath, Scheme_Env *g void add_single_require(Scheme_Module_Exports *me, /* from module */ Scheme_Object *only_phase, - Scheme_Object *src_phase_index, + Scheme_Object *src_phase_index, /* import from pahse 0 to src_phase_index */ Scheme_Object *idx, /* from module's idx; may be saved for unmarshalling */ Scheme_Env *orig_env, /* env for mark_src or copy_vars */ Scheme_Object *rn_set, /* add requires to renames in this set when no mark_src */ @@ -8524,12 +9015,12 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ int j, var_count; Scheme_Object *orig_idx = idx, *to_phase; Scheme_Object **exs, **exsns, **exss, *context_marks = scheme_null; - char *exets; + int *exets; int has_context, save_marshal_info = 0; Scheme_Object *nominal_modidx, *one_exn, *prnt_iname, *name, *rn, *ename = orig_ename; Scheme_Hash_Table *orig_onlys; int k, skip_rename, do_copy_vars; - + if (mark_src) { /* Check whether there's context for this import (which leads to generated local names). */ @@ -8886,7 +9377,7 @@ Scheme_Object *scheme_get_kernel_modidx(void) return kernel_modidx; } -void parse_requires(Scheme_Object *form, +void parse_requires(Scheme_Object *form, int at_phase, Scheme_Object *base_modidx, Scheme_Env *main_env, Scheme_Module *for_m, @@ -8961,9 +9452,12 @@ void parse_requires(Scheme_Object *form, && !SCHEME_BIGNUMP(a_mode)) scheme_wrong_syntax(NULL, i, form, "bad `%s-meta' level specification", (SAME_OBJ(for_meta_symbol, aav) ? "for" : "just")); - if (SAME_OBJ(for_meta_symbol, aav)) - mode = a_mode; - else + if (SAME_OBJ(for_meta_symbol, aav)) { + if (SCHEME_FALSEP(a_mode)) + mode = a_mode; + else + mode = scheme_bin_plus(a_mode, scheme_make_integer(0)); + } else just_mode = a_mode; } else { if (SAME_OBJ(for_syntax_symbol, aav)) @@ -9202,7 +9696,7 @@ void parse_requires(Scheme_Object *form, start_module(m, env, 0, idx, start ? eval_exp : 0, start ? eval_run : 0, - main_env->phase, scheme_null); + main_env->phase, scheme_null, 0); /* Add name to require list, if it's not there: */ if (main_env->module) { @@ -9236,16 +9730,14 @@ void parse_requires(Scheme_Object *form, x_just_mode = just_mode; x_mode = mode; - if (main_env->phase) { - /* We get here only via `eval' or `namespace-require'. */ - if (x_just_mode && SCHEME_TRUEP(x_just_mode)) { - x_just_mode = scheme_bin_plus(x_just_mode, scheme_make_integer(main_env->phase)); - } + if (at_phase) { if (x_mode && SCHEME_TRUEP(x_mode)) { - x_mode = scheme_bin_plus(x_mode, scheme_make_integer(main_env->phase)); + x_mode = scheme_bin_plus(x_mode, scheme_make_integer(at_phase)); } + /* x_just_mode refers to the mode at export, which doesn't shift + by phase context at import */ } - + add_single_require(m->me, x_just_mode, x_mode, idx, rename_env, rn_set, post_ex_rn_set, NULL, exns, onlys, prefix, iname, ename, @@ -9344,7 +9836,7 @@ do_require_execute(Scheme_Env *env, Scheme_Object *form) ht = NULL; } - parse_requires(form, modidx, env, NULL, + parse_requires(form, env->phase, modidx, env, NULL, rn_set, rn_set, check_dup_require, ht, NULL, @@ -9399,7 +9891,7 @@ static Scheme_Object *do_require(Scheme_Object *form, Scheme_Comp_Env *env, else modidx = scheme_false; - parse_requires(form, modidx, genv, NULL, + parse_requires(form, genv->phase, modidx, genv, NULL, rn_set, rn_set, check_dup_require, ht, NULL, diff --git a/src/racket/src/mzmark_type.inc b/src/racket/src/mzmark_type.inc index 3ab370bf96..94d5c422c6 100644 --- a/src/racket/src/mzmark_type.inc +++ b/src/racket/src/mzmark_type.inc @@ -2167,6 +2167,7 @@ static int namespace_val_MARK(void *p, struct NewGC *gc) { gcMARK2(e->exp_env, gc); gcMARK2(e->template_env, gc); gcMARK2(e->label_env, gc); + gcMARK2(e->instance_env, gc); gcMARK2(e->shadowed_syntax, gc); @@ -2176,6 +2177,7 @@ static int namespace_val_MARK(void *p, struct NewGC *gc) { gcMARK2(e->tt_require_names, gc); gcMARK2(e->dt_require_names, gc); gcMARK2(e->other_require_names, gc); + gcMARK2(e->running, gc); gcMARK2(e->did_starts, gc); gcMARK2(e->available_next[0], gc); gcMARK2(e->available_next[1], gc); @@ -2206,6 +2208,7 @@ static int namespace_val_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(e->exp_env, gc); gcFIXUP2(e->template_env, gc); gcFIXUP2(e->label_env, gc); + gcFIXUP2(e->instance_env, gc); gcFIXUP2(e->shadowed_syntax, gc); @@ -2215,6 +2218,7 @@ static int namespace_val_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(e->tt_require_names, gc); gcFIXUP2(e->dt_require_names, gc); gcFIXUP2(e->other_require_names, gc); + gcFIXUP2(e->running, gc); gcFIXUP2(e->did_starts, gc); gcFIXUP2(e->available_next[0], gc); gcFIXUP2(e->available_next[1], gc); @@ -2508,24 +2512,14 @@ static int module_val_MARK(void *p, struct NewGC *gc) { gcMARK2(m->dt_requires, gc); gcMARK2(m->other_requires, gc); - gcMARK2(m->body, gc); - gcMARK2(m->et_body, gc); + gcMARK2(m->bodies, gc); gcMARK2(m->me, gc); - gcMARK2(m->provide_protects, gc); - gcMARK2(m->indirect_provides, gc); - - gcMARK2(m->indirect_syntax_provides, gc); - - gcMARK2(m->et_provide_protects, gc); - gcMARK2(m->et_indirect_provides, gc); + gcMARK2(m->exp_infos, gc); gcMARK2(m->self_modidx, gc); - gcMARK2(m->accessible, gc); - gcMARK2(m->et_accessible, gc); - gcMARK2(m->insp, gc); gcMARK2(m->lang_info, gc); @@ -2558,24 +2552,14 @@ static int module_val_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(m->dt_requires, gc); gcFIXUP2(m->other_requires, gc); - gcFIXUP2(m->body, gc); - gcFIXUP2(m->et_body, gc); + gcFIXUP2(m->bodies, gc); gcFIXUP2(m->me, gc); - gcFIXUP2(m->provide_protects, gc); - gcFIXUP2(m->indirect_provides, gc); - - gcFIXUP2(m->indirect_syntax_provides, gc); - - gcFIXUP2(m->et_provide_protects, gc); - gcFIXUP2(m->et_indirect_provides, gc); + gcFIXUP2(m->exp_infos, gc); gcFIXUP2(m->self_modidx, gc); - gcFIXUP2(m->accessible, gc); - gcFIXUP2(m->et_accessible, gc); - gcFIXUP2(m->insp, gc); gcFIXUP2(m->lang_info, gc); @@ -2598,6 +2582,41 @@ static int module_val_FIXUP(void *p, struct NewGC *gc) { #define module_val_IS_CONST_SIZE 1 +static int exp_info_val_SIZE(void *p, struct NewGC *gc) { + return + gcBYTES_TO_WORDS(sizeof(Scheme_Module_Export_Info)); +} + +static int exp_info_val_MARK(void *p, struct NewGC *gc) { + Scheme_Module_Export_Info *m = (Scheme_Module_Export_Info *)p; + + gcMARK2(m->provide_protects, gc); + gcMARK2(m->indirect_provides, gc); + + gcMARK2(m->indirect_syntax_provides, gc); + + gcMARK2(m->accessible, gc); + return + gcBYTES_TO_WORDS(sizeof(Scheme_Module_Export_Info)); +} + +static int exp_info_val_FIXUP(void *p, struct NewGC *gc) { + Scheme_Module_Export_Info *m = (Scheme_Module_Export_Info *)p; + + gcFIXUP2(m->provide_protects, gc); + gcFIXUP2(m->indirect_provides, gc); + + gcFIXUP2(m->indirect_syntax_provides, gc); + + gcFIXUP2(m->accessible, gc); + return + gcBYTES_TO_WORDS(sizeof(Scheme_Module_Export_Info)); +} + +#define exp_info_val_IS_ATOMIC 0 +#define exp_info_val_IS_CONST_SIZE 1 + + static int module_phase_exports_val_SIZE(void *p, struct NewGC *gc) { return gcBYTES_TO_WORDS(sizeof(Scheme_Module_Phase_Exports)); diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index 250c6818ed..cb7fa8e498 100644 --- a/src/racket/src/mzmarksrc.c +++ b/src/racket/src/mzmarksrc.c @@ -876,6 +876,7 @@ namespace_val { gcMARK2(e->exp_env, gc); gcMARK2(e->template_env, gc); gcMARK2(e->label_env, gc); + gcMARK2(e->instance_env, gc); gcMARK2(e->shadowed_syntax, gc); @@ -885,6 +886,7 @@ namespace_val { gcMARK2(e->tt_require_names, gc); gcMARK2(e->dt_require_names, gc); gcMARK2(e->other_require_names, gc); + gcMARK2(e->running, gc); gcMARK2(e->did_starts, gc); gcMARK2(e->available_next[0], gc); gcMARK2(e->available_next[1], gc); @@ -1009,24 +1011,14 @@ module_val { gcMARK2(m->dt_requires, gc); gcMARK2(m->other_requires, gc); - gcMARK2(m->body, gc); - gcMARK2(m->et_body, gc); + gcMARK2(m->bodies, gc); gcMARK2(m->me, gc); - gcMARK2(m->provide_protects, gc); - gcMARK2(m->indirect_provides, gc); - - gcMARK2(m->indirect_syntax_provides, gc); - - gcMARK2(m->et_provide_protects, gc); - gcMARK2(m->et_indirect_provides, gc); + gcMARK2(m->exp_infos, gc); gcMARK2(m->self_modidx, gc); - gcMARK2(m->accessible, gc); - gcMARK2(m->et_accessible, gc); - gcMARK2(m->insp, gc); gcMARK2(m->lang_info, gc); @@ -1045,6 +1037,20 @@ module_val { gcBYTES_TO_WORDS(sizeof(Scheme_Module)); } +exp_info_val { + mark: + Scheme_Module_Export_Info *m = (Scheme_Module_Export_Info *)p; + + gcMARK2(m->provide_protects, gc); + gcMARK2(m->indirect_provides, gc); + + gcMARK2(m->indirect_syntax_provides, gc); + + gcMARK2(m->accessible, gc); + size: + gcBYTES_TO_WORDS(sizeof(Scheme_Module_Export_Info)); +} + module_phase_exports_val { mark: Scheme_Module_Phase_Exports *m = (Scheme_Module_Phase_Exports *)p; diff --git a/src/racket/src/optimize.c b/src/racket/src/optimize.c index 28094ffb70..b15d5a49de 100644 --- a/src/racket/src/optimize.c +++ b/src/racket/src/optimize.c @@ -2996,7 +2996,7 @@ begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context) return obj; } -static Scheme_Object *do_define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info, int for_stx) +static Scheme_Object *do_define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info) { Scheme_Object *val; Optimize_Info *einfo; @@ -3016,12 +3016,29 @@ static Scheme_Object *do_define_syntaxes_optimize(Scheme_Object *data, Optimize_ static Scheme_Object *define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info, int context) { - return do_define_syntaxes_optimize(data, info, 0); + return do_define_syntaxes_optimize(data, info); } -static Scheme_Object *define_for_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info, int context) +static Scheme_Object *begin_for_syntax_optimize(Scheme_Object *data, Optimize_Info *info, int context) { - return do_define_syntaxes_optimize(data, info, 1); + Scheme_Object *l, *a; + Optimize_Info *einfo; + + l = SCHEME_VEC_ELS(data)[2]; + + while (!SCHEME_NULLP(l)) { + einfo = scheme_optimize_info_create(); + if (info->inline_fuel < 0) + einfo->inline_fuel = -1; + + a = SCHEME_CAR(l); + a = scheme_optimize_expr(a, einfo, 0); + SCHEME_CAR(l) = a; + + l = SCHEME_CDR(l); + } + + return data; } /*========================================================================*/ @@ -4517,7 +4534,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) old_context = info->context; info->context = (Scheme_Object *)m; - cnt = SCHEME_VEC_SIZE(m->body); + cnt = SCHEME_VEC_SIZE(m->bodies[0]); if (OPT_ESTIMATE_FUTURE_SIZES) { if (info->enforce_const) { @@ -4525,7 +4542,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) size estimate, which is used to discourage early loop unrolling at the expense of later inlining. */ for (i_m = 0; i_m < cnt; i_m++) { - e = SCHEME_VEC_ELS(m->body)[i_m]; + e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { int n; @@ -4562,7 +4579,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ - e = SCHEME_VEC_ELS(m->body)[i_m]; + e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; is_proc_def = 0; if (OPT_DISCOURAGE_EARLY_INLINE && info->enforce_const) { @@ -4587,7 +4604,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) info->use_psize = 0; info->inline_fuel = inline_fuel; } - SCHEME_VEC_ELS(m->body)[i_m] = e; + SCHEME_VEC_ELS(m->bodies[0])[i_m] = e; if (info->enforce_const) { /* If this expression/definition can't have any side effect @@ -4717,7 +4734,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) shift-cloning, since there are no local variables in scope. */ int old_sz, new_sz; - e = SCHEME_VEC_ELS(m->body)[start_simltaneous]; + e = SCHEME_VEC_ELS(m->bodies[0])[start_simltaneous]; if (OPT_DELAY_GROUP_PROPAGATE || OPT_LIMIT_FUNCTION_RESIZE) { if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { @@ -4730,7 +4747,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) old_sz = 0; e = scheme_optimize_expr(e, info, 0); - SCHEME_VEC_ELS(m->body)[start_simltaneous] = e; + SCHEME_VEC_ELS(m->bodies[0])[start_simltaneous] = e; if (re_consts) { /* Install optimized closures into constant table --- @@ -4809,7 +4826,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) int can_omit = 0; for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ - e = SCHEME_VEC_ELS(m->body)[i_m]; + e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; if (scheme_omittable_expr(e, -1, -1, 0, NULL, -1)) { can_omit++; } @@ -4820,12 +4837,12 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) vec = scheme_make_vector(cnt - can_omit, NULL); for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ - e = SCHEME_VEC_ELS(m->body)[i_m]; + e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; if (!scheme_omittable_expr(e, -1, -1, 0, NULL, -1)) { SCHEME_VEC_ELS(vec)[j++] = e; } } - m->body = vec; + m->bodies[0] = vec; } } @@ -5007,8 +5024,8 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in return set_optimize(expr, info, context); case scheme_define_syntaxes_type: return define_syntaxes_optimize(expr, info, context); - case scheme_define_for_syntax_type: - return define_for_syntaxes_optimize(expr, info, context); + case scheme_begin_for_syntax_type: + return begin_for_syntax_optimize(expr, info, context); case scheme_case_lambda_sequence_type: return case_lambda_optimize(expr, info, context); case scheme_begin0_sequence_type: @@ -5225,7 +5242,7 @@ Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *expr, Optimize_I return expr; case scheme_define_values_type: case scheme_define_syntaxes_type: - case scheme_define_for_syntax_type: + case scheme_begin_for_syntax_type: case scheme_boxenv_type: return NULL; case scheme_require_form_type: @@ -5396,7 +5413,7 @@ Scheme_Object *scheme_optimize_shift(Scheme_Object *expr, int delta, int after_d case scheme_boxenv_type: case scheme_define_values_type: case scheme_define_syntaxes_type: - case scheme_define_for_syntax_type: + case scheme_begin_for_syntax_type: case scheme_require_form_type: case scheme_module_type: scheme_signal_error("scheme_optimize_shift: no shift available for %d", SCHEME_TYPE(expr)); diff --git a/src/racket/src/resolve.c b/src/racket/src/resolve.c index 644912cc5d..6f2571fcc5 100644 --- a/src/racket/src/resolve.c +++ b/src/racket/src/resolve.c @@ -729,7 +729,7 @@ case_lambda_resolve(Scheme_Object *expr, Resolve_Info *rslv) return expr; } -static Scheme_Object *do_define_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info, int for_stx) +static Scheme_Object *do_define_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info) { Comp_Prefix *cp; Resolve_Prefix *rp; @@ -748,8 +748,6 @@ static Scheme_Object *do_define_syntaxes_resolve(Scheme_Object *data, Resolve_In einfo = scheme_resolve_info_create(rp); - if (for_stx) - names = scheme_resolve_list(names, einfo); val = scheme_resolve_expr(val, einfo); rp = scheme_remap_prefix(rp, einfo); @@ -770,19 +768,54 @@ static Scheme_Object *do_define_syntaxes_resolve(Scheme_Object *data, Resolve_In names = SCHEME_CDR(names); } - vec->type = (for_stx ? scheme_define_for_syntax_type : scheme_define_syntaxes_type); + vec->type = scheme_define_syntaxes_type; return vec; } static Scheme_Object *define_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info) { - return do_define_syntaxes_resolve(data, info, 0); + return do_define_syntaxes_resolve(data, info); } -static Scheme_Object *define_for_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info) +static Scheme_Object *begin_for_syntax_resolve(Scheme_Object *data, Resolve_Info *info) { - return do_define_syntaxes_resolve(data, info, 1); + Comp_Prefix *cp; + Resolve_Prefix *rp; + Scheme_Object *l, *p, *a, *base_stack_depth, *dummy, *vec; + Resolve_Info *einfo; + + cp = (Comp_Prefix *)SCHEME_VEC_ELS(data)[0]; + dummy = SCHEME_VEC_ELS(data)[1]; + l = SCHEME_VEC_ELS(data)[2]; + + rp = scheme_resolve_prefix(1, cp, 1); + + dummy = scheme_resolve_expr(dummy, info); + + einfo = scheme_resolve_info_create(rp); + + p = scheme_null; + while (!SCHEME_NULLP(l)) { + a = SCHEME_CAR(l); + a = scheme_resolve_expr(a, einfo); + p = scheme_make_pair(a, p); + l = SCHEME_CDR(l); + } + l = scheme_reverse(p); + + rp = scheme_remap_prefix(rp, einfo); + + base_stack_depth = scheme_make_integer(einfo->max_let_depth); + + vec = scheme_make_vector(4, NULL); + SCHEME_VEC_ELS(vec)[0] = l; + SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)rp; + SCHEME_VEC_ELS(vec)[2] = base_stack_depth; + SCHEME_VEC_ELS(vec)[3] = dummy; + vec->type = scheme_begin_for_syntax_type; + + return vec; } /*========================================================================*/ @@ -2152,20 +2185,20 @@ module_expr_resolve(Scheme_Object *data, Resolve_Info *old_rslv) rslv->in_module = 1; scheme_enable_expression_resolve_lifts(rslv); - cnt = SCHEME_VEC_SIZE(m->body); + cnt = SCHEME_VEC_SIZE(m->bodies[0]); for (i = 0; i < cnt; i++) { Scheme_Object *e; - e = scheme_resolve_expr(SCHEME_VEC_ELS(m->body)[i], rslv); - SCHEME_VEC_ELS(m->body)[i] = e; + e = scheme_resolve_expr(SCHEME_VEC_ELS(m->bodies[0])[i], rslv); + SCHEME_VEC_ELS(m->bodies[0])[i] = e; } m->max_let_depth = rslv->max_let_depth; lift_vec = rslv->lifts; if (!SCHEME_NULLP(SCHEME_VEC_ELS(lift_vec)[0])) { - b = scheme_append(SCHEME_VEC_ELS(lift_vec)[0], scheme_vector_to_list(m->body)); + b = scheme_append(SCHEME_VEC_ELS(lift_vec)[0], scheme_vector_to_list(m->bodies[0])); b = scheme_list_to_vector(b); - m->body = b; + m->bodies[0] = b; } rp->num_lifts = SCHEME_INT_VAL(SCHEME_VEC_ELS(lift_vec)[1]); @@ -2288,8 +2321,8 @@ Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info) return define_values_resolve(expr, info); case scheme_define_syntaxes_type: return define_syntaxes_resolve(expr, info); - case scheme_define_for_syntax_type: - return define_for_syntaxes_resolve(expr, info); + case scheme_begin_for_syntax_type: + return begin_for_syntax_resolve(expr, info); case scheme_set_bang_type: return set_resolve(expr, info); case scheme_require_form_type: diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 97c9382887..48ca03b7f1 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -398,7 +398,7 @@ extern Scheme_Object *scheme_begin_stx; extern Scheme_Object *scheme_module_begin_stx; extern Scheme_Object *scheme_define_values_stx; extern Scheme_Object *scheme_define_syntaxes_stx; -extern Scheme_Object *scheme_define_for_syntaxes_stx; +extern Scheme_Object *scheme_begin_for_syntax_stx; extern Scheme_Object *scheme_top_stx; extern Scheme_Object *scheme_recur_symbol, *scheme_display_symbol, *scheme_write_special_symbol; @@ -2672,7 +2672,7 @@ struct Start_Module_Args; #ifdef MZ_USE_JIT void *scheme_module_run_start(Scheme_Env *menv, Scheme_Env *env, Scheme_Object *name); -void *scheme_module_exprun_start(Scheme_Env *menv, int set_ns, Scheme_Object *name); +void *scheme_module_exprun_start(Scheme_Env *menv, int phase_plus_set_ns, Scheme_Object *name); void *scheme_module_start_start(struct Start_Module_Args *a, Scheme_Object *name); #endif void *scheme_module_run_finish(Scheme_Env *menv, Scheme_Env *env); @@ -2931,6 +2931,7 @@ struct Scheme_Env { struct Scheme_Env *exp_env; struct Scheme_Env *template_env; struct Scheme_Env *label_env; + struct Scheme_Env *instance_env; /* shortcut to env where module is instantiated */ Scheme_Hash_Table *shadowed_syntax; /* top level only */ @@ -2939,7 +2940,8 @@ struct Scheme_Env { Scheme_Object *link_midx; Scheme_Object *require_names, *et_require_names, *tt_require_names, *dt_require_names; /* resolved */ Scheme_Hash_Table *other_require_names; - char running, et_running, attached, ran; + char *running; /* array of size `num_phases' if `module' and `mod_phase==0' */ + char attached, ran; Scheme_Object *did_starts; Scheme_Object *available_next[2]; @@ -2964,6 +2966,19 @@ struct Scheme_Env { /* A Scheme_Module corresponds to a module declaration. A module instantiation is reprsented by a Scheme_Env */ +typedef struct Scheme_Module_Export_Info { + MZTAG_IF_REQUIRED + char *provide_protects; /* 1 => protected, 0 => not */ + Scheme_Object **indirect_provides; /* symbols (internal names) */ + int num_indirect_provides; + + /* Only if needed to reconstruct the renaming: */ + Scheme_Object **indirect_syntax_provides; /* symbols (internal names) */ + int num_indirect_syntax_provides; + + Scheme_Hash_Table *accessible; /* (symbol -> ...) */ +} Scheme_Module_Export_Info; + typedef struct Scheme_Module { Scheme_Object so; /* scheme_module_type */ @@ -2982,29 +2997,17 @@ typedef struct Scheme_Module Scheme_Invoke_Proc prim_body; Scheme_Invoke_Proc prim_et_body; - Scheme_Object *body; /* or data, if prim_body */ - Scheme_Object *et_body; /* list of (vector list-of-names expr depth-int resolve-prefix) */ + Scheme_Object **bodies; /* array `num_phases' long */ char no_cert; struct Scheme_Module_Exports *me; - char *provide_protects; /* 1 => protected, 0 => not */ - Scheme_Object **indirect_provides; /* symbols (internal names) */ - int num_indirect_provides; - - /* Only if needed to reconstruct the renaming: */ - Scheme_Object **indirect_syntax_provides; /* symbols (internal names) */ - int num_indirect_syntax_provides; - - char *et_provide_protects; /* 1 => protected, 0 => not */ - Scheme_Object **et_indirect_provides; /* symbols (internal names) */ - int num_indirect_et_provides; + int num_phases; + Scheme_Module_Export_Info **exp_infos; /* array `num_phases' long */ Scheme_Object *self_modidx; - Scheme_Hash_Table *accessible; /* (symbol -> ...) */ - Scheme_Hash_Table *et_accessible; /* phase -> (symbol -> ...) */ Scheme_Object *insp; /* declaration-time inspector, for module instantiation and enabling access to protected imports */ @@ -3036,7 +3039,7 @@ typedef struct Scheme_Module_Phase_Exports Scheme_Object **provide_srcs; /* module access paths, #f for self */ Scheme_Object **provide_src_names; /* symbols (original internal names) */ Scheme_Object **provide_nominal_srcs; /* import source if re-exported; NULL or array of lists */ - char *provide_src_phases; /* NULL, or src phase for for-syntax import */ + int *provide_src_phases; /* NULL, or src phase for for-syntax import */ int num_provides; int num_var_provides; /* non-syntax listed first in provides */ @@ -3142,7 +3145,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object Scheme_Env *from_env, int *_would_complain, Scheme_Object **_is_constant); void scheme_check_unsafe_accessible(Scheme_Object *insp, Scheme_Env *from_env); -Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *name); +Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *name, int mod_phase); Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx, Scheme_Object *shift_from_modidx, diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index cf41c1d243..9a4c0809ba 100644 --- a/src/racket/src/schvers.h +++ b/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "5.1.3.6" +#define MZSCHEME_VERSION "5.1.3.7" #define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 3 -#define MZSCHEME_VERSION_W 6 +#define MZSCHEME_VERSION_W 7 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/racket/src/sfs.c b/src/racket/src/sfs.c index 494c65a29a..cc62b7c9d4 100644 --- a/src/racket/src/sfs.c +++ b/src/racket/src/sfs.c @@ -937,9 +937,23 @@ static Scheme_Object *define_syntaxes_sfs(Scheme_Object *data, SFS_Info *info) return do_define_syntaxes_sfs(data, info); } -static Scheme_Object *define_for_syntaxes_sfs(Scheme_Object *data, SFS_Info *info) +static Scheme_Object *begin_for_syntax_sfs(Scheme_Object *data, SFS_Info *info) { - return do_define_syntaxes_sfs(data, info); + Scheme_Object *l, *a; + + if (!info->pass) { + int depth; + depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[2]); + + for (l = SCHEME_VEC_ELS(data)[0]; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + a = SCHEME_CAR(l); + info = scheme_new_sfs_info(depth); + a = scheme_sfs(a, info, depth); + SCHEME_CAR(l) = a; + } + } + + return data; } /*========================================================================*/ @@ -1051,7 +1065,7 @@ module_sfs(Scheme_Object *data, SFS_Info *old_info) Scheme_Module *m = (Scheme_Module *)data; Scheme_Object *e, *ex; SFS_Info *info; - int i, cnt, let_depth; + int i, j, cnt, let_depth; if (!old_info->for_mod) { if (old_info->pass) @@ -1065,25 +1079,27 @@ module_sfs(Scheme_Object *data, SFS_Info *old_info) info = old_info; - cnt = SCHEME_VEC_SIZE(m->body); + cnt = SCHEME_VEC_SIZE(m->bodies[0]); scheme_sfs_start_sequence(info, cnt, 0); for (i = 0; i < cnt; i++) { - e = scheme_sfs_expr(SCHEME_VEC_ELS(m->body)[i], info, -1); - SCHEME_VEC_ELS(m->body)[i] = e; + e = scheme_sfs_expr(SCHEME_VEC_ELS(m->bodies[0])[i], info, -1); + SCHEME_VEC_ELS(m->bodies[0])[i] = e; } if (!info->pass) { - cnt = SCHEME_VEC_SIZE(m->et_body); - for (i = 0; i < cnt; i++) { - e = SCHEME_VEC_ELS(m->et_body)[i]; - - let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); - ex = SCHEME_VEC_ELS(e)[1]; - - info = scheme_new_sfs_info(let_depth); - ex = scheme_sfs(ex, info, let_depth); - SCHEME_VEC_ELS(e)[1] = ex; + for (j = m->num_phases; j-- > 1; ) { + cnt = SCHEME_VEC_SIZE(m->bodies[j]); + for (i = 0; i < cnt; i++) { + e = SCHEME_VEC_ELS(m->bodies[j])[i]; + + let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); + ex = SCHEME_VEC_ELS(e)[1]; + + info = scheme_new_sfs_info(let_depth); + ex = scheme_sfs(ex, info, let_depth); + SCHEME_VEC_ELS(e)[1] = ex; + } } } @@ -1205,11 +1221,11 @@ Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_ expr = define_values_sfs(expr, info); break; case scheme_define_syntaxes_type: - expr = define_for_syntaxes_sfs(expr, info); - break; - case scheme_define_for_syntax_type: expr = define_syntaxes_sfs(expr, info); break; + case scheme_begin_for_syntax_type: + expr = begin_for_syntax_sfs(expr, info); + break; case scheme_set_bang_type: expr = set_sfs(expr, info); break; diff --git a/src/racket/src/startup.inc b/src/racket/src/startup.inc index 39623b781f..6f6969481a 100644 --- a/src/racket/src/startup.inc +++ b/src/racket/src/startup.inc @@ -8,8 +8,8 @@ " let let* letrec" " parameterize" " define)" -"(define-values-for-syntax(here-stx)" -"(quote-syntax here))" +"(begin-for-syntax " +"(define-values(here-stx)(quote-syntax here)))" "(define-syntaxes(unless)" "(lambda(stx)" "(let-values(((s)(syntax->list stx)))" diff --git a/src/racket/src/startup.rktl b/src/racket/src/startup.rktl index 95598ea0c1..8c5b451f3d 100644 --- a/src/racket/src/startup.rktl +++ b/src/racket/src/startup.rktl @@ -41,8 +41,8 @@ parameterize define) - (define-values-for-syntax (here-stx) - (quote-syntax here)) + (begin-for-syntax + (define-values (here-stx) (quote-syntax here))) (define-syntaxes (unless) (lambda (stx) diff --git a/src/racket/src/stypes.h b/src/racket/src/stypes.h index 4f8413527a..ecc7a0818f 100644 --- a/src/racket/src/stypes.h +++ b/src/racket/src/stypes.h @@ -20,7 +20,7 @@ enum { scheme_define_values_type, /* 15 */ scheme_define_syntaxes_type, /* 16 */ - scheme_define_for_syntax_type, /* 17 */ + scheme_begin_for_syntax_type, /* 17 */ scheme_set_bang_type, /* 18 */ scheme_boxenv_type, /* 19 */ scheme_begin0_sequence_type, /* 20 */ @@ -270,6 +270,7 @@ enum { scheme_rt_validate_clearing, /* 246 */ scheme_rt_rb_node, /* 247 */ scheme_rt_lightweight_cont, /* 248 */ + scheme_rt_export_info, /* 249 */ #endif _scheme_last_type_ diff --git a/src/racket/src/syntax.c b/src/racket/src/syntax.c index fd59520c95..4a81f7ed24 100644 --- a/src/racket/src/syntax.c +++ b/src/racket/src/syntax.c @@ -4355,8 +4355,11 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ result = glob_id; } else { result = SCHEME_CDR(rename); - if (SCHEME_PAIRP(result)) + if (SCHEME_PAIRP(result)) { + if (SCHEME_INTP(SCHEME_CAR(result))) /* phase? */ + result = SCHEME_CDR(result); result = SCHEME_CAR(result); + } } } else result = glob_id; diff --git a/src/racket/src/type.c b/src/racket/src/type.c index 2c4d588850..5d6c3700a4 100644 --- a/src/racket/src/type.c +++ b/src/racket/src/type.c @@ -125,7 +125,7 @@ scheme_init_type () set_name(scheme_define_values_type, ""); set_name(scheme_define_syntaxes_type, ""); - set_name(scheme_define_for_syntax_type, ""); + set_name(scheme_begin_for_syntax_type, ""); set_name(scheme_begin0_sequence_type, ""); set_name(scheme_splice_sequence_type, ""); set_name(scheme_module_type, ""); @@ -540,7 +540,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_define_values_type, vector_obj); GC_REG_TRAV(scheme_define_syntaxes_type, vector_obj); - GC_REG_TRAV(scheme_define_for_syntax_type, vector_obj); + GC_REG_TRAV(scheme_begin_for_syntax_type, vector_obj); GC_REG_TRAV(scheme_varref_form_type, twoptr_obj); GC_REG_TRAV(scheme_apply_values_type, twoptr_obj); GC_REG_TRAV(scheme_boxenv_type, twoptr_obj); @@ -549,6 +549,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_splice_sequence_type, seq_rec); GC_REG_TRAV(scheme_set_bang_type, set_bang); GC_REG_TRAV(scheme_module_type, module_val); + GC_REG_TRAV(scheme_rt_export_info, exp_info_val); GC_REG_TRAV(scheme_require_form_type, twoptr_obj); GC_REG_TRAV(_scheme_values_types_, bad_trav); diff --git a/src/racket/src/validate.c b/src/racket/src/validate.c index 0c162d7dcb..d1e7ecb1db 100644 --- a/src/racket/src/validate.c +++ b/src/racket/src/validate.c @@ -430,7 +430,7 @@ static void do_define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, Scheme_Object *name, *val, *base_stack_depth, *dummy; int sdepth; - if (!SAME_TYPE(SCHEME_TYPE(data), (for_stx ? scheme_define_for_syntax_type : scheme_define_syntaxes_type)) + if (!SAME_TYPE(SCHEME_TYPE(data), (for_stx ? scheme_begin_for_syntax_type : scheme_define_syntaxes_type)) || (SCHEME_VEC_SIZE(data) < 4)) scheme_ill_formed_code(port); @@ -462,10 +462,13 @@ static void do_define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, if (!for_stx) { scheme_validate_code(port, SCHEME_VEC_ELS(data)[0], sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts, NULL, 0); } else { - /* Make a fake `define-values' to check with respect to the exp-time stack */ - val = scheme_clone_vector(data, 3, 1); - SCHEME_VEC_ELS(val)[0] = SCHEME_VEC_ELS(data)[0]; - scheme_validate_code(port, val, sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts, NULL, 0); + val = SCHEME_VEC_ELS(data)[0]; + while (SCHEME_PAIRP(val)) { + scheme_validate_code(port, SCHEME_CAR(val), sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts, NULL, 0); + val = SCHEME_CDR(val); + } + if (!SCHEME_NULLP(val)) + scheme_ill_formed_code(port); } } @@ -481,13 +484,13 @@ static void define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, num_toplevels, num_stxes, num_lifts, tl_use_map, 0); } -static void define_for_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) +static void begin_for_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, + char *stack, Validate_TLS tls, + int depth, int letlimit, int delta, + int num_toplevels, int num_stxes, int num_lifts, + void *tl_use_map, int result_ignored, + struct Validate_Clearing *vc, int tailpos, + Scheme_Hash_Tree *procs) { do_define_syntaxes_validate(data, port, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, 1); @@ -849,7 +852,7 @@ static void module_validate(Scheme_Object *data, Mz_CPort *port, Scheme_Hash_Tree *procs) { Scheme_Module *m; - int i, cnt, let_depth; + int i, j, cnt, let_depth; Resolve_Prefix *rp; Scheme_Object *e; @@ -859,23 +862,25 @@ static void module_validate(Scheme_Object *data, Mz_CPort *port, if (!SCHEME_MODNAMEP(m->modname)) scheme_ill_formed_code(port); - scheme_validate_code(port, m->body, m->max_let_depth, + scheme_validate_code(port, m->bodies[0], m->max_let_depth, m->prefix->num_toplevels, m->prefix->num_stxes, m->prefix->num_lifts, NULL, 1); /* validate exp-time code */ - cnt = SCHEME_VEC_SIZE(m->et_body); - for (i = 0; i < cnt; i++) { - e = SCHEME_VEC_ELS(m->et_body)[i]; + for (j = m->num_phases; j-- > 1; ) { + cnt = SCHEME_VEC_SIZE(m->bodies[j]); + for (i = 0; i < cnt; i++) { + e = SCHEME_VEC_ELS(m->bodies[j])[i]; - let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); - rp = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[3]; - e = SCHEME_VEC_ELS(e)[1]; + let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); + rp = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[3]; + e = SCHEME_VEC_ELS(e)[1]; - scheme_validate_code(port, e, let_depth, - rp->num_toplevels, rp->num_stxes, rp->num_lifts, NULL, - 0); + scheme_validate_code(port, e, let_depth, + rp->num_toplevels, rp->num_stxes, rp->num_lifts, NULL, + 0); + } } } @@ -1442,11 +1447,11 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, num_toplevels, num_stxes, num_lifts, tl_use_map, result_ignored, vc, tailpos, procs); break; - case scheme_define_for_syntax_type: + case scheme_begin_for_syntax_type: no_flo(need_flonum, port); - define_for_syntaxes_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - result_ignored, vc, tailpos, procs); + begin_for_syntaxes_validate(expr, port, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + result_ignored, vc, tailpos, procs); break; case scheme_set_bang_type: no_flo(need_flonum, port);