Make struct* use static struct field information

This PR is largely based on #732

Fixes #3265
Closes #732

pkgs/racket-doc/scribblings/reference/match.scrbl

@@ -808,6 +808,7 @@ not provided, it defaults to @racket[equal?].
  A @racket[match] pattern form that matches an instance of a structure
  type named @racket[struct-id], where the field @racket[field] in the
  instance matches the corresponding @racket[pat].
+ The fields do not include those from super types.
 
  Any field of @racket[struct-id] may be omitted, and such fields can
  occur in any order.
@@ -815,11 +816,16 @@ not provided, it defaults to @racket[equal?].
  @examples[
   #:eval match-eval
   (eval:no-prompt
-   (struct tree (val left right)))
+   (struct tree (val left right))
+   (struct tree* tree (val)))
   (match (tree 0 (tree 1 #f #f) #f)
     [(struct* tree ([val a]
                     [left (struct* tree ([right #f] [val b]))]))
      (list a b)])
+  (match (tree* 0 #f #f 42)
+    [(and (struct* tree* ([val a]))
+          (struct* tree ([val b])))
+     (list a b)])
  ]
  }
 

pkgs/racket-test/tests/match/main.rkt

@@ -3,7 +3,8 @@
 (require (for-syntax scheme/base)
          "match-tests.rkt" "match-exn-tests.rkt" "other-plt-tests.rkt" "other-tests.rkt"
          "examples.rkt"
-         rackunit rackunit/text-ui)
+         rackunit rackunit/text-ui
+         (only-in racket/base local-require))
 
 (require mzlib/plt-match)
 
@@ -300,6 +301,10 @@
    
    ))
 
+(module test-struct*-struct-info racket/base
+  (struct foo (a))
+  (provide (rename-out [foo bar])))
+
 (define struct*-tests
   (test-suite 
    "Tests of struct*"
@@ -381,7 +386,24 @@
                       [val b]))]))
                  (make-tree 0 (make-tree 1 #f #f) #f))
                 (check = 0 a)
-                (check = 1 b)))))
+                (check = 1 b)))
+   (test-case "also from documentation"
+              (let ()
+                (define-struct tree (val left right))
+                (define-struct (tree* tree) (val))
+                (match-define
+                  (and (struct* tree* ([val a]))
+                       (struct* tree ([val b])))
+                  (tree* 0 #f #f 42))
+                (check = 42 a)
+                (check = 0 b)))
+   (test-case "hygiene"
+              (let ()
+                (local-require 'test-struct*-struct-info)
+                (match-define
+                  (struct* bar ([a x]))
+                  (bar 1))
+                (check = x 1)))))
 
 (define plt-match-tests
   (test-suite "Tests for plt-match.rkt"

racket/collects/racket/contract/private/provide.rkt

@@ -18,6 +18,7 @@
                      racket/string
                      racket/struct-info
                      setup/path-to-relative
+                     "../../private/struct-util.rkt"
                      "application-arity-checking.rkt"
                      "arr-i-parse.rkt"
                      (prefix-in a: "helpers.rkt")
@@ -1085,20 +1086,6 @@
                         (loop (cdr l1)
                               (+ i 1)))])))
 
