* Fix unit/c so that less unnecessary code is generated.
* Fix contracts for signatures and units so that references to other signature members work appropriately. * Add text about signature and unit contracts to the Guide. svn: r13562
This commit is contained in:
Stevie Strickland
parent
ed9584be2a
commit
387c8b210f
|
|
@ -5,6 +5,7 @@
|
|||
syntax/boundmap
|
||||
"unit-compiletime.ss")
|
||||
scheme/contract
|
||||
scheme/pretty
|
||||
"unit-keywords.ss"
|
||||
"unit-utils.ss"
|
||||
"unit-runtime.ss")
|
||||
|
|
@ -12,57 +13,54 @@
|
|||
(provide unit/c)
|
||||
|
||||
(define-for-syntax (contract-imports/exports import?)
|
||||
(λ (table-stx import-tagged-infos import-sigs ctc-table-stx pos neg src-info name)
|
||||
(λ (table-stx import-tagged-infos import-sigs ctc-table pos neg src-info name)
|
||||
(define def-table (make-bound-identifier-mapping))
|
||||
(define ctc-table (make-bound-identifier-mapping))
|
||||
(define (convert-reference vref ctc sig-ctc)
|
||||
|
||||
(define (convert-reference vref ctc sig-ctc rename-bindings)
|
||||
(let ([wrap-with-proj
|
||||
(λ (stx)
|
||||
#`((((proj-get ctc) ctc) #,(if import? neg pos)
|
||||
#,(if import? pos neg)
|
||||
#,src-info
|
||||
#,name)
|
||||
#,stx))])
|
||||
#`(let ([ctc #,ctc])
|
||||
(if ctc
|
||||
(cons (λ ()
|
||||
(let* ([old-v #,(if sig-ctc
|
||||
#`(let ([old-v/c ((car #,vref))])
|
||||
(cons #,(wrap-with-proj #'(car old-v/c))
|
||||
(cdr old-v/c)))
|
||||
(wrap-with-proj #`((car #,vref))))])
|
||||
old-v))
|
||||
(λ (v)
|
||||
(let* ([new-v #,(if sig-ctc
|
||||
#`(cons #,(wrap-with-proj #'(car v))
|
||||
(cdr v))
|
||||
(wrap-with-proj #'v))])
|
||||
((cdr #,vref) new-v))))
|
||||
#,vref))))
|
||||
(for-each
|
||||
(lambda (tagged-info sig)
|
||||
(define v
|
||||
#`(hash-ref #,table-stx #,(car (tagged-info->keys tagged-info))))
|
||||
(define c
|
||||
#`(hash-ref #,ctc-table-stx #,(car (tagged-info->keys tagged-info))))
|
||||
(for-each
|
||||
(lambda (int/ext-name index ctc)
|
||||
(bound-identifier-mapping-put! def-table
|
||||
(car int/ext-name)
|
||||
#`(vector-ref #,v #,index))
|
||||
(bound-identifier-mapping-put! ctc-table
|
||||
(car int/ext-name)
|
||||
#`(vector-ref #,c #,index)))
|
||||
(car sig)
|
||||
(build-list (length (car sig)) values)
|
||||
(cadddr sig)))
|
||||
import-tagged-infos
|
||||
import-sigs)
|
||||
(with-syntax ((((eloc ...) ...)
|
||||
(map
|
||||
(lambda (target-sig)
|
||||
(map
|
||||
(lambda (target-int/ext-name sig-ctc)
|
||||
(λ (ctc stx)
|
||||
;; If contract coersion ends up being a large overhead, we can
|
||||
;; store the result in a local box, then just check the box to
|
||||
;; see if we need to coerce.
|
||||
#`(let ([ctc (coerce-contract 'unit/c (letrec-syntax #,rename-bindings #,ctc))])
|
||||
((((proj-get ctc) ctc)
|
||||
#,(if import? neg pos)
|
||||
#,(if import? pos neg)
|
||||
#,src-info
|
||||
#,name)
|
||||
#,stx)))])
|
||||
(if ctc
|
||||
#`(cons
|
||||
(λ ()
|
||||
(let* ([old-v
|
||||
#,(if sig-ctc
|
||||
#`(let ([old-v/c ((car #,vref))])
|
||||
(cons #,(wrap-with-proj ctc #'(car old-v/c))
|
||||
(cdr old-v/c)))
|
||||
(wrap-with-proj ctc #`((car #,vref))))])
|
||||
old-v))
|
||||
(λ (v)
|
||||
(let* ([new-v
|
||||
#,(if sig-ctc
|
||||
#`(cons #,(wrap-with-proj ctc #'(car v))
|
||||
(cdr v))
|
||||
(wrap-with-proj ctc #'v))])
|
||||
((cdr #,vref) new-v))))
|
||||
vref)))
|
||||
(for ([tagged-info (in-list import-tagged-infos)]
|
||||
[sig (in-list import-sigs)])
|
||||
(let ([v #`(hash-ref #,table-stx #,(car (tagged-info->keys tagged-info)))])
|
||||
(for ([int/ext-name (in-list (car sig))]
|
||||
[index (in-list (build-list (length (car sig)) values))])
|
||||
(bound-identifier-mapping-put! def-table
|
||||
(car int/ext-name)
|
||||
#`(vector-ref #,v #,index)))))
|
||||
(with-syntax ((((eloc ...) ...)
|
||||
(for/list ([target-sig import-sigs])
|
||||
(let ([rename-bindings
|
||||
(get-member-bindings def-table target-sig pos)])
|
||||
(for/list ([target-int/ext-name (in-list (car target-sig))]
|
||||
[sig-ctc (in-list (cadddr target-sig))])
|
||||
(let* ([vref
|
||||
(bound-identifier-mapping-get
|
||||
def-table
|
||||
|
|
@ -70,11 +68,9 @@
|
|||
[ctc
|
||||
(bound-identifier-mapping-get
|
||||
ctc-table
|
||||
(car target-int/ext-name))])
|
||||
(convert-reference vref ctc sig-ctc)))
|
||||
(car target-sig)
|
||||
(cadddr target-sig)))
|
||||
import-sigs))
|
||||
(car target-int/ext-name)
|
||||
(λ () #f))])
|
||||
(convert-reference vref ctc sig-ctc rename-bindings))))))
|
||||
(((export-keys ...) ...)
|
||||
(map tagged-info->keys import-tagged-infos)))
|
||||
#'(unit-export ((export-keys ...)
|
||||
|
|
@ -83,40 +79,6 @@
|
|||
(define-for-syntax contract-imports (contract-imports/exports #t))
|
||||
(define-for-syntax contract-exports (contract-imports/exports #f))
|
||||
|
||||
(define-for-syntax (build-contract-table import? import-tagged-infos import-sigs id-stx ctc-stx)
|
||||
(with-syntax ([((ectc ...) ...)
|
||||
(map (λ (sig ids ctcs)
|
||||
(let ([alist (map cons (syntax->list ids) (syntax->list ctcs))])
|
||||
(map (λ (int/ext-name)
|
||||
(cond
|
||||
[(assf (λ (i)
|
||||
(bound-identifier=? i (car int/ext-name)))
|
||||
alist)
|
||||
=>
|
||||
(λ (p) (cdr p))]
|
||||
[else #'#f]))
|
||||
(car sig))))
|
||||
import-sigs
|
||||
(syntax->list id-stx)
|
||||
(syntax->list ctc-stx))]
|
||||
[((export-keys ...) ...)
|
||||
(map tagged-info->keys import-tagged-infos)])
|
||||
#'(unit-export ((export-keys ...) (vector-immutable ectc ...)) ...)))
|
||||
|
||||
(define-for-syntax (check-ids name sig alist)
|
||||
(let ([ctc-sig/ids (assf (λ (i)
|
||||
(bound-identifier=? name i))
|
||||
alist)])
|
||||
(when ctc-sig/ids
|
||||
(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)))
|
||||
(cdr ctc-sig/ids))))))
|
||||
|
||||
(define-syntax/err-param (unit/c stx)
|
||||
(begin
|
||||
(define-syntax-class sig-id
|
||||
|
|
@ -152,32 +114,45 @@
|
|||
export-tagged-sigids export-sigs)
|
||||
(process-unit-export #'(e.s ...)))
|
||||
|
||||
(define contract-table
|
||||
(make-bound-identifier-mapping))
|
||||
|
||||
(define (process-sig name sig xs cs)
|
||||
(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)))
|
||||
(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)))
|
||||
xs-list))
|
||||
(for ([x (in-list xs-list)]
|
||||
[c (in-list (syntax->list cs))])
|
||||
(bound-identifier-mapping-put! contract-table x c)))
|
||||
|
||||
(check-duplicate-sigs import-tagged-infos isig null null)
|
||||
|
||||
(check-duplicate-subs export-tagged-infos esig)
|
||||
|
||||
(check-unit-ie-sigs import-sigs export-sigs)
|
||||
|
||||
(for-each (λ (sig xs)
|
||||
(let ([dup (check-duplicate-identifier (syntax->list xs))])
|
||||
(when dup
|
||||
(raise-syntax-error 'unit/c
|
||||
(format "duplicate identifier found for signature ~a" (syntax->datum sig))
|
||||
dup))))
|
||||
(syntax->list #'(i.s ... e.s ...))
|
||||
(syntax->list #'((i.x ...) ... (e.x ...) ...)))
|
||||
|
||||
(let ([alist (map syntax->list
|
||||
(syntax->list #'((i.s i.x ...) ...)))])
|
||||
(for-each (λ (name sig)
|
||||
(check-ids name sig alist))
|
||||
isig import-sigs))
|
||||
|
||||
(let ([alist (map syntax->list
|
||||
(syntax->list #'((e.s e.x ...) ...)))])
|
||||
(for-each (λ (name sig)
|
||||
(check-ids name sig alist))
|
||||
esig export-sigs))
|
||||
(for-each process-sig
|
||||
isig
|
||||
import-sigs
|
||||
(syntax->list #'((i.x ...) ...))
|
||||
(syntax->list #'((i.c ...) ...)))
|
||||
(for-each process-sig
|
||||
esig
|
||||
export-sigs
|
||||
(syntax->list #'((e.x ...) ...))
|
||||
(syntax->list #'((e.c ...) ...)))
|
||||
|
||||
(with-syntax ([((import-key ...) ...)
|
||||
(map tagged-info->keys import-tagged-infos)]
|
||||
|
|
@ -188,23 +163,20 @@
|
|||
import-tagged-infos)]
|
||||
[(export-name ...)
|
||||
(map (lambda (tag/info) (car (siginfo-names (cdr tag/info))))
|
||||
export-tagged-infos)]
|
||||
[((new-ci ...) ...) (map generate-temporaries (syntax->list #'((i.c ...) ...)))]
|
||||
[((new-ce ...) ...) (map generate-temporaries (syntax->list #'((e.c ...) ...)))])
|
||||
export-tagged-infos)])
|
||||
(quasisyntax/loc stx
|
||||
(let-values ([(new-ci ...) (values (coerce-contract 'unit/c i.c) ...)] ...
|
||||
[(new-ce ...) (values (coerce-contract 'unit/c e.c) ...)] ...)
|
||||
(begin
|
||||
(make-proj-contract
|
||||
(list 'unit/c
|
||||
(cons 'import
|
||||
(list (cons 'i.s
|
||||
(map list (list 'i.x ...)
|
||||
(build-compound-type-name new-ci ...)))
|
||||
(build-compound-type-name 'i.c ...)))
|
||||
...))
|
||||
(cons 'export
|
||||
(list (cons 'e.s
|
||||
(map list (list 'e.x ...)
|
||||
(build-compound-type-name new-ce ...)))
|
||||
(build-compound-type-name 'e.c ...)))
|
||||
...)))
|
||||
(λ (pos neg src-info name)
|
||||
(λ (unit-tmp)
|
||||
|
|
@ -227,39 +199,27 @@
|
|||
(vector-immutable (cons 'export-name
|
||||
(vector-immutable export-key ...)) ...)
|
||||
(unit-deps unit-tmp)
|
||||
(lambda ()
|
||||
(λ ()
|
||||
(let-values ([(unit-fn export-table) ((unit-go unit-tmp))])
|
||||
(values (lambda (import-table)
|
||||
(let ([import-ctc-table
|
||||
#,(build-contract-table #t
|
||||
import-tagged-infos
|
||||
import-sigs
|
||||
#'((i.x ...) ...)
|
||||
#'((new-ci ...) ...))])
|
||||
(unit-fn #,(contract-imports
|
||||
#'import-table
|
||||
import-tagged-infos
|
||||
import-sigs
|
||||
#'import-ctc-table
|
||||
#'pos
|
||||
#'neg
|
||||
#'src-info
|
||||
#'name))))
|
||||
(let ([export-ctc-table
|
||||
#,(build-contract-table #f
|
||||
export-tagged-infos
|
||||
export-sigs
|
||||
#'((e.x ...) ...)
|
||||
#'((new-ce ...) ...))])
|
||||
#,(contract-exports
|
||||
#'export-table
|
||||
export-tagged-infos
|
||||
export-sigs
|
||||
#'export-ctc-table
|
||||
#'pos
|
||||
#'neg
|
||||
#'src-info
|
||||
#'name))))))))
|
||||
(unit-fn #,(contract-imports
|
||||
#'import-table
|
||||
import-tagged-infos
|
||||
import-sigs
|
||||
contract-table
|
||||
#'pos
|
||||
#'neg
|
||||
#'src-info
|
||||
#'name)))
|
||||
#,(contract-exports
|
||||
#'export-table
|
||||
export-tagged-infos
|
||||
export-sigs
|
||||
contract-table
|
||||
#'pos
|
||||
#'neg
|
||||
#'src-info
|
||||
#'name)))))))
|
||||
(λ (v)
|
||||
(and (unit? v)
|
||||
(with-handlers ([exn:fail:contract? (λ () #f)])
|
||||
|
|
|
|||
|
|
@ -1,7 +1,10 @@
|
|||
#lang mzscheme
|
||||
#lang scheme/base
|
||||
|
||||
(require (for-syntax "unit-compiletime.ss"
|
||||
"unit-syntax.ss"))
|
||||
(require (for-syntax scheme/base
|
||||
syntax/boundmap
|
||||
"unit-compiletime.ss"
|
||||
"unit-syntax.ss")
|
||||
mzlib/contract)
|
||||
|
||||
(provide (for-syntax build-key
|
||||
check-duplicate-sigs
|
||||
|
|
@ -9,7 +12,9 @@
|
|||
iota
|
||||
process-unit-import
|
||||
process-unit-export
|
||||
tagged-info->keys))
|
||||
tagged-info->keys
|
||||
id->contract-src-info
|
||||
get-member-bindings))
|
||||
|
||||
(provide equal-hash-table
|
||||
unit-export)
|
||||
|
|
@ -21,8 +26,43 @@
|
|||
((= n 0) acc)
|
||||
(else (loop (sub1 n) (cons (sub1 n) acc))))))
|
||||
|
||||
;; id->contract-src-info : identifier -> syntax
|
||||
;; constructs the last argument to the contract, given an identifier
|
||||
(define-for-syntax (id->contract-src-info id)
|
||||
#`(list (make-srcloc (quote-syntax #,id)
|
||||
#,(syntax-line id)
|
||||
#,(syntax-column id)
|
||||
#,(syntax-position id)
|
||||
#,(syntax-span id))
|
||||
#,(format "~s" (syntax->datum id))))
|
||||
|
||||
(define-syntax-rule (equal-hash-table [k v] ...)
|
||||
(make-immutable-hash-table (list (cons k v) ...) 'equal))
|
||||
(make-immutable-hash (list (cons k v) ...)))
|
||||
|
||||
(define-for-syntax (get-member-bindings member-table sig blame)
|
||||
(for/list ([i (in-list (map car (car sig)))]
|
||||
[c (in-list (cadddr sig))])
|
||||
(let ([add-ctc
|
||||
(λ (v stx)
|
||||
(if c
|
||||
#`(let ([v/c ((car #,stx))])
|
||||
(contract (let ([#,v #,c]) #,v)
|
||||
(car v/c) (cdr v/c) #,blame
|
||||
#,(id->contract-src-info v)))
|
||||
#`((car #,stx))))])
|
||||
#`[#,i
|
||||
(make-set!-transformer
|
||||
(λ (stx)
|
||||
(syntax-case stx (set!)
|
||||
[x
|
||||
(identifier? #'x)
|
||||
#'#,(add-ctc i (bound-identifier-mapping-get
|
||||
member-table
|
||||
i))]
|
||||
[(x . y)
|
||||
#'(#,(add-ctc i (bound-identifier-mapping-get
|
||||
member-table
|
||||
i)) . y)])))])))
|
||||
|
||||
(define-syntax (unit-export stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -40,22 +80,22 @@
|
|||
;; check-duplicate-sigs : (listof (cons symbol siginfo)) (listof syntax-object)
|
||||
;; (listof (cons symbol siginfo)) (listof syntax-object) ->
|
||||
(define-for-syntax (check-duplicate-sigs tagged-siginfos sources tagged-deps dsources)
|
||||
(define import-idx (make-hash-table 'equal))
|
||||
(define import-idx (make-hash))
|
||||
(for-each
|
||||
(lambda (tinfo s)
|
||||
(define key (cons (car tinfo)
|
||||
(car (siginfo-ctime-ids (cdr tinfo)))))
|
||||
(when (hash-table-get import-idx key #f)
|
||||
(when (hash-ref import-idx key #f)
|
||||
(raise-stx-err "duplicate import signature" s))
|
||||
(hash-table-put! import-idx key #t))
|
||||
(hash-set! import-idx key #t))
|
||||
tagged-siginfos
|
||||
sources)
|
||||
(for-each
|
||||
(lambda (dep s)
|
||||
(unless (hash-table-get import-idx
|
||||
(cons (car dep)
|
||||
(car (siginfo-ctime-ids (cdr dep))))
|
||||
#f)
|
||||
(unless (hash-ref import-idx
|
||||
(cons (car dep)
|
||||
(car (siginfo-ctime-ids (cdr dep))))
|
||||
#f)
|
||||
(raise-stx-err "initialization dependency on unknown import" s)))
|
||||
tagged-deps
|
||||
dsources))
|
||||
|
|
|
|||
|
|
@ -369,16 +369,6 @@
|
|||
(cons (car x)
|
||||
(signature-siginfo (lookup-signature (cdr x)))))
|
||||
|
||||
;; id->contract-src-info : identifier -> syntax
|
||||
;; constructs the last argument to the contract, given an identifier
|
||||
(define-for-syntax (id->contract-src-info id)
|
||||
#`(list (make-srcloc (quote-syntax #,id)
|
||||
#,(syntax-line id)
|
||||
#,(syntax-column id)
|
||||
#,(syntax-position id)
|
||||
#,(syntax-span id))
|
||||
#,(format "~s" (syntax-object->datum id))))
|
||||
|
||||
(define-for-syntax (make-import-unboxing var loc ctc)
|
||||
(if ctc
|
||||
(quasisyntax/loc (error-syntax)
|
||||
|
|
@ -670,6 +660,12 @@
|
|||
target-import-tagged-infos
|
||||
target-import-sigs)
|
||||
(define def-table (make-bound-identifier-mapping))
|
||||
(define ctc-table (make-bound-identifier-mapping))
|
||||
(define sig-of-all-import-sigs
|
||||
(list (apply append (map car import-sigs))
|
||||
(apply append (map cadr import-sigs))
|
||||
(apply append (map caddr import-sigs))
|
||||
(apply append (map cadddr import-sigs))))
|
||||
(for-each
|
||||
(lambda (tagged-info sig)
|
||||
(define v
|
||||
|
|
@ -678,7 +674,10 @@
|
|||
(lambda (int/ext-name index ctc)
|
||||
(bound-identifier-mapping-put! def-table
|
||||
(car int/ext-name)
|
||||
(cons #`(vector-ref #,v #,index) ctc)))
|
||||
#`(vector-ref #,v #,index))
|
||||
(bound-identifier-mapping-put! ctc-table
|
||||
(car int/ext-name)
|
||||
ctc))
|
||||
(car sig)
|
||||
(iota (length (car sig)))
|
||||
(cadddr sig)))
|
||||
|
|
@ -687,38 +686,48 @@
|
|||
(with-syntax ((((eloc ...) ...)
|
||||
(map
|
||||
(lambda (target-sig)
|
||||
(define rename-bindings
|
||||
(get-member-bindings def-table
|
||||
sig-of-all-import-sigs
|
||||
#'(current-contract-region)))
|
||||
(map
|
||||
(lambda (target-int/ext-name target-ctc)
|
||||
(let ([vref/ctc
|
||||
(let* ([var (car target-int/ext-name)]
|
||||
[vref
|
||||
(bound-identifier-mapping-get
|
||||
def-table
|
||||
(car target-int/ext-name)
|
||||
var
|
||||
(lambda ()
|
||||
(raise-stx-err
|
||||
(format (if import?
|
||||
"identifier ~a is not present in new imports"
|
||||
"identifier ~a is not present in old exports")
|
||||
(syntax-e (car target-int/ext-name))))))])
|
||||
(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))))))))
|
||||
(syntax-e (car target-int/ext-name))))))]
|
||||
[ctc (bound-identifier-mapping-get ctc-table var)])
|
||||
(if (or target-ctc ctc)
|
||||
#`(cons
|
||||
(λ ()
|
||||
(let ([old-v #,(if ctc
|
||||
#`(let ([old-v/c ((car #,vref))])
|
||||
(contract (let ([#,var (letrec-syntax #,rename-bindings #,ctc)]) #,var)
|
||||
(car old-v/c)
|
||||
(cdr old-v/c) (current-contract-region)
|
||||
#,(id->contract-src-info var)))
|
||||
#`((car #,vref)))])
|
||||
#,(if target-ctc
|
||||
#'(cons old-v (current-contract-region))
|
||||
#'old-v)))
|
||||
(λ (v) (let ([new-v #,(if ctc
|
||||
#`(contract (let ([#,var (letrec-syntax #,rename-bindings #,ctc)]) #,var)
|
||||
(car v)
|
||||
(current-contract-region)
|
||||
(cdr v)
|
||||
#,(id->contract-src-info var))
|
||||
#'v)])
|
||||
#,(if target-ctc
|
||||
#`((cdr #,vref) (cons new-v (current-contract-region)))
|
||||
#`((cdr #,vref) new-v)))))
|
||||
vref)))
|
||||
(car target-sig)
|
||||
(cadddr target-sig)))
|
||||
target-import-sigs))
|
||||
|
|
@ -1139,7 +1148,10 @@
|
|||
(out-tags (map car tagged-out))
|
||||
(out-sigs (map caddr tagged-out))
|
||||
(dup (check-duplicate-identifier (apply append (map sig-int-names out-sigs))))
|
||||
(out-vec (generate-temporaries out-sigs)))
|
||||
(out-vec (generate-temporaries out-sigs))
|
||||
(tmarker (make-syntax-introducer))
|
||||
(vmarker (make-syntax-introducer))
|
||||
(tmp-bindings (map (λ (s) (map tmarker (map car (car s)))) out-sigs)))
|
||||
(when dup
|
||||
(raise-stx-err (format "duplicate binding for ~e" (syntax-e dup))))
|
||||
(with-syntax ((((key1 key ...) ...) (map tagged-info->keys out-tags))
|
||||
|
|
@ -1153,25 +1165,45 @@
|
|||
((out-names ...)
|
||||
(map (lambda (info) (car (siginfo-names (cdr info))))
|
||||
out-tags))
|
||||
(((tmp-binding ...) ...) tmp-bindings)
|
||||
(((val-binding ...) ...) (map (λ (s) (map vmarker (map car (car s)))) out-sigs))
|
||||
(((out-code ...) ...)
|
||||
(map
|
||||
(lambda (os ov)
|
||||
(map
|
||||
(lambda (i v c)
|
||||
(if c
|
||||
#`(let ([v/c ((car (vector-ref #,ov #,i)))])
|
||||
(contract #,c (car v/c) (cdr v/c)
|
||||
(current-contract-region)
|
||||
#,(id->contract-src-info v)))
|
||||
#`((car (vector-ref #,ov #,i)))))
|
||||
(iota (length (car os)))
|
||||
(map car (car os))
|
||||
(cadddr os)))
|
||||
(lambda (i)
|
||||
#`((car (vector-ref #,ov #,i))))
|
||||
(iota (length (car os)))))
|
||||
out-sigs
|
||||
out-vec)))
|
||||
out-vec))
|
||||
(((val-code ...) ...)
|
||||
(map (λ (tbs os)
|
||||
(map (λ (tb c)
|
||||
(if c
|
||||
#`(car #,tb)
|
||||
tb))
|
||||
tbs
|
||||
(cadddr os)))
|
||||
tmp-bindings
|
||||
out-sigs))
|
||||
(((wrap-code ...) ...)
|
||||
(map (λ (os ov tbs)
|
||||
(map (λ (tb i v c)
|
||||
(if c
|
||||
#`(contract #,(vmarker c) (car #,tb) (cdr #,tb)
|
||||
(current-contract-region)
|
||||
#,(id->contract-src-info v))
|
||||
tb))
|
||||
tbs
|
||||
(iota (length (car os)))
|
||||
(map car (car os))
|
||||
(cadddr os)))
|
||||
out-sigs
|
||||
out-vec
|
||||
tmp-bindings)))
|
||||
(quasisyntax/loc stx
|
||||
(begin
|
||||
(define-values (int-binding ... ...)
|
||||
(define-values (tmp-binding ... ...)
|
||||
#,(syntax/loc #'unit-expr
|
||||
(let ((unit-tmp unit-expr))
|
||||
(check-unit unit-tmp 'define-values/invoke-unit)
|
||||
|
|
@ -1185,6 +1217,10 @@
|
|||
(let ([out-vec (hash-table-get export-table key1)] ...)
|
||||
(unit-fn #f)
|
||||
(values out-code ... ...))))))
|
||||
(define-values (val-binding ... ...)
|
||||
(values val-code ... ...))
|
||||
(define-values (int-binding ... ...)
|
||||
(values wrap-code ... ...))
|
||||
(define-syntaxes . renames) ...
|
||||
(define-syntaxes (mac-name ...) mac-body) ... ...
|
||||
(define-values (val-name ...) val-body) ... ...)))))
|
||||
|
|
|
|||
|
|
@ -456,6 +456,159 @@ The unit @scheme[simple-factory@] is automatically provided from the
|
|||
module, inferred from the filename @filepath{simple-factory-unit.ss} by
|
||||
replacing the @filepath{-unit.ss} suffix with @schemeidfont["@"].
|
||||
|
||||
@; ----------------------------------------
|
||||
|
||||
@(interaction-eval #:eval toy-eval (require scheme/contract))
|
||||
|
||||
@section{Contracts for Units}
|
||||
|
||||
There are a couple of ways of protecting units with contracts. One way
|
||||
is useful when writing new signatures, and the other handles the case
|
||||
when a unit must conform to an already existing signature.
|
||||
|
||||
@subsection{Adding Contracts to Signatures}
|
||||
|
||||
When contracts are added to a signature, then all units which implement
|
||||
that signature are protected by those contracts. The following version
|
||||
of the @scheme[toy-factory^] signature adds the contracts previously
|
||||
written in comments:
|
||||
|
||||
@schememod/eval[[#:file
|
||||
"contracted-toy-factory-sig.ss"
|
||||
scheme]
|
||||
|
||||
(define-signature contracted-toy-factory^
|
||||
((contracted
|
||||
[build-toys (-> integer? (listof toy?))]
|
||||
[repaint (-> toy? symbol? toy?)]
|
||||
[toy? (-> any/c boolean?)]
|
||||
[toy-color (-> toy? symbol?)])))
|
||||
|
||||
(provide contracted-toy-factory^)]
|
||||
|
||||
Now we take the previous implementation of @scheme[simple-factory@] and
|
||||
implement this version of @scheme[toy-factory^] instead:
|
||||
|
||||
@schememod/eval[[#:file
|
||||
"contracted-simple-factory-unit.ss"
|
||||
scheme
|
||||
|
||||
(require "contracted-toy-factory-sig.ss")]
|
||||
|
||||
(define-unit contracted-simple-factory@
|
||||
(import)
|
||||
(export contracted-toy-factory^)
|
||||
|
||||
(printf "Factory started.\n")
|
||||
|
||||
(define-struct toy (color) #:transparent)
|
||||
|
||||
(define (build-toys n)
|
||||
(for/list ([i (in-range n)])
|
||||
(make-toy 'blue)))
|
||||
|
||||
(define (repaint t col)
|
||||
(make-toy col)))
|
||||
|
||||
(provide contracted-simple-factory@)
|
||||
]
|
||||
|
||||
As before, we can invoke our new unit and bind the exports so
|
||||
that we can use them. This time, however, misusing the exports
|
||||
causes the appropriate contract errors.
|
||||
|
||||
@interaction[
|
||||
#:eval toy-eval
|
||||
(eval:alts (require "contracted-simple-factory-unit.ss") (void))
|
||||
(define-values/invoke-unit/infer contracted-simple-factory@)
|
||||
(build-toys 3)
|
||||
(build-toys #f)
|
||||
(repaint 3 'blue)
|
||||
]
|
||||
|
||||
@subsection{Adding Contracts to Units}
|
||||
|
||||
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.
|
||||
|
||||
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.
|
||||
|
||||
@schememod/eval[[#:file
|
||||
"wrapped-toy-store-unit.ss"
|
||||
scheme
|
||||
|
||||
(require "toy-store-sig.ss"
|
||||
"toy-factory-sig.ss")]
|
||||
|
||||
(define-unit wrapped-toy-store@
|
||||
(import toy-factory^)
|
||||
(export toy-store^)
|
||||
|
||||
(define inventory null)
|
||||
|
||||
(define (store-color) 3) (code:comment #, @t{Not a valid color!})
|
||||
|
||||
(define (maybe-repaint t)
|
||||
(if (eq? (toy-color t) (store-color))
|
||||
t
|
||||
(repaint t (store-color))))
|
||||
|
||||
(define (stock! n)
|
||||
(set! inventory
|
||||
(append inventory
|
||||
(map maybe-repaint
|
||||
(build-toys n)))))
|
||||
|
||||
(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?))])))])
|
||||
]
|
||||
|
||||
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. We see this below in the
|
||||
use of @scheme[define-compound-unit] instead of @scheme[define-compound-unit/infer]
|
||||
to link the two units.
|
||||
|
||||
@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-compound-unit checked-toy-store+factory@
|
||||
(import)
|
||||
(export F S)
|
||||
(link [((F : toy-factory^)) store-specific-factory@ S]
|
||||
[((S : toy-store^)) wrapped-toy-store@ F]))
|
||||
(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)
|
||||
]
|
||||
|
||||
|
||||
@; ----------------------------------------
|
||||
|
||||
@section{@scheme[unit] versus @scheme[module]}
|
||||
|
|
|
|||
|
|
@ -615,8 +615,6 @@
|
|||
(import)
|
||||
(export toy-factory^)
|
||||
|
||||
(printf "Factory started.\n")
|
||||
|
||||
(define-struct toy (color) #:transparent)
|
||||
|
||||
(define (build-toys n)
|
||||
|
|
@ -624,4 +622,99 @@
|
|||
(make-toy 'blue)))
|
||||
|
||||
(define (repaint t col)
|
||||
(make-toy col))))
|
||||
(make-toy col)))
|
||||
|
||||
(provide toy-factory^ simple-factory@))
|
||||
|
||||
(module m4 scheme
|
||||
(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/infer U@)
|
||||
|
||||
(provide f x?))
|
||||
|
||||
(require (prefix-in m4: 'm4))
|
||||
|
||||
(test-runtime-error exn:fail:contract? "misuse of f by 'm4 (leaked uncontracted to top-level)"
|
||||
(m4:f 3))
|
||||
|
||||
(require (prefix-in m3: 'm3))
|
||||
|
||||
(test-runtime-error exn:fail:contract? "misuse of build-toys by top-level"
|
||||
(let ()
|
||||
(define-values/invoke-unit/infer m3:simple-factory@)
|
||||
(build-toys #f)))
|
||||
|
||||
(module m5 scheme
|
||||
(define-signature foo^ (f (contracted [x? (-> any/c boolean?)])))
|
||||
|
||||
(define-unit U@
|
||||
(import)
|
||||
(export foo^)
|
||||
(define (x? n) (zero? n))
|
||||
(define (f x) (x? x)))
|
||||
|
||||
(provide foo^)
|
||||
(provide/contract
|
||||
[U@
|
||||
(unit/c (import)
|
||||
(export (foo^ [f (-> x? boolean?)])))]))
|
||||
|
||||
(require (prefix-in m5: 'm5))
|
||||
|
||||
(define-values/invoke-unit m5:U@
|
||||
(import)
|
||||
(export (prefix m5: m5:foo^)))
|
||||
|
||||
(m5:f 0)
|
||||
|
||||
(test-runtime-error exn:fail:contract? "misuse of f exported by U@ by the top level"
|
||||
(m5:f 3))
|
||||
|
||||
(let ()
|
||||
(define-signature foo^ (x? f))
|
||||
(define-signature bar^ ((contracted [x? (-> number? boolean?)]
|
||||
[f (-> x? number?)])))
|
||||
(define-unit U@
|
||||
(import)
|
||||
(export bar^)
|
||||
(define x? zero?)
|
||||
(define f values))
|
||||
|
||||
(define-unit/new-import-export V@
|
||||
(import)
|
||||
(export bar^)
|
||||
((bar^) U@))
|
||||
|
||||
(define-values/invoke-unit/infer V@)
|
||||
|
||||
(f 0)
|
||||
(test-runtime-error exn:fail:contract? "top-level broke contract on f"
|
||||
(f 3)))
|
||||
|
||||
(let ()
|
||||
(define-signature foo^ ((contracted [x? (-> number? boolean?)]
|
||||
[f (-> x? number?)])))
|
||||
(define-signature bar^ (f (contracted [x? (-> any/c boolean?)])))
|
||||
(define-unit U@
|
||||
(import)
|
||||
(export foo^)
|
||||
(define x? zero?)
|
||||
(define f values))
|
||||
|
||||
(define-unit/new-import-export V@
|
||||
(import)
|
||||
(export bar^)
|
||||
((foo^) U@))
|
||||
|
||||
(define-values/invoke-unit/infer V@)
|
||||
|
||||
(f 0)
|
||||
(test-runtime-error exn:fail:contract? "V@ broke contract on f"
|
||||
(f 3)))
|
||||
Loading…
Reference in New Issue
Block a user