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

Using unsafe operations in racket/match

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/racket/match/compiler.rkt
View File

@ -116,6 +116,9 @@
;; all the rows are structures with the same predicate
(let* ([s (Row-first-pat (car rows))]
[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)])
(compile-con-pat accs pred Struct-ps))]
[else (error 'match-compile "bad key: ~a" k)]))

70
collects/racket/match/parse-helper.rkt
View File

@ -85,43 +85,47 @@
(let ([super (list-ref (extract-struct-info (syntax-local-value
struct-name))
5)])
(cond [(equal? super #t) '()] ;; no super type exists
[(equal? super #f) '()] ;; super type is unknown
[else (cons super (get-lineage super))])))
(cond [(equal? super #t) (values #t '())] ;; no super type exists
[(equal? super #f) (values #f '())] ;; super type is unknown
[else
(let-values ([(complete? lineage) (get-lineage super)])
(values complete?
(cons super lineage)))])))
(unless pred
(raise-syntax-error 'match (format "structure ~a does not have an associated predicate"
(syntax->datum struct-name))
stx struct-name))
(let* (;; the accessors come in reverse order
[acc (reverse acc)]
;; remove the first element, if it's #f
[acc (cond [(null? acc) acc]
[(not (car acc)) (cdr acc)]
[else acc])])
(make-Struct pred
(syntax-property
pred
'disappeared-use (list struct-name))
(get-lineage (cert struct-name))
acc
(cond [(eq? '_ (syntax-e pats))
(map make-Dummy acc)]
[(syntax->list pats)
=>
(lambda (ps)
(unless (= (length ps) (length acc))
(raise-syntax-error
'match
(format "~a structure ~a: expected ~a but got ~a"
"wrong number for fields for"
(syntax->datum struct-name) (length acc)
(length ps))
stx pats))
(map parse ps))]
[else (raise-syntax-error
'match
"improper syntax for struct pattern"
stx pats)]))))))
(let-values ([(complete? lineage) (get-lineage (cert struct-name))])
(let* (;; the accessors come in reverse order
[acc (reverse acc)]
;; remove the first element, if it's #f
[acc (cond [(null? acc) acc]
[(not (car acc)) (cdr acc)]
[else acc])])
(make-Struct pred
(syntax-property
pred
'disappeared-use (list struct-name))
lineage complete?
acc
(cond [(eq? '_ (syntax-e pats))
(map make-Dummy acc)]
[(syntax->list pats)
=>
(lambda (ps)
(unless (= (length ps) (length acc))
(raise-syntax-error
'match
(format "~a structure ~a: expected ~a but got ~a"
"wrong number for fields for"
(syntax->datum struct-name) (length acc)
(length ps))
stx pats))
(map parse ps))]
[else (raise-syntax-error
'match
"improper syntax for struct pattern"
stx pats)])))))))
(define (trans-match pred transformer pat)
(make-And (list (make-Pred pred) (make-App transformer pat))))

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

@ -55,9 +55,10 @@
;; pred is an identifier
;; super is an identifier, or #f
;; complete? is a boolean
;; accessors is a listof identifiers (NB in reverse order from the struct info)
;; 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
(define-struct (HashTable CPat) (key-pats val-pats) #:transparent)

12
collects/tests/match/plt-match-tests.rkt
View File

@ -179,6 +179,18 @@
(else #f)))
(check-true (origin? (make-point 0 0)))
(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