From 52aa11c4074041b2cfb4628b7c960c79419e3104 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Mon, 7 Sep 2015 14:08:55 -0400
Subject: [PATCH] Propagate object inspectors in class/c wrappers

This makes reflection work on an instance of a contracted
class in the same way that it does on the original class.
---
 .../tests/racket/contract/class.rkt           | 51 ++++++++++++++++++-
 .../collects/racket/private/class-c-old.rkt   | 12 +++--
 .../racket/private/class-internal.rkt         |  7 ++-
 3 files changed, 65 insertions(+), 5 deletions(-)

diff --git a/pkgs/racket-test/tests/racket/contract/class.rkt b/pkgs/racket-test/tests/racket/contract/class.rkt
index 26fd95fc4b..e1f74313c4 100644
--- a/pkgs/racket-test/tests/racket/contract/class.rkt
+++ b/pkgs/racket-test/tests/racket/contract/class.rkt
@@ -2566,4 +2566,53 @@
        (class object%
          (super-new)
          (define/public (callback f) (f 1))))
-     promised-produced?)))
+     promised-produced?))
+
+  ;; Tests for reflection and class contracts
+  (test/spec-passed/result
+   'reflection-1
+   '(format "~a"
+     (new (contract (class/c)
+                    (let ([x%
+                           (class object%
+                             (super-new)
+                             (inspect #f)
+                             (init-field [x 0]))])
+                      x%)
+                    'pos 'neg)))
+   "#(struct:object:x% 0)")
+
+  (test/spec-passed/result
+   'reflection-2
+   '(format "~a"
+     (new (contract (class/c)
+                    (let ([x%
+                           (class object%
+                             (super-new)
+                             (init-field [x 0]))])
+                      x%)
+                    'pos 'neg)))
+   "#(struct:object:x% ...)")
+
+  (test/spec-passed/result
+   'equality-1
+   '(let ([c%
+          (contract (class/c)
+                    (class object%
+                      (super-new)
+                      (inspect #f)
+                      (init-field [x 0]))
+                    'pos 'neg)])
+      (equal? (new c%) (new c%)))
+   #t)
+
+  (test/spec-passed/result
+   'equality-2
+   '(let ([c%
+          (contract (class/c)
+                    (class object%
+                      (super-new)
+                      (init-field [x 0]))
+                    'pos 'neg)])
+      (equal? (new c%) (new c%)))
+   #f))
diff --git a/racket/collects/racket/private/class-c-old.rkt b/racket/collects/racket/private/class-c-old.rkt
index c9cd1dc297..cb2a2be7f7 100644
--- a/racket/collects/racket/private/class-c-old.rkt
+++ b/racket/collects/racket/private/class-c-old.rkt
@@ -213,6 +213,7 @@
                             supers
                             (class-self-interface cls)
                             void ;; No inspecting
+                            (class-obj-inspector cls) ; inherit object inspector
                             
                             method-width
                             method-ht
@@ -273,7 +274,8 @@
                                         0 ;; No new fields in this class replacement
                                         undefined
                                         ;; Map object property to class:
-                                        (list (cons prop:object c)))])
+                                        (list (cons prop:object c))
+                                        (class-obj-inspector cls))])
           (set-class-struct:object! c struct:object)
           (set-class-object?! c object?)
           (set-class-make-object! c object-make)
@@ -480,6 +482,7 @@
                             supers
                             (class-self-interface cls)
                             void ;; No inspecting
+                            (class-obj-inspector cls)
                             
                             method-width
                             method-ht
@@ -542,7 +545,8 @@
                                         0 ;; No new fields in this class replacement
                                         undefined
                                         ;; Map object property to class:
-                                        (list (cons prop:object c)))])
+                                        (list (cons prop:object c))
+                                        (class-obj-inspector cls))])
           (set-class-struct:object! c struct:object)
           (set-class-object?! c object?)
           (set-class-make-object! c object-make)
@@ -1544,6 +1548,7 @@
                         (list->vector (vector->list (class-supers cls)))
                         (class-self-interface cls)
                         void ;; No inspecting
+                        (class-obj-inspector cls)
                         
                         method-width
                         method-ht
@@ -1603,7 +1608,8 @@
                                     0 ;; No new fields in this class replacement
                                     undefined
                                     ;; Map object property to class:
-                                    (list (cons prop:object c)))])
+                                    (list (cons prop:object c))
+                                    (class-obj-inspector cls))])
       (set-class-struct:object! c struct:object)
       (set-class-object?! c object?)
       (set-class-make-object! c object-make)
diff --git a/racket/collects/racket/private/class-internal.rkt b/racket/collects/racket/private/class-internal.rkt
index 81958da49b..083f7c9589 100644
--- a/racket/collects/racket/private/class-internal.rkt
+++ b/racket/collects/racket/private/class-internal.rkt
@@ -1996,6 +1996,7 @@
                       pos supers     ; pos is subclass depth, supers is vector
                       self-interface ; self interface
                       insp-mk        ; dummy struct maker to control inspection access
+                      obj-inspector  ; the inspector used for instances of this class
                       
                       method-width   ; total number of methods
                       method-ht      ; maps public names to vector positions
@@ -2371,6 +2372,7 @@ last few projections.
                                 i
                                 (let-values ([(struct: make- ? -ref -set) (make-struct-type 'insp #f 0 0 #f null inspector)])
                                   make-)
+                                inspector
                                 method-width method-ht method-names remaining-abstract-names
                                 (interfaces->contracted-methods (list i))
                                 #f
@@ -3261,6 +3263,7 @@ An example
                  0 (vector #f) 
                  object<%>
                  void ; never inspectable
+                 #f   ; this is for the inspector on the object
                  
                  0 (make-hasheq) null null null
                  #f
@@ -3411,6 +3414,7 @@ An example
                                (list->vector (vector->list (class-supers cls)))
                                (class-self-interface cls)
                                void ;; No inspecting
+                               (class-obj-inspector cls)
 
                                method-width
                                method-ht
@@ -3462,7 +3466,8 @@ An example
                                            0 ;; No new fields in this class replacement
                                            unsafe-undefined
                                            ;; Map object property to class:
-                                           (list (cons prop:object c)))])
+                                           (list (cons prop:object c))
+                                           (class-obj-inspector cls))])
              (set-class-struct:object! c struct:object)
              (set-class-object?! c object?)
              (set-class-make-object! c object-make)