%.so: %.scm
csc -s -J $<
-sam: sam.scm fifo.so
+sam: sam.scm fifo.so sam-macros.so
csc sam.scm
-(import matchable
- srfi-13
- (chicken process-context))
+(import sam-macros srfi-13 matchable)
(define (make-client-beh system)
(let ((name "name")
(recipients '()))
- (lambda (self . message)
- (match message
- (('start)
- (send-message system 'print "Welcome to chat!\n"
- "Your client address is " (address->string self) ".\n"
- "Type '/help' for a list of commands.\n")
- (send-message system 'read self))
- (('show-msg from text)
- (send-message system 'print from "> " text))
- (((? string? str))
- (if (string-prefix? "/" str)
- (let* ((maybe-idx (string-index str #\space))
- (idx (if maybe-idx maybe-idx (string-length str)))
- (cmd (substring str 1 idx))
- (arg (string-trim (substring str idx))))
- (match cmd
- ((or "h" "help")
- (send-message system 'print
- "Command | Description\n"
- "------------------------------\n"
- "/help List commands\n"
- "/name Name Set name to use in chat.\n"
- "/join <address> Join chat with specified client\n"
- "/clear Clear recipients\n"
- "/list List current recipients\n"
- "/quit Quit chat"))
- ((or "j" "join")
- (if (string-null? arg)
- (send-message system 'print "Missing address of client.")
- (begin
- (set! recipients (cons (string->address arg) recipients))
- (send-message system 'print "Added recipient to chat."))))
- ((or "c" "clear")
- (set! recipients '())
- (send-message system 'print "Cleared recipient list."))
- ((or "n" "name")
- (set! name arg)
- (send-message system 'print "Name now set to '" name "'."))
- ((or "l" "list")
- (if (null? recipients)
- (send-message system 'print "Recipients list empty.")
- (begin
- (send-message system 'print "Current recipients:")
- (let loop ((recipients-left recipients))
- (unless (null? recipients-left)
- (send-message system 'print (address->string (car recipients-left)))
- (loop (cdr recipients-left)))))))
- ((or "q" "quit")
- (send-message system 'shutdown))
- (else
- (send-message system 'print "Unrecognised command '" cmd "'"))))
- (if (null? recipients)
- (send-message system 'print "Speaking to the void.")
- (let loop ((recipients-left recipients))
- (unless (null? recipients-left)
- (send-message (car recipients-left) 'show-msg name str)
- (loop (cdr recipients-left))))))))
- (send-message system 'read self)
- 'sleep)))
+ (make-beh (self)
+ (('start) =>
+ (send-message system 'print "Welcome to chat!\n"
+ "Your client address is " (address->string self) ".\n"
+ "Type '/help' for a list of commands.\n"))
+ (('show-msg from text) =>
+ (send-message system 'print from "> " text))
+ (((? string? str)) =>
+ (if (string-prefix? "/" str)
+ (let* ((maybe-idx (string-index str #\space))
+ (idx (if maybe-idx maybe-idx (string-length str)))
+ (cmd (substring str 1 idx))
+ (arg (string-trim (substring str idx))))
+ (match cmd
+ ((or "h" "help")
+ (send-message system 'print
+ "Command | Description\n"
+ "------------------------------\n"
+ "/help List commands\n"
+ "/name Name Set name to use in chat.\n"
+ "/join <address> Join chat with specified client\n"
+ "/clear Clear recipients\n"
+ "/list List current recipients\n"
+ "/quit Quit chat"))
+ ((or "j" "join")
+ (if (string-null? arg)
+ (send-message system 'print "Missing address of client.")
+ (begin
+ (set! recipients (cons (string->address arg) recipients))
+ (send-message system 'print "Added recipient to chat."))))
+ ((or "c" "clear")
+ (set! recipients '())
+ (send-message system 'print "Cleared recipient list."))
+ ((or "n" "name")
+ (set! name arg)
+ (send-message system 'print "Name now set to '" name "'."))
+ ((or "l" "list")
+ (if (null? recipients)
+ (send-message system 'print "Recipients list empty.")
+ (begin
+ (send-message system 'print "Current recipients:")
+ (let loop ((recipients-left recipients))
+ (unless (null? recipients-left)
+ (send-message system 'print (address->string (car recipients-left)))
+ (loop (cdr recipients-left)))))))
+ ((or "q" "quit")
+ (send-message system 'shutdown))
+ (else
+ (send-message system 'print "Unrecognised command '" cmd "'"))))
+ (if (null? recipients)
+ (send-message system 'print "Speaking to the void.")
+ (let loop ((recipients-left recipients))
+ (unless (null? recipients-left)
+ (send-message (car recipients-left) 'show-msg name str)
+ (loop (cdr recipients-left)))))))
+ (finally
+ (send-message system 'read self)
+ 'sleep))))
-(define (main-beh self system)
- (send-message (make-actor (make-client-beh system)) 'start)
- 'done)
+(define-beh main-beh (self)
+ ((system) =>
+ (send-message (make-actor (make-client-beh system)) 'start)
+ 'done))
--- /dev/null
+;; Macro definitions used for SAM behaviour definition
+;;
+
+(module sam-macros
+ (make-beh define-beh)
+
+ (import scheme
+ (chicken base)
+ matchable)
+
+ (define-syntax make-beh
+ (syntax-rules (: => finally)
+ ((make-beh : parent (self) (pat => body ...) ... (finally after ...))
+ (cons (lambda (self . message)
+ (match message
+ (pat body ...)
+ ...
+ (else 'pass))
+ after ...)
+ parent))
+ ((make-beh (self) (pat => body ...) ... (finally after ...))
+ (make-beh : root-beh (self) (pat => body ...) ... (finally after ...)))
+ ((make-beh : parent (self) (pat => body ...) ...)
+ (make-beh : parent (self) (pat => body ...) ... (finally)))
+ ((make-beh (self) (pat => body ...) ...)
+ (make-beh : root-beh (self) (pat => body ...) ... (finally)))))
+
+ (define-syntax define-beh
+ (syntax-rules ()
+ ((_ name rest ...)
+ (define name (make-beh rest ...))))))
+
uuid ; ids for actors
uri-generic
udp
- fifo)
+ fifo
+ sam-macros)
;; Global variables
(define sam-version "0.1")
-;; Actors
+;; Logging
+
+(define (log-msg . args)
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (apply print (cons "## " args)))))
+
+(define (log-trace . args)
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (if trace (apply log-msg args)))))
+
+;; Behaviours
+
+(define (beh-proc beh)
+ (car beh))
+(define (beh-parent beh)
+ (cdr beh))
+(define root-beh
+ (make-beh : #f (self)
+ (('ping recipient) =>
+ (send-message recipient 'pong)
+ 'sleep)))
+
+;; Actors
(define (make-address host port id)
(list id host port))
address))
(define (deliver-message address . message)
- (if trace (print "Delivering to " address ": " message))
(let ((id (address-id address)))
- (let ((behaviour (hash-table-ref/default actor-table id '())))
- (if (null? behaviour)
- (print "## Warning: discarded message " message
- " to unknown actor id " id)
+ (log-trace "DELIVERING to " id ": " message)
+ (let loop ((beh (hash-table-ref/default actor-table id #f)))
+ (if beh
(condition-case
- (match (apply behaviour (cons address message))
+ (match (apply (beh-proc beh) (cons address message))
('done (hash-table-delete! actor-table id))
('sleep 'do-nothing)
- (new-beh (hash-table-set! actor-table id new-beh)))
- ((exn)
- (print "## Warning: actor id " id " crashed evaluating message " message)))))))
+ ('pass
+ (log-trace "Passing to parent behaviour...")
+ (loop (beh-parent beh)))
+ ((? procedure? new-beh) (hash-table-set! actor-table id new-beh))
+ (else
+ (log-msg "Warning: behaviour of actor " id " returned invalid value.")))
+ (o (exn)
+ (log-msg "Warning: actor " id " crashed evaluating message " message)
+ (print-error-message o)))
+ (log-msg "Warning: DISCARDING message to unknown actor " id ": " message)))))
;; Scheduler
(define local-queue (make-fifo))
(define (send-message address . message)
+ (log-trace "SENDING to " address ": " message)
(apply (if (address-local? address)
send-local-message
send-network-message)
((address message ...)
(apply send-message (cons address message)))
(else
- (print "Warning: received badly formatted message string '" str "'"))))
+ (log-msg "Warning: received badly formatted message string '" str "'"))))
(loop))))))
;; System interface
;; System initialization
-(define (system-beh self . message)
- (match message
-
- (('shutdown)
- (print "## System actor received shutdown message.")
- (exit 0)
- 'done)
+(define system-beh
+ (make-beh (self)
+ (('shutdown) =>
+ (log-msg "System actor received shutdown message.")
+ (exit 0)
+ 'done)
- (('print strings ...)
- (apply print strings)
- 'sleep)
+ (('print strings ...) =>
+ (apply print strings)
+ 'sleep)
- (('read reader)
- (mutex-lock! reader-queue-mutex)
- (fifo-push reader-queue reader)
- (mutex-unlock! reader-available-mutex)
- (mutex-unlock! reader-queue-mutex)
- 'sleep)))
+ (('read reader) =>
+ (mutex-lock! reader-queue-mutex)
+ (fifo-push reader-queue reader)
+ (mutex-unlock! reader-available-mutex)
+ (mutex-unlock! reader-queue-mutex)
+ 'sleep)))
(define (boot-sam)
(start-console)
(begin
(set! main (make-actor main-beh)))
((exn)
- (print "## Error starting main actor. Is main-beh defined?")
+ (log-msg "Error starting main actor. Is main-beh defined?")
(exit 1)))
(send-message main system))
(start-scheduler))
"Usage: sam -h|--help\n"
" sam [-n hostname] [-p port] source-file-1 [source-file-2 [...]] "))
-
(let loop ((args (cdr (argv))))
(match args
(((or "-h" "--help"))
(((or "-n" "--hostname") hstr rest ...)
(set! sam-host hstr)
(loop rest))
+ (((or "-t" "--trace") rest ...)
+ (log-msg "Enabling trace debugging")
+ (set! trace #t)
+ (loop rest))
(((? file-exists? filename) rest ...)
- (print* "## Loading " filename "...")
+ (log-msg "Loading " filename)
(load filename)
- (print " done.")
(loop rest))
(()
- (print "## Booting SAM\n")
+ (log-msg "Booting SAM\n")
(boot-sam))
(else
(print "Unrecognised argument '" (car args) "'.\n")
-(import matchable
- (chicken process-context)
- srfi-18)
+(import sam-macros)
-(define (main-beh self system)
- (send-message system 'print "Hello, what is your name?")
- (send-message system 'read
- (make-actor (lambda (self . message)
- (match message
- ((name)
- (send-message system 'print "Hello, " name "!")
- 'done)))))
-
- (send-message-later system 10 'print "Boo!"))
+(define-beh main-beh (self)
+ ((system) =>
+ (send-message system 'print "Hello, what is your name?")
+ (send-message system 'read
+ (make-actor (make-beh (self)
+ ((name) =>
+ (send-message system 'print "Hello, " name "!")
+ 'done))))
+ (send-message system 'ping
+ (make-actor (make-beh (self)
+ (('pong) =>
+ (send-message system 'print
+ "Received pong from system!")
+ 'done))))
+ (send-message-later system 10 'print "Boo!")
+ 'done))
The Lambda Lab / projects / sam.git / commitdiff