syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Use `continuation-prompt-available?` to support `actor` at prospect "toplevel".

This commit is contained in:
Tony Garnock-Jones 2016-02-05 18:03:40 -05:00
parent 92169d5e10
commit d5c4b30335
12 changed files with 163 additions and 159 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
prospect/actor.rkt
View File

@ -24,6 +24,7 @@
pretty-print-actor-state pretty-print-actor-state
(for-syntax analyze-pattern) (for-syntax analyze-pattern)
syndicate-actor-prompt-tag-installed?
) )
(require (for-syntax racket/base)) (require (for-syntax racket/base))
@ -157,6 +158,9 @@
(define prompt (make-continuation-prompt-tag 'syndicate-hll)) (define prompt (make-continuation-prompt-tag 'syndicate-hll))
(define (syndicate-actor-prompt-tag-installed?)
(continuation-prompt-available? prompt))
;; (Any ... -> Nothing) -> (Any ... -> Instruction) ;; (Any ... -> Nothing) -> (Any ... -> Instruction)
(define (reply-to k) (define (reply-to k)
(lambda reply-values (lambda reply-values
@ -171,6 +175,9 @@
;; ((Any ... -> Instruction) -> Instruction) ;; ((Any ... -> Instruction) -> Instruction)
(define (call-in-raw-context proc) (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 (call-with-composable-continuation
(lambda (k) (abort-current-continuation prompt (lambda () (proc (reply-to k))))) (lambda (k) (abort-current-continuation prompt (lambda () (proc (reply-to k)))))
prompt)) prompt))
@ -653,7 +660,10 @@
;; (local-require racket/pretty) ;; (local-require racket/pretty)
;; (pretty-print (syntax->datum action-fn-stx)) ;; (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): ;; ;; Given a Pred, computes (and perhaps allocates):

21
prospect/examples/actor/bank-account.rkt
View File

@ -6,17 +6,14 @@
(struct account (balance) #:prefab) (struct account (balance) #:prefab)
(struct deposit (amount) #:prefab) (struct deposit (amount) #:prefab)
(actor-body->spawn-action (actor (forever #:collect [(balance 0)]
(lambda () (assert (account balance))
(actor (forever #:collect [(balance 0)] (on (message (deposit $amount))
(assert (account balance)) (+ balance amount))))
(on (message (deposit $amount))
(+ balance amount))))
(actor (forever (on (asserted (account $balance)) (actor (forever (on (asserted (account $balance))
(printf "Balance changed to ~a\n" balance)))) (printf "Balance changed to ~a\n" balance))))
(until (asserted (observe (deposit _)))) (actor (until (asserted (observe (deposit _))))
(send! (deposit +100)) (send! (deposit +100))
(send! (deposit -30)) (send! (deposit -30)))
))

19
prospect/examples/actor/box-and-client.rkt
View File

@ -6,15 +6,12 @@
(struct set-box (new-value) #:transparent) (struct set-box (new-value) #:transparent)
(struct box-state (value) #:transparent) (struct box-state (value) #:transparent)
(actor-body->spawn-action (actor (forever #:collect [(current-value 0)]
(lambda () (assert (box-state current-value))
(actor (forever #:collect [(current-value 0)] (on (message (set-box $new-value))
(assert (box-state current-value)) (log-info "box: taking on new-value ~v" new-value)
(on (message (set-box $new-value)) new-value)))
(log-info "box: taking on new-value ~v" new-value)
new-value)))
(actor (forever (on (asserted (box-state $v)) (actor (forever (on (asserted (box-state $v))
(log-info "client: learned that box's value is now ~v" v) (log-info "client: learned that box's value is now ~v" v)
(send! (set-box (+ v 1)))))) (send! (set-box (+ v 1))))))
))

20
prospect/examples/actor/chain.rkt Normal file
View File

@ -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)

23
prospect/examples/actor/chat-client.rkt
View File

@ -8,16 +8,15 @@
(define remote-handle (tcp-address "localhost" 5999)) (define remote-handle (tcp-address "localhost" 5999))
(define stdin-evt (read-bytes-line-evt (current-input-port) 'any)) (define stdin-evt (read-bytes-line-evt (current-input-port) 'any))
(actor-body->spawn-action (spawn-tcp-driver)
(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))))
(assert (advertise (tcp-channel local-handle remote-handle _))) (forever (on (message (external-event stdin-evt (list $line)) #:meta-level 1)
(on (retracted (advertise (tcp-channel remote-handle local-handle _))) (return!)) (if (eof-object? line)
(on (message (tcp-channel remote-handle local-handle $bs)) (return!)
(write-bytes bs) (send! (tcp-channel local-handle remote-handle line))))
(flush-output)))))
(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)))

12
prospect/examples/actor/chat-no-quit-world-no-nesting.rkt
View File

