633445aebd6df810b59dba4c3eed9769c03c657b
[actors.git] / actors.scm
1 (import srfi-69 matchable)
2
3 (define trace-enabled #f)
4
5 ;;;
6 ;;; Actor creation
7 ;;;
8
9 (define actor-table (make-hash-table))
10
11 (define (make-actor-with-address address behaviour)
12   (hash-table-set! actor-table address behaviour)
13   address)
14
15 (define next-actor-address 1)
16
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))
21     address))
22
23 ;;;
24 ;;; Message dispatch
25 ;;;
26
27 (define (dispatch-message address message)
28   (if trace-enabled
29       (print "Dispatching message " message " to " address))
30   (let ((behaviour (hash-table-ref/default actor-table address '())))
31     (if (null? behaviour)
32         (print "Warning: discarded message " message " to unknown actor " address)
33         (let ((value (apply behaviour (cons address message))))
34           (case value
35             ((sleep) 'do-nothing)
36             ((done) (hash-table-delete! actor-table address))
37             (else
38              (if trace-enabled
39                  (print "Updating behaviour of " address))
40              (hash-table-set! actor-table address value)))))))
41
42 ;;;
43 ;;; FIFO queue implementation
44 ;;;
45
46 (define (make-fifo)
47   (define (cell val prev next)
48     (list val prev next))
49   (define cell-val car)
50   (define cell-prev cadr)
51   (define cell-next caddr)
52   (define (set-cell-prev! cell prev-cell)
53     (set-car! (cdr cell) prev-cell))
54   (define (set-cell-next! cell next-cell)
55     (set-car! (cddr cell) next-cell))
56
57   (let ((head '())
58         (tail '()))
59     (lambda (cmd . args)
60       (case cmd
61         ((empty?) (null? head))
62         ((push) (if (not (= (length args) 1))
63                     (error "Wrong number of arguments to push.")
64                     (if (not (null? head))
65                         (let ((old-head head))
66                           (set! head (cell (car args) '() old-head))
67                           (set-cell-prev! old-head head))
68                         (begin
69                           ;; Initialize list
70                           (set! head (cell (car args) '() '()))
71                           (set! tail head)))))
72         ((pop) (if (not (= (length args) 0))
73                    (error "Wrong number of arguments to pop.")
74                    (if (null? head)
75                        (error "FIFO empty.")
76                        (let ((old-tail tail))
77                          (set! tail (cell-prev old-tail))
78                          (if (null? tail)
79                              (set! head '())
80                              (set-cell-next! tail '()))
81                          (cell-val old-tail)))))))))
82
83 (define (fifo-push fifo x)
84   (fifo 'push x))
85
86 (define (fifo-pop fifo)
87   (fifo 'pop))
88
89 (define (fifo-empty? fifo)
90   (fifo 'empty?))
91
92
93 ;;;
94 ;;; Message queue
95 ;;;
96
97 (define message-queue (make-fifo))
98
99 (define (next-addressed-msg)
100   (if (fifo-empty? message-queue)
101       '()
102       (fifo-pop message-queue)))
103
104 (define (send-message actor . message)
105   (if trace-enabled
106       (print "Queued message " message " to " actor))
107   (fifo-push message-queue (cons actor message)))
108
109 (define (process-next-message)
110   (let ((addressed-msg (next-addressed-msg)))
111     (if (null? addressed-msg)
112         '()
113         (let ((address (car addressed-msg))
114               (message (cdr addressed-msg)))
115           (dispatch-message address message)))))
116
117 (define (run)
118   (unless (null? (process-next-message))
119     (run)))
120
121 (define (send-and-run actor . message)
122   (apply send-message (cons actor message))
123   (run))