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

Using splicing-syntax-parameterize and a syntax-introducer instead of

Browse Source 
what I had originally.

svn: r13089
This commit is contained in:
Stevie Strickland 2009-01-13 19:36:54 +00:00
parent 51da9beab4
commit 909dd82f7c
1 changed files with 36 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -24,6 +24,7 @@ improve method arity mismatch contract violation error messages?
(for-syntax syntax/kerncase) (for-syntax syntax/kerncase)
scheme/promise scheme/promise
scheme/stxparam scheme/stxparam
scheme/splicing
mzlib/etc) mzlib/etc)
(require "contract-arrow.ss" (require "contract-arrow.ss"
@ -168,10 +169,16 @@ improve method arity mismatch contract violation error messages?
#'ident))]))))) #'ident))])))))
(define-for-syntax (head-expand-all body-stxs) (define-for-syntax (head-expand-all body-stxs)
(for/list ([stx body-stxs]) (apply append
(local-expand stx (for/list ([stx body-stxs])
(syntax-local-context) (let ([exp-form (local-expand stx
(kernel-form-identifier-list)))) (syntax-local-context)
(kernel-form-identifier-list))])
(syntax-case exp-form (begin)
[(begin form ...)
(head-expand-all (syntax->list #'(form ...)))]
[_
(list exp-form)])))))
(define-for-syntax (check-exports ids body-stxs) (define-for-syntax (check-exports ids body-stxs)
(let ([defd-ids (for/fold ([id-list null]) (let ([defd-ids (for/fold ([id-list null])
@ -227,22 +234,22 @@ improve method arity mismatch contract violation error messages?
[(_ #:type type blame (arg ...) body0 body ...) [(_ #:type type blame (arg ...) body0 body ...)
(and (identifier? #'blame) (and (identifier? #'blame)
(identifier? #'type)) (identifier? #'type))
(let*-values ([(unprotected protected protections) (let*-values ([(marker) (make-syntax-introducer)]
[(unprotected protected protections)
(check-and-split-with-contract-args (syntax->list #'(arg ...)))] (check-and-split-with-contract-args (syntax->list #'(arg ...)))]
[(expanded-bodies) (head-expand-all (cons #'body0 [(expanded-bodies)
(syntax->list #'(body ...))))] (head-expand-all (cons #'body0 (syntax->list #'(body ...))))]
[(protected-ids ids contracts contract-defs) [(protected-ids contracts contract-defs)
(for/lists (protected-ids ids contracts contract-defs) (for/lists (protected-ids contracts contract-defs)
([n protected] ([n protected]
[c protections]) [c protections])
(let ([new-id (a:mangle-id stx "with-contract-id" n)]) (if (a:known-good-contract? c)
(if (a:known-good-contract? c) (values n c #f)
(values n new-id c #f) (let ([contract-id (a:mangle-id stx "with-contract-contract-id" n)])
(let ([contract-id (a:mangle-id stx "with-contract-contract-id" n)]) (values n contract-id
(values n new-id contract-id (quasisyntax/loc stx
(quasisyntax/loc stx (define-values (#,contract-id)
(define-values (#,contract-id) (verify-contract 'with-contract #,c)))))))])
(verify-contract 'with-contract #,c))))))))])
(begin (begin
(let* ([all-ids (append unprotected protected)] (let* ([all-ids (append unprotected protected)]
[dupd-id (check-duplicate-identifier all-ids)]) [dupd-id (check-duplicate-identifier all-ids)])
@ -251,24 +258,22 @@ improve method arity mismatch contract violation error messages?
"identifier appears twice in exports" "identifier appears twice in exports"
dupd-id)) dupd-id))
(check-exports (append unprotected protected) expanded-bodies)) (check-exports (append unprotected protected) expanded-bodies))
(with-syntax ([((protected-id id contract) ...) (with-syntax ([(contract-def ...) (map marker (filter values contract-defs))]
(map list protected-ids ids contracts)]
[(contract-def ...) (filter values contract-defs)]
[blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))] [blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))]
[(marked-body ...) (map marker expanded-bodies)]
[(unprotected-id ...) unprotected]) [(unprotected-id ...) unprotected])
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (splicing-syntax-parameterize ([current-contract-region blame-str])
(define-values (unprotected-id ... id ...) marked-body ...
(syntax-parameterize ([current-contract-region blame-str])
(begin-with-definitions
#,@expanded-bodies
(values unprotected-id ... protected-id ...))))
contract-def ... contract-def ...
(define-syntax protected-id #,@(map (λ (p c)
(make-with-contract-transformer #`(define-syntax #,p
(quote-syntax contract) (make-with-contract-transformer
(quote-syntax id) (quote-syntax #,(if c (marker c) c))
blame-str)) ...)))))] (quote-syntax #,(marker p))
blame-str)))
protected-ids contracts)
)))))]
[(_ #:type type blame (arg ...) body0 body ...) [(_ #:type type blame (arg ...) body0 body ...)
(raise-syntax-error 'with-contract (raise-syntax-error 'with-contract
"expected identifier for blame" "expected identifier for blame"