syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Allow field/c to have different in and out contracts 

This can be used to temporarily disallow writing to the field, or
allowing the field to be initially #f but never set to #f.
This commit is contained in:
Sam Caldwell 2016-07-20 16:34:21 -04:00
parent 3b9e483076
commit 01ad7c72f6
1 changed files with 33 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
racket/syndicate/actor.rkt
View File

@ -112,38 +112,51 @@
[() (wrap (field))] [() (wrap (field))]
[(x) (field (guard x))])) [(x) (field (guard x))]))
(define/subexpression-pos-prop (field/c ctc) (define/subexpression-pos-prop field/c
(make-field/c (coerce-contract 'field/c ctc))) (case-lambda
[(ctc)
(let ([ctc (coerce-contract 'field/c ctc)])
(make-field/c ctc ctc #f))]
[(in out)
(make-field/c (coerce-contract 'field/c in)
(coerce-contract 'field/c out)
#t)]))
(define-struct field/c (ctc) (define-struct field/c (in out both-supplied?)
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:name #:name
(lambda (ctc) (build-compound-type-name 'field/c (field/c-ctc ctc))) (lambda (ctc)
(apply build-compound-type-name
`(field/c ,(field/c-in ctc)
,@(if (field/c-both-supplied? ctc)
(list (field/c-out ctc))
(list)))))
#:first-order #:first-order
(lambda (ctc) (lambda (ctc)
(let ([ctc (field/c-ctc ctc)]) (let ([ctc (field/c-in ctc)])
(lambda (f) (and (field-handle? f) (lambda (f) (and (field-handle? f)
(ctc (f)))))) (ctc (f))))))
#:late-neg-projection #:late-neg-projection
(lambda (ctc) (lambda (ctc)
(let ([ctc (field/c-ctc ctc)]) (define in-proc (get/build-late-neg-projection (field/c-in ctc)))
(lambda (blame) (define out-proc (get/build-late-neg-projection (field/c-out ctc)))
(define proc (get/build-late-neg-projection ctc)) (λ (blame)
(define blame/c (blame-add-context blame "the field of")) (define blame/c (blame-add-context blame "the field of"))
(define proj (proc (blame-swap blame/c))) (define in-proj (in-proc (blame-swap blame/c)))
(define proj-pos (lambda (x) (proj x (blame-positive blame)))) (define out-proj (out-proc blame/c))
(lambda (f neg-party) (define proj-pos (lambda (x) (out-proj x (blame-positive blame))))
(define proj-neg (lambda (x) (proj x neg-party))) (lambda (f neg-party)
(cond (define proj-neg (lambda (x) (in-proj x neg-party)))
[(field-handle? f) (cond
(make-field-proxy f proj-neg proj-pos)] [(field-handle? f)
[else (raise-blame-error blame/c (make-field-proxy f proj-neg proj-pos)]
#:missing-party neg-party [else (raise-blame-error blame/c
f #:missing-party neg-party
'(expected: "a field"))]))))))) f
'(expected: "a field"))]))))))
(struct actor-state (mux ;; Mux (struct actor-state (mux ;; Mux
facets ;; (Hash FID Facet) facets ;; (Hash FID Facet)