From 0c47e572c012b8bcdc0f67a9cc9800e8955c62bf Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Mon, 4 Oct 2010 15:54:05 -0600
Subject: [PATCH] Using unsafe operations in racket/match

---
 collects/racket/match/compiler.rkt       |  3 +
 collects/racket/match/parse-helper.rkt   | 70 +++++++++++++-----------
 collects/racket/match/patterns.rkt       |  3 +-
 collects/tests/match/plt-match-tests.rkt | 12 ++++
 4 files changed, 54 insertions(+), 34 deletions(-)

diff --git a/collects/racket/match/compiler.rkt b/collects/racket/match/compiler.rkt
index c32a4e12fe..533d877405 100644
--- a/collects/racket/match/compiler.rkt
+++ b/collects/racket/match/compiler.rkt
@@ -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)]))
diff --git a/collects/racket/match/parse-helper.rkt b/collects/racket/match/parse-helper.rkt
index 3d45825914..5b7f3bfa79 100644
--- a/collects/racket/match/parse-helper.rkt
+++ b/collects/racket/match/parse-helper.rkt
@@ -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))))
diff --git a/collects/racket/match/patterns.rkt b/collects/racket/match/patterns.rkt
index 9ba024c964..0b562ff57a 100644
--- a/collects/racket/match/patterns.rkt
+++ b/collects/racket/match/patterns.rkt
@@ -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)
diff --git a/collects/tests/match/plt-match-tests.rkt b/collects/tests/match/plt-match-tests.rkt
index a8b9b14657..ffd23cd20a 100644
--- a/collects/tests/match/plt-match-tests.rkt
+++ b/collects/tests/match/plt-match-tests.rkt
@@ -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