From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 10 Apr 1995 23:06:09 +0000 (+0000)
Subject: Fix OS/AUTO-SAVE-PATHNAME to rewrite the buffer name so that it uses
X-Git-Tag: 20090517-FFI~6471
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ead070095e5b4d3b2259f76304d473c301d6f546;p=mit-scheme.git

Fix OS/AUTO-SAVE-PATHNAME to rewrite the buffer name so that it uses
only legal HPFS characters, when the pathname includes the buffer
name.
---

diff --git a/v7/src/edwin/os2.scm b/v7/src/edwin/os2.scm
index 1fbd571ca..7c0474a4a 100644
--- a/v7/src/edwin/os2.scm
+++ b/v7/src/edwin/os2.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: os2.scm,v 1.10 1995/04/10 20:22:42 cph Exp $
+;;;	$Id: os2.scm,v 1.11 1995/04/10 23:06:09 cph Exp $
 ;;;
 ;;;	Copyright (c) 1994-95 Massachusetts Institute of Technology
 ;;;
@@ -234,20 +234,6 @@ Includes the new backup.  Must be > 0."
 		(cons (substring filename root-start root-end)
 		      version))))))
 
-(define (os/auto-save-pathname pathname buffer)
-  (let ((pathname
-	 (or pathname
-	     (let ((name (buffer-name buffer))
-		   (directory (buffer-default-directory buffer)))
-	       (merge-pathnames (if (os2/fs-long-filenames? directory)
-				    (string-append "%" name)
-				    "%buffer%")
-				directory)))))
-    (if (os2/fs-long-filenames? pathname)
-	(merge-pathnames (string-append "#" (file-namestring pathname) "#")
-			 (directory-pathname pathname))
-	(pathname-new-type pathname "sav"))))
-
 (define (os/auto-save-filename? filename)
   (or (re-match-string-forward (re-compile-pattern "^#.+#$" #f)
 			       #f
@@ -271,6 +257,41 @@ Includes the new backup.  Must be > 0."
 		(loop (+ i 1))))))
       (os/auto-save-pathname pathname #f)))
 
+(define (os/auto-save-pathname pathname buffer)
+  (let ((pathname
+	 (or pathname
+	     (let ((directory (buffer-default-directory buffer)))
+	       (merge-pathnames (if (os2/fs-long-filenames? directory)
+				    (string-append "%"
+						   (buffer-hpfs-name buffer))
+				    "%buffer%")
+				directory)))))
+    (if (os2/fs-long-filenames? pathname)
+	(merge-pathnames (string-append "#" (file-namestring pathname) "#")
+			 (directory-pathname pathname))
+	(pathname-new-type pathname "sav"))))
+
+(define (buffer-hpfs-name buffer)
+  (let ((name (buffer-name buffer)))
+    (let ((length (string-length name)))
+      (let ((copy (make-string length)))
+	(do ((i 0 (fix:+ i 1)))
+	    ((fix:= i length))
+	  (string-set!
+	   copy i
+	   (let ((char (string-ref name i)))
+	     (if (char-set-member? char-set:valid-hpfs-chars
+				   char)
+		 char
+		 #\_))))
+	copy))))
+
+(define char-set:valid-hpfs-chars
+  (char-set-invert
+   (char-set-union (char-set #\\ #\/ #\: #\* #\? #\" #\< #\> #\|)
+		   (char-set-union (ascii-range->char-set 0 #x21)
+				   (ascii-range->char-set #x7F #x100)))))
+
 ;;;; Miscellaneous
 
 (define (os/backup-buffer? truename)