diff --git a/collects/syntax/parse/debug.rkt b/collects/syntax/parse/debug.rkt index 0cfdb37dd3..5e89215486 100644 --- a/collects/syntax/parse/debug.rkt +++ b/collects/syntax/parse/debug.rkt @@ -6,11 +6,15 @@ "private/rep.rkt" "private/kws.rkt") "../parse.rkt" + syntax/parse/private/residual "private/runtime.rkt" "private/runtime-progress.rkt" - "private/runtime-report.rkt" + (except-in "private/runtime-report.rkt" + syntax-patterns-fail) "private/kws.rkt") +;; No lazy loading for this module's dependencies. + (provide syntax-class-parse syntax-class-attributes syntax-class-arity diff --git a/collects/syntax/parse/experimental/contract.rkt b/collects/syntax/parse/experimental/contract.rkt index d0d7064e34..c0f14a6ebe 100644 --- a/collects/syntax/parse/experimental/contract.rkt +++ b/collects/syntax/parse/experimental/contract.rkt @@ -3,7 +3,7 @@ "../private/lib.rkt" "provide.rkt" unstable/wrapc - (only-in "../private/runtime.rkt" + (only-in syntax/parse/private/residual ;; keep abs. path this-context-syntax) racket/contract/base) diff --git a/collects/syntax/parse/experimental/eh.rkt b/collects/syntax/parse/experimental/eh.rkt index 2a0bc90d5d..305080721f 100644 --- a/collects/syntax/parse/experimental/eh.rkt +++ b/collects/syntax/parse/experimental/eh.rkt @@ -1,77 +1,5 @@ #lang racket/base -(require (for-syntax racket/base - syntax/parse - racket/syntax - "../private/minimatch.rkt" - "../private/rep.rkt" - "../private/rep-data.rkt" - "../private/rep-patterns.rkt") - "../private/keywords.rkt" - "../private/sc.rkt") - +(require "../private/sc.rkt" + "../private/keywords.rkt") (provide ~eh-var define-eh-alternative-set) - -(define-syntax (define-eh-alternative-set stx) - (define-syntax-class alt - #:description "eh-alternate-set alternative" - #:literals (pattern) - (pattern (pattern alt))) - (syntax-parse stx - #:literals (pattern) - [(_ name:id a:alt ...) - (parameterize ((current-syntax-context stx)) - (let* ([decls (new-declenv null #:conventions null)] - [ehpat+hstx-list - (apply append - (for/list ([alt (in-list (syntax->list #'(a.alt ...)))]) - (parse*-ellipsis-head-pattern alt decls #t #:context stx)))] - [eh-alt+defs-list - (for/list ([ehpat+hstx (in-list ehpat+hstx-list)]) - (let ([ehpat (car ehpat+hstx)] - [hstx (cadr ehpat+hstx)]) - (cond [(syntax? hstx) - (with-syntax ([(parser) (generate-temporaries '(eh-alt-parser))]) - (let ([attrs (iattrs->sattrs (pattern-attrs (ehpat-head ehpat)))]) - (list (eh-alternative (ehpat-repc ehpat) attrs #'parser) - (list #`(define parser - (parser/rhs parser () #,attrs - [#:description #f (pattern #,hstx)] - #t - #,stx))))))] - [(eh-alternative? hstx) - (list hstx null)] - [else - (error 'define-eh-alternative-set "internal error: unexpected ~e" - hstx)])))] - [eh-alts (map car eh-alt+defs-list)] - [defs (apply append (map cadr eh-alt+defs-list))]) - (with-syntax ([(def ...) defs] - [(alt-expr ...) - (for/list ([alt (in-list eh-alts)]) - (with-syntax ([repc-expr - (match (eh-alternative-repc alt) - ['#f - #'(quote #f)] - [(rep:once n u o) - #`(rep:once (quote-syntax #,n) - (quote-syntax #,u) - (quote-syntax #,o))] - [(rep:optional n o d) - #`(rep:optional (quote-syntax #,n) - (quote-syntax #,o) - (quote-syntax #,d))] - [(rep:bounds min max n u o) - #`(rep:bounds (quote #,min) - (quote #,max) - (quote-syntax #,n) - (quote-syntax #,u) - (quote-syntax #,o))])] - [attrs-expr - #`(quote #,(eh-alternative-attrs alt))] - [parser-expr - #`(quote-syntax #,(eh-alternative-parser alt))]) - #'(eh-alternative repc-expr attrs-expr parser-expr)))]) - #'(begin def ... - (define-syntax name - (eh-alternative-set (list alt-expr ...)))))))])) diff --git a/collects/syntax/parse/experimental/reflect.rkt b/collects/syntax/parse/experimental/reflect.rkt index 3445eea56b..519a9d7b62 100644 --- a/collects/syntax/parse/experimental/reflect.rkt +++ b/collects/syntax/parse/experimental/reflect.rkt @@ -1,10 +1,38 @@ #lang racket/base -(require racket/contract/base +(require (for-syntax racket/base + unstable/lazy-require + syntax/parse/private/residual-ct) ;; keep abs.path + racket/contract/base racket/contract/combinator "../private/minimatch.rkt" "../private/keywords.rkt" "../private/runtime-reflect.rkt" "../private/kws.rkt") +(begin-for-syntax + (lazy-require + [syntax/parse/private/rep-data ;; keep abs. path + (get-stxclass + stxclass-delimit-cut?)])) + +(define-syntax (reify-syntax-class stx) + (if (eq? (syntax-local-context) 'expression) + (syntax-case stx () + [(rsc sc) + (let* ([stxclass (get-stxclass #'sc)] + [splicing? (stxclass-splicing? stxclass)]) + (unless (stxclass-delimit-cut? stxclass) + (raise-syntax-error #f "cannot reify syntax class with #:no-delimit-cut option" + stx #'sc)) + (with-syntax ([name (stxclass-name stxclass)] + [parser (stxclass-parser stxclass)] + [arity (stxclass-arity stxclass)] + [(#s(attr aname adepth _) ...) (stxclass-attrs stxclass)] + [ctor + (if splicing? + #'reified-splicing-syntax-class + #'reified-syntax-class)]) + #'(ctor 'name parser 'arity '((aname adepth) ...))))]) + #`(#%expression #,stx))) (define (reified-syntax-class-arity r) (match (reified-arity r) diff --git a/collects/syntax/parse/experimental/splicing.rkt b/collects/syntax/parse/experimental/splicing.rkt index 77d911e40e..b0a3244b31 100644 --- a/collects/syntax/parse/experimental/splicing.rkt +++ b/collects/syntax/parse/experimental/splicing.rkt @@ -1,11 +1,16 @@ #lang racket/base (require (for-syntax racket/base - "../../parse.rkt" - "../private/rep-data.rkt" + syntax/parse + unstable/lazy-require "../private/kws.rkt") - "../private/runtime.rkt") + syntax/parse/private/residual) ;; keep abs. path (provide define-primitive-splicing-syntax-class) +(begin-for-syntax + (lazy-require + [syntax/parse/private/rep-attrs + (sort-sattrs)])) + (define-syntax (define-primitive-splicing-syntax-class stx) (define-syntax-class attr diff --git a/collects/syntax/parse/private/keywords.rkt b/collects/syntax/parse/private/keywords.rkt index 1b115f0aac..d37c9dfa59 100644 --- a/collects/syntax/parse/private/keywords.rkt +++ b/collects/syntax/parse/private/keywords.rkt @@ -3,12 +3,13 @@ ;; == Keywords +(define-for-syntax (bad-keyword-use stx) + (raise-syntax-error #f "keyword used out of context" stx)) + (define-syntax-rule (define-keyword name) (begin (provide name) - (define-syntax name - (lambda (stx) - (raise-syntax-error #f "keyword used out of context" stx))))) + (define-syntax name bad-keyword-use))) (define-keyword pattern) (define-keyword ~var) diff --git a/collects/syntax/parse/private/lib.rkt b/collects/syntax/parse/private/lib.rkt index 79a5a33cd1..b8ad8652db 100644 --- a/collects/syntax/parse/private/lib.rkt +++ b/collects/syntax/parse/private/lib.rkt @@ -73,11 +73,3 @@ #:attr value (syntax-local-value #'x (lambda () notfound)) #:fail-when (eq? (attribute value) notfound) #f #:fail-unless (pred (attribute value)) #f)) - -#| -(define-syntax-class expr - #:attributes () - #:description "expression" - #:commit - (pattern (~and x (~fail #:when (keyword? (syntax-e #'x)))))) -|# diff --git a/collects/syntax/parse/private/litconv.rkt b/collects/syntax/parse/private/litconv.rkt index f96e5672a6..b3cc2fdb6c 100644 --- a/collects/syntax/parse/private/litconv.rkt +++ b/collects/syntax/parse/private/litconv.rkt @@ -1,14 +1,20 @@ #lang racket/base (require (for-syntax racket/base + unstable/lazy-require "sc.rkt" "lib.rkt" + "kws.rkt" racket/syntax - syntax/keyword - "rep-data.rkt" - "rep.rkt" - "kws.rkt") - "runtime.rkt" + syntax/keyword) + syntax/parse/private/residual-ct ;; keep abs. path + syntax/parse/private/residual ;; keep abs. path (only-in unstable/syntax phase-of-enclosing-module)) +(begin-for-syntax + (lazy-require + [syntax/parse/private/rep ;; keep abs. path + (parse-kw-formals + check-conventions-rules + create-aux-def)])) (provide define-conventions define-literal-set literal-set->predicate @@ -44,6 +50,8 @@ (define/with-syntax (class-name ...) (map den:delayed-class dens)) + ;; FIXME: could move make-den:delayed to user of conventions + ;; and eliminate from residual.rkt #'(begin (define-syntax h.name (make-conventions diff --git a/collects/syntax/parse/private/parse-aux.rkt b/collects/syntax/parse/private/parse-aux.rkt new file mode 100644 index 0000000000..ab53814afc --- /dev/null +++ b/collects/syntax/parse/private/parse-aux.rkt @@ -0,0 +1,19 @@ +#lang racket/base +(require (for-template "parse.rkt")) +(provide id:define-syntax-class + id:define-splicing-syntax-class + id:syntax-parse + id:syntax-parser + id:define/syntax-parse + id:syntax-parser/template + id:parser/rhs + id:define-eh-alternative-set) + +(define (id:define-syntax-class) #'define-syntax-class) +(define (id:define-splicing-syntax-class) #'define-splicing-syntax-class) +(define (id:syntax-parse) #'syntax-parse) +(define (id:syntax-parser) #'syntax-parser) +(define (id:define/syntax-parse) #'define/syntax-parse) +(define (id:syntax-parser/template) #'syntax-parser/template) +(define (id:parser/rhs) #'parser/rhs) +(define (id:define-eh-alternative-set) #'define-eh-alternative-set) diff --git a/collects/syntax/parse/private/parse.rkt b/collects/syntax/parse/private/parse.rkt index da9918d523..02ea3e297f 100644 --- a/collects/syntax/parse/private/parse.rkt +++ b/collects/syntax/parse/private/parse.rkt @@ -4,18 +4,170 @@ syntax/id-table syntax/keyword racket/syntax + "minimatch.rkt" + "rep-attrs.rkt" "rep-data.rkt" + "rep-patterns.rkt" "rep.rkt" "kws.rkt" "txlift.rkt") + "keywords.rkt" racket/syntax racket/stxparam syntax/stx unstable/struct - "runtime.rkt" - "runtime-report.rkt" - "runtime-reflect.rkt") -(provide (all-defined-out)) + syntax/parse/private/residual ;; keep abs. path + syntax/parse/private/runtime ;; keep abs.path + syntax/parse/private/runtime-reflect) ;; keep abs. path + +;; ============================================================ + +(provide define-syntax-class + define-splicing-syntax-class + syntax-parse + syntax-parser + define/syntax-parse + syntax-parser/template + parser/rhs + define-eh-alternative-set) + +(begin-for-syntax + (define (tx:define-*-syntax-class stx splicing?) + (syntax-case stx () + [(_ header . rhss) + (parameterize ((current-syntax-context stx)) + (let-values ([(name formals arity) + (let ([p (check-stxclass-header #'header stx)]) + (values (car p) (cadr p) (caddr p)))]) + (let* ([the-rhs (parse-rhs #'rhss #f splicing? #:context stx)] + [opt-rhs+def + (and (andmap identifier? (syntax->list formals)) + (optimize-rhs the-rhs (syntax->list formals)))] + [the-rhs (if opt-rhs+def (car opt-rhs+def) the-rhs)]) + (with-syntax ([name name] + [formals formals] + [parser (generate-temporary (format-symbol "parse-~a" name))] + [arity arity] + [attrs (rhs-attrs the-rhs)] + [(opt-def ...) + (if opt-rhs+def + (list (cadr opt-rhs+def)) + '())] + [options (rhs-options the-rhs)] + [integrate-expr + (syntax-case (rhs-integrate the-rhs) () + [#s(integrate predicate description) + #'(integrate (quote-syntax predicate) + 'description)] + [#f + #''#f])]) + #`(begin (define-syntax name + (stxclass 'name 'arity + 'attrs + (quote-syntax parser) + '#,splicing? + options + integrate-expr)) + opt-def ... + (define-values (parser) + ;; If opt-rhs, do not reparse: + ;; need to keep same generated predicate name + #,(if opt-rhs+def + (begin + #`(parser/rhs/parsed + name formals attrs #,the-rhs + #,(and (rhs-description the-rhs) #t) + #,splicing? #,stx)) + #`(parser/rhs + name formals attrs rhss #,splicing? #,stx))))))))]))) + +(define-syntax define-syntax-class + (lambda (stx) (tx:define-*-syntax-class stx #f))) +(define-syntax define-splicing-syntax-class + (lambda (stx) (tx:define-*-syntax-class stx #t))) + +(define-syntax (parser/rhs stx) + (syntax-case stx () + [(parser/rhs name formals attrs rhss splicing? ctx) + (with-disappeared-uses + (let ([rhs + (parameterize ((current-syntax-context #'ctx)) + (parse-rhs #'rhss (syntax->datum #'attrs) (syntax-e #'splicing?) + #:context #'ctx))]) + #`(parser/rhs/parsed name formals attrs + #,rhs #,(and (rhs-description rhs) #t) + splicing? ctx)))])) + +(define-syntax (parser/rhs/parsed stx) + (syntax-case stx () + [(prp name formals attrs rhs rhs-has-description? splicing? ctx) + #`(let ([get-description + (lambda formals + (if 'rhs-has-description? + #,(rhs-description (syntax-e #'rhs)) + (symbol->string 'name)))]) + (parse:rhs rhs attrs formals splicing? + (if 'rhs-has-description? + #,(rhs-description (syntax-e #'rhs)) + (symbol->string 'name))))])) + +(define-syntax (syntax-parse stx) + (syntax-case stx () + [(syntax-parse stx-expr . clauses) + (quasisyntax/loc stx + (let ([x (datum->syntax #f stx-expr)]) + (parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx))))])) + +(define-syntax (syntax-parser stx) + (syntax-case stx () + [(syntax-parser . clauses) + (quasisyntax/loc stx + (lambda (x) + (let ([x (datum->syntax #f x)]) + (parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx)))))])) + +(define-syntax (syntax-parser/template stx) + (syntax-case stx () + [(syntax-parser/template ctx . clauses) + (quasisyntax/loc stx + (lambda (x) + (let ([x (datum->syntax #f x)]) + (parse:clauses x clauses one-template ctx))))])) + +(define-syntax (define/syntax-parse stx) + (syntax-case stx () + [(define/syntax-parse pattern . rest) + (let-values ([(rest pattern defs) + (parse-pattern+sides #'pattern + #'rest + #:splicing? #f + #:decls (new-declenv null) + #:context stx)]) + (let ([expr + (syntax-case rest () + [( expr ) #'expr] + [_ (raise-syntax-error #f "bad syntax" stx)])] + [attrs (pattern-attrs pattern)]) + (with-syntax ([(a ...) attrs] + [(#s(attr name _ _) ...) attrs] + [pattern pattern] + [(def ...) defs] + [expr expr]) + #'(defattrs/unpack (a ...) + (let* ([x (datum->syntax #f expr)] + [cx x] + [pr (ps-empty x x)] + [es null] + [fh0 (syntax-patterns-fail x)]) + (parameterize ((current-syntax-context x)) + def ... + (#%expression + (with ([fail-handler fh0] + [cut-prompt fh0]) + (parse:S x cx pattern pr es + (list (attribute name) ...))))))))))])) + +;; ============================================================ #| Parsing protocol: @@ -807,11 +959,72 @@ Conventions: [(_ rep #s(rep:bounds min max name too-few-msg too-many-msg)) (expect:message (or too-many-msg (name->too-many name)))])) -(define (name->too-few/once name) - (and name (format "missing required occurrence of ~a" name))) +;; ==== -(define (name->too-few name) - (and name (format "too few occurrences of ~a" name))) - -(define (name->too-many name) - (and name (format "too many occurrences of ~a" name))) +(define-syntax (define-eh-alternative-set stx) + (define (parse-alt x) + (syntax-case x (pattern) + [(pattern alt) + #'alt] + [else + (wrong-syntax x "expected eh-alternative-set alternative")])) + (parameterize ((current-syntax-context stx)) + (syntax-case stx () + [(_ name a ...) + (unless (identifier? #'name) + (wrong-syntax #'name "expected identifier")) + (let* ([alts (map parse-alt (syntax->list #'(a ...)))] + [decls (new-declenv null #:conventions null)] + [ehpat+hstx-list + (apply append + (for/list ([alt (in-list alts)]) + (parse*-ellipsis-head-pattern alt decls #t #:context stx)))] + [eh-alt+defs-list + (for/list ([ehpat+hstx (in-list ehpat+hstx-list)]) + (let ([ehpat (car ehpat+hstx)] + [hstx (cadr ehpat+hstx)]) + (cond [(syntax? hstx) + (with-syntax ([(parser) (generate-temporaries '(eh-alt-parser))]) + (let ([attrs (iattrs->sattrs (pattern-attrs (ehpat-head ehpat)))]) + (list (eh-alternative (ehpat-repc ehpat) attrs #'parser) + (list #`(define parser + (parser/rhs parser () #,attrs + [#:description #f (pattern #,hstx)] + #t + #,stx))))))] + [(eh-alternative? hstx) + (list hstx null)] + [else + (error 'define-eh-alternative-set "internal error: unexpected ~e" + hstx)])))] + [eh-alts (map car eh-alt+defs-list)] + [defs (apply append (map cadr eh-alt+defs-list))]) + (with-syntax ([(def ...) defs] + [(alt-expr ...) + (for/list ([alt (in-list eh-alts)]) + (with-syntax ([repc-expr + (match (eh-alternative-repc alt) + ['#f + #'(quote #f)] + [(rep:once n u o) + #`(rep:once (quote-syntax #,n) + (quote-syntax #,u) + (quote-syntax #,o))] + [(rep:optional n o d) + #`(rep:optional (quote-syntax #,n) + (quote-syntax #,o) + (quote-syntax #,d))] + [(rep:bounds min max n u o) + #`(rep:bounds (quote #,min) + (quote #,max) + (quote-syntax #,n) + (quote-syntax #,u) + (quote-syntax #,o))])] + [attrs-expr + #`(quote #,(eh-alternative-attrs alt))] + [parser-expr + #`(quote-syntax #,(eh-alternative-parser alt))]) + #'(eh-alternative repc-expr attrs-expr parser-expr)))]) + #'(begin def ... + (define-syntax name + (eh-alternative-set (list alt-expr ...))))))]))) diff --git a/collects/syntax/parse/private/rep-attrs.rkt b/collects/syntax/parse/private/rep-attrs.rkt index 90a02d0658..66af4ec0bb 100644 --- a/collects/syntax/parse/private/rep-attrs.rkt +++ b/collects/syntax/parse/private/rep-attrs.rkt @@ -1,9 +1,9 @@ #lang racket/base -(require racket/contract/base +(require syntax/parse/private/residual-ct ;; keep abs. path + racket/contract/base syntax/id-table racket/syntax unstable/struct) -(provide (struct-out attr)) #| An IAttr is (make-attr identifier number boolean) @@ -19,8 +19,6 @@ SAttr lists are always stored in sorted order, to make comparison of signatures easier for reified syntax-classes. |# -(define-struct attr (name depth syntax?) #:prefab) - (define (iattr? a) (and (attr? a) (identifier? (attr-name a)))) diff --git a/collects/syntax/parse/private/rep-data.rkt b/collects/syntax/parse/private/rep-data.rkt index b43f38ac74..f80f52f6df 100644 --- a/collects/syntax/parse/private/rep-data.rkt +++ b/collects/syntax/parse/private/rep-data.rkt @@ -4,45 +4,30 @@ racket/list syntax/id-table racket/syntax + syntax/parse/private/residual-ct ;; keep abs. path "minimatch.rkt" "kws.rkt" "rep-attrs.rkt" "rep-patterns.rkt") -(provide (all-from-out "rep-attrs.rkt") - (all-from-out "rep-patterns.rkt") - (struct-out stxclass) +;; from residual.rkt +(provide (struct-out stxclass) (struct-out options) (struct-out integrate) - stxclass/s? + (struct-out conventions) + (struct-out literalset) + (struct-out eh-alternative-set) + (struct-out eh-alternative)) +;; from here +(provide stxclass/s? stxclass/h? stxclass-commit? stxclass-delimit-cut? - (struct-out attr) (struct-out rhs) (struct-out variant) (struct-out clause:fail) (struct-out clause:with) (struct-out clause:attr) - (struct-out clause:do) - (struct-out conventions) - (struct-out literalset) - (struct-out eh-alternative-set) - (struct-out eh-alternative)) - -#| -A stxclass is - #s(stxclass symbol (listof symbol) (list-of SAttr) identifier bool Options Integrate/#f) -where Options = #s(options boolean boolean) - Integrate = #s(integrate id string) -Arity is defined in kws.rkt -|# -(define-struct stxclass (name arity attrs parser splicing? options integrate) - #:prefab) - -(define-struct options (commit? delimit-cut?) - #:prefab) -(define-struct integrate (predicate description) - #:prefab) + (struct-out clause:do)) (define (stxclass/s? x) (and (stxclass? x) (not (stxclass-splicing? x)))) @@ -72,33 +57,11 @@ A Variant is SideClause is defined in rep-patterns |# -#| -A Conventions is - (make-conventions id (-> (listof ConventionRule))) -A ConventionRule is (list regexp DeclEntry) -|# -(define-struct conventions (get-procedures get-rules) #:transparent) - -#| -A LiteralSet is - (make-literalset (listof (list symbol id phase-var-id))) -|# -(define-struct literalset (literals) #:transparent) - ;; make-dummy-stxclass : identifier -> SC ;; Dummy stxclass for calculating attributes of recursive stxclasses. (define (make-dummy-stxclass name) (make stxclass (syntax-e name) #f null #f #f #s(options #f #t) #f)) -#| -An EH-alternative-set is - (eh-alternative-set (listof EH-alternative) -An EH-alternative is - (eh-alternative RepetitionConstraint (listof SAttr) id) -|# -(define-struct eh-alternative-set (alts)) -(define-struct eh-alternative (repc attrs parser)) - ;; Environments #| @@ -130,7 +93,7 @@ expressions are duplicated, and may be evaluated in different scopes. (define-struct den:class (name class argu)) (define-struct den:magic-class (name class argu)) (define-struct den:parser (parser attrs splicing? commit? delimit-cut?)) -(define-struct den:delayed (parser class)) +;; and from residual.rkt: (define-struct den:delayed (parser class)) (define (new-declenv literals #:conventions [conventions null]) (make-declenv @@ -229,6 +192,7 @@ expressions are duplicated, and may be evaluated in different scopes. (struct-out den:class) (struct-out den:magic-class) (struct-out den:parser) + ;; from residual.rkt: (struct-out den:delayed)) (provide/contract diff --git a/collects/syntax/parse/private/rep-patterns.rkt b/collects/syntax/parse/private/rep-patterns.rkt index adc453045d..8b37f6cd3e 100644 --- a/collects/syntax/parse/private/rep-patterns.rkt +++ b/collects/syntax/parse/private/rep-patterns.rkt @@ -1,5 +1,6 @@ #lang racket/base -(require "rep-attrs.rkt" +(require syntax/parse/private/residual-ct ;; keep abs. path + "rep-attrs.rkt" "kws.rkt" unstable/struct (for-syntax racket/base diff --git a/collects/syntax/parse/private/rep.rkt b/collects/syntax/parse/private/rep.rkt index c0af86edb1..47c380372a 100644 --- a/collects/syntax/parse/private/rep.rkt +++ b/collects/syntax/parse/private/rep.rkt @@ -1,8 +1,9 @@ #lang racket/base (require (for-template racket/base racket/stxparam - "keywords.rkt" - "runtime.rkt") + syntax/parse/private/keywords + syntax/parse/private/residual ;; keep abs. path + syntax/parse/private/runtime) racket/contract/base "minimatch.rkt" syntax/id-table @@ -11,7 +12,10 @@ racket/syntax unstable/struct "txlift.rkt" + "rep-attrs.rkt" "rep-data.rkt" + "rep-patterns.rkt" + syntax/parse/private/residual-ct ;; keep abs. path "kws.rkt") ;; Error reporting @@ -188,7 +192,7 @@ (define attributes (options-select-value chunks '#:attributes #:default #f)) (define-values (decls defs) (get-decls+defs chunks strict?)) (values rest description transparent? attributes auto-nested? colon-notation? - decls defs (make options commit? delimit-cut?))) + decls defs (options commit? delimit-cut?))) ;; ---- diff --git a/collects/syntax/parse/private/residual-ct.rkt b/collects/syntax/parse/private/residual-ct.rkt new file mode 100644 index 0000000000..a99d49a94a --- /dev/null +++ b/collects/syntax/parse/private/residual-ct.rkt @@ -0,0 +1,54 @@ +#lang racket/base +(provide (struct-out attr) + (struct-out stxclass) + (struct-out options) + (struct-out integrate) + (struct-out conventions) + (struct-out literalset) + (struct-out eh-alternative-set) + (struct-out eh-alternative) + (struct-out den:delayed)) + +;; == from rep-attr.rkt +(define-struct attr (name depth syntax?) #:prefab) + +;; == from rep-data.rkt + +#| +A stxclass is + #s(stxclass symbol (listof symbol) (list-of SAttr) identifier bool Options Integrate/#f) +where Options = #s(options boolean boolean) + Integrate = #s(integrate id string) +Arity is defined in kws.rkt +|# +(define-struct stxclass (name arity attrs parser splicing? options integrate) + #:prefab) + +(define-struct options (commit? delimit-cut?) + #:prefab) +(define-struct integrate (predicate description) + #:prefab) + +#| +A Conventions is + (make-conventions id (-> (listof ConventionRule))) +A ConventionRule is (list regexp DeclEntry) +|# +(define-struct conventions (get-procedures get-rules) #:transparent) + +#| +A LiteralSet is + (make-literalset (listof (list symbol id phase-var-id))) +|# +(define-struct literalset (literals) #:transparent) + +#| +An EH-alternative-set is + (eh-alternative-set (listof EH-alternative)) +An EH-alternative is + (eh-alternative RepetitionConstraint (listof SAttr) id) +|# +(define-struct eh-alternative-set (alts)) +(define-struct eh-alternative (repc attrs parser)) + +(define-struct den:delayed (parser class)) diff --git a/collects/syntax/parse/private/residual.rkt b/collects/syntax/parse/private/residual.rkt new file mode 100644 index 0000000000..d89144197a --- /dev/null +++ b/collects/syntax/parse/private/residual.rkt @@ -0,0 +1,194 @@ +#lang racket/base +(require (for-syntax racket/base) + racket/stxparam + unstable/lazy-require) + +;; ============================================================ +;; Compile-time + +(require (for-syntax racket/private/sc + syntax/parse/private/residual-ct)) +(provide (for-syntax (all-from-out syntax/parse/private/residual-ct))) + +(begin-for-syntax + ;; == from runtime.rkt + + (provide make-attribute-mapping + attribute-mapping? + attribute-mapping-var + attribute-mapping-name + attribute-mapping-depth + attribute-mapping-syntax?) + + (define-struct attribute-mapping (var name depth syntax?) + #:omit-define-syntaxes + #:property prop:procedure + (lambda (self stx) + (if (attribute-mapping-syntax? self) + #`(#%expression #,(attribute-mapping-var self)) + (let ([source-name + (or (let loop ([p (syntax-property stx 'disappeared-use)]) + (cond [(identifier? p) p] + [(pair? p) (or (loop (car p)) (loop (cdr p)))] + [else #f])) + (attribute-mapping-name self))]) + #`(let ([value #,(attribute-mapping-var self)]) + (check-attr-value-is-syntax '#,(attribute-mapping-depth self) + value + (quote-syntax #,source-name)) + value))))) + ) + +;; ============================================================ +;; Run-time + +(require "runtime-progress.rkt" + syntax/stx) + +(provide (all-from-out "runtime-progress.rkt") + + this-syntax + this-context-syntax + attribute + attribute-binding + stx-list-take + stx-list-drop/cx + check-list^depth* + check-literal* + begin-for-syntax/once + + name->too-few/once + name->too-few + name->too-many + syntax-patterns-fail) + +;; == from runtime.rkt + +;; this-syntax +;; Bound to syntax being matched inside of syntax class +(define-syntax-parameter this-syntax + (lambda (stx) + (raise-syntax-error #f "used out of context: not within a syntax class" stx))) + +;; this-context-syntax +;; Bound to (expression that extracts) context syntax (bottom frame in progress) +(define-syntax-parameter this-context-syntax + (lambda (stx) + (raise-syntax-error #f "used out of context: not within a syntax class" stx))) + +(define-syntax (attribute stx) + (syntax-case stx () + [(attribute name) + (identifier? #'name) + (let ([mapping (syntax-local-value #'name (lambda () #f))]) + (unless (syntax-pattern-variable? mapping) + (raise-syntax-error #f "not bound as a pattern variable" stx #'name)) + (let ([var (syntax-mapping-valvar mapping)]) + (let ([attr (syntax-local-value var (lambda () #f))]) + (unless (attribute-mapping? attr) + (raise-syntax-error #f "not bound as an attribute" stx #'name)) + (syntax-property (attribute-mapping-var attr) + 'disappeared-use + #'name))))])) + +;; (attribute-binding id) +;; mostly for debugging/testing +(define-syntax (attribute-binding stx) + (syntax-case stx () + [(attribute-bound? name) + (identifier? #'name) + (let ([value (syntax-local-value #'name (lambda () #f))]) + (if (syntax-pattern-variable? value) + (let ([value (syntax-local-value (syntax-mapping-valvar value) (lambda () #f))]) + (if (attribute-mapping? value) + #`(quote #,(make-attr (attribute-mapping-name value) + (attribute-mapping-depth value) + (attribute-mapping-syntax? value))) + #'(quote #f))) + #'(quote #f)))])) + +;; stx-list-take : stxish nat -> syntax +(define (stx-list-take stx n) + (datum->syntax #f + (let loop ([stx stx] [n n]) + (if (zero? n) + null + (cons (stx-car stx) + (loop (stx-cdr stx) (sub1 n))))))) + +;; stx-list-drop/cx : stxish stx nat -> (values stxish stx) +(define (stx-list-drop/cx x cx n) + (let loop ([x x] [cx cx] [n n]) + (if (zero? n) + (values x + (if (syntax? x) x cx)) + (loop (stx-cdr x) + (if (syntax? x) x cx) + (sub1 n))))) + +;; check-attr-value-is-syntax : nat any id -> boolean +;; returns #t if value is a (listof^depth syntax) +;; used by attribute-mapping code above +(define (check-attr-value-is-syntax depth value source-id) + (define (check-syntax depth value) + (if (zero? depth) + (syntax? value) + (and (list? value) + (for/and ([part (in-list value)]) + (check-syntax (sub1 depth) part))))) + (unless (check-syntax depth value) + (raise-syntax-error #f + (format "attribute is bound to non-syntax value: ~e" value) + source-id))) + +;; check-list^depth* : symbol nat any -> list^depth +(define (check-list^depth* aname n0 v0) + (define (loop n v) + (when (positive? n) + (unless (list? v) + (raise-type-error aname (format "lists nested ~s deep" n0) v)) + (for ([x (in-list v)]) (loop (sub1 n) x)))) + (loop n0 v0) + v0) + +;; check-literal* : id phase phase (listof phase) stx -> void +(define (check-literal* id used-phase mod-phase ok-phases/ct-rel ctx) + (unless (or (memv (and used-phase (- used-phase mod-phase)) + ok-phases/ct-rel) + (identifier-binding id used-phase)) + (raise-syntax-error + #f + (format "literal is unbound in phase ~a (phase ~a relative to the enclosing module)" + used-phase + (and used-phase (- used-phase mod-phase))) + ctx id))) + +;; (begin-for-syntax/once expr/phase1 ...) +;; evaluates in pass 2 of module/intdefs expansion +(define-syntax (begin-for-syntax/once stx) + (syntax-case stx () + [(bfs/o e ...) + (cond [(list? (syntax-local-context)) + #`(define-values () + (begin (begin-for-syntax/once e ...) + (values)))] + [else + #'(let-syntax ([m (lambda _ (begin e ...) #'(void))]) + (m))])])) + +;; == parse.rkt + +(define (name->too-few/once name) + (and name (format "missing required occurrence of ~a" name))) + +(define (name->too-few name) + (and name (format "too few occurrences of ~a" name))) + +(define (name->too-many name) + (and name (format "too many occurrences of ~a" name))) + +;; == parse.rkt + +(lazy-require + ["runtime-report.rkt" + (syntax-patterns-fail)]) diff --git a/collects/syntax/parse/private/runtime-failure.rkt b/collects/syntax/parse/private/runtime-failure.rkt deleted file mode 100644 index 78f0b042bd..0000000000 --- a/collects/syntax/parse/private/runtime-failure.rkt +++ /dev/null @@ -1,194 +0,0 @@ -#lang racket/base -(require "minimatch.rkt" - "runtime-progress.rkt") -(provide (struct-out failure) - - expect? - (struct-out expect:thing) - (struct-out expect:atom) - (struct-out expect:literal) - (struct-out expect:message) - (struct-out expect:disj) - - normalize-expectstack - simplify-common-expectstacks - maximal-failures - partition/equal?) - -;; A Failure is (make-failure PS ExpectStack) -;; A FailureSet is one of -;; - Failure -;; - (cons FailureSet FailureSet) - -;; FailFunction = (FailureSet -> Answer) - -(define-struct failure (progress expectstack) #:prefab) - -;; == Expectations - -;; FIXME: add phase to expect:literal - -#| -An ExpectStack is (listof Expect) - -An Expect is one of - - (make-expect:thing string boolean) - * (make-expect:message string) - * (make-expect:atom atom) - * (make-expect:literal identifier) - * (make-expect:disj (non-empty-listof Expect)) - -The *-marked variants can only occur at the top of the stack. -|# -(define-struct expect:thing (description transparent?) #:prefab) -(define-struct expect:message (message) #:prefab) -(define-struct expect:atom (atom) #:prefab) -(define-struct expect:literal (literal) #:prefab) -(define-struct expect:disj (expects) #:prefab) - -(define (expect? x) - (or (expect:thing? x) - (expect:message? x) - (expect:atom? x) - (expect:literal? x) - (expect:disj? x))) - - -;; == Failure simplification == - -;; maximal-failures : FailureSet -> (listof (listof Failure)) -(define (maximal-failures fs) - (define ann-failures - (for/list ([f (in-list (flatten fs null))]) - (cons f (invert-ps (failure-progress f))))) - (maximal/progress ann-failures)) - -(define (flatten fs onto) - (cond [(pair? fs) - (flatten (car fs) (flatten (cdr fs) onto))] - [else - (cons fs onto)])) - -;; == Expectation simplification == - -;; normalize-expectstack : ExpectStack -> ExpectStack -(define (normalize-expectstack es) - (filter-expectstack (truncate-opaque-expectstack es))) - -;; truncate-opaque-expectstack : ExpectStack -> ExpectStack -;; Eliminates expectations on top of opaque (ie, transparent=#f) frames. -(define (truncate-opaque-expectstack es) - (let/ec return - (let loop ([es es]) - (match es - ['() '()] - [(cons (expect:thing description '#f) rest-es) - ;; Tricky! If multiple opaque frames, multiple "returns", - ;; but innermost one called first, so jumps past the rest. - (return (cons (car es) (loop rest-es)))] - [(cons expect rest-es) - (cons expect (loop rest-es))])))) - -;; filter-expectstack : ExpectStack -> ExpectStack -;; Eliminates missing (ie, #f) messages and descriptions -(define (filter-expectstack es) - (filter (lambda (expect) - (match expect - [(expect:thing '#f _) - #f] - [(expect:message '#f) - #f] - [_ #t])) - es)) - -#| -Simplification dilemma - -What if we have (e1 e2) and (e2)? How do we report that? -Options: - 1) consider them separate - 2) simplify to (e2), drop e1 - -Big problem with Option 1: - eg (x:id ...) matching #'1 yields - (union (failure #:progress () #:expectstack ()) - (failure #:progress () #:expectstack (#s(expect:atom ())))) -but we don't want to see "expected ()" - -So we go with option 2. -|# - -;; simplify-common-expectstacks : (listof ExpectStack) -> (listof ExpectStack) -;; Should call remove-duplicates first. -(define (simplify-common-expectstacks ess) - ;; simplify : (listof ReversedExpectStack) -> (listof ReversedExpectStack) - (define (simplify ress) - (let ([ress-partitions (partition/car ress)]) - (if ress-partitions - (apply append - (for/list ([ress-partition (in-list ress-partitions)]) - (let ([proto-frame (car (car ress-partition))] - [cdr-ress (map cdr ress-partition)]) - (map (lambda (res) (cons proto-frame res)) - (simplify/check-leafs cdr-ress))))) - (list null)))) - ;; simplify/check-leafs : (listof ReversedExpectStack) -> (listof ReversedExpectStack) - (define (simplify/check-leafs ress) - (let ([ress (simplify ress)]) - (cond [(andmap singleton? ress) - (let* ([frames (map car ress)]) - (list (list (if (singleton? frames) - (car frames) - (expect:disj frames)))))] - [else ress]))) - ;; singleton? : list -> boolean - (define (singleton? res) - (and (pair? res) (null? (cdr res)))) - (map reverse (simplify/check-leafs (map reverse ess)))) - -;; partition/car : (listof list) -> (listof (listof list))/#f -;; Returns #f if any of lists is empty. -(define (partition/car lists) - (and (andmap pair? lists) - (partition/equal? lists car))) - -(define (partition/equal? items key) - (let ([r-keys null] ;; mutated - [key-t (make-hash)]) - (for ([item (in-list items)]) - (let ([k (key item)]) - (let ([entry (hash-ref key-t k null)]) - (when (null? entry) - (set! r-keys (cons k r-keys))) - (hash-set! key-t k (cons item entry))))) - (let loop ([r-keys r-keys] [acc null]) - (cond [(null? r-keys) acc] - [else - (loop (cdr r-keys) - (cons (reverse (hash-ref key-t (car r-keys))) - acc))])))) - -;; ==== Debugging - -(provide failureset->sexpr - failure->sexpr - expectstack->sexpr - expect->sexpr) - -(define (failureset->sexpr fs) - (let ([fs (flatten fs null)]) - (case (length fs) - ((1) (failure->sexpr (car fs))) - (else `(union ,@(map failure->sexpr fs)))))) - -(define (failure->sexpr f) - (match f - [(failure progress expectstack) - `(failure ,(progress->sexpr progress) - #:expected ,(expectstack->sexpr expectstack))])) - -(define (expectstack->sexpr es) - (map expect->sexpr es)) - -(define (expect->sexpr e) - e) diff --git a/collects/syntax/parse/private/runtime-progress.rkt b/collects/syntax/parse/private/runtime-progress.rkt index d7a1789f8e..a2db66223e 100644 --- a/collects/syntax/parse/private/runtime-progress.rkt +++ b/collects/syntax/parse/private/runtime-progress.rkt @@ -1,5 +1,6 @@ #lang racket/base -(require unstable/struct +(require racket/list + unstable/struct syntax/stx "minimatch.rkt") (provide ps-empty @@ -12,14 +13,18 @@ ps-add-unpstruct ps-add-opaque + invert-ps ps->stx+index ps-context-syntax ps-difference - invert-ps - maximal/progress - - progress->sexpr) + (struct-out failure) + expect? + (struct-out expect:thing) + (struct-out expect:atom) + (struct-out expect:literal) + (struct-out expect:message) + (struct-out expect:disj)) #| Progress (PS) is a non-empty list of Progress Frames (PF). @@ -140,20 +145,6 @@ Interpretation: Inner PS structures are applied first. (loop (cdr ps)) ps])))) -#| -Progress ordering ------------------ - -Lexicographic generalization of partial order on frames - CAR < CDR < POST, stx incomparable except to self - -Progress equality ------------------ - -If ps1 = ps2 then both must "blame" the same term, -ie (ps->stx+index ps1) = (ps->stx+index ps2). -|# - ;; An Inverted PS (IPS) is a PS inverted for easy comparison. ;; An IPS may not contain any 'opaque frames. @@ -161,100 +152,72 @@ ie (ps->stx+index ps1) = (ps->stx+index ps2). (define (invert-ps ps) (reverse (ps-truncate-opaque ps))) -;; maximal/progress : (listof (cons A IPS)) -> (listof (listof A)) -;; Returns a list of equivalence sets. -(define (maximal/progress items) - (cond [(null? items) - null] - [(null? (cdr items)) - (list (list (car (car items))))] - [else - (let-values ([(rNULL rCAR rCDR rPOST rSTX leastCDR) - (partition/pf items)]) - (append (maximal/pf rNULL rCAR rCDR rPOST leastCDR) - (if (pair? rSTX) - (maximal/stx rSTX) - null)))])) -;; partition/pf : (listof (cons A IPS)) -> (listof (cons A IPS))^5 & nat/+inf.0 -(define (partition/pf items) - (let ([rNULL null] - [rCAR null] - [rCDR null] - [rPOST null] - [rSTX null] - [leastCDR #f]) - (for ([a+ips (in-list items)]) - (let ([ips (cdr a+ips)]) - (cond [(null? ips) - (set! rNULL (cons a+ips rNULL))] - [(eq? (car ips) 'car) - (set! rCAR (cons a+ips rCAR))] - [(exact-positive-integer? (car ips)) - (set! rCDR (cons a+ips rCDR)) - (set! leastCDR - (if leastCDR - (min leastCDR (car ips)) - (car ips)))] - [(eq? (car ips) 'post) - (set! rPOST (cons a+ips rPOST))] - [(syntax? (car ips)) - (set! rSTX (cons a+ips rSTX))] - [else - (error 'syntax-parse "INTERNAL ERROR in partition/pf: ~e" ips)]))) - (values rNULL rCAR rCDR rPOST rSTX leastCDR))) +;; ==== Failure ==== -;; maximal/pf : (listof (cons A IPS))^4 & nat/+inf.0-> (listof (listof A)) -(define (maximal/pf rNULL rCAR rCDR rPOST leastCDR) - (cond [(pair? rPOST) - (maximal/progress (rmap pop-item-ips rPOST))] - [(pair? rCDR) - (maximal/progress - (rmap (lambda (a+ips) - (let ([a (car a+ips)] [ips (cdr a+ips)]) - (cond [(= (car ips) leastCDR) - (cons a (cdr ips))] - [else - (cons a (cons (- (car ips) leastCDR) (cdr ips)))]))) - rCDR))] - [(pair? rCAR) - (maximal/progress (rmap pop-item-ips rCAR))] - [(pair? rNULL) - (list (map car rNULL))] - [else - null])) +;; A Failure is (make-failure PS ExpectStack) +;; A FailureSet is one of +;; - Failure +;; - (cons FailureSet FailureSet) -;; maximal/stx : (listof (cons A IPS)) -> (listof (listof A)) -(define (maximal/stx rSTX) - (let ([stxs null] - [table (make-hasheq)]) - (for ([a+ips (in-list rSTX)]) - (let* ([ips (cdr a+ips)] - [entry (hash-ref table (car ips) null)]) - (when (null? entry) - (set! stxs (cons (car ips) stxs))) - (hash-set! table (car ips) (cons a+ips entry)))) - (apply append - (map (lambda (key) - (maximal/progress (map pop-item-ips (hash-ref table key)))) - stxs)))) +;; FailFunction = (FailureSet -> Answer) -;; pop-item-ips : (cons A IPS) -> (cons A IPS) -(define (pop-item-ips a+ips) - (let ([a (car a+ips)] - [ips (cdr a+ips)]) - (cons a (cdr ips)))) +(define-struct failure (progress expectstack) #:prefab) -(define (rmap f xs) - (let rmaploop ([xs xs] [accum null]) - (cond [(pair? xs) - (rmaploop (cdr xs) (cons (f (car xs)) accum))] - [else - accum]))) +;; == Expectations -;; == Debugging == +;; FIXME: add phase to expect:literal -(provide progress->sexpr) +#| +An ExpectStack is (listof Expect) + +An Expect is one of + - (make-expect:thing string boolean) + * (make-expect:message string) + * (make-expect:atom atom) + * (make-expect:literal identifier) + * (make-expect:disj (non-empty-listof Expect)) + +The *-marked variants can only occur at the top of the stack. +|# +(define-struct expect:thing (description transparent?) #:prefab) +(define-struct expect:message (message) #:prefab) +(define-struct expect:atom (atom) #:prefab) +(define-struct expect:literal (literal) #:prefab) +(define-struct expect:disj (expects) #:prefab) + +(define (expect? x) + (or (expect:thing? x) + (expect:message? x) + (expect:atom? x) + (expect:literal? x) + (expect:disj? x))) + + +;; ==== Debugging + +(provide failureset->sexpr + failure->sexpr + expectstack->sexpr + expect->sexpr) + +(define (failureset->sexpr fs) + (let ([fs (flatten fs null)]) + (case (length fs) + ((1) (failure->sexpr (car fs))) + (else `(union ,@(map failure->sexpr fs)))))) + +(define (failure->sexpr f) + (match f + [(failure progress expectstack) + `(failure ,(progress->sexpr progress) + #:expected ,(expectstack->sexpr expectstack))])) + +(define (expectstack->sexpr es) + (map expect->sexpr es)) + +(define (expect->sexpr e) + e) (define (progress->sexpr ps) (for/list ([pf (in-list (invert-ps ps))]) diff --git a/collects/syntax/parse/private/runtime-reflect.rkt b/collects/syntax/parse/private/runtime-reflect.rkt index 6be678b4b7..58280315c0 100644 --- a/collects/syntax/parse/private/runtime-reflect.rkt +++ b/collects/syntax/parse/private/runtime-reflect.rkt @@ -1,15 +1,12 @@ #lang racket/base -(require (for-syntax racket/base - "rep-data.rkt") - "rep-attrs.rkt" +(require syntax/parse/private/residual ;; keep abs. path + (only-in syntax/parse/private/residual-ct ;; keep abs. path + attr-name attr-depth) "kws.rkt") -(provide (struct-out reified) +(provide reflect-parser + (struct-out reified) (struct-out reified-syntax-class) - (struct-out reified-splicing-syntax-class) - reify-syntax-class - reified-syntax-class? - reified-splicing-syntax-class? - reflect-parser) + (struct-out reified-splicing-syntax-class)) #| A Reified is @@ -20,32 +17,8 @@ A Reified is (define-struct (reified-syntax-class reified) ()) (define-struct (reified-splicing-syntax-class reified) ()) -;; ---- - -(define-syntax (reify-syntax-class stx) - (if (eq? (syntax-local-context) 'expression) - (syntax-case stx () - [(rsc sc) - (let* ([stxclass (get-stxclass #'sc)] - [splicing? (stxclass-splicing? stxclass)]) - (unless (stxclass-delimit-cut? stxclass) - (raise-syntax-error #f "cannot reify syntax class with #:no-delimit-cut option" - stx #'sc)) - (with-syntax ([name (stxclass-name stxclass)] - [parser (stxclass-parser stxclass)] - [arity (stxclass-arity stxclass)] - [(#s(attr aname adepth _) ...) (stxclass-attrs stxclass)] - [ctor - (if splicing? - #'reified-splicing-syntax-class - #'reified-syntax-class)]) - #'(ctor 'name parser 'arity '((aname adepth) ...))))]) - #`(#%expression #,stx))) - -;; ---- - -;; e-arity represents single call; min and max are same (define (reflect-parser obj e-arity e-attrs splicing?) + ;; e-arity represents single call; min and max are same (define who (if splicing? 'reflect-splicing-syntax-class 'reflect-syntax-class)) (if splicing? (unless (reified-splicing-syntax-class? obj) diff --git a/collects/syntax/parse/private/runtime-report.rkt b/collects/syntax/parse/private/runtime-report.rkt index f819480239..bd0f369aea 100644 --- a/collects/syntax/parse/private/runtime-report.rkt +++ b/collects/syntax/parse/private/runtime-report.rkt @@ -1,11 +1,17 @@ #lang racket/base (require racket/list "minimatch.rkt" - "runtime.rkt" + (except-in syntax/parse/private/residual + syntax-patterns-fail) "kws.rkt") (provide syntax-patterns-fail current-failure-handler) +#| +Note: there is a cyclic dependence between residual.rkt and this module, +broken by a lazy-require of this module into residual.rkt +|# + (define ((syntax-patterns-fail stx0) fs) (call-with-values (lambda () ((current-failure-handler) stx0 fs)) (lambda vals @@ -21,8 +27,6 @@ (define current-failure-handler (make-parameter default-failure-handler)) -;; ---- - #| Reporting --------- @@ -125,3 +129,223 @@ complicated. [(a . b) (cons #'a (improper-stx->list #'b))] [() null] [rest (list #'rest)])) + + +;; ==== Failure analysis ==== + + +;; == Failure simplification == + +;; maximal-failures : FailureSet -> (listof (listof Failure)) +(define (maximal-failures fs) + (define ann-failures + (for/list ([f (in-list (flatten fs))]) + (cons f (invert-ps (failure-progress f))))) + (maximal/progress ann-failures)) + +;; == Expectation simplification == + +;; normalize-expectstack : ExpectStack -> ExpectStack +(define (normalize-expectstack es) + (filter-expectstack (truncate-opaque-expectstack es))) + +;; truncate-opaque-expectstack : ExpectStack -> ExpectStack +;; Eliminates expectations on top of opaque (ie, transparent=#f) frames. +(define (truncate-opaque-expectstack es) + (let/ec return + (let loop ([es es]) + (match es + ['() '()] + [(cons (expect:thing description '#f) rest-es) + ;; Tricky! If multiple opaque frames, multiple "returns", + ;; but innermost one called first, so jumps past the rest. + (return (cons (car es) (loop rest-es)))] + [(cons expect rest-es) + (cons expect (loop rest-es))])))) + +;; filter-expectstack : ExpectStack -> ExpectStack +;; Eliminates missing (ie, #f) messages and descriptions +(define (filter-expectstack es) + (filter (lambda (expect) + (match expect + [(expect:thing '#f _) + #f] + [(expect:message '#f) + #f] + [_ #t])) + es)) + +#| +Simplification dilemma + +What if we have (e1 e2) and (e2)? How do we report that? +Options: + 1) consider them separate + 2) simplify to (e2), drop e1 + +Big problem with Option 1: + eg (x:id ...) matching #'1 yields + (union (failure #:progress () #:expectstack ()) + (failure #:progress () #:expectstack (#s(expect:atom ())))) +but we don't want to see "expected ()" + +So we go with option 2. +|# + +;; simplify-common-expectstacks : (listof ExpectStack) -> (listof ExpectStack) +;; Should call remove-duplicates first. +(define (simplify-common-expectstacks ess) + ;; simplify : (listof ReversedExpectStack) -> (listof ReversedExpectStack) + (define (simplify ress) + (let ([ress-partitions (partition/car ress)]) + (if ress-partitions + (apply append + (for/list ([ress-partition (in-list ress-partitions)]) + (let ([proto-frame (car (car ress-partition))] + [cdr-ress (map cdr ress-partition)]) + (map (lambda (res) (cons proto-frame res)) + (simplify/check-leafs cdr-ress))))) + (list null)))) + ;; simplify/check-leafs : (listof ReversedExpectStack) -> (listof ReversedExpectStack) + (define (simplify/check-leafs ress) + (let ([ress (simplify ress)]) + (cond [(andmap singleton? ress) + (let* ([frames (map car ress)]) + (list (list (if (singleton? frames) + (car frames) + (expect:disj frames)))))] + [else ress]))) + ;; singleton? : list -> boolean + (define (singleton? res) + (and (pair? res) (null? (cdr res)))) + (map reverse (simplify/check-leafs (map reverse ess)))) + +;; partition/car : (listof list) -> (listof (listof list))/#f +;; Returns #f if any of lists is empty. +(define (partition/car lists) + (and (andmap pair? lists) + (partition/equal? lists car))) + +(define (partition/equal? items key) + (let ([r-keys null] ;; mutated + [key-t (make-hash)]) + (for ([item (in-list items)]) + (let ([k (key item)]) + (let ([entry (hash-ref key-t k null)]) + (when (null? entry) + (set! r-keys (cons k r-keys))) + (hash-set! key-t k (cons item entry))))) + (let loop ([r-keys r-keys] [acc null]) + (cond [(null? r-keys) acc] + [else + (loop (cdr r-keys) + (cons (reverse (hash-ref key-t (car r-keys))) + acc))])))) + + +;; ==== Progress + +#| +Progress ordering +----------------- + +Lexicographic generalization of partial order on frames + CAR < CDR < POST, stx incomparable except to self + +Progress equality +----------------- + +If ps1 = ps2 then both must "blame" the same term, +ie (ps->stx+index ps1) = (ps->stx+index ps2). +|# + +;; maximal/progress : (listof (cons A IPS)) -> (listof (listof A)) +;; Returns a list of equivalence sets. +(define (maximal/progress items) + (cond [(null? items) + null] + [(null? (cdr items)) + (list (list (car (car items))))] + [else + (let-values ([(rNULL rCAR rCDR rPOST rSTX leastCDR) + (partition/pf items)]) + (append (maximal/pf rNULL rCAR rCDR rPOST leastCDR) + (if (pair? rSTX) + (maximal/stx rSTX) + null)))])) + +;; partition/pf : (listof (cons A IPS)) -> (listof (cons A IPS))^5 & nat/+inf.0 +(define (partition/pf items) + (let ([rNULL null] + [rCAR null] + [rCDR null] + [rPOST null] + [rSTX null] + [leastCDR #f]) + (for ([a+ips (in-list items)]) + (let ([ips (cdr a+ips)]) + (cond [(null? ips) + (set! rNULL (cons a+ips rNULL))] + [(eq? (car ips) 'car) + (set! rCAR (cons a+ips rCAR))] + [(exact-positive-integer? (car ips)) + (set! rCDR (cons a+ips rCDR)) + (set! leastCDR + (if leastCDR + (min leastCDR (car ips)) + (car ips)))] + [(eq? (car ips) 'post) + (set! rPOST (cons a+ips rPOST))] + [(syntax? (car ips)) + (set! rSTX (cons a+ips rSTX))] + [else + (error 'syntax-parse "INTERNAL ERROR in partition/pf: ~e" ips)]))) + (values rNULL rCAR rCDR rPOST rSTX leastCDR))) + +;; maximal/pf : (listof (cons A IPS))^4 & nat/+inf.0-> (listof (listof A)) +(define (maximal/pf rNULL rCAR rCDR rPOST leastCDR) + (cond [(pair? rPOST) + (maximal/progress (rmap pop-item-ips rPOST))] + [(pair? rCDR) + (maximal/progress + (rmap (lambda (a+ips) + (let ([a (car a+ips)] [ips (cdr a+ips)]) + (cond [(= (car ips) leastCDR) + (cons a (cdr ips))] + [else + (cons a (cons (- (car ips) leastCDR) (cdr ips)))]))) + rCDR))] + [(pair? rCAR) + (maximal/progress (rmap pop-item-ips rCAR))] + [(pair? rNULL) + (list (map car rNULL))] + [else + null])) + +;; maximal/stx : (listof (cons A IPS)) -> (listof (listof A)) +(define (maximal/stx rSTX) + (let ([stxs null] + [table (make-hasheq)]) + (for ([a+ips (in-list rSTX)]) + (let* ([ips (cdr a+ips)] + [entry (hash-ref table (car ips) null)]) + (when (null? entry) + (set! stxs (cons (car ips) stxs))) + (hash-set! table (car ips) (cons a+ips entry)))) + (apply append + (map (lambda (key) + (maximal/progress (map pop-item-ips (hash-ref table key)))) + stxs)))) + +;; pop-item-ips : (cons A IPS) -> (cons A IPS) +(define (pop-item-ips a+ips) + (let ([a (car a+ips)] + [ips (cdr a+ips)]) + (cons a (cdr ips)))) + +(define (rmap f xs) + (let rmaploop ([xs xs] [accum null]) + (cond [(pair? xs) + (rmaploop (cdr xs) (cons (f (car xs)) accum))] + [else + accum]))) diff --git a/collects/syntax/parse/private/runtime.rkt b/collects/syntax/parse/private/runtime.rkt index 3eb55ec333..1ebae79809 100644 --- a/collects/syntax/parse/private/runtime.rkt +++ b/collects/syntax/parse/private/runtime.rkt @@ -1,51 +1,46 @@ #lang racket/base (require racket/stxparam unstable/syntax - "runtime-progress.rkt" - "runtime-failure.rkt" + syntax/parse/private/residual ;; keep abs. path (for-syntax racket/base racket/list syntax/kerncase racket/private/sc racket/syntax - "rep-data.rkt" - "rep-attrs.rkt")) + "rep-attrs.rkt" + "rep-data.rkt")) -(provide (all-from-out "runtime-progress.rkt") - (all-from-out "runtime-failure.rkt") +(provide with + fail-handler + cut-prompt + wrap-user-code - this-syntax - this-context-syntax - - stx-list-take - stx-list-drop/cx + fail + try let-attributes let-attributes* let/unpack + defattrs/unpack - attribute - attribute-binding - check-list^depth) + check-list^depth -;; == Syntax Parameters + check-literal + no-shadow + curried-stxclass-parser + app-argu) -;; this-syntax -;; Bound to syntax being matched inside of syntax class -(define-syntax-parameter this-syntax - (lambda (stx) - (wrong-syntax stx "used out of context: not within a syntax class"))) +#| +TODO: rename file -;; this-context-syntax -;; Bound to (expression that extracts) context syntax (bottom frame in progress) -(define-syntax-parameter this-context-syntax - (lambda (stx) - (wrong-syntax stx "used out of context: not within a syntax class"))) +This file contains "runtime" (ie, phase 0) auxiliary *macros* used in +expansion of syntax-parse etc. This file must not contain any +reference that persists in a compiled program; those must go in +residual.rkt. +|# ;; == with == -(provide with) - (define-syntax (with stx) (syntax-case stx () [(with ([stxparam expr] ...) . body) @@ -58,13 +53,6 @@ ;; == Control information == -(provide fail-handler - cut-prompt - wrap-user-code - - fail - try) - (define-syntax-parameter fail-handler (lambda (stx) (wrong-syntax stx "internal error: used out of context"))) @@ -96,57 +84,8 @@ (with ([fail-handler last-fh]) e0)))))])) -;; ----- - -(require syntax/stx) -(define (stx-list-take stx n) - (datum->syntax #f - (let loop ([stx stx] [n n]) - (if (zero? n) - null - (cons (stx-car stx) - (loop (stx-cdr stx) (sub1 n))))))) - -;; stx-list-drop/cx : stxish stx nat -> (values stxish stx) -(define (stx-list-drop/cx x cx n) - (let loop ([x x] [cx cx] [n n]) - (if (zero? n) - (values x - (if (syntax? x) x cx)) - (loop (stx-cdr x) - (if (syntax? x) x cx) - (sub1 n))))) - ;; == Attributes -(begin-for-syntax - (define-struct attribute-mapping (var name depth syntax?) - #:omit-define-syntaxes - #:property prop:procedure - (lambda (self stx) - (if (attribute-mapping-syntax? self) - #`(#%expression #,(attribute-mapping-var self)) - #`(let ([value #,(attribute-mapping-var self)]) - (if (check-syntax '#,(attribute-mapping-depth self) value) - value - (raise-syntax-error - #f - (format "attribute is bound to non-syntax value: ~e" value) - (quote-syntax #,(or (let loop ([p (syntax-property stx 'disappeared-use)]) - (cond [(identifier? p) p] - [(pair? p) (or (loop (car p)) (loop (cdr p)))] - [else #f])) - (attribute-mapping-name self)))))))))) - -;; check-syntax : nat any -> boolean -;; Returns #t if value is a (listof^depth syntax) -(define (check-syntax depth value) - (if (zero? depth) - (syntax? value) - (and (list? value) - (for/and ([part (in-list value)]) - (check-syntax (sub1 depth) part))))) - (define-for-syntax (parse-attr x) (syntax-case x () [#s(attr name depth syntax?) #'(name depth syntax?)])) @@ -202,38 +141,6 @@ (define-syntax name (make-syntax-mapping 'depth (quote-syntax stmp))) ...)))])) -(define-syntax (attribute stx) - (parameterize ((current-syntax-context stx)) - (syntax-case stx () - [(attribute name) - (identifier? #'name) - (let ([mapping (syntax-local-value #'name (lambda () #f))]) - (unless (syntax-pattern-variable? mapping) - (wrong-syntax #'name "not bound as a pattern variable")) - (let ([var (syntax-mapping-valvar mapping)]) - (let ([attr (syntax-local-value var (lambda () #f))]) - (unless (attribute-mapping? attr) - (wrong-syntax #'name "not bound as an attribute")) - (syntax-property (attribute-mapping-var attr) - 'disappeared-use - #'name))))]))) - -;; (attribute-binding id) -;; mostly for debugging/testing -(define-syntax (attribute-binding stx) - (syntax-case stx () - [(attribute-bound? name) - (identifier? #'name) - (let ([value (syntax-local-value #'name (lambda () #f))]) - (if (syntax-pattern-variable? value) - (let ([value (syntax-local-value (syntax-mapping-valvar value) (lambda () #f))]) - (if (attribute-mapping? value) - #`(quote #,(make-attr (attribute-mapping-name value) - (attribute-mapping-depth value) - (attribute-mapping-syntax? value))) - #'(quote #f))) - #'(quote #f)))])) - ;; (check-list^depth attr expr) (define-syntax (check-list^depth stx) (syntax-case stx () @@ -242,20 +149,6 @@ (quasisyntax/loc #'expr (check-list^depth* 'name 'depth expr)))])) -(define (check-list^depth* aname n0 v0) - (define (loop n v) - (when (positive? n) - (unless (list? v) - (raise-type-error aname (format "lists nested ~s deep" n0) v)) - (for ([x (in-list v)]) (loop (sub1 n) x)))) - (loop n0 v0) - v0) - - -;; ==== - -(provide check-literal) - ;; (check-literal id phase-level-expr ctx) -> void (define-syntax (check-literal stx) (syntax-case stx () @@ -274,38 +167,8 @@ 'ok-phases/ct-rel (quote-syntax ctx))))])) -(define (check-literal* id used-phase mod-phase ok-phases/ct-rel ctx) - (unless (or (memv (and used-phase (- used-phase mod-phase)) - ok-phases/ct-rel) - (identifier-binding id used-phase)) - (raise-syntax-error - #f - (format "literal is unbound in phase ~a (phase ~a relative to the enclosing module)" - used-phase - (and used-phase (- used-phase mod-phase))) - ctx id))) - -;; ---- - -(provide begin-for-syntax/once) - -;; (begin-for-syntax/once expr/phase1 ...) -;; evaluates in pass 2 of module/intdefs expansion -(define-syntax (begin-for-syntax/once stx) - (syntax-case stx () - [(bfs/o e ...) - (cond [(list? (syntax-local-context)) - #`(define-values () - (begin (begin-for-syntax/once e ...) - (values)))] - [else - #'(let-syntax ([m (lambda _ (begin e ...) #'(void))]) - (m))])])) - ;; ==== -(provide no-shadow) - (begin-for-syntax (define (check-shadow def) (syntax-case def () @@ -336,11 +199,6 @@ [_ ee]))])) -;; ---- - -(provide curried-stxclass-parser - app-argu) - (define-syntax (curried-stxclass-parser stx) (syntax-case stx () [(_ class argu) diff --git a/collects/syntax/parse/private/sc.rkt b/collects/syntax/parse/private/sc.rkt index 8c8cdc7119..275cbc41ba 100644 --- a/collects/syntax/parse/private/sc.rkt +++ b/collects/syntax/parse/private/sc.rkt @@ -1,177 +1,64 @@ #lang racket/base (require (for-syntax racket/base - racket/syntax - "rep-data.rkt" - "rep.rkt") - racket/syntax - "parse.rkt" - "keywords.rkt" - "runtime.rkt" - "runtime-report.rkt") + unstable/lazy-require) + "keywords.rkt") + +;; keep and keep as abs. path -- lazy-loaded macros produce references to this +;; must be required via *absolute module path* from any disappearing module +;; (so for consistency etc, require absolutely from all modules) +(require syntax/parse/private/residual) + +(begin-for-syntax + (lazy-require + ;; load macro transformers lazily via identifier + ;; This module path must also be absolute (not sure why, + ;; but it definitely breaks on relative module path). + [syntax/parse/private/parse-aux + (id:define-syntax-class + id:define-splicing-syntax-class + id:syntax-parse + id:syntax-parser + id:define/syntax-parse + id:syntax-parser/template + id:parser/rhs + id:define-eh-alternative-set)])) (provide define-syntax-class define-splicing-syntax-class - syntax-parse syntax-parser + define/syntax-parse (except-out (all-from-out "keywords.rkt") ~reflect ~splicing-reflect ~eh-var) - attribute this-syntax - define/syntax-parse - - ;;---- syntax-parser/template - parser/rhs) + parser/rhs + define-eh-alternative-set) -(begin-for-syntax - (define (defstxclass stx header rhss splicing?) - (parameterize ((current-syntax-context stx)) - (let-values ([(name formals arity) - (let ([p (check-stxclass-header header stx)]) - (values (car p) (cadr p) (caddr p)))]) - (let* ([the-rhs (parse-rhs rhss #f splicing? #:context stx)] - [opt-rhs+def - (and (andmap identifier? (syntax->list formals)) - (optimize-rhs the-rhs (syntax->list formals)))] - [the-rhs (if opt-rhs+def (car opt-rhs+def) the-rhs)]) - (with-syntax ([name name] - [formals formals] - [rhss rhss] - [parser (generate-temporary (format-symbol "parse-~a" name))] - [arity arity] - [attrs (rhs-attrs the-rhs)] - [(opt-def ...) - (if opt-rhs+def - (list (cadr opt-rhs+def)) - '())] - [options (rhs-options the-rhs)] - [integrate-expr - (syntax-case (rhs-integrate the-rhs) () - [#s(integrate predicate description) - #'(integrate (quote-syntax predicate) - 'description)] - [#f - #''#f])]) - #`(begin (define-syntax name - (stxclass 'name 'arity - 'attrs - (quote-syntax parser) - '#,splicing? - options - integrate-expr)) - opt-def ... - (define-values (parser) - ;; If opt-rhs, do not reparse: - ;; need to keep same generated predicate name - #,(if opt-rhs+def - (begin - ;; (printf "Integrable syntax class: ~s\n" (syntax->datum #'name)) - #`(parser/rhs/parsed - name formals attrs #,the-rhs - #,(and (rhs-description the-rhs) #t) - #,splicing? #,stx)) - #`(parser/rhs - name formals attrs rhss #,splicing? #,stx)))))))))) - -(define-syntax (define-syntax-class stx) - (syntax-case stx () - [(dsc header . rhss) - (defstxclass stx #'header #'rhss #f)])) - -(define-syntax (define-splicing-syntax-class stx) - (syntax-case stx () - [(dssc header . rhss) - (defstxclass stx #'header #'rhss #t)])) - -;; ---- - -(define-syntax (parser/rhs stx) - (syntax-case stx () - [(parser/rhs name formals attrs rhss splicing? ctx) - (with-disappeared-uses - (let ([rhs - (parameterize ((current-syntax-context #'ctx)) - (parse-rhs #'rhss (syntax->datum #'attrs) (syntax-e #'splicing?) - #:context #'ctx))]) - #`(parser/rhs/parsed name formals attrs - #,rhs #,(and (rhs-description rhs) #t) - splicing? ctx)))])) - -(define-syntax (parser/rhs/parsed stx) - (syntax-case stx () - [(prp name formals attrs rhs rhs-has-description? splicing? ctx) - #`(let ([get-description - (lambda formals - (if 'rhs-has-description? - #,(rhs-description (syntax-e #'rhs)) - (symbol->string 'name)))]) - (parse:rhs rhs attrs formals splicing? - (if 'rhs-has-description? - #,(rhs-description (syntax-e #'rhs)) - (symbol->string 'name))))])) - -;; ==== - -(define-syntax (syntax-parse stx) - (syntax-case stx () - [(syntax-parse stx-expr . clauses) - (quasisyntax/loc stx - (let ([x (datum->syntax #f stx-expr)]) - (parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx))))])) - -(define-syntax (syntax-parser stx) - (syntax-case stx () - [(syntax-parser . clauses) - (quasisyntax/loc stx - (lambda (x) - (let ([x (datum->syntax #f x)]) - (parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx)))))])) - -(define-syntax (syntax-parser/template stx) - (syntax-case stx () - [(syntax-parser/template ctx . clauses) - (quasisyntax/loc stx - (lambda (x) - (let ([x (datum->syntax #f x)]) - (parse:clauses x clauses one-template ctx))))])) - -;; ==== - -(define-syntax (define/syntax-parse stx) - (syntax-case stx () - [(define/syntax-parse pattern . rest) - (let-values ([(rest pattern defs) - (parse-pattern+sides #'pattern - #'rest - #:splicing? #f - #:decls (new-declenv null) - #:context stx)]) - (let ([expr - (syntax-case rest () - [( expr ) #'expr] - [_ (raise-syntax-error #f "bad syntax" stx)])] - [attrs (pattern-attrs pattern)]) - (with-syntax ([(a ...) attrs] - [(#s(attr name _ _) ...) attrs] - [pattern pattern] - [(def ...) defs] - [expr expr]) - #'(defattrs/unpack (a ...) - (let* ([x (datum->syntax #f expr)] - [cx x] - [pr (ps-empty x x)] - [es null] - [fh0 (syntax-patterns-fail x)]) - (parameterize ((current-syntax-context x)) - def ... - (#%expression - (with ([fail-handler fh0] - [cut-prompt fh0]) - (parse:S x cx pattern pr es - (list (attribute name) ...))))))))))])) +(define-syntaxes (define-syntax-class + define-splicing-syntax-class + syntax-parse + syntax-parser + define/syntax-parse + syntax-parser/template + parser/rhs + define-eh-alternative-set) + (let ([tx (lambda (get-id) + (lambda (stx) + (syntax-case stx () + [(_ . args) + (datum->syntax stx (cons (get-id) #'args) stx)])))]) + (values + (tx id:define-syntax-class) + (tx id:define-splicing-syntax-class) + (tx id:syntax-parse) + (tx id:syntax-parser) + (tx id:define/syntax-parse) + (tx id:syntax-parser/template) + (tx id:parser/rhs) + (tx id:define-eh-alternative-set)))) diff --git a/collects/tests/stxparse/setup.rkt b/collects/tests/stxparse/setup.rkt index 5625430d55..a5c9fcb636 100644 --- a/collects/tests/stxparse/setup.rkt +++ b/collects/tests/stxparse/setup.rkt @@ -1,8 +1,9 @@ #lang racket/base (require rackunit syntax/parse - syntax/parse/private/rep-attrs - (only-in syntax/parse/private/runtime attribute-binding) + (only-in syntax/parse/private/residual + attribute-binding) + syntax/parse/private/residual-ct ;; for attr functions (for-syntax racket/base)) (provide tok diff --git a/collects/unstable/lazy-require.rkt b/collects/unstable/lazy-require.rkt index e33b7cbd96..6b4462c1f7 100644 --- a/collects/unstable/lazy-require.rkt +++ b/collects/unstable/lazy-require.rkt @@ -2,8 +2,7 @@ (require (for-syntax racket/base) racket/runtime-path racket/promise) -(provide lazy-require - (for-syntax #%datum)) +(provide lazy-require) (define-syntax (lazy-require stx) (syntax-case stx () @@ -20,7 +19,9 @@ (unless (identifier? name) (raise-syntax-error #f "expected identifier" #'orig-stx name)) #`(define #,name (make-lazy-function '#,name get-sym)))]) - #'(begin (define-runtime-module-path-index mpi-var modpath) + ;; implicit quasiquote, so can use normal module-path syntax' + ;; or escape to compute a the module-path via expression + #'(begin (define-runtime-module-path-index mpi-var (quasiquote modpath)) (define (get-sym sym) (parameterize ((current-namespace (namespace-anchor->namespace anchor))) (dynamic-require mpi-var sym))) diff --git a/collects/unstable/scribblings/lazy-require.scrbl b/collects/unstable/scribblings/lazy-require.scrbl index a7453c8dc6..776d9b53ef 100644 --- a/collects/unstable/scribblings/lazy-require.scrbl +++ b/collects/unstable/scribblings/lazy-require.scrbl @@ -11,14 +11,20 @@ @unstable[@author+email["Ryan Culpepper" "ryanc@racket-lang.org"]] -@defform[(lazy-require [mod-expr (imported-fun-id ...)] ...) - #:contracts ([mod-expr module-path?])]{ +@defform/subs[#:literals (unquote) + (lazy-require [mod (imported-fun-id ...)] ...) + ([mod module-path + (unquote module-path-expr)]) + #:contracts ([module-path-expr module-path?])]{ Defines each @racket[imported-fun-id] as a function that, when called, dynamically requires the export named @racket['imported-fun-id] from -the module specified by @racket[mod-expr] and calls it with the same +the module specified by @racket[mod] and calls it with the same arguments. - -As with @racket[define-runtime-module-path-index], @racket[mod-expr] + +The module @racket[mod] can be specified as a @racket[_module-path] +(see @racket[require]) or as an @racket[unquote]-escaped expression +that computes a module path. As with +@racket[define-runtime-module-path-index], a @racket[module-path-expr] is evaluated both in phase 0 and phase 1. }