diff --git a/racket/collects/racket/match/compiler.rkt b/racket/collects/racket/match/compiler.rkt index 1b0204192a..950d08ff86 100644 --- a/racket/collects/racket/match/compiler.rkt +++ b/racket/collects/racket/match/compiler.rkt @@ -55,11 +55,15 @@ (Row-vars-seen row))) rows) esc)]) - #`[(#,predicate-stx #,x) rhs])) + (if (procedure? predicate-stx) + #`[#,(predicate-stx x) rhs] + #`[(#,predicate-stx #,x) rhs]))) (define (compile-con-pat accs pred pat-acc) (with-syntax* ([(tmps ...) (generate-temporaries accs)] [(accs ...) accs] - [pred pred] + [question (if (procedure? pred) + (pred x) + #`(#,pred #,x))] [body (compile* (append (syntax->list #'(tmps ...)) xs) (map (lambda (row) @@ -70,7 +74,7 @@ (Row-vars-seen row))) rows) esc)]) - #`[(pred #,x) (let ([tmps (accs #,x)] ...) body)])) + #`[question (let ([tmps (accs #,x)] ...) body)])) (cond [(eq? 'box k) (compile-con-pat (list #'unsafe-unbox*) #'box? (compose list Box-p))] @@ -123,6 +127,7 @@ [pred (Struct-pred s)]) (compile-con-pat accs pred Struct-ps))] [(syntax? k) (constant-pat k)] + [(procedure? k) (constant-pat k)] [else (error 'match-compile "bad key: ~a" k)])) @@ -256,7 +261,10 @@ [pats (Row-pats row)] [app-pats (App-ps first)]) (with-syntax ([(t ...) (generate-temporaries app-pats)]) - #`(let-values ([(t ...) (#,(App-expr first) #,x)]) + #`(let-values ([(t ...) + #,(if (procedure? (App-expr first)) + ((App-expr first) x) + #`(#,(App-expr first) #,x))]) #,(compile* (append (syntax->list #'(t ...)) xs) (list (make-Row (append app-pats (cdr pats)) (Row-rhs row) diff --git a/racket/collects/racket/match/parse-helper.rkt b/racket/collects/racket/match/parse-helper.rkt index 75abc86a66..57214671e3 100644 --- a/racket/collects/racket/match/parse-helper.rkt +++ b/racket/collects/racket/match/parse-helper.rkt @@ -8,7 +8,7 @@ "syntax-local-match-introduce.rkt") (provide ddk? parse-literal all-vars pattern-var? match:syntax-err - match-expander-transform trans-match parse-struct + match-expander-transform trans-match trans-match* parse-struct dd-parse parse-quote parse-id in-splicing?) (define in-splicing? (make-parameter #f)) @@ -155,6 +155,10 @@ (define (trans-match pred transformer pat) (make-OrderedAnd (list (make-Pred pred) (make-App transformer (list pat))))) +(define (trans-match* preds transformers pats) + (make-OrderedAnd (append (map make-Pred preds) + (map (λ (t p) (make-App t (list p))) transformers pats)))) + ;; transform a match-expander application ;; parse : stx -> pattern ;; expander : identifier diff --git a/racket/collects/racket/match/parse.rkt b/racket/collects/racket/match/parse.rkt index 74ec2463dd..07e0546902 100644 --- a/racket/collects/racket/match/parse.rkt +++ b/racket/collects/racket/match/parse.rkt @@ -18,6 +18,13 @@ (define orig-insp (variable-reference->module-declaration-inspector (#%variable-reference))) +(define (literal-pat? p) + (syntax-case p () + [(_quote e) + (eq? 'quote (syntax-e #'_quote)) + (parse-literal (syntax-e #'e))] + [_ (parse-literal (syntax-e p))])) + ;; parse : syntax -> Pat ;; compile stx into a pattern, using the new syntax (define (parse stx) @@ -88,6 +95,13 @@ (raise-syntax-error 'match "dot dot k can only appear at the end of hash-table patterns" stx (ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))] + [(hash-table (k v) ...) + (andmap (λ (p) (and (literal-pat? p) (not (identifier? p)))) (syntax->list #'(k ...))) + (let ([keys (map Exact-v (map literal-pat? (syntax->list #'(k ...))))]) + (trans-match* + (cons #'hash? (for/list ([k (in-list keys)]) (λ (e) #`(hash-has-key? #,e '#,k)))) + (for/list ([k (in-list keys)]) (λ (e) #`(hash-ref #,e '#,k))) + (map parse (syntax->list #'(v ...)))))] [(hash-table p ...) (trans-match #'hash? #'(lambda (e) (hash-map e list)) diff --git a/racket/collects/racket/match/patterns.rkt b/racket/collects/racket/match/patterns.rkt index ca95354537..c175293ba5 100644 --- a/racket/collects/racket/match/patterns.rkt +++ b/racket/collects/racket/match/patterns.rkt @@ -49,16 +49,17 @@ ;; (define-struct (Boolean Atom) () #:transparent) (define-struct (Null CPat) (p) #:transparent) -;; expr is an expression +;; expr is an expression or an (expression -> expression) procedure ;; ps is a list of patterns (define-struct (App Pat) (expr ps) #:transparent) -;; pred is an expression +;; pred is an expression, or an Expr -> Expr procedure (define-struct (Pred Pat) (pred) #:transparent #:property prop:equal+hash (list (lambda (a b e?) - (and (identifier? (Pred-pred a)) (identifier? (Pred-pred b)) - (free-identifier=? (Pred-pred a) (Pred-pred b)))) + (or (eq? (Pred-pred a) (Pred-pred b)) + (and (identifier? (Pred-pred a)) (identifier? (Pred-pred b)) + (free-identifier=? (Pred-pred a) (Pred-pred b))))) (lambda (v r) (if (identifier? (Pred-pred v)) (r (syntax-e (Pred-pred v))) @@ -75,9 +76,6 @@ ;; ps is a listof patterns (define-struct (Struct CPat) (id pred super complete? accessors ps) #:transparent) -;; both fields are lists of pats -(define-struct (HashTable CPat) (key-pats val-pats) #:transparent) - ;; ps are patterns (define-struct (Or Pat) (ps) #:transparent) (define-struct (And Pat) (ps) #:transparent)