suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

..

Browse Source 
original commit: 75f6a1349c435d93a0d6b183704b086dc20f057b
This commit is contained in:
Robby Findler 2003-01-22 20:48:24 +00:00
parent 4185baad28
commit 1f91794eea
2 changed files with 155 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

194
collects/mzlib/contracts.ss
View File

@ -680,7 +680,7 @@
(cond (cond
[(flat-named-contract? fc) (flat-named-contract-type-name fc)] [(flat-named-contract? fc) (flat-named-contract-type-name fc)]
[else (or (predicate->type-name fc) [else (or (predicate->type-name fc)
"unknown type")])) (format "unknown contract ~s" fc))]))
; ;
@ -818,8 +818,10 @@
(define (class-contract/proc stx) (define (class-contract/proc stx)
(syntax-case stx () (syntax-case stx ()
[(_ (meth-name meth-contract) ...) [(_ (method-specifier meth-name meth-contract) ...)
(andmap identifier? (syntax->list (syntax (meth-name ...)))) (and
(andmap method-specifier? (syntax->list (syntax (method-specifier ...))))
(andmap identifier? (syntax->list (syntax (meth-name ...)))))
(match-let ([(`(,make-outer-checks ,xxx ,build-pieces) ...) (match-let ([(`(,make-outer-checks ,xxx ,build-pieces) ...)
(map (lambda (meth-contract-stx) (map (lambda (meth-contract-stx)
(let ([/h (select/h meth-contract-stx 'class-contract stx)]) (let ([/h (select/h meth-contract-stx 'class-contract stx)])
@ -829,90 +831,146 @@
(syntax->list (syntax (meth-contract ...))))]) (syntax->list (syntax (meth-contract ...))))])
(let* ([outer-args (syntax (val pos-blame neg-blame src-info))] (let* ([outer-args (syntax (val pos-blame neg-blame src-info))]
[val-meth-names (syntax->list (syntax (meth-name ...)))] [val-meth-names (syntax->list (syntax (meth-name ...)))]
[super-meth-names (map prefix-super val-meth-names)]) [val-publics? (map (lambda (x) (eq? 'public (syntax-e x)))
(syntax->list (syntax (method-specifier ...))))]
[super-meth-names (map prefix-super val-meth-names)]
[val-meth-contracts (syntax->list (syntax (meth-contract ...)))]
[val-meth-contract-vars (generate-temporaries val-meth-contracts)])
(with-syntax ([outer-args outer-args] (with-syntax ([outer-args outer-args]
[(super-meth-name ...) super-meth-names] [(super-meth-name ...) super-meth-names]
[(later-method ...) (map (lambda (a b c) (make-wrapper/extending-method outer-args a b c)) [(get-meth-contract ...) (map method-name->contract-method-name val-meth-names)]
val-meth-names [(method ...) (map (lambda (meth-name meth-contract-var contract-stx public?)
super-meth-names (if public?
build-pieces)] (make-wrapper-method outer-args meth-name meth-contract-var contract-stx)
[(first-method ...) (map (lambda (a b c) (make-wrapper-method outer-args a b c)) (make-wrapper-method/impl outer-args meth-name meth-contract-var contract-stx)))
val-meth-names val-meth-names
super-meth-names val-meth-contract-vars
(syntax->list (syntax meth-contract ...)))]) val-meth-contracts
val-publics?)]
[(meth-contract-var ...) val-meth-contract-vars]
[(method-contract-declarations ...) (map (lambda (meth-name meth-contract-var public?)
(if public?
(make-public-method-contract-declaration meth-name meth-contract-var)
(make-override-method-contract-declaration meth-name meth-contract-var)))
val-meth-names
val-meth-contract-vars
val-publics?)])
(foldr (foldr
(lambda (f stx) (f stx)) (lambda (f stx) (f stx))
(syntax/loc stx (syntax/loc stx
(make-contract (let ([meth-contract-var meth-contract] ...)
(lambda outer-args (make-contract
(unless (class? val) (lambda outer-args
(raise-contract-error src-info pos-blame neg-blame "expected a class, got: ~e" val)) (unless (class? val)
(let ([class-i (class->interface val)]) (raise-contract-error src-info pos-blame neg-blame "expected a class, got: ~e" val))
(void) (let ([class-i (class->interface val)])
(unless (method-in-interface? 'meth-name class-i) (void)
(raise-contract-error src-info (unless (method-in-interface? 'meth-name class-i)
pos-blame (raise-contract-error src-info
neg-blame pos-blame
"expected class to have method ~a, got: ~e" neg-blame
'meth-name "expected class to have method ~a, got: ~e"
val)) 'meth-name
...) val))
(if (implementation? val class-with-contracts<%>) ...
'(class val
(define/override (get-method-contracts) (let ([override-spec? (eq? 'override 'method-specifier)]
(list (cons 'meth-name meth-contract) ...)) [override? (method-in-interface? 'get-meth-contract class-i)])
(rename [super-meth-name meth-name] ...) (unless (boolean=? override-spec? override?)
later-method ... (if override-spec?
(super-instantiate ())) (error 'class-contract "method ~a is declared as an overriding method in ~e, but isn't" 'meth-name val)
(class* val (class-with-contracts<%>) (error 'class-contract "method ~a is declared as a public method in ~e, but isn't" 'meth-name val))))
...)
(define/public (get-method-contracts)
(list (cons 'meth-name meth-contract) ...)) (class val
(rename [super-meth-name meth-name] ...) method-contract-declarations ...
first-method ...
(super-instantiate ())))) (rename [super-meth-name meth-name] ...)
(lambda x (error 'impl-contract "unimplemented")))) method ...
(super-instantiate ())))
(lambda x (error 'impl-contract "unimplemented")))))
make-outer-checks))))] make-outer-checks))))]
[(_ (meth-name meth-contract) ...) [(_ (meth-specifier meth-name meth-contract) ...)
(for-each (lambda (name) (for-each (lambda (specifier name)
(unless (method-specifier? name)
(raise-syntax-error 'class-contract "expected either public or override" stx specifier))
(unless (identifier? name) (unless (identifier? name)
(raise-syntax-error 'class-contract "expected name" stx name))) (raise-syntax-error 'class-contract "expected name" stx name)))
(syntax->list (syntax (meth-specifier ...)))
(syntax->list (syntax (meth-name ...))))] (syntax->list (syntax (meth-name ...))))]
[(_ clz ...) [(_ clz ...)
(for-each (lambda (clz) (for-each (lambda (clz)
(syntax-case clz () (syntax-case clz ()
[(a b) (void)] [(a b c) (void)]
[else (raise-syntax-error 'class-contract "bad method/contract clause" stx clz)])) [else (raise-syntax-error 'class-contract "bad method/contract clause" stx clz)]))
(syntax->list (syntax (clz ...))))])) (syntax->list (syntax (clz ...))))]))
;; method-specifier? : syntax -> boolean
;; returns #t if x is the syntax for a valid method specifier
(define (method-specifier? x)
(or (eq? 'public (syntax-e x))
(eq? 'override (syntax-e x))))
;; make-wrapper-method : syntax[identifier] syntax[identifier] (syntax -> syntax) -> syntax ;; make-wrapper-method : syntax syntax[identifier] syntax[identifier] syntax -> syntax
;; constructs a wrapper method that checks the pre and post-condition, and ;; constructs a wrapper method that checks the pre and post-condition, and
;; calls the super method inbetween. ;; calls the super method inbetween.
(define (make-wrapper-method-old outer-args method-name super-method-name build-piece) (define (make-wrapper-method outer-args method-name contract-var contract-stx)
(with-syntax ([super-method-name super-method-name]
[method-name method-name]
[(val pos-blame neg-blame src-info) outer-args]
[super-call (car (generate-temporaries (list super-method-name)))])
(with-syntax ([(args body) (build-piece (syntax (super-call pos-blame neg-blame src-info)))])
(syntax
(define/override method-name
(let ([super-call (lambda x (super-method-name . x))])
(lambda args
body)))))))
(define (make-wrapper-method outer-args method-name super-method-name contract)
(with-syntax ([(val pos-blame neg-blame src-info) outer-args] (with-syntax ([(val pos-blame neg-blame src-info) outer-args]
[super-method-name super-method-name] [super-method-name (prefix-super method-name)]
[method-name method-name] [method-name method-name]
[contract contract]) [contract-var contract-var])
(syntax (syntax/loc contract-stx
(define/override method-name (define/override method-name
(let ([super-method (lambda x (super-method-name . x))]) (lambda args
(lambda args (let ([super-method (lambda x (super-method-name . x))])
(apply (check-contract super-method contract pos-blame neg-blame src-info) args))))))) (apply (check-contract contract-var super-method pos-blame neg-blame src-info) args)))))))
;; make-wrapper-method/impl : syntax syntax[identifier] syntax[identifier] syntax -> syntax
;; constructs a wrapper method that checks the pre and post-condition, and
;; calls the super method inbetween.
(define (make-wrapper-method/impl outer-args method-name contract-var contract-stx)
(with-syntax ([(val pos-blame neg-blame src-info) outer-args]
[super-method-name (prefix-super method-name)]
[method-name method-name]
[get-super-contract (prefix-super (method-name->contract-method-name method-name))]
[contract-var contract-var])
(syntax/loc contract-stx
(define/override method-name
(lambda args
(let ([super-method (lambda x (super-method-name . x))])
(apply (check-implication contract-var
(get-super-contract)
(check-contract contract-var
super-method
pos-blame
neg-blame
src-info)
pos-blame
src-info)
args)))))))
;; make-public-method-contract-declaration : syntax syntax -> syntax
(define (make-public-method-contract-declaration meth-name meth-contract-var)
(with-syntax ([get-contract (method-name->contract-method-name meth-name)]
[meth-contract-var meth-contract-var]
[meth-name meth-name])
(syntax
(define/public (get-contract)
meth-contract-var))))
;; make-override-method-contract-declaration : syntax syntax -> syntax
(define (make-override-method-contract-declaration meth-name meth-contract-var)
(with-syntax ([get-contract (method-name->contract-method-name meth-name)]
[super-get-contract (prefix-super (method-name->contract-method-name meth-name))]
[meth-contract-var meth-contract-var]
[meth-name meth-name])
(syntax
(begin
(rename [super-get-contract get-contract])
(define/override (get-contract)
meth-contract-var)))))
;; prefix-super : syntax[identifier] -> syntax[identifier] ;; prefix-super : syntax[identifier] -> syntax[identifier]
;; adds super- to the front of the identifier ;; adds super- to the front of the identifier
(define (prefix-super stx) (define (prefix-super stx)
@ -1418,9 +1476,7 @@
[else (cons (- n i) [else (cons (- n i)
(loop (- i 1)))])))))) (loop (- i 1)))]))))))
(define class-with-contracts<%> (define class-with-contracts<%> (interface ()))
(interface ()
))
(define-syntax (opt-> stx) (define-syntax (opt-> stx)
(syntax-case stx () (syntax-case stx ()

34
collects/tests/mzscheme/contracts.ss
View File

@ -817,7 +817,7 @@
(test/spec-passed/result (test/spec-passed/result
'class-contract1 'class-contract1
'(send '(send
(make-object (contract (class-contract (m (integer? . -> . integer?))) (make-object (contract (class-contract (public m (integer? . -> . integer?)))
(class object% (define/public (m x) x) (super-instantiate ())) (class object% (define/public (m x) x) (super-instantiate ()))
'pos 'pos
'neg)) 'neg))
@ -827,7 +827,7 @@
(test/spec-failed (test/spec-failed
'class-contract2 'class-contract2
'(contract (class-contract (m (integer? . -> . integer?))) '(contract (class-contract (public m (integer? . -> . integer?)))
object% object%
'pos 'pos
'neg) 'neg)
@ -836,7 +836,7 @@
(test/spec-failed (test/spec-failed
'class-contract3 'class-contract3
'(send '(send
(make-object (contract (class-contract (m (integer? . -> . integer?))) (make-object (contract (class-contract (public m (integer? . -> . integer?)))
(class object% (define/public (m x) x) (super-instantiate ())) (class object% (define/public (m x) x) (super-instantiate ()))
'pos 'pos
'neg)) 'neg))
@ -847,7 +847,7 @@
(test/spec-failed (test/spec-failed
'class-contract4 'class-contract4
'(send '(send
(make-object (contract (class-contract (m (integer? . -> . integer?))) (make-object (contract (class-contract (public m (integer? . -> . integer?)))
(class object% (define/public (m x) 'x) (super-instantiate ())) (class object% (define/public (m x) 'x) (super-instantiate ()))
'pos 'pos
'neg)) 'neg))
@ -855,6 +855,32 @@
1) 1)
"pos") "pos")
(test/spec-failed
'class-contract=>1
'(let* ([c% (contract (class-contract (public m ((>=/c 10) . -> . (>=/c 10))))
(class object% (define/public (m x) x) (super-instantiate ()))
'pos-c
'neg-c)]
[d% (contract (class-contract (override m ((>=/c 15) . -> . (>=/c 5))))
(class c% (define/override (m x) x) (super-instantiate ()))
'pos-d
'neg-d)])
(send (make-object d%) m 12))
"pos-d")
(test/spec-failed
'class-contract=>2
'(let* ([c% (contract (class-contract (public m ((>=/c 10) . -> . (>=/c 10))))
(class object% (define/public (m x) x) (super-instantiate ()))
'pos-c
'neg-c)]
[d% (contract (class-contract (override m ((>=/c 15) . -> . (>=/c 5))))
(class c% (define/override (m x) 8) (super-instantiate ()))
'pos-d
'neg-d)])
(send (make-object d%) m 100))
"pos-d")
)) ))
(report-errs) (report-errs)