Implemented beh hierarchy and behaviour macros.

[sam.git] / sam.scm

diff --git a/sam.scm b/sam.scm
index 8f2741f..846561c 100644 (file)
--- a/sam.scm
+++ b/sam.scm
@@ -18,7 +18,8 @@
         uuid ; ids for actors
         uri-generic
         udp
-        fifo)
+        fifo
+        sam-macros)
 
 ;; Global variables
 
@@ -29,8 +30,32 @@
 
 (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))
@@ -73,19 +98,24 @@
     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
 
@@ -95,6 +125,7 @@
 (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)
@@ -153,7 +184,7 @@
              ((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
@@ -185,24 +216,23 @@
 
 ;; 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)
@@ -213,7 +243,7 @@
         (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))
@@ -224,7 +254,6 @@
          "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"))
@@ -235,13 +264,16 @@
     (((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")