57 lines
1.9 KiB
Scheme
57 lines
1.9 KiB
Scheme
|
|
(define child? (member "child" (vector->list (current-command-line-arguments))))
|
|
|
|
(define a-lot 500000)
|
|
|
|
(unless child?
|
|
(load-relative "loadtest.ss")
|
|
|
|
(let ([path (find-executable-path (find-system-path 'exec-file) #f)])
|
|
(let-values ([(subproc in out /err) (subprocess #f #f (current-error-port)
|
|
path "-rq"
|
|
(build-path (current-load-relative-directory)
|
|
"subproc2.ss")
|
|
"child")])
|
|
(test 'running subprocess-status subproc)
|
|
(test out object-wait-multiple 0 out)
|
|
(test #f object-wait-multiple 0 in)
|
|
(fprintf out "go~n")
|
|
|
|
(test "going" read-line in)
|
|
|
|
(test #t
|
|
positive?
|
|
;; Push a-lot chars; should block at least once:
|
|
(let ([s (make-string a-lot #\a)])
|
|
(let loop ([offset 0])
|
|
(let ([ready? (object-wait-multiple 0 out)])
|
|
(printf "~a ~a~n" offset ready?)
|
|
(+ (if ready? 0 1)
|
|
(let ([n (write-string-avail s out offset)])
|
|
(if (= (+ n offset) a-lot)
|
|
0
|
|
(loop (+ offset n)))))))))
|
|
|
|
(test "done" read-line in)
|
|
|
|
'ok)))
|
|
|
|
(when child?
|
|
(with-handlers ([void (lambda (x)
|
|
(fprintf (current-error-port) "CHILD ")
|
|
(raise x))])
|
|
(if (equal? "go" (read-line (current-input-port) 'any))
|
|
(printf "going~n")
|
|
(printf "not go!~n"))
|
|
|
|
(fprintf (current-error-port) "CHILD: starting sleep~n")
|
|
(sleep 1)
|
|
(fprintf (current-error-port) "CHILD: finished sleep; reading...~n")
|
|
|
|
(unless (= a-lot (string-length (read-string a-lot)))
|
|
(fprintf (current-error-port) "CHILD: bad read count"))
|
|
|
|
(printf "done~n")
|
|
|
|
'ok))
|