#lang racket/base (require (for-template racket/base syntax/parse/private/keywords stxparse-info/parse/private/residual ;; keep abs. path stxparse-info/parse/private/runtime) racket/list racket/contract/base "make.rkt" syntax/parse/private/minimatch syntax/private/id-table syntax/stx syntax/keyword racket/syntax racket/struct "txlift.rkt" syntax/parse/private/rep-attrs syntax/parse/private/rep-data syntax/parse/private/rep-patterns syntax/parse/private/residual-ct ;; keep abs. path syntax/parse/private/kws) ;; Error reporting ;; All entry points should have explicit, mandatory #:context arg ;; (mandatory from outside, at least) (provide/contract [atomic-datum-stx? (-> syntax? boolean?)] [parse-rhs (-> syntax? (or/c false/c (listof sattr?)) boolean? #:context (or/c false/c syntax?) rhs?)] [parse-pattern+sides (-> syntax? syntax? #:splicing? boolean? #:decls DeclEnv/c #:context syntax? any)] [parse*-ellipsis-head-pattern (-> syntax? DeclEnv/c boolean? #:context syntax? any)] [parse-directive-table any/c] [get-decls+defs (-> list? boolean? #:context (or/c false/c syntax?) (values DeclEnv/c (listof syntax?)))] [create-aux-def (-> DeclEntry/c (values DeclEntry/c (listof syntax?)))] [parse-argu (-> (listof syntax?) #:context syntax? arguments?)] [parse-kw-formals (-> syntax? #:context syntax? arity?)] [check-stxclass-header (-> syntax? syntax? (list/c identifier? syntax? arity?))] [check-stxclass-application (-> syntax? syntax? (cons/c identifier? arguments?))] [check-conventions-rules (-> syntax? syntax? (listof (list/c regexp? any/c)))] [check-datum-literals-list (-> syntax? syntax? (listof den:datum-lit?))] [check-attr-arity-list (-> syntax? syntax? (listof sattr?))]) ;; ---- (define (atomic-datum-stx? stx) (let ([datum (syntax-e stx)]) (or (null? datum) (boolean? datum) (string? datum) (number? datum) (keyword? datum) (bytes? datum) (char? datum) (regexp? datum) (byte-regexp? datum)))) (define (id-predicate kw) (lambda (stx) (and (identifier? stx) (free-identifier=? stx kw) (begin (disappeared! stx) #t)))) (define wildcard? (id-predicate (quote-syntax _))) (define epsilon? (id-predicate (quote-syntax ||))) (define dots? (id-predicate (quote-syntax ...))) (define plus-dots? (id-predicate (quote-syntax ...+))) (define keywords (list (quote-syntax _) (quote-syntax ||) (quote-syntax ...) (quote-syntax ~var) (quote-syntax ~datum) (quote-syntax ~literal) (quote-syntax ~and) (quote-syntax ~or) (quote-syntax ~not) (quote-syntax ~seq) (quote-syntax ~rep) (quote-syntax ~once) (quote-syntax ~optional) (quote-syntax ~between) (quote-syntax ~rest) (quote-syntax ~describe) (quote-syntax ~!) (quote-syntax ~bind) (quote-syntax ~fail) (quote-syntax ~parse) (quote-syntax ~do) (quote-syntax ...+) (quote-syntax ~delimit-cut) (quote-syntax ~commit) (quote-syntax ~reflect) (quote-syntax ~splicing-reflect) (quote-syntax ~eh-var) (quote-syntax ~peek) (quote-syntax ~peek-not))) (define (reserved? stx) (and (identifier? stx) (for/or ([kw (in-list keywords)]) (free-identifier=? stx kw)))) (define (safe-name? stx) (and (identifier? stx) (not (regexp-match? #rx"^~" (symbol->string (syntax-e stx)))))) ;; cut-allowed? : (paramter/c boolean?) ;; Used to detect ~cut within ~not pattern. ;; (Also #:no-delimit-cut stxclass within ~not) (define cut-allowed? (make-parameter #t)) ;; --- (define (disappeared! x) (cond [(identifier? x) (record-disappeared-uses (list x))] [(and (stx-pair? x) (identifier? (stx-car x))) (record-disappeared-uses (list (stx-car x)))] [else (raise-type-error 'disappeared! "identifier or syntax with leading identifier" x)])) ;; --- ;; parse-rhs : stx boolean (or #f (listof SAttr)) stx -> RHS ;; If expected-attrs is true, then referenced stxclasses must be defined and ;; literals must be bound. Set to #f for pass1 (attr collection); ;; parser requires stxclasses to be bound. (define (parse-rhs stx expected-attrs splicing? #:context ctx) (call/txlifts (lambda () (parameterize ((current-syntax-context ctx)) (define-values (rest description transp? attributes auto-nested? colon-notation? decls defs commit? delimit-cut?) (parse-rhs/part1 stx splicing? (and expected-attrs #t))) (define variants (parameterize ((stxclass-lookup-config (cond [expected-attrs 'yes] [auto-nested? 'try] [else 'no])) (stxclass-colon-notation? colon-notation?)) (parse-variants rest decls splicing? expected-attrs))) (let ([sattrs (or attributes (intersect-sattrss (map variant-attrs variants)))]) (make rhs sattrs transp? description variants (append (get-txlifts-as-definitions) defs) commit? delimit-cut?)))))) (define (parse-rhs/part1 stx splicing? strict?) (define-values (chunks rest) (parse-keyword-options stx rhs-directive-table #:context (current-syntax-context) #:incompatible '((#:attributes #:auto-nested-attributes) (#:commit #:no-delimit-cut)) #:no-duplicates? #t)) (define description (options-select-value chunks '#:description #:default #f)) (define opaque? (and (assq '#:opaque chunks) #t)) (define transparent? (not opaque?)) (define auto-nested? (and (assq '#:auto-nested-attributes chunks) #t)) (define colon-notation? (not (assq '#:disable-colon-notation chunks))) (define commit? (and (assq '#:commit chunks) #t)) (define delimit-cut? (not (assq '#:no-delimit-cut chunks))) (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 commit? delimit-cut?)) ;; ---- (define (parse-variants rest decls splicing? expected-attrs) (define (gather-variants stx) (syntax-case stx (pattern) [((pattern . _) . rest) (begin (disappeared! (stx-car stx)) (cons (parse-variant (stx-car stx) splicing? decls expected-attrs) (gather-variants #'rest)))] [(bad-variant . rest) (wrong-syntax #'bad-variant "expected syntax-class variant")] [() null])) (gather-variants rest)) ;; get-decls+defs : chunks boolean -> (values DeclEnv (listof syntax)) (define (get-decls+defs chunks strict? #:context [ctx (current-syntax-context)]) (parameterize ((current-syntax-context ctx)) (let*-values ([(decls defs1) (get-decls chunks strict?)] [(decls defs2) (decls-create-defs decls)]) (values decls (append defs1 defs2))))) ;; get-decls : chunks -> (values DeclEnv (listof syntax)) (define (get-decls chunks strict?) (define lits (options-select-value chunks '#:literals #:default null)) (define datum-lits (options-select-value chunks '#:datum-literals #:default null)) (define litsets (options-select-value chunks '#:literal-sets #:default null)) (define convs (options-select-value chunks '#:conventions #:default null)) (define localconvs (options-select-value chunks '#:local-conventions #:default null)) (define literals (append/check-lits+litsets lits datum-lits litsets)) (define-values (convs-rules convs-defs) (for/fold ([convs-rules null] [convs-defs null]) ([conv-entry (in-list convs)]) (let* ([c (car conv-entry)] [argu (cdr conv-entry)] [get-parser-id (conventions-get-procedures c)] [rules ((conventions-get-rules c))]) (values (append rules convs-rules) (cons (make-conventions-def (map cadr rules) get-parser-id argu) convs-defs))))) (define convention-rules (append localconvs convs-rules)) (values (new-declenv literals #:conventions convention-rules) (reverse convs-defs))) ;; make-conventions-def : (listof den:delay) id Argument -> syntax (define (make-conventions-def dens get-parsers-id argu) (with-syntax ([(parser ...) (map den:delayed-parser dens)] [get-parsers get-parsers-id] [argu argu]) #'(define-values (parser ...) (apply values (app-argu get-parsers argu))))) ;; decls-create-defs : DeclEnv -> (values DeclEnv (listof stx)) (define (decls-create-defs decls0) (define (updater key value defs) (let-values ([(value newdefs) (create-aux-def value)]) (values value (append newdefs defs)))) (declenv-update/fold decls0 updater null)) ;; create-aux-def : DeclEntry -> (values DeclEntry (listof stx)) ;; FIXME: replace with txlift mechanism (define (create-aux-def entry) (match entry [(? den:lit?) (values entry null)] [(? den:datum-lit?) (values entry null)] [(? den:magic-class?) (values entry null)] [(den:class name class argu) ;; FIXME: integrable syntax classes? ;; FIXME: what if no-arity, no-args? (cond [(identifier? name) (let* ([pos-count (length (arguments-pargs argu))] [kws (arguments-kws argu)] [sc (get-stxclass/check-arity class class pos-count kws)]) (with-syntax ([sc-parser (stxclass-parser sc)]) (with-syntax ([parser (generate-temporary class)]) (values (make den:parser #'parser (stxclass-attrs sc) (stxclass/h? sc) (stxclass-opts sc)) (list #`(define-values (parser) (curried-stxclass-parser #,class #,argu)))))))] [(regexp? name) ;; Conventions rule; delay class lookup until module/intdefs pass2 ;; to allow forward references (with-syntax ([parser (generate-temporary class)] [description (generate-temporary class)]) (values (make den:delayed #'parser class) (list #`(define-values (parser) (curried-stxclass-parser #,class #,argu)))))])] [(? den:parser?) (values entry null)] [(? den:delayed?) (values entry null)])) ;; append/check-lits+litsets : .... -> (listof (U den:lit den:datum-lit)) (define (append/check-lits+litsets lits datum-lits litsets) (define seen (make-bound-id-table)) (define (check-id id [blame-ctx id]) (if (bound-id-table-ref seen id #f) (wrong-syntax blame-ctx "duplicate literal declaration: ~s" (syntax-e id)) (bound-id-table-set! seen id #t)) id) (let* ([litsets* (for/list ([entry (in-list litsets)]) (let ([litset-id (first entry)] [litset (second entry)] [lctx (third entry)] [input-phase (fourth entry)]) (define (get/check-id sym) (check-id (datum->syntax lctx sym) litset-id)) (for/list ([lse (in-list (literalset-literals litset))]) (match lse [(lse:lit internal external lit-phase) (let ([internal (get/check-id internal)] [external (syntax-property external 'literal (gensym))]) (make den:lit internal external input-phase lit-phase))] [(lse:datum-lit internal external) (let ([internal (get/check-id internal)]) (make den:datum-lit internal external))]))))] [lits* (for/list ([lit (in-list lits)]) (check-id (den:lit-internal lit)) lit)] [datum-lits* (for/list ([datum-lit (in-list datum-lits)]) (check-id (den:datum-lit-internal datum-lit)) datum-lit)]) (apply append lits* datum-lits* litsets*))) ;; parse-variant : stx boolean DeclEnv #f/(listof Sattr) -> RHS (define (parse-variant stx splicing? decls0 expected-attrs) (syntax-case stx (pattern) [(pattern p . rest) (let-values ([(rest pattern defs) (parse-pattern+sides #'p #'rest #:splicing? splicing? #:decls decls0 #:context stx)]) (disappeared! stx) (unless (stx-null? rest) (wrong-syntax (if (pair? rest) (car rest) rest) "unexpected terms after pattern directives")) (let* ([attrs (pattern-attrs pattern)] [sattrs (iattrs->sattrs attrs)]) (when expected-attrs (parameterize ((current-syntax-context stx)) ;; Called just for error-reporting (reorder-iattrs expected-attrs attrs))) (make variant stx sattrs pattern defs)))])) ;; parse-pattern+sides : stx stx -> (values stx Pattern (listof stx)) ;; Parses pattern, side clauses; desugars side clauses & merges with pattern (define (parse-pattern+sides p-stx s-stx #:splicing? splicing? #:decls decls0 #:context ctx) (let-values ([(rest decls defs sides) (parse-pattern-directives s-stx #:allow-declare? #t #:decls decls0 #:context ctx)]) (let* ([pattern0 (parse-whole-pattern p-stx decls splicing? #:context ctx #:kind 'main)] [pattern (combine-pattern+sides pattern0 sides splicing?)]) (values rest pattern defs)))) ;; parse-whole-pattern : stx DeclEnv boolean -> Pattern ;; kind is either 'main or 'with, indicates what kind of pattern declare affects (define (parse-whole-pattern stx decls [splicing? #f] #:kind kind #:context [ctx (current-syntax-context)]) (parameterize ((current-syntax-context ctx)) (define pattern (if splicing? (parse-head-pattern stx decls) (parse-single-pattern stx decls))) (define pvars (map attr-name (pattern-attrs pattern))) (define excess-domain (declenv-domain-difference decls pvars)) (when (pair? excess-domain) (wrong-syntax (car excess-domain) (string-append "identifier in #:declare clause does not appear in pattern" (case kind [(main) ""] ;; ";\n this #:declare clause affects only the main pattern"] [(with) ";\n this #:declare clause affects only the preceding #:with pattern"])))) pattern)) ;; combine-pattern+sides : Pattern (listof SideClause) -> Pattern (define (combine-pattern+sides pattern sides splicing?) (check-pattern (cond [(pair? sides) (define actions-pattern (create-action:and (ord-and-patterns sides (gensym*)))) (define and-patterns (ord-and-patterns (list pattern (pat:action actions-pattern (pat:any))) (gensym*))) (cond [splicing? (apply hpat:and and-patterns)] [else (pat:and and-patterns)])] [else pattern]))) ;; gensym* : -> UninternedSymbol ;; Like gensym, but with deterministic name from compilation-local counter. (define gensym*-counter 0) (define (gensym*) (set! gensym*-counter (add1 gensym*-counter)) (string->uninterned-symbol (format "group~a" gensym*-counter))) ;; ---- ;; parse-single-pattern : stx DeclEnv -> SinglePattern (define (parse-single-pattern stx decls) (parse-*-pattern stx decls #f #f)) ;; parse-head-pattern : stx DeclEnv -> HeadPattern (define (parse-head-pattern stx decls) (parse-*-pattern stx decls #t #f)) ;; parse-action-pattern : Stx DeclEnv -> ActionPattern (define (parse-action-pattern stx decls) (define p (parse-*-pattern stx decls #f #t)) (unless (action-pattern? p) (wrong-syntax stx "expected action pattern")) p) (define ((make-not-shadowed? decls) id) ;; Returns #f if id is in literals/datum-literals list. ;; Conventions to not shadow pattern-form bindings, under the ;; theory that conventions only apply to things already determined ;; to be pattern variables. (not (declenv-lookup decls id))) ;; suitable as id=? argument to syntax-case* (define ((make-not-shadowed-id=? decls) lit-id pat-id) (and (free-identifier=? lit-id pat-id) (not (declenv-lookup decls pat-id)))) ;; parse-*-pattern : stx DeclEnv boolean boolean -> Pattern (define (parse-*-pattern stx decls allow-head? allow-action?) (define (recur stx) (parse-*-pattern stx decls allow-head? allow-action?)) (define (check-head! x) (unless allow-head? (wrong-syntax stx "head pattern not allowed here")) x) (define (check-action! x) ;; Coerce to S-pattern IF only S-patterns allowed (cond [allow-action? x] [(not allow-head?) (action-pattern->single-pattern x)] [else (wrong-syntax stx "action pattern not allowed here")])) (define not-shadowed? (make-not-shadowed? decls)) (check-pattern (syntax-case* stx (~var ~literal ~datum ~and ~or ~not ~rest ~describe ~seq ~optional ~! ~bind ~fail ~parse ~do ~post ~peek ~peek-not ~delimit-cut ~commit ~reflect ~splicing-reflect) (make-not-shadowed-id=? decls) [id (and (identifier? #'id) (not-shadowed? #'id) (pattern-expander? (syntax-local-value #'id (λ () #f)))) (begin (disappeared! #'id) (recur (expand-pattern (syntax-local-value #'id) stx)))] [(id . rst) (and (identifier? #'id) (not-shadowed? #'id) (pattern-expander? (syntax-local-value #'id (λ () #f)))) (begin (disappeared! #'id) (recur (expand-pattern (syntax-local-value #'id) stx)))] [wildcard (and (wildcard? #'wildcard) (not-shadowed? #'wildcard)) (begin (disappeared! stx) (pat:any))] [~! (disappeared! stx) (begin (unless (cut-allowed?) (wrong-syntax stx "cut (~~!) not allowed within ~~not pattern")) (check-action! (action:cut)))] [reserved (and (reserved? #'reserved) (not-shadowed? #'reserved)) (wrong-syntax stx "pattern keyword not allowed here")] [id (identifier? #'id) (parse-pat:id stx decls allow-head?)] [datum (atomic-datum-stx? #'datum) (pat:datum (syntax->datum #'datum))] [(~var . rest) (disappeared! stx) (parse-pat:var stx decls allow-head?)] [(~datum . rest) (disappeared! stx) (syntax-case stx (~datum) [(~datum d) (pat:datum (syntax->datum #'d))] [_ (wrong-syntax stx "bad ~~datum form")])] [(~literal . rest) (disappeared! stx) (parse-pat:literal stx decls)] [(~and . rest) (disappeared! stx) (parse-pat:and stx decls allow-head? allow-action?)] [(~or . rest) (disappeared! stx) (parse-pat:or stx decls allow-head?)] [(~not . rest) (disappeared! stx) (parse-pat:not stx decls)] [(~rest . rest) (disappeared! stx) (parse-pat:rest stx decls)] [(~describe . rest) (disappeared! stx) (parse-pat:describe stx decls allow-head?)] [(~delimit-cut . rest) (disappeared! stx) (parse-pat:delimit stx decls allow-head?)] [(~commit . rest) (disappeared! stx) (parse-pat:commit stx decls allow-head?)] [(~reflect . rest) (disappeared! stx) (parse-pat:reflect stx decls #f)] [(~seq . rest) (disappeared! stx) (check-head! (parse-hpat:seq stx #'rest decls))] [(~optional . rest) (disappeared! stx) (check-head! (parse-hpat:optional stx decls))] [(~splicing-reflect . rest) (disappeared! stx) (check-head! (parse-pat:reflect stx decls #t))] [(~bind . rest) (disappeared! stx) (check-action! (parse-pat:bind stx decls))] [(~fail . rest) (disappeared! stx) (check-action! (parse-pat:fail stx decls))] [(~post . rest) (disappeared! stx) (parse-pat:post stx decls allow-head? allow-action?)] [(~peek . rest) (disappeared! stx) (check-head! (parse-pat:peek stx decls))] [(~peek-not . rest) (disappeared! stx) (check-head! (parse-pat:peek-not stx decls))] [(~parse . rest) (disappeared! stx) (check-action! (parse-pat:parse stx decls))] [(~do . rest) (disappeared! stx) (check-action! (parse-pat:do stx decls))] [(head dots . tail) (and (dots? #'dots) (not-shadowed? #'dots)) (begin (disappeared! #'dots) (parse-pat:dots stx #'head #'tail decls))] [(head plus-dots . tail) (and (plus-dots? #'plus-dots) (not-shadowed? #'plus-dots)) (begin (disappeared! #'plus-dots) (parse-pat:plus-dots stx #'head #'tail decls))] [(head . tail) (let ([headp (parse-*-pattern #'head decls #t #t)] [tailp (parse-single-pattern #'tail decls)]) (cond [(action-pattern? headp) (pat:action headp tailp)] [(head-pattern? headp) (pat:head headp tailp)] [else (pat:pair headp tailp)]))] [#(a ...) (let ([lp (parse-single-pattern (syntax/loc stx (a ...)) decls)]) (pat:vector lp))] [b (box? (syntax-e #'b)) (let ([bp (parse-single-pattern (unbox (syntax-e #'b)) decls)]) (pat:box bp))] [s (and (struct? (syntax-e #'s)) (prefab-struct-key (syntax-e #'s))) (let* ([s (syntax-e #'s)] [key (prefab-struct-key s)] [contents (struct->list s)]) (let ([lp (parse-single-pattern (datum->syntax #f contents #'s) decls)]) (pat:pstruct key lp)))]))) ;; expand-pattern : pattern-expander Syntax -> Syntax (define (expand-pattern pe stx) (let* ([proc (pattern-expander-proc pe)] [introducer (make-syntax-introducer)] [mstx (introducer (syntax-local-introduce stx))] [mresult (parameterize ([current-syntax-parse-pattern-introducer introducer]) (proc mstx))] [result (syntax-local-introduce (introducer mresult))]) result)) ;; parse-ellipsis-head-pattern : stx DeclEnv -> (listof EllipsisHeadPattern) (define (parse-ellipsis-head-pattern stx decls) (for/list ([ehpat+hstx (in-list (parse*-ellipsis-head-pattern stx decls #t))]) (car ehpat+hstx))) ;; parse*-ellipsis-head-pattern : stx DeclEnv bool ;; -> (listof (list EllipsisHeadPattern stx/eh-alternative)) (define (parse*-ellipsis-head-pattern stx decls allow-or? #:context [ctx (current-syntax-context)]) (define (recur stx) (parse*-ellipsis-head-pattern stx decls allow-or? #:context ctx)) (define not-shadowed? (make-not-shadowed? decls)) (syntax-case* stx (~eh-var ~or ~between ~optional ~once) (make-not-shadowed-id=? decls) [id (and (identifier? #'id) (not-shadowed? #'id) (pattern-expander? (syntax-local-value #'id (lambda () #f)))) (begin (disappeared! #'id) (recur (expand-pattern (syntax-local-value #'id) stx)))] [(id . rst) (and (identifier? #'id) (not-shadowed? #'id) (pattern-expander? (syntax-local-value #'id (lambda () #f)))) (begin (disappeared! #'id) (recur (expand-pattern (syntax-local-value #'id) stx)))] [(~eh-var name eh-alt-set-id) (disappeared! stx) (let () (define prefix (name->prefix #'name ".")) (define eh-alt-set (get-eh-alternative-set #'eh-alt-set-id)) (for/list ([alt (in-list (eh-alternative-set-alts eh-alt-set))]) (let* ([iattrs (id-pattern-attrs (eh-alternative-attrs alt) prefix)] [attr-count (length iattrs)]) (list (create-ehpat (hpat:var/p #f (eh-alternative-parser alt) no-arguments iattrs #f (scopts attr-count #f #t #f)) (eh-alternative-repc alt) #f) (replace-eh-alternative-attrs alt (iattrs->sattrs iattrs))))))] [(~or . _) allow-or? (begin (disappeared! stx) (unless (stx-list? stx) (wrong-syntax stx "expected sequence of patterns")) (apply append (for/list ([sub (in-list (cdr (stx->list stx)))]) (parse*-ellipsis-head-pattern sub decls allow-or?))))] [(~optional . _) (disappeared! stx) (list (parse*-ehpat/optional stx decls))] [(~once . _) (disappeared! stx) (list (parse*-ehpat/once stx decls))] [(~between . _) (disappeared! stx) (list (parse*-ehpat/bounds stx decls))] [_ (let ([head (parse-head-pattern stx decls)]) (list (list (create-ehpat head #f stx) stx)))])) (define (replace-eh-alternative-attrs alt sattrs) (match alt [(eh-alternative repc _attrs parser) (eh-alternative repc sattrs parser)])) ;; ---- (define (check-no-delimit-cut-in-not id delimit-cut?) (unless (or delimit-cut? (cut-allowed?)) (wrong-syntax id (string-append "syntax class with #:no-delimit-cut option " "not allowed within ~~not pattern")))) (define (parse-pat:id id decls allow-head?) (cond [(declenv-lookup decls id) => (lambda (entry) (parse-pat:id/entry id allow-head? entry))] [(not (safe-name? id)) (wrong-syntax id "expected identifier not starting with ~~ character")] [else (let-values ([(name suffix) (split-id/get-stxclass id decls)]) (cond [(stxclass? suffix) (parse-pat:var/sc id allow-head? name suffix no-arguments "." #f #f)] [(or (den:lit? suffix) (den:datum-lit? suffix)) (pat:and (list (pat:svar name) (parse-pat:id/entry id allow-head? suffix)))] [(declenv-apply-conventions decls id) => (lambda (entry) (parse-pat:id/entry id allow-head? entry))] [else (pat:svar name)]))])) ;; parse-pat:id/entry : Identifier .... DeclEntry -> SinglePattern ;; Handle when meaning of identifier pattern is given by declenv entry. (define (parse-pat:id/entry id allow-head? entry) (match entry [(den:lit internal literal input-phase lit-phase) (pat:literal literal input-phase lit-phase)] [(den:datum-lit internal sym) (pat:datum sym)] [(den:magic-class name class argu role) (let* ([pos-count (length (arguments-pargs argu))] [kws (arguments-kws argu)] [sc (get-stxclass/check-arity class class pos-count kws)]) (parse-pat:var/sc id allow-head? id sc argu "." role #f))] [(den:class _n _c _a) (error 'parse-pat:id "(internal error) decls had leftover stxclass entry: ~s" entry)] [(den:parser parser attrs splicing? opts) (check-no-delimit-cut-in-not id (scopts-delimit-cut? opts)) (cond [splicing? (unless allow-head? (wrong-syntax id "splicing syntax class not allowed here")) (parse-pat:id/h id parser no-arguments attrs "." #f opts)] [else (parse-pat:id/s id parser no-arguments attrs "." #f opts)])] [(den:delayed parser class) (let ([sc (get-stxclass class)]) (parse-pat:var/sc id allow-head? id sc no-arguments "." #f parser))])) (define (parse-pat:var stx decls allow-head?) (define name0 (syntax-case stx () [(_ name . _) (unless (identifier? #'name) (wrong-syntax #'name "expected identifier")) #'name] [_ (wrong-syntax stx "bad ~~var form")])) (define-values (scname sc+args-stx argu pfx role) (syntax-case stx () [(_ _name) (values #f #f null #f #f)] [(_ _name sc/sc+args . rest) (let-values ([(sc argu) (let ([p (check-stxclass-application #'sc/sc+args stx)]) (values (car p) (cdr p)))]) (define chunks (parse-keyword-options/eol #'rest var-pattern-directive-table #:no-duplicates? #t #:context stx)) (define sep (options-select-value chunks '#:attr-name-separator #:default #f)) (define role (options-select-value chunks '#:role #:default #'#f)) (values sc #'sc/sc+args argu (if sep (syntax-e sep) ".") role))] [_ (wrong-syntax stx "bad ~~var form")])) (cond [(and (epsilon? name0) (not scname)) (wrong-syntax name0 "illegal pattern variable name")] [(and (wildcard? name0) (not scname)) (pat:any)] [scname (let ([sc (get-stxclass/check-arity scname sc+args-stx (length (arguments-pargs argu)) (arguments-kws argu))]) (parse-pat:var/sc stx allow-head? name0 sc argu pfx role #f))] [else ;; Just proper name (pat:svar name0)])) (define (parse-pat:var/sc stx allow-head? name sc argu pfx role parser*) ;; if parser* not #f, overrides sc parser (check-no-delimit-cut-in-not stx (scopts-delimit-cut? (stxclass-opts sc))) (cond [(and (stxclass/s? sc) (stxclass-inline sc) (equal? argu no-arguments)) (parse-pat:id/s/integrate name (stxclass-inline sc) (scopts-desc (stxclass-opts sc)) role)] [(stxclass/s? sc) (parse-pat:id/s name (or parser* (stxclass-parser sc)) argu (stxclass-attrs sc) pfx role (stxclass-opts sc))] [(stxclass/h? sc) (unless allow-head? (wrong-syntax stx "splicing syntax class not allowed here")) (parse-pat:id/h name (or parser* (stxclass-parser sc)) argu (stxclass-attrs sc) pfx role (stxclass-opts sc))])) (define (parse-pat:id/s name parser argu attrs pfx role opts) (define prefix (name->prefix name pfx)) (define bind (name->bind name)) (pat:var/p bind parser argu (id-pattern-attrs attrs prefix) role opts)) (define (parse-pat:id/s/integrate name predicate description role) (define bind (name->bind name)) (pat:integrated bind predicate description role)) (define (parse-pat:id/h name parser argu attrs pfx role opts) (define prefix (name->prefix name pfx)) (define bind (name->bind name)) (hpat:var/p bind parser argu (id-pattern-attrs attrs prefix) role opts)) (define (name->prefix id pfx) (cond [(wildcard? id) #f] [(epsilon? id) id] [else (format-id id "~a~a" (syntax-e id) pfx #:source id)])) (define (name->bind id) (cond [(wildcard? id) #f] [(epsilon? id) #f] [else id])) ;; id-pattern-attrs : (listof SAttr)IdPrefix -> (listof IAttr) (define (id-pattern-attrs sattrs prefix) (if prefix (for/list ([a (in-list sattrs)]) (prefix-attr a prefix)) null)) ;; prefix-attr : SAttr identifier -> IAttr (define (prefix-attr a prefix) (make attr (prefix-attr-name prefix (attr-name a)) (attr-depth a) (attr-syntax? a))) ;; prefix-attr-name : id symbol -> id (define (prefix-attr-name prefix name) (orig (format-id prefix "~a~a" (syntax-e prefix) name #:source prefix))) (define (orig stx) (syntax-property stx 'original-for-check-syntax #t)) ;; ---- (define (parse-pat:reflect stx decls splicing?) (syntax-case stx () [(_ name (obj arg ...) . maybe-signature) (let () (unless (identifier? #'var) (raise-syntax-error #f "expected identifier" stx #'name)) (define attr-decls (syntax-case #'maybe-signature () [(#:attributes attr-decls) (check-attr-arity-list #'attr-decls stx)] [() null] [_ (raise-syntax-error #f "bad syntax" stx)])) (define prefix (name->prefix #'name ".")) (define bind (name->bind #'name)) (define ctor (if splicing? hpat:reflect pat:reflect)) (ctor #'obj (parse-argu (syntax->list #'(arg ...))) attr-decls bind (id-pattern-attrs attr-decls prefix)))])) ;; --- (define (parse-pat:literal stx decls) (syntax-case stx () [(_ lit . more) (unless (identifier? #'lit) (wrong-syntax #'lit "expected identifier")) (let* ([chunks (parse-keyword-options/eol #'more phase-directive-table #:no-duplicates? #t #:context stx)] [phase (options-select-value chunks '#:phase #:default #'(syntax-local-phase-level))]) ;; FIXME: Duplicates phase expr! (pat:literal #'lit phase phase))] [_ (wrong-syntax stx "bad ~~literal pattern")])) (define (parse-pat:describe stx decls allow-head?) (syntax-case stx () [(_ . rest) (let-values ([(chunks rest) (parse-keyword-options #'rest describe-option-table #:no-duplicates? #t #:context stx)]) (define transparent? (not (assq '#:opaque chunks))) (define role (options-select-value chunks '#:role #:default #'#f)) (syntax-case rest () [(description pattern) (let ([p (parse-*-pattern #'pattern decls allow-head? #f)]) (if (head-pattern? p) (hpat:describe p #'description transparent? role) (pat:describe p #'description transparent? role)))]))])) (define (parse-pat:delimit stx decls allow-head?) (syntax-case stx () [(_ pattern) (let ([p (parameterize ((cut-allowed? #t)) (parse-*-pattern #'pattern decls allow-head? #f))]) (if (head-pattern? p) (hpat:delimit p) (pat:delimit p)))])) (define (parse-pat:commit stx decls allow-head?) (syntax-case stx () [(_ pattern) (let ([p (parameterize ((cut-allowed? #t)) (parse-*-pattern #'pattern decls allow-head? #f))]) (if (head-pattern? p) (hpat:commit p) (pat:commit p)))])) (define (split-prefix xs pred) (let loop ([xs xs] [rprefix null]) (cond [(and (pair? xs) (pred (car xs))) (loop (cdr xs) (cons (car xs) rprefix))] [else (values (reverse rprefix) xs)]))) (define (parse-pat:and stx decls allow-head? allow-action?) ;; allow-action? = allowed to *return* pure action pattern; ;; all ~and patterns are allowed to *contain* action patterns (define patterns0 (parse-cdr-patterns stx decls allow-head? #t)) (define patterns1 (ord-and-patterns patterns0 (gensym*))) (define-values (actions patterns) (split-prefix patterns1 action-pattern?)) (cond [(null? patterns) (cond [allow-action? (action:and actions)] [allow-head? (wrong-syntax stx "expected at least one head pattern")] [else (wrong-syntax stx "expected at least one single-term pattern")])] [else (let ([p (parse-pat:and* stx patterns)]) (if (head-pattern? p) (for/fold ([p p]) ([action (in-list (reverse actions))]) (hpat:action action p)) (for/fold ([p p]) ([action (in-list (reverse actions))]) (pat:action action p))))])) (define (parse-pat:and* stx patterns) ;; patterns is non-empty (empty case handled above) (cond [(null? (cdr patterns)) (car patterns)] [(ormap head-pattern? patterns) ;; Check to make sure *all* are head patterns (for ([pattern (in-list patterns)] [pattern-stx (in-list (stx->list (stx-cdr stx)))]) (unless (or (action-pattern? pattern) (head-pattern? pattern)) (wrong-syntax pattern-stx "single-term pattern not allowed after head pattern"))) (let ([p0 (car patterns)] [lps (map action/head-pattern->list-pattern (cdr patterns))]) (hpat:and p0 (pat:and lps)))] [else (pat:and (for/list ([p (in-list patterns)]) (if (action-pattern? p) (action-pattern->single-pattern p) p)))])) (define (parse-pat:or stx decls allow-head?) (define patterns (parse-cdr-patterns stx decls allow-head? #f)) (cond [(null? (cdr patterns)) (car patterns)] [else (cond [(ormap head-pattern? patterns) (create-hpat:or patterns)] [else (create-pat:or patterns)])])) (define (parse-pat:not stx decls) (syntax-case stx () [(_ pattern) (let ([p (parameterize ((cut-allowed? #f)) (parse-single-pattern #'pattern decls))]) (pat:not p))] [_ (wrong-syntax stx "expected a single subpattern")])) (define (parse-hpat:seq stx list-stx decls) (define pattern (parse-single-pattern list-stx decls)) (unless (proper-list-pattern? pattern) (wrong-syntax stx "expected proper list pattern")) (hpat:seq pattern)) (define (parse-cdr-patterns stx decls allow-head? allow-action?) (unless (stx-list? stx) (wrong-syntax stx "expected sequence of patterns")) (let ([result (for/list ([sub (in-list (cdr (stx->list stx)))]) (parse-*-pattern sub decls allow-head? allow-action?))]) (when (null? result) (wrong-syntax stx "expected at least one pattern")) result)) (define (parse-pat:dots stx head tail decls) (define headps (parse-ellipsis-head-pattern head decls)) (define tailp (parse-single-pattern tail decls)) (unless (pair? headps) (wrong-syntax head "expected at least one pattern")) (pat:dots headps tailp)) (define (parse-pat:plus-dots stx head tail decls) (define headp (parse-head-pattern head decls)) (define tailp (parse-single-pattern tail decls)) (define head/rep (create-ehpat headp (make-rep:bounds 1 +inf.0 #f #f #f) head)) (pat:dots (list head/rep) tailp)) (define (parse-pat:bind stx decls) (syntax-case stx () [(_ clause ...) (let ([clauses (check-bind-clause-list #'(clause ...) stx)]) (create-action:and clauses))])) (define (parse-pat:fail stx decls) (syntax-case stx () [(_ . rest) (let-values ([(chunks rest) (parse-keyword-options #'rest fail-directive-table #:context stx #:incompatible '((#:when #:unless)) #:no-duplicates? #t)]) (let ([condition (if (null? chunks) #'#t (let ([chunk (car chunks)]) (if (eq? (car chunk) '#:when) (caddr chunk) #`(not #,(caddr chunk)))))]) (syntax-case rest () [(message) (action:fail condition #'message)] [() (action:fail condition #''#f)] [_ (wrong-syntax stx "bad ~~fail pattern")])))])) (define (parse-pat:post stx decls allow-head? allow-action?) (syntax-case stx () [(_ pattern) (let ([p (parse-*-pattern #'pattern decls allow-head? allow-action?)]) (cond [(action-pattern? p) (cond [allow-action? (action:post p)] [(not allow-head?) (pat:post (action-pattern->single-pattern p))] [else (wrong-syntax stx "action pattern not allowed here")])] [(head-pattern? p) (cond [allow-head? (hpat:post p)] [else (wrong-syntax stx "head pattern now allowed here")])] [else (pat:post p)]))])) (define (parse-pat:peek stx decls) (syntax-case stx () [(_ pattern) (let ([p (parse-head-pattern #'pattern decls)]) (hpat:peek p))])) (define (parse-pat:peek-not stx decls) (syntax-case stx () [(_ pattern) (let ([p (parse-head-pattern #'pattern decls)]) (hpat:peek-not p))])) (define (parse-pat:parse stx decls) (syntax-case stx () [(_ pattern expr) (let ([p (parse-single-pattern #'pattern decls)]) (action:parse p #'expr))] [_ (wrong-syntax stx "bad ~~parse pattern")])) (define (parse-pat:do stx decls) (syntax-case stx () [(_ stmt ...) (action:do (syntax->list #'(stmt ...)))] [_ (wrong-syntax stx "bad ~~do pattern")])) (define (parse-pat:rest stx decls) (syntax-case stx () [(_ pattern) (parse-single-pattern #'pattern decls)])) (define (parse-hpat:optional stx decls) (define-values (head-stx head iattrs _name _tmm defaults) (parse*-optional-pattern stx decls h-optional-directive-table)) (create-hpat:or (list head (hpat:action (create-action:and defaults) (hpat:seq (pat:datum '())))))) ;; parse*-optional-pattern : stx DeclEnv table ;; -> (values Syntax HeadPattern IAttrs Stx Stx (Listof BindClause)) (define (parse*-optional-pattern stx decls optional-directive-table) (syntax-case stx () [(_ p . options) (let* ([head (parse-head-pattern #'p decls)] [chunks (parse-keyword-options/eol #'options optional-directive-table #:no-duplicates? #t #:context stx)] [too-many-msg (options-select-value chunks '#:too-many #:default #'#f)] [name (options-select-value chunks '#:name #:default #'#f)] [defaults (options-select-value chunks '#:defaults #:default '())] [pattern-iattrs (pattern-attrs head)] [defaults-iattrs (append-iattrs (map pattern-attrs defaults))] [all-iattrs (union-iattrs (list pattern-iattrs defaults-iattrs))]) (when (eq? (stxclass-lookup-config) 'yes) ;; Only check that attrs in defaults clause agree with attrs ;; in pattern when attrs in pattern are known to be complete. (check-iattrs-subset defaults-iattrs pattern-iattrs stx)) (values #'p head all-iattrs name too-many-msg defaults))])) ;; -- EH patterns ;; Only parse the rep-constraint part; don't parse the head pattern within. ;; (To support eh-alternative-sets.) ;; parse*-ehpat/optional : stx DeclEnv -> (list EllipsisHeadPattern stx) (define (parse*-ehpat/optional stx decls) (define-values (head-stx head iattrs name too-many-msg defaults) (parse*-optional-pattern stx decls eh-optional-directive-table)) (list (create-ehpat head (make rep:optional name too-many-msg defaults) head-stx) head-stx)) ;; parse*-ehpat/once : stx DeclEnv -> (list EllipsisHeadPattern stx) (define (parse*-ehpat/once stx decls) (syntax-case stx () [(_ p . options) (let* ([head (parse-head-pattern #'p decls)] [chunks (parse-keyword-options/eol #'options (list (list '#:too-few check-expression) (list '#:too-many check-expression) (list '#:name check-expression)) #:context stx)] [too-few-msg (options-select-value chunks '#:too-few #:default #'#f)] [too-many-msg (options-select-value chunks '#:too-many #:default #'#f)] [name (options-select-value chunks '#:name #:default #'#f)]) (list (create-ehpat head (make rep:once name too-few-msg too-many-msg) #'p) #'p))])) ;; parse*-ehpat/bounds : stx DeclEnv -> (list EllipsisHeadPattern stx) (define (parse*-ehpat/bounds stx decls) (syntax-case stx () [(_ p min max . options) (let () (define head (parse-head-pattern #'p decls)) (define minN (syntax-e #'min)) (define maxN (syntax-e #'max)) (unless (exact-nonnegative-integer? minN) (wrong-syntax #'min "expected exact nonnegative integer")) (unless (or (exact-nonnegative-integer? maxN) (equal? maxN +inf.0)) (wrong-syntax #'max "expected exact nonnegative integer or +inf.0")) (when (> minN maxN) (wrong-syntax stx "minimum larger than maximum repetition constraint")) (let* ([chunks (parse-keyword-options/eol #'options (list (list '#:too-few check-expression) (list '#:too-many check-expression) (list '#:name check-expression)) #:context stx)] [too-few-msg (options-select-value chunks '#:too-few #:default #'#f)] [too-many-msg (options-select-value chunks '#:too-many #:default #'#f)] [name (options-select-value chunks '#:name #:default #'#f)]) (list (create-ehpat head (make rep:bounds #'min #'max name too-few-msg too-many-msg) #'p) #'p)))])) ;; ----- ;; parse-pattern-directives : stxs(PatternDirective) ;; -> stx DeclEnv (listof stx) (listof SideClause) (define (parse-pattern-directives stx #:allow-declare? allow-declare? #:decls decls #:context ctx) (parameterize ((current-syntax-context ctx)) (define-values (chunks rest) (parse-keyword-options stx pattern-directive-table #:context ctx)) (define-values (decls2 chunks2) (if allow-declare? (grab-decls chunks decls) (values decls chunks))) (define sides ;; NOTE: use *original* decls ;; because decls2 has #:declares for *above* pattern (parse-pattern-sides chunks2 decls)) (define-values (decls3 defs) (decls-create-defs decls2)) (values rest decls3 defs sides))) ;; parse-pattern-sides : (listof chunk) DeclEnv -> (listof SideClause) ;; Invariant: decls contains only literals bindings (define (parse-pattern-sides chunks decls) (match chunks [(cons (list '#:declare declare-stx _ _) rest) (wrong-syntax declare-stx "#:declare can only appear immediately after pattern or #:with clause")] [(cons (list '#:role role-stx _) rest) (wrong-syntax role-stx "#:role can only appear immediately after #:declare clause")] [(cons (list '#:fail-when fw-stx when-expr msg-expr) rest) (cons (create-post-pattern (action:fail when-expr msg-expr)) (parse-pattern-sides rest decls))] [(cons (list '#:fail-unless fu-stx unless-expr msg-expr) rest) (cons (create-post-pattern (action:fail #`(not #,unless-expr) msg-expr)) (parse-pattern-sides rest decls))] [(cons (list '#:when w-stx unless-expr) rest) (cons (create-post-pattern (action:fail #`(not #,unless-expr) #'#f)) (parse-pattern-sides rest decls))] [(cons (list '#:with with-stx pattern expr) rest) (let-values ([(decls2 rest) (grab-decls rest decls)]) (let-values ([(decls2a defs) (decls-create-defs decls2)]) (list* (action:do defs) (create-post-pattern (action:parse (parse-whole-pattern pattern decls2a #:kind 'with) expr)) (parse-pattern-sides rest decls))))] [(cons (list '#:attr attr-stx a expr) rest) (cons (action:bind a expr) ;; no POST wrapper, cannot fail (parse-pattern-sides rest decls))] [(cons (list '#:post post-stx pattern) rest) (cons (create-post-pattern (parse-action-pattern pattern decls)) (parse-pattern-sides rest decls))] [(cons (list '#:and and-stx pattern) rest) (cons (parse-action-pattern pattern decls) ;; no POST wrapper (parse-pattern-sides rest decls))] [(cons (list '#:do do-stx stmts) rest) (cons (action:do stmts) (parse-pattern-sides rest decls))] ['() '()])) ;; grab-decls : (listof chunk) DeclEnv ;; -> (values DeclEnv (listof chunk)) (define (grab-decls chunks decls0) (define (add-decl stx role-stx decls) (let ([role (and role-stx (syntax-case role-stx () [(#:role role) #'role]))]) (syntax-case stx () [(#:declare name sc) (identifier? #'sc) (add-decl* decls #'name #'sc (parse-argu null) role)] [(#:declare name (sc expr ...)) (identifier? #'sc) (add-decl* decls #'name #'sc (parse-argu (syntax->list #'(expr ...))) role)] [(#:declare name bad-sc) (wrong-syntax #'bad-sc "expected syntax class name (possibly with parameters)")]))) (define (add-decl* decls id sc-name argu role) (declenv-put-stxclass decls id sc-name argu role)) (define (loop chunks decls) (match chunks [(cons (cons '#:declare decl-stx) (cons (cons '#:role role-stx) rest)) (loop rest (add-decl decl-stx role-stx decls))] [(cons (cons '#:declare decl-stx) rest) (loop rest (add-decl decl-stx #f decls))] [_ (values decls chunks)])) (loop chunks decls0)) ;; ---- ;; Keyword Options & Checkers ;; check-attr-arity-list : stx stx -> (listof SAttr) (define (check-attr-arity-list stx ctx) (unless (stx-list? stx) (raise-syntax-error #f "expected list of attribute declarations" ctx stx)) (let ([iattrs (for/list ([x (in-list (stx->list stx))]) (check-attr-arity x ctx))]) (iattrs->sattrs (append-iattrs (map list iattrs))))) ;; check-attr-arity : stx stx -> IAttr (define (check-attr-arity stx ctx) (syntax-case stx () [attr (identifier? #'attr) (make-attr #'attr 0 #f)] [(attr depth) (begin (unless (identifier? #'attr) (raise-syntax-error #f "expected attribute name" ctx #'attr)) (unless (exact-nonnegative-integer? (syntax-e #'depth)) (raise-syntax-error #f "expected depth (nonnegative integer)" ctx #'depth)) (make-attr #'attr (syntax-e #'depth) #f))] [_ (raise-syntax-error #f "expected attribute name with optional depth declaration" ctx stx)])) ;; check-literals-list : stx stx -> (listof den:lit) ;; - txlifts defs of phase expressions ;; - txlifts checks that literals are bound (define (check-literals-list stx ctx) (unless (stx-list? stx) (raise-syntax-error #f "expected literals list" ctx stx)) (for/list ([x (in-list (stx->list stx))]) (check-literal-entry x ctx))) ;; check-literal-entry : stx stx -> den:lit (define (check-literal-entry stx ctx) (define (go internal external phase) (txlift #`(check-literal #,external #,phase #,ctx)) (let ([external (syntax-property external 'literal (gensym))]) (make den:lit internal external phase phase))) (syntax-case stx () [(internal external #:phase phase) (and (identifier? #'internal) (identifier? #'external)) (go #'internal #'external (txlift #'phase))] [(internal external) (and (identifier? #'internal) (identifier? #'external)) (go #'internal #'external #'(syntax-local-phase-level))] [id (identifier? #'id) (go #'id #'id #'(syntax-local-phase-level))] [_ (raise-syntax-error #f "expected literal entry" ctx stx)])) ;; check-datum-literals-list : stx stx -> (listof den:datum-lit) (define (check-datum-literals-list stx ctx) (unless (stx-list? stx) (raise-syntax-error #f "expected datum-literals list" ctx stx)) (for/list ([x (in-list (stx->list stx))]) (check-datum-literal-entry x ctx))) ;; check-datum-literal-entry : stx stx -> den:datum-lit (define (check-datum-literal-entry stx ctx) (syntax-case stx () [(internal external) (and (identifier? #'internal) (identifier? #'external)) (make den:datum-lit #'internal (syntax-e #'external))] [id (identifier? #'id) (make den:datum-lit #'id (syntax-e #'id))] [_ (raise-syntax-error #f "expected datum-literal entry" ctx stx)])) ;; Literal sets - Import ;; check-literal-sets-list : stx stx -> (listof (list id literalset stx stx)) (define (check-literal-sets-list stx ctx) (unless (stx-list? stx) (raise-syntax-error #f "expected literal-set list" ctx stx)) (for/list ([x (in-list (stx->list stx))]) (check-literal-set-entry x ctx))) ;; check-literal-set-entry : stx stx -> (list id literalset stx stx) (define (check-literal-set-entry stx ctx) (define (elaborate litset-id lctx phase) (let ([litset (syntax-local-value/record litset-id literalset?)]) (unless litset (raise-syntax-error #f "expected identifier defined as a literal-set" ctx litset-id)) (list litset-id litset lctx phase))) (syntax-case stx () [(litset . more) (and (identifier? #'litset)) (let* ([chunks (parse-keyword-options/eol #'more litset-directive-table #:no-duplicates? #t #:context ctx)] [lctx (options-select-value chunks '#:at #:default #'litset)] [phase (options-select-value chunks '#:phase #:default #'(syntax-local-phase-level))]) (elaborate #'litset lctx (txlift phase)))] [litset (identifier? #'litset) (elaborate #'litset #'litset #'(syntax-local-phase-level))] [_ (raise-syntax-error #f "expected literal-set entry" ctx stx)])) ;; Conventions ;; returns (listof (cons Conventions (listof syntax))) (define (check-conventions-list stx ctx) (unless (stx-list? stx) (raise-syntax-error #f "expected conventions list" ctx stx)) (for/list ([x (in-list (stx->list stx))]) (check-conventions x ctx))) ;; returns (cons Conventions (listof syntax)) (define (check-conventions stx ctx) (define (elaborate conventions-id argu) (let ([cs (syntax-local-value/record conventions-id conventions?)]) (unless cs (raise-syntax-error #f "expected identifier defined as a conventions" ctx conventions-id)) (cons cs argu))) (syntax-case stx () [(conventions arg ...) (identifier? #'conventions) (elaborate #'conventions (parse-argu (syntax->list #'(arg ...))))] [conventions (identifier? #'conventions) (elaborate #'conventions no-arguments)] [_ (raise-syntax-error "expected conventions entry" ctx stx)])) ;; returns (listof (list regexp DeclEntry)) (define (check-conventions-rules stx ctx) (unless (stx-list? stx) (raise-syntax-error #f "expected convention rule list" ctx stx)) (for/list ([x (in-list (stx->list stx))]) (check-conventions-rule x ctx))) ;; returns (list regexp DeclEntry) (define (check-conventions-rule stx ctx) (define (check-conventions-pattern x blame) (cond [(symbol? x) (regexp (string-append "^" (regexp-quote (symbol->string x)) "$"))] [(regexp? x) x] [else (raise-syntax-error #f "expected identifier convention pattern" ctx blame)])) (define (check-sc-expr x rx) (let ([x (check-stxclass-application x ctx)]) (make den:class rx (car x) (cdr x)))) (syntax-case stx () [(rx sc) (let ([name-pattern (check-conventions-pattern (syntax-e #'rx) #'rx)]) (list name-pattern (check-sc-expr #'sc name-pattern)))])) (define (check-stxclass-header stx ctx) (syntax-case stx () [name (identifier? #'name) (list #'name #'() no-arity)] [(name . formals) (identifier? #'name) (list #'name #'formals (parse-kw-formals #'formals #:context ctx))] [_ (raise-syntax-error #f "expected syntax class header" stx ctx)])) (define (check-stxclass-application stx ctx) ;; Doesn't check "operator" is actually a stxclass (syntax-case stx () [op (identifier? #'op) (cons #'op no-arguments)] [(op arg ...) (identifier? #'op) (cons #'op (parse-argu (syntax->list #'(arg ...))))] [_ (raise-syntax-error #f "expected syntax class use" ctx stx)])) ;; bind clauses (define (check-bind-clause-list stx ctx) (unless (stx-list? stx) (raise-syntax-error #f "expected sequence of bind clauses" ctx stx)) (for/list ([clause (in-list (stx->list stx))]) (check-bind-clause clause ctx))) (define (check-bind-clause clause ctx) (syntax-case clause () [(attr-decl expr) (action:bind (check-attr-arity #'attr-decl ctx) #'expr)] [_ (raise-syntax-error #f "expected bind clause" ctx clause)])) (define (check-stmt-list stx ctx) (syntax-case stx () [(e ...) (syntax->list #'(e ...))] [_ (raise-syntax-error #f "expected list of expressions and definitions" ctx stx)])) ;; Arguments and Arities ;; parse-argu : (listof stx) -> Arguments (define (parse-argu args #:context [ctx (current-syntax-context)]) (parameterize ((current-syntax-context ctx)) (define (loop args rpargs rkws rkwargs) (cond [(null? args) (arguments (reverse rpargs) (reverse rkws) (reverse rkwargs))] [(keyword? (syntax-e (car args))) (let ([kw (syntax-e (car args))] [rest (cdr args)]) (cond [(memq kw rkws) (wrong-syntax (car args) "duplicate keyword")] [(null? rest) (wrong-syntax (car args) "missing argument expression after keyword")] #| Overzealous, perhaps? [(keyword? (syntax-e (car rest))) (wrong-syntax (car rest) "expected expression following keyword")] |# [else (loop (cdr rest) rpargs (cons kw rkws) (cons (car rest) rkwargs))]))] [else (loop (cdr args) (cons (car args) rpargs) rkws rkwargs)])) (loop args null null null))) ;; parse-kw-formals : stx -> Arity (define (parse-kw-formals formals #:context [ctx (current-syntax-context)]) (parameterize ((current-syntax-context ctx)) (define id-h (make-bound-id-table)) (define kw-h (make-hasheq)) ;; keyword => 'mandatory or 'optional (define pos 0) (define opts 0) (define (add-id! id) (when (bound-id-table-ref id-h id #f) (wrong-syntax id "duplicate formal parameter" )) (bound-id-table-set! id-h id #t)) (define (loop formals) (cond [(and (stx-pair? formals) (keyword? (syntax-e (stx-car formals)))) (let* ([kw-stx (stx-car formals)] [kw (syntax-e kw-stx)] [rest (stx-cdr formals)]) (cond [(hash-ref kw-h kw #f) (wrong-syntax kw-stx "duplicate keyword")] [(stx-null? rest) (wrong-syntax kw-stx "missing formal parameter after keyword")] [else (let-values ([(formal opt?) (parse-formal (stx-car rest))]) (add-id! formal) (hash-set! kw-h kw (if opt? 'optional 'mandatory))) (loop (stx-cdr rest))]))] [(stx-pair? formals) (let-values ([(formal opt?) (parse-formal (stx-car formals))]) (when (and (positive? opts) (not opt?)) (wrong-syntax (stx-car formals) "mandatory argument may not follow optional argument")) (add-id! formal) (set! pos (add1 pos)) (when opt? (set! opts (add1 opts))) (loop (stx-cdr formals)))] [(identifier? formals) (add-id! formals) (finish #t)] [(stx-null? formals) (finish #f)] [else (wrong-syntax formals "bad argument sequence")])) (define (finish has-rest?) (arity (- pos opts) (if has-rest? +inf.0 pos) (sort (for/list ([(k v) (in-hash kw-h)] #:when (eq? v 'mandatory)) k) keyword (values id bool) (define (parse-formal formal) (syntax-case formal () [param (identifier? #'param) (values #'param #f)] [(param default) (identifier? #'param) (values #'param #t)] [_ (wrong-syntax formal "expected formal parameter with optional default")])) ;; Directive tables ;; common-parse-directive-table (define common-parse-directive-table (list (list '#:disable-colon-notation) (list '#:literals check-literals-list) (list '#:datum-literals check-datum-literals-list) (list '#:literal-sets check-literal-sets-list) (list '#:conventions check-conventions-list) (list '#:local-conventions check-conventions-rules))) ;; parse-directive-table (define parse-directive-table (list* (list '#:context check-expression) common-parse-directive-table)) ;; rhs-directive-table (define rhs-directive-table (list* (list '#:description check-expression) (list '#:transparent) (list '#:opaque) (list '#:attributes check-attr-arity-list) (list '#:auto-nested-attributes) (list '#:commit) (list '#:no-delimit-cut) common-parse-directive-table)) ;; pattern-directive-table (define pattern-directive-table (list (list '#:declare check-identifier check-expression) (list '#:role check-expression) ;; attached to preceding #:declare (list '#:fail-when check-expression check-expression) (list '#:fail-unless check-expression check-expression) (list '#:when check-expression) (list '#:with check-expression check-expression) (list '#:attr check-attr-arity check-expression) (list '#:and check-expression) (list '#:post check-expression) (list '#:do check-stmt-list))) ;; fail-directive-table (define fail-directive-table (list (list '#:when check-expression) (list '#:unless check-expression))) ;; describe-option-table (define describe-option-table (list (list '#:opaque) (list '#:role check-expression))) ;; eh-optional-directive-table (define eh-optional-directive-table (list (list '#:too-many check-expression) (list '#:name check-expression) (list '#:defaults check-bind-clause-list))) ;; h-optional-directive-table (define h-optional-directive-table (list (list '#:defaults check-bind-clause-list))) ;; phase-directive-table (define phase-directive-table (list (list '#:phase check-expression))) ;; litset-directive-table (define litset-directive-table (cons (list '#:at (lambda (stx ctx) stx)) phase-directive-table)) ;; var-pattern-directive-table (define var-pattern-directive-table (list (list '#:attr-name-separator check-stx-string) (list '#:role check-expression)))