actors.scm

   1 (import srfi-69 matchable)
   2
   3 ;;;
   4 ;;; Actor creation
   5 ;;;
   6
   7 (define actor-table (make-hash-table))
   8
   9 (define (make-actor-with-address address behaviour)
  10   (hash-table-set! actor-table address behaviour)
  11   address)
  12
  13 (define next-actor-address 1)
  14
  15 (define (make-actor behaviour)
  16   (make-actor-with-id next-actor-address behaviour)
  17   (let ((address next-actor-address))
  18     (set! next-actor-address (+ next-actor-address 1))
  19     address))
  20
  21 ;;;
  22 ;;; Message dispatch
  23 ;;;
  24
  25 (define (dispatch-message address message)
  26   (let ((behaviour (hash-table-ref actor-table address)))
  27     (unless (null? behaviour)
  28       ((hash-table-ref actor-table address)))) message)
  29
  30 ;;;
  31 ;;; FIFO queue implementation
  32 ;;;
  33
  34 (define (make-fifo)
  35   (define (cell val prev next)
  36     (list val prev next))
  37   (define cell-val car)
  38   (define cell-prev cadr)
  39   (define cell-next caddr)
  40   (define (set-cell-prev! cell prev-cell)
  41     (set-car! (cdr cell) prev-cell))
  42   (define (set-cell-next! cell next-cell)
  43     (set-car! (cddr cell) next-cell))
  44
  45   (let ((head '())
  46         (tail '()))
  47     (lambda (cmd . args)
  48       (case cmd
  49         ((empty?) (null? head))
  50         ((push) (if (not (= (length args) 1))
  51                     (error "Wrong number of arguments to push.")
  52                     (if (not (null? head))
  53                         (let ((old-head head))
  54                           (set! head (cell (car args) '() old-head))
  55                           (set-cell-prev! old-head head))
  56                         (begin
  57                           ;; Initialize list
  58                           (set! head (cell (car args) '() '()))
  59                           (set! tail head)))))
  60         ((pop) (if (not (= (length args) 0))
  61                    (error "Wrong number of arguments to pop.")
  62                    (if (null? head)
  63                        (error "FIFO empty.")
  64                        (let ((old-tail tail))
  65                          (set! tail (cell-prev old-tail))
  66                          (if (null? tail)
  67                              (set! head '())
  68                              (set-cell-next! tail '()))
  69                          (cell-val old-tail)))))))))
  70
  71 (define (fifo-push fifo x)
  72   (fifo 'push x))
  73
  74 (define (fifo-pop fifo)
  75   (fifo 'pop))
  76
  77 (define (fifo-empty? fifo)
  78   (fifo 'empty?))
  79
  80
  81 ;;;
  82 ;;; Message queue
  83 ;;;
  84
  85 (define message-queue (make-fifo))
  86
  87 (define (next-addressed-msg)
  88   (if (fifo-empty? message-queue)
  89       '()
  90       (fifo-pop message-queue)))
  91
  92 (define (send-message actor message)
  93   (fifo-push message-queue (cons actor message)))
  94
  95 (define (run)
  96   (let ((addressed-msg (next-addressed-msg)))
  97     (if (null? msg)
  98         'done
  99         (begin
 100           (apply dispatch-message addressed-msg)
 101           (run)))))
 102
 103 ;;;
 104 ;;; Send
 105 ;;;