From 8358420fccb78f4f2aa20117fcbdccd73e4afb3a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 14 Jul 2012 18:25:11 -0400 Subject: [PATCH] Use `unstable/lazy-require` to dynamically-load the compile-time of `match`. --- collects/racket/match/define-forms.rkt | 7 +++- collects/racket/match/match-expander.rkt | 20 +++++++++- collects/racket/match/match.rkt | 15 +++++--- collects/racket/match/patterns.rkt | 49 ++---------------------- collects/racket/match/struct.rkt | 17 ++++---- collects/racket/match/stxtime.rkt | 29 ++++++++++++++ 6 files changed, 74 insertions(+), 63 deletions(-) create mode 100644 collects/racket/match/stxtime.rkt diff --git a/collects/racket/match/define-forms.rkt b/collects/racket/match/define-forms.rkt index 0cdbd0c7b7..61359627dc 100644 --- a/collects/racket/match/define-forms.rkt +++ b/collects/racket/match/define-forms.rkt @@ -5,8 +5,11 @@ (only-in racket/list append* remove-duplicates) unstable/sequence syntax/parse - "patterns.rkt" - "gen-match.rkt")) + unstable/lazy-require)) + +(begin-for-syntax + (lazy-require [racket/match/patterns (bound-vars)] + [racket/match/gen-match (go parse-id go/one)])) (provide define-forms) diff --git a/collects/racket/match/match-expander.rkt b/collects/racket/match/match-expander.rkt index 4cfee9aafc..c40632dd9a 100644 --- a/collects/racket/match/match-expander.rkt +++ b/collects/racket/match/match-expander.rkt @@ -1,10 +1,26 @@ #lang racket/base -(require (for-syntax racket/base - "patterns.rkt")) +(require (for-syntax racket/base "stxtime.rkt")) (provide define-match-expander) +(begin-for-syntax + (define make-match-expander + (let () + (define-struct match-expander (match-xform legacy-xform macro-xform) + #:property prop:set!-transformer + (λ (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)))) + (define-syntax (define-match-expander stx) (define (lookup v alist) (cond [(assoc v alist) => cadr] diff --git a/collects/racket/match/match.rkt b/collects/racket/match/match.rkt index d619b62347..e16d9d236c 100644 --- a/collects/racket/match/match.rkt +++ b/collects/racket/match/match.rkt @@ -6,11 +6,15 @@ (only-in "match-expander.rkt" define-match-expander) "define-forms.rkt" - "struct.rkt" - (for-syntax "parse.rkt" - (only-in "patterns.rkt" + "struct.rkt" + (for-syntax unstable/lazy-require + (only-in "stxtime.rkt" match-...-nesting - prop:match-expander prop:legacy-match-expander))) + prop:match-expander + prop:legacy-match-expander))) + +(begin-for-syntax + (lazy-require [racket/match/parse (parse)])) (provide (for-syntax match-...-nesting prop:match-expander prop:legacy-match-expander) @@ -22,4 +26,5 @@ (define-forms parse match match* match-lambda match-lambda* match-lambda** match-let match-let* match-let-values match-let*-values - match-define match-define-values match-letrec match/values match/derived match*/derived) + match-define match-define-values match-letrec match/values + match/derived match*/derived) diff --git a/collects/racket/match/patterns.rkt b/collects/racket/match/patterns.rkt index d259986f1a..3763f6812e 100644 --- a/collects/racket/match/patterns.rkt +++ b/collects/racket/match/patterns.rkt @@ -2,9 +2,12 @@ (require syntax/boundmap racket/contract + "stxtime.rkt" (for-syntax racket/base)) -(provide (except-out (all-defined-out) +(provide (except-out (combine-out + (all-defined-out) + (all-from-out "stxtime.rkt")) struct-key-ht get-key (struct-out Row))) @@ -176,8 +179,6 @@ [(Exact? p) null] [else (error 'match "bad pattern: ~a" p)])) -(define match-...-nesting (make-parameter 0)) - (define current-renaming (make-parameter (make-free-identifier-mapping))) (define (copy-mapping ht) @@ -208,45 +209,3 @@ [vars-seen (listof (cons/c identifier? identifier?))]))) - -(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/racket/match/struct.rkt b/collects/racket/match/struct.rkt index 5266e51c3f..8b34d24cc3 100644 --- a/collects/racket/match/struct.rkt +++ b/collects/racket/match/struct.rkt @@ -2,7 +2,7 @@ (require racket/match/match-expander (for-syntax racket/base racket/struct-info - syntax/boundmap + syntax/id-table racket/list)) (define-match-expander @@ -17,7 +17,7 @@ [v (if (identifier? #'struct-name) (syntax-local-value #'struct-name fail) (fail))] - [field-acc->pattern (make-free-identifier-mapping)]) + [field-acc->pattern (make-free-id-table)]) (unless (struct-info? v) (fail)) ; Check each pattern and capture the field-accessor name (for-each (lambda (an) @@ -34,9 +34,9 @@ (syntax-e #'struct-name) (syntax-e #'field))) #'field)]) - (when (free-identifier-mapping-get field-acc->pattern field-acc (lambda () #f)) + (when (free-id-table-ref field-acc->pattern field-acc #f) (raise-syntax-error 'struct* "Field name appears twice" stx #'field)) - (free-identifier-mapping-put! field-acc->pattern field-acc #'pat))] + (free-id-table-set! field-acc->pattern field-acc #'pat))] [_ (raise-syntax-error 'struct* "expected a field pattern of the form ( )" @@ -54,14 +54,13 @@ [pats-in-order (for/list ([field-acc (in-list acc)]) (begin0 - (free-identifier-mapping-get + (free-id-table-ref field-acc->pattern field-acc - (lambda () (syntax/loc stx _))) + (syntax/loc stx _)) ; Use up pattern - (free-identifier-mapping-put! - field-acc->pattern field-acc #f)))]) + (free-id-table-remove! field-acc->pattern field-acc)))]) ; Check that all patterns were used - (free-identifier-mapping-for-each + (free-id-table-for-each field-acc->pattern (lambda (field-acc pat) (when pat diff --git a/collects/racket/match/stxtime.rkt b/collects/racket/match/stxtime.rkt new file mode 100644 index 0000000000..9c2a5e3fe2 --- /dev/null +++ b/collects/racket/match/stxtime.rkt @@ -0,0 +1,29 @@ +#lang racket/base + +(provide (all-defined-out)) + +(define match-...-nesting (make-parameter 0)) + +(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 ))