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

added this, bound in ->r and ->pp contracts, when used in object-contract

Browse Source 
svn: r1841
This commit is contained in:
Robby Findler 2006-01-16 18:42:11 +00:00
parent d93594fe2a
commit 12c7c0b6c6
2 changed files with 149 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
collects/mzlib/private/contract.ss
View File

@ -1204,8 +1204,9 @@ add struct contracts for immutable structs?
(obj-opt->/proc (syntax (opt-> (any/c req-contracts ...) (opt-contracts ...) res-contract)))
(generate-opt->vars (syntax (req-contracts ...))
(syntax (opt-contracts ...))))]
[else (let-values ([(x y z) (expand-mtd-arrow mtd-stx)])
(values (x y) z))]))
[else
(let-values ([(x y z) (expand-mtd-arrow mtd-stx)])
(values (x y) z))]))
;; generate-opt->vars : syntax[requried contracts] syntax[optional contracts] -> syntax[list of arg specs]
(define (generate-opt->vars req-stx opt-stx)
@ -1224,6 +1225,9 @@ add struct contracts for immutable structs?
(syntax-case mtd-stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)
[(->) (raise-syntax-error 'object-contract "-> must have arguments" stx mtd-stx)]
[(-> args ...)
;; this case cheats a little bit --
;; (args ...) contains the right number of arguments
;; to the method because it also contains one arg for the result! urgh.
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (args ...)))])
(values obj->/proc
(syntax (-> any/c args ...))
@ -1294,39 +1298,47 @@ add struct contracts for immutable structs?
[(->r ([x dom] ...) rng)
(andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))])
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)])
(values
obj->r/proc
(syntax (->r ([_this any/c] [x dom] ...) rng))
(syntax ((_this arg-vars ...)))))]
(syntax (->r ([this any/c] [x dom] ...) rng))
(syntax ((this-var arg-vars ...)))))]
[(->r ([x dom] ...) rest-x rest-dom rng)
(andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))])
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)])
(values
obj->r/proc
(syntax (->r ([_this any/c] [x dom] ...) rest-x rest-dom rng))
(syntax ((_this arg-vars ... . rest-var)))))]
(syntax (->r ([this any/c] [x dom] ...) rest-x rest-dom rng))
(syntax ((this-var arg-vars ... . rest-var)))))]
[(->r . x)
(raise-syntax-error 'object-contract "malformed ->r declaration")]
[(->pp ([x dom] ...) . other-stuff)
(andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))])
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)])
(values
obj->pp/proc
(syntax (->pp ([_this any/c] [x dom] ...) . other-stuff))
(syntax ((_this arg-vars ...)))))]
(syntax (->pp ([this any/c] [x dom] ...) . other-stuff))
(syntax ((this-var arg-vars ...)))))]
[(->pp . x)
(raise-syntax-error 'object-contract "malformed ->pp declaration")]
[(->pp-rest ([x dom] ...) rest-id . other-stuff)
(and (identifier? (syntax id))
(andmap identifier? (syntax->list (syntax (x ...)))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))])
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)])
(values
obj->pp-rest/proc
(syntax (->pp ([_this any/c] [x dom] ...) rest-id . other-stuff))
(syntax ((_this arg-vars ... . rest-id)))))]
(syntax (->pp ([this any/c] [x dom] ...) rest-id . other-stuff))
(syntax ((this-var arg-vars ... . rest-id)))))]
[(->pp-rest . x)
(raise-syntax-error 'object-contract "malformed ->pp-rest declaration")]
[else (raise-syntax-error 'object-contract "unknown method contract syntax" stx mtd-stx)]))

124
collects/tests/mzscheme/contract-test.ss
View File

@ -2355,6 +2355,48 @@
'pos
'neg)
m))
(test/neg-blame
'object-contract-->r/this-1
'(send (contract (object-contract (m (->r ([x (and/c integer? (lambda (x) (= x (get-field f this))))])
any)))
(new (class object% (field [f 1]) (define/public m (lambda (x) 1)) (super-new)))
'pos
'neg)
m
2))
(test/spec-passed
'object-contract-->r/this-2
'(send (contract (object-contract (m (->r ([x (and/c integer? (lambda (x) (= x (get-field f this))))])
any)))
(new (class object% (field [f 1]) (define/public m (lambda (x) 1)) (super-new)))
'pos
'neg)
m
1))
(test/neg-blame
'object-contract-->r/this-3
'(send (contract (object-contract (m (->r ([x (and/c integer? (lambda (x) (= x (get-field f this))))])
rest-var any/c
any)))
(new (class object% (field [f 1]) (define/public m (lambda (x . rest) 1)) (super-new)))
'pos
'neg)
m
2))
(test/spec-passed
'object-contract-->r/this-4
'(send (contract (object-contract (m (->r ([x (and/c integer? (lambda (x) (= x (get-field f this))))])
rest-var any/c
any)))
(new (class object% (field [f 1]) (define/public m (lambda (x . rest) 1)) (super-new)))
'pos
'neg)
m
1))
(test/spec-passed
'object-contract-->pp1
@ -2416,6 +2458,86 @@
'neg)
m))
(test/neg-blame
'object-contract-->pp/this-1
'(send (contract (object-contract (m (->pp ()
(= 1 (get-field f this))
any/c
result-x
(= 2 (get-field f this)))))
(new (class object% (field [f 2]) (define/public m (lambda () (set! f 3))) (super-new)))
'pos
'neg)
m))
(test/pos-blame
'object-contract-->pp/this-2
'(send (contract (object-contract (m (->pp ()
(= 1 (get-field f this))
any/c
result-x
(= 2 (get-field f this)))))
(new (class object% (field [f 1]) (define/public m (lambda () (set! f 3))) (super-new)))
'pos
'neg)
m))
(test/spec-passed
'object-contract-->pp/this-3
'(send (contract (object-contract (m (->pp ()
(= 1 (get-field f this))
any/c
result-x
(= 2 (get-field f this)))))
(new (class object% (field [f 1]) (define/public m (lambda () (set! f 2))) (super-new)))
'pos
'neg)
m))
(test/neg-blame
'object-contract-->pp/this-4
'(send (contract (object-contract (m (->pp-rest ()
rest-id
any/c
(= 1 (get-field f this))
any/c
result-x
(= 2 (get-field f this)))))
(new (class object% (field [f 2]) (define/public m (lambda args (set! f 3))) (super-new)))
'pos
'neg)
m))
(test/pos-blame
'object-contract-->pp/this-5
'(send (contract (object-contract (m (->pp-rest ()
rest-id
any/c
(= 1 (get-field f this))
any/c
result-x
(= 2 (get-field f this)))))
(new (class object% (field [f 1]) (define/public m (lambda args (set! f 3))) (super-new)))
'pos
'neg)
m))
(test/spec-passed
'object-contract-->pp/this-6
'(send (contract (object-contract (m (->pp-rest ()
rest-id
any/c
(= 1 (get-field f this))
any/c
result-x
(= 2 (get-field f this)))))
(new (class object% (field [f 1]) (define/public m (lambda args (set! f 2))) (super-new)))
'pos
'neg)
m))
(test/spec-passed/result
'object-contract-drop-method1
'(send (contract (object-contract (m (-> integer? integer?)))
@ -3135,7 +3257,7 @@
[(x y) y]))
(provide/contract (contract-inferred-name-test6 (opt-> (number?) (number?) number?)))))
(eval '(require contract-test-suite-inferred-name1))
(eval '(test 'contract-inferred-name-test object-name contract-inferred-name-test))
;; (eval '(test 'contract-inferred-name-test object-name contract-inferred-name-test)) ;; this one can't be made to pass, sadly.
(eval '(test 'contract-inferred-name-test2 object-name contract-inferred-name-test2))
(eval '(test 'contract-inferred-name-test3 object-name contract-inferred-name-test3))
(eval '(test 'contract-inferred-name-test4 object-name contract-inferred-name-test4))