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

generalized `begin-for-syntax'

Browse Source
This commit is contained in:
Matthew Flatt 2011-09-05 16:08:16 -06:00
parent 2f9f780727
commit d3c56c9f13
60 changed files with 2814 additions and 1966 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/compiler/decompile.rkt
View File

@ -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))

4
collects/compiler/demodularizer/gc-toplevels.rkt
View File

@ -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))]

3
collects/compiler/demodularizer/merge.rkt
View File

@ -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))

5
collects/compiler/demodularizer/nodep.rkt
View File

@ -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))))]

2
collects/compiler/demodularizer/update-toplevels.rkt
View File

@ -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))]

103
collects/compiler/zo-marshal.rkt
View File

@ -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)]

159
collects/compiler/zo-parse.rkt
View File

@ -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)

27
collects/compiler/zo-structs.rkt
View File

@ -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))]

4
collects/deinprogramm/signature/module-begin.rkt
View File

@ -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

2
collects/drracket/private/syncheck/contract-traversal.rkt
View File

@ -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)]

18
collects/errortrace/stacktrace.rkt
View File

@ -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 ...)

5
collects/gui-debugger/annotator.rkt
View File

@ -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)

4
collects/lang/private/teach-module-begin.rkt
View File

@ -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

2
collects/macro-debugger/model/trace.rkt
View File

@ -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)]

5
collects/mzlib/include.rkt
View File

@ -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

7
collects/r6rs/main.rkt
View File

@ -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))

79
collects/racket/private/define.rkt
View File

@ -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))))))

4
collects/racket/private/modbeg.rkt
View File

@ -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))))

45
collects/racket/private/old-rp.rkt
View File

@ -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)

76
collects/racket/private/reqprov.rkt
View File

@ -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))

21
collects/racket/private/stxcase-scheme.rkt
View File

@ -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

2
collects/scribble/doclang.rkt
View File

@ -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))]

1
collects/scribble/private/lp.rkt
View File

@ -50,7 +50,6 @@
[(rest ...) (if n
#`((subscript #,(format "~a" n)))
#`())])
#`(begin
(require (for-label for-label-mod ... ...))
#,@(if n

2
collects/scribble/text/syntax-utils.rkt
View File

@ -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)

22
collects/scribblings/guide/proc-macros.scrbl
View File

@ -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

62
collects/scribblings/raco/zo-struct.scrbl
View File

@ -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.}

21
collects/scribblings/reference/eval-model.scrbl
View File

@ -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

30
collects/scribblings/reference/stx-trans.scrbl
View File

@ -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?]

68
collects/scribblings/reference/syntax-model.scrbl
View File

@ -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

90
collects/scribblings/reference/syntax.scrbl
View File

@ -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].
}
@;------------------------------------------------------------------------

4
collects/syntax/kerncase.rkt
View File

@ -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

40
collects/tests/compiler/zo.rkt Normal file
View File

@ -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)

34
collects/tests/racket/module.rktl
View File

@ -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

2
collects/typed-racket/base-env/base-env.rkt
View File

@ -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

2
collects/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -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

11
doc/release-notes/racket/HISTORY.txt
View File

@ -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

4
src/racket/include/schthread.h
View File

@ -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_)

2
src/racket/src/compenv.c
View File

@ -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,

146
src/racket/src/compile.c
View File

@ -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. */

315
src/racket/src/cstartup.inc
View File

@ -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);
}

42
src/racket/src/env.c
View File

@ -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 *

49
src/racket/src/eval.c
View File

@ -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;

27
src/racket/src/fun.c
View File

@ -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);

2
src/racket/src/jit.c
View File

@ -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:
{

29
src/racket/src/jitprep.c
View File

@ -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;

347
src/racket/src/marshal.c
View File

@ -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();

2436
src/racket/src/module.c
View File

File diff suppressed because it is too large Load Diff

67
src/racket/src/mzmark_type.inc
View File

@ -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));

30
src/racket/src/mzmarksrc.c
View File

@ -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;

51
src/racket/src/optimize.c
View File

@ -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));

61
src/racket/src/resolve.c
View File

@ -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:

43
src/racket/src/schpriv.h
View File

@ -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,

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

@ -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)

54
src/racket/src/sfs.c
View File

@ -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;

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

@ -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)))"

4
src/racket/src/startup.rktl
View File

@ -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)

3
src/racket/src/stypes.h
View File

@ -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_

5
src/racket/src/syntax.c
View File

@ -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;

5
src/racket/src/type.c
View File

@ -125,7 +125,7 @@ scheme_init_type ()
set_name(scheme_define_values_type, "<define-values-code>");
set_name(scheme_define_syntaxes_type, "<define-syntaxes-code>");
set_name(scheme_define_for_syntax_type, "<define-for-syntax-code>");
set_name(scheme_begin_for_syntax_type, "<begin-for-syntax-code>");
set_name(scheme_begin0_sequence_type, "<begin0-code>");
set_name(scheme_splice_sequence_type, "<splicing-begin-code>");
set_name(scheme_module_type, "<module-code>");
@ -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);

59
src/racket/src/validate.c
View File

@ -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);