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

Make HLL `dataspace` no longer automatically `quit-dataspace`. Fixes #20.

This commit is contained in:
Tony Garnock-Jones 2017-09-25 23:52:29 +01:00
parent 4a4f43b2cb
commit 6c4ae38499
9 changed files with 92 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
examples/netstack/incremental-highlevel/main.rkt
View File

@ -41,11 +41,12 @@
(on (message (inbound (tcp-channel them us $bs))) (on (message (inbound (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)))))))
(define us (tcp-listener 5999))
(dataspace #:name 'chat-dataspace (dataspace #:name 'chat-dataspace
(define us (tcp-listener 5999)) (spawn #:name 'chat-server
(forever (assert (outbound (advertise (observe (tcp-channel _ us _))))) (assert (outbound (advertise (observe (tcp-channel _ us _)))))
(on (asserted (inbound (advertise (tcp-channel $them us _)))) (on (asserted (inbound (advertise (tcp-channel $them us _))))
(spawn-session them us))))) (spawn-session them us)))))
(let ((dst (udp-listener 6667))) (let ((dst (udp-listener 6667)))
(spawn #:name 'udp-echo-program (spawn #:name 'udp-echo-program
@ -61,25 +62,25 @@
(send! `(counter ,(counter))) (send! `(counter ,(counter)))
(counter (+ (counter) 1)))) (counter (+ (counter) 1))))
(forever (define us (tcp-listener 80)) (define us (tcp-listener 80))
(assert (outbound (advertise (observe (tcp-channel _ us _))))) (spawn (assert (outbound (advertise (observe (tcp-channel _ us _)))))
(during/spawn (inbound (advertise (tcp-channel ($ them (tcp-address _ _)) us _))) (during/spawn (inbound (advertise (tcp-channel ($ them (tcp-address _ _)) us _)))
#:name (list 'webserver-session them) #:name (list 'webserver-session them)
(log-info "Got connection from ~v" them) (log-info "Got connection from ~v" them)
(assert (outbound (advertise (tcp-channel us them _)))) (assert (outbound (advertise (tcp-channel us them _))))
(on (message (inbound (tcp-channel them us _)))) ;; ignore input (on (message (inbound (tcp-channel them us _)))) ;; ignore input
(on-start (send! 'bump)) (on-start (send! 'bump))
(on (message `(counter ,$counter)) (on (message `(counter ,$counter))
(define response (define response
(string->bytes/utf-8 (string->bytes/utf-8
(format (string-append (format (string-append
"HTTP/1.0 200 OK\r\n\r\n" "HTTP/1.0 200 OK\r\n\r\n"
"<h1>Hello world from syndicate-netstack!</h1>\n" "<h1>Hello world from syndicate-netstack!</h1>\n"
"<p>This is running on syndicate's own\n" "<p>This is running on syndicate's own\n"
"<a href='https://github.com/tonyg/syndicate/'>\n" "<a href='https://github.com/tonyg/syndicate/'>\n"
"TCP/IP stack</a>.</p>\n" "TCP/IP stack</a>.</p>\n"
"<p>There have been ~a requests prior to this one.</p>\n") "<p>There have been ~a requests prior to this one.</p>\n")
counter))) counter)))
(send! (outbound (tcp-channel us them response))) (send! (outbound (tcp-channel us them response)))
(stop-facet (current-facet-id))))))) (stop-facet (current-facet-id)))))))

25
examples/platformer/hll-main.rkt
View File

