add WritesField effect
This commit is contained in:
parent
4ab405fd70
commit
3801174525
|
@ -479,8 +479,8 @@ The JobManager then performs the job and, when finished, asserts
|
||||||
(log "JM begins on task ~a" this-id)
|
(log "JM begins on task ~a" this-id)
|
||||||
|
|
||||||
;; ID -> ...
|
;; ID -> ...
|
||||||
(define (assign-task [mngr : ID]
|
(define (∀ (ρ) (assign-task [mngr : ID]
|
||||||
[request-again! : (→fn ★/t)])
|
[request-again! : (proc -> ★/t #:effects (ρ))]))
|
||||||
(start-facet assign
|
(start-facet assign
|
||||||
(on (retracted (task-manager mngr _))
|
(on (retracted (task-manager mngr _))
|
||||||
;; our task manager has crashed
|
;; our task manager has crashed
|
||||||
|
|
|
@ -459,13 +459,35 @@
|
||||||
;; sequence of effects
|
;; sequence of effects
|
||||||
(define-type-constructor Effs #:arity >= 0)
|
(define-type-constructor Effs #:arity >= 0)
|
||||||
(define-base-types OnStart OnStop OnDataflow)
|
(define-base-types OnStart OnStop OnDataflow)
|
||||||
|
|
||||||
;; (MakesField x τ)
|
;; (MakesField x τ)
|
||||||
(define-type-constructor MakesField #:arity = 2)
|
(define-type-constructor MakesField #:arity = 2)
|
||||||
|
|
||||||
;; (ReadsField x)
|
;; (ReadsField x)
|
||||||
(define-type-constructor ReadsField #:arity = 1)
|
(define-type-constructor ReadsField #:arity = 1)
|
||||||
;; (VarAssert x [--> τ τ])
|
;; need the original name so that we can re-typecheck an assert expression with
|
||||||
|
;; different types for that name. Could also subst the original name in after
|
||||||
|
;; constructing a valid type.
|
||||||
|
(begin-for-syntax
|
||||||
|
(define RF-KEY 'ReadsField)
|
||||||
|
(define (mk-ReadsField x x-)
|
||||||
|
(attach (type-eval #`(ReadsField #,x-)) RF-KEY x))
|
||||||
|
(define (get-ReadsField-orig-field RF)
|
||||||
|
(detach RF RF-KEY)))
|
||||||
|
|
||||||
|
;; (WritesField x τ)
|
||||||
|
(define-type-constructor WritesField #:arity = 2)
|
||||||
|
(begin-for-syntax
|
||||||
|
(define WF-KEY 'WritesField)
|
||||||
|
(define (mk-WritesField x x- t)
|
||||||
|
(attach (type-eval #`(WritesField #,x- #,t)) WF-KEY x))
|
||||||
|
(define (get-WritesField-orig-field WF)
|
||||||
|
(detach WF WF-KEY)))
|
||||||
|
|
||||||
|
;; (VarAssert x [--> τ-field τ-assert])
|
||||||
(define-type-constructor VarAssert #:arity > 1)
|
(define-type-constructor VarAssert #:arity > 1)
|
||||||
(define-type-constructor --> #:arity = 2)
|
(define-type-constructor --> #:arity = 2)
|
||||||
|
|
||||||
(define-type-constructor Actor #:arity = 1)
|
(define-type-constructor Actor #:arity = 1)
|
||||||
(define-type-constructor ActorWithRole #:arity >= 1)
|
(define-type-constructor ActorWithRole #:arity >= 1)
|
||||||
;; usage: (ActorWithRole τc τr)
|
;; usage: (ActorWithRole τc τr)
|
||||||
|
@ -1280,6 +1302,9 @@
|
||||||
(values bot bot bot (mk-Realize- #'(τ-m)) bot)]
|
(values bot bot bot (mk-Realize- #'(τ-m)) bot)]
|
||||||
[(~Start _)
|
[(~Start _)
|
||||||
(values bot bot bot bot bot)]
|
(values bot bot bot bot bot)]
|
||||||
|
[(~or* (~ReadsField _)
|
||||||
|
(~WritesField _ _))
|
||||||
|
(values bot bot bot bot bot)]
|
||||||
[(~WithFacets ([nm impl] ...) fst)
|
[(~WithFacets ([nm impl] ...) fst)
|
||||||
(apply values (syntax->list (analyze-roles #'(impl ...))))]
|
(apply values (syntax->list (analyze-roles #'(impl ...))))]
|
||||||
[(~Role+Body (_)
|
[(~Role+Body (_)
|
||||||
|
@ -1292,11 +1317,14 @@
|
||||||
;; TODO - is this sub-role clause acutally needed?
|
;; TODO - is this sub-role clause acutally needed?
|
||||||
;;(~and (~Role+Body _ _ ...) sub-role) ...
|
;;(~and (~Role+Body _ _ ...) sub-role) ...
|
||||||
)
|
)
|
||||||
#:with ((~or (~Shares τ-s)
|
#:with ((~alt (~Shares τ-s)
|
||||||
|
(~VarAssert _ [~--> _ τ-va] _ ...)
|
||||||
(~Know τ-k)
|
(~Know τ-k)
|
||||||
#;(~Sends τ-m)
|
#;(~Sends τ-m)
|
||||||
#;(~Realizes τ-rlz)
|
#;(~Realizes τ-rlz)
|
||||||
(~Reacts τ-if τ-then ...))
|
(~Reacts τ-if τ-then ...)
|
||||||
|
(~ReadsField _)
|
||||||
|
(~WritesField _ _))
|
||||||
...) (flatten-effects #'(EP ...))
|
...) (flatten-effects #'(EP ...))
|
||||||
;; #:with (msg ...) (for/list ([m (in-syntax #'(τ-m ...))])
|
;; #:with (msg ...) (for/list ([m (in-syntax #'(τ-m ...))])
|
||||||
;; (mk-Message- (list m)))
|
;; (mk-Message- (list m)))
|
||||||
|
@ -1315,7 +1343,7 @@
|
||||||
(define pat-types/ext (map event-desc-type ifs/ext))
|
(define pat-types/ext (map event-desc-type ifs/ext))
|
||||||
(define pat-types/int (map event-desc-type ifs/int))
|
(define pat-types/int (map event-desc-type ifs/int))
|
||||||
(values (mk-U- #`(#,@is/e #,@pat-types/ext))
|
(values (mk-U- #`(#,@is/e #,@pat-types/ext))
|
||||||
(mk-U- #`(τ-s ... #;msg #;... #,@os/e #,@(map pattern-sub-type pat-types/ext)))
|
(mk-U- #`(τ-s ... τ-va ... #;msg #;... #,@os/e #,@(map pattern-sub-type pat-types/ext)))
|
||||||
(mk-U- #`(#,@is/i #,@pat-types/int))
|
(mk-U- #`(#,@is/i #,@pat-types/int))
|
||||||
(mk-U- #`(τ-k ... #;rlz #;... #,@os/i #,@(map pattern-sub-type pat-types/int)))
|
(mk-U- #`(τ-k ... #;rlz #;... #,@os/i #,@(map pattern-sub-type pat-types/int)))
|
||||||
(mk-U- ss))]))
|
(mk-U- ss))]))
|
||||||
|
|
|
@ -159,6 +159,9 @@
|
||||||
(Know? eff)
|
(Know? eff)
|
||||||
(Reacts? eff)
|
(Reacts? eff)
|
||||||
(MakesField? eff)
|
(MakesField? eff)
|
||||||
|
(ReadsField? eff)
|
||||||
|
(WritesField? eff)
|
||||||
|
(VarAssert? eff)
|
||||||
(row-variable? eff)))
|
(row-variable? eff)))
|
||||||
|
|
||||||
;; Any -> Bool
|
;; Any -> Bool
|
||||||
|
@ -170,6 +173,8 @@
|
||||||
(Realizes? eff)
|
(Realizes? eff)
|
||||||
(AnyActor? eff)
|
(AnyActor? eff)
|
||||||
(Start? eff)
|
(Start? eff)
|
||||||
|
(ReadsField? eff)
|
||||||
|
(WritesField? eff)
|
||||||
(row-variable? eff)))
|
(row-variable? eff)))
|
||||||
|
|
||||||
(define endpoint-effects? (curry effects-andmap endpoint-effect?))
|
(define endpoint-effects? (curry effects-andmap endpoint-effect?))
|
||||||
|
@ -272,9 +277,18 @@
|
||||||
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
|
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
|
||||||
#:fail-unless (allowed-interest? #'τ) "overly broad interest, ?̱̱★ and ??★ not allowed"
|
#:fail-unless (allowed-interest? #'τ) "overly broad interest, ?̱̱★ and ??★ not allowed"
|
||||||
#:with τs (mk-Shares- #'(τ))
|
#:with τs (mk-Shares- #'(τ))
|
||||||
#:with kont (if (stx-null? #'(F ...))
|
#:with kont (syntax-parse #'(F ...)
|
||||||
#'(just-assert e-)
|
[(~and ((~and RF (~ReadsField _)))
|
||||||
#'(type-varying-assert e e-))
|
#;(~do (displayln 0))
|
||||||
|
(~parse x (get-ReadsField-orig-field #'RF))
|
||||||
|
(~typecheck [⊢ x ≫ x- (⇒ : (~Field τ-f))])
|
||||||
|
#;(~do (displayln 'B))
|
||||||
|
(~parse (~and τ-U (~U* τ1 τ2)) (find-union #'τ-f)))
|
||||||
|
#'(type-varying-assert e e- x x- τ-f τ-U)]
|
||||||
|
[_ #'(just-assert e-)])
|
||||||
|
;; #:with kont (if (stx-null? #'(F ...))
|
||||||
|
;; #'(just-assert e-)
|
||||||
|
;; #'(type-varying-assert e e-))
|
||||||
-------------------------------------
|
-------------------------------------
|
||||||
[≻ kont])
|
[≻ kont])
|
||||||
|
|
||||||
|
@ -287,20 +301,25 @@
|
||||||
(⇒ ν (τs))])
|
(⇒ ν (τs))])
|
||||||
|
|
||||||
;; need to make sure that the type has exactly one, binary union
|
;; need to make sure that the type has exactly one, binary union
|
||||||
(define-typed-syntax (type-varying-assert e e-) ≫
|
(define-typed-syntax (type-varying-assert e e- x x- τ-f τ-U) ≫
|
||||||
#:with ((~ReadsField x)) (detach #'e- EFF-KEY)
|
#:do [(displayln 'A)]
|
||||||
#:with τe (detach #'e- ':)
|
#:with τe (detach #'e- ':)
|
||||||
[⊢ x ≫ x- (⇒ : (~Field τ))]
|
#:do [(displayln 'B)]
|
||||||
#:with (~and union (~U* τi ...)) (find-union #'τ)
|
#:with (~U* τi ...) #'τ-U
|
||||||
|
#:do [(displayln 'C)]
|
||||||
#:with ((τ-specific τe_i) ...) (for/list ([ti (in-syntax #'(τi ...))])
|
#:with ((τ-specific τe_i) ...) (for/list ([ti (in-syntax #'(τi ...))])
|
||||||
(define specific (type-subst #'union ti #'τ))
|
(define specific (type-subst #'τ-U ti #'τ-f))
|
||||||
(syntax-parse/typecheck null
|
(syntax-parse/typecheck null
|
||||||
[_ ≫
|
[_ ≫
|
||||||
|
;; perhaps I should make sure the result is a subtype of the original?
|
||||||
[[x ≫ _ : (Field #,specific)] ⊢ e ≫ _ (⇒ : τe_i)]
|
[[x ≫ _ : (Field #,specific)] ⊢ e ≫ _ (⇒ : τe_i)]
|
||||||
--------------------
|
----------------------------------------
|
||||||
[≻ (#,specific τe_i)]]))
|
[≻ (#,specific τe_i)]]))
|
||||||
|
#:do [(displayln 'D)]
|
||||||
[[x ≫ _ : Type] ⊢ x ≫ x--]
|
[[x ≫ _ : Type] ⊢ x ≫ x--]
|
||||||
#:with VA (type-eval #`(VarAssert x-- [--> τ τe] [--> τ-specific τe_i] ...))
|
#:do [(displayln 'E)]
|
||||||
|
#:with VA (type-eval #`(VarAssert x-- [--> τ-f τe] [--> τ-specific τe_i] ...))
|
||||||
|
#:do [(pretty-display (type->strX #'VA))]
|
||||||
-------------------------------------------------------------------------
|
-------------------------------------------------------------------------
|
||||||
[⊢ (syndicate:assert e-)
|
[⊢ (syndicate:assert e-)
|
||||||
(⇒ : ★/t)
|
(⇒ : ★/t)
|
||||||
|
@ -676,8 +695,10 @@
|
||||||
[⊢ e ≫ e- (⇒ : τ) (⇒ ν (~effs F ...))]
|
[⊢ e ≫ e- (⇒ : τ) (⇒ ν (~effs F ...))]
|
||||||
[⊢ x ≫ x- (⇒ : (~Field τ-x:type))]
|
[⊢ x ≫ x- (⇒ : (~Field τ-x:type))]
|
||||||
#:fail-unless (<: #'τ #'τ-x) "Ill-typed field write"
|
#:fail-unless (<: #'τ #'τ-x) "Ill-typed field write"
|
||||||
|
[[x- ≫ _ : Type] ⊢ x- ≫ x--]
|
||||||
|
#:with WF (mk-WritesField #'x #'x-- #'τ-x)
|
||||||
----------------------------------------------------
|
----------------------------------------------------
|
||||||
[⊢ (#%app- x- e-) (⇒ : ★/t) (⇒ ν (F ...))])
|
[⊢ (#%app- x- e-) (⇒ : ★/t) (⇒ ν (WF F ...))])
|
||||||
|
|
||||||
(define-simple-macro (:= e ...)
|
(define-simple-macro (:= e ...)
|
||||||
(set! e ...))
|
(set! e ...))
|
||||||
|
@ -913,7 +934,7 @@
|
||||||
(define-typed-syntax (ref x:id) ≫
|
(define-typed-syntax (ref x:id) ≫
|
||||||
[⊢ x ≫ x- ⇒ (~Field τ)]
|
[⊢ x ≫ x- ⇒ (~Field τ)]
|
||||||
[[x- ≫ _ : Type] ⊢ x- ≫ x--]
|
[[x- ≫ _ : Type] ⊢ x- ≫ x--]
|
||||||
#:with RF (mk-ReadsField- #'(x--))
|
#:with RF (mk-ReadsField #'x #'x--)
|
||||||
------------------------
|
------------------------
|
||||||
[⊢ (#%app- x-)
|
[⊢ (#%app- x-)
|
||||||
(⇒ : τ)
|
(⇒ : τ)
|
||||||
|
|
Loading…
Reference in New Issue