From 3e63caa88768897debe07c1aec41442ece520784 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 3 Jul 2009 19:47:25 +0000 Subject: [PATCH] merged changes from /branches/ryanc/sp2: added syntax/parse library and documentation added syntax/id-table library and documentation svn: r15376 --- .../macro-debugger/model/reductions-config.ss | 2 +- collects/syntax/id-table.ss | 72 ++ collects/syntax/parse.ss | 6 + collects/syntax/private/id-table.ss | 302 ++++++ .../syntax/private/stxparse/codegen-data.ss | 111 +++ collects/syntax/private/stxparse/lib.ss | 87 ++ collects/syntax/private/stxparse/parse.ss | 565 +++++++++++ collects/syntax/private/stxparse/rep-attrs.ss | 170 ++++ collects/syntax/private/stxparse/rep-data.ss | 232 +++++ .../syntax/private/stxparse/rep-patterns.ss | 147 +++ collects/syntax/private/stxparse/rep.ss | 815 +++++++++++++++ .../syntax/private/stxparse/runtime-prose.ss | 149 +++ collects/syntax/private/stxparse/runtime.ss | 382 ++++++++ collects/syntax/private/stxparse/sc.ss | 213 ++++ collects/syntax/private/util.ss | 9 + collects/syntax/private/util/error.ss | 16 + collects/syntax/private/util/expand.ss | 88 ++ collects/syntax/private/util/misc.ss | 239 +++++ collects/syntax/private/util/struct.ss | 39 + collects/syntax/scribblings/boundmap.scrbl | 6 +- collects/syntax/scribblings/id-table.scrbl | 202 ++++ collects/syntax/scribblings/parse.scrbl | 926 ++++++++++++++++++ .../scribblings/syntax-object-helpers.scrbl | 1 + collects/syntax/scribblings/syntax.scrbl | 1 + collects/tests/mzscheme/id-table-test.ss | 214 ++++ collects/tests/mzscheme/syntax-tests.ss | 1 + collects/tests/stxclass/stxclass.ss | 189 +--- collects/tests/stxclass/test.ss | 251 +++++ 28 files changed, 5283 insertions(+), 152 deletions(-) create mode 100644 collects/syntax/id-table.ss create mode 100644 collects/syntax/parse.ss create mode 100644 collects/syntax/private/id-table.ss create mode 100644 collects/syntax/private/stxparse/codegen-data.ss create mode 100644 collects/syntax/private/stxparse/lib.ss create mode 100644 collects/syntax/private/stxparse/parse.ss create mode 100644 collects/syntax/private/stxparse/rep-attrs.ss create mode 100644 collects/syntax/private/stxparse/rep-data.ss create mode 100644 collects/syntax/private/stxparse/rep-patterns.ss create mode 100644 collects/syntax/private/stxparse/rep.ss create mode 100644 collects/syntax/private/stxparse/runtime-prose.ss create mode 100644 collects/syntax/private/stxparse/runtime.ss create mode 100644 collects/syntax/private/stxparse/sc.ss create mode 100644 collects/syntax/private/util.ss create mode 100644 collects/syntax/private/util/error.ss create mode 100644 collects/syntax/private/util/expand.ss create mode 100644 collects/syntax/private/util/misc.ss create mode 100644 collects/syntax/private/util/struct.ss create mode 100644 collects/syntax/scribblings/id-table.scrbl create mode 100644 collects/syntax/scribblings/parse.scrbl create mode 100644 collects/tests/mzscheme/id-table-test.ss create mode 100644 collects/tests/stxclass/test.ss diff --git a/collects/macro-debugger/model/reductions-config.ss b/collects/macro-debugger/model/reductions-config.ss index 97228ad960..2fbe36f068 100644 --- a/collects/macro-debugger/model/reductions-config.ss +++ b/collects/macro-debugger/model/reductions-config.ss @@ -240,7 +240,7 @@ stx (apply make-prefab-struct (prefab-struct-key stx) - (vector->list rinner))))] + (cdr (vector->list rinner)))))] [else stx])) ;; make-renames-mapping : stx stx -> stx kw-args -> stx diff --git a/collects/syntax/id-table.ss b/collects/syntax/id-table.ss new file mode 100644 index 0000000000..1c7ddc5778 --- /dev/null +++ b/collects/syntax/id-table.ss @@ -0,0 +1,72 @@ +#lang scheme/base +(require (for-syntax scheme/base) + scheme/contract + scheme/dict + "private/id-table.ss") +#| +(provide id-table-position?) + +(define id-table-position/c + (flat-named-contract "id-table-position or false" + (lambda (x) (or (id-table-position? x) + (eq? x #f))))) +|# + +(define-for-syntax (format-id stx fmt . args) + (datum->syntax stx (string->symbol (apply format fmt args)))) + +(define-syntax (make-code stx) + (syntax-case stx () + [(_ idtbl) + (with-syntax ([make-idtbl + (format-id #'idtbl "make-~a" (syntax-e #'idtbl))] + [make-immutable-idtbl + (format-id #'idtbl "make-immutable-~a" (syntax-e #'idtbl))] + [mutable-idtbl? + (format-id #'idtbl "mutable-~a?" (syntax-e #'idtbl))] + [immutable-idtbl? + (format-id #'idtbl "immutable-~a?" (syntax-e #'idtbl))]) + (define (s x) (format-id #'idtbl "~a~a" (syntax-e #'idtbl) x)) + (with-syntax ([idtbl? (s '?)] + [idtbl-ref (s '-ref)] + [idtbl-set! (s '-set!)] + [idtbl-set (s '-set)] + [idtbl-remove! (s '-remove!)] + [idtbl-remove (s '-remove)] + [idtbl-count (s '-count)] + [idtbl-iterate-first (s '-iterate-first)] + [idtbl-iterate-next (s '-iterate-next)] + [idtbl-iterate-key (s '-iterate-key)] + [idtbl-iterate-value (s '-iterate-value)] + [idtbl-map (s '-map)] + [idtbl-for-each (s '-for-each)]) + #'(begin + (provide idtbl? + mutable-idtbl? + immutable-idtbl?) + (provide/contract + [make-idtbl (->* () (dict?) any)] + [make-immutable-idtbl (->* () (dict?) any)] + [idtbl-ref (->* (idtbl? any/c) (any/c) + any)] + [idtbl-set! (-> mutable-idtbl? any/c any/c + any)] + [idtbl-set (-> immutable-idtbl? any/c any/c + immutable-idtbl?)] + [idtbl-remove! (-> mutable-idtbl? any/c + any)] + [idtbl-remove (-> immutable-idtbl? any/c + immutable-idtbl?)] + [idtbl-count (-> idtbl? exact-nonnegative-integer?)] + #| + [idtbl-iterate-first (-> idtbl? id-table-position/c)] + [idtbl-iterate-next (-> idtbl? id-table-position/c id-table-position/c)] + [idtbl-iterate-key (-> idtbl? id-table-position/c identifier?)] + [idtbl-iterate-value (-> idtbl? id-table-position/c any)] + |# + [idtbl-map (-> idtbl? (-> any/c any/c any) any)] + [idtbl-for-each (-> idtbl? (-> any/c any/c any) any)]))))])) + +(make-code bound-id-table) +(make-code free-id-table) +(make-code free*-id-table) diff --git a/collects/syntax/parse.ss b/collects/syntax/parse.ss new file mode 100644 index 0000000000..85838ccdee --- /dev/null +++ b/collects/syntax/parse.ss @@ -0,0 +1,6 @@ + +#lang scheme/base +(require "private/stxparse/sc.ss" + "private/stxparse/lib.ss") +(provide (all-from-out "private/stxparse/sc.ss") + (all-from-out "private/stxparse/lib.ss")) diff --git a/collects/syntax/private/id-table.ss b/collects/syntax/private/id-table.ss new file mode 100644 index 0000000000..695bfd3795 --- /dev/null +++ b/collects/syntax/private/id-table.ss @@ -0,0 +1,302 @@ +#lang scheme/base +(require (for-syntax scheme/base) + scheme/dict) +(provide id-table-position?) + +(require (rename-in scheme/base [car s:car])) +(define-syntax (car stx) + (syntax-case stx () + [(car x) + #`(begin (unless (pair? x) + (error 'car (format "~s:~s" + '#,(syntax-line stx) + '#,(syntax-column stx)))) + (s:car x))])) + + +(define-struct id-table-position (a b)) + +(define empty-immutable-hasheq (make-immutable-hasheq null)) + +(define (check-id x who) + (unless (identifier? x) + (raise-type-error who "identifier" x))) + +(define (check-pos x who) + (unless (id-table-position? x) + (raise-type-error who "id-table-position" x))) + +(define (wrap f protectors [arity (length protectors)]) + (define name (object-name f)) + (procedure-reduce-arity + (procedure-rename + (lambda args + (let loop ([args args] [protectors protectors]) + (when (pair? args) + (unless (pair? protectors) + (error name "out of guards")) + ((car protectors) (car args) name) + (loop (cdr args) (cdr protectors)))) + (apply f args)) + name) + arity)) + +(define-for-syntax (format-id stx fmt . args) + (datum->syntax stx (string->symbol (apply format fmt args)))) + +(define-syntax (make-code stx) + (syntax-case stx () + [(_ idtbl + identifier->symbol + identifier=?) + (with-syntax ([mutable-idtbl + (format-id #'idtbl "mutable-~a" (syntax-e #'idtbl))] + [immutable-idtbl + (format-id #'idtbl "immutable-~a" (syntax-e #'idtbl))] + [make-idtbl + (format-id #'idtbl "make-~a" (syntax-e #'idtbl))] + [make-mutable-idtbl + (format-id #'idtbl "make-mutable-~a" (syntax-e #'idtbl))] + [make-immutable-idtbl + (format-id #'idtbl "make-immutable-~a" (syntax-e #'idtbl))] + [mutable-idtbl? + (format-id #'idtbl "mutable-~a?" (syntax-e #'idtbl))] + [immutable-idtbl? + (format-id #'idtbl "immutable-~a?" (syntax-e #'idtbl))]) + (define (s x) (format-id #'idtbl "~a~a" (syntax-e #'idtbl) x)) + (with-syntax ([idtbl? (s '?)] + [idtbl-hash (s '-hash)] + [idtbl-ref (s '-ref)] + [idtbl-set! (s '-set!)] + [idtbl-set (s '-set)] + [idtbl-remove! (s '-remove!)] + [idtbl-remove (s '-remove)] + [idtbl-count (s '-count)] + [idtbl-iterate-first (s '-iterate-first)] + [idtbl-iterate-next (s '-iterate-next)] + [idtbl-iterate-key (s '-iterate-key)] + [idtbl-iterate-value (s '-iterate-value)] + [idtbl-map (s '-map)] + [idtbl-for-each (s '-for-each)]) + #'(begin + + ;; Struct defs at end, so that dict methods can refer to earlier procs + + (define mk + (let ([make-idtbl + (case-lambda + [() (mk null)] + [(init-dict) + (let ([t (make-mutable-idtbl (make-hasheq))]) + (for ([(k v) (in-dict init-dict)]) + (idtbl-set! t k v)) + t)])]) + make-idtbl)) + (define mkimm + (let ([make-immutable-idtbl + (case-lambda + [() (mkimm null)] + [(init-dict) + (for/fold ([t (make-immutable-idtbl empty-immutable-hasheq)]) + ([(k v) (in-dict init-dict)]) + (idtbl-set t k v))])]) + make-immutable-idtbl)) + + (define (idtbl-ref d id [fail (lambda () + (error 'idtbl-ref + "no mapping for ~e" id))]) + (let ([i (ormap (lambda (i) (and (identifier=? (car i) id) i)) + (hash-ref (idtbl-hash d) + (identifier->symbol id) + null))]) + (if i + (cdr i) + (if (procedure? fail) + (fail) + fail)))) + + (define (idtbl-set! d id v) + (let ([l (hash-ref (idtbl-hash d) (identifier->symbol id) null)]) + (hash-set! (idtbl-hash d) + (identifier->symbol id) + (let loop ([l l]) + (cond [(null? l) (list (cons id v))] + [(identifier=? (caar l) id) + (cons (cons id v) (cdr l))] + [else (cons (car l) (loop (cdr l)))]))))) + + (define (idtbl-set d id v) + (let ([l (hash-ref (idtbl-hash d) (identifier->symbol id) null)]) + (make-immutable-idtbl + (hash-set (idtbl-hash d) + (identifier->symbol id) + (let loop ([l l]) + (cond [(null? l) (list (cons id v))] + [(identifier=? (caar l) id) + (cons (cons id v) (cdr l))] + [else (cons (car l) (loop (cdr l)))])))))) + + (define (idtbl-remove! d id) + (let* ([l (hash-ref (idtbl-hash d) (identifier->symbol id) null)] + [newl (let loop ([l l]) + (cond [(null? l) null] + [(identifier=? (caar l) id) + (cdr l)] + [else (cons (car l) (loop (cdr l)))]))]) + (if (pair? newl) + (hash-set! (idtbl-hash d) + (identifier->symbol id) + newl) + (hash-remove! (idtbl-hash d) + (identifier->symbol id))))) + + (define (idtbl-remove d id) + (let* ([l (hash-ref (idtbl-hash d) (identifier->symbol id) null)] + [newl (let loop ([l l]) + (cond [(null? l) null] + [(identifier=? (caar l) id) + (cdr l)] + [else (cons (car l) (loop (cdr l)))]))]) + (make-immutable-idtbl + (if (pair? newl) + (hash-set (idtbl-hash d) + (identifier->symbol id) + newl) + (hash-remove (idtbl-hash d) + (identifier->symbol id)))))) + + (define (idtbl-count d) + (apply + (hash-map (idtbl-hash d) (lambda (k v) (length v))))) + + (define (idtbl-for-each d p) + (define (pp i) (p (car i) (cdr i))) + (hash-for-each (idtbl-hash d) + (lambda (k v) (for-each pp v)))) + + (define (idtbl-map d f) + (define (fp i) (f (car i) (cdr i))) + (apply append + (hash-map (idtbl-hash d) + (lambda (k v) (map fp v))))) + + (define (idtbl-iterate-first d) + (let ([h (idtbl-hash d)]) + (let ([a (dict-iterate-first h)]) + (and a + (let ([b (dict-iterate-first (dict-iterate-value h a))]) + (and b (make-id-table-position a b))))))) + + (define (idtbl-iterate-next d pos) + (let ([h (idtbl-hash d)] + [a (id-table-position-a pos)] + [b (id-table-position-b pos)]) + (let ([v (dict-iterate-value h a)]) + (let ([b2 (dict-iterate-next v b)]) + (if b2 + (make-id-table-position a b2) + (let ([a2 (dict-iterate-next h a)]) + (and a2 + (let ([b2 (dict-iterate-first + (dict-iterate-value h a2))]) + (and b2 (make-id-table-position a2 b2)))))))))) + + (define (idtbl-iterate-key d pos) + (let ([h (idtbl-hash d)] + [a (id-table-position-a pos)] + [b (id-table-position-b pos)]) + (dict-iterate-key (dict-iterate-value h a) b))) + + (define (idtbl-iterate-value d pos) + (let ([h (idtbl-hash d)] + [a (id-table-position-a pos)] + [b (id-table-position-b pos)]) + (dict-iterate-value (dict-iterate-value h a) b))) + + (define (check-idtbl x who) + (unless (idtbl? x) + (raise-type-error who (symbol->string 'idtbl) x))) + (define (check-mutable-idtbl x who) + (unless (mutable-idtbl? x) + (raise-type-error who (symbol->string 'mutable-idtbl) x))) + (define (check-immutable-idtbl x who) + (unless (immutable-idtbl? x) + (raise-type-error who (symbol->string 'immutable-idtbl) x))) + + (define-struct idtbl (hash)) + (define-struct (mutable-idtbl idtbl) () + #:property prop:dict + (vector (wrap idtbl-ref (list check-idtbl check-id void) '(2 3)) + (wrap idtbl-set! (list check-mutable-idtbl check-id void)) + #f + (wrap idtbl-remove! (list check-mutable-idtbl check-id)) + #f + (wrap idtbl-count (list check-idtbl)) + (wrap idtbl-iterate-first (list check-idtbl)) + (wrap idtbl-iterate-next (list check-idtbl check-pos)) + (wrap idtbl-iterate-key (list check-idtbl check-pos)) + (wrap idtbl-iterate-value (list check-idtbl check-pos)))) + (define-struct (immutable-idtbl idtbl) () + #:property prop:dict + (vector (wrap idtbl-ref (list check-idtbl check-id void) '(2 3)) + #f + (wrap idtbl-set (list check-immutable-idtbl check-id void)) + #f + (wrap idtbl-remove (list check-immutable-idtbl check-id)) + (wrap idtbl-count (list check-idtbl)) + (wrap idtbl-iterate-first (list check-idtbl)) + (wrap idtbl-iterate-next (list check-idtbl check-pos)) + (wrap idtbl-iterate-key (list check-idtbl check-pos)) + (wrap idtbl-iterate-value (list check-idtbl check-pos)))) + + (#%provide (rename mk make-idtbl) + (rename mkimm make-immutable-idtbl) + idtbl? + mutable-idtbl? + immutable-idtbl? + idtbl-ref + idtbl-set! + idtbl-set + idtbl-remove! + idtbl-remove + idtbl-count + idtbl-iterate-first + idtbl-iterate-next + idtbl-iterate-key + idtbl-iterate-value + idtbl-map + idtbl-for-each))))])) + +(define (bound-identifier->symbol id) (syntax-e id)) + +(make-code bound-id-table + bound-identifier->symbol + bound-identifier=?) + +(define (free-identifier->symbol id) + (let ([binding (identifier-binding id)]) + (if (pair? binding) + (cadr binding) + (syntax-e id)))) + +(make-code free-id-table + free-identifier->symbol + free-identifier=?) + +(define (resolve id) + (if (syntax-transforming?) + (let-values ([(v next) + (syntax-local-value/immediate id (lambda () (values #f #f)))]) + (if next + (resolve next) + id)) + id)) + +(define (free*-identifier->symbol id) + (free-identifier->symbol (resolve id))) + +(define (free*-identifier=? a b) + (free-identifier=? (resolve a) (resolve b))) + +(make-code free*-id-table + free*-identifier->symbol + free*-identifier=?) diff --git a/collects/syntax/private/stxparse/codegen-data.ss b/collects/syntax/private/stxparse/codegen-data.ss new file mode 100644 index 0000000000..8a39de4a1a --- /dev/null +++ b/collects/syntax/private/stxparse/codegen-data.ss @@ -0,0 +1,111 @@ +#lang scheme/base +(require scheme/match + syntax/stx + (for-template scheme/base + syntax/stx + scheme/stxparam + "runtime.ss")) +(provide (all-defined-out)) + +;; Frontiers + +;; A FrontierContextExpr (FCE) is one of +;; - (make-fce Id (listof FrontierIndexExpr)) +;; A FrontierIndexExpr is +;; - #'(+ Number expr ...) +(define-struct fce (stx indexes) #:prefab) + +(define (empty-frontier x) + (make-fce x (list #'(+ 0)))) + +(define (done-frontier x) + (make-fce x (list #'(+ +inf.0)))) + +(define (frontier:add-car fc x) + (make-fce x (cons #'(+ 0) (fce-indexes fc)))) + +(define (frontier:add-cdr fc) + (define (fi:add1 fi) + (syntax-case fi (+) + [(+ n . rest) + #`(+ #,(add1 (syntax-e #'n)) . rest)])) + (make-fce (fce-stx fc) + (cons (fi:add1 (stx-car (fce-indexes fc))) + (stx-cdr (fce-indexes fc))))) + +(define (frontier:add-index fc expr) + (define (fi:add-index fi expr) + (syntax-case fi (+) + [(+ n . rest) + #`(+ n #,expr . rest)])) + (make-fce (fce-stx fc) + (cons (fi:add-index (stx-car (fce-indexes fc)) expr) + (stx-cdr (fce-indexes fc))))) + +(define (frontier:add-unvector fc x) + (frontier:add-car fc x)) +(define (frontier:add-unbox fc x) + (frontier:add-car fc x)) +(define (frontier:add-unpstruct fc x) + (frontier:add-car fc x)) + +;; A DynamicFrontierContext (DFC) is a list of numbers. +;; More operations on DFCs in runtime.ss + +(define (frontier->dfc-expr fc) + (define (fi->qq-part fi) + (syntax-case fi (+) + [(+ n) + #'n] + [expr #`(unquote expr)])) + (let ([fis (reverse (stx->list (fce-indexes fc)))]) + (with-syntax ([(part ...) (map fi->qq-part fis)]) + #`(quasiquote (part ...))))) + +(define (frontier->fstx-expr fc) + (fce-stx fc)) + +(define (frontier->index-expr fc) + (match fc + [(struct fce (stx indexes)) + #`#,(stx-car indexes)])) + +;; -------- + + +(define (get-kind kind) + (syntax-case kind () + [#:pair pairK] + [#:vector vectorK] + [#:box boxK] + [(#:pstruct key) + (make-kind #`(lambda (x) + (let ([xkey (prefab-struct-key x)]) + (and xkey (equal? xkey (quote key))))) + (list (lambda (s d) + #`(datum->syntax #,s (cdr (vector->list (struct->vector #,d))) #,s))) + (list (lambda (fc x) + (frontier:add-unpstruct fc x))))])) + +;; A Kind is +;; (make-kind id (listof (id id -> stx)) (listof (FCE id -> FCE))) + +(define-struct kind (predicate selectors frontier-procs) #:transparent) + +(define pairK + (make-kind #'pair? + (list (lambda (s d) #`(car #,d)) + (lambda (s d) #`(datum->syntax #,s (cdr #,d) #,s))) + (list (lambda (fc x) (frontier:add-car fc x)) + (lambda (fc x) (frontier:add-cdr fc))))) + +(define vectorK + (make-kind #'vector? + (list (lambda (s d) + #`(datum->syntax #,s (vector->list #,d) #,s))) + (list (lambda (fc x) (frontier:add-unvector fc x))))) + +(define boxK + (make-kind #'box? + (list (lambda (s d) #`(unbox #,d))) + (list (lambda (fc x) (frontier:add-unbox fc x))))) diff --git a/collects/syntax/private/stxparse/lib.ss b/collects/syntax/private/stxparse/lib.ss new file mode 100644 index 0000000000..3fd71f653c --- /dev/null +++ b/collects/syntax/private/stxparse/lib.ss @@ -0,0 +1,87 @@ +#lang scheme/base + +(require "sc.ss" + "../util.ss" + syntax/stx + syntax/kerncase + scheme/struct-info + scheme/private/contract-helpers + (for-syntax scheme/base + syntax/kerncase + "rep.ss" + (only-in "rep-data.ss" make-literalset)) + (for-template scheme/base + scheme/contract)) +(provide (all-defined-out)) + +(define-syntax-rule (define-pred-stxclass name pred) + (define-syntax-class name #:attributes () + (pattern x + #:fail-unless (pred (syntax-e #'x)) #f))) + +(define-pred-stxclass identifier symbol?) +(define-pred-stxclass boolean boolean?) +(define-pred-stxclass str string?) +(define-pred-stxclass character char?) +(define-pred-stxclass keyword keyword?) + +(define-pred-stxclass number number?) +(define-pred-stxclass integer integer?) +(define-pred-stxclass exact-integer exact-integer?) +(define-pred-stxclass exact-nonnegative-integer exact-nonnegative-integer?) +(define-pred-stxclass exact-positive-integer exact-positive-integer?) + +;; Aliases +(define-syntax id (make-rename-transformer #'identifier)) +(define-syntax nat (make-rename-transformer #'exact-nonnegative-integer)) +(define-syntax char (make-rename-transformer #'character)) + +(define notfound (box 'notfound)) + +(define-syntax-class (static-of pred name) + #:attributes (value) + (pattern x:id + #:fail-unless (syntax-transforming?) + "not within the extent of a macro transformer" + #:attr value (syntax-local-value #'x (lambda () notfound)) + #:fail-when (eq? (attribute value) notfound) #f)) + +(define-syntax-class static #:attributes (value) + (pattern x + #:declare x (static-of (lambda _ #t) "static") + #:attr value (attribute x.value))) + +(define-syntax-class struct-name + #:description "struct name" + #:attributes (descriptor + constructor + predicate + [accessor 1] + super + complete?) + (pattern s + #:declare s (static-of "struct name" struct-info?) + #:with info (extract-struct-info (attribute s.value)) + #:with descriptor (list-ref (attribute info) 0) + #:with constructor (list-ref (attribute info) 1) + #:with predicate (list-ref (attribute info) 2) + #:with r-accessors (reverse (list-ref (attribute info) 3)) + #:with (accessor ...) + (datum->syntax #f (let ([r-accessors (attribute r-accessors)]) + (if (and (pair? r-accessors) (eq? #f (car r-accessors))) + (cdr r-accessors) + r-accessors))) + #:with super (list-ref (attribute info) 5) + #:attr complete? (or (null? (attribute r-accessors)) + (and (pair? (attribute r-accessors)) + (not (eq? #f (car (attribute r-accessors)))))))) + +(define-syntax-class expr + #:attributes () + (pattern x + #:fail-when (keyword? (syntax-e #'x)) #f)) + +(define-syntax kernel-literals + (make-literalset + (for/list ([id (kernel-form-identifier-list)]) + (list (syntax-e id) id)))) diff --git a/collects/syntax/private/stxparse/parse.ss b/collects/syntax/private/stxparse/parse.ss new file mode 100644 index 0000000000..bd7ced5041 --- /dev/null +++ b/collects/syntax/private/stxparse/parse.ss @@ -0,0 +1,565 @@ +#lang scheme/base +(require (for-syntax scheme/base + scheme/match + scheme/private/sc + syntax/stx + syntax/id-table + "rep-data.ss" + "rep.ss" + "codegen-data.ss" + "../util.ss") + scheme/stxparam + scheme/list + scheme/match + syntax/stx + "runtime.ss" + "runtime-prose.ss") +(provide (all-defined-out)) + +(define-for-syntax (wash stx) + (syntax-e stx)) +(define-for-syntax (wash-list washer stx) + (let ([l (stx->list stx)]) + (unless l (raise-type-error 'wash-list "stx-list" stx)) + (map washer l))) +(define-for-syntax (wash-iattr stx) + (with-syntax ([#s(attr name depth syntax?) stx]) + (make-attr #'name (wash #'depth) (wash #'syntax?)))) +(define-for-syntax (wash-sattr stx) + (with-syntax ([#s(attr name depth syntax?) stx]) + (make-attr (wash #'name) (wash #'depth) (wash #'syntax?)))) + +(define-for-syntax (wash-iattrs stx) + (wash-list wash-iattr stx)) +(define-for-syntax (wash-sattrs stx) + (wash-list wash-sattr stx)) + +;; ---- + +;; (fail expr #:expect expr #:fce FCE) : expr +(define-syntax (fail stx) + (syntax-case stx () + [(fail x #:expect p #:fce fce) + (let ([fc-expr (frontier->dfc-expr (wash #'fce))] + [fstx-expr (frontier->fstx-expr (wash #'fce))]) + #`(enclosing-fail + (make-failure x #,fc-expr #,fstx-expr p)))])) + +;; (parse:rhs RHS (SAttr ...) (id ...) id boolean) +;; : expr[(values ParseFunction DescriptionFunction)] +;; Takes a list of the relevant attrs; order is significant! +;; Returns either fail or a list having length same as 'relsattrs' +(define-syntax (parse:rhs stx) + (syntax-case stx () + [(parse:rhs #s(rhs _ _ transparent? _ variants (def ...)) + relsattrs (arg ...) get-description splicing?) + #`(lambda (x arg ...) + (define (fail-rhs failure) + (expectation-of-thing (get-description arg ...) + transparent? + (if transparent? failure #f))) + def ... + (syntax-parameterize ((this-syntax (make-rename-transformer #'x))) + (with-enclosing-fail* fail-rhs + (parse:variants x relsattrs variants splicing?))))])) + +;; (parse:variants id (SAttr ...) (Variant ...) boolean) +;; : expr[SyntaxClassResult] +(define-syntax (parse:variants stx) + (syntax-case stx () + [(parse:variants x relsattrs (variant ...) splicing?) + #'(try (parse:variant x relsattrs variant splicing?) ...)])) + +(define-syntax (parse:variant stx) + (syntax-case stx () + [(parse:variant x relsattrs variant #f) + (with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant] + [fc (empty-frontier #'x)]) + #`(let () + def ... + (parse:S x fc pattern (variant-success x relsattrs variant ()))))] + [(parse:variant x relsattrs variant #t) + (with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant] + [fc (empty-frontier #'x)]) + #`(let () + def ... + (parse:H x fc pattern rest index + (variant-success x relsattrs variant (rest index)))))])) + +;; (variant-success id (SAttr ...) Variant (expr ...)) : expr[SyntaxClassResult] +(define-syntax (variant-success stx) + (syntax-case stx () + [(variant-success x relsattrs #s(variant _ _ pattern sides _) (also ...)) + #`(convert-sides x sides + (base-success-expr #,(pattern-attrs (wash #'pattern)) + relsattrs + (also ...)))])) + +;; (convert-sides id (Side ...) (m (IAttr ...) . MArgs)) : expr[X] +;; where (m (IAttr ...) MArgs) : expr[X] +(define-syntax (convert-sides stx) + (syntax-case stx () + [(convert-sides x () kexpr) + #'kexpr] + [(convert-sides x (side0 . sides) (k iattrs . kargs)) + (syntax-case #'side0 () + [#s(clause:fail condition message) + #`(if (without-fails condition) + (fail x + #:expect (expectation-of-message message) + #:fce #,(done-frontier #'x)) + (convert-sides x sides (k iattrs . kargs)))] + [#s(clause:with pattern expr (def ...)) + (with-syntax ([(p-iattr ...) (pattern-attrs (wash #'pattern))]) + #`(let ([y (without-fails expr)]) + def ... + (parse:S y #,(done-frontier #'x) pattern + (convert-sides x sides + (k (p-iattr ... . iattrs) . kargs)))))] + [#s(clause:attr a expr) + #`(let-attributes ([a (without-fails (check-list^depth a expr))]) + (convert-sides x sides (k (a . iattrs) . kargs)))])])) + +;; (base-success-expr (IAttr ...) (SAttr ...) (expr ...) : expr[SCResult] +(define-syntax (base-success-expr stx) + (syntax-case stx () + [(base-success-expr iattrs relsattrs (also ...)) + (let ([reliattrs + (reorder-iattrs (wash-sattrs #'relsattrs) + (wash-iattrs #'iattrs))]) + (with-syntax ([(#s(attr name _ _) ...) reliattrs]) + #'(list also ... (attribute name) ...)))])) + +;; ---- + +;; (parse:clauses id (Clause ...)) +(define-syntax (parse:clauses stx) + (syntax-case stx () + [(parse:clauses x clauses) + (let () + (define-values (chunks clauses-stx) + (chunk-kw-seq/no-dups #'clauses parse-directive-table)) + (define-values (decls0 defs) (get-decls+defs chunks)) + (define (for-clause clause) + (syntax-case clause () + [[p . rest] + (let-values ([(rest decls sides) + (parse-pattern-directives #'rest #:decls decls0)]) + (with-syntax ([rest rest] + [fc (empty-frontier #'x)] + [pattern (parse-whole-pattern #'p decls)]) + #`(parse:S x fc pattern + (convert-sides x #,sides + (clause-success () (let () . rest))))))])) + (unless (and (stx-list? clauses-stx) (stx-pair? clauses-stx)) + (wrong-syntax clauses-stx "expected non-empty sequence of clauses")) + (with-syntax ([(def ...) defs] + [(alternative ...) + (map for-clause (stx->list clauses-stx))]) + #`(let () + def ... + (try alternative ...))))])) + +(define-for-syntax (wash-literal stx) + (syntax-case stx () + [(a b) (list #'a #'b)])) +(define-for-syntax (wash-literals stx) + (wash-list wash-literal stx)) + +#| +;; (parse:clause id ([id id] ...) Clause) : expr +(define-syntax (parse:clause stx) + (syntax-case stx () + [(parse:clause x literals [p . rest]) + (let-values ([(rest decls sides) + (parse-pattern-directives + #'rest #:decls (new-declenv (wash-literals #'literals)))]) + (with-syntax ([rest rest] + [fc (empty-frontier #'x)] + [pattern (parse-whole-pattern #'p decls)]) + #`(parse:S x fc pattern + (convert-sides x #,sides + (clause-success () (let () . rest))))))])) +|# + +;; (clause-success (IAttr ...) expr) : expr +(define-syntax (clause-success stx) + (syntax-case stx () + [(clause-success _ expr) + #'expr])) + +;; ---- + +;; (parse:S id FCE SinglePattern expr) : expr +(define-syntax (parse:S stx) + (syntax-case stx () + [(parse:S x fc pattern0 k) + (syntax-case #'pattern0 () + [#s(internal-rest-pattern rest index index0) + #`(let ([rest x] + [index (- #,(frontier->index-expr (wash #'fc)) index0)]) + k)] + [#s(pat:name attrs pattern (name ...)) + #`(let-attributes ([#s(attr name 0 #t) x] ...) + (parse:S x fc pattern k))] + [#s(pat:any attrs) + #'k] + [#s(pat:sc (a ...) parser description bind-term? bind-attrs?) + #`(let ([result (parser x)]) + (if (ok? result) + (let/unpack ((a ...) + #,(let ([bind-term? (syntax-e #'bind-term?)] + [bind-attrs? (syntax-e #'bind-attrs?)]) + (cond [(and bind-term? bind-attrs?) + #'(cons x result)] + [bind-term? ;; not possible, I think + #'(list x)] + [bind-attrs? + #'result] + [else #'null]))) + k) + (fail x #:expect result #:fce fc)))] + [#s(pat:datum attrs datum) + #`(let ([d (syntax-e x)]) + (if (equal? d (quote datum)) + k + (fail x + #:expect (expectation-of-constant datum) + #:fce fc)))] + [#s(pat:literal attrs literal) + #`(if (and (identifier? x) (free-identifier=? x (quote-syntax literal))) + k + (fail x + #:expect (expectation-of-literal literal) + #:fce fc))] + [#s(pat:head attrs head tail) + #`(parse:H x fc head rest index + (parse:S rest #,(frontier:add-index (wash #'fc) #'index) tail k))] + [#s(pat:dots attrs head tail) + #`(parse:dots x fc head tail k)] + [#s(pat:and attrs subpatterns) + (for/fold ([k #'k]) ([subpattern (reverse (syntax->list #'subpatterns))]) + #`(parse:S x fc #,subpattern #,k))] + [#s(pat:or (a ...) (subpattern ...)) + (with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) + #`(let ([success + (lambda (fail id ...) + (with-enclosing-fail fail + (let-attributes ([a id] ...) k)))]) + (try (parse:S x fc subpattern + (disjunct subpattern success (enclosing-fail) (id ...))) + ...)))] + [#s(pat:compound attrs kind0 (part-pattern ...)) + (let ([kind (get-kind (wash #'kind0))]) + (with-syntax ([(part ...) (generate-temporaries (kind-selectors kind))]) + (with-syntax ([predicate (kind-predicate kind)] + [(part-fc ...) + (for/list ([fproc (kind-frontier-procs kind)] + [part-var (syntax->list #'(part ...))]) + (fproc (wash #'fc) part-var))] + [(part-expr ...) + (for/list ([selector (kind-selectors kind)]) + (selector #'x #'datum))]) + #`(let ([datum (syntax-e x)]) + (if (predicate datum) + (let ([part part-expr] ...) + (parse:S* (part ...) (part-fc ...) (part-pattern ...) k)) + (fail x + #:expect (expectation-of-compound kind0 (part-pattern ...)) + #:fce fc))))))] + [#s(pat:cut attrs pattern) + #`(with-enclosing-fail enclosing-cut-fail + (parse:S x fc pattern k))] + [#s(pat:describe attrs description pattern) + #`(let ([previous-fail enclosing-fail] + [previous-cut-fail enclosing-cut-fail]) + (define (new-fail failure) + (fail x + #:expect (expectation-of-thing description #f failure) + #:fce fc)) + (with-enclosing-fail* new-fail + (parse:S x #,(empty-frontier #'x) pattern + (with-enclosing-cut-fail previous-cut-fail + (with-enclosing-fail previous-fail + k)))))] + [#s(pat:bind _ clauses) + #'(convert-sides x clauses (clause-success () k))] + [#s(pat:fail _ condition message) + #`(if condition + (fail x + #:expect (expectation-of-message message) + #:fce fc) + k)])])) + +;; (parse:S* (id ...) (FCE ...) (SinglePattern ...) expr) : expr +(define-syntax parse:S* + (syntax-rules () + [(parse:S* () () () k) + k] + [(parse:S* (part0 . parts) (fc0 . fcs) (pattern0 . patterns) k) + (parse:S part0 fc0 pattern0 (parse:S* parts fcs patterns k))])) + +;; (disjunct Pattern id (expr ...) (id ...)) : expr +(define-syntax (disjunct stx) + (syntax-case stx () + [(disjunct pattern success (pre ...) (id ...)) + (with-syntax ([(#s(attr sub-id _ _) ...) (pattern-attrs (wash #'pattern))]) + (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 pre ... id ...))))))])) + +(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:name attrs pattern names) + (with-syntax ([pattern (convert-list-pattern #'pattern end-pattern)]) + #'#s(pat:name attrs pattern names))] + [#s(pat:head attrs head tail) + (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) + #'#s(pat:head attrs head tail))] + [#s(pat:dots attrs head tail) + (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) + #'#s(pat:dots attrs head tail))] + [#s(pat:compound attrs #:pair (head-part tail-part)) + (with-syntax ([tail-part (convert-list-pattern #'tail-part end-pattern)]) + #'#s(pat:compound attrs #:pair (head-part tail-part)))]))) + +;; (parse:H id FCE HeadPattern id id expr) : expr +(define-syntax (parse:H stx) + (syntax-case stx () + [(parse:H x fc head rest index k) + (syntax-case #'head () + [#s(hpat:describe _ description pattern) + #`(let ([previous-fail enclosing-fail] + [previous-cut-fail enclosing-cut-fail]) + (define (new-fail failure) + (fail x + #:expect (expectation-of-thing description #f failure) + #:fce fc)) + (with-enclosing-fail* new-fail + (parse:H x #,(empty-frontier #'x) pattern + rest index + (with-enclosing-cut-fail previous-cut-fail + (with-enclosing-fail previous-fail + k)))))] + [#s(hpat:ssc (a ...) parser description bind-term? bind-attrs?) + #`(let ([result (parser x)]) + (if (ok? result) + (let ([rest (car result)] + [index (cadr result)]) + (let/unpack ((a ...) + #,(let ([bind-term? (syntax-e #'bind-term?)] + [bind-attrs? (syntax-e #'bind-attrs?)]) + (cond [(and bind-term? bind-attrs?) + #`(cons (stx-list-take x index) (cddr result))] + [bind-term? + #'(list (stx-list-take x index))] + [bind-attrs? + #'(cddr result)] + [else + #'null]))) + k)) + (fail x #:expect result #:fce fc)))] + [#s(hpat:or (a ...) (subpattern ...)) + (with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) + #`(let ([success + (lambda (rest index fail id ...) + (with-enclosing-fail fail + (let-attributes ([a id] ...) k)))]) + (try (parse:H x fc subpattern rest index + (disjunct subpattern success + (rest index enclosing-fail) (id ...))) + ...)))] + [#s(hpat:seq attrs pattern) + (with-syntax ([index0 (frontier->index-expr (wash #'fc))]) + (with-syntax ([pattern + (convert-list-pattern + #'pattern + #'#s(internal-rest-pattern rest index index0))]) + #'(parse:S x fc pattern k)))] + [_ + (with-syntax ([attrs (pattern-attrs (wash #'head))] + [index0 (frontier->index-expr (wash #'fc))]) + #'(parse:S x fc + #s(pat:compound attrs + #:pair + (head #s(internal-rest-pattern + rest index + index0))) + k))])])) + +;; (parse:dots id FCE EHPattern SinglePattern expr) : expr +(define-syntax (parse:dots stx) + (syntax-case stx () + [(parse:dots x fc (#s(ehpat head-attrs head head-repc) ...) tail k) + (let () + (define repcs (wash-list wash #'(head-repc ...))) + (define rep-ids (for/list ([repc repcs]) + (and repc (generate-temporary 'rep)))) + (define rel-repcs (filter values repcs)) + (define rel-rep-ids (filter values rep-ids)) + (define aattrs + (for/list ([head-attrs (syntax->list #'(head-attrs ...))] + [repc repcs] + #:when #t + [a (wash-iattrs head-attrs)]) + (cons a repc))) + (define attrs (map car aattrs)) + (define attr-repcs (map cdr aattrs)) + (define ids (map attr-name attrs)) + (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] + [(a ...) attrs] + [(attr-repc ...) attr-repcs] + [loop-fc (frontier:add-index (wash #'fc) #'index)]) + (define-pattern-variable alt-map #'((id . alt-id) ...)) + (define-pattern-variable loop-k + #'(dots-loop dx (+ index index2) enclosing-fail rel-rep ... alt-id ...)) + #`(let () + (define (dots-loop dx index loop-fail rel-rep ... alt-id ...) + (with-enclosing-fail loop-fail + (try (parse:EH dx loop-fc head head-repc index2 alt-map head-rep + loop-k) + ... + (cond [(< rel-rep (rep:min-number rel-repc)) + (fail dx + #:expect (expectation-of-reps/too-few rel-rep rel-repc) + #:fce loop-fc)] + ... + [else + (let-attributes ([a (rep:finalize attr-repc alt-id)] ...) + (parse:S dx loop-fc tail k))])))) + (let ([rel-rep 0] ... + [alt-id (rep:initial-value attr-repc)] ...) + (dots-loop x 0 enclosing-fail rel-rep ... alt-id ...)))))])) + +;; (parse:EH id FCE EHPattern id id ((id . id) ...) +;; RepConstraint/#f expr) : expr +(define-syntax (parse:EH stx) + (syntax-case stx () + [(parse:EH x fc head repc index alts rep k0) + (let () + (define-pattern-variable k + (let* ([main-attrs (wash-iattrs (pattern-attrs (wash #'head)))] + [ids (map attr-name main-attrs)] + [alt-ids + (let ([table (make-bound-id-table)]) + (for ([entry (syntax->list #'alts)]) + (let ([entry (syntax-e entry)]) + (bound-id-table-set! table (car entry) (cdr entry)))) + (for/list ([id ids]) (bound-id-table-ref table id)))]) + (with-syntax ([(id ...) ids] + [(alt-id ...) alt-ids] + [(alt-a ...) (map rename-attr main-attrs alt-ids)]) + #`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...) + k0)))) + (syntax-case #'repc () + [#f #`(parse:H x fc head x index k)] + [_ #`(parse:H x fc head x index + (if (< rep (rep:max-number repc)) + (let ([rep (add1 rep)]) k) + (fail x + #:expect (expectation-of-reps/too-many rep repc) + #:fce #,(frontier:add-index (wash #'fc) + #'index))))]))])) + +;; (rep:finalize RepConstraint expr) : expr +(define-syntax (rep:finalize stx) + (syntax-case stx () + [(_ #s(rep:once _ _ _) v) #'v] + [(_ #s(rep:optional _ _) v) #'v] + [(_ _ v) #'(reverse v)])) + +;; (rep:initial-value RepConstraint) : expr +(define-syntax (rep:initial-value stx) + (syntax-case stx () + [(_ #s(rep:once _ _ _)) #'#f] + [(_ #s(rep:optional _ _)) #'#f] + [(_ _) #'null])) + +;; (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-rule (expectation-of-thing description transparent? chained) + (make-expect:thing description transparent? chained)) + +(define-syntax-rule (expectation-of-message message) + (let ([msg message]) + (if msg (make-expect:message msg) 'ineffable))) + +(define-syntax-rule (expectation-of-constant constant) + (make-expect:atom 'constant)) + +(define-syntax-rule (expectation-of-literal literal) + (make-expect:literal (quote-syntax literal))) + +(define-syntax expectation-of-compound + (syntax-rules () + [(_ #:pair (head-pattern tail-pattern)) + (make-expect:pair)] + [(_ _ _) 'ineffable])) + +(define-syntax expectation-of-reps/too-few + (syntax-rules () + [(_ rep #s(rep:once name too-few-msg too-many-msg)) + (expectation-of-message/too-few too-few-msg name)] + [(_ rep #s(rep:optional name too-many-msg)) + (error 'impossible)] + [(_ rep #s(rep:bounds min max name too-few-msg too-many-msg)) + (expectation-of-message/too-few too-few-msg name)])) + +(define-syntax expectation-of-reps/too-many + (syntax-rules () + [(_ rep #s(rep:once name too-few-msg too-many-msg)) + (expectation-of-message/too-many too-many-msg name)] + [(_ rep #s(rep:optional name too-many-msg)) + (expectation-of-message/too-many too-many-msg name)] + [(_ rep #s(rep:bounds min max name too-few-msg too-many-msg)) + (expectation-of-message/too-many too-many-msg name)])) + +(define-syntax-rule (expectation-of-message/too-few msg name) + (expectation-of-message + (or msg + (let ([n name]) + (if n + (format "missing required occurrence of ~a" n) + "repetition constraint violated"))))) + +(define-syntax-rule (expectation-of-message/too-many msg name) + (expectation-of-message + (or msg + (let ([n name]) + (if n + (format "too many occurrences of ~a" n) + "repetition constraint violated"))))) diff --git a/collects/syntax/private/stxparse/rep-attrs.ss b/collects/syntax/private/stxparse/rep-attrs.ss new file mode 100644 index 0000000000..d763d30064 --- /dev/null +++ b/collects/syntax/private/stxparse/rep-attrs.ss @@ -0,0 +1,170 @@ +#lang scheme/base +(require scheme/contract + scheme/match + syntax/stx + syntax/id-table + "../util.ss" + "rep-patterns.ss") +(provide (struct-out attr)) + +#| +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). +|# + +(define-struct attr (name depth syntax?) #:prefab) + +(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?))] + [rename-attr + (-> iattr? identifier? + iattr?)] + + ;; SAttr operations + [iattr->sattr + (-> iattr? + sattr?)] + [iattrs->sattrs + (-> (listof iattr?) + (listof sattr?))] + + [intersect-sattrss + (-> (listof (listof sattr?)) + (listof sattr?))]) + +;; 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)) + (for* ([attrs attrss] [attr attrs]) + (define name (attr-name attr)) + (define prev (bound-id-table-ref attr-t name #f)) + (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 ([a (bound-id-table-map attr-t (lambda (_ v) v))]) + (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) + (match a + [(struct attr (name depth syntax?)) + (make attr (syntax-e name) depth syntax?)])) + +(define (iattrs->sattrs as) + (map iattr->sattr as)) + +(define (rename-attr a name) + (make attr name (attr-depth a) (attr-syntax? a))) + +;; intersect-sattrss : (listof (listof SAttr)) -> (listof SAttr) +(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 attrss] + [attr attrs] + #:when (memq (attr-name attr) names)) + (put (join-attrs attr (fetch-like attr)))) + (sort (hash-map ht (lambda (k v) v)) + (lambda (a b) + (stringstring (attr-name a)) + (symbol->string (attr-name b))))))])) + +;; 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 iattrs]) + (let ([remap-name (syntax-e (attr-name iattr))]) + (hash-set! ht remap-name iattr))) + (let loop ([relsattrs relsattrs]) + (match relsattrs + ['() null] + [(cons sattr rest) + (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)))) diff --git a/collects/syntax/private/stxparse/rep-data.ss b/collects/syntax/private/stxparse/rep-data.ss new file mode 100644 index 0000000000..6bbd0941d4 --- /dev/null +++ b/collects/syntax/private/stxparse/rep-data.ss @@ -0,0 +1,232 @@ +#lang scheme/base +(require scheme/contract + scheme/match + scheme/dict + syntax/stx + syntax/id-table + "../util.ss" + "rep-attrs.ss" + "rep-patterns.ss") +(provide (all-from-out "rep-attrs.ss") + (all-from-out "rep-patterns.ss") + (struct-out stxclass) + stxclass/s? + stxclass/h? + (struct-out attr) + (struct-out rhs) + (struct-out variant) + (struct-out clause:fail) + (struct-out clause:with) + (struct-out clause:attr) + (struct-out conventions) + (struct-out literalset)) + +#| +A stxclass is + (make-sc symbol (listof symbol) (list-of SAttr) identifier identifier boolean) +|# +(define-struct stxclass (name params attrs parser-name description splicing?) + #:prefab) + +(define (stxclass/s? x) + (and (stxclass? x) (not (stxclass-splicing? x)))) +(define (stxclass/h? x) + (and (stxclass? x) (stxclass-splicing? x))) + +#| +An RHS is + (make-rhs stx (listof SAttr) boolean stx/#f (listof Variant) (listof stx)) +definitions: auxiliary definitions from #:declare +|# +(define-struct rhs (ostx attrs transparent? description variants definitions) + #:prefab) + +#| +A Variant is + (make-variant stx (listof SAttr) Pattern (listof SideClause)) +|# +(define-struct variant (ostx attrs pattern sides definitions) #:prefab) + +#| +A SideClause is one of + (make-clause:fail stx stx) + (make-clause:with pattern stx (listof stx)) + (make-clause:attr IAttr stx) +|# +(define-struct clause:fail (condition message) #:prefab) +(define-struct clause:with (pattern expr definitions) #:prefab) +(define-struct clause:attr (attr expr) #:prefab) + +#| +A Conventions is + (make-conventions (listof ConventionRule)) +A ConventionRule is (list regexp DeclEntry) +|# +(define-struct conventions (rules) #:transparent) + +#| +A LiteralSet is + (make-literalset (listof (list symbol id))) +|# +(define-struct literalset (literals) #:transparent) + +;; make-dummy-stxclass : identifier -> SC +;; Dummy stxclass for calculating attributes of recursive stxclasses. +(define (make-dummy-stxclass name) + (make stxclass (syntax-e name) null null #f #f #f)) + + +;; Environments + +#| +DeclEnv = + (make-declenv immutable-bound-id-mapping[id => DeclEntry] + (listof ConventionRule)) +DeclEntry = + (list 'literal id id) + (list 'stxclass id id (listof stx)) + (list 'parser id id (listof IAttr)) + #f +|# +(define-struct declenv (table conventions)) + +(define (new-declenv literals #:conventions [conventions null]) + (for/fold ([decls (make-declenv (make-immutable-bound-id-table) conventions)]) + ([literal literals]) + (declenv-put-literal decls (car literal) (cadr literal)))) + +(define (declenv-lookup env id #:use-conventions? [use-conventions? #t]) + (or (bound-id-table-ref (declenv-table env) id #f) + (and use-conventions? + (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 #:use-conventions? #f)]) + (when val + (cond [(eq? 'literal (car val)) + (wrong-syntax id "identifier previously declared as literal")] + [(and blame-declare? stxclass-name) + (wrong-syntax (cadr val) + "identifier previously declared with syntax class ~a" + stxclass-name)] + [else + (wrong-syntax (if blame-declare? (cadr val) id) + "identifier previously declared")])))) + +(define (declenv-put-literal env internal-id lit-id) + (declenv-check-unbound env internal-id) + (make-declenv + (bound-id-table-set (declenv-table env) internal-id + (list 'literal internal-id lit-id)) + (declenv-conventions env))) + +(define (declenv-put-stxclass env id stxclass-name args) + (declenv-check-unbound env id) + (make-declenv + (bound-id-table-set (declenv-table env) id + (list 'stxclass id stxclass-name args)) + (declenv-conventions env))) + +(define (declenv-put-parser env id parser get-description attrs splicing?) + ;; no unbound check, since replacing 'stxclass entry + (make-declenv + (bound-id-table-set (declenv-table env) id + (list (if splicing? 'splicing-parser 'parser) + parser get-description attrs)) + (declenv-conventions env))) + +;; 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 ids]) (bound-id-table-set! idbm id #t)) + (for/list ([(k v) (in-dict (declenv-table env))] + #:when (and (pair? v) (not (eq? (car v) 'literal))) + #:when (not (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 conventions]) + (and (regexp-match? (car c) sym) (cadr c))))) + +;; Contracts + +(define DeclEnv/c + (flat-named-contract 'DeclEnv declenv?)) + +(define SideClause/c + (or/c clause:fail? clause:with? clause:attr?)) + +(provide/contract + [DeclEnv/c contract?] + [SideClause/c contract?] + + [make-dummy-stxclass (-> identifier? stxclass?)] + [use-dummy-stxclasses? (parameter/c boolean?)] + + [new-declenv + (->* [(listof (list/c identifier? identifier?))] + [#:conventions list?] + DeclEnv/c)] + [declenv-lookup + (-> DeclEnv/c identifier? any)] + [declenv-put-stxclass + (-> DeclEnv/c identifier? identifier? (listof syntax?) + DeclEnv/c)] + [declenv-put-parser + (-> DeclEnv/c identifier? any/c any/c (listof sattr?) boolean? + DeclEnv/c)] + [declenv-domain-difference + (-> DeclEnv/c (listof identifier?) + (listof identifier?))] + [declenv-table + (-> DeclEnv/c any)] + + [get-stxclass + (-> identifier? any)] + [get-stxclass/check-arg-count + (-> identifier? exact-nonnegative-integer? any)] + [split-id/get-stxclass + (-> identifier? DeclEnv/c any)]) + +(define use-dummy-stxclasses? (make-parameter #f)) + +(define (get-stxclass id) + (if (use-dummy-stxclasses?) + (make-dummy-stxclass id) + (let* ([no-good + (lambda () (wrong-syntax id "not defined as syntax class"))] + [sc (syntax-local-value/catch id stxclass?)]) + (unless (stxclass? sc) + (no-good)) + sc))) + +(define (get-stxclass/check-arg-count id arg-count) + (let* ([sc (get-stxclass id)] + [expected-arg-count (length (stxclass-params sc))]) + (unless (or (= expected-arg-count arg-count) + (use-dummy-stxclasses?)) + ;; (above: don't check error if stxclass may not be defined yet) + (wrong-syntax id + "too few arguments for syntax-class ~a (expected ~s)" + (syntax-e id) + expected-arg-count)) + sc)) + +(define (split-id/get-stxclass id0 decls) + (cond [(regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id0))) + => (lambda (m) + (define id + (datum->syntax id0 (string->symbol (cadr m)) id0 id0)) + (define scname + (datum->syntax id0 (string->symbol (caddr m)) id0 id0)) + (declenv-check-unbound decls id (syntax-e scname) + #:blame-declare? #t) + (let ([sc (get-stxclass/check-arg-count scname 0)]) + (values id sc)))] + [else (values id0 #f)])) diff --git a/collects/syntax/private/stxparse/rep-patterns.ss b/collects/syntax/private/stxparse/rep-patterns.ss new file mode 100644 index 0000000000..7450f47902 --- /dev/null +++ b/collects/syntax/private/stxparse/rep-patterns.ss @@ -0,0 +1,147 @@ +#lang scheme/base +(require (for-syntax scheme/base + syntax/stx + "../util.ss")) +(provide (all-defined-out)) + +#| +A PBase/HPBase/EHPBase is (listof IAttr) + If P = (make-pattern Attrs ...) and A is in Attrs, + the depth of A is with respect to P, + not with respect to the entire enclosing pattern. + +An IdPrefix is an identifier/#f +If #f, it means bind no attributes +If identifier, it already includes the colon part, unless epsilon +|# + + +#| +A SinglePattern is one of + (make-pat:name SPBase SinglePattern (listof identifier)) + (make-pat:any SPBase) + (make-pat:sc SPBase id id boolean boolean) + (make-pat:datum SPBase datum) + (make-pat:literal SPBase identifier) + (make-pat:head SPBase HeadPattern SinglePattern) + (make-pat:dots SPBase (listof EllipsisHeadPattern) SinglePattern) + (make-pat:and SPBase (listof SinglePattern)) + (make-pat:or SPBase (listof SinglePattern)) + (make-pat:compound SPBase Kind (listof SinglePattern)) + (make-pat:cut SPBase SinglePattern) + (make-pat:describe SPBase stx SinglePattern) + (make-pat:bind SPBase (listof clause:attr)) + (make-pat:fail SPBase stx stx) + +A ListPattern is a subtype of SinglePattern; one of + (make-pat:datum SPBase '()) + (make-pat:head SPBase HeadPattern ListPattern) + (make-pat:compound SPBase '#:pair (list SinglePattern ListPattern)) + (make-pat:dots SPBase EllipsisHeadPattern SinglePattern) + (make-pat:cut SPBase ListPattern) +|# + +(define-struct pat:name (attrs pattern names) #:prefab) +(define-struct pat:any (attrs) #:prefab) +(define-struct pat:sc (attrs parser description bind-term? bind-attrs?) #:prefab) +(define-struct pat:datum (attrs datum) #:prefab) +(define-struct pat:literal (attrs id) #:prefab) +(define-struct pat:head (attrs head tail) #:prefab) +(define-struct pat:dots (attrs heads tail) #:prefab) +(define-struct pat:and (attrs patterns) #:prefab) +(define-struct pat:or (attrs patterns) #:prefab) +(define-struct pat:compound (attrs kind patterns) #:prefab) +(define-struct pat:cut (attrs pattern) #:prefab) +(define-struct pat:describe (attrs description pattern) #:prefab) +(define-struct pat:bind (attrs clauses) #:prefab) +(define-struct pat:fail (attrs when message) #:prefab) + + +#| +A HeadPattern is one of + (make-hpat:ssc HPBase id id boolean boolean) + (make-hpat:seq HPBase ListPattern) + (make-hpat:or HPBase (listof HeadPattern)) + (make-hpat:describe HPBase stx/#f HeadPattern) +|# + +(define-struct hpat:ssc (attrs parser description bind-term? bind-attrs?) #:prefab) +(define-struct hpat:seq (attrs inner) #:prefab) +(define-struct hpat:or (attrs patterns) #:prefab) +(define-struct hpat:describe (attrs description pattern) #:prefab) + +#| +An EllipsisHeadPattern is + (make-ehpat EHPBase HeadPattern RepConstraint) + +A RepConstraint is one of + (make-rep:once stx stx stx) + (make-rep:optional stx stx) + (make-rep:bounds nat/#f nat/#f stx stx stx) + #f +|# +(define-struct ehpat (attrs head repc) #:prefab) +(define-struct rep:once (name under-message over-message) #:prefab) +(define-struct rep:optional (name over-message) #:prefab) +(define-struct rep:bounds (min max name under-message over-message) #:prefab) + + +#| +A Kind is one of + '#:pair + '#:box + '#:vector + (list '#:pstruct prefab-struct-key) +|# + +(define (pattern? x) + (or (pat:name? x) + (pat:any? x) + (pat:sc? x) + (pat:datum? x) + (pat:literal? x) + (pat:head? x) + (pat:dots? x) + (pat:and? x) + (pat:or? x) + (pat:compound? x) + (pat:cut? x) + (pat:describe? x) + (pat:bind? x) + (pat:fail? x))) + +(define (head-pattern? x) + (or (hpat:ssc? x) + (hpat:seq? x) + (hpat:or? x) + (hpat:describe? 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))) + +(define pattern-attrs + (let () + (define-syntax (mk-get-attrs stx) + (syntax-case stx () + [(_ struct ...) + (with-syntax + ([([pred accessor] ...) + (for/list ([s (stx->list #'(struct ...))]) + (list (datum->syntax + s (format-symbol "~a?" (syntax-e s))) + (datum->syntax + s (format-symbol "~a-attrs" (syntax-e s)))))]) + #'(lambda (x) + (cond [(pred x) (accessor x)] ... + [else (raise-type-error 'pattern-attrs "pattern" x)])))])) + (mk-get-attrs pat:name pat:any pat:sc pat:datum pat:literal pat:head + pat:dots pat:and pat:or pat:compound pat:cut pat:describe + pat:bind pat:fail + hpat:ssc hpat:seq hpat:or hpat:describe + ehpat))) diff --git a/collects/syntax/private/stxparse/rep.ss b/collects/syntax/private/stxparse/rep.ss new file mode 100644 index 0000000000..76016dd208 --- /dev/null +++ b/collects/syntax/private/stxparse/rep.ss @@ -0,0 +1,815 @@ +#lang scheme/base +(require (for-template scheme/base) + (for-template "runtime.ss") + scheme/contract + scheme/match + scheme/dict + syntax/id-table + syntax/stx + "../util.ss" + "rep-data.ss" + "codegen-data.ss") + +(provide/contract + [parse-rhs + (-> syntax? boolean? boolean? syntax? + rhs?)] + [parse-whole-pattern + (-> syntax? DeclEnv/c + pattern?)] + [parse-pattern-directives + (->* [stx-list?] + [#:decls DeclEnv/c #:allow-declare? boolean?] + (values stx-list? DeclEnv/c (listof SideClause/c)))] + [parse-directive-table any/c] + [get-decls+defs + (-> list? + (values DeclEnv/c (listof syntax?)))] + [check-literals-list + (-> syntax? + (listof (list/c identifier? identifier?)))] + [check-literal-sets-list + (-> syntax? + (listof (listof (list/c identifier? identifier?))))] + [append-lits+litsets + (-> (listof (list/c identifier? identifier?)) + (listof (listof (list/c identifier? identifier?))) + syntax? + (listof (list/c identifier? identifier?)))] + [check-conventions-rules any/c] + [create-aux-def any/c]) + +(define (atomic-datum? stx) + (let ([datum (syntax-e stx)]) + (or (null? datum) + (boolean? datum) + (string? datum) + (number? datum) + (keyword? datum)))) + +(define (id-predicate kw) + (lambda (stx) + (and (identifier? stx) + (free-identifier=? stx kw)))) + +(define wildcard? (id-predicate (quote-syntax _))) +(define epsilon? (id-predicate (quote-syntax ||))) +(define dots? (id-predicate (quote-syntax ...))) + +(define keywords + (list (quote-syntax _) + (quote-syntax ||) + (quote-syntax ...) + (quote-syntax ~and) + (quote-syntax ~or) + (quote-syntax ~seq) + (quote-syntax ~rep) + (quote-syntax ~once) + (quote-syntax ~optional) + (quote-syntax ~rest) + (quote-syntax ~struct) + (quote-syntax ~!) + (quote-syntax ~describe) + (quote-syntax ~bind) + (quote-syntax ~fail))) + +(define (reserved? stx) + (and (identifier? stx) + (for/or ([kw keywords]) + (free-identifier=? stx kw)))) + +;; --- + +;; parse-rhs : stx boolean boolean stx -> RHS +;; If allow-unbound? is true, then all stxclasses act as if they have no attrs. +;; Used for pass1 (attr collection); parser requires stxclasses to be bound. +(define (parse-rhs stx allow-unbound? splicing? ctx) + (define-values (rest description transparent? attributes decls defs) + (parse-rhs/part1 stx ctx)) + (define patterns (parse-variants rest decls allow-unbound? splicing? ctx)) + (when (null? patterns) + (wrong-syntax ctx "expected at least one variant")) + (let ([sattrs + (or attributes + (intersect-sattrss (map variant-attrs patterns)))]) + (make rhs stx sattrs transparent? description patterns defs))) + +(define (parse-rhs/part1 stx ctx) + (define-values (chunks rest) + (chunk-kw-seq/no-dups stx rhs-directive-table #:context ctx)) + (define desc0 (assq '#:description chunks)) + (define trans0 (assq '#:transparent chunks)) + (define attrs0 (assq '#:attributes chunks)) + (define description (and desc0 (caddr desc0))) + (define transparent? (and trans0 #t)) + (define attributes (and attrs0 (caddr attrs0))) + (define-values (decls defs) (get-decls+defs chunks)) + (values rest description transparent? attributes decls defs)) + +(define (parse-variants rest decls allow-unbound? splicing? ctx) + (define (gather-patterns stx) + (syntax-case stx (pattern) + [((pattern . _) . rest) + (cons (parse-variant (stx-car stx) allow-unbound? splicing? decls) + (gather-patterns #'rest))] + [(bad-variant . rest) + (raise-syntax-error #f "expected syntax-class variant" ctx #'bad-variant)] + [() + null])) + (gather-patterns rest)) + +;; get-decls+defs : chunks -> (values DeclEnv (listof syntax)) +(define (get-decls+defs chunks) + (decls-create-defs (get-decls chunks))) + +;; get-decls : chunks -> DeclEnv +(define (get-decls chunks #:context [ctx #f]) + (define lits0 (assq '#:literals chunks)) + (define litsets0 (assq '#:literal-sets chunks)) + (define convs0 (assq '#:conventions chunks)) + (define literals + (append-lits+litsets + (if lits0 (caddr lits0) null) + (if litsets0 (caddr litsets0) null) + ctx)) + (define convention-rules (if convs0 (apply append (caddr convs0)) null)) + (new-declenv literals #:conventions convention-rules)) + +;; decls-create-defs : DeclEnv -> (values DeclEnv (listof stx)) +(define (decls-create-defs decls0) + (for/fold ([decls decls0] [defs null]) + ([(k v) (in-dict (declenv-table decls0))] + #:when (memq (car v) '(stxclass splicing-stxclass))) + (let-values ([(parser description attrs new-defs) (create-aux-def v)]) + (values (declenv-put-parser decls k parser description attrs + (eq? (car v) 'splicing-stxclass)) + (append new-defs defs))))) + +;; create-aux-def : DeclEntry -> (values id id (listof SAttr) (listof stx)) +(define (create-aux-def entry) + (let ([sc-name (caddr entry)] + [args (cadddr entry)]) + (let ([sc (get-stxclass/check-arg-count sc-name (length args))]) + (with-syntax ([sc-parser (stxclass-parser-name sc)] + [sc-description (stxclass-description sc)]) + (if (pair? args) + (with-syntax ([x (generate-temporary 'x)] + [parser (generate-temporary sc-name)] + [description (generate-temporary sc-name)] + [(arg ...) args]) + (values #'parser #'description (stxclass-attrs sc) + (list #'(define (parser x) (sc-parser x arg ...)) + #'(define (description) (description arg ...))))) + (values #'sc-parser #'sc-description (stxclass-attrs sc) + null)))))) + +(define (append-lits+litsets lits litsets ctx) + (define seen (make-bound-id-table lits)) + (for ([litset litsets]) + (for ([lit litset]) + (when (bound-id-table-ref seen (car lit) #f) + (raise-syntax-error #f "duplicate literal declaration" ctx (car lit))) + (bound-id-table-set! seen (car lit) #t))) + (apply append lits litsets)) + +;; parse-variant : stx boolean boolean boolean DeclEnv -> RHS +(define (parse-variant stx allow-unbound? splicing? decls0) + (syntax-case stx (pattern) + [(pattern p . rest) + (parameterize ((use-dummy-stxclasses? allow-unbound?)) + (let-values ([(rest decls1 clauses) + (parse-pattern-directives #'rest + #:decls decls0)]) + (define-values (decls defs) (decls-create-defs decls1)) + (unless (stx-null? rest) + (wrong-syntax (if (pair? rest) (car rest) rest) + "unexpected terms after pattern directives")) + (let* ([pattern (parse-whole-pattern #'p decls splicing?)] + [attrs + (append-iattrs + (cons (pattern-attrs pattern) + (side-clauses-attrss clauses)))] + [sattrs (iattrs->sattrs attrs)]) + (make variant stx sattrs pattern clauses defs))))])) + +(define (side-clauses-attrss clauses) + (for/list ([c clauses] + #:when (or (clause:with? c) (clause:attr? c))) + (if (clause:with? c) + (pattern-attrs (clause:with-pattern c)) + (list (clause:attr-attr c))))) + +;; parse-whole-pattern : stx DeclEnv boolean -> Pattern +(define (parse-whole-pattern stx decls [splicing? #f]) + (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 #f "declared pattern variables do not appear in pattern" + #:extra excess-domain)) + pattern) + + +;; ---- + +;; parse-single-pattern : stx DeclEnv -> SinglePattern +(define (parse-single-pattern stx decls) + (syntax-case stx (~and ~or ~rest ~struct ~! ~describe ~bind ~fail) + [wildcard + (wildcard? #'wildcard) + (make pat:any null)] + [reserved + (reserved? #'reserved) + (wrong-syntax stx "not allowed here")] + [id + (identifier? #'id) + (parse-pat:id stx decls #f)] + [datum + (atomic-datum? #'datum) + (make pat:datum null (syntax->datum #'datum))] + [(~and . rest) + (parse-pat:and stx decls)] + [(~or . rest) + (parse-pat:or stx decls #f)] + [(head dots . tail) + (dots? #'dots) + (parse-pat:dots stx #'head #'tail decls)] + [(~struct key . contents) + (let ([lp (parse-single-pattern (syntax/loc stx contents) decls)] + [key (syntax->datum #'key)]) + (make pat:compound (pattern-attrs lp) `(#:pstruct ,key) (list lp)))] + [(~! . rest) + (let ([inner (parse-single-pattern (syntax/loc stx rest) decls)]) + (make pat:cut (pattern-attrs inner) inner))] + [(~describe . rest) + (parse-pat:describe stx decls #f)] + [(~bind . rest) + (parse-pat:bind stx decls)] + [(~fail . rest) + (parse-pat:fail stx decls)] + [(~rest . rest) + (parse-pat:rest stx decls)] + [(head . tail) + (parse-pat:pair stx #'head #'tail decls)] + [#(a ...) + (let ([lp (parse-single-pattern (syntax/loc stx (a ...)) decls)]) + (make pat:compound (pattern-attrs lp) '#:vector (list lp)))] + [b + (box? (syntax-e #'b)) + (let ([bp (parse-single-pattern (unbox (syntax-e #'b)) decls)]) + (make pat:compound (pattern-attrs bp) '#:box (list bp)))] + [s + (and (struct? (syntax-e #'s)) (prefab-struct-key (syntax-e #'s))) + (let* ([s (syntax-e #'s)] + [key (prefab-struct-key s)] + [contents (cdr (vector->list (struct->vector s)))]) + (let ([lp (parse-single-pattern (datum->syntax #f contents #'s) decls)]) + (make pat:compound (pattern-attrs lp) `(#:pstruct ,key) (list lp))))])) + +;; parse-head-pattern : stx DeclEnv -> HeadPattern +(define (parse-head-pattern stx decls) + (syntax-case stx (~or ~seq ~describe) + [id + (and (identifier? #'id) (not (reserved? #'id))) + (parse-pat:id stx decls #t)] + [(~or . rest) + (parse-pat:or stx decls #t)] + [(~seq . rest) + (parse-hpat:seq stx #'rest decls)] + [(~describe . rest) + (parse-pat:describe stx decls #t)] + [_ + (parse-single-pattern stx decls)])) + +;; parse-ellipsis-head-pattern : stx DeclEnv number -> EllipsisHeadPattern +(define (parse-ellipsis-head-pattern stx decls) + (syntax-case stx (~bounds ~optional ~once) + [(~optional . _) + (parse-ehpat/optional stx decls)] + [(~once . _) + (parse-ehpat/once stx decls)] + [(~bounds . _) + (parse-ehpat/bounds stx decls)] + [_ + (let ([head (parse-head-pattern stx decls)]) + (make ehpat (map increase-depth (pattern-attrs head)) + head + #f))])) + +;; ---- + +(define (parse-pat:id id decls allow-head?) + (define entry (declenv-lookup decls id)) + (match entry + [(list 'literal internal-id literal-id) + (make pat:literal null literal-id)] + [(list 'stxclass _ _ _) + (error 'parse-pat:id "decls had leftover 'stxclass entry: ~s" entry)] + [(list 'splicing-stxclass _ _ _) + (error 'parse-pat:id "decls had leftover 'splicing-stxclass entry: ~s" entry)] + [(list 'parser parser description attrs) + (parse-pat:id/s id id parser description attrs)] + [(list 'splicing-parser parser description attrs) + (parse-pat:id/h id id parser description attrs)] + [#f + (let-values ([(name sc) (split-id/get-stxclass id decls)]) + (cond [(stxclass/s? sc) + (parse-pat:id/s id name + (stxclass-parser-name sc) + (stxclass-description sc) + (stxclass-attrs sc))] + [(stxclass/h? sc) + (unless allow-head? + (wrong-syntax id "splicing syntax class not allowed here")) + (parse-pat:id/h id name + (stxclass-parser-name sc) + (stxclass-description sc) + (stxclass-attrs sc))] + [else + (wrap/name name (make pat:any null))]))])) + +(define (parse-pat:id/s stx name parser description attrs) + (define prefix (name->prefix name)) + (define bind (name->bind name)) + (make pat:sc (id-pattern-attrs attrs bind prefix) + parser description (and bind #t) (and prefix #t))) + +(define (parse-pat:id/h stx name parser description attrs) + (define prefix (name->prefix name)) + (define bind (name->bind name)) + (make hpat:ssc (id-pattern-attrs attrs bind prefix) + parser description (and bind #t) (and prefix #t))) + +(define (name->prefix id) + (cond [(wildcard? id) #f] + [(epsilon? id) id] + [else (datum->syntax id (format-symbol "~a." (syntax-e id)))])) + +(define (name->bind id) + (cond [(wildcard? id) #f] + [(epsilon? id) #f] + [else id])) + +(define (wrap/name id pattern) + (cond [(wildcard? id) pattern] + [(epsilon? id) pattern] + [else + (let ([a (make attr id 0 #t)]) + (make pat:name (cons a (pattern-attrs pattern)) pattern (list id)))])) + +;; id-pattern-attrs : (listof SAttr) id/#f IdPrefix -> (listof IAttr) +(define (id-pattern-attrs sattrs bind prefix) + (let ([rest + (if prefix + (for/list ([a sattrs]) + (prefix-attr a prefix)) + null)]) + (if bind + (cons (make attr bind 0 #t) rest) + rest))) + +;; 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) + (datum->syntax prefix (format-symbol "~a~a" (syntax-e prefix) name))) + +;; ---- + +(define (parse-pat:describe stx decls allow-head?) + (syntax-case stx () + [(_ description pattern) + (let ([p (parse-some-pattern #'pattern decls allow-head?)]) + (if (head-pattern? p) + (make hpat:describe (pattern-attrs p) #'description p) + (make pat:describe (pattern-attrs p) #'description 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 + (let () + (define attrs (union-iattrs (map pattern-attrs patterns))) + (cond [(ormap head-pattern? patterns) + (make-hpat:or attrs patterns)] + [else + (make-pat:or attrs patterns)]))])) + +(define (parse-pat:and stx decls) + (define patterns (parse-cdr-patterns stx decls #f #t)) + (make pat:and (append-iattrs (map pattern-attrs patterns)) patterns)) + +;; FIXME: broken, first off, and second, must not reorder names, preserve original scopes +(define (simplify-and-pattern patterns0) + (define (loop patterns names) + (cond [(pair? patterns) + (match (car patterns) + [(struct pat:any ('())) + (loop (cdr patterns) names)] + [(struct pat:name (_ pattern ns)) + (loop (cons pattern (cdr patterns)) + (append ns names))])] + [else (values patterns names)])) + (define-values (patterns names) + (loop patterns0 null)) + (define base + (if (pair? patterns) + (make pat:and (append-iattrs (map pattern-attrs patterns)) patterns) + (make pat:any '()))) + (if (pair? names) + (let ([new-attrs (for/list ([name names]) (make attr name 0 #t))]) + (make pat:name (append new-attrs (pattern-attrs base)) base names)) + base)) + +(define (parse-hpat:seq stx list-stx decls) + (define pattern (parse-single-pattern list-stx decls)) + (check-list-pattern pattern stx) + (make hpat:seq (pattern-attrs pattern) pattern)) + +(define (parse-cdr-patterns stx decls allow-head? allow-cut?) + (unless (stx-list? stx) + (wrong-syntax stx "expected sequence of patterns")) + (let ([result + (for/list ([sub (cdr (stx->list stx))]) + (if allow-cut? + (or (parse-cut/and sub) + (parse-some-pattern sub decls allow-head?)) + (parse-some-pattern sub decls allow-head?)))]) + (when (null? result) + (wrong-syntax stx "expected at least one pattern")) + result)) + +(define (parse-cut/and stx) + (syntax-case stx (~!) + [~! (make pat:cut null (make pat:any null))] + [_ #f])) + +(define (parse-some-pattern stx decl allow-head?) + (define p (parse-head-pattern stx decl)) + (when (head-pattern? p) + (unless allow-head? + (wrong-syntax stx "head pattern not allowed"))) + p) + +(define (parse-pat:dots stx head tail decls) + (define headps + (syntax-case head (~or) + [(~or . _) + (begin + (unless (stx-list? head) + (wrong-syntax head "expected sequence of patterns")) + (for/list ([sub (cdr (stx->list head))]) + (parse-ellipsis-head-pattern sub decls)))] + [_ + (list (parse-ellipsis-head-pattern head decls))])) + (define tailp (parse-single-pattern tail decls)) + (define attrs + (append-iattrs (cons (pattern-attrs tailp) + (map pattern-attrs headps)))) + (make pat:dots attrs headps tailp)) + +(define (parse-pat:bind stx decls) + (syntax-case stx () + [(_ clause ...) + (parameterize ((current-syntax-context stx)) + (let ([clauses (map parse-bind-clause (syntax->list #'(clause ...)))]) + (make pat:bind + (append-iattrs (side-clauses-attrss clauses)) + clauses)))])) + +(define (parse-bind-clause clause) + (syntax-case clause () + [(attr-decl expr) + (make clause:attr (check-attr-arity #'attr-decl) #'expr)] + [_ (wrong-syntax clause "expected bind clause")])) + +(define (parse-pat:fail stx decls) + (syntax-case stx () + [(_ . rest) + (let-values ([(chunks rest) + (chunk-kw-seq/no-dups #'rest + fail-directive-table + #:context stx)]) + ;; chunks has 0 or 1 of each of #:when, #:unless + ;; if has both, second one is bad; report it + (when (> (length chunks) 1) + (wrong-syntax (cadr (cadr chunks)) + "cannot use both #:when and #:unless conditions")) + (let ([condition + (if (null? chunks) + #'#t + (let ([chunk (car chunks)]) + (if (eq? (car chunk) '#:when) + (caddr chunk) + #`(not #,(caddr chunk)))))]) + (syntax-case rest () + [(message) + (make pat:fail null condition #'message)] + [() + (wrong-syntax stx "missing message expression")] + [_ + (wrong-syntax stx "bad fail pattern")])))])) + +(define (parse-pat:rest stx decls) + (syntax-case stx () + [(_ pattern) + (parse-single-pattern #'pattern decls)])) + +(define (parse-pat:pair stx head tail decls) + (define headp (parse-head-pattern head decls)) + (define tailp (parse-single-pattern tail decls)) + (define attrs + (append-iattrs + (list (pattern-attrs headp) (pattern-attrs tailp)))) + ;; Only make pat:head if head is complicated; otherwise simple compound/pair + ;; FIXME: Could also inline ~seq patterns from head...? + (if (head-pattern? headp) + (make pat:head attrs headp tailp) + (make pat:compound attrs '#:pair (list headp tailp)))) + +(define (check-list-pattern pattern stx) + (match pattern + [(struct pat:datum (_base '())) + #t] + [(struct pat:head (_base _head tail)) + (check-list-pattern tail stx)] + [(struct pat:dots (_base _head tail)) + (check-list-pattern tail stx)] + [(struct pat:compound (_base '#:pair (list _head tail))) + (check-list-pattern tail stx)] + [(struct pat:name (_ pattern _)) + (check-list-pattern pattern stx)] + [else + (wrong-syntax stx "expected proper list pattern")])) + +(define (parse-ehpat/optional stx decls) + (syntax-case stx (~optional) + [(~optional p . options) + (let ([head (parse-head-pattern #'p decls)]) + (with-syntax ([((too-many-msg) (name)) + (parse-kw-options #'options + (list (list '#:too-many values) + (list '#:name values)) + (list (list '#:too-many #'#f) + (list '#:name #'#f)) + #:context stx)]) + (make ehpat (map attr-make-uncertain (pattern-attrs head)) + head + (make rep:optional #'name #'too-many-msg))))])) + +(define (parse-ehpat/once stx decls) + (syntax-case stx (~once) + [(~once p . options) + (let ([head (parse-head-pattern #'p decls)]) + (with-syntax ([((too-few-msg) (too-many-msg) (name)) + (parse-kw-options #'options + (list (list '#:too-few values) + (list '#:too-many values) + (list '#:name values)) + (list (list '#:too-few #'#f) + (list '#:too-many #'#f) + (list '#:name #'#f)) + #:context stx)]) + (make ehpat (pattern-attrs head) + head + (make rep:once #'name #'too-few-msg #'too-many-msg))))])) + +(define (parse-ehpat/bounds stx decls) + (syntax-case stx (~bounds) + [(~bounds p min max . options) + (let ([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) (= +inf.0 maxN)) + (wrong-syntax #'max + "expected exact nonnegative integer or +inf.0")) + (when (> minN maxN) + (wrong-syntax stx "minumum larger than maximum repetition constraint")) + (with-syntax ([((too-few-msg) (too-many-msg) (name)) + (parse-kw-options #'options + (list (list '#:too-few values) + (list '#:too-many values) + (list '#:name values)) + (list (list '#:too-few #'#f) + (list '#:too-many #'#f) + (list '#:name #'#f)))]) + (make ehpat (map increase-depth (pattern-attrs head)) + head + (make rep:bounds #'min #'max #'name #'too-few #'too-many))))])) + +;; ----- + +;; parse-pattern-directives : stxs(PatternDirective) +;; -> stx DeclEnv (listof SideClause) +(define (parse-pattern-directives stx + #:decls [decls #f] + #:allow-declare? [allow-declare? #t]) + (define-values (chunks rest) + (chunk-kw-seq stx pattern-directive-table)) + (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)) + (values rest decls2 (parse-pattern-sides chunks2 decls))) + +;; parse-pattern-sides : (listof chunk) DeclEnv +;; -> (listof SideClause/c) +;; 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 follow pattern or #:with clause")] + [(cons (list '#:fail-when fw-stx when-condition expr) rest) + (cons (make clause:fail when-condition expr) + (parse-pattern-sides rest decls))] + [(cons (list '#:fail-unless fu-stx unless-condition expr) rest) + (cons (make clause:fail #`(not #,unless-condition) expr) + (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)]) + (cons (make clause:with (parse-whole-pattern pattern decls2a) expr defs) + (parse-pattern-sides rest decls))))] + [(cons (list '#:attr attr-stx a expr) rest) + (cons (make clause:attr a expr) + (parse-pattern-sides rest decls))] + ['() + '()])) + +;; grab-decls : (listof chunk) DeclEnv +;; -> (values DeclEnv (listof chunk)) +(define (grab-decls chunks decls) + (define (add-decl stx decls) + (syntax-case stx () + [(#:declare name sc) + (identifier? #'sc) + (add-decl* #'name #'sc null)] + [(#:declare name (sc expr ...)) + (identifier? #'sc) + (add-decl* #'name #'sc (syntax->list #'(expr ...)))] + [(#:declare name bad-sc) + (wrong-syntax #'bad-sc + "expected syntax class name (possibly with parameters)")])) + (define (add-decl* id sc-name args) + (declenv-put-stxclass decls id sc-name args)) + (define (loop chunks decls) + (match chunks + [(cons (cons '#:declare decl-stx) rest) + (loop rest (add-decl decl-stx decls))] + [else (values decls chunks)])) + (loop chunks decls)) + + +;; check-lit-string : stx -> string +(define (check-lit-string stx) + (let ([x (syntax-e stx)]) + (unless (string? x) + (wrong-syntax stx "expected string literal")) + x)) + +;; check-attr-arity-list : stx -> (listof SAttr) +(define (check-attr-arity-list stx) + (unless (stx-list? stx) + (wrong-syntax stx "expected list of attribute declarations")) + (let ([iattrs (map check-attr-arity (stx->list stx))]) + (iattrs->sattrs (append-iattrs (map list iattrs))))) + +;; check-attr-arity : stx -> IAttr +(define (check-attr-arity stx) + (syntax-case stx () + [attr + (identifier? #'attr) + (make-attr #'attr 0 #f)] + [(attr depth) + (begin (unless (identifier? #'attr) + (wrong-syntax #'attr "expected attribute name")) + (unless (exact-nonnegative-integer? (syntax-e #'depth)) + (wrong-syntax #'depth "expected depth (nonnegative integer)")) + (make-attr #'attr (syntax-e #'depth) #f))] + [_ + (wrong-syntax stx "expected attribute name with optional depth declaration")])) + +;; check-literals-list : syntax -> (listof id) +(define (check-literals-list stx) + (unless (stx-list? stx) + (wrong-syntax stx "expected literals list")) + (let ([lits (map check-literal-entry (stx->list stx))]) + (let ([dup (check-duplicate-identifier (map car lits))]) + (when dup (wrong-syntax dup "duplicate literal identifier"))) + lits)) + +(define (check-literal-entry stx) + (syntax-case stx () + [(internal external) + (and (identifier? #'internal) (identifier? #'external)) + (list #'internal #'external)] + [id + (identifier? #'id) + (list #'id #'id)] + [_ + (wrong-syntax stx + "expected literal (identifier or pair of identifiers)")])) + +(define (check-literal-sets-list stx) + (unless (stx-list? stx) + (wrong-syntax stx "expected literal-set list")) + (map check-literal-set-entry (stx->list stx))) + +(define (check-literal-set-entry stx) + (define (elaborate litset-id context) + (let ([litset (syntax-local-value litset-id (lambda () #f))]) + (unless (literalset? litset) + (wrong-syntax litset-id "expected identifier defined as a literal-set")) + (elaborate-litset litset context stx))) + (syntax-case stx () + [(litset #:at context) + (and (identifier? #'litset) (identifier? #'context)) + (elaborate #'litset #'context)] + [litset + (identifier? #'litset) + (elaborate #'litset #'litset)] + [_ + (wrong-syntax stx "expected literal-set entry")])) + +(define (elaborate-litset litset context ctx) + (for/list ([entry (literalset-literals litset)]) + (list (datum->syntax context (car entry) ctx) + (cadr entry)))) + +(define (check-conventions-list stx) + (unless (stx-list? stx) + (wrong-syntax stx "expected conventions list")) + (map check-conventions (stx->list stx))) + +(define (check-conventions stx) + (define (elaborate conventions-id) + (let ([cs (syntax-local-value conventions-id (lambda () #f))]) + (unless (conventions? cs) + (wrong-syntax conventions-id "expected identifier defined as a conventions")) + (conventions-rules cs))) + (syntax-case stx () + [conventions + (identifier? #'conventions) + (elaborate #'conventions)] + [_ + (wrong-syntax stx "expected conventions entry")])) + +(define (check-conventions-rules stx) + (unless (stx-list? stx) + (wrong-syntax stx "expected convention rule list")) + (map check-conventions-rule (stx->list stx))) + +(define (check-conventions-rule stx) + (define (check-conventions-pattern x blame) + (cond [(symbol? x) (regexp (string-append "^" (regexp-quote (symbol->string x)) "$"))] + [(regexp? x) x] + [else (wrong-syntax blame "expected identifier convention pattern")])) + (define (check-sc-expr x) + (syntax-case x () + [sc (identifier? #'sc) (list #'sc null)] + [(sc arg ...) (identifier? #'sc) (list #'sc #'(arg ...))] + [_ (wrong-syntax x "expected syntax class use")])) + (syntax-case stx () + [(rx sc) + (list (check-conventions-pattern (syntax-e #'rx) #'rx) + (check-sc-expr #'sc))])) + +;; parse-directive-table +(define parse-directive-table + (list (list '#:literals check-literals-list) + (list '#:literal-sets check-literal-sets-list) + (list '#:conventions check-conventions-list))) + +;; rhs-directive-table +(define rhs-directive-table + (list* (list '#:description values) + (list '#:transparent) + (list '#:attributes check-attr-arity-list) + parse-directive-table)) + +;; pattern-directive-table +(define pattern-directive-table + (list (list '#:declare check-id values) + (list '#:fail-when values values) + (list '#:fail-unless values values) + (list '#:with values values) + (list '#:attr check-attr-arity values))) + +;; fail-directive-table +(define fail-directive-table + (list (list '#:when values) + (list '#:unless values))) diff --git a/collects/syntax/private/stxparse/runtime-prose.ss b/collects/syntax/private/stxparse/runtime-prose.ss new file mode 100644 index 0000000000..d5f9fd9aa2 --- /dev/null +++ b/collects/syntax/private/stxparse/runtime-prose.ss @@ -0,0 +1,149 @@ +#lang scheme/base +(require scheme/contract + scheme/list + scheme/match + scheme/stxparam + syntax/stx + (for-syntax scheme/base) + (for-syntax syntax/stx) + (for-syntax scheme/private/sc) + (for-syntax "rep-data.ss") + (for-syntax "../util/error.ss") + "runtime.ss") +(provide default-failure-handler) + +(define (default-failure-handler stx0 f) + (match (simplify-failure f) + [(struct failure (x frontier frontier-stx expected)) + (report-failure stx0 x (last frontier) frontier-stx expected)])) + +;; report-failure : stx stx number stx Expectation -> (escapes) +(define (report-failure stx0 x index frontier-stx expected) + (define (err msg stx0 stx) + (raise-syntax-error #f msg stx0 stx)) + (cond [(expectation-of-null? expected) + ;; FIXME: "extra term(s) after " + (syntax-case x () + [(one) + (err "unexpected term" stx0 #'one)] + [(first . more) + (err "unexpected terms starting here" stx0 #'first)] + [_ + (err "unexpected term" stx0 x)])] + [(and expected (prose-for-expectation expected index x)) + => + (lambda (msg) + (err (format "~a~a" + msg + (cond [(zero? index) ""] + [(= index +inf.0) " after matching main pattern"] + [else (format " after ~s ~a" + index + (if (= 1 index) "term" "terms"))])) + stx0 + frontier-stx))] + [else + (err #f stx0 stx0)])) + +;; FIXME: try different selection/simplification algorithms/heuristics +(define (simplify-failure f) + (match f + [(struct join-failures (f1 f2)) + (choose-error (simplify-failure f1) (simplify-failure f2))] + [(struct failure (x frontier frontier-stx expectation)) + (match expectation + [(struct expect:thing (description (and transparent? #t) chained)) + (match (simplify-failure (adjust-failure chained frontier frontier-stx)) + [(struct failure (_ _ _ (? ineffable?))) + ;; If unfolded failure is ineffable, fall back to the one with description + f] + [new-f new-f])] + [_ f])])) + +(define (adjust-failure f base-frontier base-frontier-stx) + (match f + [(struct join-failures (f1 f2)) + (make-join-failures + (adjust-failure f1 base-frontier base-frontier-stx) + (adjust-failure f2 base-frontier base-frontier-stx))] + [(struct failure (x frontier frontier-stx expectation)) + (let-values ([(frontier frontier-stx) + (combine-frontiers base-frontier base-frontier-stx + frontier frontier-stx)]) + (make-failure x frontier frontier-stx expectation))])) + +(define (combine-frontiers dfc0 stx0 dfc stx) + (cond [(null? (cdr dfc0)) + (values (cons (+ (car dfc0) (car dfc)) + (cdr dfc)) + (if (null? (cdr dfc)) + stx0 + stx))] + [else + (let-values ([(f s) (combine-frontiers (cdr dfc0) stx0 dfc stx)]) + (values (cons (car dfc0) f) s))])) + +;; choose-error : Failure Failure -> Result +(define (choose-error f1 f2) + (case (compare-dfcs (failure-frontier f1) (failure-frontier f2)) + [(>) f1] + [(<) f2] + [(=) (merge-failures f1 f2)])) + +;; merge-failures : failure failure -> failure +(define (merge-failures f1 f2) + (make-failure (failure-stx f1) + (failure-frontier f1) + (failure-frontier-stx f1) + (merge-expectations (failure-expectation f1) + (failure-expectation f2)))) + +;; ---- + +;; prose-for-expectation : Expectation syntax -> string/#f +(define (prose-for-expectation e index stx) + (cond [(expect? e) + (let ([parts + (for/list ([alt (expect->alternatives e)]) + (for-alternative alt index stx))]) + (join-sep parts ";" "or"))] + [(eq? e 'ineffable) + #f])) + +(define (for-alternative e index stx) + (match e + [(struct expect:thing (description transparent? chained)) + (format "expected ~a" description)] + [(struct expect:atom (atom)) + (format "expected the literal ~s" atom)] + [(struct expect:literal (literal)) + (format "expected the literal identifier ~s" (syntax-e literal))] + [(struct expect:message (message)) + (format "~a" message)] + [(struct expect:pair ()) + (cond [(= index 0) + "expected sequence of terms"] + [else + (if (stx-null? stx) + "expected more terms in sequence" + "expected sequence of terms")])])) + +(define (comma-list items) + (join-sep items "," "or")) + +(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/collects/syntax/private/stxparse/runtime.ss b/collects/syntax/private/stxparse/runtime.ss new file mode 100644 index 0000000000..47d611463a --- /dev/null +++ b/collects/syntax/private/stxparse/runtime.ss @@ -0,0 +1,382 @@ +#lang scheme/base +(require scheme/contract + scheme/match + scheme/stxparam + (for-syntax scheme/base + syntax/stx + scheme/private/sc + "rep-data.ss" + "rep-attrs.ss" + "../util.ss")) + +(provide pattern + ~and + ~or + ~seq + ~bounds + ~once + ~optional + ~rest + ~struct + ~! + ~describe + ~bind + ~fail + + current-expression + current-macro-name + + this-syntax + + compare-dfcs + + expect? + expectation? + (struct-out expect:thing) + (struct-out expect:atom) + (struct-out expect:literal) + (struct-out expect:message) + (struct-out expect:pair) + (struct-out expect:disj) + merge-expectations + expect->alternatives + ineffable? + + expectation-of-null? + + enclosing-fail + enclosing-cut-fail + with-enclosing-fail + with-enclosing-cut-fail + with-enclosing-fail* + without-fails + + ok? + (struct-out failure) + (struct-out join-failures) + + try + + stx-list-take + + let-attributes + attribute + let/unpack + attribute-binding + check-list^depth) + +;; == Keywords + +(define-syntax-rule (define-keyword name) + (define-syntax name + (lambda (stx) + (raise-syntax-error #f "keyword used out of context" stx)))) + +(define-keyword pattern) +(define-keyword ~and) +(define-keyword ~or) +(define-keyword ~seq) +(define-keyword ~bounds) +(define-keyword ~once) +(define-keyword ~optional) +(define-keyword ~rest) +(define-keyword ~struct) +(define-keyword ~!) +(define-keyword ~describe) +(define-keyword ~bind) +(define-keyword ~fail) + +;; == Parameters & Syntax Parameters + +;; this-syntax +;; Bound to syntax being matched inside of syntax class +(define-syntax-parameter this-syntax + (lambda (stx) + (wrong-syntax stx "used out of context: not within a syntax class"))) + +(define current-expression (make-parameter #f)) + +(define (current-macro-name) + (let ([expr (current-expression)]) + (and expr + (syntax-case expr (set!) + [(set! kw . _) + #'kw] + [(kw . _) + (identifier? #'kw) + #'kw] + [kw + (identifier? #'kw) + #'kw] + [_ #f])))) + + +;; == Dynamic Frontier Contexts (DFCs) + +;; A DFC is a list of numbers. + +;; compare-dfcs : DFC DFC -> (one-of '< '= '>) +;; Note A>B means A is "further along" than B. +(define (compare-dfcs a b) + (cond [(and (null? a) (null? b)) + '=] + [(and (pair? a) (null? b)) + '>] + [(and (null? a) (pair? b)) + '<] + [(and (pair? a) (pair? b)) + (cond [(> (car a) (car b)) '>] + [(< (car a) (car b)) '<] + [else (compare-dfcs (cdr a) (cdr b))])])) + +;; == Codegen internal syntax parameters + +(define-for-syntax not-allowed/not-parsing + (lambda (stx) + (wrong-syntax stx "used out of context: not parsing pattern"))) + +(define-syntax-parameter pattern-source not-allowed/not-parsing) + +;; Two levels of fail continuation: +;; - enclosing-fail : ordinary fail +;; - enclosing-cut-fail : last cut "prompt" + +(define-syntax-parameter enclosing-fail not-allowed/not-parsing) +(define-syntax-parameter enclosing-cut-fail not-allowed/not-parsing) + +(define-syntax-rule (with-enclosing-fail failvar expr) + (syntax-parameterize ((enclosing-fail (make-rename-transformer (quote-syntax failvar)))) + expr)) + +(define-syntax-rule (with-enclosing-cut-fail failvar expr) + (syntax-parameterize ((enclosing-cut-fail (make-rename-transformer (quote-syntax failvar)))) + expr)) + +(define-syntax-rule (with-enclosing-fail* failvar expr) + (syntax-parameterize ((enclosing-fail (make-rename-transformer (quote-syntax failvar))) + (enclosing-cut-fail (make-rename-transformer (quote-syntax failvar)))) + expr)) + +(define-syntax-rule (without-fails body) + (syntax-parameterize ((enclosing-fail not-allowed/not-parsing) + (enclosing-cut-fail not-allowed/not-parsing)) + body)) + + +;; == Success and Failure + +;; A Failure is one of +;; (make-failure stx DFC stx expectation/c) +;; (make-join-failures Failure Failure) + +(define ok? list?) + +(define-struct failure (stx frontier frontier-stx expectation) #:transparent) +(define-struct join-failures (f1 f2) #:transparent) + +;; (try expr ...) +(define-syntax (try stx) + (syntax-case stx () + [(try expr ...) + (when (stx-null? #'(expr ...)) + (raise-syntax-error #f "must have at least one attempt" stx)) + #'(try* (list (lambda (fail) + (with-enclosing-fail fail expr)) + ...) + enclosing-fail)])) + +;; FailFunction = (Failure -> Result) + +;; try* : (nonempty-listof (-> FailFunction Result)) FailFunction -> Result +(define (try* attempts fail) + (let ([first-attempt (car attempts)] + [rest-attempts (cdr attempts)]) + (if (null? rest-attempts) + (first-attempt fail) + (let ([next-fail + (lambda (f1) + (let ([combining-fail + (lambda (f2) + (fail (make-join-failures f1 f2)))]) + (try* rest-attempts combining-fail)))]) + (first-attempt next-fail))))) + + +;; == Expectations + +#| +An Expectation is one of + 'ineffable + (make-expect:thing string boolean Failure/#f) + (make-expect:atom atom) + (make-expect:literal identifier) + (make-expect:message string) + (make-expect:pair) + (make-expect:disj Expectation Expectation) +|# +(define-struct expect:thing (description transparent? chained) #:prefab) +(define-struct expect:atom (atom) #:prefab) +(define-struct expect:literal (literal) #:prefab) +(define-struct expect:message (message) #:prefab) +(define-struct expect:pair () #:prefab) +(define-struct expect:disj (a b) #:prefab) + +(define (expect? x) + (or (expect:thing? x) + (expect:atom? x) + (expect:literal? x) + (expect:message? x) + (expect:pair? x) + (expect:disj? x))) + +(define expectation? + (or/c expect? (symbols 'ineffable))) + +(define (merge-expectations a b) + (make-expect:disj a b)) + +;; expect->alternatives : Expectation -> (listof Expectation)/#f +;; #f indicates 'ineffable somewhere in expectation +(define (expect->alternatives e) + (define (loop e) + (cond [(expect:disj? e) + (union (expect->alternatives (expect:disj-a e)) + (expect->alternatives (expect:disj-b e)))] + [else (list e)])) + (let ([alts (loop e)]) + (if (for/or ([alt alts]) (eq? alt 'ineffable)) + #f + alts))) + +;; FIXME: n^2 use of union above +(define (union a b) + (append a (for/list ([x b] #:when (not (member x a))) x))) + +(define (expectation-of-null? e) + (or (equal? e '#s(expect:atom ())) + (and (expect:disj? e) + (expectation-of-null? (expect:disj-a e)) + (expectation-of-null? (expect:disj-b e))))) + +(define (ineffable? e) + (or (eq? e 'ineffable) + (and (expect:disj? e) + (or (ineffable? (expect:disj-a e)) + (ineffable? (expect:disj-b e)))))) + + +;; ----- + +(require syntax/stx) +(define (stx-list-take stx n) + (datum->syntax stx + (let loop ([stx stx] [n n]) + (if (zero? n) + null + (cons (stx-car stx) + (loop (stx-cdr stx) (sub1 n))))) + stx)) + +;; == Attributes + +(begin-for-syntax + (define-struct attribute-mapping (var name depth syntax?) + #:omit-define-syntaxes + #:property prop:procedure + (lambda (self stx) + (if (attribute-mapping-syntax? self) + #`(#%expression #,(attribute-mapping-var self)) + #`(let ([value #,(attribute-mapping-var self)]) + (if (check-syntax '#,(attribute-mapping-depth self) value) + value + (raise-syntax-error #f + "attribute is bound to non-syntax value" + (quote-syntax + #,(datum->syntax + stx + (attribute-mapping-name self) + stx))))))))) + +;; check-syntax : nat any -> boolean +;; Returns #t if value is a (listof^depth syntax) +(define (check-syntax depth value) + (if (zero? depth) + (syntax? value) + (and (list? value) + (for/and ([part value]) + (check-syntax (sub1 depth) part))))) + +(define-syntax (let-attributes stx) + (define (parse-attr x) + (syntax-case x () + [#s(attr name depth syntax?) #'(name depth syntax?)])) + (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))))])) + +(define-syntax (attribute stx) + (parameterize ((current-syntax-context stx)) + (syntax-case stx () + [(attribute name) + (identifier? #'name) + (let ([mapping (syntax-local-value #'name (lambda () #f))]) + (unless (syntax-pattern-variable? mapping) + (wrong-syntax #'name "not bound as a pattern variable")) + (let ([var (syntax-mapping-valvar mapping)]) + (let ([attr (syntax-local-value var (lambda () #f))]) + (unless (attribute-mapping? attr) + (wrong-syntax #'name "not bound as an attribute")) + (syntax-property (attribute-mapping-var attr) + 'disappeared-use + #'name))))]))) + +;; (let/unpack (([id num] ...) expr) expr) : expr +(define-syntax (let/unpack stx) + (syntax-case stx () + [(let/unpack ((a ...) packed) body) + (with-syntax ([(tmp ...) (generate-temporaries #'(a ...))]) + #'(let-values ([(tmp ...) (apply values packed)]) + (let-attributes ([a tmp] ...) body)))])) + +;; (attribute-binding id) +;; mostly for debugging/testing +(define-syntax (attribute-binding stx) + (syntax-case stx () + [(attribute-bound? name) + (identifier? #'name) + (let ([value (syntax-local-value #'name (lambda () #f))]) + (if (syntax-pattern-variable? value) + (let ([value (syntax-local-value (syntax-mapping-valvar value) (lambda () #f))]) + (if (attribute-mapping? value) + #`(quote #,(make-attr (attribute-mapping-name value) + (attribute-mapping-depth value) + (attribute-mapping-syntax? value))) + #'(quote #f))) + #'(quote #f)))])) + +;; (check-list^depth attr expr) +(define-syntax (check-list^depth stx) + (syntax-case stx () + [(_ a expr) + (with-syntax ([#s(attr name depth syntax?) #'a]) + (quasisyntax/loc #'expr + (check-list^depth* 'name 'depth expr)))])) + +(define (check-list^depth* aname n0 v0) + (define (loop n v) + (when (positive? n) + (unless (list? v) + (raise-type-error aname (format "lists nested ~s deep" n0) v)) + (for ([x v]) (loop (sub1 n) x)))) + (loop n0 v0) + v0) diff --git a/collects/syntax/private/stxparse/sc.ss b/collects/syntax/private/stxparse/sc.ss new file mode 100644 index 0000000000..70e1f4f9a3 --- /dev/null +++ b/collects/syntax/private/stxparse/sc.ss @@ -0,0 +1,213 @@ +#lang scheme/base +(require (for-syntax scheme/base + scheme/match + scheme/private/sc + "rep-data.ss" + "rep.ss" + "../util.ss") + scheme/match + syntax/stx + "parse.ss" + "runtime.ss" + "runtime-prose.ss") + +(provide define-syntax-class + define-splicing-syntax-class + + define-literal-set + define-conventions + syntax-class-parse + syntax-class-attributes + + debug-rhs + debug-pattern + + syntax-parse + syntax-parser + + pattern + ~and + ~or + ~seq + ~bounds + ~once + ~optional + ~rest + ~struct + ~! + ~describe + ~bind + ~fail + + attribute + this-syntax) + +(begin-for-syntax + (define (defstxclass stx name args rhss splicing?) + (with-syntax ([name name] + [(arg ...) args] + [rhss rhss]) + (let ([the-rhs + (parameterize ((current-syntax-context stx)) + (parse-rhs #'rhss #t splicing? stx))]) + (with-syntax ([parser (generate-temporary + (format-symbol "parse-~a" (syntax-e #'name)))] + [attrs (rhs-attrs the-rhs)]) + #`(begin (define-syntax name + (make stxclass 'name '(arg ...) + 'attrs + ((syntax-local-certifier) (quote-syntax parser)) + ((syntax-local-certifier) (quote-syntax description)) + '#,splicing?)) + (define-values (parser description) + (functions/rhs name (arg ...) attrs rhss #,splicing? #,stx)))))))) + +(define-syntax (define-syntax-class stx) + (syntax-case stx () + [(define-syntax-class name . rhss) + (identifier? #'name) + (defstxclass stx #'name #'() #'rhss #f)] + [(define-syntax-class (name arg ...) . rhss) + (andmap identifier? (syntax->list #'(name arg ...))) + (defstxclass stx #'name #'(arg ...) #'rhss #f)])) + +(define-syntax (define-splicing-syntax-class stx) + (syntax-case stx () + [(define-splicing-syntax-class name . rhss) + (identifier? #'name) + (defstxclass stx #'name #'() #'rhss #t)] + [(define-splicing-syntax-class (name arg ...) . rhss) + (andmap identifier? #'(name arg ...)) + (defstxclass stx #'name #'(arg ...) #'rhss #t)])) + +(define-syntax (define-conventions stx) + (syntax-case stx () + [(define-conventions name rule ...) + (begin + (unless (identifier? #'name) + (raise-syntax-error #f "expected identifier" stx #'name)) + (with-syntax ([([entry (def ...)] ...) + (for/list ([line (check-conventions-rules #'(rule ...))]) + (let ([rx (car line)] + [sc (car (cadr line))] + [args (cadr (cadr line))]) + (let-values ([(parser description attrs defs) + (create-aux-def (list 'stxclass rx sc args))]) + (list #`(list (quote #,rx) + (list 'parser + (quote-syntax #,parser) + (quote-syntax #,description) + (quote #,attrs))) + defs))))]) + #'(begin + def ... ... + (define-syntax name + (make-conventions + (list entry ...))))))])) + +(define-syntax (define-literal-set stx) + (syntax-case stx () + [(define-literal-set name (lit ...)) + (begin + (unless (identifier? #'name) + (raise-syntax-error #f "expected identifier" stx #'name)) + (let ([lits (check-literals-list #'(lit ...))]) + (with-syntax ([((internal external) ...) lits]) + #'(define-syntax name + (make-literalset + (list (list 'internal (quote-syntax external)) ...))))))])) + +;; ---- + +(define-syntax (functions/rhs stx) + (syntax-case stx () + [(functions/S-rhs name args attrs rhss splicing? ctx) + (with-disappeared-uses + (let ([rhs + (parameterize ((current-syntax-context #'ctx)) + (parse-rhs #'rhss #f (syntax-e #'splicing?) #'ctx))]) + #`(let ([get-description + (lambda args + #,(or (rhs-description rhs) + #'(symbol->string 'name)))]) + (values (parse:rhs #,rhs + attrs + args + get-description + splicing?) + get-description))))])) + +(define-syntax (syntax-class-parse stx) + (syntax-case stx () + [(_ s x arg ...) + (parameterize ((current-syntax-context stx)) + (let* ([arg-count (length (syntax->list #'(arg ...)))] + [stxclass (get-stxclass/check-arg-count #'s arg-count)] + [attrs (stxclass-attrs stxclass)]) + (with-syntax ([parser (stxclass-parser-name stxclass)] + [(name ...) (map attr-name attrs)] + [(depth ...) (map attr-depth attrs)]) + #'(let ([raw (parser x arg ...)]) + (if (ok? raw) + (map vector '(name ...) '(depth ...) raw) + raw)))))])) + +(define-syntax (syntax-class-attributes stx) + (syntax-case stx () + [(_ s) + (parameterize ((current-syntax-context stx)) + (let ([attrs (stxclass-attrs (get-stxclass #'s))]) + (with-syntax ([(a ...) (map attr-name attrs)] + [(depth ...) (map attr-depth attrs)]) + #'(quote ((a depth) ...)))))])) + +(define-syntax (debug-rhs stx) + (syntax-case stx () + [(debug-rhs rhs) + (let ([rhs (parse-rhs #'rhs #f stx)]) + #`(quote #,rhs))])) + +(define-syntax (debug-pattern stx) + (syntax-case stx () + [(debug-pattern p) + (let ([p (parse-whole-pattern #'p (new-declenv null))]) + #`(quote #,p))])) + +(define-syntax-rule (syntax-parse stx-expr . clauses) + (let ([x stx-expr]) + (syntax-parse* syntax-parse x . clauses))) + +(define-syntax-rule (syntax-parser . clauses) + (lambda (x) (syntax-parse* syntax-parser x . clauses))) + +(define-syntax (syntax-parse* stx) + (syntax-case stx () + [(syntax-parse report-as expr . clauses) + (with-disappeared-uses + (parameterize ((current-syntax-context + (syntax-property stx + 'report-errors-as + (syntax-e #'report-as)))) + #`(let ([x expr]) + (let ([fail (syntax-patterns-fail x)]) + (with-enclosing-fail* fail + (parameterize ((current-expression (or (current-expression) x))) + (parse:clauses x clauses)))))))])) + +(define-syntax with-patterns + (syntax-rules () + [(with-patterns () . b) + (let () . b)] + [(with-patterns ([p x] . more) . b) + (syntax-parse x [p (with-patterns more . b)])])) + +;; Failure reporting parameter & default + +(define current-failure-handler + (make-parameter default-failure-handler)) + +(define ((syntax-patterns-fail stx0) f) + (let ([value ((current-failure-handler) stx0 f)]) + (error 'current-failure-handler + "current-failure-handler: did not escape, produced ~e" value))) + diff --git a/collects/syntax/private/util.ss b/collects/syntax/private/util.ss new file mode 100644 index 0000000000..6dd0a3e5ba --- /dev/null +++ b/collects/syntax/private/util.ss @@ -0,0 +1,9 @@ +#lang scheme/base +(require "util/error.ss" + "util/expand.ss" + "util/misc.ss" + "util/struct.ss") +(provide (all-from-out "util/error.ss") + (all-from-out "util/expand.ss") + (all-from-out "util/misc.ss") + (all-from-out "util/struct.ss")) diff --git a/collects/syntax/private/util/error.ss b/collects/syntax/private/util/error.ss new file mode 100644 index 0000000000..56f7c2dba5 --- /dev/null +++ b/collects/syntax/private/util/error.ss @@ -0,0 +1,16 @@ +#lang scheme/base +(provide wrong-syntax + current-syntax-context) + +(define current-syntax-context (make-parameter #f)) + +(define (wrong-syntax stx #:extra [extras null] format-string . args) + (unless (or (eq? stx #f) (syntax? stx)) + (raise-type-error 'wrong-syntax "syntax or #f" 0 (list* stx format-string args))) + (let* ([ctx (current-syntax-context)] + [blame (and (syntax? ctx) (syntax-property ctx 'report-errors-as))]) + (raise-syntax-error (if (symbol? blame) blame #f) + (apply format format-string args) + ctx + (or stx ctx) + extras))) diff --git a/collects/syntax/private/util/expand.ss b/collects/syntax/private/util/expand.ss new file mode 100644 index 0000000000..5e8a6b99ca --- /dev/null +++ b/collects/syntax/private/util/expand.ss @@ -0,0 +1,88 @@ +#lang scheme/base +(require syntax/kerncase + syntax/stx) +(provide head-local-expand-and-categorize-syntaxes + categorize-expanded-syntaxes + head-local-expand-syntaxes) + +;; head-local-expand-syntaxes : syntax boolean boolean -> stxs ^ 6 +;; Setting allow-def-after-expr? allows def/expr interleaving. +(define (head-local-expand-and-categorize-syntaxes x allow-def-after-expr?) + (define estxs (head-local-expand-syntaxes x allow-def-after-expr?)) + (define-values (defs vdefs sdefs exprs) + (categorize-expanded-syntaxes estxs)) + (values estxs estxs defs vdefs sdefs exprs)) + +;; categorize-expanded-syntaxes : (listof stx) -> stxs ^ 4 +;; Split head-expanded stxs into +;; definitions, values-definitions, syntaxes-definitions, exprs +;; (definitions include both values-definitions and syntaxes-definitions.) +(define (categorize-expanded-syntaxes estxs0) + (let loop ([estxs estxs0] [defs null] [vdefs null] [sdefs null] [exprs null]) + (cond [(pair? estxs) + (let ([ee (car estxs)]) + (syntax-case ee (begin define-values define-syntaxes) + [(define-values . _) + (loop (cdr estxs) + (cons ee defs) + (cons ee vdefs) + sdefs + exprs)] + [(define-syntaxes (var ...) rhs) + (loop (cdr estxs) + (cons ee defs) + vdefs + (cons ee sdefs) + exprs)] + [_ + (loop (cdr estxs) + defs + vdefs + sdefs + (cons ee exprs))]))] + [(null? estxs) + (values (reverse defs) + (reverse vdefs) + (reverse sdefs) + (reverse exprs))]))) + +;; head-local-expand-syntaxes : syntax boolean -> (listof syntax) +(define (head-local-expand-syntaxes x allow-def-after-expr?) + (let ([intdef (syntax-local-make-definition-context)] + [ctx '(block)]) + (let loop ([x x] [ex null] [expr? #f]) + (cond [(stx-pair? x) + (let ([ee (local-expand (stx-car x) + ctx + (kernel-form-identifier-list) + intdef)]) + (syntax-case ee (begin define-values define-syntaxes) + [(begin e ...) + (loop (append (syntax->list #'(e ...)) (stx-cdr x)) ex expr?)] + [(begin . _) + (raise-syntax-error #f "bad begin form" ee)] + [(define-values (var ...) rhs) + (andmap identifier? (syntax->list #'(var ...))) + (begin + (when (and expr? (not allow-def-after-expr?)) + (raise-syntax-error #f "definition after expression" ee)) + (syntax-local-bind-syntaxes (syntax->list #'(var ...)) #f intdef) + (loop (stx-cdr x) (cons ee ex) expr?))] + [(define-values . _) + (raise-syntax-error #f "bad define-values form" ee)] + [(define-syntaxes (var ...) rhs) + (andmap identifier? (syntax->list #'(var ...))) + (begin + (when (and expr? (not allow-def-after-expr?)) + (raise-syntax-error #f "definition after expression" ee)) + (syntax-local-bind-syntaxes (syntax->list #'(var ...)) + #'rhs + intdef) + (loop (stx-cdr x) (cons ee ex) expr?))] + [(define-syntaxes . _) + (raise-syntax-error #f "bad define-syntaxes form" ee)] + [_ + (loop (stx-cdr x) (cons ee ex) #t)]))] + [(stx-null? x) + (internal-definition-context-seal intdef) + (reverse ex)])))) diff --git a/collects/syntax/private/util/misc.ss b/collects/syntax/private/util/misc.ss new file mode 100644 index 0000000000..f7da0ece40 --- /dev/null +++ b/collects/syntax/private/util/misc.ss @@ -0,0 +1,239 @@ +#lang scheme/base +(require syntax/kerncase + syntax/stx + (for-syntax scheme/base + scheme/private/sc)) + +(provide unwrap-syntax + + define-pattern-variable + + with-temporaries + generate-temporary + generate-n-temporaries + + current-caught-disappeared-uses + with-catching-disappeared-uses + with-disappeared-uses + syntax-local-value/catch + record-disappeared-uses + + format-symbol + + in-stx-list + in-stx-list/unwrap + + parse-kw-options + extract-kw-option + chunk-kw-seq/no-dups + chunk-kw-seq/no-dups/eol + chunk-kw-seq + reject-duplicate-chunks + check-id + check-nat/f + check-string + check-idlist) + +;; Unwrapping syntax + +;; unwrap-syntax : any #:stop-at (any -> boolean) -> any +(define (unwrap-syntax stx #:stop-at [stop-at (lambda (x) #f)]) + (let loop ([x stx]) + (cond [(stop-at x) x] + [(syntax? x) (loop (syntax-e x))] + [(pair? x) (cons (loop (car x)) (loop (cdr x)))] + [(vector? x) (apply vector-immutable (loop (vector->list x)))] + [(box? x) (box-immutable (loop (unbox x)))] + [(prefab-struct-key x) + => (lambda (key) + (apply make-prefab-struct key + (loop (cdr (vector->list (struct->vector x))))))] + [else x]))) + +;; Defining pattern variables + +(define-syntax-rule (define-pattern-variable name expr) + (begin (define var expr) + (define-syntax name (make-syntax-mapping '0 (quote-syntax var))))) + +;; Statics and disappeared uses + +(define current-caught-disappeared-uses (make-parameter #f)) + +(define-syntax-rule (with-catching-disappeared-uses . body) + (parameterize ((current-caught-disappeared-uses null)) + (let ([result (let () . body)]) + (values result (current-caught-disappeared-uses))))) + +(define-syntax-rule (with-disappeared-uses stx-expr) + (let-values ([(stx disappeared-uses) + (with-catching-disappeared-uses stx-expr)]) + (syntax-property stx + 'disappeared-use + (append (or (syntax-property stx 'disappeared-use) null) + disappeared-uses)))) + +(define (syntax-local-value/catch id pred) + (let ([value (syntax-local-value id (lambda () #f))]) + (and (pred value) + (begin (record-disappeared-uses (list id)) + value)))) + +(define (record-disappeared-uses ids) + (let ([uses (current-caught-disappeared-uses)]) + (when uses + (current-caught-disappeared-uses (append ids uses))))) + +;; Generating temporaries + +;; with-temporaries +(define-syntax-rule (with-temporaries (temp-name ...) . body) + (with-syntax ([(temp-name ...) (generate-temporaries (quote-syntax (temp-name ...)))]) + . body)) + +;; generate-temporary : any -> identifier +(define (generate-temporary [stx 'g]) + (car (generate-temporaries (list stx)))) + +;; generate-n-temporaries : exact-nonnegative-integer -> (listof identifier) +(define (generate-n-temporaries n) + (generate-temporaries + (for/list ([i (in-range n)]) + (string->symbol (format "g~sx" i))))) + +;; Symbol Formatting + +(define (format-symbol fmt . args) + (let ([args (for/list ([arg args]) (if (syntax? arg) (syntax->datum arg) arg))]) + (string->symbol (apply format fmt args)))) + +;; Syntax list sequence + +(define (in-stx-list x) + (let ([l (stx->list x)]) + (unless l + (raise-type-error 'in-stx-list "syntax list" x)) + (in-list l))) + +(define (in-stx-list/unwrap x) + (let ([l (stx->list x)]) + (unless l + (raise-type-error 'in-stx-list "syntax list" x)) + (in-list (map syntax-e l)))) + +;; Parsing keyword arguments + +;; parse-kw-options : ... +(define (parse-kw-options stx table extractions #:context [ctx #f]) + (let ([chunks (chunk-kw-seq/no-dups/eol stx table #:context ctx)]) + (for/list ([ex extractions]) + (extract-kw-option chunks ex)))) + +;; extract-kw-option : ... +(define (extract-kw-option chunks ex) + (let ([entry (assq (car ex) chunks)]) + (if entry + (cddr entry) + (cdr ex)))) + +;; chunk-kw-seq/no-dups/eol : ... +(define (chunk-kw-seq/no-dups/eol stx kws #:context [ctx #f] #:only [only #f]) + (let-values ([(chunks rest) (chunk-kw-seq/no-dups stx kws #:context ctx #:only only)]) + (unless (stx-null? rest) + (raise-syntax-error #f "unexpected terms after keyword arguments" ctx stx)) + chunks)) + +;; chunk-kw-seq/no-dups : syntax +;; alist[keyword => (listof (stx -> any))] +;; -> (values (listof (cons kw (cons stx(kw) (listof any)))) stx) +(define (chunk-kw-seq/no-dups stx kws #:context [ctx #f] #:only [only #f]) + (let-values ([(chunks rest) (chunk-kw-seq stx kws #:context ctx)]) + (reject-duplicate-chunks chunks #:context ctx #:only only) + (values chunks rest))) + +;; chunk-kw-seq : stx +;; alist[keyword => (listof (stx -> any)) +;; -> (values (listof (cons kw (cons stx(kw) (listof any)))) stx) +(define (chunk-kw-seq stx kws #:context [ctx #f]) + (define (loop stx rchunks) + (syntax-case stx () + [(kw . more) + (and (keyword? (syntax-e #'kw)) (assq (syntax-e #'kw) kws)) + (let* ([kw-value (syntax-e #'kw)] + [arity (cdr (assq kw-value kws))] + [args+rest (stx-split #'more arity)]) + (if args+rest + (loop (cdr args+rest) + (cons (list* kw-value #'kw (car args+rest)) rchunks)) + (raise-syntax-error #f "too few arguments for keyword" #'kw ctx)))] + [(kw . more) + (keyword? (syntax-e #'kw)) + (raise-syntax-error #f + (format "unexpected keyword, expected one of ~s" (map car kws)) + ctx + #'kw)] + [_ + (values (reverse rchunks) stx)])) + (loop stx null)) + +;; reject-duplicate-chunks : (listof (cons kw (cons stx(kw) (listof any)))) -> void +(define (reject-duplicate-chunks chunks + #:context [ctx #f] + #:only [only #f]) + (define kws (make-hasheq)) + (define (loop chunks) + (when (pair? chunks) + (let ([kw (caar chunks)]) + (when (or (not only) (memq kw only)) + (when (hash-ref kws kw #f) + (raise-syntax-error #f "duplicate keyword argument" (cadar chunks) ctx)) + (hash-set! kws kw #t))) + (loop (cdr chunks)))) + (loop chunks)) + +;; alist-select : (listof (cons A B)) A -> (listof B) +(define (alist-select alist key) + (cond [(pair? alist) + (if (eq? (caar alist) key) + (cons (cdar alist) (alist-select (cdr alist) key)) + (alist-select (cdr alist) key))] + [else null])) + +;; stx-split : stx nat -> (cons (listof stx) stx) +(define (stx-split stx procs) + (define (loop stx procs acc) + (cond [(null? procs) + (cons (reverse acc) stx)] + [(stx-pair? stx) + (loop (stx-cdr stx) (cdr procs) (cons ((car procs) (stx-car stx)) acc))] + [else #f])) + (loop stx procs null)) + +;; check-id : stx -> identifier +(define (check-id stx) + (unless (identifier? stx) + (raise-syntax-error 'pattern "expected identifier" stx)) + stx) + +;; check-string : stx -> stx +(define (check-string stx) + (unless (string? (syntax-e stx)) + (raise-syntax-error #f "expected string" stx)) + stx) + +;; nat/f : any -> boolean +(define (nat/f x) + (or (not x) (exact-nonnegative-integer? x))) + +;; check-nat/f : stx -> stx +(define (check-nat/f stx) + (let ([d (syntax-e stx)]) + (unless (nat/f d) + (raise-syntax-error #f "expected exact nonnegative integer or #f" stx)) + stx)) + +;; check-idlist : stx -> (listof identifier) +(define (check-idlist stx) + (unless (and (stx-list? stx) (andmap identifier? (stx->list stx))) + (raise-syntax-error #f "expected list of identifiers" stx)) + (stx->list stx)) diff --git a/collects/syntax/private/util/struct.ss b/collects/syntax/private/util/struct.ss new file mode 100644 index 0000000000..e28d31b7ae --- /dev/null +++ b/collects/syntax/private/util/struct.ss @@ -0,0 +1,39 @@ +#lang scheme/base +(require (for-syntax scheme/base + scheme/struct-info)) + +(provide make) + +;; (make struct-name field-expr ...) +;; Checks that correct number of fields given. +(define-syntax (make stx) + (define (bad-struct-name x) + (raise-syntax-error #f "expected struct name" stx x)) + (define (get-struct-info id) + (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))) + (syntax-case stx () + [(make S expr ...) + (let () + (define info (get-struct-info #'S)) + (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)" + (syntax-e #'S) + num-slots) + stx))) + (with-syntax ([constructor constructor]) + #'(constructor expr ...)))])) diff --git a/collects/syntax/scribblings/boundmap.scrbl b/collects/syntax/scribblings/boundmap.scrbl index 0c685de99b..2edc334be1 100644 --- a/collects/syntax/scribblings/boundmap.scrbl +++ b/collects/syntax/scribblings/boundmap.scrbl @@ -4,6 +4,10 @@ @title[#:tag "boundmap"]{Hashing on @scheme[bound-identifier=?] and @scheme[free-identifier=?]} +See also @schememodname[syntax/id-table] for an implementation of +identifier mappings using the @schememodname[scheme/dict] dictionary +interface. + @defmodule[syntax/boundmap] @defproc[(make-bound-identifier-mapping) bound-identifier-mapping?]{ @@ -120,4 +124,4 @@ Like @scheme[hash-table-map].} (listof any?)] )]{ -The same as @scheme[make-module-identifier-mapping], etc.} +The same as @scheme[make-free-identifier-mapping], etc.} diff --git a/collects/syntax/scribblings/id-table.scrbl b/collects/syntax/scribblings/id-table.scrbl new file mode 100644 index 0000000000..81221d5b4f --- /dev/null +++ b/collects/syntax/scribblings/id-table.scrbl @@ -0,0 +1,202 @@ +#lang scribble/doc +@(require "common.ss" + (for-label syntax/id-table) + (for-label scheme/dict)) + +@title[#:tag "idtable"]{Identifier dictionaries} + +@defmodule[syntax/id-table] + +This module provides functionality like that of +@schememodname[syntax/boundmap] but with more operations, standard +names, implementation of the @schememodname[scheme/dict] interface, +and immutable (functionally-updating) variants. + +@section{Dictionaries for @scheme[bound-identifier=?]} + +Bound-identifier tables implement the dictionary interface of +@scheme[scheme/dict]. Consequently, all of the appropriate generic +functions (@scheme[dict-ref], @scheme[dict-map], etc) can be used on +free-identifier tables. + +@deftogether[[ +@defproc[(make-bound-id-table [init-dict dict? null]) + mutable-bound-id-table?] +@defproc[(make-immutable-bound-id-table [init-dict dict? null]) + immutable-bound-id-table?]]]{ + +Produces a dictionary mapping syntax identifiers to arbitrary +values. The mapping uses @scheme[bound-identifier=?] to compare keys, +but also uses a hash table based on symbol equality to make the +mapping efficient in the common case. The two procedures produce +mutable and immutable dictionaries, respectively. + +The optional @scheme[init-dict] argument provides the initial +mappings. It must be a dictionary, and its keys must all be +identifiers. If the @scheme[init-dict] dictionary has multiple +distinct entries whose keys are @scheme[bound-identifier=?], only one +of the entries appears in the new id-table, and it is not specified +which entry is picked. +} + +@defproc[(bound-id-table? [v any/c]) boolean?]{ + +Returns @scheme[#t] if @scheme[v] was produced by +@scheme[make-bound-id-table] or +@scheme[make-immutable-bound-id-table], @scheme[#f] otherwise. +} + +@deftogether[[ +@defproc[(mutable-bound-id-table? [v any/c]) boolean?] +@defproc[(immutable-bound-id-table? [v any/c]) boolean?] +]]{ + +Predicate for the mutable and immutable variants of bound-identifier +tables, respectively. +} + +@defproc[(bound-id-table-ref [table bound-id-table?] + [id identifier?] + [failure any/c + (lambda () (raise (make-exn:fail .....)))]) + any]{ + +Like @scheme[hash-ref] for bound identifier tables. In particular, if +@scheme[id] is not found, the @scheme[failure] argument is applied if +it is a procedure, or simply returned otherwise. +} + +@defproc[(bound-id-table-set! [table mutable-bound-id-table?] + [id identifier?] + [v any/c]) + void?]{ + +Like @scheme[hash-set!] for mutable bound-identifier tables. +} + +@defproc[(bound-id-table-set [table immutable-bound-id-table?] + [id identifier?] + [v any/c]) + immutable-bound-id-table?]{ + +Like @scheme[hash-set] for immutable bound-identifier tables. +} + +@defproc[(bound-id-table-remove! [table mutable-bound-id-table?] + [id identifier?]) + void?]{ + +Like @scheme[hash-remove!] for mutable bound-identifier tables. +} + +@defproc[(bound-id-table-remove [table immutable-bound-id-table?] + [id identifier?] + [v any/c]) + immutable-bound-id-table?]{ + +Like @scheme[hash-remove] for immutable bound-identifier tables. +} + +@defproc[(bound-id-table-map [table bound-id-table?] + [proc (-> identifier? any/c any)]) + list?]{ + +Like @scheme[hash-map] for bound-identifier tables. +} + +@defproc[(bound-id-table-for-each [table bound-id-table?] + [proc (-> identifier? any/c any)]) + void?]{ + +Like @scheme[hash-for-each] for bound-identifier tables. +} + +@defproc[(bound-id-table-count [table bound-id-table?]) + exact-nonnegative-integer?]{ + +Like @scheme[hash-count] for bound-identifier tables. + +} + +@;{ +@deftogether[[ +@defproc[(bound-id-table-iterate-first [table bound-id-table?]) + id-table-position?] +@defproc[(bound-id-table-iterate-next [table bound-id-table?] + [position id-table-position?]) + id-table-position?] +@defproc[(bound-id-table-iterate-key [table bound-id-table?] + [position id-table-position?]) + identifier?] +@defproc[(bound-id-table-iterate-value [table bound-it-table?] + [position id-table-position?]) + identifier?]]]{ + +Like the corresponding dictionary procedures from +@schememodname[scheme/dict] for for bound-identifier tables. +} +} + +@;{----------} +@section{Dictionaries for @scheme[free-identifier=?]} + +Free-identifier tables implement the dictionary interface of +@scheme[scheme/dict]. Consequently, all of the appropriate generic +functions (@scheme[dict-ref], @scheme[dict-map], etc) can be used on +free-identifier tables. + +@deftogether[[ +@defproc[(make-free-id-table [init-dict dict? null]) + mutable-free-id-table?] +@defproc[(make-immutable-free-id-table [init-dict dict? null]) + immutable-free-id-table?] +@defproc[(free-id-table? [v any/c]) boolean?] +@defproc[(mutable-free-id-table? [v any/c]) boolean?] +@defproc[(immutable-free-id-table? [v any/c]) boolean?] +@defproc[(free-id-table-ref [table free-id-table?] + [id identifier?] + [failure any/c + (lambda () (raise (make-exn:fail .....)))]) + any] +@defproc[(free-id-table-set! [table mutable-free-id-table?] + [id identifier?] + [v any/c]) + void?] +@defproc[(free-id-table-set [table immutable-free-id-table?] + [id identifier?] + [v any/c]) + immutable-free-id-table?] +@defproc[(free-id-table-remove! [table mutable-free-id-table?] + [id identifier?]) + void?] +@defproc[(free-id-table-remove [table immutable-free-id-table?] + [id identifier?] + [v any/c]) + immutable-free-id-table?] +@defproc[(free-id-table-map [table free-id-table?] + [proc (-> identifier? any/c any)]) + list?] +@defproc[(free-id-table-for-each [table free-id-table?] + [proc (-> identifier? any/c any)]) + void?] +@defproc[(free-id-table-count [table free-id-table?]) + exact-nonnegative-integer?] +@;{ +@defproc[(free-id-table-iterate-first [table free-id-table?]) + id-table-position?] +@defproc[(free-id-table-iterate-next [table free-id-table?] + [position id-table-position?]) + id-table-position?] +@defproc[(free-id-table-iterate-key [table free-id-table?] + [position id-table-position?]) + identifier?] +@defproc[(free-id-table-iterate-value [table free-it-table?] + [position id-table-position?]) + identifier?] +}]]{ + +Like the procedures for bound-identifier tables +(@scheme[make-bound-id-table], @scheme[bound-id-table-ref], etc), but +for free-identifier tables, which use @scheme[free-identifier=?] to +compare keys. +} diff --git a/collects/syntax/scribblings/parse.scrbl b/collects/syntax/scribblings/parse.scrbl new file mode 100644 index 0000000000..e962c63e38 --- /dev/null +++ b/collects/syntax/scribblings/parse.scrbl @@ -0,0 +1,926 @@ +#lang scribble/doc +@(require scribble/manual + scribble/struct + scribble/decode + scribble/eval + scheme/sandbox + (for-label scheme/base + scheme/contract + syntax/parse + syntax/kerncase)) + +@(define ellipses @scheme[...]) + +@(begin + (define the-eval + (parameterize ((sandbox-output 'string) + (sandbox-error-output 'string)) + (make-evaluator 'scheme/base #:requires '(syntax/parse)))) + (define-syntax-rule (myexamples e ...) + (parameterize ((error-print-source-location #f)) + (examples #:eval the-eval e ...)))) + +@title[#:tag "stxparse"]{Parsing and classifying syntax} + +The @schememodname[syntax/parse] library provides a framework for +describing and parsing syntax. Using @schememodname[syntax/parse], +macro writers can define new syntactic categories, specify their legal +syntax, and use them to write clear, concise, and robust macros. The +library also provides a pattern-matching form, @scheme[syntax-parse], +which offers many improvements over @scheme[syntax-case]. + +@defmodule[syntax/parse] + +@;{----------} + +@section{Parsing syntax} + +This section describes the @scheme[syntax-parse] pattern matching +form, syntax patterns, and attributes. + +@defform/subs[(syntax-parse stx-expr parse-option ... clause ...+) + ([parse-option (code:line #:literals (literal ...)) + (code:line #:literal-sets (literal-set ...)) + (code:line #:conventions (convention-id ...))] + [literal literal-id + (pattern-id literal-id)] + [literal-set literal-set-id + [literal-set-id #:at context-id]] + [clause (syntax-pattern pattern-directive ... expr)])]{ + +Evaluates @scheme[stx-expr], which should produce a syntax object, and +matches it against the @scheme[clause]s in order. If some clause's +pattern matches, its attributes are bound to the corresponding +subterms of the syntax object and that clause's side conditions and +@scheme[expr] is evaluated. The result is the result of @scheme[expr]. + +If the syntax object fails to match any of the patterns (or all +matches fail the corresponding clauses' side conditions), a syntax +error is raised. + +The @scheme[#:literals] option specifies identifiers that should match +as literals, rather than simply being pattern variables. A literal in +the literals list has two components: the identifier used within the +pattern to signify the positions to be matched (@scheme[pattern-id]), +and the identifier expected to occur in those positions +(@scheme[literal-id]). If the single-identifier form is used, the same +identifier is used for both purposes. + +Many literals can be declared at once via one or more @tech{literal sets}, +imported with the @scheme[#:literal-sets] option. The literal-set +definition determines the literal identifiers to recognize and the +names used in the patterns to recognize those literals. + +The @scheme[#:conventions] option imports @tech{convention}s that give +default syntax classes to pattern variables that do not explicitly +specify a syntax class. +} + +@defform[(syntax-parser maybe-literals clause ...)]{ + +Like @scheme[syntax-parse], but produces a matching procedure. The +procedure accepts a single argument, which should be a syntax object. + +} + +The grammar of @deftech{syntax patterns} accepted by +@scheme[syntax-parse] and @scheme[syntax-parser] is given in the +following table: + +@schemegrammar*[#:literals (_ ~or ~and ~seq ~rep ~once ~optional + ~rest ~struct ~! ~describe ~bind ~fail) + [S-pattern + pvar-id + pvar-id:syntax-class-id + literal-id + atomic-datum + (H-pattern . S-pattern) + ((~or EH-pattern ...+) #,ellipses . S-pattern) + (EH-pattern #,ellipses . S-pattern) + (~and S-pattern ...+) + (~or S-pattern ...+) + #((unsyntax @svar[pattern-part]) ...) + #s(prefab-struct-key (unsyntax @svar[pattern-part]) ...) + (~rest S-pattern) + (~describe expr S-pattern) + (~! . S-pattern) + (~bind [attr-id expr] ...) + (~fail maybe-fail-condition message-expr)] + [L-pattern + () + (H-pattern . L-pattern) + ((~or EH-pattern ...+) #,ellipses . L-pattern) + (EH-pattern #,ellipses . L-pattern) + (~rest L-pattern) + (~! . L-pattern)] + [H-pattern + (~or H-pattern ...+) + (~seq . L-pattern) + (~describe expr H-pattern) + S-pattern] + [EH-pattern + (~once H-pattern once-option ...) + (~optional H-pattern optional-option ...) + H-pattern]] + +There are three main kinds of syntax pattern: @tech{S-patterns} (for +``single patterns''), @tech{H-patterns} (for ``head patterns''), and +@tech{EH-patterns} (for ``ellipsis head patterns''). A fourth kind, +@tech{L-patterns} (for ``list patterns''), is a restricted subset of +@tech{S-patterns}. When a special form in this manual refers to +@svar[syntax-pattern] (eg, the description of the +@scheme[syntax-parse] special form), it means specifically +@tech{S-pattern}. + +@subsection{S-pattern variants} + +An @deftech{S-pattern} (for ``single pattern'') is a pattern that +describes a single term. The pattern may, of course, consist of other +parts. For example, @scheme[(17 ...)] is an @tech{S-pattern} +that matches any term that is a proper list of repeated +@schemeresult[17] numerals. The @deftech{L-pattern}s (for ``list +pattern'') are @tech{S-pattern} having a restricted structure that +constrains it to match only terms that are proper lists. + +Here are the variants of @tech{S-pattern}: + +@specsubform[pvar-id]{ + +If @scheme[pvar-id] has no syntax class (by @scheme[#:declare] or +@scheme[#:convention]), the pattern matches anything. The pattern +variable is bound to the matched subterm, unless the pattern variable +is the wildcard (@scheme[_]), in which case no binding occurs. + +If @scheme[pvar-id] does have an associated syntax class, it behaves +like the following form. +} + +@specsubform[pvar-id:syntax-class-id]{ + +Matches only subterms specified by the @svar[syntax-class-id]. The +syntax class's attributes are computed for the subterm and bound to +the pattern variables formed by prefixing @svar[pvar-id.] to the +name of the attribute. @svar[pvar-id] is bound to the matched +subterm. + +If @svar[pvar-id] is @scheme[_], no attributes are bound. + +If @svar[pvar-id] is empty (that is, if the pattern is of the form +@svar[:syntax-class-id]), then the syntax class's attributes are +bound, but their names are not prefixed first. + +@myexamples[ +(syntax-parse #'x + [var:id (syntax-e #'var)]) +(syntax-parse #'12 + [var:id (syntax-e #'var)]) +(syntax-parse #'(x y z) + [var:id (syntax-e #'var)])] +} + +@specsubform[literal-id]{ + +An identifier that appears in the literals list is not a pattern +variable; instead, it is a literal that matches any identifier +@scheme[free-identifier=?] to it. + +Specifically, if @scheme[literal-id] is the ``pattern'' name of an +entry in the literals list, then it represents a pattern that matches +only identifiers @scheme[free-identifier=?] to the ``literal'' +name. These identifiers are often the same. + +@myexamples[ +(syntax-parse #'(define x 12) + #:literals (define) + [(define var:id body:expr) 'ok]) +(syntax-parse #'(lambda x 12) + #:literals (define) + [(define var:id body:expr) 'ok]) +(syntax-parse #'(define x 12) + #:literals ([def define]) + [(def var:id body:expr) 'ok]) +(syntax-parse #'(lambda x 12) + #:literals ([def define]) + [(def var:id body:expr) 'ok]) +] +} + +@specsubform[atomic-datum]{ + +Numbers, strings, booleans, keywords, and the empty list match as +literals. + +@myexamples[ +(syntax-parse #'(a #:foo bar) + [(x #:foo y) (syntax->datum #'y)]) +(syntax-parse #'(a foo bar) + [(x #:foo y) (syntax->datum #'y)]) +] + +} + +@specsubform[(H-pattern . S-pattern)]{ + +Matches any term that can be decomposed into a list prefix matching +the @tech{H-pattern} and a suffix matching the S-pattern. + +Note that the pattern may match terms that are not even improper +lists; if the head pattern can match a zero-length head, then the +whole pattern matches whatever the tail pattern accepts. + +The first pattern can be an @tech{S-pattern}, in which case the whole +pattern matches any pair whose first element matches the first pattern +and whose rest matches the second. + +See @tech{H-patterns} for more information. +} + +@specsubform[#:literals (~or) ((~or EH-pattern ...+) #,ellipses . S-pattern)] +@specsubform[(EH-pattern #,ellipses . S-pattern)]{ + +Matches any term that can be decomposed into a list head matching some +number of repetitions of the @tech{EH-pattern} alternatives (subject +to its repetition constraints) followed by a list tail matching the +S-pattern. + +In other words, the whole pattern matches either the second pattern +(which need not be a list) or a term whose head matches one of the +alternatives of the first pattern and whose tail recursively matches +the whole sequence pattern. + +The @scheme[~or]-free variant is shorthand for the @scheme[~or] +variant with just one alternative. + +See @tech{EH-patterns} for more information. +} + +@specsubform[#:literals (~and) (~and S-pattern ...)]{ + +Matches any syntax that matches all of the included patterns. + +Attributes bound in subpatterns are available to subsequent +subpatterns. The whole pattern binds all of the subpatterns' +attributes. + +One use for @scheme[~and]-patterns is preserving a whole +term (including its lexical context, source location, etc) while also +examining its structure. Syntax classes are useful for the same +purpose, but @scheme[~and] can be lighter weight. + +@(interaction-eval #:eval the-eval + (begin (define (check-imports . _) #f))) + +@myexamples[ +(syntax-parse #'(m (import one two)) + #:literals (import) + [(_ (~and import-clause (import i ...))) + (let ([bad (check-imports + (syntax->list #'(i ...)))]) + (when bad + (raise-syntax-error + #f "bad import" #'import-clause bad)) + 'ok)]) +] + +} + +@specsubform[#:literals (~or) (~or S-pattern ...)]{ + +Matches any term that matches one of the included patterns. + +The whole pattern binds @emph{all} of the subpatterns' attributes. An +attribute that is not bound by the ``chosen'' subpattern has a value +of @scheme[#f]. The same attribute may be bound by multiple +subpatterns, and if it is bound by all of the subpatterns, it is sure +to have a value if the whole pattern matches. + +@myexamples[ +(syntax-parse #'a + [(~or x:id (~and x #f)) (syntax->datum #'x)]) +(syntax-parse #'#f + [(~or x:id (~and x #f)) (syntax->datum #'x)]) +] +} + +@specsubform[#(#, @svar[pattern-part] ...)]{ + +Matches a term that is a vector whose elements, when considered as a +list, match the @tech{S-pattern} corresponding to +@scheme[(pattern-part ...)]. + +@myexamples[ +(syntax-parse #'#(1 2 3) + [#(x y z) (syntax->datum #'z)]) +(syntax-parse #'#(1 2 3) + [#(x y ...) (syntax->datum #'(y ...))]) +(syntax-parse #'#(1 2 3) + [#(x ~rest y) (syntax->datum #'y)]) +] + +} + +@specsubform[#s(prefab-struct-key #, @svar[pattern-part] ...)]{ + +Matches a term that is a prefab struct whose key is exactly the given +key and whose sequence of fields, when considered as a list, match the +@tech{S-pattern} corresponding to @scheme[(pattern-part ...)]. + +@myexamples[ +(syntax-parse #'#s(point 1 2 3) + [#s(point x y z) 'ok]) +(syntax-parse #'#s(point 1 2 3) + [#s(point x y ...) (syntax->datum #'(y ...))]) +(syntax-parse #'#s(point 1 2 3) + [#s(point x ~rest y) (syntax->datum #'y)]) +] +} + +@specsubform[#:literals (~rest) (~rest S-pattern)]{ + +Matches just like the inner @scheme[S-pattern]. The @scheme[~rest] +pattern form is useful in positions where improper lists (``dots'') +are not allowed by the reader, such as vector and structure patterns +(see above). + +@myexamples[ +(syntax-parse #'(1 2 3) + [(x ~rest y) (syntax->datum #'y)]) +(syntax-parse #'#(1 2 3) + [#(x ~rest y) (syntax->datum #'y)]) +] +} + +@specsubform[#:literals (~describe) (~describe expr S-pattern)]{ + +The @scheme[~describe] pattern form annotates a pattern with a +description, a string expression that is evaluated in the scope of all +prior attribute bindings. If parsing the inner pattern fails, then the +description is used to synthesize the error message. + +A describe-pattern also affects backtracking in two ways: + +@itemize{ + +@item{A cut-pattern (@scheme[~!]) within a describe-pattern only +eliminates choice-points created within the describe-pattern.} + +@item{If a describe-pattern succeeds, then all choice points created +within the describe-pattern are discarded, and a failure @emph{after} +the describe-pattern backtracks to a choice point @emph{before} the +describe-pattern, never one @emph{within} it.}}} + +@specsubform[#:literals (~!) (~! . S-pattern)]{ + +The @scheme[~!] operator, pronounced ``cut'', eliminates backtracking +choice points and commits parsing to the current branch of the pattern +it is exploring. + +Common opportunities for cut-patterns come from recognizing special +forms based on keywords. Consider the following expression: + +@interaction[#:eval the-eval +(syntax-parse #'(define-values a 123) + #:literals (define-values define-syntaxes) + [(define-values (x:id ...) e) 'define-values] + [(define-syntaxes (x:id ...) e) 'define-syntaxes] + [e 'expression])] + +Given the ill-formed term @scheme[(define-values a 123)], the +expression tries the first clause, fails to match @scheme[a] against +the pattern @scheme[(x:id ...)], and then backtracks to the second +clause and ultimately the third clause, producing the value +@scheme['expression]. But the term is not an expression; it is an +ill-formed use of @scheme[define-values]! The proper way to write the +@scheme[syntax-parse] expression follows: + +@interaction[#:eval the-eval +(syntax-parse #'(define-values a 123) + #:literals (define-values define-syntaxes) + [(define-values ~! (x:id ...) e) 'define-values] + [(define-syntaxes ~! (x:id ...) e) 'define-syntaxes] + [e 'expression])] + +Now, given the same term, @scheme[syntax-parse] tries the first +clause, and since the keyword @scheme[define-values] matches, the +cut-pattern commits to the current pattern, eliminating the choice +points for the second and third clauses. So when the clause fails to +match, the @scheme[syntax-parse] expression raises an error. + +The effect of a @scheme[~!] pattern is delimited by the nearest +enclosing @scheme[~describe] pattern. If there is no enclosing +@scheme[~describe] pattern but the cut occurs within a syntax class +definition, then only choice points within the syntax class definition +are discarded. +} + +@specsubform[#:literals (~bind) (~bind [attr-id expr] ...)]{ + +This pattern matches any term. Its effect is to evaluate the +@scheme[expr]s and bind them to the given @scheme[attr-id]s as +attributes. +} + +@specsubform/subs[#:literals (~fail) (~fail maybe-fail-condition message-expr) + ([maybe-fail-condition (code:line) + (code:line #:when condition-expr) + (code:line #:unless condition-expr)])]{ + +This pattern succeeds or fails independent of the term being matched +against. If the condition is absent, or if the @scheme[#:when] +condition evaluates to a true value, or if the @scheme[#:unless] +condition evaluates to @scheme[#f], then the pattern fails with the +given message. Otherwise the pattern succeeds. + +Fail patterns can be used together with cut patterns to recognize +specific ill-formed terms and address them with specially-created +failure messages. +} + + +@subsection{H-pattern variants} + +An @deftech{H-pattern} (for ``head pattern'') is a pattern that +describes some number of terms that occur at the head of some list +(possibly an improper list). An H-pattern's usefulness comes from +being able to match heads of different lengths. H-patterns are useful +for specifying optional forms such as keyword arguments. + +Here are the variants of @tech{H-pattern}: + +@specsubform[#:literals (~seq) (~seq . L-pattern)]{ + +Matches a head whose elements, if put in a list, would match the given +@tech{L-pattern}. + +@myexamples[ +(syntax-parse #'(1 2 3 4) + [((~seq 1 2 3) 4) 'ok]) +] +} + +@specsubform[#:literals (~or) (~or H-pattern ...)]{ + +Like the S-pattern version of @scheme[~or], but matches a term head +instead. + +@myexamples[ +(syntax-parse #'(#:foo 2 a b c) + [((~or (~seq #:foo x) (~seq)) y:id ...) + (attribute x)]) +] +} + +@specsubform[#:literals (~describe) (~describe expr H-pattern)]{ + +Like the S-pattern version of @scheme[~describe], but matches a head +pattern instead. +} + +@specsubform[S-pattern]{ + +Matches a head of one element, which must be a term matching the given +@tech{S-pattern}. +} + + +@subsection{EH-pattern forms} + +An @deftech{EH-pattern} (for ``ellipsis-head pattern'') is pattern +that describes some number of terms, like an @tech{H-pattern}, but may +also place contraints on the number of times it occurs in a +repetition. EH-patterns (and ellipses) are useful for matching keyword +arguments where the keywords may come in any order. + +@myexamples[ +(define parser1 + (syntax-parser + [((~or (~once (~seq #:a x) #:name "#:a keyword") + (~optional (~seq #:b y) #:name "#:b keyword") + (~seq #:c z)) ...) + 'ok])) +(parser1 #'(#:a 1)) +(parser1 #'(#:b 2 #:c 3 #:c 25 #:a 'hi)) +(parser1 #'(#:a 1 #:a 2)) +] + +The pattern requires exactly one occurrence of the @scheme[#:a] +keyword and argument, at most one occurrence of the @scheme[#:b] +keyword and argument, and any number of @scheme[#:c] keywords and +arguments. The ``pieces'' can occur in any order. + +Here are the variants of @tech{EH-pattern}: + +@specsubform/subs[#:literals (~once) (~once H-pattern once-option ...) + ([once-option (code:line #:name name-expr) + (code:line #:too-few too-few-message-expr) + (code:line #:too-many too-many-message-expr)])]{ + +Matches if the inner H-pattern matches. This pattern must be selected +exactly once in the match of the entire repetition sequence. + +If the pattern is not chosen in the repetition sequence, then an error +is raised with a message, either @scheme[too-few-message-expr] or +@schemevalfont{"missing required occurrence of @scheme[name-expr]"}. + +If the pattern is chosen more than once in the repetition sequence, +then an error is raised with a message, either +@scheme[too-many-message-expr] or @schemevalfont{"too many occurrences +of @scheme[name-expr]"}. +} + +@specsubform/subs[#:literals (~optional) (~optional H-pattern optional-option ...) + ([optional-option (code:line #:name name-expr) + (code:line #:too-many too-many-message-expr)])]{ + +Matches if the inner H-pattern matches. This pattern may be used at +most once in the match of the entire repetition. + +If the pattern is chosen more than once in the repetition sequence, +then an error is raised with a message, either +@scheme[too-many-message-expr] or @schemevalfont{"too many occurrences +of @scheme[name-expr]"}. +} + + +@subsection{Pattern directives} + +Both @scheme[syntax-parse] and @scheme[syntax-parser] support +directives for annotating the pattern and specifying side +conditions. The grammar for pattern directives follows: + +@schemegrammar[pattern-directive + (code:line #:declare pattern-id syntax-class-id) + (code:line #:declare pattern-id (syntax-class-id expr ...)) + (code:line #:with syntax-pattern expr) + (code:line #:fail-when condition-expr message-expr) + (code:line #:fail-unless condition-expr message-expr)] + +@specsubform[(code:line #:declare pvar-id syntax-class-id)] +@specsubform[(code:line #:declare pvar-id (syntax-class-id expr ...))]{ + +The first form is equivalent to using the +@svar[pvar-id:syntax-class-id] form in the pattern (but it is +illegal to use both for a single pattern variable). The +@scheme[#:declare] form may be preferred when writing macro-defining +macros or to avoid dealing with structured identifiers. + +The second form allows the use of parameterized syntax classes, which +cannot be expressed using the ``colon'' notation. The @scheme[expr]s +are evaluated outside the scope of any of the attribute bindings from +pattern that the @scheme[#:declare] directive applies to. + +} + +@specsubform[(code:line #:with syntax-pattern expr)]{ + +Evaluates the @scheme[expr] in the context of all previous attribute +bindings and matches it against the pattern. If the match succeeds, +the pattern's attributes are added to environment for the evaluation +of subsequent side conditions. If the @scheme[#:with] match fails, the +matching process backtracks. Since a syntax object may match a pattern +in several ways, backtracking may cause the same clause to be tried +multiple times before the next clause is reached. +} + +@specsubform[(code:line #:fail-when condition-expr message-expr)] +@specsubform[(code:line #:fail-unless condition-expr message-expr)]{ + +Evaluates the @scheme[condition-expr] in the context of all previous +attribute bindings. If the value is any non-false value for +@scheme[#:fail-when] or if the value is @scheme[#f] for +@scheme[#:fail-unless], the matching process backtracks (with the +given message); otherwise, it continues. + +} + +@deftogether[[ +@defidform[~or] +@defidform[~and] +@defidform[~seq] +@defidform[~once] +@defidform[~optional] +@defidform[~rest] +@;{@defidform[~struct]} +@defidform[~describe] +@defidform[~!] +@defidform[~bind] +@defidform[~fail]]]{ + +Syntax pattern keywords, recognized by @scheme[syntax-parse]. + +} + +@defform[(attribute attr-id)]{ + +Returns the value associated with the attribute named +@scheme[attr-id]. If @scheme[attr-id] is not bound as an attribute, an +error is raised. If @scheme[attr-id] is an attribute with a nonzero +ellipsis depth, then the result has the corresponding level of list +nesting. + +The values returned by @scheme[attribute] never undergo additional +wrapping as syntax objects, unlike values produced by some uses of +@scheme[syntax], @scheme[quasisyntax], etc. Consequently, the +@scheme[attribute] form is preferred when the attribute value is used +as data, not placed in a syntax object. + +} + +@;{----------} + +@section{Syntax Classes} + +Syntax classes provide an abstraction mechanism for the specification +of syntax. Built-in syntax classes are supplied that recognize basic +classes such as @scheme[identifier]s and @scheme[keyword]s. +Programmers can compose basic syntax classes to build specifications +of more complex syntax, such as lists of distinct identifiers and +formal arguments with keywords. Macros that manipulate the same +syntactic structures can share syntax class definitions. The structure +of syntax classes and patterns also allows @scheme[syntax-parse] to +automatically generate error messages for syntax errors. + +When a syntax class accepts (matches) a syntax object, it computes and +provides attributes based on the contents of the matched syntax. While +the values of the attributes depend on the matched syntax, the set of +attributes and each attribute's ellipsis nesting depth is fixed for +each syntax class. + +@defform*/subs[#:literals (pattern basic-syntax-class) + [(define-syntax-class name-id stxclass-option ... + stxclass-variant ...+) + (define-syntax-class (name-id arg-id ...) stxclass-option ... + stxclass-variant ...+)] + ([stxclass-option + (code:line #:attributes (attr-arity-decl ...)) + (code:line #:description description) + (code:line #:transparent) + (code:line #:literals (literal-entry ...)) + (code:line #:literal-sets (literal-set ...)) + (code:line #:conventions (convention-id ...))] + [attr-arity-decl + attr-name-id + (attr-name-id depth)] + [stxclass-variant + (pattern syntax-pattern stxclass-pattern-directive ...)])]{ + +Defines @scheme[name-id] as a syntax class. When the @scheme[arg-id]s +are present, they are bound as variables (not pattern variables) in +the body. The body of the syntax-class definition contains a non-empty +sequence of @scheme[pattern] variants. + +@specsubform[(code:line #:attributes (attr-arity-decl ...))]{ + +Declares the attributes of the syntax class. An attribute arity +declaration consists of the attribute name and optionally its ellipsis +depth (zero if not explicitly specified). + +If the attributes are not explicitly listed, they are inferred as the +set of all pattern variables occurring in every variant of the syntax +class. Pattern variables that occur at different ellipsis depths are +not included, nor are nested attributes. + +} + +@specsubform[(code:line #:description description)]{ + +The @scheme[description] argument is an expression (evaluated in a +scope containing the syntax class's parameters) that should evaluate +to a string. It is used in error messages involving the syntax +class. For example, if a term is rejected by the syntax class, an +error of the form @schemevalfont{"expected @scheme[description]"} may +be synthesized. + +If absent, the name of the syntax class is used instead. + +} + +@specsubform[#:transparent]{ + +Indicates that errors may be reported with respect to the internal +structure of the syntax class. +} + +@specsubform[(code:line #:literals (literal-entry))] +@specsubform[(code:line #:literal-sets (literal-set ...))] +@specsubform[(code:line #:conventions (convention-id ...))]{ + +Declares the literals and conventions that apply to the syntax class's +variant patterns and their immediate @scheme[#:with] clauses. Patterns +occuring within subexpressions of the syntax class (for example, on +the right-hand side of a @scheme[#:fail-when] clause) are not +affected. + +These options have the same meaning as under @scheme[syntax-parse]. +} + +@specsubform/subs[#:literals (pattern) + (pattern syntax-pattern stxclass-pattern-directive ...) + ([stxclass-pattern-directive + pattern-directive + (code:line #:rename internal-id external-id)])]{ + +Accepts syntax matching the given syntax pattern with the accompanying +pattern directives as in @scheme[syntax-parse]. + +The attributes of the variant are the attributes of the pattern +together with all attributes bound by @scheme[#:with] clauses, +including nested attributes produced by syntax classes associated with +the pattern variables. +} +} + +@defform*/subs[#:literals (pattern) + [(define-splicing-syntax-class name-id stxclass-option ... + stxclass-variant ...+) + (define-splicing-syntax-class (name-id arg-id ...) stxclass-option ... + stxclass-variant ...+)] + ()]{ + +Defines @scheme[name-id] as a splicing syntax class. A splicing syntax +class encapsulates @tech{H-patterns} as an ordinary syntax class +encapsulates @tech{S-patterns}. + +} + +@defidform[pattern]{ + +Keyword recognized by @scheme[define-syntax-class]. It may not be +used as an expression. +} + + +@subsection{Attributes} + +A syntax class has a set of @deftech{attribute}s. Each attribute has a +name, an ellipsis depth, and a set of nested attributes. When an +instance of the syntax class is parsed and bound to a pattern +variable, additional pattern variables are bound for each of the +syntax class's attributes. The name of these additional pattern +variables is the dotted concatenation of the primary pattern +variable with the name of the attribute. + +For example, if pattern variable @scheme[p] is bound to an instance of +a syntax class with attribute @scheme[a], then the pattern variable +@scheme[p.a] is bound to the value of that attribute. The ellipsis +depth of @scheme[p.a] is the sum of the depths of @scheme[p] and +attribute @scheme[a]. + +The attributes of a syntax class are either given explicitly with an +@scheme[#:attributes] option or inferred from the pattern variables of +the syntax class's variants. + + +@subsection{Inspection tools} + +The following special forms are for debugging syntax classes. + +@defform[(syntax-class-attributes syntax-class-id)]{ + +Returns a list of the syntax class's attributes in flattened +form. Each attribute is listed by its name and ellipsis depth. +} + +@defform[(syntax-class-parse syntax-class-id stx-expr arg-expr ...)]{ + +Runs the parser for the syntax class (parameterized by the +@scheme[arg-expr]s) on the syntax object produced by +@scheme[stx-expr]. On success, the result is a list of vectors +representing the attribute bindings of the syntax class. Each vector +contains the attribute name, depth, and associated value. On failure, +the result is some internal representation of the failure. +} + + +@;{----------} + +@section{Literal sets and Conventions} + +Sometimes the same literals are recognized in a number of different +places. The most common example is the literals for fully expanded +programs, which are used in many analysis and transformation +tools. Specifying literals individually is burdensome and error-prone. +As a remedy, @schememodname[syntax/parse] offers @deftech{literal +set}s. A literal set is defined via @scheme[define-literal-set] and +used via the @scheme[#:literal-set] option of @scheme[syntax-parse]. + +@defform/subs[(define-literal-set name-id (literal ...)) + ([literal literal-id + (pattern-id literal-id)])]{ + +Defines @scheme[name] as a @tech{literal set}. Each @scheme[literal] +can have a separate @scheme[pattern-id] and @scheme[literal-id]. The +@scheme[pattern-id] determines what identifiers in the pattern are +treated as literals. The @scheme[literal-id] determines what +identifiers the literal matches. + +@myexamples[ +(define-literal-set def-litset + (define-values define-syntaxes)) +(syntax-parse #'(define-syntaxes (x) 12) + #:literal-sets (def-litset) + [(define-values (x:id ...) e:expr) 'v] + [(define-syntaxes (x:id ...) e:expr) 's]) +] + +} + +@defform/subs[(define-conventions name-id (id-pattern syntax-class) ...) + ([name-pattern exact-id + name-rx] + [syntax-class syntax-class-id + (syntax-class-id expr ...)])]{ + +Defines @deftech{conventions} that supply default syntax classes for +pattern variables. A pattern variable that has no explicit syntax +class is checked against each @scheme[id-pattern], and the first one +that matches determines the syntax class for the pattern. If no +@scheme[id-pattern] matches, then the pattern variable has no syntax +class. + +@myexamples[ +(define-conventions xyz-as-ids + [x id] [y id] [z id]) +(syntax-parse #'(a b c 1 2 3) + #:conventions (xyz-as-ids) + [(x ... n ...) (syntax->datum #'(x ...))]) +(define-conventions xn-prefixes + [#rx"^x" id] + [#rx"^n" nat]) +(syntax-parse #'(a b c 1 2 3) + #:conventions (xn-prefixes) + [(x0 x ... n0 n ...) (syntax->datum #'(x0 (x ...) n0 (n ...)))]) +] + +} + +@;{----------} + +@section{Library syntax classes and literal sets} + +@subsection{Syntax classes} + +@(begin + (define-syntax-rule (defstxclass name . pre-flows) + (defidform name . pre-flows)) + (define-syntax-rule (defstxclass* (name arg ...) . pre-flows) + (defform (name arg ...) . pre-flows))) + +@defstxclass[expr]{ + +Matches anything except a keyword literal (to distinguish expressions +from the start of a keyword argument sequence). The term is not +otherwise inspected, and no guarantee is made that the term is +actually a valid expression. + +} + +@deftogether[( +@defstxclass[identifier] +@defstxclass[boolean] +@defstxclass[str] +@defstxclass[char] +@defstxclass[keyword] +@defstxclass[number] +@defstxclass[integer] +@defstxclass[exact-integer] +@defstxclass[exact-nonnegative-integer] +@defstxclass[exact-positive-integer])]{ + +Match syntax satisfying the corresponding predicates. + +} + +@defstxclass[id]{ Alias for @scheme[identifier]. } +@defstxclass[nat]{ Alias for @scheme[exact-nonnegative-integer]. } + +@defform[(static-of predicate description)]{ + +Matches an identifier that is bound in the syntactic environment to +static information (see @scheme[syntax-local-value]) satisfying the +given @scheme[predicate]. If the term does not match, the +@scheme[description] argument is used to describe the expected syntax. + +When used outside of the dynamic extend of a macro transformer (see +@scheme[syntax-transforming?]), matching fails. + +The attribute @var[value] contains the value the name is bound to. +} + +@defstxclass[static]{ + +Like @scheme[static-of], but matches any identifier bound to static +information (see @scheme[syntax-local-value]). + +The attribute @var[value] contains the value the name is bound to. +} + +@subsection{Literal sets} + +@defidform[kernel-literals]{ + +Literal set containing the identifiers for fully-expanded expression +and definition forms (the same as provided by +@scheme[kernel-form-identifier-list]). + +} diff --git a/collects/syntax/scribblings/syntax-object-helpers.scrbl b/collects/syntax/scribblings/syntax-object-helpers.scrbl index bff81ea78d..ea843877ce 100644 --- a/collects/syntax/scribblings/syntax-object-helpers.scrbl +++ b/collects/syntax/scribblings/syntax-object-helpers.scrbl @@ -6,6 +6,7 @@ @include-section["stx.scrbl"] @include-section["kerncase.scrbl"] @include-section["boundmap.scrbl"] +@include-section["id-table.scrbl"] @include-section["to-string.scrbl"] @include-section["free-vars.scrbl"] @include-section["strip-context.scrbl"] diff --git a/collects/syntax/scribblings/syntax.scrbl b/collects/syntax/scribblings/syntax.scrbl index f5387c2f67..d8ce83e7af 100644 --- a/collects/syntax/scribblings/syntax.scrbl +++ b/collects/syntax/scribblings/syntax.scrbl @@ -20,5 +20,6 @@ @include-section["docprovide.scrbl"] +@include-section["parse.scrbl"] @index-section[] diff --git a/collects/tests/mzscheme/id-table-test.ss b/collects/tests/mzscheme/id-table-test.ss new file mode 100644 index 0000000000..63c11af5ab --- /dev/null +++ b/collects/tests/mzscheme/id-table-test.ss @@ -0,0 +1,214 @@ +(load-relative "loadtest.ss") + +(require syntax/id-table + scheme/dict) + +(Section 'id-table) + +(test #t bound-id-table? (make-bound-id-table)) +(test #t bound-id-table? (make-immutable-bound-id-table)) + +(test #t mutable-bound-id-table? (make-bound-id-table)) +(test #t immutable-bound-id-table? (make-immutable-bound-id-table)) + +(let () + ;; contains-same? : (listof x) (listof x) -> boolean + (define (contains-same? l1 l2) + (and (andmap (lambda (x) (member x l2)) l1) + (andmap (lambda (x) (member x l1)) l2) + #t)) + + (let-values ([(x1 x2 x3 x4) + (syntax-case (expand #'((lambda (x) x) (lambda (x) x))) () + [(x (a (x1) x2) (c (x3) x4)) + (values (syntax x1) + (syntax x2) + (syntax x3) + (syntax x4))])]) + + (let ([check (lambda (=?) + (test #t =? x1 x2) + (test #t =? x3 x4) + (when (=? x1 x3) + ((current-print) "huh!?")) + (test #f =? x1 x3) + (test #f =? x1 x4) + (test #f =? x2 x3) + (test #f =? x2 x4))]) + (check bound-identifier=?) + (check free-identifier=?)) + + (let ([table (make-bound-id-table)]) + (bound-id-table-set! table x1 #f) + (test #f bound-id-table-ref table x1) + + (bound-id-table-set! table x1 1) + (bound-id-table-set! table x2 2) + (bound-id-table-set! table x3 3) + (bound-id-table-set! table x4 4) + (test 2 bound-id-table-ref table x1) + (test 2 bound-id-table-ref table x2) + (test 4 bound-id-table-ref table x3) + (test 4 bound-id-table-ref table x4) + (test #t + contains-same? + (list 2 4) + (bound-id-table-map table (lambda (x y) y))) + (test #t + contains-same? + (list 2 4) + (dict-map table (lambda (x y) y))) + + (test 2 bound-id-table-count table) + + + (test #t + contains-same? + (list 2 4) + (let ([l '()]) + (bound-id-table-for-each + table + (lambda (x y) + (set! l (cons y l)))) + l)) + (test #t + contains-same? + (list 2 4) + (let ([l '()]) + (dict-for-each + table + (lambda (x y) + (set! l (cons y l)))) + l))) + + + (let ([table (make-free-id-table)]) + (free-id-table-set! table x1 1) + (free-id-table-set! table x2 2) + (free-id-table-set! table x3 3) + (free-id-table-set! table x4 4) + (test 2 free-id-table-ref table x1) + (test 2 free-id-table-ref table x2) + (test 4 free-id-table-ref table x3) + (test 4 free-id-table-ref table x4) + + (test #t + contains-same? + (list 2 4) + (free-id-table-map table (lambda (x y) y))) + (test #t + contains-same? + (list 2 4) + (dict-map table (lambda (x y) y))) + (test 2 free-id-table-count table) + + (test #t + contains-same? + (list 2 4) + (let ([l '()]) + (free-id-table-for-each + table + (lambda (x y) + (set! l (cons y l)))) + l)) + (test #t + contains-same? + (list 2 4) + (let ([l '()]) + (dict-for-each + table + (lambda (x y) + (set! l (cons y l)))) + l)))) + + (let-values ([(y1 y2 y3 y4) + (syntax-case (expand #'(module m mzscheme (require (prefix x: mzscheme)) + x:+ - x:-)) () + [(a b c (d e f y1 y2 y3 y4)) + (values (syntax y1) + (syntax y2) + (syntax y3) + (syntax y4))])]) + + (let ([table (make-bound-id-table)]) + (bound-id-table-set! table y1 1) + (bound-id-table-set! table y2 2) + (bound-id-table-set! table y3 3) + (bound-id-table-set! table y4 4) + (test 1 bound-id-table-ref table y1) + (test 2 bound-id-table-ref table y2) + (test 3 bound-id-table-ref table y3) + (test 4 bound-id-table-ref table y4) + + (test #t + contains-same? + (list 1 2 3 4) + (bound-id-table-map table (lambda (x y) y))) + (test #t + contains-same? + (list 1 2 3 4) + (dict-map table (lambda (x y) y))) + (test 4 bound-id-table-count table) + + (test #t + contains-same? + (list 1 2 3 4) + (let ([l '()]) + (bound-id-table-for-each + table + (lambda (x y) + (set! l (cons y l)))) + l)) + (test #t + contains-same? + (list 1 2 3 4) + (let ([l '()]) + (dict-for-each + table + (lambda (x y) + (set! l (cons y l)))) + l))) + + (let ([table (make-free-id-table)]) + (free-id-table-set! table y1 #f) + (test #f free-id-table-ref table y1) + + (free-id-table-set! table y1 1) + (free-id-table-set! table y2 2) + (free-id-table-set! table y3 3) + (free-id-table-set! table y4 4) + (test 2 free-id-table-ref table y1) + (test 2 free-id-table-ref table y2) + (test 4 free-id-table-ref table y3) + (test 4 free-id-table-ref table y4) + + (test #t + contains-same? + (list 2 4) + (free-id-table-map table (lambda (x y) y))) + (test #t + contains-same? + (list 2 4) + (dict-map table (lambda (x y) y))) + (test 2 free-id-table-count table) + + (test #t + contains-same? + (list 2 4) + (let ([l '()]) + (free-id-table-for-each + table + (lambda (x y) + (set! l (cons y l)))) + l)) + (test #t + contains-same? + (list 2 4) + (let ([l '()]) + (dict-for-each + table + (lambda (x y) + (set! l (cons y l)))) + l)) + ))) + +(report-errs) diff --git a/collects/tests/mzscheme/syntax-tests.ss b/collects/tests/mzscheme/syntax-tests.ss index fe999246af..31142e7b76 100644 --- a/collects/tests/mzscheme/syntax-tests.ss +++ b/collects/tests/mzscheme/syntax-tests.ss @@ -2,6 +2,7 @@ (load-in-sandbox "moddep.ss") (load-in-sandbox "boundmap-test.ss") +(load-in-sandbox "id-table-test.ss") (load-in-sandbox "cm.ss") (load-in-sandbox "module-reader.ss") diff --git a/collects/tests/stxclass/stxclass.ss b/collects/tests/stxclass/stxclass.ss index 1ebeb878c2..6bcded5217 100644 --- a/collects/tests/stxclass/stxclass.ss +++ b/collects/tests/stxclass/stxclass.ss @@ -1,10 +1,9 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2 9)) - (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 2 9)) - stxclass - stxclass/private/sc - (for-syntax scheme/base stxclass)) +(require (planet schematics/schemeunit:2:9/test) + (planet schematics/schemeunit:2:9/graphical-ui) + syntax/parse + (for-syntax scheme/base syntax/parse)) ;; Testing stuff @@ -34,10 +33,12 @@ (pattern (a b c))) (define-syntax-class two-or-three/tag + #:attributes (a a.a a.b) (pattern a:two) (pattern a:three)) (define-syntax-class two-to-four/untagged + #:attributes (a b) (pattern :two) (pattern :three) (pattern (a b c d))) @@ -60,7 +61,7 @@ (define-syntax-rule (test-sc-attrs name ([attr depth] ...)) (test-case (format "~s" 'name) - (let* ([r-attrs (attrs-of name)] + (let* ([r-attrs (syntax-class-attributes name)] [r-names (map car r-attrs)] [expected '((attr depth) ...)]) (for ([ra r-names]) @@ -76,7 +77,7 @@ (define-syntax-rule (test-parse-sc sc stx ([attr depth form] ...)) (test-case (format "~s" 'sc) - (let* ([r (parse-sc sc stx)] + (let* ([r (syntax-class-parse sc stx)] [r-attrs (for/list ([record r]) (vector-ref record 0))] [expected '([attr depth form] ...)]) (for ([ra r-attrs]) @@ -90,7 +91,7 @@ (define-syntax-rule (test-patterns pattern stx . body) (test-case (format "~s" 'pattern) - (with-patterns ([pattern stx]) . body))) + (syntax-parse stx [pattern . body]))) ;; Tests @@ -101,7 +102,7 @@ (test-sc-attrs two ([a 0] [b 0])) (test-sc-attrs three ([a 0] [b 0] [c 0])) (test-sc-attrs two-or-three/tag ([a 0] [a.a 0] [a.b 0])) - (test-sc-attrs id-num ([x 0] [x.datum 0] [n 0] [n.datum 0]))) + (test-sc-attrs id-num ([x 0] [n 0]))) (test-suite "parse-sc" (test-parse-sc one #'1 ([a 0 1])) (test-parse-sc two #'(1 2) ([a 0 1] [b 0 2])) @@ -109,113 +110,56 @@ (test-parse-sc two-or-three/tag #'(1 2 3) ([a 0 (1 2 3)] [a.a 0 1] [a.b 0 2])) (test-parse-sc id-num #'(this 12) - ([x 0 this] [x.datum 0 this] [n 0 12] [n.datum 0 12])) + ([x 0 this] [n 0 12])) (test-parse-sc id-string #'(that "here") - ([x 0 that] [x.datum 0 that] - [label 0 "here"] [label.datum 0 "here"]))) + ([x 0 that] [label 0 "here"]))) (test-suite "with-patterns" (test-patterns (t:two-to-four/untagged ...) #'((1 2 3) (4 5) (6 7 8)) (check-equal? (syntax->datum #'(t.a ...)) '(1 4 6))) (test-patterns (t:two-to-four/untagged ...) #'((1 2 3) (4 5) (6 7 8)) (check-equal? (syntax->datum #'(t.b ...)) '(2 5 7))) - (test-patterns ({~or {x:id v:nat} {s:str}} ...) #'(x 1 y 2 "whee" x 3) + (test-patterns ({~or {~seq x:id v:nat} s:str} ...) #'(x 1 y 2 "whee" x 3) (check-equal? (stx->datum #'((x v) ...)) '((x 1) (y 2) (x 3))) (check-equal? (stx->datum #'(s ...)) '("whee"))) - (test-patterns ({~or {x:id v:nat} {s:str}} ...) #'(x 1 y 2 "whee" x 3) + (test-patterns ({~or {~seq x:id v:nat} s:str} ...) #'(x 1 y 2 "whee" x 3) (check-equal? (stx->datum #'((x v) ...)) '((x 1) (y 2) (x 3))) (check-equal? (stx->datum #'(s ...)) '("whee"))) - (test-patterns ({~or {1} #:min 1 #:max 1 - {2} #:min 1 #:max 1 - {3} #:min 1 #:max 1} ...) + (test-patterns ({~or (~once 1) + (~once 2) + (~once 3)} ...) #'(1 2 3) 'ok) - (test-patterns ({~or {a:id} {b:nat} {c:str}} ...) #'("one" 2 three) + (test-patterns ({~or a:id b:nat c:str} ...) #'("one" 2 three) (check-equal? (stx->datum #'(a ...)) '(three)) (check-equal? (stx->datum #'(b ...)) '(2)) (check-equal? (stx->datum #'(c ...)) '("one"))) - (test-patterns ({~or {1} #:min 1 #:max 1 - {2} #:min 1 #:max 1 - {3} #:min 1 #:max 1 - {x} #:min 1 #:max 1 - {y} #:min 1 #:max 1 - {w} #:min 1 #:max 1} ...) + (test-patterns ({~or (~once 1) + (~once 2) + (~once 3) + (~once x) + (~once y) + (~once w)} ...) #'(1 2 3 x y z) - (for ([s (syntax->list #'(x ... y ... w ...))]) (check-pred identifier? s)) + (for ([s (syntax->list #'(x y w))]) (check-pred identifier? s)) (check-equal? (sort - (map symbol->string (stx->datum #'(x ... y ... w ...))) + (map symbol->string (stx->datum #'(x y w))) stringdatum #'(x ...)) '(x y z))) ))) -(define-syntax (test-expr stx) - (with-patterns ([(_ e:expr/local-expand) stx]) - #'(quote e.expanded))) - -(define-syntax (convert-block stx) - (with-patterns ([(_ . b:block/head-local-expand) stx]) - (with-patterns ([((_ svars srhs) ...) #'(b.sdef ...)] - [((_ vvars vrhs) ...) #'(b.vdef ...)]) - ;;(printf "here's the expanded block:\n~s\n" #'b.expanded-block) - #'(letrec-syntaxes+values ((svars srhs) ...) ((vvars vrhs) ...) - (begin b.expr ...))))) - -(define-syntax (begin/defs stx) - (with-patterns - ([(_ . b:internal-definitions) stx] - [((_ svars srhs) ...) #'(b.sdef ...)] - [((_ (vvar ...) bleh) ...) #'(b.vdef ...)] - [(expr ...) - (for/list ([form (syntax->list #'(b.expanded ...))]) - (syntax-parse form - [dv:define-values-form - #'(set!-values (dv.var ...) dv.rhs)] - [ds:define-syntaxes-form - #'(void)] - [e - #'e]))]) - #'(letrec-syntaxes+values - ((svars srhs) ...) - (((vvar ...) (let ((vvar #f) ...) (values vvar ...))) ...) - (begin expr ...)))) - -(define-syntax (begin/defs* stx) - (with-patterns - ([(_ . b:internal-definitions) stx] - [((_ svars srhs) ...) #'(b.sdef ...)] - [(head ... last) #'(b.expanded ...)] - [((preclause ...) ...) - (for/list ([form (syntax->list #'(head ...))]) - (syntax-parse form - [dv:define-values-form - #'([(dv.var ...) dv.rhs])] - [_:define-syntaxes-form - #'()] - [e - #'([() (begin e (values))])]))] - [(clause ...) #'(preclause ... ...)]) - #'(letrec-syntaxes+values - ((svars srhs) ...) - (clause ...) - (begin tail)))) - -(convert-block - (define x 1) - (define y 2) - (+ x y)) - (define-syntax-class bindings (pattern ((var:id e) ...) #:with vars #'(var ...))) (define-syntax-class sorted (pattern (n:nat ...) - #:when (sorted? (syntax->datum #'(n ...))))) + #:fail-unless (sorted? (syntax->datum #'(n ...))) "not sorted")) (define (sorted? ns) (define (loop ns min) @@ -225,61 +169,6 @@ [(null? ns) #t])) (loop ns -inf.0)) -(define-syntax madd1 - (syntax-parser - [(_ e:expr/num) - #'(+ 1 e)])) - -(define-syntax mapp-to-1 - (syntax-parser - [(_ e) - #:declare e expr/num->num - #'(e 1)])) - -(define-syntax bad-mapp-to-1 - (syntax-parser - [(_ e:expr/num->num) - #'(e 'whoa)])) - -#; -(define-syntax (madd2 stx) - (syntax-parse stx - [(_ e:expr/nat) - #'(+ 2 e)])) - - -(define-syntax-class expr/nat - (pattern e - #:declare e (expr/c #'number?))) - -(define-syntax-class cond-clauses - (pattern ([#:else answer]) - #:with tests (list #'#t) - #:with answers (list #'answer)) - (pattern ([test answer] . more:cond-clauses) - #:with tests (cons #'test #'more.tests) - #:with answers (cons #'answer #'more.answers)) - (pattern ([test #:=> answer] . more:cond-clauses) - #:with tests (cons #'test #'more.tests) - #:with answers (cons #'answer #'more.answers)) - (pattern () - #:with tests null - #:with answers null)) - -(define-syntax-class zork - (pattern f:frob)) -(define-syntax-class frob - (pattern x:id)) - -(syntax-parse #'1 - [x:nat - (define (check d) - (unless (positive? d) - (error "not positive"))) - (check #'x.datum) - 'ok]) - - (define-syntax-class Opaque (pattern (a:id n:nat))) (define-syntax-class Transparent @@ -295,12 +184,12 @@ [(plus) (void)]) (define-syntax-class (nat> n) - #:description (format "nat > ~s" n) - (pattern x:nat #:when (> (syntax-e #'x) n))) + #:description (format "nat > ~s" n) + (pattern x:nat #:fail-unless (> (syntax-e #'x) n) #f)) (syntax-parse #'(1 2 3) - [(a:nat b0:nat c0:nat) - #:with b #'b0 - #:declare b (nat> (attribute a.datum)) - #:with c #'c0 - #:declare c (nat> (attribute b0.datum)) - (void)]) + [(a:nat b0:nat c0:nat) + #:with b #'b0 + #:declare b (nat> (syntax-e #'a)) + #:with c #'c0 + #:declare c (nat> (syntax-e #'b0)) + (void)]) diff --git a/collects/tests/stxclass/test.ss b/collects/tests/stxclass/test.ss new file mode 100644 index 0000000000..cff41a8336 --- /dev/null +++ b/collects/tests/stxclass/test.ss @@ -0,0 +1,251 @@ +#lang scheme +(require syntax/parse + syntax/private/stxparse/rep-attrs + syntax/private/stxparse/runtime) +(require schemeunit) + +;; tok = test pattern ok +(define-syntax tok + (syntax-rules () + [(tok s p expr #:pre [pre-p ...] #:post [post-p ...]) + (test-case (format "line ~s: ~s match ~s" + (syntax-line (quote-syntax s)) + 's 'p) + (syntax-parse (quote-syntax s) + [pre-p (error 'wrong-pattern "~s" 'pre-p)] ... + [p expr] + [post-p (error 'wrong-pattern "~s" 'post-p)] ...) + (void))] + [(tok s p expr) + (tok s p expr #:pre () #:post ())] + [(tok s p) + (tok s p 'ok)])) + +(define-syntax-rule (bound b ...) + (begin (bound1 b) ...)) + +(define-syntax bound1 + (syntax-rules () + [(bound1 (name depth)) + (let ([a (attribute-binding name)]) + (check-pred attr? a) + (when (attr? a) + (check-equal? (attr-depth a) 'depth)))] + [(bound1 (name depth syntax?)) + (let ([a (attribute-binding name)]) + (check-pred attr? a) + (when (attr? a) + (check-equal? (attr-depth a) 'depth) + (check-equal? (attr-syntax? a) 'syntax?)))])) + +(define-syntax-rule (s= t v) + (check-equal? (syntax->datum #'t) v)) + +(define-syntax-rule (a= a v) + (check-equal? (attribute a) v)) + +(define-syntax-rule (terx s p rx ...) + (terx* s [p] rx ...)) + +(define-syntax terx* + (syntax-rules () + [(terx s [p ...] rx ...) + (test-case (format "line ~s: ~a match ~s for error" + (syntax-line (quote-syntax s)) + 's '(p ...)) + (check-exn (lambda (exn) + (erx rx (exn-message exn)) ...) + (lambda () + (syntax-parse (quote-syntax s) + [p 'ok] ...))) + (void))])) + +(define-syntax erx + (syntax-rules (not) + [(erx (not rx) msg) + (check-false (regexp-match? rx msg))] + [(erx rx msg) + (check regexp-match? rx msg)])) + + +;; ======== + +(define-syntax-class one + (pattern (a))) +(define-syntax-class two + (pattern (a b))) + +;; ======== + + +;; == Parsing tests + +;; -- S patterns +;; name patterns +(tok 1 a + (and (bound (a 0)) (s= a 1))) +(tok (a b c) a + (and (bound (a 0)) (s= a '(a b c)))) +(tok 1 a + 'ok + #:pre [] #:post [1]) + +;; wildcard patterns +(tok 1 _) +(tok (a b c) _) +(tok (a b) (_ _)) ;; multiple _'s allowed + +;; sc tests -> lib tests +(tok (1) x:one + (and (bound (x 0) (x.a 0)) (s= x '(1)) (s= x.a 1))) +(tok (1 2) x:two + (and (bound (x 0) (x.a 0) (x.b 0)) (s= x '(1 2)) (s= x.a 1) (s= x.b 2))) +(tok (1 2) x:two + 'ok + #:pre [x:one] #:post []) +(tok (1) x:one + 'ok + #:pre [()] #:post [x:two]) +;; check if wildcard, no attr bound + +(terx (1) _:two "expected two") +(terx (1 2) _:one "expected one") +(terx (1 (2 3)) (_:one _:two) "expected one") +(terx ((1) 2) (_:one _:two) "expected two") + +;; datum patterns +(tok 1 1 + 'ok) +(tok 1 _ + #t + #:pre [2] #:post []) +(tok "here" "here" + 'ok + #:pre ["there"] #:post []) +(tok #f #f + 'ok + #:pre [#t 0] #:post [_]) + +(terx 1 2 "literal 2") +(terx (1 2) 1 "literal 1") +(terx (1 2) (1 1) "literal 1") + +;; literal patterns +(syntax-parse #'+ #:literals (+ -) + [+ (void)]) +(syntax-parse #'+ #:literals (+ -) + [- (error 'wrong)] + [+ (void)]) +(syntax-parse #'+ #:literals (+ -) + [+ (void)] + [_ (error 'wrong)]) + +;; compound patterns +(tok (a b c) (x y z) + (and (bound (x 0) (y 0) (z 0)) (s= x 'a) (s= y 'b)) + #:pre [(x y)] #:post []) +(tok (a . b) (x . y) + (and (bound (x 0) (y 0)) (s= x 'a) (s= y 'b)) + #:pre [(x y)] #:post []) +(tok #(a b c) #(x y z) + (and (bound (x 0) (y 0) (z 0)) (s= x 'a) (s= y 'b))) +(tok #(a b c) #(x y z) + (and (bound (x 0) (y 0) (z 0)) (s= x 'a) (s= y 'b))) +(tok #&1 #&x + (and (bound (x 0)) (s= x 1))) + +;; head patterns +;; See H-patterns + +;; dots patterns +;; See EH-patterns + +;; and patterns +(tok 1 (~and a 1) + (and (bound (a 0)) (s= a 1))) +(tok 1 (~and 1 1) + 'ok + #:pre [(~and 1 2)] #:post [(~and 2 2)]) +(tok (1 2 3) (~and w (x y z)) + (and (bound (w 0) (x 0) (y 0) (z 0)) + (s= w '(1 2 3)) (s= x 1))) +(tok (1 2 3) (~and (1 _ _) (_ 2 _) (_ _ 3)) + 'ok) +(tok (1 2 3) (~and (x _ _) (_ y _) (_ _ z)) + (and (bound (x 0) (y 0) (z 0)))) + +;; or patterns +(tok 1 (~or 1 2 3) + 'ok) +(tok 3 (~or 1 2 3) + 'ok) +(tok (1) (~or (a) (a b) (a b c)) + (and (bound (a 0 #t) (b 0 #f) (c 0 #f)) (s= a 1) (a= b #f) (a= c #f))) +(tok (1 2 3) (~or (a) (a b) (a b c)) + (and (bound (a 0 #t) (b 0 #f) (c 0 #f)) (s= a 1) (s= b 2) (s= c 3))) +(tok 1 (~or 5 _) + 'ok) +(tok #t (~or #t #f) + 'ok) +(tok #t (~or (~and #t x) (~and #f x)) + (and (bound (x 0 #t)))) + +;; epsilon-name patterns +(tok (1) :one + (and (bound (a 0)) (s= a 1))) +(tok (1 2) :two + (and (bound (a 0) (b 0)) (s= a 1) (s= b 2))) +(tok (1 2) (~and x:two :two) + (and (bound (x 0) (x.a 0) (a 0)) (s= x '(1 2)) (s= x.a 1) (s= a 1))) + +;; cut patterns +(terx* (1 2 3) [(1 ~! 4) (1 2 3)] + "4" (not "2")) + +;; cut-in-and +(terx* 1 [(~and a:nat ~! 2) b:nat] + "2") + +;; cut&describe interaction +(tok (1 (2 3)) (1 (~or (~describe "foo" (2 ~! 4)) (2 3)))) +(tok (1 2 3) (1 2 3) + 'ok + #:pre [(~describe "foo" (1 2 ~! 4))] #:post []) + +;; bind patterns +(tok 1 (~and x (~bind [y #'x])) + (s= y '1)) +(tok 1 (~or x:id (~bind [x #'default])) + (s= x 'default)) + +;; fail patterns +(tok (1 2 3) _ + 'ok + #:pre [(~fail "pass") (error 'wrong)] #:post []) +(terx 1 (~fail "wanted 2") + #rx"wanted 2") +(terx 1 (~and n:nat (~fail #:unless (even? (syntax-e #'n)) "wanted even number")) + #rx"wanted even number") + +;; -- H patterns + +;; seq +(tok (1 2 3) ((~seq 1 2) 3)) +(tok (1 2 3) (1 (~seq 2) 3)) +(tok (1 2 3) ((~seq) 1 2 3)) + +;; or +(tok (1 2 3) ((~or (~seq 1 2) 1) 3)) +(tok (1 2 3) ((~or 1 (~seq 1 2)) 3)) +(tok (1 2 3) ((~or (~seq 1) (~seq 1 2)) 3)) +(tok (1 2 3) ((~or (~seq 1) (~seq)) 1 2 3)) +(tok (1 2 3) ((~or (~seq 1) (~seq)) 1 2 3 (~or (~seq 4) (~seq)))) + +;; describe +(tok (1 2 3) ((~describe "one-two" (~seq 1 2)) 3)) +(terx (1 3 3) ((~describe "one-two" (~seq 1 2)) 3) + "one-two") + +;; == Lib tests + +;; == Error tests