From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 19 Nov 1999 14:10:49 +0000 (+0000)
Subject: New procedure DIRECTORY-FILE-NAMES for those cases when DIRECTORY-READ
X-Git-Tag: 20090517-FFI~4418
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1f85d4e8073910b8ad901aed9ddd7e26f05d7643;p=mit-scheme.git

New procedure DIRECTORY-FILE-NAMES for those cases when DIRECTORY-READ
is a pain.
---

diff --git a/v7/src/runtime/sfile.scm b/v7/src/runtime/sfile.scm
index 728b6e30f..358f3c1a0 100644
--- a/v7/src/runtime/sfile.scm
+++ b/v7/src/runtime/sfile.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: sfile.scm,v 14.20 1999/01/02 06:19:10 cph Exp $
+$Id: sfile.scm,v 14.21 1999/11/19 14:10:49 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -50,6 +50,25 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   ((ucode-primitive file-eq?) (->namestring (merge-pathnames x))
 			      (->namestring (merge-pathnames y))))
 
+(define (current-file-time)
+  (call-with-temporary-file-pathname file-modification-time))
+
+(define (directory-file-names directory)
+  (let ((channel
+	 (directory-channel-open
+	  (->namestring (pathname-as-directory directory)))))
+    (let loop ((result '()))
+      (let ((name (directory-channel-read channel)))
+	(if name
+	    (loop
+	     (if (or (string=? "." name)
+		     (string=? ".." name))
+		 result
+		 (cons name result)))
+	    (begin
+	      (directory-channel-close channel)
+	      result))))))
+
 (define (call-with-temporary-filename receiver)
   (call-with-temporary-file-pathname
    (lambda (pathname)
@@ -86,9 +105,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
        (vector-set! objects slot
 		    (delete! filename (vector-ref objects slot)))
        ((ucode-primitive set-fixed-objects-vector! 1) objects)))))
-
-(define (current-file-time)
-  (call-with-temporary-file-pathname file-modification-time))
 
 (define (guarantee-init-file-specifier object procedure)
   (if (not (init-file-specifier? object))