~ chicken-core (chicken-5) 2b5650ef6e9c141aed8ab8ed3875ad414aefaf3a
commit 2b5650ef6e9c141aed8ab8ed3875ad414aefaf3a
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Jul 5 09:49:34 2010 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Jul 5 09:49:34 2010 +0200
more posix-refactoring and fixing of bugs related to this
diff --git a/posix-common.scm b/posix-common.scm
index 248f6c27..a03861c9 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -53,6 +53,18 @@ static C_TLS struct stat C_statbuf;
EOF
))
+(include "common-declarations.scm")
+
+
+(define posix-error
+ (let ([strerror (foreign-lambda c-string "strerror" int)]
+ [string-append string-append] )
+ (lambda (type loc msg . args)
+ (let ([rn (##sys#update-errno)])
+ (apply ##sys#signal-hook type loc (string-append msg " - " (strerror rn)) args) ) ) ) )
+
+(define ##sys#posix-error posix-error)
+
;;; File properties
@@ -67,8 +79,6 @@ EOF
(define-foreign-variable _stat_st_mode unsigned-int "C_statbuf.st_mode")
(define-foreign-variable _stat_st_dev unsigned-int "C_statbuf.st_dev")
(define-foreign-variable _stat_st_rdev unsigned-int "C_statbuf.st_rdev")
-(define-foreign-variable _stat_st_blksize unsigned-int "C_statbuf.st_blksize")
-(define-foreign-variable _stat_st_blocks unsigned-int "C_statbuf.st_blocks")
(define-syntax (stat-mode x r c)
;; no need to rename here
@@ -179,6 +189,41 @@ EOF
(##sys#substring buffer 0 len)
(##sys#signal-hook #:file-error 'current-directory "cannot retrieve current directory") ) ) ) ) ) )
+(define delete-directory
+ (lambda (name)
+ (##sys#check-string name 'delete-directory)
+ (let ((sname (##sys#make-c-string (##sys#expand-home-path name) 'delete-directory)))
+ (unless (fx= 0 (##core#inline "C_rmdir" sname))
+ (posix-error #:file-error 'delete-directory "cannot delete directory" name) )
+ name)))
+
+(define directory
+ (let ([make-string make-string])
+ (lambda (#!optional (spec (current-directory)) show-dotfiles?)
+ (##sys#check-string spec 'directory)
+ (let ([buffer (make-string 256)]
+ [handle (##sys#make-pointer)]
+ [entry (##sys#make-pointer)] )
+ (##core#inline "C_opendir" (##sys#make-c-string (##sys#expand-home-path spec) 'directory) handle)
+ (if (##sys#null-pointer? handle)
+ (posix-error #:file-error 'directory "cannot open directory" spec)
+ (let loop ()
+ (##core#inline "C_readdir" handle entry)
+ (if (##sys#null-pointer? entry)
+ (begin
+ (##core#inline "C_closedir" handle)
+ '() )
+ (let* ([flen (##core#inline "C_foundfile" entry buffer)]
+ [file (##sys#substring buffer 0 flen)]
+ [char1 (string-ref file 0)]
+ [char2 (and (fx> flen 1) (string-ref file 1))] )
+ (if (and (eq? #\. char1)
+ (or (not char2)
+ (and (eq? #\. char2) (eq? 2 flen))
+ (not show-dotfiles?) ) )
+ (loop)
+ (cons file (loop)) ) ) ) ) ) ) ) ) )
+
;;; Filename globbing:
@@ -186,6 +231,7 @@ EOF
(let ((regexp regexp)
(string-match string-match)
(glob->regexp glob->regexp)
+ (directory directory)
(make-pathname make-pathname)
(decompose-pathname decompose-pathname) )
(lambda paths
@@ -196,7 +242,7 @@ EOF
(let-values (((dir fil ext) (decompose-pathname path)))
(let* ((patt (glob->regexp (make-pathname #f (or fil "*") ext)))
(rx (regexp patt)))
- (let loop ((fns (##sys#directory (or dir ".") #t)))
+ (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)))) )
diff --git a/posixunix.scm b/posixunix.scm
index ae437aa0..773f5d57 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -470,21 +470,13 @@ static int set_file_mtime(char *filename, C_word tm)
EOF
) )
-(include "common-declarations.scm")
+;; these are not available on Windows
-(register-feature! 'posix)
-
-(define posix-error
- (let ([strerror (foreign-lambda c-string "strerror" int)]
- [string-append string-append] )
- (lambda (type loc msg . args)
- (let ([rn (##sys#update-errno)])
- (apply ##sys#signal-hook type loc (string-append msg " - " (strerror rn)) args) ) ) ) )
+(define-foreign-variable _stat_st_blksize unsigned-int "C_statbuf.st_blksize")
+(define-foreign-variable _stat_st_blocks unsigned-int "C_statbuf.st_blocks")
;; Faster versions of common operations
-(define ##sys#posix-error posix-error)
-
(define ##sys#file-nonblocking!
(foreign-lambda* bool ([int fd])
"int val = fcntl(fd, F_GETFL, 0);"
@@ -777,43 +769,6 @@ EOF
(posix-error #:file-error 'change-directory "cannot change current directory" name) )
name)))
-(define delete-directory
- (lambda (name)
- (##sys#check-string name 'delete-directory)
- (let ((sname (##sys#make-c-string (##sys#expand-home-path name) 'delete-directory)))
- (unless (fx= 0 (##core#inline "C_rmdir" sname))
- (posix-error #:file-error 'delete-directory "cannot delete directory" name) )
- name)))
-
-(define ##sys#directory
- (let ([make-string make-string])
- (lambda (#!optional (spec (current-directory)) show-dotfiles?)
- (##sys#check-string spec 'directory)
- (let ([buffer (make-string 256)]
- [handle (##sys#make-pointer)]
- [entry (##sys#make-pointer)] )
- (##core#inline "C_opendir" (##sys#make-c-string (##sys#expand-home-path spec) 'directory) handle)
- (if (##sys#null-pointer? handle)
- (posix-error #:file-error 'directory "cannot open directory" spec)
- (let loop ()
- (##core#inline "C_readdir" handle entry)
- (if (##sys#null-pointer? entry)
- (begin
- (##core#inline "C_closedir" handle)
- '() )
- (let* ([flen (##core#inline "C_foundfile" entry buffer)]
- [file (##sys#substring buffer 0 flen)]
- [char1 (string-ref file 0)]
- [char2 (and (fx> flen 1) (string-ref file 1))] )
- (if (and (eq? #\. char1)
- (or (not char2)
- (and (eq? #\. char2) (eq? 2 flen))
- (not show-dotfiles?) ) )
- (loop)
- (cons file (loop)) ) ) ) ) ) ) ) ) )
-
-(define directory ##sys#directory)
-
;;; Pipes:
diff --git a/posixwin.scm b/posixwin.scm
index a3e9af43..9f313952 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -903,18 +903,10 @@ static int set_file_mtime(char *filename, C_word tm)
EOF
) )
-(include "common-declarations.scm")
-(register-feature! 'posix)
-
-(define posix-error
- (let ([strerror (foreign-lambda c-string "strerror" int)]
- [string-append string-append] )
- (lambda (type loc msg . args)
- (let ([rn (##sys#update-errno)])
- (apply ##sys#signal-hook type loc (string-append msg " - " (strerror rn)) args) ) ) ) )
+;;; common code
-(define ##sys#posix-error posix-error)
+(include "posix-common.scm")
;;; Lo-level I/O:
@@ -1138,46 +1130,6 @@ EOF
#:file-error 'change-directory "cannot change current directory" name) )
name)))
-(define delete-directory
- (lambda (name)
- (##sys#check-string name 'delete-directory)
- (let ((sname (##sys#make-c-string (##sys#expand-home-path name) 'delete-directory)))
- (unless (fx= 0 (##core#inline "C_rmdir" sname))
- (##sys#update-errno)
- (##sys#signal-hook #:file-error 'delete-directory "cannot delete directory" name) )
- name)))
-
-(define directory
- (let ([string-append string-append]
- [make-string make-string]
- [string string])
- (lambda (#!optional (spec (current-directory)) show-dotfiles?)
- (##sys#check-string spec 'directory)
- (let ([buffer (make-string 256)]
- [handle (##sys#make-pointer)]
- [entry (##sys#make-pointer)] )
- (##core#inline "C_opendir" (##sys#make-c-string (##sys#expand-home-path spec) 'directory) handle)
- (if (##sys#null-pointer? handle)
- (begin
- (##sys#update-errno)
- (##sys#signal-hook #:file-error 'directory "cannot open directory" spec) )
- (let loop ()
- (##core#inline "C_readdir" handle entry)
- (if (##sys#null-pointer? entry)
- (begin
- (##core#inline "C_closedir" handle)
- '() )
- (let* ([flen (##core#inline "C_foundfile" entry buffer)]
- [file (##sys#substring buffer 0 flen)]
- [char1 (string-ref file 0)]
- [char2 (and (> flen 1) (string-ref file 1))] )
- (if (and (eq? char1 #\.)
- (or (not char2)
- (and (eq? char2 #\.) (eq? flen 2))
- (not show-dotfiles?) ) )
- (loop)
- (cons file (loop)) ) ) ) ) ) ) ) ) )
-
;;; Pipes:
@@ -1932,8 +1884,3 @@ EOF
(define prot/none 0)
(define prot/read 0)
(define prot/write 0)
-
-
-;;; common code
-
-(include "posix-common.scm")
Trap