observe-gestalt
This commit is contained in:
parent
20a50967c5
commit
d991ad934f
|
@ -7,6 +7,7 @@
|
||||||
;; all the free variables in the actor.
|
;; all the free variables in the actor.
|
||||||
|
|
||||||
(provide actor
|
(provide actor
|
||||||
|
observe-gestalt
|
||||||
observe-subscribers
|
observe-subscribers
|
||||||
observe-advertisers
|
observe-advertisers
|
||||||
advertise
|
advertise
|
||||||
|
@ -39,6 +40,7 @@
|
||||||
[(_ forms ...)
|
[(_ forms ...)
|
||||||
(analyze-actor #'(forms ...))]))
|
(analyze-actor #'(forms ...))]))
|
||||||
|
|
||||||
|
(define-syntax (observe-gestalt stx) (raise-syntax-error #f "Use of observe-gestalt outside actor form" stx))
|
||||||
(define-syntax (observe-subscribers stx) (raise-syntax-error #f "Use of observe-subscribers outside actor form" stx))
|
(define-syntax (observe-subscribers stx) (raise-syntax-error #f "Use of observe-subscribers outside actor form" stx))
|
||||||
(define-syntax (observe-advertisers stx) (raise-syntax-error #f "Use of observe-advertisers outside actor form" stx))
|
(define-syntax (observe-advertisers stx) (raise-syntax-error #f "Use of observe-advertisers outside actor form" stx))
|
||||||
(define-syntax (advertise stx) (raise-syntax-error #f "Use of advertise outside actor form" stx))
|
(define-syntax (advertise stx) (raise-syntax-error #f "Use of advertise outside actor form" stx))
|
||||||
|
@ -179,7 +181,8 @@
|
||||||
(push! body-forms #`(define #,statetemp-stx #,stateexp-stx)))
|
(push! body-forms #`(define #,statetemp-stx #,stateexp-stx)))
|
||||||
|
|
||||||
(define (walk-forms forms-stx)
|
(define (walk-forms forms-stx)
|
||||||
(syntax-case forms-stx (observe-subscribers
|
(syntax-case forms-stx (observe-gestalt
|
||||||
|
observe-subscribers
|
||||||
observe-advertisers
|
observe-advertisers
|
||||||
advertise
|
advertise
|
||||||
subscribe
|
subscribe
|
||||||
|
@ -202,6 +205,10 @@
|
||||||
(push-statevar! #'statevar statetemp #'stateexp)
|
(push-statevar! #'statevar statetemp #'stateexp)
|
||||||
(walk-forms #'(rest ...)))]
|
(walk-forms #'(rest ...)))]
|
||||||
|
|
||||||
|
[((observe-gestalt g [pattern body ...] ...) rest ...)
|
||||||
|
(begin (analyze-general-observer! #'g #'([pattern (begin-transition body ...)] ...))
|
||||||
|
(walk-forms #'(rest ...)))]
|
||||||
|
|
||||||
[((observe-subscribers pat body ...) rest ...)
|
[((observe-subscribers pat body ...) rest ...)
|
||||||
(begin (analyze-observation! #'pat #'(body ...) #t)
|
(begin (analyze-observation! #'pat #'(body ...) #t)
|
||||||
(walk-forms #'(rest ...)))]
|
(walk-forms #'(rest ...)))]
|
||||||
|
@ -273,6 +280,31 @@
|
||||||
[#:when participator-condition condition]
|
[#:when participator-condition condition]
|
||||||
[#:meta-level participator-meta-level meta-level]))
|
[#:meta-level participator-meta-level meta-level]))
|
||||||
|
|
||||||
|
(define (analyze-general-observer! gestalt-stx event-handler-clauses-stx)
|
||||||
|
(define-temporaries
|
||||||
|
[gestalt-name0 #'general]
|
||||||
|
[gestalt-init gestalt-stx])
|
||||||
|
(define gestalt-name (identifier-append gestalt-stx 'gestalt: gestalt-name0))
|
||||||
|
(push-statevar! gestalt-name gestalt-init #'#f)
|
||||||
|
|
||||||
|
(push! gestalt-updaters
|
||||||
|
#`(begin
|
||||||
|
(define #,gestalt-init #,gestalt-stx)
|
||||||
|
#:update [#,gestalt-name #,gestalt-init]))
|
||||||
|
|
||||||
|
(push! gestalt-fragments gestalt-name)
|
||||||
|
|
||||||
|
(push! event-handlers
|
||||||
|
(lambda (e-stx)
|
||||||
|
#`(match-state state
|
||||||
|
(let ((filtered-event (filter-event #,e-stx #,gestalt-name)))
|
||||||
|
(if (not filtered-event)
|
||||||
|
#f
|
||||||
|
((match filtered-event
|
||||||
|
#,@event-handler-clauses-stx
|
||||||
|
[_ #f])
|
||||||
|
state)))))))
|
||||||
|
|
||||||
(define (analyze-observation! pat-stx body-stx pub?)
|
(define (analyze-observation! pat-stx body-stx pub?)
|
||||||
(define-values (o remaining-stx)
|
(define-values (o remaining-stx)
|
||||||
(analyze-observer-body body-stx (observer #f #f #f #f #f #f #f #f)))
|
(analyze-observer-body body-stx (observer #f #f #f #f #f #f #f #f)))
|
||||||
|
@ -538,6 +570,7 @@
|
||||||
|
|
||||||
;;; Local Variables:
|
;;; Local Variables:
|
||||||
;;; eval: (put 'begin-transition 'scheme-indent-function 0)
|
;;; eval: (put 'begin-transition 'scheme-indent-function 0)
|
||||||
|
;;; eval: (put 'observe-gestalt 'scheme-indent-function 1)
|
||||||
;;; eval: (put 'observe-subscribers 'scheme-indent-function 1)
|
;;; eval: (put 'observe-subscribers 'scheme-indent-function 1)
|
||||||
;;; eval: (put 'observe-advertisers 'scheme-indent-function 1)
|
;;; eval: (put 'observe-advertisers 'scheme-indent-function 1)
|
||||||
;;; eval: (put 'subscribe 'scheme-indent-function 1)
|
;;; eval: (put 'subscribe 'scheme-indent-function 1)
|
||||||
|
|
Loading…
Reference in New Issue