~ chicken-core (chicken-5) 88f742d318aa43c9ae3ac85b11ca1a6d8da9de85
commit 88f742d318aa43c9ae3ac85b11ca1a6d8da9de85
Author: felix <bunny351@gmail.com>
AuthorDate: Wed May 5 11:05:52 2010 +0200
Commit: felix <bunny351@gmail.com>
CommitDate: Wed May 5 11:05:52 2010 +0200
slight posix refactoring work; 2nd arg to find-files is optional; fixed unbound var in unix version of file-modification-time setter
diff --git a/manual/Unit posix b/manual/Unit posix
index f15d3096..74d0b009 100644
--- a/manual/Unit posix
+++ b/manual/Unit posix
@@ -1069,7 +1069,7 @@ These variables contain error codes as returned by {{errno}}.
==== find-files
-<procedure>(find-files DIRECTORY PREDICATE [ACTION [IDENTITY [LIMIT]]])</procedure>
+<procedure>(find-files DIRECTORY [PREDICATE [ACTION [IDENTITY [LIMIT]]]])</procedure>
Recursively traverses the contents of {{DIRECTORY}} (which should be a
string) and invokes the procedure {{ACTION}} for all files in which
@@ -1077,7 +1077,8 @@ the procedure {{PREDICATE}} is true. {{PREDICATE}} may be a procedure
of one argument or a regular-expression string. {{ACTION}} should be
a procedure of two arguments: the currently encountered file and the
result of the previous invocation of {{ACTION}}, or, if this is the
-first invocation, the value of {{IDENTITY}}. {{ACTION}} defaults to
+first invocation, the value of {{IDENTITY}}. {{PREDICATE}} defaults to
+{{(constantly #t)}}, {{ACTION}} defaults to
{{cons}}, {{IDENTITY}} defaults to {{()}}. {{LIMIT}} should be a
procedure of one argument that is called for each nested directory and
which should return true, if that directory is to be traversed
diff --git a/posix-common.scm b/posix-common.scm
index ce61daa9..0771a218 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -33,15 +33,43 @@ EOF
))
+;;; File properties
+
+(define (file-size f) (##sys#stat f #f 'file-size) _stat_st_size)
+
+(define file-modification-time
+ (getter-with-setter
+ (lambda (f)
+ (##sys#stat f #f 'file-modification-time) _stat_st_mtime)
+ (lambda (f t)
+ (##sys#check-number t 'set-file-modification-time)
+ (let ((r ((foreign-lambda int "set_file_mtime" c-string scheme-object)
+ (##sys#expand-home-path f) t)))
+ (when (fx< r 0)
+ (posix-error
+ #:file-error 'set-file-modification-time
+ "cannot set file modification-time" f t))))))
+
+(define (file-access-time f) (##sys#stat f #f 'file-access-time) _stat_st_atime)
+(define (file-change-time f) (##sys#stat f #f 'file-change-time) _stat_st_ctime)
+(define (file-owner f) (##sys#stat f #f 'file-owner) _stat_st_uid)
+(define (file-permissions f) (##sys#stat f #f 'file-permissions) _stat_st_mode)
+
+(define (regular-file? fname)
+ (##sys#check-string fname 'regular-file?)
+ (let ((info (##sys#file-info (##sys#expand-home-path fname))))
+ (and info (fx= 0 (##sys#slot info 4))) ) )
+
+
;;; Set or get current directory:
(define current-directory
- (let ([make-string make-string])
+ (let ((make-string make-string))
(lambda (#!optional dir)
(if dir
(change-directory dir)
- (let* ([buffer (make-string 1024)]
- [len (##core#inline "C_curdir" buffer)] )
+ (let* ((buffer (make-string 1024))
+ (len (##core#inline "C_curdir" buffer)) )
#+(or unix cygwin)
(##sys#update-errno)
(if len
@@ -49,46 +77,69 @@ EOF
(##sys#signal-hook #:file-error 'current-directory "cannot retrieve current directory") ) ) ) ) ) )
+;;; Filename globbing:
+
+(define glob
+ (let ((regexp regexp)
+ (string-match string-match)
+ (glob->regexp glob->regexp)
+ (directory directory)
+ (make-pathname make-pathname)
+ (decompose-pathname decompose-pathname) )
+ (lambda paths
+ (let conc-loop ((paths paths))
+ (if (null? paths)
+ '()
+ (let ((path (car paths)))
+ (let-values (((dir fil ext) (decompose-pathname path)))
+ (let* ((patt (glob->regexp (make-pathname #f (or fil "*") ext)))
+ (rx (regexp patt)))
+ (let loop ((fns (directory (or dir ".") #t)))
+ (cond ((null? fns) (conc-loop (cdr paths)))
+ ((string-match rx (car fns))
+ => (lambda (m) (cons (make-pathname dir (car m)) (loop (cdr fns)))) )
+ (else (loop (cdr fns))) ) ) ) ) ) ) ) ) ) )
+
+
;;; Find matching files:
(define find-files
- (let ([glob glob]
- [string-match string-match]
- [make-pathname make-pathname]
- [pathname-file pathname-file]
- [directory? directory?] )
- (lambda (dir pred . action-id-limit)
- (let-optionals
- action-id-limit
- ([action (lambda (x y) (cons x y))] ; we want cons inlined
- [id '()]
- [limit #f] )
+ (let ((glob glob)
+ (string-match string-match)
+ (make-pathname make-pathname)
+ (pathname-file pathname-file)
+ (directory? directory?) )
+ (lambda (dir #!optional
+ (pred (lambda _ #t))
+ (action (lambda (x y) (cons x y))) ; we want cons inlined
+ (id '())
+ (limit #f) )
(##sys#check-string dir 'find-files)
- (let* ([depth 0]
- [lproc
- (cond [(not limit) (lambda _ #t)]
- [(fixnum? limit) (lambda _ (fx< depth limit))]
- [else limit] ) ]
- [pproc
+ (let* ((depth 0)
+ (lproc
+ (cond ((not limit) (lambda _ #t))
+ ((fixnum? limit) (lambda _ (fx< depth limit)))
+ (else limit) ) )
+ (pproc
(if (or (string? pred) (regexp? pred))
(lambda (x) (string-match pred x))
- pred) ] )
- (let loop ([fs (glob (make-pathname dir "*"))]
- [r id] )
+ pred) ) )
+ (let loop ((fs (glob (make-pathname dir "*")))
+ (r id) )
(if (null? fs)
r
- (let ([f (##sys#slot fs 0)]
- [rest (##sys#slot fs 1)] )
- (cond [(directory? f)
- (cond [(member (pathname-file f) '("." "..")) (loop rest r)]
- [(lproc f)
+ (let ((f (##sys#slot fs 0))
+ (rest (##sys#slot fs 1)) )
+ (cond ((directory? f)
+ (cond ((member (pathname-file f) '("." "..")) (loop rest r))
+ ((lproc f)
(loop rest
- (fluid-let ([depth (fx+ depth 1)])
+ (fluid-let ((depth (fx+ depth 1)))
(loop (glob (make-pathname f "*"))
- (if (pproc f) (action f r) r)) ) ) ]
- [else (loop rest (if (pproc f) (action f r) r))] ) ]
- [(pproc f) (loop rest (action f r))]
- [else (loop rest r)] ) ) ) ) ) ) ) ) )
+ (if (pproc f) (action f r) r)) ) ) )
+ (else (loop rest (if (pproc f) (action f r) r))) ) )
+ ((pproc f) (loop rest (action f r)))
+ (else (loop rest r)) ) ) ) ) ) ) ) )
;;; TODO: add more here...
diff --git a/posixunix.scm b/posixunix.scm
index 70ec8a94..4682a154 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -785,31 +785,6 @@ EOF
_stat_st_dev _stat_st_rdev
_stat_st_blksize _stat_st_blocks) )
-(define (file-size f) (##sys#stat f #f 'file-size) _stat_st_size)
-
-(define file-modification-time
- (getter-with-setter
- (lambda (f)
- (##sys#stat f #f 'file-modification-time) _stat_st_mtime)
- (lambda (f t)
- (##sys#check-number t 'set-file-modification-time)
- (let ((r ((foreign-lambda int "set_file_mtime" c-string scheme-object)
- (##sys#expand-home-path file) t)))
- (when (fx< r 0)
- (posix-error
- #:file-error 'set-file-modification-time
- "cannot set file modification-time" f t))))))
-
-(define (file-access-time f) (##sys#stat f #f 'file-access-time) _stat_st_atime)
-(define (file-change-time f) (##sys#stat f #f 'file-change-time) _stat_st_ctime)
-(define (file-owner f) (##sys#stat f #f 'file-owner) _stat_st_uid)
-(define (file-permissions f) (##sys#stat f #f 'file-permissions) _stat_st_mode)
-
-(define (regular-file? fname)
- (##sys#check-string fname 'regular-file?)
- (##sys#stat fname #t 'regular-file?)
- (foreign-value "C_isreg" bool) )
-
(define (symbolic-link? fname)
(##sys#check-string fname 'symbolic-link?)
(##sys#stat fname #t 'symbolic-link?)
@@ -2023,30 +1998,6 @@ EOF
host) ) ) )
-;;; Filename globbing:
-
-(define glob
- (let ([regexp regexp]
- [string-match string-match]
- [glob->regexp glob->regexp]
- [directory directory]
- [make-pathname make-pathname]
- [decompose-pathname decompose-pathname] )
- (lambda paths
- (let conc-loop ([paths paths])
- (if (null? paths)
- '()
- (let ([path (car paths)])
- (let-values ([(dir fil ext) (decompose-pathname path)])
- (let* ([patt (glob->regexp (make-pathname #f (or fil "*") ext))]
- [rx (regexp patt)])
- (let loop ([fns (directory (or dir ".") #t)])
- (cond [(null? fns) (conc-loop (cdr paths))]
- [(string-match rx (car fns))
- => (lambda (m) (cons (make-pathname dir (car m)) (loop (cdr fns)))) ]
- [else (loop (cdr fns))] ) ) ) ) ) ) ) ) ) )
-
-
;;; Process handling:
(define process-fork
diff --git a/posixwin.scm b/posixwin.scm
index 7d8dd59f..75e53cc9 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -1097,33 +1097,6 @@ EOF
_stat_st_atime _stat_st_ctime _stat_st_mtime
0 0 0 0) )
-(define (file-size f) (##sys#stat f) _stat_st_size)
-
-(define file-modification-time
- (getter-with-setter
- (lambda (f)
- (##sys#stat f) _stat_st_mtime)
- (lambda (f t)
- (##sys#check-string f 'set-file-modification-time)
- (##sys#check-number t 'set-file-modification-time)
- (let ((r ((foreign-lambda int "set_file_mtime" c-string scheme-object)
- (##sys#expand-home-path f)
- t)))
- (when (fx< r 0)
- (posix-error
- #:file-error 'set-file-modification-time
- "cannot set file modification-time" f t))))))
-
-(define (file-access-time f) (##sys#stat f) _stat_st_atime)
-(define (file-change-time f) (##sys#stat f) _stat_st_ctime)
-(define (file-owner f) (##sys#stat f) _stat_st_uid)
-(define (file-permissions f) (##sys#stat f) _stat_st_mode)
-
-(define (regular-file? fname)
- (##sys#check-string fname 'regular-file?)
- (let ((info (##sys#file-info (##sys#expand-home-path fname))))
- (and info (fx= 0 (##sys#slot info 4))) ) )
-
(define (symbolic-link? fname)
(##sys#check-string fname 'symbolic-link?)
#f)
@@ -1707,30 +1680,6 @@ EOF
0)
(##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size) ) ) ) )
-;;; Filename globbing:
-
-(define glob
- (let ([regexp regexp]
- [string-match string-match]
- [glob->regexp glob->regexp]
- [directory directory]
- [make-pathname make-pathname]
- [decompose-pathname decompose-pathname] )
- (lambda paths
- (let conc-loop ([paths paths])
- (if (null? paths)
- '()
- (let ([path (car paths)])
- (let-values ([(dir fil ext) (decompose-pathname path)])
- (let* ([patt (glob->regexp (make-pathname #f (or fil "*") ext))]
- [rx (regexp patt)])
- (let loop ([fns (directory (or dir ".") #t)])
- (cond [(null? fns) (conc-loop (cdr paths))]
- [(string-match rx (car fns))
- => (lambda (m) (cons (make-pathname dir (car m)) (loop (cdr fns)))) ]
- [else (loop (cdr fns))] ) ) ) ) ) ) ) ) ) )
-
-
;;; Process handling:
(define-foreign-variable _p_overlay int "P_OVERLAY")
diff --git a/regex.scm b/regex.scm
index 17a3d84f..494c4702 100644
--- a/regex.scm
+++ b/regex.scm
@@ -264,7 +264,8 @@
(rest (cdr cs)) )
(cond ((char=? c #\*)
(if dir
- `((or (: (~ ("./\\")) (* (~ ("/\\"))))
+ `((or (: (~ ("./\\"))
+ (* (~ ("/\\"))))
(* (~ ("./\\"))))
,@(loop rest #f))
`((* (~ ("/\\"))) ,@(loop rest #f))))
diff --git a/types.db b/types.db
index 359c1f93..d8318400 100644
--- a/types.db
+++ b/types.db
@@ -761,7 +761,7 @@
(fileno/stderr fixnum)
(fileno/stdin fixnum)
(fileno/stdout fixnum)
-(find-files (procedure find-files (string * #!optional (procedure (string string) *) * fixnum) list))
+(find-files (procedure find-files (string #!optional * (procedure (string string) *) * fixnum) list))
(get-groups (procedure get-groups () list))
(get-host-name (procedure get-host-name () string))
(glob (procedure glob (#!rest string) list))
Trap