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

racket/unit: fix problem with contracts

Browse Source 
Part of the expansion to handle contracts confused internal and
external names of signature elements. The new macro expander is less
tolerant of the mistake.
This commit is contained in:
Matthew Flatt 2015-07-21 10:19:40 -06:00
parent 76a0eef121
commit 444518b344
4 changed files with 25 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
pkgs/racket-test/tests/units/test-unit-contracts.rkt
View File

@ -705,6 +705,24 @@
(test-contract-error "m4" "f" "not an x"
(m4:f 3))
(module m4:f racket
(define-signature foo^ (x? (contracted [f (-> x? boolean?)])))
(define-unit U@
(import)
(export foo^)
(define (x? x) #f)
(define (f x) (x? x)))
(define-values/invoke-unit U@ (import) (export [prefix f: foo^]))
(provide f:f f:x?))
(require (prefix-in m4: 'm4:f))
(test-contract-error "m4:f" "f:f" "not an f:x"
(m4:f:f 3))
(require (prefix-in m3: 'm3))
(test-contract-error top-level "build-toys" "not a integer"

2
racket/collects/racket/private/unit-contract.rkt
View File

@ -54,7 +54,7 @@
#`(vector-ref #,v #,index)))))
(with-syntax ((((eloc ...) ...)
(for/list ([target-sig import-sigs])
(let ([rename-bindings (get-member-bindings def-table target-sig #`(blame-positive #,blame-id))])
(let ([rename-bindings (get-member-bindings def-table target-sig #`(blame-positive #,blame-id) #f)])
(for/list ([target-int/ext-name (in-list (car target-sig))]
[sig-ctc (in-list (cadddr target-sig))])
(let* ([var (car target-int/ext-name)]

5
racket/collects/racket/private/unit-utils.rkt
View File

@ -28,8 +28,9 @@
(define-syntax-rule (equal-hash-table [k v] ...)
(make-immutable-hash (list (cons k v) ...)))
(define-for-syntax (get-member-bindings member-table sig pos)
(define-for-syntax (get-member-bindings member-table sig pos bind?)
(for/list ([i (in-list (map car (car sig)))]
[ix (in-list (map cdr (car sig)))]
[c (in-list (cadddr sig))])
(let ([add-ctc
(λ (v stx)
@ -39,7 +40,7 @@
(contract c-stx (car v/c) (cdr v/c) #,pos
(quote #,v) (quote-syntax #,v))))
#`(#,stx)))])
#`[#,i
#`[#,(if bind? ix i)
(make-set!-transformer
(λ (stx)
(syntax-case stx (set!)

5
racket/collects/racket/unit.rkt
View File

@ -1252,7 +1252,8 @@
[ctc (bound-identifier-mapping-get ctc-table var)]
[rename-bindings (get-member-bindings def-table
(bound-identifier-mapping-get sig-table var)
#'(current-contract-region))])
#'(current-contract-region)
#t)])
(with-syntax ([ctc-stx (if ctc (syntax-property
#`(letrec-syntax #,rename-bindings #,ctc)
'inferred-name var)
@ -1732,7 +1733,7 @@
(((wrap-code ...) ...)
(map (λ (os ov tbs)
(define rename-bindings
(get-member-bindings def-table os #'(quote-module-name)))
(get-member-bindings def-table os #'(quote-module-name) #t))
(map (λ (tb i v c)
(if c
(with-syntax ([ctc-stx