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

..

Browse Source 
original commit: 0d1defb6fd20a2a08e420ad6de0637a69c6a1ec1
This commit is contained in:
Robby Findler 2003-01-27 04:41:53 +00:00
parent 60f376b488
commit 06a424cb56
2 changed files with 104 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

184
collects/mzlib/contracts.ss
View File

@ -18,12 +18,12 @@
(require-for-syntax mzscheme (require-for-syntax mzscheme
"list.ss" "list.ss"
(lib "match.ss") "match.ss"
(lib "stx.ss" "syntax") (lib "stx.ss" "syntax")
(lib "name.ss" "syntax")) (lib "name.ss" "syntax"))
(require "private/class-sneaky.ss" (require "private/class-sneaky.ss"
(lib "etc.ss")) "etc.ss")
(require (lib "contract-helpers.scm" "mzlib" "private")) (require (lib "contract-helpers.scm" "mzlib" "private"))
(require-for-syntax (prefix a: (lib "contract-helpers.scm" "mzlib" "private"))) (require-for-syntax (prefix a: (lib "contract-helpers.scm" "mzlib" "private")))
@ -883,8 +883,6 @@
(andmap identifier? (syntax->list (syntax (meth-name ...))))) (andmap identifier? (syntax->list (syntax (meth-name ...)))))
(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 ...)))]
[val-publics? (map (lambda (x) (eq? 'public (syntax-e x)))
(syntax->list (syntax (method-specifier ...))))]
[super-meth-names (map prefix-super val-meth-names)] [super-meth-names (map prefix-super val-meth-names)]
[val-meth-contracts (syntax->list (syntax (meth-contract ...)))] [val-meth-contracts (syntax->list (syntax (meth-contract ...)))]
[val-meth-contract-vars (generate-temporaries val-meth-contracts)]) [val-meth-contract-vars (generate-temporaries val-meth-contracts)])
@ -895,34 +893,15 @@
[(super-meth-name ...) super-meth-names] [(super-meth-name ...) super-meth-names]
[(get-meth-contract ...) (map method-name->contract-method-name val-meth-names)] [(get-meth-contract ...) (map method-name->contract-method-name val-meth-names)]
[(method ...) [(method ...)
(map (lambda (meth-name meth-contract-var contract-stx public?) (map (lambda (meth-name meth-contract-var contract-stx)
(if public? (make-class-wrapper-method outer-args
(make-class-wrapper-method outer-args meth-name
meth-name meth-contract-var
meth-contract-var contract-stx))
contract-stx)
(make-class-wrapper-method/impl outer-args
meth-name
meth-contract-var
contract-stx)))
val-meth-names val-meth-names
val-meth-contract-vars val-meth-contract-vars
val-meth-contracts val-meth-contracts)]
val-publics?)]
[(meth-contract-var ...) val-meth-contract-vars] [(meth-contract-var ...) val-meth-contract-vars]
[(method-contract-declarations ...)
(map (lambda (src-stx meth-name meth-contract-var public?)
(if public?
(make-public-method-contract-declaration src-stx
meth-name
meth-contract-var)
(make-override-method-contract-declaration src-stx
meth-name
meth-contract-var)))
val-meth-contracts
val-meth-names
val-meth-contract-vars
val-publics?)]
[this (datum->syntax-object (syntax form) 'this stx)] [this (datum->syntax-object (syntax form) 'this stx)]
[super-init (datum->syntax-object (syntax form) 'super-instantiate stx)] [super-init (datum->syntax-object (syntax form) 'super-instantiate stx)]
[super-make (datum->syntax-object (syntax form) 'super-make-object stx)]) [super-make (datum->syntax-object (syntax form) 'super-make-object stx)])
@ -934,9 +913,16 @@
(syntax/loc stx (syntax/loc stx
(super-init ())))]) (super-init ())))])
(syntax/loc stx (syntax/loc stx
(let ([meth-contract-var meth-contract] ...) (make-contract
(make-contract (lambda outer-args
(lambda outer-args (let ([super-contracts-ht
(let loop ([cls val])
(cond
[(sneaky-class? cls) (sneaky-class-contract-table cls)]
[else (let ([super (class-super-class cls)])
(and super
(loop super)))]))]
[meth-contract-var meth-contract] ...)
(unless (class? val) (unless (class? val)
(raise-contract-error src-info pos-blame neg-blame "expected a class, got: ~e" val)) (raise-contract-error src-info pos-blame neg-blame "expected a class, got: ~e" val))
(let ([class-i (class->interface val)]) (let ([class-i (class->interface val)])
@ -948,25 +934,18 @@
"expected class to have method ~a, got: ~e" "expected class to have method ~a, got: ~e"
'meth-name 'meth-name
val)) val))
...
(let ([override-spec? (eq? 'override 'method-specifier)]
[override? (method-in-interface? 'get-meth-contract class-i)])
(unless (boolean=? override-spec? override?)
(if override-spec?
(error 'class-contract "method ~a is declared as an overriding method in ~e, but isn't" 'meth-name val)
(error 'class-contract "method ~a is declared as a public method in ~e, but isn't" 'meth-name val))))
...) ...)
(let ([c (class*/names-sneaky
(class*/names-sneaky (this super-init super-make) val ()
(this super-init super-make) val ()
(rename [super-meth-name meth-name] ...)
method-contract-declarations ... method ...
call-super-initializer)]
(rename [super-meth-name meth-name] ...) [ht (make-hash-table)])
method ... (set-sneaky-class-contract-table! c ht)
call-super-initializer)) (hash-table-put! ht 'meth-name meth-contract-var) ...
(lambda x (error 'impl-contract "unimplemented for class contracts"))))))))] c)))
(lambda x (error 'impl-contract "unimplemented for class contracts")))))))]
[(_ (meth-specifier meth-name meth-contract) ...) [(_ (meth-specifier meth-name meth-contract) ...)
(for-each (lambda (specifier name) (for-each (lambda (specifier name)
(unless (method-specifier? name) (unless (method-specifier? name)
@ -1002,9 +981,9 @@
val-meth-contracts)] val-meth-contracts)]
[(meth-contract-var ...) val-meth-contract-vars]) [(meth-contract-var ...) val-meth-contract-vars])
(syntax/loc stx (syntax/loc stx
(let ([meth-contract-var meth-contract] ...) (make-contract
(make-contract (lambda outer-args
(lambda outer-args (let ([meth-contract-var meth-contract] ...)
(unless (object? val) (unless (object? val)
(raise-contract-error src-info pos-blame neg-blame "expected an object, got: ~e" val)) (raise-contract-error src-info pos-blame neg-blame "expected an object, got: ~e" val))
(let ([obj-i (object-interface val)]) (let ([obj-i (object-interface val)])
@ -1022,8 +1001,8 @@
val val
(class object% (class object%
method ... method ...
(super-instantiate ())))) (super-instantiate ())))))
(lambda x (error 'impl-contract "unimplemented for object contracts")))))))] (lambda x (error 'impl-contract "unimplemented for object contracts"))))))]
[(_ (meth-name meth-contract) ...) [(_ (meth-name meth-contract) ...)
(for-each (lambda (name) (for-each (lambda (name)
(unless (identifier? name) (unless (identifier? name)
@ -1096,70 +1075,37 @@
[method-name-string (symbol->string (syntax-e method-name))] [method-name-string (symbol->string (syntax-e method-name))]
[contract-var contract-var]) [contract-var contract-var])
(syntax/loc contract-stx (syntax/loc contract-stx
(define/override method-name (define/override method-name
(lambda args (lambda args
(let ([super-method (lambda x (super-method-name . x))] (let* ([super-method (lambda x (super-method-name . x))]
[method-specific-src-info [method-specific-src-info
(if (identifier? src-info) (if (identifier? src-info)
(datum->syntax-object (datum->syntax-object
src-info src-info
(string->symbol (string->symbol
(string-append (string-append
(symbol->string (syntax-e src-info)) (symbol->string (syntax-e src-info))
" method " " method "
method-name-string))) method-name-string)))
src-info)]) src-info)]
(apply (check-contract contract-var [super-contract (and super-contracts-ht
super-method (hash-table-get super-contracts-ht
pos-blame 'method-name
neg-blame (lambda () #f)))]
method-specific-src-info) [wrapped-method (check-contract contract-var
args))))))) super-method
pos-blame
;; make-class-wrapper-method/impl : syntax syntax[identifier] syntax[identifier] syntax -> syntax neg-blame
;; constructs a wrapper method that checks the pre and post-condition, and method-specific-src-info)])
;; calls the super method inbetween. (apply
(define (make-class-wrapper-method/impl outer-args method-name contract-var contract-stx) (if super-contract
(with-syntax ([(val pos-blame neg-blame src-info) outer-args] (check-implication contract-var
[super-method-name (prefix-super method-name)] super-contract
[method-name method-name] wrapped-method
[get-super-contract (prefix-super (method-name->contract-method-name method-name))] pos-blame
[contract-var contract-var]) src-info)
(syntax/loc contract-stx wrapped-method)
(define/override method-name args)))))))
(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 src-stx 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/loc src-stx
(define/public (get-contract)
meth-contract-var))))
;; make-override-method-contract-declaration : syntax syntax -> syntax
(define (make-override-method-contract-declaration src-stx 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/loc src-stx
(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

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

@ -998,6 +998,45 @@
(interface-extension? (object-interface d) (object-interface c)))) (interface-extension? (object-interface d) (object-interface c))))
(list #t #t #t #t #t)) (list #t #t #t #t #t))
(test/spec-passed
'recursive-class1
'(letrec ([cc (class-contract (public m (-> dd dd)))]
[dd (class-contract (public n (-> cc cc)))]
[c% (contract cc (class object% (define/public (m x) x) (super-instantiate ())) 'c-pos 'c-neg)]
[d% (contract dd (class object% (define/public (n x) x) (super-instantiate ())) 'd-pos 'd-neg)])
(send (make-object c%) m d%)
(send (make-object d%) n c%)))
(test/spec-failed
'recursive-class1
'(letrec ([cc (class-contract (public m (-> dd dd)))]
[dd (class-contract (public n (-> cc cc)))]
[c% (contract cc (class object% (define/public (m x) x) (super-instantiate ())) 'c-pos 'c-neg)]
[d% (contract dd (class object% (define/public (n x) x) (super-instantiate ())) 'd-pos 'd-neg)])
(send (make-object c%) m c%))
"c-neg")
(test/spec-passed
'recursive-object1
'(letrec ([cc (object-contract (m (-> dd dd)))]
[dd (object-contract (m (-> cc cc)))]
[% (class object% (define/public (m x) x) (super-instantiate ()))]
[c (contract cc (make-object %) 'c-pos 'c-neg)]
[d (contract dd (make-object %) 'd-pos 'd-neg)])
(send c m d)
(send d m c)))
(test/spec-failed
'recursive-object2
'(letrec ([cc (object-contract (m (-> dd dd)))]
[dd (object-contract (n (-> cc cc)))]
[% (class object% (define/public (m x) x) (define/public (n x) x) (super-instantiate ()))]
[c (contract cc (make-object %) 'c-pos 'c-neg)]
[d (contract dd (make-object %) 'd-pos 'd-neg)])
(send c m c))
"c-neg")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;; ;; ;;
;; Flat Contract Tests ;; ;; Flat Contract Tests ;;