From cf5b0184f071bad59fa8ce707f88f2059fa132ee Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 11 Jul 1995 23:10:49 +0000
Subject: [PATCH] New implementation of OS/TRIM-PATHNAME-STRING takes second
 argument (prefix to trim off) and tests to see if the prefix should be
 removed or retained.  This changes behavior in some unusual cases, but allows
 the \\foo\bar notation to be used on DOS/OS2/NT.

---
 v7/src/edwin/dos.scm  | 59 ++++++++-----------------------------------
 v7/src/edwin/os2.scm  | 18 ++++++-------
 v7/src/edwin/unix.scm | 25 +++++++-----------
 3 files changed, 28 insertions(+), 74 deletions(-)

diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm
index 831573653..d0c574dc0 100644
--- a/v7/src/edwin/dos.scm
+++ b/v7/src/edwin/dos.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: dos.scm,v 1.25 1995/05/05 22:32:23 cph Exp $
+;;;	$Id: dos.scm,v 1.26 1995/07/11 23:10:41 cph Exp $
 ;;;
 ;;;	Copyright (c) 1992-95 Massachusetts Institute of Technology
 ;;;
@@ -86,57 +86,18 @@ Includes the new backup.  Must be > 0."
 (define os/directory-char-set (char-set #\\ #\/))
 (define os/expand-char-set (char-set #\$ #\~))
 
-(define (os/trim-pathname-string string)
-  ;; Trim a filename with false starts to a unique name
-  (define (trim-for-duplicate-top-level-directory string)
-    (let ((end (string-length string)))
-      (let loop ((index end))
-	(let ((slash
-	       (substring-find-previous-char-in-set string 0 index
-						    os/directory-char-set)))
-	  (cond ((not slash) string)
-		((and (fix:< (fix:1+ slash) end)
-		      (char-set-member? os/expand-char-set
-					(string-ref string (fix:1+ slash))))
-		 (string-tail string (fix:1+ slash)))
-		((zero? slash)
-		 string)
-		((char-set-member? os/directory-char-set
-				   (string-ref string (fix:-1+ slash)))
-		 (string-tail string slash))
-		(else
-		 (loop (fix:-1+ slash))))))))
-
-  (define (trim-for-duplicate-device string)
-    (let ((end (string-length string))
-	  (sep (char-set-union (char-set #\:)
-			       (char-set-union
-				os/expand-char-set
-				os/directory-char-set))))
-      (let ((colon
-	     (substring-find-previous-char string 0 end #\:)))
-	(cond ((or (not colon) (zero? colon))
-	       string)
-	      ((and (fix:< (fix:1+ colon) end)
-		    (char-set-member? os/expand-char-set
-				      (string-ref string (fix:1+ colon))))
-	       (string-tail string (fix:1+ colon)))
-	      ((substring-find-previous-char-in-set string 0 colon sep)
-	       =>
-	       (lambda (before)
-		 (string-tail string 
-			      (if (char-set-member? os/expand-char-set
-						    (string-ref string before))
-				  before
-				  (fix:1+ before)))))
-	      (else
-	       string)))))
-
-  (trim-for-duplicate-device (trim-for-duplicate-top-level-directory string)))
+(define (os/trim-pathname-string string prefix)
+  (let ((index (string-match-forward prefix string)))
+    (if (and index
+	     (re-match-substring-forward
+	      (re-compile-pattern "[\\/$~]\\|[a-zA-Z]:" #t)
+	      #t #f string index (string-length string)))
+	(string-tail string index)
+	string)))
 
 (define os/pathname->display-string
   ->namestring)
-
+
 (define (file-type->version type version)
   (let ((version-string
 	 (and (fix:fixnum? version)
diff --git a/v7/src/edwin/os2.scm b/v7/src/edwin/os2.scm
index d291b8a82..87111b824 100644
--- a/v7/src/edwin/os2.scm
+++ b/v7/src/edwin/os2.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: os2.scm,v 1.18 1995/05/19 18:52:49 cph Exp $
+;;;	$Id: os2.scm,v 1.19 1995/07/11 23:10:34 cph Exp $
 ;;;
 ;;;	Copyright (c) 1994-95 Massachusetts Institute of Technology
 ;;;
@@ -90,14 +90,14 @@ Includes the new backup.  Must be > 0."
 
 ;;;; Filename I/O
 
-(define (os/trim-pathname-string string)
-  (let ((end (string-length string))
-	(pattern (re-compile-pattern "[\\/]\\([\\/$~]\\|[a-zA-Z]:\\)" #t)))
-    (let loop ((start 0))
-      (cond ((re-search-substring-forward pattern #t #f string start end)
-	     (loop (re-match-start-index 1)))
-	    ((fix:= start 0) string)
-	    (else (string-tail string start))))))
+(define (os/trim-pathname-string string prefix)
+  (let ((index (string-match-forward prefix string)))
+    (if (and index
+	     (re-match-substring-forward
+	      (re-compile-pattern "[\\/$~]\\|[a-zA-Z]:" #t)
+	      #t #f string index (string-length string)))
+	(string-tail string index)
+	string)))
 
 (define (os/pathname->display-string pathname)
   (or (let ((relative (enough-pathname pathname (user-homedir-pathname))))
diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm
index 1795113de..4d893c804 100644
--- a/v7/src/edwin/unix.scm
+++ b/v7/src/edwin/unix.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: unix.scm,v 1.51 1995/06/28 19:56:43 cph Exp $
+;;;	$Id: unix.scm,v 1.52 1995/07/11 23:10:49 cph Exp $
 ;;;
 ;;;	Copyright (c) 1989-95 Massachusetts Institute of Technology
 ;;;
@@ -88,21 +88,14 @@ Includes the new backup.  Must be > 0."
   2
   (lambda (n) (and (exact-integer? n) (> n 0))))
 
-(define (os/trim-pathname-string string)
-  (let ((end (string-length string)))
-    (let loop ((index end))
-      (let ((slash (substring-find-previous-char string 0 index #\/)))
-	(cond ((not slash)
-	       string)
-	      ((and (< (1+ slash) end)
-		    (memv (string-ref string (1+ slash)) '(#\~ #\$)))
-	       (string-tail string (1+ slash)))
-	      ((zero? slash)
-	       string)
-	      ((char=? #\/ (string-ref string (-1+ slash)))
-	       (string-tail string slash))
-	      (else
-	       (loop (-1+ slash))))))))
+(define (os/trim-pathname-string string prefix)
+  (let ((index (string-match-forward prefix string)))
+    (if (and index
+	     (re-match-substring-forward (re-compile-pattern "[/$~]" #t)
+					 #t #f string index
+					 (string-length string)))
+	(string-tail string index)
+	string)))
 
 (define (os/pathname->display-string pathname)
   (let ((pathname (enough-pathname pathname (user-homedir-pathname))))
-- 
2.25.1