Using unsafe operations in racket/match

This commit is contained in:
Jay McCarthy 2010-10-04 15:54:05 -06:00
parent 0965af6c69
commit 0c47e572c0
4 changed files with 54 additions and 34 deletions

View File

@ -116,6 +116,9 @@
;; all the rows are structures with the same predicate ;; all the rows are structures with the same predicate
(let* ([s (Row-first-pat (car rows))] (let* ([s (Row-first-pat (car rows))]
[accs (Struct-accessors s)] [accs (Struct-accessors s)]
[accs (if (Struct-complete? s)
(build-list (length accs) (λ (i) #`(λ (x) (unsafe-struct*-ref x #,i))))
accs)]
[pred (Struct-pred s)]) [pred (Struct-pred s)])
(compile-con-pat accs pred Struct-ps))] (compile-con-pat accs pred Struct-ps))]
[else (error 'match-compile "bad key: ~a" k)])) [else (error 'match-compile "bad key: ~a" k)]))

View File

@ -85,13 +85,17 @@
(let ([super (list-ref (extract-struct-info (syntax-local-value (let ([super (list-ref (extract-struct-info (syntax-local-value
struct-name)) struct-name))
5)]) 5)])
(cond [(equal? super #t) '()] ;; no super type exists (cond [(equal? super #t) (values #t '())] ;; no super type exists
[(equal? super #f) '()] ;; super type is unknown [(equal? super #f) (values #f '())] ;; super type is unknown
[else (cons super (get-lineage super))]))) [else
(let-values ([(complete? lineage) (get-lineage super)])
(values complete?
(cons super lineage)))])))
(unless pred (unless pred
(raise-syntax-error 'match (format "structure ~a does not have an associated predicate" (raise-syntax-error 'match (format "structure ~a does not have an associated predicate"
(syntax->datum struct-name)) (syntax->datum struct-name))
stx struct-name)) stx struct-name))
(let-values ([(complete? lineage) (get-lineage (cert struct-name))])
(let* (;; the accessors come in reverse order (let* (;; the accessors come in reverse order
[acc (reverse acc)] [acc (reverse acc)]
;; remove the first element, if it's #f ;; remove the first element, if it's #f
@ -102,7 +106,7 @@
(syntax-property (syntax-property
pred pred
'disappeared-use (list struct-name)) 'disappeared-use (list struct-name))
(get-lineage (cert struct-name)) lineage complete?
acc acc
(cond [(eq? '_ (syntax-e pats)) (cond [(eq? '_ (syntax-e pats))
(map make-Dummy acc)] (map make-Dummy acc)]
@ -121,7 +125,7 @@
[else (raise-syntax-error [else (raise-syntax-error
'match 'match
"improper syntax for struct pattern" "improper syntax for struct pattern"
stx pats)])))))) stx pats)])))))))
(define (trans-match pred transformer pat) (define (trans-match pred transformer pat)
(make-And (list (make-Pred pred) (make-App transformer pat)))) (make-And (list (make-Pred pred) (make-App transformer pat))))

View File

@ -55,9 +55,10 @@
;; pred is an identifier ;; pred is an identifier
;; super is an identifier, or #f ;; super is an identifier, or #f
;; complete? is a boolean
;; accessors is a listof identifiers (NB in reverse order from the struct info) ;; accessors is a listof identifiers (NB in reverse order from the struct info)
;; ps is a listof patterns ;; ps is a listof patterns
(define-struct (Struct CPat) (id pred super accessors ps) #:transparent) (define-struct (Struct CPat) (id pred super complete? accessors ps) #:transparent)
;; both fields are lists of pats ;; both fields are lists of pats
(define-struct (HashTable CPat) (key-pats val-pats) #:transparent) (define-struct (HashTable CPat) (key-pats val-pats) #:transparent)

View File

@ -179,6 +179,18 @@
(else #f))) (else #f)))
(check-true (origin? (make-point 0 0))) (check-true (origin? (make-point 0 0)))
(check-false (origin? (make-point 1 1))))) (check-false (origin? (make-point 1 1)))))
; This test ensures that the unsafe struct optimization is correct
(test-case "struct patterns (with opaque parent)"
(let ()
(define-struct opq (any))
(parameterize ([current-inspector (make-sibling-inspector)])
(define-struct point (x y) #:super struct:opq)
(define (origin? pt)
(match pt
((struct point (0 0)) #t)
(else #f)))
(check-true (origin? (make-point 'a 0 0)))
(check-false (origin? (make-point 'a 1 1))))))
)) ))
(define nonlinear-tests (define nonlinear-tests