diff --git a/collects/honu/main.ss b/collects/honu/main.ss index e410ba8448..e3d65b245e 100644 --- a/collects/honu/main.ss +++ b/collects/honu/main.ss @@ -1295,36 +1295,38 @@ [exprs (let ([def-ctx (syntax-local-make-definition-context)] [ctx (generate-expand-context)]) - (let loop ([exprs (cddddr (cdr (syntax->list stx)))]) - (apply - append - (map (lambda (expr) - (let ([expr (local-expand - expr - ctx - block-expand-stop-forms - def-ctx)]) - (syntax-case expr (begin define-values define-syntaxes) - [(begin . rest) - (loop (syntax->list #'rest))] - [(define-syntaxes (id ...) rhs) - (andmap identifier? (syntax->list #'(id ...))) - (with-syntax ([rhs (local-transformer-expand - #'rhs - 'expression - null)]) - (syntax-local-bind-syntaxes - (syntax->list #'(id ...)) - #'rhs def-ctx) - (list #'(define-syntaxes (id ...) rhs)))] - [(define-values (id ...) rhs) - (andmap identifier? (syntax->list #'(id ...))) - (let ([ids (syntax->list #'(id ...))]) - (syntax-local-bind-syntaxes ids #f def-ctx) - (list expr))] - [else - (list expr)]))) - exprs))))]) + (begin0 + (let loop ([exprs (cddddr (cdr (syntax->list stx)))]) + (apply + append + (map (lambda (expr) + (let ([expr (local-expand + expr + ctx + block-expand-stop-forms + def-ctx)]) + (syntax-case expr (begin define-values define-syntaxes) + [(begin . rest) + (loop (syntax->list #'rest))] + [(define-syntaxes (id ...) rhs) + (andmap identifier? (syntax->list #'(id ...))) + (with-syntax ([rhs (local-transformer-expand + #'rhs + 'expression + null)]) + (syntax-local-bind-syntaxes + (syntax->list #'(id ...)) + #'rhs def-ctx) + (list #'(define-syntaxes (id ...) rhs)))] + [(define-values (id ...) rhs) + (andmap identifier? (syntax->list #'(id ...))) + (let ([ids (syntax->list #'(id ...))]) + (syntax-local-bind-syntaxes ids #f def-ctx) + (list expr))] + [else + (list expr)]))) + exprs))) + (internal-definition-context-seal def-ctx)))]) #`(let () #,@(let loop ([exprs exprs][prev-defns null][prev-exprs null]) (cond diff --git a/collects/mzlib/etc.ss b/collects/mzlib/etc.ss index 1e72899af5..c9b28bb194 100644 --- a/collects/mzlib/etc.ss +++ b/collects/mzlib/etc.ss @@ -386,6 +386,7 @@ [else (list expr)]))) exprs)))]) + (internal-definition-context-seal def-ctx) (let loop ([exprs exprs] [prev-stx-defns null] [prev-defns null] diff --git a/collects/mzlib/private/sigutil.ss b/collects/mzlib/private/sigutil.ss index a99eedf6b5..cf507a4e3f 100644 --- a/collects/mzlib/private/sigutil.ss +++ b/collects/mzlib/private/sigutil.ss @@ -667,6 +667,7 @@ (let loop ([pre-lines null][lines (append import-stxes body)][port #f][port-name #f][body null][vars null]) (cond [(and (null? pre-lines) (not port) (null? lines)) + (internal-definition-context-seal def-ctx) (make-parsed-unit imports renames vars diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss index 29443d50ca..f05c7f8691 100644 --- a/collects/mzlib/private/unit-compiletime.ss +++ b/collects/mzlib/private/unit-compiletime.ss @@ -18,7 +18,7 @@ (provide (rename build-siginfo make-siginfo) siginfo-names siginfo-ctime-ids siginfo-rtime-ids siginfo-subtype unprocess-link-record-bind unprocess-link-record-use - set!-trans-extract do-identifier + set!-trans-extract process-tagged-import process-tagged-export lookup-signature lookup-def-unit make-id-mapper make-id-mappers sig-names sig-int-names sig-ext-names map-sig split-requires apply-mac complete-exports complete-imports check-duplicate-subs @@ -186,20 +186,17 @@ (lambda (x) x) sig))) - ;; do-prefix : sig syntax-object -> sig + ;; do-prefix : id id -> id ;; ensures that pid is an identifier - (define (do-prefix sig pid) - (check-id pid) - (let ((p (syntax-e pid))) - (map-sig - (lambda (id) - (datum->syntax-object - id - (string->symbol (format "~a~a" p (syntax-e id))))) - (lambda (x) x) - sig))) + (define (do-prefix stx pid) + (if (identifier? stx) + (datum->syntax-object + stx + (string->symbol (format "~a~a" (syntax-e pid) (syntax-e stx))) + stx) + stx)) - ;; do-only : sig (listof identifier) -> sig + ;; do-only/except : sig (listof identifier) -> sig ;; ensures that only-ids are identifiers and are mentioned in the signature (define (do-only/except sig only/except-ids put get) (check-module-id-subset only/except-ids @@ -217,22 +214,22 @@ sig))) ;; do-identifier : identifier (box (cons identifier siginfo)) -> sig - (define (do-identifier spec res bind?) + (define (do-identifier spec res bind? add-prefix) (let* ((sig (lookup-signature spec)) (vars (signature-vars sig)) (vals (signature-val-defs sig)) (stxs (signature-stx-defs sig)) (delta-introduce (if bind? - (let ([f (make-syntax-delta-introducer - spec - (signature-orig-binder sig))]) + (let ([f (syntax-local-make-delta-introducer + spec)]) (lambda (id) (syntax-local-introduce (f id)))) values))) (set-box! res (cons spec (signature-siginfo sig))) (map-sig (lambda (id) (syntax-local-introduce (syntax-local-get-shadower - (delta-introduce id)))) + (add-prefix + (delta-introduce id))))) syntax-local-introduce (list (map cons vars vars) (map @@ -301,43 +298,47 @@ (check-tagged-spec-syntax spec import? identifier?) (syntax-case spec (tag) ((tag sym spec) - (let ([s (process-import/export #'spec res bind?)]) + (let ([s (process-import/export #'spec res bind? values)]) (list (cons (syntax-e #'sym) (cdr (unbox res))) (cons (syntax-e #'sym) (car (unbox res))) s))) ((tag . _) (raise-stx-err "expected (tag symbol )" spec)) - (_ (let ([s (process-import/export spec res bind?)]) + (_ (let ([s (process-import/export spec res bind? values)]) (list (cons #f (cdr (unbox res))) (cons #f (car (unbox res))) s))))) + (define (add-prefixes add-prefix l) + (map add-prefix (syntax->list l))) ;; process-import/export : syntax-object (box (cons identifier) siginfo) -> sig - (define (process-import/export spec res bind?) + (define (process-import/export spec res bind? add-prefix) (syntax-case spec (only except prefix rename) (_ (identifier? spec) - (do-identifier spec res bind?)) + (do-identifier spec res bind? add-prefix)) ((only sub-spec id ...) - (do-only/except (process-import/export #'sub-spec res bind?) - (syntax->list #'(id ...)) - (lambda (x) x) + (do-only/except (process-import/export #'sub-spec res bind? add-prefix) + (add-prefixes add-prefix #'(id ...)) + (lambda (id) id) (lambda (id) (car (generate-temporaries #`(#,id)))))) ((except sub-spec id ...) - (do-only/except (process-import/export #'sub-spec res bind?) - (syntax->list #'(id ...)) + (do-only/except (process-import/export #'sub-spec res bind? add-prefix) + (add-prefixes add-prefix #'(id ...)) (lambda (id) (car (generate-temporaries #`(#,id)))) - (lambda (x) x))) + (lambda (id) id))) ((prefix pid sub-spec) - (do-prefix (process-import/export #'sub-spec res bind?) #'pid)) + (process-import/export #'sub-spec res bind? + (lambda (id) + (do-prefix (add-prefix id) #'pid)))) ((rename sub-spec (internal external) ...) (let* ((sig-res - (do-rename (process-import/export #'sub-spec res bind?) + (do-rename (process-import/export #'sub-spec res bind? add-prefix) #'(internal ...) - #'(external ...))) + (datum->syntax-object #f (add-prefixes add-prefix #'(external ...))))) (dup (check-duplicate-identifier (sig-int-names sig-res)))) (when dup (raise-stx-err @@ -353,7 +354,7 @@ ;; process-spec : syntax-object -> sig (define (process-spec spec) (check-tagged-spec-syntax spec #f identifier?) - (process-import/export spec (box #f) #t)) + (process-import/export spec (box #f) #t values)) ; ;; extract-siginfo : (union import-spec export-spec) -> ??? diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 60072b633c..698092ee6f 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -333,6 +333,7 @@ (define-for-syntax (add-context-to-sig sig) (let ((def-ctx (syntax-local-make-definition-context))) (syntax-local-bind-syntaxes (sig-ext-names sig) #f def-ctx) + (internal-definition-context-seal def-ctx) (map-sig (lambda (x) x) (lambda (x) (localify x def-ctx)) sig))) @@ -619,6 +620,7 @@ [_ (void)])) expanded-body) table)]) + (internal-definition-context-seal def-ctx) ;; Mark exported names and ;; check that all exported names are defined (as var): diff --git a/collects/mzlib/unit200.ss b/collects/mzlib/unit200.ss index 9952cebe62..c3cdbb6d0a 100644 --- a/collects/mzlib/unit200.ss +++ b/collects/mzlib/unit200.ss @@ -158,7 +158,10 @@ [else (list defn-or-expr)]))) defns&exprs))) values)]) + (let ([all-expanded (expand-all (syntax->list (syntax (defn&expr ...))))]) + (when def-ctx + (internal-definition-context-seal def-ctx)) ;; Get all the defined names, sorting out variable definitions ;; from syntax definitions. (let* ([definition? diff --git a/collects/r5rs/main.ss b/collects/r5rs/main.ss index ec3205135a..8c166179c2 100644 --- a/collects/r5rs/main.ss +++ b/collects/r5rs/main.ss @@ -410,6 +410,7 @@ (cdr exprs))) (reverse idss) (reverse rhss) (reverse stx-idss) (reverse stx-rhss))]))))]) + (internal-definition-context-seal def-ctx) (if (and (null? (syntax-e #'(stx-rhs ...))) (andmap (lambda (ids) (= 1 (length (syntax->list ids)))) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss new file mode 100644 index 0000000000..41827b90bb --- /dev/null +++ b/collects/scheme/package.ss @@ -0,0 +1,252 @@ +#lang scheme/base +(require (for-syntax scheme/base + syntax/kerncase + syntax/boundmap)) + +(provide define-package + open-package) + +(begin-for-syntax + (define-struct package (exports hidden) + #:omit-define-syntaxes + #:property prop:procedure (lambda (r stx) + (raise-syntax-error + #f + "misuse of a package name" + stx))) + + (define (reverse-mapping id exports hidden) + (or (ormap (lambda (m) + (and (free-identifier=? id (cdr m)) + (car m))) + exports) + (ormap (lambda (h) + (and (free-identifier=? id h) + ;; Name is inaccessible. Generate a temporary to + ;; avoid potential duplicate-definition errors + ;; when the name is bound in the same context as + ;; the package. + (car (generate-temporaries (list id))))) + hidden) + id))) + +(define-syntax (define-package stx) + (syntax-case stx () + [(_ pack-id exports form ...) + (let ([id #'pack-id] + [exports #'exports]) + (unless (identifier? id) + (raise-syntax-error #f + "expected an identifier" + stx + id)) + (let ([exports + (cond + [(eq? (syntax-e exports) 'all-defined) #f] + [(syntax->list exports) + => (lambda (l) + (for-each (lambda (i) + (unless (identifier? i) + (raise-syntax-error #f + "expected identifier to export" + stx + i))) + l) + (let ([dup-id (check-duplicate-identifier l)]) + (when dup-id + (raise-syntax-error + #f + "duplicate export" + stx + dup-id))) + l)] + [else (raise-syntax-error #f + "expected a parenthesized sequence of identifiers to export" + stx + exports)])]) + (let* ([def-ctx (syntax-local-make-definition-context)] + [ctx (cons (gensym 'intdef) + (let ([orig-ctx (syntax-local-context)]) + (if (pair? orig-ctx) + orig-ctx + null)))] + [pre-package-id (lambda (id) + (identifier-remove-from-definition-context + id + def-ctx))] + [kernel-forms (kernel-form-identifier-list)] + [init-exprs (syntax->list #'(form ...))] + [new-bindings (make-bound-identifier-mapping)] + [fixup-sub-package (lambda (renamed-exports renamed-defines) + (lambda (stx) + (syntax-case* stx (define-syntaxes #%plain-app make-package quote-syntax + list cons #%plain-lambda) + free-transformer-identifier=? + [(define-syntaxes (pack-id) + (#%plain-app + make-package + (#%plain-lambda () + (#%plain-app list + (#%plain-app cons + (quote-syntax export) + (quote-syntax renamed)) + ...)) + hidden)) + (with-syntax ([(export ...) + (map (lambda (id) + (if (or (ormap (lambda (e-id) + (bound-identifier=? id e-id)) + renamed-exports) + (not (ormap (lambda (e-id) + (bound-identifier=? id e-id)) + renamed-defines))) + ;; Need to preserve the original + (pre-package-id id) + ;; It's not accessible, so just hide the name + ;; to avoid re-binding errors. + (car (generate-temporaries (list id))))) + (syntax->list #'(export ...)))]) + (syntax/loc stx + (define-syntaxes (pack-id) + (make-package + (lambda () + (list (cons (quote-syntax export) + (quote-syntax renamed)) + ...)) + hidden))))] + [_ stx])))]) + (let ([register-bindings! + (lambda (ids) + (for-each (lambda (id) + (when (bound-identifier-mapping-get new-bindings id (lambda () #f)) + (raise-syntax-error #f + "duplicate binding" + stx + id)) + (bound-identifier-mapping-put! new-bindings + id + #t)) + ids))] + [add-package-context (lambda (stx) + (let ([q (local-expand #`(quote #,stx) + ctx + (list #'quote) + def-ctx)]) + (syntax-case q () + [(_ stx) #'stx])))]) + (let loop ([exprs init-exprs] + [rev-forms null] + [defined null]) + (cond + [(null? exprs) + (internal-definition-context-seal def-ctx) + (let ([exports-renamed (map add-package-context (or exports null))] + [defined-renamed (bound-identifier-mapping-map new-bindings + (lambda (k v) k))]) + (for-each (lambda (ex renamed) + (unless (bound-identifier-mapping-get new-bindings + renamed + (lambda () #f)) + (raise-syntax-error #f + "no definition for exported identifier" + stx + ex))) + (or exports null) + exports-renamed) + (with-syntax ([(export ...) exports] + [(renamed ...) exports-renamed] + [(hidden ...) + (begin + (for-each (lambda (ex) + (bound-identifier-mapping-put! new-bindings ex #f)) + exports-renamed) + (filter + values + (bound-identifier-mapping-map new-bindings + (lambda (k v) (and v k)))))]) + #`(begin + #,@(map (fixup-sub-package exports-renamed defined-renamed) (reverse rev-forms)) + (define-syntax pack-id + (make-package + (lambda () + (list (cons (quote-syntax export) + (quote-syntax renamed)) + ...)) + (lambda () + (list (quote-syntax hidden) ...)))))))] + [else + (let ([expr (local-expand (car exprs) ctx kernel-forms def-ctx)]) + (syntax-case expr (begin define-syntaxes define-values) + [(begin . rest) + (loop (append (syntax->list #'rest) (cdr exprs)) + rev-forms + defined)] + [(define-syntaxes (id ...) rhs) + (andmap identifier? (syntax->list #'(id ...))) + (with-syntax ([rhs (local-transformer-expand + #'rhs + 'expression + null)]) + (let ([ids (syntax->list #'(id ...))]) + (syntax-local-bind-syntaxes ids #'rhs def-ctx) + (register-bindings! ids) + (loop (cdr exprs) + (cons #'(define-syntaxes (id ...) rhs) + rev-forms) + (cons ids defined))))] + [(define-values (id ...) rhs) + (andmap identifier? (syntax->list #'(id ...))) + (let ([ids (syntax->list #'(id ...))]) + (syntax-local-bind-syntaxes ids #f def-ctx) + (register-bindings! ids) + (loop (cdr exprs) + (cons expr rev-forms) + (cons ids defined)))] + [else + (loop (cdr exprs) + (cons #`(define-values () (begin #,expr (values))) + rev-forms) + defined)]))]))))))])) + +(define-syntax (open-package stx) + (syntax-case stx () + [(_ pack-id) + (let ([id #'pack-id]) + (unless (identifier? id) + (raise-syntax-error #f + "expected an identifier for a package" + stx + id)) + (let ([v (syntax-local-value id (lambda () #f))]) + (unless (package? v) + (raise-syntax-error #f + "identifier is not bound to a package" + stx + id)) + (let ([introduce (syntax-local-make-delta-introducer + (syntax-local-introduce id))]) + (with-syntax ([(intro ...) + (map (lambda (i) + (syntax-local-introduce + (syntax-local-get-shadower + (introduce i)))) + (map car ((package-exports v))))] + [(defined ...) + (map (lambda (v) (syntax-local-introduce (cdr v))) + ((package-exports v)))] + [((a . b) ...) (map (lambda (p) + (cons (syntax-local-introduce (car p)) + (syntax-local-introduce (cdr p)))) + ((package-exports v)))] + [(h ...) (map syntax-local-introduce ((package-hidden v)))]) + #'(begin + (define-syntaxes (intro ...) + (let ([rev-map (lambda (x) + (reverse-mapping + x + (list (cons (quote-syntax a) + (quote-syntax b)) + ...) + (list (quote-syntax h) ...)))]) + (values (make-rename-transformer #'defined rev-map) + ...))))))))])) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 36356c5413..37006a569d 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -1214,6 +1214,8 @@ proc)))))) methods)))] [lookup-localize-cdr (lambda (p) (lookup-localize (cdr p)))]) + + (internal-definition-context-seal def-ctx) ;; ---- build final result ---- (with-syntax ([public-names (map lookup-localize-cdr publics)] diff --git a/collects/scheme/splicing.ss b/collects/scheme/splicing.ss index 7124f054be..23eb987652 100644 --- a/collects/scheme/splicing.ss +++ b/collects/scheme/splicing.ss @@ -52,6 +52,7 @@ (let ([def-ctx (syntax-local-make-definition-context)] [ctx (list (gensym 'intdef))]) (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) + (internal-definition-context-seal def-ctx) (let* ([add-context (lambda (expr) (let ([q (local-expand #`(quote #,expr) diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 4ef99b1666..eb0ced966b 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -58,15 +58,19 @@ Returns the procedure that was passed to @scheme[make-set!-transformer] to create @scheme[transformer].} -@defproc[(make-rename-transformer [id-stx syntax?]) +@defproc[(make-rename-transformer [id-stx syntax?] + [delta-introduce (identifier? . -> . identifier?) + (lambda (id) id)]) rename-transformer?]{ -Creates a value that, when used as a @tech{transformer binding}, -inserts the identifier @scheme[id-stx] in place of whatever identifier -binds the transformer, including in non-application positions, and in +Creates a @tech{rename transformer} that, when used as a +@tech{transformer binding}, acts as a transformer that insert the +identifier @scheme[id-stx] in place of whatever identifier binds the +transformer, including in non-application positions, and in @scheme[set!] expressions. Such a transformer could be written manually, but the one created by @scheme[make-rename-transformer] -cooperates specially with @scheme[syntax-local-value] (see below).} +cooperates specially with @scheme[syntax-local-value] and +@scheme[syntax-local-make-delta-introducer].} @defproc[(rename-transformer? [v any/c]) boolean?]{ @@ -184,15 +188,25 @@ expressions are reported as @scheme[define-values] forms (in the transformer environment).} +@defproc[(internal-definition-context? [v any/c]) boolean?]{ + +Returns @scheme[#t] if @scheme[v] is an @tech{internal-definition +context}, @scheme[#f] otherwise.} + + @defproc[(syntax-local-make-definition-context) internal-definition-context?]{ -Creates an opaque internal-definition context value to be used with -@scheme[local-expand] and other functions. A transformer should create -one context for each set of internal definitions to be expanded, and -use it when expanding any form whose lexical context should include -the definitions. After discovering an internal @scheme[define-values] -or @scheme[define-syntaxes] form, use +Creates an opaque @tech{internal-definition context} value to be used +with @scheme[local-expand] and other functions. A transformer should +create one context for each set of internal definitions to be +expanded, and use it when expanding any form whose lexical context +should include the definitions. After discovering an internal +@scheme[define-values] or @scheme[define-syntaxes] form, use @scheme[syntax-local-bind-syntaxes] to add bindings to the context. +Finally, the transformer must call +@scheme[internal-definition-context-seal] after all bindings have been +added; if an unsealed @tech{internal-definition context} is detected +in a fully expanded expression, the @exnraise[exn:fail:contract]. @transform-time[]} @@ -203,7 +217,7 @@ or @scheme[define-syntaxes] form, use void?]{ Binds each identifier in @scheme[id-list] within the -internal-definition context represented by @scheme[intdef-ctx], where +@tech{internal-definition context} represented by @scheme[intdef-ctx], where @scheme[intdef-ctx] is the result of @scheme[syntax-local-make-definition-context]. Supply @scheme[#f] for @scheme[expr] when the identifiers correspond to @@ -216,6 +230,24 @@ match the number of identifiers, otherwise the @transform-time[]} +@defproc[(internal-definition-context-seal [intdef-ctx internal-definition-context?]) + void?]{ + +Indicates that no further bindings will be added to +@scheme[intdef-ctx], which must not be sealed already. See also +@scheme[syntax-local-make-definition-context].} + + +@defproc[(identifier-remove-from-defininition-context [id-stx identifier?] + [intdef-ctx internal-definition-context?]) + identifier?]{ + +Removes @scheme[intdef-ctx] from the @tech{lexical information} of +@scheme[id-stx]. This operation is useful for correlating a identifier +that is bound in an internal-definition context with its binding +before the internal-definition context was created.} + + @defproc[(syntax-local-value [id-stx syntax?] [failure-thunk (or/c (-> any) #f) #f] @@ -225,16 +257,16 @@ match the number of identifiers, otherwise the any]{ Returns the @tech{transformer binding} value of @scheme[id-stx] in -either the context asscoiated with @scheme[intdef-ctx] (if not +either the context associated with @scheme[intdef-ctx] (if not @scheme[#f]) or the context of the expression being expanded (if @scheme[indef-ctx] is @scheme[#f]). If @scheme[intdef-ctx] is provided, it must be an extension of the context of the expression being expanded. -If @scheme[id-stx] is bound to a rename transformer created with -@scheme[make-rename-transformer], @scheme[syntax-local-value] +If @scheme[id-stx] is bound to a @tech{rename transformer} created +with @scheme[make-rename-transformer], @scheme[syntax-local-value] effectively calls itself with the target of the rename and returns -that result, instead of the rename transformer. +that result, instead of the @tech{rename transformer}. If @scheme[id-stx] has no @tech{transformer binding} (via @scheme[define-syntax], @scheme[let-syntax], etc.) in that @@ -333,8 +365,8 @@ context}. The identity of the lists's first element (i.e., its @scheme[eq?]ness) reflects the identity of the internal-definition context; in particular two transformer expansions receive the same first value if and only if they are invoked for the same -internal-definition context. Later values in the list similarly -identify internal-definition contexts that are still being expanded, +@tech{internal-definition context}. Later values in the list similarly +identify @tech{internal-definition contexts} that are still being expanded, and that required the expansion of nested internal-definition contexts. @@ -440,20 +472,53 @@ mark}. Multiple applications of the same @scheme[make-syntax-introducer] result procedure use the same mark, and different result procedures use distinct marks.} -@defproc[(make-syntax-delta-introducer [ext-stx syntax?] [base-stx syntax?]) +@defproc[(make-syntax-delta-introducer [ext-stx syntax?] + [base-stx syntax?] + [phase-level (or/c #f exact-integer?) + (syntax-local-phase-level)]) (syntax? . -> . syntax?)]{ Produces a procedure that behaves like -@scheme[syntax-local-introduce], but using the @tech{syntax -marks} of @scheme[ext-stx] that are not shared with @scheme[base-stx]. +@scheme[syntax-local-introduce], but using the @tech{syntax marks} of +@scheme[ext-stx] that are not shared with @scheme[base-stx]. If +@scheme[ext-stx] does not extend the set of marks in @scheme[base-stx] +but @scheme[ext-stx] has a module binding in the @tech{phase level} +indicated by @scheme[phase-level], then any marks of @scheme[ext-stx] +that would be needed to preserve its binding are not transferred in an +introduction. -This procedure is useful when @scheme[_m-id] has a transformer binding -that records some @scheme[_orig-id], and a use of @scheme[_m-id] -introduces a binding of @scheme[_orig-id]. In that case, the -@tech{syntax marks} in the use of @scheme[_m-id] since the binding of -@scheme[_m-id] should be transferred to the binding instance of -@scheme[_orig-id], so that it captures uses with the same lexical -context as the use of @scheme[_m-id].} +This procedure is potentially useful when @scheme[_m-id] has a +transformer binding that records some @scheme[_orig-id], and a use of +@scheme[_m-id] introduces a binding of @scheme[_orig-id]. In that +case, the @tech{syntax marks} in the use of @scheme[_m-id] since the +binding of @scheme[_m-id] should be transferred to the binding +instance of @scheme[_orig-id], so that it captures uses with the same +lexical context as the use of @scheme[_m-id]. + +More typically, however, @scheme[syntax-local-make-delta-introducer] +should be used, since it cooperates with @tech{rename transformers}.} + +@defproc[(syntax-local-make-delta-introducer [id identifier?]) + (identifier? . -> . identifier?)]{ + +Determines the binding of @scheme[id]. If the binding is not a +@tech{rename transformer}, the result is an introducer as created by +@scheme[make-syntax-delta-introducer] using @scheme[id] and the +binding of @scheme[id] in the environment of expansion. If the binding +is a @tech{rename transformer}, then the introducer is one composed +with the target of the @tech{rename transformer} and its +binding. Furthermore, the @scheme[_delta-introduce] functions +associated with the @tech{rename transformers} (supplied as the second +argument to @scheme[make-rename-transformer]) are composed (in +first-to-last order) before the introducers created with +@scheme[make-syntax-delta-introducer] (which are composed +last-to-first). + +The @exnraise[exn:fail:contract] if @scheme[id] or any identifier in +its rename-transformer chain has no binding. + +@transform-time[]} + @defproc[(syntax-local-transforming-module-provides?) boolean?]{ diff --git a/collects/scribblings/reference/syntax-model.scrbl b/collects/scribblings/reference/syntax-model.scrbl index 79220ca738..dfa0d2bf55 100644 --- a/collects/scribblings/reference/syntax-model.scrbl +++ b/collects/scribblings/reference/syntax-model.scrbl @@ -543,8 +543,9 @@ transformer binding's value. When @scheme[_id] is bound to a @deftech{rename transformer} produced by @scheme[make-rename-transformer], it is replaced with the identifier passed to @scheme[make-rename-transformer]. Furthermore, the binding -is also specially handled by @scheme[syntax-local-value] as used by -@tech{syntax transformer}s. +is also specially handled by @scheme[syntax-local-value] and +@scheme[syntax-local-make-delta-introducer] as used by @tech{syntax +transformer}s. In addition to using marks to track introduced identifiers, the expander tracks the expansion history of a form through @tech{syntax diff --git a/collects/tests/mzscheme/macro.ss b/collects/tests/mzscheme/macro.ss index 4080b105b7..5c9b022a05 100644 --- a/collects/tests/mzscheme/macro.ss +++ b/collects/tests/mzscheme/macro.ss @@ -214,7 +214,7 @@ (arity-test make-set!-transformer 1 1) (arity-test set!-transformer? 1 1) -(arity-test make-rename-transformer 1 1) +(arity-test make-rename-transformer 1 2) (arity-test rename-transformer? 1 1) ;; Test inheritance of context when . is used in a pattern @@ -400,4 +400,36 @@ ;; ---------------------------------------- +(define-syntax (bind stx) + (syntax-case stx () + [(_ handle def) + (let ([def-ctx (syntax-local-make-definition-context)] + [ctx (cons (gensym 'intdef) + (let ([orig-ctx (syntax-local-context)]) + (if (pair? orig-ctx) + orig-ctx + null)))] + [kernel-forms (list #'define-values)]) + (let ([def (local-expand #'def ctx kernel-forms def-ctx)]) + (syntax-case def () + [(define-values (id) rhs) + (begin + (syntax-local-bind-syntaxes (list #'id) #f def-ctx) + #'(begin + (define-values (id) rhs) + (define-syntax handle (quote-syntax id))))] + [_ (error "no")])))])) + +(define-syntax (nab stx) + (syntax-case stx () + [(_ handle) + (syntax-local-value #'handle)])) + +(let () + (bind h (define q 5)) + (define q 8) + (nab h)) + +;; ---------------------------------------- + (report-errs) diff --git a/collects/tests/units/test-unit.ss b/collects/tests/units/test-unit.ss index e7cb92bc2c..2dd639d3b2 100644 --- a/collects/tests/units/test-unit.ss +++ b/collects/tests/units/test-unit.ss @@ -1644,12 +1644,16 @@ (define-signature sig^ (u-a)) -(define unit@ - (unit - (import) - (export sig^) +(define-unit unit@ + (import) + (export sig^) + + (define u-a 'zero)) - (define u-a 'zero))) +(test 'zero + (let ([q:u-a 5]) + (define-values/invoke-unit unit@ (import) (export (prefix q: sig^))) + q:u-a)) (define-syntax (use-unit stx) (syntax-case stx () @@ -1658,6 +1662,13 @@ (define-values/invoke-unit unit@ (import) (export sig^)) u-a)])) +(define-syntax (use-unit2 stx) + (syntax-case stx () + [(_) + #'(let () + (define-values/invoke-unit/infer unit@) + u-a)])) + (define-syntax (use-unit-badly1 stx) (syntax-case stx () [(_ u-a) @@ -1673,6 +1684,7 @@ u-a)])) (test 'zero (use-unit)) +(test 'zero (use-unit2)) (test-runtime-error exn:fail:contract:variable? "context mismatch; no u-a" (use-unit-badly1 u-a)) (test-runtime-error exn:fail:contract:variable? "context mismatch; no u-a" diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index dcedcf7591..3f2e2654cb 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,3 +1,12 @@ +Version 4.1.3.2 +Added internal-definition-context-seal, which must be used on an + internal-definition context before it's part of a fully expanded form +Added syntax-local-make-delta-introducer +Changed make-rename-transformer to accept an introducer argument that + cooperates with syntax-local-make-delta-introducer +Added internal-defininition-context? +Added identifier-remove-from-defininition-context + Version 4.1.3, November 2008 Changed scheme to re-export scheme/port In scheme/port: added diff --git a/src/mzscheme/src/cstartup.inc b/src/mzscheme/src/cstartup.inc index e91cdcf96c..9e6dc1fde0 100644 --- a/src/mzscheme/src/cstartup.inc +++ b/src/mzscheme/src/cstartup.inc @@ -1,5 +1,5 @@ { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,50,46,52,50,0,0,0,1,0,0,6,0,9,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,50,50,0,0,0,1,0,0,6,0,9,0, 13,0,26,0,29,0,34,0,41,0,46,0,51,0,58,0,65,0,69,0,78, 0,84,0,98,0,112,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0, 177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,68,1,107,1,146, @@ -14,11 +14,11 @@ 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,98, -10,35,11,8,188,227,94,159,2,16,35,35,159,2,15,35,35,16,20,2,3, +10,35,11,8,174,227,94,159,2,16,35,35,159,2,15,35,35,16,20,2,3, 2,2,2,4,2,2,2,10,2,2,2,5,2,2,2,6,2,2,2,7,2, 2,2,8,2,2,2,9,2,2,2,11,2,2,2,12,2,2,97,36,11,8, -188,227,93,159,2,15,35,36,16,2,2,13,161,2,2,36,2,13,2,2,2, -13,97,10,11,11,8,188,227,16,0,97,10,37,11,8,188,227,16,0,13,16, +174,227,93,159,2,15,35,36,16,2,2,13,161,2,2,36,2,13,2,2,2, +13,97,10,11,11,8,174,227,16,0,97,10,37,11,8,174,227,16,0,13,16, 4,35,29,11,11,2,2,11,18,98,64,104,101,114,101,8,31,8,30,8,29, 8,28,8,27,27,248,22,133,4,23,196,1,249,22,190,3,80,158,38,35,251, 22,74,2,17,248,22,89,23,200,2,12,249,22,64,2,1,248,22,91,23,202, @@ -28,14 +28,14 @@ 36,28,248,22,72,248,22,66,23,195,2,248,22,65,193,249,22,190,3,80,158, 38,35,251,22,74,2,17,248,22,65,23,200,2,249,22,64,2,12,248,22,66, 23,202,1,11,18,100,10,8,31,8,30,8,29,8,28,8,27,16,4,11,11, -2,18,3,1,7,101,110,118,57,57,53,57,16,4,11,11,2,19,3,1,7, -101,110,118,57,57,54,48,27,248,22,66,248,22,133,4,23,197,1,28,248,22, +2,18,3,1,7,101,110,118,57,55,50,53,16,4,11,11,2,19,3,1,7, +101,110,118,57,55,50,54,27,248,22,66,248,22,133,4,23,197,1,28,248,22, 72,23,194,2,20,15,159,36,35,36,28,248,22,72,248,22,66,23,195,2,248, 22,65,193,249,22,190,3,80,158,38,35,250,22,74,2,20,248,22,74,249,22, 74,248,22,74,2,21,248,22,65,23,202,2,251,22,74,2,17,2,21,2,21, 249,22,64,2,5,248,22,66,23,205,1,18,100,11,8,31,8,30,8,29,8, -28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,57,57,54,50,16,4, -11,11,2,19,3,1,7,101,110,118,57,57,54,51,248,22,133,4,193,27,248, +28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,57,55,50,56,16,4, +11,11,2,19,3,1,7,101,110,118,57,55,50,57,248,22,133,4,193,27,248, 22,133,4,194,249,22,64,248,22,74,248,22,65,196,248,22,66,195,27,248,22, 66,248,22,133,4,23,197,1,249,22,190,3,80,158,38,35,28,248,22,52,248, 22,191,3,248,22,65,23,198,2,27,249,22,2,32,0,89,162,8,44,36,42, @@ -65,8 +65,8 @@ 251,22,74,2,17,28,249,22,162,8,248,22,191,3,248,22,65,23,201,2,64, 101,108,115,101,10,248,22,65,23,198,2,250,22,75,2,20,9,248,22,66,23, 201,1,249,22,64,2,8,248,22,66,23,203,1,99,8,31,8,30,8,29,8, -28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,57,57,56,53,16,4, -11,11,2,19,3,1,7,101,110,118,57,57,56,54,18,158,94,10,64,118,111, +28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,57,55,53,49,16,4, +11,11,2,19,3,1,7,101,110,118,57,55,53,50,18,158,94,10,64,118,111, 105,100,8,47,27,248,22,66,248,22,133,4,196,249,22,190,3,80,158,38,35, 28,248,22,52,248,22,191,3,248,22,65,197,250,22,74,2,26,248,22,74,248, 22,65,199,248,22,89,198,27,248,22,191,3,248,22,65,197,250,22,74,2,26, @@ -99,7 +99,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 2032); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,50,46,52,60,0,0,0,1,0,0,3,0,16,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,50,60,0,0,0,1,0,0,3,0,16,0, 21,0,38,0,53,0,71,0,87,0,97,0,115,0,135,0,151,0,169,0,200, 0,229,0,251,0,9,1,15,1,29,1,34,1,44,1,52,1,80,1,112,1, 157,1,202,1,226,1,9,2,11,2,68,2,158,3,199,3,33,5,137,5,241, @@ -344,12 +344,12 @@ EVAL_ONE_SIZED_STR((char *)expr, 5068); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,50,46,52,8,0,0,0,1,0,0,6,0,19,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,50,8,0,0,0,1,0,0,6,0,19,0, 34,0,48,0,62,0,76,0,111,0,0,0,255,0,0,0,65,113,117,111,116, 101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37, 110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122, 11,29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35, -37,107,101,114,110,101,108,11,98,10,35,11,8,190,229,97,159,2,2,35,35, +37,107,101,114,110,101,108,11,98,10,35,11,8,176,229,97,159,2,2,35,35, 159,2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,35,16, 0,159,35,20,103,159,35,16,1,65,98,101,103,105,110,16,0,83,158,41,20, 100,138,69,35,37,98,117,105,108,116,105,110,29,11,11,11,10,10,18,96,11, @@ -361,40 +361,41 @@ EVAL_ONE_SIZED_STR((char *)expr, 292); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,50,46,52,52,0,0,0,1,0,0,3,0,14,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,50,53,0,0,0,1,0,0,3,0,14,0, 41,0,47,0,60,0,74,0,96,0,122,0,134,0,152,0,172,0,184,0,200, -0,223,0,3,1,8,1,13,1,18,1,23,1,54,1,58,1,66,1,74,1, -82,1,185,1,230,1,250,1,29,2,64,2,98,2,108,2,155,2,165,2,172, -2,71,4,84,4,103,4,222,4,234,4,130,5,144,5,8,6,14,6,28,6, -55,6,140,6,142,6,207,6,142,12,201,12,233,12,0,0,157,15,0,0,29, -11,11,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,105,108,115,11,29,94,2,4, -68,35,37,112,97,114,97,109,122,11,1,20,100,101,102,97,117,108,116,45,114, -101,97,100,101,114,45,103,117,97,114,100,1,24,45,109,111,100,117,108,101,45, -104,97,115,104,45,116,97,98,108,101,45,116,97,98,108,101,71,45,112,97,116, -104,45,99,97,99,104,101,77,45,108,111,97,100,105,110,103,45,102,105,108,101, -110,97,109,101,79,45,108,111,97,100,105,110,103,45,112,114,111,109,112,116,45, -116,97,103,71,45,112,114,101,118,45,114,101,108,116,111,75,45,112,114,101,118, -45,114,101,108,116,111,45,100,105,114,1,21,115,112,108,105,116,45,114,101,108, -97,116,105,118,101,45,115,116,114,105,110,103,1,34,109,97,107,101,45,115,116, -97,110,100,97,114,100,45,109,111,100,117,108,101,45,110,97,109,101,45,114,101, -115,111,108,118,101,114,64,98,111,111,116,64,115,97,109,101,5,3,46,122,111, -64,108,111,111,112,1,29,115,116,97,110,100,97,114,100,45,109,111,100,117,108, -101,45,110,97,109,101,45,114,101,115,111,108,118,101,114,63,108,105,98,67,105, -103,110,111,114,101,100,249,22,14,195,80,158,37,45,249,80,159,37,48,36,195, -10,27,28,23,195,2,28,249,22,162,8,23,197,2,80,158,38,46,87,94,23, -195,1,80,158,36,47,27,248,22,171,4,23,197,2,28,248,22,135,13,23,194, -2,91,159,38,11,90,161,38,35,11,248,22,156,13,23,197,1,87,95,83,160, -37,11,80,158,40,46,198,83,160,37,11,80,158,40,47,192,192,11,11,28,23, -193,2,192,87,94,23,193,1,27,247,22,189,4,28,192,192,247,22,175,13,20, -14,159,80,158,35,39,250,80,158,38,40,249,22,27,11,80,158,40,39,22,189, -4,28,248,22,135,13,23,198,2,23,197,1,87,94,23,197,1,247,22,175,13, -247,194,250,22,153,13,23,197,1,23,199,1,249,80,158,42,38,23,198,1,2, -18,252,22,153,13,23,199,1,23,201,1,6,6,6,110,97,116,105,118,101,247, -22,177,7,249,80,158,44,38,23,200,1,80,158,44,35,87,94,23,194,1,27, +0,223,0,3,1,8,1,13,1,18,1,27,1,32,1,63,1,67,1,75,1, +83,1,91,1,194,1,239,1,3,2,31,2,62,2,117,2,127,2,174,2,184, +2,191,2,78,4,91,4,110,4,229,4,241,4,137,5,151,5,15,6,21,6, +35,6,62,6,147,6,149,6,214,6,149,12,208,12,240,12,0,0,164,15,0, +0,29,11,11,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,105,108,115,11,29,94, +2,4,68,35,37,112,97,114,97,109,122,11,1,20,100,101,102,97,117,108,116, +45,114,101,97,100,101,114,45,103,117,97,114,100,1,24,45,109,111,100,117,108, +101,45,104,97,115,104,45,116,97,98,108,101,45,116,97,98,108,101,71,45,112, +97,116,104,45,99,97,99,104,101,77,45,108,111,97,100,105,110,103,45,102,105, +108,101,110,97,109,101,79,45,108,111,97,100,105,110,103,45,112,114,111,109,112, +116,45,116,97,103,71,45,112,114,101,118,45,114,101,108,116,111,75,45,112,114, +101,118,45,114,101,108,116,111,45,100,105,114,1,21,115,112,108,105,116,45,114, +101,108,97,116,105,118,101,45,115,116,114,105,110,103,1,34,109,97,107,101,45, +115,116,97,110,100,97,114,100,45,109,111,100,117,108,101,45,110,97,109,101,45, +114,101,115,111,108,118,101,114,64,98,111,111,116,64,115,97,109,101,5,3,46, +122,111,6,6,6,110,97,116,105,118,101,64,108,111,111,112,1,29,115,116,97, +110,100,97,114,100,45,109,111,100,117,108,101,45,110,97,109,101,45,114,101,115, +111,108,118,101,114,63,108,105,98,67,105,103,110,111,114,101,100,249,22,14,195, +80,158,37,45,249,80,159,37,48,36,195,10,27,28,23,195,2,28,249,22,162, +8,23,197,2,80,158,38,46,87,94,23,195,1,80,158,36,47,27,248,22,171, +4,23,197,2,28,248,22,135,13,23,194,2,91,159,38,11,90,161,38,35,11, +248,22,156,13,23,197,1,87,95,83,160,37,11,80,158,40,46,198,83,160,37, +11,80,158,40,47,192,192,11,11,28,23,193,2,192,87,94,23,193,1,27,247, +22,189,4,28,192,192,247,22,175,13,20,14,159,80,158,35,39,250,80,158,38, +40,249,22,27,11,80,158,40,39,22,189,4,28,248,22,135,13,23,198,2,23, +197,1,87,94,23,197,1,247,22,175,13,247,194,250,22,153,13,23,197,1,23, +199,1,249,80,158,42,38,23,198,1,2,18,252,22,153,13,23,199,1,23,201, +1,2,19,247,22,177,7,249,80,158,44,38,23,200,1,80,158,44,35,87,94, 23,194,1,27,250,22,170,13,196,11,32,0,89,162,8,44,35,40,9,222,11, -28,192,249,22,64,195,194,11,27,248,23,195,1,23,196,1,27,250,22,170,13, +28,192,249,22,64,195,194,11,27,252,22,153,13,23,200,1,23,202,1,2,19, +247,22,177,7,249,80,158,45,38,23,201,1,80,158,45,35,27,250,22,170,13, 196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249,22,64,195,194,11, 249,247,22,180,13,248,22,65,195,195,27,250,22,153,13,23,198,1,23,200,1, 249,80,158,43,38,23,199,1,2,18,27,250,22,170,13,196,11,32,0,89,162, @@ -407,156 +408,155 @@ 249,22,160,13,23,203,1,23,195,1,200,90,161,38,36,11,248,22,156,13,23, 194,2,87,94,23,196,1,90,161,36,39,11,28,249,22,162,8,23,196,2,68, 114,101,108,97,116,105,118,101,87,94,23,194,1,2,17,23,194,1,90,161,36, -40,11,247,22,177,13,27,89,162,43,36,49,62,122,111,225,7,5,3,33,27, -27,89,162,43,36,51,9,225,8,6,4,33,28,27,249,22,5,89,162,8,44, -36,47,9,223,5,33,29,23,203,2,27,28,23,195,2,27,249,22,5,83,158, -39,20,97,94,89,162,8,44,36,47,9,223,5,33,30,23,198,1,23,205,2, -27,28,23,196,2,11,193,28,192,192,28,193,28,23,196,2,28,249,22,166,3, -248,22,66,196,248,22,66,23,199,2,193,11,11,11,87,94,23,195,1,11,28, -23,193,2,249,80,159,47,54,36,202,89,162,43,35,45,9,224,14,2,33,31, -87,94,23,193,1,27,28,23,197,1,27,249,22,5,83,158,39,20,97,94,89, -162,8,44,36,50,9,225,14,12,10,33,32,23,203,1,23,206,1,27,28,196, -11,193,28,192,192,28,193,28,196,28,249,22,166,3,248,22,66,196,248,22,66, -199,193,11,11,11,11,28,192,249,80,159,48,54,36,203,89,162,43,35,45,9, -224,15,2,33,33,249,80,159,48,54,36,203,89,162,43,35,44,9,224,15,7, -33,34,32,36,89,162,8,44,36,54,2,19,222,33,38,0,17,35,114,120,34, -94,40,46,42,63,41,47,40,46,42,41,36,34,27,249,22,185,13,2,37,23, -196,2,28,23,193,2,87,94,23,194,1,249,22,64,248,22,89,23,196,2,27, -248,22,98,23,197,1,27,249,22,185,13,2,37,23,196,2,28,23,193,2,87, -94,23,194,1,249,22,64,248,22,89,23,196,2,27,248,22,98,23,197,1,27, -249,22,185,13,2,37,23,196,2,28,23,193,2,87,94,23,194,1,249,22,64, -248,22,89,23,196,2,248,2,36,248,22,98,23,197,1,248,22,74,194,248,22, -74,194,248,22,74,194,32,39,89,162,43,36,54,2,19,222,33,40,28,248,22, -72,248,22,66,23,195,2,249,22,7,9,248,22,65,195,91,159,37,11,90,161, -37,35,11,27,248,22,66,23,197,2,28,248,22,72,248,22,66,23,195,2,249, -22,7,9,248,22,65,195,91,159,37,11,90,161,37,35,11,27,248,22,66,23, -197,2,28,248,22,72,248,22,66,23,195,2,249,22,7,9,248,22,65,195,91, -159,37,11,90,161,37,35,11,248,2,39,248,22,66,23,197,2,249,22,7,249, -22,64,248,22,65,23,200,1,23,197,1,195,249,22,7,249,22,64,248,22,65, -23,200,1,23,197,1,195,249,22,7,249,22,64,248,22,65,23,200,1,23,197, -1,195,27,248,2,36,23,195,1,28,194,192,248,2,39,193,87,95,28,248,22, -169,4,195,12,250,22,128,9,2,20,6,20,20,114,101,115,111,108,118,101,100, -45,109,111,100,117,108,101,45,112,97,116,104,197,28,24,193,2,248,24,194,1, -195,87,94,23,193,1,12,27,27,250,22,138,2,80,158,41,42,248,22,141,14, -247,22,182,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,122,87,94, -250,22,136,2,80,158,42,42,248,22,141,14,247,22,182,11,195,192,250,22,136, -2,195,198,66,97,116,116,97,99,104,251,211,197,198,199,10,28,192,250,22,191, -8,11,196,195,248,22,189,8,194,28,249,22,163,6,194,6,1,1,46,2,17, -28,249,22,163,6,194,6,2,2,46,46,62,117,112,192,28,249,22,164,8,248, -22,66,23,200,2,23,197,1,28,249,22,162,8,248,22,65,23,200,2,23,196, -1,251,22,189,8,2,20,6,26,26,99,121,99,108,101,32,105,110,32,108,111, -97,100,105,110,103,32,97,116,32,126,101,58,32,126,101,23,200,1,249,22,2, -22,66,248,22,79,249,22,64,23,206,1,23,202,1,12,12,247,192,20,14,159, -80,158,39,44,249,22,64,248,22,141,14,247,22,182,11,23,197,1,20,14,159, -80,158,39,39,250,80,158,42,40,249,22,27,11,80,158,44,39,22,151,4,23, -196,1,249,247,22,188,4,23,198,1,248,22,53,248,22,139,13,23,198,1,87, -94,28,28,248,22,135,13,23,197,2,10,248,22,175,4,23,197,2,12,28,23, -198,2,250,22,191,8,11,6,15,15,98,97,100,32,109,111,100,117,108,101,32, -112,97,116,104,23,201,2,250,22,128,9,2,20,6,19,19,109,111,100,117,108, -101,45,112,97,116,104,32,111,114,32,112,97,116,104,23,199,2,28,28,248,22, -62,23,197,2,249,22,162,8,248,22,65,23,199,2,2,4,11,248,22,170,4, -248,22,89,197,28,28,248,22,62,23,197,2,249,22,162,8,248,22,65,23,199, -2,66,112,108,97,110,101,116,11,87,94,28,207,12,20,14,159,80,158,37,39, -250,80,158,40,40,249,22,27,11,80,158,42,39,22,182,11,23,197,1,90,161, -36,35,10,249,22,152,4,21,94,2,21,6,18,18,112,108,97,110,101,116,47, -114,101,115,111,108,118,101,114,46,115,115,1,27,112,108,97,110,101,116,45,109, -111,100,117,108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114,12,251, -211,199,200,201,202,87,94,23,193,1,27,89,162,8,44,36,45,79,115,104,111, -119,45,99,111,108,108,101,99,116,105,111,110,45,101,114,114,223,6,33,44,27, -28,248,22,52,23,199,2,27,250,22,138,2,80,158,43,43,249,22,64,23,204, -2,247,22,176,13,11,28,23,193,2,192,87,94,23,193,1,91,159,37,11,90, -161,37,35,11,249,80,159,44,48,36,248,22,55,23,204,2,11,27,251,80,158, -47,50,2,20,23,202,1,28,248,22,72,23,199,2,23,199,2,248,22,65,23, -199,2,28,248,22,72,23,199,2,9,248,22,66,23,199,2,249,22,153,13,23, -195,1,28,248,22,72,23,197,1,87,94,23,197,1,6,7,7,109,97,105,110, -46,115,115,249,22,180,6,23,199,1,6,3,3,46,115,115,28,248,22,157,6, -23,199,2,87,94,23,194,1,27,248,80,159,41,55,36,23,201,2,27,250,22, -138,2,80,158,44,43,249,22,64,23,205,2,23,199,2,11,28,23,193,2,192, -87,94,23,193,1,91,159,37,11,90,161,37,35,11,249,80,159,45,48,36,23, -204,2,11,250,22,1,22,153,13,23,199,1,249,22,78,249,22,2,32,0,89, -162,8,44,36,43,9,222,33,45,23,200,1,248,22,74,23,200,1,28,248,22, -135,13,23,199,2,87,94,23,194,1,28,248,22,158,13,23,199,2,23,198,2, -248,22,74,6,26,26,32,40,97,32,112,97,116,104,32,109,117,115,116,32,98, -101,32,97,98,115,111,108,117,116,101,41,28,249,22,162,8,248,22,65,23,201, -2,2,21,27,250,22,138,2,80,158,43,43,249,22,64,23,204,2,247,22,176, -13,11,28,23,193,2,192,87,94,23,193,1,91,159,38,11,90,161,37,35,11, -249,80,159,45,48,36,248,22,89,23,205,2,11,90,161,36,37,11,28,248,22, -72,248,22,91,23,204,2,28,248,22,72,23,194,2,249,22,187,13,0,8,35, -114,120,34,91,46,93,34,23,196,2,11,10,27,27,28,23,197,2,249,22,78, -28,248,22,72,248,22,91,23,208,2,21,93,6,5,5,109,122,108,105,98,249, -22,1,22,78,249,22,2,80,159,51,56,36,248,22,91,23,211,2,23,197,2, -28,248,22,72,23,196,2,248,22,74,23,197,2,23,195,2,251,80,158,49,50, -2,20,23,204,1,248,22,65,23,198,2,248,22,66,23,198,1,249,22,153,13, -23,195,1,28,23,198,1,87,94,23,196,1,23,197,1,28,248,22,72,23,197, -1,87,94,23,197,1,6,7,7,109,97,105,110,46,115,115,28,249,22,187,13, -0,8,35,114,120,34,91,46,93,34,23,199,2,23,197,1,249,22,180,6,23, -199,1,6,3,3,46,115,115,28,249,22,162,8,248,22,65,23,201,2,64,102, -105,108,101,249,22,160,13,248,22,164,13,248,22,89,23,202,2,248,80,159,42, -55,36,23,202,2,12,87,94,28,28,248,22,135,13,23,194,2,10,248,22,179, -7,23,194,2,87,94,23,200,1,12,28,23,200,2,250,22,191,8,67,114,101, -113,117,105,114,101,249,22,141,7,6,17,17,98,97,100,32,109,111,100,117,108, -101,32,112,97,116,104,126,97,28,23,198,2,248,22,65,23,199,2,6,0,0, -23,203,1,87,94,23,200,1,250,22,128,9,2,20,249,22,141,7,6,13,13, -109,111,100,117,108,101,32,112,97,116,104,126,97,28,23,198,2,248,22,65,23, -199,2,6,0,0,23,201,2,27,28,248,22,179,7,23,195,2,249,22,184,7, -23,196,2,35,249,22,162,13,248,22,163,13,23,197,2,11,27,28,248,22,179, -7,23,196,2,249,22,184,7,23,197,2,36,248,80,158,42,51,23,195,2,91, -159,38,11,90,161,38,35,11,28,248,22,179,7,23,199,2,250,22,7,2,22, -249,22,184,7,23,203,2,37,2,22,248,22,156,13,23,198,2,87,95,23,195, -1,23,193,1,27,28,248,22,179,7,23,200,2,249,22,184,7,23,201,2,38, -249,80,158,47,52,23,197,2,5,0,27,28,248,22,179,7,23,201,2,249,22, -184,7,23,202,2,39,248,22,170,4,23,200,2,27,27,250,22,138,2,80,158, -51,42,248,22,141,14,247,22,182,11,11,28,23,193,2,192,87,94,23,193,1, -27,247,22,122,87,94,250,22,136,2,80,158,52,42,248,22,141,14,247,22,182, -11,195,192,87,95,28,23,209,1,27,250,22,138,2,23,197,2,197,11,28,23, -193,1,12,87,95,27,27,28,248,22,17,80,158,51,45,80,158,50,45,247,22, -19,250,22,25,248,22,23,23,197,2,80,158,53,44,23,196,1,27,248,22,141, -14,247,22,182,11,249,22,3,83,158,39,20,97,94,89,162,8,44,36,54,9, -226,12,11,2,3,33,46,23,195,1,23,196,1,248,28,248,22,17,80,158,50, -45,32,0,89,162,43,36,41,9,222,33,47,80,159,49,57,36,89,162,43,35, -50,9,227,14,9,8,4,3,33,48,250,22,136,2,23,197,1,197,10,12,28, -28,248,22,179,7,23,202,1,11,27,248,22,157,6,23,208,2,28,192,192,28, -248,22,62,23,208,2,249,22,162,8,248,22,65,23,210,2,2,21,11,250,22, -136,2,80,158,50,43,28,248,22,157,6,23,210,2,249,22,64,23,211,1,248, -80,159,53,55,36,23,213,1,87,94,23,210,1,249,22,64,23,211,1,247,22, -176,13,252,22,181,7,23,208,1,23,207,1,23,205,1,23,203,1,201,12,193, -91,159,37,10,90,161,36,35,10,11,90,161,36,36,10,83,158,38,20,96,96, -2,20,89,162,8,44,36,50,9,224,2,0,33,42,89,162,43,38,48,9,223, -1,33,43,89,162,43,39,8,30,9,225,2,3,0,33,49,208,87,95,248,22, -150,4,248,80,158,37,49,247,22,182,11,248,22,188,4,80,158,36,36,248,22, -173,12,80,159,36,41,36,159,35,20,103,159,35,16,1,65,98,101,103,105,110, -16,0,83,158,41,20,100,138,66,35,37,98,111,111,116,2,1,11,11,10,10, -36,80,158,35,35,20,103,159,39,16,19,30,2,1,2,2,193,30,2,1,2, -3,193,30,2,5,72,112,97,116,104,45,115,116,114,105,110,103,63,10,30,2, -5,75,112,97,116,104,45,97,100,100,45,115,117,102,102,105,120,7,30,2,6, -1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101, -121,4,30,2,6,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,30,2,1,2,7,193,30,2,1,2,8, -193,30,2,1,2,9,193,30,2,1,2,10,193,30,2,1,2,11,193,30,2, -1,2,12,193,30,2,1,2,13,193,30,2,1,2,14,193,30,2,1,2,15, -193,30,2,5,69,45,102,105,110,100,45,99,111,108,0,30,2,5,76,110,111, -114,109,97,108,45,99,97,115,101,45,112,97,116,104,6,30,2,5,79,112,97, -116,104,45,114,101,112,108,97,99,101,45,115,117,102,102,105,120,9,30,2,1, -2,16,193,16,0,11,11,16,11,2,10,2,11,2,8,2,9,2,12,2,13, -2,3,2,7,2,2,2,15,2,14,46,11,38,35,11,11,16,1,2,16,16, -1,11,16,1,2,16,36,36,36,11,11,16,0,16,0,16,0,35,35,11,11, -11,16,0,16,0,16,0,35,35,16,0,16,16,83,158,35,16,2,89,162,43, -36,44,9,223,0,33,23,80,159,35,57,36,83,158,35,16,2,89,162,43,36, -44,9,223,0,33,24,80,159,35,56,36,83,158,35,16,2,89,162,43,36,48, -67,103,101,116,45,100,105,114,223,0,33,25,80,159,35,55,36,83,158,35,16, -2,89,162,43,37,48,68,119,105,116,104,45,100,105,114,223,0,33,26,80,159, -35,54,36,83,158,35,16,2,248,22,176,7,69,115,111,45,115,117,102,102,105, -120,80,159,35,35,36,83,158,35,16,2,89,162,43,37,59,2,3,223,0,33, -35,80,159,35,36,36,83,158,35,16,2,32,0,89,162,8,44,36,41,2,7, -222,192,80,159,35,41,36,83,158,35,16,2,247,22,125,80,159,35,42,36,83, -158,35,16,2,247,22,124,80,159,35,43,36,83,158,35,16,2,247,22,60,80, -159,35,44,36,83,158,35,16,2,248,22,18,74,109,111,100,117,108,101,45,108, -111,97,100,105,110,103,80,159,35,45,36,83,158,35,16,2,11,80,158,35,46, -83,158,35,16,2,11,80,158,35,47,83,158,35,16,2,32,0,89,162,43,37, -44,2,14,222,33,41,80,159,35,48,36,83,158,35,16,2,89,162,8,44,36, -44,2,15,223,0,33,50,80,159,35,49,36,83,158,35,16,2,89,162,43,35, -43,2,16,223,0,33,51,80,159,35,53,36,95,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,9,9,9,35,0}; - EVAL_ONE_SIZED_STR((char *)expr, 4122); +40,11,247,22,177,13,27,89,162,43,36,49,62,122,111,225,7,5,3,33,28, +27,89,162,43,36,51,9,225,8,6,4,33,29,27,249,22,5,89,162,8,44, +36,46,9,223,5,33,30,23,203,2,27,28,23,195,1,27,249,22,5,89,162, +8,44,36,52,9,225,13,11,9,33,31,23,205,2,27,28,23,196,2,11,193, +28,192,192,28,193,28,23,196,2,28,249,22,166,3,248,22,66,196,248,22,66, +23,199,2,193,11,11,11,11,28,23,193,2,249,80,159,47,54,36,202,89,162, +43,35,45,9,224,14,2,33,32,87,94,23,193,1,27,28,23,197,1,27,249, +22,5,83,158,39,20,97,94,89,162,8,44,36,50,9,225,14,12,10,33,33, +23,203,1,23,206,1,27,28,196,11,193,28,192,192,28,193,28,196,28,249,22, +166,3,248,22,66,196,248,22,66,199,193,11,11,11,11,28,192,249,80,159,48, +54,36,203,89,162,43,35,45,9,224,15,2,33,34,249,80,159,48,54,36,203, +89,162,43,35,44,9,224,15,7,33,35,32,37,89,162,8,44,36,54,2,20, +222,33,39,0,17,35,114,120,34,94,40,46,42,63,41,47,40,46,42,41,36, +34,27,249,22,185,13,2,38,23,196,2,28,23,193,2,87,94,23,194,1,249, +22,64,248,22,89,23,196,2,27,248,22,98,23,197,1,27,249,22,185,13,2, +38,23,196,2,28,23,193,2,87,94,23,194,1,249,22,64,248,22,89,23,196, +2,27,248,22,98,23,197,1,27,249,22,185,13,2,38,23,196,2,28,23,193, +2,87,94,23,194,1,249,22,64,248,22,89,23,196,2,248,2,37,248,22,98, +23,197,1,248,22,74,194,248,22,74,194,248,22,74,194,32,40,89,162,43,36, +54,2,20,222,33,41,28,248,22,72,248,22,66,23,195,2,249,22,7,9,248, +22,65,195,91,159,37,11,90,161,37,35,11,27,248,22,66,23,197,2,28,248, +22,72,248,22,66,23,195,2,249,22,7,9,248,22,65,195,91,159,37,11,90, +161,37,35,11,27,248,22,66,23,197,2,28,248,22,72,248,22,66,23,195,2, +249,22,7,9,248,22,65,195,91,159,37,11,90,161,37,35,11,248,2,40,248, +22,66,23,197,2,249,22,7,249,22,64,248,22,65,23,200,1,23,197,1,195, +249,22,7,249,22,64,248,22,65,23,200,1,23,197,1,195,249,22,7,249,22, +64,248,22,65,23,200,1,23,197,1,195,27,248,2,37,23,195,1,28,194,192, +248,2,40,193,87,95,28,248,22,169,4,195,12,250,22,128,9,2,21,6,20, +20,114,101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97,116,104, +197,28,24,193,2,248,24,194,1,195,87,94,23,193,1,12,27,27,250,22,138, +2,80,158,41,42,248,22,141,14,247,22,182,11,11,28,23,193,2,192,87,94, +23,193,1,27,247,22,122,87,94,250,22,136,2,80,158,42,42,248,22,141,14, +247,22,182,11,195,192,250,22,136,2,195,198,66,97,116,116,97,99,104,251,211, +197,198,199,10,28,192,250,22,191,8,11,196,195,248,22,189,8,194,28,249,22, +163,6,194,6,1,1,46,2,17,28,249,22,163,6,194,6,2,2,46,46,62, +117,112,192,28,249,22,164,8,248,22,66,23,200,2,23,197,1,28,249,22,162, +8,248,22,65,23,200,2,23,196,1,251,22,189,8,2,21,6,26,26,99,121, +99,108,101,32,105,110,32,108,111,97,100,105,110,103,32,97,116,32,126,101,58, +32,126,101,23,200,1,249,22,2,22,66,248,22,79,249,22,64,23,206,1,23, +202,1,12,12,247,192,20,14,159,80,158,39,44,249,22,64,248,22,141,14,247, +22,182,11,23,197,1,20,14,159,80,158,39,39,250,80,158,42,40,249,22,27, +11,80,158,44,39,22,151,4,23,196,1,249,247,22,188,4,23,198,1,248,22, +53,248,22,139,13,23,198,1,87,94,28,28,248,22,135,13,23,197,2,10,248, +22,175,4,23,197,2,12,28,23,198,2,250,22,191,8,11,6,15,15,98,97, +100,32,109,111,100,117,108,101,32,112,97,116,104,23,201,2,250,22,128,9,2, +21,6,19,19,109,111,100,117,108,101,45,112,97,116,104,32,111,114,32,112,97, +116,104,23,199,2,28,28,248,22,62,23,197,2,249,22,162,8,248,22,65,23, +199,2,2,4,11,248,22,170,4,248,22,89,197,28,28,248,22,62,23,197,2, +249,22,162,8,248,22,65,23,199,2,66,112,108,97,110,101,116,11,87,94,28, +207,12,20,14,159,80,158,37,39,250,80,158,40,40,249,22,27,11,80,158,42, +39,22,182,11,23,197,1,90,161,36,35,10,249,22,152,4,21,94,2,22,6, +18,18,112,108,97,110,101,116,47,114,101,115,111,108,118,101,114,46,115,115,1, +27,112,108,97,110,101,116,45,109,111,100,117,108,101,45,110,97,109,101,45,114, +101,115,111,108,118,101,114,12,251,211,199,200,201,202,87,94,23,193,1,27,89, +162,8,44,36,45,79,115,104,111,119,45,99,111,108,108,101,99,116,105,111,110, +45,101,114,114,223,6,33,45,27,28,248,22,52,23,199,2,27,250,22,138,2, +80,158,43,43,249,22,64,23,204,2,247,22,176,13,11,28,23,193,2,192,87, +94,23,193,1,91,159,37,11,90,161,37,35,11,249,80,159,44,48,36,248,22, +55,23,204,2,11,27,251,80,158,47,50,2,21,23,202,1,28,248,22,72,23, +199,2,23,199,2,248,22,65,23,199,2,28,248,22,72,23,199,2,9,248,22, +66,23,199,2,249,22,153,13,23,195,1,28,248,22,72,23,197,1,87,94,23, +197,1,6,7,7,109,97,105,110,46,115,115,249,22,180,6,23,199,1,6,3, +3,46,115,115,28,248,22,157,6,23,199,2,87,94,23,194,1,27,248,80,159, +41,55,36,23,201,2,27,250,22,138,2,80,158,44,43,249,22,64,23,205,2, +23,199,2,11,28,23,193,2,192,87,94,23,193,1,91,159,37,11,90,161,37, +35,11,249,80,159,45,48,36,23,204,2,11,250,22,1,22,153,13,23,199,1, +249,22,78,249,22,2,32,0,89,162,8,44,36,43,9,222,33,46,23,200,1, +248,22,74,23,200,1,28,248,22,135,13,23,199,2,87,94,23,194,1,28,248, +22,158,13,23,199,2,23,198,2,248,22,74,6,26,26,32,40,97,32,112,97, +116,104,32,109,117,115,116,32,98,101,32,97,98,115,111,108,117,116,101,41,28, +249,22,162,8,248,22,65,23,201,2,2,22,27,250,22,138,2,80,158,43,43, +249,22,64,23,204,2,247,22,176,13,11,28,23,193,2,192,87,94,23,193,1, +91,159,38,11,90,161,37,35,11,249,80,159,45,48,36,248,22,89,23,205,2, +11,90,161,36,37,11,28,248,22,72,248,22,91,23,204,2,28,248,22,72,23, +194,2,249,22,187,13,0,8,35,114,120,34,91,46,93,34,23,196,2,11,10, +27,27,28,23,197,2,249,22,78,28,248,22,72,248,22,91,23,208,2,21,93, +6,5,5,109,122,108,105,98,249,22,1,22,78,249,22,2,80,159,51,56,36, +248,22,91,23,211,2,23,197,2,28,248,22,72,23,196,2,248,22,74,23,197, +2,23,195,2,251,80,158,49,50,2,21,23,204,1,248,22,65,23,198,2,248, +22,66,23,198,1,249,22,153,13,23,195,1,28,23,198,1,87,94,23,196,1, +23,197,1,28,248,22,72,23,197,1,87,94,23,197,1,6,7,7,109,97,105, +110,46,115,115,28,249,22,187,13,0,8,35,114,120,34,91,46,93,34,23,199, +2,23,197,1,249,22,180,6,23,199,1,6,3,3,46,115,115,28,249,22,162, +8,248,22,65,23,201,2,64,102,105,108,101,249,22,160,13,248,22,164,13,248, +22,89,23,202,2,248,80,159,42,55,36,23,202,2,12,87,94,28,28,248,22, +135,13,23,194,2,10,248,22,179,7,23,194,2,87,94,23,200,1,12,28,23, +200,2,250,22,191,8,67,114,101,113,117,105,114,101,249,22,141,7,6,17,17, +98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,126,97,28,23,198,2, +248,22,65,23,199,2,6,0,0,23,203,1,87,94,23,200,1,250,22,128,9, +2,21,249,22,141,7,6,13,13,109,111,100,117,108,101,32,112,97,116,104,126, +97,28,23,198,2,248,22,65,23,199,2,6,0,0,23,201,2,27,28,248,22, +179,7,23,195,2,249,22,184,7,23,196,2,35,249,22,162,13,248,22,163,13, +23,197,2,11,27,28,248,22,179,7,23,196,2,249,22,184,7,23,197,2,36, +248,80,158,42,51,23,195,2,91,159,38,11,90,161,38,35,11,28,248,22,179, +7,23,199,2,250,22,7,2,23,249,22,184,7,23,203,2,37,2,23,248,22, +156,13,23,198,2,87,95,23,195,1,23,193,1,27,28,248,22,179,7,23,200, +2,249,22,184,7,23,201,2,38,249,80,158,47,52,23,197,2,5,0,27,28, +248,22,179,7,23,201,2,249,22,184,7,23,202,2,39,248,22,170,4,23,200, +2,27,27,250,22,138,2,80,158,51,42,248,22,141,14,247,22,182,11,11,28, +23,193,2,192,87,94,23,193,1,27,247,22,122,87,94,250,22,136,2,80,158, +52,42,248,22,141,14,247,22,182,11,195,192,87,95,28,23,209,1,27,250,22, +138,2,23,197,2,197,11,28,23,193,1,12,87,95,27,27,28,248,22,17,80, +158,51,45,80,158,50,45,247,22,19,250,22,25,248,22,23,23,197,2,80,158, +53,44,23,196,1,27,248,22,141,14,247,22,182,11,249,22,3,83,158,39,20, +97,94,89,162,8,44,36,54,9,226,12,11,2,3,33,47,23,195,1,23,196, +1,248,28,248,22,17,80,158,50,45,32,0,89,162,43,36,41,9,222,33,48, +80,159,49,57,36,89,162,43,35,50,9,227,14,9,8,4,3,33,49,250,22, +136,2,23,197,1,197,10,12,28,28,248,22,179,7,23,202,1,11,27,248,22, +157,6,23,208,2,28,192,192,28,248,22,62,23,208,2,249,22,162,8,248,22, +65,23,210,2,2,22,11,250,22,136,2,80,158,50,43,28,248,22,157,6,23, +210,2,249,22,64,23,211,1,248,80,159,53,55,36,23,213,1,87,94,23,210, +1,249,22,64,23,211,1,247,22,176,13,252,22,181,7,23,208,1,23,207,1, +23,205,1,23,203,1,201,12,193,91,159,37,10,90,161,36,35,10,11,90,161, +36,36,10,83,158,38,20,96,96,2,21,89,162,8,44,36,50,9,224,2,0, +33,43,89,162,43,38,48,9,223,1,33,44,89,162,43,39,8,30,9,225,2, +3,0,33,50,208,87,95,248,22,150,4,248,80,158,37,49,247,22,182,11,248, +22,188,4,80,158,36,36,248,22,173,12,80,159,36,41,36,159,35,20,103,159, +35,16,1,65,98,101,103,105,110,16,0,83,158,41,20,100,138,66,35,37,98, +111,111,116,2,1,11,11,10,10,36,80,158,35,35,20,103,159,39,16,19,30, +2,1,2,2,193,30,2,1,2,3,193,30,2,5,72,112,97,116,104,45,115, +116,114,105,110,103,63,10,30,2,5,75,112,97,116,104,45,97,100,100,45,115, +117,102,102,105,120,7,30,2,6,1,20,112,97,114,97,109,101,116,101,114,105, +122,97,116,105,111,110,45,107,101,121,4,30,2,6,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,30,2, +1,2,7,193,30,2,1,2,8,193,30,2,1,2,9,193,30,2,1,2,10, +193,30,2,1,2,11,193,30,2,1,2,12,193,30,2,1,2,13,193,30,2, +1,2,14,193,30,2,1,2,15,193,30,2,5,69,45,102,105,110,100,45,99, +111,108,0,30,2,5,76,110,111,114,109,97,108,45,99,97,115,101,45,112,97, +116,104,6,30,2,5,79,112,97,116,104,45,114,101,112,108,97,99,101,45,115, +117,102,102,105,120,9,30,2,1,2,16,193,16,0,11,11,16,11,2,10,2, +11,2,8,2,9,2,12,2,13,2,3,2,7,2,2,2,15,2,14,46,11, +38,35,11,11,16,1,2,16,16,1,11,16,1,2,16,36,36,36,11,11,16, +0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16, +16,83,158,35,16,2,89,162,43,36,44,9,223,0,33,24,80,159,35,57,36, +83,158,35,16,2,89,162,43,36,44,9,223,0,33,25,80,159,35,56,36,83, +158,35,16,2,89,162,43,36,48,67,103,101,116,45,100,105,114,223,0,33,26, +80,159,35,55,36,83,158,35,16,2,89,162,43,37,48,68,119,105,116,104,45, +100,105,114,223,0,33,27,80,159,35,54,36,83,158,35,16,2,248,22,176,7, +69,115,111,45,115,117,102,102,105,120,80,159,35,35,36,83,158,35,16,2,89, +162,43,37,59,2,3,223,0,33,36,80,159,35,36,36,83,158,35,16,2,32, +0,89,162,8,44,36,41,2,7,222,192,80,159,35,41,36,83,158,35,16,2, +247,22,125,80,159,35,42,36,83,158,35,16,2,247,22,124,80,159,35,43,36, +83,158,35,16,2,247,22,60,80,159,35,44,36,83,158,35,16,2,248,22,18, +74,109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159,35,45,36,83, +158,35,16,2,11,80,158,35,46,83,158,35,16,2,11,80,158,35,47,83,158, +35,16,2,32,0,89,162,43,37,44,2,14,222,33,42,80,159,35,48,36,83, +158,35,16,2,89,162,8,44,36,44,2,15,223,0,33,51,80,159,35,49,36, +83,158,35,16,2,89,162,43,35,43,2,16,223,0,33,52,80,159,35,53,36, +95,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,9,9,9,35,0}; + EVAL_ONE_SIZED_STR((char *)expr, 4131); } diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 7c64c50239..75bcbcd3b0 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -96,6 +96,9 @@ static Scheme_Object *local_exp_time_name(int argc, Scheme_Object *argv[]); static Scheme_Object *local_context(int argc, Scheme_Object *argv[]); static Scheme_Object *local_phase_level(int argc, Scheme_Object *argv[]); static Scheme_Object *local_make_intdef_context(int argc, Scheme_Object *argv[]); +static Scheme_Object *intdef_context_seal(int argc, Scheme_Object *argv[]); +static Scheme_Object *intdef_context_p(int argc, Scheme_Object *argv[]); +static Scheme_Object *id_intdef_remove(int argc, Scheme_Object *argv[]); static Scheme_Object *local_introduce(int argc, Scheme_Object *argv[]); static Scheme_Object *local_module_introduce(int argc, Scheme_Object *argv[]); static Scheme_Object *local_get_shadower(int argc, Scheme_Object *argv[]); @@ -108,6 +111,7 @@ static Scheme_Object *local_lift_expr(int argc, Scheme_Object *argv[]); static Scheme_Object *local_lift_context(int argc, Scheme_Object *argv[]); static Scheme_Object *local_lift_end_statement(int argc, Scheme_Object *argv[]); static Scheme_Object *make_introducer(int argc, Scheme_Object *argv[]); +static Scheme_Object *local_make_delta_introduce(int argc, Scheme_Object *argv[]); static Scheme_Object *make_set_transformer(int argc, Scheme_Object *argv[]); static Scheme_Object *set_transformer_p(int argc, Scheme_Object *argv[]); static Scheme_Object *set_transformer_proc(int argc, Scheme_Object *argv[]); @@ -510,10 +514,15 @@ static void make_kernel_env(void) GLOBAL_PRIM_W_ARITY("syntax-local-context", local_context, 0, 0, env); GLOBAL_PRIM_W_ARITY("syntax-local-phase-level", local_phase_level, 0, 0, env); GLOBAL_PRIM_W_ARITY("syntax-local-make-definition-context", local_make_intdef_context, 0, 0, env); + GLOBAL_PRIM_W_ARITY("internal-definition-context-seal", intdef_context_seal, 1, 1, env); + GLOBAL_PRIM_W_ARITY("internal-definition-context?", intdef_context_p, 1, 1, env); + GLOBAL_PRIM_W_ARITY("identifier-remove-from-definition-context", id_intdef_remove, 2, 2, env); GLOBAL_PRIM_W_ARITY("syntax-local-get-shadower", local_get_shadower, 1, 1, env); GLOBAL_PRIM_W_ARITY("syntax-local-introduce", local_introduce, 1, 1, env); GLOBAL_PRIM_W_ARITY("make-syntax-introducer", make_introducer, 0, 1, env); + GLOBAL_PRIM_W_ARITY("syntax-local-make-delta-introducer", local_make_delta_introduce, 1, 1, env); GLOBAL_PRIM_W_ARITY("syntax-local-certifier", local_certify, 0, 1, env); + GLOBAL_PRIM_W_ARITY("syntax-local-module-exports", local_module_exports, 1, 1, env); GLOBAL_PRIM_W_ARITY("syntax-local-module-defined-identifiers", local_module_definitions, 0, 0, env); GLOBAL_PRIM_W_ARITY("syntax-local-module-required-identifiers", local_module_imports, 2, 2, env); @@ -523,7 +532,7 @@ static void make_kernel_env(void) GLOBAL_PRIM_W_ARITY("set!-transformer?", set_transformer_p, 1, 1, env); GLOBAL_PRIM_W_ARITY("set!-transformer-procedure", set_transformer_proc, 1, 1, env); - GLOBAL_PRIM_W_ARITY("make-rename-transformer", make_rename_transformer, 1, 1, env); + GLOBAL_PRIM_W_ARITY("make-rename-transformer", make_rename_transformer, 1, 2, env); GLOBAL_PRIM_W_ARITY("rename-transformer?", rename_transformer_p, 1, 1, env); GLOBAL_PRIM_W_ARITY("rename-transformer-target", rename_transformer_target, 1, 1, env); @@ -2525,6 +2534,17 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, } } + if (_lexical_binding_id) { + if (!(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) + val = scheme_stx_remove_extra_marks(find_id, COMPILE_DATA(frame)->const_names[i], + ((frame->flags & SCHEME_CAPTURE_LIFTED) + ? NULL + : uid)); + else + val = find_id; + *_lexical_binding_id = val; + } + val = COMPILE_DATA(frame)->const_vals[i]; if (!val) { @@ -4230,6 +4250,38 @@ local_make_intdef_context(int argc, Scheme_Object *argv[]) return c; } +static Scheme_Object * +intdef_context_p(int argc, Scheme_Object *argv[]) +{ + return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_intdef_context_type) + ? scheme_true + : scheme_false); +} + +static Scheme_Object *intdef_context_seal(int argc, Scheme_Object *argv[]) +{ + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_intdef_context_type)) + scheme_wrong_type("internal-definition-context-seal", + "internal-definition context", 0, argc, argv); + + scheme_stx_seal_rib(SCHEME_PTR2_VAL(argv[0])); + return scheme_void; +} + +static Scheme_Object * +id_intdef_remove(int argc, Scheme_Object *argv[]) +{ + if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) + scheme_wrong_type("identifier-from-from-definition-context", + "syntax identifier", 0, argc, argv); + + if (!SAME_TYPE(SCHEME_TYPE(argv[1]), scheme_intdef_context_type)) + scheme_wrong_type("identifier-remove-from-definition-context", + "internal-definition context", 1, argc, argv); + + return scheme_stx_id_remove_rib(argv[0], SCHEME_PTR2_VAL(argv[1])); +} + static Scheme_Object * local_introduce(int argc, Scheme_Object *argv[]) { @@ -4332,7 +4384,7 @@ local_get_shadower(int argc, Scheme_Object *argv[]) SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i]))) { esym = COMPILE_DATA(frame)->const_names[i]; env_marks = scheme_stx_extract_marks(esym); - if (scheme_equal(env_marks, sym_marks)) { + if (1 || scheme_equal(env_marks, sym_marks)) { sym = esym; if (COMPILE_DATA(frame)->const_uids) { uid = COMPILE_DATA(frame)->const_uids[i]; @@ -4348,9 +4400,9 @@ local_get_shadower(int argc, Scheme_Object *argv[]) } if (!uid) { - /* No lexical shadower, but strip module context and mark barriers, if any. */ + /* No lexical shadower, but strip module context, if any */ sym = scheme_stx_strip_module_context(sym); - /* Add current module context, if any. */ + /* Add current module context, if any */ sym = local_module_introduce(1, &sym); return sym; } @@ -4364,7 +4416,9 @@ local_get_shadower(int argc, Scheme_Object *argv[]) rn = scheme_make_rename(uid, 1); scheme_set_rename(rn, 0, result); - return scheme_add_rename(result, rn); + result = scheme_add_rename(result, rn); + + return result; } } @@ -4391,6 +4445,115 @@ make_introducer(int argc, Scheme_Object *argv[]) "syntax-introducer", 1, 1); } +static Scheme_Object * +delta_introducer_proc(void *_i_plus_m, int argc, Scheme_Object *argv[]) +{ + Scheme_Object *p = (Scheme_Object *)_i_plus_m, *l, *v, *a[1]; + const char *who = "delta introducer attached to a rename transformer"; + + v = argv[0]; + if (!SCHEME_STXP(v) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(v))) { + scheme_wrong_type(who, "identifier", 0, argc, argv); + } + + /* Apply mapping functions: */ + l = SCHEME_CDR(p); + while (SCHEME_PAIRP(l)) { + a[0] = v; + v = _scheme_apply(SCHEME_CAR(l), 1, a); + l = SCHEME_CDR(l); + } + + /* Apply delta-introducing functions: */ + l = SCHEME_CAR(p); + while (SCHEME_PAIRP(l)) { + a[0] = v; + v = _scheme_apply(SCHEME_CAR(l), 1, a); + if (!SCHEME_STXP(v) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(v))) { + a[0] = v; + scheme_wrong_type(who, "identifier", -1, -1, a); + } + l = SCHEME_CDR(l); + } + + return v; +} + +static Scheme_Object * +local_make_delta_introduce(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *sym, *binder, *introducer, *a[2], *v; + Scheme_Object *introducers = scheme_null, *mappers = scheme_null; + int renamed = 0; + Scheme_Comp_Env *env; + + env = scheme_current_thread->current_local_env; + if (!env) + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "syntax-local-make-delta-introducer: not currently transforming"); + + if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) + scheme_wrong_type("syntax-local-make-delta-introducer", "syntax identifier", 0, argc, argv); + + sym = argv[0]; + + sym = scheme_stx_activate_certs(sym); + + while (1) { + binder = NULL; + + v = scheme_lookup_binding(sym, env, + (SCHEME_NULL_FOR_UNBOUND + + SCHEME_RESOLVE_MODIDS + + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK + + SCHEME_OUT_OF_CONTEXT_OK + SCHEME_ELIM_CONST), + scheme_current_thread->current_local_certs, + scheme_current_thread->current_local_modidx, + NULL, NULL, &binder); + + /* Deref globals */ + if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_variable_type)) + v = (Scheme_Object *)(SCHEME_VAR_BUCKET(v))->val; + + if (!v || NOT_SAME_TYPE(SCHEME_TYPE(v), scheme_macro_type)) { + scheme_arg_mismatch("syntax-local-make-delta-introducer", + (renamed + ? "not defined as syntax (after renaming): " + : "not defined as syntax: "), + argv[0]); + } + + if (!binder) { + /* Not a lexical biding, so use empty id */ + binder = scheme_datum_to_syntax(scheme_intern_symbol("no-binder"), + scheme_false, scheme_false, 1, 0); + } + + a[0] = sym; + a[1] = binder; + introducer = scheme_syntax_make_transfer_intro(2, a); + introducers = scheme_make_pair(introducer, introducers); + + v = SCHEME_PTR_VAL(v); + if (SAME_TYPE(SCHEME_TYPE(v), scheme_id_macro_type)) { + sym = SCHEME_PTR1_VAL(v); + + v = SCHEME_PTR2_VAL(v); + if (!SCHEME_FALSEP(v)) + mappers = scheme_make_pair(v, mappers); + + renamed = 1; + SCHEME_USE_FUEL(1); + } else { + /* that's the end of the chain */ + mappers = scheme_reverse(mappers); + return scheme_make_closed_prim_w_arity(delta_introducer_proc, + scheme_make_pair(introducers, mappers), + "syntax-delta-introducer", 1, 1); + } + } +} + static Scheme_Object * certifier(void *_data, int argc, Scheme_Object **argv) { @@ -4689,9 +4852,13 @@ make_rename_transformer(int argc, Scheme_Object *argv[]) if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) scheme_wrong_type("make-rename-transformer", "syntax identifier", 0, argc, argv); - v = scheme_alloc_small_object(); + if (argc > 1) + scheme_check_proc_arity("make-rename-transformer", 1, 1, argc, argv); + + v = scheme_alloc_object(); v->type = scheme_id_macro_type; - SCHEME_PTR_VAL(v) = argv[0]; + SCHEME_PTR1_VAL(v) = argv[0]; + SCHEME_PTR2_VAL(v) = ((argc > 1) ? argv[1] : scheme_false); return v; } diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index ad1973066c..859f21deea 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -6453,6 +6453,7 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, if (!more) { /* We've converted to a letrec or letrec-values+syntaxes */ + scheme_stx_seal_rib(rib); rec[drec].env_already = 1; if (rec[drec].comp) { @@ -6473,6 +6474,8 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, } } + scheme_stx_seal_rib(rib); + if (rec[drec].comp) { Scheme_Object *vname, *rest; @@ -9535,6 +9538,11 @@ local_eval(int argc, Scheme_Object **argv) stx_env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(argv[2]); rib = SCHEME_PTR2_VAL(argv[2]); + + if (scheme_stx_is_rib_sealed(rib)) { + scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-bind-syntaxes: given " + "internal-definition context has been sealed"); + } if (!scheme_is_sub_env(stx_env, env)) { scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-bind-syntaxes: transforming context does " diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index df3bae8b96..d6f5546903 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -5184,6 +5184,8 @@ static int lex_rib_SIZE(void *p) { static int lex_rib_MARK(void *p) { Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)p; gcMARK(rib->rename); + gcMARK(rib->timestamp); + gcMARK(rib->sealed); gcMARK(rib->next); return gcBYTES_TO_WORDS(sizeof(Scheme_Lexical_Rib)); @@ -5192,6 +5194,8 @@ static int lex_rib_MARK(void *p) { static int lex_rib_FIXUP(void *p) { Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)p; gcFIXUP(rib->rename); + gcFIXUP(rib->timestamp); + gcFIXUP(rib->sealed); gcFIXUP(rib->next); return gcBYTES_TO_WORDS(sizeof(Scheme_Lexical_Rib)); diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index fcf503e2c0..abf1066285 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -2118,6 +2118,8 @@ lex_rib { mark: Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)p; gcMARK(rib->rename); + gcMARK(rib->timestamp); + gcMARK(rib->sealed); gcMARK(rib->next); size: gcBYTES_TO_WORDS(sizeof(Scheme_Lexical_Rib)); diff --git a/src/mzscheme/src/schminc.h b/src/mzscheme/src/schminc.h index 468bba7d2c..40e1023314 100644 --- a/src/mzscheme/src/schminc.h +++ b/src/mzscheme/src/schminc.h @@ -13,7 +13,7 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 938 +#define EXPECTED_PRIM_COUNT 942 #ifdef MZSCHEME_SOMETHING_OMITTED # undef USE_COMPILED_STARTUP diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 8cff95e5c6..6e93798b60 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -720,6 +720,9 @@ void scheme_set_rename(Scheme_Object *rnm, int pos, Scheme_Object *oldname); Scheme_Object *scheme_make_rename_rib(void); void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename); void scheme_drop_first_rib_rename(Scheme_Object *ro); +Scheme_Object *scheme_stx_id_remove_rib(Scheme_Object *stx, Scheme_Object *ro); +void scheme_stx_seal_rib(Scheme_Object *rib); +int scheme_stx_is_rib_sealed(Scheme_Object *rib); Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename); Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib); @@ -727,6 +730,8 @@ Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib); Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *o, Scheme_Object *relative_to, Scheme_Object *uid); +Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv); + #define mzMOD_RENAME_TOPLEVEL 0 #define mzMOD_RENAME_NORMAL 1 #define mzMOD_RENAME_MARKED 2 diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 809edc18dd..d53c03204c 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.3.1" +#define MZSCHEME_VERSION "4.1.3.2" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 3 -#define MZSCHEME_VERSION_W 1 +#define MZSCHEME_VERSION_W 2 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index e24d1a87dd..6aa53457e7 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -55,7 +55,6 @@ static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv); static Scheme_Object *syntax_property(int argc, Scheme_Object **argv); static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv); static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_transfer_intro(int argc, Scheme_Object **argv); static Scheme_Object *bound_eq(int argc, Scheme_Object **argv); static Scheme_Object *module_eq(int argc, Scheme_Object **argv); @@ -198,6 +197,7 @@ typedef struct Scheme_Lexical_Rib { Scheme_Object so; Scheme_Object *rename; /* a vector for a lexical rename */ Scheme_Object *timestamp; + int *sealed; struct Scheme_Lexical_Rib *next; } Scheme_Lexical_Rib; @@ -226,7 +226,7 @@ static Module_Renames *krn; - A wrap-elem (vector ... ...) is also a lexical rename var resolved where the variables have already been resolved and filtered (no mark - comparison needed with the remaining wraps) + or lexical-env comparison needed with the remaining wraps) - A wrap-elem (make-rib vector rib) is an extensible set of lexical renames; it is the same as @@ -454,9 +454,9 @@ void scheme_init_stx(Scheme_Env *env) env); scheme_add_global_constant("make-syntax-delta-introducer", - scheme_make_immed_prim(syntax_transfer_intro, + scheme_make_immed_prim(scheme_syntax_make_transfer_intro, "make-syntax-delta-introducer", - 2, 2), + 2, 3), env); scheme_add_global_constant("bound-identifier=?", @@ -1038,11 +1038,16 @@ void scheme_set_rename(Scheme_Object *rnm, int pos, Scheme_Object *oldname) Scheme_Object *scheme_make_rename_rib() { Scheme_Lexical_Rib *rib; + int *sealed; rib = MALLOC_ONE_TAGGED(Scheme_Lexical_Rib); rib->so.type = scheme_lexical_rib_type; rib->timestamp = current_rib_timestamp; + sealed = (int *)scheme_malloc_atomic(sizeof(int)); + *sealed = 0; + rib->sealed = sealed; + current_rib_timestamp = scheme_add1(1, ¤t_rib_timestamp); return (Scheme_Object *)rib; @@ -1061,6 +1066,7 @@ void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename) rib->next = naya; naya->timestamp = rib->timestamp; + naya->sealed = rib->sealed; } void scheme_drop_first_rib_rename(Scheme_Object *ro) @@ -1069,6 +1075,68 @@ void scheme_drop_first_rib_rename(Scheme_Object *ro) rib->next = rib->next->next; } +void scheme_stx_seal_rib(Scheme_Object *rib) +{ + *((Scheme_Lexical_Rib *)rib)->sealed = 1; +} + +int scheme_stx_is_rib_sealed(Scheme_Object *rib) +{ + return *((Scheme_Lexical_Rib *)rib)->sealed; +} + +Scheme_Object *scheme_stx_id_remove_rib(Scheme_Object *stx, Scheme_Object *ro) +{ + Scheme_Object *v; + int count = 0, rib_count = 0; + WRAP_POS awl; + Wrap_Chunk *wc; + Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)ro, *rib2; + + WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); + while (!WRAP_POS_END_P(awl)) { + count++; + v = WRAP_POS_FIRST(awl); + if (SCHEME_RIBP(v)) { + rib2 = (Scheme_Lexical_Rib *)v; + if (SAME_OBJ(rib2->timestamp, rib->timestamp)) + rib_count++; + } + WRAP_POS_INC(awl); + } + + if (!rib_count) + return stx; + + count -= rib_count; + + wc = MALLOC_WRAP_CHUNK(count); + wc->type = scheme_wrap_chunk_type; + wc->len = count; + + count = 0; + WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); + while (!WRAP_POS_END_P(awl)) { + v = WRAP_POS_FIRST(awl); + if (SCHEME_RIBP(v)) { + rib2 = (Scheme_Lexical_Rib *)v; + if (SAME_OBJ(rib2->timestamp, rib->timestamp)) + v = NULL; + } + if (v) { + wc->a[count++] = v; + } + WRAP_POS_INC(awl); + } + + v = scheme_make_pair((Scheme_Object *)wc, scheme_null); + + stx = scheme_add_rename(stx, scheme_make_integer(0)); + ((Scheme_Stx *)stx)->wraps = v; + + return stx; +} + /******************** module renames ********************/ static int same_phase(Scheme_Object *a, Scheme_Object *b) @@ -3363,7 +3431,8 @@ static int explain_resolves = 0; static Scheme_Object *resolve_env(WRAP_POS *_wraps, Scheme_Object *a, Scheme_Object *orig_phase, int w_mod, Scheme_Object **get_names, - Scheme_Object *skip_ribs, int *_binding_marks_skipped) + Scheme_Object *skip_ribs, int *_binding_marks_skipped, + int *_depends_on_unsealed_rib, int depth) /* Module binding ignored if w_mod is 0. If module bound, result is module idx, and get_names[0] is set to source name, get_names[1] is set to the nominal source module, get_names[2] is set to @@ -3385,9 +3454,10 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, Scheme_Object *bdg = NULL, *floating = NULL; Scheme_Hash_Table *export_registry = NULL; int mresult_skipped = 0; + int depends_on_unsealed_rib = 0; - EXPLAIN(printf("Resolving %s [skips: %s]:\n", SCHEME_SYM_VAL(SCHEME_STX_VAL(a)), - scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL))); + EXPLAIN(fprintf(stderr, "%d Resolving %s [skips: %s]:\n", depth, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)), + scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL))); if (_wraps) { WRAP_POS_COPY(wraps, *_wraps); @@ -3401,17 +3471,17 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, Scheme_Object *result, *key; int did_lexical = 0; - EXPLAIN(printf("Rename...\n")); + EXPLAIN(fprintf(stderr, "%d Rename...\n", depth)); result = scheme_false; while (!SCHEME_NULLP(o_rename_stack)) { key = SCHEME_CAAR(o_rename_stack); if (SAME_OBJ(key, result)) { - EXPLAIN(printf("Match %s\n", scheme_write_to_string(key, 0))); + EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0))); did_lexical = 1; result = SCHEME_CDR(SCHEME_CAR(o_rename_stack)); } else { - EXPLAIN(printf("No match %s\n", scheme_write_to_string(key, 0))); + EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0))); if (SAME_OBJ(key, scheme_true)) { /* marks a module-level renaming that overrides lexical renaming */ did_lexical = 0; @@ -3422,11 +3492,11 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, while (stack_pos) { key = rename_stack[stack_pos - 1]; if (SAME_OBJ(key, result)) { - EXPLAIN(printf("Match %s\n", scheme_write_to_string(key, 0))); + EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0))); result = rename_stack[stack_pos - 2]; did_lexical = 1; } else { - EXPLAIN(printf("No match %s\n", scheme_write_to_string(key, 0))); + EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0))); if (SAME_OBJ(key, scheme_true)) { /* marks a module-level renaming that overrides lexical renaming */ did_lexical = 0; @@ -3441,7 +3511,10 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } else if (get_names) get_names[0] = scheme_undefined; - EXPLAIN(printf("Result: %s\n", scheme_write_to_string(result, 0))); + if (_depends_on_unsealed_rib) + *_depends_on_unsealed_rib = depends_on_unsealed_rib; + + EXPLAIN(fprintf(stderr, "%d Result: %s\n", depth, scheme_write_to_string(result, 0))); return result; } else if ((SCHEME_RENAMESP(WRAP_POS_FIRST(wraps)) @@ -3451,7 +3524,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, Module_Renames *mrn; int skipped; - EXPLAIN(printf("Rename/set\n")); + EXPLAIN(fprintf(stderr, "%d Rename/set\n", depth)); if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps))) { mrn = (Module_Renames *)WRAP_POS_FIRST(wraps); @@ -3467,7 +3540,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, if (mrn && (!is_in_module || (mrn->kind != mzMOD_RENAME_TOPLEVEL)) && !skip_other_mods) { - EXPLAIN(printf(" use rename %p %d\n", mrn->phase, mrn->kind)); + EXPLAIN(fprintf(stderr, "%d use rename %p %d\n", depth, mrn->phase, mrn->kind)); if (mrn->kind != mzMOD_RENAME_TOPLEVEL) is_in_module = 1; @@ -3482,7 +3555,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, if (mrn->marked_names) { /* Resolve based on rest of wraps: */ if (!bdg) { - bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, skip_ribs, NULL); + bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, skip_ribs, NULL, NULL, depth+1); if (SCHEME_FALSEP(bdg)) { if (!floating_checked) { floating = check_floating_id(a); @@ -3509,7 +3582,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, glob_id = SCHEME_STX_VAL(a); } - EXPLAIN(printf(" search %s\n", scheme_write_to_string(glob_id, 0))); + EXPLAIN(fprintf(stderr, "%d search %s\n", depth, scheme_write_to_string(glob_id, 0))); rename = scheme_hash_get(mrn->ht, glob_id); if (!rename && mrn->nomarshal_ht) @@ -3525,7 +3598,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, get_names_done = 1; } - EXPLAIN(printf(" search result: %p\n", rename)); + EXPLAIN(fprintf(stderr, "%d search result: %p\n", depth, rename)); if (rename) { if (mrn->kind == mzMOD_RENAME_MARKED) { @@ -3675,6 +3748,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, is_rib = NULL; } + EXPLAIN(fprintf(stderr, "%d lexical rename (%d)\n", depth, is_rib ? 1 : 0)); + c = SCHEME_RENAME_LEN(rename); /* Get index from hash table, if there is one: */ @@ -3711,32 +3786,36 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, other_env = scheme_false; envname = SCHEME_VEC_ELS(rename)[2+c+ri]; same = 1; - EXPLAIN(printf("Targes %s <- %s\n", - scheme_write_to_string(envname, 0), - scheme_write_to_string(other_env, 0))); + no_lexical = 1; /* simplified table always has final result */ + EXPLAIN(fprintf(stderr, "%d Targes %s <- %s\n", depth, + scheme_write_to_string(envname, 0), + scheme_write_to_string(other_env, 0))); } else { envname = SCHEME_VEC_ELS(rename)[0]; other_env = SCHEME_VEC_ELS(rename)[2+c+ri]; if (SCHEME_VOIDP(other_env)) { + int rib_dep = 0; SCHEME_USE_FUEL(1); - other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL); - if (!is_rib) + other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1); + if (!is_rib && !rib_dep) SCHEME_VEC_ELS(rename)[2+c+ri] = other_env; + if (rib_dep) + depends_on_unsealed_rib = 1; SCHEME_USE_FUEL(1); } - EXPLAIN(printf("Target %s <- %s (%d)\n", - scheme_write_to_string(envname, 0), - scheme_write_to_string(other_env, 0), - nom_mod_p(rename))); + EXPLAIN(fprintf(stderr, "%d Target %s <- %s (%d)\n", depth, + scheme_write_to_string(envname, 0), + scheme_write_to_string(other_env, 0), + nom_mod_p(rename))); { WRAP_POS w2; WRAP_POS_INIT(w2, ((Scheme_Stx *)renamed)->wraps); same = same_marks(&w2, &wraps, other_env); if (!same) - EXPLAIN(printf("Different marks\n")); + EXPLAIN(fprintf(stderr, "%d Different marks\n", depth)); } } @@ -3755,8 +3834,11 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, o_rename_stack); } if (is_rib) { - /* skip rest of rib (if any) and future instances of the same rib */ - rib = NULL; + /* skip future instances of the same rib; + used to skip the rest of the current rib, too, but + that's wrong in the case that the same symbolic + name with multiple binding contexts is re-bound + in a rib */ skip_ribs = add_skip_set(is_rib->timestamp, skip_ribs); } } @@ -3768,17 +3850,17 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } else if (SCHEME_RIBP(WRAP_POS_FIRST(wraps)) && !no_lexical) { /* Lexical-rename rib. Splice in the names. */ rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(wraps); - EXPLAIN(printf("Rib: %p...\n", rib)); + EXPLAIN(fprintf(stderr, "%d Rib: %p...\n", depth, rib)); if (skip_ribs) { if (in_skip_set(rib->timestamp, skip_ribs)) { - EXPLAIN(printf("Skip rib\n")); + EXPLAIN(fprintf(stderr, "%d Skip rib\n", depth)); rib = NULL; } } if (rib) { if (nonempty_rib(rib)) { if (SAME_OBJ(did_rib, rib)) { - EXPLAIN(printf("Did rib\n")); + EXPLAIN(fprintf(stderr, "%d Did rib\n", depth)); rib = NULL; } else { recur_skip_ribs = add_skip_set(rib->timestamp, recur_skip_ribs); @@ -3789,6 +3871,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, rib = NULL; } } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))) { + EXPLAIN(fprintf(stderr, "%d mark %p\n", depth, WRAP_POS_FIRST(wraps))); did_rib = NULL; } else if (SCHEME_HASHTP(WRAP_POS_FIRST(wraps))) { Scheme_Hash_Table *ht = (Scheme_Hash_Table *)WRAP_POS_FIRST(wraps); @@ -3883,13 +3966,13 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ if (mrn->needs_unmarshal) { /* Use resolve_env to trigger unmarshal, so that we don't have to implement top/from shifts here: */ - resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL); + resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL, NULL, 0); } if (mrn->marked_names) { /* Resolve based on rest of wraps: */ if (!bdg) - bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL); + bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL, NULL, 0); if (SCHEME_FALSEP(bdg)) { if (!floating_checked) { floating = check_floating_id(a); @@ -3969,8 +4052,8 @@ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *pha if ((a == asym) || (b == bsym)) return 1; - a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL); - b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL); + a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL, NULL, 0); + b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL, NULL, 0); if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type)) a = scheme_module_resolve(a, 0); @@ -4012,7 +4095,7 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **a, Scheme_Object *phase, names[4] = NULL; names[5] = NULL; - modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL); + modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, NULL, 0); if (names[0]) { if (SAME_OBJ(names[0], scheme_undefined)) { @@ -4038,12 +4121,12 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **a, Scheme_Object *phase, } Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a) - /* Returns either NULL or a lexical-rename symbol */ + /* Returns either false, a lexical-rename symbol, or void for "floating" */ { if (SCHEME_STXP(a)) { Scheme_Object *r; - r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL); + r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL, NULL, 0); if (SCHEME_FALSEP(r)) r = check_floating_id(a); @@ -4051,7 +4134,7 @@ Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a) if (r) return r; } - return NULL; + return scheme_false; } int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, Scheme_Object *phase) @@ -4075,13 +4158,13 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u if (!SAME_OBJ(asym, bsym)) return 0; - ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL); + ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL, NULL, 0); /* No need to module_resolve ae, because we ignored module renamings. */ if (uid) be = uid; else { - be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL); + be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL, NULL, 0); /* No need to module_resolve be, because we ignored module renamings. */ } @@ -4111,7 +4194,7 @@ int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a) { explain_resolves++; - a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL); + a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0); --explain_resolves; return a; } @@ -4483,13 +4566,30 @@ Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist) The wraps->datum tools are also used to simplify syntax object (to minimize the occupied space among a set of objects). */ -static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_cache) +#define EXPLAIN_SIMP 0 +#if EXPLAIN_SIMP +#define EXPLAIN_S(x) if (explain_simp) x +static int explain_simp = 0; +static void print_skips(Scheme_Object *skips) { - WRAP_POS w; - WRAP_POS prev; - WRAP_POS w2; - Scheme_Object *stack = scheme_null, *key, *old_key, *skip_ribs = scheme_null, *orig_skip_ribs; - Scheme_Object *v, *v2, *v2l, *stx, *name, *svl; + while (skips) { + printf(" skip %s\n", scheme_write_to_string(SCHEME_CAR(skips), NULL)); + skips = SCHEME_CDR(skips); + } +} +#else +#define EXPLAIN_S(x) /* empty */ +#endif + +static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_cache) +{ + WRAP_POS w, prev, w2; + Scheme_Object *stack = scheme_null, *key, *old_key, *prec_ribs = NULL, *prev_prec_ribs; + Scheme_Object *ribs_stack = scheme_null; + Scheme_Object *v, *v2, *v2l, *stx, *name, *svl, *end_mutable = NULL; + Scheme_Lexical_Rib *did_rib = NULL; + Scheme_Hash_Table *skip_ribs_ht = NULL, *prev_skip_ribs_ht; + int copy_on_write; long size, vsize, psize, i, j, pos; /* Although it makes no sense to simplify the rename table itself, @@ -4497,48 +4597,136 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca (But don't mutate the wrap list, because that will stomp on tables that might be needed by a propoagation.) - A lex_cache maps wrap starts w to simplified tables. A lex_cache - is modified by this function, only, but it's also read in - datum_to_wraps. + A lex_cache maps wrap starts within `w' to lists of simplified + tables. This helps avoid re-simplifying when the result is + clearly going to be the same. A lex_cache is read and modified by + this function, only. - In addition to depending on the rest of the wraps, a - simplification can depend on preceding wraps due to rib - skipping. So the lex_cache maps a wrap to another hash table that - maps a skip list to a simplified rename. */ + In addition to depending on the rest of the wraps, a resolved + binding can depend on preceding wraps due to rib skipping. For + now, simplifications that depend on preceding wraps are not + cached (though individual computed renamings are cached to save + space). + + The simplification stragegy mostly works inside out: since later + renames depend on earlier renames, we simplify the earlier ones + first, and then collapse to a flattened rename while working + outward. This also lets us track shared tails in some common + cases. + + A catch with the inside-out approach has to do with ribs (again). + Preceding ribs determine the recur_skip_ribs set, so we can + simply track that as we recur into the wraps initially to build + our worklist. However, whether we process a rib at all (on the + way out in the second pass) for a given id depends on whether any + preceding instance of the same rib (i.e., further out) matches + the symbol and marks. So, we have to compute that summary as we + go in. */ WRAP_POS_INIT(w, wraps); WRAP_POS_INIT_END(prev); old_key = NULL; + v2l = scheme_null; + while (!WRAP_POS_END_P(w)) { if (SCHEME_VECTORP(WRAP_POS_FIRST(w)) || SCHEME_RIBP(WRAP_POS_FIRST(w))) { /* Lexical rename */ key = WRAP_POS_KEY(w); if (!SAME_OBJ(key, old_key)) { - v = scheme_hash_get(lex_cache, key); - if (v) - v = scheme_hash_get((Scheme_Hash_Table *)v, skip_ribs); + if (!prec_ribs) + v = scheme_hash_get(lex_cache, key); + else + v = NULL; } else v = NULL; old_key = key; - orig_skip_ribs = skip_ribs; + prev_prec_ribs = prec_ribs; + prev_skip_ribs_ht = skip_ribs_ht; if (v) { /* Tables here are already simplified. */ - WRAP_POS_COPY(prev, w); + v2l = v; /* build on simplify chain extracted from cache */ + end_mutable = v2l; /* No non-simplified table can follow a simplified one */ break; } else { - int add = 0; + int add = 0, skip_this = 0; v = WRAP_POS_FIRST(w); if (SCHEME_RIBP(v)) { /* A rib certainly isn't simplified yet. */ - add = 1; - if (nonempty_rib((Scheme_Lexical_Rib *)v)) - skip_ribs = scheme_make_pair(((Scheme_Lexical_Rib *)v)->timestamp, skip_ribs); + Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)v; + add = 1; + if (SAME_OBJ(did_rib, rib) + || !nonempty_rib(rib)) { + skip_this = 1; + EXPLAIN_S(fprintf(stderr, " to skip %p=%s\n", rib, + scheme_write_to_string(rib->timestamp, NULL))); + } else { + did_rib = rib; + if (!*rib->sealed) { + scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); + return NULL; + } + prec_ribs = add_skip_set(rib->timestamp, prec_ribs); + + EXPLAIN_S(fprintf(stderr, " down rib %p=%s\n", rib, + scheme_write_to_string(rib->timestamp, NULL))); + EXPLAIN_S(print_skips(prec_ribs)); + + copy_on_write = 1; + + /* Compute, per id, whether to skip later instances of rib: */ + for (rib = rib->next; rib; rib = rib->next) { + vsize = SCHEME_RENAME_LEN(rib->rename); + for (i = 0; i < vsize; i++) { + stx = SCHEME_VEC_ELS(rib->rename)[2+i]; + + EXPLAIN_S(fprintf(stderr, " skip? %s %p=%s %s\n", + scheme_write_to_string(SCHEME_STX_VAL(stx), NULL), + rib, + scheme_write_to_string(rib->timestamp, NULL), + scheme_write_to_string(SCHEME_VEC_ELS(rib->rename)[0], NULL))); + + /* already skipped? */ + if (!skip_ribs_ht + || !scheme_hash_get(skip_ribs_ht, scheme_make_pair(SCHEME_STX_VAL(stx), rib->timestamp))) { + /* No. Should we skip? */ + Scheme_Object *other_env; + other_env = SCHEME_VEC_ELS(rib->rename)[2+vsize+i]; + if (SCHEME_VOIDP(other_env)) { + int rib_dep; + other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0); + if (rib_dep) { + scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); + return NULL; + } + SCHEME_VEC_ELS(rib->rename)[2+vsize+i] = other_env; + } + WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); + if (same_marks(&w2, &w, other_env)) { + /* yes, skip */ + EXPLAIN_S(fprintf(stderr, " skip! %s\n", + scheme_write_to_string(SCHEME_STX_VAL(stx), NULL))); + if (!skip_ribs_ht) + skip_ribs_ht = scheme_make_hash_table_equal(); + else if (copy_on_write) + skip_ribs_ht = scheme_clone_hash_table(skip_ribs_ht); + copy_on_write = 0; + scheme_hash_set(skip_ribs_ht, + scheme_make_pair(SCHEME_STX_VAL(stx), rib->timestamp), + scheme_true); + } + } else { + EXPLAIN_S(fprintf(stderr, " already skipped %s\n", + scheme_write_to_string(SCHEME_STX_VAL(stx), NULL))); + } + } + } + } } else { /* Need to simplify this vector? */ if (SCHEME_VEC_SIZE(v) == 1) @@ -4550,15 +4738,25 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca } if (add) { + if (skip_this) { + ribs_stack = scheme_make_pair(scheme_false, ribs_stack); + } else { + ribs_stack = scheme_make_pair(scheme_make_pair(prec_ribs, + (Scheme_Object *)prev_skip_ribs_ht), + ribs_stack); + } + /* Need to simplify, but do deepest first: */ - if (SCHEME_NULLP(stack) || !SAME_OBJ(SCHEME_CAR(SCHEME_CAR(stack)), key)) { - stack = CONS(CONS(key, orig_skip_ribs), stack); + if (SCHEME_NULLP(stack) || !SAME_OBJ(SCHEME_VEC_ELS(SCHEME_CAR(stack))[0], key)) { + v = scheme_make_vector(2, NULL); + SCHEME_VEC_ELS(v)[0] = key; + SCHEME_VEC_ELS(v)[1] = prev_prec_ribs; + stack = CONS(v, stack); } } else { /* This is already simplified. Remember it and stop, because no non-simplified table can follow a simplified one. */ - if (WRAP_POS_END_P(prev)) - WRAP_POS_COPY(prev, w); + WRAP_POS_COPY(prev, w); break; } } @@ -4569,11 +4767,8 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca while (!SCHEME_NULLP(stack)) { key = SCHEME_CAR(stack); - orig_skip_ribs = SCHEME_CDR(key); - key = SCHEME_CAR(key); - v2l = scheme_null; - - skip_ribs = orig_skip_ribs; + prev_prec_ribs = SCHEME_VEC_ELS(key)[1]; + key = SCHEME_VEC_ELS(key)[0]; WRAP_POS_REVINIT(w, key); @@ -4586,22 +4781,43 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca && !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[2]))) { /* This is the place to simplify: */ Scheme_Lexical_Rib *rib = NULL, *init_rib = NULL; - Scheme_Object *skip_ribs = NULL; - int ii, vvsize; + Scheme_Object *local_ribs; + int ii, vvsize, done_rib_pos = 0; - if (SCHEME_RIBP(v)) { - init_rib = (Scheme_Lexical_Rib *)v; - if (nonempty_rib(init_rib)) - skip_ribs = scheme_make_pair(init_rib->timestamp, skip_ribs); - rib = init_rib->next; + if (SCHEME_FALSEP(SCHEME_CAR(ribs_stack))) { + EXPLAIN_S(fprintf(stderr, " skip rib %p=%s\n", v, + scheme_write_to_string(((Scheme_Lexical_Rib *)v)->timestamp, NULL))); + ribs_stack = SCHEME_CDR(ribs_stack); vsize = 0; - while (rib) { - vsize += SCHEME_RENAME_LEN(rib->rename); - rib = rib->next; + } else { + prec_ribs = SCHEME_CAR(SCHEME_CAR(ribs_stack)); + skip_ribs_ht = (Scheme_Hash_Table *)SCHEME_CDR(SCHEME_CAR(ribs_stack)); + ribs_stack = SCHEME_CDR(ribs_stack); + + if (SCHEME_RIBP(v)) { + init_rib = (Scheme_Lexical_Rib *)v; + EXPLAIN_S(fprintf(stderr, " up rib %p=%s\n", init_rib, + scheme_write_to_string(init_rib->timestamp, NULL))); + EXPLAIN_S(print_skips(prec_ribs)); + rib = init_rib->next; + vsize = 0; + local_ribs = NULL; + while (rib) { + /* We need to process the renamings in reverse order: */ + local_ribs = scheme_make_raw_pair((Scheme_Object *)rib, local_ribs); + + vsize += SCHEME_RENAME_LEN(rib->rename); + rib = rib->next; + } + if (local_ribs) { + rib = (Scheme_Lexical_Rib *)SCHEME_CAR(local_ribs); + local_ribs = SCHEME_CDR(local_ribs); + } + } else { + vsize = SCHEME_RENAME_LEN(v); + local_ribs = NULL; } - rib = init_rib->next; - } else - vsize = SCHEME_RENAME_LEN(v); + } /* Initial size; may shrink: */ size = vsize; @@ -4612,7 +4828,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca /* Local vector (different from i when we have a rib) */ ii = 0; - vvsize= vsize; + vvsize = vsize; for (i = 0; i < vsize; i++) { if (rib) { @@ -4620,7 +4836,9 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca vvsize = SCHEME_RENAME_LEN(v); while (ii >= vvsize) { ii = 0; - rib = rib->next; + done_rib_pos = pos; + rib = (Scheme_Lexical_Rib *)SCHEME_CAR(local_ribs); + local_ribs = SCHEME_CDR(local_ribs); v = rib->rename; vvsize = SCHEME_RENAME_LEN(v); } @@ -4629,38 +4847,71 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca name = SCHEME_STX_VAL(stx); SCHEME_VEC_ELS(v2)[2+pos] = name; - { + if (!rib + || !skip_ribs_ht + || !scheme_hash_get(skip_ribs_ht, scheme_make_pair(name, rib->timestamp))) { /* Either this name is in prev, in which case the answer must match this rename's target, or this rename's answer applies. */ Scheme_Object *ok = NULL, *ok_replace = NULL; int ok_replace_index = 0; + Scheme_Object *other_env; + + if (rib) { + EXPLAIN_S(fprintf(stderr, " resolve %s %s (%d)\n", + scheme_write_to_string(name, NULL), + scheme_write_to_string(rib->timestamp, NULL), + done_rib_pos)); + } + + other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii]; + if (SCHEME_VOIDP(other_env)) { + other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, NULL, 0); + SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env; + } if (!WRAP_POS_END_P(prev) || SCHEME_PAIRP(v2l)) { WRAP_POS w3; Scheme_Object *vp; - Scheme_Object *other_env; - other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii]; - if (SCHEME_VOIDP(other_env)) { - other_env = resolve_env(NULL, stx, 0, 0, NULL, skip_ribs, NULL); - SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env; - } - - /* Check marks (now that we have the correct barriers). */ + /* Check marks (now that we have the correct barriers). */ WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); if (!same_marks(&w2, &w, other_env)) { other_env = NULL; } if (other_env) { - /* First, check simplications in v2l. - If not in v2l, try prev. */ - if (!ok) { + /* A simplified table need to have the final answer, so + fold conversions from the rest of the wraps. In the case + of ribs, the "rest" can include earlier rib renamings. + Otherwise, check simplications accumulated in v2l (possibly from a + previously simplified tail in the same cache). Finally, + try prev (from a previously simplified tail in an earlier + round of simplifying). */ + int rib_found = 0; + if (done_rib_pos) { + for (j = 0; j < done_rib_pos; j++) { + if (SAME_OBJ(SCHEME_VEC_ELS(v2)[2+j], name)) { + rib_found = 1; + if (SAME_OBJ(SCHEME_VEC_ELS(v2)[2+size+j], other_env)) { + ok = SCHEME_VEC_ELS(v)[0]; + ok_replace = v2; + ok_replace_index = 2 + size + j; + } else { + EXPLAIN_S(fprintf(stderr, " not matching prev rib\n")); + ok = NULL; + } + break; + } + } + } + if (!rib_found) { + int passed_mutable = 0; WRAP_POS_COPY(w3, prev); svl = v2l; for (; SCHEME_PAIRP(svl) || !WRAP_POS_END_P(w3); ) { + if (SAME_OBJ(svl, end_mutable)) passed_mutable = 1; if (SCHEME_PAIRP(svl)) vp = SCHEME_CAR(svl); else @@ -4672,13 +4923,16 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca if (SAME_OBJ(SCHEME_VEC_ELS(vp)[2+psize+j], other_env)) { ok = SCHEME_VEC_ELS(v)[0]; } else { + EXPLAIN_S(fprintf(stderr, + " not matching deeper %s\n", + scheme_write_to_string(other_env, NULL))); ok = NULL; /* Alternate time/space tradeoff: could be SCHEME_VEC_ELS(vp)[2+psize+j], which is the value from prev */ } - if (ok && SCHEME_PAIRP(svl)) { - /* Need to overwrite old map, instead + if (ok && SCHEME_PAIRP(svl) && !passed_mutable) { + /* Can overwrite old map, instead of adding a new one. */ ok_replace = vp; ok_replace_index = 2 + psize + j; @@ -4697,26 +4951,45 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca } if (WRAP_POS_END_P(w3) && SCHEME_NULLP(svl) && SCHEME_FALSEP(other_env)) ok = SCHEME_VEC_ELS(v)[0]; - } else - ok = NULL; - } + } + } else + ok = NULL; } else { - WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); - if (same_marks(&w2, &w, scheme_false)) - ok = SCHEME_VEC_ELS(v)[0]; - else - ok = NULL; + if (!SCHEME_FALSEP(other_env)) { + EXPLAIN_S(fprintf(stderr, " not based on #f\n")); + ok = NULL; + } else { + WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); + if (same_marks(&w2, &w, scheme_false)) + ok = SCHEME_VEC_ELS(v)[0]; + else { + EXPLAIN_S(fprintf(stderr, " not matching marks\n")); + ok = NULL; + } + } } if (ok) { if (ok_replace) { + EXPLAIN_S(fprintf(stderr, " replace mapping %s\n", + scheme_write_to_string(ok, NULL))); SCHEME_VEC_ELS(ok_replace)[ok_replace_index] = ok; } else { + EXPLAIN_S(fprintf(stderr, " add mapping %s\n", + scheme_write_to_string(ok, NULL))); SCHEME_VEC_ELS(v2)[2+size+pos] = ok; pos++; } - } - } + } else { + EXPLAIN_S(fprintf(stderr, " no mapping %s\n", + scheme_write_to_string(name, NULL))); + } + } else { + EXPLAIN_S(fprintf(stderr, " skip %s %s %p\n", + scheme_write_to_string(name, NULL), + scheme_write_to_string(rib->timestamp, NULL), + rib)); + } ii++; } @@ -4758,15 +5031,16 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca WRAP_POS_DEC(w); } - v = scheme_hash_get(lex_cache, key); - if (!v) { - v = (Scheme_Object *)scheme_make_hash_table_equal(); - scheme_hash_set(lex_cache, key, v); + if (!prev_prec_ribs) { + /* no dependency on ribs, so we can globally cache this result */ + scheme_hash_set(lex_cache, v, v2l); + end_mutable = v2l; } - scheme_hash_set((Scheme_Hash_Table *)v, skip_ribs, v2l); stack = SCHEME_CDR(stack); } + + return v2l; } static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, @@ -4774,7 +5048,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, Scheme_Hash_Table *rns, int just_simplify) { - Scheme_Object *stack, *a, *old_key, *simplifies = scheme_null, *skip_ribs = scheme_null; + Scheme_Object *stack, *a, *old_key, *simplifies = scheme_null, *prec_ribs = scheme_null; WRAP_POS w; Scheme_Hash_Table *lex_cache, *reverse_map; int stack_size = 0; @@ -4812,7 +5086,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, } /* Ensures that all lexical tables in w have been simplified */ - simplify_lex_renames(w_in, lex_cache); + simplifies = simplify_lex_renames(w_in, lex_cache); if (mt) scheme_marshal_push_refs(mt); @@ -4840,14 +5114,9 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, /* a is not a simplified table; need to look it up; if simplifies is non-null, then we already have found a list of simplified tables for the current wrap segment. */ - if (SCHEME_NULLP(simplifies)) { - simplifies = scheme_hash_get(lex_cache, old_key); - simplifies = scheme_hash_get((Scheme_Hash_Table *)simplifies, skip_ribs); - /* assert: a is not NULL; see the simplify_lex_rename() call above */ - } if (SCHEME_RIBP(a)) { if (nonempty_rib((Scheme_Lexical_Rib *)a)) - skip_ribs = scheme_make_pair(((Scheme_Lexical_Rib *)a)->timestamp, skip_ribs); + prec_ribs = scheme_make_pair(((Scheme_Lexical_Rib *)a)->timestamp, prec_ribs); } a = SCHEME_CAR(simplifies); /* used up one simplification: */ @@ -6494,6 +6763,16 @@ Scheme_Object *scheme_new_stx_simplify_cache() void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache) { +#if 0 + if (SAME_OBJ(scheme_intern_symbol("x"), SCHEME_STX_VAL(stx))) { + fprintf(stderr, + "simplifying... %s\n", + scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0), + NULL)); + explain_simp = 1; + } +#endif + if (cache) { Scheme_Hash_Table *rns; @@ -6501,6 +6780,15 @@ void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache) simplify_syntax_inner(stx, rns, NULL); } + +#if 0 + if (explain_simp) { + explain_simp = 0; + fprintf(stderr, "simplified: %s\n", + scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0), + NULL)); + } +#endif } /*========================================================================*/ @@ -6924,16 +7212,49 @@ static Scheme_Object *delta_introducer(int argc, struct Scheme_Object *argv[], S return r; } -static Scheme_Object *syntax_transfer_intro(int argc, Scheme_Object **argv) +static Scheme_Object *extract_phase(const char *who, int pos, int argc, Scheme_Object **argv, + Scheme_Object *delta, int use_shift) +{ + Scheme_Object *phase; + + if (argc > pos) { + phase = argv[pos]; + if (!SCHEME_FALSEP(phase) + && !SCHEME_INTP(phase) + && !SCHEME_BIGNUMP(phase)) + scheme_wrong_type(who, "exact integer or #f", pos, argc, argv); + } else { + Scheme_Thread *p = scheme_current_thread; + long ph; + ph = (p->current_local_env + ? p->current_local_env->genv->phase + : (use_shift + ? p->current_phase_shift + : 0)); + phase = scheme_make_integer(ph); + + if (SCHEME_FALSEP(delta) || SCHEME_FALSEP(phase)) + phase = scheme_false; + else + phase = scheme_bin_plus(delta, phase); + } + + return phase; +} + +Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv) { Scheme_Object *orig_m1, *m1, *m2, *delta, *a[1]; int l1, l2; + Scheme_Object *phase; - if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("make-syntax-delta-introducer", "syntax", 0, argc, argv); + if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) + scheme_wrong_type("make-syntax-delta-introducer", "syntax identifier", 0, argc, argv); if (!SCHEME_STXP(argv[1])) scheme_wrong_type("make-syntax-delta-introducer", "syntax", 1, argc, argv); + phase = extract_phase("make-syntax-delta-introducer", 2, argc, argv, scheme_make_integer(0), 1); + m1 = scheme_stx_extract_marks(argv[0]); orig_m1 = m1; m2 = scheme_stx_extract_marks(argv[1]); @@ -6949,15 +7270,11 @@ static Scheme_Object *syntax_transfer_intro(int argc, Scheme_Object **argv) } if (!scheme_equal(m1, m2)) { - /* tails don't match, so keep all marks --- except those that determine a module binding */ + /* tails don't match, so keep all marks --- except + those that determine a module binding */ int skipped = 0; - Scheme_Object *phase; - Scheme_Thread *p = scheme_current_thread; - phase = scheme_make_integer(p->current_local_env - ? p->current_local_env->genv->phase - : 0); - resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped); + resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped, NULL, 0); if (skipped) { /* Just keep the first `skipped' marks. */ @@ -6992,18 +7309,7 @@ static Scheme_Object *bound_eq(int argc, Scheme_Object **argv) if (!SCHEME_STX_IDP(argv[1])) scheme_wrong_type("bound-identifier=?", "identifier syntax", 1, argc, argv); - if (argc > 2) { - phase = argv[2]; - if (!SCHEME_FALSEP(phase) - && !SCHEME_INTP(phase) - && !SCHEME_BIGNUMP(phase)) - scheme_wrong_type("bound-identifier=?", "exact integer or #f", 2, argc, argv); - } else { - Scheme_Thread *p = scheme_current_thread; - phase = scheme_make_integer(p->current_local_env - ? p->current_local_env->genv->phase - : 0); - } + phase = extract_phase("bound-identifier=?", 2, argc, argv, scheme_make_integer(0), 0); return (scheme_stx_bound_eq(argv[0], argv[1], phase) ? scheme_true @@ -7019,24 +7325,11 @@ static Scheme_Object *do_module_eq(const char *who, int delta, int argc, Scheme_ if (!SCHEME_STX_IDP(argv[1])) scheme_wrong_type(who, "identifier syntax", 1, argc, argv); - if (argc > 2) { - phase = argv[2]; - if (!SCHEME_FALSEP(phase) - && !SCHEME_INTP(phase) - && !SCHEME_BIGNUMP(phase)) - scheme_wrong_type(who, "exact integer or #f", 2, argc, argv); - } else { - Scheme_Thread *p = scheme_current_thread; - if (delta == MZ_LABEL_PHASE) - phase = scheme_false; - else { - long ph; - ph = (delta + (p->current_local_env - ? p->current_local_env->genv->phase - : 0)); - phase = scheme_make_integer(ph); - } - } + phase = extract_phase(who, 2, argc, argv, + ((delta == MZ_LABEL_PHASE) + ? scheme_false + : scheme_make_integer(delta)), + 0); return (scheme_stx_module_eq2(argv[0], argv[1], phase, NULL) ? scheme_true @@ -7073,6 +7366,8 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a)) scheme_wrong_type(name, "identifier syntax", 0, argc, argv); + phase = extract_phase(name, 1, argc, argv, dphase, 1); + if (argc > 1) { phase = argv[1]; if (!SCHEME_FALSEP(phase) diff --git a/src/mzscheme/src/type.c b/src/mzscheme/src/type.c index 3f26099c07..e0582c5813 100644 --- a/src/mzscheme/src/type.c +++ b/src/mzscheme/src/type.c @@ -577,7 +577,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_svector_type, svector_val); GC_REG_TRAV(scheme_set_macro_type, small_object); - GC_REG_TRAV(scheme_id_macro_type, small_object); + GC_REG_TRAV(scheme_id_macro_type, twoptr_obj); GC_REG_TRAV(scheme_stx_type, stx_val); GC_REG_TRAV(scheme_stx_offset_type, stx_off_val);