use the new version of object/c

Author: rfindler

typed-racket-lib/info.rkt

@@ -2,7 +2,7 @@
 
 (define collection 'multi)
 
-(define deps '(("base" #:version "8.18.0.4")
+(define deps '(("base" #:version "9.1.0.7")
                "source-syntax"
                "pconvert-lib"
                "compatibility-lib" ;; to assign types

typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt

@@ -283,13 +283,11 @@
          (let-values ([(rcvr-var) rcvr])
            (let-values (((meth-var) (~and find-app (#%plain-app find-method/who _ _ _))))
              (let-values ([(arg-var) args] ...)
-               (if wrapped-object-check
-                   ignore-this-case
-                   (~and core-app
-                         (~or (#%plain-app _ _ _arg-var2 ...)
-                              (let-values ([(_) _] ...)
-                                (#%plain-app (#%plain-app _ _ _ _ _ _)
-                                             _ _ _ ...)))))))))
+               (~and core-app
+                     (~or (#%plain-app _ _ _arg-var2 ...)
+                          (let-values ([(_) _] ...)
+                            (#%plain-app (#%plain-app _ _ _ _ _ _)
+                                         _ _ _ ...))))))))
        (register-ignored! form)
        (tc/send #'find-app #'core-app
                 #'rcvr-var #'rcvr

typed-racket-lib/typed-racket/utils/opaque-object.rkt

@@ -27,9 +27,6 @@
 ;; blame parties (e.g., a particular module).
 
 (require racket/class
-         (only-in racket/private/class-c-old
-                  base-object/c? build-object/c-type-name object/c-width-subtype?
-                  object/c-common-methods-stronger? object/c-common-fields-stronger?)
          racket/match
          racket/contract/base
          racket/contract/combinator
@@ -39,100 +36,6 @@
 
 (provide object/c-opaque)
 
-(module+ for-testing
-  (provide restrict-typed->/c
-           restrict-typed-field/c))
-
-;; projection for base-object/c-opaque
-(define ((object/c-opaque-late-neg-proj ctc) blame)
-  (match-define (base-object/c-opaque
-                 base-ctc
-                 methods method-ctcs
-                 fields field-ctcs)
-    ctc)
-  (define guard/c (dynamic-object/c methods method-ctcs fields field-ctcs))
-  (define guard/c-proj ((contract-late-neg-projection guard/c) blame))
-  (λ (obj neg-party)
-    (unless (object? obj)
-      (raise-blame-error blame #:missing-party neg-party obj "expected an object got ~a" obj))
-    (define actual-fields (field-names obj))
-    (define actual-methods
-      (interface->method-names (object-interface obj)))
-    (define remaining-fields
-      (remove* fields actual-fields))
-    (define remaining-methods
-      (remove* methods actual-methods))
-    (cond
-      [(and (null? remaining-methods) (null? remaining-fields))
-       (guard/c-proj obj neg-party)]
-      [else
-       (define restrict-guard/c
-         (dynamic-object/c remaining-methods
-                           (for/list ([m (in-list remaining-methods)])
-                             (restrict-typed->/c m))
-                           remaining-fields
-                           (for/list ([m (in-list remaining-fields)])
-                             (restrict-typed-field/c m))))
-       ;; FIXME: this is a bit sketchy because we have to construct
-       ;;        a contract that depends on the actual object that we got
-       ;;        since we don't know its methods beforehand
-       (((contract-late-neg-projection restrict-guard/c) blame)
-        (guard/c-proj obj neg-party)
-        neg-party)])))
-
-(define (object/c-opaque-name ctc)
-  (build-object/c-type-name 'object/c-opaque
-                            (base-object/c-opaque-method-names ctc)
-                            (base-object/c-opaque-method-ctcs ctc)
-                            (base-object/c-opaque-field-names ctc)
-                            (base-object/c-opaque-field-ctcs ctc)))
-
-;; Similar to object/c-stronger, but without width subtyping.
-;; (Intuition: unspecified fields are guarded by the strongest possible contract)
-;; An opaque object contract `this` is stronger than `that` when:
-;; - `that` is an opaque contract
-;;   and `this` specifies at most the same members as `that`
-;;   and `this` has stronger contracts on all members
-;; - `that` is an object/c contract
-;;   and `this` has stronger contracts on their common members
-(define (object/c-opaque-stronger? this that)
-  (define that-opaque? (base-object/c-opaque? that))
-  (cond
-   [(or that-opaque?
-        (base-object/c? that))
-    (define this-ctc (base-object/c-opaque-obj/c this))
-    (define that-ctc (if that-opaque? (base-object/c-opaque-obj/c that) that))
-    (and
-      (if that-opaque?
-        ;; then members of `this` should be a SUBSET of members of `that`
-        (object/c-width-subtype? that-ctc this-ctc)
-        #t)
-      (object/c-common-fields-stronger? this-ctc that-ctc)
-      (object/c-common-methods-stronger? this-ctc that-ctc)
-      #t)]
-   [else #f]))
-
-;; An `object/c-opaque` contract is equivalent to another `object/c-opaque`
-;;  contract that has the same fields+methods and the same contracts on them.
-(define (object/c-opaque-equivalent? this that)
-  (and (base-object/c-opaque? that)
-       (contract-equivalent? (base-object/c-opaque-obj/c this)
-                             (base-object/c-opaque-obj/c that))))
-
-(struct base-object/c-opaque
-  (obj/c ; keep a copy of the normal object/c for first-order and stronger checks
-   method-names method-ctcs field-names field-ctcs)
-  #:property prop:contract
-  (build-contract-property
-   #:stronger object/c-opaque-stronger?
-   #:equivalent object/c-opaque-equivalent?
-   #:name object/c-opaque-name
-   #:first-order (λ (ctc)
-                   (define obj/c (base-object/c-opaque-obj/c ctc))
-                   (λ (val)
-                     (contract-first-order-passes? obj/c val)))
-   #:late-neg-projection object/c-opaque-late-neg-proj))
-
 (begin-for-syntax
  (define-syntax-class object/c-clause
    #:attributes (method-names method-ctcs field-names field-ctcs)
@@ -151,76 +54,7 @@
   (syntax-parse stx
    [(_ ?clause:object/c-clause ...)
     (syntax/loc stx
-      (let ([names  (append ?clause.method-names ...)]
-            [ctcs   (append ?clause.method-ctcs ...)]
-            [fnames (append ?clause.field-names ...)]
-            [fctcs  (append ?clause.field-ctcs ...)])
-        (base-object/c-opaque
-         (dynamic-object/c names ctcs fnames fctcs)
-         names ctcs fnames fctcs)))]))
-
-;; This contract combinator prevents the method call if the target
-;; method is typed (assuming that the caller is untyped or the receiving
-;; object went through untyped code)
-(define (((restrict-typed->-late-neg-projection ctc) blame) val neg-party)
-  (cond
-    [(typed-method? val)
-     (chaperone-procedure val
-                          (make-keyword-procedure
-                           (λ (_ kw-args . rst)
-                             (raise-blame-error (blame-swap blame) val #:missing-party neg-party
-                                                "cannot call uncontracted typed method"))
-                           (λ args
-                             (raise-blame-error (blame-swap blame) val #:missing-party neg-party
-                                                "cannot call uncontracted typed method"))))]
-    [else val]))
-
-;; Returns original method name
-(define (restrict-typed->-name ctc)
-  (define name (restrict-typed->/c-name ctc))
-  (build-compound-type-name 'restrict-typed->/c name))
-
-(define (restrict-typed->/c-equivalent? this that)
-  (and (restrict-typed->/c? that)
-       (eq? (restrict-typed->/c-name this)
-            (restrict-typed->/c-name that))))
-
-(struct restrict-typed->/c (name)
-        #:property prop:chaperone-contract
-        (build-chaperone-contract-property
-         #:name restrict-typed->-name
-         #:stronger restrict-typed->/c-equivalent?
-         #:equivalent restrict-typed->/c-equivalent?
-         #:late-neg-projection restrict-typed->-late-neg-projection))
-
-(define (restrict-typed-field-late-neg-proj ctc)
-  (define name (restrict-typed-field/c-name ctc))
-  (λ (*blame)
-    (define blame
-      ;; Blame has been swapped if this is for a set-field!, in which case
-      ;; the blame matches the original negative party. Otherwise we want
-      ;; to swap to blame negative.
-      (if (blame-swapped? *blame)
-          *blame
-          (blame-swap *blame)))
-    (λ (val neg-party)
-      (raise-blame-error
-       blame val #:missing-party neg-party
-       "cannot read or write field hidden by Typed Racket"))))
-
-(define (restrict-typed-field-name ctc)
-  (define name (restrict-typed-field/c-name ctc))
-  (build-compound-type-name 'restrict-typed-field/c name))
-
-(define (restrict-typed-field-equivalent? this that)
-  (and (restrict-typed-field/c? that)
-       (equal? (restrict-typed-field/c-name this)
-               (restrict-typed-field/c-name that))))
-
-(struct restrict-typed-field/c (name)
-        #:property prop:flat-contract
-        (build-flat-contract-property
-         #:name restrict-typed-field-name
-         #:stronger restrict-typed-field-equivalent?
-         #:equivalent restrict-typed-field-equivalent?
-         #:late-neg-projection restrict-typed-field-late-neg-proj))
+      (object/c ?clause ...
+                #:opaque-except typed-method?
+                #:opaque-fields #t
+                #:do-not-check-class-field-accessor-or-mutator-access))]))