diff --git a/collects/mzlib/private/contract-object.rkt b/collects/mzlib/private/contract-object.rkt index 8daded940a..0188cb4069 100644 --- a/collects/mzlib/private/contract-object.rkt +++ b/collects/mzlib/private/contract-object.rkt @@ -295,21 +295,12 @@ (list 'field-name ...) (list field-ctc-var ...)))) #:first-order (lambda (val) - (check-object-contract val #f (list 'method-name ...) (list 'field-name ...)))) - ctc)))))])))) + (let/ec ret + (check-object-contract val (list 'method-name ...) (list 'field-name ...) + (λ args (ret #f))))))) + ctc))))])))) -(define (check-object val blame) - (unless (object? val) - (raise-blame-error blame val "expected an object, got ~e" val))) - -(define (check-method val method-name val-mtd-names blame) - (unless (memq method-name val-mtd-names) - (raise-blame-error blame val "expected an object with method ~s" method-name))) - -(define (field-error val field-name blame) - (raise-blame-error blame val "expected an object with field ~s" field-name)) - (define (make-mixin-contract . %/<%>s) ((and/c (flat-contract class?) (apply and/c (map sub/impl?/c %/<%>s))) diff --git a/collects/racket/contract/private/object.rkt b/collects/racket/contract/private/object.rkt index 653109102d..23132838d8 100644 --- a/collects/racket/contract/private/object.rkt +++ b/collects/racket/contract/private/object.rkt @@ -53,7 +53,9 @@ #:first-order (λ (ctc) (λ (val) - (check-object-contract val #f (object-contract-methods ctc) (object-contract-fields ctc)))))) + (let/ec ret + (check-object-contract val (object-contract-methods ctc) (object-contract-fields ctc) + (λ args (ret #f)))))))) (define-syntax (object-contract stx) (syntax-case stx () diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index d6e04fde2f..135ec7abe5 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -2496,84 +2496,79 @@ (define-syntax-rule (->dm . stx) (syntax-parameterize ([making-a-method #'this-param]) (->d . stx))) -(define (class/c-check-first-order ctc cls blame) - (let/ec return - (define (failed str . args) - (if blame - (apply raise-blame-error blame cls str args) - (return #f))) - (unless (class? cls) - (failed "not a class")) - (let ([method-ht (class-method-ht cls)] - [beta-methods (class-beta-methods cls)] - [meth-flags (class-meth-flags cls)]) - (for ([m (class/c-methods ctc)]) - (unless (hash-ref method-ht m #f) - (failed "no public method ~a" m))) - (for ([m (class/c-inherits ctc)]) - (unless (hash-ref method-ht m #f) - (failed "no public method ~a" m))) - (for ([m (class/c-overrides ctc)]) - (let ([index (hash-ref method-ht m #f)]) - (unless index - (failed "no public method ~a" m)) - (let ([vec (vector-ref beta-methods index)]) - (unless (zero? (vector-length vec)) - (failed "method ~a was previously augmentable" m))) - (let ([flag (vector-ref meth-flags index)]) - (when (eq? flag 'final) - (failed "method ~a is final" m))))) - (for ([m (class/c-augments ctc)]) - (let ([index (hash-ref method-ht m #f)]) - (unless index - (failed "no public method ~a" m)) - (let* ([vec (vector-ref beta-methods index)]) - (when (zero? (vector-length vec)) - (failed "method ~a has never been augmentable" m)) - (when (vector-ref vec (sub1 (vector-length vec))) - (failed "method ~a is currently overrideable, not augmentable" m))))) - (for ([m (class/c-augrides ctc)]) - (let ([index (hash-ref method-ht m #f)]) - (unless index - (failed "no public method ~a" m)) - (let ([vec (vector-ref beta-methods index)]) - (when (zero? (vector-length vec)) - (failed "method ~a has never been augmentable" m)) - (unless (vector-ref vec (sub1 (vector-length vec))) - (failed "method ~a is currently augmentable, not overrideable" m))))) - (for ([s (class/c-supers ctc)]) - (let ([index (hash-ref method-ht s #f)]) - (unless index - (failed "no public method ~a" s)) - (let ([flag (vector-ref meth-flags index)]) - (when (eq? flag 'final) - (failed "method ~a is final" s)) - (when (eq? flag 'augmentable) - (failed "method ~a is augmentable, not overrideable" s))))) - (for ([i (class/c-inners ctc)]) - (let ([index (hash-ref method-ht i #f)]) - (unless index - (failed "no public method ~a" i)) - (let ([vec (vector-ref beta-methods index)]) - (when (zero? (vector-length vec)) - (failed "method ~a has never been augmentable" i))) - (let ([flag (vector-ref meth-flags index)]) - (when (eq? flag 'final) - (failed "method ~a is final" i))))) - (let ([field-ht (class-field-ht cls)]) - (for ([f (class/c-fields ctc)]) - (unless (hash-ref field-ht f #f) - (failed "no public field ~a" f))) - (for ([f (class/c-inherit-fields ctc)]) - (unless (hash-ref field-ht f #f) - (failed "no public field ~a" f))))) - #t)) +(define (class/c-check-first-order ctc cls fail) + (unless (class? cls) + (fail "not a class")) + (let ([method-ht (class-method-ht cls)] + [beta-methods (class-beta-methods cls)] + [meth-flags (class-meth-flags cls)]) + (for ([m (class/c-methods ctc)]) + (unless (hash-ref method-ht m #f) + (fail "no public method ~a" m))) + (for ([m (class/c-inherits ctc)]) + (unless (hash-ref method-ht m #f) + (fail "no public method ~a" m))) + (for ([m (class/c-overrides ctc)]) + (let ([index (hash-ref method-ht m #f)]) + (unless index + (fail "no public method ~a" m)) + (let ([vec (vector-ref beta-methods index)]) + (unless (zero? (vector-length vec)) + (fail "method ~a was previously augmentable" m))) + (let ([flag (vector-ref meth-flags index)]) + (when (eq? flag 'final) + (fail "method ~a is final" m))))) + (for ([m (class/c-augments ctc)]) + (let ([index (hash-ref method-ht m #f)]) + (unless index + (fail "no public method ~a" m)) + (let* ([vec (vector-ref beta-methods index)]) + (when (zero? (vector-length vec)) + (fail "method ~a has never been augmentable" m)) + (when (vector-ref vec (sub1 (vector-length vec))) + (fail "method ~a is currently overrideable, not augmentable" m))))) + (for ([m (class/c-augrides ctc)]) + (let ([index (hash-ref method-ht m #f)]) + (unless index + (fail "no public method ~a" m)) + (let ([vec (vector-ref beta-methods index)]) + (when (zero? (vector-length vec)) + (fail "method ~a has never been augmentable" m)) + (unless (vector-ref vec (sub1 (vector-length vec))) + (fail "method ~a is currently augmentable, not overrideable" m))))) + (for ([s (class/c-supers ctc)]) + (let ([index (hash-ref method-ht s #f)]) + (unless index + (fail "no public method ~a" s)) + (let ([flag (vector-ref meth-flags index)]) + (when (eq? flag 'final) + (fail "method ~a is final" s)) + (when (eq? flag 'augmentable) + (fail "method ~a is augmentable, not overrideable" s))))) + (for ([i (class/c-inners ctc)]) + (let ([index (hash-ref method-ht i #f)]) + (unless index + (fail "no public method ~a" i)) + (let ([vec (vector-ref beta-methods index)]) + (when (zero? (vector-length vec)) + (fail "method ~a has never been augmentable" i))) + (let ([flag (vector-ref meth-flags index)]) + (when (eq? flag 'final) + (fail "method ~a is final" i))))) + (let ([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))) + (for ([f (class/c-inherit-fields ctc)]) + (unless (hash-ref field-ht f #f) + (fail "no public field ~a" f))))) + #t) (define (class/c-proj ctc) (λ (blame) (let ([bswap (blame-swap blame)]) (λ (cls) - (class/c-check-first-order ctc cls blame) + (class/c-check-first-order ctc cls (λ args (apply raise-blame-error blame cls args))) (let* ([name (class-name cls)] [never-wrapped? (eq? (class-orig-cls cls) cls)] ;; Only add a new slot if we're not projecting an already contracted class. @@ -2927,7 +2922,8 @@ #:first-order (λ (ctc) (λ (cls) - (class/c-check-first-order ctc cls #f))))) + (let/ec ret + (class/c-check-first-order ctc cls (λ args (ret #f)))))))) (define-for-syntax (parse-class/c-specs forms object/c?) (define parsed-forms (make-hasheq)) @@ -3088,28 +3084,23 @@ augments augment-ctcs augrides augride-ctcs)))))])) -(define (check-object-contract obj blame methods fields) - (let/ec return - (define (failed str . args) - (if blame - (apply raise-blame-error blame obj str args) - (return #f))) - (unless (object? obj) - (failed "not a object")) - (let ([cls (object-ref obj)]) - (let ([method-ht (class-method-ht cls)]) - (for ([m methods]) - (unless (hash-ref method-ht m #f) - (failed "no public method ~a" m)))) - (let ([field-ht (class-field-ht cls)]) - (for ([m fields]) - (unless (hash-ref field-ht m #f) - (failed "no public field ~a" m))))))) +(define (check-object-contract obj methods fields fail) + (unless (object? obj) + (fail "not a object")) + (let ([cls (object-ref obj)]) + (let ([method-ht (class-method-ht cls)]) + (for ([m methods]) + (unless (hash-ref method-ht m #f) + (fail "no public method ~a" m)))) + (let ([field-ht (class-field-ht cls)]) + (for ([m fields]) + (unless (hash-ref field-ht m #f) + (fail "no public field ~a" m))))) + #t) (define (object/c-proj ctc) (λ (blame) (λ (obj) - (check-object-contract obj blame (object/c-methods ctc) (object/c-fields ctc)) (make-wrapper-object ctc obj blame (object/c-methods ctc) (object/c-method-contracts ctc) (object/c-fields ctc) (object/c-field-contracts ctc))))) @@ -3139,7 +3130,8 @@ #:first-order (λ (ctc) (λ (obj) - (check-object-contract obj #f (object/c-methods ctc) (object/c-fields ctc)))))) + (let/ec ret + (check-object-contract obj (object/c-methods ctc) (object/c-fields ctc) (λ args (ret #f)))))))) (define-syntax (object/c stx) (syntax-case stx () @@ -4441,7 +4433,7 @@ ;; make-wrapper-object: contract object blame (listof symbol) (listof contract?) (listof symbol) (listof contract?) (define (make-wrapper-object ctc obj blame methods method-contracts fields field-contracts) - (check-object-contract obj blame methods fields) + (check-object-contract obj methods fields (λ args (apply raise-blame-error blame obj args))) (let* ([new-cls (make-wrapper-class (object-ref obj) blame methods method-contracts fields field-contracts)]) (impersonate-struct obj object-ref (λ (o c) new-cls) impersonator-prop:contracted ctc)))