Introduce level-anchor and level-anchor->meta-level
This commit is contained in:
parent
5aebc7fa75
commit
cecb261c6b
|
@ -5,5 +5,7 @@
|
||||||
assert
|
assert
|
||||||
))
|
))
|
||||||
(require "actor.rkt")
|
(require "actor.rkt")
|
||||||
|
(require "hierarchy.rkt")
|
||||||
(provide (all-from-out "lang.rkt")
|
(provide (all-from-out "lang.rkt")
|
||||||
(all-from-out "actor.rkt"))
|
(all-from-out "actor.rkt")
|
||||||
|
(all-from-out "hierarchy.rkt"))
|
||||||
|
|
|
@ -249,7 +249,7 @@
|
||||||
(pattern (~seq) #:attr Pred #'#t))
|
(pattern (~seq) #:attr Pred #'#t))
|
||||||
|
|
||||||
(define-splicing-syntax-class meta-level
|
(define-splicing-syntax-class meta-level
|
||||||
(pattern (~seq #:meta-level level:integer))
|
(pattern (~seq #:meta-level level:expr))
|
||||||
(pattern (~seq) #:attr level #'0))
|
(pattern (~seq) #:attr level #'0))
|
||||||
|
|
||||||
(define-splicing-syntax-class priority
|
(define-splicing-syntax-class priority
|
||||||
|
@ -637,11 +637,6 @@
|
||||||
#`(for [(entry (in-set entry-set))]
|
#`(for [(entry (in-set entry-set))]
|
||||||
#,entry-handler-stx)))])))))
|
#,entry-handler-stx)))])))))
|
||||||
|
|
||||||
(define-for-syntax (prepend-at-meta-stx stx level)
|
|
||||||
(if (zero? level)
|
|
||||||
stx
|
|
||||||
#`(at-meta #,(prepend-at-meta-stx stx (- level 1)))))
|
|
||||||
|
|
||||||
(define-for-syntax (analyze-event outer-expr-stx event-stx terminal? script-stx priority-stx)
|
(define-for-syntax (analyze-event outer-expr-stx event-stx terminal? script-stx priority-stx)
|
||||||
(syntax-parse event-stx
|
(syntax-parse event-stx
|
||||||
#:literals [core:message asserted retracted rising-edge]
|
#:literals [core:message asserted retracted rising-edge]
|
||||||
|
@ -657,7 +652,7 @@
|
||||||
(define capture-vals
|
(define capture-vals
|
||||||
(match-value/captures
|
(match-value/captures
|
||||||
body
|
body
|
||||||
#,(prepend-at-meta-stx proj (syntax-e #'L.level))))
|
(core:prepend-at-meta #,proj L.level)))
|
||||||
(and capture-vals
|
(and capture-vals
|
||||||
(schedule-script!
|
(schedule-script!
|
||||||
#:priority #,priority-stx
|
#:priority #,priority-stx
|
||||||
|
|
|
@ -56,11 +56,16 @@
|
||||||
(send! 'dump)
|
(send! 'dump)
|
||||||
(forever))
|
(forever))
|
||||||
|
|
||||||
(dataspace (actor #:name 'observer-in-ds
|
(let ((anchor (level-anchor)))
|
||||||
(forever
|
(dataspace (define LEVEL (level-anchor->meta-level anchor))
|
||||||
(assert 'observer-in-ds-ready #:meta-level 1)
|
(log-info "Outer level anchor: ~a" anchor)
|
||||||
(on-start (log-info "observer-in-ds: STARTING"))
|
(log-info "Inner level anchor: ~a" (level-anchor))
|
||||||
(define/query-set items `(item ,$a ,$b) #:meta-level 1 (list a b))
|
(log-info "Computed meta-level: ~v" LEVEL)
|
||||||
(on (message 'dump #:meta-level 1)
|
(actor #:name 'observer-in-ds
|
||||||
(log-info "observer-in-ds: ~v" (items)))))
|
(forever
|
||||||
(forever))
|
(assert 'observer-in-ds-ready #:meta-level LEVEL)
|
||||||
|
(on-start (log-info "observer-in-ds: STARTING"))
|
||||||
|
(define/query-set items `(item ,$a ,$b) #:meta-level LEVEL (list a b))
|
||||||
|
(on (message 'dump #:meta-level LEVEL)
|
||||||
|
(log-info "observer-in-ds: ~v" (items)))))
|
||||||
|
(forever)))
|
||||||
|
|
|
@ -7,7 +7,9 @@
|
||||||
target-event
|
target-event
|
||||||
current-actor-path-rev
|
current-actor-path-rev
|
||||||
current-actor-path
|
current-actor-path
|
||||||
call/extended-actor-path)
|
call/extended-actor-path
|
||||||
|
level-anchor
|
||||||
|
level-anchor->meta-level)
|
||||||
|
|
||||||
;; An event destined for a particular node in the actor hierarchy.
|
;; An event destined for a particular node in the actor hierarchy.
|
||||||
;; Used to inject events from the outside world.
|
;; Used to inject events from the outside world.
|
||||||
|
@ -34,3 +36,29 @@
|
||||||
(define (call/extended-actor-path pid thunk)
|
(define (call/extended-actor-path pid thunk)
|
||||||
(parameterize ((current-actor-path-rev (cons pid (current-actor-path-rev))))
|
(parameterize ((current-actor-path-rev (cons pid (current-actor-path-rev))))
|
||||||
(thunk)))
|
(thunk)))
|
||||||
|
|
||||||
|
;; Retrieves an abstract value to be used with level-anchor->meta-level to compute a
|
||||||
|
;; relative meta-level number. Concretely, is the actor path to the current actor's
|
||||||
|
;; dataspace.
|
||||||
|
;;
|
||||||
|
;; TODO: Once dataspaces are split into mux and relay, this will need to change to count
|
||||||
|
;; just relay steps.
|
||||||
|
(define (level-anchor)
|
||||||
|
(if (null? (current-actor-path-rev)) ;; outside even ground
|
||||||
|
'()
|
||||||
|
(reverse (cdr (current-actor-path-rev)))))
|
||||||
|
|
||||||
|
;; Computes the number of nesting levels between the current actor's dataspace and the
|
||||||
|
;; dataspace path passed in.
|
||||||
|
(define (level-anchor->meta-level anchor)
|
||||||
|
(define ds-path (level-anchor))
|
||||||
|
(let loop ((outer anchor) (inner ds-path))
|
||||||
|
(cond
|
||||||
|
[(null? outer) (length inner)]
|
||||||
|
[(and (pair? inner)
|
||||||
|
(equal? (car outer) (car inner)))
|
||||||
|
(loop (cdr outer) (cdr inner))]
|
||||||
|
[else (error 'level-anchor->meta-level
|
||||||
|
"Attempt to access dataspace ~a from non-contained dataspace ~a"
|
||||||
|
anchor
|
||||||
|
ds-path)])))
|
||||||
|
|
Loading…
Reference in New Issue