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

expander: code clean-ups

Browse Source 
Use `define/who` consistently, remove some unused `require`s, and fix
some bad indentation.
This commit is contained in:
Matthew Flatt 2018-03-05 18:08:08 -07:00
parent bbefc9ed50
commit c5653b5bdd
35 changed files with 15955 additions and 15690 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
racket/src/expander/boot/utils-primitive.rkt
View File

@ -1,6 +1,5 @@
#lang racket/base
(require racket/private/config
racket/private/executable-path
"../common/reflect-hash.rkt"
(only-in "../eval/load.rkt" load/use-compiled)
"../eval/collection.rkt")

13
racket/src/expander/common/contract.rkt
View File

@ -1,13 +1,4 @@
#lang racket/base
(require (for-syntax racket/base))
(require racket/private/check)
(provide check)
(define-syntax-rule (check who pred arg)
(unless (pred arg)
(raise-argument-error who (as-string pred) arg)))
(define-syntax (as-string stx)
(syntax-case stx ()
[(_ id)
(datum->syntax stx (symbol->string (syntax-e #'id)) stx)]))
(provide (all-from-out racket/private/check))

10
racket/src/expander/common/intern.rkt
View File

@ -74,11 +74,11 @@
(define P 100) ; number of values to intern and discard
(struct val (key other)
#:transparent
#:property prop:equal+hash (list
(lambda (v1 v2 eql?) (eql? (val-key v1) (val-key v2)))
(lambda (v1 code) (code (val-key v1)))
(lambda (v1 code) (code (val-key v1)))))
#:transparent
#:property prop:equal+hash (list
(lambda (v1 v2 eql?) (eql? (val-key v1) (val-key v2)))
(lambda (v1 code) (code (val-key v1)))
(lambda (v1 code) (code (val-key v1)))))
(define tt (make-weak-intern-table))

176
racket/src/expander/common/module-path.rkt
View File

@ -43,29 +43,29 @@
;; ----------------------------------------
(struct resolved-module-path (name)
#:authentic
#:property prop:equal+hash
;; Although equal resolved module paths are `eq?` externally,
;; we need this equality predicate to hash them for the
;; interning table
(list (lambda (a b eql?)
(eql? (resolved-module-path-name a)
(resolved-module-path-name b)))
(lambda (a hash-code)
(hash-code (resolved-module-path-name a)))
(lambda (a hash-code)
(hash-code (resolved-module-path-name a))))
#:property prop:custom-write
(lambda (r port mode)
(when mode
(write-string "#<resolved-module-path:" port))
(fprintf port "~a" (format-resolved-module-path-name (resolved-module-path-name r)))
(when mode
(write-string ">" port)))
#:property prop:serialize
(lambda (r ser-push! state)
(ser-push! 'tag '#:resolved-module-path)
(ser-push! (resolved-module-path-name r))))
#:authentic
#:property prop:equal+hash
;; Although equal resolved module paths are `eq?` externally,
;; we need this equality predicate to hash them for the
;; interning table
(list (lambda (a b eql?)
(eql? (resolved-module-path-name a)
(resolved-module-path-name b)))
(lambda (a hash-code)
(hash-code (resolved-module-path-name a)))
(lambda (a hash-code)
(hash-code (resolved-module-path-name a))))
#:property prop:custom-write
(lambda (r port mode)
(when mode
(write-string "#<resolved-module-path:" port))
(fprintf port "~a" (format-resolved-module-path-name (resolved-module-path-name r)))
(when mode
(write-string ">" port)))
#:property prop:serialize
(lambda (r ser-push! state)
(ser-push! 'tag '#:resolved-module-path)
(ser-push! (resolved-module-path-name r))))
(define (deserialize-resolved-module-path n)
(make-resolved-module-path n))
@ -129,58 +129,58 @@
;; ----------------------------------------
(struct module-path-index (path base [resolved #:mutable] [shift-cache #:mutable])
#:authentic
#:property prop:equal+hash
(list (lambda (a b eql?)
(and (eql? (module-path-index-path a)
(module-path-index-path b))
(eql? (module-path-index-base a)
(module-path-index-base b))))
(lambda (a hash-code)
(and (+ (hash-code (module-path-index-path a))
(hash-code (module-path-index-base a)))))
(lambda (a hash-code)
(and (+ (hash-code (module-path-index-path a))
(hash-code (module-path-index-base a))))))
#:property prop:custom-write
(lambda (r port mode)
(write-string "#<module-path-index" port)
(cond
[(top-level-module-path-index? r)
(fprintf port ":top-level")]
[(module-path-index-path r)
(define l (let loop ([r r])
(cond
[(not r) null]
[(resolved-module-path? r)
(list
"+"
(format "~a" r))]
[(module-path-index-path r)
(cons (let loop ([v (module-path-index-path r)])
(cond
[(and (pair? v)
(eq? 'quote (car v))
(null? (cddr v)))
(format-symbol (cadr v))]
[(and (pair? v)
(eq? 'submod (car v)))
(format-submod (loop (cadr v)) (cddr v))]
[else
(format "~.s" v)]))
(loop (module-path-index-base r)))]
[(module-path-index-resolved r)
(list
"+"
(format "~a" (module-path-index-resolved r)))]
[else null])))
(fprintf port ":~.a" (apply string-append
(car l)
(for/list ([i (in-list (cdr l))])
(format " ~a" i))))]
[(module-path-index-resolved r)
(fprintf port "=~a" (module-path-index-resolved r))])
(write-string ">" port)))
#:authentic
#:property prop:equal+hash
(list (lambda (a b eql?)
(and (eql? (module-path-index-path a)
(module-path-index-path b))
(eql? (module-path-index-base a)
(module-path-index-base b))))
(lambda (a hash-code)
(and (+ (hash-code (module-path-index-path a))
(hash-code (module-path-index-base a)))))
(lambda (a hash-code)
(and (+ (hash-code (module-path-index-path a))
(hash-code (module-path-index-base a))))))
#:property prop:custom-write
(lambda (r port mode)
(write-string "#<module-path-index" port)
(cond
[(top-level-module-path-index? r)
(fprintf port ":top-level")]
[(module-path-index-path r)
(define l (let loop ([r r])
(cond
[(not r) null]
[(resolved-module-path? r)
(list
"+"
(format "~a" r))]
[(module-path-index-path r)
(cons (let loop ([v (module-path-index-path r)])
(cond
[(and (pair? v)
(eq? 'quote (car v))
(null? (cddr v)))
(format-symbol (cadr v))]
[(and (pair? v)
(eq? 'submod (car v)))
(format-submod (loop (cadr v)) (cddr v))]
[else
(format "~.s" v)]))
(loop (module-path-index-base r)))]
[(module-path-index-resolved r)
(list
"+"
(format "~a" (module-path-index-resolved r)))]
[else null])))
(fprintf port ":~.a" (apply string-append
(car l)
(for/list ([i (in-list (cdr l))])
(format " ~a" i))))]
[(module-path-index-resolved r)
(fprintf port "=~a" (module-path-index-resolved r))])
(write-string ">" port)))
;; Serialization of a module path index is handled specially, because they
;; must be shared across phases of a module
@ -190,8 +190,8 @@
[(name) (make-self-module-path-index (make-resolved-module-path name))]
[() top-level-module-path-index]))
(define (module-path-index-resolve mpi [load? #f])
(check 'module-path-index-resolve module-path-index? mpi)
(define/who (module-path-index-resolve mpi [load? #f])
(check who module-path-index? mpi)
(or (module-path-index-resolved mpi)
(let ([mod-name ((current-module-name-resolver)
(module-path-index-path mpi)
@ -214,26 +214,24 @@
(module-path-index-join path base)]
[else mpi]))
(define (module-path-index-join mod-path base [submod #f])
(unless (or (not mod-path)
(module-path? mod-path))
(raise-argument-error 'module-path-index-join "(or/c #f module-path?)" mod-path))
(define/who (module-path-index-join mod-path base [submod #f])
(check who #:or-false module-path? mod-path)
(unless (or (not base)
(resolved-module-path? base)
(module-path-index? base))
(raise-argument-error 'module-path-index-join "(or/c #f resolved-module-path? module-path-index?)" base))
(raise-argument-error who "(or/c #f resolved-module-path? module-path-index?)" base))
(unless (or (not submod)
(and (pair? submod)
(list? submod)
(andmap symbol? submod)))
(raise-argument-error 'module-path-index-join "(or/c #f (non-empty-listof symbol?))" submod))
(raise-argument-error who "(or/c #f (non-empty-listof symbol?))" submod))
(when (and (not mod-path)
base)
(raise-arguments-error 'module-path-index-join
(raise-arguments-error who
"cannot combine #f path with non-#f base"
"given base" base))
(when (and submod mod-path)
(raise-arguments-error 'module-path-index-join
(raise-arguments-error who
"cannot combine #f submodule list with non-#f module path"
"given module path" mod-path
"given submodule list" submod))
@ -258,13 +256,13 @@
(module-path-index-resolve base load?)
base))
(define (module-path-index-split mpi)
(check 'module-path-index-split module-path-index? mpi)
(define/who (module-path-index-split mpi)
(check who module-path-index? mpi)
(values (module-path-index-path mpi)
(module-path-index-base mpi)))
(define (module-path-index-submodule mpi)
(check 'module-path-index-submodule module-path-index? mpi)
(define/who (module-path-index-submodule mpi)
(check who module-path-index? mpi)
(and (not (module-path-index-path mpi))
(let ([r (module-path-index-resolved mpi)])
(and r

20
racket/src/expander/common/struct-star.rkt
View File

@ -33,13 +33,13 @@
outer-name inner-name outer-name-inner
all-fields ; including parent fields
outer-fields inner-fields mutators)
#:property prop:procedure (lambda (shape stx)
(with-syntax ([make-id (struct*-shape-constructor shape)])
(syntax-case stx ()
[(id arg ...)
(syntax/loc stx (make-id arg ...))]
[else
(syntax/loc stx make-id)])))))
#:property prop:procedure (lambda (shape stx)
(with-syntax ([make-id (struct*-shape-constructor shape)])
(syntax-case stx ()
[(id arg ...)
(syntax/loc stx (make-id arg ...))]
[else
(syntax/loc stx make-id)])))))
(define-syntax (struct* stx)
(let-values ([(name parent-name fields options)
@ -99,10 +99,10 @@
#`(begin
(struct outer-name outer-parent-name ... (chain-field ... outer-field ...)
option ...
#:reflection-name 'name
#:authentic)
#:reflection-name 'name
#:authentic)
(struct inner-name inner-parent-name ... (inner-field ...)
#:authentic)
#:authentic)
(define-syntax name (struct*-shape
(quote-syntax make-name)
(quote-parent-syntax parent-name)

6
racket/src/expander/compile/compiled-in-memory.rkt
View File

@ -34,6 +34,6 @@
namespace-scopes
;; To track whether a form in a top-level sequence can be discarded:
purely-functional?)
#:property prop:custom-write
(lambda (cim port mode)
(write (compiled-in-memory-linklet-directory cim) port)))
#:property prop:custom-write
(lambda (cim port mode)
(write (compiled-in-memory-linklet-directory cim) port)))

4
racket/src/expander/demo.rkt
View File

@ -725,11 +725,9 @@
'definition-shadows-initial-require)))
#rx"already required")
(check-error
(eval-module-declaration '(module m '#%kernel
(eval-module-declaration '(module m '#%kernel
(define-values (list) 5)
(#%require '#%kernel)))
#rx"already defined")
;; ----------------------------------------

28
racket/src/expander/eval/api.rkt
View File

@ -24,51 +24,51 @@
expand-once
expand-syntax-once)
(define eval
(define/who eval
(case-lambda
[(s) ((current-eval) (intro s))]
[(s ns)
(check 'eval namespace? ns)
(check who namespace? ns)
(parameterize ([current-namespace ns])
((current-eval) (intro s ns)))]))
(define eval-syntax
(define/who eval-syntax
(case-lambda
[(s)
(check 'eval-syntax syntax? s)
(check who syntax? s)
((current-eval) s)]
[(s ns)
(check 'eval-syntax syntax? s)
(check 'eval-syntax namespace? ns)
(check who syntax? s)
(check who namespace? ns)
(parameterize ([current-namespace ns])
((current-eval) s))]))
(define (compile s)
((current-compile) (intro s) #f))
(define (compile-syntax s)
(check 'compile-syntax syntax? s)
(define/who (compile-syntax s)
(check who syntax? s)
((current-compile) s #f))
(define (expand s)
(direct:expand (intro s) (current-namespace) #t))
(define (expand-syntax s)
(check 'expand-syntax syntax? s)
(define/who (expand-syntax s)
(check who syntax? s)
(direct:expand s (current-namespace) #t))
(define (expand-once s)
(direct:expand-once (intro s)))
(define (expand-syntax-once s)
(check 'expand-syntax-once syntax? s)
(define/who (expand-syntax-once s)
(check who syntax? s)
(direct:expand-once s))
(define (expand-to-top-form s)
(direct:expand-to-top-form (intro s)))
(define (expand-syntax-to-top-form s)
(check 'expand-syntax-to-top-form syntax? s)
(define/who (expand-syntax-to-top-form s)
(check who syntax? s)
(direct:expand-to-top-form s))

9
racket/src/expander/eval/dynamic-require.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "../common/phase.rkt"
"../common/contract.rkt"
"../syntax/module-binding.rkt"
"../syntax/api.rkt"
"../namespace/namespace.rkt"
@ -119,11 +120,11 @@
(define (default-dynamic-require-fail-thunk)
(error "failed"))
(define (dynamic-require mod-path sym [fail-k default-dynamic-require-fail-thunk])
(do-dynamic-require 'dynamic-require mod-path sym fail-k))
(define/who (dynamic-require mod-path sym [fail-k default-dynamic-require-fail-thunk])
(do-dynamic-require who mod-path sym fail-k))
(define (dynamic-require-for-syntax mod-path sym [fail-k default-dynamic-require-fail-thunk])
(define/who (dynamic-require-for-syntax mod-path sym [fail-k default-dynamic-require-fail-thunk])
(parameterize ([current-namespace
(let ([ns (current-namespace)])
(namespace->namespace-at-phase ns (add1 (namespace-phase ns))))])
(do-dynamic-require 'dynamic-require-for-syntax mod-path sym fail-k)))
(do-dynamic-require who mod-path sym fail-k)))

36
racket/src/expander/eval/reflect.rkt
View File

@ -41,18 +41,18 @@
(hash-ref (linklet-bundle->hash ld) 'decl #f)
#t)))
(define module-compiled-name
(define/who module-compiled-name
(case-lambda
[(c)
(check 'module-compiled-name compiled-module-expression? c)
(check who compiled-module-expression? c)
(module-compiled-current-name c)]
[(c name)
(check 'module-compiled-name compiled-module-expression? c)
(check who compiled-module-expression? c)
(unless (or (symbol? name)
(and (pair? name)
(list? name)
(andmap symbol? name)))
(raise-argument-error 'module-compiled-name
(raise-argument-error who
"(or/c symbol? (cons/c symbol? (non-empty-listof symbol?)))"
name))
(define-values (i-name prefix)
@ -62,10 +62,10 @@
(values (car r) (reverse (cdr r))))))
(change-module-name c i-name prefix)]))
(define module-compiled-submodules
(define/who module-compiled-submodules
(case-lambda
[(c non-star?)
(check 'module-compiled-submodules compiled-module-expression? c)
(check who compiled-module-expression? c)
(cond
[(compiled-in-memory? c)
;; We have a convenient `compiled-in-memory` structure
@ -86,10 +86,10 @@
;; a linklet bundle represents a module with no submodules
null])])]
[(c non-star? submods)
(check 'module-compiled-submodules compiled-module-expression? c)
(check who compiled-module-expression? c)
(unless (and (list? submods)
(andmap compiled-module-expression? submods))
(raise-argument-error 'module-compiled-submodules "(listof compiled-module-expression?)" submods))
(raise-argument-error who "(listof compiled-module-expression?)" submods))
(cond
[(and (null? submods)
(or (linklet-bundle? (compiled->linklet-directory-or-bundle c))
@ -134,24 +134,24 @@
(append (if non-star? submods (module-compiled-submodules c #t))
(if non-star? (module-compiled-submodules c #f) submods)))))])]))
(define (module-compiled-language-info c)
(check 'module-compiled-language-info compiled-module-expression? c)
(define/who (module-compiled-language-info c)
(check who compiled-module-expression? c)
(define h (compiled-module->h c))
(hash-ref h 'language-info #f))
(define (module-compiled-imports c)
(check 'module-compiled-imports compiled-module-expression? c)
(define/who (module-compiled-imports c)
(check who compiled-module-expression? c)
(define inst (compiled-module->declaration-instance c))
(instance-variable-value inst 'requires))
(define (module-compiled-exports c)
(check 'module-compiled-imports compiled-module-expression? c)
(define/who (module-compiled-exports c)
(check who compiled-module-expression? c)
(define inst (compiled-module->declaration-instance c))
(provides->api-provides (instance-variable-value inst 'provides)
(instance-variable-value inst 'self-mpi)))
(define (module-compiled-indirect-exports c)
(check 'module-compiled-indirect-imports compiled-module-expression? c)
(define/who (module-compiled-indirect-exports c)
(check who compiled-module-expression? c)
(define-values (h inst) (compiled-module->h+declaration-instance c))
(define min-phase (hash-ref h 'min-phase 0))
(define max-phase (hash-ref h 'max-phase 0))
@ -163,8 +163,8 @@
(linklet-export-variables linklet)
null)))))
(define (module-compiled-cross-phase-persistent? c)
(check 'module-compiled-cross-phase-persistent? compiled-module-expression? c)
(define/who (module-compiled-cross-phase-persistent? c)
(check who compiled-module-expression? c)
(define h (compiled-module->h c))
(hash-ref h 'cross-phase-persistent? #f))

6
racket/src/expander/expand/liberal-def-ctx.rkt
View File

@ -8,9 +8,9 @@
(make-struct-type-property 'liberal-define-context))
(struct liberal-define-context ()
#:transparent
#:property prop:liberal-define-context #t
#:constructor-name make-liberal-define-context)
#:transparent
#:property prop:liberal-define-context #t
#:constructor-name make-liberal-define-context)

12
racket/src/expander/expand/missing-module.rkt
View File

@ -26,13 +26,13 @@
v)))
(struct exn:fail:filesystem:missing-module exn:fail:filesystem (path)
#:extra-constructor-name make-exn:fail:filesystem:missing-module
#:transparent
#:property prop:exn:missing-module (lambda (e) (exn:fail:filesystem:missing-module-path e)))
#:extra-constructor-name make-exn:fail:filesystem:missing-module
#:transparent
#:property prop:exn:missing-module (lambda (e) (exn:fail:filesystem:missing-module-path e)))
(struct exn:fail:syntax:missing-module exn:fail:syntax (path)
#:extra-constructor-name make-exn:fail:syntax:missing-module
#:transparent
#:property prop:exn:missing-module (lambda (e) (exn:fail:syntax:missing-module-path e)))
#:extra-constructor-name make-exn:fail:syntax:missing-module
#:transparent
#:property prop:exn:missing-module (lambda (e) (exn:fail:syntax:missing-module-path e)))
(define current-module-path-for-load
(make-parameter #f

2
racket/src/expander/expand/set-bang-trans.rkt
View File

@ -41,7 +41,7 @@
(define make-set!-transformer
(let ()
(struct set!-transformer (proc)
#:property prop:set!-transformer 0)
#:property prop:set!-transformer 0)
(lambda (proc)
(unless (and (procedure? proc)
(procedure-arity-includes? proc 1))

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

@ -88,13 +88,13 @@
(define ctx (get-current-expand-context 'syntax-local-context))
(expand-context-context ctx))
(define (syntax-local-introduce s)
(check 'syntax-local-introduce syntax? s)
(define/who (syntax-local-introduce s)
(check who syntax? s)
(define ctx (get-current-expand-context 'syntax-local-introduce))
(flip-introduction-scopes s ctx))
(define (syntax-local-identifier-as-binding id)
(check syntax-local-identifier-as-binding identifier? id)
(define/who (syntax-local-identifier-as-binding id)
(check who identifier? id)
(define ctx (get-current-expand-context 'syntax-local-identifier-as-binding))
(remove-use-site-scopes id ctx))
@ -104,8 +104,8 @@
(expand-context-phase ctx)
0))
(define (syntax-local-name)
(define ctx (get-current-expand-context 'syntax-local-name))
(define/who (syntax-local-name)
(define ctx (get-current-expand-context who))
(define id (expand-context-name ctx))
(and id
;; Strip lexical context, but keep source-location information
@ -123,12 +123,10 @@
[(flip) (flip-scope s sc)]
[else (raise-argument-error 'syntax-introducer "(or/c 'add 'remove 'flip)" mode)])))
(define (make-syntax-delta-introducer ext-s base-s [phase (syntax-local-phase-level)])
(check 'make-syntax-delta-introducer syntax? ext-s)
(unless (or (syntax? base-s) (not base-s))
(raise-argument-error 'make-syntax-delta-introducer "(or/c syntax? #f)" base-s))
(unless (phase? phase)
(raise-argument-error 'make-syntax-delta-introducer phase?-string phase))
(define/who (make-syntax-delta-introducer ext-s base-s [phase (syntax-local-phase-level)])
(check who syntax? ext-s)
(check who syntax? #:or-false base-s)
(check who phase? #:contract phase?-string phase)
(define ext-scs (syntax-scope-set ext-s phase))
(define base-scs (syntax-scope-set (or base-s empty-syntax) phase))
(define use-base-scs (if (subset? base-scs ext-scs)
@ -146,8 +144,8 @@
[(flip) (flip-scopes s delta-scs)]
[else (raise-argument-error 'syntax-introducer "(or/c 'add 'remove 'flip)" mode)]))))
(define (syntax-local-make-delta-introducer id-stx)
(check 'syntax-local-make-delta-introducer identifier? id-stx)
(define/who (syntax-local-make-delta-introducer id-stx)
(check who identifier? id-stx)
(raise
(exn:fail:unsupported "syntax-local-make-delta-introducer: not supported anymore"
(current-continuation-marks))))
@ -157,17 +155,8 @@
(define (do-syntax-local-value who id intdef failure-thunk
#:immediate? immediate?)
(check who identifier? id)
(unless (or (not failure-thunk)
(and (procedure? failure-thunk)
(procedure-arity-includes? failure-thunk 0)))
(raise-argument-error who
"(or #f (procedure-arity-includes/c 0))"
failure-thunk))
(unless (or (not intdef)
(internal-definition-context? intdef))
(raise-argument-error who
"(or #f internal-definition-context?)"
failure-thunk))
(check who #:or-false (procedure-arity-includes/c 0) failure-thunk)
(check who #:or-false internal-definition-context? intdef)
(define current-ctx (get-current-expand-context who))
(define ctx (if intdef
(struct*-copy expand-context current-ctx
@ -186,7 +175,7 @@
(log-expand ctx 'local-value-result #f)
(if failure-thunk
(failure-thunk)
(error 'syntax-local-value "unbound identifier: ~v" id))]
(error who "unbound identifier: ~v" id))]
[else
(define-values (v primitive? insp protected?)
(lookup b ctx id #:out-of-context-as-variable? #t))
@ -195,7 +184,7 @@
(log-expand ctx 'local-value-result #f)
(if failure-thunk
(failure-thunk)
(error 'syntax-local-value "identifier is not bound to syntax: ~v" id))]
(error who "identifier is not bound to syntax: ~v" id))]
[else
(log-expand* ctx #:unless (and (rename-transformer? v) (not immediate?))
['local-value-result #t])
@ -234,32 +223,32 @@
(flip-introduction-scopes s ctx)
(expand-context-phase ctx))))
(define (syntax-local-lift-expression s)
(car (do-lift-values-expression 'syntax-local-lift-expression 1 s)))
(define/who (syntax-local-lift-expression s)
(car (do-lift-values-expression who 1 s)))
(define (syntax-local-lift-values-expression n s)
(do-lift-values-expression 'syntax-local-lift-values-expression n s))
(define/who (syntax-local-lift-values-expression n s)
(do-lift-values-expression who n s))
(define (syntax-local-lift-context)
(define ctx (get-current-expand-context 'syntax-local-lift-context))
(define/who (syntax-local-lift-context)
(define ctx (get-current-expand-context who))
(root-expand-context-lift-key ctx))
;; ----------------------------------------
(define (syntax-local-lift-module s)
(check 'syntax-local-lift-module syntax? s)
(define ctx (get-current-expand-context 'syntax-local-lift-module))
(define/who (syntax-local-lift-module s)
(check who syntax? s)
(define ctx (get-current-expand-context who))
(define phase (expand-context-phase ctx))
(case (core-form-sym s phase)
[(module module*)
(define lifts (expand-context-module-lifts ctx))
(unless lifts
(raise-arguments-error 'syntax-local-lift-module
(raise-arguments-error who
"not currently transforming within a module declaration or top level"
"form to lift" s))
(add-lifted-module! lifts (flip-introduction-scopes s ctx) phase)]
[else
(raise-arguments-error 'syntax-local-lift-module "not a module form"
(raise-arguments-error who "not a module form"
"given form" s)])
(log-expand ctx 'lift-statement s))
@ -291,18 +280,16 @@
(add-lifted! lift-ctx post-s wrt-phase) ; record lift for the target phase
(values ctx post-s))
(define (syntax-local-lift-require s use-s)
(define/who (syntax-local-lift-require s use-s)
(define sc (new-scope 'macro))
(define-values (ctx added-s)
(do-local-lift-to-module 'syntax-local-lift-require
(do-local-lift-to-module who
(datum->syntax #f s)
#:no-target-msg "could not find target context"
#:intro? #f
#:more-checks
(lambda ()
(check 'syntax-local-lift-require
syntax?
use-s))
(check who syntax? use-s))
#:get-lift-ctx expand-context-require-lifts
#:get-wrt-phase require-lift-context-wrt-phase
#:add-lifted! add-lifted-require!
@ -318,9 +305,9 @@
(log-expand ctx 'lift-require added-s use-s result-s)
result-s)
(define (syntax-local-lift-provide s)
(define/who (syntax-local-lift-provide s)
(define-values (ctx result-s)
(do-local-lift-to-module 'syntax-local-lift-provide
(do-local-lift-to-module who
s
#:no-target-msg "not expanding in a module run-time body"
#:get-lift-ctx expand-context-to-module-lifts
@ -334,9 +321,9 @@
(wrap-form '#%provide s phase))))
(log-expand ctx 'lift-provide result-s))
(define (syntax-local-lift-module-end-declaration s)
(define/who (syntax-local-lift-module-end-declaration s)
(define-values (ctx also-s)
(do-local-lift-to-module 'syntax-local-lift-module-end-declaration
(do-local-lift-to-module who
s
#:no-target-msg "not currently transforming an expression within a module declaration"
#:get-lift-ctx expand-context-to-module-lifts
@ -364,20 +351,20 @@
;; ----------------------------------------
(define (syntax-local-module-defined-identifiers)
(define/who (syntax-local-module-defined-identifiers)
(unless (syntax-local-transforming-module-provides?)
(raise-arguments-error 'syntax-local-module-defined-identifiers "not currently transforming module provides"))
(raise-arguments-error who "not currently transforming module provides"))
(define ctx (get-current-expand-context 'syntax-local-module-defined-identifiers))
(requireds->phase-ht (extract-module-definitions (expand-context-requires+provides ctx))))
(define (syntax-local-module-required-identifiers mod-path phase-level)
(define/who (syntax-local-module-required-identifiers mod-path phase-level)
(unless (or (not mod-path) (module-path? mod-path))
(raise-argument-error 'syntax-local-module-required-identifiers "(or/c module-path? #f)" mod-path))
(raise-argument-error who "(or/c module-path? #f)" mod-path))
(unless (or (eq? phase-level #t) (phase? phase-level))
(raise-argument-error 'syntax-local-module-required-identifiers (format "(or/c ~a #t)" phase?-string) phase-level))
(raise-argument-error who (format "(or/c ~a #t)" phase?-string) phase-level))
(unless (syntax-local-transforming-module-provides?)
(raise-arguments-error 'syntax-local-module-required-identifiers "not currently transforming module provides"))
(raise-arguments-error who "not currently transforming module provides"))
(define ctx (get-current-expand-context 'syntax-local-module-required-identifiers))
(define requires+provides (expand-context-requires+provides ctx))
(define mpi (and mod-path
@ -399,11 +386,11 @@
;; ----------------------------------------
(define (syntax-local-module-exports mod-path)
(define/who (syntax-local-module-exports mod-path)
(unless (or (module-path? mod-path)
(and (syntax? mod-path)
(module-path? (syntax->datum mod-path))))
(raise-argument-error 'syntax-local-module-exports
(raise-argument-error who
(string-append
"(or/c module-path?\n"
" (and/c syntax?\n"
@ -425,8 +412,8 @@
(for/list ([sym (in-hash-keys syms)])
sym))))
(define (syntax-local-submodules)
(define ctx (get-current-expand-context 'syntax-local-submodules))
(define/who (syntax-local-submodules)
(define ctx (get-current-expand-context who))
(define submods (expand-context-declared-submodule-names ctx))
(for/list ([(name kind) (in-hash submods)]
#:when (eq? kind 'module))
@ -435,9 +422,9 @@
;; ----------------------------------------
;; Works well enough for some backward compatibility:
(define (syntax-local-get-shadower id [only-generated? #f])
(check 'syntax-local-get-shadower identifier? id)
(define ctx (get-current-expand-context 'syntax-local-get-shadower))
(define/who (syntax-local-get-shadower id [only-generated? #f])
(check who identifier? id)
(define ctx (get-current-expand-context who))
(define new-id (add-scopes id (expand-context-scopes ctx)))
(if (syntax-clean? id)
new-id

1
racket/src/expander/main.rkt
View File

@ -11,7 +11,6 @@
"read/api.rkt"
"read/primitive-parameter.rkt"
"namespace/api.rkt"
(prefix-in wrapper: "eval/api.rkt")
"namespace/attach.rkt"
"namespace/api-module.rkt"
"namespace/core.rkt"

42
racket/src/expander/namespace/api-module.rkt
View File

@ -21,34 +21,31 @@
;; ----------------------------------------
(define (module-declared? mod [load? #f])
(unless (module-reference? mod)
(raise-argument-error 'module-declared? module-reference-str mod))
(define/who (module-declared? mod [load? #f])
(check who module-reference? #:contract module-reference-str mod)
(define ns (current-namespace))
(define name (reference->resolved-module-path mod #:load? load?))
(and (namespace->module ns name) #t))
(define (module-predefined? mod)
(unless (module-reference? mod)
(raise-argument-error 'module-predefined? module-reference-str mod))
(define/who (module-predefined? mod)
(check who module-reference? #:contract module-reference-str mod)
(define ns (current-namespace))
(define name (reference->resolved-module-path mod #:load? #f))
(define m (namespace->module ns name))
(and m (module-is-predefined? m)))
(define (module-> extract who mod [load? #f])
(unless (module-reference? mod)
(raise-argument-error who module-reference-str mod))
(check who module-reference? #:contract module-reference-str mod)
(define m (namespace->module/complain who
(current-namespace)
(reference->resolved-module-path mod #:load? load?)))
(extract m))
(define (module->language-info mod [load? #f])
(module-> module-language-info 'module->language-info mod load?))
(define/who (module->language-info mod [load? #f])
(module-> module-language-info who mod load?))
(define (module->imports mod)
(module-> module-requires 'module->imports mod))
(define/who (module->imports mod)
(module-> module-requires who mod))
(define (module->exports mod)
(define-values (provides self)
@ -67,10 +64,9 @@
(or (not b/p) (provided-as-protected? b/p)))
'module-provide-protected? mod))
(define (module->namespace mod [ns (current-namespace)])
(unless (module-reference? mod)
(raise-argument-error 'module->namespace module-reference-str mod))
(check 'module->namespace namespace? ns)
(define/who (module->namespace mod [ns (current-namespace)])
(check who module-reference? #:contract module-reference-str mod)
(check who namespace? ns)
(define name (reference->resolved-module-path mod #:load? #t))
(define phase (namespace-phase ns))
(define m-ns (namespace->module-namespace ns name phase))
@ -78,11 +74,11 @@
;; Check for declaration:
(namespace->module/complain 'module->namespace ns name)
;; Must be declared, but not instantiated
(raise-arguments-error 'module->namespace
(raise-arguments-error who
"module not instantiated in the current namespace"
"name" name))
(unless (inspector-superior? (current-code-inspector) (namespace-inspector m-ns))
(raise-arguments-error 'module->namespace
(raise-arguments-error who
"current code inspector cannot access namespace of module"
"module name" name))
(unless (namespace-get-root-expand-ctx m-ns)
@ -93,15 +89,15 @@
(namespace-module-make-available! ns (namespace-mpi m-ns) phase)
m-ns)
(define (namespace-unprotect-module insp mod [ns (current-namespace)])
(check 'namespace-unprotect-module inspector? insp)
(check 'namespace-unprotect-module module-path? mod)
(check 'namespace-unprotect-module namespace? ns)
(define/who (namespace-unprotect-module insp mod [ns (current-namespace)])
(check who inspector? insp)
(check who module-path? mod)
(check who namespace? ns)
(define name (reference->resolved-module-path mod #:load? #f))
(define phase (namespace-phase ns))
(define m-ns (namespace->module-namespace ns name phase))
(unless m-ns
(raise-arguments-error 'namespace-unprotect-module
(raise-arguments-error who
"module not instantiated"
"module name" name))
(when (inspector-superior? insp (namespace-inspector m-ns))

74
racket/src/expander/namespace/api.rkt
View File

@ -54,9 +54,9 @@
(namespace-primitive-module-visit! ns '#%kernel)
ns)
(define (namespace-syntax-introduce s [ns (current-namespace)])
(check 'namespace-syntax-introduce syntax? s)
(check 'namespace-syntax-introduce namespace? ns)
(define/who (namespace-syntax-introduce s [ns (current-namespace)])
(check who syntax? s)
(check who namespace? ns)
(define root-ctx (namespace-get-root-expand-ctx ns))
(define post-scope (root-expand-context-post-expansion-scope root-ctx))
(define other-namespace-scopes (for/list ([sc (in-set
@ -91,10 +91,10 @@
(define (namespace-datum-introduce s)
(namespace-syntax-introduce (datum->syntax #f s)))
(define (namespace-module-identifier [where (current-namespace)])
(define/who (namespace-module-identifier [where (current-namespace)])
(unless (or (namespace? where)
(phase? where))
(raise-argument-error 'namespace-module-identifier
(raise-argument-error who
(string-append "(or/c namespace? " phase?-string ")")
where))
(datum->syntax (syntax-shift-phase-level core-stx
@ -103,8 +103,8 @@
where))
'module))
(define (namespace-symbol->identifier sym)
(check 'namespace-symbol->identifier symbol? sym)
(define/who (namespace-symbol->identifier sym)
(check who symbol? sym)
(namespace-syntax-introduce (datum->syntax #f sym)))
;; ----------------------------------------
@ -146,36 +146,36 @@
#:skip-variable-phase-level skip-variable-phase-level
#:who who)]))
(define (namespace-require req [ns (current-namespace)])
(do-namespace-require 'namespace-require req ns))
(define/who (namespace-require req [ns (current-namespace)])
(do-namespace-require who req ns))
(define (namespace-require/expansion-time req [ns (current-namespace)])
(do-namespace-require #:run? #f #:visit? #t 'namespace-require/expansion-time req ns))
(define/who (namespace-require/expansion-time req [ns (current-namespace)])
(do-namespace-require #:run? #f #:visit? #t who req ns))
(define (namespace-require/constant req [ns (current-namespace)])
(do-namespace-require 'namespace-require/constant req ns
(define/who (namespace-require/constant req [ns (current-namespace)])
(do-namespace-require who req ns
#:copy-variable-phase-level 0
#:copy-variable-as-constant? #t))
(define (namespace-require/copy req [ns (current-namespace)])
(do-namespace-require 'namespace-require/copy req ns
(define/who (namespace-require/copy req [ns (current-namespace)])
(do-namespace-require who req ns
#:copy-variable-phase-level 0
#:skip-variable-phase-level 0))
;; ----------------------------------------
(define (namespace-variable-value sym
[use-mapping? #t]
[failure-thunk #f]
[ns (current-namespace)])
(check 'namespace-variable-value symbol? sym)
(define/who (namespace-variable-value sym
[use-mapping? #t]
[failure-thunk #f]
[ns (current-namespace)])
(check who symbol? sym)
(unless (or (not failure-thunk)
(and (procedure? failure-thunk)
(procedure-arity-includes? failure-thunk 0)))
(raise-argument-error 'namespace-variable-value
(raise-argument-error who
"(or/c #f (procedure-arity-includes/c 0))"
failure-thunk))
(check 'namespace-variable-value namespace? ns)
(check who namespace? ns)
((let/ec escape
(define-values (var-ns var-phase-level var-sym)
(cond
@ -221,13 +221,13 @@
sym)))))))
(lambda () val))))
(define (namespace-set-variable-value! sym
val
[map? #f]
[ns (current-namespace)]
[as-constant? #f])
(check 'namespace-variable-value symbol? sym)
(check 'namespace-variable-value namespace? ns)
(define/who (namespace-set-variable-value! sym
val
[map? #f]
[ns (current-namespace)]
[as-constant? #f])
(check who symbol? sym)
(check who namespace? ns)
(namespace-set-variable! ns (namespace-phase ns) sym val as-constant?)
(when map?
(namespace-unset-transformer! ns (namespace-phase ns) sym)
@ -238,14 +238,14 @@
sym)
(namespace-phase ns))))
(define (namespace-undefine-variable! sym
[ns (current-namespace)])
(check 'namespace-variable-value symbol? sym)
(check 'namespace-variable-value namespace? ns)
(define/who (namespace-undefine-variable! sym
[ns (current-namespace)])
(check who symbol? sym)
(check who namespace? ns)
(namespace-unset-variable! ns (namespace-phase ns) sym))
(define (namespace-mapped-symbols [ns (current-namespace)])
(check 'namespace-mapped-symbols namespace? ns)
(define/who (namespace-mapped-symbols [ns (current-namespace)])
(check who namespace? ns)
(set->list
(set-union
(syntax-mapped-names (root-expand-context-all-scopes-stx (namespace-get-root-expand-ctx ns))
@ -253,6 +253,6 @@
(list->set
(instance-variable-names (namespace->instance ns 0))))))
(define (namespace-base-phase [ns (current-namespace)])
(check 'namespace-base-phase namespace? ns)
(define/who (namespace-base-phase [ns (current-namespace)])
(check who namespace? ns)
(namespace-phase ns))

33
racket/src/expander/namespace/namespace.rkt
View File

@ -2,7 +2,6 @@
(require racket/promise
"../common/phase.rkt"
"../common/small-hash.rkt"
"../syntax/scope.rkt"
"../syntax/bulk-binding.rkt"
"../common/module-path.rkt"
"../expand/root-expand-context.rkt"
@ -62,22 +61,22 @@
[inspector #:mutable] ; instantiation-time inspector
available-module-instances ; phase -> list of module-instance [shared among modules]
module-instances) ; union resolved-module-path -> module-instance [shared among modules]
;; ; 0-phase -> resolved-module-path -> module-instance
;; ; where the first option is for cross phase persistent modules
#:property prop:custom-write
(lambda (ns port mode)
(write-string "#<namespace" port)
(define n (namespace-source-name ns))
(when n
(fprintf port ":~a" (namespace->name ns)))
(define 0-phase (namespace-0-phase ns))
(define phase-level (phase- (namespace-phase ns)
0-phase))
(unless (zero-phase? phase-level)
(fprintf port ":~s" phase-level))
(unless (zero-phase? 0-phase)
(fprintf port "~a~s" (if (positive? 0-phase) "+" "") 0-phase))
(write-string ">" port)))
;; ; 0-phase -> resolved-module-path -> module-instance
;; ; where the first option is for cross phase persistent modules
#:property prop:custom-write
(lambda (ns port mode)
(write-string "#<namespace" port)
(define n (namespace-source-name ns))
(when n
(fprintf port ":~a" (namespace->name ns)))
(define 0-phase (namespace-0-phase ns))
(define phase-level (phase- (namespace-phase ns)
0-phase))
(unless (zero-phase? phase-level)
(fprintf port ":~s" phase-level))
(unless (zero-phase? 0-phase)
(fprintf port "~a~s" (if (positive? 0-phase) "+" "") 0-phase))
(write-string ">" port)))
(struct definitions (variables ; linklet instance
transformers)) ; sym -> val

14
racket/src/expander/namespace/provided.rkt
View File

@ -10,13 +10,13 @@
;; Wrapper for provides that are protected or syntax
(struct provided (binding protected? syntax?)
#:transparent
#:property prop:serialize
(lambda (p ser-push! state)
(ser-push! 'tag '#:provided)
(ser-push! (provided-binding p))
(ser-push! (provided-protected? p))
(ser-push! (provided-syntax? p))))
#:transparent
#:property prop:serialize
(lambda (p ser-push! state)
(ser-push! 'tag '#:provided)
(ser-push! (provided-binding p))
(ser-push! (provided-protected? p))
(ser-push! (provided-syntax? p))))
(define (provided-as-binding v)
(if (provided? v) (provided-binding v) v))

36
racket/src/expander/namespace/variable-reference.rkt
View File

@ -18,12 +18,12 @@
variable-reference->module-base-phase
variable-reference->module-declaration-inspector)
(define (variable-reference->empty-namespace vr)
(check 'variable-reference->empty-namespace variable-reference? vr)
(define/who (variable-reference->empty-namespace vr)
(check who variable-reference? vr)
(new-namespace (variable-reference->namespace vr)))
(define (variable-reference->namespace vr)
(check 'variable-reference->namespace variable-reference? vr)
(define/who (variable-reference->namespace vr)
(check who variable-reference? vr)
(define inst (variable-reference->instance vr))
(cond
[(symbol? inst)
@ -40,37 +40,37 @@
;; Get the defining namespace for the referenced variable
(instance-data inst)]))
(define (variable-reference->module-path-index vr)
(check 'variable-reference->module-path-index variable-reference? vr)
(define/who (variable-reference->module-path-index vr)
(check who variable-reference? vr)
(define mpi (namespace-mpi (variable-reference->namespace vr)))
(if (top-level-module-path-index? mpi)
#f
mpi))
(define (variable-reference->resolved-module-path vr)
(check 'variable-reference->resolved-module-path variable-reference? vr)
(define/who (variable-reference->resolved-module-path vr)
(check who variable-reference? vr)
(define mpi (variable-reference->module-path-index vr))
(and mpi (module-path-index-resolve mpi)))
(define (variable-reference->module-source vr)
(check 'variable-reference->module-source variable-reference? vr)
(define/who (variable-reference->module-source vr)
(check who variable-reference? vr)
(define ns (variable-reference->namespace vr))
(namespace-source-name ns))
(define (variable-reference->phase vr)
(check 'variable-reference->phase variable-reference? vr)
(define/who (variable-reference->phase vr)
(check who variable-reference? vr)
(namespace-phase (variable-reference->namespace vr)))
(define (variable-reference->module-base-phase vr)
(check 'variable-reference->module-base-phase variable-reference? vr)
(define/who (variable-reference->module-base-phase vr)
(check who variable-reference? vr)
(namespace-0-phase (variable-reference->namespace vr)))
(define (variable-reference->module-declaration-inspector vr)
(check 'variable-reference->module-declaration-inspector variable-reference? vr)
(define/who (variable-reference->module-declaration-inspector vr)
(check who variable-reference? vr)
(when (variable-reference->instance vr)
(raise-arguments-error 'variable-reference->module-declaration-inspector
(raise-arguments-error who
"variable reference does not refer to an anonymous module variable"
"variable reference" vr))
(or (namespace-declaration-inspector (variable-reference->namespace vr))
(raise-arguments-error 'variable-reference->module-declaration-inspector
(raise-arguments-error who
"given variable reference is not from a module")))

52
racket/src/expander/read/api.rkt
View File

@ -14,43 +14,37 @@
read/recursive
read-language)
(define (read-syntax [src (object-name (current-input-port))] [in (current-input-port)])
(check 'read-syntax input-port? in)
(define/who (read-syntax [src (object-name (current-input-port))] [in (current-input-port)])
(check who input-port? in)
(raw:read-syntax src in))
(define (read-syntax/recursive [src (object-name (current-input-port))]
[in (current-input-port)]
[start #f]
[readtable (current-readtable)]
[graph? #t])
(check 'read-syntax/recursive input-port? in)
(unless (or (char? start) (not start))
(raise-argument-error 'read-syntax/recursive "(or/c char? #f)" start))
(unless (or (readtable? readtable) (not readtable))
(raise-argument-error 'read-syntax/recursive "(or/c readtable? #f)" readtable))
(define/who (read-syntax/recursive [src (object-name (current-input-port))]
[in (current-input-port)]
[start #f]
[readtable (current-readtable)]
[graph? #t])
(check who input-port? in)
(check who char? #:or-false start)
(check who readtable? #:or-false readtable)
(raw:read-syntax/recursive src in start readtable graph?))
(define (read [in (current-input-port)])
(check 'read input-port? in)
(define/who (read [in (current-input-port)])
(check who input-port? in)
(raw:read in))
(define (read/recursive [in (current-input-port)]
[start #f]
[readtable (current-readtable)]
[graph? #t])
(check 'read/recursive input-port? in)
(unless (or (char? start) (not start))
(raise-argument-error 'read/recursive "(or/c char? #f)" start))
(unless (or (readtable? readtable) (not readtable))
(raise-argument-error 'read/recursive "(or/c readtable? #f)" readtable))
(define/who (read/recursive [in (current-input-port)]
[start #f]
[readtable (current-readtable)]
[graph? #t])
(check who input-port? in)
(check who char? #:or-false start)
(check who readtable? #:or-false readtable)
(raw:read/recursive in start readtable graph?))
(define (read-language [in (current-input-port)]
[fail-thunk read-language-fail-thunk])
(check 'read-language input-port? in)
(unless (and (procedure? fail-thunk)
(procedure-arity-includes? fail-thunk 0))
(raise-argument-error 'read-language "(procedure-arity-includes?/c 0)" fail-thunk))
(define/who (read-language [in (current-input-port)]
[fail-thunk read-language-fail-thunk])
(check who input-port? in)
(check who (procedure-arity-includes/c 0) fail-thunk)
(raw:read-language in (if (eq? fail-thunk read-language-fail-thunk)
#f
fail-thunk)))

13
racket/src/expander/read/readtable-parameter.rkt
View File

@ -1,4 +1,5 @@
#lang racket/base
(require "../common/contract.rkt")
(provide current-readtable
prop:readtable prop:readtable?)
@ -6,11 +7,7 @@
(define-values (prop:readtable prop:readtable? prop:readtable-ref)
(make-struct-type-property 'readtable))
(define current-readtable (make-parameter #f
(lambda (v)
(unless (or (not v)
(prop:readtable? v))
(raise-argument-error 'current-readtable
"(or/c readtable? #f)"
v))
v)))
(define/who current-readtable (make-parameter #f
(lambda (v)
(check who prop:readtable? #:or-false v)
v)))

2
racket/src/expander/read/readtable.rkt
View File

@ -30,7 +30,7 @@
;; 'no-delimit, or a character whose default to use;
;; absence of a mapping is the default for that character
delimiter-ht)
#:property prop:readtable #t)
#:property prop:readtable #t)
(define (make-readtable rt . args)
(unless (or (not rt) (readtable? rt))

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

@ -22,15 +22,15 @@
syntax-rearm
syntax-taint)
(define (syntax-tainted? s)
(check 'syntax-tainted? syntax? s)
(define/who (syntax-tainted? s)
(check who syntax? s)
(raw:syntax-tainted? s))
(define (syntax-arm s [maybe-insp #f] [use-mode? #f])
(check 'syntax-arm syntax? s)
(define/who (syntax-arm s [maybe-insp #f] [use-mode? #f])
(check who syntax? s)
(unless (or (not maybe-insp)
(inspector? maybe-insp))
(raise-argument-error 'syntax-arm "(or/c inspector? #f)" maybe-insp))
(raise-argument-error who "(or/c inspector? #f)" maybe-insp))
(define insp (inspector-for-taint maybe-insp))
(cond
[use-mode?
@ -41,17 +41,17 @@
[else
(raw:syntax-arm s insp)]))
(define (syntax-disarm s maybe-insp)
(check 'syntax-disarm syntax? s)
(define/who (syntax-disarm s maybe-insp)
(check who syntax? s)
(unless (or (not maybe-insp)
(inspector? maybe-insp))
(raise-argument-error 'syntax-disarm "(or/c inspector? #f)" maybe-insp))
(raise-argument-error who "(or/c inspector? #f)" maybe-insp))
(define insp (inspector-for-taint maybe-insp))
(raw:syntax-disarm s insp))
(define (syntax-rearm s from-s [use-mode? #f])
(check 'syntax-disarm syntax? s)
(check 'syntax-disarm syntax? from-s)
(define/who (syntax-rearm s from-s [use-mode? #f])
(check who syntax? s)
(check who syntax? from-s)
(cond
[use-mode? (taint-dispatch
s
@ -60,8 +60,8 @@
[else
(raw:syntax-rearm s from-s)]))
(define (syntax-taint s)
(check 'syntax-taint syntax? s)
(define/who (syntax-taint s)
(check who syntax? s)
(raw:syntax-taint s))
;; ----------------------------------------
@ -70,5 +70,3 @@
(or maybe-insp
(current-module-code-inspector)
(current-code-inspector)))
;; ----------------------------------------

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

@ -54,12 +54,12 @@
syntax-track-origin
syntax-debug-info)
(define (syntax-e s)
(check 'syntax-e syntax? s)
(define/who (syntax-e s)
(check who syntax? s)
(raw:syntax-e s))
(define (syntax->datum s)
(check 'syntax->datum syntax? s)
(define/who (syntax->datum s)
(check who syntax? s)
(raw:syntax->datum s))
(define (maybe-syntax->datum s)
@ -67,13 +67,13 @@
(raw:syntax->datum s)
s))
(define (datum->syntax stx-c s [stx-l #f] [stx-p #f] [ignored #f])
(define/who (datum->syntax stx-c s [stx-l #f] [stx-p #f] [ignored #f])
(unless (or (not stx-c) (syntax? stx-c))
(raise-argument-error 'datum->syntax "(or #f syntax?)" stx-c))
(raise-argument-error who "(or #f syntax?)" stx-c))
(unless (or (not stx-l)
(syntax? stx-l)
(encoded-srcloc? stx-l))
(raise-argument-error 'datum->syntax
(raise-argument-error who
(string-append "(or #f syntax?\n"
" (list/c any/c\n"
" (or/c exact-positive-integer? #f)\n"
@ -87,101 +87,94 @@
" (or/c exact-nonnegative-integer? #f)))")
stx-l))
(unless (or (not stx-p) (syntax? stx-p))
(raise-argument-error 'datum->syntax "(or #f syntax?)" stx-p))
(raise-argument-error who "(or #f syntax?)" stx-p))
(raw:datum->syntax stx-c s (to-srcloc-stx stx-l) stx-p))
(define (syntax->list s)
(check 'syntax->list syntax? s)
(define/who (syntax->list s)
(check who syntax? s)
(raw:syntax->list s))
(define (syntax-original? s)
(check 'syntax-original? syntax? s)
(define/who (syntax-original? s)
(check who syntax? s)
(and (syntax-property s original-property-sym)
(not (syntax-any-macro-scopes? s))))
(define (bound-identifier=? a b [phase (syntax-local-phase-level)])
(check 'bound-identifier=? identifier? a)
(check 'bound-identifier=? identifier? b)
(unless (phase? phase)
(raise-argument-error 'bound-identifier=? phase?-string phase))
(define/who (bound-identifier=? a b [phase (syntax-local-phase-level)])
(check who identifier? a)
(check who identifier? b)
(check who phase? #:contract phase?-string phase)
(raw:bound-identifier=? a b phase))
(define (free-identifier=? a b
[a-phase (syntax-local-phase-level)]
[b-phase a-phase])
(check 'free-identifier=? identifier? a)
(check 'free-identifier=? identifier? b)
(unless (phase? a-phase)
(raise-argument-error 'free-identifier=? phase?-string a-phase))
(unless (phase? b-phase)
(raise-argument-error 'free-identifier=? phase?-string b-phase))
(define/who (free-identifier=? a b
[a-phase (syntax-local-phase-level)]
[b-phase a-phase])
(check who identifier? a)
(check who identifier? b)
(check who phase? #:contract phase?-string a-phase)
(check who phase? #:contract phase?-string b-phase)
(raw:free-identifier=? a b a-phase b-phase))
(define (free-transformer-identifier=? a b)
(check 'free-transformer-identifier=? identifier? a)
(check 'free-transformer-identifier=? identifier? b)
(define/who (free-transformer-identifier=? a b)
(check who identifier? a)
(check who identifier? b)
(define phase (add1 (syntax-local-phase-level)))
(raw:free-identifier=? a b phase phase))
(define (free-template-identifier=? a b)
(check 'free-template-identifier=? identifier? a)
(check 'free-template-identifier=? identifier? b)
(define/who (free-template-identifier=? a b)
(check who identifier? a)
(check who identifier? b)
(define phase (sub1 (syntax-local-phase-level)))
(raw:free-identifier=? a b phase phase))
(define (free-label-identifier=? a b)
(check 'free-label-identifier=? identifier? a)
(check 'free-label-identifier=? identifier? b)
(define/who (free-label-identifier=? a b)
(check who identifier? a)
(check who identifier? b)
(raw:free-identifier=? a b #f #f))
(define (identifier-binding id [phase (syntax-local-phase-level)] [top-level-symbol? #f])
(check 'identifier-binding identifier? id)
(unless (phase? phase)
(raise-argument-error 'identifier-binding phase?-string phase))
(define/who (identifier-binding id [phase (syntax-local-phase-level)] [top-level-symbol? #f])
(check who identifier? id)
(check who phase? #:contract phase?-string phase)
(raw:identifier-binding id phase top-level-symbol?))
(define (identifier-transformer-binding id [phase (syntax-local-phase-level)])
(check 'identifier-transformer-binding identifier? id)
(define/who (identifier-transformer-binding id [phase (syntax-local-phase-level)])
(check who identifier? id)
(raw:identifier-binding id (and phase (add1 phase))))
(define (identifier-template-binding id)
(check 'identifier-template-binding identifier? id)
(define/who (identifier-template-binding id)
(check who identifier? id)
(raw:identifier-binding id (sub1 (syntax-local-phase-level))))
(define (identifier-label-binding id)
(check 'identifier-label-binding identifier? id)
(define/who (identifier-label-binding id)
(check who identifier? id)
(raw:identifier-binding id #f))
(define (identifier-binding-symbol id [phase (syntax-local-phase-level)])
(check 'identifier-binding-symbol identifier? id)
(unless (phase? phase)
(raise-argument-error 'identifier-binding-symbol phase?-string phase))
(define/who (identifier-binding-symbol id [phase (syntax-local-phase-level)])
(check who identifier? id)
(check who phase? #:contract phase?-string phase)
(raw:identifier-binding-symbol id phase))
(define (identifier-prune-lexical-context id [syms null])
(check 'identifier-prune-lexical-context identifier? id)
(define/who (identifier-prune-lexical-context id [syms null])
(check who identifier? id)
(unless (and (list? syms)
(andmap symbol? syms))
(raise-argument-error 'identifier-prune-lexical-context "(listof symbol?)" syms))
(raise-argument-error who "(listof symbol?)" syms))
;; It's a no-op in the Racket v6.5 expander
id)
(define (syntax-debug-info s [phase (syntax-local-phase-level)] [all-bindings? #f])
(check 'syntax-debug-info syntax? s)
(unless (phase? phase)
(raise-argument-error 'syntax-debug-info phase?-string phase))
(define/who (syntax-debug-info s [phase (syntax-local-phase-level)] [all-bindings? #f])
(check who syntax? s)
(check who phase? #:contract phase?-string phase)
(raw:syntax-debug-info s phase all-bindings?))
(define (syntax-shift-phase-level s phase)
(check 'syntax-shift-phase-level syntax? s)
(unless (phase? phase)
(raise-argument-error 'syntax-shift-phase-level phase?-string phase))
(define/who (syntax-shift-phase-level s phase)
(check who syntax? s)
(check who phase? #:contract phase?-string phase)
(raw:syntax-shift-phase-level s phase))
(define (syntax-track-origin new-stx old-stx id)
(check 'syntax-track-origin syntax? new-stx)
(check 'syntax-track-origin syntax? old-stx)
(check 'syntax-track-origin identifier? id)
(define/who (syntax-track-origin new-stx old-stx id)
(check who syntax? new-stx)
(check who syntax? old-stx)
(check who identifier? id)
(define s (raw:syntax-track-origin new-stx old-stx id))
(define ctx (get-current-expand-context #:fail-ok? #t))
(when ctx (log-expand ctx 'track-origin new-stx s))

34
racket/src/expander/syntax/binding-table.rkt
View File

@ -43,11 +43,11 @@
(struct table-with-bulk-bindings (syms
syms/serialize ; copy of `syms`, but maybe with less nominal info
bulk-bindings)
#:property prop:serialize
(lambda (twbb ser-push! state)
(ser-push! 'tag '#:table-with-bulk-bindings)
(ser-push! (table-with-bulk-bindings-syms/serialize twbb))
(ser-push! (table-with-bulk-bindings-bulk-bindings twbb))))
#:property prop:serialize
(lambda (twbb ser-push! state)
(ser-push! 'tag '#:table-with-bulk-bindings)
(ser-push! (table-with-bulk-bindings-syms/serialize twbb))
(ser-push! (table-with-bulk-bindings-bulk-bindings twbb))))
(define (deserialize-table-with-bulk-bindings syms bulk-bindings)
(table-with-bulk-bindings syms syms bulk-bindings))
@ -56,18 +56,18 @@
(struct bulk-binding-at (scopes ; scope set
bulk) ; bulk-binding
#:property prop:serialize
(lambda (bba ser-push! state)
;; Data that is interpreted by the deserializer:
(ser-push! 'tag '#:bulk-binding-at)
(ser-push! (bulk-binding-at-scopes bba))
(ser-push! (bulk-binding-at-bulk bba)))
#:property prop:reach-scopes
(lambda (sms reach)
;; bulk bindings are pruned dependong on whether all scopes
;; in `scopes` are reachable, and we shouldn't get here
;; when looking for scopes
(error "shouldn't get here")))
#:property prop:serialize
(lambda (bba ser-push! state)
;; Data that is interpreted by the deserializer:
(ser-push! 'tag '#:bulk-binding-at)
(ser-push! (bulk-binding-at-scopes bba))
(ser-push! (bulk-binding-at-bulk bba)))
#:property prop:reach-scopes
(lambda (sms reach)
;; bulk bindings are pruned dependong on whether all scopes
;; in `scopes` are reachable, and we shouldn't get here
;; when looking for scopes
(error "shouldn't get here")))
(define (deserialize-bulk-binding-at scopes bulk)
(bulk-binding-at scopes bulk))

112
racket/src/expander/syntax/bulk-binding.rkt
View File

@ -1,10 +1,8 @@
#lang racket/base
(require "../compile/serialize-property.rkt"
"syntax.rkt"
"binding-table.rkt" ; defines `prop:bulk-binding`
"binding.rkt"
"../common/module-path.rkt"
(only-in "../compile/reserved-symbol.rkt" bulk-binding-registry-id)
"../namespace/provided.rkt")
(provide provide-binding-to-require-binding
@ -81,61 +79,61 @@
provide-phase-level ; providing module's import phase
phase-shift ; providing module's instantiation phase
bulk-binding-registry) ; a registry for finding bulk bindings lazily
#:property prop:bulk-binding
(bulk-binding-class
(lambda (b mpi-shifts)
(or (bulk-binding-provides b)
;; Here's where we find provided bindings for unmarshaled syntax
(let ([mod-name (module-path-index-resolve
(apply-syntax-shifts
(bulk-binding-mpi b)
mpi-shifts))])
(unless (bulk-binding-bulk-binding-registry b)
(error "namespace mismatch: no bulk-binding registry available:"
mod-name))
(define table (bulk-binding-registry-table (bulk-binding-bulk-binding-registry b)))
(define bulk-provide (hash-ref table mod-name #f))
(unless bulk-provide
(error "namespace mismatch: bulk bindings not found in registry for module:"
mod-name))
;; Reset `provide` and `self` to the discovered information
(set-bulk-binding-self! b (bulk-provide-self bulk-provide))
(define provides (hash-ref (bulk-provide-provides bulk-provide)
(bulk-binding-provide-phase-level b)))
;; Remove exceptions and add prefix
(define excepts (bulk-binding-excepts b))
(define prefix (bulk-binding-prefix b))
(define adjusted-provides
(cond
[(or prefix (positive? (hash-count excepts)))
(bulk-provides-add-prefix-remove-exceptions provides prefix excepts)]
[else provides]))
;; Record the adjusted `provides` table for quick future access:
(set-bulk-binding-provides! b adjusted-provides)
adjusted-provides)))
(lambda (b binding sym)
;; Convert the provided binding to a required binding on
;; demand during binding resolution
(provide-binding-to-require-binding
binding (if (bulk-binding-prefix b)
(string->symbol
(substring (symbol->string sym)
(string-length (symbol->string (bulk-binding-prefix b)))))
sym)
#:self (bulk-binding-self b)
#:mpi (bulk-binding-mpi b)
#:provide-phase-level (bulk-binding-provide-phase-level b)
#:phase-shift (bulk-binding-phase-shift b))))
#:property prop:serialize
;; Serialization drops the `provides` table and the providing module's `self`
(lambda (b ser-push! reachable-scopes)
(ser-push! 'tag '#:bulk-binding)
(ser-push! (bulk-binding-prefix b))
(ser-push! (bulk-binding-excepts b))
(ser-push! (bulk-binding-mpi b))
(ser-push! (bulk-binding-provide-phase-level b))
(ser-push! (bulk-binding-phase-shift b))
(ser-push! 'tag '#:bulk-binding-registry)))
#:property prop:bulk-binding
(bulk-binding-class
(lambda (b mpi-shifts)
(or (bulk-binding-provides b)
;; Here's where we find provided bindings for unmarshaled syntax
(let ([mod-name (module-path-index-resolve
(apply-syntax-shifts
(bulk-binding-mpi b)
mpi-shifts))])
(unless (bulk-binding-bulk-binding-registry b)
(error "namespace mismatch: no bulk-binding registry available:"
mod-name))
(define table (bulk-binding-registry-table (bulk-binding-bulk-binding-registry b)))
(define bulk-provide (hash-ref table mod-name #f))
(unless bulk-provide
(error "namespace mismatch: bulk bindings not found in registry for module:"
mod-name))
;; Reset `provide` and `self` to the discovered information
(set-bulk-binding-self! b (bulk-provide-self bulk-provide))
(define provides (hash-ref (bulk-provide-provides bulk-provide)
(bulk-binding-provide-phase-level b)))
;; Remove exceptions and add prefix
(define excepts (bulk-binding-excepts b))
(define prefix (bulk-binding-prefix b))
(define adjusted-provides
(cond
[(or prefix (positive? (hash-count excepts)))
(bulk-provides-add-prefix-remove-exceptions provides prefix excepts)]
[else provides]))
;; Record the adjusted `provides` table for quick future access:
(set-bulk-binding-provides! b adjusted-provides)
adjusted-provides)))
(lambda (b binding sym)
;; Convert the provided binding to a required binding on
;; demand during binding resolution
(provide-binding-to-require-binding
binding (if (bulk-binding-prefix b)
(string->symbol
(substring (symbol->string sym)
(string-length (symbol->string (bulk-binding-prefix b)))))
sym)
#:self (bulk-binding-self b)
#:mpi (bulk-binding-mpi b)
#:provide-phase-level (bulk-binding-provide-phase-level b)
#:phase-shift (bulk-binding-phase-shift b))))
#:property prop:serialize
;; Serialization drops the `provides` table and the providing module's `self`
(lambda (b ser-push! reachable-scopes)
(ser-push! 'tag '#:bulk-binding)
(ser-push! (bulk-binding-prefix b))
(ser-push! (bulk-binding-excepts b))
(ser-push! (bulk-binding-mpi b))
(ser-push! (bulk-binding-provide-phase-level b))
(ser-push! (bulk-binding-phase-shift b))
(ser-push! 'tag '#:bulk-binding-registry)))
(define (deserialize-bulk-binding prefix excepts mpi provide-phase-level phase-shift bulk-binding-registry)
(bulk-binding #f prefix excepts #f mpi provide-phase-level phase-shift bulk-binding-registry))

51
racket/src/expander/syntax/error.rkt
View File

@ -13,47 +13,46 @@
raise-unbound-syntax-error)
(struct exn:fail:syntax exn:fail (exprs)
#:extra-constructor-name make-exn:fail:syntax
#:transparent
#:property prop:exn:srclocs (lambda (e) (filter values (map syntax-srcloc (exn:fail:syntax-exprs e))))
#:guard (lambda (str cm exprs info)
(unless (and (list? exprs)
(andmap syntax? exprs))
(raise-argument-error 'exn:fail:syntax "(listof syntax?)" exprs))
(values str cm exprs)))
#:extra-constructor-name make-exn:fail:syntax
#:transparent
#:property prop:exn:srclocs (lambda (e) (filter values (map syntax-srcloc (exn:fail:syntax-exprs e))))
#:guard (lambda (str cm exprs info)
(unless (and (list? exprs)
(andmap syntax? exprs))
(raise-argument-error 'exn:fail:syntax "(listof syntax?)" exprs))
(values str cm exprs)))
(struct exn:fail:syntax:unbound exn:fail:syntax ()
#:extra-constructor-name make-exn:fail:syntax:unbound
#:transparent)
#:extra-constructor-name make-exn:fail:syntax:unbound
#:transparent)
(define (raise-syntax-error given-name message
[expr #f] [sub-expr #f]
[extra-sources null]
[message-suffix ""])
(do-raise-syntax-error exn:fail:syntax given-name message
(define/who (raise-syntax-error given-name message
[expr #f] [sub-expr #f]
[extra-sources null]
[message-suffix ""])
(do-raise-syntax-error who exn:fail:syntax given-name message
expr sub-expr
extra-sources
message-suffix))
(define (raise-unbound-syntax-error given-name message
[expr #f] [sub-expr #f]
[extra-sources null]
[message-suffix ""])
(do-raise-syntax-error exn:fail:syntax:unbound given-name message
(define/who (raise-unbound-syntax-error given-name message
[expr #f] [sub-expr #f]
[extra-sources null]
[message-suffix ""])
(do-raise-syntax-error who exn:fail:syntax:unbound given-name message
expr sub-expr
extra-sources
message-suffix))
(define (do-raise-syntax-error exn:fail:syntax given-name message
(define (do-raise-syntax-error who exn:fail:syntax given-name message
expr sub-expr
extra-sources
message-suffix)
(unless (or (not given-name) (symbol? given-name))
(raise-argument-error 'raise-syntax-error "(or/c symbol? #f)" given-name))
(check 'raise-syntax-error string? message)
(check who symbol? #:or-false given-name)
(check who string? message)
(unless (and (list? extra-sources)
(andmap syntax? extra-sources))
(raise-argument-error 'raise-syntax-error "(listof syntax?)" extra-sources))
(check 'raise-syntax-error string? message-suffix)
(raise-argument-error who "(listof syntax?)" extra-sources))
(check who string? message-suffix)
(define name
(format "~a" (or given-name
(extract-form-name expr)

8
racket/src/expander/syntax/full-binding.rkt
View File

@ -9,10 +9,10 @@
;; `free-identifier=?` equivalence
(struct full-binding (frame-id ; used to trigger use-site scopes
free=id) ; `free-identifier=?` equivalence via a rename-transformer binding
#:authentic
#:property prop:binding-reach-scopes
(lambda (b)
(binding-free=id b)))
#:authentic
#:property prop:binding-reach-scopes
(lambda (b)
(binding-free=id b)))
(define (binding-frame-id b)
(and (full-binding? b)

14
racket/src/expander/syntax/local-binding.rkt
View File

@ -22,13 +22,13 @@
;; the binding was local. The `frame-id` field is used to
;; trigger use-site scopes as needed
(struct full-local-binding full-binding (key)
#:authentic
#:property prop:serialize
(lambda (b ser-push! state)
;; Data that is interpreted by the deserializer:
(ser-push! 'tag '#:local-binding)
(ser-push! (full-local-binding-key b))
(ser-push! (full-binding-free=id b))))
#:authentic
#:property prop:serialize
(lambda (b ser-push! state)
;; Data that is interpreted by the deserializer:
(ser-push! 'tag '#:local-binding)
(ser-push! (full-local-binding-key b))
(ser-push! (full-binding-free=id b))))
(define (deserialize-full-local-binding key free=id)
(full-local-binding #f free=id key))

74
racket/src/expander/syntax/module-binding.rkt
View File

@ -1,7 +1,5 @@
#lang racket/base
(require "../common/set.rkt"
"../compile/serialize-property.rkt"
"../compile/serialize-state.rkt"
(require "../compile/serialize-property.rkt"
"full-binding.rkt")
(provide make-module-binding
@ -84,43 +82,43 @@
nominal-require-phase
extra-inspector ; preserves access to protected definitions
extra-nominal-bindings)
#:authentic
#:transparent
#:property prop:serialize
(lambda (b ser-push! state)
;; Dropping the frame id may simplify the representation:
(define simplified-b
(if (full-binding-frame-id b)
(module-binding-update b #:frame-id #f)
b))
(cond
[(full-module-binding? simplified-b)
(ser-push! 'tag '#:module-binding)
(ser-push! (full-module-binding-module b))
(ser-push! (full-module-binding-sym b))
(ser-push! (full-module-binding-phase b))
(ser-push! (full-module-binding-nominal-module b))
(ser-push! (full-module-binding-nominal-phase b))
(ser-push! (full-module-binding-nominal-sym b))
(ser-push! (full-module-binding-nominal-require-phase b))
(ser-push! (full-binding-free=id b))
(if (full-module-binding-extra-inspector b)
(ser-push! 'tag '#:inspector)
(ser-push! #f))
(ser-push! (full-module-binding-extra-nominal-bindings b))]
[else
(ser-push! simplified-b)])))
#:authentic
#:transparent
#:property prop:serialize
(lambda (b ser-push! state)
;; Dropping the frame id may simplify the representation:
(define simplified-b
(if (full-binding-frame-id b)
(module-binding-update b #:frame-id #f)
b))
(cond
[(full-module-binding? simplified-b)
(ser-push! 'tag '#:module-binding)
(ser-push! (full-module-binding-module b))
(ser-push! (full-module-binding-sym b))
(ser-push! (full-module-binding-phase b))
(ser-push! (full-module-binding-nominal-module b))
(ser-push! (full-module-binding-nominal-phase b))
(ser-push! (full-module-binding-nominal-sym b))
(ser-push! (full-module-binding-nominal-require-phase b))
(ser-push! (full-binding-free=id b))
(if (full-module-binding-extra-inspector b)
(ser-push! 'tag '#:inspector)
(ser-push! #f))
(ser-push! (full-module-binding-extra-nominal-bindings b))]
[else
(ser-push! simplified-b)])))
(struct simple-module-binding (module phase sym nominal-module)
#:authentic
#:transparent
#:property prop:serialize
(lambda (b ser-push! state)
(ser-push! 'tag '#:simple-module-binding)
(ser-push! (simple-module-binding-module b))
(ser-push! (simple-module-binding-sym b))
(ser-push! (simple-module-binding-phase b))
(ser-push! (simple-module-binding-nominal-module b))))
#:authentic
#:transparent
#:property prop:serialize
(lambda (b ser-push! state)
(ser-push! 'tag '#:simple-module-binding)
(ser-push! (simple-module-binding-module b))
(ser-push! (simple-module-binding-sym b))
(ser-push! (simple-module-binding-phase b))
(ser-push! (simple-module-binding-nominal-module b))))
(define (deserialize-full-module-binding module sym phase
nominal-module

29
racket/src/expander/syntax/property.rkt
View File

@ -10,24 +10,24 @@
;; ----------------------------------------
(define syntax-property
(define/who syntax-property
(case-lambda
[(s key)
(check 'syntax-property syntax? s)
(check who syntax? s)
(define v (hash-ref (syntax-props s) key #f))
(plain-property-value v)]
[(s key val)
(check 'syntax-property syntax? s)
(check who syntax? s)
(define pval (if (eq? key 'paren-shape)
(preserved-property-value val)
val))
(struct-copy syntax s
[props (hash-set (syntax-props s) key pval)])]
[(s key val preserved?)
(check 'syntax-property syntax? s)
(check who syntax? s)
(when preserved?
(unless (and (symbol? key) (symbol-interned? key))
(raise-arguments-error 'syntax-property
(raise-arguments-error who
"key for a perserved property must be an interned symbol"
"given key" key
"given value" val)))
@ -37,19 +37,18 @@
(struct-copy syntax s
[props (hash-set (syntax-props s) key pval)])]))
(define (syntax-property-preserved? s key)
(check 'syntax-property-preserved syntax? s)
(define/who (syntax-property-preserved? s key)
(check who syntax? s)
(unless (and (symbol? key) (symbol-interned? key))
(raise-argument-error 'syntax-property "(and/c symbol? symbol-interned?)" key))
(raise-argument-error who "(and/c symbol? symbol-interned?)" key))
(preserved-property-value? (hash-ref (syntax-props s) key #f)))
(define syntax-property-symbol-keys
(lambda (s)
(unless (syntax? s)
(raise-argument-error 'syntax-property-symbol-keys "syntax" s))
(for/list ([(k v) (in-immutable-hash (syntax-props s))]
#:when (and (symbol? k) (symbol-interned? k)))
k)))
(define/who (syntax-property-symbol-keys s)
(unless (syntax? s)
(raise-argument-error who "syntax" s))
(for/list ([(k v) (in-immutable-hash (syntax-props s))]
#:when (and (symbol? k) (symbol-interned? k)))
k))
(define (syntax-property-remove s key)
(if (hash-ref (syntax-props s) key #f)

242
racket/src/expander/syntax/scope.rkt
View File

@ -74,43 +74,43 @@
(struct scope (id ; internal scope identity; used for sorting
kind ; debug info
[binding-table #:mutable]) ; see "binding-table.rkt"
#:authentic
;; Custom printer:
#:property prop:custom-write
(lambda (sc port mode)
(write-string "#<scope:" port)
(display (scope-id sc) port)
(write-string ":" port)
(display (scope-kind sc) port)
(write-string ">" port))
#:property prop:serialize
(lambda (s ser-push! state)
(unless (set-member? (serialize-state-reachable-scopes state) s)
(error "internal error: found supposedly unreachable scope"))
(cond
[(eq? s top-level-common-scope)
(ser-push! 'tag '#:scope)]
[else
(ser-push! 'tag '#:scope+kind)
(ser-push! (scope-kind s))]))
#:property prop:serialize-fill!
(lambda (s ser-push! state)
(cond
[(binding-table-empty? (scope-binding-table s))
(ser-push! 'tag #f)]
[else
(ser-push! 'tag '#:scope-fill!)
(ser-push! (binding-table-prune-to-reachable (scope-binding-table s) state))]))
#:property prop:reach-scopes
(lambda (s reach)
;; the `bindings` field is handled via `prop:scope-with-bindings`
(void))
#:property prop:scope-with-bindings
(lambda (s get-reachable-scopes reach register-trigger)
(binding-table-register-reachable (scope-binding-table s)
get-reachable-scopes
reach
register-trigger)))
#:authentic
;; Custom printer:
#:property prop:custom-write
(lambda (sc port mode)
(write-string "#<scope:" port)
(display (scope-id sc) port)
(write-string ":" port)
(display (scope-kind sc) port)
(write-string ">" port))
#:property prop:serialize
(lambda (s ser-push! state)
(unless (set-member? (serialize-state-reachable-scopes state) s)
(error "internal error: found supposedly unreachable scope"))
(cond
[(eq? s top-level-common-scope)
(ser-push! 'tag '#:scope)]
[else
(ser-push! 'tag '#:scope+kind)
(ser-push! (scope-kind s))]))
#:property prop:serialize-fill!
(lambda (s ser-push! state)
(cond
[(binding-table-empty? (scope-binding-table s))
(ser-push! 'tag #f)]
[else
(ser-push! 'tag '#:scope-fill!)
(ser-push! (binding-table-prune-to-reachable (scope-binding-table s) state))]))
#:property prop:reach-scopes
(lambda (s reach)
;; the `bindings` field is handled via `prop:scope-with-bindings`
(void))
#:property prop:scope-with-bindings
(lambda (s get-reachable-scopes reach register-trigger)
(binding-table-register-reachable (scope-binding-table s)
get-reachable-scopes
reach
register-trigger)))
(define deserialize-scope
(case-lambda
@ -138,76 +138,76 @@
scopes ; phase -> representative-scope
shifted ; box of table: interned shifted-multi-scopes for non-label phases
label-shifted) ; box of table: interned shifted-multi-scopes for label phases
#:authentic
#:property prop:serialize
(lambda (ms ser-push! state)
(ser-push! 'tag '#:multi-scope)
(ser-push! (multi-scope-name ms))
;; Prune to reachable representative scopes
(define multi-scope-tables (serialize-state-multi-scope-tables state))
(ser-push! (or (hash-ref multi-scope-tables (multi-scope-scopes ms) #f)
(let ([ht (make-hasheqv)])
(for ([(phase sc) (in-hash (multi-scope-scopes ms))])
(when (set-member? (serialize-state-reachable-scopes state) sc)
(hash-set! ht phase sc)))
(hash-set! multi-scope-tables (multi-scope-scopes ms) ht)
ht))))
#:property prop:reach-scopes
(lambda (s reach)
;; the `scopes` field is handled via `prop:scope-with-bindings`
(void))
#:property prop:scope-with-bindings
(lambda (ms get-reachable-scopes reach register-trigger)
;; This scope is reachable via its multi-scope, but it only
;; matters if it's reachable through a binding (otherwise it
;; can be re-generated later). We don't want to keep a scope
;; that can be re-generated, because pruning it makes
;; compilation more deterministic relative to other
;; compilations that involve a shared module. If the scope
;; itself has any bindings, then we count it as reachable
;; through a binding (which is an approxmation, because
;; other scopes in the binding may be unreachable, but it
;; seems good enough for determinism).
;; To make that work, `binding-table-register-reachable`
;; needs to recognize representative scopes and treat
;; them differently, hence `prop:implicitly-reachable`.
(for ([sc (in-hash-values (multi-scope-scopes ms))])
(unless (binding-table-empty? (scope-binding-table sc))
(reach sc)))))
#:authentic
#:property prop:serialize
(lambda (ms ser-push! state)
(ser-push! 'tag '#:multi-scope)
(ser-push! (multi-scope-name ms))
;; Prune to reachable representative scopes
(define multi-scope-tables (serialize-state-multi-scope-tables state))
(ser-push! (or (hash-ref multi-scope-tables (multi-scope-scopes ms) #f)
(let ([ht (make-hasheqv)])
(for ([(phase sc) (in-hash (multi-scope-scopes ms))])
(when (set-member? (serialize-state-reachable-scopes state) sc)
(hash-set! ht phase sc)))
(hash-set! multi-scope-tables (multi-scope-scopes ms) ht)
ht))))
#:property prop:reach-scopes
(lambda (s reach)
;; the `scopes` field is handled via `prop:scope-with-bindings`
(void))
#:property prop:scope-with-bindings
(lambda (ms get-reachable-scopes reach register-trigger)
;; This scope is reachable via its multi-scope, but it only
;; matters if it's reachable through a binding (otherwise it
;; can be re-generated later). We don't want to keep a scope
;; that can be re-generated, because pruning it makes
;; compilation more deterministic relative to other
;; compilations that involve a shared module. If the scope
;; itself has any bindings, then we count it as reachable
;; through a binding (which is an approxmation, because
;; other scopes in the binding may be unreachable, but it
;; seems good enough for determinism).
;; To make that work, `binding-table-register-reachable`
;; needs to recognize representative scopes and treat
;; them differently, hence `prop:implicitly-reachable`.
(for ([sc (in-hash-values (multi-scope-scopes ms))])
(unless (binding-table-empty? (scope-binding-table sc))
(reach sc)))))
(define (deserialize-multi-scope name scopes)
(multi-scope (new-deserialize-scope-id!) name scopes (box (hasheqv)) (box (hash))))
(struct representative-scope scope (owner ; a multi-scope for which this one is a phase-specific identity
phase) ; phase of this scope
#:authentic
#:mutable ; to support serialization
#:property prop:custom-write
(lambda (sc port mode)
(write-string "#<scope:" port)
(display (scope-id sc) port)
(when (representative-scope-owner sc)
(write-string "=" port)
(display (multi-scope-id (representative-scope-owner sc)) port))
(write-string "@" port)
(display (representative-scope-phase sc) port)
(write-string ">" port))
#:property prop:serialize
(lambda (s ser-push! state)
(ser-push! 'tag '#:representative-scope)
(ser-push! (scope-kind s))
(ser-push! (representative-scope-phase s)))
#:property prop:serialize-fill!
(lambda (s ser-push! state)
(ser-push! 'tag '#:representative-scope-fill!)
(ser-push! (binding-table-prune-to-reachable (scope-binding-table s) state))
(ser-push! (representative-scope-owner s)))
#:property prop:reach-scopes
(lambda (s reach)
;; the inherited `bindings` field is handled via `prop:scope-with-bindings`
(reach (representative-scope-owner s)))
;; Used by `binding-table-register-reachable`:
#:property prop:implicitly-reachable #t)
#:authentic
#:mutable ; to support serialization
#:property prop:custom-write
(lambda (sc port mode)
(write-string "#<scope:" port)
(display (scope-id sc) port)
(when (representative-scope-owner sc)
(write-string "=" port)
(display (multi-scope-id (representative-scope-owner sc)) port))
(write-string "@" port)
(display (representative-scope-phase sc) port)
(write-string ">" port))
#:property prop:serialize
(lambda (s ser-push! state)
(ser-push! 'tag '#:representative-scope)
(ser-push! (scope-kind s))
(ser-push! (representative-scope-phase s)))
#:property prop:serialize-fill!
(lambda (s ser-push! state)
(ser-push! 'tag '#:representative-scope-fill!)
(ser-push! (binding-table-prune-to-reachable (scope-binding-table s) state))
(ser-push! (representative-scope-owner s)))
#:property prop:reach-scopes
(lambda (s reach)
;; the inherited `bindings` field is handled via `prop:scope-with-bindings`
(reach (representative-scope-owner s)))
;; Used by `binding-table-register-reachable`:
#:property prop:implicitly-reachable #t)
(define (deserialize-representative-scope kind phase)
(define v (representative-scope (new-deserialize-scope-id!) kind #f #f phase))
@ -219,22 +219,22 @@
(struct shifted-multi-scope (phase ; non-label phase shift or shifted-to-label-phase
multi-scope) ; a multi-scope
#:authentic
#:property prop:custom-write
(lambda (sms port mode)
(write-string "#<scope:" port)
(display (multi-scope-id (shifted-multi-scope-multi-scope sms)) port)
(write-string "@" port)
(display (shifted-multi-scope-phase sms) port)
(write-string ">" port))
#:property prop:serialize
(lambda (sms ser-push! state)
(ser-push! 'tag '#:shifted-multi-scope)
(ser-push! (shifted-multi-scope-phase sms))
(ser-push! (shifted-multi-scope-multi-scope sms)))
#:property prop:reach-scopes
(lambda (sms reach)
(reach (shifted-multi-scope-multi-scope sms))))
#:authentic
#:property prop:custom-write
(lambda (sms port mode)
(write-string "#<scope:" port)
(display (multi-scope-id (shifted-multi-scope-multi-scope sms)) port)
(write-string "@" port)
(display (shifted-multi-scope-phase sms) port)
(write-string ">" port))
#:property prop:serialize
(lambda (sms ser-push! state)
(ser-push! 'tag '#:shifted-multi-scope)
(ser-push! (shifted-multi-scope-phase sms))
(ser-push! (shifted-multi-scope-multi-scope sms)))
#:property prop:reach-scopes
(lambda (sms reach)
(reach (shifted-multi-scope-multi-scope sms))))
(define (deserialize-shifted-multi-scope phase multi-scope)
(intern-shifted-multi-scope phase multi-scope))
@ -466,10 +466,10 @@
add-mpi-shifts ; #f or (mpi-shifts -> mpi-shifts)
inspector ; #f or inspector
tamper) ; see "tamper.rkt"
#:authentic
#:property prop:propagation syntax-e
#:property prop:propagation-tamper (lambda (p) (propagation-tamper p))
#:property prop:propagation-set-tamper (lambda (p v) (propagation-set-tamper p v)))
#:authentic
#:property prop:propagation syntax-e
#:property prop:propagation-tamper (lambda (p) (propagation-tamper p))
#:property prop:propagation-set-tamper (lambda (p v) (propagation-set-tamper p v)))
(define (propagation-add prop sc prev-scs prev-smss prev-mss)
(if (propagation? prop)

202
racket/src/expander/syntax/syntax.rkt
View File

@ -37,107 +37,107 @@
srcloc ; source location
props ; properties
inspector) ; inspector for access to protected bindings
#:authentic
;; Custom printer:
#:property prop:custom-write
(lambda (s port mode)
(write-string "#<syntax" port)
(define srcloc (syntax-srcloc s))
(when srcloc
(define srcloc-str (srcloc->string srcloc))
(when srcloc-str
(fprintf port ":~a" srcloc-str)))
(fprintf port " ~.s" (syntax->datum s))
(write-string ">" port))
#:property prop:serialize
(lambda (s ser-push! state)
(define prop (syntax-scope-propagations+tamper s))
(define content
(if (propagation? prop)
((propagation-ref prop) s)
(syntax-content s)))
(define properties
(intern-properties
(syntax-props s)
(lambda ()
(for/hasheq ([(k v) (in-hash (syntax-props s))]
#:when (preserved-property-value? v))
(values k (check-value-to-preserve (plain-property-value v) syntax?))))
state))
(define tamper
(serialize-tamper (syntax-tamper s)))
(define context-triple
(intern-context-triple (intern-scopes (syntax-scopes s) state)
(intern-shifted-multi-scopes (syntax-shifted-multi-scopes s) state)
(intern-mpi-shifts (syntax-mpi-shifts s) state)
state))
(define stx-state (get-syntax-context state))
(cond
[(or properties tamper)
(ser-push! 'tag '#:syntax+props)
(push-syntax-context! state #f)
(ser-push! content)
(pop-syntax-context! state)
(ser-push! 'reference context-triple)
(ser-push! 'reference (syntax-srcloc s))
(ser-push! properties)
(ser-push! tamper)
(when stx-state (set-syntax-state-all-sharing?! stx-state #f))]
[else
;; We rely on two passes to reach a fixpoint on sharing:
(define sharing-mode (hash-ref (serialize-state-sharing-syntaxes state) s 'unknown))
(cond
[(eq? sharing-mode 'share)
(ser-push! 'tag '#:datum->syntax)
(ser-push! (syntax->datum s))]
[(eq? sharing-mode 'unknown)
(ser-push! 'tag '#:syntax)
;; Communicate to nested syntax objects the info that they might share
(define this-state (and (no-pair-syntax-in-cdr? content)
(syntax-state #t context-triple (syntax-srcloc s))))
(push-syntax-context! state this-state)
;; Serialize content
(ser-push! content)
;; Check whether we're sharing for all nested syntax objects
(pop-syntax-context! state)
(define new-sharing-mode
(if (and this-state
(syntax-state-all-sharing? this-state))
'share
'none))
(hash-set! (serialize-state-sharing-syntaxes state)
s
;; If the syntax object has only simple content,
;; it doesn't need any sharing support by itself
(if (datum-has-elements? content)
new-sharing-mode
'none))
(when (and stx-state (eq? new-sharing-mode 'none))
(set-syntax-state-all-sharing?! stx-state #f))]
[else
(ser-push! 'tag '#:syntax)
(push-syntax-context! state #f)
(ser-push! content)
(pop-syntax-context! state)])
;; Finish up
(ser-push! 'reference context-triple)
(ser-push! 'reference (syntax-srcloc s))
(when stx-state
(unless (and (eq? context-triple (syntax-state-context-triple stx-state))
(equal? (syntax-srcloc s) (syntax-state-srcloc stx-state)))
(set-syntax-state-all-sharing?! stx-state #f)))]))
#:property prop:reach-scopes
(lambda (s reach)
(define prop (syntax-scope-propagations+tamper s))
(reach (if (propagation? prop)
((propagation-ref prop) s)
(syntax-content s)))
(reach (syntax-scopes s))
(reach (syntax-shifted-multi-scopes s))
(for ([(k v) (in-immutable-hash (syntax-props s))]
#:when (preserved-property-value? v))
(reach (plain-property-value v)))
(reach (syntax-srcloc s))))
#:authentic
;; Custom printer:
#:property prop:custom-write
(lambda (s port mode)
(write-string "#<syntax" port)
(define srcloc (syntax-srcloc s))
(when srcloc
(define srcloc-str (srcloc->string srcloc))
(when srcloc-str
(fprintf port ":~a" srcloc-str)))
(fprintf port " ~.s" (syntax->datum s))
(write-string ">" port))
#:property prop:serialize
(lambda (s ser-push! state)
(define prop (syntax-scope-propagations+tamper s))
(define content
(if (propagation? prop)
((propagation-ref prop) s)
(syntax-content s)))
(define properties
(intern-properties
(syntax-props s)
(lambda ()
(for/hasheq ([(k v) (in-hash (syntax-props s))]
#:when (preserved-property-value? v))
(values k (check-value-to-preserve (plain-property-value v) syntax?))))
state))
(define tamper
(serialize-tamper (syntax-tamper s)))
(define context-triple
(intern-context-triple (intern-scopes (syntax-scopes s) state)
(intern-shifted-multi-scopes (syntax-shifted-multi-scopes s) state)
(intern-mpi-shifts (syntax-mpi-shifts s) state)
state))
(define stx-state (get-syntax-context state))
(cond
[(or properties tamper)
(ser-push! 'tag '#:syntax+props)
(push-syntax-context! state #f)
(ser-push! content)
(pop-syntax-context! state)
(ser-push! 'reference context-triple)
(ser-push! 'reference (syntax-srcloc s))
(ser-push! properties)
(ser-push! tamper)
(when stx-state (set-syntax-state-all-sharing?! stx-state #f))]
[else
;; We rely on two passes to reach a fixpoint on sharing:
(define sharing-mode (hash-ref (serialize-state-sharing-syntaxes state) s 'unknown))
(cond
[(eq? sharing-mode 'share)
(ser-push! 'tag '#:datum->syntax)
(ser-push! (syntax->datum s))]
[(eq? sharing-mode 'unknown)
(ser-push! 'tag '#:syntax)
;; Communicate to nested syntax objects the info that they might share
(define this-state (and (no-pair-syntax-in-cdr? content)
(syntax-state #t context-triple (syntax-srcloc s))))
(push-syntax-context! state this-state)
;; Serialize content
(ser-push! content)
;; Check whether we're sharing for all nested syntax objects
(pop-syntax-context! state)
(define new-sharing-mode
(if (and this-state
(syntax-state-all-sharing? this-state))
'share
'none))
(hash-set! (serialize-state-sharing-syntaxes state)
s
;; If the syntax object has only simple content,
;; it doesn't need any sharing support by itself
(if (datum-has-elements? content)
new-sharing-mode
'none))
(when (and stx-state (eq? new-sharing-mode 'none))
(set-syntax-state-all-sharing?! stx-state #f))]
[else
(ser-push! 'tag '#:syntax)
(push-syntax-context! state #f)
(ser-push! content)
(pop-syntax-context! state)])
;; Finish up
(ser-push! 'reference context-triple)
(ser-push! 'reference (syntax-srcloc s))
(when stx-state
(unless (and (eq? context-triple (syntax-state-context-triple stx-state))
(equal? (syntax-srcloc s) (syntax-state-srcloc stx-state)))
(set-syntax-state-all-sharing?! stx-state #f)))]))
#:property prop:reach-scopes
(lambda (s reach)
(define prop (syntax-scope-propagations+tamper s))
(reach (if (propagation? prop)
((propagation-ref prop) s)
(syntax-content s)))
(reach (syntax-scopes s))
(reach (syntax-shifted-multi-scopes s))
(for ([(k v) (in-immutable-hash (syntax-props s))]
#:when (preserved-property-value? v))
(reach (plain-property-value v)))
(reach (syntax-srcloc s))))
;; Property to abstract over handling of propagation for
;; serialization; property value takes a syntax object and

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

File diff suppressed because it is too large Load Diff