Message delivery now catches exceptions and prints warning.

[sam.git] / sam.scm

diff --git a/sam.scm b/sam.scm
index 1d23712..8f2741f 100644 (file)
--- a/sam.scm
+++ b/sam.scm
@@ -1,8 +1,8 @@
 ;; Simple Actor Machine
 ;;
 ;; A virtual machine which houses a population of actors which can
-;; communicate using messages with actors on the same machine or other
-;; machines via the network.
+;; communicate using messages with actors on the same host or other
+;; hosts via the network.
 
 (import scheme
         (chicken base)
@@ -77,12 +77,15 @@
   (let ((id (address-id address)))
     (let ((behaviour (hash-table-ref/default actor-table id '())))
       (if (null? behaviour)
-          (print "Warning: discarded message " message
+          (print "## Warning: discarded message " message
                  " to unknown actor id " id)
-          (match (apply (hash-table-ref actor-table id) (cons address message))
-            ('done (hash-table-delete! actor-table id))
-            ('sleep 'do-nothing)
-            (new-beh (hash-table-set! actor-table id new-beh)))))))
+          (condition-case
+              (match (apply behaviour (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)))))))
 
 ;; Scheduler
 
@@ -210,7 +213,7 @@
         (begin
           (set! main (make-actor main-beh)))
       ((exn)
-       (print "Error starting main actor. Is main-beh defined?")
+       (print "## Error starting main actor. Is main-beh defined?")
        (exit 1)))
     (send-message main system))
   (start-scheduler))
@@ -233,11 +236,12 @@
      (set! sam-host hstr)
      (loop rest))
     (((? file-exists? filename) rest ...)
-     (print* "Loading " filename "...")
+     (print* "## Loading " filename "...")
      (load filename)
      (print " done.")
      (loop rest))
     (()
+     (print "## Booting SAM\n")
      (boot-sam))
     (else
      (print "Unrecognised argument '" (car args) "'.\n")