710 lines
29 KiB
Racket
710 lines
29 KiB
Racket
#lang scheme/base
|
|
(require (for-syntax scheme/base
|
|
racket/private/sc
|
|
syntax/stx
|
|
syntax/id-table
|
|
syntax/keyword
|
|
unstable/syntax
|
|
"rep-data.ss"
|
|
"rep.ss"
|
|
"codegen-data.ss"
|
|
"../util/txlift.ss"
|
|
"../util.ss")
|
|
scheme/stxparam
|
|
scheme/list
|
|
syntax/stx
|
|
"runtime.ss"
|
|
"runtime-prose.ss")
|
|
(provide (all-defined-out))
|
|
|
|
(define-for-syntax (wash stx)
|
|
(syntax-e stx))
|
|
(define-for-syntax (wash-list washer stx)
|
|
(let ([l (stx->list stx)])
|
|
(unless l (raise-type-error 'wash-list "stx-list" stx))
|
|
(map washer l)))
|
|
(define-for-syntax (wash-iattr stx)
|
|
(with-syntax ([#s(attr name depth syntax?) stx])
|
|
(make-attr #'name (wash #'depth) (wash #'syntax?))))
|
|
(define-for-syntax (wash-sattr stx)
|
|
(with-syntax ([#s(attr name depth syntax?) stx])
|
|
(make-attr (wash #'name) (wash #'depth) (wash #'syntax?))))
|
|
|
|
(define-for-syntax (wash-iattrs stx)
|
|
(wash-list wash-iattr stx))
|
|
(define-for-syntax (wash-sattrs stx)
|
|
(wash-list wash-sattr stx))
|
|
|
|
;; ----
|
|
|
|
;; An FCE is expr[DFC]
|
|
|
|
;; (fail expr #:expect expr #:fce FCE) : expr
|
|
(define-syntax (fail stx)
|
|
(syntax-case stx ()
|
|
[(fail x #:expect p #:fce fce)
|
|
#'(enclosing-fail (make-failure x fce p))]))
|
|
|
|
;; ----
|
|
|
|
;; (parse:rhs RHS (SAttr ...) (id ...) id boolean)
|
|
;; : expr[(values ParseFunction DescriptionFunction)]
|
|
;; Takes a list of the relevant attrs; order is significant!
|
|
;; Returns either fail or a list having length same as 'relsattrs'
|
|
(define-syntax (parse:rhs stx)
|
|
(syntax-case stx ()
|
|
[(parse:rhs #s(rhs _ _ transparent? _ variants (def ...) commit?)
|
|
relsattrs (arg ...) get-description splicing?)
|
|
(with-syntax ([(k-param ...)
|
|
(if (syntax-e #'commit?)
|
|
#'()
|
|
#'(return))]
|
|
[k-ref/fail
|
|
(if (syntax-e #'commit?)
|
|
#'values
|
|
#'return)]
|
|
[k-ref/ok
|
|
(if (syntax-e #'commit?)
|
|
#'values
|
|
#'(lambda (result) (return (cons enclosing-fail result))))])
|
|
#| #`(with-error-collector
|
|
(make-parser
|
|
(lambda ___)
|
|
(collect-error)))
|
|
|#
|
|
#'(lambda (x k-param ... arg ...)
|
|
(define (fail-rhs failure)
|
|
(k-ref/fail
|
|
(expectation-of-thing (get-description arg ...)
|
|
transparent?
|
|
(if transparent? failure #f))))
|
|
def ...
|
|
(syntax-parameterize ((this-syntax (make-rename-transformer #'x)))
|
|
(with-enclosing-fail* fail-rhs
|
|
(parse:variants x relsattrs variants splicing? k-ref/ok)))))]))
|
|
|
|
;; (parse:variants id (SAttr ...) (Variant ...) boolean)
|
|
;; : expr[SyntaxClassResult]
|
|
(define-syntax (parse:variants stx)
|
|
(syntax-case stx ()
|
|
[(parse:variants x relsattrs (variant ...) splicing? k-ref)
|
|
#'(try (parse:variant x relsattrs variant splicing? k-ref) ...)]))
|
|
|
|
(define-syntax (parse:variant stx)
|
|
(syntax-case stx ()
|
|
[(parse:variant x relsattrs variant #f k-ref)
|
|
(with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant])
|
|
#`(let ([fc (dfc-empty x)])
|
|
def ...
|
|
(parse:S x fc pattern (variant-success x relsattrs variant () k-ref))))]
|
|
[(parse:variant x relsattrs variant #t k-ref)
|
|
(with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant])
|
|
#`(let ([fc (dfc-empty x)])
|
|
def ...
|
|
(parse:H x fc pattern rest index
|
|
(variant-success x relsattrs variant (rest index) k-ref))))]))
|
|
|
|
;; (variant-success id (SAttr ...) Variant (expr ...)) : expr[SyntaxClassResult]
|
|
(define-syntax (variant-success stx)
|
|
(syntax-case stx ()
|
|
[(variant-success x relsattrs #s(variant _ _ pattern sides _) (also ...) k-ref)
|
|
#`(convert-sides x sides
|
|
(base-success-expr #,(pattern-attrs (wash #'pattern))
|
|
relsattrs
|
|
(also ...)
|
|
k-ref))]))
|
|
|
|
;; (convert-sides id (Side ...) (m (IAttr ...) . MArgs)) : expr[X]
|
|
;; where (m (IAttr ...) MArgs) : expr[X]
|
|
(define-syntax (convert-sides stx)
|
|
(syntax-case stx ()
|
|
[(convert-sides x () kexpr)
|
|
#'kexpr]
|
|
[(convert-sides x (side0 . sides) (k iattrs . kargs))
|
|
(syntax-case #'side0 ()
|
|
[#s(clause:fail condition message)
|
|
#`(let* ([c (without-fails condition)]
|
|
[fc (dfc-add-post (dfc-empty x) (if (syntax? c) c x))])
|
|
(if c
|
|
(fail (if (syntax? c) c x)
|
|
#:expect (expectation-of-message message)
|
|
#:fce fc)
|
|
(convert-sides x sides (k iattrs . kargs))))]
|
|
[#s(clause:with pattern expr (def ...))
|
|
(with-syntax ([(p-iattr ...) (pattern-attrs (wash #'pattern))])
|
|
#`(let* ([y (datum->syntax #f (without-fails expr))]
|
|
[fc (dfc-add-post (dfc-empty x) y)])
|
|
def ...
|
|
(parse:S y fc pattern
|
|
(convert-sides x sides
|
|
(k (p-iattr ... . iattrs) . kargs)))))]
|
|
[#s(clause:attr a expr)
|
|
#`(let-attributes ([a (without-fails (check-list^depth a expr))])
|
|
(convert-sides x sides (k (a . iattrs) . kargs)))])]))
|
|
|
|
;; (base-success-expr (IAttr ...) (SAttr ...) (expr ...) : expr[SCResult]
|
|
(define-syntax (base-success-expr stx)
|
|
(syntax-case stx ()
|
|
[(base-success-expr iattrs relsattrs (also ...) k-ref)
|
|
(let ([reliattrs
|
|
(reorder-iattrs (wash-sattrs #'relsattrs)
|
|
(wash-iattrs #'iattrs))])
|
|
(with-syntax ([(#s(attr name _ _) ...) reliattrs])
|
|
#'(k-ref (list also ... (attribute name) ...))))]))
|
|
|
|
;; ----
|
|
|
|
;; (parse:clauses id (Clause ...))
|
|
(define-syntax (parse:clauses stx)
|
|
(syntax-case stx ()
|
|
[(parse:clauses x clauses ctx)
|
|
(with-disappeared-uses
|
|
(with-txlifts
|
|
(lambda ()
|
|
(define-values (chunks clauses-stx)
|
|
(parse-keyword-options #'clauses parse-directive-table
|
|
#:context #'ctx
|
|
#:no-duplicates? #t))
|
|
(define context
|
|
(options-select-value chunks '#:context #:default #'x))
|
|
(define-values (decls0 defs)
|
|
(get-decls+defs chunks #t #:context #'ctx))
|
|
(define (for-clause clause)
|
|
(syntax-case clause ()
|
|
[[p . rest]
|
|
(let-values ([(rest decls2 defs2 sides)
|
|
(parse-pattern-directives #'rest
|
|
#:allow-declare? #t
|
|
#:decls decls0
|
|
#:context #'ctx)])
|
|
(unless (and (stx-list? rest) (stx-pair? rest))
|
|
(raise-syntax-error #f
|
|
"expected non-empty clause body"
|
|
#'ctx
|
|
clause))
|
|
(with-syntax ([rest rest]
|
|
[pattern
|
|
(parse-whole-pattern #'p decls2 #:context #'ctx)]
|
|
[(local-def ...) defs2])
|
|
#`(let ([fc (dfc-empty x)])
|
|
local-def ...
|
|
(parse:S x fc pattern
|
|
(convert-sides x #,sides
|
|
(clause-success () (let () . rest)))))))]))
|
|
(unless (and (stx-list? clauses-stx) (stx-pair? clauses-stx))
|
|
(raise-syntax-error #f "expected non-empty sequence of clauses" #'ctx))
|
|
(with-syntax ([(def ...) (append (get-txlifts-as-definitions) defs)]
|
|
[(alternative ...)
|
|
(map for-clause (stx->list clauses-stx))])
|
|
#`(let ([fail (syntax-patterns-fail #,context)])
|
|
def ...
|
|
(with-enclosing-fail* fail
|
|
(try alternative ...)))))))]))
|
|
|
|
;; (clause-success (IAttr ...) expr) : expr
|
|
(define-syntax (clause-success stx)
|
|
(syntax-case stx ()
|
|
[(clause-success _ expr)
|
|
#'expr]))
|
|
|
|
;; ----
|
|
|
|
;; (parse:S id FCE SinglePattern expr) : expr
|
|
(define-syntax (parse:S stx)
|
|
(syntax-case stx ()
|
|
[(parse:S x fc pattern0 k)
|
|
(syntax-case #'pattern0 ()
|
|
[#s(internal-rest-pattern rest rest-fc)
|
|
#`(let ([rest x]
|
|
[rest-fc fc])
|
|
k)]
|
|
[#s(pat:name attrs pattern (name ...))
|
|
#`(let-attributes ([#s(attr name 0 #t) x] ...)
|
|
(parse:S x fc pattern k))]
|
|
[#s(pat:any attrs)
|
|
#'k]
|
|
[#s(pat:var _attrs name #f () () _)
|
|
#'(let-attributes ([#s(attr name 0 #t) x])
|
|
k)]
|
|
[#s(pat:var _attrs name parser (arg ...) (nested-a ...) commit?)
|
|
(with-syntax* ([(name-attr ...)
|
|
(if (identifier? #'name)
|
|
#'([#s(attr name 0 #t) x])
|
|
#'())]
|
|
[ok-e
|
|
#'(let-attributes (name-attr ...)
|
|
(let/unpack ((nested-a ...) result)
|
|
k))]
|
|
[fail-e
|
|
#'(fail x #:expect result #:fce fc)])
|
|
(if (syntax-e #'commit?)
|
|
#'(let ([result (parser x arg ...)])
|
|
(if (ok? result)
|
|
ok-e
|
|
fail-e))
|
|
#'(parser x
|
|
(lambda (result)
|
|
(if (ok? result)
|
|
(let ([fail-k (car result)]
|
|
[result (cdr result)])
|
|
(with-enclosing-fail fail-k
|
|
ok-e))
|
|
fail-e))
|
|
arg ...)))]
|
|
[#s(pat:datum attrs datum)
|
|
#`(let ([d (syntax->datum x)])
|
|
(if (equal? d (quote datum))
|
|
k
|
|
(fail x
|
|
#:expect (expectation pattern0)
|
|
#:fce fc)))]
|
|
[#s(pat:literal attrs literal input-phase lit-phase)
|
|
#`(if (and (identifier? x)
|
|
(free-identifier=?/phases x input-phase
|
|
(quote-syntax literal) lit-phase))
|
|
k
|
|
(fail x
|
|
#:expect (expectation pattern0)
|
|
#:fce fc))]
|
|
[#s(pat:ghost attrs ghost subpattern)
|
|
#'(parse:G x fc ghost (parse:S x fc subpattern k))]
|
|
[#s(pat:head attrs head tail)
|
|
#`(parse:H x fc head rest rest-fc
|
|
(parse:S rest rest-fc tail k))]
|
|
[#s(pat:dots attrs head tail)
|
|
#`(parse:dots x fc head tail k)]
|
|
[#s(pat:and attrs subpatterns)
|
|
(for/fold ([k #'k]) ([subpattern (reverse (syntax->list #'subpatterns))])
|
|
#`(parse:S x fc #,subpattern #,k))]
|
|
[#s(pat:or (a ...) (subpattern ...))
|
|
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
|
|
#`(let ([success
|
|
(lambda (fail id ...)
|
|
(with-enclosing-fail fail
|
|
(let-attributes ([a id] ...) k)))])
|
|
(try (parse:S x fc subpattern
|
|
(disjunct subpattern success (enclosing-fail) (id ...)))
|
|
...)))]
|
|
[#s(pat:not () subpattern)
|
|
#`(let ([fail-to-succeed (lambda (_failure) k)]
|
|
[outer-fail enclosing-fail])
|
|
(with-enclosing-fail* fail-to-succeed
|
|
(parse:S x fc subpattern
|
|
(with-enclosing-fail outer-fail
|
|
(fail x #:expect (expectation pattern0) #:fce fc)))))]
|
|
[#s(pat:compound attrs kind0 (part-pattern ...))
|
|
(let ([kind (get-kind (wash #'kind0))])
|
|
(with-syntax ([(part ...) (generate-temporaries (kind-selectors kind))])
|
|
(with-syntax ([predicate (kind-predicate kind)]
|
|
[(part-fc ...) (generate-temporaries #'(part ...))]
|
|
[(part-fc-proc ...) (kind-frontier-procs kind)]
|
|
[(part-expr ...)
|
|
(for/list ([selector (kind-selectors kind)])
|
|
(selector #'x #'datum))])
|
|
#`(let ([datum (syntax-e x)])
|
|
(if (predicate datum)
|
|
(let ([part part-expr] ...)
|
|
(let ([part-fc (part-fc-proc fc part)] ...)
|
|
(parse:S* (part ...) (part-fc ...) (part-pattern ...) k)))
|
|
(fail x
|
|
#:expect (expectation pattern0)
|
|
#:fce fc))))))]
|
|
[#s(pat:describe attrs description transparent? pattern)
|
|
#`(let ([previous-fail enclosing-fail]
|
|
[previous-cut-fail enclosing-cut-fail])
|
|
(define (new-fail failure)
|
|
(fail x
|
|
#:expect (expectation-of-thing description transparent? failure)
|
|
#:fce fc))
|
|
(with-enclosing-fail* new-fail
|
|
(let ([new-fc (dfc-empty x)])
|
|
(parse:S x new-fc pattern
|
|
(with-enclosing-cut-fail previous-cut-fail
|
|
(with-enclosing-fail previous-fail
|
|
k))))))])]))
|
|
|
|
;; (parse:S* (id ...) (FCE ...) (SinglePattern ...) expr) : expr
|
|
(define-syntax parse:S*
|
|
(syntax-rules ()
|
|
[(parse:S* () () () k)
|
|
k]
|
|
[(parse:S* (part0 . parts) (fc0 . fcs) (pattern0 . patterns) k)
|
|
(parse:S part0 fc0 pattern0 (parse:S* parts fcs patterns k))]))
|
|
|
|
;; (disjunct Pattern id (expr ...) (id ...)) : expr
|
|
(define-syntax (disjunct stx)
|
|
(syntax-case stx ()
|
|
[(disjunct pattern success (pre ...) (id ...))
|
|
(with-syntax ([(#s(attr sub-id _ _) ...) (pattern-attrs (wash #'pattern))])
|
|
(with-syntax ([(alt-sub-id ...) (generate-temporaries #'(sub-id ...))])
|
|
#`(let ([alt-sub-id (attribute sub-id)] ...)
|
|
(let ([id #f] ...)
|
|
(let ([sub-id alt-sub-id] ...)
|
|
(success pre ... id ...))))))]))
|
|
|
|
;; (disjunct (clause:attr ...) id (expr ...) (id ...)) : expr
|
|
(define-syntax (disjunct/sides stx)
|
|
(syntax-case stx ()
|
|
[(disjunct/sides clauses success (pre ...) (id ...))
|
|
(with-syntax ([(#s(clause:attr #s(attr sub-id _ _) _) ...) #'clauses])
|
|
(with-syntax ([(alt-sub-id ...) (generate-temporaries #'(sub-id ...))])
|
|
#`(let ([alt-sub-id (attribute sub-id)] ...)
|
|
(let ([id #f] ...)
|
|
(let ([sub-id alt-sub-id] ...)
|
|
(success pre ... id ...))))))]))
|
|
|
|
|
|
;; (parse:G id FCE SinglePattern expr) : expr
|
|
(define-syntax (parse:G stx)
|
|
(syntax-case stx ()
|
|
[(parse:G x fc pattern0 k)
|
|
(syntax-case #'pattern0 ()
|
|
[#s(ghost:cut _)
|
|
#`(with-enclosing-fail enclosing-cut-fail k)]
|
|
[#s(ghost:bind _ clauses)
|
|
#`(convert-sides x clauses (clause-success () k))]
|
|
[#s(ghost:fail _ early? condition message)
|
|
#`(let* ([c (without-fails condition)]
|
|
[fc* (if (quote early?)
|
|
fc
|
|
(dfc-add-post fc (if (syntax? c) c x)))])
|
|
(if c
|
|
(fail (if (syntax? c) c x)
|
|
#:expect (expectation pattern0)
|
|
#:fce fc*)
|
|
k))]
|
|
[#s(ghost:parse _ pattern expr)
|
|
#`(let* ([y (datum->syntax #f (without-fails expr))]
|
|
[fc* (dfc-add-post fc y)])
|
|
(parse:S y fc* pattern k))])]))
|
|
|
|
(begin-for-syntax
|
|
;; convert-list-pattern : ListPattern id -> SinglePattern
|
|
;; Converts '() datum pattern at end of list to bind (cons stx index)
|
|
;; to rest-var.
|
|
(define (convert-list-pattern pattern end-pattern)
|
|
(syntax-case pattern ()
|
|
[#s(pat:datum () ())
|
|
end-pattern]
|
|
[#s(pat:name attrs pattern names)
|
|
(with-syntax ([pattern (convert-list-pattern #'pattern end-pattern)])
|
|
#'#s(pat:name attrs pattern names))]
|
|
[#s(pat:ghost attrs ghost tail)
|
|
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
|
|
#'#s(pat:ghost attrs ghost tail))]
|
|
[#s(pat:head attrs head tail)
|
|
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
|
|
#'#s(pat:head attrs head tail))]
|
|
[#s(pat:dots attrs head tail)
|
|
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
|
|
#'#s(pat:dots attrs head tail))]
|
|
[#s(pat:compound attrs #:pair (head-part tail-part))
|
|
(with-syntax ([tail-part (convert-list-pattern #'tail-part end-pattern)])
|
|
#'#s(pat:compound attrs #:pair (head-part tail-part)))])))
|
|
|
|
;; (parse:H id FCE HeadPattern id id expr) : expr
|
|
;; x must not alias rest
|
|
(define-syntax (parse:H stx)
|
|
(syntax-case stx ()
|
|
[(parse:H x fc head rest rest-fc k)
|
|
(syntax-case #'head ()
|
|
[#s(hpat:describe _ description transparent? pattern)
|
|
#`(let ([previous-fail enclosing-fail]
|
|
[previous-cut-fail enclosing-cut-fail])
|
|
(define (new-fail failure)
|
|
(fail x
|
|
#:expect (expectation-of-thing description transparent? failure)
|
|
#:fce fc))
|
|
(let ([fc* (dfc-empty x)])
|
|
(with-enclosing-fail* new-fail
|
|
(parse:H x fc* pattern rest rest-fc
|
|
(with-enclosing-cut-fail previous-cut-fail
|
|
(with-enclosing-fail previous-fail
|
|
k))))))]
|
|
[#s(hpat:var _attrs name parser (arg ...) (nested-a ...) commit?)
|
|
(with-syntax* ([(name-attr ...)
|
|
(if (identifier? #'name)
|
|
#'([#s(attr name 0 #t)
|
|
(stx-list-take x (dfc->index local-fc))])
|
|
#'())]
|
|
[ok-e
|
|
#'(let* ([rest (car result)]
|
|
[local-fc (cadr result)]
|
|
[rest-fc (dfc-append fc local-fc)])
|
|
(let-attributes (name-attr ...)
|
|
(let/unpack ((nested-a ...) (cddr result))
|
|
k)))]
|
|
[fail-e
|
|
#'(fail x #:expect result #:fce fc)])
|
|
(if (syntax-e #'commit?)
|
|
#'(let ([result (parser x arg ...)])
|
|
(if (ok? result)
|
|
ok-e
|
|
fail-e))
|
|
#'(parser x
|
|
(lambda (result)
|
|
(if (ok? result)
|
|
(let ([fail-k (car result)]
|
|
[result (cdr result)])
|
|
(with-enclosing-fail fail-k
|
|
ok-e))
|
|
fail-e))
|
|
arg ...)))]
|
|
[#s(hpat:and (a ...) head single)
|
|
#`(parse:H x fc head rest rest-fc
|
|
(let ([lst (stx-list-take x (dfc-difference fc rest-fc))])
|
|
(parse:S lst fc single k)))]
|
|
[#s(hpat:or (a ...) (subpattern ...))
|
|
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
|
|
#`(let ([success
|
|
(lambda (rest rest-fc fail id ...)
|
|
(with-enclosing-fail fail
|
|
(let-attributes ([a id] ...) k)))])
|
|
(try (parse:H x fc subpattern rest rest-fc
|
|
(disjunct subpattern success
|
|
(rest rest-fc enclosing-fail) (id ...)))
|
|
...)))]
|
|
[#s(hpat:seq attrs pattern)
|
|
(with-syntax ([pattern
|
|
(convert-list-pattern
|
|
#'pattern
|
|
#'#s(internal-rest-pattern rest rest-fc))])
|
|
#'(parse:S x fc pattern k))]
|
|
[#s(hpat:optional (a ...) pattern defaults)
|
|
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
|
|
#`(let ([success
|
|
(lambda (rest rest-fc fail id ...)
|
|
(with-enclosing-fail fail
|
|
(let-attributes ([a id] ...) k)))])
|
|
(try (parse:H x fc pattern rest rest-fc
|
|
(success rest rest-fc enclosing-fail (attribute id) ...))
|
|
(let ([rest x]
|
|
[rest-fc fc])
|
|
(convert-sides x defaults
|
|
(clause-success ()
|
|
(disjunct/sides defaults success
|
|
(rest rest-fc enclosing-fail)
|
|
(id ...))))))))]
|
|
[_
|
|
(with-syntax ([attrs (pattern-attrs (wash #'head))])
|
|
#'(parse:S x fc
|
|
#s(pat:compound attrs
|
|
#:pair
|
|
(head #s(internal-rest-pattern rest rest-fc)))
|
|
k))])]))
|
|
|
|
;; (parse:dots id FCE EHPattern SinglePattern expr) : expr
|
|
(define-syntax (parse:dots stx)
|
|
(syntax-case stx ()
|
|
[(parse:dots x fc (#s(ehpat head-attrs head head-repc) ...) tail k)
|
|
(let ()
|
|
(define repcs (wash-list wash #'(head-repc ...)))
|
|
(define rep-ids (for/list ([repc repcs])
|
|
(and repc (generate-temporary 'rep))))
|
|
(define rel-repcs (filter values repcs))
|
|
(define rel-rep-ids (filter values rep-ids))
|
|
(define aattrs
|
|
(for/list ([head-attrs (syntax->list #'(head-attrs ...))]
|
|
[repc repcs]
|
|
#:when #t
|
|
[a (wash-iattrs head-attrs)])
|
|
(cons a repc)))
|
|
(define attrs (map car aattrs))
|
|
(define attr-repcs (map cdr aattrs))
|
|
(define ids (map attr-name attrs))
|
|
(with-syntax ([(id ...) ids]
|
|
[(alt-id ...) (generate-temporaries ids)]
|
|
[reps rel-rep-ids]
|
|
[(head-rep ...) rep-ids]
|
|
[(rel-rep ...) rel-rep-ids]
|
|
[(rel-repc ...) rel-repcs]
|
|
[(a ...) attrs]
|
|
[(attr-repc ...) attr-repcs])
|
|
(define-pattern-variable alt-map #'((id . alt-id) ...))
|
|
(define-pattern-variable loop-k
|
|
#'(dots-loop dx* loop-fc* enclosing-fail rel-rep ... alt-id ...))
|
|
#`(let ()
|
|
(define (dots-loop dx loop-fc loop-fail rel-rep ... alt-id ...)
|
|
(with-enclosing-fail loop-fail
|
|
(try (parse:EH dx loop-fc head head-repc dx* loop-fc* alt-map head-rep
|
|
loop-k)
|
|
...
|
|
(cond [(< rel-rep (rep:min-number rel-repc))
|
|
(fail dx
|
|
#:expect (expectation-of-reps/too-few rel-rep rel-repc)
|
|
#:fce (dfc-add-pre loop-fc #f))]
|
|
...
|
|
[else
|
|
(let-attributes ([a (rep:finalize a attr-repc alt-id)] ...)
|
|
(parse:S dx loop-fc tail k))]))))
|
|
(let ([rel-rep 0] ...
|
|
[alt-id (rep:initial-value attr-repc)] ...)
|
|
(dots-loop x fc enclosing-fail rel-rep ... alt-id ...)))))]))
|
|
|
|
;; (parse:EH id FCE EHPattern id id ((id . id) ...)
|
|
;; RepConstraint/#f expr) : expr
|
|
(define-syntax (parse:EH stx)
|
|
(syntax-case stx ()
|
|
[(parse:EH x fc head repc x* fc* alts rep k0)
|
|
(let ()
|
|
(define-pattern-variable k
|
|
(let* ([main-attrs (wash-iattrs (pattern-attrs (wash #'head)))]
|
|
[ids (map attr-name main-attrs)]
|
|
[alt-ids
|
|
(let ([table (make-bound-id-table)])
|
|
(for ([entry (syntax->list #'alts)])
|
|
(let ([entry (syntax-e entry)])
|
|
(bound-id-table-set! table (car entry) (cdr entry))))
|
|
(for/list ([id ids]) (bound-id-table-ref table id)))])
|
|
(with-syntax ([(id ...) ids]
|
|
[(alt-id ...) alt-ids]
|
|
[(alt-a ...) (map rename-attr main-attrs alt-ids)])
|
|
#`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...)
|
|
k0))))
|
|
(syntax-case #'repc ()
|
|
[#f #`(parse:H x fc head x* fc* k)]
|
|
[_ #`(parse:H x fc head x* fc*
|
|
(if (< rep (rep:max-number repc))
|
|
(let ([rep (add1 rep)]) k)
|
|
(fail x*
|
|
#:expect (expectation-of-reps/too-many rep repc)
|
|
#:fce fc*)))]))]))
|
|
|
|
;; (rep:initial-value RepConstraint) : expr
|
|
(define-syntax (rep:initial-value stx)
|
|
(syntax-case stx ()
|
|
[(_ #s(rep:once _ _ _)) #'#f]
|
|
[(_ #s(rep:optional _ _ _)) #'#f]
|
|
[(_ _) #'null]))
|
|
|
|
;; (rep:finalize RepConstraint expr) : expr
|
|
(define-syntax (rep:finalize stx)
|
|
(syntax-case stx ()
|
|
[(_ a #s(rep:optional _ _ defaults) v)
|
|
(with-syntax ([#s(attr name _ _) #'a]
|
|
[(#s(clause:attr da de) ...) #'defaults])
|
|
(let ([default
|
|
(for/or ([da (syntax->list #'(da ...))]
|
|
[de (syntax->list #'(de ...))])
|
|
(with-syntax ([#s(attr dname _ _) da])
|
|
(and (bound-identifier=? #'name #'dname) de)))])
|
|
(if default
|
|
#`(or v #,default)
|
|
#'v)))]
|
|
[(_ a #s(rep:once _ _ _) v) #'v]
|
|
[(_ a _ v) #'(reverse v)]))
|
|
|
|
;; (rep:min-number RepConstraint) : expr
|
|
(define-syntax (rep:min-number stx)
|
|
(syntax-case stx ()
|
|
[(_ #s(rep:once _ _ _)) #'1]
|
|
[(_ #s(rep:optional _ _ _)) #'0]
|
|
[(_ #s(rep:bounds min max _ _ _)) #'min]))
|
|
|
|
;; (rep:max-number RepConstraint) : expr
|
|
(define-syntax (rep:max-number stx)
|
|
(syntax-case stx ()
|
|
[(_ #s(rep:once _ _ _)) #'1]
|
|
[(_ #s(rep:optional _ _ _)) #'1]
|
|
[(_ #s(rep:bounds min max _ _ _)) #'max]))
|
|
|
|
;; (rep:combine RepConstraint expr expr) : expr
|
|
(define-syntax (rep:combine stx)
|
|
(syntax-case stx ()
|
|
[(_ #s(rep:once _ _ _) a b) #'a]
|
|
[(_ #s(rep:optional _ _ _) a b) #'a]
|
|
[(_ _ a b) #'(cons a b)]))
|
|
|
|
;; ----
|
|
|
|
;; (expectation Pattern)
|
|
(define-syntax (expectation stx)
|
|
(syntax-case stx ()
|
|
[(_ #s(pat:datum attrs d))
|
|
#'(begin (collect-error '(datum d))
|
|
(make-expect:atom 'd))]
|
|
[(_ #s(pat:literal attrs lit input-phase lit-phase))
|
|
#'(begin (collect-error '(literal lit))
|
|
(make-expect:literal (quote-syntax lit)))]
|
|
;; 2 pat:compound patterns
|
|
;;[(_ #s(pat:compound attrs #:pair (head-pattern tail-pattern)))
|
|
;; #'(make-expect:pair)]
|
|
[(_ #s(pat:compound attrs kind0 (part-pattern ...)))
|
|
#'(collect-error 'ineffable)]
|
|
[(_ #s(pat:not _ pattern))
|
|
#'(collect-error 'ineffable)]
|
|
[(_ #s(ghost:fail _ _e condition message))
|
|
#'(expectation-of-message message)]))
|
|
|
|
;; ----
|
|
|
|
(define-syntax-rule (expectation-of-thing description transparent? chained)
|
|
(make-expect:thing description transparent? chained))
|
|
|
|
(define-syntax-rule (expectation-of-message message)
|
|
(let ([msg (collect-error message)])
|
|
(if msg
|
|
(make-expect:message msg)
|
|
'ineffable)))
|
|
|
|
(define-syntax expectation-of-reps/too-few
|
|
(syntax-rules ()
|
|
[(_ rep #s(rep:once name too-few-msg too-many-msg))
|
|
(expectation-of-message/too-few too-few-msg name)]
|
|
[(_ rep #s(rep:optional name too-many-msg _))
|
|
(error 'impossible)]
|
|
[(_ rep #s(rep:bounds min max name too-few-msg too-many-msg))
|
|
(expectation-of-message/too-few too-few-msg name)]))
|
|
|
|
(define-syntax expectation-of-reps/too-many
|
|
(syntax-rules ()
|
|
[(_ rep #s(rep:once name too-few-msg too-many-msg))
|
|
(expectation-of-message/too-many too-many-msg name)]
|
|
[(_ rep #s(rep:optional name too-many-msg _))
|
|
(expectation-of-message/too-many too-many-msg name)]
|
|
[(_ rep #s(rep:bounds min max name too-few-msg too-many-msg))
|
|
(expectation-of-message/too-many too-many-msg name)]))
|
|
|
|
(define-syntax expectation-of-message/too-few
|
|
(syntax-rules ()
|
|
[(emtf #f #f)
|
|
(expectation-of-message "repetition constraint violated")]
|
|
[(emtf #f name)
|
|
(expectation-of-message
|
|
(format "missing required occurrence of ~a" name))]
|
|
[(emtf msg _)
|
|
(expectation-of-message msg)]))
|
|
|
|
(define-syntax expectation-of-message/too-many
|
|
(syntax-rules ()
|
|
[(emtm #f #f)
|
|
(expectation-of-message
|
|
(format "repetition constraint violated"))]
|
|
[(emtm #f name)
|
|
(expectation-of-message
|
|
(format "too many occurrences of ~a" name))]
|
|
[(emtm msg _)
|
|
(expectation-of-message msg)]))
|
|
|
|
;;
|
|
|
|
(define-syntax-parameter collect-error
|
|
(syntax-rules ()
|
|
[(ce thing) thing]
|
|
[(ce) '()]))
|
|
|
|
(define-syntax-rule (with-error-collector body)
|
|
(...
|
|
(let-syntax ([tmp (box null)])
|
|
(syntax-parameterize ((collect-error
|
|
(lambda (stx)
|
|
(let ([b (syntax-local-value #'tmp)])
|
|
(syntax-case stx ()
|
|
[(ce thing)
|
|
(begin (set-box! b (cons #'thing (unbox b)))
|
|
#'thing)]
|
|
[(ce)
|
|
(with-syntax ([(thing ...) (reverse (unbox b))])
|
|
#'(list #'thing ...))])))))
|
|
body))))
|