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

make contract-out signal more errors in terms of itself

Browse Source 
instead of provide/contract

closes PR 13752
This commit is contained in:
Robby Findler 2013-05-15 09:34:17 -05:00
parent c981c55768
commit a0c9dfd54e
3 changed files with 25 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/racket/contract/private/out.rkt
View File

@ -24,6 +24,6 @@
(syntax-case stx ()
[(_ . args)
(syntax-local-lift-module-end-declaration
#`(provide/contract . args))])
#`(provide/contract-for-contract-out . args))])
#`(combine-out))))

18
collects/racket/contract/private/provide.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(provide provide/contract
provide/contract-for-contract-out
(protect-out (for-syntax true-provide/contract
make-provide/contract-transformer
provide/contract-transformer?
@ -523,7 +524,7 @@
#f
(with-syntax ([field-contract-id field-contract-id]
[field-contract field-contract])
#'(define field-contract-id (verify-contract 'provide/contract field-contract)))))
#`(define field-contract-id (verify-contract '#,who field-contract)))))
field-contract-ids
field-contracts))]
[(field-contracts ...) field-contracts]
@ -753,9 +754,9 @@
#,@(if no-need-to-check-ctrct?
(list)
(list #'(define contract-id
(list #`(define contract-id
(let ([ex-id ctrct]) ;; let is here to give the right name.
(verify-contract 'provide/contract ex-id)))))
(verify-contract '#,who ex-id)))))
(define-syntax id-rename
(make-provide/contract-transformer (quote-syntax contract-id)
(a:update-loc
@ -833,22 +834,27 @@
(define pos-module-source (quote-module-name))
bodies ...)))]))]))
(define-syntax (provide/contract stx)
(define-for-syntax (provide/contract-for-whom stx who)
(define s-l-c (syntax-local-context))
(case s-l-c
[(module-begin)
#`(begin ;; force us into the 'module' local context
#,stx)]
[(module) ;; the good case
(true-provide/contract stx #f 'provide/contract)]
(true-provide/contract stx #f who)]
[else ;; expression or internal definition
(raise-syntax-error 'provide/contract
(raise-syntax-error who
(format "not allowed in a ~a context"
(if (pair? s-l-c)
"internal definition"
s-l-c))
stx)]))
(define-syntax (provide/contract stx)
(provide/contract-for-whom stx 'provide/contract))
(define-syntax (provide/contract-for-contract-out stx)
(provide/contract-for-whom stx 'contract-out))
(define (make-pc-struct-type struct-name srcloc struct:struct-name . ctcs)
(chaperone-struct-type
struct:struct-name

12
collects/tests/racket/contract-test.rktl
View File

@ -14924,6 +14924,18 @@ so that propagation occurs.
(λ (x)
(and (exn:fail:contract:blame? x)
(regexp-match #rx"^g.*contract from: pce10-bug" (exn-message x)))))
(contract-error-test
'contract-error-test18
#'(begin
(eval '(module pce18-bug racket
(struct point (x y))
(provide (contract-out
(struct point ([x integer?])))))))
(λ (x)
(and (exn:fail:syntax? x)
;; testing that the error says "contract-out" and not "provide/contract"
(regexp-match #rx"contract-out: found 2 fields" (exn-message x)))))
(contract-eval
`(,test