Initial commit.

diff --git a/actors.scm b/actors.scm
new file mode 100644 (file)
index 0000000..b8e52a8
--- /dev/null
+++ b/actors.scm
@@ -0,0 +1,105 @@
+(import srfi-69 matchable)
+
+;;;
+;;; Actor creation
+;;;
+
+(define actor-table (make-hash-table))
+
+(define (make-actor-with-address address behaviour)
+  (hash-table-set! actor-table address behaviour)
+  address)
+
+(define next-actor-address 1)
+
+(define (make-actor behaviour)
+  (make-actor-with-id next-actor-address behaviour)
+  (let ((address next-actor-address))
+    (set! next-actor-address (+ next-actor-address 1))
+    address))
+
+;;;
+;;; Message dispatch
+;;;
+
+(define (dispatch-message address message)
+  (let ((behaviour (hash-table-ref actor-table address)))
+    (unless (null? behaviour)
+      ((hash-table-ref actor-table address)))) message)
+
+;;;
+;;; FIFO queue implementation
+;;;
+
+(define (make-fifo)
+  (define (cell val prev next)
+    (list val prev next))
+  (define cell-val car)
+  (define cell-prev cadr)
+  (define cell-next caddr)
+  (define (set-cell-prev! cell prev-cell)
+    (set-car! (cdr cell) prev-cell))
+  (define (set-cell-next! cell next-cell)
+    (set-car! (cddr cell) next-cell))
+
+  (let ((head '())
+        (tail '()))
+    (lambda (cmd . args)
+      (case cmd
+        ((empty?) (null? head))
+        ((push) (if (not (= (length args) 1))
+                    (error "Wrong number of arguments to push.")
+                    (if (not (null? head))
+                        (let ((old-head head))
+                          (set! head (cell (car args) '() old-head))
+                          (set-cell-prev! old-head head))
+                        (begin
+                          ;; Initialize list
+                          (set! head (cell (car args) '() '()))
+                          (set! tail head)))))
+        ((pop) (if (not (= (length args) 0))
+                   (error "Wrong number of arguments to pop.")
+                   (if (null? head)
+                       (error "FIFO empty.")
+                       (let ((old-tail tail))
+                         (set! tail (cell-prev old-tail))
+                         (if (null? tail)
+                             (set! head '())
+                             (set-cell-next! tail '()))
+                         (cell-val old-tail)))))))))
+
+(define (fifo-push fifo x)
+  (fifo 'push x))
+
+(define (fifo-pop fifo)
+  (fifo 'pop))
+
+(define (fifo-empty? fifo)
+  (fifo 'empty?))
+
+
+;;;
+;;; Message queue
+;;;
+
+(define message-queue (make-fifo))
+
+(define (next-addressed-msg)
+  (if (fifo-empty? message-queue)
+      '()
+      (fifo-pop message-queue)))
+
+(define (send-message actor message)
+  (fifo-push message-queue (cons actor message)))
+
+(define (run)
+  (let ((addressed-msg (next-addressed-msg)))
+    (if (null? msg)
+        'done
+        (begin
+          (apply dispatch-message addressed-msg)
+          (run)))))
+
+;;;
+;;; Send
+;;;