syndicate-lang
/
racket-matrix-2012
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Support debug-names for bindings

This commit is contained in:
Tony Garnock-Jones 2012-03-11 13:06:54 -04:00
parent bab1beb5ec
commit ee6731a9b5
1 changed files with 14 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
presence/conversation.rkt
View File

@ -54,7 +54,8 @@
;; *both* topic when seen as predicates. The remaining variables are
;; again to be interpreted as universally quantified.
(struct join-message (member-to-room ;; sync channel
(struct join-message (debug-name ;; any
member-to-room ;; sync channel
room-to-member ;; sync channel
disconnect-box ;; blocking-box
member-thread ;; thread
@ -66,7 +67,8 @@
(struct room-state (name ch members) #:transparent)
(struct route (local-topic remote-topic remote-binding) #:transparent)
(struct binding ([topics #:mutable] ;; set of advertised topics
(struct binding (debug-name ;; any
[topics #:mutable] ;; set of advertised topics
[flows #:mutable] ;; map from signalled (i.e. non-virtual) flow to ref count
[routes #:mutable] ;; map from flow to set of route
in-ch ;; sync channel
@ -88,16 +90,18 @@
(thread (lambda () (room-main (room-state name ch '()))))
(room name ch))
(define (join-room room)
(make-object membership% (room-ch room)))
(define (join-room room [debug-name-base 'handle])
(make-object membership% (room-ch room) (gensym debug-name-base)))
(define membership%
(class* object% ()
(init room-init)
(init debug-name-init)
(super-new)
(define room room-init)
(define debug-name debug-name-init)
(define names (set)) ;; set of all our advertised topics
(define flows (set)) ;; set of all current flows
(define in-ch (make-channel))
@ -111,7 +115,7 @@
(set! connected #f)
(set! reason v)
v)))
(channel-put room (join-message out-ch in-ch disconnect-box
(channel-put room (join-message debug-name out-ch in-ch disconnect-box
(current-thread)
(current-thread-exit-status)))
@ -217,8 +221,9 @@
(define ((join-message-handler message) state)
(match message
[(join-message in-ch out-ch disconnect-box thread exit-status)
(define b (binding (set)
[(join-message debug-name in-ch out-ch disconnect-box thread exit-status)
(define b (binding debug-name
(set)
(hash)
(hash)
in-ch
@ -318,7 +323,7 @@
(set-binding-topics! b (set-remove (binding-topics b) departing-topic))))
(define (((handle-binding-message b) message) state)
;;(write `(considering ,message from ,(binding-name b))) (newline)
;;(write `(considering ,message from ,(binding-debug-name b))) (newline)
(match message
[(leave-message why)
(part state b why)]
@ -357,5 +362,5 @@
(define (enqueue-message! b message)
(define qb (binding-queue-box b))
;;(write `(enqueued ,message for ,(binding-name b))) (newline)
;;(write `(enqueued ,message for ,(binding-debug-name b))) (newline)
(set-box! qb (enqueue (unbox qb) message)))