~ chicken-core (chicken-5) d71c259c7aa144993305d438e26853617376f70d
commit d71c259c7aa144993305d438e26853617376f70d
Author: felix <bunny351@gmail.com>
AuthorDate: Thu Apr 29 11:27:00 2010 +0200
Commit: felix <bunny351@gmail.com>
CommitDate: Thu Apr 29 11:27:00 2010 +0200
removed create-temporary-directory from setup-api; removed unused internal function; moved current-directory into posix-common.scm; fix in files.scm
diff --git a/eval.scm b/eval.scm
index 8d135070..1a901601 100644
--- a/eval.scm
+++ b/eval.scm
@@ -29,8 +29,7 @@
(unit eval)
(uses expand)
(disable-warning var)
- (hide ##sys#split-at-separator
- ##sys#r4rs-environment ##sys#r5rs-environment
+ (hide ##sys#r4rs-environment ##sys#r5rs-environment
##sys#interaction-environment pds pdss pxss d)
(not inline ##sys#repl-eval-hook ##sys#repl-read-hook ##sys#repl-print-hook
##sys#read-prompt-hook ##sys#alias-global-hook ##sys#user-read-hook
@@ -1065,18 +1064,6 @@
(define load-library ##sys#load-library)
-(define ##sys#split-at-separator
- (let ([reverse reverse] )
- (lambda (str sep)
- (let ([len (##sys#size str)])
- (let loop ([items '()] [i 0] [j 0])
- (cond [(fx>= i len)
- (reverse (cons (##sys#substring str j len) items)) ]
- [(char=? (##core#inline "C_subchar" str i) sep)
- (let ([i2 (fx+ i 1)])
- (loop (cons (##sys#substring str j i) items) i2 i2) ) ]
- [else (loop items (fx+ i 1) j)] ) ) ) ) ) )
-
(define ##sys#include-forms-from-file
(let ((load-verbose load-verbose)
(print print)
diff --git a/files.scm b/files.scm
index 0b7edf81..4288bb9e 100644
--- a/files.scm
+++ b/files.scm
@@ -42,8 +42,11 @@
(hide chop-pds absolute-pathname-root root-origin root-directory split-directory)
(disable-interrupts)
(foreign-declare #<<EOF
+#include <unistd.h>
+
#ifndef _WIN32
-# define C_mkdir(str) C_fix(mkdir(C_c_string(str), S_IRWXU | S_IRWXG | S_IRWXO))
+# include <sys/stat.h>
+# define C_mkdir(str) C_fix(mkdir(C_c_string(str), S_IRWXU | S_IRWXG | S_IRWXO))
#else
# define C_mkdir(str) C_fix(mkdir(C_c_string(str)))
#endif
@@ -211,6 +214,7 @@ EOF
(define make-pathname)
(define make-absolute-pathname)
+
(let ([string-append string-append]
[absolute-pathname? absolute-pathname?]
[def-pds "/"] )
@@ -257,16 +261,16 @@ EOF
(set! make-pathname
(lambda (dirs file #!optional ext)
- (_make-pathname 'make-pathname (canonicalize-dirs dirs pds) file ext pds)))
+ (_make-pathname 'make-pathname (canonicalize-dirs dirs def-pds) file ext def-pds)))
(set! make-absolute-pathname
(lambda (dirs file #!optional ext)
(_make-pathname
'make-absolute-pathname
- (let ([dir (canonicalize-dirs dirs pds)])
+ (let ([dir (canonicalize-dirs dirs def-pds)])
(if (absolute-pathname? dir)
dir
- (##sys#string-append (or pds def-pds) dir)) )
+ (##sys#string-append def-pds dir)) )
file ext pds) ) ) )
(define decompose-pathname
@@ -359,8 +363,7 @@ EOF
(or (get-environment-variable "TMPDIR")
(get-environment-variable "TEMP")
(get-environment-variable "TMP")
- (file-exists? "/tmp")
- (
+ "/tmp")))
(set! temp tmp)
tmp)))
(set! create-temporary-file
diff --git a/posix-common.scm b/posix-common.scm
index 508fad7f..ce61daa9 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -24,6 +24,31 @@
; POSSIBILITY OF SUCH DAMAGE.
+(declare
+ (foreign-declare #<<EOF
+
+#define C_curdir(buf) (getcwd(C_c_string(buf), 1024) ? C_fix(strlen(C_c_string(buf))) : C_SCHEME_FALSE)
+
+EOF
+))
+
+
+;;; Set or get current directory:
+
+(define current-directory
+ (let ([make-string make-string])
+ (lambda (#!optional dir)
+ (if dir
+ (change-directory dir)
+ (let* ([buffer (make-string 1024)]
+ [len (##core#inline "C_curdir" buffer)] )
+ #+(or unix cygwin)
+ (##sys#update-errno)
+ (if len
+ (##sys#substring buffer 0 len)
+ (##sys#signal-hook #:file-error 'current-directory "cannot retrieve current directory") ) ) ) ) ) )
+
+
;;; Find matching files:
(define find-files
diff --git a/posixunix.scm b/posixunix.scm
index 6f0bf358..70ec8a94 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -148,8 +148,6 @@ static C_TLS struct stat C_statbuf;
#define C_readdir(h,e) C_set_block_item(e, 0, (C_word) readdir((DIR *)C_block_item(h, 0)))
#define C_foundfile(e,b) (strcpy(C_c_string(b), ((struct dirent *) C_block_item(e, 0))->d_name), C_fix(strlen(((struct dirent *) C_block_item(e, 0))->d_name)))
-#define C_curdir(buf) (getcwd(C_c_string(buf), 256) ? C_fix(strlen(C_c_string(buf))) : C_SCHEME_FALSE)
-
#define open_binary_input_pipe(a, n, name) C_mpointer(a, popen(C_c_string(name), "r"))
#define open_text_input_pipe(a, n, name) open_binary_input_pipe(a, n, name)
#define open_binary_output_pipe(a, n, name) C_mpointer(a, popen(C_c_string(name), "w"))
@@ -945,17 +943,6 @@ EOF
(##sys#check-string fname 'directory?)
(*directory? 'directory? (##sys#expand-home-path fname)) )
-(define current-directory
- (let ([make-string make-string])
- (lambda (#!optional dir)
- (if dir
- (change-directory dir)
- (let* ([buffer (make-string 256)]
- [len (##core#inline "C_curdir" buffer)] )
- (if len
- (##sys#substring buffer 0 len)
- (posix-error #:file-error 'current-directory "cannot retrieve current directory") ) ) ) ) ) )
-
;;; Pipes:
diff --git a/posixwin.scm b/posixwin.scm
index 85cfd3b3..7d8dd59f 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -233,8 +233,6 @@ readdir(DIR * dir)
#define C_readdir(h,e) C_set_block_item(e, 0, (C_word) readdir((DIR *)C_block_item(h, 0)))
#define C_foundfile(e,b) (strcpy(C_c_string(b), ((struct dirent *) C_block_item(e, 0))->d_name), C_fix(strlen(((struct dirent *) C_block_item(e, 0))->d_name)))
-#define C_curdir(buf) (getcwd(C_c_string(buf), 256) ? C_fix(strlen(C_c_string(buf))) : C_SCHEME_FALSE)
-
#define open_binary_input_pipe(a, n, name) C_mpointer(a, _popen(C_c_string(name), "r"))
#define open_text_input_pipe(a, n, name) open_binary_input_pipe(a, n, name)
#define open_binary_output_pipe(a, n, name) C_mpointer(a, _popen(C_c_string(name), "w"))
@@ -1266,18 +1264,6 @@ EOF
(##sys#platform-fixup-pathname (##sys#expand-home-path fname)))))
(and info (fx= 1 (##sys#slot info 4))) ) )
-(define current-directory
- (let ([make-string make-string])
- (lambda (#!optional dir)
- (if dir
- (change-directory dir)
- (let* ([buffer (make-string 256)]
- [len (##core#inline "C_curdir" buffer)] )
- (##sys#update-errno)
- (if len
- (##sys#substring buffer 0 len)
- (##sys#signal-hook #:file-error 'current-directory "cannot retrieve current directory") ) ) ) ) ) )
-
;;; Pipes:
diff --git a/setup-api.scm b/setup-api.scm
index 4b1bfb5f..018f51ed 100644
--- a/setup-api.scm
+++ b/setup-api.scm
@@ -53,13 +53,12 @@
test-compile try-compile run-verbose
extra-features
copy-file move-file
- required-chicken-version required-extension-version cross-chicken
+ required-chicken-version required-extension-version
sudo-install keep-intermediates
version>=?
extension-name-and-version
extension-name
extension-version
- create-temporary-directory
remove-directory
remove-extension
read-info
@@ -753,17 +752,6 @@
(make-pathname (repository-path) egg ".setup-info")
read))
-(define (create-temporary-directory)
- (let ((dir (or (get-environment-variable "TMPDIR")
- (get-environment-variable "TEMP")
- (get-environment-variable "TMP")
- "/tmp")))
- (let loop ()
- (let* ((n (##sys#fudge 16)) ; current milliseconds
- (pn (make-pathname dir (string-append "chicken-install-" (number->string n 16)) "tmp")))
- (cond ((file-exists? pn) (loop))
- (else (create-directory pn) pn))))))
-
(define (remove-directory dir #!optional (strict #t))
(cond ((not (file-exists? dir))
(if strict
Trap