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

This doesn't quite work (neither does syntax-parameterize), but at least

Browse Source 
it gives us an idea of where we're going and I can bug Ryan tomorrow :D

svn: r11637
This commit is contained in:
Stevie Strickland 2008-09-11 02:09:28 +00:00
parent a7d5a2aaef
commit 55f89f2da8
1 changed files with 81 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -12,7 +12,8 @@ improve method arity mismatch contract violation error messages?
(provide (rename-out [-contract contract])
recursive-contract
provide/contract
define/contract)
define/contract
with-contract)
(require (for-syntax scheme/base)
(for-syntax "contract-opt-guts.ss")
@ -117,6 +118,85 @@ improve method arity mismatch contract violation error messages?
(syntax name))]))
;
;
; ; ;
; ; ; ; ;
; ; ; ; ;
; ; ; ; ; ;;;; ; ;;; ;;; ;;; ; ;;; ;;;; ; ;; ;;;; ;;; ;;;;
; ; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ;
; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;
; ; ; ; ;;; ; ; ;;; ;;; ; ; ;;; ; ;;;; ; ;;; ;;;
;
;
;
(define-for-syntax current-contract-region (make-parameter #f))
(define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id)
(make-set!-transformer
(lambda (stx)
(with-syntax ([neg-blame-id #`(if #,(current-contract-region)
#,(current-contract-region)
(module-source-as-symbol #'#,id))]
[pos-blame-id #`(quote #,(syntax-e pos-blame-id))]
[contract-id contract-id]
[id id])
(syntax-case stx (set!)
[(set! id arg)
(raise-syntax-error 'with-contract
"cannot set! a with-contract variable"
stx
(syntax id))]
[(f arg ...)
(syntax/loc stx
((-contract contract-id
id
pos-blame-id
neg-blame-id
(quote-syntax f))
arg ...))]
[ident
(identifier? (syntax ident))
(syntax/loc stx
(-contract contract-id
id
pos-blame-id
neg-blame-id
(quote-syntax ident)))])))))
(define-syntax (with-contract stx)
(let ([introducer (make-syntax-introducer)])
(syntax-case stx ()
[(_ blame ([name contract-expr] ...) body0 body ...)
(and (identifier? (syntax blame))
(andmap identifier? (syntax->list (syntax (name ...)))))
(parameterize ([current-contract-region (syntax-e (syntax blame))])
(with-syntax ([(id ...)
(map introducer (syntax->list (syntax (name ...))))]
[(contract-id ...)
(map (lambda (n)
(a:mangle-id stx "with-contract-contract-id" n))
(syntax->list (syntax (name ...))))]
[(new-body ...)
(map introducer
(syntax->list (syntax (body0 body ...))))])
(syntax/loc stx
(begin
(define contract-id contract-expr) ...
(define-syntax name
(make-with-contract-transformer
(quote-syntax contract-id)
(quote-syntax id)
(quote-syntax blame))) ...
new-body ...))))])))
;
;
;