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

90
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,48 +638,51 @@ 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
(let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct)]) [(stx id ctrct user-rename-id)
(with-syntax ([id-rename ((if mangle-for-maker? (code-for-one-id/new-name stx id ctrct user-rename-id #f)]
a:mangle-id-for-maker [(stx id ctrct user-rename-id mangle-for-maker?)
a:mangle-id) (let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct)])
provide-stx (with-syntax ([id-rename ((if mangle-for-maker?
"provide/contract-id" a:mangle-id-for-maker
(or user-rename-id id))] a:mangle-id)
[contract-id (if no-need-to-check-ctrct? provide-stx
ctrct "provide/contract-id"
(a:mangle-id provide-stx (or user-rename-id id))]
"provide/contract-contract-id" [contract-id (if no-need-to-check-ctrct?
(or user-rename-id id)))] ctrct
[pos-module-source (a:mangle-id provide-stx (a:mangle-id provide-stx
"provide/contract-pos-module-source" "provide/contract-contract-id"
(or user-rename-id id))] (or user-rename-id id)))]
[pos-stx (datum->syntax-object id 'here)] [pos-module-source (a:mangle-id provide-stx
[id id] "provide/contract-pos-module-source"
[ctrct (syntax-property ctrct 'inferred-name id)] (or user-rename-id id))]
[external-name (or user-rename-id id)] [pos-stx (datum->syntax-object id 'here)]
[where-stx stx]) [id id]
(with-syntax ([code [ctrct (syntax-property ctrct 'inferred-name id)]
(quasisyntax/loc stx [external-name (or user-rename-id id)]
(begin [where-stx stx])
(provide (rename id-rename external-name)) (with-syntax ([code
(quasisyntax/loc stx
(define pos-module-source (module-source-as-symbol #'pos-stx)) (begin
#,@(if no-need-to-check-ctrct? (define pos-module-source (module-source-as-symbol #'pos-stx))
(list)
(list #'(define contract-id (verify-contract ctrct)))) #,@(if no-need-to-check-ctrct?
(list)
(define-syntax id-rename (list #'(define contract-id (verify-contract ctrct))))
(make-provide/contract-transformer (quote-syntax contract-id) (define-syntax id-rename
(quote-syntax id) (make-provide/contract-transformer (quote-syntax contract-id)
(quote-syntax pos-module-source)))))]) (quote-syntax id)
(quote-syntax pos-module-source)))
(syntax-local-lift-module-end-declaration
#'(begin (provide (rename id-rename external-name))))])
(-contract contract-id id pos-module-source 'ignored #'id)
(void))) (syntax-local-lift-module-end-declaration
#'(begin
(syntax (code id-rename))))))) (-contract contract-id id pos-module-source 'ignored #'id)
(void)))
(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