Introduce level-anchor and level-anchor->meta-level
This commit is contained in:
parent
5aebc7fa75
commit
cecb261c6b
|
@ -5,5 +5,7 @@
|
|||
assert
|
||||
))
|
||||
(require "actor.rkt")
|
||||
(require "hierarchy.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))
|
||||
|
||||
(define-splicing-syntax-class meta-level
|
||||
(pattern (~seq #:meta-level level:integer))
|
||||
(pattern (~seq #:meta-level level:expr))
|
||||
(pattern (~seq) #:attr level #'0))
|
||||
|
||||
(define-splicing-syntax-class priority
|
||||
|
@ -637,11 +637,6 @@
|
|||
#`(for [(entry (in-set entry-set))]
|
||||
#,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)
|
||||
(syntax-parse event-stx
|
||||
#:literals [core:message asserted retracted rising-edge]
|
||||
|
@ -657,7 +652,7 @@
|
|||
(define capture-vals
|
||||
(match-value/captures
|
||||
body
|
||||
#,(prepend-at-meta-stx proj (syntax-e #'L.level))))
|
||||
(core:prepend-at-meta #,proj L.level)))
|
||||
(and capture-vals
|
||||
(schedule-script!
|
||||
#:priority #,priority-stx
|
||||
|
|
|
@ -56,11 +56,16 @@
|
|||
(send! 'dump)
|
||||
(forever))
|
||||
|
||||
(dataspace (actor #:name 'observer-in-ds
|
||||
(forever
|
||||
(assert 'observer-in-ds-ready #:meta-level 1)
|
||||
(on-start (log-info "observer-in-ds: STARTING"))
|
||||
(define/query-set items `(item ,$a ,$b) #:meta-level 1 (list a b))
|
||||
(on (message 'dump #:meta-level 1)
|
||||
(log-info "observer-in-ds: ~v" (items)))))
|
||||
(forever))
|
||||
(let ((anchor (level-anchor)))
|
||||
(dataspace (define LEVEL (level-anchor->meta-level anchor))
|
||||
(log-info "Outer level anchor: ~a" anchor)
|
||||
(log-info "Inner level anchor: ~a" (level-anchor))
|
||||
(log-info "Computed meta-level: ~v" LEVEL)
|
||||
(actor #:name 'observer-in-ds
|
||||
(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
|
||||
current-actor-path-rev
|
||||
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.
|
||||
;; Used to inject events from the outside world.
|
||||
|
@ -34,3 +36,29 @@
|
|||
(define (call/extended-actor-path pid thunk)
|
||||
(parameterize ((current-actor-path-rev (cons pid (current-actor-path-rev))))
|
||||
(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