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

..

Browse Source 
original commit: 506ac9967e119993bae271d05f7cb36c770b5e38
This commit is contained in:
Robby Findler 2003-11-01 22:23:00 +00:00
parent e0da116481
commit e3aa7128fb
2 changed files with 44 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
collects/mzlib/contract.ss
View File

@ -1004,7 +1004,6 @@ improve method arity mismatch contract violation error messages?
(raise-syntax-error 'object-contract "malformed ->d* method contract" stx mtd-stx)]
[else (raise-syntax-error 'object-contract "unknown method contract syntax" stx mtd-stx)]))
;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc]
(define (build-methods-stx arg-spec-stxss)
(let loop ([arg-spec-stxss arg-spec-stxss]
@ -1093,7 +1092,6 @@ improve method arity mismatch contract violation error messages?
(list methods ...)
'(field-name ...)
)]
[method-names-list '(method-name ...)]
[field-names-list '(field-name ...)])
(lambda (val)
(unless (object? val)
@ -1107,15 +1105,7 @@ improve method arity mismatch contract violation error messages?
(interface->method-names
(object-interface
val))])
(for-each (lambda (val-mtd-name)
(unless (memq val-mtd-name method-names-list)
(raise-contract-error src-info
pos-blame
neg-blame
orig-str
"object has an extra method ~s"
val-mtd-name)))
val-mtd-names)
(void)
(unless (memq 'method-name val-mtd-names)
(raise-contract-error src-info
pos-blame
@ -1125,15 +1115,6 @@ improve method arity mismatch contract violation error messages?
'method-name))
...)
(for-each (lambda (val-field-name)
(unless (memq val-field-name field-names-list)
(raise-contract-error src-info
pos-blame
neg-blame
orig-str
"object has an extra field ~s"
val-field-name)))
(field-names val))
(unless (field-bound? field-name val)
(raise-contract-error src-info
pos-blame

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

@ -1439,19 +1439,50 @@
'neg)
m 1 #t 'x 'y))
(test/pos-blame
'object-contract-drop-method
'(contract (object-contract (m (-> integer? integer?)))
(new (class object% (define/public (m x) x) (define/public (n x) x) (super-new)))
'pos
'neg))
(test/spec-passed/result
'object-contract-drop-method1
'(send (contract (object-contract (m (-> integer? integer?)))
(new (class object% (define/public (m x) x) (define/public (n x) x) (super-new)))
'pos
'neg)
n 1)
1)
(test/pos-blame
'object-contract-drop-field
'(contract (object-contract (field f integer?))
(new (class object% (field [f 1] [g 2]) (super-new)))
'pos
'neg))
(test/spec-passed/result
'object-contract-drop-method2
'(let ([o (contract (object-contract (m (-> integer? integer?)))
(new (class object% (define/public (m x) x) (define/public (n x) x) (super-new)))
'pos
'neg)])
(with-method ([m (o m)]
[n (o n)])
(list (m 1) (n 2))))
'(1 2))
(test/spec-passed/result
'object-contract-drop-field1
'(get-field g (contract (object-contract (field f integer?))
(new (class object% (field [f 1] [g 2]) (super-new)))
'pos
'neg))
2)
(test/spec-passed/result
'object-contract-drop-field2
'(field-bound? g (contract (object-contract (field f integer?))
(new (class object% (field [f 1] [g 2]) (super-new)))
'pos
'neg))
#t)
(test/spec-passed/result
'object-contract-drop-field3
'(field-names
(contract (object-contract)
(new (class object% (field [g 2]) (super-new)))
'pos
'neg))
'(g))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;