@ -671,17 +671,17 @@
;; kills the dataspace. ;; kills the dataspace.
(define (wait-for-level-termination) (define (wait-for-level-termination)
(react/suspend (done) (spawn
(assert (outbound (level-running))) (assert (outbound (level-running)))
(stop-when (retracted (game-piece-configuration player-id _ _ _)) (on (retracted (game-piece-configuration player-id _ _ _))
(log-info "Player died! Terminating level.") (log-info "Player died! Terminating level.")
(play-sound-sequence 270328) (play-sound-sequence 270328)
(done)) (quit-dataspace!))
(stop-when (message (inbound (level-completed))) (on (message (inbound (level-completed)))
(log-info "Level completed! Terminating level.") (log-info "Level completed! Terminating level.")
(play-sound-sequence 270330) (play-sound-sequence 270330)
(send! (outbound (add-to-score 100))) (send! (outbound (add-to-score 100)))
(done)))) (quit-dataspace!))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LevelSpawner ;; LevelSpawner
@ -816,5 +816,4 @@
(spawn-keyboard-integrator) (spawn-keyboard-integrator)
(spawn-scene-manager) (spawn-scene-manager)
(dataspace (spawn-score-keeper) (dataspace (spawn-score-keeper)
(spawn-level-spawner 0) (spawn-level-spawner 0))
(forever))

10
racket/syndicate/actor.rkt
View File

@ -57,6 +57,7 @@
patch! patch!
perform-actions! perform-actions!
flush! flush!
quit-dataspace!
syndicate-effects-available? syndicate-effects-available?
@ -342,10 +343,7 @@
(syntax-parse stx (syntax-parse stx
[(_ name:name script ...) [(_ name:name script ...)
(quasisyntax/loc stx (quasisyntax/loc stx
(let ((spawn-action (core:dataspace-actor (let ((spawn-action (core:dataspace-actor #:name name.N (actor-action script ...))))
#:name name.N
(actor-action script ...
(schedule-action! (core:quit-dataspace))))))
(if (syndicate-effects-available?) (if (syndicate-effects-available?)
(schedule-action! spawn-action) (schedule-action! spawn-action)
spawn-action)))])) spawn-action)))]))
@ -1322,6 +1320,10 @@
(until (core:message ack) (until (core:message ack)
(on-start (send! ack)))) (on-start (send! ack))))
(define (quit-dataspace!)
(ensure-in-script! 'quit-dataspace!)
(schedule-action! (core:quit-dataspace)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (format-field-descriptor d) (define (format-field-descriptor d)

4
racket/syndicate/dataspace.rkt
View File

@ -177,6 +177,10 @@
[(<actor> boot initial-assertions) [(<actor> boot initial-assertions)
(invoke-process (mux-next-pid (dataspace-mux w)) ;; anticipate pid allocation (invoke-process (mux-next-pid (dataspace-mux w)) ;; anticipate pid allocation
(lambda () (lambda ()
(when (not (trie? initial-assertions))
(error 'actor
"actor initial assertions must be trie; was ~v"
initial-assertions))
(match (boot) (match (boot)
[(and results (list (? procedure?) (? general-transition?) _)) [(and results (list (? procedure?) (? general-transition?) _))
results] results]

33
racket/syndicate/examples/actor/chat-no-quit-world.rkt
View File

@ -7,24 +7,23 @@
(struct says (who what) #:prefab) (struct says (who what) #:prefab)
(struct present (who) #:prefab) (struct present (who) #:prefab)
(dataspace (define us (tcp-listener 5999)) (define us (tcp-listener 5999))
(forever (dataspace (spawn (assert (outbound (advertise (observe (tcp-channel _ us _)))))
(assert (outbound (advertise (observe (tcp-channel _ us _))))) (during/spawn (inbound (advertise (tcp-channel $them us _)))
(during/spawn (inbound (advertise (tcp-channel $them us _))) (assert (outbound (advertise (tcp-channel us them _))))
(assert (outbound (advertise (tcp-channel us them _))))
(define (send-to-remote fmt . vs) (define (send-to-remote fmt . vs)
(send! (outbound (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))) (send! (outbound (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))))
(define user (gensym 'user)) (define user (gensym 'user))
(on-start (send-to-remote "Welcome, ~a.\n" user)) (on-start (send-to-remote "Welcome, ~a.\n" user))
(assert (present user)) (assert (present user))
(on (message (inbound (tcp-channel them us $bs))) (on (message (inbound (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)))))
(during (present $who) (during (present $who)
(unless (equal? who user) (unless (equal? who user)
(on-start (send-to-remote "~a arrived.\n" who)) (on-start (send-to-remote "~a arrived.\n" who))
(on-stop (send-to-remote "~a departed.\n" who)) (on-stop (send-to-remote "~a departed.\n" who))
(on (message (says who $what)) (send-to-remote "~a says: ~a\n" who what))))))) (on (message (says who $what)) (send-to-remote "~a says: ~a\n" who what)))))))

40
racket/syndicate/examples/actor/chat.rkt
View File

@ -8,27 +8,27 @@
(struct present (who) #:prefab) (struct present (who) #:prefab)
(struct shutdown () #:prefab) (struct shutdown () #:prefab)
(dataspace (define us (tcp-listener 5999)) (define us (tcp-listener 5999))
(until (message (shutdown)) (dataspace (spawn (on (message (shutdown)) (quit-dataspace!))
(assert (outbound (advertise (observe (tcp-channel _ us _))))) (assert (outbound (advertise (observe (tcp-channel _ us _)))))
(during/spawn (inbound (advertise (tcp-channel $them us _))) (during/spawn (inbound (advertise (tcp-channel $them us _)))
(assert (outbound (advertise (tcp-channel us them _)))) (assert (outbound (advertise (tcp-channel us them _))))
(define (send-to-remote fmt . vs) (define (send-to-remote fmt . vs)
(send! (outbound (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))) (send! (outbound (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))))
(define user (gensym 'user)) (define user (gensym 'user))
(on-start (send-to-remote "Welcome, ~a.\n" user)) (on-start (send-to-remote "Welcome, ~a.\n" user))
(assert (present user)) (assert (present user))
(on (message (inbound (tcp-channel them us $bs))) (on (message (inbound (tcp-channel them us $bs)))
(define input-string (string-trim (bytes->string/utf-8 bs))) (define input-string (string-trim (bytes->string/utf-8 bs)))
(if (equal? input-string "quit-dataspace") (if (equal? input-string "quit-dataspace")
(send! (shutdown)) (send! (shutdown))
(send! (says user input-string)))) (send! (says user input-string))))
(during (present $who) (during (present $who)
(unless (equal? who user) (unless (equal? who user)
(on-start (send-to-remote "~a arrived.\n" who)) (on-start (send-to-remote "~a arrived.\n" who))
(on-stop (send-to-remote "~a departed.\n" who)) (on-stop (send-to-remote "~a departed.\n" who))
(on (message (says who $what)) (send-to-remote "~a says: ~a\n" who what))))))) (on (message (says who $what)) (send-to-remote "~a says: ~a\n" who what)))))))

3
racket/syndicate/examples/actor/fib-server.rkt
View File

@ -50,4 +50,5 @@
(until (rising-edge (= (counter) 2))) (until (rising-edge (= (counter) 2)))
(log-info "Quitting main") (log-info "Quitting main")
(until (message (inbound (timer-expired 'wait _))) (until (message (inbound (timer-expired 'wait _)))
(on-start (send! (outbound (set-timer 'wait 100 'relative)))))) (on-start (send! (outbound (set-timer 'wait 100 'relative)))))
(quit-dataspace!))

3
racket/syndicate/examples/actor/query-set.rkt
View File

@ -65,5 +65,4 @@
(on-start (log-info "observer-in-ds: STARTING")) (on-start (log-info "observer-in-ds: STARTING"))
(define/query-set items (inbound* LEVEL `(item ,$a ,$b)) (list a b)) (define/query-set items (inbound* LEVEL `(item ,$a ,$b)) (list a b))
(on (message (inbound* LEVEL 'dump)) (on (message (inbound* LEVEL 'dump))
(log-info "observer-in-ds: ~v" (items)))) (log-info "observer-in-ds: ~v" (items))))))
(forever)))

9
racket/syndicate/examples/actor/sandbox-os.rkt
View File

@ -29,12 +29,13 @@
(dataspace (define id (symbol->string (gensym 'app))) (dataspace (define id (symbol->string (gensym 'app)))
(printf "Starting app ~a\n" id) (printf "Starting app ~a\n" id)
(schedule-action! (program-boot-actions 'syndicate/examples/actor/bank-account)) (schedule-action! (program-boot-actions 'syndicate/examples/actor/bank-account))
(forever (spawn
(assert (outbound (running-app id))) (assert (outbound (running-app id)))
(stop-when (message (inbound (kill-app id))) (on (message (inbound (kill-app id)))
(printf "Received signal for app ~a\n" id)) (printf "Received signal for app ~a\n" id)
(quit-dataspace!))
(during (account $balance) (during (account $balance)
(assert (outbound (named-account name balance))))))) (assert (outbound (named-account name balance)))))))
(run-bank-account 'a) (run-bank-account 'a)
(run-bank-account 'b) (run-bank-account 'b)