Clean up first-order checking in object/c and object-contract.
Use let/ec only when needed (i.e. when raise-blame-error is not used). Also remove some of the old checking functions from mzlib's object-contract code that are no longer needed now that we have unified the first-order checking.
This commit is contained in:
Stevie Strickland
parent
5f7099c9bd
commit
96db670d8c
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user