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

possible fix to PR 9204

Browse Source 
svn: r7587
This commit is contained in:
Robby Findler 2007-10-29 02:28:30 +00:00
parent 697957e60a
commit 3724e47d0c
1 changed files with 46 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -14,8 +14,7 @@ improve method arity mismatch contract violation error messages?
(require-for-syntax mzscheme (require-for-syntax mzscheme
"contract-opt-guts.ss" "contract-opt-guts.ss"
(lib "list.ss") (lib "list.ss"))
(lib "etc.ss"))
(require "contract-arrow.ss" (require "contract-arrow.ss"
"contract-guts.ss" "contract-guts.ss"
@ -639,7 +638,10 @@ improve method arity mismatch contract violation error messages?
;; builds a begin expression for the entire contract and provide ;; builds a begin expression for the entire contract and provide
;; the first syntax object is used for source locations ;; the first syntax object is used for source locations
(define code-for-one-id/new-name (define code-for-one-id/new-name
(opt-lambda (stx id ctrct user-rename-id [mangle-for-maker? #f]) (case-lambda
[(stx id ctrct user-rename-id)
(code-for-one-id/new-name stx id ctrct user-rename-id #f)]
[(stx id ctrct user-rename-id mangle-for-maker?)
(let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct)]) (let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct)])
(with-syntax ([id-rename ((if mangle-for-maker? (with-syntax ([id-rename ((if mangle-for-maker?
a:mangle-id-for-maker a:mangle-id-for-maker
@ -663,24 +665,24 @@ improve method arity mismatch contract violation error messages?
(with-syntax ([code (with-syntax ([code
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
(provide (rename id-rename external-name))
(define pos-module-source (module-source-as-symbol #'pos-stx)) (define pos-module-source (module-source-as-symbol #'pos-stx))
#,@(if no-need-to-check-ctrct? #,@(if no-need-to-check-ctrct?
(list) (list)
(list #'(define contract-id (verify-contract ctrct)))) (list #'(define contract-id (verify-contract ctrct))))
(define-syntax id-rename (define-syntax id-rename
(make-provide/contract-transformer (quote-syntax contract-id) (make-provide/contract-transformer (quote-syntax contract-id)
(quote-syntax id) (quote-syntax id)
(quote-syntax pos-module-source)))))]) (quote-syntax pos-module-source)))
(provide (rename id-rename external-name))))])
(syntax-local-lift-module-end-declaration (syntax-local-lift-module-end-declaration
#'(begin #'(begin
(-contract contract-id id pos-module-source 'ignored #'id) (-contract contract-id id pos-module-source 'ignored #'id)
(void))) (void)))
(syntax (code id-rename))))))) (syntax (code id-rename)))))]))
(with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))]) (with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))])
(syntax (syntax