master: pathnames: fix dot escaping with multiple preceding escapes

The branch "master" has been updated in SBCL:
       via  b6e0563c8a6bee1fd18c5297a3935086aa114946 (commit)
      from  4720de5763f11aab4e0feae250a3df065da473ab (commit)

- Log -----------------------------------------------------------------
commit b6e0563c8a6bee1fd18c5297a3935086aa114946
Author: Stas Boukarev <[email protected]>
Date:   Mon Apr 13 18:29:59 2026 +0300

    pathnames: fix dot escaping with multiple preceding escapes
---
 src/code/filesys.lisp     | 29 ++++++++++++++---------------
 tests/pathnames.pure.lisp | 29 ++++++++++++++++++++++++-----
 2 files changed, 38 insertions(+), 20 deletions(-)

diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index 485af16ce..aab1ac203 100644
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -258,21 +258,20 @@
 (defun extract-name-type-and-version (namestr start end escape-char)
   (declare (type simple-string namestr)
            (type index start end))
-  (flet ((escape-p (i)
-           (and (>= i start) (char= (aref namestr i) escape-char))))
-    (let ((last-dot
-            (loop for i from (1- end) downto (1+ start)
-                  when (and (char= (aref namestr i) #\.)
-                            (or (not (escape-p (1- i)))
-                                (escape-p (- i 2))))
-                  return i)))
-      (if last-dot
-          (values (maybe-make-pattern namestr start last-dot escape-char)
-                  (maybe-make-pattern namestr (1+ last-dot) end escape-char)
-                  :newest)
-          (values (maybe-make-pattern namestr start end escape-char)
-                  nil
-                  :newest)))))
+  (let ((last-dot
+          (loop for i from (1- end) downto (1+ start)
+                when (and (char= (aref namestr i) #\.)
+                          (evenp (loop for i from (1- i) downto start
+                                       while (char= (char namestr i) escape-char)
+                                       count t)))
+                return i)))
+    (if last-dot
+        (values (maybe-make-pattern namestr start last-dot escape-char)
+                (maybe-make-pattern namestr (1+ last-dot) end escape-char)
+                :newest)
+        (values (maybe-make-pattern namestr start end escape-char)
+                nil
+                :newest))))
 
 
 ;;;; Grabbing the kind of file when we have a native-namestring.
diff --git a/tests/pathnames.pure.lisp b/tests/pathnames.pure.lisp
index 7faf14a1a..8bc2d6ea9 100644
--- a/tests/pathnames.pure.lisp
+++ b/tests/pathnames.pure.lisp
@@ -1029,8 +1029,27 @@
     (assert (equal ";FOO.LISP" (enough-namestring pathname defaults)))))
 
 (with-test (:name :[-escaping)
-  (assert (pathname-match-p "n" (opaque-identity #p"[n\\]a]")))
-  (assert (pathname-match-p "]" (opaque-identity #p"[n\\]a]")))
-  (assert (pathname-match-p "a" (opaque-identity #p"[n\\]a]")))
-  (assert (not (pathname-match-p "c" (opaque-identity #p"[n\\]a]"))))
-  (assert (pathname-match-p "ab" (opaque-identity #p"[n\\]a]b"))))
+  #-win32
+  (progn
+    (assert (pathname-match-p "n" (opaque-identity #p"[n\\]a]")))
+    (assert (pathname-match-p "]" (opaque-identity #p"[n\\]a]")))
+    (assert (pathname-match-p "a" (opaque-identity #p"[n\\]a]")))
+    (assert (not (pathname-match-p "c" (opaque-identity #p"[n\\]a]"))))
+    (assert (pathname-match-p "ab" (opaque-identity #p"[n\\]a]b"))))
+  #+win32
+  (progn
+    (assert (pathname-match-p "n" (opaque-identity #p"[n^]a]")))
+    (assert (pathname-match-p "]" (opaque-identity #p"[n^]a]")))
+    (assert (pathname-match-p "a" (opaque-identity #p"[n^]a]")))
+    (assert (not (pathname-match-p "c" (opaque-identity #p"[n^]a]"))))
+    (assert (pathname-match-p "ab" (opaque-identity #p"[n^]a]b")))))
+
+(with-test (:name :dot-escaping)
+  #-win32
+  (progn
+    (assert (equal (pathname-name (pathname "\\\\\\.abc")) "\\.abc"))
+    (assert (not (pathname-type (pathname "\\\\\\.abc")))))
+  #+win32
+  (progn
+    (assert (equal (pathname-name (pathname "^^^.abc")) "^.abc"))
+    (assert (not (pathname-type (pathname "^^^.abc"))))))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL