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

update expander logging (#2968)

Browse Source 
This simplifies the expander logging in some places and adds logging for arming/disarming and scope changes (eg syntax-local-introduce) so the macro stepper can better track term identity.

This relies on corresponding changes to the racket/macro-debugger repo.
This commit is contained in:
Ryan Culpepper 2019-12-14 01:27:24 +01:00 committed by GitHub
parent bcd8de5c9a
commit 6380df8aca
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
18 changed files with 10747 additions and 10819 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "7.5.0.11")
(define version "7.5.0.12")
(define deps `("racket-lib"
["racket" #:version ,version]))

15069
pkgs/racket-test-core/tests/racket/expobs-regression.rktd
View File

File diff suppressed because it is too large Load Diff

6
racket/src/expander/boot/expobs-primitive.rkt
View File

@ -1,7 +1,9 @@
#lang racket/base
(require "../expand/context.rkt")
(require "../expand/context.rkt"
"../expand/syntax-local.rkt")
(provide expobs-primitives)
(define expobs-primitives
(hasheq 'current-expand-observe current-expand-observe))
(hasheq 'current-expand-observe current-expand-observe
'syntax-local-expand-observer syntax-local-expand-observer))

45
racket/src/expander/eval/main.rkt
View File

@ -163,27 +163,13 @@
(expand-single form ns observer to-parsed?
#:serializable? serializable?)))]
[else
(log-top-lift-begin-before ctx require-lifts lifts exp-s ns)
(define new-s
(wrap-lifts-as-begin (append require-lifts lifts)
#:adjust-form (lambda (form)
(log-expand ctx 'next)
(expand-single form ns observer to-parsed?
#:serializable? serializable?))
#:adjust-body (lambda (form)
(cond
[to-parsed? form]
[else
(log-expand ctx 'next)
;; This re-expansion should be unnecessary, but we do it
;; for a kind of consistentcy with `expand/capture-lifts`
;; and for expansion observers
(expand-single form ns observer to-parsed?
#:serializable? serializable?)]))
exp-s
(namespace-phase ns)))
(log-top-begin-after ctx new-s)
new-s]))
(log-expand ctx 'lift-loop new-s)
(expand-single new-s ns observer to-parsed?
#:serializable? serializable?)]))
(define (expand-once s [ns (current-namespace)])
(per-top-level s ns
@ -262,7 +248,7 @@
[else
(case (core-form-sym disarmed-exp-s phase)
[(begin)
(log-expand ctx 'prim-begin)
(log-expand ctx 'prim-begin disarmed-exp-s)
(define-match m disarmed-exp-s '(begin e ...))
;; Map `loop` over the `e`s, but in the case of `eval`,
;; tail-call for last one:
@ -289,7 +275,7 @@
new-s]
[else (begin-loop (m 'e))])]
[(begin-for-syntax)
(log-expand tl-ctx 'prim-begin-for-syntax)
(log-expand tl-ctx 'prim-begin-for-syntax disarmed-exp-s)
(define-match m disarmed-exp-s '(begin-for-syntax e ...))
(define next-phase (add1 phase))
(define next-ns (namespace->namespace-at-phase ns next-phase))
@ -389,25 +375,12 @@
(define new-s (wrap-lifts-as-begin (append require-lifts lifts)
exp-s
(namespace-phase ns)))
(...log-expand obs ['lift-loop new-s])
(log-top-begin-before ctx new-s))))
(define-match m new-s '(begin e ...))
(...log-expand obs ['enter-lift-loop new-s]))))
(define (log-top-begin-before ctx new-s)
(define (log-top-lift-begin-after ctx new-s)
(log-expand...
ctx
(lambda (obs)
(define-match m new-s '(begin e ...))
(...log-expand obs
['visit new-s] ['resolve (m 'begin)]
['enter-prim new-s] ['prim-begin]
['enter-list (datum->syntax #f (m 'e) new-s)]))))
(define (log-top-begin-after ctx new-s)
(log-expand...
ctx
(lambda (obs)
(define-match m new-s '(begin e ...))
(log-expand* ctx
['exit-list (datum->syntax #f (m 'e) new-s)]
['exit-prim new-s]
['return new-s]))))
['end-lift-loop new-s]))))

84
racket/src/expander/expand/body.rkt
View File

@ -29,7 +29,7 @@
(define (expand-body bodys ctx
#:source s
#:stratified? [stratified? #f])
(log-expand ctx 'enter-block (datum->syntax #f bodys))
(log-expand ctx 'enter-block bodys)
;; In principle, we have an outside-edge scope that identifies the
;; original content of the definition context --- but a body always
;; exists inside some binding form, so that form's scope will do;
@ -39,7 +39,7 @@
(define init-bodys
(for/list ([body (in-list bodys)])
(add-scope body inside-sc)))
(log-expand ctx 'block-renames (datum->syntax #f init-bodys) (datum->syntax #f bodys))
(log-expand ctx 'block-renames init-bodys bodys)
(define phase (expand-context-phase ctx))
(define frame-id (make-reference-record)) ; accumulates info on referenced variables
(define def-ctx-scopes (box null))
@ -105,7 +105,7 @@
(case (core-form-sym disarmed-exp-body phase)
[(begin)
;; Splice a `begin` form
(log-expand body-ctx 'prim-begin)
(log-expand body-ctx 'prim-begin disarmed-exp-body)
(define-match m disarmed-exp-body '(begin e ...))
(define (track e) (syntax-track-origin e exp-body))
(define splice-bodys (append (map track (m 'e)) rest-bodys))
@ -125,10 +125,10 @@
[(define-values)
;; Found a variable definition; add bindings, extend the
;; environment, and continue
(log-expand body-ctx 'prim-define-values)
(log-expand body-ctx 'prim-define-values disarmed-exp-body)
(define-match m disarmed-exp-body '(define-values (id ...) rhs))
(define ids (remove-use-site-scopes (m 'id) body-ctx))
(log-expand body-ctx 'rename-one (datum->syntax #f (list ids (m 'rhs))))
(log-expand body-ctx 'rename-one (list ids (m 'rhs)))
(define new-dups (check-no-duplicate-ids ids phase exp-body dups))
(define counter (root-expand-context-counter ctx))
(define local-sym (and (expand-context-normalize-locals? ctx) 'loc))
@ -175,10 +175,10 @@
;; Found a macro definition; add bindings, evaluate the
;; compile-time right-hand side, install the compile-time
;; values in the environment, and continue
(log-expand body-ctx 'prim-define-syntaxes)
(log-expand body-ctx 'prim-define-syntaxes disarmed-exp-body)
(define-match m disarmed-exp-body '(define-syntaxes (id ...) rhs))
(define ids (remove-use-site-scopes (m 'id) body-ctx))
(log-expand body-ctx 'rename-one (datum->syntax #f (list ids (m 'rhs))))
(log-expand body-ctx 'rename-one (list ids (m 'rhs)))
(define new-dups (check-no-duplicate-ids ids phase exp-body dups))
(define counter (root-expand-context-counter ctx))
(define local-sym (and (expand-context-normalize-locals? ctx) 'mac))
@ -276,10 +276,8 @@
[post-expansion #:parent root-expand-context #f]))
;; Helper to expand and wrap the ending expressions in `begin`, if needed:
(define (finish-bodys)
(define block->list? (null? val-idss))
(unless block->list? (log-expand body-ctx 'next-group)) ; to go with 'block->letrec
(define last-i (sub1 (length done-bodys)))
(log-expand body-ctx 'enter-list (datum->syntax #f done-bodys))
(log-expand body-ctx 'enter-list done-bodys)
(define exp-bodys
(for/list ([done-body (in-list done-bodys)]
[i (in-naturals)])
@ -288,20 +286,17 @@
(struct*-copy expand-context finish-ctx
[name name])
finish-ctx))))
(log-expand body-ctx 'exit-list (datum->syntax #f exp-bodys))
(log-expand body-ctx 'exit-list exp-bodys)
(reference-record-clear! frame-id)
exp-bodys)
(cond
[(and (null? val-idss)
(null? disappeared-transformer-bindings))
;; No definitions, so just return the body list
(log-expand finish-ctx 'block->list (datum->syntax s done-bodys))
(log-expand finish-ctx 'block->list)
(finish-bodys)]
[else
(log-expand... finish-ctx (lambda (obs)
;; Simulate old expansion steps
(log-letrec-values obs finish-ctx s val-idss val-rhss track-stxs
stx-clauses done-bodys)))
(log-expand finish-ctx 'block->letrec val-idss val-rhss done-bodys)
;; Roughly, finish expanding the right-hand sides, finish the body
;; expression, then add a `letrec-values` wrapper:
(define exp-s (expand-and-split-bindings-by-reference
@ -310,15 +305,17 @@
#:frame-id frame-id #:ctx finish-ctx
#:source s #:had-stxes? (pair? stx-clauses)
#:get-body finish-bodys #:track? #f))
(log-expand* body-ctx ['exit-prim exp-s] ['return exp-s])
(if (expand-context-to-parsed? body-ctx)
(list exp-s)
(let ([exp-s (attach-disappeared-transformer-bindings
exp-s
disappeared-transformer-bindings)])
(list (for/fold ([exp-s exp-s]) ([form (in-list disappeared-transformer-forms)]
#:when form)
(syntax-track-origin exp-s form)))))]))
(let ([tracked-exp-s
(for/fold ([exp-s exp-s]) ([form (in-list disappeared-transformer-forms)]
#:when form)
(syntax-track-origin exp-s form))])
(log-expand finish-ctx 'finish-block (list tracked-exp-s))
(list tracked-exp-s))))]))
;; Roughly, create a `letrec-values` for for the given ids, right-hand sides, and
;; body. While expanding right-hand sides, though, keep track of whether any
@ -334,7 +331,7 @@
(define phase (expand-context-phase ctx))
(let loop ([idss idss] [keyss keyss] [rhss rhss] [track-stxs track-stxs]
[accum-idss null] [accum-keyss null] [accum-rhss null] [accum-track-stxs null]
[track? track?] [get-list? #f] [can-log? #t])
[track? track?] [get-list? #f])
(cond
[(null? idss)
(cond
@ -359,7 +356,6 @@
(core-id 'letrec-values phase))
,(build-clauses accum-idss accum-rhss accum-track-stxs)
,@exp-body))))
(log-expand* ctx #:when (and can-log? (log-tag? had-stxes? ctx)) ['tag result-s])
(if get-list? (list result-s) result-s)])]
[else
(log-expand ctx 'next)
@ -377,7 +373,7 @@
(unless (null? accum-idss) (error "internal error: accumulated ids not empty"))
(define exp-rest (loop (cdr idss) (cdr keyss) (cdr rhss) (cdr track-stxs)
null null null null
#f #t #f))
#f #t))
(define result-s
(if (expand-context-to-parsed? ctx)
(parsed-let-values (keep-properties-only s)
@ -390,13 +386,12 @@
`(,(core-id 'let-values phase)
(,(build-clause ids expanded-rhs track-stx))
,@exp-rest))))
(log-expand* ctx #:when (and can-log? (log-tag? had-stxes? ctx)) ['tag result-s])
(if get-list? (list result-s) result-s)]
[(and (not forward-references?)
(or split? (null? (cdr idss))))
(define exp-rest (loop (cdr idss) (cdr keyss) (cdr rhss) (cdr track-stxs)
null null null null
#f #t #f))
#f #t))
(define result-s
(if (expand-context-to-parsed? ctx)
(parsed-letrec-values (keep-properties-only s)
@ -413,13 +408,12 @@
(cons expanded-rhs accum-rhss)
(cons track-stx accum-track-stxs))
,@exp-rest))))
(log-expand* ctx #:when (and can-log? (log-tag? had-stxes? ctx)) ['tag result-s])
(if get-list? (list result-s) result-s)]
[else
(loop (cdr idss) (cdr keyss) (cdr rhss) (cdr track-stxs)
(cons ids accum-idss) (cons (car keyss) accum-keyss)
(cons expanded-rhs accum-rhss) (cons track-stx accum-track-stxs)
track? get-list? can-log?)])])))
track? get-list?)])])))
(define (build-clauses accum-idss accum-rhss accum-track-stxs)
(map build-clause
@ -446,39 +440,3 @@
(define (log-tag? had-stxes? ctx)
(and had-stxes?
(not (expand-context-only-immediate? ctx))))
;; Generate observer actions that simulate the old expander
;; going back through `letrec-values`:
(define (log-letrec-values obs ctx s val-idss val-rhss track-stxs
stx-clauses done-bodys)
(define phase (expand-context-phase ctx))
(define clauses (for/list ([val-ids (in-list val-idss)]
[val-rhs (in-list val-rhss)]
[track-stx (in-list track-stxs)])
(datum->syntax #f `[,val-ids ,val-rhs] track-stx)))
(define had-stxes? (not (null? stx-clauses)))
(define lv-id (core-id (if had-stxes? 'letrec-syntaxes+values 'letrec-values) phase))
(define lv-s (datum->syntax #f (if had-stxes?
`(,lv-id ,stx-clauses ,clauses ,@done-bodys)
`(,lv-id ,clauses ,@done-bodys))
s))
(...log-expand obs
['block->letrec (list lv-s)]
['visit lv-s]
['resolve lv-id]
['enter-prim lv-s])
(cond
[had-stxes?
(...log-expand obs
['prim-letrec-syntaxes+values]
['letrec-syntaxes-renames stx-clauses clauses (datum->syntax #f done-bodys s)]
['prepare-env]
['next-group])
(unless (null? val-idss)
(...log-expand obs
['prim-letrec-values]
['let-renames clauses (datum->syntax #f done-bodys s)]))]
[else
(...log-expand obs
['prim-letrec-values]
['let-renames clauses (datum->syntax #f done-bodys s)])]))

6
racket/src/expander/expand/context.rkt
View File

@ -18,6 +18,7 @@
copy-root-expand-context
current-expand-context
get-current-expand-context
without-expand-context
current-expand-observe
@ -145,6 +146,11 @@
#f
(raise-arguments-error who "not currently expanding"))))
(define-syntax-rule (without-expand-context body ...)
(parameterize-like
#:with ([current-expand-context #f])
body ...))
;; ----------------------------------------
;; For macro debugging. This parameter is only used by the expander

24
racket/src/expander/expand/definition-context.rkt
View File

@ -132,16 +132,20 @@
(raise-argument-error 'internal-definition-context-introduce "internal-definition-context?" intdef))
(unless (syntax? s)
(raise-argument-error 'internal-definition-context-introduce "syntax?" s))
(add-intdef-scopes s intdef
#:always? #t
#:action (case mode
[(add) add-scope]
[(remove) remove-scope]
[(flip) flip-scope]
[else (raise-argument-error
'internal-definition-context-introduce
"(or/c 'add 'remove 'flip)"
mode)])))
(define new-s
(add-intdef-scopes s intdef
#:always? #t
#:action (case mode
[(add) add-scope]
[(remove) remove-scope]
[(flip) flip-scope]
[else (raise-argument-error
'internal-definition-context-introduce
"(or/c 'add 'remove 'flip)"
mode)])))
(define ctx (get-current-expand-context #:fail-ok? #t))
(when ctx (log-expand ctx 'track-syntax 'internal-definition-context-introduce new-s s))
new-s)
;; internal-definition-context-seal
(define (internal-definition-context-seal intdef)

102
racket/src/expander/expand/expr.rkt
View File

@ -31,7 +31,7 @@
;; ----------------------------------------
;; Common expansion for `lambda` and `case-lambda`
(define (lambda-clause-expander s disarmed-s formals bodys ctx log-renames-tag)
(define (lambda-clause-expander s disarmed-s formals bodys ctx)
(define sc (new-scope 'local))
(define phase (expand-context-phase ctx))
;; Parse and check formal arguments:
@ -48,7 +48,7 @@
(env-extend env key (local-variable id))))
(define sc-formals (add-scope formals sc))
(define sc-bodys (for/list ([body (in-list bodys)]) (add-scope body sc)))
(log-expand ctx log-renames-tag sc-formals (datum->syntax #f sc-bodys))
(log-expand ctx 'lambda-renames sc-formals sc-bodys)
;; Expand the function body:
(define body-ctx (struct*-copy expand-context ctx
[env body-env]
@ -65,12 +65,12 @@
(add-core-form!
'lambda
(lambda (s ctx)
(log-expand ctx 'prim-lambda)
(define disarmed-s (syntax-disarm s))
(log-expand ctx 'prim-lambda disarmed-s)
(define-match m disarmed-s '(lambda formals body ...+))
(define rebuild-s (keep-as-needed ctx s #:keep-for-parsed? #t))
(define-values (formals body)
(lambda-clause-expander s disarmed-s (m 'formals) (m 'body) ctx 'lambda-renames))
(lambda-clause-expander s disarmed-s (m 'formals) (m 'body) ctx))
(if (expand-context-to-parsed? ctx)
(parsed-lambda rebuild-s formals body)
(rebuild
@ -101,8 +101,8 @@
(add-core-form!
'case-lambda
(lambda (s ctx)
(log-expand ctx 'prim-case-lambda)
(define disarmed-s (syntax-disarm s))
(log-expand ctx 'prim-case-lambda disarmed-s)
(define-match m disarmed-s '(case-lambda [formals body ...+] ...))
(define-match cm disarmed-s '(case-lambda clause ...))
(define rebuild-s (keep-as-needed ctx s #:keep-for-parsed? #t))
@ -113,7 +113,7 @@
(log-expand ctx 'next)
(define rebuild-clause (keep-as-needed ctx clause))
(define-values (exp-formals exp-body)
(lambda-clause-expander s disarmed-s formals body ctx 'lambda-renames))
(lambda-clause-expander s disarmed-s formals body ctx))
(if (expand-context-to-parsed? ctx)
(list exp-formals exp-body)
(rebuild rebuild-clause `[,exp-formals ,@exp-body]))))
@ -159,11 +159,10 @@
(define (make-let-values-form #:log-tag log-tag
#:syntaxes? [syntaxes? #f]
#:rec? [rec? #f]
#:split-by-reference? [split-by-reference? #f]
#:renames-log-tag [renames-log-tag 'let-renames])
#:split-by-reference? [split-by-reference? #f])
(lambda (s ctx)
(log-expand ctx log-tag)
(define disarmed-s (syntax-disarm s))
(log-expand ctx log-tag disarmed-s)
(define-match stx-m disarmed-s #:when syntaxes?
'(letrec-syntaxes+values
([(id:trans ...) trans-rhs] ...)
@ -181,6 +180,10 @@
(define trans-idss (for/list ([ids (in-list (if syntaxes? (stx-m 'id:trans) null))])
(for/list ([id (in-list ids)])
(add-scope id sc))))
(define trans-rhss (if syntaxes? ; implies rec?
(for/list ([rhs (in-list (stx-m 'trans-rhs))])
(add-scope rhs sc))
'()))
(define val-idss (for/list ([ids (in-list (if syntaxes? (stx-m 'id:val) (val-m 'id:val)))])
(for/list ([id (in-list ids)])
(add-scope id sc))))
@ -217,18 +220,16 @@
(if rec?
(add-scope new-body body-sc)
new-body)))
(log-expand... ctx (lambda (obs)
(log-let-renames obs renames-log-tag val-idss val-rhss bodys
trans-idss (and syntaxes? (stx-m 'trans-rhs)) sc)))
(log-expand ctx 'letX-renames trans-idss trans-rhss val-idss val-rhss bodys)
;; Evaluate compile-time expressions (if any):
(when syntaxes?
(log-expand ctx 'prepare-env)
(prepare-next-phase-namespace ctx))
(define trans-valss (for/list ([rhs (in-list (if syntaxes? (stx-m 'trans-rhs) '()))]
(define trans-valss (for/list ([rhs (in-list trans-rhss)]
[ids (in-list trans-idss)])
(log-expand* ctx ['next] ['enter-bind])
(define trans-val (eval-for-syntaxes-binding 'letrec-syntaxes+values
(add-scope rhs sc) ids ctx))
rhs ids ctx))
(log-expand ctx 'exit-bind)
trans-val))
;; Fill expansion-time environment:
@ -247,6 +248,8 @@
[id (in-list ids)])
(maybe-install-free=id-in-context! val id phase ctx)
(env-extend env key val))))
(when syntaxes?
(log-expand ctx 'next-group))
;; Expand right-hand sides and body
(define expr-ctx (as-expression-context ctx))
(define orig-rrs (expand-context-reference-records expr-ctx))
@ -276,11 +279,7 @@
(datum->syntax #f (syntax-e val-id) val-id val-id)))
val-idss))
(when syntaxes?
(log-expand... ctx (lambda (obs) (log-letrec-values obs val-idss val-rhss bodys))))
(define (get-body)
(log-expand* ctx #:unless (and syntaxes? (null? val-idss)) ['next-group])
(define body-ctx (struct*-copy expand-context rec-ctx
[reference-records orig-rrs]))
(expand-body bodys (as-tail-context body-ctx #:wrt ctx) #:source rebuild-s))
@ -322,27 +321,6 @@
result-s
(attach-disappeared-transformer-bindings result-s trans-idss))))
(define (log-let-renames obs renames-log-tag val-idss val-rhss bodys
trans-idss trans-rhss sc)
(define vals+body (cons (for/list ([val-ids (in-list val-idss)]
[val-rhs (in-list val-rhss)])
(datum->syntax #f `[,val-ids ,val-rhs]))
(datum->syntax #f bodys)))
(...log-expand obs [renames-log-tag (if (not trans-rhss)
vals+body
(cons
(for/list ([trans-ids (in-list trans-idss)]
[trans-rhs (in-list trans-rhss)])
(datum->syntax #f `[,trans-ids ,(add-scope trans-rhs sc)]))
vals+body))]))
(define (log-letrec-values obs val-idss val-rhss bodys)
(...log-expand obs ['next-group])
(unless (null? val-idss)
(...log-expand obs ['prim-letrec-values])
(log-let-renames obs 'let-renames val-idss val-rhss bodys
#f #f #f)))
(add-core-form!
'let-values
(make-let-values-form #:log-tag 'prim-let-values))
@ -354,16 +332,15 @@
(add-core-form!
'letrec-syntaxes+values
(make-let-values-form #:syntaxes? #t #:rec? #t #:split-by-reference? #t
#:log-tag 'prim-letrec-syntaxes+values
#:renames-log-tag 'letrec-syntaxes-renames))
#:log-tag 'prim-letrec-syntaxes+values))
;; ----------------------------------------
(add-core-form!
'#%stratified-body
(lambda (s ctx)
(log-expand ctx 'prim-#%stratified)
(define disarmed-s (syntax-disarm s))
(log-expand ctx 'prim-#%stratified disarmed-s)
(define-match m disarmed-s '(#%stratified-body body ...+))
(define rebuild-s (keep-as-needed ctx s #:keep-for-error? #t))
(define exp-body (expand-body (m 'body) ctx #:stratified? #t #:source rebuild-s))
@ -381,8 +358,8 @@
(add-core-form!
'#%datum
(lambda (s ctx)
(log-expand ctx 'prim-#%datum)
(define disarmed-s (syntax-disarm s))
(log-expand ctx 'prim-#%datum disarmed-s)
(define-match m disarmed-s '(#%datum . datum))
(define datum (m 'datum))
(when (and (syntax? datum)
@ -401,8 +378,8 @@
(add-core-form!
'#%app
(lambda (s ctx)
(log-expand ctx 'prim-#%app)
(define disarmed-s (syntax-disarm s))
(log-expand ctx 'prim-#%app disarmed-s)
(define-match m disarmed-s '(#%app e ...))
(define es (m 'e))
(cond
@ -421,7 +398,7 @@
(define rebuild-prefixless (and (syntax? prefixless)
(keep-as-needed ctx prefixless #:keep-for-parsed? keep-for-parsed?)))
(define expr-ctx (as-expression-context ctx))
(log-expand* expr-ctx ['enter-list (datum->syntax #f es s)] ['next])
(log-expand expr-ctx 'next)
(define rest-es (cdr es))
(define exp-rator (expand (car es) expr-ctx))
(define exp-es (for/list ([e (in-list rest-es)])
@ -435,14 +412,13 @@
(if rebuild-prefixless
(rebuild rebuild-prefixless exp-es)
exp-es)))
(log-expand expr-ctx 'exit-list (datum->syntax #f es rebuild-s))
(rebuild rebuild-s (cons (m '#%app) es))])])))
(add-core-form!
'quote
(lambda (s ctx)
(log-expand ctx 'prim-quote)
(log-expand ctx 'prim-quote #f)
(define-match m (syntax-disarm s) '(quote datum))
(if (expand-context-to-parsed? ctx)
(parsed-quote (keep-properties-only~ s) (syntax->datum (m 'datum)))
@ -451,8 +427,8 @@
(add-core-form!
'quote-syntax
(lambda (s ctx)
(log-expand ctx 'prim-quote-syntax)
(define disarmed-s (syntax-disarm s))
(log-expand ctx 'prim-quote-syntax disarmed-s)
(define-match m-local disarmed-s #:try '(quote-syntax datum #:local))
(define-match m disarmed-s #:unless (m-local) '(quote-syntax datum))
(cond
@ -482,8 +458,8 @@
(add-core-form!
'if
(lambda (s ctx)
(log-expand ctx 'prim-if)
(define disarmed-s (syntax-disarm s))
(log-expand ctx 'prim-if disarmed-s)
(define-match bad-m disarmed-s #:try '(_ _ _))
(when (bad-m) (raise-syntax-error #f "missing an \"else\" expression" s))
(define-match m disarmed-s '(if tst thn els))
@ -504,8 +480,8 @@
(add-core-form!
'with-continuation-mark
(lambda (s ctx)
(log-expand ctx 'prim-with-continuation-mark)
(define disarmed-s (syntax-disarm s))
(log-expand ctx 'prim-with-continuation-mark disarmed-s)
(define-match m disarmed-s '(with-continuation-mark key val body))
(define expr-ctx (as-expression-context ctx))
(define rebuild-s (keep-as-needed ctx s))
@ -521,24 +497,17 @@
(list (m 'with-continuation-mark) exp-key exp-val exp-body)))))
(define (make-begin log-tag parsed-begin
#:list-start-index list-start-index
#:last-is-tail? last-is-tail?)
(lambda (s ctx)
(log-expand ctx log-tag)
(define disarmed-s (syntax-disarm s))
(log-expand ctx log-tag disarmed-s)
(define-match m disarmed-s '(begin e ...+))
(define expr-ctx (if last-is-tail?
(as-begin-expression-context ctx)
(as-expression-context ctx)))
(define rebuild-s (keep-as-needed ctx s))
(define exp-es
(let loop ([es (m 'e)] [index list-start-index])
(when (zero? index)
(log-expand... ctx
(lambda (obs)
(unless (zero? list-start-index)
(...log-expand obs ['next]))
(...log-expand obs ['enter-list (datum->syntax #f es rebuild-s)]))))
(let loop ([es (m 'e)])
(cond
[(null? es) null]
[else
@ -547,8 +516,7 @@
(cons (expand (car es) (if (and last-is-tail? (null? rest-es))
(as-tail-context expr-ctx #:wrt ctx)
expr-ctx))
(loop rest-es (sub1 index)))])))
(log-expand ctx 'exit-list (datum->syntax #f (list-tail exp-es list-start-index) rebuild-s))
(loop rest-es))])))
(if (expand-context-to-parsed? ctx)
(parsed-begin rebuild-s exp-es)
(rebuild
@ -557,7 +525,7 @@
(add-core-form!
'begin
(let ([nonempty-begin (make-begin 'prim-begin parsed-begin #:list-start-index 0 #:last-is-tail? #t)])
(let ([nonempty-begin (make-begin 'prim-begin parsed-begin #:last-is-tail? #t)])
(lambda (s ctx)
;; Empty `begin` allowed in 'top-level and 'module contexts,
;; which might get here via `local-expand`:
@ -574,7 +542,7 @@
(add-core-form!
'begin0
(make-begin 'prim-begin0 parsed-begin0 #:list-start-index 1 #:last-is-tail? #f))
(make-begin 'prim-begin0 parsed-begin0 #:last-is-tail? #f))
(define (register-eventual-variable!? id ctx)
(cond
@ -592,8 +560,8 @@
(add-core-form!
'#%top
(lambda (s ctx [implicit-omitted? #f])
(log-expand ctx 'prim-#%top)
(define disarmed-s (syntax-disarm s))
(log-expand ctx 'prim-#%top disarmed-s)
(define id (cond
[implicit-omitted?
;; As a special favor to `local-expand`, the expander
@ -653,8 +621,8 @@
(add-core-form!
'set!
(lambda (s ctx)
(log-expand ctx 'prim-set!)
(define disarmed-s (syntax-disarm s))
(log-expand ctx 'prim-set! disarmed-s)
(define-match m disarmed-s '(set! id rhs))
(define orig-id (m 'id))
(let rename-loop ([id orig-id] [from-rename? #f])
@ -723,8 +691,8 @@
(add-core-form!
'#%variable-reference
(lambda (s ctx)
(log-expand ctx 'prim-#%variable-reference)
(define disarmed-s (syntax-disarm s))
(log-expand ctx 'prim-#%variable-reference disarmed-s)
(define-match id-m disarmed-s #:try '(#%variable-reference id))
(define-match top-m disarmed-s #:unless (id-m) #:try '(#%variable-reference (#%top . id)))
(define-match empty-m disarmed-s #:unless (or (id-m) (top-m)) '(#%variable-reference))
@ -762,8 +730,8 @@
(add-core-form!
'#%expression
(lambda (s ctx)
(log-expand ctx 'prim-#%expression)
(define disarmed-s (syntax-disarm s))
(log-expand ctx 'prim-#%expression disarmed-s)
(define-match m disarmed-s '(#%expression e))
(define rebuild-s (keep-as-needed ctx s #:for-track? #t))
(define exp-e (expand (m 'e) (as-tail-context (as-expression-context ctx)

46
racket/src/expander/expand/local-expand.rkt
View File

@ -110,7 +110,8 @@
(expand-context-keep-#%expression? ctx)))
#:track-to-be-defined? track-to-be-defined?))
(namespace-visit-available-modules! (expand-context-namespace ctx) phase)
(without-expand-context
(namespace-visit-available-modules! (expand-context-namespace ctx) phase))
(log-expand local-ctx 'enter-local s)
(define input-s (add-intdef-scopes (flip-introduction-scopes s ctx) intdefs))
@ -119,29 +120,30 @@
(log-expand local-ctx 'local-pre input-s)
(when stop-ids (log-expand local-ctx 'start))
(define output-s (cond
[(and as-transformer? capture-lifts?)
(expand-transformer input-s local-ctx
#:context context
#:expand-lifts? #f
#:begin-form? #t
#:lift-key lift-key
#:always-wrap? #t
#:keep-stops? #t)]
[as-transformer?
(expand-transformer input-s local-ctx
#:context context
#:expand-lifts? #f
#:begin-form? (eq? 'top-level context)
#:lift-key lift-key
#:keep-stops? #t)]
[capture-lifts?
(expand/capture-lifts input-s local-ctx
(define output-s (without-expand-context
(cond
[(and as-transformer? capture-lifts?)
(expand-transformer input-s local-ctx
#:context context
#:expand-lifts? #f
#:begin-form? #t
#:lift-key lift-key
#:always-wrap? #t)]
[else
(expand input-s local-ctx)]))
#:always-wrap? #t
#:keep-stops? #t)]
[as-transformer?
(expand-transformer input-s local-ctx
#:context context
#:expand-lifts? #f
#:begin-form? (eq? 'top-level context)
#:lift-key lift-key
#:keep-stops? #t)]
[capture-lifts?
(expand/capture-lifts input-s local-ctx
#:begin-form? #t
#:lift-key lift-key
#:always-wrap? #t)]
[else
(expand input-s local-ctx)])))
(log-expand local-ctx 'local-post output-s)

110
racket/src/expander/expand/log.rkt
View File

@ -44,6 +44,25 @@
[(null? args) #f]
[else (apply list* args)])))
;; Expansion logging is interpreted by the macro stepper: see
;;
;; (lib macro-debugger/model/deriv-{tokens,parser})
;;
;; In particular, deriv-tokens.rkt describes the payloads carried by each of the
;; events listed below, and deriv-parser.rkt describes the grammar of events and
;; how it corresponds to the procedures in the expander implementation.
;; Here are a few non-obvious considerations for the logging design:
;;
;; - 'prim-X events should occur before error checking (including define-match)
;; - payloads should contain no artificial syntax objects (that is, they should
;; only contain syntax objects from the input or that will be the basis for
;; results (possibly adjusted by scopes, etc))
;; - arming and disarming should be reported separately from rewrites, so that
;; the macro stepper can track the identity of terms (it's complicated---some
;; adjustments can be collapsed, as long as the intermediate syntax objects
;; are not externally visible)
(define key->arity
;; event-symbol => (U Nat 'any)
#hash(;; basic empty tokens
@ -56,34 +75,39 @@
(exit-bind . 0)
(exit-local-bind . 0)
(prepare-env . 0)
(enter-begin-for-syntax . 0)
(exit-begin-for-syntax . 0)
;; basic tokens
(visit . 1)
(resolve . 1)
(enter-macro . 1)
(enter-macro . 2)
(macro-pre-x . 1)
(macro-post-x . 2)
(exit-macro . 1)
(exit-macro . 2)
(enter-prim . 1)
(exit-prim . 1)
(return . 1)
(stop/return . 1)
(exit-prim/return . 1)
(enter-block . 1)
(block->list . 1)
(block->letrec . 1)
(block->list . 0)
(block->letrec . 3)
(finish-block . 1)
(splice . 1)
(enter-list . 1)
(exit-list . 1)
(enter-check . 1)
(exit-check . 1)
(module-body . 1)
(lift-loop . 1)
(letlift-loop . 1)
(module-lift-loop . 1)
(module-lift-end-loop . 1)
(lift-expr . 2)
(lift-statement . 1)
(lift-expr . 3)
(lift-end-decl . 3)
(lift-require . 3)
(lift-provide . 1)
(lift-module . 2)
(enter-local . 1)
(local-pre . 1)
(local-post . 1)
@ -92,44 +116,52 @@
(opaque-expr . 1)
(variable . 2)
(tag . 1)
(tag2 . 2)
(tag/context . 1)
(rename-one . 1)
(rename-list . 1)
(track-origin . 2)
(track-syntax . 3)
(local-value . 1)
(local-value-result . 1)
(rename-transformer . 1)
(module-end-lifts . 1)
(module-pass1-lifts . 3)
(module-pass2-lifts . 3)
(module-pass1-case . 1)
(exit-case . 1)
;; renames tokens **
(lambda-renames . 2)
(let-renames . any) ;; renames consed by expander... sometimes
(letrec-syntaxes-renames . any) ;; renames consed by expander... sometimes
(letX-renames . 5)
(block-renames . 2)
;; prim tokens
(prim-stop . 0)
(prim-module . 0)
(prim-module-begin . 0)
(prim-define-syntaxes . 0)
(prim-define-values . 0)
(prim-if . 0)
(prim-with-continuation-mark . 0)
(prim-begin . 0)
(prim-begin0 . 0)
(prim-#%app . 0)
(prim-lambda . 0)
(prim-case-lambda . 0)
(prim-let-values . 0)
(prim-letrec-values . 0)
(prim-letrec-syntaxes+values . 0)
(prim-#%datum . 0)
(prim-#%top . 0)
(prim-quote . 0)
(prim-quote-syntax . 0)
(prim-require . 0)
(prim-provide . 0)
(prim-set! . 0)
(prim-#%expression . 0)
(prim-#%variable-reference . 0)
(prim-#%stratified . 0)
(prim-begin-for-syntax . 0)
(prim-submodule . 0)
(prim-submodule* . 0)))
(prim-stop . 1)
(prim-module . 1)
(prim-module-begin . 1)
(prim-define-syntaxes . 1)
(prim-define-values . 1)
(prim-if . 1)
(prim-with-continuation-mark . 1)
(prim-begin . 1)
(prim-begin0 . 1)
(prim-#%app . 1)
(prim-lambda . 1)
(prim-case-lambda . 1)
(prim-let-values . 1)
(prim-letrec-values . 1)
(prim-letrec-syntaxes+values . 1)
(prim-#%datum . 1)
(prim-#%top . 1)
(prim-quote . 1)
(prim-quote-syntax . 1)
(prim-require . 1)
(prim-provide . 1)
(prim-set! . 1)
(prim-#%expression . 1)
(prim-#%variable-reference . 1)
(prim-#%stratified . 1)
(prim-begin-for-syntax . 1)
(prim-declare . 1)
(prim-submodule . 1)
(prim-submodule* . 1)))

73
racket/src/expander/expand/main.rkt
View File

@ -67,13 +67,12 @@
;; Main expander dispatch
(define (expand s ctx
;; Aplying a rename transformer substitutes
;; Applying a rename transformer substitutes
;; an id without changing `s`
#:alternate-id [alternate-id #f]
#:skip-log? [skip-log? #f]
;; For expanding an implicit implemented by a rename transformer:
#:fail-non-transformer [fail-non-transformer #f])
(log-expand* ctx #:unless skip-log? [(if (expand-context-only-immediate? ctx) 'enter-check 'visit) s])
(log-expand ctx 'visit s)
(cond
[(syntax-identifier? s)
(expand-identifier s ctx alternate-id)]
@ -101,7 +100,7 @@
(define binding (resolve+shift id (expand-context-phase ctx)
#:ambiguous-value 'ambiguous
#:immediate? #t))
(log-expand* ctx #:unless (expand-context-only-immediate? ctx) ['resolve id])
(log-expand ctx 'resolve id)
(cond
[(eq? binding 'ambiguous)
(raise-ambiguous-error id ctx)]
@ -125,7 +124,7 @@
(define binding (resolve+shift id (expand-context-phase ctx)
#:ambiguous-value 'ambiguous
#:immediate? #t))
(log-expand* ctx #:unless (expand-context-only-immediate? ctx) ['resolve id])
(log-expand ctx 'resolve id)
(cond
[(eq? binding 'ambiguous)
(when fail-non-transformer (fail-non-transformer))
@ -157,17 +156,17 @@
(define (expand-implicit sym s ctx trigger-id)
(cond
[(expand-context-only-immediate? ctx)
(log-expand* ctx ['exit-check s])
(log-expand ctx 'stop/return s)
s]
[else
(define disarmed-s (syntax-disarm s))
(define id (datum->syntax disarmed-s sym))
(guard-stop
id ctx s
(log-expand* ctx ['resolve id])
(define b (resolve+shift id (expand-context-phase ctx)
#:ambiguous-value 'ambiguous
#:immediate? #t))
(log-expand ctx 'resolve id)
(cond
[(eq? b 'ambiguous)
(raise-ambiguous-error id ctx)]
@ -205,7 +204,9 @@
(if (and (expand-context-to-parsed? ctx)
(free-id-set-empty? (expand-context-stops ctx)))
(parsed-id tl-id tl-b #f)
tl-id)]
(begin
(log-expand* ctx ['variable tl-id] ['return tl-id])
tl-id))]
[else
(raise-syntax-implicit-error s sym trigger-id ctx)])])]))]))
@ -225,11 +226,12 @@
(and (not (parsed? exp-s)) exp-s)))
(cond
[(expand-context-only-immediate? ctx)
(log-expand ctx 'stop/return s)
s]
[(parsed? exp-s) exp-s]
[else
(define result-s (syntax-track-origin exp-s s))
(log-expand ctx 'opaque-expr result-s)
(log-expand ctx 'opaque-expr result-s) ;; FIXME: or exp-s?
(if (and (expand-context-to-parsed? ctx)
(free-id-set-empty? (expand-context-stops ctx)))
(expand result-s ctx) ; fully expanded to compiled
@ -237,7 +239,7 @@
(define (make-explicit ctx sym s disarmed-s)
(define new-s (syntax-rearm (datum->syntax disarmed-s (cons sym disarmed-s) s s) s))
(log-expand ctx 'tag new-s)
(log-expand ctx 'tag2 new-s disarmed-s)
new-s)
;; ----------------------------------------
@ -269,12 +271,12 @@
(define (dispatch-core-form t s ctx)
(cond
[(expand-context-only-immediate? ctx)
(log-expand* ctx ['exit-check s])
(log-expand ctx 'stop/return s)
s]
[(expand-context-observer ctx)
(log-expand ctx 'enter-prim s)
(define result-s ((core-form-expander t) s ctx))
(log-expand* ctx ['exit-prim (extract-syntax result-s)] ['return (extract-syntax result-s)])
(log-expand ctx 'exit-prim/return (extract-syntax result-s))
result-s]
[else
;; As previous case, but as a tail call:
@ -285,7 +287,7 @@
(define (dispatch-implicit-#%top-core-form t s ctx)
(log-expand ctx 'enter-prim s)
(define result-s ((core-form-expander t) s ctx #t))
(log-expand* ctx ['exit-prim result-s] ['return result-s])
(log-expand ctx 'exit-prim/return result-s)
result-s)
;; Call a macro expander, taking into account whether it works
@ -294,9 +296,8 @@
#:fail-non-transformer fail-non-transformer)
(cond
[(not-in-this-expand-context? t ctx)
(log-expand ctx 'enter-macro s)
(define adj-s (avoid-current-expand-context (substitute-alternate-id s id) t ctx))
(log-expand ctx 'exit-macro s)
(log-expand ctx 'tag/context adj-s)
(expand adj-s ctx)]
[(and (expand-context-should-not-encounter-macros? ctx)
;; It's ok to have a rename transformer whose target
@ -306,33 +307,28 @@
(raise-syntax-error #f
"encountered a macro binding in form that should be fully expanded"
s)]
[(rename-transformer? t)
(cond
[(expand-context-just-once? ctx) s]
[else
(define alt-id (apply-rename-transformer t id ctx))
(log-expand ctx 'rename-transformer alt-id)
(expand s ctx
#:alternate-id alt-id
#:fail-non-transformer fail-non-transformer)])]
[else
(log-expand* ctx #:when (and (expand-context-only-immediate? ctx)
(not (rename-transformer? t)))
;; The old expander would emit 'resolve for a rename transformer
;; as long as it's not the first one encountered in immediate mode
['visit s] ['resolve id])
;; Apply transformer and expand again
(define-values (exp-s re-ctx)
(if (rename-transformer? t)
(values s ctx)
(apply-transformer t insp-of-t s id ctx binding)))
(log-expand* ctx #:when (and (expand-context-only-immediate? ctx)
(not (rename-transformer? t)))
['return exp-s])
(apply-transformer t insp-of-t s id ctx binding))
(cond
[(expand-context-just-once? ctx) exp-s]
[else (expand exp-s re-ctx
#:alternate-id (and (rename-transformer? t) (apply-rename-transformer t id ctx))
#:skip-log? (or (expand-context-only-immediate? ctx)
(rename-transformer? t))
#:fail-non-transformer (and (rename-transformer? t) fail-non-transformer))])]))
[(expand-context-just-once? ctx) exp-s]
[else (expand exp-s re-ctx)])]))
;; Handle the expansion of a variable to itself
(define (dispatch-variable t s id ctx binding primitive? protected?)
(cond
[(expand-context-only-immediate? ctx)
(log-expand* ctx ['exit-check s])
(log-expand ctx 'stop/return id)
id]
[else
(log-expand ctx 'variable s id)
@ -366,8 +362,8 @@
(performance-region
['expand '_ 'macro]
(log-expand ctx 'enter-macro s)
(define disarmed-s (syntax-disarm s))
(log-expand ctx 'enter-macro disarmed-s s)
(define intro-scope (new-scope 'macro))
(define intro-s (flip-scope disarmed-s intro-scope))
;; In a definition context, we need use-site scopes
@ -393,7 +389,7 @@
;; Track expansion:
(define tracked-s (syntax-track-origin post-s cleaned-s (or origin-id (if (syntax-identifier? s) s (car (syntax-e s))))))
(define rearmed-s (taint-dispatch tracked-s (lambda (t-s) (syntax-rearm t-s s)) (expand-context-phase ctx)))
(log-expand ctx 'exit-macro rearmed-s)
(log-expand ctx 'exit-macro rearmed-s post-s)
(values rearmed-s
(accumulate-def-ctx-scopes ctx def-ctx-scopes))))
@ -510,8 +506,7 @@
(free-id-set-member? (expand-context-stops ctx)
(expand-context-phase ctx)
id))
(log-expand* ctx #:unless (expand-context-only-immediate? ctx)
['resolve id] ['enter-prim s] ['prim-stop] ['exit-prim s] ['return s])
(log-expand* ctx ['resolve id] ['stop/return s])
s]
[else
otherwise ...]))
@ -539,8 +534,8 @@
;; ----------------------------------------
;; Expand `s` as a compile-time expression relative to the current
;; expansion context
;; Expand `s` and capture lifted expressions, combining expanded term
;; and lifts using `begin` or `let` wrapper
(define (expand/capture-lifts s ctx
#:expand-lifts? [expand-lifts? #f]
#:begin-form? [begin-form? #f]

222
racket/src/expander/expand/module.rkt
View File

@ -46,7 +46,7 @@
'module
(lambda (s ctx)
(unless (eq? (expand-context-context ctx) 'top-level)
(log-expand ctx 'prim-module)
(log-expand ctx 'prim-module #f)
(raise-syntax-error #f "allowed only at the top level" s))
(performance-region
['expand 'module]
@ -55,13 +55,13 @@
(add-core-form!
'module*
(lambda (s ctx)
(log-expand ctx 'prim-module)
(log-expand ctx 'prim-module #f)
(raise-syntax-error #f "illegal use (not in a module top-level)" s)))
(add-core-form!
'#%module-begin
(lambda (s ctx)
(log-expand ctx 'prim-module-begin)
(log-expand ctx 'prim-module-begin #f)
(unless (eq? (expand-context-context ctx) 'module-begin)
(raise-syntax-error #f "not in a module-definition context" s))
(unless (expand-context-module-begin-k ctx)
@ -77,7 +77,7 @@
(add-core-form!
'#%declare
(lambda (s ctx)
(log-expand ctx 'prim-declare)
(log-expand ctx 'prim-declare #f)
;; The `#%module-begin` expander handles `#%declare`
(raise-syntax-error #f "not allowed outside of a module body" s)))
@ -91,8 +91,8 @@
#:mpis-for-enclosing-reset [mpis-for-enclosing-reset #f]
;; For cross-linklet inlining among submodules compiled together:
#:modules-being-compiled [modules-being-compiled (make-hasheq)])
(log-expand init-ctx 'prim-module)
(define disarmed-s (syntax-disarm s))
(log-expand init-ctx 'prim-module disarmed-s)
(define-match m disarmed-s '(module id:module-name initial-require body ...))
(define rebuild-s (keep-as-needed init-ctx s #:keep-for-parsed? #t #:keep-for-error? #t))
@ -211,6 +211,7 @@
keep-enclosing-scope-at-phase)]))
(log-expand init-ctx 'prepare-env)
(initial-require! #:bind? #t)
(log-expand init-ctx 'rename-one bodys)
;; To detect whether the body is expanded multiple times:
(define again? #f)
@ -260,11 +261,11 @@
;; that wasn't already introduced into the mdoule's inside scope,
;; add it to all the given body forms
(define added-s (add-scope mb-s inside-scope))
(log-expand ctx 'rename-one added-s)
(define disarmed-mb-s (syntax-disarm added-s))
(define-match mb-m disarmed-mb-s '(#%module-begin body ...))
(define bodys (mb-m 'body))
(log-expand ctx 'rename-one added-s)
(define rebuild-mb-s (keep-as-needed ctx mb-s))
@ -364,14 +365,16 @@
#:shared-module-ends module-ends
#:end-as-expressions? #t)]))
(finish-expanding-body-expressons partially-expanded-bodys
#:phase phase
#:ctx body-ctx
#:self self
#:declared-submodule-names declared-submodule-names
#:compiled-submodules compiled-submodules
#:modules-being-compiled modules-being-compiled
#:mpis-to-reset mpis-to-reset)))
(finish-expanding-body-expressions partially-expanded-bodys
#:phase phase
#:ctx body-ctx
#:self self
#:declared-submodule-names declared-submodule-names
#:compiled-submodules compiled-submodules
#:modules-being-compiled modules-being-compiled
#:mpis-to-reset mpis-to-reset)))
(log-expand ctx 'next-group)
;; Check that any tentatively allowed reference at phase >= 1 is ok
(check-defined-by-now need-eventually-defined self ctx requires+provides)
@ -402,7 +405,7 @@
;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;; Pass 4: expand `module*` submodules
(log-expand ctx 'next)
(log-expand ctx 'next-group)
;; Create a new namespace to avoid retaining the instance that
;; was needed to expand this module body:
@ -501,7 +504,8 @@
#:def-ctx-scopes mb-def-ctx-scopes
#:phase phase
#:s s))
(log-expand ctx 'next)
;; Expand the body
(define expanded-mb (performance-region
['expand 'module-begin]
@ -588,7 +592,6 @@
[(= 1 (length bodys))
;; Maybe it's already a `#%module-begin` form, or maybe it
;; will expand to one
(log-expand ctx 'rename-one (car bodys))
(cond
[(eq? '#%module-begin (core-form-sym (syntax-disarm (car bodys)) phase))
;; Done
@ -596,10 +599,12 @@
[else
;; A single body form might be a macro that expands to
;; the primitive `#%module-begin` form:
(define named-body-s (add-enclosing-name-property (car bodys) module-name-sym))
(log-expand ctx 'track-syntax 'property named-body-s (car bodys))
(define partly-expanded-body
(performance-region
['expand 'module-begin]
(expand (add-enclosing-name-property (car bodys) module-name-sym)
(expand named-body-s
(make-mb-ctx))))
(cond
[(eq? '#%module-begin (core-form-sym (syntax-disarm partly-expanded-body) phase))
@ -614,7 +619,9 @@
;; Multiple body forms definitely need a `#%module-begin` wrapper
(add-module-begin bodys s scopes-s phase module-name-sym
(make-mb-ctx))]))
(add-enclosing-name-property mb module-name-sym))
(define named-mb (add-enclosing-name-property mb module-name-sym))
(log-expand ctx 'track-syntax 'property named-mb mb)
named-mb)
;; Add `#%module-begin`, because it's needed
(define (add-module-begin bodys s scopes-s phase module-name-sym mb-ctx
@ -626,11 +633,11 @@
(raise-syntax-error #f "no #%module-begin binding in the module's language" s))
(define mb (datum->syntax disarmed-scopes-s `(,mb-id ,@bodys) s s))
(log-expand mb-ctx 'tag mb)
(when log-rename-one?
(log-expand mb-ctx 'rename-one mb))
(define named-mb (add-enclosing-name-property mb module-name-sym))
(log-expand mb-ctx 'track-syntax 'property named-mb mb)
(define partly-expanded-mb (performance-region
['expand 'module-begin]
(expand (add-enclosing-name-property mb module-name-sym)
(expand named-mb
mb-ctx)))
(unless (eq? '#%module-begin (core-form-sym (syntax-disarm partly-expanded-mb) phase))
(raise-syntax-error #f "expansion of #%module-begin is not a #%plain-module-begin form" s
@ -708,7 +715,6 @@
[(null? bodys)
(cond
[(and tail? (not (zero? phase)))
(log-expand partial-body-ctx 'module-lift-end-loop '())
null]
[tail?
;; Were at the very end of the module; if there are any lifted-to-end
@ -717,10 +723,12 @@
(append
(get-and-clear-end-lifts! (expand-context-to-module-lifts partial-body-ctx))
(get-and-clear-provide-lifts! (expand-context-to-module-lifts partial-body-ctx))))
(log-expand partial-body-ctx 'module-lift-end-loop bodys)
(cond
[(null? bodys) null]
[else (loop #t (add-post-expansion-scope bodys partial-body-ctx))])]
[else
(define added-bodys (add-post-expansion-scope bodys partial-body-ctx))
(log-expand partial-body-ctx 'module-end-lifts added-bodys)
(loop #t added-bodys)])]
[else null])]
[else
(define rest-bodys (cdr bodys))
@ -731,46 +739,53 @@
(expand (car bodys) partial-body-ctx)))
(define disarmed-exp-body (syntax-disarm exp-body))
(define lifted-defns (get-and-clear-lifts! (expand-context-lifts partial-body-ctx)))
(when (pair? lifted-defns)
(log-lifted-defns partial-body-ctx lifted-defns exp-body rest-bodys))
(log-expand partial-body-ctx 'rename-one exp-body)
(define lifted-reqs (get-and-clear-require-lifts! (expand-context-require-lifts partial-body-ctx)))
(define lifted-mods (get-and-clear-module-lifts! (expand-context-module-lifts partial-body-ctx)))
(define added-lifted-mods (add-post-expansion-scope lifted-mods partial-body-ctx))
(unless (and (null? lifted-defns) (null? lifted-reqs) (null? lifted-mods))
(log-expand partial-body-ctx 'module-pass1-lifts
(lifted-defns-extract-syntax lifted-defns)
lifted-reqs
added-lifted-mods))
(define exp-lifted-mods (loop #f added-lifted-mods))
(log-expand partial-body-ctx 'module-pass1-case exp-body)
(append/tail-on-null
;; Save any requires lifted during partial expansion
(get-and-clear-require-lifts! (expand-context-require-lifts partial-body-ctx))
lifted-reqs
;; Ditto for expressions
lifted-defns
;; Ditto for modules, which need to be processed
(loop #f (add-post-expansion-scope
(get-and-clear-module-lifts! (expand-context-module-lifts partial-body-ctx))
partial-body-ctx))
exp-lifted-mods
;; Dispatch on form revealed by partial expansion
(case (core-form-sym disarmed-exp-body phase)
[(begin)
(log-expand partial-body-ctx 'prim-begin disarmed-exp-body)
(define-match m disarmed-exp-body '(begin e ...))
(define (track e) (syntax-track-origin e exp-body))
(define spliced-bodys (append (map track (m 'e)) rest-bodys))
(log-expand partial-body-ctx 'splice spliced-bodys)
(loop tail? spliced-bodys)]
[(begin-for-syntax)
(log-expand* partial-body-ctx ['enter-prim exp-body] ['prim-begin-for-syntax] ['prepare-env])
(log-expand partial-body-ctx 'prim-begin-for-syntax disarmed-exp-body)
(define-match m disarmed-exp-body '(begin-for-syntax e ...))
(log-expand partial-body-ctx 'prepare-env)
(define ct-m-ns (namespace->namespace-at-phase m-ns (add1 phase)))
(prepare-next-phase-namespace partial-body-ctx)
(log-expand partial-body-ctx 'phase-up)
(define-match m disarmed-exp-body '(begin-for-syntax e ...))
(define nested-bodys (pass-1-and-2-loop (m 'e) (add1 phase) #f))
(log-expand partial-body-ctx 'next-group)
(namespace-run-available-modules! m-ns (add1 phase)) ; to support running `begin-for-syntax`
(eval-nested-bodys nested-bodys (add1 phase) ct-m-ns self partial-body-ctx)
(namespace-visit-available-modules! m-ns phase) ; since we're shifting back a phase
(log-expand partial-body-ctx 'exit-prim
(log-expand partial-body-ctx 'exit-case
(let ([s-nested-bodys (for/list ([nested-body (in-list nested-bodys)])
(extract-syntax nested-body))])
(datum->syntax #f (cons (m 'begin-for-syntax) s-nested-bodys) exp-body)))
(cons (m 'begin-for-syntax) s-nested-bodys)))
(cons
(semi-parsed-begin-for-syntax exp-body nested-bodys)
(loop tail? rest-bodys))]
[(define-values)
(log-expand* partial-body-ctx ['enter-prim exp-body] ['prim-define-values])
(log-expand partial-body-ctx 'prim-define-values disarmed-exp-body)
(define-match m disarmed-exp-body '(define-values (id ...) rhs))
(define ids (remove-use-site-scopes (m 'id) partial-body-ctx))
(check-no-duplicate-ids ids phase exp-body)
@ -784,16 +799,16 @@
;; In case `local-expand` created a binding with `sym` to a transformer
(namespace-unset-transformer! m-ns phase sym))
(add-defined-syms! requires+provides syms phase)
(log-expand partial-body-ctx 'exit-prim
(datum->syntax #f `(,(m 'define-values) ,ids ,(m 'rhs)) exp-body))
(log-expand partial-body-ctx 'exit-case `(,(m 'define-values) ,ids ,(m 'rhs)))
(cons
(semi-parsed-define-values exp-body syms ids (m 'rhs))
(loop tail? rest-bodys))]
[(define-syntaxes)
(log-expand* partial-body-ctx ['enter-prim exp-body] ['prim-define-syntaxes] ['prepare-env])
(log-expand partial-body-ctx 'prim-define-syntaxes disarmed-exp-body)
(define-match m disarmed-exp-body '(define-syntaxes (id ...) rhs))
(log-expand partial-body-ctx 'prepare-env)
(prepare-next-phase-namespace partial-body-ctx)
(log-expand partial-body-ctx 'phase-up)
(define-match m disarmed-exp-body '(define-syntaxes (id ...) rhs))
(define ids (remove-use-site-scopes (m 'id) partial-body-ctx))
(check-no-duplicate-ids ids phase exp-body)
(check-ids-unbound ids phase requires+provides #:in exp-body)
@ -821,7 +836,7 @@
[id (in-list ids)])
(maybe-install-free=id-in-context! val id phase partial-body-ctx)
(namespace-set-transformer! m-ns phase sym val))
(log-expand partial-body-ctx 'exit-prim (datum->syntax #f `(,(m 'define-syntaxes) ,ids ,exp-rhs)))
(log-expand partial-body-ctx 'exit-case `(,(m 'define-syntaxes) ,ids ,exp-rhs))
(define parsed-body (parsed-define-syntaxes (keep-properties-only exp-body) ids syms parsed-rhs))
(cons (if (expand-context-to-parsed? partial-body-ctx)
parsed-body
@ -832,7 +847,7 @@
parsed-body))
(loop tail? rest-bodys))]
[(#%require)
(log-expand* partial-body-ctx ['enter-prim exp-body] ['prim-require])
(log-expand partial-body-ctx 'prim-require disarmed-exp-body)
(define ready-body (remove-use-site-scopes disarmed-exp-body partial-body-ctx))
(define-match m ready-body '(#%require req ...))
(parse-and-perform-requires! (m 'req) exp-body #:self self
@ -840,15 +855,17 @@
requires+provides
#:declared-submodule-names declared-submodule-names
#:who 'module)
(log-expand partial-body-ctx 'exit-prim ready-body)
(log-expand partial-body-ctx 'exit-case ready-body)
(cons exp-body
(loop tail? rest-bodys))]
[(#%provide)
(log-expand partial-body-ctx 'prim-stop #f)
;; save for last pass
(cons exp-body
(loop tail? rest-bodys))]
[(module)
;; Submodule to parse immediately
(log-expand partial-body-ctx 'prim-submodule #f)
(define ready-body (remove-use-site-scopes exp-body partial-body-ctx))
(define submod
(expand-submodule ready-body self partial-body-ctx
@ -861,11 +878,11 @@
(loop tail? rest-bodys))]
[(module*)
;; Submodule to save for after this module
(log-expand* partial-body-ctx ['enter-prim exp-body] ['prim-submodule*]
['exit-prim exp-body])
(log-expand partial-body-ctx 'prim-stop #f)
(cons exp-body
(loop tail? rest-bodys))]
[(#%declare)
(log-expand partial-body-ctx 'prim-declare disarmed-exp-body)
(define-match m disarmed-exp-body '(#%declare kw ...))
(for ([kw (in-list (m 'kw))])
(unless (keyword? (syntax-e kw))
@ -882,6 +899,7 @@
(loop tail? rest-bodys))]
[else
;; save expression for next pass
(log-expand partial-body-ctx 'prim-stop #f)
(cons exp-body
(loop tail? rest-bodys))]))])))
@ -917,20 +935,19 @@
;; ----------------------------------------
;; Pass 2 of `module` expansion, which expands all expressions
(define (finish-expanding-body-expressons partially-expanded-bodys
#:phase phase
#:ctx body-ctx
#:self self
#:declared-submodule-names declared-submodule-names
#:compiled-submodules compiled-submodules
#:modules-being-compiled modules-being-compiled
#:mpis-to-reset mpis-to-reset)
(define (finish-expanding-body-expressions partially-expanded-bodys
#:phase phase
#:ctx body-ctx
#:self self
#:declared-submodule-names declared-submodule-names
#:compiled-submodules compiled-submodules
#:modules-being-compiled modules-being-compiled
#:mpis-to-reset mpis-to-reset)
(let loop ([tail? #t] [bodys partially-expanded-bodys])
(cond
[(null? bodys)
(cond
[(and tail? (not (zero? phase)))
(log-expand body-ctx 'module-lift-end-loop '())
null]
[tail?
;; We're at the very end of the module, again, so check for lifted-to-end
@ -941,9 +958,9 @@
(get-and-clear-provide-lifts! (expand-context-to-module-lifts body-ctx))))
(cond
[(null? bodys)
(log-expand body-ctx 'module-lift-end-loop '())
null]
[else
(log-expand body-ctx 'module-end-lifts bodys)
(loop #t (add-post-expansion-scope bodys body-ctx))])]
[else null])]
[else
@ -965,11 +982,11 @@
(define-match m (syntax-disarm s) #:unless (expand-context-to-parsed? rhs-ctx)
'(define-values _ _))
(define rebuild-s (keep-as-needed rhs-ctx s #:keep-for-parsed? #t))
(log-defn-enter body-ctx body)
(log-expand* body-ctx ['visit #f] ['enter-prim #f] ['prim-define-values #f])
(define exp-rhs (performance-region
['expand 'form-in-module/2]
(expand (semi-parsed-define-values-rhs body) rhs-ctx)))
(log-defn-exit body-ctx body exp-rhs)
(log-expand* body-ctx ['exit-prim/return #f])
(define comp-form
(parsed-define-values rebuild-s ids syms
(if (expand-context-to-parsed? rhs-ctx)
@ -1008,9 +1025,10 @@
(define lifted-modules (get-and-clear-module-lifts! (expand-context-module-lifts body-ctx)))
(define no-lifts? (and (null? lifted-defns) (null? lifted-modules) (null? lifted-requires)))
(unless no-lifts?
(log-expand body-ctx 'module-lift-loop (append lifted-requires
(lifted-defns-extract-syntax lifted-defns)
(add-post-expansion-scope lifted-modules body-ctx))))
(log-expand body-ctx 'module-pass2-lifts
lifted-requires
(add-post-expansion-scope lifted-modules body-ctx)
(lifted-defns-extract-syntax lifted-defns)))
(define exp-lifted-modules
;; If there were any module lifts, the `module` forms need to
;; be expanded
@ -1022,14 +1040,15 @@
#:declared-submodule-names declared-submodule-names
#:compiled-submodules compiled-submodules
#:modules-being-compiled modules-being-compiled))
(unless no-lifts? (log-expand body-ctx 'next-group))
(define exp-lifted-defns
;; If there were any lifts, the right-hand sides need to be expanded
(loop #f lifted-defns))
(unless no-lifts? (log-expand body-ctx 'next))
(unless no-lifts? (log-expand body-ctx 'next-group))
(append
lifted-requires
exp-lifted-defns
exp-lifted-modules
exp-lifted-defns
(cons exp-body
(loop tail? rest-bodys)))])))
@ -1075,10 +1094,13 @@
[(null? bodys) null]
[(or (parsed? (car bodys))
(expanded+parsed? (car bodys)))
(log-expand ctx 'next)
(cons (car bodys)
(loop (cdr bodys) phase))]
[(semi-parsed-begin-for-syntax? (car bodys))
(log-expand ctx 'enter-begin-for-syntax)
(define nested-bodys (loop (semi-parsed-begin-for-syntax-body (car bodys)) (add1 phase)))
(log-expand ctx 'exit-begin-for-syntax)
;; Stil semi-parsed; finished in pass 4
(cons (struct-copy semi-parsed-begin-for-syntax (car bodys)
[body nested-bodys])
@ -1087,7 +1109,7 @@
(define disarmed-body (syntax-disarm (car bodys)))
(case (core-form-sym disarmed-body phase)
[(#%provide)
(log-expand* ctx ['enter-prim (car bodys)] ['prim-provide])
(log-expand* ctx ['enter-prim (car bodys)] ['prim-provide disarmed-body])
(define-match m disarmed-body '(#%provide spec ...))
(define-values (track-stxes specs)
(parse-and-expand-provides! (m 'spec) (car bodys)
@ -1112,6 +1134,7 @@
(cons new-s
(loop (cdr bodys) phase))])]
[else
(log-expand ctx 'next)
(cons (car bodys)
(loop (cdr bodys) phase))])]))))
@ -1203,10 +1226,12 @@
(cond
[(semi-parsed-begin-for-syntax? body)
(define body-s (semi-parsed-begin-for-syntax-s body))
(log-expand submod-ctx 'enter-begin-for-syntax)
(define-match m (syntax-disarm body-s) '(begin-for-syntax _ ...))
(define rebuild-body-s (keep-as-needed submod-ctx body-s))
(define nested-bodys (loop (semi-parsed-begin-for-syntax-body body) (add1 phase)))
(define parsed-bfs (parsed-begin-for-syntax rebuild-body-s (parsed-only nested-bodys)))
(log-expand submod-ctx 'exit-begin-for-syntax)
(cons
(if (expand-context-to-parsed? submod-ctx)
parsed-bfs
@ -1217,6 +1242,7 @@
[(or (parsed? body)
(expanded+parsed? body))
;; We can skip any other parsed form
(log-expand submod-ctx 'next)
(cons body
(loop rest-bodys phase))]
[else
@ -1260,6 +1286,7 @@
(loop rest-bodys phase))]
[else
;; We can skip any other unparsed form
(log-expand submod-ctx 'next)
(cons body
(loop rest-bodys phase))])])])))
@ -1322,8 +1349,7 @@
#:declared-submodule-names declared-submodule-names
#:compiled-submodules compiled-submodules
#:modules-being-compiled modules-being-compiled)
(unless is-star?
(log-expand* ctx ['enter-prim s] [(if is-star? 'prim-submodule* 'prim-submodule)]))
(log-expand* ctx ['enter-prim s] [(if is-star? 'prim-submodule* 'prim-submodule) #f])
;; Register name and check for duplicates
(define-match m s '(module name . _))
@ -1373,9 +1399,6 @@
(eval-module compiled-submodule
#:with-submodules? #f))
(unless is-star?
(log-expand ctx 'exit-prim (extract-syntax submod)))
;; Return the expanded submodule
(cond
[(not is-star?)
@ -1395,6 +1418,7 @@
#:compiled-submodules compiled-submodules
#:modules-being-compiled modules-being-compiled)
(for/list ([body (in-list bodys)])
(log-expand ctx 'next)
(case (core-form-sym (syntax-disarm body) phase)
[(module)
(expand-submodule body self ctx
@ -1427,63 +1451,3 @@
(define (lifted-defns-extract-syntax lifted-defns)
(for/list ([lifted-defn (in-list lifted-defns)])
(defn-extract-syntax lifted-defn)))
(define (log-lifted-defns partial-body-ctx lifted-defns exp-body rest-bodys)
(log-expand...
partial-body-ctx
(lambda (obs)
(define s-lifted-defns (lifted-defns-extract-syntax lifted-defns))
(...log-expand obs ['rename-list (cons exp-body rest-bodys)] ['module-lift-loop s-lifted-defns])
;; The old expander retried expanding the lifted definitions.
;; We know that they immediately stop, so we don't do that here,
;; but we simulate the observer events.
(for ([s-lifted-defn (in-list s-lifted-defns)])
(define-match m s-lifted-defn '(define-values _ ...))
(...log-expand obs
['next]
['visit s-lifted-defn]
['resolve (m 'define-values)]
['enter-prim s-lifted-defn]
['prim-stop]
['exit-prim s-lifted-defn]
['return s-lifted-defn]
['rename-one s-lifted-defn]
['enter-prim s-lifted-defn]
['prim-define-values]
['exit-prim s-lifted-defn]))
;; A 'next, etc., to simulate retrying the expression that
;; generated the lifts --- which we know must be a stop form,
;; but we need to simulate the trip back around the loop:
(define-match m exp-body '(form-id . _))
(...log-expand obs
['next]
['visit exp-body]
['resolve (m 'form-id)]
['enter-prim exp-body]
['prim-stop]
['exit-prim exp-body]
['return exp-body]))))
(define (log-defn-enter ctx defn)
(log-expand...
ctx
(lambda (obs)
(define s-defn (defn-extract-syntax defn))
(define-match m s-defn '(define-values _ ...))
(...log-expand obs
['visit s-defn]
['resolve (m 'define-values)]
['enter-prim s-defn]
['prim-define-values]))))
(define (log-defn-exit ctx defn exp-rhs)
(log-expand...
ctx
(lambda (obs)
(define s-defn
(datum->syntax #f `(define-values ,(semi-parsed-define-values-ids defn)
,exp-rhs)
(semi-parsed-define-values-s defn)))
(...log-expand obs
['exit-prim s-defn]
['return s-defn]))))

71
racket/src/expander/expand/syntax-local.rkt
View File

@ -57,6 +57,8 @@
syntax-local-module-required-identifiers
syntax-local-module-exports
syntax-local-submodules
syntax-local-expand-observer
syntax-local-get-shadower)
@ -92,12 +94,16 @@
(define/who (syntax-local-introduce s)
(check who syntax? s)
(define ctx (get-current-expand-context 'syntax-local-introduce))
(flip-introduction-and-use-scopes s ctx))
(define new-s (flip-introduction-and-use-scopes s ctx))
(log-expand ctx 'track-syntax 'syntax-local-introduce new-s s)
new-s)
(define/who (syntax-local-identifier-as-binding id)
(check who identifier? id)
(define ctx (get-current-expand-context 'syntax-local-identifier-as-binding))
(remove-use-site-scopes id ctx))
(define new-id (remove-use-site-scopes id ctx))
(log-expand ctx 'track-syntax 'syntax-local-identifier-as-binding new-id id)
new-id)
(define (syntax-local-phase-level)
(define ctx (get-current-expand-context #:fail-ok? #t))
@ -124,11 +130,15 @@
(define (do-make-syntax-introducer sc)
(lambda (s [mode 'flip])
(check 'syntax-introducer syntax? s)
(case mode
[(add) (add-scope s sc)]
[(remove) (remove-scope s sc)]
[(flip) (flip-scope s sc)]
[else (raise-argument-error 'syntax-introducer "(or/c 'add 'remove 'flip)" mode)])))
(define new-s
(case mode
[(add) (add-scope s sc)]
[(remove) (remove-scope s sc)]
[(flip) (flip-scope s sc)]
[else (raise-argument-error 'syntax-introducer "(or/c 'add 'remove 'flip)" mode)]))
(define ctx (get-current-expand-context #:fail-ok? #t))
(when ctx (log-expand ctx 'track-syntax mode new-s s))
new-s))
(define/who (make-syntax-delta-introducer ext-s base-s [phase (syntax-local-phase-level)])
(check who syntax? ext-s)
@ -145,12 +155,16 @@
(define maybe-taint (if (syntax-clean? ext-s) values syntax-taint))
(define shifts (syntax-mpi-shifts ext-s))
(lambda (s [mode 'add])
(maybe-taint
(case mode
[(add) (syntax-add-shifts (add-scopes s delta-scs) shifts #:non-source? #t)]
[(remove) (remove-scopes s delta-scs)]
[(flip) (syntax-add-shifts (flip-scopes s delta-scs) shifts #:non-source? #t)]
[else (raise-argument-error 'syntax-introducer "(or/c 'add 'remove 'flip)" mode)]))))
(define new-s
(maybe-taint
(case mode
[(add) (syntax-add-shifts (add-scopes s delta-scs) shifts #:non-source? #t)]
[(remove) (remove-scopes s delta-scs)]
[(flip) (syntax-add-shifts (flip-scopes s delta-scs) shifts #:non-source? #t)]
[else (raise-argument-error 'syntax-introducer "(or/c 'add 'remove 'flip)" mode)])))
(define ctx (get-current-expand-context #:fail-ok? #t))
(when ctx (log-expand ctx 'track-syntax mode new-s s))
new-s))
(define/who (syntax-local-make-delta-introducer id-stx)
(check who identifier? id-stx)
@ -223,12 +237,13 @@
(set-box! counter (add1 (unbox counter)))
(define name (string->unreadable-symbol (format "lifted/~a" (unbox counter))))
(add-scope (datum->syntax #f name) (new-scope 'macro))))
(log-expand ctx 'lift-expr ids s)
(define added-s (flip-introduction-scopes s ctx))
(log-expand ctx 'lift-expr ids s added-s)
(map (lambda (id) (flip-introduction-scopes id ctx))
;; returns converted ids:
(add-lifted! lifts
ids
(flip-introduction-scopes s ctx)
added-s
(expand-context-phase ctx))))
(define/who (syntax-local-lift-expression s)
@ -254,15 +269,17 @@
(raise-arguments-error who
"not currently transforming within a module declaration or top level"
"form to lift" s))
(add-lifted-module! lifts (flip-introduction-scopes s ctx) phase)]
(define added-s (flip-introduction-scopes s ctx))
(add-lifted-module! lifts added-s phase)
(log-expand ctx 'lift-module s added-s)]
[else
(raise-arguments-error who "not a module form"
"given form" s)])
(log-expand ctx 'lift-statement s))
"given form" s)]))
;; ----------------------------------------
(define (do-local-lift-to-module who s
#:log-tag [log-tag #f]
#:no-target-msg no-target-msg
#:intro? [intro? #t]
#:more-checks [more-checks void]
@ -285,6 +302,9 @@
(define shift-s (for/fold ([s pre-s]) ([phase (in-range phase wrt-phase -1)]) ; shift from lift-context phase
(shift-wrap s (sub1 phase) lift-ctx)))
(define post-s (post-wrap shift-s wrt-phase lift-ctx)) ; post-wrap at lift-context phase
(when log-tag
;; Separate changes in scopes (s -> added-s) from wrapping (added-s -> post-s).
(log-expand ctx log-tag s added-s post-s))
(add-lifted! lift-ctx post-s wrt-phase) ; record lift for the target phase
(values ctx post-s))
@ -307,8 +327,9 @@
#:post-wrap
(lambda (s phase require-lift-ctx)
(wrap-form '#%require (add-scope s sc) phase))))
(namespace-visit-available-modules! (expand-context-namespace ctx)
(expand-context-phase ctx))
(without-expand-context
(namespace-visit-available-modules! (expand-context-namespace ctx)
(expand-context-phase ctx)))
(define result-s (add-scope use-s sc))
(log-expand ctx 'lift-require added-s use-s result-s)
result-s)
@ -333,6 +354,7 @@
(define-values (ctx also-s)
(do-local-lift-to-module who
s
#:log-tag 'lift-end-decl
#:no-target-msg "not currently transforming an expression within a module declaration"
#:get-lift-ctx expand-context-to-module-lifts
#:get-wrt-phase (lambda (lift-ctx) 0) ; always relative to 0
@ -345,7 +367,7 @@
#:shift-wrap
(lambda (s phase to-module-lift-ctx)
(wrap-form 'begin-for-syntax s phase))))
(log-expand ctx 'lift-statement s))
(void))
(define (wrap-form sym s phase)
(datum->syntax
@ -429,6 +451,13 @@
;; ----------------------------------------
;; Exported via #%expobs, not #%kernel
(define/who (syntax-local-expand-observer)
(define ctx (get-current-expand-context 'syntax-local-expand-observer))
(expand-context-observer ctx))
;; ----------------------------------------
;; Works well enough for some backward compatibility:
(define/who (syntax-local-get-shadower id [only-generated? #f])
(check who identifier? id)

22
racket/src/expander/expand/top.rkt
View File

@ -22,10 +22,10 @@
(add-core-form!
'define-values
(lambda (s ctx)
(log-expand ctx 'prim-define-values)
(define disarmed-s (syntax-disarm s))
(log-expand ctx 'prim-define-values disarmed-s)
(unless (eq? (expand-context-context ctx) 'top-level)
(raise-syntax-error #f "not allowed in an expression position" s))
(define disarmed-s (syntax-disarm s))
(define-match m s '(define-values (id ...) rhs))
(define-values (ids syms) (as-expand-time-top-level-bindings (m 'id) s ctx))
(define exp-rhs (expand (m 'rhs) (as-named-context (as-expression-context ctx) ids)))
@ -38,13 +38,13 @@
(add-core-form!
'define-syntaxes
(lambda (s ctx)
(log-expand ctx 'prim-define-syntaxes)
(log-expand ctx 'prepare-env)
(define disarmed-s (syntax-disarm s))
(log-expand ctx 'prim-define-syntaxes disarmed-s)
(unless (eq? (expand-context-context ctx) 'top-level)
(raise-syntax-error #f "not in a definition context" s))
(define disarmed-s (syntax-disarm s))
(define-match m disarmed-s '(define-syntaxes (id ...) rhs))
(define-values (ids syms) (as-expand-time-top-level-bindings (m 'id) s ctx))
(log-expand ctx 'prepare-env)
(define exp-rhs (expand-transformer (m 'rhs) (as-named-context ctx ids)))
(if (expand-context-to-parsed? ctx)
(parsed-define-syntaxes s ids syms exp-rhs)
@ -55,10 +55,10 @@
(add-core-form!
'begin-for-syntax
(lambda (s ctx)
(log-expand ctx 'prim-begin-for-syntax #f)
(unless (eq? (expand-context-context ctx) 'top-level)
(raise-syntax-error #f "not in a definition context" s))
(define-match m s '(begin-for-syntax form ...))
(log-expand ctx 'prim-begin-for-syntax)
(log-expand ctx 'prepare-env)
(define trans-ctx (context->transformer-context ctx 'top-level #:keep-stops? #t))
(define lift-ctx (make-lift-context
@ -68,13 +68,13 @@
[lifts lift-ctx]))
(define all-exp-forms
(let loop ([forms (m 'form)])
(log-expand ctx 'enter-list (datum->syntax #f (m 'form) s))
(log-expand ctx 'enter-list (m 'form))
(define exp-forms
(let loop ([forms forms] [accum null])
(cond
[(null? forms)
(define forms (reverse accum))
(log-expand ctx 'exit-list (datum->syntax #f forms s))
(log-expand ctx 'exit-list forms)
forms]
[else
(log-expand ctx 'next)
@ -97,10 +97,10 @@
(add-core-form!
'#%require
(lambda (s ctx)
(log-expand ctx 'prim-require)
(define disarmed-s (syntax-disarm s))
(log-expand ctx 'prim-require disarmed-s)
(unless (eq? (expand-context-context ctx) 'top-level)
(raise-syntax-error #f "allowed only in a module or the top level" s))
(define disarmed-s (syntax-disarm s))
(define-match m disarmed-s '(#%require req ...))
(define sc (new-scope 'macro)) ; to hide bindings
(define ns (expand-context-namespace ctx))
@ -125,5 +125,5 @@
(add-core-form!
'#%provide
(lambda (s ctx)
(log-expand ctx 'prim-provide)
(log-expand ctx 'prim-provide #f)
(raise-syntax-error #f "not allowed outside of a module body" s)))

49
racket/src/expander/syntax/api-taint.rkt
View File

@ -12,7 +12,9 @@
(only-in "../expand/syntax-local.rkt" syntax-local-phase-level)
"../namespace/core.rkt"
"../namespace/inspector.rkt"
"../common/contract.rkt")
"../common/contract.rkt"
(only-in "../expand/context.rkt" get-current-expand-context)
"../expand/log.rkt")
;; Provides public versions of taint-related syntax functions
@ -32,14 +34,18 @@
(inspector? maybe-insp))
(raise-argument-error who "(or/c inspector? #f)" maybe-insp))
(define insp (inspector-for-taint maybe-insp))
(cond
[use-mode?
(taint-dispatch
s
(lambda (s) (raw:syntax-arm s insp))
(syntax-local-phase-level))]
[else
(raw:syntax-arm s insp)]))
(define armed-s
(cond
[use-mode?
(taint-dispatch
s
(lambda (s) (raw:syntax-arm s insp))
(syntax-local-phase-level))]
[else
(raw:syntax-arm s insp)]))
(define ctx (get-current-expand-context #:fail-ok? #t))
(when ctx (log-expand ctx 'track-syntax 'arm armed-s s))
armed-s)
(define/who (syntax-disarm s maybe-insp)
(check who syntax? s)
@ -47,18 +53,25 @@
(inspector? maybe-insp))
(raise-argument-error who "(or/c inspector? #f)" maybe-insp))
(define insp (inspector-for-taint maybe-insp))
(raw:syntax-disarm s insp))
(define disarmed-s (raw:syntax-disarm s insp))
(define ctx (get-current-expand-context #:fail-ok? #t))
(when ctx (log-expand ctx 'track-syntax 'disarm disarmed-s s))
disarmed-s)
(define/who (syntax-rearm s from-s [use-mode? #f])
(check who syntax? s)
(check who syntax? from-s)
(cond
[use-mode? (taint-dispatch
s
(lambda (s) (raw:syntax-rearm s from-s))
(syntax-local-phase-level))]
[else
(raw:syntax-rearm s from-s)]))
(define rearmed-s
(cond
[use-mode? (taint-dispatch
s
(lambda (s) (raw:syntax-rearm s from-s))
(syntax-local-phase-level))]
[else
(raw:syntax-rearm s from-s)]))
(define ctx (get-current-expand-context #:fail-ok? #t))
(when ctx (log-expand ctx 'track-syntax 'rearm rearmed-s s))
rearmed-s)
(define/who (syntax-taint s)
(check who syntax? s)

2
racket/src/expander/syntax/api.rkt
View File

@ -219,5 +219,5 @@
(check who identifier? id)
(define s (raw:syntax-track-origin new-stx old-stx id))
(define ctx (get-current-expand-context #:fail-ok? #t))
(when ctx (log-expand ctx 'track-origin new-stx s))
(when ctx (log-expand ctx 'track-syntax 'track-origin new-stx s))
s)

2
racket/src/racket/src/schvers.h
View File

@ -16,7 +16,7 @@
#define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 5
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 11
#define MZSCHEME_VERSION_W 12
/* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x

5631
racket/src/racket/src/startup.inc
View File

File diff suppressed because it is too large Load Diff