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

130
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
(parameterize ([pretty-print-print-line (lambda (sexp)
(let ([prompt " "]
[old-liner (pretty-print-print-line)]) (parameterize ([pretty-print-print-line
(lambda (ln port ol cols) (let ([prompt " "]
(let ([ov (old-liner ln port ol cols)]) [old-liner (pretty-print-print-line)])
(if ln (lambda (ln port ol cols)
(begin (display prompt port) (let ([ov (old-liner ln port ol cols)])
(+ (string-length prompt) ov)) (if ln
ov))))]) (begin (display prompt port)
(pretty-print sexp) (+ (string-length prompt) ov))
(newline)))]) ov))))])
(unless (and in-port (pretty-print sexp)
out-port (newline)))])
(or (not (char-ready? in-port)) (unless (and in-port
(not (eof-object? (peek-char in-port))))) out-port
(restart-mred)) (or (not (char-ready? in-port))
(printf " ~a // ~a: sending to mred:~n" section-name test-name) (not (eof-object? (peek-char in-port)))))
(show-text sexp) (restart-mred))
(write sexp out-port) (printf " ~a // ~a: sending to mred:~n" section-name test-name)
(newline out-port) (show-text sexp)
(let ([answer (with-handlers ([(lambda (x) #t)
(with-handlers ([(lambda (x) #t) (lambda (x)
(lambda (x) (cond
(if (tcp-error? x);; assume tcp-error means app closed ;; this means that mred was closed
eof ;; so we can restart it and try again.
(list 'cant-read [(tcp-error? x)
(string-append (restart-mred)
(exn-message x) (write sexp out-port)
"; rest of string: " (newline out-port)]
(format [else (raise x)]))])
"~s" (write sexp out-port)
(apply (newline out-port))
string (let ([answer
(let loop () (with-handlers ([(lambda (x) #t)
(if (char-ready? in-port) (lambda (x)
(let ([char (read-char in-port)]) (if (tcp-error? x);; assume tcp-error means app closed
(if (eof-object? char) eof
null (list 'cant-read
(cons char (loop)))) (string-append
null))))))))]) (exn-message x)
(read in-port))]) "; rest of string: "
(unless (or (eof-object? answer) (format
(and (list? answer) "~s"
(= 2 (length answer)))) (apply
(error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer)) string
(let loop ()
(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