diff --git a/prospect/actor.rkt b/prospect/actor.rkt index e1c88f4..c765ceb 100644 --- a/prospect/actor.rkt +++ b/prospect/actor.rkt @@ -24,6 +24,7 @@ pretty-print-actor-state (for-syntax analyze-pattern) + syndicate-actor-prompt-tag-installed? ) (require (for-syntax racket/base)) @@ -157,6 +158,9 @@ (define prompt (make-continuation-prompt-tag 'syndicate-hll)) +(define (syndicate-actor-prompt-tag-installed?) + (continuation-prompt-available? prompt)) + ;; (Any ... -> Nothing) -> (Any ... -> Instruction) (define (reply-to k) (lambda reply-values @@ -171,6 +175,9 @@ ;; ((Any ... -> Instruction) -> Instruction) (define (call-in-raw-context proc) + (when (not (syndicate-actor-prompt-tag-installed?)) + (error 'call-in-raw-context + "Attempt to invoke imperative Syndicate actor action outside actor context.")) (call-with-composable-continuation (lambda (k) (abort-current-continuation prompt (lambda () (proc (reply-to k))))) prompt)) @@ -653,7 +660,10 @@ ;; (local-require racket/pretty) ;; (pretty-print (syntax->datum action-fn-stx)) - #`(spawn! '#,linkage-kind #,action-fn-stx)) + #`(let ((do-spawn (lambda () (spawn! '#,linkage-kind #,action-fn-stx)))) + (if (syndicate-actor-prompt-tag-installed?) + (do-spawn) + (actor-body->spawn-action do-spawn)))) ) ;; ;; Given a Pred, computes (and perhaps allocates): diff --git a/prospect/examples/actor/bank-account.rkt b/prospect/examples/actor/bank-account.rkt index 54dc45c..9b52787 100644 --- a/prospect/examples/actor/bank-account.rkt +++ b/prospect/examples/actor/bank-account.rkt @@ -6,17 +6,14 @@ (struct account (balance) #:prefab) (struct deposit (amount) #:prefab) -(actor-body->spawn-action - (lambda () - (actor (forever #:collect [(balance 0)] - (assert (account balance)) - (on (message (deposit $amount)) - (+ balance amount)))) +(actor (forever #:collect [(balance 0)] + (assert (account balance)) + (on (message (deposit $amount)) + (+ balance amount)))) - (actor (forever (on (asserted (account $balance)) - (printf "Balance changed to ~a\n" balance)))) +(actor (forever (on (asserted (account $balance)) + (printf "Balance changed to ~a\n" balance)))) - (until (asserted (observe (deposit _)))) - (send! (deposit +100)) - (send! (deposit -30)) - )) +(actor (until (asserted (observe (deposit _)))) + (send! (deposit +100)) + (send! (deposit -30))) diff --git a/prospect/examples/actor/box-and-client.rkt b/prospect/examples/actor/box-and-client.rkt index d61c3e3..8f71293 100644 --- a/prospect/examples/actor/box-and-client.rkt +++ b/prospect/examples/actor/box-and-client.rkt @@ -6,15 +6,12 @@ (struct set-box (new-value) #:transparent) (struct box-state (value) #:transparent) -(actor-body->spawn-action - (lambda () - (actor (forever #:collect [(current-value 0)] - (assert (box-state current-value)) - (on (message (set-box $new-value)) - (log-info "box: taking on new-value ~v" new-value) - new-value))) +(actor (forever #:collect [(current-value 0)] + (assert (box-state current-value)) + (on (message (set-box $new-value)) + (log-info "box: taking on new-value ~v" new-value) + new-value))) - (actor (forever (on (asserted (box-state $v)) - (log-info "client: learned that box's value is now ~v" v) - (send! (set-box (+ v 1)))))) - )) +(actor (forever (on (asserted (box-state $v)) + (log-info "client: learned that box's value is now ~v" v) + (send! (set-box (+ v 1)))))) diff --git a/prospect/examples/actor/chain.rkt b/prospect/examples/actor/chain.rkt new file mode 100644 index 0000000..be7ebcb --- /dev/null +++ b/prospect/examples/actor/chain.rkt @@ -0,0 +1,20 @@ +#lang prospect + +(require prospect/actor) +(require prospect/drivers/timer) + +(spawn-timer-driver) + +(define (sleep sec) + (define timer-id (gensym 'sleep)) + (until (message (timer-expired timer-id _)) + #:init [(send! (set-timer timer-id (* sec 1000.0) 'relative))])) + +(define (chain-step n) + (printf "chain-step ~v\n" n) + (actor (sleep 1) + (if (< n 5) + (chain-step (+ n 1)) + (printf "done.\n")))) + +(chain-step 0) diff --git a/prospect/examples/actor/chat-client.rkt b/prospect/examples/actor/chat-client.rkt index 5a7cb97..d18e166 100644 --- a/prospect/examples/actor/chat-client.rkt +++ b/prospect/examples/actor/chat-client.rkt @@ -8,16 +8,15 @@ (define remote-handle (tcp-address "localhost" 5999)) (define stdin-evt (read-bytes-line-evt (current-input-port) 'any)) -(actor-body->spawn-action - (lambda () - (perform-core-action! (spawn-tcp-driver)) - (forever (on (message (external-event stdin-evt (list $line)) #:meta-level 1) - (if (eof-object? line) - (return!) - (send! (tcp-channel local-handle remote-handle line)))) +(spawn-tcp-driver) - (assert (advertise (tcp-channel local-handle remote-handle _))) - (on (retracted (advertise (tcp-channel remote-handle local-handle _))) (return!)) - (on (message (tcp-channel remote-handle local-handle $bs)) - (write-bytes bs) - (flush-output))))) +(forever (on (message (external-event stdin-evt (list $line)) #:meta-level 1) + (if (eof-object? line) + (return!) + (send! (tcp-channel local-handle remote-handle line)))) + + (assert (advertise (tcp-channel local-handle remote-handle _))) + (on (retracted (advertise (tcp-channel remote-handle local-handle _))) (return!)) + (on (message (tcp-channel remote-handle local-handle $bs)) + (write-bytes bs) + (flush-output))) diff --git a/prospect/examples/actor/chat-no-quit-world-no-nesting.rkt b/prospect/examples/actor/chat-no-quit-world-no-nesting.rkt index 0bbe30d..1c51daa 100644 --- a/prospect/examples/actor/chat-no-quit-world-no-nesting.rkt +++ b/prospect/examples/actor/chat-no-quit-world-no-nesting.rkt @@ -29,10 +29,8 @@ (on (message (tcp-channel them us $bs)) (send! (says user (string-trim (bytes->string/utf-8 bs)))))))) -(actor-body->spawn-action - (lambda () - (perform-core-action! (spawn-tcp-driver)) - (define us (tcp-listener 5999)) - (forever (assert (advertise (observe (tcp-channel _ us _)))) - (on (asserted (advertise (tcp-channel $them us _))) - (spawn-session them us))))) +(spawn-tcp-driver) +(define us (tcp-listener 5999)) +(forever (assert (advertise (observe (tcp-channel _ us _)))) + (on (asserted (advertise (tcp-channel $them us _))) + (spawn-session them us))) diff --git a/prospect/examples/actor/chat-no-quit-world.rkt b/prospect/examples/actor/chat-no-quit-world.rkt index cfb9a4b..4970c44 100644 --- a/prospect/examples/actor/chat-no-quit-world.rkt +++ b/prospect/examples/actor/chat-no-quit-world.rkt @@ -30,10 +30,8 @@ (on (message (tcp-channel them us $bs) #:meta-level 1) (send! (says user (string-trim (bytes->string/utf-8 bs)))))))) -(actor-body->spawn-action - (lambda () - (perform-core-action! (spawn-tcp-driver)) - (network (define us (tcp-listener 5999)) - (forever (assert (advertise (observe (tcp-channel _ us _))) #:meta-level 1) - (on (asserted (advertise (tcp-channel $them us _)) #:meta-level 1) - (spawn-session them us)))))) +(spawn-tcp-driver) +(network (define us (tcp-listener 5999)) + (forever (assert (advertise (observe (tcp-channel _ us _))) #:meta-level 1) + (on (asserted (advertise (tcp-channel $them us _)) #:meta-level 1) + (spawn-session them us)))) diff --git a/prospect/examples/actor/chat-simplified-internals.rkt b/prospect/examples/actor/chat-simplified-internals.rkt index 80e4afb..9e0845d 100644 --- a/prospect/examples/actor/chat-simplified-internals.rkt +++ b/prospect/examples/actor/chat-simplified-internals.rkt @@ -34,22 +34,19 @@ (on (message (tcp-incoming-data id $bs)) (send! (says user (string-trim (bytes->string/utf-8 bs)))))))) -(actor-body->spawn-action - (lambda () - (perform-core-action! (spawn-tcp-driver)) +(spawn-tcp-driver) - (define us (tcp-listener 5999)) - (actor (forever (assert (advertise (observe (tcp-channel _ us _)))) - (on (asserted (advertise (tcp-channel $them us _))) - (define id (seal (list them us))) - (actor (state [(assert (tcp-remote-open id)) - (on (message (tcp-channel them us $bs)) - (send! (tcp-incoming-data id bs))) - (on (message (tcp-outgoing-data id $bs)) - (send! (tcp-channel us them bs)))] - [(retracted (advertise (tcp-channel them us _))) (void)] - [(retracted (tcp-local-open id)) (void)]))))) +(define us (tcp-listener 5999)) +(actor (forever (assert (advertise (observe (tcp-channel _ us _)))) + (on (asserted (advertise (tcp-channel $them us _))) + (define id (seal (list them us))) + (actor (state [(assert (tcp-remote-open id)) + (on (message (tcp-channel them us $bs)) + (send! (tcp-incoming-data id bs))) + (on (message (tcp-outgoing-data id $bs)) + (send! (tcp-channel us them bs)))] + [(retracted (advertise (tcp-channel them us _))) (void)] + [(retracted (tcp-local-open id)) (void)]))))) - (forever (on (asserted (tcp-remote-open $id)) - (spawn-session id))) - )) +(forever (on (asserted (tcp-remote-open $id)) + (spawn-session id))) diff --git a/prospect/examples/actor/chat.rkt b/prospect/examples/actor/chat.rkt index e030bf6..7ce3b40 100644 --- a/prospect/examples/actor/chat.rkt +++ b/prospect/examples/actor/chat.rkt @@ -34,11 +34,9 @@ (send! (shutdown)) (send! (says user input-string))))))) -(actor-body->spawn-action - (lambda () - (perform-core-action! (spawn-tcp-driver)) - (network (define us (tcp-listener 5999)) - (until (message (shutdown)) - (assert (advertise (observe (tcp-channel _ us _))) #:meta-level 1) - (on (asserted (advertise (tcp-channel $them us _)) #:meta-level 1) - (spawn-session them us)))))) +(spawn-tcp-driver) +(network (define us (tcp-listener 5999)) + (until (message (shutdown)) + (assert (advertise (observe (tcp-channel _ us _))) #:meta-level 1) + (on (asserted (advertise (tcp-channel $them us _)) #:meta-level 1) + (spawn-session them us)))) diff --git a/prospect/examples/actor/echo.rkt b/prospect/examples/actor/echo.rkt index 52b5921..0707faa 100644 --- a/prospect/examples/actor/echo.rkt +++ b/prospect/examples/actor/echo.rkt @@ -3,16 +3,14 @@ (require prospect/actor) (require prospect/drivers/tcp) -(actor-body->spawn-action - (lambda () - (perform-core-action! (spawn-tcp-driver)) +(spawn-tcp-driver) - (define server-id (tcp-listener 5999)) - (forever (assert (advertise (observe (tcp-channel _ server-id _)))) - (on (asserted (advertise (tcp-channel $c server-id _))) - (printf "Accepted connection from ~v\n" c) - (actor (until (retracted (advertise (tcp-channel c server-id _))) - (assert (advertise (tcp-channel server-id c _))) - (on (message (tcp-channel c server-id $bs)) - (send! (tcp-channel server-id c bs)))) - (printf "Closed connection ~v\n" c)))))) +(define server-id (tcp-listener 5999)) +(forever (assert (advertise (observe (tcp-channel _ server-id _)))) + (on (asserted (advertise (tcp-channel $c server-id _))) + (printf "Accepted connection from ~v\n" c) + (actor (until (retracted (advertise (tcp-channel c server-id _))) + (assert (advertise (tcp-channel server-id c _))) + (on (message (tcp-channel c server-id $bs)) + (send! (tcp-channel server-id c bs)))) + (printf "Closed connection ~v\n" c)))) diff --git a/prospect/examples/actor/file-system.rkt b/prospect/examples/actor/file-system.rkt index d4ecd96..23f337c 100644 --- a/prospect/examples/actor/file-system.rkt +++ b/prospect/examples/actor/file-system.rkt @@ -10,64 +10,59 @@ (struct save (file) #:prefab) (struct delete (name) #:prefab) -(actor-body->spawn-action - (lambda () +(spawn-timer-driver) - (perform-core-action! (spawn-timer-driver)) +(actor (forever #:collect [(files (hash))] + (on (asserted (observe (file $name _))) + (printf "At least one reader exists for ~v\n" name) + (begin0 (until (retracted (observe (file name _))) + #:collect [(content (hash-ref files name #f))] + (assert (file name content)) + (on (message (save (file name $content))) content) + (on (message (delete name)) #f)) + (printf "No remaining readers exist for ~v\n" name))) + (on (message (save (file $name $content))) (hash-set files name content)) + (on (message (delete $name)) (hash-remove files name)))) - (actor (forever #:collect [(files (hash))] - (on (asserted (observe (file $name _))) - (printf "At least one reader exists for ~v\n" name) - (begin0 (until (retracted (observe (file name _))) - #:collect [(content (hash-ref files name #f))] - (assert (file name content)) - (on (message (save (file name $content))) content) - (on (message (delete name)) #f)) - (printf "No remaining readers exist for ~v\n" name))) - (on (message (save (file $name $content))) (hash-set files name content)) - (on (message (delete $name)) (hash-remove files name)))) +(define (sleep sec) + (define timer-id (gensym 'sleep)) + (until (message (timer-expired timer-id _)) + #:init [(send! (set-timer timer-id (* sec 1000.0) 'relative))])) - (define (sleep sec) - (define timer-id (gensym 'sleep)) - (until (message (timer-expired timer-id _)) - #:init [(send! (set-timer timer-id (* sec 1000.0) 'relative))])) - - ;; Shell - (let ((e (read-bytes-line-evt (current-input-port) 'any))) - (define (print-prompt) - (printf "> ") - (flush-output)) - (define reader-count 0) - (define (generate-reader-id) - (begin0 reader-count - (set! reader-count (+ reader-count 1)))) - (actor (print-prompt) - (until (message (external-event e (list (? eof-object? _))) #:meta-level 1) - (on (message (external-event e (list (? bytes? $bs))) #:meta-level 1) - (match (string-split (string-trim (bytes->string/utf-8 bs))) - [(list "open" name) - (define reader-id (generate-reader-id)) - (actor (printf "Reader ~a opening file ~v.\n" reader-id name) - (until (message `(stop-watching ,name)) - (on (asserted (file name $contents)) - (printf "Reader ~a sees that ~v contains: ~v\n" - reader-id - name - contents))) - (printf "Reader ~a closing file ~v.\n" reader-id name))] - [(list "close" name) - (send! `(stop-watching ,name))] - [(list* "write" name words) - (send! (save (file name words)))] - [(list "delete" name) - (send! (delete name))] - [_ - (printf "I'm afraid I didn't understand that.\n") - (printf "Try: open filename\n") - (printf " close filename\n") - (printf " write filename some text goes here\n") - (printf " delete filename\n")]) - (sleep 0.1) - (print-prompt))))) - - )) +;; Shell +(let ((e (read-bytes-line-evt (current-input-port) 'any))) + (define (print-prompt) + (printf "> ") + (flush-output)) + (define reader-count 0) + (define (generate-reader-id) + (begin0 reader-count + (set! reader-count (+ reader-count 1)))) + (actor (print-prompt) + (until (message (external-event e (list (? eof-object? _))) #:meta-level 1) + (on (message (external-event e (list (? bytes? $bs))) #:meta-level 1) + (match (string-split (string-trim (bytes->string/utf-8 bs))) + [(list "open" name) + (define reader-id (generate-reader-id)) + (actor (printf "Reader ~a opening file ~v.\n" reader-id name) + (until (message `(stop-watching ,name)) + (on (asserted (file name $contents)) + (printf "Reader ~a sees that ~v contains: ~v\n" + reader-id + name + contents))) + (printf "Reader ~a closing file ~v.\n" reader-id name))] + [(list "close" name) + (send! `(stop-watching ,name))] + [(list* "write" name words) + (send! (save (file name words)))] + [(list "delete" name) + (send! (delete name))] + [_ + (printf "I'm afraid I didn't understand that.\n") + (printf "Try: open filename\n") + (printf " close filename\n") + (printf " write filename some text goes here\n") + (printf " delete filename\n")]) + (sleep 0.1) + (print-prompt))))) diff --git a/prospect/examples/actor/mini-echo.rkt b/prospect/examples/actor/mini-echo.rkt index ea1fb26..b75c70a 100644 --- a/prospect/examples/actor/mini-echo.rkt +++ b/prospect/examples/actor/mini-echo.rkt @@ -5,19 +5,16 @@ (struct echo-req (body) #:prefab) (struct echo-resp (body) #:prefab) -(actor-body->spawn-action - (lambda () - (actor (forever #:collect [(count 0)] - (on (message (echo-req $body)) - (send! (echo-resp body)) - (+ count 1)))) +(actor (forever #:collect [(count 0)] + (on (message (echo-req $body)) + (send! (echo-resp body)) + (+ count 1)))) - (actor (forever (on (message (echo-resp $body)) - (printf "Received: ~v\n" body)))) +(actor (forever (on (message (echo-resp $body)) + (printf "Received: ~v\n" body)))) - (until (asserted (observe (echo-req _)))) - (until (asserted (observe (echo-resp _)))) - (send! (echo-req 0)) - (send! (echo-req 1)) - (send! (echo-req 2)) - )) +(actor (until (asserted (observe (echo-req _)))) + (until (asserted (observe (echo-resp _)))) + (send! (echo-req 0)) + (send! (echo-req 1)) + (send! (echo-req 2)))