From 591dcc4a278f680e4c473e49703891965510ff94 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 13 Nov 2011 22:10:05 -0500 Subject: [PATCH] Add `prop:match-expander' and `prop:legacy-match-expander'. --- collects/racket/match/match.rkt | 11 ++-- collects/racket/match/parse-helper.rkt | 5 +- collects/racket/match/parse-legacy.rkt | 6 +-- collects/racket/match/parse.rkt | 2 +- collects/racket/match/patterns.rkt | 63 +++++++++++++++------- collects/scribblings/reference/match.scrbl | 29 ++++++++++ 6 files changed, 88 insertions(+), 28 deletions(-) diff --git a/collects/racket/match/match.rkt b/collects/racket/match/match.rkt index 6b6eb9179b..d619b62347 100644 --- a/collects/racket/match/match.rkt +++ b/collects/racket/match/match.rkt @@ -6,14 +6,17 @@ (only-in "match-expander.rkt" define-match-expander) "define-forms.rkt" - "struct.rkt" + "struct.rkt" (for-syntax "parse.rkt" - (only-in "patterns.rkt" match-...-nesting))) + (only-in "patterns.rkt" + match-...-nesting + prop:match-expander prop:legacy-match-expander))) -(provide (for-syntax match-...-nesting) +(provide (for-syntax match-...-nesting + prop:match-expander prop:legacy-match-expander) match-equality-test define-match-expander - struct* == + struct* == exn:misc:match?) (define-forms parse diff --git a/collects/racket/match/parse-helper.rkt b/collects/racket/match/parse-helper.rkt index 200c669688..2d8e5d1436 100644 --- a/collects/racket/match/parse-helper.rkt +++ b/collects/racket/match/parse-helper.rkt @@ -138,13 +138,16 @@ error-msg) (let* ([expander* (syntax-local-value expander)] [transformer (accessor expander*)] + ;; this transformer might have been defined w/ `syntax-id-rules' [transformer (if (set!-transformer? transformer) (set!-transformer-procedure transformer) transformer)]) (unless transformer (raise-syntax-error #f error-msg expander*)) (let* ([introducer (make-syntax-introducer)] [mstx (introducer (syntax-local-introduce stx))] - [mresult (transformer mstx)] + [mresult (if (procedure-arity-includes? transformer 2) + (transformer expander* mstx) + (transformer mstx))] [result (syntax-local-introduce (introducer mresult))]) ;(emit-local-step stx result #:id expander) (parse result)))) diff --git a/collects/racket/match/parse-legacy.rkt b/collects/racket/match/parse-legacy.rkt index 4697acba61..d717f988bc 100644 --- a/collects/racket/match/parse-legacy.rkt +++ b/collects/racket/match/parse-legacy.rkt @@ -18,10 +18,10 @@ (lambda (x y) (eq? (syntax-e x) (syntax-e y))) [(expander args ...) (and (identifier? #'expander) - (match-expander? - (syntax-local-value #'expander (lambda () #f)))) + (legacy-match-expander? + (syntax-local-value #'expander (λ () #f)))) (match-expander-transform - parse #'expander disarmed-stx match-expander-legacy-xform + parse #'expander disarmed-stx legacy-match-expander-proc "This expander only works with the standard match syntax")] [(and p ...) (make-And (map parse (syntax->list #'(p ...))))] diff --git a/collects/racket/match/parse.rkt b/collects/racket/match/parse.rkt index 585aebec90..541870229f 100644 --- a/collects/racket/match/parse.rkt +++ b/collects/racket/match/parse.rkt @@ -32,7 +32,7 @@ (match-expander? (syntax-local-value #'expander (lambda () #f)))) (match-expander-transform - rearm+parse #'expander disarmed-stx match-expander-match-xform + rearm+parse #'expander disarmed-stx match-expander-proc "This expander only works with the legacy match syntax")] [(var v) (identifier? #'v) diff --git a/collects/racket/match/patterns.rkt b/collects/racket/match/patterns.rkt index c780e4fd79..2bd95e22e1 100644 --- a/collects/racket/match/patterns.rkt +++ b/collects/racket/match/patterns.rkt @@ -1,8 +1,8 @@ -#lang scheme/base +#lang racket/base (require syntax/boundmap - scheme/contract - (for-syntax scheme/base)) + racket/contract + (for-syntax racket/base)) (provide (except-out (all-defined-out) struct-key-ht @@ -208,20 +208,45 @@ [vars-seen (listof (cons/c identifier? identifier?))]))) -(define-struct match-expander (match-xform legacy-xform macro-xform) -#| #:property prop:procedure (lambda (me stx) - (define xf (match-expander-macro-xform me)) - (define xf* (if (set!-transformer? xf) - (set!-transformer-procedure xf) - xf)) - (xf* stx))|# - #:property prop:set!-transformer (lambda (me stx) - (define xf (match-expander-macro-xform me)) - (if (set!-transformer? xf) - ((set!-transformer-procedure xf) stx) - (syntax-case stx (set!) - [(set! . _) - (raise-syntax-error #f "cannot mutate syntax identifier" stx)] - [_ (xf stx)])))) -(provide (struct-out match-expander)) +(struct acc-prop (n acc)) +(define (make-struct-type-property/accessor name [guard #f] [supers null]) + (define-values (p pred? acc) + (make-struct-type-property name + (λ (pval sinfo) + (cond [(exact-nonnegative-integer? pval) + (acc-prop pval (cadddr sinfo))] + [else (if (procedure? guard) + (guard pval sinfo) + pval)])) + supers)) + (values p pred? (lambda (v) + (define v* (acc v)) + (if (acc-prop? v*) + ((acc-prop-acc v*) v (acc-prop-n v*)) + v*)))) + +(define-values (prop:match-expander match-expander? match-expander-proc) + (make-struct-type-property/accessor 'prop:match-expander)) + +(define-values (prop:legacy-match-expander legacy-match-expander? legacy-match-expander-proc) + (make-struct-type-property/accessor 'prop:legacy-match-expander )) + +(define make-match-expander + (let () + (define-struct match-expander (match-xform legacy-xform macro-xform) + #:property prop:set!-transformer (lambda (me stx) + (define xf (match-expander-macro-xform me)) + (if (set!-transformer? xf) + ((set!-transformer-procedure xf) stx) + (syntax-case stx (set!) + [(set! . _) + (raise-syntax-error #f "cannot mutate syntax identifier" stx)] + [_ (xf stx)]))) + #:property prop:match-expander (struct-field-index match-xform) + #:property prop:legacy-match-expander (struct-field-index legacy-xform)) + (values make-match-expander))) + +(provide match-expander? legacy-match-expander? + match-expander-proc legacy-match-expander-proc + prop:match-expander prop:legacy-match-expander) diff --git a/collects/scribblings/reference/match.scrbl b/collects/scribblings/reference/match.scrbl index 8eefe8b1c2..6274d51165 100644 --- a/collects/scribblings/reference/match.scrbl +++ b/collects/scribblings/reference/match.scrbl @@ -525,6 +525,35 @@ For example, to extend the pattern matcher and destructure syntax lists, } +@defthing[prop:match-expander struct-type-property?]{ + +A @tech{structure type property} to identify structure types that act +as @tech{match expanders} like the ones created by +@racket[define-match-expander]. + +The property value must be an exact non-negative integer or a +procedure of one or two arguments. In the former case, the integer +designates a field within the structure that should contain a +procedure; the integer must be between @racket[0] (inclusive) and the +number of non-automatic fields in the structure type (exclusive, not +counting supertype fields), and the designated field must also be +specified as immutable. + +If the property value is a procedure of one argument, then the +procedure serves as the transformer for match expansion. If the property value is a procedure of two +arguments, then the first argument is the structure whose type has +@racket[prop:match-expander] property, and the second argument is a +syntax object as for a @tech{match expander}.. + +If the property value is a @tech{assignment transformer}, then the wrapped +procedure is extracted with +@racket[set!-transformer-procedure] before it is called. +} + +@defthing[prop:legacy-match-expander struct-type-property?]{ +Like @racket[prop:match-expander], but for the legacy match syntax. +} + @defparam[match-equality-test comp-proc (any/c any/c . -> . any)]{