X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=sam.git;a=blobdiff_plain;f=sam.scm;h=fbe800e53436138590f3674c7900b7e86e851e39;hp=f09914e835f1d258c743666336f67c51149ae94d;hb=HEAD;hpb=dd9d28a6e6bb76533890d84cb48900352ff8fa68

diff --git a/sam.scm b/sam.scm
index f09914e..fbe800e 100644
--- a/sam.scm
+++ b/sam.scm
@@ -42,19 +42,28 @@
     (lambda ()
       (if trace (apply log-msg args)))))
 
+(define (->stringrep arg)
+  (with-output-to-string
+    (lambda ()
+      (write arg))))
+
 ;; Behaviours
 ;; (See also macros defined in sam-macros.scm.)
 
 (define (beh-proc beh)
-  (car beh))
+  (cadr beh))
 (define (beh-parent beh)
-  (cdr beh))  
+  (caddr beh))  
 
 (define root-beh
   (make-beh : #f (self)
             (('ping recipient) =>
-             (send-message recipient 'pong)
-             'sleep)))
+             (send-message recipient 'pong))))
+
+(define (beh? x)
+  (and (pair? x)
+       (not (null? x))
+       (eq? (car x) 'beh)))
 
 ;; Actors
 
@@ -100,23 +109,22 @@
 
 (define (deliver-message address . message)
   (let ((id (address-id address)))
-    (log-trace "DELIVERING to " id ": " message)
+    (log-trace "DELIVERING to " id ": " (->stringrep message))
     (let loop ((beh (hash-table-ref/default actor-table id #f)))
       (if beh
           (condition-case
               (match (apply (beh-proc beh) (cons address message))
                 ('done (hash-table-delete! actor-table id))
-                ('sleep 'do-nothing)
                 ('pass
                  (log-trace "Passing to parent behaviour...")
                  (loop (beh-parent beh)))
-                ((? procedure? new-beh) (hash-table-set! actor-table id new-beh))
+                ((? beh? new-beh) (hash-table-set! actor-table id new-beh))
                 (else
-                 (log-msg "Warning: behaviour of actor " id " returned invalid value.")))
+                 'do-nothing)) ; sleep is now the default
             (o (exn)
-             (log-msg "Warning: actor " id " crashed evaluating message " message)
+             (log-msg "Warning: actor " id " crashed evaluating message " (->stringrep message))
              (print-error-message o)))
-          (log-msg "Warning: DISCARDING message to unknown actor " id ": " message)))))
+          (log-msg "Warning: DISCARDING message to unknown actor " id ": " (->stringrep message))))))
 
 ;; Scheduler
 
@@ -126,7 +134,7 @@
 (define local-queue (make-fifo))
 
 (define (send-message address . message)
-  (log-trace "SENDING to " address ": " message)
+  (log-trace "SENDING to " address ": " (->stringrep message))
   (apply (if (address-local? address)
              send-local-message
              send-network-message)
@@ -217,23 +225,22 @@
 
 ;; System initialization
 
-(define system-beh
-  (make-beh (self)
-            (('shutdown) =>
-             (log-msg "System actor received shutdown message.")
-             (exit 0)
-             'done)
-
-            (('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)))
+(define-beh system-beh
+  (self)
+
+  (('shutdown) =>
+   (log-msg "System actor received shutdown message.")
+   (exit 0)
+   'done)
+
+  (('print strings ...) =>
+   (apply print strings))
+
+  (('read reader) =>
+   (mutex-lock! reader-queue-mutex)
+   (fifo-push reader-queue reader)
+   (mutex-unlock! reader-available-mutex)
+   (mutex-unlock! reader-queue-mutex)))
 
 (define (boot-sam)
   (start-console)