suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Use unstable/lazy-require to dynamically-load the compile-time of match.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2012-07-14 18:25:11 -04:00
parent b987be068e
commit 8358420fcc
6 changed files with 74 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/racket/match/define-forms.rkt
View File

@ -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)

20
collects/racket/match/match-expander.rkt
View File

@ -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]

15
collects/racket/match/match.rkt
View File

@ -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)

49
collects/racket/match/patterns.rkt
View File

@ -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)

17
collects/racket/match/struct.rkt
View File

@ -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 (<field-id> <pat>)"
@ -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

29
collects/racket/match/stxtime.rkt Normal file
View File

@ -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 ))