From f176bc708ee499fb7756c1b07e82259f20f27545 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 6 Jun 2007 19:39:07 +0000
Subject: [PATCH] Rewrite PATHNAME-SIMPLIFY so that it better handles the case
 where part of the pathname refers to non-existing file structure.

---
 v7/src/runtime/unxpth.scm | 55 +++++++++++++++++++++------------------
 1 file changed, 29 insertions(+), 26 deletions(-)

diff --git a/v7/src/runtime/unxpth.scm b/v7/src/runtime/unxpth.scm
index 446b89083..b167f2de6 100644
--- a/v7/src/runtime/unxpth.scm
+++ b/v7/src/runtime/unxpth.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: unxpth.scm,v 14.33 2007/04/15 17:43:08 cph Exp $
+$Id: unxpth.scm,v 14.34 2007/06/06 19:39:07 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -318,28 +318,31 @@ USA.
 	 pathname)))
 
 (define (unix/pathname-simplify pathname)
-  (or (and (implemented-primitive-procedure? (ucode-primitive file-eq? 2))
-	   (let ((directory (pathname-directory pathname)))
-	     (and (pair? directory)
-		  (let ((directory*
-			 (cons (car directory)
-			       (reverse!
-				(let loop
-				    ((elements (reverse (cdr directory))))
-				  (if (pair? elements)
-				      (let ((head (car elements))
-					    (tail (loop (cdr elements))))
-					(if (and (eq? head 'UP)
-						 (pair? tail)
-						 (not (eq? (car tail) 'UP)))
-					    (cdr tail)
-					    (cons head tail)))
-				      '()))))))
-		    (and (not (equal? directory directory*))
-			 (let ((pathname*
-				(pathname-new-directory pathname directory*)))
-			   (and ((ucode-primitive file-eq? 2)
-				 (->namestring pathname)
-				 (->namestring pathname*))
-				pathname*)))))))
-      pathname))
\ No newline at end of file
+  (if (pair? (pathname-directory pathname))
+      (let loop ((pathname pathname) (np 1))
+	(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)))
+		pathname))))
+      pathname))
+
+(define (delete-up directory p)
+  (let loop ((p* directory))
+    (if (eq? p* p)
+	(cddr 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
-- 
2.25.1