From ab68a4dc38481aa0be3a16ed87769331c71f64bb Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Tue, 24 Feb 2015 17:25:00 -0500 Subject: [PATCH] Add option to ignore local names in opaque class/c --- .../scribblings/reference/class.scrbl | 10 ++++- .../tests/racket/contract/class.rkt | 42 ++++++++++++++++++- .../collects/racket/private/class-c-old.rkt | 23 +++++----- 3 files changed, 60 insertions(+), 15 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/class.scrbl b/pkgs/racket-doc/scribblings/reference/class.scrbl index 81b22da5b7..b8f7d8b445 100644 --- a/pkgs/racket-doc/scribblings/reference/class.scrbl +++ b/pkgs/racket-doc/scribblings/reference/class.scrbl @@ -1737,7 +1737,8 @@ resulting trait are the same as for @racket[trait-sum], otherwise the ([maybe-opaque (code:line) - (code:line #:opaque)] + (code:line #:opaque) + (code:line #:opaque #:ignore-local-member-names)] [member-spec method-spec @@ -1785,7 +1786,9 @@ A class contract can be specified to be @emph{opaque} with the @racket[#:opaque] keyword. An opaque class contract will only accept a class that defines exactly the external methods and fields specified by the contract. A contract error is raised if the contracted class contains any methods or fields that are -not specified. +not specified. Methods or fields with local member names (i.e., defined with +@racket[define-local-member-name]) are ignored for this check if +@racket[#:ignore-local-member-names] is provided. The external contracts are as follows: @@ -2008,6 +2011,9 @@ As with the external contracts, when a method or field name is specified checked on any access and/or mutation of the field that occurs in such subclasses.} +@history[#:changed "6.1.1.8" + @string-append{Opaque class/c now optionally ignores local + member names if an additional keyword is supplied.}] ]} @defform[(absent absent-spec ...)]{ diff --git a/pkgs/racket-test/tests/racket/contract/class.rkt b/pkgs/racket-test/tests/racket/contract/class.rkt index 23bf7f5f86..abc7286ba3 100644 --- a/pkgs/racket-test/tests/racket/contract/class.rkt +++ b/pkgs/racket-test/tests/racket/contract/class.rkt @@ -131,7 +131,16 @@ (class object% (super-new) (define/public (m x) 3) (define/public (n) 4)) 'pos 'neg))) - + + (test/spec-passed + 'class/c-first-order-opaque-method-3-ignore + '(let () + (define-local-member-name n) + (contract (class/c #:opaque #:ignore-local-member-names [m (-> any/c number? number?)]) + (class object% (super-new) (define/public (m x) 3) (define/public (n) 4)) + 'pos + 'neg))) + (test/pos-blame 'class/c-first-order-opaque-method-4 '(contract @@ -141,6 +150,16 @@ (class object% (super-new) (define/public (m x) 3) (define/public (n) 4))) 'pos 'neg)) + + (test/spec-passed + 'class/c-first-order-opaque-method-4-ignore + '(contract + (class/c #:opaque #:ignore-local-member-names [m (-> any/c number? number?)]) + (let () + (define-local-member-name n) + (class object% (super-new) (define/public (m x) 3) (define/public (n) 4))) + 'pos + 'neg)) (test/pos-blame 'class/c-first-order-opaque-method-5 @@ -231,13 +250,22 @@ 'neg)) (test/pos-blame - 'class/c-first-order-opaque-field-2 + 'class/c-first-order-opaque-field-3 '(contract (class/c #:opaque (field [m number?])) (let () (define-local-member-name n) (class object% (super-new) (field [m 5] [n 3]))) 'pos 'neg)) + + (test/spec-passed + 'class/c-first-order-opaque-field-3-ignore + '(contract (class/c #:opaque #:ignore-local-member-names (field [m number?])) + (let () + (define-local-member-name n) + (class object% (super-new) (field [m 5] [n 3]))) + 'pos + 'neg)) ;; No true first-order tests here, other than just to make ;; sure they're accepted. For init-field, we can at least @@ -498,6 +526,16 @@ (super-new)) 'pos 'neg)) + + (test/spec-passed + 'class/c-first-order-opaque-super-3-ignore + '(contract (class/c #:opaque #:ignore-local-member-names) + (class (let () + (define-local-member-name m) + (class object% (super-new) (define/public (m) 3))) + (super-new)) + 'pos + 'neg)) (test/spec-passed 'class/c-first-order-opaque-super-4 diff --git a/racket/collects/racket/private/class-c-old.rkt b/racket/collects/racket/private/class-c-old.rkt index c81b288182..6e97d5c4b9 100644 --- a/racket/collects/racket/private/class-c-old.rkt +++ b/racket/collects/racket/private/class-c-old.rkt @@ -37,6 +37,7 @@ (syntax-parameterize ([making-a-method #'this-param] [method-contract? #t]) (->d . stx))) (define (class/c-check-first-order ctc cls fail) + (define opaque? (class/c-opaque? ctc)) (unless (class? cls) (fail '(expected: "a class" given: "~v") cls)) (define method-ht (class-method-ht cls)) @@ -55,31 +56,29 @@ [else m/l]))) (unless (contract-first-order-passes? c meth-proc) (fail "public method ~a doesn't match contract" m)))) - (unless (class/c-opaque? ctc) + (unless opaque? (for ([m (class/c-absents ctc)]) (when (hash-ref method-ht m #f) (fail "class already contains public method ~a" m)))) - (when (class/c-opaque? ctc) + (when opaque? (for ([m (in-hash-keys method-ht)]) (unless (memq m (class/c-methods ctc)) - (if (symbol-interned? m) - (fail "method ~a not specified in contract" m) - (fail "some local member not specified in contract"))))) + (when (or (not (symbol? opaque?)) (symbol-interned? m)) + (fail "method ~a not specified in contract" m))))) (define field-ht (class-field-ht cls)) (for ([f (class/c-fields ctc)]) (unless (hash-ref field-ht f #f) (fail "no public field ~a" f))) - (unless (class/c-opaque? ctc) + (unless opaque? (for ([f (class/c-absent-fields ctc)]) (when (hash-ref field-ht f #f) (fail "class already contains public field ~a" f)))) - (when (class/c-opaque? ctc) + (when opaque? (for ([f (in-hash-keys field-ht)]) (unless (memq f (class/c-fields ctc)) - (if (symbol-interned? f) - (fail "field ~a not specified in contract" f) - (fail "some local member field not specified in contract"))))) + (when (or (not (symbol? opaque?)) (symbol-interned? f)) + (fail "field ~a not specified in contract" f))))) #t) (define (internal-class/c-check-first-order internal-ctc cls fail) @@ -862,7 +861,7 @@ (check-one-stronger internal-class/c-augrides internal-class/c-augride-contracts this-internal that-internal) - (if (class/c-opaque? this) (class/c-opaque? that) #t) + (equal? (class/c-opaque? this) (class/c-opaque? that)) (all-included? (class/c-absent-fields that) (class/c-absent-fields this)) (all-included? (class/c-absents that) (class/c-absents this)))] [else #f])) @@ -1129,6 +1128,8 @@ (define-syntax (class/c stx) (define-splicing-syntax-class opaque-keyword + (pattern (~seq #:opaque #:ignore-local-member-names) + #:with opaque? #''ignore-local-member-names) (pattern (~seq #:opaque) #:with opaque? #'#t) (pattern (~seq) #:with opaque? #'#f))