Introduce `object` and `spawn/link`
This commit is contained in:
parent
b5c57381fa
commit
247fd1b2c0
|
@ -12,18 +12,17 @@
|
||||||
(define reporter (report-stats REPORT_EVERY))
|
(define reporter (report-stats REPORT_EVERY))
|
||||||
(send! k (hash 'getter
|
(send! k (hash 'getter
|
||||||
(embedded
|
(embedded
|
||||||
(ref (during* #:name 'subscription-handler
|
(object #:name 'subscription-handler
|
||||||
(lambda (observer)
|
[#:asserted observer
|
||||||
(log-info "observer ~v" observer)
|
(log-info "observer ~v" observer)
|
||||||
(at (embedded-value observer) (assert (value)))))))
|
(at (embedded-value observer) (assert (value)))]))
|
||||||
'setter
|
'setter
|
||||||
(embedded
|
(embedded
|
||||||
(ref (entity #:name 'update-handler
|
(object #:name 'update-handler
|
||||||
#:message
|
[#:asserted new-value
|
||||||
(lambda (new-value)
|
(reporter new-value)
|
||||||
(reporter new-value)
|
(when (= new-value LIMIT) (stop-facet root-facet))
|
||||||
(when (= new-value LIMIT) (stop-facet root-facet))
|
(value new-value)]))))))
|
||||||
(value new-value)))))))))
|
|
||||||
|
|
||||||
(define (client getter setter)
|
(define (client getter setter)
|
||||||
(log-info "client start")
|
(log-info "client start")
|
||||||
|
@ -32,33 +31,29 @@
|
||||||
(define count 0)
|
(define count 0)
|
||||||
(at getter
|
(at getter
|
||||||
(assert (embedded
|
(assert (embedded
|
||||||
(ref (entity #:name 'termination-detector
|
(object #:name 'termination-detector
|
||||||
#:assert
|
[#:asserted _
|
||||||
(lambda (_value _handle)
|
(set! count (+ count 1))
|
||||||
(set! count (+ count 1)))
|
#:retracted
|
||||||
#:retract
|
(set! count (- count 1))
|
||||||
(lambda (_handle)
|
(when (zero? count)
|
||||||
(set! count (- count 1))
|
(log-info "Client detected box termination")
|
||||||
(when (zero? count)
|
(stop-facet root-facet))])))
|
||||||
(log-info "Client detected box termination")
|
|
||||||
(stop-facet root-facet)))))))
|
|
||||||
(assert (embedded
|
(assert (embedded
|
||||||
(ref (entity #:name 'update-handler
|
(object #:name 'update-handler
|
||||||
#:assert
|
[#:asserted value (send! setter (+ value 1))]))))))
|
||||||
(lambda (value _handle) (send! setter (+ value 1))))))))))
|
|
||||||
|
|
||||||
(module+ main
|
(module+ main
|
||||||
(time
|
(time
|
||||||
(actor-system
|
(actor-system
|
||||||
(define root-facet this-facet)
|
(define root-facet this-facet)
|
||||||
(define disarm (facet-prevent-inert-check! this-facet))
|
(define disarm (facet-prevent-inert-check! this-facet))
|
||||||
(box (ref (entity #:name 'box-boot-handler
|
(box (object #:name 'box-boot-handler
|
||||||
#:message
|
[#:asserted refs
|
||||||
(lambda (refs)
|
(log-info "refs ~v" refs)
|
||||||
(log-info "refs ~v" refs)
|
(match-define (hash-table ('getter (embedded g))
|
||||||
(match-define (hash-table ('getter (embedded g))
|
('setter (embedded s))) refs)
|
||||||
('setter (embedded s))) refs)
|
(client g s)
|
||||||
(client g s)
|
(stop-facet root-facet)])
|
||||||
(stop-facet root-facet))))
|
|
||||||
500000
|
500000
|
||||||
100000))))
|
100000))))
|
||||||
|
|
|
@ -28,25 +28,20 @@
|
||||||
(spawn #:name 'tcp-server
|
(spawn #:name 'tcp-server
|
||||||
(at ds
|
(at ds
|
||||||
(during/spawn (Connection $conn (TcpInbound "0.0.0.0" 5999))
|
(during/spawn (Connection $conn (TcpInbound "0.0.0.0" 5999))
|
||||||
(define gatekeeper
|
|
||||||
(ref
|
|
||||||
(during* #:name (list conn 'gatekeeper)
|
|
||||||
(lambda (assertion)
|
|
||||||
(match (parse-Resolve assertion)
|
|
||||||
[(? eof-object?) (void)]
|
|
||||||
[(Resolve unvalidated-sturdyref observer)
|
|
||||||
(at ds
|
|
||||||
(during (Bind (SturdyRef-oid unvalidated-sturdyref) $key $target)
|
|
||||||
(define sturdyref (validate unvalidated-sturdyref key))
|
|
||||||
(define attenuation
|
|
||||||
(append-map Attenuation-value
|
|
||||||
(reverse (SturdyRef-caveatChain sturdyref))))
|
|
||||||
(define attenuated-target
|
|
||||||
(apply attenuate-entity-ref target attenuation))
|
|
||||||
(at observer (assert (embedded attenuated-target)))))])))))
|
|
||||||
(run-relay #:name conn
|
(run-relay #:name conn
|
||||||
#:packet-writer (lambda (bs) (send-data conn bs))
|
#:packet-writer (lambda (bs) (send-data conn bs))
|
||||||
#:setup-inputs
|
#:setup-inputs
|
||||||
(lambda (tr)
|
(lambda (tr)
|
||||||
(accept-connection conn #:on-data (lambda (bs) (accept-bytes tr bs))))
|
(accept-connection conn #:on-data (lambda (bs) (accept-bytes tr bs))))
|
||||||
#:initial-ref gatekeeper))))))
|
#:initial-ref
|
||||||
|
(object #:name (list conn 'gatekeeper)
|
||||||
|
[(Resolve unvalidated-sturdyref observer)
|
||||||
|
(at ds
|
||||||
|
(during (Bind (SturdyRef-oid unvalidated-sturdyref) $key $target)
|
||||||
|
(define sturdyref (validate unvalidated-sturdyref key))
|
||||||
|
(define attenuation
|
||||||
|
(append-map Attenuation-value
|
||||||
|
(reverse (SturdyRef-caveatChain sturdyref))))
|
||||||
|
(define attenuated-target
|
||||||
|
(apply attenuate-entity-ref target attenuation))
|
||||||
|
(at observer (assert (embedded attenuated-target)))))])))))))
|
||||||
|
|
|
@ -61,10 +61,11 @@
|
||||||
(on-stop (close-input-port i)
|
(on-stop (close-input-port i)
|
||||||
(close-output-port o))
|
(close-output-port o))
|
||||||
(start-inbound-relay connection-custodian name local-peer i)
|
(start-inbound-relay connection-custodian name local-peer i)
|
||||||
|
(define relay (outbound-relay name o))
|
||||||
(at local-peer
|
(at local-peer
|
||||||
(assert (ActiveSocket-controller
|
(assert (ActiveSocket-controller
|
||||||
(ref (entity #:name (list name 'socket)
|
(object #:name (list name 'socket)
|
||||||
#:message (outbound-relay name o))))))))))
|
[#:asserted (Socket data) (relay data)]))))))))
|
||||||
|
|
||||||
(define (spawn-inbound ds custodian i o spec)
|
(define (spawn-inbound ds custodian i o spec)
|
||||||
(define name (call-with-values (lambda () (tcp-addresses i #t)) list))
|
(define name (call-with-values (lambda () (tcp-addresses i #t)) list))
|
||||||
|
@ -74,29 +75,25 @@
|
||||||
(close-output-port o))
|
(close-output-port o))
|
||||||
|
|
||||||
(define active-controller #f)
|
(define active-controller #f)
|
||||||
(define active-controller-handle #f)
|
(define relay (outbound-relay name o))
|
||||||
(at ds
|
(at ds
|
||||||
(assert (Connection
|
(assert (Connection
|
||||||
(ref (entity #:name (list name 'active-socket)
|
(object
|
||||||
#:assert
|
#:name (list name 'active-socket)
|
||||||
(lambda (m handle)
|
[#:asserted (ActiveSocket-controller controller)
|
||||||
(match (parse-ActiveSocket m)
|
(log-syndicate/drivers/tcp-debug "~v controller for ~v" controller this-actor)
|
||||||
[(ActiveSocket-controller controller)
|
(when (not active-controller)
|
||||||
(log-syndicate/drivers/tcp-debug "~v controller for ~v" controller this-actor)
|
(start-inbound-relay custodian name controller i))
|
||||||
(when (not active-controller)
|
(set! active-controller controller)
|
||||||
(start-inbound-relay custodian name controller i))
|
#:retracted
|
||||||
(set! active-controller controller)
|
(when (eq? controller active-controller)
|
||||||
(set! active-controller-handle handle)]
|
(log-syndicate/drivers/tcp-debug "peer withdrawn ~v" this-actor)
|
||||||
[(ActiveSocket-close message)
|
(stop-current-facet))]
|
||||||
(log-syndicate/drivers/tcp-debug "closing ~v:\n~a" this-actor message)
|
[#:asserted (ActiveSocket-close message)
|
||||||
(stop-current-facet)]))
|
(log-syndicate/drivers/tcp-debug "closing ~v:\n~a" this-actor message)
|
||||||
#:retract
|
(stop-current-facet)]
|
||||||
(lambda (handle)
|
[#:asserted (ActiveSocket-Socket (Socket data))
|
||||||
(when (equal? handle active-controller-handle)
|
(relay data)])
|
||||||
(log-syndicate/drivers/tcp-debug "peer withdrawn ~v" this-actor)
|
|
||||||
(stop-current-facet)))
|
|
||||||
#:message
|
|
||||||
(outbound-relay name o)))
|
|
||||||
spec)))))
|
spec)))))
|
||||||
|
|
||||||
(define (start-inbound-relay custodian name target i)
|
(define (start-inbound-relay custodian name target i)
|
||||||
|
@ -113,17 +110,15 @@
|
||||||
|
|
||||||
(define (outbound-relay name o)
|
(define (outbound-relay name o)
|
||||||
(define flush-pending #f)
|
(define flush-pending #f)
|
||||||
(lambda (m)
|
(lambda (payload)
|
||||||
(match (parse-ActiveSocket m)
|
(log-syndicate/drivers/tcp-debug "outbound data ~v for ~v" payload name)
|
||||||
[(ActiveSocket-Socket (Socket payload))
|
(write-bytes payload o)
|
||||||
(log-syndicate/drivers/tcp-debug "outbound data ~v for ~v" payload name)
|
(when (not flush-pending)
|
||||||
(write-bytes payload o)
|
(set! flush-pending #t)
|
||||||
(when (not flush-pending)
|
(facet-on-end-of-turn! this-facet
|
||||||
(set! flush-pending #t)
|
(lambda ()
|
||||||
(facet-on-end-of-turn! this-facet
|
(set! flush-pending #f)
|
||||||
(lambda ()
|
(flush-output o))))))
|
||||||
(set! flush-pending #f)
|
|
||||||
(flush-output o))))])))
|
|
||||||
|
|
||||||
(define (read-bytes-avail input-port #:limit [limit 65536])
|
(define (read-bytes-avail input-port #:limit [limit 65536])
|
||||||
(define buffer (make-bytes limit))
|
(define buffer (make-bytes limit))
|
||||||
|
@ -134,11 +129,8 @@
|
||||||
(define (accept-connection conn #:on-data on-data)
|
(define (accept-connection conn #:on-data on-data)
|
||||||
(at conn
|
(at conn
|
||||||
(assert (ActiveSocket-controller
|
(assert (ActiveSocket-controller
|
||||||
(ref (entity #:name 'inbound-socket-controller
|
(object #:name 'inbound-socket-controller
|
||||||
#:message
|
[#:asserted (Socket data) (on-data data)])))))
|
||||||
(lambda (m)
|
|
||||||
(match-define (Socket data) (parse-Socket m))
|
|
||||||
(on-data data))))))))
|
|
||||||
|
|
||||||
(define (establish-connection ds spec
|
(define (establish-connection ds spec
|
||||||
#:on-connected on-connected
|
#:on-connected on-connected
|
||||||
|
@ -146,16 +138,16 @@
|
||||||
#:on-disconnected [on-disconnected (lambda () (stop-current-facet))]
|
#:on-disconnected [on-disconnected (lambda () (stop-current-facet))]
|
||||||
#:on-rejected [on-rejected (lambda () (stop-current-facet))])
|
#:on-rejected [on-rejected (lambda () (stop-current-facet))])
|
||||||
(define s
|
(define s
|
||||||
(entity #:name 'outbound-socket
|
(object #:name 'outbound-socket
|
||||||
#:assert (lambda (m _handle)
|
[#:asserted (ActiveSocket-controller peer)
|
||||||
(match (parse-ActiveSocket m)
|
(on-connected peer)
|
||||||
[(ActiveSocket-controller peer) (on-connected peer)]
|
#:retracted
|
||||||
[(ActiveSocket-close message) (on-rejected message)]))
|
(on-disconnected)]
|
||||||
#:retract (lambda (_handle) (on-disconnected))
|
[#:asserted (ActiveSocket-close message)
|
||||||
#:message (lambda (m)
|
(on-rejected message)]
|
||||||
(match (parse-ActiveSocket m)
|
[#:asserted (ActiveSocket-Socket (Socket data))
|
||||||
[(ActiveSocket-Socket (Socket data)) (on-data data)]))))
|
(on-data data)]))
|
||||||
(at ds (assert (Connection (ref s) spec))))
|
(at ds (assert (Connection s spec))))
|
||||||
|
|
||||||
(define (send-data conn data)
|
(define (send-data conn data)
|
||||||
(send! conn (Socket (if (bytes? data) data (string->bytes/utf-8 data)))))
|
(send! conn (Socket (if (bytes? data) data (string->bytes/utf-8 data)))))
|
||||||
|
|
|
@ -6,9 +6,11 @@
|
||||||
(provide (for-syntax preserves-pattern-registry
|
(provide (for-syntax preserves-pattern-registry
|
||||||
register-preserves-pattern!
|
register-preserves-pattern!
|
||||||
analyse-pattern
|
analyse-pattern
|
||||||
analyse-pattern-bindings)
|
analyse-pattern-bindings
|
||||||
|
analyse-match-pattern)
|
||||||
define-preserves-pattern
|
define-preserves-pattern
|
||||||
:pattern
|
:pattern
|
||||||
|
:parse
|
||||||
|
|
||||||
pattern->constant-values
|
pattern->constant-values
|
||||||
pattern->constant-paths
|
pattern->constant-paths
|
||||||
|
@ -42,7 +44,7 @@
|
||||||
|
|
||||||
(define-syntax (define-preserves-pattern stx)
|
(define-syntax (define-preserves-pattern stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ top-type-name (ctor-stx field-stxs ...) pattern-stx bindings-stx)
|
[(_ top-type-name parser-name (ctor-stx field-stxs ...) pattern-stx bindings-stx)
|
||||||
#`(begin (begin-for-syntax
|
#`(begin (begin-for-syntax
|
||||||
(register-preserves-pattern!
|
(register-preserves-pattern!
|
||||||
#'ctor-stx
|
#'ctor-stx
|
||||||
|
@ -52,6 +54,10 @@
|
||||||
(syntax-case s ()
|
(syntax-case s ()
|
||||||
[(_ field-stxs ...) pattern-stx]
|
[(_ field-stxs ...) pattern-stx]
|
||||||
[_ (raise-syntax-error 'ctor-stx "Invalid pattern")])]
|
[_ (raise-syntax-error 'ctor-stx "Invalid pattern")])]
|
||||||
|
['match-pattern
|
||||||
|
(syntax-case s ()
|
||||||
|
[(_ field-stxs ...) #`(app parser-name (ctor-stx field-stxs ...))]
|
||||||
|
[_ (raise-syntax-error 'ctor-stx "Invalid match-pattern")])]
|
||||||
['bindings
|
['bindings
|
||||||
(syntax-case s ()
|
(syntax-case s ()
|
||||||
[(_ field-stxs ...) bindings-stx]
|
[(_ field-stxs ...) bindings-stx]
|
||||||
|
@ -130,8 +136,7 @@
|
||||||
[(expander args ...)
|
[(expander args ...)
|
||||||
(pattern-expander-id? #'expander)
|
(pattern-expander-id? #'expander)
|
||||||
(pattern-expander-transform disarmed-stx
|
(pattern-expander-transform disarmed-stx
|
||||||
(lambda (result)
|
(lambda (result) (walk (syntax-rearm result stx))))]
|
||||||
(walk (syntax-rearm result stx))))]
|
|
||||||
|
|
||||||
;; Extremely limited support for quasiquoting and quoting
|
;; Extremely limited support for quasiquoting and quoting
|
||||||
[(quasiquote (unquote p)) (walk #'p)]
|
[(quasiquote (unquote p)) (walk #'p)]
|
||||||
|
@ -231,6 +236,54 @@
|
||||||
[other
|
[other
|
||||||
'()])))
|
'()])))
|
||||||
|
|
||||||
|
(define (analyse-match-pattern stx)
|
||||||
|
(let walk ((stx stx))
|
||||||
|
(define disarmed-stx (syntax-disarm stx orig-insp))
|
||||||
|
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
||||||
|
[(ctor args ...)
|
||||||
|
(constructor-registered? #'ctor)
|
||||||
|
((free-id-table-ref preserves-pattern-registry #'ctor) 'match-pattern disarmed-stx)]
|
||||||
|
|
||||||
|
[(expander args ...)
|
||||||
|
(pattern-expander-id? #'expander)
|
||||||
|
(pattern-expander-transform disarmed-stx
|
||||||
|
(lambda (result) (walk (syntax-rearm result stx))))]
|
||||||
|
|
||||||
|
;; Extremely limited support for quasiquoting and quoting
|
||||||
|
[(quasiquote (unquote p)) (walk #'p)]
|
||||||
|
[(quasiquote (p ...)) (walk #'(list (quasiquote p) ...))]
|
||||||
|
[(quasiquote p) #''p]
|
||||||
|
[(quote p) #''p]
|
||||||
|
|
||||||
|
[(unquote p) (raise-syntax-error #f "Out-of-place unquote in match-pattern")]
|
||||||
|
|
||||||
|
[(ctor piece ...)
|
||||||
|
(struct-info? (id-value #'ctor))
|
||||||
|
#`(ctor (:parse piece) ...)]
|
||||||
|
|
||||||
|
[(list-stx piece ...)
|
||||||
|
(list-id? #'list-stx)
|
||||||
|
#`(list-stx (:parse piece) ...)]
|
||||||
|
|
||||||
|
[(hash-stx piece ...)
|
||||||
|
(hash-or-hasheqv-id? #'hash-stx)
|
||||||
|
#`(hash-table #,@(let loop ((pieces (syntax->list #'(piece ...))))
|
||||||
|
(match pieces
|
||||||
|
['() '()]
|
||||||
|
[(list* k v more) (list* k #`(:parse #,v) (loop more))]))
|
||||||
|
[_ _] ___)]
|
||||||
|
|
||||||
|
[(or-stx piece ...)
|
||||||
|
(and (identifier? #'or-stx) (free-identifier=? #'or #'or-stx))
|
||||||
|
#`(or (:parse piece) ...)]
|
||||||
|
|
||||||
|
[(and-stx piece ...)
|
||||||
|
(and (identifier? #'and-stx) (free-identifier=? #'and #'and-stx))
|
||||||
|
#`(and (:parse piece) ...)]
|
||||||
|
|
||||||
|
[other
|
||||||
|
#`other])))
|
||||||
|
|
||||||
(define (expand-:pattern stx)
|
(define (expand-:pattern stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ pat-stx atomic-literal-transformer)
|
[(_ pat-stx atomic-literal-transformer)
|
||||||
|
@ -252,6 +305,11 @@
|
||||||
(lambda (stx)
|
(lambda (stx)
|
||||||
(expand-:pattern stx)))
|
(expand-:pattern stx)))
|
||||||
|
|
||||||
|
(define-match-expander :parse
|
||||||
|
(lambda (stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ pat-stx) (analyse-match-pattern #'pat-stx)])))
|
||||||
|
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
(define (select-pattern-leaves desc capture-fn lit-fn)
|
(define (select-pattern-leaves desc capture-fn lit-fn)
|
||||||
|
|
|
@ -117,7 +117,10 @@
|
||||||
[_ #f])))
|
[_ #f])))
|
||||||
(if (not fields)
|
(if (not fields)
|
||||||
(k-nonrecord)
|
(k-nonrecord)
|
||||||
`(define-preserves-pattern ,top-name (,name ,@(map escape (map ty-field-name fields)))
|
`(define-preserves-pattern
|
||||||
|
,top-name
|
||||||
|
,(format-symbol "parse-~a" top-name)
|
||||||
|
(,name ,@(map escape (map ty-field-name fields)))
|
||||||
(quasisyntax ,(pat-pattern p))
|
(quasisyntax ,(pat-pattern p))
|
||||||
(append ,@(for/list [(f (in-list fields))]
|
(append ,@(for/list [(f (in-list fields))]
|
||||||
`(map ,(final-atom-destructurer (unwrap (ty-field-pattern f)))
|
`(map ,(final-atom-destructurer (unwrap (ty-field-pattern f)))
|
||||||
|
@ -126,16 +129,20 @@
|
||||||
|
|
||||||
(match def
|
(match def
|
||||||
[(Definition-or p0 p1 pN)
|
[(Definition-or p0 p1 pN)
|
||||||
`(begin ,@(for/list [(named-alt (in-list (list* p0 p1 pN)))
|
`(begin
|
||||||
(alt-ty (in-list (map ty-variant-type (ty-union-variants (definition-ty def)))))]
|
,@(for/list [(named-alt (in-list (list* p0 p1 pN)))
|
||||||
(match-define (NamedAlternative variant-label-str pattern) named-alt)
|
(alt-ty (in-list (map ty-variant-type (ty-union-variants (definition-ty def)))))]
|
||||||
(define full-name (format-symbol "~a-~a" name variant-label-str))
|
(match-define (NamedAlternative variant-label-str pattern) named-alt)
|
||||||
(top-pat name full-name pattern alt-ty
|
(define full-name (format-symbol "~a-~a" name variant-label-str))
|
||||||
(lambda ()
|
(top-pat name full-name pattern alt-ty
|
||||||
`(define-preserves-pattern ,name (,full-name value)
|
(lambda ()
|
||||||
(analyse-pattern #'value)
|
`(define-preserves-pattern
|
||||||
(map ,(final-atom-destructurer (unwrap pattern))
|
,name
|
||||||
(analyse-pattern-bindings (syntax value))))))))]
|
,(format-symbol "parse-~a" name)
|
||||||
|
(,full-name value)
|
||||||
|
(analyse-pattern #'value)
|
||||||
|
(map ,(final-atom-destructurer (unwrap pattern))
|
||||||
|
(analyse-pattern-bindings (syntax value))))))))]
|
||||||
[(? Definition-and?)
|
[(? Definition-and?)
|
||||||
`(begin)]
|
`(begin)]
|
||||||
[(Definition-Pattern p)
|
[(Definition-Pattern p)
|
||||||
|
|
|
@ -9,6 +9,7 @@
|
||||||
|
|
||||||
entity
|
entity
|
||||||
actor-system
|
actor-system
|
||||||
|
object
|
||||||
|
|
||||||
ref
|
ref
|
||||||
react
|
react
|
||||||
|
@ -20,6 +21,7 @@
|
||||||
sync!
|
sync!
|
||||||
send!
|
send!
|
||||||
spawn
|
spawn
|
||||||
|
spawn/link
|
||||||
|
|
||||||
begin/dataflow
|
begin/dataflow
|
||||||
define/dataflow
|
define/dataflow
|
||||||
|
@ -75,6 +77,73 @@
|
||||||
[(_ name:<name> expr ...)
|
[(_ name:<name> expr ...)
|
||||||
#'(actor:actor-system #:name name.N (lambda () expr ...))]))
|
#'(actor:actor-system #:name name.N (lambda () expr ...))]))
|
||||||
|
|
||||||
|
(define-syntax (object stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ name:<name> handler ...)
|
||||||
|
#`(let ((state (make-hash)))
|
||||||
|
(define (handler-function assertion)
|
||||||
|
(-object-clauses assertion [] [handler ...]))
|
||||||
|
(ref (entity #:name name.N
|
||||||
|
#:assert (lambda (m h) (-object-assert state handler-function m h))
|
||||||
|
#:retract (lambda (h) (-object-retract state h))
|
||||||
|
#:message (lambda (m) (-object-message handler-function m)))))]))
|
||||||
|
|
||||||
|
(define (-object-assert state handler-function assertion handle)
|
||||||
|
(define k (handler-function assertion))
|
||||||
|
(when k (hash-set! state handle k)))
|
||||||
|
|
||||||
|
(define (-object-retract state handle)
|
||||||
|
(define k (hash-ref state handle #f))
|
||||||
|
(when k
|
||||||
|
(hash-remove! state handle)
|
||||||
|
(k)))
|
||||||
|
|
||||||
|
(define (-object-message handler-function message)
|
||||||
|
(define k (handler-function message))
|
||||||
|
(when k
|
||||||
|
(k)))
|
||||||
|
|
||||||
|
(define-syntax (-object-clauses stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ input [completed ...] [])
|
||||||
|
#'(match input
|
||||||
|
completed ...
|
||||||
|
[_ #f])]
|
||||||
|
|
||||||
|
[(_ input [completed ...] [ [#:spawn pat body ...] more ... ])
|
||||||
|
#'(-object-clauses input
|
||||||
|
[completed ...]
|
||||||
|
[ [#:during pat (spawn/link body ...)] more ... ])]
|
||||||
|
|
||||||
|
[(_ input [completed ...] [ [#:asserted pat body+ ... #:retracted body- ...] more ... ])
|
||||||
|
#`(-object-clauses input
|
||||||
|
[ completed ... [(-object-pattern pat)
|
||||||
|
body+ ...
|
||||||
|
#,(if (null? (syntax->list #'(body- ...)))
|
||||||
|
#`#f
|
||||||
|
#`(lambda () body- ...))] ]
|
||||||
|
[more ...])]
|
||||||
|
|
||||||
|
[(_ input [completed ...] [ [#:asserted pat body+ ...] more ... ])
|
||||||
|
#'(-object-clauses input
|
||||||
|
[completed ...]
|
||||||
|
[ [#:asserted pat body+ ... #:retracted] more ... ])]
|
||||||
|
|
||||||
|
[(_ input [completed ...] [ [pat body ...] more ... ])
|
||||||
|
#'(-object-clauses input
|
||||||
|
[completed ...]
|
||||||
|
[ [#:asserted pat
|
||||||
|
(define f (react (facet-prevent-inert-check! this-facet) body ...))
|
||||||
|
#:retracted
|
||||||
|
(stop-facet f)]
|
||||||
|
more ... ])]))
|
||||||
|
|
||||||
|
(define-match-expander -object-pattern
|
||||||
|
(lambda (stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ pat-stx)
|
||||||
|
(analyse-match-pattern #'pat-stx)])))
|
||||||
|
|
||||||
(define (ref entity)
|
(define (ref entity)
|
||||||
(entity-ref this-facet entity '()))
|
(entity-ref this-facet entity '()))
|
||||||
|
|
||||||
|
@ -114,6 +183,21 @@
|
||||||
this-turn
|
this-turn
|
||||||
(lambda () setup-expr ...))]))
|
(lambda () setup-expr ...))]))
|
||||||
|
|
||||||
|
(define-syntax (spawn/link stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ name-stx:<name> daemon:<daemon?> setup-expr ...)
|
||||||
|
#`(begin
|
||||||
|
(define name name-stx.N)
|
||||||
|
(define monitor (ref (entity/stop-on-retract #:name (list name 'monitor-in-parent))))
|
||||||
|
(define monitor-handle (turn-assert! this-turn monitor 'alive))
|
||||||
|
(turn-spawn! this-turn
|
||||||
|
#:name name
|
||||||
|
#:daemon? daemon.D
|
||||||
|
#:link
|
||||||
|
(entity/stop-on-retract #:name (list name 'monitor-in-child))
|
||||||
|
(lambda () setup-expr ...)
|
||||||
|
(hasheq monitor-handle #t)))]))
|
||||||
|
|
||||||
(define-syntax-rule (begin/dataflow expr ...)
|
(define-syntax-rule (begin/dataflow expr ...)
|
||||||
(turn-dataflow! this-turn (lambda () expr ...)))
|
(turn-dataflow! this-turn (lambda () expr ...)))
|
||||||
|
|
||||||
|
@ -216,23 +300,10 @@
|
||||||
(lambda (stx)
|
(lambda (stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ pat name-stx:<name> daemon:<daemon?> expr ...)
|
[(_ pat name-stx:<name> daemon:<daemon?> expr ...)
|
||||||
#`(assert
|
#`(assert (Observe (:pattern pat)
|
||||||
(Observe (:pattern pat)
|
(ref (during* (lambda (bindings)
|
||||||
(ref (during*
|
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
|
||||||
(lambda (bindings)
|
(spawn/link #:name name-stx.N #:daemon? daemon.D expr ...))))))])))
|
||||||
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
|
|
||||||
(define name name-stx.N)
|
|
||||||
(define monitor
|
|
||||||
(ref (entity/stop-on-retract #:name (list name 'monitor-in-parent))))
|
|
||||||
(define monitor-handle (turn-assert! this-turn monitor 'alive))
|
|
||||||
(turn-spawn! this-turn
|
|
||||||
#:name name
|
|
||||||
#:daemon? daemon.D
|
|
||||||
#:link
|
|
||||||
(entity/stop-on-retract #:name
|
|
||||||
(list name 'monitor-in-child))
|
|
||||||
(lambda () expr ...)
|
|
||||||
(hasheq monitor-handle #t)))))))])))
|
|
||||||
|
|
||||||
(define (during* f #:name [name '?])
|
(define (during* f #:name [name '?])
|
||||||
(define assertion-map (make-hash))
|
(define assertion-map (make-hash))
|
||||||
|
@ -255,6 +326,7 @@
|
||||||
;;; Local Variables:
|
;;; Local Variables:
|
||||||
;;; eval: (put 'actor-system/dataspace 'racket-indent-function 1)
|
;;; eval: (put 'actor-system/dataspace 'racket-indent-function 1)
|
||||||
;;; eval: (put 'at 'racket-indent-function 1)
|
;;; eval: (put 'at 'racket-indent-function 1)
|
||||||
|
;;; eval: (put 'object 'racket-indent-function 0)
|
||||||
;;; eval: (put 'react 'racket-indent-function 0)
|
;;; eval: (put 'react 'racket-indent-function 0)
|
||||||
;;; eval: (put 'spawn 'racket-indent-function 0)
|
;;; eval: (put 'spawn 'racket-indent-function 0)
|
||||||
;;; eval: (put 'stop-when 'racket-indent-function 1)
|
;;; eval: (put 'stop-when 'racket-indent-function 1)
|
||||||
|
|
Loading…
Reference in New Issue