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

There is now a new form, define-unit/contract, that basically mixes

Browse Source 
define-unit with the application of a unit contract.  So you can think
of it as a define/contract for units that keeps the static info needed
for link inference.

svn: r13584
This commit is contained in:
Stevie Strickland 2009-02-14 21:32:02 +00:00
parent 093a897708
commit cbcad0528c
7 changed files with 236 additions and 125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/mzlib/private/unit-compiletime.ss
View File

@ -111,16 +111,21 @@
(parameterize ((error-syntax stx))
(raise-stx-err "illegal use of signature form"))))
;; (make-unit-info identifier (listof (cons symbol identifier)) (listof (cons symbol identifier)) identifier)
(define-struct/proc unit-info (unit-id import-sig-ids export-sig-ids deps orig-binder)
;; (make-unit-info identifier (listof (cons symbol identifier)) (listof (cons symbol identifier)) identifier boolean)
(define-struct/proc unit-info (unit-id import-sig-ids export-sig-ids deps orig-binder contracted?)
(lambda (struct stx)
(with-syntax ((u (unit-info-unit-id struct)))
(syntax-case stx (set!)
((set! x y)
#`(begin
#,(syntax/loc #'y (check-unit y 'set!))
#,(syntax/loc #'y (check-sigs y (unit-import-sigs u) (unit-export-sigs u) 'set!))
(set! u y)))
(if (unit-info-contracted? struct)
(raise-syntax-error 'set!
"cannot set! a contracted unit"
stx
(syntax x))
#`(begin
#,(syntax/loc #'y (check-unit y 'set!))
#,(syntax/loc #'y (check-sigs y (unit-import-sigs u) (unit-export-sigs u) 'set!))
(set! u y))))
((_ . y)
(syntax/loc stx (u . y)))
(x

57
collects/mzlib/private/unit-contract-syntax.ss
View File

@ -4,7 +4,8 @@
"unit-compiletime.ss"
(for-template "unit-keywords.ss"))
(provide import-clause export-clause)
(provide import-clause/contract export-clause/contract dep-clause
import-clause/c export-clause/c)
(define-syntax-class sig-id
#:attributes ()
@ -14,29 +15,55 @@
(signature? (set!-trans-extract x))))))
(define-syntax-class sig-spec #:literals (prefix rename only except)
#:attributes ((name 0))
#:transparent
(pattern name:sig-id)
(pattern (prefix i:identifier s:sig-spec)
#:with name #'s.name)
(pattern (rename s:sig-spec [int:identifier ext:identifier] ...)
#:with name #'s.name)
(pattern (only s:sig-spec i:identifier ...)
#:with name #'s.name)
(pattern (except s:sig-spec i:identifier ...)
#:with name #'s.name))
(define-syntax-class tagged-sig-spec #:literals (tag)
#:transparent
(pattern s:sig-spec
#:with i #f)
(pattern (tag i:identifier s:sig-spec)))
(define-syntax-class tagged-sig-id #:literals (tag)
#:attributes ()
#:transparent
(pattern s:sig-id)
(pattern (prefix i:identifier s:sig-spec))
(pattern (rename s:sig-spec [int:identifier ext:identifier] ...))
(pattern (only s:sig-spec i:identifier ...))
(pattern (except s:sig-spec i:identifier ...)))
(define-syntax-class tagged-sig-spec #:literals (tag)
#:attributes ()
#:transparent
(pattern s:sig-spec)
(pattern (tag i:identifier s:sig-spec)))
(pattern (tag i:identifier s:sig-id)))
(define-syntax-class unit/c-clause
#:transparent
(pattern (s:tagged-sig-id [x:identifier c:expr] ...))
(pattern s:tagged-sig-id ;; allow a non-wrapped sig, which is the same as (sig)
#:with (x ...) null
#:with (c ...) null))
(define-syntax-class import-clause/c #:literals (import)
#:transparent
(pattern (import i:unit/c-clause ...)))
(define-syntax-class export-clause/c #:literals (export)
#:transparent
(pattern (export e:unit/c-clause ...)))
(define-syntax-class unit/contract-clause
#:transparent
(pattern (s:tagged-sig-spec [x:identifier c:expr] ...))
(pattern s:tagged-sig-spec ;; allow a non-wrapped sig, which is the same as (sig)
#:with (x ...) null
#:with (c ...) null))
(define-syntax-class import-clause #:literals (import)
(define-syntax-class import-clause/contract #:literals (import)
#:transparent
(pattern (import i:unit/c-clause ...)))
(define-syntax-class export-clause #:literals (export)
(pattern (import i:unit/contract-clause ...)))
(define-syntax-class export-clause/contract #:literals (export)
#:transparent
(pattern (export e:unit/c-clause ...)))
(pattern (export e:unit/contract-clause ...)))
(define-syntax-class dep-clause #:literals (init-depend)
#:transparent
(pattern (init-depend s:tagged-sig-id ...)))

32
collects/mzlib/private/unit-contract.ss
View File

@ -4,12 +4,13 @@
stxclass
syntax/boundmap
"unit-compiletime.ss"
"unit-contract-syntax.ss")
"unit-contract-syntax.ss"
"unit-syntax.ss")
scheme/contract
"unit-utils.ss"
"unit-runtime.ss")
(provide unit/c)
(provide (for-syntax unit/c/core) unit/c)
(define-for-syntax (contract-imports/exports import?)
(λ (table-stx import-tagged-infos import-sigs ctc-table pos neg src-info name)
@ -78,9 +79,9 @@
(define-for-syntax contract-imports (contract-imports/exports #t))
(define-for-syntax contract-exports (contract-imports/exports #f))
(define-syntax/err-param (unit/c stx)
(define-for-syntax (unit/c/core stx)
(syntax-parse stx
[(_ :import-clause :export-clause)
[(:import-clause/c :export-clause/c)
(begin
(define-values (isig tagged-import-sigs import-tagged-infos
import-tagged-sigids import-sigs)
@ -97,17 +98,15 @@
(define xs-list (syntax->list xs))
(let ([dup (check-duplicate-identifier xs-list)])
(when dup
(raise-syntax-error 'unit/c
(format "duplicate identifier found for signature ~a"
(syntax->datum name))
dup)))
(raise-stx-err (format "duplicate identifier found for signature ~a"
(syntax->datum name))
dup)))
(let ([ids (map car (car sig))])
(for-each (λ (id)
(unless (memf (λ (i) (bound-identifier=? id i)) ids)
(raise-syntax-error 'unit/c
(format "identifier not member of signature ~a"
(syntax-e name))
id)))
(raise-stx-err (format "identifier not member of signature ~a"
(syntax-e name))
id)))
xs-list))
(for ([x (in-list xs-list)]
[c (in-list (syntax->list cs))])
@ -130,7 +129,9 @@
(syntax->list #'((e.x ...) ...))
(syntax->list #'((e.c ...) ...)))
(with-syntax ([((import-key ...) ...)
(with-syntax ([(isig ...) isig]
[(esig ...) esig]
[((import-key ...) ...)
(map tagged-info->keys import-tagged-infos)]
[((export-key ...) ...)
(map tagged-info->keys export-tagged-infos)]
@ -210,6 +211,11 @@
(list #f "not-used") 'not-used null))
#t)))))))]))
(define-syntax/err-param (unit/c stx)
(syntax-case stx ()
[(_ . sstx)
(unit/c/core #'sstx)]))
(define (contract-check-helper sub-sig super-sig import? val src-info blame ctc)
(define t (make-hash))
(let loop ([i (sub1 (vector-length sub-sig))])

97
collects/mzlib/unit.ss
View File

@ -1,11 +1,13 @@
(module unit mzscheme
(require-for-syntax mzlib/list
stxclass
syntax/boundmap
syntax/context
syntax/kerncase
syntax/name
syntax/struct
syntax/stx
"private/unit-contract-syntax.ss"
"private/unit-compiletime.ss"
"private/unit-syntax.ss")
@ -20,14 +22,15 @@
(provide define-signature-form struct open
define-signature provide-signature-elements
only except rename import export prefix link tag init-depend extends contracted
unit? (all-from "private/unit-contract.ss")
unit?
(rename :unit unit) define-unit
compound-unit define-compound-unit compound-unit/infer define-compound-unit/infer
invoke-unit define-values/invoke-unit
invoke-unit/infer define-values/invoke-unit/infer
unit-from-context define-unit-from-context
define-unit-binding
unit/new-import-export define-unit/new-import-export)
unit/new-import-export define-unit/new-import-export
unit/c define-unit/contract)
(define-syntax/err-param (define-signature-form stx)
(syntax-case stx ()
@ -1264,32 +1267,38 @@
(define-for-syntax (build-define-unit-helper contracted?)
(lambda (stx build err-msg)
(syntax-case stx ()
((_ name . rest)
(begin
(check-id #'name)
(let-values (((exp i e d) (parameterize ([error-syntax (syntax-property (error-syntax) 'inferred-name (syntax-e #'name))])
(build #'rest ))))
(with-syntax ((((itag . isig) ...) i)
(((etag . esig) ...) e)
(((deptag . depsig) ...) d)
(contracted? contracted?))
(quasisyntax/loc (error-syntax)
(begin
(define u #,exp)
(define-syntax name
(make-set!-transformer
(make-unit-info ((syntax-local-certifier) (quote-syntax u))
(list (cons 'itag (quote-syntax isig)) ...)
(list (cons 'etag (quote-syntax esig)) ...)
(list (cons 'deptag (quote-syntax deptag)) ...)
(quote-syntax name)
contracted?)))))))))
((_)
(raise-stx-err err-msg)))))
;; build-define-unit : syntax-object
;; (syntax-object -> (values syntax-object (listof identifier) (listof identifier))
;; string ->
;; syntax-object
(define-for-syntax (build-define-unit stx build err-msg)
(syntax-case stx ()
((_ name . rest)
(begin
(check-id #'name)
(let-values (((exp i e d) (parameterize ([error-syntax (syntax-property (error-syntax) 'inferred-name (syntax-e #'name))])
(build #'rest ))))
(with-syntax ((((itag . isig) ...) i)
(((etag . esig) ...) e)
(((deptag . depsig) ...) d))
(quasisyntax/loc (error-syntax)
(begin
(define u #,exp)
(define-syntax name
(make-set!-transformer
(make-unit-info ((syntax-local-certifier) (quote-syntax u))
(list (cons 'itag (quote-syntax isig)) ...)
(list (cons 'etag (quote-syntax esig)) ...)
(list (cons 'deptag (quote-syntax deptag)) ...)
(quote-syntax name))))))))))
((_)
(raise-stx-err err-msg))))
(define-for-syntax build-define-unit (build-define-unit-helper #f))
(define-for-syntax build-define-unit/contracted (build-define-unit-helper #t))
(define-for-syntax (build-define-unit-binding stx)
@ -1360,6 +1369,46 @@
(check-ufc-syntax sig)
(build-unit-from-context sig))
"missing unit name and signature"))
(define-for-syntax (build-unit/contract stx)
(syntax-parse stx
[(:import-clause/contract :export-clause/contract dep:dep-clause . body)
(let-values ([(exp isigs esigs deps)
(build-unit
(check-unit-syntax
(syntax/loc stx
((import i.s ...) (export e.s ...) dep . body))))])
(with-syntax ([(import-tagged-sig-id ...)
(map (λ (i s)
(if (identifier? i) #`(tag #,i #,s) s))
(syntax->list #'(i.s.i ...))
(syntax->list #'(i.s.s.name ...)))]
[(export-tagged-sig-id ...)
(map (λ (i s)
(if (identifier? i) #`(tag #,i #,s) s))
(syntax->list #'(e.s.i ...))
(syntax->list #'(e.s.s.name ...)))])
(with-syntax ([name (syntax-local-infer-name (error-syntax))]
[new-unit exp]
[unit-contract
(unit/c/core
(syntax/loc stx
((import (import-tagged-sig-id [i.x i.c] ...) ...)
(export (export-tagged-sig-id [e.x e.c] ...) ...))))]
[src-info (id->contract-src-info #'name)])
(values
(syntax/loc stx
(contract unit-contract new-unit '(unit name) (current-contract-region) src-info))
isigs esigs deps))))]
[(ic:import-clause/contract ec:export-clause/contract . body)
(build-unit/contract
(syntax/loc stx
(ic ec (init-depend) . body)))]))
(define-syntax/err-param (define-unit/contract stx)
(build-define-unit/contracted stx (λ (stx)
(build-unit/contract stx))
"missing unit name"))
(define-for-syntax (unprocess-tagged-id ti)
(if (car ti)

92
collects/scribblings/guide/unit.scrbl
View File

@ -530,85 +530,49 @@ causes the appropriate contract errors.
However, sometimes we may have a unit that must conform to an
already existing signature that is not contracted. In this case,
we can use the @scheme[unit/c] contract combinator, which creates
a new unit that protects parts of the wrapped unit as desired.
we can create a unit contract with @scheme[unit/c] or use
the @scheme[define-unit/contract] form, which defines a unit which
has been wrapped with a unit contract.
For example, here's a version of @scheme[toy-store@] which has a
slightly buggy implementation of the uncontracted @scheme[toy-store^]
signature. When we provide the new @scheme[wrapped-toy-store@] unit,
we protect its exports.
For example, here's a version of @scheme[toy-factory@] which still
implements the regular @scheme[toy-factory^], but whose exports
have been protected with an appropriate unit contract.
@schememod/eval[[#:file
"wrapped-toy-store-unit.ss"
"wrapped-simple-factory-unit.ss"
scheme
(require "toy-store-sig.ss"
"toy-factory-sig.ss")]
(require "toy-factory-sig.ss")]
(define-unit wrapped-toy-store@
(import toy-factory^)
(export toy-store^)
(define-unit/contract wrapped-simple-factory@
(import)
(export (toy-factory^
[build-toys (-> integer? (listof toy?))]
[repaint (-> toy? symbol? toy?)]
[toy? (-> any/c boolean?)]
[toy-color (-> toy? symbol?)]))
(define inventory null)
(printf "Factory started.\n")
(define (store-color) 3) (code:comment #, @t{Not a valid color!})
(define-struct toy (color) #:transparent)
(define (maybe-repaint t)
(if (eq? (toy-color t) (store-color))
t
(repaint t (store-color))))
(define (build-toys n)
(for/list ([i (in-range n)])
(make-toy 'blue)))
(define (stock! n)
(set! inventory
(append inventory
(map maybe-repaint
(build-toys n)))))
(define (repaint t col)
(make-toy col)))
(define (get-inventory) inventory))
(provide/contract
[wrapped-toy-store@
(unit/c (import toy-factory^)
(export (toy-store^
[store-color (-> symbol?)]
[stock! (-> integer? void?)]
[get-inventory (-> (listof toy?))])))])
(provide contracted-simple-factory@)
]
Since the result of the @scheme[unit/c] combinator is a new unit value
which has not been defined with @scheme[define-unit] or another similar
form, we run into problems with signature inference. The section
@secref{firstclassunits} lists options that we can use to handle the
resulting values.
@interaction[
#:eval toy-eval
(eval:alts (require "wrapped-toy-store-unit.ss")
(define wrapped-toy-store@
(contract (unit/c (import toy-factory^)
(export (toy-store^
[store-color (-> symbol?)]
[stock! (-> integer? void?)]
[get-inventory (-> (listof toy?))])))
wrapped-toy-store@
'wrapped-toy-store-unit
'top-level
(list (make-srcloc 'top-level #f #f #f #f) "wrapped-toy-store@"))))
(define-unit-binding protected-toy-store@
wrapped-toy-store@
(import toy-factory^)
(export toy-store^))
(define-compound-unit/infer checked-toy-store+factory@
(import)
(export toy-factory^ toy-store^)
(link store-specific-factory@ protected-toy-store@))
(define-values/invoke-unit/infer checked-toy-store+factory@)
(store-color)
(stock! 'a)
(code:comment #, @t{This fails because of the factory's (store-color) call})
(stock! 4)
(code:comment #, @t{Since it failed, there's no inventory})
(get-inventory)
(eval:alts (require "wrapped-simple-factory-unit.ss") (void))
(define-values/invoke-unit/infer wrapped-simple-factory@)
(build-toys 3)
(build-toys #f)
(repaint 3 'blue)
]

18
collects/scribblings/reference/units.scrbl
View File

@ -635,8 +635,8 @@ Expands to a @scheme[provide] of all identifiers implied by the
@defform/subs[#:literals (import export)
(unit/c (import sig-block ...) (export sig-block ...))
([sig-block (tagged-sig-spec [id contract] ...)
tagged-sig-spec])]{
([sig-block (tagged-sig-id [id contract] ...)
tagged-sig-id])]{
A @deftech{unit contract} wraps a unit and checks both its imported and
exported identifiers to ensure that they match the appropriate contracts.
@ -649,6 +649,20 @@ identifier which is not listed for a given signature is left alone.
Variables used in a given @scheme[contract] expression first refer to other
variables in the same signature, and then to the context of the
@scheme[unit/c] expression.}
@defform/subs[#:literals (import export)
(define-unit/contract unit-id
(import sig-spec-block ...)
(export sig-spec-block ...)
init-depends-decl
unit-body-expr-or-defn
...)
([sig-spec-block (tagged-sig-spec [id contract] ...)
tagged-sig-spec])]{
The @scheme[define-unit/contract] form defines an unit compatible with
link inference whose imports and exports are contracted with a unit
contract. The unit name is used for the positive blame of the contract.}
@; ------------------------------------------------------------------------

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

@ -717,4 +717,50 @@
(f 0)
(test-runtime-error exn:fail:contract? "V@ broke contract on f"
(f 3)))
(f 3)))
(let ()
(define-signature foo^ (x y))
(define-unit/contract U@
(import)
(export (foo^ [x (-> number? number?)]))
(define (x n) (zero? n))
(define y 4))
(define-unit V@
(import foo^)
(export)
(x 4))
(define-compound-unit/infer W@
(import) (export) (link U@ V@))
(define-values/invoke-unit/infer U@)
y
(test-runtime-error exn:fail:contract? "top-level broke contract on x"
(x #t))
(test-runtime-error exn:fail:contract? "U@ broke contract on x"
(x 3))
(test-runtime-error exn:fail:contract? "U@ broke contract on x"
(invoke-unit W@)))
(let ()
(define-signature foo^ (x? f))
(define-unit/contract U@
(import)
(export (foo^ [f (-> x? number?)]))
(define (x? n) (or (= n 3)
(zero? n)))
(define (f n) (if (= n 3) #t n)))
(define-unit V@
(import foo^)
(export)
(test-runtime-error exn:fail:contract? "top-level broke contract on x"
(f 2))
(test-runtime-error exn:fail:contract? "U@ broke contract on x"
(f 3)))
(define-compound-unit/infer W@
(import) (export) (link U@ V@))
(define-values/invoke-unit/infer U@)
(test-runtime-error exn:fail:contract? "top-level broke contract on x"
(f 4))
(test-runtime-error exn:fail:contract? "U@ broke contract on x"
(f 3))
(invoke-unit W@))