Abstraction of the boxes used for unit imports/exports to allow for adding
contracts in an already created unit. svn: r13331
This commit is contained in:
Stevie Strickland
parent
ab5a01da76
commit
f6493e1c32
|
|
@ -472,12 +472,12 @@
|
|||
(define-for-syntax (make-import-unboxing var loc ctc)
|
||||
(if ctc
|
||||
(quasisyntax/loc (error-syntax)
|
||||
(quote-syntax (let ([v/c (unbox #,loc)])
|
||||
(quote-syntax (let ([v/c ((car #,loc))])
|
||||
(contract #,ctc (car v/c) (cdr v/c)
|
||||
(current-contract-region)
|
||||
#,(id->contract-src-info var)))))
|
||||
(quasisyntax/loc (error-syntax)
|
||||
(quote-syntax (unbox #,loc)))))
|
||||
(quote-syntax ((car #,loc))))))
|
||||
|
||||
;; build-unit : syntax-object ->
|
||||
;; (values syntax-object (listof identifier) (listof identifier))
|
||||
|
|
@ -557,7 +557,10 @@
|
|||
(list (cons 'dept depr) ...)
|
||||
(syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))])
|
||||
(lambda ()
|
||||
(let ([eloc (box undefined)] ... ...)
|
||||
(let ([eloc (let ([loc (box undefined)])
|
||||
(cons
|
||||
(λ () (unbox loc))
|
||||
(λ (v) (set-box! loc v))))] ... ...)
|
||||
(values
|
||||
(lambda (import-table)
|
||||
(let-values ([(iloc ...)
|
||||
|
|
@ -731,12 +734,12 @@
|
|||
(current-contract-region)
|
||||
'cant-happen
|
||||
#,(id->contract-src-info id))
|
||||
(set-box! #,export-loc
|
||||
(let ([#,id #,tmp])
|
||||
(cons #,id (current-contract-region))))))
|
||||
((cdr #,export-loc)
|
||||
(let ([#,id #,tmp])
|
||||
(cons #,id (current-contract-region))))))
|
||||
(quasisyntax/loc defn-or-expr
|
||||
(set-box! #,export-loc
|
||||
(let ([#,id #,tmp]) #,id))))
|
||||
((cdr #,export-loc)
|
||||
(let ([#,id #,tmp]) #,id))))
|
||||
(quasisyntax/loc defn-or-expr
|
||||
(define-syntax #,id
|
||||
(make-id-mapper (quote-syntax #,tmp)))))))]
|
||||
|
|
@ -776,12 +779,6 @@
|
|||
(lambda (target-sig)
|
||||
(map
|
||||
(lambda (target-int/ext-name target-ctc)
|
||||
(when target-ctc
|
||||
(raise-stx-err
|
||||
(format (if import?
|
||||
"identifier ~a is contracted in old imports"
|
||||
"identifier ~a is contracted in new exports")
|
||||
(syntax-e (car target-int/ext-name)))))
|
||||
(let ([vref/ctc
|
||||
(bound-identifier-mapping-get
|
||||
def-table
|
||||
|
|
@ -792,13 +789,26 @@
|
|||
"identifier ~a is not present in new imports"
|
||||
"identifier ~a is not present in old exports")
|
||||
(syntax-e (car target-int/ext-name))))))])
|
||||
(when (cdr vref/ctc)
|
||||
(raise-stx-err
|
||||
(format (if import?
|
||||
"identifier ~a is contracted in new imports"
|
||||
"identifier ~a is contracted in old exports")
|
||||
(syntax-e (car target-int/ext-name)))))
|
||||
(car vref/ctc)))
|
||||
(let ([old-cl (car vref/ctc)])
|
||||
#`(cons
|
||||
(λ ()
|
||||
(let ([old-v #,(if (cdr vref/ctc)
|
||||
#`(let ([old-v/c ((car #,old-cl))])
|
||||
(contract #,(cdr vref/ctc) (car old-v/c)
|
||||
(cdr old-v/c) (current-contract-region)
|
||||
#,(id->contract-src-info (car target-int/ext-name))))
|
||||
#`((car #,old-cl)))])
|
||||
#,(if target-ctc
|
||||
#'(cons old-v (current-contract-region))
|
||||
#'old-v)))
|
||||
(λ (v) (let ([new-v #,(if (cdr vref/ctc)
|
||||
#`(contract #,(cdr vref/ctc) (car v)
|
||||
(current-contract-region) (cdr v)
|
||||
#,(id->contract-src-info (car target-int/ext-name)))
|
||||
#'v)])
|
||||
#,(if target-ctc
|
||||
#`((cdr #,old-cl) (cons new-v (current-contract-region)))
|
||||
#`((cdr #,old-cl) new-v))))))))
|
||||
(car target-sig)
|
||||
(cadddr target-sig)))
|
||||
target-import-sigs))
|
||||
|
|
@ -902,19 +912,20 @@
|
|||
(vector-immutable (cons 'export-name
|
||||
(vector-immutable export-key ...)) ...)
|
||||
(list (cons 'dept depr) ...)
|
||||
(lambda ()
|
||||
(let-values ([(unit-fn export-table) ((unit-go unit-tmp))])
|
||||
(values (lambda (import-table)
|
||||
(unit-fn #,(redirect-imports #'import-table
|
||||
import-tagged-infos
|
||||
import-sigs
|
||||
orig-import-tagged-infos
|
||||
orig-import-sigs)))
|
||||
#,(redirect-exports #'export-table
|
||||
orig-export-tagged-infos
|
||||
orig-export-sigs
|
||||
export-tagged-infos
|
||||
export-sigs)))))))
|
||||
(syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))])
|
||||
(lambda ()
|
||||
(let-values ([(unit-fn export-table) ((unit-go unit-tmp))])
|
||||
(values (lambda (import-table)
|
||||
(unit-fn #,(redirect-imports #'import-table
|
||||
import-tagged-infos
|
||||
import-sigs
|
||||
orig-import-tagged-infos
|
||||
orig-import-sigs)))
|
||||
#,(redirect-exports #'export-table
|
||||
orig-export-tagged-infos
|
||||
orig-export-sigs
|
||||
export-tagged-infos
|
||||
export-sigs))))))))
|
||||
import-tagged-sigids
|
||||
export-tagged-sigids
|
||||
dep-tagged-sigids)))))))
|
||||
|
|
@ -1238,11 +1249,11 @@
|
|||
(map
|
||||
(lambda (i v c)
|
||||
(if c
|
||||
#`(let ([v/c (unbox (vector-ref #,ov #,i))])
|
||||
#`(let ([v/c ((car (vector-ref #,ov #,i)))])
|
||||
(contract #,c (car v/c) (cdr v/c)
|
||||
(current-contract-region)
|
||||
#,(id->contract-src-info v)))
|
||||
#`(unbox (vector-ref #,ov #,i))))
|
||||
#`((car (vector-ref #,ov #,i)))))
|
||||
(iota (length (car os)))
|
||||
(map car (car os))
|
||||
(cadddr os)))
|
||||
|
|
|
|||
|
|
@ -196,46 +196,338 @@
|
|||
(test-runtime-error exn:fail:contract? "top-level misuses f"
|
||||
(f #t)))
|
||||
|
||||
;; eventually we can hopefully fix this so these are allowed, but for right
|
||||
;; now, test that they fail during unit/new-import-export
|
||||
;; unit/new-import-export tests
|
||||
|
||||
(define-signature sig7 (x))
|
||||
(define-signature sig8 ((contracted [x number?])))
|
||||
(define-signature sig7 (f))
|
||||
(define-signature sig8 ((contracted [f (-> number? number?)])))
|
||||
(define-signature sig9 ((contracted [f (-> number? number?)])))
|
||||
|
||||
;; All units that play nicely
|
||||
(define-unit unit12
|
||||
(import sig7)
|
||||
(export)
|
||||
x)
|
||||
(f 3))
|
||||
(define-unit unit13
|
||||
(import sig8)
|
||||
(export)
|
||||
x)
|
||||
(f 3))
|
||||
(define-unit unit14
|
||||
(import)
|
||||
(export sig8)
|
||||
(define x 3))
|
||||
(export sig7)
|
||||
(define f (λ (n) 3)))
|
||||
(define-unit unit15
|
||||
(import)
|
||||
(export sig7)
|
||||
(define x 3))
|
||||
(export sig8)
|
||||
(define f (λ (n) 3)))
|
||||
|
||||
(test-syntax-error "not contracted in old import -> contracted in new"
|
||||
(unit/new-import-export
|
||||
(import sig8)
|
||||
(export)
|
||||
(() unit12 sig7)))
|
||||
(test-syntax-error "contracted in old import -> not contracted in new"
|
||||
(unit/new-import-export
|
||||
(import sig7)
|
||||
(export)
|
||||
(() unit13 sig8)))
|
||||
(test-syntax-error "not contracted in old export -> contracted in new"
|
||||
(unit/new-import-export
|
||||
(import)
|
||||
(export sig8)
|
||||
((sig7) unit14)))
|
||||
(test-syntax-error "contracted in old export -> not contracted in new"
|
||||
(unit/new-import-export
|
||||
(import)
|
||||
(export sig7)
|
||||
((sig8) unit15)))
|
||||
;; All units that don't play nicely (or won't after converted)
|
||||
(define-unit unit16
|
||||
(import sig7)
|
||||
(export)
|
||||
(f #t))
|
||||
(define-unit unit17
|
||||
(import sig8)
|
||||
(export)
|
||||
(f #t))
|
||||
(define-unit unit18
|
||||
(import)
|
||||
(export sig7)
|
||||
(define f (λ (n) #t)))
|
||||
(define-unit unit19
|
||||
(import)
|
||||
(export sig8)
|
||||
(define f (λ (n) #t)))
|
||||
|
||||
;; Converting units without internal contract violations
|
||||
|
||||
;; uncontracted import -> contracted import
|
||||
(define-unit/new-import-export unit20
|
||||
(import sig8)
|
||||
(export)
|
||||
(() unit12 sig7))
|
||||
(let ()
|
||||
(define-compound-unit unit21
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig8)) unit15]
|
||||
[() unit20 S]))
|
||||
(invoke-unit unit21))
|
||||
(let ()
|
||||
(define-compound-unit unit22
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig8)) unit19]
|
||||
[() unit20 S]))
|
||||
(test-runtime-error exn:fail:contract? "unit19 provides bad f"
|
||||
(invoke-unit unit22)))
|
||||
|
||||
;; contracted import -> uncontracted import
|
||||
(define-unit/new-import-export unit23
|
||||
(import sig7)
|
||||
(export)
|
||||
(() unit13 sig8))
|
||||
(let ()
|
||||
(define-compound-unit unit24
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig7)) unit14]
|
||||
[() unit23 S]))
|
||||
(invoke-unit unit24))
|
||||
(let ()
|
||||
(define-compound-unit unit25
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig7)) unit18]
|
||||
[() unit23 S]))
|
||||
(test-runtime-error exn:fail:contract? "unit23 provides f with no protection into a bad context"
|
||||
(invoke-unit unit25)))
|
||||
|
||||
;; contracted import -> contracted import
|
||||
(define-unit/new-import-export unit26
|
||||
(import sig9)
|
||||
(export)
|
||||
(() unit13 sig8))
|
||||
(let ()
|
||||
(define-unit unit27-1
|
||||
(import)
|
||||
(export sig9)
|
||||
(define (f n) 3))
|
||||
(define-compound-unit unit27-2
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig9)) unit27-1]
|
||||
[() unit26 S]))
|
||||
(invoke-unit unit27-2))
|
||||
(let ()
|
||||
(define-unit unit28-1
|
||||
(import)
|
||||
(export sig9)
|
||||
(define (f n) #f))
|
||||
(define-compound-unit unit28-2
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig9)) unit28-1]
|
||||
[() unit26 S]))
|
||||
(test-runtime-error exn:fail:contract? "unit28-1 broke contract on f"
|
||||
(invoke-unit unit28-2)))
|
||||
|
||||
;; uncontracted export -> contracted export
|
||||
(define-unit/new-import-export unit29
|
||||
(import)
|
||||
(export sig8)
|
||||
((sig7) unit14))
|
||||
(let ()
|
||||
(define-compound-unit unit30
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig8)) unit29]
|
||||
[() unit13 S]))
|
||||
(invoke-unit unit30))
|
||||
(let ()
|
||||
(define-compound-unit unit31
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig8)) unit29]
|
||||
[() unit17 S]))
|
||||
(test-runtime-error exn:fail:contract? "unit17 misuses f"
|
||||
(invoke-unit unit31)))
|
||||
|
||||
;; contracted export -> uncontracted export
|
||||
(define-unit/new-import-export unit32
|
||||
(import)
|
||||
(export sig7)
|
||||
((sig8) unit15))
|
||||
(let ()
|
||||
(define-compound-unit unit33
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig7)) unit32]
|
||||
[() unit14 S]))
|
||||
(invoke-unit unit33))
|
||||
(let ()
|
||||
(define-compound-unit unit34
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig7)) unit32]
|
||||
[() unit16 S]))
|
||||
(test-runtime-error exn:fail:contract? "unit32 provides f with no protection into bad context"
|
||||
(invoke-unit unit34)))
|
||||
|
||||
;; contracted export -> contracted export
|
||||
(define-unit/new-import-export unit35
|
||||
(import)
|
||||
(export sig9)
|
||||
((sig8) unit15))
|
||||
(let ()
|
||||
(define-unit unit36-1
|
||||
(import sig9)
|
||||
(export)
|
||||
(f 3))
|
||||
(define-compound-unit unit36-2
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig9)) unit35]
|
||||
[() unit36-1 S]))
|
||||
(invoke-unit unit36-2))
|
||||
(let ()
|
||||
(define-unit unit37-1
|
||||
(import sig9)
|
||||
(export)
|
||||
(f #f))
|
||||
(define-compound-unit unit37-2
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig9)) unit35]
|
||||
[() unit37-1 S]))
|
||||
(test-runtime-error exn:fail:contract? "unit37-1 broke contract on f"
|
||||
(invoke-unit unit37-2)))
|
||||
|
||||
;; Converting units with internal contract violations
|
||||
|
||||
;; uncontracted import -> contracted import
|
||||
(define-unit/new-import-export unit38
|
||||
(import sig8)
|
||||
(export)
|
||||
(() unit16 sig7))
|
||||
(let ()
|
||||
(define-compound-unit unit39
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig8)) unit15]
|
||||
[() unit38 S]))
|
||||
(test-runtime-error exn:fail:contract? "unit38 allowed f to flow into uncontracted bad context"
|
||||
(invoke-unit unit39)))
|
||||
(let ()
|
||||
(define-compound-unit unit40
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig8)) unit19]
|
||||
[() unit38 S]))
|
||||
(test-runtime-error exn:fail:contract? "unit38 allowed f to flow into uncontracted bad context"
|
||||
(invoke-unit unit40)))
|
||||
|
||||
;; contracted import -> uncontracted import
|
||||
(define-unit/new-import-export unit41
|
||||
(import sig7)
|
||||
(export)
|
||||
(() unit17 sig8))
|
||||
(let ()
|
||||
(define-compound-unit unit42
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig7)) unit14]
|
||||
[() unit41 S]))
|
||||
(test-runtime-error exn:fail:contract? "unit17 misuses f"
|
||||
(invoke-unit unit42)))
|
||||
(let ()
|
||||
(define-compound-unit unit43
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig7)) unit18]
|
||||
[() unit41 S]))
|
||||
(test-runtime-error exn:fail:contract? "unit17 misuses f"
|
||||
(invoke-unit unit43)))
|
||||
|
||||
;; contracted import -> contracted import
|
||||
(define-unit/new-import-export unit44
|
||||
(import sig9)
|
||||
(export)
|
||||
(() unit17 sig8))
|
||||
(let ()
|
||||
(define-unit unit45-1
|
||||
(import)
|
||||
(export sig9)
|
||||
(define (f n) 3))
|
||||
(define-compound-unit unit45-2
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig9)) unit45-1]
|
||||
[() unit44 S]))
|
||||
(test-runtime-error exn:fail:contract? "unit17 misuses f"
|
||||
(invoke-unit unit45-2)))
|
||||
(let ()
|
||||
(define-unit unit46-1
|
||||
(import)
|
||||
(export sig9)
|
||||
(define (f n) #t))
|
||||
(define-compound-unit unit46-2
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig9)) unit46-1]
|
||||
[() unit44 S]))
|
||||
(test-runtime-error exn:fail:contract? "unit17 misuses f"
|
||||
(invoke-unit unit46-2)))
|
||||
|
||||
;; uncontracted export -> contracted export
|
||||
(define-unit/new-import-export unit47
|
||||
(import)
|
||||
(export sig8)
|
||||
((sig7) unit18))
|
||||
(let ()
|
||||
(define-compound-unit unit48
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig8)) unit47]
|
||||
[() unit13 S]))
|
||||
(test-runtime-error exn:fail:contract? "unit47 provided bad f"
|
||||
(invoke-unit unit48)))
|
||||
(let ()
|
||||
(define-compound-unit unit49
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig8)) unit47]
|
||||
[() unit17 S]))
|
||||
(test-runtime-error exn:fail:contract? "unit17 misuses f"
|
||||
(invoke-unit unit49)))
|
||||
|
||||
;; contracted import -> uncontracted import
|
||||
(define-unit/new-import-export unit50
|
||||
(import)
|
||||
(export sig7)
|
||||
((sig8) unit19))
|
||||
(let ()
|
||||
(define-compound-unit unit51
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig7)) unit50]
|
||||
[() unit12 S]))
|
||||
(test-runtime-error exn:fail:contract? "unit19 provides bad f"
|
||||
(invoke-unit unit51)))
|
||||
(let ()
|
||||
(define-compound-unit unit52
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig7)) unit50]
|
||||
[() unit16 S]))
|
||||
(test-runtime-error exn:fail:contract? "unit50 provides unprotected f into bad context"
|
||||
(invoke-unit unit52)))
|
||||
|
||||
;; contracted export -> contracted export
|
||||
(define-unit/new-import-export unit53
|
||||
(import)
|
||||
(export sig9)
|
||||
((sig8) unit19))
|
||||
(let ()
|
||||
(define-unit unit54-1
|
||||
(import sig9)
|
||||
(export)
|
||||
(f 3))
|
||||
(define-compound-unit unit54-2
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig9)) unit53]
|
||||
[() unit54-1 S]))
|
||||
(test-runtime-error exn:fail:contract? "unit19 provides bad f"
|
||||
(invoke-unit unit54-2)))
|
||||
(let ()
|
||||
(define-unit unit55-1
|
||||
(import sig9)
|
||||
(export)
|
||||
(f #t))
|
||||
(define-compound-unit unit55-2
|
||||
(import)
|
||||
(export)
|
||||
(link [((S : sig9)) unit53]
|
||||
[() unit55-1 S]))
|
||||
(test-runtime-error exn:fail:contract? "unit55-1 misuses f"
|
||||
(invoke-unit unit55-2)))
|
||||
Loading…
Reference in New Issue
Block a user