improved consistency of Windows filename handling

original commit: 9017943cdba8c54c8f0acf20b037174780c10039

LOG

@@ -1016,3 +1016,8 @@
   in threaded builds) when a lot of small objects are allocated by
   C code with no intervening Scheme-side allocation or dirty writes.
     alloc.c, types.h, externs.h
+- made Windows filename handling in directory-list, file-access-time,
+  file-change-time, file-directory?, file-exists?, file-modification-time,
+  get-mode, and path-absolute more consistent with
+  https://docs.microsoft.com/en-us/windows/desktop/FileIO/naming-a-file
+    6.ss, 6.ms, io.stex, release_notes.stex

csug/io.stex

@@ -3687,9 +3687,9 @@ are involved.
 
 \begin{tabular}{llllllll}
 path               & abs         & first              & rest               & parent             & last               & root               & ext       \\
-\scheme{c:}        & \scheme{#t} & \scheme{c:}        & \scheme{_}         & \scheme{c:}        & \scheme{_}         & \scheme{c:}        & \scheme{_} \\
+\scheme{c:}        & \scheme{#f} & \scheme{c:}        & \scheme{_}         & \scheme{c:}        & \scheme{_}         & \scheme{c:}        & \scheme{_} \\
 \scheme{c:/}       & \scheme{#t} & \scheme{c:/}       & \scheme{_}         & \scheme{c:/}       & \scheme{_}         & \scheme{c:/}       & \scheme{_} \\
-\scheme{c:a/b}     & \scheme{#t} & \scheme{c:}        & \scheme{a/b}       & \scheme{c:a}       & \scheme{b}         & \scheme{c:a/b}     & \scheme{_} \\
+\scheme{c:a/b}     & \scheme{#f} & \scheme{c:}        & \scheme{a/b}       & \scheme{c:a}       & \scheme{b}         & \scheme{c:a/b}     & \scheme{_} \\
 \scheme{//s/a/b.c} & \scheme{#t} & \scheme{//s}       & \scheme{a/b.c}     & \scheme{//s/a}     & \scheme{b.c}       & \scheme{//s/a/b}   & \scheme{c} \\
 \scheme{//s.com}   & \scheme{#t} & \scheme{//s.com}   & \scheme{_}         & \scheme{//s.com}   & \scheme{_}         & \scheme{//s.com}   & \scheme{_} \\
 \end{tabular}

mats/6.ms

@@ -1673,7 +1673,7 @@
 (begin (define-record $acyclic ((immutable notme))) (record-reader '$acyclic (type-descriptor $acyclic)))
 
 (xmat
-  "; Test error \"fasl object created by different release\"\n; This one is the list (a b c d) created by version 5.9b\n\n#@5.9b
a
b
c
d\f&\n"
+  "; Test error \"fasl object created by different release\"\n; This one is the list (a b c d) created by version 5.9b\n\n#@\x2;\x4;\x0;\x0;\x0;5.9b\x0;\x4;\x0;\x0;\x0;\x2;\x1;\x0;\x0;\x0;a\x2;\x1;\x0;\x0;\x0;b\x2;\x1;\x0;\x0;\x0;c\x2;\x1;\x0;\x0;\x0;d\f&\x0;\x0;\x0;\n"
   )
 
 (xmat
@@ -2858,7 +2858,7 @@
   (or (not (windows?))
       (> (length (directory-list "\\\\?\\c:\\")) 0))
   (or (not (windows?))
-      (> (length (directory-list "\\\\?\\c:")) 0))
+      (> (length (directory-list "\\\\?\\C:\\")) 0))
   (file-directory? "/")
   (file-directory? "/.")
   (file-exists? ".")
@@ -2869,7 +2869,7 @@
            (file-directory? "c:/."))
       (not (file-directory? "c:")))
   (if (windows?)
-      (and (file-directory? "\\\\?\\c:")
+      (and (not (file-directory? "\\\\?\\c:"))
            (file-directory? "\\\\?\\c:\\"))
       (not (file-directory? "\\\\?\\c:")))
   (if (windows?)
@@ -2878,7 +2878,7 @@
            (file-exists? "c:/."))
       (not (file-exists? "c:")))
   (if (windows?)
-      (and (file-exists? "\\\\?\\c:")
+      (and (not (file-exists? "\\\\?\\c:"))
            (file-exists? "\\\\?\\c:\\"))
       (not (file-exists? "\\\\?\\c:")))
   (if (windows?)
@@ -2899,9 +2899,9 @@
         (and (logtest m #o400)
              (not (logtest m #o111)))))
   (or (not (windows?))
-      (and (fixnum? (get-mode "c:"))
+      (and (fixnum? (get-mode "c:/"))
-           (eqv? (get-mode "c:") (get-mode "c:/"))
+           (eqv? (get-mode "c:/") (get-mode "C:\\"))
-           (eqv? (get-mode "c:") (get-mode "c:/."))))
+           (eqv? (get-mode "c:/") (get-mode "c:\\."))))
   (if (or (windows?) (embedded?))
       (fixnum? (get-mode "../mats"))
       (eqv? (logand (get-mode "../mats") #o700) #o700))
@@ -2930,9 +2930,9 @@
            (time? (file-change-time "c:/"))
            (time? (file-modification-time "c:/"))))
   (or (not (windows?))
-      (and (time? (file-access-time "\\\\?\\c:"))
+      (and (time? (file-access-time "\\\\?\\C:\\"))
-           (time? (file-change-time "\\\\?\\c:"))
+           (time? (file-change-time "\\\\?\\C:\\"))
-           (time? (file-modification-time "\\\\?\\c:"))))
+           (time? (file-modification-time "\\\\?\\C:\\"))))
   (or (not (windows?))
       (and (time? (file-access-time "\\\\?\\c:\\"))
            (time? (file-change-time "\\\\?\\c:\\"))
@@ -3120,9 +3120,7 @@
   (eq? (path-absolute? "/abc") #t)
   (eq? (path-absolute? "foo") #f)
   (eq? (path-absolute? "foo/bar/a.b") #f)
-  (eq?
+  (eq? (path-absolute? "c:abc") #f)
-    (path-absolute? "c:abc")
-    (and (windows?) #t))
 
   (equal? (path-parent "") "")
   (equal? (path-parent "a") "")
@@ -3275,17 +3273,17 @@
    ; windows
     (if (windows?)
         (table
-          ("c:" "t" "c:" "" "c:" "" "c:" "")
+          ("c:" "f" "c:" "" "c:" "" "c:" "")
           ("c:/" "t" "c:/" "" "c:/" "" "c:/" "")
-          ("c:.." "t" "c:" ".." "c:" ".." "c:.." "")
+          ("c:.." "f" "c:" ".." "c:" ".." "c:.." "")
-          ("c:../" "t" "c:" "../" "c:.." "" "c:../" "")
+          ("c:../" "f" "c:" "../" "c:.." "" "c:../" "")
-          ("c:../a" "t" "c:" "../a" "c:.." "a" "c:../a" "")
+          ("c:../a" "f" "c:" "../a" "c:.." "a" "c:../a" "")
-          ("c:." "t" "c:" "." "c:" "." "c:." "")
+          ("c:." "f" "c:" "." "c:" "." "c:." "")
-          ("c:./" "t" "c:" "./" "c:." "" "c:./" "")
+          ("c:./" "f" "c:" "./" "c:." "" "c:./" "")
-          ("c:./a" "t" "c:" "./a" "c:." "a" "c:./a" "")
+          ("c:./a" "f" "c:" "./a" "c:." "a" "c:./a" "")
           ("c:/abc" "t" "c:/" "abc" "c:/" "abc" "c:/abc" "")
-          ("c:abc" "t" "c:" "abc" "c:" "abc" "c:abc" "")
+          ("c:abc" "f" "c:" "abc" "c:" "abc" "c:abc" "")
-          ("c:abc/def" "t" "c:" "abc/def" "c:abc" "def" "c:abc/def" "")
+          ("c:abc/def" "f" "c:" "abc/def" "c:abc" "def" "c:abc/def" "")
           ("c:/abc/def" "t" "c:/" "abc/def" "c:/abc" "def" "c:/abc/def" "")
           ("//abc" "t" "//abc" "" "//abc" "" "//abc" "")
           ("//abc/" "t" "//abc" "" "//abc" "" "//abc/" "")

release_notes/release_notes.stex

@@ -1592,6 +1592,20 @@ in fasl files does not generally make sense.
 %-----------------------------------------------------------------------------
 \section{Bug Fixes}\label{section:bugfixes}
 
+\subsection{Disk-relative filenames in Windows (9.5.1)}
+
+In Windows, filenames that start with a disk designator but no
+directory separator are now treated as relative paths. For example,
+\scheme{(path-absolute? "C:")} now returns \scheme{#f}, and
+\scheme{(directory-list "C:")} now lists the files in the current
+directory on disk C instead of the files in the root directory of disk
+C.
+
+In addition, \scheme{file-access-time}, \scheme{file-change-time},
+\scheme{file-directory?}, \scheme{file-exists?},
+\scheme{file-modification-time}, and \scheme{get-mode} no longer
+remove trailing directory separators on Windows.
+
 \subsection{Globally unique names on non-Windows systems no longer contain the IP address (9.5.1)}
 
 The globally unique names of gensyms no longer contain the IP address

s/6.ss

@@ -128,15 +128,7 @@
          (let ([x (fp path follow?)])
            (if (fixnum? x)
                x
-               (if-feature windows
+               (err x)))]))))
-                 (let ([y (let ([n (string-length path)])
-                            (and (fx> n 0)
-                              (fp (if (directory-separator? (string-ref path (fx- n 1)))
-                                      (substring path 0 (fx- n 1))
-                                      (string-append path "\\"))
-                                  follow?)))])
-                   (if (fixnum? y) y (err x)))
-                 (err x))))]))))
 
 (let ()
   (define file-x-time
@@ -155,18 +147,7 @@
           (let ([x (path-fp file follow?)])
             (if (pair? x)
                 (make-time 'time-utc (cdr x) (car x))
-                (if-feature windows
+                (path-err file x)))
-                  (let ([y (let ([n (string-length file)])
-                             (and (fx> n 0)
-                               (path-fp
-                                 (if (directory-separator? (string-ref file (fx- n 1)))
-                                     (substring file 0 (fx- n 1))
-                                     (string-append file "\\"))
-                                 follow?)))])
-                    (if (pair? y)
-                        (make-time 'time-utc (cdr y) (car y))
-                        (path-err file x)))
-                  (path-err file x))))
           (let ([x (fd-fp (port-file-descriptor file))])
             (cond
               [(pair? x) (make-time 'time-utc (cdr x) (car x))]
@@ -208,9 +189,9 @@
                                        (and (not (char=? (string-ref path i) #\*))
                                             (nostars? (fx+ i 1))))))
                       ($oops who "invalid directory name ~s" path))
-                    (wl (if (directory-separator? (string-ref path (fx- n 1)))
+                    (wl (if (memv (string-ref path (fx- n 1)) '(#\\ #\/ #\:))
-                            (format "~a*" path)
+                            (string-append path "*")
-                            (format "~a\\*" path))))))
+                            (string-append path "\\*"))))))
               (foreign-procedure "(cs)directory_list" (string) scheme-object))])
     (lambda (path)
       (unless (string? path) ($oops who "~s is not a string" path))
@@ -237,15 +218,7 @@
         [(path) (file-exists? path #t)]
         [(path follow?)
          (unless (string? path) ($oops who "~s is not a string" path))
-         (if-feature windows
+         (fp path follow?)]))))
-           (or (fp path follow?)
-               (let ([n (string-length path)])
-                 (and (fx> n 0)
-                      (fp (if (directory-separator? (string-ref path (fx- n 1)))
-                              (substring path 0 (fx- n 1))
-                              (string-append path "\\"))
-                          follow?))))
-           (fp path follow?))]))))
 
 (define-who #(r6rs: file-exists?)
   (lambda (path)
@@ -267,15 +240,7 @@
         [(path) (file-directory? path #t)]
         [(path follow?)
          (unless (string? path) ($oops who "~s is not a string" path))
-         (if-feature windows
+         (fp path follow?)]))))
-           (or (fp path follow?)
-               (let ([n (string-length path)])
-                 (and (fx> n 0)
-                      (fp (if (directory-separator? (string-ref path (fx- n 1)))
-                              (substring path 0 (fx- n 1))
-                              (string-append path "\\"))
-                          follow?))))
-           (fp path follow?))]))))
 
 (define-who file-symbolic-link?
   (let ([fp (foreign-procedure "(cs)file_symbolic_linkp" (string) boolean)])
@@ -376,7 +341,7 @@
               (char=? (string-ref s 1) #\:)
               (let ([c (string-ref s 0)])
                 (or (char<=? #\a c #\z) (char<=? #\A c #\Z))))
-         (if (and (>= n 3) (directory-separator? (string-ref s 2))) 3 2)]
+         (if (and (fx>= n 3) (directory-separator? (string-ref s 2))) 3 2)]
         [(and windows?
               (fx>= n 4)
               (char=? (string-ref s 0) #\\)
@@ -388,7 +353,7 @@
                  (char=? (string-ref s 5) #\:)
                  (let ([c (string-ref s 4)])
                    (or (char<=? #\a c #\z) (char<=? #\A c #\Z))))
-            (if (and (>= n 7) (char=? (string-ref s 6) #\\)) 7 6)]
+            (if (and (fx>= n 7) (char=? (string-ref s 6) #\\)) 7 6)]
            [(and windows?
                  (fx>= n 8)
                  (char-ci=? (string-ref s 4) #\U)
@@ -427,22 +392,16 @@
 
   (set-who! path-absolute?
     (lambda (s)
-      (define directory-separator? (directory-separator-predicate s))
       (unless (string? s) ($oops who "~s is not a string" s))
       (let ([n (string-length s)])
         (or (and (fx>= n 1) (directory-separator? (string-ref s 0)))
             (and (fx>= n 1) (char=? (string-ref s 0) #\~))
             (and windows?
-                 (fx>= n 2)
+                 (fx>= n 3)
                  (char=? (string-ref s 1) #\:)
                  (let ([c (string-ref s 0)])
-                   (or (char<=? #\a c #\z) (char<=? #\A c #\Z))))
+                   (or (char<=? #\a c #\z) (char<=? #\A c #\Z)))
-            (and windows?
+                 (directory-separator? (string-ref s 2)))))))
-                 (fx>= n 4)
-                 (char=? (string-ref s 0) #\\)
-                 (char=? (string-ref s 1) #\\)
-                 (char=? (string-ref s 2) #\?)
-                 (char=? (string-ref s 3) #\\))))))
 
   (set-who! path-extension
     (lambda (s)