smalltalk-tng

view experiments/tng-scratch.scm @ 323:454c18798969

find changesets by author, revision, files, or words in the commit message
merger
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
date Tue Feb 07 11:34:20 2012 -0500 (3 months ago)
parents
children
line source
1 (require (lib "9.ss" "srfi")
2 (lib "1.ss" "srfi")
3 "queue.ss")
4
5 (define *runq* (make-q))
6
7 (define (schedule thunk)
8 (enq! *runq* thunk))
9
10 (define *throw-to-mainloop* '*throw-to-mainloop-not-initialised*)
11
12 (define (mainloop)
13 (begin
14 (call-with-current-continuation (lambda (cc) (set! *throw-to-mainloop* cc)))
15 (if (q-empty? *runq*)
16 (wait-for-events)
17 (begin
18 ((deq! *runq*))
19 (mainloop)))))
20
21 (define (throw-to-mainloop)
22 (*throw-to-mainloop* #f))
23
24 (define (wait-for-events) ;; %%%
25 (display "Waiting for events.")
26 (newline)
27 (exit))
28
29 (define-record-type
30
31 (define-record-type oop
32 (make-oop outputs input slots)
33 oop?
34 (outputs oop-outputs set-oop-outputs!)
35 (input oop-input set-oop-input!)
36 (slots oop-slots set-oop-slots!))
37
38 (define-record-type input-handler
39 (make-input-handler next proc datum)
40 input-handler?
41 (next input-handler-next)
42 (proc input-handler-proc)
43 (datum input-handler-datum))
44
45 (define *nil* '*nil*)
46
47 (define (primitive-new n)
48 (make-oop (make-q) #f (make-vector n *nil*)))
49
50 (define (oop-ref o n)
51 (vector-ref (oop-slots o) n))
52
53 (define (oop-set! o n x)
54 (vector-set! (oop-slots o) n x))
55
56 (define (oop-length o)
57 (vector-length (oop-slots o)))
58
59 (define (oop-send-full! oop message)
60 (let ((handler (oop-input oop)))
61 (if (not handler)
62 (enq! (oop-outputs oop) message)
63 (schedule (lambda () ((input-handler-proc handler)
64 (input-handler-datum handler)
65 #f
66 message))))))
67
68 ;; Channel send
69 ;; - RPC service ready
70 ;; (A) - if (isa message <message>),
71 ;; call service with selector+args, collect result, send to continuation
72 ;; else ERROR <message> expected
73 ;; - reader ready
74 ;; (B) - schedule reader action
75 ;; - none ready
76 ;; (C) - enqueue message
77 ;; Channel receive
78 ;; - RPC client ready
79 ;; - as for (B)
80 ;; - sender ready
81 ;; - as for (B)
82 ;; - none ready
83 ;; (D) - enqueue reader
84 ;; RPC client
85 ;; - RPC service ready
86 ;; (E) - call service with selector+args, returning result directly
87 ;; - reader ready
88 ;; (F) - build message and schedule reader action
89 ;; - none ready
90 ;; (G) - build message and enqueue
91 ;; RPC service
92 ;; - RPC client ready
93 ;; - as for (A)
94 ;; - sender ready
95 ;; - as for (A)
96 ;; - none ready
97 ;; (H) - enqueue RPC service
98
99 (define (oop-send-fast! oop selector argv)
100 (let ((handler (oop-input oop)))
101 (if (not handler)
102 (call-with-current-continuation
103 (lambda (k)
104 (let ((message (make-message k selector argv)))
105 (enq! (oop-outputs oop) message)
106 (throw-to-mainloop))))
107 ((input-handler-proc handler)
108 (input-handler-datum handler)
109 selector
110 argv))))
111
112 (define (*restoring-handler* datum selector message)
113 (set-oop-input! (vector-ref datum 0)
114 (vector-ref datum 1))
115 ((vector-ref datum 2)
116 (vector-ref datum 3)
117 selector
118 message))
119
120 (define (oop-hook-oneshot-input! oop handler-proc handler-datum)
121 (let ((outputs (oop-outputs oop)))
122 (if (q-empty? outputs)
123 (let ((old-handler (oop-input oop)))
124 (set-oop-input! oop (make-input-handler *restoring-handler*
125 (vector oop
126 old-handler
127 handler-proc
128 handler-datum))))
129 (let ((message (deq! outputs)))
130 (schedule
131 (handler-proc
132 handler-datum
133 #f
134 message)
135
136 (define (oop-hook-repeating-input! oop handler-proc handler-datum)
137 (set-oop-input! oop (make-input-handler handler-proc
138 handler-datum)))