commit 5be04ef8fd1f25516fd59d0ee22ea80c5f2cd02f
parent e117e4f919bf524040ff33c2854eec7fadb10567
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Mon, 23 Jan 2017 21:29:42 +0100
Removed all structure definitions from the copy of syntax/parse, and used the ones definied in the official syntax/parse
Diffstat:
23 files changed, 52 insertions(+), 1535 deletions(-)
diff --git a/parse.rkt b/parse.rkt
@@ -12,7 +12,7 @@
(begin-for-syntax
(require racket/contract/base
- stxparse-info/parse/private/residual-ct)
+ syntax/parse/private/residual-ct)
(provide pattern-expander?
(contract-out
[pattern-expander
diff --git a/parse/debug.rkt b/parse/debug.rkt
@@ -2,9 +2,9 @@
(require (for-syntax racket/base
syntax/stx
racket/syntax
- "private/rep-data.rkt"
+ syntax/parse/private/rep-data
"private/rep.rkt"
- "private/kws.rkt")
+ syntax/parse/private/kws)
racket/list
racket/pretty
"../parse.rkt"
@@ -13,7 +13,7 @@
"private/runtime.rkt"
"private/runtime-progress.rkt"
"private/runtime-report.rkt"
- "private/kws.rkt")
+ syntax/parse/private/kws)
;; No lazy loading for this module's dependencies.
diff --git a/parse/experimental/private/substitute.rkt b/parse/experimental/private/substitute.rkt
@@ -1,5 +1,5 @@
#lang racket/base
-(require stxparse-info/parse/private/minimatch
+(require syntax/parse/private/minimatch
racket/private/promise
racket/private/stx) ;; syntax/stx
(provide translate)
diff --git a/parse/experimental/provide.rkt b/parse/experimental/provide.rkt
@@ -4,10 +4,10 @@
syntax/location
(for-syntax racket/base
racket/syntax
- "../private/minimatch.rkt"
+ syntax/parse/private/minimatch
stxparse-info/parse/pre
- stxparse-info/parse/private/residual-ct ;; keep abs. path
- "../private/kws.rkt"
+ syntax/parse/private/residual-ct ;; keep abs. path
+ syntax/parse/private/kws
syntax/contract))
(provide provide-syntax-class/contract
syntax-class/c
diff --git a/parse/experimental/reflect.rkt b/parse/experimental/reflect.rkt
@@ -2,21 +2,21 @@
(require (for-syntax racket/base
racket/lazy-require
racket/syntax
- stxparse-info/parse/private/residual-ct) ;; keep abs.path
+ syntax/parse/private/residual-ct) ;; keep abs.path
racket/contract/base
racket/contract/combinator
- "../private/minimatch.rkt"
+ syntax/parse/private/minimatch
"../private/keywords.rkt"
"../private/runtime-reflect.rkt"
- "../private/kws.rkt")
+ syntax/parse/private/kws)
(begin-for-syntax
(lazy-require
- [stxparse-info/parse/private/rep-data ;; keep abs. path
+ [syntax/parse/private/rep-data ;; keep abs. path
(get-stxclass)]))
;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require)
;; Without this, dependencies don't get collected.
(require racket/runtime-path (for-meta 2 '#%kernel))
-(define-runtime-module-path-index _unused_ 'stxparse-info/parse/private/rep-data)
+(define-runtime-module-path-index _unused_ 'syntax/parse/private/rep-data)
(define-syntax (reify-syntax-class stx)
(if (eq? (syntax-local-context) 'expression)
diff --git a/parse/experimental/specialize.rkt b/parse/experimental/specialize.rkt
@@ -1,8 +1,8 @@
#lang racket/base
(require (for-syntax racket/base
racket/syntax
- "../private/kws.rkt"
- "../private/rep-data.rkt"
+ syntax/parse/private/kws
+ syntax/parse/private/rep-data
"../private/rep.rkt")
"../private/runtime.rkt")
(provide define-syntax-class/specialize)
diff --git a/parse/experimental/splicing.rkt b/parse/experimental/splicing.rkt
@@ -2,18 +2,18 @@
(require (for-syntax racket/base
stxparse-info/parse
racket/lazy-require
- "../private/kws.rkt")
+ syntax/parse/private/kws)
stxparse-info/parse/private/residual) ;; keep abs. path
(provide define-primitive-splicing-syntax-class)
(begin-for-syntax
(lazy-require
- [stxparse-info/parse/private/rep-attrs
+ [syntax/parse/private/rep-attrs
(sort-sattrs)]))
;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require)
;; Without this, dependencies don't get collected.
(require racket/runtime-path (for-meta 2 '#%kernel))
-(define-runtime-module-path-index _unused_ 'stxparse-info/parse/private/rep-attrs)
+(define-runtime-module-path-index _unused_ 'syntax/parse/private/rep-attrs)
(define-syntax (define-primitive-splicing-syntax-class stx)
diff --git a/parse/experimental/template.rkt b/parse/experimental/template.rkt
@@ -2,7 +2,7 @@
(require (for-syntax racket/base
"dset.rkt"
racket/syntax
- stxparse-info/parse/private/minimatch
+ syntax/parse/private/minimatch
racket/private/stx ;; syntax/stx
racket/private/sc
racket/struct)
diff --git a/parse/private/kws.rkt b/parse/private/kws.rkt
@@ -1,175 +0,0 @@
-#lang racket/base
-(provide (struct-out arguments)
- (struct-out arity)
- no-arguments
- no-arity
- to-procedure-arity
- arguments->arity
- check-arity
- check-arity/neg
- check-curry
- join-sep
- kw->string
- diff/sorted/eq)
-
-#|
-An Arguments is
- #s(arguments (listof stx) (listof keyword) (listof stx))
-|#
-(define-struct arguments (pargs kws kwargs) #:prefab)
-
-(define no-arguments (arguments null null null))
-
-#|
-An Arity is
- #s(arity nat nat/+inf.0 (listof keyword) (listof keyword))
-|#
-(define-struct arity (minpos maxpos minkws maxkws)
- #:prefab)
-
-(define no-arity (arity 0 0 null null))
-
-;; ----
-
-(define (to-procedure-arity minpos maxpos)
- (cond [(= minpos maxpos) minpos]
- [(= maxpos +inf.0) (arity-at-least minpos)]
- [else (for/list ([i (in-range minpos (add1 maxpos))]) i)]))
-
-(define (arguments->arity argu)
- (let ([pos (length (arguments-pargs argu))]
- [kws (arguments-kws argu)])
- (arity pos pos kws kws)))
-
-(define (check-arity arity pos-count keywords proc)
- (let ([msg (gen-arity-msg (arity-minpos arity)
- (arity-maxpos arity)
- (arity-minkws arity)
- (arity-maxkws arity)
- pos-count (sort keywords keyword<?))])
- (when msg
- (proc msg))))
-
-(define (check-arity/neg arity pos-count keywords proc)
- (let ([msg (gen-arity-msg/neg (arity-minpos arity)
- (arity-maxpos arity)
- (arity-minkws arity)
- (arity-maxkws arity)
- pos-count (sort keywords keyword<?))])
- (when msg
- (proc msg))))
-
-(define (arity-sat? minpos maxpos minkws maxkws pos-count keywords)
- (and (<= minpos pos-count maxpos)
- (null? (diff/sorted/eq minkws keywords))
- (null? (diff/sorted/eq keywords maxkws))))
-
-(define (gen-arity-msg minpos maxpos minkws maxkws pos-count keywords)
- (if (arity-sat? minpos maxpos minkws maxkws pos-count keywords)
- #f
- (let ([pos-exp (gen-pos-exp-msg minpos maxpos)]
- [minkws-exp (gen-minkws-exp-msg minkws)]
- [optkws-exp (gen-optkws-exp-msg minkws maxkws)]
- [pos-got (gen-pos-got-msg pos-count)]
- [kws-got (gen-kws-got-msg keywords maxkws)])
- (string-append
- "expected "
- (join-sep (filter string? (list pos-exp minkws-exp optkws-exp))
- "," "and")
- "; got "
- (join-sep (filter string? (list pos-got kws-got))
- "," "and")))))
-
-(define (gen-arity-msg/neg minpos maxpos minkws maxkws pos-count keywords)
- (if (arity-sat? minpos maxpos minkws maxkws pos-count keywords)
- #f
- (let ([pos-exp (gen-pos-exp-msg minpos maxpos)]
- [minkws-exp (gen-minkws-exp-msg minkws)]
- [optkws-exp (gen-optkws-exp-msg minkws maxkws)]
- [pos-got (gen-pos-got-msg pos-count)]
- [kws-got (gen-kws-got-msg keywords maxkws)])
- (string-append
- "expected a syntax class that accepts "
- (join-sep (filter string? (list pos-got kws-got))
- "," "and")
- "; got one that accepts "
- (join-sep (filter string? (list pos-exp minkws-exp optkws-exp))
- "," "and")))))
-
-(define (check-curry arity pos-count keywords proc)
- (let ([maxpos (arity-maxpos arity)]
- [maxkws (arity-maxkws arity)])
- (when (> pos-count maxpos)
- (proc (format "too many arguments: expected at most ~s, got ~s"
- maxpos pos-count)))
- (let ([extrakws (diff/sorted/eq keywords maxkws)])
- (when (pair? extrakws)
- (proc (format "syntax class does not accept keyword arguments for ~a"
- (join-sep (map kw->string extrakws) "," "and")))))))
-
-;; ----
-
-(define (gen-pos-exp-msg minpos maxpos)
- (format "~a positional argument~a"
- (cond [(= maxpos minpos) minpos]
- [(= maxpos +inf.0) (format "at least ~a" minpos)]
- [else
- (format "between ~a and ~a" minpos maxpos)])
- (if (= minpos maxpos 1) "" "s")))
-
-(define (gen-minkws-exp-msg minkws)
- (and (pair? minkws)
- (format "~amandatory keyword argument~a for ~a"
- (if (= (length minkws) 1) "a " "")
- (if (= (length minkws) 1) "" "s")
- (join-sep (map kw->string minkws) "," "and"))))
-
-(define (gen-optkws-exp-msg minkws maxkws)
- (let ([optkws (diff/sorted/eq maxkws minkws)])
- (and (pair? optkws)
- (format "~aoptional keyword argument~a for ~a"
- (if (= (length optkws) 1) "an " "")
- (if (= (length optkws) 1) "" "s")
- (join-sep (map kw->string optkws) "," "and")))))
-
-(define (gen-pos-got-msg pos-count)
- (format "~a positional argument~a"
- pos-count (if (= pos-count 1) "" "s")))
-
-(define (gen-kws-got-msg keywords maxkws)
- (cond [(pair? keywords)
- (format "~akeyword argument~a for ~a"
- (if (= (length keywords) 1) "a " "")
- (if (= (length keywords) 1) "" "s")
- (join-sep (map kw->string keywords) "," "and"))]
- [(pair? maxkws) "no keyword arguments"]
- [else #f]))
-
-;; ----
-
-(define (kw->string kw) (format "~a" kw))
-
-(define (diff/sorted/eq xs ys)
- (if (pair? xs)
- (let ([ys* (memq (car xs) ys)])
- (if ys*
- (diff/sorted/eq (cdr xs) (cdr ys*))
- (cons (car xs) (diff/sorted/eq (cdr xs) ys))))
- null))
-
-(define (join-sep items sep0 ult0 [prefix ""])
- (define sep (string-append sep0 " "))
- (define ult (string-append ult0 " "))
- (define (loop items)
- (cond [(null? items)
- null]
- [(null? (cdr items))
- (list sep ult (car items))]
- [else
- (list* sep (car items) (loop (cdr items)))]))
- (case (length items)
- [(0) #f]
- [(1) (string-append prefix (car items))]
- [(2) (format "~a~a ~a~a" prefix (car items) ult (cadr items))]
- [else (let ([strings (list* (car items) (loop (cdr items)))])
- (apply string-append prefix strings))]))
diff --git a/parse/private/litconv.rkt b/parse/private/litconv.rkt
@@ -3,9 +3,9 @@
racket/lazy-require
"sc.rkt"
"lib.rkt"
- "kws.rkt"
+ syntax/parse/private/kws
racket/syntax)
- stxparse-info/parse/private/residual-ct ;; keep abs. path
+ syntax/parse/private/residual-ct ;; keep abs. path
stxparse-info/parse/private/residual) ;; keep abs. path
(begin-for-syntax
(lazy-require
diff --git a/parse/private/minimatch.rkt b/parse/private/minimatch.rkt
@@ -1,105 +0,0 @@
-#lang racket/base
-(require (for-syntax racket/base racket/struct-info))
-(provide match ?)
-
-(define-syntax (match stx)
- (syntax-case stx ()
- [(match e clause ...)
- #`(let ([x e])
- (match-c x
- clause ...
- [_ (error 'minimatch "match at ~s:~s:~s failed: ~e"
- '#,(syntax-source stx)
- '#,(syntax-line stx)
- '#,(syntax-column stx)
- x)]))]))
-
-(define-syntax match-c
- (syntax-rules ()
- [(match-c x)
- (error 'minimatch)]
- [(match-c x [pattern result ...] clause ...)
- (let ([fail (lambda () (match-c x clause ...))])
- (match-p x pattern (let () result ...) (fail)))]))
-
-;; (match-p id Pattern SuccessExpr FailureExpr)
-(define-syntax (match-p stx)
- (syntax-case stx (quote cons list vector STRUCT ?)
- [(match-p x wildcard success failure)
- (and (identifier? #'wildcard) (free-identifier=? #'wildcard #'_))
- #'success]
- [(match-p x (quote lit) success failure)
- #'(if (equal? x (quote lit))
- success
- failure)]
- [(match-p x (cons p1 p2) success failure)
- #'(if (pair? x)
- (let ([x1 (car x)]
- [x2 (cdr x)])
- (match-p x1 p1 (match-p x2 p2 success failure) failure))
- failure)]
- [(match-p x (list) success failure)
- #'(match-p x (quote ()) success failure)]
- [(match-p x (list p1 p ...) success failure)
- #'(match-p x (cons p1 (list p ...)) success failure)]
- [(match-p x (vector p ...) success failure)
- #'(if (and (vector? x) (= (vector-length x) (length '(p ...))))
- (let ([x* (vector->list x)])
- (match-p x* (list p ...) success failure))
- failure)]
- [(match-p x var success failure)
- (identifier? #'var)
- #'(let ([var x]) success)]
- [(match-p x (STRUCT S (p ...)) success failure)
- (identifier? #'S)
- (let ()
- (define (not-a-struct)
- (raise-syntax-error #f "expected struct name" #'S))
- (define si (syntax-local-value #'S not-a-struct))
- (unless (struct-info? si)
- (not-a-struct))
- (let* ([si (extract-struct-info si)]
- [predicate (list-ref si 2)]
- [accessors (reverse (list-ref si 3))])
- (unless (andmap identifier? accessors)
- (raise-syntax-error #f "struct has incomplete information" #'S))
- (with-syntax ([predicate predicate]
- [(accessor ...) accessors])
- #'(if (predicate x)
- (let ([y (list (accessor x) ...)])
- (match-p y (list p ...) success failure))
- failure))))]
- [(match-p x (? predicate pat ...) success failure)
- #'(if (predicate x)
- (match-p* ((x pat) ...) success failure)
- failure)]
- [(match-p x (S p ...) success failure)
- (identifier? #'S)
- (if (struct-info? (syntax-local-value #'S (lambda () #f)))
- #'(match-p x (STRUCT S (p ...)) success failure)
- (raise-syntax-error #f "bad minimatch form" stx #'S))]
- [(match-p x s success failure)
- (prefab-struct-key (syntax-e #'s))
- (with-syntax ([key (prefab-struct-key (syntax-e #'s))]
- [(p ...) (cdr (vector->list (struct->vector (syntax-e #'s))))])
- #'(let ([xkey (prefab-struct-key x)])
- (if (equal? xkey 'key)
- (let ([xps (cdr (vector->list (struct->vector x)))])
- (match-p xps (list p ...) success failure))
- failure)))]
- [(match-p x pattern success failure)
- (raise-syntax-error 'minimatch "bad pattern" #'pattern)]
- ))
-
-(define-syntax match-p*
- (syntax-rules ()
- [(match-p* () success failure)
- success]
- [(match-p* ((x1 p1) . rest) success failure)
- (match-p x1 p1 (match-p* rest success failure) failure)]))
-
-(define-syntax ?
- (lambda (stx)
- (raise-syntax-error #f "illegal use of minimatch form '?'" stx)))
-
-(define-syntax STRUCT #f) ;; internal keyword
diff --git a/parse/private/opt.rkt b/parse/private/opt.rkt
@@ -1,10 +1,10 @@
#lang racket/base
(require racket/syntax
racket/pretty
- stxparse-info/parse/private/residual-ct ;; keep abs. path
- "minimatch.rkt"
- "rep-patterns.rkt"
- "kws.rkt")
+ syntax/parse/private/residual-ct ;; keep abs. path
+ syntax/parse/private/minimatch
+ syntax/parse/private/rep-patterns
+ syntax/parse/private/kws)
(provide (struct-out pk1)
(rename-out [optimize-matrix0 optimize-matrix]))
diff --git a/parse/private/parse.rkt b/parse/private/parse.rkt
@@ -4,12 +4,12 @@
syntax/private/id-table
syntax/keyword
racket/syntax
- "minimatch.rkt"
- "rep-attrs.rkt"
- "rep-data.rkt"
- "rep-patterns.rkt"
+ syntax/parse/private/minimatch
+ syntax/parse/private/rep-attrs
+ syntax/parse/private/rep-data
+ syntax/parse/private/rep-patterns
"rep.rkt"
- "kws.rkt"
+ syntax/parse/private/kws
"opt.rkt"
"txlift.rkt")
"keywords.rkt"
diff --git a/parse/private/rep-attrs.rkt b/parse/private/rep-attrs.rkt
@@ -1,194 +0,0 @@
-#lang racket/base
-(require stxparse-info/parse/private/residual-ct ;; keep abs. path
- racket/contract/base
- syntax/private/id-table
- racket/syntax
- "make.rkt")
-
-#|
-An IAttr is (make-attr identifier number boolean)
-An SAttr is (make-attr symbol number boolean)
-
-The number is the ellipsis nesting depth. The boolean is true iff the
-attr is guaranteed to be bound to a value which is a syntax object (or
-a list^depth of syntax objects).
-|#
-
-#|
-SAttr lists are always stored in sorted order, to make comparison
-of signatures easier for reified syntax-classes.
-|#
-
-(define (iattr? a)
- (and (attr? a) (identifier? (attr-name a))))
-
-(define (sattr? a)
- (and (attr? a) (symbol? (attr-name a))))
-
-;; increase-depth : Attr -> Attr
-(define (increase-depth x)
- (make attr (attr-name x) (add1 (attr-depth x)) (attr-syntax? x)))
-
-(provide/contract
- [iattr? (any/c . -> . boolean?)]
- [sattr? (any/c . -> . boolean?)]
-
- [increase-depth
- (-> attr? attr?)]
- [attr-make-uncertain
- (-> attr? attr?)]
-
- ;; IAttr operations
- [append-iattrs
- (-> (listof (listof iattr?))
- (listof iattr?))]
- [union-iattrs
- (-> (listof (listof iattr?))
- (listof iattr?))]
- [reorder-iattrs
- (-> (listof sattr?) (listof iattr?)
- (listof iattr?))]
-
- ;; SAttr operations
- [iattr->sattr
- (-> iattr?
- sattr?)]
- [iattrs->sattrs
- (-> (listof iattr?)
- (listof sattr?))]
- [sort-sattrs
- (-> (listof sattr?)
- (listof sattr?))]
-
- [intersect-sattrss
- (-> (listof (listof sattr?))
- (listof sattr?))]
-
- [check-iattrs-subset
- (-> (listof iattr?)
- (listof iattr?)
- (or/c syntax? false/c)
- any)])
-
-;; IAttr operations
-
-;; append-iattrs : (listof (listof IAttr)) -> (listof IAttr)
-(define (append-iattrs attrss)
- (let* ([all (apply append attrss)]
- [names (map attr-name all)]
- [dup (check-duplicate-identifier names)])
- (when dup
- (wrong-syntax dup "duplicate attribute"))
- all))
-
-;; union-iattrs : (listof (listof IAttr)) -> (listof IAttr)
-(define (union-iattrs attrss)
- (define count-t (make-bound-id-table))
- (define attr-t (make-bound-id-table))
- (define list-count (length attrss))
- (define attr-keys null)
- (for* ([attrs (in-list attrss)] [attr (in-list attrs)])
- (define name (attr-name attr))
- (define prev (bound-id-table-ref attr-t name #f))
- (unless prev (set! attr-keys (cons name attr-keys)))
- (bound-id-table-set! attr-t name (join-attrs attr prev))
- (let ([pc (bound-id-table-ref count-t name 0)])
- (bound-id-table-set! count-t name (add1 pc))))
- (for/list ([k (in-list attr-keys)])
- (define a (bound-id-table-ref attr-t k))
- (if (= (bound-id-table-ref count-t (attr-name a)) list-count)
- a
- (attr-make-uncertain a))))
-
-;; join-attrs : Attr Attr/#f -> Attr
-;; Works with both IAttrs and SAttrs.
-;; Assumes attrs have same name.
-(define (join-attrs a b)
- (if (and a b)
- (proper-join-attrs a b)
- (or a b)))
-
-(define (proper-join-attrs a b)
- (let ([aname (attr-name a)])
- (unless (equal? (attr-depth a) (attr-depth b))
- (wrong-syntax (and (syntax? aname) aname)
- "attribute '~a' occurs with different nesting depth"
- (if (syntax? aname) (syntax-e aname) aname)))
- (make attr aname (attr-depth a) (and (attr-syntax? a) (attr-syntax? b)))))
-
-(define (attr-make-uncertain a)
- (make attr (attr-name a) (attr-depth a) #f))
-
-(define (iattr->sattr a)
- (let ([name (attr-name a)]
- [depth (attr-depth a)]
- [syntax? (attr-syntax? a)])
- (make attr (syntax-e name) depth syntax?)))
-
-(define (iattrs->sattrs as)
- (sort-sattrs (map iattr->sattr as)))
-
-(define (sort-sattrs as)
- (sort as string<?
- #:key (lambda (a) (symbol->string (attr-name a)))
- #:cache-keys? #t))
-
-;; intersect-sattrss : (listof (listof SAttr)) -> (listof SAttr)
-;; FIXME: rely on sorted inputs, simplify algorithm and avoid second sort?
-(define (intersect-sattrss attrss)
- (cond [(null? attrss) null]
- [else
- (let* ([namess (map (lambda (attrs) (map attr-name attrs)) attrss)]
- [names (filter (lambda (s)
- (andmap (lambda (names) (memq s names))
- (cdr namess)))
- (car namess))]
- [ht (make-hasheq)]
- [put (lambda (attr) (hash-set! ht (attr-name attr) attr))]
- [fetch-like (lambda (attr) (hash-ref ht (attr-name attr) #f))])
- (for* ([attrs (in-list attrss)]
- [attr (in-list attrs)]
- #:when (memq (attr-name attr) names))
- (put (join-attrs attr (fetch-like attr))))
- (sort-sattrs (hash-map ht (lambda (k v) v))))]))
-
-;; reorder-iattrs : (listof SAttr) (listof IAttr) -> (listof IAttr)
-;; Reorders iattrs (and restricts) based on relsattrs
-;; If a relsattr is not found, or if depth or contents mismatches, raises error.
-(define (reorder-iattrs relsattrs iattrs)
- (let ([ht (make-hasheq)])
- (for ([iattr (in-list iattrs)])
- (let ([remap-name (syntax-e (attr-name iattr))])
- (hash-set! ht remap-name iattr)))
- (let loop ([relsattrs relsattrs])
- (if (null? relsattrs)
- null
- (let ([sattr (car relsattrs)]
- [rest (cdr relsattrs)])
- (let ([iattr (hash-ref ht (attr-name sattr) #f)])
- (check-iattr-satisfies-sattr iattr sattr)
- (cons iattr (loop rest))))))))
-
-(define (check-iattr-satisfies-sattr iattr sattr)
- (unless iattr
- (wrong-syntax #f "required attribute is not defined: ~s" (attr-name sattr)))
- (unless (= (attr-depth iattr) (attr-depth sattr))
- (wrong-syntax (attr-name iattr)
- "attribute has wrong depth (expected ~s, found ~s)"
- (attr-depth sattr) (attr-depth iattr)))
- (when (and (attr-syntax? sattr) (not (attr-syntax? iattr)))
- (wrong-syntax (attr-name iattr)
- "attribute may not be bound to syntax: ~s"
- (attr-name sattr))))
-
-;; check-iattrs-subset : (listof IAttr) (listof IAttr) stx -> void
-(define (check-iattrs-subset little big ctx)
- (define big-t (make-bound-id-table))
- (for ([a (in-list big)])
- (bound-id-table-set! big-t (attr-name a) #t))
- (for ([a (in-list little)])
- (unless (bound-id-table-ref big-t (attr-name a) #f)
- (raise-syntax-error #f
- "attribute bound in defaults but not in pattern"
- ctx
- (attr-name a)))))
diff --git a/parse/private/rep-data.rkt b/parse/private/rep-data.rkt
@@ -1,303 +0,0 @@
-#lang racket/base
-(require racket/contract/base
- racket/dict
- syntax/private/id-table
- racket/syntax
- stxparse-info/parse/private/residual-ct ;; keep abs. path
- "minimatch.rkt"
- "kws.rkt")
-;; from residual.rkt
-(provide (struct-out stxclass)
- (struct-out conventions)
- (struct-out literalset)
- (struct-out eh-alternative-set)
- (struct-out eh-alternative))
-;; from here
-(provide stxclass/s?
- stxclass/h?
- (struct-out rhs)
- (struct-out variant))
-
-(define (stxclass/s? x)
- (and (stxclass? x) (not (stxclass-splicing? x))))
-(define (stxclass/h? x)
- (and (stxclass? x) (stxclass-splicing? x)))
-
-;; An RHS is #s(rhs SAttrs Bool Stx/#f Variants Stxs Bool Bool)
-(define-struct rhs
- (attrs ;; (Listof Sattr)
- transparent? ;; Bool
- description ;; Syntax/#f
- variants ;; (Listof Variant)
- definitions ;; (Listof Stx), aux definitions from txlifts, local conventions?, etc
- commit? ;; Bool
- delimit-cut? ;; Bool
- ) #:prefab)
-
-;; A Variant is (variant Stx SAttrs Pattern Stxs)
-(define-struct variant
- (ostx ;; Stx
- attrs ;; (Listof SAttr)
- pattern ;; Pattern
- definitions ;; (Listof Stx)
- ) #:prefab)
-
-;; make-dummy-stxclass : identifier -> SC
-;; Dummy stxclass for calculating attributes of recursive stxclasses.
-(define (make-dummy-stxclass name)
- (stxclass (syntax-e name) #f null #f #f (scopts 0 #t #t #f) #f))
-
-;; Environments
-
-#|
-DeclEnv =
- (make-declenv immutable-bound-id-mapping[id => DeclEntry]
- (listof ConventionRule))
-
-DeclEntry =
-- (den:lit Id Id Stx Stx)
-- (den:datum-lit Id Symbol)
-- (den:class Id Id Arguments)
-- (den:magic-class Id Id Arguments Stx)
-- (den:parser Id (Listof SAttr) Bool scopts)
-- (den:delayed Id Id)
-
-Arguments is defined in rep-patterns.rkt
-
-A DeclEnv is built up in stages:
- 1) syntax-parse (or define-syntax-class) directives
- #:literals -> den:lit
- #:datum-literals -> den:datum-lit
- #:local-conventions -> den:class
- #:conventions -> den:delayed
- #:literal-sets -> den:lit
- 2) pattern directives
- #:declare -> den:magic-class
- 3) create-aux-def creates aux parser defs
- den:class -> den:parser or den:delayed
-
-== Scoping ==
-
-A #:declare directive results in a den:magic-class entry, which
-indicates that the pattern variable's syntax class arguments (if any)
-have "magical scoping": they are evaluated in the scope where the
-pattern variable occurs. If the variable occurs multiple times, the
-expressions are duplicated, and may be evaluated in different scopes.
-|#
-
-(define-struct declenv (table conventions))
-
-(define-struct den:class (name class argu))
-(define-struct den:magic-class (name class argu role))
-(define-struct den:parser (parser attrs splicing? opts))
-;; and from residual.rkt:
-;; (define-struct den:lit (internal external input-phase lit-phase))
-;; (define-struct den:datum-lit (internal external))
-;; (define-struct den:delayed (parser class))
-
-(define (new-declenv literals #:conventions [conventions null])
- (let* ([table (make-immutable-bound-id-table)]
- [table (for/fold ([table table]) ([literal (in-list literals)])
- (let ([id (cond [(den:lit? literal) (den:lit-internal literal)]
- [(den:datum-lit? literal) (den:datum-lit-internal literal)])])
- ;;(eprintf ">> added ~e\n" id)
- (bound-id-table-set table id literal)))])
- (make-declenv table conventions)))
-
-(define (declenv-lookup env id)
- (bound-id-table-ref (declenv-table env) id #f))
-
-(define (declenv-apply-conventions env id)
- (conventions-lookup (declenv-conventions env) id))
-
-(define (declenv-check-unbound env id [stxclass-name #f]
- #:blame-declare? [blame-declare? #f])
- ;; Order goes: literals, pattern, declares
- ;; So blame-declare? only applies to stxclass declares
- (let ([val (declenv-lookup env id)])
- (match val
- [(den:lit _i _e _ip _lp)
- (wrong-syntax id "identifier previously declared as literal")]
- [(den:datum-lit _i _e)
- (wrong-syntax id "identifier previously declared as literal")]
- [(den:magic-class name _c _a _r)
- (if (and blame-declare? stxclass-name)
- (wrong-syntax name
- "identifier previously declared with syntax class ~a"
- stxclass-name)
- (wrong-syntax (if blame-declare? name id)
- "identifier previously declared"))]
- [(den:class name _c _a)
- (if (and blame-declare? stxclass-name)
- (wrong-syntax name
- "identifier previously declared with syntax class ~a"
- stxclass-name)
- (wrong-syntax (if blame-declare? name id)
- "identifier previously declared"))]
- [(den:parser _p _a _sp _opts)
- (wrong-syntax id "(internal error) late unbound check")]
- ['#f (void)])))
-
-(define (declenv-put-stxclass env id stxclass-name argu [role #f])
- (declenv-check-unbound env id)
- (make-declenv
- (bound-id-table-set (declenv-table env) id
- (den:magic-class id stxclass-name argu role))
- (declenv-conventions env)))
-
-;; declenv-update/fold : DeclEnv (Id/Regexp DeclEntry a -> DeclEntry a) a
-;; -> (values DeclEnv a)
-(define (declenv-update/fold env0 f acc0)
- (define-values (acc1 rules1)
- (for/fold ([acc acc0] [newrules null])
- ([rule (in-list (declenv-conventions env0))])
- (let-values ([(val acc) (f (car rule) (cadr rule) acc)])
- (values acc (cons (list (car rule) val) newrules)))))
- (define-values (acc2 table2)
- (for/fold ([acc acc1] [table (make-immutable-bound-id-table)])
- ([(k v) (in-dict (declenv-table env0))])
- (let-values ([(val acc) (f k v acc)])
- (values acc (bound-id-table-set table k val)))))
- (values (make-declenv table2 (reverse rules1))
- acc2))
-
-;; returns ids in domain of env but not in given list
-(define (declenv-domain-difference env ids)
- (define idbm (make-bound-id-table))
- (for ([id (in-list ids)]) (bound-id-table-set! idbm id #t))
- (for/list ([(k v) (in-dict (declenv-table env))]
- #:when (or (den:class? v) (den:magic-class? v) (den:parser? v))
- #:unless (bound-id-table-ref idbm k #f))
- k))
-
-;; Conventions = (listof (list regexp DeclEntry))
-
-(define (conventions-lookup conventions id)
- (let ([sym (symbol->string (syntax-e id))])
- (for/or ([c (in-list conventions)])
- (and (regexp-match? (car c) sym) (cadr c)))))
-
-;; Contracts
-
-(define DeclEnv/c declenv?)
-
-(define DeclEntry/c
- (or/c den:lit? den:datum-lit? den:class? den:magic-class? den:parser? den:delayed?))
-
-(provide (struct-out den:class)
- (struct-out den:magic-class)
- (struct-out den:parser)
- ;; from residual.rkt:
- (struct-out den:lit)
- (struct-out den:datum-lit)
- (struct-out den:delayed))
-
-(provide/contract
- [DeclEnv/c contract?]
- [DeclEntry/c contract?]
-
- [make-dummy-stxclass (-> identifier? stxclass?)]
- [stxclass-lookup-config (parameter/c (symbols 'no 'try 'yes))]
- [stxclass-colon-notation? (parameter/c boolean?)]
-
- [new-declenv
- (->* [(listof (or/c den:lit? den:datum-lit?))]
- [#:conventions list?]
- DeclEnv/c)]
- [declenv-lookup
- (-> DeclEnv/c identifier? any)]
- [declenv-apply-conventions
- (-> DeclEnv/c identifier? any)]
- [declenv-put-stxclass
- (-> DeclEnv/c identifier? identifier? arguments? (or/c syntax? #f)
- DeclEnv/c)]
- [declenv-domain-difference
- (-> DeclEnv/c (listof identifier?)
- (listof identifier?))]
- [declenv-update/fold
- (-> DeclEnv/c
- (-> (or/c identifier? regexp?) DeclEntry/c any/c (values DeclEntry/c any/c))
- any/c
- (values DeclEnv/c any/c))]
-
- [get-stxclass
- (-> identifier? stxclass?)]
- [get-stxclass/check-arity
- (-> identifier? syntax? exact-nonnegative-integer? (listof keyword?)
- stxclass?)]
- [split-id/get-stxclass
- (-> identifier? DeclEnv/c
- (values identifier? (or/c stxclass? den:lit? den:datum-lit? #f)))])
-
-;; stxclass-lookup-config : (parameterof (U 'no 'try 'yes))
-;; 'no means don't lookup, always use dummy (no nested attrs)
-;; 'try means lookup, but on failure use dummy (-> nested attrs only from prev.)
-;; 'yes means lookup, raise error on failure
-(define stxclass-lookup-config (make-parameter 'yes))
-
-;; stxclass-colon-notation? : (parameterof boolean)
-;; if #t, then x:sc notation means (~var x sc)
-;; otherwise, just a var
-(define stxclass-colon-notation? (make-parameter #t))
-
-(define (get-stxclass id)
- (define config (stxclass-lookup-config))
- (if (eq? config 'no)
- (make-dummy-stxclass id)
- (cond [(syntax-local-value/record id stxclass?) => values]
- [(eq? config 'try)
- (make-dummy-stxclass id)]
- [else (wrong-syntax id "not defined as syntax class")])))
-
-(define (get-stxclass/check-arity id stx pos-count keywords)
- (let ([sc (get-stxclass id)])
- (unless (memq (stxclass-lookup-config) '(try no))
- (check-arity (stxclass-arity sc) pos-count keywords
- (lambda (msg)
- (raise-syntax-error #f msg stx))))
- sc))
-
-(define (split-id/get-stxclass id0 decls)
- (cond [(and (stxclass-colon-notation?)
- (regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id0))))
- => (lambda (m)
- (define-values [src ln col pos span]
- (syntax-srcloc-values id0))
- (define id-str (cadr m))
- (define id-len (string-length id-str))
- (define suffix-str (caddr m))
- (define suffix-len (string-length suffix-str))
- (define id
- (datum->syntax id0 (string->symbol id-str)
- (list src ln col pos id-len)
- id0))
- (define suffix
- (datum->syntax id0 (string->symbol suffix-str)
- (list src ln (and col (+ col id-len 1)) (and pos (+ pos id-len 1)) suffix-len)
- id0))
- (declenv-check-unbound decls id (syntax-e suffix)
- #:blame-declare? #t)
- (let ([suffix-entry (declenv-lookup decls suffix)])
- (cond [(or (den:lit? suffix-entry) (den:datum-lit? suffix-entry))
- (values id suffix-entry)]
- [else
- (let ([sc (get-stxclass/check-arity suffix id0 0 null)])
- (values id sc))])))]
- [else (values id0 #f)]))
-
-(define (syntax-srcloc-values stx)
- (values (syntax-source stx)
- (syntax-line stx)
- (syntax-column stx)
- (syntax-position stx)
- (syntax-span stx)))
-
-;; ----
-
-(provide get-eh-alternative-set)
-
-(define (get-eh-alternative-set id)
- (let ([v (syntax-local-value id (lambda () #f))])
- (unless (eh-alternative-set? v)
- (wrong-syntax id "not defined as an eh-alternative-set"))
- v))
diff --git a/parse/private/rep-patterns.rkt b/parse/private/rep-patterns.rkt
@@ -1,616 +0,0 @@
-#lang racket/base
-(require stxparse-info/parse/private/residual-ct ;; keep abs. path
- "rep-attrs.rkt"
- "minimatch.rkt"
- racket/syntax)
-(provide (all-defined-out))
-
-#|
-Uses Arguments from kws.rkt
-|#
-
-#|
-A SinglePattern is one of
- (pat:any)
- (pat:svar id) -- "simple" var, no stxclass
- (pat:var/p Id Id Arguments (Listof IAttr) Stx scopts) -- var with parser
- (pat:literal identifier Stx Stx)
- (pat:datum datum)
- (pat:action ActionPattern SinglePattern)
- (pat:head HeadPattern SinglePattern)
- (pat:dots (listof EllipsisHeadPattern) SinglePattern)
- (pat:and (listof SinglePattern))
- (pat:or (listof IAttr) (listof SinglePattern) (listof (listof IAttr)))
- (pat:not SinglePattern)
- (pat:pair SinglePattern SinglePattern)
- (pat:vector SinglePattern)
- (pat:box SinglePattern)
- (pat:pstruct key SinglePattern)
- (pat:describe SinglePattern stx boolean stx)
- (pat:delimit SinglePattern)
- (pat:commit SinglePattern)
- (pat:reflect stx Arguments (listof SAttr) id (listof IAttr))
- (pat:ord SinglePattern UninternedSymbol Nat)
- (pat:post SinglePattern)
- (pat:integrated id/#f id string stx)
-
-A ListPattern is a subtype of SinglePattern; one of
- (pat:datum '())
- (pat:action ActionPattern ListPattern)
- (pat:head HeadPattern ListPattern)
- (pat:pair SinglePattern ListPattern)
- (pat:dots EllipsisHeadPattern ListPattern)
-|#
-
-(define-struct pat:any () #:prefab)
-(define-struct pat:svar (name) #:prefab)
-(define-struct pat:var/p (name parser argu nested-attrs role opts) #:prefab)
-(define-struct pat:literal (id input-phase lit-phase) #:prefab)
-(define-struct pat:datum (datum) #:prefab)
-(define-struct pat:action (action inner) #:prefab)
-(define-struct pat:head (head tail) #:prefab)
-(define-struct pat:dots (heads tail) #:prefab)
-(define-struct pat:and (patterns) #:prefab)
-(define-struct pat:or (attrs patterns attrss) #:prefab)
-(define-struct pat:not (pattern) #:prefab)
-(define-struct pat:pair (head tail) #:prefab)
-(define-struct pat:vector (pattern) #:prefab)
-(define-struct pat:box (pattern) #:prefab)
-(define-struct pat:pstruct (key pattern) #:prefab)
-(define-struct pat:describe (pattern description transparent? role) #:prefab)
-(define-struct pat:delimit (pattern) #:prefab)
-(define-struct pat:commit (pattern) #:prefab)
-(define-struct pat:reflect (obj argu attr-decls name nested-attrs) #:prefab)
-(define-struct pat:ord (pattern group index) #:prefab)
-(define-struct pat:post (pattern) #:prefab)
-(define-struct pat:integrated (name predicate description role) #:prefab)
-
-#|
-A ActionPattern is one of
- (action:cut)
- (action:fail stx stx)
- (action:bind IAttr Stx)
- (action:and (listof ActionPattern))
- (action:parse SinglePattern stx)
- (action:do (listof stx))
- (action:ord ActionPattern UninternedSymbol Nat)
- (action:post ActionPattern)
-
-A BindAction is (action:bind IAttr Stx)
-A SideClause is just an ActionPattern
-|#
-
-(define-struct action:cut () #:prefab)
-(define-struct action:fail (when message) #:prefab)
-(define-struct action:bind (attr expr) #:prefab)
-(define-struct action:and (patterns) #:prefab)
-(define-struct action:parse (pattern expr) #:prefab)
-(define-struct action:do (stmts) #:prefab)
-(define-struct action:ord (pattern group index) #:prefab)
-(define-struct action:post (pattern) #:prefab)
-
-#|
-A HeadPattern is one of
- (hpat:var/p Id Id Arguments (Listof IAttr) Stx scopts)
- (hpat:seq ListPattern)
- (hpat:action ActionPattern HeadPattern)
- (hpat:and HeadPattern SinglePattern)
- (hpat:or (listof IAttr) (listof HeadPattern) (listof (listof IAttr)))
- (hpat:describe HeadPattern stx/#f boolean stx)
- (hpat:delimit HeadPattern)
- (hpat:commit HeadPattern)
- (hpat:reflect stx Arguments (listof SAttr) id (listof IAttr))
- (hpat:ord HeadPattern UninternedSymbol Nat)
- (hpat:post HeadPattern)
- (hpat:peek HeadPattern)
- (hpat:peek-not HeadPattern)
-|#
-
-(define-struct hpat:var/p (name parser argu nested-attrs role scopts) #:prefab)
-(define-struct hpat:seq (inner) #:prefab)
-(define-struct hpat:action (action inner) #:prefab)
-(define-struct hpat:and (head single) #:prefab)
-(define-struct hpat:or (attrs patterns attrss) #:prefab)
-(define-struct hpat:describe (pattern description transparent? role) #:prefab)
-(define-struct hpat:delimit (pattern) #:prefab)
-(define-struct hpat:commit (pattern) #:prefab)
-(define-struct hpat:reflect (obj argu attr-decls name nested-attrs) #:prefab)
-(define-struct hpat:ord (pattern group index) #:prefab)
-(define-struct hpat:post (pattern) #:prefab)
-(define-struct hpat:peek (pattern) #:prefab)
-(define-struct hpat:peek-not (pattern) #:prefab)
-
-#|
-An EllipsisHeadPattern is
- (ehpat (Listof IAttr) HeadPattern RepConstraint Boolean)
-
-A RepConstraint is one of
- (rep:once stx stx stx)
- (rep:optional stx stx (listof BindAction))
- (rep:bounds nat posint/+inf.0 stx stx stx)
- #f
-|#
-
-(define-struct ehpat (attrs head repc check-null?) #:prefab)
-(define-struct rep:once (name under-message over-message) #:prefab)
-(define-struct rep:optional (name over-message defaults) #:prefab)
-(define-struct rep:bounds (min max name under-message over-message) #:prefab)
-
-(define (pattern? x)
- (or (pat:any? x)
- (pat:svar? x)
- (pat:var/p? x)
- (pat:literal? x)
- (pat:datum? x)
- (pat:action? x)
- (pat:head? x)
- (pat:dots? x)
- (pat:and? x)
- (pat:or? x)
- (pat:not? x)
- (pat:pair? x)
- (pat:vector? x)
- (pat:box? x)
- (pat:pstruct? x)
- (pat:describe? x)
- (pat:delimit? x)
- (pat:commit? x)
- (pat:reflect? x)
- (pat:ord? x)
- (pat:post? x)
- (pat:integrated? x)))
-
-(define (action-pattern? x)
- (or (action:cut? x)
- (action:bind? x)
- (action:fail? x)
- (action:and? x)
- (action:parse? x)
- (action:do? x)
- (action:ord? x)
- (action:post? x)))
-
-(define (head-pattern? x)
- (or (hpat:var/p? x)
- (hpat:seq? x)
- (hpat:action? x)
- (hpat:and? x)
- (hpat:or? x)
- (hpat:describe? x)
- (hpat:delimit? x)
- (hpat:commit? x)
- (hpat:reflect? x)
- (hpat:ord? x)
- (hpat:post? x)
- (hpat:peek? x)
- (hpat:peek-not? x)))
-
-(define (ellipsis-head-pattern? x)
- (ehpat? x))
-
-(define single-pattern? pattern?)
-
-(define (single-or-head-pattern? x)
- (or (single-pattern? x)
- (head-pattern? x)))
-
-;; check-pattern : *Pattern -> *Pattern
-;; Does attr computation to catch errors, but returns same pattern.
-(define (check-pattern p)
- (void (pattern-attrs p))
- p)
-
-;; pattern-attrs-table : Hasheq[*Pattern => (Listof IAttr)]
-(define pattern-attrs-table (make-weak-hasheq))
-
-;; pattern-attrs : *Pattern -> (Listof IAttr)
-(define (pattern-attrs p)
- (hash-ref! pattern-attrs-table p (lambda () (pattern-attrs* p))))
-
-(define (pattern-attrs* p)
- (match p
- ;; -- S patterns
- [(pat:any)
- null]
- [(pat:svar name)
- (list (attr name 0 #t))]
- [(pat:var/p name _ _ nested-attrs _ _)
- (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
- [(pat:reflect _ _ _ name nested-attrs)
- (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
- [(pat:datum _)
- null]
- [(pat:literal _ _ _)
- null]
- [(pat:action a sp)
- (append-iattrs (map pattern-attrs (list a sp)))]
- [(pat:head headp tailp)
- (append-iattrs (map pattern-attrs (list headp tailp)))]
- [(pat:pair headp tailp)
- (append-iattrs (map pattern-attrs (list headp tailp)))]
- [(pat:vector sp)
- (pattern-attrs sp)]
- [(pat:box sp)
- (pattern-attrs sp)]
- [(pat:pstruct key sp)
- (pattern-attrs sp)]
- [(pat:describe sp _ _ _)
- (pattern-attrs sp)]
- [(pat:and ps)
- (append-iattrs (map pattern-attrs ps))]
- [(pat:or _ ps _)
- (union-iattrs (map pattern-attrs ps))]
- [(pat:not _)
- null]
- [(pat:dots headps tailp)
- (append-iattrs (map pattern-attrs (append headps (list tailp))))]
- [(pat:delimit sp)
- (pattern-attrs sp)]
- [(pat:commit sp)
- (pattern-attrs sp)]
- [(pat:ord sp _ _)
- (pattern-attrs sp)]
- [(pat:post sp)
- (pattern-attrs sp)]
- [(pat:integrated name _ _ _)
- (if name (list (attr name 0 #t)) null)]
-
- ;; -- A patterns
- [(action:cut)
- null]
- [(action:fail _ _)
- null]
- [(action:bind attr expr)
- (list attr)]
- [(action:and ps)
- (append-iattrs (map pattern-attrs ps))]
- [(action:parse sp _)
- (pattern-attrs sp)]
- [(action:do _)
- null]
- [(action:ord sp _ _)
- (pattern-attrs sp)]
- [(action:post sp)
- (pattern-attrs sp)]
-
- ;; -- H patterns
- [(hpat:var/p name _ _ nested-attrs _ _)
- (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
- [(hpat:reflect _ _ _ name nested-attrs)
- (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
- [(hpat:seq lp)
- (pattern-attrs lp)]
- [(hpat:action a hp)
- (append-iattrs (map pattern-attrs (list a hp)))]
- [(hpat:describe hp _ _ _)
- (pattern-attrs hp)]
- [(hpat:and hp sp)
- (append-iattrs (map pattern-attrs (list hp sp)))]
- [(hpat:or _ ps _)
- (union-iattrs (map pattern-attrs ps))]
- [(hpat:delimit hp)
- (pattern-attrs hp)]
- [(hpat:commit hp)
- (pattern-attrs hp)]
- [(hpat:ord hp _ _)
- (pattern-attrs hp)]
- [(hpat:post hp)
- (pattern-attrs hp)]
- [(hpat:peek hp)
- (pattern-attrs hp)]
- [(hpat:peek-not hp)
- null]
-
- ;; EH patterns
- [(ehpat iattrs _ _ _)
- iattrs]
- ))
-
-;; ----
-
-;; pattern-has-cut? : *Pattern -> Boolean
-;; Returns #t if p *might* cut (~!, not within ~delimit-cut).
-(define (pattern-has-cut? p)
- (match p
- ;; -- S patterns
- [(pat:any) #f]
- [(pat:svar name) #f]
- [(pat:var/p _ _ _ _ _ opts) (not (scopts-delimit-cut? opts))]
- [(pat:reflect _ _ _ name nested-attrs) #f]
- [(pat:datum _) #f]
- [(pat:literal _ _ _) #f]
- [(pat:action a sp) (or (pattern-has-cut? a) (pattern-has-cut? sp))]
- [(pat:head headp tailp) (or (pattern-has-cut? headp) (pattern-has-cut? tailp))]
- [(pat:pair headp tailp) (or (pattern-has-cut? headp) (pattern-has-cut? tailp))]
- [(pat:vector sp) (pattern-has-cut? sp)]
- [(pat:box sp) (pattern-has-cut? sp)]
- [(pat:pstruct key sp) (pattern-has-cut? sp)]
- [(pat:describe sp _ _ _) (pattern-has-cut? sp)]
- [(pat:and ps) (ormap pattern-has-cut? ps)]
- [(pat:or _ ps _) (ormap pattern-has-cut? ps)]
- [(pat:not _) #f]
- [(pat:dots headps tailp) (or (ormap pattern-has-cut? headps) (pattern-has-cut? tailp))]
- [(pat:delimit sp) #f]
- [(pat:commit sp) #f]
- [(pat:ord sp _ _) (pattern-has-cut? sp)]
- [(pat:post sp) (pattern-has-cut? sp)]
- [(pat:integrated name _ _ _) #f]
-
- ;; -- A patterns
- [(action:cut) #t]
- [(action:fail _ _) #f]
- [(action:bind attr expr) #f]
- [(action:and ps) (ormap pattern-has-cut? ps)]
- [(action:parse sp _) (pattern-has-cut? sp)]
- [(action:do _) #f]
- [(action:ord sp _ _) (pattern-has-cut? sp)]
- [(action:post sp) (pattern-has-cut? sp)]
-
- ;; -- H patterns
- [(hpat:var/p _ _ _ _ _ opts) (not (scopts-delimit-cut? opts))]
- [(hpat:reflect _ _ _ name nested-attrs) #f]
- [(hpat:seq lp) (pattern-has-cut? lp)]
- [(hpat:action a hp) (or (pattern-has-cut? a) (pattern-has-cut? hp))]
- [(hpat:describe hp _ _ _) (pattern-has-cut? hp)]
- [(hpat:and hp sp) (or (pattern-has-cut? hp) (pattern-has-cut? sp))]
- [(hpat:or _ ps _) (ormap pattern-has-cut? ps)]
- [(hpat:delimit hp) #f]
- [(hpat:commit hp) #f]
- [(hpat:ord hp _ _) (pattern-has-cut? hp)]
- [(hpat:post hp) (pattern-has-cut? hp)]
- [(hpat:peek hp) (pattern-has-cut? hp)]
- [(hpat:peek-not hp) (pattern-has-cut? hp)]
-
- ;; EH patterns
- [(ehpat _ hp _ _) (pattern-has-cut? hp)]
- ))
-
-;; ----
-
-(define (create-pat:or ps)
- (define attrss (map pattern-attrs ps))
- (pat:or (union-iattrs attrss) ps attrss))
-
-(define (create-hpat:or ps)
- (define attrss (map pattern-attrs ps))
- (hpat:or (union-iattrs attrss) ps attrss))
-
-;; create-ehpat : HeadPattern RepConstraint Syntax -> EllipsisHeadPattern
-(define (create-ehpat head repc head-stx)
- (let* ([iattrs0 (pattern-attrs head)]
- [iattrs (repc-adjust-attrs iattrs0 repc)])
- (define nullable (hpat-nullable head))
- (define unbounded-iterations?
- (cond [(rep:once? repc) #f]
- [(rep:optional? repc) #f]
- [(rep:bounds? repc) (eq? (rep:bounds-max repc) +inf.0)]
- [else #t]))
- (when (and (eq? nullable 'yes) unbounded-iterations?)
- (when #f (wrong-syntax head-stx "nullable ellipsis-head pattern"))
- (when #t (log-syntax-parse-error "nullable ellipsis-head pattern: ~e" head-stx)))
- (ehpat iattrs head repc (case nullable [(yes unknown) unbounded-iterations?] [(no) #f]))))
-
-(define (repc-adjust-attrs iattrs repc)
- (cond [(rep:once? repc)
- iattrs]
- [(rep:optional? repc)
- (map attr-make-uncertain iattrs)]
- [(or (rep:bounds? repc) (eq? #f repc))
- (map increase-depth iattrs)]
- [else
- (error 'repc-adjust-attrs "INTERNAL ERROR: unexpected: ~e" repc)]))
-
-;; ----
-
-(define (action/head-pattern->list-pattern p)
- (cond [(action-pattern? p)
- (pat:action p (pat:any))]
- [(hpat:seq? p)
- ;; simplification: just extract list pattern from hpat:seq
- (hpat:seq-inner p)]
- [else
- (pat:head p (pat:datum '()))]))
-
-(define (action-pattern->single-pattern a)
- (pat:action a (pat:any)))
-
-(define (proper-list-pattern? p)
- (or (and (pat:datum? p) (eq? (pat:datum-datum p) '()))
- (and (pat:pair? p) (proper-list-pattern? (pat:pair-tail p)))
- (and (pat:head? p) (proper-list-pattern? (pat:head-tail p)))
- (and (pat:dots? p) (proper-list-pattern? (pat:dots-tail p)))
- (and (pat:action? p) (proper-list-pattern? (pat:action-inner p)))))
-
-;; ----
-
-(define-syntax-rule (define/memo (f x) body ...)
- (define f
- (let ([memo-table (make-weak-hasheq)])
- (lambda (x)
- (hash-ref! memo-table x (lambda () body ...))))))
-
-;; ----
-
-;; An AbsFail is a Nat encoding the bitvector { sub? : 1, post? : 1 }
-;; Finite abstraction of failuresets based on progress bins. That is:
-(define AF-NONE 0) ;; cannot fail
-(define AF-SUB 1) ;; can fail with progress < POST
-(define AF-POST 2) ;; can fail with progress >= POST
-(define AF-ANY 3) ;; can fail with progress either < or >= POST
-
-;; AF-nz? : AbsFail -> {0, 1}
-(define (AF-nz? af) (if (= af AF-NONE) 0 1))
-
-;; AF<? : AbsFail AbsFail -> Boolean
-;; True if every failure in af1 has strictly less progress than any failure in af2.
-;; Note: trivially satisfied if either side cannot fail.
-(define (AF<? af1 af2)
- ;; (0, *), (*, 0), (1, 2)
- (or (= af1 AF-NONE)
- (= af2 AF-NONE)
- (and (= af1 AF-SUB) (= af2 AF-POST))))
-
-;; pattern-absfail : *Pattern -> AbsFail
-(define/memo (pattern-AF p)
- (define (patterns-AF ps)
- (for/fold ([af 0]) ([p (in-list ps)]) (bitwise-ior af (pattern-AF p))))
- (cond [(pat:any? p) AF-NONE]
- [(pat:svar? p) AF-NONE]
- [(pat:var/p? p) AF-ANY]
- [(pat:literal? p) AF-SUB]
- [(pat:datum? p) AF-SUB]
- [(pat:action? p) (bitwise-ior (pattern-AF (pat:action-action p))
- (pattern-AF (pat:action-inner p)))]
- [(pat:head? p) AF-ANY]
- [(pat:dots? p) AF-ANY]
- [(pat:and? p) (patterns-AF (pat:and-patterns p))]
- [(pat:or? p) (patterns-AF (pat:or-patterns p))]
- [(pat:not? p) AF-SUB]
- [(pat:pair? p) AF-SUB]
- [(pat:vector? p) AF-SUB]
- [(pat:box? p) AF-SUB]
- [(pat:pstruct? p) AF-SUB]
- [(pat:describe? p) (pattern-AF (pat:describe-pattern p))]
- [(pat:delimit? p) (pattern-AF (pat:delimit-pattern p))]
- [(pat:commit? p) (pattern-AF (pat:commit-pattern p))]
- [(pat:reflect? p) AF-ANY]
- [(pat:ord? p) (pattern-AF (pat:ord-pattern p))]
- [(pat:post? p) (if (AF-nz? (pattern-AF (pat:post-pattern p))) AF-POST AF-NONE)]
- [(pat:integrated? p) AF-SUB]
- ;; Action patterns
- [(action:cut? p) AF-NONE]
- [(action:fail? p) AF-SUB]
- [(action:bind? p) AF-NONE]
- [(action:and? p) (patterns-AF (action:and-patterns p))]
- [(action:parse? p) (if (AF-nz? (pattern-AF (action:parse-pattern p))) AF-SUB AF-NONE)]
- [(action:do? p) AF-NONE]
- [(action:ord? p) (pattern-AF (action:ord-pattern p))]
- [(action:post? p) (if (AF-nz? (pattern-AF (action:post-pattern p))) AF-POST AF-NONE)]
- ;; Head patterns, eh patterns, etc
- [else AF-ANY]))
-
-;; pattern-cannot-fail? : *Pattern -> Boolean
-(define (pattern-cannot-fail? p)
- (= (pattern-AF p) AF-NONE))
-
-;; pattern-can-fail? : *Pattern -> Boolean
-(define (pattern-can-fail? p)
- (not (pattern-cannot-fail? p)))
-
-;; patterns-AF-sorted? : (Listof *Pattern) -> AF/#f
-;; Returns AbsFail (true) if any failure from pattern N+1 has strictly
-;; greater progress than any failure from patterns 0 through N.
-(define (patterns-AF-sorted? ps)
- (for/fold ([af AF-NONE]) ([p (in-list ps)])
- (define afp (pattern-AF p))
- (and af (AF<? af afp) (bitwise-ior af afp))))
-
-;; ----
-
-;; patterns-cannot-fail? : (Listof SinglePattern) -> Boolean
-;; Returns true if the disjunction of the patterns always succeeds---and thus no
-;; failure-tracking needed. Note: beware cut!
-(define (patterns-cannot-fail? patterns)
- (and (not (ormap pattern-has-cut? patterns))
- (ormap pattern-cannot-fail? patterns)))
-
-;; ----
-
-;; An AbsNullable is 'yes | 'no | 'unknown (3-valued logic)
-
-(define (3and a b)
- (case a
- [(yes) b]
- [(no) 'no]
- [(unknown) (case b [(yes unknown) 'unknown] [(no) 'no])]))
-
-(define (3or a b)
- (case a
- [(yes) 'yes]
- [(no) b]
- [(unknown) (case b [(yes) 'yes] [(no unknown) 'unknown])]))
-
-(define (3andmap f xs) (foldl 3and 'yes (map f xs)))
-(define (3ormap f xs) (foldl 3or 'no (map f xs)))
-
-;; lpat-nullable : ListPattern -> AbsNullable
-(define/memo (lpat-nullable lp)
- (match lp
- [(pat:datum '()) 'yes]
- [(pat:action ap lp) (lpat-nullable lp)]
- [(pat:head hp lp) (3and (hpat-nullable hp) (lpat-nullable lp))]
- [(pat:pair sp lp) 'no]
- [(pat:dots ehps lp) (3and (3andmap ehpat-nullable ehps) (lpat-nullable lp))]
- ;; For hpat:and, handle the following which are not ListPatterns
- [(pat:and lps) (3andmap lpat-nullable lps)]
- [(pat:any) #t]
- [_ 'unknown]))
-
-;; hpat-nullable : HeadPattern -> AbsNullable
-(define/memo (hpat-nullable hp)
- (match hp
- [(hpat:seq lp) (lpat-nullable lp)]
- [(hpat:action ap hp) (hpat-nullable hp)]
- [(hpat:and hp sp) (3and (hpat-nullable hp) (lpat-nullable sp))]
- [(hpat:or _attrs hps _attrss) (3ormap hpat-nullable hps)]
- [(hpat:describe hp _ _ _) (hpat-nullable hp)]
- [(hpat:delimit hp) (hpat-nullable hp)]
- [(hpat:commit hp) (hpat-nullable hp)]
- [(hpat:ord hp _ _) (hpat-nullable hp)]
- [(hpat:post hp) (hpat-nullable hp)]
- [(? pattern? hp) 'no]
- [_ 'unknown]))
-
-;; ehpat-nullable : EllipsisHeadPattern -> AbsNullable
-(define (ehpat-nullable ehp)
- (match ehp
- [(ehpat _ hp repc _)
- (3or (repc-nullable repc) (hpat-nullable hp))]))
-
-;; repc-nullable : RepConstraint -> AbsNullable
-(define (repc-nullable repc)
- (cond [(rep:once? repc) 'no]
- [(and (rep:bounds? repc) (> (rep:bounds-min repc) 0)) 'no]
- [else 'yes]))
-
-;; ----
-
-;; create-post-pattern : *Pattern -> *Pattern
-(define (create-post-pattern p)
- (cond [(pattern-cannot-fail? p)
- p]
- [(pattern? p)
- (pat:post p)]
- [(head-pattern? p)
- (hpat:post p)]
- [(action-pattern? p)
- (action:post p)]
- [else (error 'syntax-parse "INTERNAL ERROR: create-post-pattern ~e" p)]))
-
-;; create-ord-pattern : *Pattern UninternedSymbol Nat -> *Pattern
-(define (create-ord-pattern p group index)
- (cond [(pattern-cannot-fail? p)
- p]
- [(pattern? p)
- (pat:ord p group index)]
- [(head-pattern? p)
- (hpat:ord p group index)]
- [(action-pattern? p)
- (action:ord p group index)]
- [else (error 'syntax-parse "INTERNAL ERROR: create-ord-pattern ~e" p)]))
-
-;; ord-and-patterns : (Listof *Pattern) UninternedSymbol -> (Listof *Pattern)
-;; If at most one subpattern can fail, no need to wrap. More
-;; generally, if possible failures are already consistent with and
-;; ordering, no need to wrap.
-(define (ord-and-patterns patterns group)
- (cond [(patterns-AF-sorted? patterns) patterns]
- [else
- (for/list ([p (in-list patterns)] [index (in-naturals)])
- (create-ord-pattern p group index))]))
-
-;; create-action:and : (Listof ActionPattern) -> ActionPattern
-(define (create-action:and actions)
- (match actions
- [(list action) action]
- [_ (action:and actions)]))
diff --git a/parse/private/rep.rkt b/parse/private/rep.rkt
@@ -6,18 +6,18 @@
racket/list
racket/contract/base
"make.rkt"
- "minimatch.rkt"
+ syntax/parse/private/minimatch
syntax/private/id-table
syntax/stx
syntax/keyword
racket/syntax
racket/struct
"txlift.rkt"
- "rep-attrs.rkt"
- "rep-data.rkt"
- "rep-patterns.rkt"
- stxparse-info/parse/private/residual-ct ;; keep abs. path
- "kws.rkt")
+ syntax/parse/private/rep-attrs
+ syntax/parse/private/rep-data
+ syntax/parse/private/rep-patterns
+ syntax/parse/private/residual-ct ;; keep abs. path
+ syntax/parse/private/kws)
;; Error reporting
;; All entry points should have explicit, mandatory #:context arg
diff --git a/parse/private/residual-ct.rkt b/parse/private/residual-ct.rkt
@@ -1,97 +0,0 @@
-#lang racket/base
-(provide (struct-out attr)
- (struct-out stxclass)
- (struct-out scopts)
- (struct-out conventions)
- (struct-out literalset)
- (struct-out lse:lit)
- (struct-out lse:datum-lit)
- (struct-out eh-alternative-set)
- (struct-out eh-alternative)
- (struct-out den:lit)
- (struct-out den:datum-lit)
- (struct-out den:delayed)
- log-syntax-parse-error
- log-syntax-parse-warning
- log-syntax-parse-info
- log-syntax-parse-debug
- prop:pattern-expander
- pattern-expander?
- pattern-expander-proc
- current-syntax-parse-pattern-introducer
- syntax-local-syntax-parse-pattern-introduce)
-
-(define-logger syntax-parse)
-
-;; == from rep-attr.rkt
-(define-struct attr (name depth syntax?) #:prefab)
-
-;; == from rep-data.rkt
-
-;; A stxclass is #s(stxclass Symbol Arity SAttrs Id Bool scopts Id/#f)
-(define-struct stxclass
- (name ;; Symbol
- arity ;; Arity (defined in kws.rkt)
- attrs ;; (Listof SAttr)
- parser ;; Id, reference to parser (see parse.rkt for parser signature)
- splicing? ;; Bool
- opts ;; scopts
- inline ;; Id/#f, reference to a predicate
- ) #:prefab)
-
-;; A scopts is #s(scopts Nat Bool Bool String/#f)
-;; These are passed on to var patterns.
-(define-struct scopts
- (attr-count ;; Nat
- commit? ;; Bool
- delimit-cut? ;; Bool
- desc ;; String/#f, String = known constant description
- ) #:prefab)
-
-#|
-A Conventions is
- (make-conventions id (-> (listof ConventionRule)))
-A ConventionRule is (list regexp DeclEntry)
-|#
-(define-struct conventions (get-procedures get-rules) #:transparent)
-
-#|
-A LiteralSet is
- (make-literalset (listof LiteralSetEntry))
-An LiteralSetEntry is one of
- - (make-lse:lit Symbol Id Stx)
- - (make-lse:datum-lit Symbol Symbol)
-|#
-(define-struct literalset (literals) #:transparent)
-(define-struct lse:lit (internal external phase) #:transparent)
-(define-struct lse:datum-lit (internal external) #:transparent)
-
-#|
-An EH-alternative-set is
- (eh-alternative-set (listof EH-alternative))
-An EH-alternative is
- (eh-alternative RepetitionConstraint (listof SAttr) id)
-|#
-(define-struct eh-alternative-set (alts))
-(define-struct eh-alternative (repc attrs parser))
-
-(define-struct den:lit (internal external input-phase lit-phase) #:transparent)
-(define-struct den:datum-lit (internal external) #:transparent)
-(define-struct den:delayed (parser class))
-
-;; == Pattern expanders
-
-(define-values (prop:pattern-expander pattern-expander? get-proc-getter)
- (make-struct-type-property 'pattern-expander))
-
-(define (pattern-expander-proc pat-expander)
- (define get-proc (get-proc-getter pat-expander))
- (get-proc pat-expander))
-
-(define current-syntax-parse-pattern-introducer
- (make-parameter
- (lambda (stx)
- (error 'syntax-local-syntax-parse-pattern-introduce "not expanding syntax-parse pattern"))))
-
-(define (syntax-local-syntax-parse-pattern-introduce stx)
- ((current-syntax-parse-pattern-introducer) stx))
diff --git a/parse/private/residual.rkt b/parse/private/residual.rkt
@@ -8,8 +8,8 @@
;; Compile-time
(require (for-syntax racket/private/sc
- stxparse-info/parse/private/residual-ct))
-(provide (for-syntax (all-from-out stxparse-info/parse/private/residual-ct)))
+ syntax/parse/private/residual-ct))
+(provide (for-syntax (all-from-out syntax/parse/private/residual-ct)))
(begin-for-syntax
;; == from runtime.rkt
@@ -21,7 +21,14 @@
attribute-mapping-depth
attribute-mapping-syntax?)
- (define-struct attribute-mapping (var name depth syntax?)
+ (require (only-in (for-template syntax/parse/private/residual)
+ make-attribute-mapping
+ attribute-mapping?
+ attribute-mapping-var
+ attribute-mapping-name
+ attribute-mapping-depth
+ attribute-mapping-syntax?))
+ #;(define-struct attribute-mapping (var name depth syntax?)
#:omit-define-syntaxes
#:property prop:procedure
(lambda (self stx)
diff --git a/parse/private/runtime-progress.rkt b/parse/private/runtime-progress.rkt
@@ -1,6 +1,6 @@
#lang racket/base
(require racket/list
- "minimatch.rkt")
+ syntax/parse/private/minimatch)
(provide ps-empty
ps-add-car
ps-add-cdr
diff --git a/parse/private/runtime-reflect.rkt b/parse/private/runtime-reflect.rkt
@@ -1,8 +1,8 @@
#lang racket/base
(require stxparse-info/parse/private/residual ;; keep abs. path
- (only-in stxparse-info/parse/private/residual-ct ;; keep abs. path
+ (only-in syntax/parse/private/residual-ct ;; keep abs. path
attr-name attr-depth)
- "kws.rkt")
+ syntax/parse/private/kws)
(provide reflect-parser
(struct-out reified)
(struct-out reified-syntax-class)
diff --git a/parse/private/runtime-report.rkt b/parse/private/runtime-report.rkt
@@ -4,9 +4,9 @@
syntax/stx
racket/struct
syntax/srcloc
- "minimatch.rkt"
+ syntax/parse/private/minimatch
stxparse-info/parse/private/residual
- "kws.rkt")
+ syntax/parse/private/kws)
(provide call-current-failure-handler
current-failure-handler
invert-failure
diff --git a/parse/private/runtime.rkt b/parse/private/runtime.rkt
@@ -8,7 +8,7 @@
syntax/strip-context
racket/private/sc
racket/syntax
- "rep-data.rkt"))
+ syntax/parse/private/rep-data))
(provide with
fail-handler
