From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Sat, 31 Aug 2013 21:59:26 +0000 (-0700)
Subject: runtime/unxpth: Remove ./ when simplifying.
X-Git-Tag: release-9.2.0~137
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=00aab1c7edd41b1d45bd01bf9861dc99270fa924;p=mit-scheme.git

runtime/unxpth: Remove ./ when simplifying.
---

diff --git a/src/runtime/unxpth.scm b/src/runtime/unxpth.scm
index 8ee14b33d..1272b0ca2 100644
--- a/src/runtime/unxpth.scm
+++ b/src/runtime/unxpth.scm
@@ -115,9 +115,9 @@ USA.
        (delete-matching-items components string-null?)))
 
 (define (parse-directory-component component)
-  (if (string=? ".." component)
-      'UP
-      component))
+  (cond ((string=? ".." component) 'UP)
+	((string=? "." component) 'HERE)
+	(else component)))
 
 (define (string-components string delimiter)
   (substring-components string 0 (string-length string) delimiter))
@@ -172,6 +172,7 @@ USA.
 
 (define (unparse-directory-component component)
   (cond ((eq? component 'UP) "..")
+	((eq? component 'HERE) ".")
 	((string? component) component)
 	(else
 	 (error:illegal-pathname-component component "directory component"))))
@@ -204,7 +205,7 @@ USA.
 		 (lambda (element)
 		   (if (string? element)
 		       (not (string-null? element))
-		       (eq? element 'UP)))))
+		       (memq element '(UP HERE))))))
 	  (simplify-directory directory))
 	 (else
 	  (error:illegal-pathname-component directory "directory")))
@@ -314,17 +315,23 @@ USA.
 	(let ((directory (pathname-directory pathname)))
 	  (let scan ((p (list-tail directory np)) (np np))
 	    (if (pair? p)
-		(if (and (not (eq? (car p) 'UP))
-			 (pair? (cdr p))
-			 (eq? (cadr p) 'UP))
-		    (let ((pathname*
-			   (pathname-new-directory pathname
-						   (delete-up directory p))))
-		      (if (file-eq? (directory-pathname pathname)
-				    (directory-pathname pathname*))
-			  (loop pathname* np)
-			  (scan (cddr p) (+ np 2))))
-		    (scan (cdr p) (+ np 1)))
+		(cond ((and (not (eq? (car p) 'UP))
+			    (pair? (cdr p))
+			    (eq? (cadr p) 'UP))
+		       (let ((pathname*
+			      (pathname-new-directory pathname
+						      (delete-up directory p))))
+			 (if (file-eq? (directory-pathname pathname)
+				       (directory-pathname pathname*))
+			     (loop pathname* np)
+			     (scan (cddr p) (+ np 2)))))
+		      ((eq? (car p) 'HERE)
+		       (let ((pathname*
+			      (pathname-new-directory pathname
+						      (delete-here directory p))))
+			 (loop pathname* np)))
+		      (else
+		       (scan (cdr p) (+ np 1))))
 		pathname))))
       pathname))
 
@@ -334,6 +341,12 @@ USA.
 	(cddr p*)
 	(cons (car p*) (loop (cdr p*))))))
 
+(define (delete-here directory p)
+  (let loop ((p* directory))
+    (if (eq? p* p)
+	(cdr p)
+	(cons (car p*) (loop (cdr p*))))))
+
 (define (file-eq? p1 p2)
   ((ucode-primitive file-eq? 2) (->namestring (merge-pathnames p1))
 				(->namestring (merge-pathnames p2))))
\ No newline at end of file