From 25f40fefb0198416fae8e952e40b3e143a4e782a Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Mon, 10 Nov 2008 23:36:11 -0500 Subject: [PATCH] Added the following file system primitives - file-readable? path -> boolean - file-writable? path -> boolean - file-executable? path -> boolean - file-size path -> integer - rename-file source dest -> void (thanks to Andreas Rottmann) --- ...ikarus.compiler.tag-annotation-analysis.ss | 3 + scheme/ikarus.posix.ss | 79 +++++++++++++++---- scheme/last-revision | 2 +- scheme/makefile.ss | 5 ++ src/ikarus-data.h | 4 + src/ikarus-pointers.c | 13 +++ src/ikarus-runtime.c | 59 ++++++++++++++ 7 files changed, 149 insertions(+), 16 deletions(-) diff --git a/scheme/ikarus.compiler.tag-annotation-analysis.ss b/scheme/ikarus.compiler.tag-annotation-analysis.ss index d45e0c6..a7ec02e 100644 --- a/scheme/ikarus.compiler.tag-annotation-analysis.ss +++ b/scheme/ikarus.compiler.tag-annotation-analysis.ss @@ -85,6 +85,9 @@ [file-exists? boolean] [file-regular? boolean] [file-directory? boolean] + [file-readable? boolean] + [file-writable? boolean] + [file-executable? boolean] [file-symbolic-link? boolean] [record? boolean] [record-field-mutable? boolean] diff --git a/scheme/ikarus.posix.ss b/scheme/ikarus.posix.ss index cc66747..95f516b 100644 --- a/scheme/ikarus.posix.ss +++ b/scheme/ikarus.posix.ss @@ -15,24 +15,27 @@ (library (ikarus.posix) - (export posix-fork fork waitpid system file-exists? delete-file - nanosleep getenv env environ file-ctime file-mtime - current-directory - file-regular? file-directory? file-symbolic-link? make-symbolic-link - directory-list make-directory delete-directory change-mode - kill strerror - wstatus-pid wstatus-exit-status wstatus-received-signal) + + (export + posix-fork fork waitpid system file-exists? delete-file + nanosleep getenv env environ file-ctime file-mtime + current-directory file-regular? file-directory? file-readable? + file-writable? file-executable? file-size rename-file + file-symbolic-link? make-symbolic-link directory-list + make-directory delete-directory change-mode kill strerror + wstatus-pid wstatus-exit-status wstatus-received-signal) + (import (rnrs bytevectors) (except (ikarus) - nanosleep - posix-fork fork waitpid system file-exists? delete-file - getenv env environ file-ctime file-mtime - current-directory - file-regular? file-directory? file-symbolic-link? make-symbolic-link - directory-list make-directory delete-directory change-mode - kill strerror - wstatus-pid wstatus-exit-status wstatus-received-signal)) + nanosleep posix-fork fork waitpid system file-exists? + delete-file getenv env environ file-ctime file-mtime + current-directory file-regular? file-directory? + file-readable? file-writable? file-executable? file-size + rename-file file-symbolic-link? make-symbolic-link + directory-list make-directory delete-directory change-mode + kill strerror wstatus-pid wstatus-exit-status + wstatus-received-signal)) (define posix-fork (lambda () @@ -151,6 +154,15 @@ [(-45) #f] ;; from ikarus-errno.c: ENOENT -- path does not exist [else (raise/strerror who r path)])))) + + (define access + (lambda (path how who) + (unless (string? path) + (die who "not a string" path)) + (let ([r (foreign-call "ikrt_access" (string->utf8 path) how)]) + (unless (boolean? r) (raise/strerror who r path)) + r))) + (define file-exists? (case-lambda [(path) (file-exists? path #t)] @@ -173,6 +185,29 @@ (lambda (path) (eq? 'symlink (stat path #f 'file-symbolic-link?)))) + + (define file-readable? + (lambda (path) + (access path 1 'file-readable?))) + + (define file-writable? + (lambda (path) + (access path 2 'file-writable?))) + + (define file-executable? + (lambda (path) + (access path 4 'file-executable?))) + + (define file-size + (lambda (path) + (define who 'file-size) + (unless (string? path) + (die who "filename is not a string" path)) + (let* ([v (foreign-call "ikrt_file_size" (string->utf8 path))]) + (if (>= v 0) + v + (raise/strerror who v path))))) + (define delete-file (lambda (x) (define who 'delete-file) @@ -183,6 +218,20 @@ (unless (eq? v #t) (raise/strerror who v x))))) + + (define rename-file + (lambda (src dst) + (define who 'rename-file) + (unless (string? src) + (die who "source file name is not a string" src)) + (unless (string? dst) + (die who "destination file name is not a string" dst)) + (let ([v (foreign-call "ikrt_rename_file" + (string->utf8 src) + (string->utf8 dst))]) + (unless (eq? v #t) + (raise/strerror who v src))))) + (define directory-list (lambda (path) (define who 'directory-list) diff --git a/scheme/last-revision b/scheme/last-revision index eeda100..8912fa1 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1664 +1665 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 23a9a01..7f18925 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -1246,9 +1246,13 @@ [vector-sort! i r sr] [file-exists? i r fi] [delete-file i r fi] + [rename-file i] [file-regular? i] [file-directory? i] [file-symbolic-link? i] + [file-readable? i] + [file-writable? i] + [file-executable? i] [current-directory i] [directory-list i] [make-directory i] @@ -1257,6 +1261,7 @@ [make-symbolic-link i] [file-ctime i] [file-mtime i] + [file-size i] [fork i] [define-record-type i r rs] [fields i r rs] diff --git a/src/ikarus-data.h b/src/ikarus-data.h index 504dd31..8336d62 100644 --- a/src/ikarus-data.h +++ b/src/ikarus-data.h @@ -220,6 +220,10 @@ ikptr ik_underflow_handler(ikpcb*); ikptr ik_unsafe_alloc(ikpcb* pcb, int size); ikptr ik_safe_alloc(ikpcb* pcb, int size); +ikptr u_to_number(unsigned long, ikpcb*); +ikptr ull_to_number(unsigned long long, ikpcb*); +ikptr normalize_bignum(long int limbs, int sign, ikptr r); + #define IK_HEAP_EXT_SIZE (32 * 4096) #define IK_HEAPSIZE (1024 * ((wordsize==4)?1:2) * 4096) /* 4/8 MB */ diff --git a/src/ikarus-pointers.c b/src/ikarus-pointers.c index d9798cb..85fecf6 100644 --- a/src/ikarus-pointers.c +++ b/src/ikarus-pointers.c @@ -3,6 +3,7 @@ #include #include #include +#include ikptr ikrt_isapointer(ikptr x, ikpcb* pcb){ @@ -262,6 +263,18 @@ u_to_number(unsigned long n, ikpcb* pcb) { return bn+vector_tag; } + +ikptr +ull_to_number(unsigned long long n, ikpcb* pcb) { + unsigned long long mxn = ((unsigned long)-1)>>(fx_shift+1); + if (n <= mxn) { + return fix(n); + } + ikptr bn = ik_safe_alloc(pcb, align(disp_bignum_data+sizeof(long long))); + bcopy((char*)(&n), (char*)(bn+disp_bignum_data), sizeof(long long)); + return normalize_bignum(sizeof(long long)/sizeof(mp_limb_t), 0, bn); +} + ikptr d_to_number(double n, ikpcb* pcb) { ikptr x = ik_safe_alloc(pcb, flonum_size) + vector_tag; diff --git a/src/ikarus-runtime.c b/src/ikarus-runtime.c index 75a0032..5d0fbe5 100644 --- a/src/ikarus-runtime.c +++ b/src/ikarus-runtime.c @@ -1037,3 +1037,62 @@ ikrt_debug(ikptr x){ fprintf(stderr, "DEBUG 0x%016lx\n", (long int)x); return 0; } + +ikptr +ikrt_access(ikptr filename, ikptr how /*, ikpcb* pcb */){ + char* fn = (char*)(filename + off_bytevector_data); + int r; + int ik_how; + int c_how; + + ik_how = unfix(how); + if (ik_how == 0) { + c_how = F_OK; + } else { + c_how = 0; + if (ik_how & 1) c_how |= R_OK; + if (ik_how & 2) c_how |= W_OK; + if (ik_how & 4) c_how |= X_OK; + } + + r = access(fn, c_how); + if (r == 0) { + return true_object; + } else if ((errno == EACCES) || + (errno == EROFS) || + (errno == ETXTBSY)) { + return false_object; + } else { + return ik_errno_to_code(); + } +} + +ikptr +ikrt_file_size(ikptr filename, ikpcb* pcb){ + char* fn = (char*)(filename + off_bytevector_data); + struct stat s; + int r = stat(fn, &s); + if (r == 0) { + if (sizeof(off_t) == sizeof(long)) { + return u_to_number(s.st_size, pcb); + } else if (sizeof(off_t) == sizeof(long long)) { + return ull_to_number(s.st_size, pcb); + } else { + fprintf(stderr, "internal error in ikarus: invalid off_t size\n"); + exit(-1); + } + } else { + return ik_errno_to_code(); + } +} + +ikptr +ikrt_rename_file(ikptr src, ikptr dst /* ikpcb* pcb */){ + int err = rename((char*)(src + off_bytevector_data), + (char*)(dst + off_bytevector_data)); + if (err == 0) { + return true_object; + } else { + return ik_errno_to_code(); + } +}