runtime/unxpth: Remove ./ when simplifying.

diff --git a/src/runtime/unxpth.scm b/src/runtime/unxpth.scm
index 8ee14b33d679c8ebb4cdb84418ff1b681dd9b246..1272b0ca2fb45e561682565c31a3284a60f2ab04 100644 (file)
--- 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