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