From 0101f584fbf55c9484812de9ffcdbb2d9e29402a Mon Sep 17 00:00:00 2001 From: Sorawee Porncharoenwase 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)