
Changed backtracking algorithm, runtime representations - syntax classes, ~describe no longer implicitly commit - ~describe no longer delimits effect of cut Added keyword & optional args for stxclasses Added ~do and #:do, ~post, ~commit and #:commit, ~delimit-cut and #:no-delimit-cut Added syntax/parse/debug, syntax/parse/experimental/* - expr/c for contracting macro sub-expressions moved from syntax/parse to syntax/parse/experimental/contract - syntax class reflection (~reflect, ~splicing-reflect) - eh-alternative-sets (~eh-var) - provide-syntax-class/contract (only for params, not attrs so far) Changed ~fail to not include POST progress (#:fail still does) old (~fail _) is now (~post (~fail _)) Made msg argument of ~fail optional Removed generic "repetition constraint violated" msg Removed atom-in-list stxclass Removed unnecessary datum->syntax on cdr of pair pattern massive improvements to long-list microbenchmarks Optimization: integrable syntax classes (id, expr, keyword) need better measurements Optimization: ad hoc elimination of head/tail choice point for (EH ... . ()) patterns Added unstable/wrapc (proc version of expr/c)
105 lines
3.7 KiB
Racket
105 lines
3.7 KiB
Racket
#lang racket/base
|
|
(require unstable/struct
|
|
(for-syntax racket/base racket/struct-info unstable/struct))
|
|
(provide match make ?)
|
|
|
|
(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 make 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 var success failure)
|
|
(identifier? #'var)
|
|
#'(let ([var x]) success)]
|
|
[(match-p x (make S p ...) success failure)
|
|
#'(match-p x (struct S (p ...)) success failure)]
|
|
[(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 ...) (struct->list (syntax-e #'s))])
|
|
#'(let ([xkey (prefab-struct-key x)])
|
|
(if (equal? xkey 'key)
|
|
(let ([xps (struct->list x)])
|
|
(match-p xps (list p ...) success failure))
|
|
failure)))]
|
|
))
|
|
|
|
(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 struct
|
|
(lambda (stx)
|
|
(raise-syntax-error #f "illegal use of keyword" stx)))
|
|
|
|
(define-syntax ?
|
|
(lambda (stx)
|
|
(raise-syntax-error #f "illegal use of minimatch form '?'" stx)))
|