Adjust class/c to use the new strategy for the external

parts of a contract (field, method, init, absent clauses)

Still to do:

- delay the creation of the class that checks internal contracts
  until a new derived class is created from a contracted class.

- extend the new implementation so it handles interface contracts
  (currently the old version of the external contracts is still there,
  just to handle this case)

The first of those is what (I hope) will bring down the memory
footprint for class/c contracts.

pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt

@@ -33,6 +33,13 @@
               'pos
               'neg))
   
+  (test/spec-passed
+   'class/c-first-order-opaque-class-3
+   '(contract (class/c #:opaque m)
+              (class object% (super-new) (define/public (m) 3))
+              'pos
+              'neg))
+  
   (test/pos-blame
    'class/c-first-order-method-1
    '(contract (class/c [m (-> any/c number? number?)])
@@ -1108,6 +1115,22 @@
            [d%/c/c (contract (class/c (init [a number?])) d%/c 'pos 'neg)])
       (new d%/c/c [a #t] [a "foo"])))
   
+  (test/spec-passed
+   'class/c-higher-order-init-9
+   '(let ([c% (contract (class/c (init [a number?]))
+                        (class object% (super-new) (init a))
+                        'pos
+                        'neg)])
+      (make-object c% 3)))
+  
+  (test/neg-blame
+   'class/c-higher-order-init-10
+   '(let ([c% (contract (class/c (init [a number?]))
+                        (class object% (super-new) (init a))
+                        'pos
+                        'neg)])
+      (make-object c% #f)))
+  
   (test/spec-passed
    'class/c-higher-order-init-field-1
    '(let ([c% (contract (class/c (init-field [f (-> number? number?)]))
@@ -2085,6 +2108,44 @@
       x)
    1)
   
+  (test/pos-blame
+   'class/c-field-in-class-with-interface-ctc
+   '(get-field f (new (contract (class/c (field [f integer?]))
+                                (class* object% ((interface () [m (-> any/c integer?)]))
+                                  (field [f #f])
+                                  (define/public (m) 1)
+                                  (super-new))
+                                'pos
+                                'neg))))
+  
+  (test/pos-blame
+   'class/c-field-in-class-with-interface-ctc2
+   '(new (contract (class/c (field f))
+                   (class* object% ((interface () [m (-> any/c integer?)]))
+                     (define/public (m) 1)
+                     (super-new))
+                   'pos
+                   'neg)))
+  
+  (test/pos-blame
+   'class/c-absent-in-class-with-interface-ctc
+   '(contract (class/c (absent m))
+              (class* object% ((interface () [m (-> any/c integer?)]))
+                (define/public (m) 1)
+                (super-new))
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'class/c-absent-in-class-with-interface-ctc
+   '(contract (class/c (absent (field f)))
+              (class* object% ((interface () [m (-> any/c integer?)]))
+                (define/public (m) 1)
+                (field [f 1])
+                (super-new))
+              'pos
+              'neg))
+  
   (let ([expected-given?
          (λ (exn) (and (regexp-match? #rx"callback: contract violation" (exn-message exn))
                        (regexp-match? #rx"expected: boolean[?]" (exn-message exn))

pkgs/racket-pkgs/racket-test/tests/racket/contract/first-order.rkt

@@ -203,8 +203,4 @@
   (ctest #t contract-first-order-passes?
          (class/c [m (-> any/c integer? integer?)]) 
          (class* object% ((interface () [m (-> any/c integer? integer?)]))
-           (define/public (m x) x)))
+           (define/public (m x) x))))
-  
-  
-  
-  )

racket/collects/racket/class.rkt

@@ -6,7 +6,8 @@
 ;; All of the implementation is actually in private/class-internal.rkt,
 ;;  which provides extra (private) functionality to contract.rkt.
 (require "private/class-internal.rkt"
-         "private/class-c-old.rkt")
+         (except-in "private/class-c-old.rkt" class/c)
+         (rename-in "private/class-c-new.rkt" [class/c2 class/c]))
   
 (provide-public-names)
 (provide generic?)

racket/collects/racket/private/class-c-new.rkt

@@ -11,126 +11,6 @@
 
 (provide class/c2)
 
-(define-for-syntax (parse-class/c stx)
-  (define (give-up) (values #f #f #f #f #f))
-  (define-values (opaque? args)
-    (syntax-case stx ()
-      [(_ #:opaque args ...)
-       (values #t #'(args ...))]
-      [(_ args ...)
-       (let ()
-         (define stx-args #'(args ...))
-         (define l (syntax->list stx-args))
-         (printf "l ~\n" l)
-         (when (and (pair? l) (keyword? (syntax-e (car l))))
-           (raise-syntax-error #f "unrecognized keyword" stx (car l)))
-         (values #f stx-args))]))
-  (syntax-case args ()
-    [(clauses ...)
-     (let loop ([clauses (syntax->list #'(clauses ...))]
-                [mths '()]
-                [flds '()]
-                [inits '()]
-                [let-bindings '()])
-       (cond
-         [(null? clauses) 
-          (values opaque?
-                  (reverse mths)
-                  (reverse flds)
-                  (reverse inits)
-                  (reverse let-bindings))]
-         [else
-          (syntax-case (car clauses) (field inherit inherit-field init init-field super inner 
-                                            override augment augride absent)
-            [(super . x) (give-up)]
-            [(inner . x) (give-up)]
-            [(override . x) (give-up)]
-            [(augment . x) (give-up)]
-            [(augride . x) (give-up)]
-            [(absent . x) (give-up)]
-            [(inherit . x) (give-up)]
-            [(inherit-field . x) (give-up)]
-            [(field x ...) (give-up)]
-            [(init x ...) 
-             (let ()
-               (define new-let-bindings let-bindings)
-               (define new-inits '())
-               (for ([clause (in-list (syntax->list #'(x ...)))])
-                 (syntax-case clause ()
-                   [(id ctc)
-                    (with-syntax ([(x) (generate-temporaries #'(id))])
-                      (set! new-let-bindings (cons #`[x ctc] new-let-bindings))
-                      (set! new-inits (cons #`[id x] new-inits)))]
-                   [id
-                    (identifier? #'id)
-                    (begin
-                      (set! new-inits (cons #`[id just-check-existence] new-inits)))]
-                   [_
-                    (raise-syntax-error 'class/c "expected a field-spec" stx clause)]))
-               (loop (cdr clauses)
-                     mths flds (append new-inits inits) new-let-bindings))]
-            [(init-field x ...)
-             (let ()
-               (define new-let-bindings let-bindings)
-               (define clauses '())
-               (for ([cl (in-list (syntax->list #'(x ...)))])
-                 (syntax-case cl ()
-                   [(id ctc) 
-                    (identifier? #'id)
-                    (with-syntax ([(x) (generate-temporaries (list #'id))])
-                      (set! new-let-bindings (cons #`[x ctc] new-let-bindings))
-                      (set! clauses (cons #'[id x] clauses)))]
-                   [id
-                    (identifier? #'id)
-                    (begin
-                      (set! clauses (cons #'[id just-check-existence] clauses)))]
-                   [_
-                    (raise-syntax-error 'class/c "expected a field-spec" stx cl)]))
-               (loop (cdr clauses) mths (append clauses flds) (append clauses inits)
-                     new-let-bindings))]
-                                           
-            [x (identifier? #'x) 
-               (loop (cdr clauses) 
-                     (cons #`[#,(car clauses) just-check-existence] mths)
-                     flds inits let-bindings)]
-            [[mth ctc] 
-             (identifier? #'mth)
-             (with-syntax ([(x) (generate-temporaries #'(mth))])
-               (loop (cdr clauses) 
-                     (cons #`[mth x] mths)
-                     flds
-                     inits
-                     (cons #`[x ctc] let-bindings)))]
-            [else (give-up)])]))]))
-
-#;
-(define-syntax (class/c2 stx)
-  (define-values (opaque? mths flds inits let-bindings) (parse-class/c stx))
-  (cond
-    [(and mths (null? flds))
-     (syntax-case (list mths inits) ()
-       [(((mth-name mth-ctc) ...)
-         ((init-name init-ctc) ...))
-        ;(printf " yup: ~a:~a\n" (syntax-source stx) (syntax-line stx))
-        (with-syntax ([(lmth-name ...) (for/list ([m (in-list (syntax->list #'(mth-name ...)))])
-                                         (localize m))]
-                      [name (syntax-local-infer-name stx)])
-          ;#'(class/c [m ctc] ...)
-          #`(let #,let-bindings
-              (make-an-ext-class/c-contract '#,opaque?
-                                            (list `lmth-name ...)
-                                            (list mth-ctc ...)
-                                            '() '()
-                                            (list 'init-name ...)
-                                            (list init-ctc ...)
-                                            'name
-                                            empty-internal/c)))])]
-    [else
-     ;(printf "nope: ~a:~a\n" (syntax-source stx) (syntax-line stx))
-     (syntax-case stx ()
-       [(_ args ...)
-        #'(class/c args ...)])]))
-
 (define-syntax (class/c2 stx)
   (define-values (opaque? args)
     (syntax-case stx ()
@@ -143,7 +23,6 @@
            (raise-syntax-error #f "unrecognized keyword" stx (car stx-args)))
          (values #f stx-args))]))
   (define-values (bindings pfs) (parse-class/c-specs args #f))
-  (printf ">> ~s ~s\n" bindings (hash-ref pfs 'methods null))
   (with-syntax ([methods #`(list #,@(reverse (hash-ref pfs 'methods null)))]
                 [method-ctcs #`(list #,@(reverse (hash-ref pfs 'method-contracts null)))]
                 [fields #`(list #,@(reverse (hash-ref pfs 'fields null)))]
@@ -182,15 +61,16 @@
                   [opaque? opaque?])
       (syntax/loc stx
         (let bindings
-;          (let-values ([(inits init-ctcs) (sort-inits+contracts (list (cons i i-c) ...))])
           (make-an-ext-class/c-contract
            'opaque?
            methods method-ctcs
            fields field-ctcs
-             (list 'i ...)
+           (list i ...)
            (list i-c ...)
+           absents 
+           absent-fields
            'name
-             (internal-class/c
+           (build-internal-class/c
             inherits inherit-ctcs
             inherit-fields inherit-field-ctcs
             supers super-ctcs
@@ -224,13 +104,23 @@
                         (if (just-check-existence? ctc) 
                             any/c
                             ctc))))
+              
+              (define fields 
+                (for/list ([(fld ctc) (in-hash (ext-class/c-contract-table-of-flds-to-ctcs this))])
+                  fld))
+              (define field-ctcs
+                (for/list ([(fld ctc) (in-hash (ext-class/c-contract-table-of-flds-to-ctcs this))])
+                  (if (just-check-existence? ctc)
+                      #f
+                      ctc)))
+              
               (define ctc
                 (make-class/c
                  ;; methods
                  (map car mth-lst)
                  (map cdr mth-lst)
                  
-                 '() '() ;; fields  
+                 fields field-ctcs
                  
                  ;; inits
                  (map (λ (x) (list-ref x 0)) (ext-class/c-contract-init-ctc-pairs this))
@@ -241,14 +131,17 @@
                             ctc))
                       (ext-class/c-contract-init-ctc-pairs this))
                  
-                 '() '() ;; absent
+                 (ext-class/c-contract-absent-methods this)
-                 empty-internal-class/c
+                 (ext-class/c-contract-absent-fields this)
-                 #f ;; opaque?
+
-                 #f ;; name
+                 (ext-class/c-contract-internal-ctc this)
-                 ))
+                 (ext-class/c-contract-opaque? this)
+                 (ext-class/c-contract-name this)))
               (λ (neg-party)
                 (((class/c-proj ctc) (blame-add-missing-party blame neg-party)) cls))]
-             [else (build-neg-acceptor-proc this maybe-err blame cls (make-hash) '())])]
+             [else 
+              (build-neg-acceptor-proc this maybe-err blame cls (make-hash) '() 
+                                       (make-hasheq) (make-hasheq))])]
           [(wrapped-class? cls) 
            (define neg-acceptors-ht
              (wrapped-class-info-neg-acceptors-ht (wrapped-class-the-info cls)))
@@ -266,7 +159,9 @@
            (build-neg-acceptor-proc this maybe-err blame 
                                     (wrapped-class-info-class the-info)
                                     new-mths-ht
-                                    fixed-neg-init-projs)]
+                                    fixed-neg-init-projs
+                                    (wrapped-class-info-pos-field-projs the-info)
+                                    (wrapped-class-info-neg-field-projs the-info))]
           [else
            (maybe-err
             (λ (neg-party)
@@ -274,20 +169,13 @@
                blame #:missing-party neg-party cls
                '(expected: "a class"))))])))))
 
-(define empty-internal-class/c
+(define (build-neg-acceptor-proc this maybe-err blame cls new-mths-ht old-init-pairs 
-  (internal-class/c
+                                 old-pos-fld-ht old-neg-fld-ht)
-   '() '() ;; inherit
-   '() '() ;; inherit fields
-   '() '() ;; super
-   '() '() ;; inner
-   '() '() ;; override
-   '() '() ;; augment
-   '() '())) ;; augride
-
-(define (build-neg-acceptor-proc this maybe-err blame cls new-mths-ht old-init-pairs)
   (define mth->idx (class-method-ht cls))
   (define mtd-vec (class-methods cls))
   
+  (define internal-proj (internal-class/c-proj (ext-class/c-contract-internal-ctc this)))
+  
   (define (get-unwrapped-method name)
     (cond
       [(hash-ref new-mths-ht name #f) => values]
@@ -299,6 +187,9 @@
   (define neg-extra-arg-ht (make-hash))
   (define neg-acceptors-ht (make-hash))
   
+  (define pos-field-projs (hash-copy old-pos-fld-ht))
+  (define neg-field-projs (hash-copy old-neg-fld-ht))
+  
   (define (generic-wrapper mth)
     (define raw-proc (get-unwrapped-method mth))
     (make-keyword-procedure
@@ -322,7 +213,7 @@
        ;; if we just check the method's existence,
        ;; then make an inefficient wrapper for it
        ;; that discards the neg-party argument
-       (generic-wrapper mth)]
+       (hash-set! neg-extra-arg-ht mth (generic-wrapper mth))]
       [else
        (define w/blame (proj (blame-add-method-context blame mth)))
        (define projd-mth (w/blame m-mth))
@@ -341,7 +232,16 @@
                (apply (projd-mth neg-party) args)))]))
        (hash-set! neg-extra-arg-ht mth neg-acceptor)]))
   
+  (define absent-methods (ext-class/c-contract-absent-methods this))
   (for ([(mth _) (in-hash mth->idx)])
+    (when (member mth absent-methods)
+      (maybe-err
+       (λ (neg-party)
+         (raise-blame-error 
+          blame #:missing-party neg-party cls
+          '(expected: "a class that does not have the method ~a")
+          mth))))
+    
     ;; use a generic wrapper to drop the neg-party argument, which means
     ;; methods without explicit contracts are going to be slow
     (unless (hash-ref neg-extra-arg-ht mth #f)
@@ -353,7 +253,7 @@
                  (format " ~a" mth)))
              (raise-blame-error 
               blame #:missing-party neg-party cls
-              '(expected: "~a" given: "a class that has a method ~a")
+              '(expected: "~a" given: "a class that has a method: ~a")
               (cond
                 [(null? mth-names) "a class with no methods"]
                 [(null? (cdr mth-names)) 
@@ -363,6 +263,58 @@
                          (apply string-append mth-names))])
               mth)))
           (hash-set! neg-extra-arg-ht mth (generic-wrapper mth)))))
+  
+  (for ([(fld proj) (in-hash (ext-class/c-contract-table-of-flds-to-projs this))])
+    (define field-ht (class-field-ht cls))
+    (define fi (hash-ref field-ht fld #f))
+    (unless fi
+      (maybe-err
+       (λ (neg-party)
+         (raise-blame-error 
+          blame #:missing-party neg-party cls
+          '(expected: "a class with a public field named ~a")
+          fld))))
+    
+    (unless (just-check-existence? proj)
+      (define (update-ht field-projs field-info-internal-ref/set! swap?)
+        (define prior (hash-ref field-projs fld (λ () (field-info-internal-ref/set! fi))))
+        (define w-blame (proj (blame-add-field-context blame proj #:swap? swap?)))
+        (hash-set! field-projs fld (cons w-blame prior)))
+      (update-ht pos-field-projs field-info-internal-ref #f)
+      (update-ht neg-field-projs field-info-internal-set! #t)))
+  
+  (define absent-fields (ext-class/c-contract-absent-fields this))
+  (unless (null? absent-fields)
+    (for ([(fld proj) (in-hash (class-field-ht cls))])
+      (when (member fld absent-fields)
+        (maybe-err
+         (λ (neg-party)
+           (raise-blame-error 
+            blame #:missing-party neg-party cls
+            '(expected: "a class that does not have the field ~a")
+            fld))))))
+  
+  (when (ext-class/c-contract-opaque? this)
+    (define allowed-flds (ext-class/c-contract-table-of-flds-to-projs this))
+    (for ([(fld proj) (in-hash (class-field-ht cls))])
+      (unless (hash-ref allowed-flds fld #f)
+        (maybe-err
+         (λ (neg-party)
+           (define fld-names
+             (for/list ([(fld proj) (in-hash allowed-flds)])
+               (format " ~a" fld)))
+           (raise-blame-error 
+            blame #:missing-party neg-party cls
+            '(expected: "~a" given: "a class that has the field: ~a")
+            (cond
+              [(null? fld-names) "a class with no fields"]
+              [(null? (cdr fld-names))
+               (format "a class with only one field:~a" (car fld-names))]
+              [else
+               (format "a class with only the fields:~a" 
+                       (apply string-append fld-names))])
+            fld))))))
+      
   (define new-init-projs 
     (for/list ([ctc-pair (in-list (ext-class/c-contract-init-ctc-pairs this))])
       (define ctc (list-ref ctc-pair 1))
@@ -374,14 +326,28 @@
                  (blame-add-init-context blame (car ctc-pair)))))))
   (define merged-init-pairs (merge-init-pairs old-init-pairs new-init-projs))
   (define the-info (wrapped-class-info cls blame neg-extra-arg-ht neg-acceptors-ht 
+                                       pos-field-projs neg-field-projs
                                        merged-init-pairs))
+  
   (λ (neg-party)
     ;; run this for the side-effect of 
     ;; checking that first-order tests on
     ;; methods (arity, etc) all pass
     (for ([(mth neg-party-acceptor) (in-hash neg-acceptors-ht)])
       (neg-party-acceptor neg-party))
-    (wrapped-class the-info neg-party)))
+    
+    ;; XXX: we have to not do this;
+    ;; (instead we should use just the-info)
+    ;; the internal projection should run
+    ;; on the class only when it is
+    ;; time to instantiate it; not here
+    (define the-info/adjusted-cls
+      (struct-copy wrapped-class-info
+                   the-info
+                   [class ((internal-proj (blame-add-missing-party blame neg-party))
+                           cls)]))
+    
+    (wrapped-class the-info/adjusted-cls neg-party)))
 
 (define (merge-init-pairs old-init-pairs new-init-pairs)
   (cond
@@ -410,32 +376,42 @@
                                       mth-names mth-ctcs
                                       fld-names fld-ctcs
                                       init-names init-ctcs 
+                                      absent-methods absent-fields
                                       ctc-name internal-ctc)
-  (define ctc-hash
+  (define (build-a-ctc-table names ctcs)
-    (make-hash (for/list ([raw-ctc (in-list mth-ctcs)]
+    (make-hash (for/list ([raw-ctc (in-list ctcs)]
-                          [name (in-list mth-names)])
+                          [name (in-list names)])
                  (define ctc (if (just-check-existence? raw-ctc)
                                  raw-ctc
                                  (coerce-contract 'class/c raw-ctc)))
                  (cons name ctc))))
-  (ext-class/c-contract 
+  (define (build-a-proj-table hash names)
-   opaque?
+    (make-hash
-   ctc-hash
+     (for/list ([name (in-list names)])
-   (make-hash (for/list ([name (in-list mth-names)])
+       (define ctc (hash-ref hash name))
-                (define ctc (hash-ref ctc-hash name))
        (cond
          [(just-check-existence? ctc)
           (cons name ctc)]
          [else
           (define proj (get/build-val-first-projection ctc))
-                   (cons name proj)])))
+          (cons name proj)]))))
+  (define mth-ctc-hash (build-a-ctc-table mth-names mth-ctcs))
+  (define fld-ctc-hash (build-a-ctc-table fld-names fld-ctcs))
+  (define mth-proj-hash (build-a-proj-table mth-ctc-hash mth-names))
+  (define fld-proj-hash (build-a-proj-table fld-ctc-hash fld-names))
+  (ext-class/c-contract 
+   opaque?
+   mth-ctc-hash mth-proj-hash
+   fld-ctc-hash fld-proj-hash
    (for/list ([name (in-list init-names)]
               [ctc (in-list init-ctcs)])
      (list name
            (if (just-check-existence? ctc)
                ctc
                (coerce-contract 'class/c ctc))))
-   ctc-name))
+   absent-methods absent-fields
+   ctc-name
+   internal-ctc))
 
 (define (class/c-first-order-passes? ctc cls)
   (cond
@@ -444,15 +420,26 @@
      (define mtd-vec (class-methods cls))
      (for/and ([(name ctc) (in-hash (ext-class/c-contract-table-of-meths-to-ctcs ctc))])
        (define mth-idx (hash-ref mth->idx name #f))
-       (and mth-idx
+       (cond
-            (contract-first-order-passes? ctc (vector-ref mtd-vec mth-idx))))]
+         [mth-idx
+          (define mth-record (vector-ref mtd-vec mth-idx))
+          (contract-first-order-passes? 
+           ctc 
+           (if (pair? mth-record)
+               (car mth-record)
+               mth-record))]
+         [else #f]))]
     [else #f]))
 
 (struct ext-class/c-contract (opaque?
                               table-of-meths-to-ctcs 
                               table-of-meths-to-projs
+                              table-of-flds-to-ctcs
+                              table-of-flds-to-projs
                               init-ctc-pairs
-                              name)
+                              absent-methods absent-fields
+                              name
+                              internal-ctc)
   #:property prop:contract
   (build-contract-property
    #:projection 

racket/collects/racket/private/class-c-old.rkt

@@ -9,13 +9,14 @@
          (only-in "../contract/private/arrow.rkt" making-a-method method-contract?))
 
 (provide make-class/c class/c-proj
-         blame-add-method-context blame-add-init-context
+         blame-add-method-context blame-add-field-context blame-add-init-context
          class/c ->m ->*m ->dm case->m object/c instanceof/c
          make-wrapper-object
          check-object-contract
          (for-syntax parse-class/c-specs)
          (struct-out internal-class/c)
-         just-check-existence just-check-existence?)
+         just-check-existence just-check-existence?
+         build-internal-class/c internal-class/c-proj)
 
 (define undefined (letrec ([x x]) x))
 
@@ -153,7 +154,6 @@
 (define (class/c-external-proj ctc)
   (define ctc-methods (class/c-methods ctc))
   (λ (blame)
-    (define bswap (blame-swap blame))
     (define public-method-projections
       (for/list ([name (in-list ctc-methods)]
                  [c (in-list (class/c-method-contracts ctc))])
@@ -165,9 +165,9 @@
                  [c (in-list (class/c-field-contracts ctc))])
         (and c
              (let ([p-pos ((contract-projection c)
-                           (blame-add-context blame (format "the ~a field in" f)))]
+                           (blame-add-field-context blame f #:swap? #f))]
                    [p-neg ((contract-projection c)
-                           (blame-add-context bswap (format "the ~a field in" f)))])
+                           (blame-add-field-context blame f #:swap? #t))])
                (cons p-pos p-neg)))))
     
     ;; zip the inits and contracts together for ordered selection
@@ -307,7 +307,7 @@
               (define mp (vector-ref methods i))
               (vector-set! methods i (make-method (p mp) m)))))
         
-        ;; Handle both external field contracts
+        ;; Handle external field contracts
         (unless no-field-ctcs?
           (for ([f (in-list (class/c-fields ctc))]
                 [p-pr (in-list external-field-projections)])
@@ -724,6 +724,9 @@
      (blame-add-context blame "an unnamed method in")]
     [else (error 'blame-add-method-context "uhoh ~s" name)]))
 
+(define (blame-add-field-context blame f #:swap? swap?)
+  (blame-add-context blame (format "the ~a field in" f) #:swap? swap?))
+
 (define (build-internal-class/c inherits inherit-contracts inherit-fields inherit-field-contracts
                                 supers super-contracts inners inner-contracts
                                 overrides override-contracts augments augment-contracts
@@ -1161,9 +1164,12 @@
       (define new-cls (p (object-ref val)))
       (cond
         [(wrapped-class? new-cls)
+         (define the-info (wrapped-class-the-info new-cls))
          (wrapped-object
           val
-          (wrapped-class-info-neg-extra-arg-ht (wrapped-class-the-info new-cls))
+          (wrapped-class-info-neg-extra-arg-ht the-info)
+          (wrapped-class-info-pos-field-projs the-info)
+          (wrapped-class-info-neg-field-projs the-info)
           (wrapped-class-neg-party new-cls))]
         [else
          (impersonate-struct val object-ref (λ (o c) new-cls)
@@ -1303,11 +1309,9 @@
       (for ([f (in-list fields)]
             [c (in-list field-contracts)])
         (when c
-          (define fld-context (format "the ~a field in" f))
+          (define fi (hash-ref field-ht f))
-          (define bset (blame-add-context blame fld-context #:swap? #t))
+          (define p-pos ((contract-projection c) (blame-add-field-context blame f #:swap? #f)))
-          (let ([fi (hash-ref field-ht f)]
+          (define p-neg ((contract-projection c) (blame-add-field-context blame f #:swap? #t)))
-                [p-pos ((contract-projection c) (blame-add-context blame fld-context))]
+          (hash-set! field-ht f (field-info-extend-external fi p-pos p-neg)))))
-                [p-neg ((contract-projection c) bset)])
-            (hash-set! field-ht f (field-info-extend-external fi p-pos p-neg))))))
     
     c))

racket/collects/racket/private/class-internal.rkt

@@ -3241,6 +3241,8 @@ An example
      (wrapped-object
       unwrapped-o
       (wrapped-class-info-neg-extra-arg-ht the-info)
+      (wrapped-class-info-pos-field-projs the-info)
+      (wrapped-class-info-neg-field-projs the-info)
       (wrapped-class-neg-party class))]
     [else
      (raise-argument-error 'instantiate "class?" class)]))
@@ -3763,22 +3765,43 @@ An example
   (do-set-field! 'set-field! id obj val))
 
 (define (do-set-field! who id obj val)
-  (unless (object? obj)
+  (cond
+    [(_object? obj) 
+     (do-set-field!/raw-object who id obj val)]
+    [(wrapped-object? obj)
+     (define projs+set! (hash-ref (wrapped-object-neg-field-projs obj) id #f))
+     (cond
+       [projs+set! 
+        (define np (wrapped-object-neg-party obj))
+        (let loop ([projs+set! projs+set!]
+                   [val val])
+          (cond
+            [(pair? projs+set!)
+             (define the-proj (car projs+set!))
+             (loop (cdr projs+set!)
+                   ((the-proj val) np))]
+            [else
+             (projs+set! (wrapped-object-object obj) val)]))]
+       [else
+        (do-field-get/raw-object who id (wrapped-object-object obj))])]    
+    [else
      (raise-argument-error who
                            "object?"
-                          obj))
+                           obj)]))
-  (let* ([cls (object-ref/unwrap obj)]
+
-         [field-ht (class-field-ht cls)]
+(define (do-set-field!/raw-object who id obj val)
-         [fi (hash-ref field-ht id #f)])
+  (define cls (object-ref obj))
+  (define field-ht (class-field-ht cls))
+  (define fi (hash-ref field-ht id #f))
   (if fi
       ((field-info-external-set! fi) obj val)
       (obj-error who
                  "given object does not have the requested field"
                  "field name" (as-write id)
-                    "object" obj))))
+                 "object" obj)))
 
 (define (dynamic-set-field! id obj val)
-  (unless (symbol? id) (raise-argument-error 'dynamic-get-field "symbol?" id))
+  (unless (symbol? id) (raise-argument-error 'dynamic-set-field! "symbol?" id))
   (do-set-field! 'dynamic-set-field! id obj val))
 
 (define-syntax (get-field stx)
@@ -3796,19 +3819,40 @@ An example
   (do-get-field 'get-field id obj))
 
 (define (do-get-field who id obj)
-  (unless (object? obj)
+  (cond
+    [(_object? obj)
+     (do-field-get/raw-object who id obj)]
+    [(wrapped-object? obj)
+     (define projs+ref (hash-ref (wrapped-object-pos-field-projs obj) id #f))
+     (cond
+       [projs+ref
+        (define np (wrapped-object-neg-party obj))
+        (let loop ([projs+ref projs+ref])
+          (cond
+            [(pair? projs+ref)
+             (define the-proj (car projs+ref))
+             (define field-val-with-other-contracts (loop (cdr projs+ref)))
+             ((the-proj field-val-with-other-contracts) np)]
+            [else
+             ;; projs+ref is the struct field accessor
+             (projs+ref (wrapped-object-object obj))]))]
+       [else
+        (do-field-get/raw-object who id (wrapped-object-object obj))])]
+    [else 
      (raise-argument-error who
                            "object?"
-                          obj))
+                           obj)]))
-  (let* ([cls (object-ref/unwrap obj)]
+
-         [field-ht (class-field-ht cls)]
+(define (do-field-get/raw-object who id obj)
-         [fi (hash-ref field-ht id #f)])
+  (define cls (object-ref obj))
+  (define field-ht (class-field-ht cls))
+  (define fi (hash-ref field-ht id #f))
   (if fi
       ((field-info-external-ref fi) obj)
       (obj-error who
                  "given object does not have the requested field"
                  "field name" (as-write id)
-                   "object" obj))))
+                 "object" obj)))
 
 (define (dynamic-get-field id obj)
   (unless (symbol? id) (raise-argument-error 'dynamic-get-field "symbol?" id))
@@ -4170,7 +4214,10 @@ An example
 ;; runtime wrappers to support contracts with better space properties
 ;;--------------------------------------------------------------------
 
-(struct wrapped-class-info (class blame neg-extra-arg-ht neg-acceptors-ht init-proj-pairs)
+(struct wrapped-class-info (class blame 
+                             neg-extra-arg-ht neg-acceptors-ht 
+                             pos-field-projs neg-field-projs
+                             init-proj-pairs)
   #:transparent)
 (struct wrapped-class (the-info neg-party)
   #:property prop:custom-write
@@ -4183,7 +4230,8 @@ An example
       [(wrapped-class? class) (loop (wrapped-class-info-class (wrapped-class-the-info class)))]
       [else class])))
 
-(struct wrapped-object (object method-wrappers neg-party) #:transparent
+(struct wrapped-object (object method-wrappers pos-field-projs neg-field-projs neg-party)
+  #:transparent
   #:property prop:custom-write
   (λ (stct port mode)
     (do-custom-write (wrapped-object-object stct) port mode)))
@@ -4488,6 +4536,9 @@ An example
          object-ref/unwrap impersonator-prop:original-object has-original-object? original-object
          ;; end class-c-old.rkt requirements
 
+         field-info-internal-ref
+         field-info-internal-set!
+         
          (rename-out [_class class]) class* class/derived
          define-serializable-class define-serializable-class*
          (rename-out [-class? class?])