suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

..

Browse Source 
original commit: c53e6ee932d82c68274375c48e710def981ed9e0
This commit is contained in:
Robby Findler 2000-08-21 16:49:14 +00:00
parent 984dd9daff
commit 0cac9609e5
1 changed files with 71 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

128
collects/tests/framework/main.ss
View File

@ -133,66 +133,78 @@
(regexp-match re:tcp-write-error (exn-message exn)))) (regexp-match re:tcp-write-error (exn-message exn))))
(define send-sexp-to-mred (define send-sexp-to-mred
(lambda (sexp) (let ([failed-last-time? #f])
(let ([show-text (lambda (sexp)
(lambda (sexp) (let/ec k
(let ([show-text
(lambda (sexp)
(parameterize ([pretty-print-print-line (parameterize ([pretty-print-print-line
(let ([prompt " "] (let ([prompt " "]
[old-liner (pretty-print-print-line)]) [old-liner (pretty-print-print-line)])
(lambda (ln port ol cols) (lambda (ln port ol cols)
(let ([ov (old-liner ln port ol cols)]) (let ([ov (old-liner ln port ol cols)])
(if ln (if ln
(begin (display prompt port) (begin (display prompt port)
(+ (string-length prompt) ov)) (+ (string-length prompt) ov))
ov))))]) ov))))])
(pretty-print sexp) (pretty-print sexp)
(newline)))]) (newline)))])
(unless (and in-port (unless (and in-port
out-port out-port
(or (not (char-ready? in-port)) (or (not (char-ready? in-port))
(not (eof-object? (peek-char in-port))))) (not (eof-object? (peek-char in-port)))))
(restart-mred)) (restart-mred))
(printf " ~a // ~a: sending to mred:~n" section-name test-name) (printf " ~a // ~a: sending to mred:~n" section-name test-name)
(show-text sexp) (show-text sexp)
(write sexp out-port) (with-handlers ([(lambda (x) #t)
(newline out-port) (lambda (x)
(let ([answer (cond
(with-handlers ([(lambda (x) #t) ;; this means that mred was closed
(lambda (x) ;; so we can restart it and try again.
(if (tcp-error? x);; assume tcp-error means app closed [(tcp-error? x)
eof (restart-mred)
(list 'cant-read (write sexp out-port)
(string-append (newline out-port)]
(exn-message x) [else (raise x)]))])
"; rest of string: " (write sexp out-port)
(format (newline out-port))
"~s" (let ([answer
(apply (with-handlers ([(lambda (x) #t)
string (lambda (x)
(let loop () (if (tcp-error? x);; assume tcp-error means app closed
(if (char-ready? in-port) eof
(let ([char (read-char in-port)]) (list 'cant-read
(if (eof-object? char) (string-append
null (exn-message x)
(cons char (loop)))) "; rest of string: "
null))))))))]) (format
(read in-port))]) "~s"
(unless (or (eof-object? answer) (apply
(and (list? answer) string
(= 2 (length answer)))) (let loop ()
(error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer)) (if (char-ready? in-port)
(let ([char (read-char in-port)])
(if (eof-object? char)
null
(cons char (loop))))
null))))))))])
(read in-port))])
(unless (or (eof-object? answer)
(and (list? answer)
(= 2 (length answer))))
(error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer))
(if (eof-object? answer) (if (eof-object? answer)
(raise (make-eof-result)) (raise (make-eof-result))
(case (car answer) (case (car answer)
[(error) [(error)
(error 'send-sexp-to-mred "mred raised \"~a\"" (second answer))] (error 'send-sexp-to-mred "mred raised \"~a\"" (second answer))]
[(cant-read) (error 'mred/cant-parse (second answer))] [(cant-read) (error 'mred/cant-parse (second answer))]
[(normal) [(normal)
(printf " ~a // ~a: received from mred:~n" section-name test-name) (printf " ~a // ~a: received from mred:~n" section-name test-name)
(show-text (second answer)) (show-text (second answer))
(eval (second answer))])))))) (eval (second answer))]))))))))
(define test (define test