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

added a little optimization to provide/contract

Browse Source 
svn: r14646
This commit is contained in:
Robby Findler 2009-04-29 03:48:45 +00:00
parent 6cdf2ed976
commit 87c9aba9e0
2 changed files with 21 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/scheme/private/contract.ss
View File

@ -1217,6 +1217,12 @@ improve method arity mismatch contract violation error messages?
[ctrct (syntax-property ctrct 'inferred-name id)]
[external-name (or user-rename-id id)]
[where-stx stx])
(with-syntax ([extra-test
(syntax-case #'ctrct (->)
[(-> dom ... arg)
#`(and (procedure? id)
(procedure-arity-includes? id #,(length (syntax->list #'(dom ...)))))]
[_ #f])])
(with-syntax ([code
(quasisyntax/loc stx
(begin
@ -1234,10 +1240,11 @@ improve method arity mismatch contract violation error messages?
(syntax-local-lift-module-end-declaration
#`(begin
(-contract contract-id id pos-module-source 'ignored #,(id->contract-src-info #'id))
(unless extra-test
(-contract contract-id id pos-module-source 'ignored #,(id->contract-src-info #'id)))
(void)))
(syntax (code id-rename)))))]))
(syntax (code id-rename))))))]))
(with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))])
(signal-dup-syntax-error)

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

@ -6560,6 +6560,18 @@ so that propagation occurs.
(and (exn? x)
(regexp-match #rx"cannot set!" (exn-message x)))))
(contract-error-test
#'(begin
(eval '(module pce8-bug1 scheme/base
(require scheme/contract)
(define (f x) x)
(provide/contract [f (-> integer? integer? integer?)])))
(eval '(require 'pce8-bug1)))
(λ (x)
(printf ">> ~s\n" (exn-message x))
(and (exn? x)
(regexp-match #rx"pce8-bug" (exn-message x)))))
(contract-eval `(,test 'pos guilty-party (with-handlers ((void values)) (contract not #t 'pos 'neg))))
(report-errs)