diff --git a/pkgs/racket-doc/scribblings/reference/class.scrbl b/pkgs/racket-doc/scribblings/reference/class.scrbl index 7a34cb9b76..81b22da5b7 100644 --- a/pkgs/racket-doc/scribblings/reference/class.scrbl +++ b/pkgs/racket-doc/scribblings/reference/class.scrbl @@ -2076,6 +2076,17 @@ Produces a contract for an object, where the object is an instance of a class that conforms to @racket[class-contract]. } +@defproc[(dynamic-object/c [method-names (listof symbol?)] + [method-contracts (listof contract?)] + [field-names (listof symbol?)] + [field-contracts (listof contract?)]) + contract?]{ +Produces a contract for an object, similar to @racket[object/c] but +where the names and contracts for both methods and fields can be +computed dynamically. The list of names and contracts for both +methods and field respectively must have the same lengths. +} + @defform/subs[ #:literals (field -> ->* ->d) diff --git a/pkgs/racket-test/tests/racket/contract/object.rkt b/pkgs/racket-test/tests/racket/contract/object.rkt index bdec975267..7fada3dde7 100644 --- a/pkgs/racket-test/tests/racket/contract/object.rkt +++ b/pkgs/racket-test/tests/racket/contract/object.rkt @@ -17,6 +17,13 @@ 'pos 'neg)) +(test/spec-passed + 'object/c-first-order-object-3 + '(contract (dynamic-object/c null null null null) + (new object%) + 'pos + 'neg)) + (test/pos-blame 'object/c-first-order-method-1 '(contract (object/c [m (-> any/c number? number?)]) @@ -31,6 +38,13 @@ 'pos 'neg)) +(test/spec-passed + 'object/c-first-order-method-3 + '(contract (dynamic-object/c '(m) (list (-> any/c number? number?)) null null) + (new (class object% (super-new) (define/public (m x) (add1 x)))) + 'pos + 'neg)) + (test/pos-blame 'object/c-first-order-local-method-1 '(let () @@ -63,6 +77,13 @@ 'pos 'neg)) +(test/spec-passed + 'object/c-first-order-field-3 + '(contract (dynamic-object/c null null '(n) (list number?)) + (new (class object% (super-new) (field [n 3]))) + 'pos + 'neg)) + (test/pos-blame 'object/c-first-order-local-field-1 '(let () @@ -158,4 +179,42 @@ 'pos 'neg)]) (set-field! n pre-o #t) - (get-field n o)))) + (get-field n o))) + +(test/pos-blame + 'object/c-higher-order-field-9 + '(let* ([pre-o (new (class object% (super-new) (field [n 3])))] + [o (contract (dynamic-object/c null null '(n) (list number?)) + pre-o + 'pos + 'neg)]) + (set-field! n pre-o #t) + (get-field n o))) + +(test/spec-passed/result + 'object/c-field-existence + '(send (contract + (object/c + (field foo bar) + (baz (->m integer? integer?))) + (new (class object% + (super-new) + (field (foo 0) (bar 0)) + (define/public (baz n) n))) + 'pos 'neg) + baz 1) + 1) + +(test/spec-passed/result + 'object/c-field-existence2 + '(send (contract + (object/c + (field foo bar) + (baz (->m integer? (listof integer?)))) + (new (class object% + (super-new) + (field (foo 0) (bar 1)) + (define/public (baz n) (list foo bar)))) + 'pos 'neg) + baz 1) + '(0 1))) diff --git a/racket/collects/racket/private/class-c-old.rkt b/racket/collects/racket/private/class-c-old.rkt index 93c09277ff..0181a05b88 100644 --- a/racket/collects/racket/private/class-c-old.rkt +++ b/racket/collects/racket/private/class-c-old.rkt @@ -19,7 +19,8 @@ (struct-out internal-class/c) just-check-existence just-check-existence? build-internal-class/c internal-class/c-proj - class/c-internal-name-clauses) + class/c-internal-name-clauses + dynamic-object/c) ;; Shorthand contracts that treat the implicit object argument as if it were ;; contracted with any/c. @@ -1201,6 +1202,31 @@ #:key (compose symbol->string car))) (values (map car sorted) (map cdr sorted))) +;; dynamic-object/c : Listof Listof +;; Listof Listof +;; -> Contract +;; An external constructor provided in order to allow runtime +;; construction of object contracts by libraries that want to +;; implement their own object contract variants +(define (dynamic-object/c method-names method-contracts + field-names field-contracts) + (define (ensure-symbols names) + (unless (and (list? names) (andmap symbol? names)) + (raise-argument-error 'dynamic-object/c "(listof symbol?)" names))) + (define (ensure-length names ctcs) + (unless (= (length names) (length ctcs)) + (raise-arguments-error 'dynamic-object/c + "expected the same number of names and contracts" + "names" names + "contracts" ctcs))) + (ensure-symbols method-names) + (ensure-length method-names method-contracts) + (ensure-symbols field-names) + (ensure-length field-names field-contracts) + (make-base-object/c + method-names (coerce-contracts 'dynamic-object/c method-contracts) + field-names (coerce-contracts 'dynamic-object/c field-contracts))) + (define (check-object-contract obj methods fields fail) (unless (object? obj) (fail '(expected: "an object" given: "~e") obj)) diff --git a/racket/collects/racket/private/class-internal.rkt b/racket/collects/racket/private/class-internal.rkt index 2518565166..e55a575bcc 100644 --- a/racket/collects/racket/private/class-internal.rkt +++ b/racket/collects/racket/private/class-internal.rkt @@ -62,6 +62,7 @@ (struct-out exn:fail:object) make-primitive-class class/c ->m ->*m ->dm case->m object/c instanceof/c + dynamic-object/c ;; "keywords": private public override augment