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.

diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm
index 83157365321774f2a107942a4019d72c660589c5..d0c574dc02c32427f88e90c46556601f8b13c87b 100644 (file)
--- 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)
-\f
+
 (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 d291b8a82ceb69e8411b3b2e48cf85599125bbe2..87111b824de8bcd54b6602f27c816122c0b186dd 100644 (file)
--- 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."
 \f
 ;;;; 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 1795113de48e9db2021d5db6f67238f04f56c3fc..4d893c8046725a217869e8a97cc348fe59cdbd14 100644 (file)
--- 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))))
 \f
-(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))))