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))]
[(x) (field (guard x))]))
(define/subexpression-pos-prop (field/c ctc)
(make-field/c (coerce-contract 'field/c ctc)))
(define/subexpression-pos-prop field/c
(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
#:omit-define-syntaxes
#:property prop:contract
(build-contract-property
#: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
(lambda (ctc)
(let ([ctc (field/c-ctc ctc)])
(let ([ctc (field/c-in ctc)])
(lambda (f) (and (field-handle? f)
(ctc (f))))))
#:late-neg-projection
(lambda (ctc)
(let ([ctc (field/c-ctc ctc)])
(lambda (blame)
(define proc (get/build-late-neg-projection ctc))
(define blame/c (blame-add-context blame "the field of"))
(define proj (proc (blame-swap blame/c)))
(define proj-pos (lambda (x) (proj x (blame-positive blame))))
(lambda (f neg-party)
(define proj-neg (lambda (x) (proj x neg-party)))
(cond
[(field-handle? f)
(make-field-proxy f proj-neg proj-pos)]
[else (raise-blame-error blame/c
#:missing-party neg-party
f
'(expected: "a field"))])))))))
(define in-proc (get/build-late-neg-projection (field/c-in ctc)))
(define out-proc (get/build-late-neg-projection (field/c-out ctc)))
(λ (blame)
(define blame/c (blame-add-context blame "the field of"))
(define in-proj (in-proc (blame-swap blame/c)))
(define out-proj (out-proc blame/c))
(define proj-pos (lambda (x) (out-proj x (blame-positive blame))))
(lambda (f neg-party)
(define proj-neg (lambda (x) (in-proj x neg-party)))
(cond
[(field-handle? f)
(make-field-proxy f proj-neg proj-pos)]
[else (raise-blame-error blame/c
#:missing-party neg-party
f
'(expected: "a field"))]))))))
(struct actor-state (mux ;; Mux
facets ;; (Hash FID Facet)