Removed all structure definitions from the copy of syntax/parse, and used the ones definied in the official syntax/parse
This commit is contained in:
Georges Dupéron
parent
e117e4f919
commit
5be04ef8fd
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))]))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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]))
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
@ -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))
|
||||
|
|
@ -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)]))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@
|
|||
syntax/strip-context
|
||||
racket/private/sc
|
||||
racket/syntax
|
||||
"rep-data.rkt"))
|
||||
syntax/parse/private/rep-data))
|
||||
|
||||
(provide with
|
||||
fail-handler
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user