1(library (nmosh io core)
2         (export
3           io-dispatch-loop
4           io-dispatch
5           io-dispatch-sync
6
7           ;; process
8           launch!)
9         (import (nmosh io master-queue)
10                 (nmosh aio platform win32)
11                 (nmosh win32 util) ;; mbcs
12                 (yuni core)
13                 (shorten)
14                 (rnrs))
15
16(define Q nmosh-io-master-queue)
17
18(define (io-dispatch-loop)
19  (io-dispatch)
20  (io-dispatch-loop))
21
22(define io-dispatch/one
23  (case-lambda
24    (()
25     (queue-wait Q)
26     (queue-dispatch Q))
27    ((timeout)
28     (queue-wait/timeout Q timeout)
29     (queue-dispatch Q timeout))))
30
31(define-syntax io-dispatch-sync
32  (syntax-rules ()
33    ((_ resume form0 ...)
34     (call/cc (lambda (resume)
35                (let () form0 ...)
36                (io-dispatch-loop))))))
37
38;; FIXME: io-dispatch should dispach all queued events..
39(define io-dispatch io-dispatch/one)
40
41(define (do-plet-lookup obj sym default)
42  (let ((p (assoc sym obj)))
43    (if p
44      (cdr p)
45      default)))
46
47(define-syntax plet-bind
48  (syntax-rules ()
49    ((_ obj (prop default))
50     (plet-bind obj (prop prop default)))
51    ((_ obj (name prop default))
52     (define name (do-plet-lookup obj 'prop default)))
53    ((_ obj prop)
54     (plet-bind obj (prop prop #f)))))
55
56(define-syntax plet
57  (syntax-rules ()
58    ((_ obj (bind0 ...) body ...)
59     (let ()
60       (plet-bind obj bind0) ...
61       body ...))))
62
63(define-syntax prop-list
64  (syntax-rules ()
65    ((_) '())
66    ((_ (name prop ...) next ...)
67     (cons (list 'name prop ...)
68           (prop-list next ...)))
69    ((_ (name . prop) next ...)
70     (cons (cons 'name prop)
71           (prop-list next ...)))))
72
73(define-syntax launch!
74  (syntax-rules ()
75    ((_ propent0 propent1 ...)
76     (do-launch! (prop-list propent0 propent1 ...)))
77    ((_ name (propent0 propent1 ...))
78     (letrec ((name (launch! (propent0 propent1 ...))))
79       name))))
80
81(define (prop-append prop sym value)
82  ;; FIXME: check dupe.
83  (append prop
84          (list (list sym value))))
85(define (prop-replace prop sym value)
86  (define (item-name ent) (if (pair? ent) (car ent) ent))
87  (if (pair? prop)
88    (let ((item (item-name (car prop)))
89          (rest (cdr prop)))
90      (if (eq? item sym)
91        (cons (list sym value) rest)
92        (cons (car prop)
93              (prop-replace rest sym value))))
94    (list (list sym value))))
95
96;; FIXME:stub
97(define (fold-launch-prop prop)
98  (define (generate-finish finish-clause prop)
99    (define (create-g+s/binary)
100      (define buffer-list '())
101      (define (make-buffer)
102        (let ((bv (make-bytevector 4096)))
103          (set! buffer-list (cons bv buffer-list))
104          (set! current-buffer bv)
105          (set! ptr 0)
106          bv))
107      (define (buffer-size) (bytevector-length current-buffer))
108      (define (enough-space? size) (< (+ size ptr) (buffer-size)))
109
110      ;; buffer
111      (define current-buffer)
112      (define ptr)
113
114      (define (recv buf offset count) ;; => 0
115        ;(display (list 'recv recv offset count))(newline)
116        (cond
117          (buf
118            (cond
119              ((enough-space? count)
120               (bytevector-copy! buf offset current-buffer ptr count)
121               (set! ptr (+ ptr count))
122               0)
123              (else
124                (let* ((remain (- (buffer-size) ptr))
125                       (rest (- count remain)))
126                  (bytevector-copy! buf offset current-buffer ptr remain)
127                  (make-buffer)
128                  (bytevector-copy! buf (+ offset remain) current-buffer 0 rest)
129                  (set! ptr rest)
130                  0))))
131          (else
132            (assertion-violation 'aio-receive
133                                 "invalid argument"
134                                 buf))))
135
136      (define (finish/phase1) ;; => bv
137        (define total-size
138          (fold-left + 0 (map bytevector-length buffer-list)))
139        (define bv (make-bytevector total-size))
140        (define (copy-loop ptr cur)
141          (when (pair? cur)
142            (let* ((rest (cdr cur))
143                   (buf (car cur))
144                   (size (bytevector-length buf))
145                   (next (- ptr size)))
146              (bytevector-copy! buf 0 bv next size)
147              (copy-loop next rest))))
148        (copy-loop total-size buffer-list)
149        (set! buffer-list #f) ;; invalidate buffer
150        bv)
151      (define (finish)
152        (cond
153          ((= 0 ptr)
154           (set! buffer-list (cdr buffer-list)))
155          (else
156            (let ((rest (cdr buffer-list))
157                  (new-buf (make-bytevector ptr)))
158              (bytevector-copy! current-buffer 0 new-buf 0 ptr)
159              (set! buffer-list (cons new-buf rest)))))
160        (finish/phase1))
161      (make-buffer) ;; generate first buffer
162      (cons recv finish))
163    (define (create-g+s/string)
164      (let* ((bin (create-g+s/binary))
165             (recv/bin (car bin))
166             (finish/bin (cdr bin)))
167        (define (finish)
168          (mbcs->string (finish/bin)))
169        (cons recv/bin finish)))
170    (define (create-g+s type)
171      (define (string-type? x)
172        (case x
173          ((stdout/bin stderr/bin) #f)
174          ((stdout stderr) #t)
175          (else (assertion-violation 'launch!
176                                     "invalid argument"
177                                     x))))
178      (if (string-type? type)
179        (create-g+s/string)
180        (create-g+s/binary)))
181    (define (name-bin x)
182      (case x
183        ((stdout stdout/bin) 'stdout/bin)
184        ((stderr stderr/bin) 'stderr/bin)
185        (else (assertion-violation 'launch!
186                                   "invalid argument"
187                                   x))))
188    (let ((args (cdar finish-clause))
189          (orig-finish (cadr finish-clause)))
190      (let ((args-generator+getter (map create-g+s args)))
191        (define (invoke p) ((cdr p)))
192        (define (finish status)
193          (apply orig-finish (cons status
194                                   (map invoke args-generator+getter))))
195        (fold-left (^[cur sym e]
196                     (prop-append cur (name-bin sym) (car e)))
197                   (prop-replace prop 'finish finish)
198                   args
199                   args-generator+getter))))
200  (define (find-finish prop)
201    (find (^e (and (pair? (car e)) (eq? (caar e) 'finish)))
202                   prop))
203  (define (fold-finish prop)
204    (let ((finish-clause (find-finish prop)))
205      (if finish-clause
206        (generate-finish finish-clause prop)
207        prop)))
208  (fold-finish prop))
209
210;; base property set..
211;;  exec = argv[1..]
212;;  chdir = string(chdir)
213;;  stdout/bin = (^[buf offset count] ...)
214;;  stderr/bin = (^[buf offset count] ...)
215;;  finish = (^[status] ...)
216(define (do-launch! prop)
217  (define (pass/in x)
218    (if x
219      (pipe/in (car x))
220      (discard)))
221  (define (pass/result x)
222    (if x
223      (car x)
224      (lambda (bogus) 0)))
225  (let ((base-prop (fold-launch-prop prop)))
226    (plet base-prop (exec chdir stdout/bin stderr/bin finish)
227          (queue-process-launch
228            Q
229            exec
230            chdir
231            #f ;; FIXME: implement env*
232            (discard) ;; FIXME: implement input
233            (pass/in stdout/bin)
234            (pass/in stderr/bin)
235            (pass/result finish)))))
236
237)
238