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

put the receive-sexps-port.ss file in tmp

Browse Source 
svn: r9735
This commit is contained in:
Eli Barzilay 2008-05-08 11:59:13 +00:00
parent c0957923f0
commit 77c354e1c0
3 changed files with 28 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/tests/framework/framework-test-engine.ss
View File

@ -25,28 +25,27 @@
(lambda ()
(with-handlers ([(lambda (x) #t)
(lambda (x)
(printf "test suite thread died: ~a~n"
(printf "test suite thread died: ~a\n"
(if (exn? x)
(exn-message x)
(format "~s" x))))])
(let ([port (call-with-input-file
(build-path
(collection-path "tests" "framework")
"receive-sexps-port.ss")
(build-path (find-system-path 'temp-dir)
"framework-tests-receive-sexps-port.ss")
read)])
(debug-printf mr-tcp "about to connect to ~a~n" port)
(debug-printf mr-tcp "about to connect to ~a\n" port)
(let*-values ([(in out) (tcp-connect "127.0.0.1" port)])
(let loop ()
(debug-printf mr-tcp "about to read~n")
(debug-printf mr-tcp "about to read\n")
(let ([sexp (read in)])
(if (eof-object? sexp)
(begin
(debug-printf mr-tcp "got eof~n")
(debug-printf mr-tcp "got eof\n")
(close-input-port in)
(close-output-port out)
(exit))
(begin
(debug-printf mr-tcp "got expression to evaluate~n")
(debug-printf mr-tcp "got expression to evaluate\n")
(write
(let ([these-errs (protect (lambda () (begin0 errs (set! errs null))))])
(if (null? these-errs)

2
collects/tests/framework/info.ss
View File

@ -1,3 +1,3 @@
#lang setup/infotab
(define compile-omit-paths '("key-specs.ss" "utils.ss" "receive-sexps-port.ss"))
(define compile-omit-paths '("key-specs.ss" "utils.ss"))

46
collects/tests/framework/test-suite-utils.ss
View File

@ -52,31 +52,25 @@
(define load-framework-automatically? #t)
(define initial-port 6012)
(define port-filename (build-path
(collection-path "tests" "framework")
"receive-sexps-port.ss"))
(define port-filename
(build-path (find-system-path 'temp-dir)
"framework-tests-receive-sexps-port.ss"))
(unless (file-exists? port-filename)
(call-with-output-file port-filename
(lambda (port)
(write initial-port port))))
(lambda (port) (write initial-port port))))
(define listener
(let loop ()
(let ([port (call-with-input-file port-filename read)])
(with-handlers ([exn:fail?
(lambda (x)
(let ([next (+ port 1)])
(call-with-output-file port-filename
(lambda (p)
(write next p))
'truncate)
(debug-printf mz-tcp " tcp-listen failed for port ~a, attempting ~a~n"
port
next)
(loop)))])
(debug-printf mz-tcp "listening to ~a~n" port)
(tcp-listen port)))))
(let loop ([port (call-with-input-file port-filename read)])
(let ([l (with-handlers ([exn:fail? (lambda (_) #f)])
(tcp-listen port))])
(if l
(begin (debug-printf mz-tcp "listening to ~a\n" port)
(call-with-output-file port-filename
(lambda (p) (write port p)) 'truncate)
l)
(begin (debug-printf mz-tcp " tcp-listen failed for port ~a\n" port)
(loop (add1 port)))))))
(define in-port #f)
(define out-port #f)
@ -95,7 +89,7 @@
(path->string
(build-path (collection-path "tests" "framework")
"framework-test-engine.ss")))))
(debug-printf mz-tcp "accepting listener~n")
(debug-printf mz-tcp "accepting listener\n")
(let-values ([(in out) (tcp-accept listener)])
(set! in-port in)
(set! out-port out))
@ -116,7 +110,7 @@
(define shutdown-listener
(lambda ()
(shutdown-mred)
(debug-printf mz-tcp "closing listener~n")
(debug-printf mz-tcp "closing listener\n")
(tcp-close listener)))
(define shutdown-mred
@ -177,7 +171,7 @@
(or (not (char-ready? in-port))
(not (eof-object? (peek-char in-port))))))
(restart-mred))
(debug-printf messages " ~a // ~a: sending to mred:~n" section-name test-name)
(debug-printf messages " ~a // ~a: sending to mred:\n" section-name test-name)
(show-text sexp)
(with-handlers ([exn:fail?
(lambda (x)
@ -214,14 +208,14 @@
(cons char (loop))))
null))))))))])
(read in-port))])
(debug-printf messages " ~a // ~a: received from mred:~n" section-name test-name)
(debug-printf messages " ~a // ~a: received from mred:\n" section-name test-name)
(show-text answer)
(unless (or (eof-object? answer)
(and (list? answer)
(= 2 (length answer))
(memq (car answer)
'(error last-error cant-read normal))))
(error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer))
(error 'send-sexp-to-mred "unpected result from mred: ~s\n" answer))
(if (eof-object? answer)
(raise (make-eof-result))
(case (car answer)
@ -259,7 +253,7 @@
(format "~s" x))))])
(not (passed? result)))])
(when failed
(debug-printf schedule "FAILED ~a:~n ~s~n" test-name result)
(debug-printf schedule "FAILED ~a:\n ~s\n" test-name result)
(set! failed-tests (cons (cons section-name test-name) failed-tests))
(case jump
[(section) (section-jump)]