From: Tim Vaughan Date: Sat, 6 Jul 2019 22:58:53 +0000 (+0200) Subject: Initial commit. X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=02d417662aac86f8fba65a69bef8b6cc5923becd;p=actors.git Initial commit. --- 02d417662aac86f8fba65a69bef8b6cc5923becd diff --git a/actors.scm b/actors.scm new file mode 100644 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 +;;;