1 (import srfi-69 matchable)
3 (define trace-enabled #t)
9 (define actor-table (make-hash-table))
11 (define (make-actor-with-address address behaviour)
12 (hash-table-set! actor-table address behaviour)
15 (define next-actor-address 1)
17 (define (make-actor behaviour)
18 (make-actor-with-address next-actor-address behaviour)
19 (let ((address next-actor-address))
20 (set! next-actor-address (+ next-actor-address 1))
27 (define (dispatch-message address message)
29 (print "Dispatching message " message " to " address))
30 (let ((behaviour (hash-table-ref/default actor-table address '())))
32 (print "Warning: discarded message " message " to unknown actor " address)
33 (let ((value (apply behaviour (cons address message))))
35 ('done (hash-table-delete! actor-table address))
38 hash-table-set! actor-table address value))))))
41 ;;; FIFO queue implementation
45 (define (cell val prev next)
48 (define cell-prev cadr)
49 (define cell-next caddr)
50 (define (set-cell-prev! cell prev-cell)
51 (set-car! (cdr cell) prev-cell))
52 (define (set-cell-next! cell next-cell)
53 (set-car! (cddr cell) next-cell))
59 ((empty?) (null? head))
60 ((push) (if (not (= (length args) 1))
61 (error "Wrong number of arguments to push.")
62 (if (not (null? head))
63 (let ((old-head head))
64 (set! head (cell (car args) '() old-head))
65 (set-cell-prev! old-head head))
68 (set! head (cell (car args) '() '()))
70 ((pop) (if (not (= (length args) 0))
71 (error "Wrong number of arguments to pop.")
74 (let ((old-tail tail))
75 (set! tail (cell-prev old-tail))
78 (set-cell-next! tail '()))
79 (cell-val old-tail)))))))))
81 (define (fifo-push fifo x)
84 (define (fifo-pop fifo)
87 (define (fifo-empty? fifo)
95 (define message-queue (make-fifo))
97 (define (next-addressed-msg)
98 (if (fifo-empty? message-queue)
100 (fifo-pop message-queue)))
102 (define (send-message actor . message)
104 (print "Queued message " message " to " actor))
105 (fifo-push message-queue (cons actor message)))
107 (define (process-next-message)
108 (let ((addressed-msg (next-addressed-msg)))
109 (if (null? addressed-msg)
111 (let ((address (car addressed-msg))
112 (message (cdr addressed-msg)))
113 (dispatch-message address message)))))
116 (unless (null? (process-next-message))
119 (define (send-and-run actor . message)
120 (apply send-message (cons actor message))
128 (make-actor-with-address 'factorial
129 (lambda (self customer . message)
131 ((n) (send-message self customer n 1) 'sleep)
132 ((0 acc) (send-message customer acc) 'done)
133 ((n acc) (send-message self customer (- n 1) (* acc n)) 'sleep)))))
136 (make-actor-with-address 'println
137 (lambda (self . message)
138 (apply print message)
141 (send-message factorial println 5)
142 (send-message factorial println 7)