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

Support prefab struct literals in quasipatterns.

Browse Source 
Fixes PR 10050.

svn: r17495
This commit is contained in:
Sam Tobin-Hochstadt 2010-01-06 16:41:17 +00:00
parent 3006abec4b
commit ac9d2d8d9e
4 changed files with 61 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/scheme/match/compiler.ss
View File

@ -8,7 +8,8 @@
"reorder.ss"
scheme/struct-info
scheme/stxparam
scheme/nest)
scheme/nest
unstable/syntax)
(provide compile*)
@ -43,8 +44,8 @@
esc)])
#`[(#,predicate-stx #,x) rhs]))
(define (compile-con-pat accs pred pat-acc)
(with-syntax ([(tmps ...) (generate-temporaries accs)])
(with-syntax ([(accs ...) accs]
(with-syntax* ([(tmps ...) (generate-temporaries accs)]
[(accs ...) accs]
[pred pred]
[body (compile*
(append (syntax->list #'(tmps ...)) xs)
@ -56,7 +57,7 @@
(Row-vars-seen row)))
rows)
esc)])
#`[(pred #,x) (let ([tmps (accs #,x)] ...) body)])))
#`[(pred #,x) (let ([tmps (accs #,x)] ...) body)]))
(cond
[(eq? 'box k)
(compile-con-pat (list #'unbox) #'box? (compose list Box-p))]
@ -116,7 +117,22 @@
[accs (Struct-accessors s)]
[pred (Struct-pred s)])
(compile-con-pat accs pred Struct-ps))]
[else (error 'compile "bad key: ~a" k)]))
;; it's a prefab struct
[(list? k)
(let* ([s (Row-first-pat (car rows))]
[key (PrefabStruct-key s)]
[pats (PrefabStruct-ps s)])
(with-syntax*
([struct-type-id (syntax-local-lift-expression #`(prefab-key->struct-type '#,key #,(length pats)))]
[(_ _ _ acc-proc _ _ _ _) (syntax-local-lift-values-expression 8 #`(struct-type-info struct-type-id))])
(compile-con-pat
(for/list ([p pats]
[i (in-naturals)])
#`(make-struct-field-accessor acc-proc #,i)
#;#`(lambda (val) (acc-proc val #,i)))
#`(struct-type-make-predicate struct-type-id)
PrefabStruct-ps)))]
[else (error 'match-compile "bad key: ~a" k)]))
;; produces the syntax for a let clause

10
collects/scheme/match/parse-quasi.ss
View File

@ -57,6 +57,16 @@
(pq #'rest)
#f))]
[(a . b) (make-Pair (pq #'a) (pq #'b))]
;; prefab structs
[struct
(prefab-struct-key (syntax-e #'struct))
(let ([key (prefab-struct-key (syntax-e #'struct))]
[pats (cdr (vector->list (struct->vector (syntax-e #'struct))))])
(make-And (list (make-Pred #`(struct-type-make-predicate (prefab-key->struct-type '#,key #,(length pats))))
(make-App #'struct->vector
(make-Vector (cons (make-Dummy #f) (map pq pats))))))
#;
(make-PrefabStruct key (map pq pats)))]
;; the hard cases
[#(p ...)
(ormap (lambda (p)

7
collects/scheme/match/patterns.ss
View File

@ -59,6 +59,10 @@
;; ps is a listof patterns
(define-struct (Struct CPat) (id pred super accessors ps) #:transparent)
;; ps is a listof patterns
;; key is a prefab struct key
(define-struct (PrefabStruct CPat) (key pred accessors ps) #:transparent)
;; both fields are lists of pats
(define-struct (HashTable CPat) (key-pats val-pats) #:transparent)
@ -105,6 +109,7 @@
;; the result is #f if p is not a constructor pattern
(define (pat-key p)
(cond [(Struct? p) (get-key (Struct-id p))]
[(PrefabStruct? p) (list (PrefabStruct-key p))]
[(Box? p) 'box]
[(Vector? p) 'vector]
[(Pair? p) 'pair]
@ -167,6 +172,8 @@
(merge (map bound-vars (Vector-ps p)))]
[(Struct? p)
(merge (map bound-vars (Struct-ps p)))]
[(PrefabStruct? p)
(merge (map bound-vars (PrefabStruct-ps p)))]
[(App? p)
(bound-vars (App-p p))]
[(Not? p) null]

18
collects/tests/match/examples.ss
View File

@ -608,4 +608,22 @@
(match `(begin 1 2 3)
[`(begin ,es ... ,en)
(list es en)]))
(comp '(a b c)
(let ()
(define-struct foo (a b c) #:prefab)
(match (make-foo 'a 'b 'c)
[`#s(foo ,x ,y ,z)
(list x y z)])))
(comp '(a b c)
(let ()
(define-struct foo (a b c) #:prefab)
(define-struct (bar foo) (d) #:prefab)
(match (make-bar 'a 'b 'c 1)
[`#s((bar foo 3) ,x ,y ,z ,w)
(list x y z)])
))
))