commit 8d4f899aa3e84d53239177e2335f665833c67dc8 Author: Georges Dupéron <georges.duperon@gmail.com> Date: Sun, 22 Jan 2017 16:20:54 +0100 Imported files from https://github.com/racket/racket/commit/28f1df4cffcc21c0892454406645ab05d93b9e79 Diffstat:
| A | LICENSE | | | 14 | ++++++++++++++ |
| A | parse.rkt | | | 30 | ++++++++++++++++++++++++++++++ |
| A | parse/debug.rkt | | | 127 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/define.rkt | | | 20 | ++++++++++++++++++++ |
| A | parse/experimental/contract.rkt | | | 40 | ++++++++++++++++++++++++++++++++++++++++ |
| A | parse/experimental/dset.rkt | | | 54 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/experimental/eh.rkt | | | 5 | +++++ |
| A | parse/experimental/private/substitute.rkt | | | 477 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/experimental/provide.rkt | | | 156 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/experimental/reflect.rkt | | | 149 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/experimental/specialize.rkt | | | 40 | ++++++++++++++++++++++++++++++++++++++++ |
| A | parse/experimental/splicing.rkt | | | 95 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/experimental/template.rkt | | | 662 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/lib/function-header.rkt | | | 112 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/pre.rkt | | | 10 | ++++++++++ |
| A | parse/private/3d-stx.rkt | | | 250 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/keywords.rkt | | | 40 | ++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/kws.rkt | | | 175 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/lib.rkt | | | 75 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/litconv.rkt | | | 284 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/make.rkt | | | 43 | +++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/minimatch.rkt | | | 105 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/opt.rkt | | | 430 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/parse-aux.rkt | | | 21 | +++++++++++++++++++++ |
| A | parse/private/parse.rkt | | | 1193 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/rep-attrs.rkt | | | 194 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/rep-data.rkt | | | 303 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/rep-patterns.rkt | | | 616 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/rep.rkt | | | 1646 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/residual-ct.rkt | | | 97 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/residual.rkt | | | 302 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/runtime-progress.rkt | | | 257 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/runtime-reflect.rkt | | | 81 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/runtime-report.rkt | | | 784 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/runtime.rkt | | | 220 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/sc.rkt | | | 75 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/private/txlift.rkt | | | 45 | +++++++++++++++++++++++++++++++++++++++++++++ |
| A | parse/todo.txt | | | 48 | ++++++++++++++++++++++++++++++++++++++++++++++++ |
38 files changed, 9275 insertions(+), 0 deletions(-)
diff --git a/LICENSE b/LICENSE @@ -0,0 +1,14 @@ +License +------- + +Racket +Copyright (c) 2010-2017 PLT Design Inc. + +Racket is distributed under the GNU Lesser General Public License +(LGPL). This implies that you may link Racket into proprietary +applications, provided you follow the rules stated in the LGPL. You can +also modify Racket; if you distribute a modified version, you must +distribute it under the terms of the LGPL, which in particular states +that you must release the source code for the modified software. + +See racket/src/COPYING_LESSER.txt for more information. diff --git a/parse.rkt b/parse.rkt @@ -0,0 +1,30 @@ +#lang racket/base +(require (for-syntax racket/base) + racket/contract/base + "parse/pre.rkt" + "parse/experimental/provide.rkt" + "parse/experimental/contract.rkt") +(provide (except-out (all-from-out "parse/pre.rkt") + static) + expr/c) +(provide-syntax-class/contract + [static (syntax-class/c [(-> any/c any/c) (or/c string? symbol? #f)])]) + +(begin-for-syntax + (require racket/contract/base + syntax/parse/private/residual-ct) + (provide pattern-expander? + (contract-out + [pattern-expander + (-> (-> syntax? syntax?) pattern-expander?)] + [prop:pattern-expander + (struct-type-property/c (-> pattern-expander? (-> syntax? syntax?)))] + [syntax-local-syntax-parse-pattern-introduce + (-> syntax? syntax?)])) + + (define pattern-expander + (let () + (struct pattern-expander (proc) #:transparent + #:omit-define-syntaxes + #:property prop:pattern-expander (λ (this) (pattern-expander-proc this))) + pattern-expander))) diff --git a/parse/debug.rkt b/parse/debug.rkt @@ -0,0 +1,127 @@ +#lang racket/base +(require (for-syntax racket/base + syntax/stx + racket/syntax + "private/rep-data.rkt" + "private/rep.rkt" + "private/kws.rkt") + racket/list + racket/pretty + "../parse.rkt" + (except-in syntax/parse/private/residual + prop:pattern-expander syntax-local-syntax-parse-pattern-introduce) + "private/runtime.rkt" + "private/runtime-progress.rkt" + "private/runtime-report.rkt" + "private/kws.rkt") + +;; No lazy loading for this module's dependencies. + +(provide syntax-class-parse + syntax-class-attributes + syntax-class-arity + syntax-class-keywords + + debug-rhs + debug-pattern + debug-parse + debug-syntax-parse!) + +(define-syntax (syntax-class-parse stx) + (syntax-case stx () + [(_ s x arg ...) + (parameterize ((current-syntax-context stx)) + (with-disappeared-uses + (let* ([argu (parse-argu (syntax->list #'(arg ...)) #:context stx)] + [stxclass + (get-stxclass/check-arity #'s stx + (length (arguments-pargs argu)) + (arguments-kws argu))] + [attrs (stxclass-attrs stxclass)]) + (with-syntax ([parser (stxclass-parser stxclass)] + [argu argu] + [(name ...) (map attr-name attrs)] + [(depth ...) (map attr-depth attrs)]) + #'(let ([fh (lambda (fs) fs)]) + (app-argu parser x x (ps-empty x x) #f fh fh #f + (lambda (fh . attr-values) + (map vector '(name ...) '(depth ...) attr-values)) + argu))))))])) + +(define-syntaxes (syntax-class-attributes + syntax-class-arity + syntax-class-keywords) + (let () + (define ((mk handler) stx) + (syntax-case stx () + [(_ s) + (parameterize ((current-syntax-context stx)) + (with-disappeared-uses + (handler (get-stxclass #'s))))])) + (values (mk (lambda (s) + (let ([attrs (stxclass-attrs s)]) + (with-syntax ([(a ...) (map attr-name attrs)] + [(d ...) (map attr-depth attrs)]) + #'(quote ((a d) ...)))))) + (mk (lambda (s) + (let ([a (stxclass-arity s)]) + #`(to-procedure-arity '#,(arity-minpos a) '#,(arity-maxpos a))))) + (mk (lambda (s) + (let ([a (stxclass-arity s)]) + #`(values '#,(arity-minkws a) '#,(arity-maxkws a)))))))) + +(define-syntax (debug-rhs stx) + (syntax-case stx () + [(debug-rhs rhs) + (let ([rhs (parse-rhs #'rhs #f #f #:context stx)]) + #`(quote #,rhs))])) + +(define-syntax (debug-pattern stx) + (syntax-case stx () + [(debug-pattern p . rest) + (let-values ([(rest pattern defs) + (parse-pattern+sides #'p #'rest + #:splicing? #f + #:decls (new-declenv null) + #:context stx)]) + (unless (stx-null? rest) + (raise-syntax-error #f "unexpected terms" stx rest)) + #`(quote ((definitions . #,defs) + (pattern #,pattern))))])) + +(define-syntax-rule (debug-parse x p ...) + (let/ec escape + (parameterize ((current-failure-handler + (lambda (_ fs) + (define-values (raw-fs-sexpr maximal-fs-sexpr) (fs->sexprs fs)) + (escape + `(parse-failure + #:raw-failures + ,raw-fs-sexpr + #:maximal-failures + ,maximal-fs-sexpr))))) + (syntax-parse x [p 'success] ...)))) + +(define (fs->sexprs fs) + (let* ([raw-fs (map invert-failure (reverse (flatten fs)))] + [selected-groups (maximal-failures raw-fs)]) + (values (failureset->sexpr raw-fs) + (let ([selected (map (lambda (fs) + (cons 'progress-class + (map failure->sexpr fs))) + selected-groups)]) + (if (= (length selected) 1) + (car selected) + (cons 'union selected)))))) + +(define (debug-syntax-parse!) + (define old-failure-handler (current-failure-handler)) + (current-failure-handler + (lambda (ctx fs) + (define-values (raw-fs-sexpr maximal-fs-sexpr) (fs->sexprs fs)) + (eprintf "*** syntax-parse debug info ***\n") + (eprintf "Raw failures:\n") + (pretty-write raw-fs-sexpr (current-error-port)) + (eprintf "Maximal failures:\n") + (pretty-write maximal-fs-sexpr (current-error-port)) + (old-failure-handler ctx fs)))) diff --git a/parse/define.rkt b/parse/define.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require (for-syntax racket/base + syntax/parse + "private/sc.rkt")) +(provide define-simple-macro + define-syntax-parser + (for-syntax (all-from-out syntax/parse))) + +(define-syntax (define-simple-macro stx) + (syntax-parse stx + [(define-simple-macro (~and (macro:id . _) pattern) . body) + #`(define-syntax macro + (syntax-parser/template + #,((make-syntax-introducer) stx) + [pattern . body]))])) + +(define-simple-macro (define-syntax-parser macro:id option-or-clause ...) + (define-syntax macro + (syntax-parser option-or-clause ...))) + diff --git a/parse/experimental/contract.rkt b/parse/experimental/contract.rkt @@ -0,0 +1,40 @@ +#lang racket/base +(require syntax/parse/pre + "provide.rkt" + syntax/contract + (only-in syntax/parse/private/residual ;; keep abs. path + this-context-syntax + this-role) + racket/contract/base) + +(define not-given (gensym)) + +(define-syntax-class (expr/c ctc-stx + #:positive [pos-blame 'use-site] + #:negative [neg-blame 'from-macro] + #:macro [macro-name #f] + #:name [expr-name not-given] + #:context [ctx #f]) + #:attributes (c) + #:commit + (pattern y:expr + #:with + c (wrap-expr/c ctc-stx + #'y + #:positive pos-blame + #:negative neg-blame + #:name (if (eq? expr-name not-given) + this-role + expr-name) + #:macro macro-name + #:context (or ctx (this-context-syntax))))) + +(provide-syntax-class/contract + [expr/c (syntax-class/c (syntax?) + (#:positive (or/c syntax? string? module-path-index? + 'from-macro 'use-site 'unknown) + #:negative (or/c syntax? string? module-path-index? + 'from-macro 'use-site 'unknown) + #:name (or/c identifier? string? symbol? #f) + #:macro (or/c identifier? string? symbol? #f) + #:context (or/c syntax? #f)))]) diff --git a/parse/experimental/dset.rkt b/parse/experimental/dset.rkt @@ -0,0 +1,54 @@ +#lang racket/base + +;; A dset is an `equal?`-based set, but it preserves order based on +;; the history of additions, so that if items are added in a +;; deterministic order, they come back out in a deterministic order. + +(provide dset + dset-empty? + dset->list + dset-add + dset-union + dset-subtract + dset-filter) + +(define dset + (case-lambda + [() (hash)] + [(e) (hash e 0)])) + +(define (dset-empty? ds) + (zero? (hash-count ds))) + +(define (dset->list ds) + (map cdr + (sort (for/list ([(k v) (in-hash ds)]) + (cons v k)) + < + #:key car))) + +(define (dset-add ds e) + (if (hash-ref ds e #f) + ds + (hash-set ds e (hash-count ds)))) + +(define (dset-union ds1 ds2) + (cond + [((hash-count ds1) . > . (hash-count ds2)) + (dset-union ds2 ds1)] + [else + (for/fold ([ds2 ds2]) ([e (dset->list ds1)]) + (dset-add ds2 e))])) + +(define (dset-subtract ds1 ds2) + ;; ! takes O(size(ds2)) time ! + (for/fold ([r (dset)]) ([e (in-list (dset->list ds1))]) + (if (hash-ref ds2 e #f) + r + (dset-add r e)))) + +(define (dset-filter ds pred) + (for/fold ([r (dset)]) ([e (in-list (dset->list ds))]) + (if (pred e) + (dset-add r e) + r))) diff --git a/parse/experimental/eh.rkt b/parse/experimental/eh.rkt @@ -0,0 +1,5 @@ +#lang racket/base +(require "../private/sc.rkt" + "../private/keywords.rkt") +(provide ~eh-var + define-eh-alternative-set) diff --git a/parse/experimental/private/substitute.rkt b/parse/experimental/private/substitute.rkt @@ -0,0 +1,477 @@ +#lang racket/base +(require syntax/parse/private/minimatch + racket/private/promise + racket/private/stx) ;; syntax/stx +(provide translate) + +#| +;; Doesn't seem to make much difference. +(require (rename-in racket/unsafe/ops + [unsafe-vector-ref vector-ref] + [unsafe-vector-set! vector-set!] + [unsafe-car car] + [unsafe-cdr cdr])) +|# + +;; ============================================================ + +#| +A Guide (G) is one of: + - '_ + - VarRef ;; no syntax check + - (vector 'check VarRef) ;; check value is syntax + - (cons G G) + - (vector 'vector G) + - (vector 'struct G) + - (vector 'box G) + - (vector 'dots HG (listof (vector-of VarRef)) nat (listof nat) G) + - (vector 'app HG G) + - (vector 'escaped G) + - (vector 'orelse G G) + - (vector 'metafun integer G) + - (vector 'copy-props G (listof symbol)) + - (vector 'set-props G (listof (cons symbol any))) + - (vector 'unsyntax VarRef) + - (vector 'relocate G) + +A HeadGuide (HG) is one of: + - G + - (vector 'app-opt H) + - (vector 'orelse-h H H) + - (vector 'splice G) + - (vector 'unsyntax-splicing VarRef) + +An VarRef is one of + - positive-exact-integer ;; represents depth=0 pvar ref or metafun ref + - negative-exact-integer ;; represents depth>0 pvar ref (within ellipsis) +|# + +(define (head-guide? x) + (match x + [(vector 'app-opt g) #t] + [(vector 'splice g) #t] + [(vector 'orelse-h g1 g2) #t] + [(vector 'unsyntax-splicing var) #t] + [_ #f])) + +;; ============================================================ + +;; Used to indicate absent pvar in template; ?? catches +;; Note: not an exn, don't need continuation marks +(struct absent-pvar (ctx v wanted-list?)) + +;; ============================================================ + +;; A translated-template is (vector loop-env -> syntax) +;; A loop-env is either a vector of values or a single value, +;; depending on lenv-mode of enclosing ellipsis ('dots) form. + +(define (translate stx g env-length) + (let ([f (translate-g stx stx g env-length 0)]) + (lambda (env lenv) + (unless (>= (vector-length env) env-length) + (error 'template "internal error: environment too short")) + (with-handlers ([absent-pvar? + (lambda (ap) + (err/not-syntax (absent-pvar-ctx ap) (absent-pvar-v ap)))]) + (f env lenv))))) + +;; lenv-mode is one of +;; - 'one ;; lenv is single value; address as -1 +;; - nat ;; lenv is vector; address as (- -1 index); 0 means no loop env + +(define (translate-g stx0 stx g env-length lenv-mode) + (define (loop stx g) (translate-g stx0 stx g env-length lenv-mode)) + (define (loop-h stx hg) (translate-hg stx0 stx hg env-length lenv-mode)) + (define (get index env lenv) (get-var index env lenv lenv-mode)) + + (match g + + ['_ (lambda (env lenv) stx)] + + [(? exact-integer? index) + (check-var index env-length lenv-mode) + (lambda (env lenv) (get index env lenv))] + + [(vector 'check index) + (check-var index env-length lenv-mode) + (lambda (env lenv) (check-stx stx (get index env lenv)))] + + [(cons g1 g2) + (let ([f1 (loop (stx-car stx) g1)] + [f2 (loop (stx-cdr stx) g2)]) + (cond [(syntax? stx) + (lambda (env lenv) + (restx stx (cons (f1 env lenv) (f2 env lenv))))] + [(eq? g1 '_) + (let ([c1 (stx-car stx)]) + (lambda (env lenv) + (cons c1 (f2 env lenv))))] + [(eq? g2 '_) + (let ([c2 (stx-cdr stx)]) + (lambda (env lenv) + (cons (f1 env lenv) c2)))] + [else + (lambda (env lenv) + (cons (f1 env lenv) (f2 env lenv)))]))] + + [(vector 'dots ghead henv nesting uptos gtail) + ;; At each nesting depth, indexes [0,upto) of lenv* vary; the rest are fixed. + ;; An alternative would be to have a list of henvs, but that would inhibit + ;; the nice simple vector reuse via vector-car/cdr!. + (let* ([lenv*-len (vector-length henv)] + [ghead-is-hg? (head-guide? ghead)] + [ftail (loop (stx-drop (add1 nesting) stx) gtail)]) + (for ([var (in-vector henv)]) + (check-var var env-length lenv-mode)) + (unless (= nesting (length uptos)) + (error 'template "internal error: wrong number of uptos")) + (let ([last-upto + (for/fold ([last 1]) ([upto (in-list uptos)]) + (unless (<= upto lenv*-len) + (error 'template "internal error: upto is too big")) + (unless (>= upto last) + (error 'template "internal error: uptos decreased: ~e" uptos)) + upto)]) + (unless (= lenv*-len last-upto) + (error 'template "internal error: last upto was not full env"))) + (cond [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?) + (equal? ghead '-1)) + ;; Fast path for (pvar ... . T) template + ;; - no list? or syntax? checks needed (because ghead is just raw varref, + ;; no 'check' wrapper) + ;; - avoid trivial map, just append + (let ([var-index (vector-ref henv 0)]) + (lambda (env lenv) + (let ([lenv* (get var-index env lenv)]) + (restx stx (append lenv* (ftail env lenv))))))] + [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?)) + ;; Fast path for (T ... . T) template + ;; - specialize lenv to avoid vector allocation/mutation + ;; - body is deforested (append (map _ _) _) preserving eval order + ;; - could try to eliminate 'check-list', but probably not worth the bother + (let* ([fhead (translate-g stx0 (stx-car stx) ghead env-length 'one)] + [var-index (vector-ref henv 0)]) + (lambda (env lenv) + (restx stx + (let ([lenv* (check-list/depth stx (get var-index env lenv) 1)]) + (let dotsloop ([lenv* lenv*]) + (if (null? lenv*) + (ftail env lenv) + (cons (fhead env (car lenv*)) + (dotsloop (cdr lenv*)))))))))] + [else + ;; Slow/general path for (H ...^n . T) + (let ([fhead (if ghead-is-hg? + (translate-hg stx0 (stx-car stx) ghead env-length lenv*-len) + (translate-g stx0 (stx-car stx) ghead env-length lenv*-len))]) + (lambda (env lenv) + #| + The template is "driven" by pattern variables bound to (listof^n syntax). + For example, in (H ... ... . T), the pvars of H have (listof (listof syntax)), + and we need a doubly-nested loop, like + (for/list ([stxlist^1 (in-list stxlist^2)]) + (for/list ([stx (in-list stxlist^1)]) + ___ fhead ___)) + Since we can have arbitrary numbers of ellipses, we have 'nestloop' recur + over ellipsis levels and 'dotsloop' recur over the contents of the pattern + variables' (listof^n syntax) values. + + Also, we reuse lenv vectors to reduce allocation. There is one aux lenv + vector per nesting level, preallocated in aux-lenvs. For continuation-safety + we must install a continuation barrier around metafunction applications. + |# + (define (nestloop lenv* nesting uptos aux-lenvs) + (cond [(zero? nesting) + (fhead env lenv*)] + [else + (let ([iters (check-lenv/get-iterations stx lenv*)]) + (let ([lenv** (car aux-lenvs)] + [aux-lenvs** (cdr aux-lenvs)] + [upto** (car uptos)] + [uptos** (cdr uptos)]) + (let dotsloop ([iters iters]) + (if (zero? iters) + null + (begin (vector-car/cdr! lenv** lenv* upto**) + (let ([row (nestloop lenv** (sub1 nesting) uptos** aux-lenvs**)]) + (cons row (dotsloop (sub1 iters)))))))))])) + (define initial-lenv* + (vector-map (lambda (index) (get index env lenv)) henv)) + (define aux-lenvs + (for/list ([depth (in-range nesting)]) (make-vector lenv*-len))) + + ;; Check initial-lenv* contains lists of right depths. + ;; At each nesting depth, indexes [0,upto) of lenv* vary; + ;; uptos is monotonic nondecreasing (every variable varies in inner + ;; loop---this is always counterintuitive to me). + (let checkloop ([depth nesting] [uptos uptos] [start 0]) + (when (pair? uptos) + (for ([v (in-vector initial-lenv* start (car uptos))]) + (check-list/depth stx v depth)) + (checkloop (sub1 depth) (cdr uptos) (car uptos)))) + + (define head-results + ;; if ghead-is-hg?, is (listof^(nesting+1) stx) -- extra listof for loop-h + ;; otherwise, is (listof^nesting stx) + (nestloop initial-lenv* nesting uptos aux-lenvs)) + (define tail-result (ftail env lenv)) + (restx stx + (nested-append head-results + (if ghead-is-hg? nesting (sub1 nesting)) + tail-result))))]))] + + [(vector 'app ghead gtail) + (let ([fhead (loop-h (stx-car stx) ghead)] + [ftail (loop (stx-cdr stx) gtail)]) + (lambda (env lenv) + (restx stx (append (fhead env lenv) (ftail env lenv)))))] + + [(vector 'escaped g1) + (loop (stx-cadr stx) g1)] + + [(vector 'orelse g1 g2) + (let ([f1 (loop (stx-cadr stx) g1)] + [f2 (loop (stx-caddr stx) g2)]) + (lambda (env lenv) + (with-handlers ([absent-pvar? + (lambda (_e) + (f2 env lenv))]) + (f1 env lenv))))] + + [(vector 'metafun index g1) + (let ([f1 (loop (stx-cdr stx) g1)]) + (check-var index env-length lenv-mode) + (lambda (env lenv) + (let ([v (restx stx (cons (stx-car stx) (f1 env lenv)))] + [mark (make-syntax-introducer)] + [old-mark (current-template-metafunction-introducer)] + [mf (get index env lenv)]) + (parameterize ((current-template-metafunction-introducer mark)) + (let ([r (call-with-continuation-barrier (lambda () (mf (mark (old-mark v)))))]) + (unless (syntax? r) + (raise-syntax-error #f "result of template metafunction was not syntax" stx)) + (restx stx (old-mark (mark r))))))))] + + [(vector 'vector g1) + (let ([f1 (loop (vector->list (syntax-e stx)) g1)]) + (lambda (env lenv) + (restx stx (list->vector (f1 env lenv)))))] + + [(vector 'struct g1) + (let ([f1 (loop (cdr (vector->list (struct->vector (syntax-e stx)))) g1)] + [key (prefab-struct-key (syntax-e stx))]) + (lambda (env lenv) + (restx stx (apply make-prefab-struct key (f1 env lenv)))))] + + [(vector 'box g1) + (let ([f1 (loop (unbox (syntax-e stx)) g1)]) + (lambda (env lenv) + (restx stx (box (f1 env lenv)))))] + + [(vector 'copy-props g1 keys) + (let ([f1 (loop stx g1)]) + (lambda (env lenv) + (for/fold ([v (f1 env lenv)]) ([key (in-list keys)]) + (let ([pvalue (syntax-property stx key)]) + (if pvalue + (syntax-property v key pvalue) + v)))))] + + [(vector 'set-props g1 props-alist) + (let ([f1 (loop stx g1)]) + (lambda (env lenv) + (for/fold ([v (f1 env lenv)]) ([entry (in-list props-alist)]) + (syntax-property v (car entry) (cdr entry)))))] + + [(vector 'unsyntax var) + (let ([f1 (loop stx var)]) + (lambda (env lenv) + (restx stx (f1 env lenv))))] + + [(vector 'relocate g1 var) + (let ([f1 (loop stx g1)]) + (lambda (env lenv) + (let ([result (f1 env lenv)] + [loc (get var env lenv)]) + (if (or (syntax-source loc) + (syntax-position loc)) + (datum->syntax result (syntax-e result) loc result) + result))))])) + +(define (translate-hg stx0 stx hg env-length lenv-mode) + (define (loop stx g) (translate-g stx0 stx g env-length lenv-mode)) + (define (loop-h stx hg) (translate-hg stx0 stx hg env-length lenv-mode)) + (define (get index env lenv) (get-var index env lenv lenv-mode)) + + (match hg + + [(vector 'app-opt hg1) + (let ([f1 (loop-h (stx-cadr stx) hg1)]) + (lambda (env lenv) + (with-handlers ([absent-pvar? (lambda (_e) null)]) + (f1 env lenv))))] + + [(vector 'orelse-h hg1 hg2) + (let ([f1 (loop-h (stx-cadr stx) hg1)] + [f2 (loop-h (stx-caddr stx) hg2)]) + (lambda (env lenv) + (with-handlers ([absent-pvar? + (lambda (_e) + (f2 env lenv))]) + (f1 env lenv))))] + + [(vector 'splice g1) + (let ([f1 (loop (stx-cdr stx) g1)]) + (lambda (env lenv) + (let* ([v (f1 env lenv)] + [v* (stx->list v)]) + (unless (list? v*) + (raise-syntax-error 'template + "splicing template did not produce a syntax list" + stx)) + v*)))] + + [(vector 'unsyntax-splicing index) + (check-var index env-length lenv-mode) + (lambda (env lenv) + (let* ([v (get index env lenv)] + [v* (stx->list v)]) + (unless (list? v*) + (raise-syntax-error 'template + "unsyntax-splicing expression did not produce a syntax list" + stx)) + v*))] + + [_ + (let ([f (loop stx hg)]) + (lambda (env lenv) + (list (f env lenv))))])) + +(define (get-var index env lenv lenv-mode) + (cond [(positive? index) + (vector-ref env (sub1 index))] + [(negative? index) + (case lenv-mode + ((one) lenv) + (else (vector-ref lenv (- -1 index))))])) + +(define (check-var index env-length lenv-mode) + (cond [(positive? index) + (unless (< (sub1 index) env-length) + (error/bad-index index))] + [(negative? index) + (unless (< (- -1 index) + (case lenv-mode + ((one) 1) + (else lenv-mode))) + (error/bad-index))])) + +(define (check-lenv/get-iterations stx lenv) + (unless (list? (vector-ref lenv 0)) + (error 'template "pattern variable used in ellipsis pattern is not defined")) + (let ([len0 (length (vector-ref lenv 0))]) + (for ([v (in-vector lenv)]) + (unless (list? v) + (error 'template "pattern variable used in ellipsis pattern is not defined")) + (unless (= len0 (length v)) + (raise-syntax-error 'template + "incompatible ellipsis match counts for template" + stx))) + len0)) + +;; ---- + +(define current-template-metafunction-introducer + (make-parameter + (lambda (stx) + (if (syntax-transforming?) + (syntax-local-introduce stx) + stx)))) + +;; ---- + +(define (stx-cadr x) (stx-car (stx-cdr x))) +(define (stx-cddr x) (stx-cdr (stx-cdr x))) +(define (stx-caddr x) (stx-car (stx-cdr (stx-cdr x)))) + +(define (stx-drop n x) + (cond [(zero? n) x] + [else (stx-drop (sub1 n) (stx-cdr x))])) + +(define (restx basis val) + (if (syntax? basis) + (datum->syntax basis val basis) + val)) + +;; nested-append : (listof^(nesting+1) A) nat (listof A) -> (listof A) +;; (Actually, in practice onto is stx, so this is an improper append.) +(define (nested-append lst nesting onto) + (cond [(zero? nesting) (append lst onto)] + [(null? lst) onto] + [else (nested-append (car lst) (sub1 nesting) + (nested-append (cdr lst) nesting onto))])) + +(define (check-stx ctx v) + (let loop ([v v]) + (cond [(syntax? v) + v] + [(promise? v) + (loop (force v))] + [(eq? v #f) + (raise (absent-pvar ctx v #f))] + [else (err/not-syntax ctx v)]))) + +(define (check-list/depth ctx v0 depth0) + (let depthloop ([v v0] [depth depth0]) + (cond [(zero? depth) v] + [(and (= depth 1) (list? v)) v] + [else + (let loop ([v v]) + (cond [(null? v) + null] + [(pair? v) + (let ([new-car (depthloop (car v) (sub1 depth))] + [new-cdr (loop (cdr v))]) + ;; Don't copy unless necessary + (if (and (eq? new-car (car v)) (eq? new-cdr (cdr v))) + v + (cons new-car new-cdr)))] + [(promise? v) + (loop (force v))] + [(eq? v #f) + (raise (absent-pvar ctx v0 #t))] + [else + (err/not-syntax ctx v0)]))]))) + +;; Note: slightly different from error msg in syntax/parse/private/residual: +;; here says "contains" instead of "is bound to", because might be within list +(define (err/not-syntax ctx v) + (raise-syntax-error #f + (format "attribute contains non-syntax value\n value: ~e" v) + ctx)) + +(define (error/bad-index index) + (error 'template "internal error: bad index: ~e" index)) + +(define (vector-car/cdr! dest-v src-v upto) + (let ([len (vector-length dest-v)]) + (let loop ([i 0]) + (when (< i upto) + (let ([p (vector-ref src-v i)]) + (vector-set! dest-v i (car p)) + (vector-set! src-v i (cdr p))) + (loop (add1 i)))) + (let loop ([j upto]) + (when (< j len) + (vector-set! dest-v j (vector-ref src-v j)) + (loop (add1 j)))))) + +(define (vector-map f src-v) + (let* ([len (vector-length src-v)] + [dest-v (make-vector len)]) + (let loop ([i 0]) + (when (< i len) + (vector-set! dest-v i (f (vector-ref src-v i))) + (loop (add1 i)))) + dest-v)) diff --git a/parse/experimental/provide.rkt b/parse/experimental/provide.rkt @@ -0,0 +1,156 @@ +#lang racket/base +(require racket/contract/base + racket/contract/combinator + syntax/location + (for-syntax racket/base + racket/syntax + "../private/minimatch.rkt" + syntax/parse/pre + syntax/parse/private/residual-ct ;; keep abs. path + "../private/kws.rkt" + syntax/contract)) +(provide provide-syntax-class/contract + syntax-class/c + splicing-syntax-class/c) + +;; FIXME: +;; - seems to get first-requiring-module wrong, not surprising +;; - extend to contracts on attributes? +;; - syntax-class/c etc just a made-up name, for now +;; (connect to dynamic syntax-classes, eventually) + +(define-syntaxes (syntax-class/c splicing-syntax-class/c) + (let ([nope + (lambda (stx) + (raise-syntax-error #f "not within `provide-syntax-class/contract form" stx))]) + (values nope nope))) + +(begin-for-syntax + (define-struct ctcrec (mpcs mkws mkwcs opcs okws okwcs) #:prefab + #:omit-define-syntaxes)) + +(begin-for-syntax + ;; do-one-contract : stx id stxclass ctcrec id -> stx + (define (do-one-contract stx scname stxclass rec pos-module-source) + ;; First, is the contract feasible? + (match (stxclass-arity stxclass) + [(arity minpos maxpos minkws maxkws) + (let* ([minpos* (length (ctcrec-mpcs rec))] + [maxpos* (+ minpos* (length (ctcrec-opcs rec)))] + [minkws* (sort (map syntax-e (ctcrec-mkws rec)) keyword<?)] + [maxkws* (sort (append minkws* (map syntax-e (ctcrec-okws rec))) keyword<?)]) + (define (err msg . args) + (apply wrong-syntax scname msg args)) + (unless (<= minpos minpos*) + (err (string-append "expected a syntax class with at most ~a " + "required positional arguments, got one with ~a") + minpos* minpos)) + (unless (<= maxpos* maxpos) + (err (string-append "expected a syntax class with at least ~a " + "total positional arguments (required and optional), " + "got one with ~a") + maxpos* maxpos)) + (unless (null? (diff/sorted/eq minkws minkws*)) + (err (string-append "expected a syntax class with at most the " + "required keyword arguments ~a, got one with ~a") + (join-sep (map kw->string minkws*) "," "and") + (join-sep (map kw->string minkws) "," "and"))) + (unless (null? (diff/sorted/eq maxkws* maxkws)) + (err (string-append "expected a syntax class with at least the optional " + "keyword arguments ~a, got one with ~a") + (join-sep (map kw->string maxkws*) "," "and") + (join-sep (map kw->string maxkws) "," "and"))) + (with-syntax ([scname scname] + [#s(stxclass name arity attrs parser splicing? opts inline) + stxclass] + [#s(ctcrec (mpc ...) (mkw ...) (mkwc ...) + (opc ...) (okw ...) (okwc ...)) + rec] + [arity* (arity minpos* maxpos* minkws* maxkws*)] + [(parser-contract contracted-parser contracted-scname) + (generate-temporaries #`(contract parser #,scname))]) + (with-syntax ([(mpc-id ...) (generate-temporaries #'(mpc ...))] + [(mkwc-id ...) (generate-temporaries #'(mkwc ...))] + [(opc-id ...) (generate-temporaries #'(opc ...))] + [(okwc-id ...) (generate-temporaries #'(okwc ...))]) + (with-syntax ([((mkw-c-part ...) ...) #'((mkw mkwc-id) ...)] + [((okw-c-part ...) ...) #'((okw okwc-id) ...)] + [((mkw-name-part ...) ...) #'((mkw ,(contract-name mkwc-id)) ...)] + [((okw-name-part ...) ...) #'((okw ,(contract-name okwc-id)) ...)]) + #`(begin + (define parser-contract + (let ([mpc-id mpc] ... + [mkwc-id mkwc] ... + [opc-id opc] ... + [okwc-id okwc] ...) + (rename-contract + (->* (any/c any/c any/c any/c any/c any/c any/c any/c + mpc-id ... mkw-c-part ... ...) + (okw-c-part ... ...) + any) + `(,(if 'splicing? 'splicing-syntax-class/c 'syntax-class/c) + [,(contract-name mpc-id) ... mkw-name-part ... ...] + [okw-name-part ... ...])))) + (define-module-boundary-contract contracted-parser + parser parser-contract #:pos-source #,pos-module-source) + (define-syntax contracted-scname + (make-stxclass + (quote-syntax name) + 'arity* + 'attrs + (quote-syntax contracted-parser) + 'splicing? + 'opts #f)) ;; must disable inlining + (provide (rename-out [contracted-scname scname])))))))]))) + +(define-syntax (provide-syntax-class/contract stx) + + (define-syntax-class stxclass-ctc + #:description "syntax-class/c or splicing-syntax-class/c form" + #:literals (syntax-class/c splicing-syntax-class/c) + #:attributes (rec) + #:commit + (pattern ((~or syntax-class/c splicing-syntax-class/c) + mand:ctclist + (~optional opt:ctclist)) + #:attr rec (make-ctcrec (attribute mand.pc.c) + (attribute mand.kw) + (attribute mand.kwc.c) + (or (attribute opt.pc.c) '()) + (or (attribute opt.kw) '()) + (or (attribute opt.kwc.c) '())))) + + (define-syntax-class ctclist + #:attributes ([pc.c 1] [kw 1] [kwc.c 1]) + #:commit + (pattern ((~or pc:expr (~seq kw:keyword kwc:expr)) ...) + #:with (pc.c ...) (for/list ([pc-expr (in-list (syntax->list #'(pc ...)))]) + (wrap-expr/c #'contract? pc-expr)) + #:with (kwc.c ...) (for/list ([kwc-expr (in-list (syntax->list #'(kwc ...)))]) + (wrap-expr/c #'contract? kwc-expr)))) + + (syntax-parse stx + [(_ [scname c:stxclass-ctc] ...) + #:declare scname (static stxclass? "syntax class") + (parameterize ((current-syntax-context stx)) + (with-disappeared-uses + #`(begin (define pos-module-source (quote-module-name)) + #,@(for/list ([scname (in-list (syntax->list #'(scname ...)))] + [stxclass (in-list (attribute scname.value))] + [rec (in-list (attribute c.rec))]) + (do-one-contract stx scname stxclass rec #'pos-module-source)))))])) + +;; Copied from unstable/contract, +;; which requires racket/contract, not racket/contract/base + +;; rename-contract : contract any/c -> contract +;; If the argument is a flat contract, so is the result. +(define (rename-contract ctc name) + (let ([ctc (coerce-contract 'rename-contract ctc)]) + (if (flat-contract? ctc) + (flat-named-contract name (flat-contract-predicate ctc)) + (let* ([ctc-fo (contract-first-order ctc)] + [late-neg-proj (contract-late-neg-projection ctc)]) + (make-contract #:name name + #:late-neg-projection late-neg-proj + #:first-order ctc-fo))))) diff --git a/parse/experimental/reflect.rkt b/parse/experimental/reflect.rkt @@ -0,0 +1,149 @@ +#lang racket/base +(require (for-syntax racket/base + racket/lazy-require + racket/syntax + 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)])) +;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require) +;; Without this, dependencies don't get collected. +(require racket/runtime-path (for-meta 2 '#%kernel)) +(define-runtime-module-path-index _unused_ 'syntax/parse/private/rep-data) + +(define-syntax (reify-syntax-class stx) + (if (eq? (syntax-local-context) 'expression) + (syntax-case stx () + [(rsc sc) + (with-disappeared-uses + (let* ([stxclass (get-stxclass #'sc)] + [splicing? (stxclass-splicing? stxclass)]) + (unless (scopts-delimit-cut? (stxclass-opts 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) + [(arity minpos maxpos _ _) + (to-procedure-arity minpos maxpos)])) + +(define (reified-syntax-class-keywords r) + (match (reified-arity r) + [(arity _ _ minkws maxkws) + (values minkws maxkws)])) + +(define (reified-syntax-class-attributes r) + (reified-signature r)) + +(define reified-syntax-class-curry + (make-keyword-procedure + (lambda (kws1 kwargs1 r . rest1) + (match r + [(reified name parser arity1 sig) + (let () + (check-curry arity1 (length rest1) kws1 + (lambda (msg) + (raise-mismatch-error 'reified-syntax-class-curry + (string-append msg ": ") r))) + (let* ([curried-arity + (match arity1 + [(arity minpos maxpos minkws maxkws) + (let* ([rest1-length (length rest1)] + [minpos* (- minpos rest1-length)] + [maxpos* (- maxpos rest1-length)] + [minkws* (sort (remq* kws1 minkws) keyword<?)] + [maxkws* (sort (remq* kws1 maxkws) keyword<?)]) + (arity minpos* maxpos* minkws* maxkws*))])] + [curried-parser + (make-keyword-procedure + (lambda (kws2 kwargs2 x cx pr es fh cp rl success . rest2) + (let-values ([(kws kwargs) (merge2 kws1 kws2 kwargs1 kwargs2)]) + (keyword-apply parser kws kwargs x cx pr es fh cp rl success + (append rest1 rest2)))))] + [ctor + (cond [(reified-syntax-class? r) + reified-syntax-class] + [(reified-splicing-syntax-class? r) + reified-splicing-syntax-class] + [else + (error 'curry-reified-syntax-class "INTERNAL ERROR: ~e" r)])]) + (ctor name curried-parser curried-arity sig)))])))) + +(define (merge2 kws1 kws2 kwargs1 kwargs2) + (cond [(null? kws1) + (values kws2 kwargs2)] + [(null? kws2) + (values kws1 kwargs1)] + [(keyword<? (car kws1) (car kws2)) + (let-values ([(m-kws m-kwargs) + (merge2 (cdr kws1) kws2 (cdr kwargs1) kwargs2)]) + (values (cons (car kws1) m-kws) (cons (car kwargs1) m-kwargs)))] + [else + (let-values ([(m-kws m-kwargs) + (merge2 kws1 (cdr kws2) kwargs1 (cdr kwargs2))]) + (values (cons (car kws2) m-kws) (cons (car kwargs2) m-kwargs)))])) + +;; ---- + +(provide reify-syntax-class + ~reflect + ~splicing-reflect) + +(provide/contract + [reified-syntax-class? + (-> any/c boolean?)] + [reified-splicing-syntax-class? + (-> any/c boolean?)] + [reified-syntax-class-attributes + (-> (or/c reified-syntax-class? reified-splicing-syntax-class?) + (listof (list/c symbol? exact-nonnegative-integer?)))] + [reified-syntax-class-arity + (-> (or/c reified-syntax-class? reified-splicing-syntax-class?) + procedure-arity?)] + [reified-syntax-class-keywords + (-> (or/c reified-syntax-class? reified-splicing-syntax-class?) + (values (listof keyword?) + (listof keyword?)))] + [reified-syntax-class-curry + (make-contract #:name '(->* ((or/c reified-syntax-class? reified-splicing-syntax-class/c)) + (#:<kw> any/c ...) + #:rest list? + (or/c reified-syntax-class? reified-splicing-syntax-class/c)) + #:late-neg-projection + (lambda (blame) + (let ([check-reified + ((contract-late-neg-projection + (or/c reified-syntax-class? reified-splicing-syntax-class?)) + (blame-swap blame))]) + (lambda (f neg-party) + (if (and (procedure? f) + (procedure-arity-includes? f 1)) + (make-keyword-procedure + (lambda (kws kwargs r . args) + (keyword-apply f kws kwargs (check-reified r neg-party) args))) + (raise-blame-error + blame #:missing-party neg-party + f + "expected a procedure of at least one argument, given ~e" + f))))) + #:first-order + (lambda (f) + (and (procedure? f) (procedure-arity-includes? f))))]) + diff --git a/parse/experimental/specialize.rkt b/parse/experimental/specialize.rkt @@ -0,0 +1,40 @@ +#lang racket/base +(require (for-syntax racket/base + racket/syntax + "../private/kws.rkt" + "../private/rep-data.rkt" + "../private/rep.rkt") + "../private/runtime.rkt") +(provide define-syntax-class/specialize) + +(define-syntax (define-syntax-class/specialize stx) + (parameterize ((current-syntax-context stx)) + (syntax-case stx () + [(dscs header sc-expr) + (with-disappeared-uses + (let-values ([(name formals arity) + (let ([p (check-stxclass-header #'header stx)]) + (values (car p) (cadr p) (caddr p)))] + [(target-scname argu) + (let ([p (check-stxclass-application #'sc-expr stx)]) + (values (car p) (cdr p)))]) + (let* ([pos-count (length (arguments-pargs argu))] + [kws (arguments-kws argu)] + [target (get-stxclass/check-arity target-scname target-scname pos-count kws)]) + (with-syntax ([name name] + [formals formals] + [parser (generate-temporary (format-symbol "parser-~a" #'name))] + [splicing? (stxclass-splicing? target)] + [arity arity] + [attrs (stxclass-attrs target)] + [opts (stxclass-opts target)] + [target-parser (stxclass-parser target)] + [argu argu]) + #`(begin (define-syntax name + (stxclass 'name 'arity 'attrs + (quote-syntax parser) + 'splicing? + 'opts #f)) + (define-values (parser) + (lambda (x cx pr es fh0 cp0 rl success . formals) + (app-argu target-parser x cx pr es fh0 cp0 rl success argu))))))))]))) diff --git a/parse/experimental/splicing.rkt b/parse/experimental/splicing.rkt @@ -0,0 +1,95 @@ +#lang racket/base +(require (for-syntax racket/base + syntax/parse + racket/lazy-require + "../private/kws.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)])) +;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require) +;; Without this, dependencies don't get collected. +(require racket/runtime-path (for-meta 2 '#%kernel)) +(define-runtime-module-path-index _unused_ 'syntax/parse/private/rep-attrs) + +(define-syntax (define-primitive-splicing-syntax-class stx) + + (define-syntax-class attr + #:commit + (pattern name:id + #:with depth #'0) + (pattern [name:id depth:nat])) + + (syntax-parse stx + [(dssp (name:id param:id ...) + (~or (~once (~seq #:attributes (a:attr ...)) + #:name "attributes declaration") + (~once (~seq #:description description) + #:name "description declaration")) ... + proc:expr) + #'(begin + (define (get-description param ...) + description) + (define parser + (let ([permute (mk-permute '(a.name ...))]) + (lambda (x cx pr es fh _cp rl success param ...) + (let ([stx (datum->syntax cx x cx)]) + (let ([result + (let/ec escape + (cons 'ok + (proc stx + (lambda ([msg #f] [stx #f]) + (escape (list 'error msg stx))))))]) + (case (car result) + ((ok) + (apply success + ((mk-check-result pr 'name (length '(a.name ...)) permute x cx fh) + (cdr result)))) + ((error) + (let ([es + (es-add-message (cadr result) + (es-add-thing pr (get-description param ...) #f rl es))]) + (fh (failure pr es)))))))))) + (define-syntax name + (stxclass 'name (arity (length '(param ...)) (length '(param ...)) '() '()) + (sort-sattrs '(#s(attr a.name a.depth #f) ...)) + (quote-syntax parser) + #t + (scopts (length '(a.name ...)) #t #t #f) + #f)))])) + +(define (mk-permute unsorted-attrs) + (let ([sorted-attrs + (sort unsorted-attrs string<? #:key symbol->string #:cache-keys? #t)]) + (if (equal? unsorted-attrs sorted-attrs) + values + (let* ([pos-table + (for/hasheq ([a (in-list unsorted-attrs)] [i (in-naturals)]) + (values a i))] + [indexes + (for/vector ([a (in-list sorted-attrs)]) + (hash-ref pos-table a))]) + (lambda (result) + (for/list ([index (in-vector indexes)]) + (list-ref result index))))))) + +(define (mk-check-result pr name attr-count permute x cx fh) + (lambda (result) + (unless (list? result) + (error name "parser returned non-list")) + (let ([rlength (length result)]) + (unless (= rlength (+ 1 attr-count)) + (error name "parser returned list of wrong length; expected length ~s, got ~e" + (+ 1 attr-count) + result)) + (let ([skip (car result)]) + ;; Compute rest-x & rest-cx from skip + (unless (exact-nonnegative-integer? skip) + (error name "expected exact nonnegative integer for first element of result list, got ~e" + skip)) + (let-values ([(rest-x rest-cx) (stx-list-drop/cx x cx skip)]) + (list* fh rest-x rest-cx (ps-add-cdr pr skip) + (permute (cdr result)))))))) diff --git a/parse/experimental/template.rkt b/parse/experimental/template.rkt @@ -0,0 +1,662 @@ +#lang racket/base +(require (for-syntax racket/base + "dset.rkt" + racket/syntax + syntax/parse/private/minimatch + racket/private/stx ;; syntax/stx + racket/private/sc + racket/struct) + syntax/parse/private/residual + "private/substitute.rkt") +(provide template + template/loc + quasitemplate + quasitemplate/loc + define-template-metafunction + ?? + ?@) + +#| +To do: +- improve error messages +|# + +#| +A Template (T) is one of: + - pvar + - const (including () and non-pvar identifiers) + - (metafunction . T) + - (H . T) + - (H ... . T), (H ... ... . T), etc + - (?? T T) + - #(T*) + - #s(prefab-struct-key T*) + * (unquote expr) + +A HeadTemplate (H) is one of: + - T + - (?? H) + - (?? H H) + - (?@ . T) + * (unquote-splicing expr) +|# + +(begin-for-syntax + (define (do-template ctx tstx quasi? loc-id) + (with-disappeared-uses + (parameterize ((current-syntax-context ctx) + (quasi (and quasi? (box null)))) + (let*-values ([(guide deps props-guide) (parse-template tstx loc-id)] + [(vars) + (for/list ([dep (in-vector deps)]) + (cond [(pvar? dep) (pvar-var dep)] + [(template-metafunction? dep) + (template-metafunction-var dep)] + [else + (error 'template + "internal error: bad environment entry: ~e" + dep)]))]) + (with-syntax ([t tstx]) + (syntax-arm + (cond [(equal? guide '1) + ;; was (template pvar), implies props-guide = '_ + (car vars)] + [(and (equal? guide '_) (equal? props-guide '_)) + #'(quote-syntax t)] + [else + (with-syntax ([guide guide] + [props-guide props-guide] + [vars-vector + (if (pair? vars) + #`(vector . #,vars) + #''#())] + [((un-var . un-form) ...) + (if quasi? (reverse (unbox (quasi))) null)]) + #'(let ([un-var (handle-unsyntax un-form)] ...) + (substitute (quote-syntax t) + 'props-guide + 'guide + vars-vector)))])))))))) + +(define-syntax (template stx) + (syntax-case stx () + [(template t) + (do-template stx #'t #f #f)] + [(template t #:properties (prop ...)) + (andmap identifier? (syntax->list #'(prop ...))) + (parameterize ((props-to-serialize (syntax->datum #'(prop ...))) + (props-to-transfer (syntax->datum #'(prop ...)))) + (do-template stx #'t #f #f))])) + +(define-syntax (quasitemplate stx) + (syntax-case stx () + [(quasitemplate t) + (do-template stx #'t #t #f)])) + +(define-syntaxes (template/loc quasitemplate/loc) + ;; FIXME: better to replace unsyntax form, shrink template syntax constant + (let ([make-tx + (lambda (quasi?) + (lambda (stx) + (syntax-case stx () + [(?/loc loc-expr t) + (syntax-arm + (with-syntax ([main-expr (do-template stx #'t quasi? #'loc-stx)]) + #'(let ([loc-stx (handle-loc '?/loc loc-expr)]) + main-expr)))])))]) + (values (make-tx #f) (make-tx #t)))) + +(define (handle-loc who x) + (if (syntax? x) + x + (raise-argument-error who "syntax?" x))) + +;; FIXME: what lexical context should result of expr get if not syntax? +(define-syntax handle-unsyntax + (syntax-rules (unsyntax unsyntax-splicing) + [(handle-syntax (unsyntax expr)) expr] + [(handle-syntax (unsyntax-splicing expr)) expr])) + +;; substitute-table : hash[stx => translated-template] +;; Cache for closure-compiled templates. Key is just syntax of +;; template, since eq? templates must have equal? guides. +(define substitute-table (make-weak-hasheq)) + +;; props-syntax-table : hash[stx => stx] +(define props-syntax-table (make-weak-hasheq)) + +(define (substitute stx props-guide g main-env) + (let* ([stx (if (eq? props-guide '_) + stx + (or (hash-ref props-syntax-table stx #f) + (let* ([pf (translate stx props-guide 0)] + [pstx (pf '#() #f)]) + (hash-set! props-syntax-table stx pstx) + pstx)))] + [f (or (hash-ref substitute-table stx #f) + (let ([f (translate stx g (vector-length main-env))]) + (hash-set! substitute-table stx f) + f))]) + (f main-env #f))) + +;; ---- + +(define-syntaxes (?? ?@) + (let ([tx (lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx))]) + (values tx tx))) + +;; ============================================================ + +#| +See private/substitute for definition of Guide (G) and HeadGuide (HG). + +A env-entry is one of + - (pvar syntax-mapping attribute-mapping/#f depth-delta) + - template-metafunction + +The depth-delta associated with a depth>0 pattern variable is the difference +between the pattern variable's depth and the depth at which it is used. (For +depth 0 pvars, it's #f.) For example, in + + (with-syntax ([x #'0] + [(y ...) #'(1 2)] + [((z ...) ...) #'((a b) (c d))]) + (template (((x y) ...) ...))) + +the depth-delta for x is #f, the depth-delta for y is 1, and the depth-delta for +z is 0. Coincidentally, the depth-delta is the same as the depth of the ellipsis +form at which the variable should be moved to the loop-env. That is, the +template above should be interpreted as roughly similar to + + (let ([x (pvar-value-of x)] + [y (pvar-value-of y)] + [z (pvar-value-of z)]) + (for ([Lz (in-list z)]) ;; depth 0 + (for ([Ly (in-list y)] ;; depth 1 + [Lz (in-list Lz)]) + (___ x Ly Lz ___)))) + +A Pre-Guide is like a Guide but with env-entry and (setof env-entry) +instead of integers and integer vectors. +|# + +(begin-for-syntax + (struct pvar (sm attr dd) #:prefab)) + +;; ============================================================ + +(define-syntax (define-template-metafunction stx) + (syntax-case stx () + [(dsm (id arg ...) . body) + #'(dsm id (lambda (arg ...) . body))] + [(dsm id expr) + (identifier? #'id) + (with-syntax ([(internal-id) (generate-temporaries #'(id))]) + #'(begin (define internal-id expr) + (define-syntax id + (template-metafunction (quote-syntax internal-id)))))])) + +(begin-for-syntax + (struct template-metafunction (var))) + +;; ============================================================ + +(begin-for-syntax + + ;; props-to-serialize determines what properties are saved even when + ;; code is compiled. (Unwritable values are dropped.) + ;; props-to-transfer determines what properties are transferred from + ;; template to stx constructed. + ;; If a property is in props-to-transfer but not props-to-serialize, + ;; compiling the module may have caused the property to disappear. + ;; If a property is in props-to-serialize but not props-to-transfer, + ;; it will show up only in constant subtrees. + ;; The behavior of 'syntax' is serialize '(), transfer '(paren-shape). + + ;; props-to-serialize : (parameterof (listof symbol)) + (define props-to-serialize (make-parameter '())) + + ;; props-to-transfer : (parameterof (listof symbol)) + (define props-to-transfer (make-parameter '(paren-shape))) + + ;; quasi : (parameterof (or/c #f (list^n (boxof QuasiPairs)))) + ;; each list wrapper represents nested quasi wrapping + ;; QuasiPairs = (listof (cons/c identifier syntax)) + (define quasi (make-parameter #f)) + + ;; parse-template : stx id/#f -> (values guide (vectorof env-entry) guide) + (define (parse-template t loc-id) + (let*-values ([(drivers pre-guide props-guide) (parse-t t 0 #f)] + [(drivers pre-guide) + (if loc-id + (let* ([loc-sm (make-syntax-mapping 0 loc-id)] + [loc-pvar (pvar loc-sm #f #f)]) + (values (dset-add drivers loc-pvar) + (relocate-guide pre-guide loc-pvar))) + (values drivers pre-guide))]) + (let* ([main-env (dset->env drivers (hash))] + [guide (guide-resolve-env pre-guide main-env)]) + (values guide + (index-hash->vector main-env) + props-guide)))) + + ;; dset->env : (dsetof env-entry) -> hash[env-entry => nat] + (define (dset->env drivers init-env) + (for/fold ([env init-env]) + ([pvar (in-list (dset->list drivers))] + [n (in-naturals (+ 1 (hash-count init-env)))]) + (hash-set env pvar n))) + + ;; guide-resolve-env : pre-guide hash[env-entry => nat] -> guide + (define (guide-resolve-env g0 main-env) + (define (loop g loop-env) + (define (get-index x) + (let ([loop-index (hash-ref loop-env x #f)]) + (if loop-index + (- loop-index) + (hash-ref main-env x)))) + (match g + ['_ '_] + [(cons g1 g2) + (cons (loop g1 loop-env) (loop g2 loop-env))] + [(? pvar? pvar) + (if (pvar-check? pvar) + (vector 'check (get-index pvar)) + (get-index pvar))] + [(vector 'dots head new-hdrivers/level nesting '#f tail) + (let-values ([(sub-loop-env r-uptos) + (for/fold ([env (hash)] [r-uptos null]) + ([new-hdrivers (in-list new-hdrivers/level)]) + (let ([new-env (dset->env new-hdrivers env)]) + (values new-env (cons (hash-count new-env) r-uptos))))]) + (let ([sub-loop-vector (index-hash->vector sub-loop-env get-index)]) + (vector 'dots + (loop head sub-loop-env) + sub-loop-vector + nesting + (reverse r-uptos) + (loop tail loop-env))))] + [(vector 'app head tail) + (vector 'app (loop head loop-env) (loop tail loop-env))] + [(vector 'escaped g1) + (vector 'escaped (loop g1 loop-env))] + [(vector 'orelse g1 g2) + (vector 'orelse (loop g1 loop-env) (loop g2 loop-env))] + [(vector 'orelse-h g1 g2) + (vector 'orelse-h (loop g1 loop-env) (loop g2 loop-env))] + [(vector 'metafun mf g1) + (vector 'metafun + (get-index mf) + (loop g1 loop-env))] + [(vector 'vector g1) + (vector 'vector (loop g1 loop-env))] + [(vector 'struct g1) + (vector 'struct (loop g1 loop-env))] + [(vector 'box g1) + (vector 'box (loop (unbox g) loop-env))] + [(vector 'copy-props g1 keys) + (vector 'copy-props (loop g1 loop-env) keys)] + [(vector 'set-props g1 props-alist) + (vector 'set-props (loop g1 loop-env) props-alist)] + [(vector 'app-opt g1) + (vector 'app-opt (loop g1 loop-env))] + [(vector 'splice g1) + (vector 'splice (loop g1 loop-env))] + [(vector 'unsyntax var) + (vector 'unsyntax (get-index var))] + [(vector 'unsyntax-splicing var) + (vector 'unsyntax-splicing (get-index var))] + [(vector 'relocate g1 var) + (vector 'relocate (loop g1 loop-env) (get-index var))] + [else (error 'template "internal error: bad pre-guide: ~e" g)])) + (loop g0 '#hash())) + + ;; ---------------------------------------- + + ;; relocate-gude : stx guide -> guide + (define (relocate-guide g0 loc-pvar) + (define (relocate g) + (vector 'relocate g loc-pvar)) + (define (error/no-relocate) + (wrong-syntax #f "cannot apply syntax location to template")) + (define (loop g) + (match g + ['_ + (relocate g)] + [(cons g1 g2) + (relocate g)] + [(? pvar? g) + g] + [(vector 'dots head new-hdrivers/level nesting '#f tail) + ;; Ideally, should error. For perfect backwards compatability, + ;; should relocate. But if there are zero iterations, that + ;; means we'd relocate tail (which might be bad). Making + ;; relocation depend on number of iterations would be + ;; complicated. So just ignore. + g] + [(vector 'escaped g1) + (vector 'escaped (loop g1))] + [(vector 'vector g1) + (relocate g)] + [(vector 'struct g1) + (relocate g)] + [(vector 'box g1) + (relocate g)] + [(vector 'copy-props g1 keys) + (vector 'copy-props (loop g1) keys)] + [(vector 'unsyntax var) + g] + ;; ---- + [(vector 'app ghead gtail) + (match ghead + [(vector 'unsyntax-splicing _) g] + [_ (error/no-relocate)])] + ;; ---- + [(vector 'orelse g1 g2) + (error/no-relocate)] + [(vector 'orelse-h g1 g2) + (error/no-relocate)] + [(vector 'metafun mf g1) + (error/no-relocate)] + [(vector 'app-opt g1) + (error/no-relocate)] + [(vector 'splice g1) + (error/no-relocate)] + [(vector 'unsyntax-splicing var) + g] + [else (error 'template "internal error: bad guide for relocation: ~e" g0)])) + (loop g0)) + + ;; ---------------------------------------- + + (define (wrap-props stx env-set pre-guide props-guide) + (let ([saved-prop-values + (if (syntax? stx) + (for/fold ([entries null]) ([prop (in-list (props-to-serialize))]) + (let ([v (syntax-property stx prop)]) + (if (and v (quotable? v)) + (cons (cons prop v) entries) + entries))) + null)] + [copy-props + (if (syntax? stx) + (for/list ([prop (in-list (props-to-transfer))] + #:when (syntax-property stx prop)) + prop) + null)]) + (values env-set + (cond [(eq? pre-guide '_) + ;; No need to copy props; already on constant + '_] + [(pair? copy-props) + (vector 'copy-props pre-guide copy-props)] + [else pre-guide]) + (if (pair? saved-prop-values) + (vector 'set-props props-guide saved-prop-values) + props-guide)))) + + (define (quotable? v) + (or (null? v) + (string? v) + (bytes? v) + (number? v) + (boolean? v) + (char? v) + (keyword? v) + (regexp? v) + (byte-regexp? v) + (and (box? v) (quotable? (unbox v))) + (and (symbol? v) (symbol-interned? v)) + (and (pair? v) (quotable? (car v)) (quotable? (cdr v))) + (and (vector? v) (andmap quotable? (vector->list v))) + (and (hash? v) (andmap quotable? (hash->list v))) + (and (prefab-struct-key v) (andmap quotable? (struct->list v))))) + + (define (cons-guide g1 g2) + (if (and (eq? g1 '_) (eq? g2 '_)) '_ (cons g1 g2))) + + (define (list-guide . gs) + (foldr cons-guide '_ gs)) + + ;; parse-t : stx nat boolean -> (values (dsetof env-entry) pre-guide props-guide) + (define (parse-t t depth esc?) + (syntax-case t (?? ?@ unsyntax quasitemplate) + [id + (identifier? #'id) + (cond [(or (and (not esc?) + (or (free-identifier=? #'id (quote-syntax ...)) + (free-identifier=? #'id (quote-syntax ??)) + (free-identifier=? #'id (quote-syntax ?@)))) + (and (quasi) + (or (free-identifier=? #'id (quote-syntax unsyntax)) + (free-identifier=? #'id (quote-syntax unsyntax-splicing))))) + (wrong-syntax #'id "illegal use")] + [else + (let ([pvar (lookup #'id depth)]) + (cond [(pvar? pvar) + (values (dset pvar) pvar '_)] + [(template-metafunction? pvar) + (wrong-syntax t "illegal use of syntax metafunction")] + [else + (wrap-props #'id (dset) '_ '_)]))])] + [(mf . template) + (and (not esc?) + (identifier? #'mf) + (template-metafunction? (lookup #'mf #f))) + (let-values ([(mf) (lookup #'mf #f)] + [(drivers guide props-guide) (parse-t #'template depth esc?)]) + (values (dset-add drivers mf) + (vector 'metafun mf guide) + (cons-guide '_ props-guide)))] + [(unsyntax t1) + (quasi) + (let ([qval (quasi)]) + (cond [(box? qval) + (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-expr))]) + (set-box! qval (cons (cons #'tmp t) (unbox qval))) + (let* ([fake-sm (make-syntax-mapping 0 #'tmp)] + [fake-pvar (pvar fake-sm #f #f)]) + (values (dset fake-pvar) (vector 'unsyntax fake-pvar) '_)))] + [else + (parameterize ((quasi (car qval))) + (let-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)]) + (wrap-props t + drivers + (list-guide '_ guide) + (list-guide '_ props-guide))))]))] + [(quasitemplate t1) + ;; quasitemplate escapes inner unsyntaxes + (quasi) + (parameterize ((quasi (list (quasi)))) + (let-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)]) + (wrap-props t + drivers + (list-guide '_ guide) + (list-guide '_ props-guide))))] + [(DOTS template) + (and (not esc?) + (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) + (let-values ([(drivers guide props-guide) (parse-t #'template depth #t)]) + (values drivers (vector 'escaped guide) + (list-guide '_ props-guide)))] + [(?? t1 t2) + (not esc?) + (let-values ([(drivers1 guide1 props-guide1) (parse-t #'t1 depth esc?)] + [(drivers2 guide2 props-guide2) (parse-t #'t2 depth esc?)]) + (values (dset-union drivers1 drivers2) + (vector 'orelse guide1 guide2) + (list-guide '_ props-guide1 props-guide2)))] + [(head DOTS . tail) + (and (not esc?) + (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) + (let-values ([(nesting tail) + (let loop ([nesting 1] [tail #'tail]) + (syntax-case tail () + [(DOTS . tail) + (and (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) + (loop (add1 nesting) #'tail)] + [else (values nesting tail)]))]) + (let-values ([(hdrivers _hsplice? hguide hprops-guide) + (parse-h #'head (+ depth nesting) esc?)] + [(tdrivers tguide tprops-guide) + (parse-t tail depth esc?)]) + (when (dset-empty? hdrivers) + (wrong-syntax #'head "no pattern variables before ellipsis in template")) + (when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth))) + ;; FIXME: improve error message? + (let ([bad-dots + ;; select the nestingth (last) ellipsis as the bad one + (stx-car (stx-drop nesting t))]) + (wrong-syntax bad-dots "too many ellipses in template"))) + (wrap-props t + (dset-union hdrivers tdrivers) + ;; pre-guide hdrivers is (listof (setof pvar)) + ;; set of pvars new to each level + (let* ([hdrivers/level + (for/list ([i (in-range nesting)]) + (dset-filter hdrivers (pvar/dd<=? (+ depth i))))] + [new-hdrivers/level + (let loop ([raw hdrivers/level] [last (dset)]) + (cond [(null? raw) null] + [else + (cons (dset-subtract (car raw) last) + (loop (cdr raw) (car raw)))]))]) + (vector 'dots hguide new-hdrivers/level nesting #f tguide)) + (cons-guide hprops-guide (cons-guide '_ tprops-guide)))))] + [(head . tail) + (let-values ([(hdrivers hsplice? hguide hprops-guide) + (parse-h #'head depth esc?)] + [(tdrivers tguide tprops-guide) + (parse-t #'tail depth esc?)]) + (wrap-props t + (dset-union hdrivers tdrivers) + (cond [(and (eq? hguide '_) (eq? tguide '_)) '_] + [hsplice? (vector 'app hguide tguide)] + [else (cons hguide tguide)]) + (cons-guide hprops-guide tprops-guide)))] + [vec + (vector? (syntax-e #'vec)) + (let-values ([(drivers guide props-guide) + (parse-t (vector->list (syntax-e #'vec)) depth esc?)]) + (wrap-props t drivers + (if (eq? guide '_) '_ (vector 'vector guide)) + (if (eq? props-guide '_) '_ (vector 'vector props-guide))))] + [pstruct + (prefab-struct-key (syntax-e #'pstruct)) + (let-values ([(drivers guide props-guide) + (parse-t (cdr (vector->list (struct->vector (syntax-e #'pstruct)))) depth esc?)]) + (wrap-props t drivers + (if (eq? guide '_) '_ (vector 'struct guide)) + (if (eq? props-guide '_) '_ (vector 'struct props-guide))))] + [#&template + (let-values ([(drivers guide props-guide) + (parse-t #'template depth esc?)]) + (wrap-props t drivers + (if (eq? guide '_) '_ (vector 'box guide)) + (if (eq? props-guide '_) '_ (vector 'box props-guide))))] + [const + (wrap-props t (dset) '_ '_)])) + + ;; parse-h : stx nat boolean -> (values (dsetof env-entry) boolean pre-head-guide props-guide) + (define (parse-h h depth esc?) + (syntax-case h (?? ?@ unsyntax-splicing) + [(?? t) + (not esc?) + (let-values ([(drivers splice? guide props-guide) + (parse-h #'t depth esc?)]) + (values drivers #t + (vector 'app-opt guide) + (list-guide '_ props-guide)))] + [(?? t1 t2) + (not esc?) + (let-values ([(drivers1 splice?1 guide1 props-guide1) (parse-h #'t1 depth esc?)] + [(drivers2 splice?2 guide2 props-guide2) (parse-h #'t2 depth esc?)]) + (values (dset-union drivers1 drivers2) + (or splice?1 splice?2) + (vector (if (or splice?1 splice?2) 'orelse-h 'orelse) + guide1 guide2) + (list-guide '_ props-guide1 props-guide2)))] + [(?@ . t) + (not esc?) + (let-values ([(drivers guide props-guide) (parse-t #'t depth esc?)]) + (values drivers #t (vector 'splice guide) (cons-guide '_ props-guide)))] + [(unsyntax-splicing t1) + (quasi) + (let ([qval (quasi)]) + (cond [(box? qval) + (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-splicing-expr))]) + (set-box! qval (cons (cons #'tmp h) (unbox qval))) + (let* ([fake-sm (make-syntax-mapping 0 #'tmp)] + [fake-pvar (pvar fake-sm #f #f)]) + (values (dset fake-pvar) #t (vector 'unsyntax-splicing fake-pvar) '_)))] + [else + (parameterize ((quasi (car qval))) + (let*-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)] + [(drivers guide props-guide) + (wrap-props h + drivers + (list-guide '_ guide) + (list-guide '_ props-guide))]) + (values drivers #f guide props-guide)))]))] + [t + (let-values ([(drivers guide props-guide) (parse-t #'t depth esc?)]) + (values drivers #f guide props-guide))])) + + (define (lookup id depth) + (let ([v (syntax-local-value/record id (lambda (v) (or (syntax-pattern-variable? v) + (template-metafunction? v))))]) + (cond [(syntax-pattern-variable? v) + (let* ([pvar-depth (syntax-mapping-depth v)] + [attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))] + [attr (and (attribute-mapping? attr) attr)]) + (cond [(not depth) ;; not looking for pvars, only for metafuns + #f] + [(zero? pvar-depth) + (pvar v attr #f)] + [(>= depth pvar-depth) + (pvar v attr (- depth pvar-depth))] + [else + (wrong-syntax id "missing ellipses with pattern variable in template")]))] + [(template-metafunction? v) + v] + [else + ;; id is a literal; check that for all x s.t. id = x.y, x is not an attribute + (for ([pfx (in-list (dotted-prefixes id))]) + (let ([pfx-v (syntax-local-value pfx (lambda () #f))]) + (when (and (syntax-pattern-variable? pfx-v) + (let ([valvar (syntax-mapping-valvar pfx-v)]) + (attribute-mapping? (syntax-local-value valvar (lambda () #f))))) + (wrong-syntax id "undefined nested attribute of attribute `~a'" (syntax-e pfx))))) + #f]))) + + (define (dotted-prefixes id) + (let* ([id-string (symbol->string (syntax-e id))] + [dot-locations (map car (regexp-match-positions* #rx"\\.[^.]" id-string))]) + (for/list ([loc (in-list dot-locations)]) + (datum->syntax id (string->symbol (substring id-string 0 loc)))))) + + (define (index-hash->vector hash [f values]) + (let ([vec (make-vector (hash-count hash))]) + (for ([(value index) (in-hash hash)]) + (vector-set! vec (sub1 index) (f value))) + vec)) + + (define ((pvar/dd<=? expected-dd) x) + (match x + [(pvar sm attr dd) (and dd (<= dd expected-dd))] + [_ #f])) + + (define (pvar-var x) + (match x + [(pvar sm '#f dd) (syntax-mapping-valvar sm)] + [(pvar sm attr dd) (attribute-mapping-var attr)])) + + (define (pvar-check? x) + (match x + [(pvar sm '#f dd) #f] + [(pvar sm attr dd) (not (attribute-mapping-syntax? attr))])) + + (define (stx-drop n x) + (cond [(zero? n) x] + [else (stx-drop (sub1 n) (stx-cdr x))])) + ) diff --git a/parse/lib/function-header.rkt b/parse/lib/function-header.rkt @@ -0,0 +1,112 @@ +#lang racket/base + +(require "../../parse.rkt" + "../experimental/template.rkt" + racket/dict) + +(provide function-header formal formals) + +(define-syntax-class function-header + (pattern ((~or header:function-header name:id) . args:formals) + #:attr params + (template ((?@ . (?? header.params ())) + . args.params)))) + +(define-syntax-class formals + #:attributes (params) + (pattern (arg:formal ...) + #:attr params #'(arg.name ...) + #:fail-when (check-duplicate-identifier (syntax->list #'params)) + "duplicate argument name" + #:fail-when (check-duplicate (attribute arg.kw) + #:same? (λ (x y) + (and x y (equal? (syntax-e x) + (syntax-e y))))) + "duplicate keyword for argument" + #:fail-when (invalid-option-placement + (attribute arg.name) (attribute arg.default)) + "default-value expression missing") + (pattern (arg:formal ... . rest:id) + #:attr params #'(arg.name ... rest) + #:fail-when (check-duplicate-identifier (syntax->list #'params)) + "duplicate argument name" + #:fail-when (check-duplicate (attribute arg.kw) + #:same? (λ (x y) + (and x y (equal? (syntax-e x) + (syntax-e y))))) + "duplicate keyword for argument" + #:fail-when (invalid-option-placement + (attribute arg.name) (attribute arg.default)) + "default-value expression missing")) + +(define-splicing-syntax-class formal + #:attributes (name kw default) + (pattern name:id + #:attr kw #f + #:attr default #f) + (pattern [name:id default] + #:attr kw #f) + (pattern (~seq kw:keyword name:id) + #:attr default #f) + (pattern (~seq kw:keyword [name:id default]))) + +;; invalid-option-placement : (Listof Id) (Listof Syntax/#f) -> Id/#f +;; Checks for mandatory argument after optional argument; if found, returns +;; identifier of mandatory argument. +(define (invalid-option-placement names defaults) + ;; find-mandatory : (Listof Id) (Listof Syntax/#f) -> Id/#f + ;; Finds first name w/o corresponding default. + (define (find-mandatory names defaults) + (for/first ([name (in-list names)] + [default (in-list defaults)] + #:when (not default)) + name)) + ;; Skip through mandatory args until first optional found, then search + ;; for another mandatory. + (let loop ([names names] [defaults defaults]) + (cond [(or (null? names) (null? defaults)) + #f] + [(eq? (car defaults) #f) ;; mandatory + (loop (cdr names) (cdr defaults))] + [else ;; found optional + (find-mandatory (cdr names) (cdr defaults))]))) + +;; Copied from unstable/list +;; check-duplicate : (listof X) +;; #:key (X -> K) +;; #:same? (or/c (K K -> bool) dict?) +;; -> X or #f +(define (check-duplicate items + #:key [key values] + #:same? [same? equal?]) + (cond [(procedure? same?) + (cond [(eq? same? equal?) + (check-duplicate/t items key (make-hash) #t)] + [(eq? same? eq?) + (check-duplicate/t items key (make-hasheq) #t)] + [(eq? same? eqv?) + (check-duplicate/t items key (make-hasheqv) #t)] + [else + (check-duplicate/list items key same?)])] + [(dict? same?) + (let ([dict same?]) + (if (dict-mutable? dict) + (check-duplicate/t items key dict #t) + (check-duplicate/t items key dict #f)))])) +(define (check-duplicate/t items key table mutating?) + (let loop ([items items] [table table]) + (and (pair? items) + (let ([key-item (key (car items))]) + (if (dict-ref table key-item #f) + (car items) + (loop (cdr items) (if mutating? + (begin (dict-set! table key-item #t) table) + (dict-set table key-item #t)))))))) +(define (check-duplicate/list items key same?) + (let loop ([items items] [sofar null]) + (and (pair? items) + (let ([key-item (key (car items))]) + (if (for/or ([prev (in-list sofar)]) + (same? key-item prev)) + (car items) + (loop (cdr items) (cons key-item sofar))))))) diff --git a/parse/pre.rkt b/parse/pre.rkt @@ -0,0 +1,10 @@ +#lang racket/base +(require "private/sc.rkt" + "private/litconv.rkt" + "private/lib.rkt") +(provide (except-out (all-from-out "private/sc.rkt") + define-integrable-syntax-class + syntax-parser/template + parser/rhs) + (all-from-out "private/litconv.rkt") + (all-from-out "private/lib.rkt")) diff --git a/parse/private/3d-stx.rkt b/parse/private/3d-stx.rkt @@ -0,0 +1,250 @@ +#lang racket/base +(require (only-in '#%flfxnum flvector? fxvector?) + (only-in '#%extfl extflonum? extflvector?)) +(provide 2d-stx? + check-datum) + +;; Checks for 3D syntax (syntax that contains unwritable values, etc) + +(define INIT-FUEL #e1e6) + +;; TO DO: +;; - extension via proc (any -> list/#f), +;; value considered good if result is list, all values in list are good + +;; -- + +#| +Some other predicates one might like to have: + - would (read (write x)) succeed and be equal/similar to x? + - would (datum->syntax #f x) succeed? + - would (syntax->datum (datum->syntax #f x)) succeed and be equal/similar to x? + - would (eval (read (write (compile `(quote ,x))))) succeed and be equal/similar to x? + +where equal/similar could mean one of the following: + - equal?, which equates eg (vector 1 2 3) and (vector-immutable 1 2 3) + - equal? relaxed to equate eg mutable and immutable hashes (but not prefabs) + - equal? but also requiring same mutability at every point + +Some aux definitions: + +(define (rt x) + (define-values (in out) (make-pipe)) + (write x out) + (close-output-port out) + (read in)) + +(define (wrsd x) + (define-values (in out) (make-pipe)) + (write x out) + (close-output-port out) + (syntax->datum (read-syntax #f in))) + +(define (dsd x) + (syntax->datum (datum->syntax #f x))) + +(define (evalc x) ;; mimics compiled zo-file constraints + (eval (rt (compile `(quote ,x))))) + +How mutability behaves: + - for vectors, boxes: + - read always mutable + - read-syntax always immutable + - (dsd x) always immutable + - (evalc x) always immutable + - for hashes: + - read always immutable + - (dsd x) same as x + - (evalc x) always immutable (!!!) + - for prefab structs: + - read same as x + - read-syntax same as x + - (dsd x) same as x + - (evalc x) same as x + +Symbols + - (dsd x) same as x + - (evalc x) preserves interned, unreadable, makes new uninterned (loses eq-ness) + +Chaperones allow the lazy generation of infinite trees of data +undetectable by eq?-based cycle detection. Might be helpful to have +chaperone-eq? (not recursive, just chaperones of same object) and +chaperone-eq?-hash-code, to use with make-custom-hash.) + +Impersonators allow the lazy generation of infinite trees of data, +period. + +|# + +;; ---- + +;; 2d-stx? : any ... -> boolean +;; Would (write (compile `(quote-syntax ,x))) succeed? +;; If traverse-syntax? is #t, recurs into existing syntax +;; If traverse-syntax? is #f, assumes existing stxobjs are 2d, and only +;; checks if *new* 3d syntax would be created. +(define (2d-stx? x + #:traverse-syntax? [traverse-syntax? #t] + #:irritant [irritant-box #f]) + (check-datum x + #:syntax-mode (if traverse-syntax? 'compound 'atomic) + #:allow-impersonators? #f + #:allow-mutable? 'no-hash/prefab + #:allow-unreadable-symbols? #t + #:allow-cycles? #t + #:irritant irritant-box)) + +;; ---- + +;; check-datum : any ... -> boolean +;; where StxMode = (U 'atomic 'compound #f) +;; Returns nat if x is "good", #f if "bad" +;; If irritant-b is a box, the first bad subvalue found is put in the box. +;; If visited-t is a hash, it is used to detect cycles. +(define (check-datum x + #:syntax-mode [stx-mode #f] + #:allow-impersonators? [allow-impersonators? #f] + #:allow-mutable? [allow-mutable? #f] + #:allow-unreadable-symbols? [allow-unreadable? #f] + #:allow-cycles? [allow-cycles? #f] + #:irritant [irritant-b #f]) + ;; Try once with some fuel. If runs out of fuel, try again with cycle checking. + (define (run fuel visited-t) + (check* x fuel visited-t + stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles? + irritant-b)) + (let ([result (run INIT-FUEL #f)]) + (cond [(not (equal? result 0)) ;; nat>0 or #f + (and result #t)] + [else + ;; (eprintf "out of fuel, restarting\n") + (and (run +inf.0 (make-hasheq)) #t)]))) + +;; check* : any nat/+inf.0 StxMode boolean boolean boolean box -> nat/#f +;; Returns #f if bad, positive nat if good, 0 if ran out of fuel +;; If bad, places bad subvalue in irritant-b, if box +(define (check* x0 fuel0 visited-t + stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles? + irritant-b) + (define no-mutable? (not allow-mutable?)) + (define no-mutable-hash/prefab? (or no-mutable? (eq? allow-mutable? 'no-hash/prefab))) + (define no-cycle? (not allow-cycles?)) + (define no-impersonator? (not allow-impersonators?)) + (define (loop x fuel) + (if (and fuel (not (zero? fuel))) + (loop* x fuel) + fuel)) + (define (loop* x fuel) + (define (bad) (when irritant-b (set-box! irritant-b x)) #f) + (define-syntax-rule (with-mutable-check mutable? body ...) ;; don't use for hash or prefab + (cond [(and no-mutable? mutable?) + (bad)] + [else + body ...])) + (define-syntax-rule (with-cycle-check body ...) + (cond [(and visited-t (hash-ref visited-t x #f)) + => (lambda (status) + (cond [(and no-cycle? (eq? status 'traversing)) + (bad)] + [else + fuel]))] + [else + (when visited-t + (hash-set! visited-t x 'traversing)) + (begin0 (begin body ...) + (when visited-t + (hash-remove! visited-t x)))])) + ;; (eprintf "-- checking ~s, fuel ~s\n" x fuel) + (cond + ;; Immutable compound + [(and visited-t (list? x)) + ;; space optimization: if list (finite), no need to store all cdr pairs in cycle table + ;; don't do unless visited-t present, else expands fuel by arbitrary factors + (with-cycle-check + (for/fold ([fuel (sub1 fuel)]) ([e (in-list x)] #:break (not fuel)) + (loop e fuel)))] + [(pair? x) + (with-cycle-check + (let ([fuel (loop (car x) (sub1 fuel))]) + (loop (cdr x) fuel)))] + ;; Atomic + [(or (null? x) + (boolean? x) + (number? x) + (char? x) + (keyword? x) + (regexp? x) + (byte-regexp? x) + (extflonum? x)) + fuel] + [(symbol? x) + (cond [(symbol-interned? x) + fuel] + [(symbol-unreadable? x) + (if allow-unreadable? fuel (bad))] + [else ;; uninterned + (if (eq? allow-unreadable? #t) fuel (bad))])] + ;; Mutable flat + [(or (string? x) + (bytes? x)) + (with-mutable-check (not (immutable? x)) + fuel)] + [(or (fxvector? x) + (flvector? x) + (extflvector? x)) + (with-mutable-check (not (immutable? x)) + fuel)] + ;; Syntax + [(syntax? x) + (case stx-mode + ((atomic) fuel) + ((compound) (loop (syntax-e x) fuel)) + (else (bad)))] + ;; Impersonators and chaperones + [(and no-impersonator? (impersonator? x)) ;; else continue to chaperoned type + (bad)] + [(and no-impersonator? (chaperone? x)) ;; else continue to impersonated type + (bad)] + [else + (with-cycle-check + (cond + ;; Mutable (maybe) compound + [(vector? x) + (with-mutable-check (not (immutable? x)) + (for/fold ([fuel fuel]) ([e (in-vector x)] #:break (not fuel)) + (loop e fuel)))] + [(box? x) + (with-mutable-check (not (immutable? x)) + (loop (unbox x) (sub1 fuel)))] + [(prefab-struct-key x) + => (lambda (key) + (cond [(and no-mutable-hash/prefab? (mutable-prefab-key? key)) + (bad)] + [else + ;; traverse key, since contains arbitrary auto-value + (let ([fuel (loop key fuel)]) + (loop (struct->vector x) fuel))]))] + [(hash? x) + (cond [(and no-mutable-hash/prefab? (not (immutable? x))) + (bad)] + [else + (for/fold ([fuel fuel]) ([(k v) (in-hash x)] #:break (not fuel)) + (let ([fuel (loop k fuel)]) + (loop v fuel)))])] + ;; Bad + [else + (bad)]))])) + (loop x0 fuel0)) + +;; mutable-prefab-key? : prefab-key -> boolean +(define (mutable-prefab-key? key) + ;; A prefab-key is either + ;; - symbol + ;; - (list* symbol maybe-nat maybe-list maybe-vector prefab-key) + ;; where mutable fields indicated by vector + ;; This code is probably overly general; racket seems to normalize keys. + (let loop ([k key]) + (and (pair? k) + (or (and (vector? (car k)) + (positive? (vector-length (car k)))) + (loop (cdr k)))))) diff --git a/parse/private/keywords.rkt b/parse/private/keywords.rkt @@ -0,0 +1,40 @@ +#lang racket/base +(require (for-syntax racket/base)) + +;; == 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 bad-keyword-use))) + +(define-keyword pattern) +(define-keyword ~var) +(define-keyword ~datum) +(define-keyword ~literal) +(define-keyword ~and) +(define-keyword ~or) +(define-keyword ~not) +(define-keyword ~seq) +(define-keyword ~between) +(define-keyword ~once) +(define-keyword ~optional) +(define-keyword ~rest) +(define-keyword ~describe) +(define-keyword ~!) +(define-keyword ~bind) +(define-keyword ~fail) +(define-keyword ~parse) +(define-keyword ~do) +(define-keyword ...+) +(define-keyword ~delimit-cut) +(define-keyword ~commit) +(define-keyword ~reflect) +(define-keyword ~splicing-reflect) +(define-keyword ~post) +(define-keyword ~eh-var) +(define-keyword ~peek) +(define-keyword ~peek-not) diff --git a/parse/private/kws.rkt b/parse/private/kws.rkt @@ -0,0 +1,175 @@ +#lang racket/base +(provide (struct-out arguments) + (struct-out arity) + no-arguments + no-arity + to-procedure-arity + arguments->arity + check-arity + check-arity/neg + check-curry + join-sep + kw->string + diff/sorted/eq) + +#| +An Arguments is + #s(arguments (listof stx) (listof keyword) (listof stx)) +|# +(define-struct arguments (pargs kws kwargs) #:prefab) + +(define no-arguments (arguments null null null)) + +#| +An Arity is + #s(arity nat nat/+inf.0 (listof keyword) (listof keyword)) +|# +(define-struct arity (minpos maxpos minkws maxkws) + #:prefab) + +(define no-arity (arity 0 0 null null)) + +;; ---- + +(define (to-procedure-arity minpos maxpos) + (cond [(= minpos maxpos) minpos] + [(= maxpos +inf.0) (arity-at-least minpos)] + [else (for/list ([i (in-range minpos (add1 maxpos))]) i)])) + +(define (arguments->arity argu) + (let ([pos (length (arguments-pargs argu))] + [kws (arguments-kws argu)]) + (arity pos pos kws kws))) + +(define (check-arity arity pos-count keywords proc) + (let ([msg (gen-arity-msg (arity-minpos arity) + (arity-maxpos arity) + (arity-minkws arity) + (arity-maxkws arity) + pos-count (sort keywords keyword<?))]) + (when msg + (proc msg)))) + +(define (check-arity/neg arity pos-count keywords proc) + (let ([msg (gen-arity-msg/neg (arity-minpos arity) + (arity-maxpos arity) + (arity-minkws arity) + (arity-maxkws arity) + pos-count (sort keywords keyword<?))]) + (when msg + (proc msg)))) + +(define (arity-sat? minpos maxpos minkws maxkws pos-count keywords) + (and (<= minpos pos-count maxpos) + (null? (diff/sorted/eq minkws keywords)) + (null? (diff/sorted/eq keywords maxkws)))) + +(define (gen-arity-msg minpos maxpos minkws maxkws pos-count keywords) + (if (arity-sat? minpos maxpos minkws maxkws pos-count keywords) + #f + (let ([pos-exp (gen-pos-exp-msg minpos maxpos)] + [minkws-exp (gen-minkws-exp-msg minkws)] + [optkws-exp (gen-optkws-exp-msg minkws maxkws)] + [pos-got (gen-pos-got-msg pos-count)] + [kws-got (gen-kws-got-msg keywords maxkws)]) + (string-append + "expected " + (join-sep (filter string? (list pos-exp minkws-exp optkws-exp)) + "," "and") + "; got " + (join-sep (filter string? (list pos-got kws-got)) + "," "and"))))) + +(define (gen-arity-msg/neg minpos maxpos minkws maxkws pos-count keywords) + (if (arity-sat? minpos maxpos minkws maxkws pos-count keywords) + #f + (let ([pos-exp (gen-pos-exp-msg minpos maxpos)] + [minkws-exp (gen-minkws-exp-msg minkws)] + [optkws-exp (gen-optkws-exp-msg minkws maxkws)] + [pos-got (gen-pos-got-msg pos-count)] + [kws-got (gen-kws-got-msg keywords maxkws)]) + (string-append + "expected a syntax class that accepts " + (join-sep (filter string? (list pos-got kws-got)) + "," "and") + "; got one that accepts " + (join-sep (filter string? (list pos-exp minkws-exp optkws-exp)) + "," "and"))))) + +(define (check-curry arity pos-count keywords proc) + (let ([maxpos (arity-maxpos arity)] + [maxkws (arity-maxkws arity)]) + (when (> pos-count maxpos) + (proc (format "too many arguments: expected at most ~s, got ~s" + maxpos pos-count))) + (let ([extrakws (diff/sorted/eq keywords maxkws)]) + (when (pair? extrakws) + (proc (format "syntax class does not accept keyword arguments for ~a" + (join-sep (map kw->string extrakws) "," "and"))))))) + +;; ---- + +(define (gen-pos-exp-msg minpos maxpos) + (format "~a positional argument~a" + (cond [(= maxpos minpos) minpos] + [(= maxpos +inf.0) (format "at least ~a" minpos)] + [else + (format "between ~a and ~a" minpos maxpos)]) + (if (= minpos maxpos 1) "" "s"))) + +(define (gen-minkws-exp-msg minkws) + (and (pair? minkws) + (format "~amandatory keyword argument~a for ~a" + (if (= (length minkws) 1) "a " "") + (if (= (length minkws) 1) "" "s") + (join-sep (map kw->string minkws) "," "and")))) + +(define (gen-optkws-exp-msg minkws maxkws) + (let ([optkws (diff/sorted/eq maxkws minkws)]) + (and (pair? optkws) + (format "~aoptional keyword argument~a for ~a" + (if (= (length optkws) 1) "an " "") + (if (= (length optkws) 1) "" "s") + (join-sep (map kw->string optkws) "," "and"))))) + +(define (gen-pos-got-msg pos-count) + (format "~a positional argument~a" + pos-count (if (= pos-count 1) "" "s"))) + +(define (gen-kws-got-msg keywords maxkws) + (cond [(pair? keywords) + (format "~akeyword argument~a for ~a" + (if (= (length keywords) 1) "a " "") + (if (= (length keywords) 1) "" "s") + (join-sep (map kw->string keywords) "," "and"))] + [(pair? maxkws) "no keyword arguments"] + [else #f])) + +;; ---- + +(define (kw->string kw) (format "~a" kw)) + +(define (diff/sorted/eq xs ys) + (if (pair? xs) + (let ([ys* (memq (car xs) ys)]) + (if ys* + (diff/sorted/eq (cdr xs) (cdr ys*)) + (cons (car xs) (diff/sorted/eq (cdr xs) ys)))) + null)) + +(define (join-sep items sep0 ult0 [prefix ""]) + (define sep (string-append sep0 " ")) + (define ult (string-append ult0 " ")) + (define (loop items) + (cond [(null? items) + null] + [(null? (cdr items)) + (list sep ult (car items))] + [else + (list* sep (car items) (loop (cdr items)))])) + (case (length items) + [(0) #f] + [(1) (string-append prefix (car items))] + [(2) (format "~a~a ~a~a" prefix (car items) ult (cadr items))] + [else (let ([strings (list* (car items) (loop (cdr items)))]) + (apply string-append prefix strings))])) diff --git a/parse/private/lib.rkt b/parse/private/lib.rkt @@ -0,0 +1,75 @@ +#lang racket/base +(require "sc.rkt" + "keywords.rkt" + (for-syntax racket/base)) + +(provide identifier + boolean + str + character + keyword + number + integer + exact-integer + exact-nonnegative-integer + exact-positive-integer + + id + nat + char + + expr + static) + + +(define (expr-stx? x) + (not (keyword-stx? x))) + +(define ((stxof pred?) x) (and (syntax? x) (pred? (syntax-e x)))) +(define keyword-stx? (stxof keyword?)) +(define boolean-stx? (stxof boolean?)) +(define string-stx? (stxof string?)) +(define char-stx? (stxof char?)) +(define number-stx? (stxof number?)) +(define integer-stx? (stxof integer?)) +(define exact-integer-stx? (stxof exact-integer?)) +(define exact-nonnegative-integer-stx? (stxof exact-nonnegative-integer?)) +(define exact-positive-integer-stx? (stxof exact-positive-integer?)) + +;; == Integrable syntax classes == + +(define-integrable-syntax-class identifier (quote "identifier") identifier?) +(define-integrable-syntax-class expr (quote "expression") expr-stx?) +(define-integrable-syntax-class keyword (quote "keyword") keyword-stx?) +(define-integrable-syntax-class boolean (quote "boolean") boolean-stx?) +(define-integrable-syntax-class character (quote "character") char-stx?) +(define-integrable-syntax-class str (quote "string") string-stx?) +(define-integrable-syntax-class number (quote "number") number-stx?) +(define-integrable-syntax-class integer (quote "integer") integer-stx?) +(define-integrable-syntax-class exact-integer (quote "exact-integer") exact-integer-stx?) +(define-integrable-syntax-class exact-nonnegative-integer + (quote "exact-nonnegative-integer") + exact-nonnegative-integer-stx?) +(define-integrable-syntax-class exact-positive-integer + (quote "exact-positive-integer") + exact-positive-integer-stx?) + +;; Aliases +(define-syntax id (make-rename-transformer #'identifier)) +(define-syntax nat (make-rename-transformer #'exact-nonnegative-integer)) +(define-syntax char (make-rename-transformer #'character)) + +;; == Normal syntax classes == + +(define notfound (box 'notfound)) + +(define-syntax-class (static pred [name #f]) + #:attributes (value) + #:description name + #:commit + (pattern x:id + #:fail-unless (syntax-transforming?) + "not within the dynamic extent of a macro transformation" + #:attr value (syntax-local-value #'x (lambda () notfound)) + #:fail-when (eq? (attribute value) notfound) #f + #:fail-unless (pred (attribute value)) #f)) diff --git a/parse/private/litconv.rkt b/parse/private/litconv.rkt @@ -0,0 +1,284 @@ +#lang racket/base +(require (for-syntax racket/base + racket/lazy-require + "sc.rkt" + "lib.rkt" + "kws.rkt" + racket/syntax) + syntax/parse/private/residual-ct ;; keep abs. path + syntax/parse/private/residual) ;; keep abs. path +(begin-for-syntax + (lazy-require + [syntax/private/keyword (options-select-value parse-keyword-options)] + [syntax/parse/private/rep ;; keep abs. path + (parse-kw-formals + check-conventions-rules + check-datum-literals-list + create-aux-def)])) +;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require) +;; Without this, dependencies don't get collected. +(require racket/runtime-path racket/syntax (for-meta 2 '#%kernel)) +(define-runtime-module-path-index _unused_ 'syntax/parse/private/rep) + +(provide define-conventions + define-literal-set + literal-set->predicate + kernel-literals) + +(define-syntax (define-conventions stx) + + (define-syntax-class header + #:description "name or name with formal parameters" + #:commit + (pattern name:id + #:with formals #'() + #:attr arity (arity 0 0 null null)) + (pattern (name:id . formals) + #:attr arity (parse-kw-formals #'formals #:context stx))) + + (syntax-parse stx + [(define-conventions h:header rule ...) + (let () + (define rules (check-conventions-rules #'(rule ...) stx)) + (define rxs (map car rules)) + (define dens0 (map cadr rules)) + (define den+defs-list + (for/list ([den0 (in-list dens0)]) + (let-values ([(den defs) (create-aux-def den0)]) + (cons den defs)))) + (define dens (map car den+defs-list)) + (define defs (apply append (map cdr den+defs-list))) + + (define/with-syntax (rx ...) rxs) + (define/with-syntax (def ...) defs) + (define/with-syntax (parser ...) + (map den:delayed-parser dens)) + (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 + (quote-syntax get-parsers) + (lambda () + (let ([class-names (list (quote-syntax class-name) ...)]) + (map list + (list 'rx ...) + (map make-den:delayed + (generate-temporaries class-names) + class-names)))))) + (define get-parsers + (lambda formals + def ... + (list parser ...)))))])) + +(define-for-syntax (check-phase-level stx ctx) + (unless (or (exact-integer? (syntax-e stx)) + (eq? #f (syntax-e stx))) + (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx)) + stx) + +;; check-litset-list : stx stx -> (listof (cons id literalset)) +(define-for-syntax (check-litset-list stx ctx) + (syntax-case stx () + [(litset-id ...) + (for/list ([litset-id (syntax->list #'(litset-id ...))]) + (let* ([val (and (identifier? litset-id) + (syntax-local-value/record litset-id literalset?))]) + (if val + (cons litset-id val) + (raise-syntax-error #f "expected literal set name" ctx litset-id))))] + [_ (raise-syntax-error #f "expected list of literal set names" ctx stx)])) + +;; check-literal-entry/litset : stx stx -> (list id id) +(define-for-syntax (check-literal-entry/litset stx ctx) + (syntax-case stx () + [(internal external) + (and (identifier? #'internal) (identifier? #'external)) + (list #'internal #'external)] + [id + (identifier? #'id) + (list #'id #'id)] + [_ (raise-syntax-error #f "expected literal entry" ctx stx)])) + +(define-for-syntax (check-duplicate-literals ctx imports lits datum-lits) + (let ([lit-t (make-hasheq)]) ;; sym => #t + (define (check+enter! key blame-stx) + (when (hash-ref lit-t key #f) + (raise-syntax-error #f (format "duplicate literal: ~a" key) ctx blame-stx)) + (hash-set! lit-t key #t)) + (for ([id+litset (in-list imports)]) + (let ([litset-id (car id+litset)] + [litset (cdr id+litset)]) + (for ([entry (in-list (literalset-literals litset))]) + (cond [(lse:lit? entry) + (check+enter! (lse:lit-internal entry) litset-id)] + [(lse:datum-lit? entry) + (check+enter! (lse:datum-lit-internal entry) litset-id)])))) + (for ([datum-lit (in-list datum-lits)]) + (let ([internal (den:datum-lit-internal datum-lit)]) + (check+enter! (syntax-e internal) internal))) + (for ([lit (in-list lits)]) + (check+enter! (syntax-e (car lit)) (car lit))))) + +(define-syntax (define-literal-set stx) + (syntax-case stx () + [(define-literal-set name . rest) + (let-values ([(chunks rest) + (parse-keyword-options + #'rest + `((#:literal-sets ,check-litset-list) + (#:datum-literals ,check-datum-literals-list) + (#:phase ,check-phase-level) + (#:for-template) + (#:for-syntax) + (#:for-label)) + #:incompatible '((#:phase #:for-template #:for-syntax #:for-label)) + #:context stx + #:no-duplicates? #t)]) + (unless (identifier? #'name) + (raise-syntax-error #f "expected identifier" stx #'name)) + (let ([relphase + (cond [(assq '#:for-template chunks) -1] + [(assq '#:for-syntax chunks) 1] + [(assq '#:for-label chunks) #f] + [else (options-select-value chunks '#:phase #:default 0)])] + [datum-lits + (options-select-value chunks '#:datum-literals #:default null)] + [lits (syntax-case rest () + [( (lit ...) ) + (for/list ([lit (in-list (syntax->list #'(lit ...)))]) + (check-literal-entry/litset lit stx))] + [_ (raise-syntax-error #f "bad syntax" stx)])] + [imports (options-select-value chunks '#:literal-sets #:default null)]) + (check-duplicate-literals stx imports lits datum-lits) + (with-syntax ([((internal external) ...) lits] + [(datum-internal ...) (map den:datum-lit-internal datum-lits)] + [(datum-external ...) (map den:datum-lit-external datum-lits)] + [(litset-id ...) (map car imports)] + [relphase relphase]) + #`(begin + (define phase-of-literals + (and 'relphase + (+ (variable-reference->module-base-phase (#%variable-reference)) + 'relphase))) + (define-syntax name + (make-literalset + (append (literalset-literals (syntax-local-value (quote-syntax litset-id))) + ... + (list (make-lse:lit 'internal + (quote-syntax external) + (quote-syntax phase-of-literals)) + ... + (make-lse:datum-lit 'datum-internal + 'datum-external) + ...)))) + (begin-for-syntax/once + (for ([x (in-list (syntax->list #'(external ...)))]) + (unless (identifier-binding x 'relphase) + (raise-syntax-error #f + (format "literal is unbound in phase ~a~a~a" + 'relphase + (case 'relphase + ((1) " (for-syntax)") + ((-1) " (for-template)") + ((#f) " (for-label)") + (else "")) + " relative to the enclosing module") + (quote-syntax #,stx) x))))))))])) + +#| +NOTES ON PHASES AND BINDINGS + +(module M .... + .... (define-literal-set LS #:phase PL ....) + ....) + +For the expansion of the define-literal-set form, the bindings of the literals +can be accessed by (identifier-binding lit PL), because the phase of the enclosing +module (M) is 0. + +LS may be used, however, in a context where the phase of the enclosing +module is not 0, so each instantiation of LS needs to calculate the +phase of M and add that to PL. + +-- + +Normally, literal sets that define the same name conflict. But it +would be nice to allow them to both be imported in the case where they +refer to the same binding. + +Problem: Can't do the check eagerly, because the binding of L may +change between when define-literal-set is compiled and the comparison +involving L. For example: + + (module M racket + (require syntax/parse) + (define-literal-set LS (lambda)) + (require (only-in some-other-lang lambda)) + .... LS ....) + +The expansion of the LS definition sees a different lambda than the +one that the literal in LS actually refers to. + +Similarly, a literal in LS might not be defined when the expander +runs, but might get defined later. (Although I think that will already +cause an error, so don't worry about that case.) +|# + +;; FIXME: keep one copy of each identifier (?) + +(define-syntax (literal-set->predicate stx) + (syntax-case stx () + [(literal-set->predicate litset-id) + (let ([val (and (identifier? #'litset-id) + (syntax-local-value/record #'litset-id literalset?))]) + (unless val (raise-syntax-error #f "expected literal set name" stx #'litset-id)) + (let ([lits (literalset-literals val)]) + (with-syntax ([((lit phase-var) ...) + (for/list ([lit (in-list lits)] + #:when (lse:lit? lit)) + (list (lse:lit-external lit) (lse:lit-phase lit)))] + [(datum-lit ...) + (for/list ([lit (in-list lits)] + #:when (lse:datum-lit? lit)) + (lse:datum-lit-external lit))]) + #'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...) + '(datum-lit ...)))))])) + +(define (make-literal-set-predicate lits datum-lits) + (lambda (x [phase (syntax-local-phase-level)]) + (or (for/or ([lit (in-list lits)]) + (let ([lit-id (car lit)] + [lit-phase (cadr lit)]) + (free-identifier=? x lit-id phase lit-phase))) + (and (memq (syntax-e x) datum-lits) #t)))) + +;; Literal sets + +(define-literal-set kernel-literals + (begin + begin0 + define-values + define-syntaxes + define-values-for-syntax ;; kept for compat. + begin-for-syntax + set! + let-values + letrec-values + #%plain-lambda + case-lambda + if + quote + quote-syntax + letrec-syntaxes+values + with-continuation-mark + #%expression + #%plain-app + #%top + #%datum + #%variable-reference + module module* #%provide #%require #%declare + #%plain-module-begin)) diff --git a/parse/private/make.rkt b/parse/private/make.rkt @@ -0,0 +1,43 @@ +#lang racket/base +(require (for-syntax racket/base + racket/struct-info)) +(provide make) + +;; get-struct-info : identifier stx -> struct-info-list +(define-for-syntax (get-struct-info id ctx) + (define (bad-struct-name x) + (raise-syntax-error #f "expected struct name" ctx x)) + (unless (identifier? id) + (bad-struct-name id)) + (let ([value (syntax-local-value id (lambda () #f))]) + (unless (struct-info? value) + (bad-struct-name id)) + (extract-struct-info value))) + +;; (make struct-name field-expr ...) +;; Checks that correct number of fields given. +(define-syntax (make stx) + (syntax-case stx () + [(make S expr ...) + (let () + (define info (get-struct-info #'S stx)) + (define constructor (list-ref info 1)) + (define accessors (list-ref info 3)) + (unless (identifier? #'constructor) + (raise-syntax-error #f "constructor not available for struct" stx #'S)) + (unless (andmap identifier? accessors) + (raise-syntax-error #f "incomplete info for struct type" stx #'S)) + (let ([num-slots (length accessors)] + [num-provided (length (syntax->list #'(expr ...)))]) + (unless (= num-provided num-slots) + (raise-syntax-error + #f + (format "wrong number of arguments for struct ~s (expected ~s, got ~s)" + (syntax-e #'S) + num-slots + num-provided) + stx))) + (with-syntax ([constructor constructor]) + (syntax-property #'(constructor expr ...) + 'disappeared-use + #'S)))])) diff --git a/parse/private/minimatch.rkt b/parse/private/minimatch.rkt @@ -0,0 +1,105 @@ +#lang racket/base +(require (for-syntax racket/base racket/struct-info)) +(provide match ?) + +(define-syntax (match stx) + (syntax-case stx () + [(match e clause ...) + #`(let ([x e]) + (match-c x + clause ... + [_ (error 'minimatch "match at ~s:~s:~s failed: ~e" + '#,(syntax-source stx) + '#,(syntax-line stx) + '#,(syntax-column stx) + x)]))])) + +(define-syntax match-c + (syntax-rules () + [(match-c x) + (error 'minimatch)] + [(match-c x [pattern result ...] clause ...) + (let ([fail (lambda () (match-c x clause ...))]) + (match-p x pattern (let () result ...) (fail)))])) + +;; (match-p id Pattern SuccessExpr FailureExpr) +(define-syntax (match-p stx) + (syntax-case stx (quote cons list vector STRUCT ?) + [(match-p x wildcard success failure) + (and (identifier? #'wildcard) (free-identifier=? #'wildcard #'_)) + #'success] + [(match-p x (quote lit) success failure) + #'(if (equal? x (quote lit)) + success + failure)] + [(match-p x (cons p1 p2) success failure) + #'(if (pair? x) + (let ([x1 (car x)] + [x2 (cdr x)]) + (match-p x1 p1 (match-p x2 p2 success failure) failure)) + failure)] + [(match-p x (list) success failure) + #'(match-p x (quote ()) success failure)] + [(match-p x (list p1 p ...) success failure) + #'(match-p x (cons p1 (list p ...)) success failure)] + [(match-p x (vector p ...) success failure) + #'(if (and (vector? x) (= (vector-length x) (length '(p ...)))) + (let ([x* (vector->list x)]) + (match-p x* (list p ...) success failure)) + failure)] + [(match-p x var success failure) + (identifier? #'var) + #'(let ([var x]) success)] + [(match-p x (STRUCT S (p ...)) success failure) + (identifier? #'S) + (let () + (define (not-a-struct) + (raise-syntax-error #f "expected struct name" #'S)) + (define si (syntax-local-value #'S not-a-struct)) + (unless (struct-info? si) + (not-a-struct)) + (let* ([si (extract-struct-info si)] + [predicate (list-ref si 2)] + [accessors (reverse (list-ref si 3))]) + (unless (andmap identifier? accessors) + (raise-syntax-error #f "struct has incomplete information" #'S)) + (with-syntax ([predicate predicate] + [(accessor ...) accessors]) + #'(if (predicate x) + (let ([y (list (accessor x) ...)]) + (match-p y (list p ...) success failure)) + failure))))] + [(match-p x (? predicate pat ...) success failure) + #'(if (predicate x) + (match-p* ((x pat) ...) success failure) + failure)] + [(match-p x (S p ...) success failure) + (identifier? #'S) + (if (struct-info? (syntax-local-value #'S (lambda () #f))) + #'(match-p x (STRUCT S (p ...)) success failure) + (raise-syntax-error #f "bad minimatch form" stx #'S))] + [(match-p x s success failure) + (prefab-struct-key (syntax-e #'s)) + (with-syntax ([key (prefab-struct-key (syntax-e #'s))] + [(p ...) (cdr (vector->list (struct->vector (syntax-e #'s))))]) + #'(let ([xkey (prefab-struct-key x)]) + (if (equal? xkey 'key) + (let ([xps (cdr (vector->list (struct->vector x)))]) + (match-p xps (list p ...) success failure)) + failure)))] + [(match-p x pattern success failure) + (raise-syntax-error 'minimatch "bad pattern" #'pattern)] + )) + +(define-syntax match-p* + (syntax-rules () + [(match-p* () success failure) + success] + [(match-p* ((x1 p1) . rest) success failure) + (match-p x1 p1 (match-p* rest success failure) failure)])) + +(define-syntax ? + (lambda (stx) + (raise-syntax-error #f "illegal use of minimatch form '?'" stx))) + +(define-syntax STRUCT #f) ;; internal keyword diff --git a/parse/private/opt.rkt b/parse/private/opt.rkt @@ -0,0 +1,430 @@ +#lang racket/base +(require racket/syntax + racket/pretty + syntax/parse/private/residual-ct ;; keep abs. path + "minimatch.rkt" + "rep-patterns.rkt" + "kws.rkt") +(provide (struct-out pk1) + (rename-out [optimize-matrix0 optimize-matrix])) + +;; controls debugging output for optimization successes and failures +(define DEBUG-OPT-SUCCEED #f) +(define DEBUG-OPT-FAIL #f) + +;; ---- + +;; A Matrix is a (listof PK) where each PK has same number of columns +;; A PK is one of +;; - (pk1 (listof pattern) expr) -- a simple row in a parsing matrix +;; - (pk/same pattern Matrix) -- a submatrix with a common first column factored out +;; - (pk/pair Matrix) -- a submatrix with pair patterns in the first column unfolded +;; - (pk/and Matrix) -- a submatrix with and patterns in the first column unfolded +(struct pk1 (patterns k) #:prefab) +(struct pk/same (pattern inner) #:prefab) +(struct pk/pair (inner) #:prefab) +(struct pk/and (inner) #:prefab) + +(define (pk-columns pk) + (match pk + [(pk1 patterns k) (length patterns)] + [(pk/same p inner) (add1 (pk-columns inner))] + [(pk/pair inner) (sub1 (pk-columns inner))] + [(pk/and inner) (sub1 (pk-columns inner))])) + +;; Can factor pattern P given clauses like +;; [ P P1 ... | e1] [ | [P1 ... | e1] ] +;; [ P ⋮ | ⋮] => [P | [ ⋮ | ⋮] ] + ; [ P PN ... | eN] [ | [PN ... | eN] ] +;; if P cannot cut and P succeeds at most once (otherwise may reorder backtracking) + +;; Can unfold pair patterns as follows: +;; [ (P11 . P12) P1 ... | e1 ] [ P11 P12 P1 ... | e1 ] +;; [ ⋮ ⋮ | ⋮ ] => check pair, [ ⋮ | ⋮ ] +;; [ (PN1 . PN2) PN ... | eN ] [ PN1 PN2 PN ... | eN ] + +;; Can unfold ~and patterns similarly; ~and patterns can hide +;; factoring opportunities. + +;; ---- + +(define (optimize-matrix0 rows) + (define now (current-inexact-milliseconds)) + (when (and DEBUG-OPT-SUCCEED (> (length rows) 1)) + (eprintf "\n%% optimizing (~s):\n" (length rows)) + (pretty-write (matrix->sexpr rows) (current-error-port))) + (define result (optimize-matrix rows)) + (define then (current-inexact-milliseconds)) + (when (and DEBUG-OPT-SUCCEED (> (length rows) 1)) + (cond [(= (length result) (length rows)) + (eprintf "%% !! FAILED !! (~s ms)\n\n" (floor (- then now)))] + [else + (eprintf "==> (~s ms)\n" (floor (- then now))) + (pretty-write (matrix->sexpr result) (current-error-port)) + (eprintf "\n")])) + result) + +;; optimize-matrix : (listof pk1) -> Matrix +(define (optimize-matrix rows) + (cond [(null? rows) null] + [(null? (cdr rows)) rows] ;; no opportunities for 1 row + [(null? (pk1-patterns (car rows))) rows] + [else + ;; first unfold and-patterns + (let-values ([(col1 col2) + (for/lists (col1 col2) ([row (in-list rows)]) + (unfold-and (car (pk1-patterns row)) null))]) + (cond [(ormap pair? col2) + (list + (pk/and + (optimize-matrix* + (for/list ([row (in-list rows)] + [col1 (in-list col1)] + [col2 (in-list col2)]) + (pk1 (list* col1 + (make-and-pattern col2) + (cdr (pk1-patterns row))) + (pk1-k row))))))] + [else (optimize-matrix* rows)]))])) + +;; optimize-matrix* : (listof pk1) -> Matrix +;; The matrix is nonempty, and first column has no unfoldable pat:and. +;; Split into submatrixes (sequences of rows) starting with similar patterns, +;; handle according to similarity, then recursively optimize submatrixes. +(define (optimize-matrix* rows) + (define row1 (car rows)) + (define pat1 (car (pk1-patterns row1))) + (define k1 (pk1-k row1)) + ;; Now accumulate rows starting with patterns like pat1 + (define-values (like? combine) (pattern->partitioner pat1)) + (let loop ([rows (cdr rows)] [rrows (list row1)]) + (cond [(null? rows) + (cons (combine (reverse rrows)) null)] + [else + (define row1 (car rows)) + (define pat1 (car (pk1-patterns row1))) + (cond [(like? pat1) + (loop (cdr rows) (cons row1 rrows))] + [else + (cons (combine (reverse rrows)) + (optimize-matrix* rows))])]))) + +;; pattern->partitioner : pattern -> (values (pattern -> boolean) ((listof pk1) -> PK)) +(define (pattern->partitioner pat1) + (match pat1 + [(pat:pair head tail) + (values (lambda (p) (pat:pair? p)) + (lambda (rows) + (when DEBUG-OPT-SUCCEED + (eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1))) + (cond [(> (length rows) 1) + (pk/pair (optimize-matrix + (for/list ([row (in-list rows)]) + (let* ([patterns (pk1-patterns row)] + [pat1 (car patterns)]) + (pk1 (list* (pat:pair-head pat1) + (pat:pair-tail pat1) + (cdr patterns)) + (pk1-k row))))))] + [else (car rows)])))] + [(? pattern-factorable?) + (values (lambda (pat2) (pattern-equal? pat1 pat2)) + (lambda (rows) + (when DEBUG-OPT-SUCCEED + (eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1))) + (cond [(> (length rows) 1) + (pk/same pat1 + (optimize-matrix + (for/list ([row (in-list rows)]) + (pk1 (cdr (pk1-patterns row)) (pk1-k row)))))] + [else (car rows)])))] + [_ + (values (lambda (pat2) + (when DEBUG-OPT-FAIL + (when (pattern-equal? pat1 pat2) + (eprintf "** cannot factor: ~e\n" (syntax->datum #`#,pat2)))) + #f) + (lambda (rows) + ;; (length rows) = 1 + (car rows)))])) + +;; unfold-and : pattern (listof pattern) -> (values pattern (listof pattern)) +(define (unfold-and p onto) + (match p + [(pat:and subpatterns) + ;; pat:and is worth unfolding if first subpattern is not pat:action + ;; if first subpattern is also pat:and, keep unfolding + (let* ([first-sub (car subpatterns)] + [rest-subs (cdr subpatterns)]) + (cond [(not (pat:action? first-sub)) + (when #f ;; DEBUG-OPT-SUCCEED + (eprintf ">> unfolding: ~e\n" p)) + (unfold-and first-sub (*append rest-subs onto))] + [else (values p onto)]))] + [_ (values p onto)])) + +(define (pattern-factorable? p) + ;; Can factor out p if p can succeed at most once, does not cut + ;; - if p can succeed multiple times, then factoring changes success order + ;; - if p can cut, then factoring changes which choice points are discarded (too few) + (match p + [(pat:any) #t] + [(pat:svar _n) #t] + [(pat:var/p _ _ _ _ _ (scopts _ commit? _ _)) + ;; commit? implies delimit-cut + commit?] + [(? pat:integrated?) #t] + [(pat:literal _lit _ip _lp) #t] + [(pat:datum _datum) #t] + [(pat:action _act _pat) #f] + [(pat:head head tail) + (and (pattern-factorable? head) + (pattern-factorable? tail))] + [(pat:dots heads tail) + ;; Conservative approximation for common case: one head pattern + ;; In general, check if heads don't overlap, don't overlap with tail. + (and (= (length heads) 1) + (let ([head (car heads)]) + (and (pattern-factorable? head))) + (equal? tail (pat:datum '())))] + [(pat:and patterns) + (andmap pattern-factorable? patterns)] + [(pat:or patterns) #f] + [(pat:not pattern) #f] ;; FIXME: ? + [(pat:pair head tail) + (and (pattern-factorable? head) + (pattern-factorable? tail))] + [(pat:vector pattern) + (pattern-factorable? pattern)] + [(pat:box pattern) + (pattern-factorable? pattern)] + [(pat:pstruct key pattern) + (pattern-factorable? pattern)] + [(pat:describe pattern _desc _trans _role) + (pattern-factorable? pattern)] + [(pat:delimit pattern) + (pattern-factorable? pattern)] + [(pat:commit pattern) #t] + [(? pat:reflect?) #f] + [(pat:ord pattern _ _) + (pattern-factorable? pattern)] + [(pat:post pattern) + (pattern-factorable? pattern)] + ;; ---- + [(hpat:var/p _ _ _ _ _ (scopts _ commit? _ _)) + commit?] + [(hpat:seq inner) + (pattern-factorable? inner)] + [(hpat:commit inner) #t] + ;; ---- + [(ehpat head repc) + (and (equal? repc #f) + (pattern-factorable? head))] + ;; ---- + [else #f])) + +(define (subpatterns-equal? as bs) + (and (= (length as) (length bs)) + (for/and ([a (in-list as)] + [b (in-list bs)]) + (pattern-equal? a b)))) + +(define (pattern-equal? a b) + (define result + (cond [(and (pat:any? a) (pat:any? b)) #t] + [(and (pat:svar? a) (pat:svar? b)) + (bound-identifier=? (pat:svar-name a) (pat:svar-name b))] + [(and (pat:var/p? a) (pat:var/p? b)) + (and (free-id/f-equal? (pat:var/p-parser a) (pat:var/p-parser b)) + (bound-id/f-equal? (pat:var/p-name a) (pat:var/p-name b)) + (equal-iattrs? (pat:var/p-nested-attrs a) (pat:var/p-nested-attrs b)) + (equal-argu? (pat:var/p-argu a) (pat:var/p-argu b)) + (expr-equal? (pat:var/p-role a) (pat:var/p-role b)))] + [(and (pat:integrated? a) (pat:integrated? b)) + (and (bound-id/f-equal? (pat:integrated-name a) (pat:integrated-name b)) + (free-identifier=? (pat:integrated-predicate a) + (pat:integrated-predicate b)) + (expr-equal? (pat:integrated-role a) (pat:integrated-role b)))] + [(and (pat:literal? a) (pat:literal? b)) + ;; literals are hard to compare, so compare gensyms attached to + ;; literal ids (see rep.rkt) instead + (let ([ka (syntax-property (pat:literal-id a) 'literal)] + [kb (syntax-property (pat:literal-id b) 'literal)]) + (and ka kb (eq? ka kb)))] + [(and (pat:datum? a) (pat:datum? b)) + (equal? (pat:datum-datum a) + (pat:datum-datum b))] + [(and (pat:head? a) (pat:head? b)) + (and (pattern-equal? (pat:head-head a) (pat:head-head b)) + (pattern-equal? (pat:head-tail a) (pat:head-tail b)))] + [(and (pat:dots? a) (pat:dots? b)) + (and (subpatterns-equal? (pat:dots-heads a) (pat:dots-heads b)) + (pattern-equal? (pat:dots-tail a) (pat:dots-tail b)))] + [(and (pat:and? a) (pat:and? b)) + (subpatterns-equal? (pat:and-patterns a) (pat:and-patterns b))] + [(and (pat:or? a) (pat:or? b)) + (subpatterns-equal? (pat:or-patterns a) (pat:or-patterns b))] + [(and (pat:not? a) (pat:not? b)) + (pattern-equal? (pat:not-pattern a) (pat:not-pattern b))] + [(and (pat:pair? a) (pat:pair? b)) + (and (pattern-equal? (pat:pair-head a) (pat:pair-head b)) + (pattern-equal? (pat:pair-tail a) (pat:pair-tail b)))] + [(and (pat:vector? a) (pat:vector? b)) + (pattern-equal? (pat:vector-pattern a) (pat:vector-pattern b))] + [(and (pat:box? a) (pat:box? b)) + (pattern-equal? (pat:box-pattern a) (pat:box-pattern b))] + [(and (pat:pstruct? a) (pat:pstruct? b)) + (and (equal? (pat:pstruct-key a) + (pat:pstruct-key b)) + (pattern-equal? (pat:pstruct-pattern a) + (pat:pstruct-pattern b)))] + [(and (pat:describe? a) (pat:describe? b)) #f] ;; can't compare desc exprs + [(and (pat:delimit? a) (pat:delimit? b)) + (pattern-equal? (pat:delimit-pattern a) (pat:delimit-pattern b))] + [(and (pat:commit? a) (pat:commit? b)) + (pattern-equal? (pat:commit-pattern a) (pat:commit-pattern b))] + [(and (pat:reflect? a) (pat:reflect? b)) #f] ;; FIXME: ? + [(and (pat:ord? a) (pat:ord? b)) + (and (pattern-equal? (pat:ord-pattern a) (pat:ord-pattern b)) + (equal? (pat:ord-group a) (pat:ord-group b)) + (equal? (pat:ord-index a) (pat:ord-index b)))] + [(and (pat:post? a) (pat:post? b)) + (pattern-equal? (pat:post-pattern a) (pat:post-pattern b))] + ;; --- + [(and (hpat:var/p? a) (hpat:var/p? b)) + (and (free-id/f-equal? (hpat:var/p-parser a) (hpat:var/p-parser b)) + (bound-id/f-equal? (hpat:var/p-name a) (hpat:var/p-name b)) + (equal-iattrs? (hpat:var/p-nested-attrs a) (hpat:var/p-nested-attrs b)) + (equal-argu? (hpat:var/p-argu a) (hpat:var/p-argu b)) + (expr-equal? (hpat:var/p-role a) (hpat:var/p-role b)))] + [(and (hpat:seq? a) (hpat:seq? b)) + (pattern-equal? (hpat:seq-inner a) (hpat:seq-inner b))] + ;; --- + [(and (ehpat? a) (ehpat? b)) + (and (equal? (ehpat-repc a) #f) + (equal? (ehpat-repc b) #f) + (pattern-equal? (ehpat-head a) (ehpat-head b)))] + ;; FIXME: more? + [else #f])) + (when DEBUG-OPT-FAIL + (when (and (eq? result #f) + (equal? (syntax->datum #`#,a) (syntax->datum #`#,b))) + (eprintf "** pattern-equal? failed on ~e\n" a))) + result) + +(define (equal-iattrs? as bs) + (and (= (length as) (length bs)) + ;; assumes attrs in same order + (for/and ([aa (in-list as)] + [ba (in-list bs)]) + (and (bound-identifier=? (attr-name aa) (attr-name ba)) + (equal? (attr-depth aa) (attr-depth ba)) + (equal? (attr-syntax? aa) (attr-syntax? ba)))))) + +(define (expr-equal? a b) + ;; Expression equality is undecidable in general. Especially difficult for unexpanded + ;; code, but it would be very difficult to set up correct env for local-expand because of + ;; attr binding rules. So, do *very* conservative approx: simple variables and literals. + ;; FIXME: any other common cases? + (cond [(not (and (syntax? a) (syntax? b))) + (equal? a b)] + [(and (identifier? a) (identifier? b)) + ;; note: "vars" might be identifier macros (unsafe to consider equal), + ;; so check var has no compile-time binding + (and (free-identifier=? a b) + (let/ec k (syntax-local-value a (lambda () (k #t))) #f))] + [(syntax-case (list a b) (quote) + [((quote ad) (quote bd)) + (cons (syntax->datum #'ad) (syntax->datum #'bd))] + [_ #f]) + => (lambda (ad+bd) + (equal? (car ad+bd) (cdr ad+bd)))] + [else + ;; approx: equal? only if both simple data (bool, string, etc), no inner stx + (let ([ad (syntax-e a)] + [bd (syntax-e b)]) + (and (equal? ad bd) + (free-identifier=? (datum->syntax a '#%datum) #'#%datum) + (free-identifier=? (datum->syntax b '#%datum) #'#%datum)))])) + +(define (equal-argu? a b) + (define (unwrap-arguments x) + (match x + [(arguments pargs kws kwargs) + (values pargs kws kwargs)])) + (define (list-equal? as bs inner-equal?) + (and (= (length as) (length bs)) + (andmap inner-equal? as bs))) + (let-values ([(apargs akws akwargs) (unwrap-arguments a)] + [(bpargs bkws bkwargs) (unwrap-arguments b)]) + (and (list-equal? apargs bpargs expr-equal?) + (equal? akws bkws) + (list-equal? akwargs bkwargs expr-equal?)))) + +(define (free-id/f-equal? a b) + (or (and (eq? a #f) + (eq? b #f)) + (and (identifier? a) + (identifier? b) + (free-identifier=? a b)))) + +(define (bound-id/f-equal? a b) + (or (and (eq? a #f) + (eq? b #f)) + (and (identifier? a) + (identifier? b) + (bound-identifier=? a b)))) + +(define (make-and-pattern subs) + (cond [(null? subs) (pat:any)] ;; shouldn't happen + [(null? (cdr subs)) (car subs)] + [else (pat:and subs)])) + +(define (*append a b) (if (null? b) a (append a b))) + +(define (stx-e x) (if (syntax? x) (syntax-e x) x)) + +;; ---- + +(define (matrix->sexpr rows) + (cond [(null? rows) ;; shouldn't happen + '(FAIL)] + [(null? (cdr rows)) + (pk->sexpr (car rows))] + [else + (cons 'TRY (map pk->sexpr rows))])) +(define (pk->sexpr pk) + (match pk + [(pk1 pats k) + (cons 'MATCH (map pattern->sexpr pats))] + [(pk/same pat inner) + (list 'SAME (pattern->sexpr pat) (matrix->sexpr inner))] + [(pk/pair inner) + (list 'PAIR (matrix->sexpr inner))] + [(pk/and inner) + (list 'AND (matrix->sexpr inner))])) +(define (pattern->sexpr p) + (match p + [(pat:any) '_] + [(pat:integrated name pred desc _) + (format-symbol "~a:~a" (or name '_) desc)] + [(pat:svar name) + (syntax-e name)] + [(pat:var/p name parser _ _ _ _) + (cond [(and parser (regexp-match #rx"^parse-(.*)$" (symbol->string (syntax-e parser)))) + => (lambda (m) + (format-symbol "~a:~a" (or name '_) (cadr m)))] + [else + (if name (syntax-e name) '_)])] + [(? pat:literal?) `(quote ,(syntax->datum (pat:literal-id p)))] + [(pat:datum datum) datum] + [(? pat:action?) 'ACTION] + [(pat:pair head tail) + (cons (pattern->sexpr head) (pattern->sexpr tail))] + [(pat:head head tail) + (cons (pattern->sexpr head) (pattern->sexpr tail))] + [(pat:dots (list eh) tail) + (list* (pattern->sexpr eh) '... (pattern->sexpr tail))] + [(ehpat _as hpat '#f _cn) + (pattern->sexpr hpat)] + [_ 'PATTERN])) diff --git a/parse/private/parse-aux.rkt b/parse/private/parse-aux.rkt @@ -0,0 +1,21 @@ +#lang racket/base +(require (for-template "parse.rkt")) +(provide id:define-syntax-class + id:define-splicing-syntax-class + id:define-integrable-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:define-integrable-syntax-class) #'define-integrable-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/parse/private/parse.rkt b/parse/private/parse.rkt @@ -0,0 +1,1193 @@ +#lang racket/base +(require (for-syntax racket/base + syntax/stx + syntax/private/id-table + syntax/keyword + racket/syntax + "minimatch.rkt" + "rep-attrs.rkt" + "rep-data.rkt" + "rep-patterns.rkt" + "rep.rkt" + "kws.rkt" + "opt.rkt" + "txlift.rkt") + "keywords.rkt" + racket/syntax + racket/stxparam + syntax/stx + 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 + define-integrable-syntax-class + syntax-parse + syntax-parser + define/syntax-parse + syntax-parser/template + parser/rhs + define-eh-alternative-set + (for-syntax rhs->parser)) + +(begin-for-syntax + ;; constant-desc : Syntax -> String/#f + (define (constant-desc stx) + (syntax-case stx (quote) + [(quote datum) + (let ([d (syntax-e #'datum)]) + (and (string? d) d))] + [expr + (let ([d (syntax-e #'expr)]) + (and (string? d) + (free-identifier=? #'#%datum (datum->syntax #'expr '#%datum)) + d))])) + + (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)]) + (with-syntax ([name name] + [formals formals] + [desc (cond [(rhs-description the-rhs) => constant-desc] + [else (symbol->string (syntax-e name))])] + [parser (generate-temporary (format-symbol "parse-~a" name))] + [arity arity] + [attrs (rhs-attrs the-rhs)] + [commit? (rhs-commit? the-rhs)] + [delimit-cut? (rhs-delimit-cut? the-rhs)]) + #`(begin (define-syntax name + (stxclass 'name 'arity + 'attrs + (quote-syntax parser) + '#,splicing? + (scopts (length 'attrs) 'commit? 'delimit-cut? desc) + #f)) + (define-values (parser) + (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 (define-integrable-syntax-class stx) + (syntax-case stx (quote) + [(_ name (quote description) predicate) + (with-syntax ([parser (generate-temporary (format-symbol "parse-~a" (syntax-e #'name)))] + [no-arity no-arity]) + #'(begin (define-syntax name + (stxclass 'name no-arity '() + (quote-syntax parser) + #f + (scopts 0 #t #t 'description) + (quote-syntax predicate))) + (define (parser x cx pr es fh0 cp0 rl success) + (if (predicate x) + (success fh0) + (let ([es (es-add-thing pr 'description #t rl es)]) + (fh0 (failure* pr es)))))))])) + +(define-syntax (parser/rhs stx) + (syntax-case stx () + [(parser/rhs name formals relsattrs rhss splicing? ctx) + (with-disappeared-uses + (let () + (define the-rhs + (parameterize ((current-syntax-context #'ctx)) + (parse-rhs #'rhss (syntax->datum #'relsattrs) (syntax-e #'splicing?) + #:context #'ctx))) + (rhs->parser #'name #'formals #'relsattrs the-rhs (syntax-e #'splicing?) #'ctx)))])) + +(begin-for-syntax + (define (rhs->parser name formals relsattrs the-rhs splicing? [ctx #f]) + (define-values (transparent? description variants defs commit? delimit-cut?) + (match the-rhs + [(rhs _ transparent? description variants defs commit? delimit-cut?) + (values transparent? description variants defs commit? delimit-cut?)])) + (define vdefss (map variant-definitions variants)) + (define formals* (rewrite-formals formals #'x #'rl)) + (define patterns (map variant-pattern variants)) + (define no-fail? + (and (not splicing?) ;; FIXME: commit? needed? + (patterns-cannot-fail? patterns))) + (when no-fail? (log-syntax-parse-debug "(stxclass) cannot fail: ~e" ctx)) + (define body + (cond [(null? patterns) + #'(fail (failure* pr es))] + [splicing? + (with-syntax ([(alternative ...) + (for/list ([pattern (in-list patterns)]) + (with-syntax ([pattern pattern] + [relsattrs relsattrs] + [iattrs (pattern-attrs pattern)] + [commit? commit?] + [result-pr + (if transparent? + #'rest-pr + #'(ps-pop-opaque rest-pr))]) + #'(parse:H x cx rest-x rest-cx rest-pr pattern pr es + (variant-success relsattrs iattrs (rest-x rest-cx result-pr) + success cp0 commit?))))]) + #'(try alternative ...))] + [else + (with-syntax ([matrix + (optimize-matrix + (for/list ([pattern (in-list patterns)]) + (with-syntax ([iattrs (pattern-attrs pattern)] + [relsattrs relsattrs] + [commit? commit?]) + (pk1 (list pattern) + #'(variant-success relsattrs iattrs () + success cp0 commit?)))))]) + #'(parse:matrix ((x cx pr es)) matrix))])) + (with-syntax ([formals* formals*] + [(def ...) defs] + [((vdef ...) ...) vdefss] + [description (or description (symbol->string (syntax-e name)))] + [transparent? transparent?] + [delimit-cut? delimit-cut?] + [body body]) + #`(lambda (x cx pr es fh0 cp0 rl success . formals*) + (with ([this-syntax x] + [this-role rl]) + def ... + vdef ... ... + (#%expression + (syntax-parameterize ((this-context-syntax + (syntax-rules () + [(tbs) (ps-context-syntax pr)]))) + (let ([es (es-add-thing pr description 'transparent? rl + #,(if no-fail? #'#f #'es))] + [pr (if 'transparent? pr (ps-add-opaque pr))]) + (with ([fail-handler fh0] + [cut-prompt cp0]) + ;; Update the prompt, if required + ;; FIXME: can be optimized away if no cut exposed within variants + (with-maybe-delimit-cut delimit-cut? + body)))))))))) + +(define-syntax (syntax-parse stx) + (syntax-case stx () + [(syntax-parse stx-expr . clauses) + (quasisyntax/loc stx + (let ([x (datum->syntax #f stx-expr)]) + (with ([this-syntax x]) + (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)]) + (with ([this-syntax 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)]) + (with ([this-syntax x]) + (parse:clauses x clauses one-template ctx)))))])) + +(define-syntax (define/syntax-parse stx) + (syntax-case stx () + [(define/syntax-parse pattern . rest) + (with-disappeared-uses + (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 #f] + [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 protocols: + +(parse:<X> <X-args> pr es success-expr) : Ans + + <S-args> : x cx + <H-args> : x cx rest-x rest-cx rest-pr + <EH-args> : x cx ??? + <A-args> : x cx + + x is term to parse, usually syntax but can be pair/null (stx-list?) in cdr patterns + cx is most recent syntax object: if x must be coerced to syntax, use cx as lexctx and src + pr, es are progress and expectstack, respectively + rest-x, rest-cx, rest-pr are variable names to bind in context of success-expr + +(stxclass-parser x cx pr es fail-handler cut-prompt role success-proc arg ...) : Ans + + success-proc: + for stxclass, is (fail-handler attr-value ... -> Ans) + for splicing-stxclass, is (fail-handler rest-x rest-cx rest-pr attr-value -> Ans) + fail-handler, cut-prompt : failure -> Ans + +Fail-handler is normally represented with stxparam 'fail-handler', but must be +threaded through stxclass calls (in through stxclass-parser, out through +success-proc) to support backtracking. Cut-prompt is never changed within +stxclass or within alternative, so no threading needed. + +Usually sub-patterns processed in tail position, but *can* do non-tail calls for: + - ~commit + - var of stxclass with ~commit +It is also safe to keep normal tail-call protocol and just adjust fail-handler. +There is no real benefit to specializing ~commit, since it does not involve +creating a success closure. + +Some optimizations: + - commit protocol for stxclasses (but not ~commit, no point) + - avoid continue-vs-end choice point in (EH ... . ()) by eager pair check + - integrable stxclasses, specialize ellipses of integrable stxclasses + - pattern lists that cannot fail set es=#f to disable ExpectStack allocation +|# + +;; ---- + +(begin-for-syntax + (define (wash stx) + (syntax-e stx)) + (define (wash-list washer stx) + (let ([l (stx->list stx)]) + (unless l (raise-type-error 'wash-list "stx-list" stx)) + (map washer l))) + (define (wash-iattr stx) + (with-syntax ([#s(attr name depth syntax?) stx]) + (attr #'name (wash #'depth) (wash #'syntax?)))) + (define (wash-sattr stx) + (with-syntax ([#s(attr name depth syntax?) stx]) + (attr (wash #'name) (wash #'depth) (wash #'syntax?)))) + (define (wash-iattrs stx) + (wash-list wash-iattr stx)) + (define (wash-sattrs stx) + (wash-list wash-sattr stx)) + (define (generate-n-temporaries n) + (generate-temporaries + (for/list ([i (in-range n)]) + (string->symbol (format "g~sx" i)))))) + +;; ---- + +#| +Conventions: + - rhs : RHS + - iattr : IAttr + - relsattr : SAttr + - splicing? : bool + - x : id (var) + - cx : id (var, may be shadowed) + - pr : id (var, may be shadowed) + - es : id (var, may be shadowed) + - success : var (bound to success procedure) + - k : expr + - rest-x, rest-cx, rest-pr : id (to be bound) + - fh, cp, rl : id (var) +|# + +(begin-for-syntax + (define (rewrite-formals fstx x-id rl-id) + (with-syntax ([x x-id] + [rl rl-id]) + (let loop ([fstx fstx]) + (syntax-case fstx () + [([kw arg default] . more) + (keyword? (syntax-e #'kw)) + (cons #'(kw arg (with ([this-syntax x] [this-role rl]) default)) + (loop #'more))] + [([arg default] . more) + (not (keyword? (syntax-e #'kw))) + (cons #'(arg (with ([this-syntax x] [this-role rl]) default)) + (loop #'more))] + [(formal . more) + (cons #'formal (loop #'more))] + [_ fstx]))))) + +;; (with-maybe-delimit-cut bool expr) +(define-syntax with-maybe-delimit-cut + (syntax-rules () + [(wmdc #t k) + (with ([cut-prompt fail-handler]) k)] + [(wmdc #f k) + k])) + +;; (variant-success relsattrs variant (also:id ...) success bool) : expr[Ans] +(define-syntax (variant-success stx) + (syntax-case stx () + [(variant-success relsattrs iattrs (also ...) success cp0 commit?) + #`(with-maybe-reset-fail commit? cp0 + (base-success-expr iattrs relsattrs (also ...) success))])) + +;; (with-maybe-reset-fail bool id expr) +(define-syntax with-maybe-reset-fail + (syntax-rules () + [(wmrs #t cp0 k) + (with ([fail-handler cp0]) k)] + [(wmrs #f cp0 k) + k])) + +;; (base-success-expr iattrs relsattrs (also:id ...) success) : expr[Ans] +(define-syntax (base-success-expr stx) + (syntax-case stx () + [(base-success-expr iattrs relsattrs (also ...) success) + (let ([reliattrs + (reorder-iattrs (wash-sattrs #'relsattrs) + (wash-iattrs #'iattrs))]) + (with-syntax ([(#s(attr name _ _) ...) reliattrs]) + #'(success fail-handler also ... (attribute name) ...)))])) + +;; ---- + +;; (parse:clauses x clauses ctx) +(define-syntax (parse:clauses stx) + (syntax-case stx () + [(parse:clauses x clauses body-mode ctx) + ;; if templates? is true, expect one form after kwargs in clause, wrap it with syntax + ;; otherwise, expect non-empty body sequence (defs and exprs) + (with-disappeared-uses + (with-txlifts + (lambda () + (define who + (syntax-case #'ctx () + [(m . _) (identifier? #'m) #'m] + [_ 'syntax-parse])) + (define-values (chunks clauses-stx) + (parse-keyword-options #'clauses parse-directive-table + #:context #'ctx + #:no-duplicates? #t)) + (define context + (options-select-value chunks '#:context #:default #'x)) + (define colon-notation? + (not (assq '#:disable-colon-notation chunks))) + (define-values (decls0 defs) + (get-decls+defs chunks #t #:context #'ctx)) + ;; for-clause : stx -> (values pattern stx (listof stx)) + (define (for-clause clause) + (syntax-case clause () + [[p . rest] + (let-values ([(rest pattern defs2) + (parameterize ((stxclass-colon-notation? colon-notation?)) + (parse-pattern+sides #'p #'rest + #:splicing? #f + #:decls decls0 + #:context #'ctx))]) + (let ([body-expr + (case (syntax-e #'body-mode) + ((one-template) + (syntax-case rest () + [(template) + #'(syntax template)] + [_ (raise-syntax-error #f "expected exactly one template" #'ctx)])) + ((body-sequence) + (syntax-case rest () + [(e0 e ...) #'(let () e0 e ...)] + [_ (raise-syntax-error #f "expected non-empty clause body" + #'ctx clause)])) + (else + (raise-syntax-error #f "internal error: unknown body mode" #'ctx #'body-mode)))]) + (values pattern body-expr defs2)))] + [_ (raise-syntax-error #f "expected clause" #'ctx clause)])) + (unless (stx-list? clauses-stx) + (raise-syntax-error #f "expected sequence of clauses" #'ctx)) + (define-values (patterns body-exprs defs2s) + (for/lists (patterns body-exprs defs2s) ([clause (in-list (stx->list clauses-stx))]) + (for-clause clause))) + (define no-fail? (patterns-cannot-fail? patterns)) + (when no-fail? (log-syntax-parse-debug "cannot fail: ~e" #'ctx)) + (with-syntax ([(def ...) (apply append (get-txlifts-as-definitions) defs defs2s)]) + #`(let* ([ctx0 (normalize-context '#,who #,context x)] + [pr (ps-empty x (cadr ctx0))] + [es #,(if no-fail? #'#f #'#t)] + [cx x] + [fh0 (syntax-patterns-fail ctx0)]) + def ... + (parameterize ((current-syntax-context (cadr ctx0))) + (with ([fail-handler fh0] + [cut-prompt fh0]) + #,(cond [(pair? patterns) + (with-syntax ([matrix + (optimize-matrix + (for/list ([pattern (in-list patterns)] + [body-expr (in-list body-exprs)]) + (pk1 (list pattern) body-expr)))]) + #'(parse:matrix ((x cx pr es)) matrix)) + #| + (with-syntax ([(alternative ...) + (for/list ([pattern (in-list patterns)] + [body-expr (in-list body-exprs)]) + #`(parse:S x cx #,pattern pr es #,body-expr))]) + #`(try alternative ...)) + |#] + [else + #`(fail (failure* pr es))]))))))))])) + +;; ---- + +;; (parse:matrix ((x cx pr es) ...) (PK ...)) : expr[Ans] +;; (parse:matrix (in1 ... inN) (#s(pk1 (P11 ... P1N) e1) ... #s(pk1 (PM1 ... PMN) eM))) +;; represents the matching matrix +;; [_in1_..._inN_|____] +;; [ P11 ... P1N | e1 ] +;; [ ⋮ ⋮ | ⋮ ] +;; [ PM1 ... PMN | eM ] + +(define-syntax (parse:matrix stx) + (syntax-case stx () + [(parse:matrix ins (pk ...)) + #'(try (parse:pk ins pk) ...)])) + +(define-syntax (parse:pk stx) + (syntax-case stx () + [(parse:pk () #s(pk1 () k)) + #'k] + [(parse:pk ((x cx pr es) . ins) #s(pk1 (pat1 . pats) k)) + #'(parse:S x cx pat1 pr es (parse:pk ins #s(pk1 pats k)))] + [(parse:pk ((x cx pr es) . ins) #s(pk/same pat1 inner)) + #'(parse:S x cx pat1 pr es (parse:matrix ins inner))] + [(parse:pk ((x cx pr es) . ins) #s(pk/pair inner)) + #'(let-values ([(datum tcx) + (if (syntax? x) + (values (syntax-e x) x) + (values x cx))]) + (if (pair? datum) + (let ([hx (car datum)] + [hcx (car datum)] + [hpr (ps-add-car pr)] + [tx (cdr datum)] + [tpr (ps-add-cdr pr)]) + (parse:matrix ((hx hcx hpr es) (tx tcx tpr es) . ins) inner)) + (let ([es* (if (null? datum) (es-add-proper-pair (first-desc:matrix inner) es) es)]) + (fail (failure* pr es*)))))] + [(parse:pk (in1 . ins) #s(pk/and inner)) + #'(parse:matrix (in1 in1 . ins) inner)])) + +(define-syntax (first-desc:matrix stx) + (syntax-case stx () + [(fdm (#s(pk1 (pat1 . pats) k))) + #'(first-desc:S pat1)] + [(fdm (#s(pk/same pat1 pks))) + #'(first-desc:S pat1)] + [(fdm (pk ...)) ;; FIXME + #'#f])) + +;; ---- + +;; (parse:S x cx S-pattern pr es k) : expr[Ans] +;; In k: attrs(S-pattern) are bound. +(define-syntax (parse:S stx) + (syntax-case stx () + [(parse:S x cx pattern0 pr es k) + (syntax-case #'pattern0 () + [#s(internal-rest-pattern rest-x rest-cx rest-pr) + #`(let ([rest-x x] + [rest-cx cx] + [rest-pr pr]) + k)] + [#s(pat:any) + #'k] + [#s(pat:svar name) + #'(let-attributes ([#s(attr name 0 #t) (datum->syntax cx x cx)]) + k)] + [#s(pat:var/p name parser argu (nested-a ...) role + #s(scopts attr-count commit? _delimit? _desc)) + (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))] + [(name-attr ...) + (if (identifier? #'name) + #'([#s(attr name 0 #t) (datum->syntax cx x cx)]) + #'())]) + (if (not (syntax-e #'commit?)) + ;; The normal protocol + #'(app-argu parser x cx pr es fail-handler cut-prompt role + (lambda (fh av ...) + (let-attributes (name-attr ...) + (let-attributes* ((nested-a ...) (av ...)) + (with ([fail-handler fh]) + k)))) + argu) + ;; The commit protocol + ;; (Avoids putting k in procedure) + #'(let-values ([(fs av ...) + (with ([fail-handler (lambda (fs) (values fs (let ([av #f]) av) ...))]) + (with ([cut-prompt fail-handler]) + (app-argu parser x cx pr es fail-handler cut-prompt role + (lambda (fh av ...) (values #f av ...)) + argu)))]) + (if fs + (fail fs) + (let-attributes (name-attr ...) + (let-attributes* ((nested-a ...) (av ...)) + k))))))] + [#s(pat:reflect obj argu attr-decls name (nested-a ...)) + (with-syntax ([(name-attr ...) + (if (identifier? #'name) + #'([#s(attr name 0 #t) (datum->syntax cx x cx)]) + #'())]) + (with-syntax ([arity (arguments->arity (syntax->datum #'argu))]) + #'(let ([parser (reflect-parser obj 'arity 'attr-decls #f)]) + (app-argu parser x cx pr es fail-handler cut-prompt #f + (lambda (fh . result) + (let-attributes (name-attr ...) + (let/unpack ((nested-a ...) result) + (with ([fail-handler fh]) + k)))) + argu))))] + [#s(pat:datum datum) + (with-syntax ([unwrap-x + (if (atomic-datum-stx? #'datum) + #'(if (syntax? x) (syntax-e x) x) + #'(syntax->datum (datum->syntax #f x)))]) + #`(let ([d unwrap-x]) + (if (equal? d (quote datum)) + k + (fail (failure* pr (es-add-atom 'datum es))))))] + [#s(pat:literal literal input-phase lit-phase) + #`(if (and (identifier? x) + (free-identifier=? x (quote-syntax literal) input-phase lit-phase)) + k + (fail (failure* pr (es-add-literal (quote-syntax literal) es))))] + [#s(pat:action action subpattern) + #'(parse:A x cx action pr es (parse:S x cx subpattern pr es k))] + [#s(pat:head head tail) + #`(parse:H x cx rest-x rest-cx rest-pr head pr es + (parse:S rest-x rest-cx tail rest-pr es k))] + [#s(pat:dots head tail) + #`(parse:dots x cx head tail pr es k)] + [#s(pat:and subpatterns) + (for/fold ([k #'k]) ([subpattern (in-list (reverse (syntax->list #'subpatterns)))]) + #`(parse:S x cx #,subpattern pr es #,k))] + [#s(pat:or (a ...) (subpattern ...) (subattrs ...)) + (with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) + #`(let ([success + (lambda (fh id ...) + (let-attributes ([a id] ...) + (with ([fail-handler fh]) + k)))]) + (try (parse:S x cx subpattern pr es + (disjunct subattrs success () (id ...))) + ...)))] + [#s(pat:not subpattern) + #`(let* ([fh0 fail-handler] + [pr0 pr] + [es0 es] + [fail-to-succeed + (lambda (fs) k)]) + ;; ~not implicitly prompts to be safe, + ;; but ~! not allowed within ~not (unless within ~delimit-cut, etc) + ;; (statically checked!) + (with ([fail-handler fail-to-succeed] + [cut-prompt fail-to-succeed]) ;; to be safe + (parse:S x cx subpattern pr es + (fh0 (failure* pr0 es0)))))] + [#s(pat:pair head tail) + #`(let ([datum (if (syntax? x) (syntax-e x) x)] + [cx (if (syntax? x) x cx)]) ;; FIXME: shadowing cx?! + (if (pair? datum) + (let ([hx (car datum)] + [hcx (car datum)] + [hpr (ps-add-car pr)] + [tx (cdr datum)] + [tpr (ps-add-cdr pr)]) + (parse:S hx hcx head hpr es + (parse:S tx cx tail tpr es k))) + (let ([es* (if (null? datum) (es-add-proper-pair (first-desc:S head) es) es)]) + (fail (failure* pr es*)))))] + [#s(pat:vector subpattern) + #`(let ([datum (if (syntax? x) (syntax-e x) x)]) + (if (vector? datum) + (let ([datum (vector->list datum)] + [vcx (if (syntax? x) x cx)] ;; FIXME: (vector? datum) => (syntax? x) ??? + [pr* (ps-add-unvector pr)]) + (parse:S datum vcx subpattern pr* es k)) + (fail (failure* pr es))))] + [#s(pat:box subpattern) + #`(let ([datum (if (syntax? x) (syntax-e x) x)]) + (if (box? datum) + (let ([datum (unbox datum)] + [bcx (if (syntax? x) x cx)] ;; FIXME: (box? datum) => (syntax? x) ??? + [pr* (ps-add-unbox pr)]) + (parse:S datum bcx subpattern pr* es k)) + (fail (failure* pr es))))] + [#s(pat:pstruct key subpattern) + #`(let ([datum (if (syntax? x) (syntax-e x) x)]) + (if (let ([xkey (prefab-struct-key datum)]) + (and xkey (equal? xkey 'key))) + (let ([datum (cdr (vector->list (struct->vector datum)))] + [scx (if (syntax? x) x cx)] ;; FIXME: (struct? datum) => (syntax? x) ??? + [pr* (ps-add-unpstruct pr)]) + (parse:S datum scx subpattern pr* es k)) + (fail (failure* pr es))))] + [#s(pat:describe pattern description transparent? role) + #`(let ([es* (es-add-thing pr description transparent? role es)] + [pr* (if 'transparent? pr (ps-add-opaque pr))]) + (parse:S x cx pattern pr* es* k))] + [#s(pat:delimit pattern) + #`(let ([cp0 cut-prompt]) + (with ([cut-prompt fail-handler]) + (parse:S x cx pattern pr es (with ([cut-prompt cp0]) k))))] + [#s(pat:commit pattern) + #`(let ([fh0 fail-handler] + [cp0 cut-prompt]) + (with ([cut-prompt fh0]) + (parse:S x cx pattern pr es + (with ([cut-prompt cp0] + [fail-handler fh0]) + k))))] + [#s(pat:ord pattern group index) + #`(let ([pr* (ps-add pr '#s(ord group index))]) + (parse:S x cx pattern pr* es k))] + [#s(pat:post pattern) + #`(let ([pr* (ps-add-post pr)]) + (parse:S x cx pattern pr* es k))] + [#s(pat:integrated name predicate description role) + (with-syntax ([(name-attr ...) + (if (identifier? #'name) + #'([#s(attr name 0 #t) x*]) + #'())]) + #'(let ([x* (datum->syntax cx x cx)]) + (if (predicate x*) + (let-attributes (name-attr ...) k) + (let ([es* (es-add-thing pr 'description #t role es)]) + (fail (failure* pr es*))))))])])) + +;; (first-desc:S S-pattern) : expr[FirstDesc] +(define-syntax (first-desc:S stx) + (syntax-case stx () + [(fds p) + (syntax-case #'p () + [#s(pat:any) + #''(any)] + [#s(pat:svar name) + #''(any)] + [#s(pat:var/p _ _ _ _ _ #s(scopts _ _ _ desc)) + #'(quote desc)] + [#s(pat:datum d) + #''(datum d)] + [#s(pat:literal id _ip _lp) + #''(literal id)] + [#s(pat:describe _p desc _t? _role) + #`(quote #,(or (constant-desc #'desc) #'#f))] + [#s(pat:delimit pattern) + #'(first-desc:S pattern)] + [#s(pat:commit pattern) + #'(first-desc:S pattern)] + [#s(pat:ord pattern _ _) + #'(first-desc:S pattern)] + [#s(pat:post pattern) + #'(first-desc:S pattern)] + [#s(pat:integrated _name _pred description _role) + #''description] + [_ #'#f])])) + +;; (first-desc:H HeadPattern) : Expr +(define-syntax (first-desc:H stx) + (syntax-case stx () + [(fdh hpat) + (syntax-case #'hpat () + [#s(hpat:var/p _ _ _ _ _ #s(scopts _ _ _ desc)) #'(quote desc)] + [#s(hpat:seq lp) #'(first-desc:L lp)] + [#s(hpat:describe _hp desc _t? _r) + #`(quote #,(or (constant-desc #'desc) #'#f))] + [#s(hpat:delimit hp) #'(first-desc:H hp)] + [#s(hpat:commit hp) #'(first-desc:H hp)] + [#s(hpat:ord hp _ _) #'(first-desc:H hp)] + [#s(hpat:post hp) #'(first-desc:H hp)] + [_ #'(first-desc:S hpat)])])) + +(define-syntax (first-desc:L stx) + (syntax-case stx () + [(fdl lpat) + (syntax-case #'lpat () + [#s(pat:pair sp lp) #'(first-desc:S sp)] + [_ #'#f])])) + +;; (disjunct (iattr ...) success (pre:expr ...) (id:id ...)) : expr[Ans] +(define-syntax (disjunct stx) + (syntax-case stx () + [(disjunct (#s(attr sub-id _ _) ...) success (pre ...) (id ...)) + (with-syntax ([(alt-sub-id ...) (generate-temporaries #'(sub-id ...))]) + #`(let ([alt-sub-id (attribute sub-id)] ...) + (let ([id #f] ...) + (let ([sub-id alt-sub-id] ...) + (success fail-handler pre ... id ...)))))])) + +;; (parse:A x cx A-pattern pr es k) : expr[Ans] +;; In k: attrs(A-pattern) are bound. +(define-syntax (parse:A stx) + (syntax-case stx () + [(parse:A x cx pattern0 pr es k) + (syntax-case #'pattern0 () + [#s(action:and (action ...)) + (for/fold ([k #'k]) ([action (in-list (reverse (syntax->list #'(action ...))))]) + #`(parse:A x cx #,action pr es #,k))] + [#s(action:cut) + #'(with ([fail-handler cut-prompt]) k)] + [#s(action:bind a expr) + #'(let-attributes ([a (wrap-user-code expr)]) k)] + [#s(action:fail condition message) + #`(let ([c (wrap-user-code condition)]) + (if c + (let ([pr* (if (syntax? c) (ps-add-stx pr c) pr)] + [es* (es-add-message message es)]) + (fail (failure* pr* es*))) + k))] + [#s(action:parse pattern expr) + #`(let* ([y (datum->syntax/with-clause (wrap-user-code expr))] + [cy y] + [pr* (ps-add-stx pr y)]) + (parse:S y cy pattern pr* es k))] + [#s(action:do (stmt ...)) + #'(let () (no-shadow stmt) ... (#%expression k))] + [#s(action:ord pattern group index) + #'(let ([pr* (ps-add pr '#s(ord group index))]) + (parse:A x cx pattern pr* es k))] + [#s(action:post pattern) + #'(let ([pr* (ps-add-post pr)]) + (parse:A x cx pattern pr* es k))])])) + +(begin-for-syntax + ;; convert-list-pattern : ListPattern id -> SinglePattern + ;; Converts '() datum pattern at end of list to bind (cons stx index) + ;; to rest-var. + (define (convert-list-pattern pattern end-pattern) + (syntax-case pattern () + [#s(pat:datum ()) + end-pattern] + [#s(pat:action action tail) + (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) + #'#s(pat:action action tail))] + [#s(pat:head head tail) + (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) + #'#s(pat:head head tail))] + [#s(pat:dots head tail) + (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) + #'#s(pat:dots head tail))] + [#s(pat:pair head-part tail-part) + (with-syntax ([tail-part (convert-list-pattern #'tail-part end-pattern)]) + #'#s(pat:pair head-part tail-part))]))) + +;; (parse:H x cx rest-x rest-cx rest-pr H-pattern pr es k) +;; In k: rest, rest-pr, attrs(H-pattern) are bound. +(define-syntax (parse:H stx) + (syntax-case stx () + [(parse:H x cx rest-x rest-cx rest-pr head pr es k) + (syntax-case #'head () + [#s(hpat:describe pattern description transparent? role) + #`(let ([es* (es-add-thing pr description transparent? role es)] + [pr* (if 'transparent? pr (ps-add-opaque pr))]) + (parse:H x cx rest-x rest-cx rest-pr pattern pr* es* + (let ([rest-pr (if 'transparent? rest-pr (ps-pop-opaque rest-pr))]) + k)))] + [#s(hpat:var/p name parser argu (nested-a ...) role + #s(scopts attr-count commit? _delimit? _desc)) + (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))] + [(name-attr ...) + (if (identifier? #'name) + #'([#s(attr name 0 #t) + (stx-list-take x (ps-difference pr rest-pr))]) + #'())]) + (if (not (syntax-e #'commit?)) + ;; The normal protocol + #`(app-argu parser x cx pr es fail-handler cut-prompt role + (lambda (fh rest-x rest-cx rest-pr av ...) + (let-attributes (name-attr ...) + (let-attributes* ((nested-a ...) (av ...)) + (with ([fail-handler fh]) + k)))) + argu) + ;; The commit protocol + ;; (Avoids putting k in procedure) + #'(let-values ([(fs rest-x rest-cx rest-pr av ...) + (with ([fail-handler (lambda (fs) (values fs #f #f #f (let ([av #f]) av) ...))]) + (with ([cut-prompt fail-handler]) + (app-argu parser x cx pr es fail-handler cut-prompt role + (lambda (fh rest-x rest-cx rest-pr av ...) + (values #f rest-x rest-cx rest-pr av ...)) + argu)))]) + (if fs + (fail fs) + (let-attributes (name-attr ...) + (let-attributes* ((nested-a ...) (av ...)) + k))))))] + [#s(hpat:reflect obj argu attr-decls name (nested-a ...)) + (with-syntax ([(name-attr ...) + (if (identifier? #'name) + #'([#s(attr name 0 #t) + (stx-list-take x (ps-difference pr rest-pr))]) + #'())]) + (with-syntax ([arity (arguments->arity (syntax->datum #'argu))]) + #'(let ([parser (reflect-parser obj 'arity 'attr-decls #t)]) + (app-argu parser x cx pr es fail-handler cut-prompt #f + (lambda (fh rest-x rest-cx rest-pr . result) + (let-attributes (name-attr ...) + (let/unpack ((nested-a ...) result) + (with ([fail-handler fh]) + k)))) + argu))))] + [#s(hpat:and head single) + #`(let ([cx0 cx]) + (parse:H x cx rest-x rest-cx rest-pr head pr es + (let ([lst (stx-list-take x (ps-difference pr rest-pr))]) + (parse:S lst cx0 single pr es k))))] + [#s(hpat:or (a ...) (subpattern ...) (subattrs ...)) + (with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) + #`(let ([success + (lambda (fh rest-x rest-cx rest-pr id ...) + (let-attributes ([a id] ...) + (with ([fail-handler fh]) + k)))]) + (try (parse:H x cx rest-x rest-cx rest-pr subpattern pr es + (disjunct subattrs success (rest-x rest-cx rest-pr) (id ...))) + ...)))] + [#s(hpat:seq pattern) + (with-syntax ([pattern + (convert-list-pattern + #'pattern + #'#s(internal-rest-pattern rest-x rest-cx rest-pr))]) + #'(parse:S x cx pattern pr es k))] + [#s(hpat:action action subpattern) + #'(parse:A x cx action pr es (parse:H x cx rest-x rest-cx rest-pr subpattern pr es k))] + [#s(hpat:delimit pattern) + #'(let ([cp0 cut-prompt]) + (with ([cut-prompt fail-handler]) + (parse:H x cx rest-x rest-cx rest-pr pattern pr es + (with ([cut-prompt cp0]) k))))] + [#s(hpat:commit pattern) + #`(let ([fh0 fail-handler] + [cp0 cut-prompt]) + (with ([cut-prompt fh0]) + (parse:H x cx rest-x rest-cx rest-pr pattern pr es + (with ([cut-prompt cp0] + [fail-handler fh0]) + k))))] + [#s(hpat:ord pattern group index) + #`(let ([pr* (ps-add pr '#s(ord group index))]) + (parse:H x cx rest-x rest-cx rest-pr pattern pr* es + (let ([rest-pr (ps-pop-ord rest-pr)]) k)))] + [#s(hpat:post pattern) + #'(let ([pr* (ps-add-post pr)]) + (parse:H x cx rest-x rest-cx rest-pr pattern pr* es + (let ([rest-pr (ps-pop-post rest-pr)]) k)))] + [#s(hpat:peek pattern) + #`(let ([saved-x x] [saved-cx cx] [saved-pr pr]) + (parse:H x cx dummy-x dummy-cx dummy-pr pattern pr es + (let ([rest-x saved-x] [rest-cx saved-cx] [rest-pr saved-pr]) + k)))] + [#s(hpat:peek-not subpattern) + #`(let* ([fh0 fail-handler] + [pr0 pr] + [es0 es] + [fail-to-succeed + (lambda (fs) + (let ([rest-x x] + [rest-cx cx] + [rest-pr pr]) + k))]) + ;; ~not implicitly prompts to be safe, + ;; but ~! not allowed within ~not (unless within ~delimit-cut, etc) + ;; (statically checked!) + (with ([fail-handler fail-to-succeed] + [cut-prompt fail-to-succeed]) ;; to be safe + (parse:H x cx rest-x rest-cx rest-pr subpattern pr es + (fh0 (failure* pr0 es0)))))] + [_ + #'(parse:S x cx + ;; FIXME: consider proper-list-pattern? (yes is consistent with ~seq) + #s(pat:pair head #s(internal-rest-pattern rest-x rest-cx rest-pr)) + pr es k)])])) + +;; (parse:dots x cx EH-pattern S-pattern pr es k) : expr[Ans] +;; In k: attrs(EH-pattern, S-pattern) are bound. +(define-syntax (parse:dots stx) + (syntax-case stx () + ;; == Specialized cases + ;; -- (x ... . ()) + [(parse:dots x cx (#s(ehpat (attr0) #s(pat:svar name) #f #f)) + #s(pat:datum ()) pr es k) + #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es void #f #f)]) + (case status + ((ok) (let-attributes ([attr0 result]) k)) + (else (fail result))))] + ;; -- (x:sc ... . ()) where sc is an integrable stxclass like id or expr + [(parse:dots x cx (#s(ehpat (attr0) #s(pat:integrated _name pred? desc role) #f #f)) + #s(pat:datum ()) pr es k) + #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es pred? desc role)]) + (case status + ((ok) (let-attributes ([attr0 result]) k)) + (else (fail result))))] + ;; -- (x:sc ... . ()) where sc is a stxclass with commit + ;; Since head pattern does commit, no need to thread fail-handler, cut-prompt through. + ;; Microbenchmark suggests this isn't a useful specialization + ;; (probably try-or-pair/null-check already does the useful part) + ;; == General case + [(parse:dots x cx (#s(ehpat head-attrs head head-repc check-null?) ...) tail pr es k) + (let () + (define repcs (wash-list wash #'(head-repc ...))) + (define rep-ids (for/list ([repc (in-list repcs)]) + (and repc (generate-temporary 'rep)))) + (define rel-repcs (filter values repcs)) + (define rel-rep-ids (filter values rep-ids)) + (define rel-heads (for/list ([head (in-list (syntax->list #'(head ...)))] + [repc (in-list repcs)] + #:when repc) + head)) + (define aattrs + (for/list ([head-attrs (in-list (syntax->list #'(head-attrs ...)))] + [repc (in-list repcs)] + #:when #t + [a (in-list (wash-iattrs head-attrs))]) + (cons a repc))) + (define attrs (map car aattrs)) + (define attr-repcs (map cdr aattrs)) + (define ids (map attr-name attrs)) + (define tail-pattern-is-null? (equal? (syntax->datum #'tail) '#s(pat:datum ()))) + (with-syntax ([(id ...) ids] + [(alt-id ...) (generate-temporaries ids)] + [reps rel-rep-ids] + [(head-rep ...) rep-ids] + [(rel-rep ...) rel-rep-ids] + [(rel-repc ...) rel-repcs] + [(rel-head ...) rel-heads] + [(a ...) attrs] + [(attr-repc ...) attr-repcs] + [do-pair/null? + ;; FIXME: do pair/null check only if no nullable head patterns + ;; (and tail-pattern-is-null? (andmap not (syntax->datum #'(nullable? ...)))) + tail-pattern-is-null?]) + (define/with-syntax alt-map #'((id . alt-id) ...)) + (define/with-syntax loop-k + #'(dots-loop dx* dcx* loop-pr* fail-handler rel-rep ... alt-id ...)) + #`(let () + ;; dots-loop : stx progress rel-rep ... alt-id ... -> Ans + (define (dots-loop dx dcx loop-pr fh rel-rep ... alt-id ...) + (with ([fail-handler fh]) + (try-or-pair/null-check do-pair/null? dx dcx loop-pr es + (try (parse:EH dx dcx loop-pr head-attrs check-null? head-repc dx* dcx* loop-pr* + alt-map head-rep head es loop-k) + ...) + (cond [(< rel-rep (rep:min-number rel-repc)) + (let ([es (expectation-of-reps/too-few es rel-rep rel-repc rel-head)]) + (fail (failure* loop-pr es)))] + ... + [else + (let-attributes ([a (rep:finalize a attr-repc alt-id)] ...) + (parse:S dx dcx tail loop-pr es k))])))) + (let ([rel-rep 0] ... + [alt-id (rep:initial-value attr-repc)] ...) + (dots-loop x cx pr fail-handler rel-rep ... alt-id ...)))))])) + +;; (try-or-pair/null-check bool x cx es pr pair-alt maybe-null-alt) +(define-syntax try-or-pair/null-check + (syntax-rules () + [(topc #t x cx pr es pair-alt null-alt) + (cond [(stx-pair? x) pair-alt] + [(stx-null? x) null-alt] + [else (fail (failure* pr es))])] + [(topc _ x cx pr es alt1 alt2) + (try alt1 alt2)])) + +;; (parse:EH x cx pr repc x* cx* pr* alts rep H-pattern es k) : expr[Ans] +;; In k: x*, cx*, pr*, alts`attrs(H-pattern) are bound and rep is shadowed. +(define-syntax (parse:EH stx) + (syntax-case stx () + [(parse:EH x cx pr attrs check-null? repc x* cx* pr* alts rep head es k) + (let () + (define/with-syntax k* + (let* ([main-attrs (wash-iattrs #'attrs)] + [ids (map attr-name main-attrs)] + [alt-ids + (let ([table (make-bound-id-table)]) + (for ([entry (in-list (syntax->list #'alts))]) + (let ([entry (syntax-e entry)]) + (bound-id-table-set! table (car entry) (cdr entry)))) + (for/list ([id (in-list ids)]) (bound-id-table-ref table id)))]) + (with-syntax ([(id ...) ids] + [(alt-id ...) alt-ids]) + #`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...) + #,(if (syntax->datum #'check-null?) + #'(if (zero? (ps-difference pr pr*)) (error/null-eh-match) k) + #'k))))) + (syntax-case #'repc () + [#f #`(parse:H x cx x* cx* pr* head pr es k*)] + [_ #`(parse:H x cx x* cx* pr* head pr es + (if (< rep (rep:max-number repc)) + (let ([rep (add1 rep)]) k*) + (let ([es* (expectation-of-reps/too-many es rep repc)]) + (fail (failure* pr* es*)))))]))])) + +;; (rep:initial-value RepConstraint) : expr +(define-syntax (rep:initial-value stx) + (syntax-case stx () + [(_ #s(rep:once _ _ _)) #'#f] + [(_ #s(rep:optional _ _ _)) #'#f] + [(_ _) #'null])) + +;; (rep:finalize RepConstraint expr) : expr +(define-syntax (rep:finalize stx) + (syntax-case stx () + [(_ a #s(rep:optional _ _ defaults) v) + (with-syntax ([#s(attr name _ _) #'a] + [(#s(action:bind da de) ...) #'defaults]) + (let ([default + (for/or ([da (in-list (syntax->list #'(da ...)))] + [de (in-list (syntax->list #'(de ...)))]) + (with-syntax ([#s(attr dname _ _) da]) + (and (bound-identifier=? #'name #'dname) de)))]) + (if default + #`(or v #,default) + #'v)))] + [(_ a #s(rep:once _ _ _) v) #'v] + [(_ a _ v) #'(reverse v)])) + +;; (rep:min-number RepConstraint) : expr +(define-syntax (rep:min-number stx) + (syntax-case stx () + [(_ #s(rep:once _ _ _)) #'1] + [(_ #s(rep:optional _ _ _)) #'0] + [(_ #s(rep:bounds min max _ _ _)) #'min])) + +;; (rep:max-number RepConstraint) : expr +(define-syntax (rep:max-number stx) + (syntax-case stx () + [(_ #s(rep:once _ _ _)) #'1] + [(_ #s(rep:optional _ _ _)) #'1] + [(_ #s(rep:bounds min max _ _ _)) #'max])) + +;; (rep:combine RepConstraint expr expr) : expr +(define-syntax (rep:combine stx) + (syntax-case stx () + [(_ #s(rep:once _ _ _) a b) #'a] + [(_ #s(rep:optional _ _ _) a b) #'a] + [(_ _ a b) #'(cons a b)])) + +;; ---- + +(define-syntax expectation-of-reps/too-few + (syntax-rules () + [(_ es rep #s(rep:once name too-few-msg too-many-msg) hpat) + (cond [(or too-few-msg (name->too-few/once name)) + => (lambda (msg) (es-add-message msg es))] + [(first-desc:H hpat) => (lambda (fd) (es-add-proper-pair fd es))] + [else es])] + [(_ es rep #s(rep:optional name too-many-msg _) hpat) + (error 'syntax-parse "INTERNAL ERROR: impossible (too-few)")] + [(_ es rep #s(rep:bounds min max name too-few-msg too-many-msg) hpat) + (cond [(or too-few-msg (name->too-few name)) + => (lambda (msg) (es-add-message msg es))] + [(first-desc:H hpat) => (lambda (fd) (es-add-proper-pair fd es))] + [else es])])) + +(define-syntax expectation-of-reps/too-many + (syntax-rules () + [(_ es rep #s(rep:once name too-few-msg too-many-msg)) + (es-add-message (or too-many-msg (name->too-many name)) es)] + [(_ es rep #s(rep:optional name too-many-msg _)) + (es-add-message (or too-many-msg (name->too-many name)) es)] + [(_ es rep #s(rep:bounds min max name too-few-msg too-many-msg)) + (es-add-message (or too-many-msg (name->too-many name)) es)])) + +;; ==== + +(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 + ;; repc structs are prefab; recreate using prefab + ;; quasiquote exprs to avoid moving constructors + ;; to residual module + (syntax-case (eh-alternative-repc alt) () + [#f + #''#f] + [#s(rep:once n u o) + #'`#s(rep:once ,(quote-syntax n) + ,(quote-syntax u) + ,(quote-syntax o))] + [#s(rep:optional n o d) + #'`#s(rep:optional ,(quote-syntax n) + ,(quote-syntax o) + ,(quote-syntax d))] + [#s(rep:bounds min max n u o) + #'`#s(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/parse/private/rep-attrs.rkt b/parse/private/rep-attrs.rkt @@ -0,0 +1,194 @@ +#lang racket/base +(require syntax/parse/private/residual-ct ;; keep abs. path + racket/contract/base + syntax/private/id-table + racket/syntax + "make.rkt") + +#| +An IAttr is (make-attr identifier number boolean) +An SAttr is (make-attr symbol number boolean) + +The number is the ellipsis nesting depth. The boolean is true iff the +attr is guaranteed to be bound to a value which is a syntax object (or +a list^depth of syntax objects). +|# + +#| +SAttr lists are always stored in sorted order, to make comparison +of signatures easier for reified syntax-classes. +|# + +(define (iattr? a) + (and (attr? a) (identifier? (attr-name a)))) + +(define (sattr? a) + (and (attr? a) (symbol? (attr-name a)))) + +;; increase-depth : Attr -> Attr +(define (increase-depth x) + (make attr (attr-name x) (add1 (attr-depth x)) (attr-syntax? x))) + +(provide/contract + [iattr? (any/c . -> . boolean?)] + [sattr? (any/c . -> . boolean?)] + + [increase-depth + (-> attr? attr?)] + [attr-make-uncertain + (-> attr? attr?)] + + ;; IAttr operations + [append-iattrs + (-> (listof (listof iattr?)) + (listof iattr?))] + [union-iattrs + (-> (listof (listof iattr?)) + (listof iattr?))] + [reorder-iattrs + (-> (listof sattr?) (listof iattr?) + (listof iattr?))] + + ;; SAttr operations + [iattr->sattr + (-> iattr? + sattr?)] + [iattrs->sattrs + (-> (listof iattr?) + (listof sattr?))] + [sort-sattrs + (-> (listof sattr?) + (listof sattr?))] + + [intersect-sattrss + (-> (listof (listof sattr?)) + (listof sattr?))] + + [check-iattrs-subset + (-> (listof iattr?) + (listof iattr?) + (or/c syntax? false/c) + any)]) + +;; IAttr operations + +;; append-iattrs : (listof (listof IAttr)) -> (listof IAttr) +(define (append-iattrs attrss) + (let* ([all (apply append attrss)] + [names (map attr-name all)] + [dup (check-duplicate-identifier names)]) + (when dup + (wrong-syntax dup "duplicate attribute")) + all)) + +;; union-iattrs : (listof (listof IAttr)) -> (listof IAttr) +(define (union-iattrs attrss) + (define count-t (make-bound-id-table)) + (define attr-t (make-bound-id-table)) + (define list-count (length attrss)) + (define attr-keys null) + (for* ([attrs (in-list attrss)] [attr (in-list attrs)]) + (define name (attr-name attr)) + (define prev (bound-id-table-ref attr-t name #f)) + (unless prev (set! attr-keys (cons name attr-keys))) + (bound-id-table-set! attr-t name (join-attrs attr prev)) + (let ([pc (bound-id-table-ref count-t name 0)]) + (bound-id-table-set! count-t name (add1 pc)))) + (for/list ([k (in-list attr-keys)]) + (define a (bound-id-table-ref attr-t k)) + (if (= (bound-id-table-ref count-t (attr-name a)) list-count) + a + (attr-make-uncertain a)))) + +;; join-attrs : Attr Attr/#f -> Attr +;; Works with both IAttrs and SAttrs. +;; Assumes attrs have same name. +(define (join-attrs a b) + (if (and a b) + (proper-join-attrs a b) + (or a b))) + +(define (proper-join-attrs a b) + (let ([aname (attr-name a)]) + (unless (equal? (attr-depth a) (attr-depth b)) + (wrong-syntax (and (syntax? aname) aname) + "attribute '~a' occurs with different nesting depth" + (if (syntax? aname) (syntax-e aname) aname))) + (make attr aname (attr-depth a) (and (attr-syntax? a) (attr-syntax? b))))) + +(define (attr-make-uncertain a) + (make attr (attr-name a) (attr-depth a) #f)) + +(define (iattr->sattr a) + (let ([name (attr-name a)] + [depth (attr-depth a)] + [syntax? (attr-syntax? a)]) + (make attr (syntax-e name) depth syntax?))) + +(define (iattrs->sattrs as) + (sort-sattrs (map iattr->sattr as))) + +(define (sort-sattrs as) + (sort as string<? + #:key (lambda (a) (symbol->string (attr-name a))) + #:cache-keys? #t)) + +;; intersect-sattrss : (listof (listof SAttr)) -> (listof SAttr) +;; FIXME: rely on sorted inputs, simplify algorithm and avoid second sort? +(define (intersect-sattrss attrss) + (cond [(null? attrss) null] + [else + (let* ([namess (map (lambda (attrs) (map attr-name attrs)) attrss)] + [names (filter (lambda (s) + (andmap (lambda (names) (memq s names)) + (cdr namess))) + (car namess))] + [ht (make-hasheq)] + [put (lambda (attr) (hash-set! ht (attr-name attr) attr))] + [fetch-like (lambda (attr) (hash-ref ht (attr-name attr) #f))]) + (for* ([attrs (in-list attrss)] + [attr (in-list attrs)] + #:when (memq (attr-name attr) names)) + (put (join-attrs attr (fetch-like attr)))) + (sort-sattrs (hash-map ht (lambda (k v) v))))])) + +;; reorder-iattrs : (listof SAttr) (listof IAttr) -> (listof IAttr) +;; Reorders iattrs (and restricts) based on relsattrs +;; If a relsattr is not found, or if depth or contents mismatches, raises error. +(define (reorder-iattrs relsattrs iattrs) + (let ([ht (make-hasheq)]) + (for ([iattr (in-list iattrs)]) + (let ([remap-name (syntax-e (attr-name iattr))]) + (hash-set! ht remap-name iattr))) + (let loop ([relsattrs relsattrs]) + (if (null? relsattrs) + null + (let ([sattr (car relsattrs)] + [rest (cdr relsattrs)]) + (let ([iattr (hash-ref ht (attr-name sattr) #f)]) + (check-iattr-satisfies-sattr iattr sattr) + (cons iattr (loop rest)))))))) + +(define (check-iattr-satisfies-sattr iattr sattr) + (unless iattr + (wrong-syntax #f "required attribute is not defined: ~s" (attr-name sattr))) + (unless (= (attr-depth iattr) (attr-depth sattr)) + (wrong-syntax (attr-name iattr) + "attribute has wrong depth (expected ~s, found ~s)" + (attr-depth sattr) (attr-depth iattr))) + (when (and (attr-syntax? sattr) (not (attr-syntax? iattr))) + (wrong-syntax (attr-name iattr) + "attribute may not be bound to syntax: ~s" + (attr-name sattr)))) + +;; check-iattrs-subset : (listof IAttr) (listof IAttr) stx -> void +(define (check-iattrs-subset little big ctx) + (define big-t (make-bound-id-table)) + (for ([a (in-list big)]) + (bound-id-table-set! big-t (attr-name a) #t)) + (for ([a (in-list little)]) + (unless (bound-id-table-ref big-t (attr-name a) #f) + (raise-syntax-error #f + "attribute bound in defaults but not in pattern" + ctx + (attr-name a))))) diff --git a/parse/private/rep-data.rkt b/parse/private/rep-data.rkt @@ -0,0 +1,303 @@ +#lang racket/base +(require racket/contract/base + racket/dict + syntax/private/id-table + racket/syntax + syntax/parse/private/residual-ct ;; keep abs. path + "minimatch.rkt" + "kws.rkt") +;; from residual.rkt +(provide (struct-out stxclass) + (struct-out conventions) + (struct-out literalset) + (struct-out eh-alternative-set) + (struct-out eh-alternative)) +;; from here +(provide stxclass/s? + stxclass/h? + (struct-out rhs) + (struct-out variant)) + +(define (stxclass/s? x) + (and (stxclass? x) (not (stxclass-splicing? x)))) +(define (stxclass/h? x) + (and (stxclass? x) (stxclass-splicing? x))) + +;; An RHS is #s(rhs SAttrs Bool Stx/#f Variants Stxs Bool Bool) +(define-struct rhs + (attrs ;; (Listof Sattr) + transparent? ;; Bool + description ;; Syntax/#f + variants ;; (Listof Variant) + definitions ;; (Listof Stx), aux definitions from txlifts, local conventions?, etc + commit? ;; Bool + delimit-cut? ;; Bool + ) #:prefab) + +;; A Variant is (variant Stx SAttrs Pattern Stxs) +(define-struct variant + (ostx ;; Stx + attrs ;; (Listof SAttr) + pattern ;; Pattern + definitions ;; (Listof Stx) + ) #:prefab) + +;; make-dummy-stxclass : identifier -> SC +;; Dummy stxclass for calculating attributes of recursive stxclasses. +(define (make-dummy-stxclass name) + (stxclass (syntax-e name) #f null #f #f (scopts 0 #t #t #f) #f)) + +;; Environments + +#| +DeclEnv = + (make-declenv immutable-bound-id-mapping[id => DeclEntry] + (listof ConventionRule)) + +DeclEntry = +- (den:lit Id Id Stx Stx) +- (den:datum-lit Id Symbol) +- (den:class Id Id Arguments) +- (den:magic-class Id Id Arguments Stx) +- (den:parser Id (Listof SAttr) Bool scopts) +- (den:delayed Id Id) + +Arguments is defined in rep-patterns.rkt + +A DeclEnv is built up in stages: + 1) syntax-parse (or define-syntax-class) directives + #:literals -> den:lit + #:datum-literals -> den:datum-lit + #:local-conventions -> den:class + #:conventions -> den:delayed + #:literal-sets -> den:lit + 2) pattern directives + #:declare -> den:magic-class + 3) create-aux-def creates aux parser defs + den:class -> den:parser or den:delayed + +== Scoping == + +A #:declare directive results in a den:magic-class entry, which +indicates that the pattern variable's syntax class arguments (if any) +have "magical scoping": they are evaluated in the scope where the +pattern variable occurs. If the variable occurs multiple times, the +expressions are duplicated, and may be evaluated in different scopes. +|# + +(define-struct declenv (table conventions)) + +(define-struct den:class (name class argu)) +(define-struct den:magic-class (name class argu role)) +(define-struct den:parser (parser attrs splicing? opts)) +;; and from residual.rkt: +;; (define-struct den:lit (internal external input-phase lit-phase)) +;; (define-struct den:datum-lit (internal external)) +;; (define-struct den:delayed (parser class)) + +(define (new-declenv literals #:conventions [conventions null]) + (let* ([table (make-immutable-bound-id-table)] + [table (for/fold ([table table]) ([literal (in-list literals)]) + (let ([id (cond [(den:lit? literal) (den:lit-internal literal)] + [(den:datum-lit? literal) (den:datum-lit-internal literal)])]) + ;;(eprintf ">> added ~e\n" id) + (bound-id-table-set table id literal)))]) + (make-declenv table conventions))) + +(define (declenv-lookup env id) + (bound-id-table-ref (declenv-table env) id #f)) + +(define (declenv-apply-conventions env id) + (conventions-lookup (declenv-conventions env) id)) + +(define (declenv-check-unbound env id [stxclass-name #f] + #:blame-declare? [blame-declare? #f]) + ;; Order goes: literals, pattern, declares + ;; So blame-declare? only applies to stxclass declares + (let ([val (declenv-lookup env id)]) + (match val + [(den:lit _i _e _ip _lp) + (wrong-syntax id "identifier previously declared as literal")] + [(den:datum-lit _i _e) + (wrong-syntax id "identifier previously declared as literal")] + [(den:magic-class name _c _a _r) + (if (and blame-declare? stxclass-name) + (wrong-syntax name + "identifier previously declared with syntax class ~a" + stxclass-name) + (wrong-syntax (if blame-declare? name id) + "identifier previously declared"))] + [(den:class name _c _a) + (if (and blame-declare? stxclass-name) + (wrong-syntax name + "identifier previously declared with syntax class ~a" + stxclass-name) + (wrong-syntax (if blame-declare? name id) + "identifier previously declared"))] + [(den:parser _p _a _sp _opts) + (wrong-syntax id "(internal error) late unbound check")] + ['#f (void)]))) + +(define (declenv-put-stxclass env id stxclass-name argu [role #f]) + (declenv-check-unbound env id) + (make-declenv + (bound-id-table-set (declenv-table env) id + (den:magic-class id stxclass-name argu role)) + (declenv-conventions env))) + +;; declenv-update/fold : DeclEnv (Id/Regexp DeclEntry a -> DeclEntry a) a +;; -> (values DeclEnv a) +(define (declenv-update/fold env0 f acc0) + (define-values (acc1 rules1) + (for/fold ([acc acc0] [newrules null]) + ([rule (in-list (declenv-conventions env0))]) + (let-values ([(val acc) (f (car rule) (cadr rule) acc)]) + (values acc (cons (list (car rule) val) newrules))))) + (define-values (acc2 table2) + (for/fold ([acc acc1] [table (make-immutable-bound-id-table)]) + ([(k v) (in-dict (declenv-table env0))]) + (let-values ([(val acc) (f k v acc)]) + (values acc (bound-id-table-set table k val))))) + (values (make-declenv table2 (reverse rules1)) + acc2)) + +;; returns ids in domain of env but not in given list +(define (declenv-domain-difference env ids) + (define idbm (make-bound-id-table)) + (for ([id (in-list ids)]) (bound-id-table-set! idbm id #t)) + (for/list ([(k v) (in-dict (declenv-table env))] + #:when (or (den:class? v) (den:magic-class? v) (den:parser? v)) + #:unless (bound-id-table-ref idbm k #f)) + k)) + +;; Conventions = (listof (list regexp DeclEntry)) + +(define (conventions-lookup conventions id) + (let ([sym (symbol->string (syntax-e id))]) + (for/or ([c (in-list conventions)]) + (and (regexp-match? (car c) sym) (cadr c))))) + +;; Contracts + +(define DeclEnv/c declenv?) + +(define DeclEntry/c + (or/c den:lit? den:datum-lit? den:class? den:magic-class? den:parser? den:delayed?)) + +(provide (struct-out den:class) + (struct-out den:magic-class) + (struct-out den:parser) + ;; from residual.rkt: + (struct-out den:lit) + (struct-out den:datum-lit) + (struct-out den:delayed)) + +(provide/contract + [DeclEnv/c contract?] + [DeclEntry/c contract?] + + [make-dummy-stxclass (-> identifier? stxclass?)] + [stxclass-lookup-config (parameter/c (symbols 'no 'try 'yes))] + [stxclass-colon-notation? (parameter/c boolean?)] + + [new-declenv + (->* [(listof (or/c den:lit? den:datum-lit?))] + [#:conventions list?] + DeclEnv/c)] + [declenv-lookup + (-> DeclEnv/c identifier? any)] + [declenv-apply-conventions + (-> DeclEnv/c identifier? any)] + [declenv-put-stxclass + (-> DeclEnv/c identifier? identifier? arguments? (or/c syntax? #f) + DeclEnv/c)] + [declenv-domain-difference + (-> DeclEnv/c (listof identifier?) + (listof identifier?))] + [declenv-update/fold + (-> DeclEnv/c + (-> (or/c identifier? regexp?) DeclEntry/c any/c (values DeclEntry/c any/c)) + any/c + (values DeclEnv/c any/c))] + + [get-stxclass + (-> identifier? stxclass?)] + [get-stxclass/check-arity + (-> identifier? syntax? exact-nonnegative-integer? (listof keyword?) + stxclass?)] + [split-id/get-stxclass + (-> identifier? DeclEnv/c + (values identifier? (or/c stxclass? den:lit? den:datum-lit? #f)))]) + +;; stxclass-lookup-config : (parameterof (U 'no 'try 'yes)) +;; 'no means don't lookup, always use dummy (no nested attrs) +;; 'try means lookup, but on failure use dummy (-> nested attrs only from prev.) +;; 'yes means lookup, raise error on failure +(define stxclass-lookup-config (make-parameter 'yes)) + +;; stxclass-colon-notation? : (parameterof boolean) +;; if #t, then x:sc notation means (~var x sc) +;; otherwise, just a var +(define stxclass-colon-notation? (make-parameter #t)) + +(define (get-stxclass id) + (define config (stxclass-lookup-config)) + (if (eq? config 'no) + (make-dummy-stxclass id) + (cond [(syntax-local-value/record id stxclass?) => values] + [(eq? config 'try) + (make-dummy-stxclass id)] + [else (wrong-syntax id "not defined as syntax class")]))) + +(define (get-stxclass/check-arity id stx pos-count keywords) + (let ([sc (get-stxclass id)]) + (unless (memq (stxclass-lookup-config) '(try no)) + (check-arity (stxclass-arity sc) pos-count keywords + (lambda (msg) + (raise-syntax-error #f msg stx)))) + sc)) + +(define (split-id/get-stxclass id0 decls) + (cond [(and (stxclass-colon-notation?) + (regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id0)))) + => (lambda (m) + (define-values [src ln col pos span] + (syntax-srcloc-values id0)) + (define id-str (cadr m)) + (define id-len (string-length id-str)) + (define suffix-str (caddr m)) + (define suffix-len (string-length suffix-str)) + (define id + (datum->syntax id0 (string->symbol id-str) + (list src ln col pos id-len) + id0)) + (define suffix + (datum->syntax id0 (string->symbol suffix-str) + (list src ln (and col (+ col id-len 1)) (and pos (+ pos id-len 1)) suffix-len) + id0)) + (declenv-check-unbound decls id (syntax-e suffix) + #:blame-declare? #t) + (let ([suffix-entry (declenv-lookup decls suffix)]) + (cond [(or (den:lit? suffix-entry) (den:datum-lit? suffix-entry)) + (values id suffix-entry)] + [else + (let ([sc (get-stxclass/check-arity suffix id0 0 null)]) + (values id sc))])))] + [else (values id0 #f)])) + +(define (syntax-srcloc-values stx) + (values (syntax-source stx) + (syntax-line stx) + (syntax-column stx) + (syntax-position stx) + (syntax-span stx))) + +;; ---- + +(provide get-eh-alternative-set) + +(define (get-eh-alternative-set id) + (let ([v (syntax-local-value id (lambda () #f))]) + (unless (eh-alternative-set? v) + (wrong-syntax id "not defined as an eh-alternative-set")) + v)) diff --git a/parse/private/rep-patterns.rkt b/parse/private/rep-patterns.rkt @@ -0,0 +1,616 @@ +#lang racket/base +(require syntax/parse/private/residual-ct ;; keep abs. path + "rep-attrs.rkt" + "minimatch.rkt" + racket/syntax) +(provide (all-defined-out)) + +#| +Uses Arguments from kws.rkt +|# + +#| +A SinglePattern is one of + (pat:any) + (pat:svar id) -- "simple" var, no stxclass + (pat:var/p Id Id Arguments (Listof IAttr) Stx scopts) -- var with parser + (pat:literal identifier Stx Stx) + (pat:datum datum) + (pat:action ActionPattern SinglePattern) + (pat:head HeadPattern SinglePattern) + (pat:dots (listof EllipsisHeadPattern) SinglePattern) + (pat:and (listof SinglePattern)) + (pat:or (listof IAttr) (listof SinglePattern) (listof (listof IAttr))) + (pat:not SinglePattern) + (pat:pair SinglePattern SinglePattern) + (pat:vector SinglePattern) + (pat:box SinglePattern) + (pat:pstruct key SinglePattern) + (pat:describe SinglePattern stx boolean stx) + (pat:delimit SinglePattern) + (pat:commit SinglePattern) + (pat:reflect stx Arguments (listof SAttr) id (listof IAttr)) + (pat:ord SinglePattern UninternedSymbol Nat) + (pat:post SinglePattern) + (pat:integrated id/#f id string stx) + +A ListPattern is a subtype of SinglePattern; one of + (pat:datum '()) + (pat:action ActionPattern ListPattern) + (pat:head HeadPattern ListPattern) + (pat:pair SinglePattern ListPattern) + (pat:dots EllipsisHeadPattern ListPattern) +|# + +(define-struct pat:any () #:prefab) +(define-struct pat:svar (name) #:prefab) +(define-struct pat:var/p (name parser argu nested-attrs role opts) #:prefab) +(define-struct pat:literal (id input-phase lit-phase) #:prefab) +(define-struct pat:datum (datum) #:prefab) +(define-struct pat:action (action inner) #:prefab) +(define-struct pat:head (head tail) #:prefab) +(define-struct pat:dots (heads tail) #:prefab) +(define-struct pat:and (patterns) #:prefab) +(define-struct pat:or (attrs patterns attrss) #:prefab) +(define-struct pat:not (pattern) #:prefab) +(define-struct pat:pair (head tail) #:prefab) +(define-struct pat:vector (pattern) #:prefab) +(define-struct pat:box (pattern) #:prefab) +(define-struct pat:pstruct (key pattern) #:prefab) +(define-struct pat:describe (pattern description transparent? role) #:prefab) +(define-struct pat:delimit (pattern) #:prefab) +(define-struct pat:commit (pattern) #:prefab) +(define-struct pat:reflect (obj argu attr-decls name nested-attrs) #:prefab) +(define-struct pat:ord (pattern group index) #:prefab) +(define-struct pat:post (pattern) #:prefab) +(define-struct pat:integrated (name predicate description role) #:prefab) + +#| +A ActionPattern is one of + (action:cut) + (action:fail stx stx) + (action:bind IAttr Stx) + (action:and (listof ActionPattern)) + (action:parse SinglePattern stx) + (action:do (listof stx)) + (action:ord ActionPattern UninternedSymbol Nat) + (action:post ActionPattern) + +A BindAction is (action:bind IAttr Stx) +A SideClause is just an ActionPattern +|# + +(define-struct action:cut () #:prefab) +(define-struct action:fail (when message) #:prefab) +(define-struct action:bind (attr expr) #:prefab) +(define-struct action:and (patterns) #:prefab) +(define-struct action:parse (pattern expr) #:prefab) +(define-struct action:do (stmts) #:prefab) +(define-struct action:ord (pattern group index) #:prefab) +(define-struct action:post (pattern) #:prefab) + +#| +A HeadPattern is one of + (hpat:var/p Id Id Arguments (Listof IAttr) Stx scopts) + (hpat:seq ListPattern) + (hpat:action ActionPattern HeadPattern) + (hpat:and HeadPattern SinglePattern) + (hpat:or (listof IAttr) (listof HeadPattern) (listof (listof IAttr))) + (hpat:describe HeadPattern stx/#f boolean stx) + (hpat:delimit HeadPattern) + (hpat:commit HeadPattern) + (hpat:reflect stx Arguments (listof SAttr) id (listof IAttr)) + (hpat:ord HeadPattern UninternedSymbol Nat) + (hpat:post HeadPattern) + (hpat:peek HeadPattern) + (hpat:peek-not HeadPattern) +|# + +(define-struct hpat:var/p (name parser argu nested-attrs role scopts) #:prefab) +(define-struct hpat:seq (inner) #:prefab) +(define-struct hpat:action (action inner) #:prefab) +(define-struct hpat:and (head single) #:prefab) +(define-struct hpat:or (attrs patterns attrss) #:prefab) +(define-struct hpat:describe (pattern description transparent? role) #:prefab) +(define-struct hpat:delimit (pattern) #:prefab) +(define-struct hpat:commit (pattern) #:prefab) +(define-struct hpat:reflect (obj argu attr-decls name nested-attrs) #:prefab) +(define-struct hpat:ord (pattern group index) #:prefab) +(define-struct hpat:post (pattern) #:prefab) +(define-struct hpat:peek (pattern) #:prefab) +(define-struct hpat:peek-not (pattern) #:prefab) + +#| +An EllipsisHeadPattern is + (ehpat (Listof IAttr) HeadPattern RepConstraint Boolean) + +A RepConstraint is one of + (rep:once stx stx stx) + (rep:optional stx stx (listof BindAction)) + (rep:bounds nat posint/+inf.0 stx stx stx) + #f +|# + +(define-struct ehpat (attrs head repc check-null?) #:prefab) +(define-struct rep:once (name under-message over-message) #:prefab) +(define-struct rep:optional (name over-message defaults) #:prefab) +(define-struct rep:bounds (min max name under-message over-message) #:prefab) + +(define (pattern? x) + (or (pat:any? x) + (pat:svar? x) + (pat:var/p? x) + (pat:literal? x) + (pat:datum? x) + (pat:action? x) + (pat:head? x) + (pat:dots? x) + (pat:and? x) + (pat:or? x) + (pat:not? x) + (pat:pair? x) + (pat:vector? x) + (pat:box? x) + (pat:pstruct? x) + (pat:describe? x) + (pat:delimit? x) + (pat:commit? x) + (pat:reflect? x) + (pat:ord? x) + (pat:post? x) + (pat:integrated? x))) + +(define (action-pattern? x) + (or (action:cut? x) + (action:bind? x) + (action:fail? x) + (action:and? x) + (action:parse? x) + (action:do? x) + (action:ord? x) + (action:post? x))) + +(define (head-pattern? x) + (or (hpat:var/p? x) + (hpat:seq? x) + (hpat:action? x) + (hpat:and? x) + (hpat:or? x) + (hpat:describe? x) + (hpat:delimit? x) + (hpat:commit? x) + (hpat:reflect? x) + (hpat:ord? x) + (hpat:post? x) + (hpat:peek? x) + (hpat:peek-not? x))) + +(define (ellipsis-head-pattern? x) + (ehpat? x)) + +(define single-pattern? pattern?) + +(define (single-or-head-pattern? x) + (or (single-pattern? x) + (head-pattern? x))) + +;; check-pattern : *Pattern -> *Pattern +;; Does attr computation to catch errors, but returns same pattern. +(define (check-pattern p) + (void (pattern-attrs p)) + p) + +;; pattern-attrs-table : Hasheq[*Pattern => (Listof IAttr)] +(define pattern-attrs-table (make-weak-hasheq)) + +;; pattern-attrs : *Pattern -> (Listof IAttr) +(define (pattern-attrs p) + (hash-ref! pattern-attrs-table p (lambda () (pattern-attrs* p)))) + +(define (pattern-attrs* p) + (match p + ;; -- S patterns + [(pat:any) + null] + [(pat:svar name) + (list (attr name 0 #t))] + [(pat:var/p name _ _ nested-attrs _ _) + (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)] + [(pat:reflect _ _ _ name nested-attrs) + (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)] + [(pat:datum _) + null] + [(pat:literal _ _ _) + null] + [(pat:action a sp) + (append-iattrs (map pattern-attrs (list a sp)))] + [(pat:head headp tailp) + (append-iattrs (map pattern-attrs (list headp tailp)))] + [(pat:pair headp tailp) + (append-iattrs (map pattern-attrs (list headp tailp)))] + [(pat:vector sp) + (pattern-attrs sp)] + [(pat:box sp) + (pattern-attrs sp)] + [(pat:pstruct key sp) + (pattern-attrs sp)] + [(pat:describe sp _ _ _) + (pattern-attrs sp)] + [(pat:and ps) + (append-iattrs (map pattern-attrs ps))] + [(pat:or _ ps _) + (union-iattrs (map pattern-attrs ps))] + [(pat:not _) + null] + [(pat:dots headps tailp) + (append-iattrs (map pattern-attrs (append headps (list tailp))))] + [(pat:delimit sp) + (pattern-attrs sp)] + [(pat:commit sp) + (pattern-attrs sp)] + [(pat:ord sp _ _) + (pattern-attrs sp)] + [(pat:post sp) + (pattern-attrs sp)] + [(pat:integrated name _ _ _) + (if name (list (attr name 0 #t)) null)] + + ;; -- A patterns + [(action:cut) + null] + [(action:fail _ _) + null] + [(action:bind attr expr) + (list attr)] + [(action:and ps) + (append-iattrs (map pattern-attrs ps))] + [(action:parse sp _) + (pattern-attrs sp)] + [(action:do _) + null] + [(action:ord sp _ _) + (pattern-attrs sp)] + [(action:post sp) + (pattern-attrs sp)] + + ;; -- H patterns + [(hpat:var/p name _ _ nested-attrs _ _) + (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)] + [(hpat:reflect _ _ _ name nested-attrs) + (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)] + [(hpat:seq lp) + (pattern-attrs lp)] + [(hpat:action a hp) + (append-iattrs (map pattern-attrs (list a hp)))] + [(hpat:describe hp _ _ _) + (pattern-attrs hp)] + [(hpat:and hp sp) + (append-iattrs (map pattern-attrs (list hp sp)))] + [(hpat:or _ ps _) + (union-iattrs (map pattern-attrs ps))] + [(hpat:delimit hp) + (pattern-attrs hp)] + [(hpat:commit hp) + (pattern-attrs hp)] + [(hpat:ord hp _ _) + (pattern-attrs hp)] + [(hpat:post hp) + (pattern-attrs hp)] + [(hpat:peek hp) + (pattern-attrs hp)] + [(hpat:peek-not hp) + null] + + ;; EH patterns + [(ehpat iattrs _ _ _) + iattrs] + )) + +;; ---- + +;; pattern-has-cut? : *Pattern -> Boolean +;; Returns #t if p *might* cut (~!, not within ~delimit-cut). +(define (pattern-has-cut? p) + (match p + ;; -- S patterns + [(pat:any) #f] + [(pat:svar name) #f] + [(pat:var/p _ _ _ _ _ opts) (not (scopts-delimit-cut? opts))] + [(pat:reflect _ _ _ name nested-attrs) #f] + [(pat:datum _) #f] + [(pat:literal _ _ _) #f] + [(pat:action a sp) (or (pattern-has-cut? a) (pattern-has-cut? sp))] + [(pat:head headp tailp) (or (pattern-has-cut? headp) (pattern-has-cut? tailp))] + [(pat:pair headp tailp) (or (pattern-has-cut? headp) (pattern-has-cut? tailp))] + [(pat:vector sp) (pattern-has-cut? sp)] + [(pat:box sp) (pattern-has-cut? sp)] + [(pat:pstruct key sp) (pattern-has-cut? sp)] + [(pat:describe sp _ _ _) (pattern-has-cut? sp)] + [(pat:and ps) (ormap pattern-has-cut? ps)] + [(pat:or _ ps _) (ormap pattern-has-cut? ps)] + [(pat:not _) #f] + [(pat:dots headps tailp) (or (ormap pattern-has-cut? headps) (pattern-has-cut? tailp))] + [(pat:delimit sp) #f] + [(pat:commit sp) #f] + [(pat:ord sp _ _) (pattern-has-cut? sp)] + [(pat:post sp) (pattern-has-cut? sp)] + [(pat:integrated name _ _ _) #f] + + ;; -- A patterns + [(action:cut) #t] + [(action:fail _ _) #f] + [(action:bind attr expr) #f] + [(action:and ps) (ormap pattern-has-cut? ps)] + [(action:parse sp _) (pattern-has-cut? sp)] + [(action:do _) #f] + [(action:ord sp _ _) (pattern-has-cut? sp)] + [(action:post sp) (pattern-has-cut? sp)] + + ;; -- H patterns + [(hpat:var/p _ _ _ _ _ opts) (not (scopts-delimit-cut? opts))] + [(hpat:reflect _ _ _ name nested-attrs) #f] + [(hpat:seq lp) (pattern-has-cut? lp)] + [(hpat:action a hp) (or (pattern-has-cut? a) (pattern-has-cut? hp))] + [(hpat:describe hp _ _ _) (pattern-has-cut? hp)] + [(hpat:and hp sp) (or (pattern-has-cut? hp) (pattern-has-cut? sp))] + [(hpat:or _ ps _) (ormap pattern-has-cut? ps)] + [(hpat:delimit hp) #f] + [(hpat:commit hp) #f] + [(hpat:ord hp _ _) (pattern-has-cut? hp)] + [(hpat:post hp) (pattern-has-cut? hp)] + [(hpat:peek hp) (pattern-has-cut? hp)] + [(hpat:peek-not hp) (pattern-has-cut? hp)] + + ;; EH patterns + [(ehpat _ hp _ _) (pattern-has-cut? hp)] + )) + +;; ---- + +(define (create-pat:or ps) + (define attrss (map pattern-attrs ps)) + (pat:or (union-iattrs attrss) ps attrss)) + +(define (create-hpat:or ps) + (define attrss (map pattern-attrs ps)) + (hpat:or (union-iattrs attrss) ps attrss)) + +;; create-ehpat : HeadPattern RepConstraint Syntax -> EllipsisHeadPattern +(define (create-ehpat head repc head-stx) + (let* ([iattrs0 (pattern-attrs head)] + [iattrs (repc-adjust-attrs iattrs0 repc)]) + (define nullable (hpat-nullable head)) + (define unbounded-iterations? + (cond [(rep:once? repc) #f] + [(rep:optional? repc) #f] + [(rep:bounds? repc) (eq? (rep:bounds-max repc) +inf.0)] + [else #t])) + (when (and (eq? nullable 'yes) unbounded-iterations?) + (when #f (wrong-syntax head-stx "nullable ellipsis-head pattern")) + (when #t (log-syntax-parse-error "nullable ellipsis-head pattern: ~e" head-stx))) + (ehpat iattrs head repc (case nullable [(yes unknown) unbounded-iterations?] [(no) #f])))) + +(define (repc-adjust-attrs iattrs repc) + (cond [(rep:once? repc) + iattrs] + [(rep:optional? repc) + (map attr-make-uncertain iattrs)] + [(or (rep:bounds? repc) (eq? #f repc)) + (map increase-depth iattrs)] + [else + (error 'repc-adjust-attrs "INTERNAL ERROR: unexpected: ~e" repc)])) + +;; ---- + +(define (action/head-pattern->list-pattern p) + (cond [(action-pattern? p) + (pat:action p (pat:any))] + [(hpat:seq? p) + ;; simplification: just extract list pattern from hpat:seq + (hpat:seq-inner p)] + [else + (pat:head p (pat:datum '()))])) + +(define (action-pattern->single-pattern a) + (pat:action a (pat:any))) + +(define (proper-list-pattern? p) + (or (and (pat:datum? p) (eq? (pat:datum-datum p) '())) + (and (pat:pair? p) (proper-list-pattern? (pat:pair-tail p))) + (and (pat:head? p) (proper-list-pattern? (pat:head-tail p))) + (and (pat:dots? p) (proper-list-pattern? (pat:dots-tail p))) + (and (pat:action? p) (proper-list-pattern? (pat:action-inner p))))) + +;; ---- + +(define-syntax-rule (define/memo (f x) body ...) + (define f + (let ([memo-table (make-weak-hasheq)]) + (lambda (x) + (hash-ref! memo-table x (lambda () body ...)))))) + +;; ---- + +;; An AbsFail is a Nat encoding the bitvector { sub? : 1, post? : 1 } +;; Finite abstraction of failuresets based on progress bins. That is: +(define AF-NONE 0) ;; cannot fail +(define AF-SUB 1) ;; can fail with progress < POST +(define AF-POST 2) ;; can fail with progress >= POST +(define AF-ANY 3) ;; can fail with progress either < or >= POST + +;; AF-nz? : AbsFail -> {0, 1} +(define (AF-nz? af) (if (= af AF-NONE) 0 1)) + +;; AF<? : AbsFail AbsFail -> Boolean +;; True if every failure in af1 has strictly less progress than any failure in af2. +;; Note: trivially satisfied if either side cannot fail. +(define (AF<? af1 af2) + ;; (0, *), (*, 0), (1, 2) + (or (= af1 AF-NONE) + (= af2 AF-NONE) + (and (= af1 AF-SUB) (= af2 AF-POST)))) + +;; pattern-absfail : *Pattern -> AbsFail +(define/memo (pattern-AF p) + (define (patterns-AF ps) + (for/fold ([af 0]) ([p (in-list ps)]) (bitwise-ior af (pattern-AF p)))) + (cond [(pat:any? p) AF-NONE] + [(pat:svar? p) AF-NONE] + [(pat:var/p? p) AF-ANY] + [(pat:literal? p) AF-SUB] + [(pat:datum? p) AF-SUB] + [(pat:action? p) (bitwise-ior (pattern-AF (pat:action-action p)) + (pattern-AF (pat:action-inner p)))] + [(pat:head? p) AF-ANY] + [(pat:dots? p) AF-ANY] + [(pat:and? p) (patterns-AF (pat:and-patterns p))] + [(pat:or? p) (patterns-AF (pat:or-patterns p))] + [(pat:not? p) AF-SUB] + [(pat:pair? p) AF-SUB] + [(pat:vector? p) AF-SUB] + [(pat:box? p) AF-SUB] + [(pat:pstruct? p) AF-SUB] + [(pat:describe? p) (pattern-AF (pat:describe-pattern p))] + [(pat:delimit? p) (pattern-AF (pat:delimit-pattern p))] + [(pat:commit? p) (pattern-AF (pat:commit-pattern p))] + [(pat:reflect? p) AF-ANY] + [(pat:ord? p) (pattern-AF (pat:ord-pattern p))] + [(pat:post? p) (if (AF-nz? (pattern-AF (pat:post-pattern p))) AF-POST AF-NONE)] + [(pat:integrated? p) AF-SUB] + ;; Action patterns + [(action:cut? p) AF-NONE] + [(action:fail? p) AF-SUB] + [(action:bind? p) AF-NONE] + [(action:and? p) (patterns-AF (action:and-patterns p))] + [(action:parse? p) (if (AF-nz? (pattern-AF (action:parse-pattern p))) AF-SUB AF-NONE)] + [(action:do? p) AF-NONE] + [(action:ord? p) (pattern-AF (action:ord-pattern p))] + [(action:post? p) (if (AF-nz? (pattern-AF (action:post-pattern p))) AF-POST AF-NONE)] + ;; Head patterns, eh patterns, etc + [else AF-ANY])) + +;; pattern-cannot-fail? : *Pattern -> Boolean +(define (pattern-cannot-fail? p) + (= (pattern-AF p) AF-NONE)) + +;; pattern-can-fail? : *Pattern -> Boolean +(define (pattern-can-fail? p) + (not (pattern-cannot-fail? p))) + +;; patterns-AF-sorted? : (Listof *Pattern) -> AF/#f +;; Returns AbsFail (true) if any failure from pattern N+1 has strictly +;; greater progress than any failure from patterns 0 through N. +(define (patterns-AF-sorted? ps) + (for/fold ([af AF-NONE]) ([p (in-list ps)]) + (define afp (pattern-AF p)) + (and af (AF<? af afp) (bitwise-ior af afp)))) + +;; ---- + +;; patterns-cannot-fail? : (Listof SinglePattern) -> Boolean +;; Returns true if the disjunction of the patterns always succeeds---and thus no +;; failure-tracking needed. Note: beware cut! +(define (patterns-cannot-fail? patterns) + (and (not (ormap pattern-has-cut? patterns)) + (ormap pattern-cannot-fail? patterns))) + +;; ---- + +;; An AbsNullable is 'yes | 'no | 'unknown (3-valued logic) + +(define (3and a b) + (case a + [(yes) b] + [(no) 'no] + [(unknown) (case b [(yes unknown) 'unknown] [(no) 'no])])) + +(define (3or a b) + (case a + [(yes) 'yes] + [(no) b] + [(unknown) (case b [(yes) 'yes] [(no unknown) 'unknown])])) + +(define (3andmap f xs) (foldl 3and 'yes (map f xs))) +(define (3ormap f xs) (foldl 3or 'no (map f xs))) + +;; lpat-nullable : ListPattern -> AbsNullable +(define/memo (lpat-nullable lp) + (match lp + [(pat:datum '()) 'yes] + [(pat:action ap lp) (lpat-nullable lp)] + [(pat:head hp lp) (3and (hpat-nullable hp) (lpat-nullable lp))] + [(pat:pair sp lp) 'no] + [(pat:dots ehps lp) (3and (3andmap ehpat-nullable ehps) (lpat-nullable lp))] + ;; For hpat:and, handle the following which are not ListPatterns + [(pat:and lps) (3andmap lpat-nullable lps)] + [(pat:any) #t] + [_ 'unknown])) + +;; hpat-nullable : HeadPattern -> AbsNullable +(define/memo (hpat-nullable hp) + (match hp + [(hpat:seq lp) (lpat-nullable lp)] + [(hpat:action ap hp) (hpat-nullable hp)] + [(hpat:and hp sp) (3and (hpat-nullable hp) (lpat-nullable sp))] + [(hpat:or _attrs hps _attrss) (3ormap hpat-nullable hps)] + [(hpat:describe hp _ _ _) (hpat-nullable hp)] + [(hpat:delimit hp) (hpat-nullable hp)] + [(hpat:commit hp) (hpat-nullable hp)] + [(hpat:ord hp _ _) (hpat-nullable hp)] + [(hpat:post hp) (hpat-nullable hp)] + [(? pattern? hp) 'no] + [_ 'unknown])) + +;; ehpat-nullable : EllipsisHeadPattern -> AbsNullable +(define (ehpat-nullable ehp) + (match ehp + [(ehpat _ hp repc _) + (3or (repc-nullable repc) (hpat-nullable hp))])) + +;; repc-nullable : RepConstraint -> AbsNullable +(define (repc-nullable repc) + (cond [(rep:once? repc) 'no] + [(and (rep:bounds? repc) (> (rep:bounds-min repc) 0)) 'no] + [else 'yes])) + +;; ---- + +;; create-post-pattern : *Pattern -> *Pattern +(define (create-post-pattern p) + (cond [(pattern-cannot-fail? p) + p] + [(pattern? p) + (pat:post p)] + [(head-pattern? p) + (hpat:post p)] + [(action-pattern? p) + (action:post p)] + [else (error 'syntax-parse "INTERNAL ERROR: create-post-pattern ~e" p)])) + +;; create-ord-pattern : *Pattern UninternedSymbol Nat -> *Pattern +(define (create-ord-pattern p group index) + (cond [(pattern-cannot-fail? p) + p] + [(pattern? p) + (pat:ord p group index)] + [(head-pattern? p) + (hpat:ord p group index)] + [(action-pattern? p) + (action:ord p group index)] + [else (error 'syntax-parse "INTERNAL ERROR: create-ord-pattern ~e" p)])) + +;; ord-and-patterns : (Listof *Pattern) UninternedSymbol -> (Listof *Pattern) +;; If at most one subpattern can fail, no need to wrap. More +;; generally, if possible failures are already consistent with and +;; ordering, no need to wrap. +(define (ord-and-patterns patterns group) + (cond [(patterns-AF-sorted? patterns) patterns] + [else + (for/list ([p (in-list patterns)] [index (in-naturals)]) + (create-ord-pattern p group index))])) + +;; create-action:and : (Listof ActionPattern) -> ActionPattern +(define (create-action:and actions) + (match actions + [(list action) action] + [_ (action:and actions)])) diff --git a/parse/private/rep.rkt b/parse/private/rep.rkt @@ -0,0 +1,1646 @@ +#lang racket/base +(require (for-template racket/base + syntax/parse/private/keywords + syntax/parse/private/residual ;; keep abs. path + syntax/parse/private/runtime) + racket/list + racket/contract/base + "make.rkt" + "minimatch.rkt" + syntax/private/id-table + syntax/stx + syntax/keyword + racket/syntax + racket/struct + "txlift.rkt" + "rep-attrs.rkt" + "rep-data.rkt" + "rep-patterns.rkt" + syntax/parse/private/residual-ct ;; keep abs. path + "kws.rkt") + +;; 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 <options> -> (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) <kw-args> +;; -> 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<?) + (sort (hash-map kw-h (lambda (k v) k)) + keyword<?))) + (loop formals))) + +;; parse-formal : stx -> (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))) diff --git a/parse/private/residual-ct.rkt b/parse/private/residual-ct.rkt @@ -0,0 +1,97 @@ +#lang racket/base +(provide (struct-out attr) + (struct-out stxclass) + (struct-out scopts) + (struct-out conventions) + (struct-out literalset) + (struct-out lse:lit) + (struct-out lse:datum-lit) + (struct-out eh-alternative-set) + (struct-out eh-alternative) + (struct-out den:lit) + (struct-out den:datum-lit) + (struct-out den:delayed) + log-syntax-parse-error + log-syntax-parse-warning + log-syntax-parse-info + log-syntax-parse-debug + prop:pattern-expander + pattern-expander? + pattern-expander-proc + current-syntax-parse-pattern-introducer + syntax-local-syntax-parse-pattern-introduce) + +(define-logger syntax-parse) + +;; == from rep-attr.rkt +(define-struct attr (name depth syntax?) #:prefab) + +;; == from rep-data.rkt + +;; A stxclass is #s(stxclass Symbol Arity SAttrs Id Bool scopts Id/#f) +(define-struct stxclass + (name ;; Symbol + arity ;; Arity (defined in kws.rkt) + attrs ;; (Listof SAttr) + parser ;; Id, reference to parser (see parse.rkt for parser signature) + splicing? ;; Bool + opts ;; scopts + inline ;; Id/#f, reference to a predicate + ) #:prefab) + +;; A scopts is #s(scopts Nat Bool Bool String/#f) +;; These are passed on to var patterns. +(define-struct scopts + (attr-count ;; Nat + commit? ;; Bool + delimit-cut? ;; Bool + desc ;; String/#f, String = known constant 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 LiteralSetEntry)) +An LiteralSetEntry is one of + - (make-lse:lit Symbol Id Stx) + - (make-lse:datum-lit Symbol Symbol) +|# +(define-struct literalset (literals) #:transparent) +(define-struct lse:lit (internal external phase) #:transparent) +(define-struct lse:datum-lit (internal external) #: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:lit (internal external input-phase lit-phase) #:transparent) +(define-struct den:datum-lit (internal external) #:transparent) +(define-struct den:delayed (parser class)) + +;; == Pattern expanders + +(define-values (prop:pattern-expander pattern-expander? get-proc-getter) + (make-struct-type-property 'pattern-expander)) + +(define (pattern-expander-proc pat-expander) + (define get-proc (get-proc-getter pat-expander)) + (get-proc pat-expander)) + +(define current-syntax-parse-pattern-introducer + (make-parameter + (lambda (stx) + (error 'syntax-local-syntax-parse-pattern-introduce "not expanding syntax-parse pattern")))) + +(define (syntax-local-syntax-parse-pattern-introduce stx) + ((current-syntax-parse-pattern-introducer) stx)) diff --git a/parse/private/residual.rkt b/parse/private/residual.rkt @@ -0,0 +1,302 @@ +#lang racket/base +(require (for-syntax racket/base) + racket/stxparam + racket/lazy-require + racket/private/promise) + +;; ============================================================ +;; 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)]) + (if (syntax-list^depth? '#,(attribute-mapping-depth self) value) + value + (check/force-syntax-list^depth '#,(attribute-mapping-depth self) + value + (quote-syntax #,source-name)))))))) + ) + +;; ============================================================ +;; Run-time + +(require "runtime-progress.rkt" + "3d-stx.rkt" + syntax/stx) + +(provide (all-from-out "runtime-progress.rkt") + + this-syntax + this-role + this-context-syntax + attribute + attribute-binding + stx-list-take + stx-list-drop/cx + datum->syntax/with-clause + check/force-syntax-list^depth + check-literal* + error/null-eh-match + begin-for-syntax/once + + name->too-few/once + name->too-few + name->too-many + normalize-context + 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))) + +(define-syntax-parameter this-role + (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 + (list (syntax-local-introduce #'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/force-syntax-list^depth : nat any id -> (listof^depth syntax) +;; Checks that value is (listof^depth syntax); forces promises. +;; Slow path for attribute-mapping code, assumes value is not syntax-list^depth? already. +(define (check/force-syntax-list^depth depth value0 source-id) + (define (bad sub-depth sub-value) + (attribute-not-syntax-error depth value0 source-id sub-depth sub-value)) + (define (loop depth value) + (cond [(promise? value) + (loop depth (force value))] + [(zero? depth) + (if (syntax? value) value (bad depth value))] + [else (loop-list depth value)])) + (define (loop-list depth value) + (cond [(promise? value) + (loop-list depth (force value))] + [(pair? value) + (let ([new-car (loop (sub1 depth) (car value))] + [new-cdr (loop-list depth (cdr value))]) + ;; Don't copy unless necessary + (if (and (eq? new-car (car value)) + (eq? new-cdr (cdr value))) + value + (cons new-car new-cdr)))] + [(null? value) + null] + [else + (bad depth value)])) + (loop depth value0)) + +(define (attribute-not-syntax-error depth0 value0 source-id sub-depth sub-value) + (raise-syntax-error #f + (format (string-append "bad attribute value for syntax template" + "\n attribute value: ~e" + "\n expected for attribute: ~a" + "\n sub-value: ~e" + "\n expected for sub-value: ~a") + value0 + (describe-depth depth0) + sub-value + (describe-depth sub-depth)) + source-id)) + +(define (describe-depth depth) + (cond [(zero? depth) "syntax"] + [else (format "list of depth ~s of syntax" depth)])) + +;; syntax-list^depth? : nat any -> boolean +;; Returns true iff value is (listof^depth syntax). +(define (syntax-list^depth? depth value) + (if (zero? depth) + (syntax? value) + (and (list? value) + (for/and ([part (in-list value)]) + (syntax-list^depth? (sub1 depth) part))))) + +;; datum->syntax/with-clause : any -> syntax +(define (datum->syntax/with-clause x) + (cond [(syntax? x) x] + [(2d-stx? x #:traverse-syntax? #f) + (datum->syntax #f x #f)] + [else + (error 'datum->syntax/with-clause + (string-append + "implicit conversion to 3D syntax\n" + " right-hand side of #:with clause or ~~parse pattern would be 3D syntax\n" + " value: ~e") + x)])) + +;; 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))) + +;; error/null-eh-match : -> (escapes) +(define (error/null-eh-match) + (error 'syntax-parse "an ellipsis-head pattern matched an empty sequence")) + +;; (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 + +;; normalize-context : Symbol Any Syntax -> (list Symbol/#f Syntax) +(define (normalize-context who ctx stx) + (cond [(syntax? ctx) + (list #f ctx)] + [(symbol? ctx) + (list ctx stx)] + [(eq? ctx #f) + (list #f stx)] + [(and (list? ctx) + (= (length ctx) 2) + (or (symbol? (car ctx)) (eq? #f (car ctx))) + (syntax? (cadr ctx))) + ctx] + [else (error who "bad #:context argument\n expected: ~s\n given: ~e" + '(or/c syntax? symbol? #f (list/c (or/c symbol? #f) syntax?)) + ctx)])) + +;; == parse.rkt + +(lazy-require + ["runtime-report.rkt" + (call-current-failure-handler ctx fs)]) + +;; syntax-patterns-fail : (list Symbol/#f Syntax) -> FailureSet -> (escapes) +(define ((syntax-patterns-fail ctx) fs) + (call-current-failure-handler ctx fs)) + +;; == specialized ellipsis parser +;; returns (values 'ok attr-values) or (values 'fail failure) + +(provide predicate-ellipsis-parser) + +(define (predicate-ellipsis-parser x cx pr es pred? desc rl) + (let ([elems (stx->list x)]) + (if (and elems (list? elems) (andmap pred? elems)) + (values 'ok elems) + (let loop ([x x] [cx cx] [i 0]) + (cond [(syntax? x) + (loop (syntax-e x) x i)] + [(pair? x) + (if (pred? (car x)) + (loop (cdr x) cx (add1 i)) + (let* ([pr (ps-add-cdr pr i)] + [pr (ps-add-car pr)] + [es (es-add-thing pr desc #t rl es)]) + (values 'fail (failure pr es))))] + [else ;; not null, because stx->list failed + (let ([pr (ps-add-cdr pr i)] + #| + ;; Don't extend es! That way we don't get spurious "expected ()" + ;; that *should* have been cancelled out by ineffable pair failures. + |#) + (values 'fail (failure pr es)))]))))) diff --git a/parse/private/runtime-progress.rkt b/parse/private/runtime-progress.rkt @@ -0,0 +1,257 @@ +#lang racket/base +(require racket/list + "minimatch.rkt") +(provide ps-empty + ps-add-car + ps-add-cdr + ps-add-stx + ps-add-unbox + ps-add-unvector + ps-add-unpstruct + ps-add-opaque + ps-add-post + ps-add + (struct-out ord) + + ps-pop-opaque + ps-pop-ord + ps-pop-post + ps-context-syntax + ps-difference + + (struct-out failure) + failure* + + expect? + (struct-out expect:thing) + (struct-out expect:atom) + (struct-out expect:literal) + (struct-out expect:message) + (struct-out expect:disj) + (struct-out expect:proper-pair) + + es-add-thing + es-add-message + es-add-atom + es-add-literal + es-add-proper-pair) + +;; FIXME: add phase to expect:literal + +;; == Failure == + +#| +A Failure is (failure PS ExpectStack) + +A FailureSet is one of + - Failure + - (cons FailureSet FailureSet) + +A FailFunction = (FailureSet -> Answer) +|# +(define-struct failure (progress expectstack) #:prefab) + +;; failure* : PS ExpectStack/#f -> Failure/#t +(define (failure* ps es) (if es (failure ps es) #t)) + +;; == Progress == + +#| +Progress (PS) is a non-empty list of Progress Frames (PF). + +A Progress Frame (PF) is one of + - stx ;; "Base" frame, or ~parse/#:with term + - 'car ;; car of pair; also vector->list, unbox, struct->list, etc + - nat ;; Represents that many repeated cdrs + - 'post ;; late/post-traversal check + - #s(ord group index) ;; ~and subpattern, only comparable w/in group + - 'opaque + +The error-reporting context (ie, syntax-parse #:context arg) is always +the final frame. + +All non-stx frames (eg car, cdr) interpreted as applying to nearest following +stx frame. + +A stx frame is introduced + - always at base (that is, by syntax-parse) + - if syntax-parse has #:context arg, then two stx frames at bottom: + (list to-match-stx context-stx) + - by #:with/~parse + - by #:fail-*/#:when/~fail & stx + +Interpretation: later frames are applied first. + eg, (list 'car 1 stx) + means ( car of ( cdr once of stx ) ) + NOT apply car, then apply cdr once, then stop +|# +(define-struct ord (group index) #:prefab) + +(define (ps-empty stx ctx) + (if (eq? stx ctx) + (list stx) + (list stx ctx))) +(define (ps-add-car parent) + (cons 'car parent)) +(define (ps-add-cdr parent [times 1]) + (if (zero? times) + parent + (match (car parent) + [(? exact-positive-integer? n) + (cons (+ times n) (cdr parent))] + [_ + (cons times parent)]))) +(define (ps-add-stx parent stx) + (cons stx parent)) +(define (ps-add-unbox parent) + (ps-add-car parent)) +(define (ps-add-unvector parent) + (ps-add-car parent)) +(define (ps-add-unpstruct parent) + (ps-add-car parent)) +(define (ps-add-opaque parent) + (cons 'opaque parent)) +(define (ps-add parent frame) + (cons frame parent)) +(define (ps-add-post parent) + (cons 'post parent)) + +;; ps-context-syntax : Progress -> syntax +(define (ps-context-syntax ps) + ;; Bottom frame is always syntax + (last ps)) + +;; ps-difference : PS PS -> nat +;; Returns N s.t. B = (ps-add-cdr^N A) +(define (ps-difference a b) + (define-values (a-cdrs a-base) + (match a + [(cons (? exact-positive-integer? a-cdrs) a-base) + (values a-cdrs a-base)] + [_ (values 0 a)])) + (define-values (b-cdrs b-base) + (match b + [(cons (? exact-positive-integer? b-cdrs) b-base) + (values b-cdrs b-base)] + [_ (values 0 b)])) + (unless (eq? a-base b-base) + (error 'ps-difference "INTERNAL ERROR: ~e does not extend ~e" b a)) + (- b-cdrs a-cdrs)) + +;; ps-pop-opaque : PS -> PS +;; Used to continue with progress from opaque head pattern. +(define (ps-pop-opaque ps) + (match ps + [(cons (? exact-positive-integer? n) (cons 'opaque ps*)) + (ps-add-cdr ps* n)] + [(cons 'opaque ps*) + ps*] + [_ (error 'ps-pop-opaque "INTERNAL ERROR: opaque frame not found: ~e" ps)])) + +;; ps-pop-ord : PS -> PS +(define (ps-pop-ord ps) + (match ps + [(cons (? exact-positive-integer? n) (cons (? ord?) ps*)) + (ps-add-cdr ps* n)] + [(cons (? ord?) ps*) + ps*] + [_ (error 'ps-pop-ord "INTERNAL ERROR: ord frame not found: ~e" ps)])) + +;; ps-pop-post : PS -> PS +(define (ps-pop-post ps) + (match ps + [(cons (? exact-positive-integer? n) (cons 'post ps*)) + (ps-add-cdr ps* n)] + [(cons 'post ps*) + ps*] + [_ (error 'ps-pop-post "INTERNAL ERROR: post frame not found: ~e" ps)])) + + +;; == Expectations == + +#| +There are multiple types that use the same structures, optimized for +different purposes. + +-- During parsing, the goal is to minimize/consolidate allocations. + +An ExpectStack (during parsing) is one of + - (expect:thing Progress String Boolean String/#f ExpectStack) + * (expect:message String ExpectStack) + * (expect:atom Datum ExpectStack) + * (expect:literal Identifier ExpectStack) + * (expect:proper-pair FirstDesc ExpectStack) + * #t + +The *-marked variants can only occur at the top of the stack (ie, not +in the next field of another Expect). The top of the stack contains +the most specific information. + +An ExpectStack can also be #f, which means no failure tracking is +requested (and thus no more ExpectStacks should be allocated). + +-- During reporting, the goal is ease of manipulation. + +An ExpectList (during reporting) is (listof Expect). + +An Expect is one of + - (expect:thing #f String #t String/#f StxIdx) + * (expect:message String StxIdx) + * (expect:atom Datum StxIdx) + * (expect:literal Identifier StxIdx) + * (expect:proper-pair FirstDesc StxIdx) + * (expect:disj (NEListof Expect) StxIdx) + - '... + +A StxIdx is (cons Syntax Nat) + +That is, the next link is replaced with the syntax+index of the term +being complained about. An expect:thing's progress is replaced with #f. + +An expect:disj never contains a '... or another expect:disj. + +We write ExpectList when the most specific information comes first and +RExpectList when the most specific information comes last. +|# +(struct expect:thing (term description transparent? role next) #:prefab) +(struct expect:message (message next) #:prefab) +(struct expect:atom (atom next) #:prefab) +(struct expect:literal (literal next) #:prefab) +(struct expect:disj (expects next) #:prefab) +(struct expect:proper-pair (first-desc next) #:prefab) + +(define (expect? x) + (or (expect:thing? x) + (expect:message? x) + (expect:atom? x) + (expect:literal? x) + (expect:disj? x) + (expect:proper-pair? x))) + +(define (es-add-thing ps description transparent? role next) + (if (and next description) + (expect:thing ps description transparent? role next) + next)) + +(define (es-add-message message next) + (if (and next message) + (expect:message message next) + next)) + +(define (es-add-atom atom next) + (and next (expect:atom atom next))) + +(define (es-add-literal literal next) + (and next (expect:literal literal next))) + +(define (es-add-proper-pair first-desc next) + (and next (expect:proper-pair first-desc next))) + +#| +A FirstDesc is one of + - #f -- unknown, multiple possible, etc + - string -- description + - (list 'any) + - (list 'literal symbol) + - (list 'datum datum) +|# diff --git a/parse/private/runtime-reflect.rkt b/parse/private/runtime-reflect.rkt @@ -0,0 +1,81 @@ +#lang racket/base +(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 reflect-parser + (struct-out reified) + (struct-out reified-syntax-class) + (struct-out reified-splicing-syntax-class)) + +#| +A Reified is + (reified symbol ParserFunction nat (listof (list symbol nat))) +|# +(define-struct reified-base (name) #:transparent) +(define-struct (reified reified-base) (parser arity signature)) +(define-struct (reified-syntax-class reified) ()) +(define-struct (reified-splicing-syntax-class reified) ()) + +(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) + (raise-type-error who "reified splicing-syntax-class" obj)) + (unless (reified-syntax-class? obj) + (raise-type-error who "reified syntax-class" obj))) + (check-params who e-arity (reified-arity obj) obj) + (adapt-parser who + (for/list ([a (in-list e-attrs)]) + (list (attr-name a) (attr-depth a))) + (reified-signature obj) + (reified-parser obj) + splicing?)) + +(define (check-params who e-arity r-arity obj) + (let ([e-pos (arity-minpos e-arity)] + [e-kws (arity-minkws e-arity)]) + (check-arity/neg r-arity e-pos e-kws + (lambda (msg) + (raise-mismatch-error who (string-append msg ": ") obj))))) + +(define (adapt-parser who esig0 rsig0 parser splicing?) + (if (equal? esig0 rsig0) + parser + (let ([indexes + (let loop ([esig esig0] [rsig rsig0] [index 0]) + (cond [(null? esig) + null] + [(and (pair? rsig) (eq? (caar esig) (caar rsig))) + (unless (= (cadar esig) (cadar rsig)) + (wrong-depth who (car esig) (car rsig))) + (cons index (loop (cdr esig) (cdr rsig) (add1 index)))] + [(and (pair? rsig) + (string>? (symbol->string (caar esig)) + (symbol->string (caar rsig)))) + (loop esig (cdr rsig) (add1 index))] + [else + (error who "reified syntax-class is missing declared attribute `~s'" + (caar esig))]))]) + (define (take-indexes result indexes) + (let loop ([result result] [indexes indexes] [i 0]) + (cond [(null? indexes) null] + [(= (car indexes) i) + (cons (car result) (loop (cdr result) (cdr indexes) (add1 i)))] + [else + (loop (cdr result) indexes (add1 i))]))) + (make-keyword-procedure + (lambda (kws kwargs x cx pr es fh cp rl success . rest) + (keyword-apply parser kws kwargs x cx pr es fh cp rl + (if splicing? + (lambda (fh x cx pr . result) + (apply success fh x cx pr (take-indexes result indexes))) + (lambda (fh . result) + (apply success fh (take-indexes result indexes)))) + rest)))))) + +(define (wrong-depth who a b) + (error who + "reified syntax-class has wrong depth for attribute `~s'; expected ~s, got ~s instead" + (car a) (cadr a) (cadr b))) diff --git a/parse/private/runtime-report.rkt b/parse/private/runtime-report.rkt @@ -0,0 +1,784 @@ +#lang racket/base +(require racket/list + racket/format + syntax/stx + racket/struct + syntax/srcloc + "minimatch.rkt" + syntax/parse/private/residual + "kws.rkt") +(provide call-current-failure-handler + current-failure-handler + invert-failure + maximal-failures + invert-ps + ps->stx+index) + +#| +TODO: given (expect:thing _ D _ R) and (expect:thing _ D _ #f), + simplify to (expect:thing _ D _ #f) + thus, "expected D" rather than "expected D or D for R" (?) +|# + +#| +Note: there is a cyclic dependence between residual.rkt and this module, +broken by a lazy-require of this module into residual.rkt +|# + +(define (call-current-failure-handler ctx fs) + (call-with-values (lambda () ((current-failure-handler) ctx fs)) + (lambda vals + (error 'current-failure-handler + "current-failure-handler: did not escape, produced ~e" + (case (length vals) + ((1) (car vals)) + (else (cons 'values vals))))))) + +(define (default-failure-handler ctx fs) + (handle-failureset ctx fs)) + +(define current-failure-handler + (make-parameter default-failure-handler)) + + +;; ============================================================ +;; Processing failure sets + +#| +We use progress to select the maximal failures and determine the syntax +they're complaining about. After that, we no longer care about progress. + +Old versions of syntax-parse (through 6.4) grouped failures into +progress-equivalence-classes and generated reports by class, but only showed +one report. New syntax-parse just mixes all maximal failures together and +deals with the fact that they might not be talking about the same terms. +|# + +;; handle-failureset : (list Symbol/#f Syntax) FailureSet -> escapes +(define (handle-failureset ctx fs) + (define inverted-fs (map invert-failure (reverse (flatten fs)))) + (define maximal-classes (maximal-failures inverted-fs)) + (define ess (map failure-expectstack (append* maximal-classes))) + (define report (report/sync-shared ess)) + ;; Hack: alternative to new (primitive) phase-crossing exn type is to store + ;; extra information in exn continuation marks. Currently for debugging only. + (with-continuation-mark 'syntax-parse-error + (hasheq 'raw-failures fs + 'maximal maximal-classes) + (error/report ctx report))) + +;; An RFailure is (failure IPS RExpectList) + +;; invert-failure : Failure -> RFailure +(define (invert-failure f) + (match f + [(failure ps es) + (failure (invert-ps ps) (invert-expectstack es (ps->stx+index ps)))])) + +;; A Report is (report String (Listof String) Syntax/#f Syntax/#f) +(define-struct report (message context stx within-stx) #:prefab) + + +;; ============================================================ +;; Progress + +;; maximal-failures : (listof InvFailure) -> (listof (listof InvFailure)) +(define (maximal-failures fs) + (maximal/progress + (for/list ([f (in-list fs)]) + (cons (failure-progress f) f)))) + +#| +Progress ordering +----------------- + +Nearly a lexicographic generalization of partial order on frames. + (( CAR < CDR ) || stx ) < POST ) + - stx incomparable except with self + +But ORD prefixes are sorted out (and discarded) before comparison with +rest of progress. Like post, ord comparable only w/in same group: + - (ord g n1) < (ord g n2) if n1 < n2 + - (ord g1 n1) || (ord g2 n2) when g1 != g2 + + +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. + +;; invert-ps : PS -> IPS +;; Reverse and truncate at earliest 'opaque frame. +(define (invert-ps ps) + (reverse (ps-truncate-opaque ps))) + +;; ps-truncate-opaque : PS -> PS +;; Returns maximal tail with no 'opaque frame. +(define (ps-truncate-opaque ps) + (let loop ([ps ps] [acc ps]) + ;; acc is the biggest tail that has not been seen to contain 'opaque + (cond [(null? ps) acc] + [(eq? (car ps) 'opaque) + (loop (cdr ps) (cdr ps))] + [else (loop (cdr ps) acc)]))) + +;; maximal/progress : (listof (cons IPS A)) -> (listof (listof A)) +;; Eliminates As with non-maximal progress, then groups As into +;; equivalence classes according to progress. +(define (maximal/progress items) + (cond [(null? items) + null] + [(null? (cdr items)) + (list (list (cdr (car items))))] + [else + (let loop ([items items] [non-ORD-items null]) + (define-values (ORD non-ORD) + (partition (lambda (item) (ord? (item-first-prf item))) items)) + (cond [(pair? ORD) + (loop (maximal-prf1/ord ORD) (append non-ORD non-ORD-items))] + [else + (maximal/prf1 (append non-ORD non-ORD-items))]))])) + +;; maximal/prf1 : (Listof (Cons IPS A) -> (Listof (Listof A)) +(define (maximal/prf1 items) + (define-values (POST rest1) + (partition (lambda (item) (eq? 'post (item-first-prf item))) items)) + (cond [(pair? POST) + (maximal/progress (map item-pop-prf POST))] + [else + (define-values (STX rest2) + (partition (lambda (item) (syntax? (item-first-prf item))) rest1)) + (define-values (CDR rest3) + (partition (lambda (item) (exact-integer? (item-first-prf item))) rest2)) + (define-values (CAR rest4) + (partition (lambda (item) (eq? 'car (item-first-prf item))) rest3)) + (define-values (NULL rest5) + (partition (lambda (item) (eq? '#f (item-first-prf item))) rest4)) + (unless (null? rest5) + (error 'syntax-parse "INTERNAL ERROR: bad progress: ~e\n" rest5)) + (cond [(pair? CDR) + (define leastCDR (apply min (map item-first-prf CDR))) + (append + (maximal/stx STX) + (maximal/progress (map (lambda (item) (item-pop-prf-ncdrs item leastCDR)) CDR)))] + [(pair? CAR) + (append + (maximal/stx STX) + (maximal/progress (map item-pop-prf CAR)))] + [(pair? STX) + (maximal/stx STX)] + [(pair? NULL) + (list (map cdr NULL))] + [else null])])) + +;; maximal-prf1/ord : (NEListof (Cons IPS A)) -> (NEListof (Cons IPS A)) +;; PRE: each item has ORD first frame +;; Keep only maximal by first frame and pop first frame from each item. +(define (maximal-prf1/ord items) + ;; groups : (NEListof (NEListof (cons A IPS))) + (define groups (group-by (lambda (item) (ord-group (item-first-prf item))) items)) + (append* + (for/list ([group (in-list groups)]) + (define group* (filter-max group (lambda (item) (ord-index (item-first-prf item))))) + (map item-pop-prf group*)))) + +;; maximal/stx : (NEListof (cons IPS A)) -> (NEListof (NEListof A)) +;; PRE: Each IPS starts with a stx frame. +(define (maximal/stx items) + ;; groups : (Listof (Listof (cons IPS A))) + (define groups (group-by item-first-prf items)) + (append* + (for/list ([group (in-list groups)]) + (maximal/progress (map item-pop-prf group))))) + +;; filter-max : (Listof X) (X -> Nat) -> (Listof X) +(define (filter-max xs x->nat) + (let loop ([xs xs] [nmax -inf.0] [r-keep null]) + (cond [(null? xs) + (reverse r-keep)] + [else + (define n0 (x->nat (car xs))) + (cond [(> n0 nmax) + (loop (cdr xs) n0 (list (car xs)))] + [(= n0 nmax) + (loop (cdr xs) nmax (cons (car xs) r-keep))] + [else + (loop (cdr xs) nmax r-keep)])]))) + +;; item-first-prf : (cons IPS A) -> prframe/#f +(define (item-first-prf item) + (define ips (car item)) + (and (pair? ips) (car ips))) + +;; item-split-ord : (cons IPS A) -> (cons IPS (cons IPS A)) +(define (item-split-ord item) + (define ips (car item)) + (define a (cdr item)) + (define-values (rest-ips r-ord) + (let loop ([ips ips] [r-ord null]) + (cond [(and (pair? ips) (ord? (car ips))) + (loop (cdr ips) (cons (car ips) r-ord))] + [else (values ips r-ord)]))) + (list* (reverse r-ord) rest-ips a)) + +;; item-pop-prf : (cons IPS A) -> (cons IPS A) +(define (item-pop-prf item) + (let ([ips (car item)] + [a (cdr item)]) + (cons (cdr ips) a))) + +;; item-pop-prf-ncdrs : (cons IPS A) -> (cons IPS A) +;; Assumes first frame is nat > ncdrs. +(define (item-pop-prf-ncdrs item ncdrs) + (let ([ips (car item)] + [a (cdr item)]) + (cond [(= (car ips) ncdrs) (cons (cdr ips) a)] + [else (cons (cons (- (car ips) ncdrs) (cdr ips)) a)]))) + +;; ps->stx+index : Progress -> (cons Syntax Nat) +;; Gets the innermost stx that should have a real srcloc, and the offset +;; (number of cdrs) within that where the progress ends. +(define (ps->stx+index ps) + (define (interp ps) + (match ps + [(cons (? syntax? stx) _) stx] + [(cons 'car parent) + (let* ([d (interp parent)] + [d (if (syntax? d) (syntax-e d) d)]) + (cond [(pair? d) (car d)] + [(vector? d) (vector->list d)] + [(box? d) (unbox d)] + [(prefab-struct-key d) (struct->list d)] + [else (error 'ps->stx+index "INTERNAL ERROR: unexpected: ~e" d)]))] + [(cons (? exact-positive-integer? n) parent) + (for/fold ([stx (interp parent)]) ([i (in-range n)]) + (stx-cdr stx))] + [(cons (? ord?) parent) + (interp parent)] + [(cons 'post parent) + (interp parent)])) + (let ([ps (ps-truncate-opaque ps)]) + (match ps + [(cons (? syntax? stx) _) + (cons stx 0)] + [(cons 'car parent) + (cons (interp ps) 0)] + [(cons (? exact-positive-integer? n) parent) + (cons (interp parent) n)] + [(cons (? ord?) parent) + (ps->stx+index parent)] + [(cons 'post parent) + (ps->stx+index parent)]))) + + +;; ============================================================ +;; Expectation simplification + +;; normalize-expectstack : ExpectStack StxIdx -> ExpectList +;; Converts to list, converts expect:thing term rep, and truncates +;; expectstack after opaque (ie, transparent=#f) frames. +(define (normalize-expectstack es stx+index [truncate-opaque? #t]) + (reverse (invert-expectstack es stx+index truncate-opaque?))) + +;; invert-expectstack : ExpectStack StxIdx -> RExpectList +;; Converts to reversed list, converts expect:thing term rep, +;; and truncates expectstack after opaque (ie, transparent=#f) frames. +(define (invert-expectstack es stx+index [truncate-opaque? #t]) + (let loop ([es es] [acc null]) + (match es + ['#f acc] + ['#t acc] + [(expect:thing ps desc tr? role rest-es) + (cond [(and truncate-opaque? (not tr?)) + (loop rest-es (cons (expect:thing #f desc #t role (ps->stx+index ps)) null))] + [else + (loop rest-es (cons (expect:thing #f desc tr? role (ps->stx+index ps)) acc))])] + [(expect:message message rest-es) + (loop rest-es (cons (expect:message message stx+index) acc))] + [(expect:atom atom rest-es) + (loop rest-es (cons (expect:atom atom stx+index) acc))] + [(expect:literal literal rest-es) + (loop rest-es (cons (expect:literal literal stx+index) acc))] + [(expect:proper-pair first-desc rest-es) + (loop rest-es (cons (expect:proper-pair first-desc stx+index) acc))]))) + +;; expect->stxidx : Expect -> StxIdx +(define (expect->stxidx e) + (cond [(expect:thing? e) (expect:thing-next e)] + [(expect:message? e) (expect:message-next e)] + [(expect:atom? e) (expect:atom-next e)] + [(expect:literal? e) (expect:literal-next e)] + [(expect:proper-pair? e) (expect:proper-pair-next e)] + [(expect:disj? e) (expect:disj-next e)])) + +#| Simplification + +A list of ExpectLists represents a tree, with shared tails meaning shared +branches of the tree. We need a "reasonable" way to simplify it to a list to +show to the user. Here we develop "reasonable" by example. (It would be nice, +of course, to also have some way of exploring the full failure trees.) + +Notation: [A B X] means an ExpectList with class/description A at root and X +at leaf. If the term sequences differ, write [t1:A ...] etc. + +Options: + (o) = "old behavior (through 6.4)" + (f) = "first divergence" + (s) = "sync on shared" + +Case 1: [A B X], [A B Y] + + This is nearly the ideal situation: report as + + expected X or Y, while parsing B, while parsing A + +Case 2: [A X], [A] + + For example, matching #'1 as (~describe A (x:id ...)) yields [A], [A '()], + but we don't want to see "expected ()". + + So simplify to [A]---that is, drop X. + +But there are other cases that are more problematic. + +Case 3: [t1:A t2:B t3:X], [t1:A t2:C t3:Y] + + Could report as: + (o) expected X for t3, while parsing t2 as B, while parsing t1 as A (also other errors) + (f) expected B or C for t2, while parsing t1 as A + (x) expected X or Y for t3, while parsing t2 as B or C, while parsing t1 as A + + (o) is not good + (b) loses the most specific error information + (x) implies spurious contexts (eg, X while parsing C) + + I like (b) best for this situation, but ... + +Case 4: [t1:A t2:B t4:X], [t1:A t3:C t4:Y] + + Could report as: + (f') expected B or C, while parsing t1 as A + (s) expected X or Y for t4, while ..., while parsing t1 as A + (f) expected A for t1 + + (f') is problematic, since terms are different! + (s) okay, but nothing good to put in that ... space + (f) loses a lot of information + +Case 5: [t1:A t2:B t3:X], [t1:A t4:C t5:Y] + + Only feasible choice (no other sync points): + (f,s) expected A for t1 + +Case 6: [t1:A _ t2:B t3:X], [t1:A _ t2:C t3:Y] + + Could report as: + (s') expected X or Y for t3, while parsing t2 as B or C, while ..., while parsing t1 as A + (s) expected X or Y for t3, while ..., while parsing t1 as A + + (s') again implies spurious contexts, bad + (s) okay + +Case 7: [_ t2:B t3:C _], [_ t3:C t2:B _] + + Same frames show up in different orders. (Can this really happen? Probably, + with very weird uses of ~parse.) + +-- + +This suggests the following new algorithm based on (s): +- Step 1: emit an intermediate "unified" expectstack (extended with "..." markers) + - make a list (in order) of frames shared by all expectstacks + - emit those frames with "..." markers if (sometimes) unshared stuff between + - continue processing with the tails after the last shared frame: + - find the last term shared by all expectstacks (if any) + - find the last frame for that term for each expectstack + - combine in expect:disj and emit +- Step 2: + - remove trailing and collapse adjacent "..." markers + +|# + +;; report* : (NEListof RExpectList) ((NEListof (NEListof RExpectList)) -> ExpectList) +;; -> Report +(define (report* ess handle-divergence) + (define es ;; ExpectList + (let loop ([ess ess] [acc null]) + (cond [(ormap null? ess) acc] + [else + (define groups (group-by car ess)) + (cond [(singleton? groups) + (define group (car groups)) + (define frame (car (car group))) + (loop (map cdr group) (cons frame acc))] + [else ;; found point of divergence + (append (handle-divergence groups) acc)])]))) + (define stx+index (if (pair? es) (expect->stxidx (car es)) (cons #f 0))) + (report/expectstack (clean-up es) (car stx+index) (cdr stx+index))) + +;; clean-up : ExpectList -> ExpectList +;; Remove leading and collapse adjacent '... markers +(define (clean-up es) + (if (and (pair? es) (eq? (car es) '...)) + (clean-up (cdr es)) + (let loop ([es es]) + (cond [(null? es) null] + [(eq? (car es) '...) + (cons '... (clean-up es))] + [else (cons (car es) (loop (cdr es)))])))) + +;; -- + +;; report/first-divergence : (NEListof RExpectList) -> Report +;; Generate a single report, using frames from root to first divergence. +(define (report/first-divergence ess) + (report* ess handle-divergence/first)) + +;; handle-divergence/first : (NEListof (NEListof RExpectList)) -> ExpectList +(define (handle-divergence/first ess-groups) + (define representative-ess (map car ess-groups)) + (define first-frames (map car representative-ess)) + ;; Do all of the first frames talk about the same term? + (cond [(all-equal? (map expect->stxidx first-frames)) + (list (expect:disj first-frames #f))] + [else null])) + +;; -- + +;; report/sync-shared : (NEListof RExpectList) -> Report +;; Generate a single report, syncing on shared frames (and later, terms). +(define (report/sync-shared ess) + (report* ess handle-divergence/sync-shared)) + +;; handle-divergence/sync-shared : (NEListof (NEListof RExpectList)) -> ExpectList +(define (handle-divergence/sync-shared ess-groups) + (define ess (append* ess-groups)) ;; (NEListof RExpectList) + (define shared-frames (get-shared ess values)) + ;; rsegs : (NEListof (Rev2n+1-Listof RExpectList)) + (define rsegs (for/list ([es (in-list ess)]) (rsplit es values shared-frames))) + (define final-seg (map car rsegs)) ;; (NEListof RExpectList), no common frames + (define ctx-rsegs (transpose (map cdr rsegs))) ;; (Rev2n-Listof (NEListof RExpectList)) + (append (hd/sync-shared/final final-seg) + (hd/sync-shared/ctx ctx-rsegs))) + +;; hd/sync-shared/final : (NEListof RExpectList) -> ExpectList +;; PRE: ess has no shared frames, but may have shared terms. +(define (hd/sync-shared/final ess0) + (define ess (remove-extensions ess0)) + (define shared-terms (get-shared ess expect->stxidx)) + (cond [(null? shared-terms) null] + [else + ;; split at the last shared term + (define rsegs ;; (NEListof (3-Listof RExpectList)) + (for/list ([es (in-list ess)]) + (rsplit es expect->stxidx (list (last shared-terms))))) + ;; only care about the got segment and pre, not post + (define last-term-ess ;; (NEListof RExpectList) + (map cadr rsegs)) + (define pre-term-ess ;; (NEListof RExpectList) + (map caddr rsegs)) + ;; last is most specific + (append + (list (expect:disj (remove-duplicates (reverse (map last last-term-ess))) + (last shared-terms))) + (if (ormap pair? pre-term-ess) '(...) '()))])) + +;; hd/sync-shared/ctx : (Rev2n-Listof (NEListof RExpectList)) -> ExpectList +;; In [gotN preN ... got1 pre1] order, where 1 is root-most, N is leaf-most. +;; We want leaf-most-first, so just process naturally. +(define (hd/sync-shared/ctx rsegs) + (let loop ([rsegs rsegs]) + (cond [(null? rsegs) null] + [(null? (cdr rsegs)) (error 'syntax-parse "INTERNAL ERROR: bad segments")] + [else (append + ;; shared frame: possible for duplicate ctx frames, but unlikely + (let ([ess (car rsegs)]) (list (car (car ess)))) + ;; inter frames: + (let ([ess (cadr rsegs)]) (if (ormap pair? ess) '(...) '())) + ;; recur + (loop (cddr rsegs)))]))) + +;; transpose : (Listof (Listof X)) -> (Listof (Listof X)) +(define (transpose xss) + (cond [(ormap null? xss) null] + [else (cons (map car xss) (transpose (map cdr xss)))])) + +;; get-shared : (Listof (Listof X)) (X -> Y) -> (Listof Y) +;; Return a list of Ys s.t. occur in order in (map of) each xs in xss. +(define (get-shared xss get-y) + (cond [(null? xss) null] + [else + (define yhs ;; (Listof (Hash Y => Nat)) + (for/list ([xs (in-list xss)]) + (for/hash ([x (in-list xs)] [i (in-naturals 1)]) + (values (get-y x) i)))) + (remove-duplicates + (let loop ([xs (car xss)] [last (for/list ([xs (in-list xss)]) 0)]) + ;; last is list of indexes of last accepted y; only accept next if occurs + ;; after last in every sequence (see Case 7 above) + (cond [(null? xs) null] + [else + (define y (get-y (car xs))) + (define curr (for/list ([yh (in-list yhs)]) (hash-ref yh y -1))) + (cond [(andmap > curr last) + (cons y (loop (cdr xs) curr))] + [else (loop (cdr xs) last)])])))])) + +;; rsplit : (Listof X) (X -> Y) (Listof Y) -> (Listof (Listof X)) +;; Given [y1 ... yN], splits xs into [rest gotN preN ... got1 pre1]. +;; Thus the result has 2N+1 elements. The sublists are in original order. +(define (rsplit xs get-y ys) + (define (loop xs ys segsacc) + (cond [(null? ys) (cons xs segsacc)] + [else (pre-loop xs ys segsacc null)])) + (define (pre-loop xs ys segsacc preacc) + (cond [(and (pair? xs) (equal? (get-y (car xs)) (car ys))) + (got-loop (cdr xs) ys segsacc preacc (list (car xs)))] + [else + (pre-loop (cdr xs) ys segsacc (cons (car xs) preacc))])) + (define (got-loop xs ys segsacc preacc gotacc) + (cond [(and (pair? xs) (equal? (get-y (car xs)) (car ys))) + (got-loop (cdr xs) ys segsacc preacc (cons (car xs) gotacc))] + [else + (loop xs (cdr ys) (list* (reverse gotacc) (reverse preacc) segsacc))])) + (loop xs ys null)) + +;; singleton? : list -> boolean +(define (singleton? x) (and (pair? x) (null? (cdr x)))) + +;; remove-extensions : (Listof (Listof X)) -> (Listof (Listof X)) +;; Remove any element that is an extension of another. +(define (remove-extensions xss) + (cond [(null? xss) null] + [else + (let loop ([xss xss]) + (cond [(singleton? xss) xss] + [(ormap null? xss) (list null)] + [else + (define groups (group-by car xss)) + (append* + (for/list ([group (in-list groups)]) + (define group* (loop (map cdr group))) + (map (lambda (x) (cons (caar group) x)) group*)))]))])) + +;; all-equal? : (Listof Any) -> Boolean +(define (all-equal? xs) (for/and ([x (in-list xs)]) (equal? x (car xs)))) + + +;; ============================================================ +;; Reporting + +;; report/expectstack : ExpectList Syntax Nat -> Report +(define (report/expectstack es stx index) + (define frame-expect (and (pair? es) (car es))) + (define context-frames (if (pair? es) (cdr es) null)) + (define context (append* (map context-prose-for-expect context-frames))) + (cond [(not frame-expect) + (report "bad syntax" context #f #f)] + [else + (define-values (x cx) (stx-list-drop/cx stx stx index)) + (define frame-stx (datum->syntax cx x cx)) + (define within-stx (if (syntax? x) #f cx)) + (cond [(and (match frame-expect [(expect:atom '() _) #t] [_ #f]) + (stx-pair? frame-stx)) + (report "unexpected term" context (stx-car frame-stx) #f)] + [(expect:disj? frame-expect) + (report (prose-for-expects (expect:disj-expects frame-expect)) + context frame-stx within-stx)] + [else + (report (prose-for-expects (list frame-expect)) + context frame-stx within-stx)])])) + +;; prose-for-expects : (listof Expect) -> string +(define (prose-for-expects expects) + (define msgs (filter expect:message? expects)) + (define things (filter expect:thing? expects)) + (define literal (filter expect:literal? expects)) + (define atom/symbol + (filter (lambda (e) (and (expect:atom? e) (symbol? (expect:atom-atom e)))) expects)) + (define atom/nonsym + (filter (lambda (e) (and (expect:atom? e) (not (symbol? (expect:atom-atom e))))) expects)) + (define proper-pairs (filter expect:proper-pair? expects)) + (join-sep + (append (map prose-for-expect (append msgs things)) + (prose-for-expects/literals literal "identifiers") + (prose-for-expects/literals atom/symbol "literal symbols") + (prose-for-expects/literals atom/nonsym "literals") + (prose-for-expects/pairs proper-pairs)) + ";" "or")) + +(define (prose-for-expects/literals expects whats) + (cond [(null? expects) null] + [(singleton? expects) (map prose-for-expect expects)] + [else + (define (prose e) + (match e + [(expect:atom (? symbol? atom) _) + (format "`~s'" atom)] + [(expect:atom atom _) + (format "~s" atom)] + [(expect:literal literal _) + (format "`~s'" (syntax-e literal))])) + (list (string-append "expected one of these " whats ": " + (join-sep (map prose expects) "," "or")))])) + +(define (prose-for-expects/pairs expects) + (if (pair? expects) (list (prose-for-proper-pair-expects expects)) null)) + +;; prose-for-expect : Expect -> string +(define (prose-for-expect e) + (match e + [(expect:thing _ description transparent? role _) + (if role + (format "expected ~a for ~a" description role) + (format "expected ~a" description))] + [(expect:atom (? symbol? atom) _) + (format "expected the literal symbol `~s'" atom)] + [(expect:atom atom _) + (format "expected the literal ~s" atom)] + [(expect:literal literal _) + (format "expected the identifier `~s'" (syntax-e literal))] + [(expect:message message _) + message] + [(expect:proper-pair '#f _) + "expected more terms"])) + +;; prose-for-proper-pair-expects : (listof expect:proper-pair) -> string +(define (prose-for-proper-pair-expects es) + (define descs (remove-duplicates (map expect:proper-pair-first-desc es))) + (cond [(for/or ([desc descs]) (equal? desc #f)) + ;; FIXME: better way to indicate unknown ??? + "expected more terms"] + [else + (format "expected more terms starting with ~a" + (join-sep (map prose-for-first-desc descs) + "," "or"))])) + +;; prose-for-first-desc : FirstDesc -> string +(define (prose-for-first-desc desc) + (match desc + [(? string?) desc] + [(list 'any) "any term"] ;; FIXME: maybe should cancel out other descs ??? + [(list 'literal id) (format "the identifier `~s'" id)] + [(list 'datum (? symbol? s)) (format "the literal symbol `~s'" s)] + [(list 'datum d) (format "the literal ~s" d)])) + +;; context-prose-for-expect : (U '... expect:thing) -> (listof string) +(define (context-prose-for-expect e) + (match e + ['... + (list "while parsing different things...")] + [(expect:thing '#f description transparent? role stx+index) + (let ([stx (stx+index->stx stx+index)]) + (cons (~a "while parsing " description + (if role (~a " for " role) "")) + (if (error-print-source-location) + (list (~a " term: " + (~s (syntax->datum stx) + #:limit-marker "..." + #:max-width 50)) + (~a " location: " + (or (source-location->string stx) "not available"))) + null)))])) + +(define (stx+index->stx stx+index) + (let*-values ([(stx) (car stx+index)] + [(index) (cdr stx+index)] + [(x cx) (stx-list-drop/cx stx stx index)]) + (datum->syntax cx x cx))) + + +;; ============================================================ +;; Raise exception + +(define (error/report ctx report) + (let* ([message (report-message report)] + [context (report-context report)] + [stx (cadr ctx)] + [who (or (car ctx) (infer-who stx))] + [sub-stx (report-stx report)] + [within-stx (report-within-stx report)] + [message + (format "~a: ~a~a~a~a~a" + who message + (format-if "at" (stx-if-loc sub-stx)) + (format-if "within" (stx-if-loc within-stx)) + (format-if "in" (stx-if-loc stx)) + (if (null? context) + "" + (apply string-append + "\n parsing context: " + (for/list ([c (in-list context)]) + (format "\n ~a" c)))))] + [message + (if (error-print-source-location) + (let ([source-stx (or stx sub-stx within-stx)]) + (string-append (source-location->prefix source-stx) message)) + message)]) + (raise + (exn:fail:syntax message (current-continuation-marks) + (map syntax-taint + (cond [within-stx (list within-stx)] + [sub-stx (list sub-stx)] + [stx (list stx)] + [else null])))))) + +(define (format-if prefix val) + (if val + (format "\n ~a: ~a" prefix val) + "")) + +(define (stx-if-loc stx) + (and (syntax? stx) + (error-print-source-location) + (format "~.s" (syntax->datum stx)))) + +(define (infer-who stx) + (let* ([maybe-id (if (stx-pair? stx) (stx-car stx) stx)]) + (if (identifier? maybe-id) (syntax-e maybe-id) '?))) + +(define (comma-list items) + (join-sep items "," "or")) + +(define (improper-stx->list stx) + (syntax-case stx () + [(a . b) (cons #'a (improper-stx->list #'b))] + [() null] + [rest (list #'rest)])) + + +;; ============================================================ +;; Debugging + +(provide failureset->sexpr + failure->sexpr + expectstack->sexpr + expect->sexpr) + +(define (failureset->sexpr fs) + (let ([fs (flatten fs)]) + (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 ps)]) + (match pf + [(? syntax? stx) 'stx] + [_ pf]))) diff --git a/parse/private/runtime.rkt b/parse/private/runtime.rkt @@ -0,0 +1,220 @@ +#lang racket/base +(require racket/stxparam + syntax/parse/private/residual ;; keep abs. path + (for-syntax racket/base + racket/list + syntax/kerncase + syntax/strip-context + racket/private/sc + racket/syntax + "rep-data.rkt")) + +(provide with + fail-handler + cut-prompt + wrap-user-code + + fail + try + + let-attributes + let-attributes* + let/unpack + + defattrs/unpack + + check-literal + no-shadow + curried-stxclass-parser + app-argu) + +#| +TODO: rename file + +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 == + +(define-syntax (with stx) + (syntax-case stx () + [(with ([stxparam expr] ...) . body) + (with-syntax ([(var ...) (generate-temporaries #'(stxparam ...))]) + (syntax/loc stx + (let ([var expr] ...) + (syntax-parameterize ((stxparam (make-rename-transformer (quote-syntax var))) + ...) + . body))))])) + +;; == Control information == + +(define-syntax-parameter fail-handler + (lambda (stx) + (wrong-syntax stx "internal error: fail-handler used out of context"))) +(define-syntax-parameter cut-prompt + (lambda (stx) + (wrong-syntax stx "internal error: cut-prompt used out of context"))) + +(define-syntax-rule (wrap-user-code e) + (with ([fail-handler #f] + [cut-prompt #t]) + e)) + +(define-syntax-rule (fail fs) + (fail-handler fs)) + +(define-syntax (try stx) + (syntax-case stx () + [(try e0 e ...) + (with-syntax ([(re ...) (reverse (syntax->list #'(e ...)))]) + (with-syntax ([(fh ...) (generate-temporaries #'(re ...))]) + (with-syntax ([(next-fh ...) (drop-right (syntax->list #'(fail-handler fh ...)) 1)] + [(last-fh) (take-right (syntax->list #'(fail-handler fh ...)) 1)]) + #'(let* ([fh (lambda (fs1) + (with ([fail-handler + (lambda (fs2) + (next-fh (cons fs1 fs2)))]) + re))] + ...) + (with ([fail-handler last-fh]) + e0)))))])) + +;; == Attributes + +(define-for-syntax (parse-attr x) + (syntax-case x () + [#s(attr name depth syntax?) #'(name depth syntax?)])) + +(define-syntax (let-attributes stx) + (syntax-case stx () + [(let-attributes ([a value] ...) . body) + (with-syntax ([((name depth syntax?) ...) + (map parse-attr (syntax->list #'(a ...)))]) + (with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))] + [(stmp ...) (generate-temporaries #'(name ...))]) + #'(letrec-syntaxes+values + ([(stmp) (make-attribute-mapping (quote-syntax vtmp) + 'name 'depth 'syntax?)] ...) + ([(vtmp) value] ...) + (letrec-syntaxes+values + ([(name) (make-syntax-mapping 'depth (quote-syntax stmp))] ...) + () + . body))))])) + +;; (let-attributes* (([id num] ...) (expr ...)) expr) : expr +;; Special case: empty attrs need not match number of value exprs. +(define-syntax let-attributes* + (syntax-rules () + [(la* (() _) . body) + (let () . body)] + [(la* ((a ...) (val ...)) . body) + (let-attributes ([a val] ...) . body)])) + +;; (let/unpack (([id num] ...) expr) expr) : expr +;; Special case: empty attrs need not match packed length +(define-syntax (let/unpack stx) + (syntax-case stx () + [(let/unpack (() packed) body) + #'body] + [(let/unpack ((a ...) packed) body) + (with-syntax ([(tmp ...) (generate-temporaries #'(a ...))]) + #'(let-values ([(tmp ...) (apply values packed)]) + (let-attributes ([a tmp] ...) body)))])) + +(define-syntax (defattrs/unpack stx) + (syntax-case stx () + [(defattrs (a ...) packed) + (with-syntax ([((name depth syntax?) ...) + (map parse-attr (syntax->list #'(a ...)))]) + (with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))] + [(stmp ...) (generate-temporaries #'(name ...))]) + #'(begin (define-values (vtmp ...) (apply values packed)) + (define-syntax stmp + (make-attribute-mapping (quote-syntax vtmp) + 'name 'depth 'syntax?)) + ... + (define-syntax name (make-syntax-mapping 'depth (quote-syntax stmp))) + ...)))])) + +(define-syntax-rule (phase-of-enclosing-module) + (variable-reference->module-base-phase + (#%variable-reference))) + +;; (check-literal id phase-level-expr ctx) -> void +(define-syntax (check-literal stx) + (syntax-case stx () + [(check-literal id used-phase-expr ctx) + (let* ([ok-phases/ct-rel + ;; id is bound at each of ok-phases/ct-rel + ;; (phase relative to the compilation of the module in which the + ;; 'syntax-parse' (or related) form occurs) + (filter (lambda (p) (identifier-binding #'id p)) '(0 1 -1 #f))]) + ;; so we can avoid run-time call to identifier-binding if + ;; (+ (phase-of-enclosing-module) ok-phase/ct-rel) = used-phase + (with-syntax ([ok-phases/ct-rel ok-phases/ct-rel]) + #`(check-literal* (quote-syntax id) + used-phase-expr + (phase-of-enclosing-module) + 'ok-phases/ct-rel + ;; If context is not stripped, racket complains about + ;; being unable to restore bindings for compiled code; + ;; and all we want is the srcloc, etc. + (quote-syntax #,(strip-context #'ctx)))))])) + +;; ==== + +(begin-for-syntax + (define (check-shadow def) + (syntax-case def () + [(_def (x ...) . _) + (parameterize ((current-syntax-context def)) + (for ([x (in-list (syntax->list #'(x ...)))]) + (let ([v (syntax-local-value x (lambda _ #f))]) + (when (syntax-pattern-variable? v) + (wrong-syntax + x + ;; FIXME: customize "~do pattern" vs "#:do block" as appropriate + "definition in ~~do pattern must not shadow attribute binding")))))]))) + +(define-syntax (no-shadow stx) + (syntax-case stx () + [(no-shadow e) + (let ([ee (local-expand #'e (syntax-local-context) + (kernel-form-identifier-list))]) + (syntax-case ee (begin define-values define-syntaxes) + [(begin d ...) + #'(begin (no-shadow d) ...)] + [(define-values . _) + (begin (check-shadow ee) + ee)] + [(define-syntaxes . _) + (begin (check-shadow ee) + ee)] + [_ + ee]))])) + +(define-syntax (curried-stxclass-parser stx) + (syntax-case stx () + [(_ class argu) + (with-syntax ([#s(arguments (parg ...) (kw ...) _) #'argu]) + (let ([sc (get-stxclass/check-arity #'class #'class + (length (syntax->list #'(parg ...))) + (syntax->datum #'(kw ...)))]) + (with-syntax ([parser (stxclass-parser sc)]) + #'(lambda (x cx pr es fh cp rl success) + (app-argu parser x cx pr es fh cp rl success argu)))))])) + +(define-syntax (app-argu stx) + (syntax-case stx () + [(aa proc extra-parg ... #s(arguments (parg ...) (kw ...) (kwarg ...))) + #| + Use keyword-apply directly? + #'(keyword-apply proc '(kw ...) (list kwarg ...) parg ... null) + If so, create separate no-keyword clause. + |# + ;; For now, let #%app handle it. + (with-syntax ([((kw-part ...) ...) #'((kw kwarg) ...)]) + #'(proc kw-part ... ... extra-parg ... parg ...))])) diff --git a/parse/private/sc.rkt b/parse/private/sc.rkt @@ -0,0 +1,75 @@ +#lang racket/base +(require (for-syntax racket/base + racket/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 + racket/syntax + racket/stxparam + syntax/stx) + +(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:define-integrable-syntax-class + id:syntax-parse + id:syntax-parser + id:define/syntax-parse + id:syntax-parser/template + id:parser/rhs + id:define-eh-alternative-set)])) +;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require) +;; Without this, dependencies don't get collected. +(require racket/runtime-path (for-meta 2 '#%kernel)) +(define-runtime-module-path-index _unused_ 'syntax/parse/private/parse-aux) + +(provide define-syntax-class + define-splicing-syntax-class + define-integrable-syntax-class + syntax-parse + syntax-parser + define/syntax-parse + + (except-out (all-from-out "keywords.rkt") + ~reflect + ~splicing-reflect + ~eh-var) + attribute + this-syntax + + syntax-parser/template + parser/rhs + define-eh-alternative-set) + +(define-syntaxes (define-syntax-class + define-splicing-syntax-class + define-integrable-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:define-integrable-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/parse/private/txlift.rkt b/parse/private/txlift.rkt @@ -0,0 +1,45 @@ +#lang racket/base +(require (for-template racket/base)) +(provide txlift + get-txlifts-as-definitions + with-txlifts + call/txlifts) + +;; Like lifting definitions, but within a single transformer. + +;; current-liftbox : Parameter of [#f or (Listof (list Id Stx))] +(define current-liftbox (make-parameter #f)) + +(define (call/txlifts proc) + (parameterize ((current-liftbox (box null))) + (proc))) + +(define (txlift expr) + (let ([liftbox (current-liftbox)]) + (check 'txlift liftbox) + (let ([var (car (generate-temporaries '(txlift)))]) + (set-box! liftbox (cons (list var expr) (unbox liftbox))) + var))) + +(define (get-txlifts) + (let ([liftbox (current-liftbox)]) + (check 'get-txlifts liftbox) + (reverse (unbox liftbox)))) + +(define (get-txlifts-as-definitions) + (let ([liftbox (current-liftbox)]) + (check 'get-txlifts-as-definitions liftbox) + (map (lambda (p) + #`(define #,@p)) + (reverse (unbox liftbox))))) + +(define (check who lb) + (unless (box? lb) + (error who "not in a txlift-catching context"))) + +(define (with-txlifts proc) + (call/txlifts + (lambda () + (let ([v (proc)]) + (with-syntax ([((var rhs) ...) (get-txlifts)]) + #`(let* ([var rhs] ...) #,v)))))) diff --git a/parse/todo.txt b/parse/todo.txt @@ -0,0 +1,48 @@ +Things to do for syntax/parse +============================= + +TEST & DOC - Generalize stxclass arities. +TEST & DOC - provide-syntax-class/contract + +Refine expr/c. + +Wrap default args in stxclass parameters with 'this-syntax' + - other stxparams? like 'this-base-syntax' etc? + +Add debugging mode that records *all* intermediate patterns +on expectstack. + +Add "roles" to error messages, eg + expected identifier for foo thingummy name +instead of the current + expected identifier + +Improve ~do. + +Improve reflection. + +More cowbell. + +Reorganize tests. + +Allow reflected syntax classes in conventions. + +Rename "conventions" to "convention-set"? + +Unify convention-sets and literal-sets? + +For documentation, talk about "primary attributes" vs "nested +attributes". Helps explain ~eh-var and #:auto-nested-attributes. + +For documentation, deftech "term-sequence", use consistently in +H-pattern docs, etc. + +Add documentation sections: + - Pattern matching model + - Static semantics (attributes) + +Add syntax exception variant with more information. + +Fix syntaxes pinpointed for repetition constraint violations. + +Make a #:with-like version of #:defaults (currently #:attr-like).