@ -29,10 +29,8 @@
(on (message (tcp-channel them us $bs)) (on (message (tcp-channel them us $bs))
(send! (says user (string-trim (bytes->string/utf-8 bs)))))))) (send! (says user (string-trim (bytes->string/utf-8 bs))))))))
(actor-body->spawn-action (spawn-tcp-driver)
(lambda () (define us (tcp-listener 5999))
(perform-core-action! (spawn-tcp-driver)) (forever (assert (advertise (observe (tcp-channel _ us _))))
(define us (tcp-listener 5999)) (on (asserted (advertise (tcp-channel $them us _)))
(forever (assert (advertise (observe (tcp-channel _ us _)))) (spawn-session them us)))
(on (asserted (advertise (tcp-channel $them us _)))
(spawn-session them us)))))

12
prospect/examples/actor/chat-no-quit-world.rkt
View File

@ -30,10 +30,8 @@
(on (message (tcp-channel them us $bs) #:meta-level 1) (on (message (tcp-channel them us $bs) #:meta-level 1)
(send! (says user (string-trim (bytes->string/utf-8 bs)))))))) (send! (says user (string-trim (bytes->string/utf-8 bs))))))))
(actor-body->spawn-action (spawn-tcp-driver)
(lambda () (network (define us (tcp-listener 5999))
(perform-core-action! (spawn-tcp-driver)) (forever (assert (advertise (observe (tcp-channel _ us _))) #:meta-level 1)
(network (define us (tcp-listener 5999)) (on (asserted (advertise (tcp-channel $them us _)) #:meta-level 1)
(forever (assert (advertise (observe (tcp-channel _ us _))) #:meta-level 1) (spawn-session them us))))
(on (asserted (advertise (tcp-channel $them us _)) #:meta-level 1)
(spawn-session them us))))))

31
prospect/examples/actor/chat-simplified-internals.rkt
View File

@ -34,22 +34,19 @@
(on (message (tcp-incoming-data id $bs)) (on (message (tcp-incoming-data id $bs))
(send! (says user (string-trim (bytes->string/utf-8 bs)))))))) (send! (says user (string-trim (bytes->string/utf-8 bs))))))))
(actor-body->spawn-action (spawn-tcp-driver)
(lambda ()
(perform-core-action! (spawn-tcp-driver))
(define us (tcp-listener 5999)) (define us (tcp-listener 5999))
(actor (forever (assert (advertise (observe (tcp-channel _ us _)))) (actor (forever (assert (advertise (observe (tcp-channel _ us _))))
(on (asserted (advertise (tcp-channel $them us _))) (on (asserted (advertise (tcp-channel $them us _)))
(define id (seal (list them us))) (define id (seal (list them us)))
(actor (state [(assert (tcp-remote-open id)) (actor (state [(assert (tcp-remote-open id))
(on (message (tcp-channel them us $bs)) (on (message (tcp-channel them us $bs))
(send! (tcp-incoming-data id bs))) (send! (tcp-incoming-data id bs)))
(on (message (tcp-outgoing-data id $bs)) (on (message (tcp-outgoing-data id $bs))
(send! (tcp-channel us them bs)))] (send! (tcp-channel us them bs)))]
[(retracted (advertise (tcp-channel them us _))) (void)] [(retracted (advertise (tcp-channel them us _))) (void)]
[(retracted (tcp-local-open id)) (void)]))))) [(retracted (tcp-local-open id)) (void)])))))
(forever (on (asserted (tcp-remote-open $id)) (forever (on (asserted (tcp-remote-open $id))
(spawn-session id))) (spawn-session id)))
))

14
prospect/examples/actor/chat.rkt
View File

@ -34,11 +34,9 @@
(send! (shutdown)) (send! (shutdown))
(send! (says user input-string))))))) (send! (says user input-string)))))))
(actor-body->spawn-action (spawn-tcp-driver)
(lambda () (network (define us (tcp-listener 5999))
(perform-core-action! (spawn-tcp-driver)) (until (message (shutdown))
(network (define us (tcp-listener 5999)) (assert (advertise (observe (tcp-channel _ us _))) #:meta-level 1)
(until (message (shutdown)) (on (asserted (advertise (tcp-channel $them us _)) #:meta-level 1)
(assert (advertise (observe (tcp-channel _ us _))) #:meta-level 1) (spawn-session them us))))
(on (asserted (advertise (tcp-channel $them us _)) #:meta-level 1)
(spawn-session them us))))))

22
prospect/examples/actor/echo.rkt
View File

@ -3,16 +3,14 @@
(require prospect/actor) (require prospect/actor)
(require prospect/drivers/tcp) (require prospect/drivers/tcp)
(actor-body->spawn-action (spawn-tcp-driver)
(lambda ()
(perform-core-action! (spawn-tcp-driver))
(define server-id (tcp-listener 5999)) (define server-id (tcp-listener 5999))
(forever (assert (advertise (observe (tcp-channel _ server-id _)))) (forever (assert (advertise (observe (tcp-channel _ server-id _))))
(on (asserted (advertise (tcp-channel $c server-id _))) (on (asserted (advertise (tcp-channel $c server-id _)))
(printf "Accepted connection from ~v\n" c) (printf "Accepted connection from ~v\n" c)
(actor (until (retracted (advertise (tcp-channel c server-id _))) (actor (until (retracted (advertise (tcp-channel c server-id _)))
(assert (advertise (tcp-channel server-id c _))) (assert (advertise (tcp-channel server-id c _)))
(on (message (tcp-channel c server-id $bs)) (on (message (tcp-channel c server-id $bs))
(send! (tcp-channel server-id c bs)))) (send! (tcp-channel server-id c bs))))
(printf "Closed connection ~v\n" c)))))) (printf "Closed connection ~v\n" c))))

111
prospect/examples/actor/file-system.rkt
View File

@ -10,64 +10,59 @@
(struct save (file) #:prefab) (struct save (file) #:prefab)
(struct delete (name) #:prefab) (struct delete (name) #:prefab)
(actor-body->spawn-action (spawn-timer-driver)
(lambda ()
(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))] (define (sleep sec)
(on (asserted (observe (file $name _))) (define timer-id (gensym 'sleep))
(printf "At least one reader exists for ~v\n" name) (until (message (timer-expired timer-id _))
(begin0 (until (retracted (observe (file name _))) #:init [(send! (set-timer timer-id (* sec 1000.0) 'relative))]))
#: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) ;; Shell
(define timer-id (gensym 'sleep)) (let ((e (read-bytes-line-evt (current-input-port) 'any)))
(until (message (timer-expired timer-id _)) (define (print-prompt)
#:init [(send! (set-timer timer-id (* sec 1000.0) 'relative))])) (printf "> ")
(flush-output))
;; Shell (define reader-count 0)
(let ((e (read-bytes-line-evt (current-input-port) 'any))) (define (generate-reader-id)
(define (print-prompt) (begin0 reader-count
(printf "> ") (set! reader-count (+ reader-count 1))))
(flush-output)) (actor (print-prompt)
(define reader-count 0) (until (message (external-event e (list (? eof-object? _))) #:meta-level 1)
(define (generate-reader-id) (on (message (external-event e (list (? bytes? $bs))) #:meta-level 1)
(begin0 reader-count (match (string-split (string-trim (bytes->string/utf-8 bs)))
(set! reader-count (+ reader-count 1)))) [(list "open" name)
(actor (print-prompt) (define reader-id (generate-reader-id))
(until (message (external-event e (list (? eof-object? _))) #:meta-level 1) (actor (printf "Reader ~a opening file ~v.\n" reader-id name)
(on (message (external-event e (list (? bytes? $bs))) #:meta-level 1) (until (message `(stop-watching ,name))
(match (string-split (string-trim (bytes->string/utf-8 bs))) (on (asserted (file name $contents))
[(list "open" name) (printf "Reader ~a sees that ~v contains: ~v\n"
(define reader-id (generate-reader-id)) reader-id
(actor (printf "Reader ~a opening file ~v.\n" reader-id name) name
(until (message `(stop-watching ,name)) contents)))
(on (asserted (file name $contents)) (printf "Reader ~a closing file ~v.\n" reader-id name))]
(printf "Reader ~a sees that ~v contains: ~v\n" [(list "close" name)
reader-id (send! `(stop-watching ,name))]
name [(list* "write" name words)
contents))) (send! (save (file name words)))]
(printf "Reader ~a closing file ~v.\n" reader-id name))] [(list "delete" name)
[(list "close" name) (send! (delete name))]
(send! `(stop-watching ,name))] [_
[(list* "write" name words) (printf "I'm afraid I didn't understand that.\n")
(send! (save (file name words)))] (printf "Try: open filename\n")
[(list "delete" name) (printf " close filename\n")
(send! (delete name))] (printf " write filename some text goes here\n")
[_ (printf " delete filename\n")])
(printf "I'm afraid I didn't understand that.\n") (sleep 0.1)
(printf "Try: open filename\n") (print-prompt)))))
(printf " close filename\n")
(printf " write filename some text goes here\n")
(printf " delete filename\n")])
(sleep 0.1)
(print-prompt)))))
))

25
prospect/examples/actor/mini-echo.rkt
View File

@ -5,19 +5,16 @@
(struct echo-req (body) #:prefab) (struct echo-req (body) #:prefab)
(struct echo-resp (body) #:prefab) (struct echo-resp (body) #:prefab)
(actor-body->spawn-action (actor (forever #:collect [(count 0)]
(lambda () (on (message (echo-req $body))
(actor (forever #:collect [(count 0)] (send! (echo-resp body))
(on (message (echo-req $body)) (+ count 1))))
(send! (echo-resp body))
(+ count 1))))
(actor (forever (on (message (echo-resp $body)) (actor (forever (on (message (echo-resp $body))
(printf "Received: ~v\n" body)))) (printf "Received: ~v\n" body))))
(until (asserted (observe (echo-req _)))) (actor (until (asserted (observe (echo-req _))))
(until (asserted (observe (echo-resp _)))) (until (asserted (observe (echo-resp _))))
(send! (echo-req 0)) (send! (echo-req 0))
(send! (echo-req 1)) (send! (echo-req 1))
(send! (echo-req 2)) (send! (echo-req 2)))
))