From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 21 Oct 1988 22:22:10 +0000 (+0000)
Subject: Change directory reader to default the name/type/version to WILD, and
X-Git-Tag: 20090517-FFI~12486
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1b8c6e17e4fa3aa908d78e1cc513c6de076a70ab;p=mit-scheme.git

Change directory reader to default the name/type/version to WILD, and
to be faster for that default case.  Also add optional second argument
to disable sorting of output.  These changes combine to give a fairly
fast interface to the underlying directory reader.
---

diff --git a/v7/src/runtime/unxdir.scm b/v7/src/runtime/unxdir.scm
index 1e1ce6cf4..d5c3165ea 100644
--- a/v7/src/runtime/unxdir.scm
+++ b/v7/src/runtime/unxdir.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxdir.scm,v 14.2 1988/06/13 11:59:36 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxdir.scm,v 14.3 1988/10/21 22:21:28 cph Rel $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -37,52 +37,49 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 
-(define (initialize-package!)
-  (set! associate-on-name (association-procedure string=? car))
-  (set! type<? (component<? string<?))
-  (set! version<? (component<? <)))
-
-(define (directory-read pattern)
-  "Returns a list of all the files in `pattern' -- correctly handles
-wildcarding of whole pathname components, for example
-
-	*.scm
-	/u/cph/*/foo.*.*
-	foo.*.3
-	bar.*.0
-
-but doesn't do more general wildcarding like
-
-	foo*bar.scm
-"
-  (sort-pathnames
-   (let ((pattern (pathname->absolute-pathname (->pathname pattern))))
-     (map (let ((directory-path (pathname-directory-path pattern)))
-	    (lambda (pathname)
-	      (merge-pathnames directory-path pathname)))
-	  (let ((pathnames
-		 (generate-directory-pathnames
-		  (pathname-directory-string pattern))))
-	    (if (eq? (pathname-version pattern) 'NEWEST)
-		(extract-greatest-versions 
-		 (list-transform-positive pathnames
-		   (lambda (instance)
-		     (match-name&type pattern instance))))
+(define (directory-read pattern #!optional sort?)
+  (if (if (default-object? sort?) true sort?)
+      (sort (directory-read-nosort pattern) pathname<?)
+      (directory-read-nosort pattern)))
+
+(define (directory-read-nosort pattern)
+  (let ((pattern
+	 (pathname-default (pathname->absolute-pathname (->pathname pattern))
+			   false false false
+			   'WILD 'WILD 'WILD)))
+    (let ((directory-path (pathname-directory-path pattern)))
+      (let ((pathnames (generate-directory-pathnames directory-path)))
+	(cond ((and (eq? 'WILD (pathname-name pattern))
+		    (eq? 'WILD (pathname-type pattern))
+		    (eq? 'WILD (pathname-version pattern)))
+	       pathnames)
+	      ((not (eq? (pathname-version pattern) 'NEWEST))
+	       (list-transform-positive pathnames
+		 (lambda (instance)
+		   (and (match-component (pathname-name pattern)
+					 (pathname-name instance))
+			(match-component (pathname-type pattern)
+					 (pathname-type instance))
+			(match-component (pathname-version pattern)
+					 (pathname-version instance))))))
+	      (else
+	       (extract-greatest-versions 
 		(list-transform-positive pathnames
 		  (lambda (instance)
-		    (and (match-name&type pattern instance)
-			 (match-component
-			  (pathname-version pattern)
-			  (pathname-version instance)))))))))))
-
-(define (match-name&type pattern instance)
-  (and (match-component (pathname-name pattern) (pathname-name instance))
-       (match-component (pathname-type pattern) (pathname-type instance))))
-
-(define (match-component pattern instance)
-  (or (eq? pattern 'WILD)
-      (equal? pattern instance)))
-
+		    (and (match-component (pathname-name pattern)
+					  (pathname-name instance))
+			 (match-component (pathname-type pattern)
+					  (pathname-type instance))))))))))))
+
+(define (generate-directory-pathnames pathname)
+  (let loop
+      ((name ((ucode-primitive open-directory) (pathname->string pathname)))
+       (result '()))
+    (if name
+	(loop ((ucode-primitive directory-read))
+	      (cons (merge-pathnames pathname (string->pathname name))
+		    result))
+	(reverse! result))))
 (define (extract-greatest-versions pathnames)
   (let ((name-alist '()))
     (for-each (lambda (pathname)
@@ -106,9 +103,10 @@ but doesn't do more general wildcarding like
     (mapcan (lambda (name-entry)
 	      (map cdr (cdr name-entry)))
 	    name-alist)))
-
-(define (sort-pathnames pathnames)
-  (sort pathnames pathname<?))
+
+(define (match-component pattern instance)
+  (or (eq? pattern 'WILD)
+      (equal? pattern instance)))
 
 (define (pathname<? x y)
   (or (string<? (pathname-name x) (pathname-name y))
@@ -116,7 +114,12 @@ but doesn't do more general wildcarding like
 	   (or (type<? (pathname-type x) (pathname-type y))
 	       (and (equal? (pathname-type x) (pathname-type y))
 		    (version<? (pathname-version x) (pathname-version y)))))))
-
+
+(define (initialize-package!)
+  (set! associate-on-name (association-procedure string=? car))
+  (set! type<? (component<? string<?))
+  (set! version<? (component<? <)))
+
 (define associate-on-name)
 
 (define-integrable (associate-on-type type types)
@@ -128,11 +131,4 @@ but doesn't do more general wildcarding like
 	(else (and y (not (eq? 'UNSPECIFIC y)) (< x y)))))
 
 (define type<?)
-(define version<?)
-
-(define (generate-directory-pathnames directory-string)
-  (map string->pathname
-       (let loop ((name ((ucode-primitive open-directory) directory-string)))
-	 (if name
-	     (cons name (loop ((ucode-primitive directory-read))))
-	     '()))))
\ No newline at end of file
+(define version<?)
\ No newline at end of file
diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index adfc4e36b..f8e89d759 100644
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.24 1988/10/21 00:18:54 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.25 1988/10/21 22:22:10 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -45,7 +45,7 @@ MIT in each case. |#
 		     '()))
   (add-system! microcode-system)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-identification! "Runtime" 14 24))
+  (add-identification! "Runtime" 14 25))
 
 (define microcode-system)