From 77c354e1c0d55d7b5bf65f9b03bc1f15e7098e0c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 8 May 2008 11:59:13 +0000 Subject: [PATCH] put the receive-sexps-port.ss file in tmp svn: r9735 --- .../tests/framework/framework-test-engine.ss | 15 +++--- collects/tests/framework/info.ss | 2 +- collects/tests/framework/test-suite-utils.ss | 46 ++++++++----------- 3 files changed, 28 insertions(+), 35 deletions(-) diff --git a/collects/tests/framework/framework-test-engine.ss b/collects/tests/framework/framework-test-engine.ss index 122e6c312c..7931b029e4 100644 --- a/collects/tests/framework/framework-test-engine.ss +++ b/collects/tests/framework/framework-test-engine.ss @@ -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) diff --git a/collects/tests/framework/info.ss b/collects/tests/framework/info.ss index e271d9238b..cce7f58000 100644 --- a/collects/tests/framework/info.ss +++ b/collects/tests/framework/info.ss @@ -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")) diff --git a/collects/tests/framework/test-suite-utils.ss b/collects/tests/framework/test-suite-utils.ss index 71cb91a826..3da9087317 100644 --- a/collects/tests/framework/test-suite-utils.ss +++ b/collects/tests/framework/test-suite-utils.ss @@ -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)]