From e8fa0613db40ed6fcca58d4f55ee9dfeedcdfd24 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 9 Feb 2020 18:27:14 -0700
Subject: [PATCH] cs: fix internal issues in struct [property] layer

---
 racket/src/cs/rumble/procedure.ss |  1 +
 racket/src/cs/rumble/struct.ss    | 37 ++++++++++++++++++-------------
 2 files changed, 23 insertions(+), 15 deletions(-)

diff --git a/racket/src/cs/rumble/procedure.ss b/racket/src/cs/rumble/procedure.ss
index 12213d0870..b992a419ca 100644
--- a/racket/src/cs/rumble/procedure.ss
+++ b/racket/src/cs/rumble/procedure.ss
@@ -449,6 +449,7 @@
      (do-procedure-reduce-arity-mask proc mask name)]
     [(proc mask) (procedure-reduce-arity-mask proc mask #f)]))
 
+;; see also `procedure-rename*` in "struct.ss"
 (define (do-procedure-reduce-arity-mask proc mask name)
   (cond
    [(and (wrapper-procedure? proc)
diff --git a/racket/src/cs/rumble/struct.ss b/racket/src/cs/rumble/struct.ss
index d434ecd3a3..bc0c381d67 100644
--- a/racket/src/cs/rumble/struct.ss
+++ b/racket/src/cs/rumble/struct.ss
@@ -41,14 +41,13 @@
                  (and (procedure? guard)
                       (procedure-arity-includes? guard 2)))
        (raise-argument-error who "(or/c (procedure-arity-includes/c 2) #f 'can-impersonate)" guard))
-     (unless (and (or (null? supers) ; avoid `list?` until it's defined
-                      (list? supers))
-                  (andmap (lambda (p)
-                            (and (pair? p)
-                                 (struct-type-property? (car p))
-                                 (procedure? (cdr p))
-                                 (procedure-arity-includes? (cdr p) 1)))
-                          supers))
+     (unless (and (#%list? supers)
+                  (#%andmap (lambda (p)
+                              (and (pair? p)
+                                   (struct-type-property? (car p))
+                                   (procedure? (cdr p))
+                                   (procedure-arity-includes? (cdr p) 1)))
+                            supers))
        (raise-argument-error who "(listof (cons/c struct-type-property? (procedure-arity-includes/c 1)))" supers))
      (let* ([can-impersonate? (and (or can-impersonate? (eq? guard 'can-impersonate)) #t)]
             [st (make-struct-type-prop name (and (not (eq? guard 'can-impersonate)) guard) supers)]
@@ -80,7 +79,7 @@
                         [(procedure? fail) (|#%app| fail)]
                         [else fail]))])
        (letrec ([acc
-                 (procedure-rename
+                 (procedure-rename*
                   (case-lambda
                    [(v fail)
                     (cond
@@ -99,8 +98,9 @@
                                   pv))
                             (do-fail fail v)))])]
                    [(v) (acc v default-fail)])
+                  6
                   accessor-name)])
-         (let ([pred (procedure-rename pred predicate-name)])
+         (let ([pred (procedure-rename* pred 2 predicate-name)])
            (add-to-table! property-accessors
                           acc
                           (cons pred can-impersonate?))
@@ -141,6 +141,13 @@
 (define (struct-property-set! prop rtd val)
   (putprop (record-type-uid rtd) prop val))
 
+;; Must be consistent with `procedure-rename` in "procedure.ss",
+;; but needed before that one is defined:
+(define (procedure-rename* proc mask name)
+  (make-arity-wrapper-procedure proc
+                                mask
+                                (vector name proc)))
+
 ;; ----------------------------------------
 
 (define-record-type (inspector new-inspector inspector?)
@@ -194,9 +201,9 @@
          :contract "(or/c procedure? exact-nonnegative-integer? #f)"
          proc-spec)
   (check who
-         :test (and (list props)
-                    (andmap (lambda (i) (and (pair? i) (struct-type-property? (car i))))
-                            props))
+         :test (and (#%list? props)
+                    (#%andmap (lambda (i) (and (pair? i) (struct-type-property? (car i))))
+                              props))
          :contract "(listof (cons/c struct-type-property? any/c))"
          props)
   (check who
@@ -206,8 +213,8 @@
          :contract "(or/c inspector? #f 'prefab)"
          insp)
   (check who
-         :test (and (list? immutables)
-                    (andmap exact-nonnegative-integer? immutables))
+         :test (and (#%list? immutables)
+                    (#%andmap exact-nonnegative-integer? immutables))
          :contract "(listof exact-nonnegative-integer?)"
          immutables)
   (check who :or-false procedure? guard)