From 0101f584fbf55c9484812de9ffcdbb2d9e29402a Mon Sep 17 00:00:00 2001
From: Sorawee Porncharoenwase <sorawee.pwase@gmail.com>
Date: Sat, 30 Jan 2021 03:49:59 -0800
Subject: [PATCH] struct*: fix incorrect struct-info extraction

Also add tests for `struct-copy` and `struct*` for cases
where struct-field-info is not available

Fixes #3662
---
 .../racket-test-core/tests/racket/struct.rktl | 23 ++++++++++++++++
 pkgs/racket-test/tests/match/main.rkt         | 27 ++++++++++++++++++-
 racket/collects/racket/match/struct.rkt       |  8 +++++-
 3 files changed, 56 insertions(+), 2 deletions(-)

diff --git a/pkgs/racket-test-core/tests/racket/struct.rktl b/pkgs/racket-test-core/tests/racket/struct.rktl
index 8bbfd2eefe..569febac08 100644
--- a/pkgs/racket-test-core/tests/racket/struct.rktl
+++ b/pkgs/racket-test-core/tests/racket/struct.rktl
@@ -1196,6 +1196,29 @@
   (struct a-b a (d) #:transparent)
   (syntax-test #'(struct-copy a-b (a-b 1 2) [c 10])))
 
+(module test-struct-copy-no-struct-field-info racket/base
+  (provide bar)
+  (require (for-syntax racket/struct-info
+                       racket/base))
+  (define (bar-car x) (car x))
+  (define (bar-cdr x) (cdr x))
+  (define (bar? x) (pair? x))
+
+  (struct foo ())
+
+  (define-syntax bar
+    (make-struct-info
+     (λ () (list #f
+                 #'cons
+                 #'bar?
+                 (list #'bar-cdr #'bar-car)
+                 (list #f #f)
+                 #'foo)))))
+
+(let ()
+  (local-require 'test-struct-copy-no-struct-field-info)
+  (test (cons 3 2) 'struct-copy1 (struct-copy bar (cons 1 2) [car 3])))
+
 (test #t prefab-key? 'apple)
 (test #f prefab-key? '#(apple))
 (test #t prefab-key? '(apple 4))
diff --git a/pkgs/racket-test/tests/match/main.rkt b/pkgs/racket-test/tests/match/main.rkt
index 383cd5bf26..2c1545a952 100644
--- a/pkgs/racket-test/tests/match/main.rkt
+++ b/pkgs/racket-test/tests/match/main.rkt
@@ -305,6 +305,25 @@
   (struct foo (a))
   (provide (rename-out [foo bar])))
 
+(module test-struct*-no-struct-field-info racket/base
+  (provide bar)
+  (require (for-syntax racket/struct-info
+                       racket/base))
+  (define (bar-car x) (car x))
+  (define (bar-cdr x) (cdr x))
+  (define (bar? x) (pair? x))
+
+  (struct foo ())
+
+  (define-syntax bar
+    (make-struct-info
+     (λ () (list #f
+                 #'cons
+                 #'bar?
+                 (list #'bar-cdr #'bar-car)
+                 (list #f #f)
+                 #'foo)))))
+
 (define struct*-tests
   (test-suite 
    "Tests of struct*"
@@ -403,7 +422,13 @@
                 (match-define
                   (struct* bar ([a x]))
                   (bar 1))
-                (check = x 1)))))
+                (check = x 1)))
+
+   (test-case "without struct-field-info"
+     (let ()
+       (local-require 'test-struct*-no-struct-field-info)
+       (match-define (struct* bar ([car x])) (list 1 2 3))
+       (check = x 1)))))
 
 (define plt-match-tests
   (test-suite "Tests for plt-match.rkt"
diff --git a/racket/collects/racket/match/struct.rkt b/racket/collects/racket/match/struct.rkt
index 7053724cb1..d9703d2ae4 100644
--- a/racket/collects/racket/match/struct.rkt
+++ b/racket/collects/racket/match/struct.rkt
@@ -11,7 +11,7 @@
   (define num-fields (length accessors))
   (define num-super-fields
     (if (identifier? parent)
-        (length (cadddr (syntax-local-value parent)))
+        (length (cadddr (id->struct-info parent orig-stx)))
         0))
   (define num-own-fields (- num-fields num-super-fields))
   (define own-accessors (take accessors num-own-fields))
@@ -21,6 +21,12 @@
     (string->symbol (substring (symbol->string (syntax-e accessor))
                                (add1 (string-length struct-name))))))
 
+(define-for-syntax (id->struct-info id stx)
+  (define compile-time-info (syntax-local-value id (lambda () #f)))
+  (unless (struct-info? compile-time-info)
+    (raise-syntax-error #f "identifier is not bound to a structure type" stx id))
+  (extract-struct-info compile-time-info))
+
 (define-match-expander
   struct*
   (lambda (stx)