From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Wed, 20 Jul 2011 16:29:49 +0000 (-0700)
Subject: Rename test-{,g}port-performance.scm.
X-Git-Tag: mit-scheme-pucked-9.2.12~677
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9f06e5a6e97f90a37688bc9853627b05669b4df8;p=mit-scheme.git

Rename test-{,g}port-performance.scm.
---

diff --git a/tests/gtk/test-port-performance.scm b/tests/gtk/test-gport-performance.scm
similarity index 83%
rename from tests/gtk/test-port-performance.scm
rename to tests/gtk/test-gport-performance.scm
index e7b64ec64..bbb767026 100644
--- a/tests/gtk/test-port-performance.scm
+++ b/tests/gtk/test-gport-performance.scm
@@ -76,15 +76,17 @@ USA.
 (define (make-read-exprs with-input-port)
   (named-lambda (read-exprs)
     (map (lambda (file)
-	 (with-input-port
-	  file
-	  (lambda (port)
-	    (let loop ()
-	      (let ((obj (read port)))
-		(if (eof-object? obj)
-		    '()
-		    (cons obj (loop))))))))
-       (directory-read "../../src/runtime/*.scm"))))
+	   (with-input-port
+	    file
+	    (lambda (port)
+	      (let loop ()
+		(let ((obj (read port)))
+		  (if (eof-object? obj)
+		      '()
+		      (cons obj (loop))))))))
+	 (directory-read
+	  (merge-pathnames (->simple-pathname "../../src/runtime/")
+			   "*.scm")))))
 
 (define (make-write-exprs with-output-port)
   (named-lambda (write-exprs data)
@@ -117,17 +119,22 @@ USA.
 
 (define (call-with-input-gfile pathname receiver)
   (let* ((port ((access open-input-gfile (->environment '(gtk)))
-		(string-append "file://" (->truename* pathname))))
+		(string-append "file://" (->simple-namestring pathname))))
 	 (value (receiver port)))
     (close-input-port port)
     value))
 
-(define-integrable (->truename* pathname)
-  (let loop ((simpler (pathname-simplify (->truename pathname))))
+(define-integrable (->simple-namestring pathname)
+  (->namestring (->simple-pathname pathname)))
+
+(define (->simple-pathname pathname)
+  (let loop ((simpler (pathname-simplify
+		       (merge-pathnames pathname (working-directory-pathname))))
+	     (count 1))
     (let ((again (pathname-simplify simpler)))
-      (if (pathname=? again simpler)
-	  (->namestring again)
-	  (loop again)))))
+      (cond ((fix:> count 100) (error "Could not simplify:" pathname))
+	    ((pathname=? again simpler) again)
+	    (else (loop again (fix:1+ count)))))))
 
 (define (call-with-tmp-output-file receiver)
   (call-with-temporary-file-pathname
@@ -138,7 +145,8 @@ USA.
   (call-with-temporary-file-pathname
    (lambda (pathname)
      (let* ((port ((access open-output-gfile (->environment '(gtk)))
-		   (string-append "file://" (->truename* pathname))))
+		   (string-append "file://"
+				  (->simple-namestring pathname))))
 	    (value (receiver port)))
        (close-output-port port)
        value))))
@@ -156,4 +164,4 @@ USA.
   (loop 1))
 
 ;(register-test 'port-performance test-port-performance)
-(test-port-performance)
\ No newline at end of file
+;(test-port-performance)
\ No newline at end of file