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

Abstraction of the boxes used for unit imports/exports to allow for adding

Browse Source 
contracts in an already created unit.

svn: r13331
This commit is contained in:
Stevie Strickland 2009-01-31 01:39:23 +00:00
parent ab5a01da76
commit f6493e1c32
2 changed files with 369 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

83
collects/mzlib/unit.ss
View File

@ -472,12 +472,12 @@
(define-for-syntax (make-import-unboxing var loc ctc) (define-for-syntax (make-import-unboxing var loc ctc)
(if ctc (if ctc
(quasisyntax/loc (error-syntax) (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) (contract #,ctc (car v/c) (cdr v/c)
(current-contract-region) (current-contract-region)
#,(id->contract-src-info var))))) #,(id->contract-src-info var)))))
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
(quote-syntax (unbox #,loc))))) (quote-syntax ((car #,loc))))))
;; build-unit : syntax-object -> ;; build-unit : syntax-object ->
;; (values syntax-object (listof identifier) (listof identifier)) ;; (values syntax-object (listof identifier) (listof identifier))
@ -557,7 +557,10 @@
(list (cons 'dept depr) ...) (list (cons 'dept depr) ...)
(syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))]) (syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))])
(lambda () (lambda ()
(let ([eloc (box undefined)] ... ...) (let ([eloc (let ([loc (box undefined)])
(cons
(λ () (unbox loc))
(λ (v) (set-box! loc v))))] ... ...)
(values (values
(lambda (import-table) (lambda (import-table)
(let-values ([(iloc ...) (let-values ([(iloc ...)
@ -731,12 +734,12 @@
(current-contract-region) (current-contract-region)
'cant-happen 'cant-happen
#,(id->contract-src-info id)) #,(id->contract-src-info id))
(set-box! #,export-loc ((cdr #,export-loc)
(let ([#,id #,tmp]) (let ([#,id #,tmp])
(cons #,id (current-contract-region)))))) (cons #,id (current-contract-region))))))
(quasisyntax/loc defn-or-expr (quasisyntax/loc defn-or-expr
(set-box! #,export-loc ((cdr #,export-loc)
(let ([#,id #,tmp]) #,id)))) (let ([#,id #,tmp]) #,id))))
(quasisyntax/loc defn-or-expr (quasisyntax/loc defn-or-expr
(define-syntax #,id (define-syntax #,id
(make-id-mapper (quote-syntax #,tmp)))))))] (make-id-mapper (quote-syntax #,tmp)))))))]
@ -776,12 +779,6 @@
(lambda (target-sig) (lambda (target-sig)
(map (map
(lambda (target-int/ext-name target-ctc) (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 (let ([vref/ctc
(bound-identifier-mapping-get (bound-identifier-mapping-get
def-table def-table
@ -792,13 +789,26 @@
"identifier ~a is not present in new imports" "identifier ~a is not present in new imports"
"identifier ~a is not present in old exports") "identifier ~a is not present in old exports")
(syntax-e (car target-int/ext-name))))))]) (syntax-e (car target-int/ext-name))))))])
(when (cdr vref/ctc) (let ([old-cl (car vref/ctc)])
(raise-stx-err #`(cons
(format (if import? (λ ()
"identifier ~a is contracted in new imports" (let ([old-v #,(if (cdr vref/ctc)
"identifier ~a is contracted in old exports") #`(let ([old-v/c ((car #,old-cl))])
(syntax-e (car target-int/ext-name))))) (contract #,(cdr vref/ctc) (car old-v/c)
(car vref/ctc))) (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) (car target-sig)
(cadddr target-sig))) (cadddr target-sig)))
target-import-sigs)) target-import-sigs))
@ -902,19 +912,20 @@
(vector-immutable (cons 'export-name (vector-immutable (cons 'export-name
(vector-immutable export-key ...)) ...) (vector-immutable export-key ...)) ...)
(list (cons 'dept depr) ...) (list (cons 'dept depr) ...)
(lambda () (syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))])
(let-values ([(unit-fn export-table) ((unit-go unit-tmp))]) (lambda ()
(values (lambda (import-table) (let-values ([(unit-fn export-table) ((unit-go unit-tmp))])
(unit-fn #,(redirect-imports #'import-table (values (lambda (import-table)
import-tagged-infos (unit-fn #,(redirect-imports #'import-table
import-sigs import-tagged-infos
orig-import-tagged-infos import-sigs
orig-import-sigs))) orig-import-tagged-infos
#,(redirect-exports #'export-table orig-import-sigs)))
orig-export-tagged-infos #,(redirect-exports #'export-table
orig-export-sigs orig-export-tagged-infos
export-tagged-infos orig-export-sigs
export-sigs))))))) export-tagged-infos
export-sigs))))))))
import-tagged-sigids import-tagged-sigids
export-tagged-sigids export-tagged-sigids
dep-tagged-sigids))))))) dep-tagged-sigids)))))))
@ -1238,11 +1249,11 @@
(map (map
(lambda (i v c) (lambda (i v c)
(if 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) (contract #,c (car v/c) (cdr v/c)
(current-contract-region) (current-contract-region)
#,(id->contract-src-info v))) #,(id->contract-src-info v)))
#`(unbox (vector-ref #,ov #,i)))) #`((car (vector-ref #,ov #,i)))))
(iota (length (car os))) (iota (length (car os)))
(map car (car os)) (map car (car os))
(cadddr os))) (cadddr os)))

352
collects/tests/units/test-unit-contracts.ss
View File

@ -196,46 +196,338 @@
(test-runtime-error exn:fail:contract? "top-level misuses f" (test-runtime-error exn:fail:contract? "top-level misuses f"
(f #t))) (f #t)))
;; eventually we can hopefully fix this so these are allowed, but for right ;; unit/new-import-export tests
;; now, test that they fail during unit/new-import-export
(define-signature sig7 (x)) (define-signature sig7 (f))
(define-signature sig8 ((contracted [x number?]))) (define-signature sig8 ((contracted [f (-> number? number?)])))
(define-signature sig9 ((contracted [f (-> number? number?)])))
;; All units that play nicely
(define-unit unit12 (define-unit unit12
(import sig7) (import sig7)
(export) (export)
x) (f 3))
(define-unit unit13 (define-unit unit13
(import sig8) (import sig8)
(export) (export)
x) (f 3))
(define-unit unit14 (define-unit unit14
(import) (import)
(export sig8) (export sig7)
(define x 3)) (define f (λ (n) 3)))
(define-unit unit15 (define-unit unit15
(import) (import)
(export sig7) (export sig8)
(define x 3)) (define f (λ (n) 3)))
(test-syntax-error "not contracted in old import -> contracted in new" ;; All units that don't play nicely (or won't after converted)
(unit/new-import-export (define-unit unit16
(import sig8) (import sig7)
(export) (export)
(() unit12 sig7))) (f #t))
(test-syntax-error "contracted in old import -> not contracted in new" (define-unit unit17
(unit/new-import-export (import sig8)
(import sig7) (export)
(export) (f #t))
(() unit13 sig8))) (define-unit unit18
(test-syntax-error "not contracted in old export -> contracted in new" (import)
(unit/new-import-export (export sig7)
(import) (define f (λ (n) #t)))
(export sig8) (define-unit unit19
((sig7) unit14))) (import)
(test-syntax-error "contracted in old export -> not contracted in new" (export sig8)
(unit/new-import-export (define f (λ (n) #t)))
(import)
(export sig7) ;; Converting units without internal contract violations
((sig8) unit15)))
;; 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)))