From 028f4d8bcc64d3d4a29dd923e3b46d22b989f1ba Mon Sep 17 00:00:00 2001
From: "Guillermo J. Rozas" <edu/mit/csail/zurich/gjr>
Date: Sat, 8 Aug 1992 16:23:06 +0000
Subject: [PATCH] Improve the pattern matcher to allow a trailing #\* to mean
 .* as well.

---
 v7/src/runtime/dosdir.scm | 17 +++++++++++++++--
 1 file changed, 15 insertions(+), 2 deletions(-)

diff --git a/v7/src/runtime/dosdir.scm b/v7/src/runtime/dosdir.scm
index 03d5dd82e..2f2bfb9cd 100644
--- a/v7/src/runtime/dosdir.scm
+++ b/v7/src/runtime/dosdir.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dosdir.scm,v 1.3 1992/08/06 13:45:41 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dosdir.scm,v 1.4 1992/08/08 16:23:06 jinx Exp $
 
 Copyright (c) 1992 Massachusetts Institute of Technology
 
@@ -37,6 +37,8 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 
+(define directory-read/adjust-patterns? true)
+
 (define (directory-read pattern #!optional sort?)
   (if (if (default-object? sort?) true sort?)
       (sort (directory-read-nosort pattern) pathname<?)
@@ -44,7 +46,7 @@ MIT in each case. |#
 
 (define (directory-read-nosort pattern)
   (let ((pattern
-	 (let ((pattern (merge-pathnames pattern)))
+	 (let ((pattern (adjust-directory-pattern (merge-pathnames pattern))))
 	   (let ((name (pathname-name pattern))
 		 (type (pathname-type pattern)))
 	     (if (or name type)
@@ -73,6 +75,17 @@ MIT in each case. |#
 		       (and (match-name (pathname-name instance))
 			    (match-type (pathname-type instance))))))))))))
 
+(define (adjust-directory-pattern pathname)
+  (if (and directory-read/adjust-patterns?
+	   (not (pathname-type pathname))
+	   (let ((name (pathname-name pathname)))
+	     (and (string? name)
+		  (let ((len (string-length name)))
+		    (and (> len 0)
+			 (char=? (string-ref name (-1+ len)) #\*))))))
+      (pathname-new-type pathname 'WILD)
+      pathname))
+
 (define (generate-directory-pathnames pathname)
   (let ((channel (directory-channel-open (->namestring pathname))))
     (let loop ((result '()))
-- 
2.25.1