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

Fix bug where #:when-disabled on-message endpoints were processing 

events even when "disabled".
This commit is contained in:
Tony Garnock-Jones 2016-09-25 15:06:22 -04:00
parent 4ea2586666
commit d00f0cbf13
1 changed files with 58 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

111
racket/syndicate/actor.rkt
View File

@ -410,7 +410,7 @@
(define (on-event* where proc #:priority [priority *normal-priority*]) (define (on-event* where proc #:priority [priority *normal-priority*])
(add-endpoint! where (add-endpoint! where
(lambda () patch-empty) (lambda () patch-empty)
(lambda (e _synthetic?) (lambda (e _current-interests _synthetic?)
(schedule-script! #:priority priority #f (lambda () (proc e)))))) (schedule-script! #:priority priority #f (lambda () (proc e))))))
(define-syntax (on stx) (define-syntax (on stx)
@ -468,9 +468,11 @@
(define-syntax (define/dataflow stx) (define-syntax (define/dataflow stx)
(syntax-parse stx (syntax-parse stx
[(_ fieldname expr) [(_ fieldname expr)
(quasisyntax/loc stx (define/dataflow fieldname expr #:default #f))]
[(_ fieldname expr #:default default-expr)
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
(field [fieldname #f]) (field [fieldname default-expr])
(begin/dataflow (fieldname expr))))])) (begin/dataflow (fieldname expr))))]))
(define-syntax (asserted stx) (raise-syntax-error #f "asserted: Used outside event spec" stx)) (define-syntax (asserted stx) (raise-syntax-error #f "asserted: Used outside event spec" stx))
@ -669,42 +671,43 @@
(lambda () (if #,when-pred-stx (lambda () (if #,when-pred-stx
(core:sub #,pat) (core:sub #,pat)
patch-empty)) patch-empty))
(lambda (e synthetic?) (lambda (e current-interests synthetic?)
(core:match-event e (when (not (trie-empty? current-interests))
[(? #,event-predicate-stx p) (core:match-event e
(define proj #,proj-stx) [(? #,event-predicate-stx p)
(define proj-arity (projection-arity proj)) (define proj #,proj-stx)
(define entry-set (trie-project/set #:take proj-arity (define proj-arity (projection-arity proj))
(#,patch-accessor-stx p) (define entry-set (trie-project/set #:take proj-arity
proj)) (#,patch-accessor-stx p)
(when (not entry-set) proj))
(error 'asserted (when (not entry-set)
"Wildcard interest discovered while projecting by ~v at ~a" (error 'asserted
proj "Wildcard interest discovered while projecting by ~v at ~a"
#,(source-location->string P-stx))) proj
#,(let ((entry-handler-stx #,(source-location->string P-stx)))
(quasisyntax/loc script-stx #,(let ((entry-handler-stx
(let ((instantiated (instantiate-projection proj entry))) (quasisyntax/loc script-stx
(and (#,change-detector-stx instantiated synthetic?) (let ((instantiated (instantiate-projection proj entry)))
(schedule-script! (and (#,change-detector-stx instantiated synthetic?)
#:priority #,priority-stx (schedule-script!
#,(if terminal? #'#t #'#f) #:priority #,priority-stx
(lambda () #,(if terminal? #'#t #'#f)
(match-define (list #,@bindings) entry) (lambda ()
#,script-stx))))))) (match-define (list #,@bindings) entry)
(if terminal? #,script-stx)))))))
#`(let ((entry-count (set-count entry-set))) (if terminal?
(cond #`(let ((entry-count (set-count entry-set)))
[(zero? entry-count)] (cond
[(= entry-count 1) [(zero? entry-count)]
(let ((entry (set-first entry-set))) [(= entry-count 1)
#,entry-handler-stx)] (let ((entry (set-first entry-set)))
[else #,entry-handler-stx)]
(error 'asserted [else
"Multiple assertions triggered stop-when at ~a" (error 'asserted
#,(source-location->string P-stx))])) "Multiple assertions triggered stop-when at ~a"
#`(for [(entry (in-set entry-set))] #,(source-location->string P-stx))]))
#,entry-handler-stx)))]))))) #`(for [(entry (in-set entry-set))]
#,entry-handler-stx)))]))))))
(define-for-syntax orig-insp (define-for-syntax orig-insp
(variable-reference->module-declaration-inspector (#%variable-reference))) (variable-reference->module-declaration-inspector (#%variable-reference)))
@ -737,20 +740,21 @@
(lambda () (if #,when-pred-stx (lambda () (if #,when-pred-stx
(core:sub #,pat) (core:sub #,pat)
patch-empty)) patch-empty))
(lambda (e _synthetic?) (lambda (e current-interests _synthetic?)
(core:match-event e (when (not (trie-empty? current-interests))
[(core:message body) (core:match-event e
(define capture-vals [(core:message body)
(match-value/captures (define capture-vals
body (match-value/captures
#,proj)) body
(and capture-vals #,proj))
(schedule-script! (and capture-vals
#:priority #,priority-stx (schedule-script!
#,(if terminal? #'#t #'#f) #:priority #,priority-stx
(lambda () #,(if terminal? #'#t #'#f)
(apply (lambda #,bindings #,script-stx) (lambda ()
capture-vals))))]))))] (apply (lambda #,bindings #,script-stx)
capture-vals))))])))))]
[(asserted P) [(asserted P)
(analyze-asserted/retracted outer-expr-stx when-pred-stx event-stx terminal? script-stx (analyze-asserted/retracted outer-expr-stx when-pred-stx event-stx terminal? script-stx
#t #'P priority-stx)] #t #'P priority-stx)]
@ -1087,9 +1091,10 @@
(run-scripts!)))) (run-scripts!))))
(define (facet-handle-event! fid f e synthetic?) (define (facet-handle-event! fid f e synthetic?)
(define mux (actor-state-mux (current-actor-state)))
(with-current-facet fid (facet-field-descriptors f) #f (with-current-facet fid (facet-field-descriptors f) #f
(for [(ep (in-hash-values (facet-endpoints f)))] (for [(ep (in-hash-values (facet-endpoints f)))]
((endpoint-handler-fn ep) e synthetic?)))) ((endpoint-handler-fn ep) e (mux-interests-of mux (endpoint-id ep)) synthetic?))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Script suspend-and-resume. ;; Script suspend-and-resume.