-       (define (predicate->struct-name orig-stx stx)
-         (if stx
-             (let ([m (regexp-match #rx"^(.*)[?]$" (format "~a" (syntax-e stx)))])
-               (cond
-                 [m (cadr m)]
-                 [else (raise-syntax-error
-                        who
-                        "unable to cope with a struct supertype whose predicate doesn't end with `?'"
-                        orig-stx)]))
-             (raise-syntax-error
-              who
-              "unable to cope with a struct whose predicate is unknown"
-              orig-stx)))
-
        ;; get-field-names/no-field-info :: string?
        ;;                                  (listof identifier?)
        ;;                                  (or/c identifier? boolean?)
@@ -1137,7 +1124,7 @@
          (define predicate (list-ref struct-info-list 2))
          (define accessors (list-ref struct-info-list 3))
          (define super-info (list-ref struct-info-list 5))
-         (define struct-name (predicate->struct-name provide-stx predicate))
+         (define struct-name (predicate->struct-name who provide-stx predicate))
          (define immediate-field-names
            (if (struct-field-info? the-struct-info)
                (struct-field-info-list the-struct-info)

racket/collects/racket/match/struct.rkt

@@ -2,8 +2,24 @@
 (require racket/match/match-expander
          (for-syntax racket/base
                      racket/struct-info
-                     syntax/id-table
+                     racket/list
-                     racket/list))
+                     "../private/struct-util.rkt"))
+
+(define-for-syntax (extract-field-names orig-stx the-struct-info)
+  (define accessors (list-ref the-struct-info 3))
+  (define parent (list-ref the-struct-info 5))
+  (define num-fields (length accessors))
+  (define num-super-fields
+    (if (identifier? parent)
+        (length (cadddr (syntax-local-value parent)))
+        0))
+  (define num-own-fields (- num-fields num-super-fields))
+  (define own-accessors (take accessors num-own-fields))
+  (define struct-name (predicate->struct-name 'struct* orig-stx (list-ref the-struct-info 2)))
+  (for/list ([accessor (in-list own-accessors)])
+    ;; add1 for hyphen
+    (string->symbol (substring (symbol->string (syntax-e accessor))
+                               (add1 (string-length struct-name))))))
 
 (define-match-expander
   struct*
@@ -17,57 +33,44 @@
               [v (if (identifier? #'struct-name)
                      (syntax-local-value #'struct-name fail)
                      (fail))]
-              [field-acc->pattern (make-free-id-table)])
+              [field->pattern (make-hash)])
          (unless (struct-info? v) (fail))
-         ; Check each pattern and capture the field-accessor name
+         (define the-struct-info (extract-struct-info v))
-         (for-each (lambda (an)
+
-                     (syntax-case an ()
+         ;; own-fields and all-accessors are in the reverse order
-                       [(field pat)
+         (define all-accessors (list-ref the-struct-info 3))
-                        (unless (identifier? #'field)
+         (define own-fields
-                          (raise-syntax-error 
+           (if (struct-field-info? v)
-                           'struct* "not an identifier for field name" 
+               (struct-field-info-list v)
-                           stx #'field))
+               (extract-field-names stx the-struct-info)))
-                        (let ([field-acc
+         ;; Use hash instead of set so that we don't need to require racket/set
-                               (datum->syntax #'field
+         (define field-set (for/hash ([field own-fields]) (values field #t)))
-                                              (string->symbol
+
-                                               (format "~a-~a"
+         ;; Check that all field names are valid
-                                                       (syntax-e #'struct-name)
+         (for ([an (in-list (syntax->list #'(field+pat ...)))])
-                                                       (syntax-e #'field)))
+           (syntax-case an ()
-                                              #'field)])
+             [(field pat)
-                          (when (free-id-table-ref field-acc->pattern field-acc #f)
+              (let ([fail-field (λ (msg) (raise-syntax-error 'struct* msg stx #'field))])
-                            (raise-syntax-error 'struct* "Field name appears twice" stx #'field)) 
+                (unless (identifier? #'field)
-                          (free-id-table-set! field-acc->pattern field-acc #'pat))]
+                  (fail-field "not an identifier for field name"))
-                       [_
+                (define name (syntax-e #'field))
-                        (raise-syntax-error
+                (unless (hash-has-key? field-set name)
-                         'struct* "expected a field pattern of the form (<field-id> <pat>)"
+                  (fail-field "field name not associated with given structure type"))
-                         stx an)]))
+                (when (hash-has-key? field->pattern name)
-                   (syntax->list #'(field+pat ...)))
+                  (fail-field "field name appears twice"))
-         (let* (; Get the structure info
+                (hash-set! field->pattern name #'pat))]
-                [acc (fourth (extract-struct-info v))]
+             [_ (raise-syntax-error
-                ;; the accessors come in reverse order
+                 'struct* "expected a field pattern of the form (<field-id> <pat>)"
-                [acc (reverse acc)]
+                 stx an)]))
-                ;; remove the first element, if it's #f
+
-                [acc (cond [(empty? acc) acc]
+         ;; pats is in the reverse order
-                           [(not (first acc)) (rest acc)]
+         (define pats
-                           [else acc])]
+           (for/list ([field (in-sequences (in-list own-fields)
-                ; Order the patterns in the order of the accessors
+                                           (in-cycle '(#f)))]
-                [pats-in-order
+                      [accessor (in-list all-accessors)]
-                 (for/list ([field-acc (in-list acc)])
+                      #:when accessor)
-                   (begin0
+             (hash-ref field->pattern field (syntax/loc stx _))))
-                     (free-id-table-ref
+         (quasisyntax/loc stx (struct struct-name #,(reverse pats))))])))
-                      field-acc->pattern field-acc
-                      (syntax/loc stx _))
-                     ; Use up pattern
-                     (free-id-table-remove! field-acc->pattern field-acc)))])
-           ; Check that all patterns were used
-           (free-id-table-for-each
-            field-acc->pattern
-            (lambda (field-acc pat)
-              (when pat
-                (raise-syntax-error 'struct* "field name not associated with given structure type"
-                                    stx field-acc))))
-           (quasisyntax/loc stx
-             (struct struct-name #,pats-in-order))))])))
 
 (provide struct* ==)
 

racket/collects/racket/private/define-struct.rkt

@@ -10,7 +10,8 @@
                          "stx.rkt" "stxcase-scheme.rkt" "qq-and-or.rkt" "cond.rkt"
                          "define-et-al.rkt"
                          "stxloc.rkt" "qqstx.rkt"
-                         "struct-info.rkt"))
+                         "struct-info.rkt"
+                         "struct-util.rkt"))
 
   (#%provide define-struct*
              define-struct/derived
@@ -899,16 +900,6 @@
       [(null? xs) xs]
       [else (cons (car xs) (take (cdr xs) (sub1 n)))]))
 
-  ;; modified from racket/collects/racket/contract/private/provide.rkt
-  (define-for-syntax (predicate->struct-name orig-stx stx)
-    (cond
-      [(regexp-match #rx"^(.*)[?]$" (format "~a" (syntax-e stx))) => cadr]
-      [else
-       (raise-syntax-error
-        #f
-        "unable to cope with a struct type whose predicate doesn't end with `?'"
-        orig-stx)]))
-
   (define-for-syntax (find-accessor/no-field-info the-struct-info fld stx)
     (define accessors (list-ref the-struct-info 3))
     (define parent (list-ref the-struct-info 5))
@@ -920,7 +911,7 @@
           0))
     (define num-own-fields (- num-fields num-super-fields))
     (define own-accessors (take accessors num-own-fields))
-    (define struct-name (predicate->struct-name stx (list-ref the-struct-info 2)))
+    (define struct-name (predicate->struct-name #f stx (list-ref the-struct-info 2)))
     (define accessor-name (string->symbol (format "~a-~a" struct-name (syntax-e fld))))
     (or (findf (λ (a) (eq? accessor-name (syntax-e a))) own-accessors)
         (raise-syntax-error

racket/collects/racket/private/struct-util.rkt

@@ -0,0 +1,22 @@
+(module struct-util '#%kernel
+  (#%require "define.rkt"
+             "cond.rkt")
+
+  (#%provide predicate->struct-name)
+
+  ;; predicate->struct-name : any/c syntax? (or/c identifier? #f) -> string?
+  ;; Infers struct name from a predicate identifier. This is used as a fallback
+  ;; method to extract field names when struct-field-info is not available.
+  (define (predicate->struct-name who orig-stx stx)
+    (if stx
+        (cond
+          [(regexp-match #rx"^(.*)[?]$" (symbol->string (syntax-e stx))) => cadr]
+          [else
+           (raise-syntax-error
+            who
+            "unable to cope with a struct type whose predicate doesn't end with `?'"
+            orig-stx)])
+        (raise-syntax-error
+         who
+         "unable to cope with a struct whose predicate is unknown"
+         orig-stx))))