Author: koutou Date: Mon Dec 15 04:06:30 2008 New Revision: 5680
Modified: trunk/test/uim-test-utils-new.scm trunk/test/util/test-record.scm Log: * test/uim-test-utils-new.scm: add uim-eval and uim-raw-eval that don't read evaluated result. * test/util/test-record.scm: use uim-eval. Modified: trunk/test/uim-test-utils-new.scm ============================================================================== --- trunk/test/uim-test-utils-new.scm (original) +++ trunk/test/uim-test-utils-new.scm Mon Dec 15 04:06:30 2008 @@ -25,7 +25,7 @@ ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR ;;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ;;; ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -;;;; +;;; (define-module test.uim-test-utils-new (use gauche.process) @@ -78,42 +78,37 @@ (define (uim-sh-display string out) (uim-sh-output out (lambda () (display string)))) -(define (uim-sh-read in) +(define (uim-sh-read-block in) (set! (port-buffering in) :none) - (uim-sh-select in) - (let ((uim-sh-output (with-error-handler - (lambda (err) - ;; (report-error err) - (read-line in) ;; ignore read error - #f) - (lambda () - (read in))))) - (if (eq? 'Error: uim-sh-output) - (error (uim-sh-read-error in)) - uim-sh-output))) - -(define (uim-sh-read-error in) - (let* ((blocks (if *uim-sh-multiline-error* - (unfold (lambda (in) - (not (or (char-ready? in) - (begin - (sys-nanosleep 100000000) ;; 0.1s - (char-ready? in))))) - (lambda (in) - (read-block 4096 in)) - values - in) - (list (read-line in)))) - (msg (string-trim-both (string-concatenate blocks)))) - msg)) + (let ((result (call-with-output-string + (lambda (out) + (let loop ((ready (uim-sh-select in '(1 0)))) + (when ready + (display (read-block 4096 in) out) + (loop (uim-sh-select in 1)))))))) + (if (string-prefix? "Error:" result) + (error (string-trim-both result)) + result))) -(define (uim sexp) +(define (uim-read-from-string string) + (read-from-string string)) + +(define (uim-read in) + (uim-read-from-string (uim-sh-read-block in))) + +(define (uim-eval sexp) (uim-sh-write sexp (process-input *uim-sh-process*)) - (uim-sh-read (process-output *uim-sh-process*))) + (uim-sh-read-block (process-output *uim-sh-process*))) -(define (uim-raw string) +(define (uim sexp) + (uim-read-from-string (uim-eval sexp))) + +(define (uim-eval-raw string) (uim-sh-display string (process-input *uim-sh-process*)) - (uim-sh-read (process-output *uim-sh-process*))) + (uim-sh-read-block (process-output *uim-sh-process*))) + +(define (uim-raw string) + (uim-read-from-string (uim-eval-raw string))) (define (uim-bool sexp) (not (not (uim sexp)))) Modified: trunk/test/util/test-record.scm ============================================================================== --- trunk/test/util/test-record.scm (original) +++ trunk/test/util/test-record.scm Mon Dec 15 04:06:30 2008 @@ -53,13 +53,12 @@ (assert-uim-false '(symbol-bound? 'test-rec-set-fourth!)) (assert-uim-false '(symbol-bound? 'test-rec-set-fifth!)) - (assert-uim-true '(begin - (define-record 'test-rec - '((first #f) - (second foo) - (third "bar") - (fourth 4))) - #t)) ;; suppress closure result + (uim-eval '(begin + (define-record 'test-rec + '((first #f) + (second foo) + (third "bar") + (fourth 4))))) (assert-uim-true '(symbol-bound? 'test-rec-new)) (assert-uim-true '(symbol-bound? 'test-rec-first)) @@ -89,13 +88,12 @@ #f) (define (define-record) - (uim '(begin - (define-record 'test-rec - '((first #f) - (second foo) - (third "bar") - (fourth 4))) - #t))) ;; suppress closure result + (uim-eval '(begin + (define-record 'test-rec + '((first #f) + (second foo) + (third "bar") + (fourth 4)))))) (define (test-getters) (define-record)
