From: Tim Vaughan Date: Sun, 2 May 2021 21:15:02 +0000 (+0200) Subject: Implemented beh hierarchy and behaviour macros. X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=db875d2441ba67f863dc6e848d609f67d42eacf5;p=sam.git Implemented beh hierarchy and behaviour macros. --- diff --git a/Makefile b/Makefile index 34bd08b..ee8239e 100644 --- a/Makefile +++ b/Makefile @@ -3,5 +3,5 @@ all: sam %.so: %.scm csc -s -J $< -sam: sam.scm fifo.so +sam: sam.scm fifo.so sam-macros.so csc sam.scm diff --git a/chat_client.scm b/chat_client.scm index d500579..e6e205d 100644 --- a/chat_client.scm +++ b/chat_client.scm @@ -1,70 +1,68 @@ -(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
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
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)) diff --git a/sam-macros.scm b/sam-macros.scm new file mode 100644 index 0000000..16faba3 --- /dev/null +++ b/sam-macros.scm @@ -0,0 +1,32 @@ +;; 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 ...)))))) + diff --git a/sam.scm b/sam.scm index 8f2741f..846561c 100644 --- 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") diff --git a/simple_test.scm b/simple_test.scm index f20d203..35c9d48 100644 --- a/simple_test.scm +++ b/simple_test.scm @@ -1,14 +1,18 @@ -(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))