Changes from Derick Eddington supporting file system info:

- Added file-regular?, file-directory?, file-symbolic-link?,
  directory-list, make-directory, delete-directory, change-mode, 
  and make-symbolic-link.

- Bug fix in ikrt_open_input_fd and ikrt_open_output_fd which
  considered a 0 FD as an error.

- Bug fix in ikrt_getcwd about len+1.

- Bug fix of &i/o-file-protection which didn't have &i/o-filename as
  its parent.

- There is a new src/ikarus-errno.c file.  

- Made tcp-connect and friends tell when they "failed to resolve
  host name or connect".

- To support the uses of &i/o-filename subtypes, I modified
  print-condition so it will cleanly print the parents' fields of a
  condition;
This commit is contained in:
Abdulaziz Ghuloum 2008-05-31 10:43:55 -07:00
parent 6437aa98e0
commit 53905b9eea
11 changed files with 377 additions and 311 deletions

Binary file not shown.

View File

@ -311,7 +311,7 @@
make-i/o-filename-error i/o-filename-error?
(filename i/o-error-filename))
(define-condition-type &i/o-file-protection &i/o
(define-condition-type &i/o-file-protection &i/o-filename
make-i/o-file-protection-error i/o-file-protection-error?)
(define-condition-type &i/o-file-is-read-only &i/o-file-protection
@ -351,28 +351,38 @@
(define print-condition
(let ()
(define (print-simple-condition x p)
(let f ([rtd (record-rtd x)])
(let* ([rtd (record-rtd x)]
[rf (let l ([rtd rtd] [accum '()])
(if rtd
(l (record-type-parent rtd)
(cons
(cons rtd (record-type-field-names rtd))
accum))
(remp (lambda (a) (zero? (vector-length (cdr a))))
accum)))]
[rf-len (apply + (map vector-length
(map cdr rf)))])
(let ([name (record-type-name rtd)])
(display name p))
(let ([v (record-type-field-names rtd)])
(case (vector-length v)
[(0) (newline p)]
[(1)
(display ": " p)
(write ((record-accessor rtd 0) x) p)
(newline p)]
[else
(display ":\n" p)
(let f ([i 0])
(unless (= i (vector-length v))
(display " " p)
(display (vector-ref v i) p)
(display ": " p)
(write ((record-accessor rtd i) x) p)
(newline)
(f (+ i 1))))]))))
;; (let ([parent (record-type-parent rtd)])
;; (when parent (f parent)))))
(display name p))
(case rf-len
[(0) (newline p)]
[(1)
(display ": " p)
(write ((record-accessor (caar rf) 0) x) p)
(newline p)]
[else
(display ":\n" p)
(for-each
(lambda (a)
(let f ([i 0] [rtd (car a)] [v (cdr a)])
(unless (= i (vector-length v))
(display " " p)
(display (vector-ref v i) p)
(display ": " p)
(write ((record-accessor rtd i) x) p)
(newline)
(f (+ i 1) rtd v))))
rf)])))
(define (print-condition x p)
(cond
[(condition? x)

View File

@ -76,7 +76,6 @@
(import
(ikarus system $io)
(except (ikarus)
port? input-port? output-port? textual-port? binary-port?
open-file-input-port open-input-file
@ -1187,54 +1186,26 @@
(eof-object? (lookahead-u8 p)))]
[else (die 'port-eof? "not an input port" p)])))
(define EAGAIN-error-code -22) ;;; from ikarus-io.c
(define io-errors-vec
'#(#| 0 |# "unknown error"
#| 1 |# "bad file name"
#| 2 |# "operation interrupted"
#| 3 |# "not a directory"
#| 4 |# "file name too long"
#| 5 |# "missing entities"
#| 6 |# "insufficient access privileges"
#| 7 |# "circular path"
#| 8 |# "file is a directory"
#| 9 |# "file system is read-only"
#| 10 |# "maximum open files reached"
#| 11 |# "maximum open files reached"
#| 12 |# "ENXIO"
#| 13 |# "operation not supported"
#| 14 |# "not enough space on device"
#| 15 |# "quota exceeded"
#| 16 |# "io error"
#| 17 |# "device is busy"
#| 18 |# "access fault"
#| 19 |# "file already exists"
#| 20 |# "invalid file name"
#| 21 |# "non-blocking operation would block"
#| 22 |# "broken pipe (e.g., writing to a closed process or socket)"
#| 23 |# "connection refused"
#| 24 |# "not a socket"
#| 25 |# "not enough memory to perform operation"
))
(define EAGAIN-error-code -6) ;;; from ikarus-errno.c
(define (io-error who id err . other-conditions)
(let ([err (fxnot err)])
(let ([msg
(cond
[(fx< err (vector-length io-errors-vec))
(vector-ref io-errors-vec err)]
[else "unknown error"])])
(raise
(apply condition
(make-who-condition who)
(make-i/o-error)
(case err
[(6 9 18) (make-i/o-file-protection-error)]
[(19) (make-i/o-file-already-exists-error id)]
[else (condition)])
(make-message-condition msg)
(make-i/o-filename-error id)
other-conditions)))))
(raise
(apply condition
(make-who-condition who)
(make-message-condition (strerror err))
(case err
;; from ikarus-errno.c: EACCES=-2, EFAULT=-21, EROFS=-71, EEXIST=-20,
;; EIO=-29, ENOENT=-45
;; Why is EFAULT included here?
[(-2 -21) (make-i/o-file-protection-error id)]
[(-71) (make-i/o-file-is-read-only-error id)]
[(-20) (make-i/o-file-already-exists-error id)]
[(-29) (make-i/o-error)]
[(-45) (make-i/o-file-does-not-exist-error id)]
[else (if id
(make-irritants-condition (list id))
(condition))])
other-conditions)))
;(define block-size 4096)
;(define block-size (* 4 4096))
@ -2177,8 +2148,9 @@
(unless (and (string? host) (string? srvc))
(die 'who "host and service must both be strings" host srvc))
(socket->ports
(foreign-call foreign-name
(string->utf8 host) (string->utf8 srvc))
(or (foreign-call foreign-name
(string->utf8 host) (string->utf8 srvc))
(die 'who "failed to resolve host name or connect" host srvc))
'who
(string-append host ":" srvc)
block?))]))
@ -2252,8 +2224,8 @@
pending)
;;; do select
(let ([rv (foreign-call "ikrt_select" n rbv wbv xbv)])
(when (< rv 0)
(die 'select "error selecting from fds")))
(when (< rv 0)
(io-error 'select #f rv)))
;;; go through fds again and see if they're selected
(for-each
(lambda (t)

View File

@ -14,15 +14,21 @@
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(library (ikarus posix)
(library (ikarus.posix)
(export posix-fork fork waitpid system file-exists? delete-file
nanosleep getenv env environ file-ctime current-directory)
nanosleep getenv env environ file-ctime current-directory
file-regular? file-directory? file-symbolic-link? make-symbolic-link
directory-list make-directory delete-directory change-mode
strerror)
(import
(rnrs bytevectors)
(except (ikarus)
nanosleep
posix-fork fork waitpid system file-exists? delete-file
getenv env environ file-ctime current-directory))
getenv env environ file-ctime current-directory
file-regular? file-directory? file-symbolic-link? make-symbolic-link
directory-list make-directory delete-directory change-mode
strerror))
(define posix-fork
(lambda ()
@ -33,15 +39,17 @@
(let ([pid (posix-fork)])
(cond
[(fx= pid 0) (child-proc)]
[(fx= pid -1)
(die 'fork "failed")]
[(fx< pid 0) (raise/strerror 'fork pid)]
[else (parent-proc pid)]))))
(define waitpid
(lambda (pid)
(unless (fixnum? pid)
(die 'waitpid "not a fixnum" pid))
(foreign-call "ikrt_waitpid" pid)))
(let ([r (foreign-call "ikrt_waitpid" pid)])
(if (fx< r 0)
(raise/strerror 'waitpid r)
r))))
(define system
(lambda (x)
@ -49,59 +57,110 @@
(die 'system "not a string" x))
(let ([rv (foreign-call "ik_system"
(string->utf8 x))])
(if (fx= rv -1)
(die 'system "failed")
(if (fx< rv 0)
(raise/strerror 'system rv)
rv))))
(define stat
(lambda (path follow who)
(unless (string? path)
(die who "not a string" path))
(let ([r (foreign-call "ikrt_stat" (string->utf8 path) follow)])
(case r
[(0) 'unknown]
[(1) 'regular]
[(2) 'directory]
[(3) 'symlink]
[(-45) #f] ;; from ikarus-errno.c: ENOENT -- path does not exist
[else (raise/strerror who r path)]))))
(define file-exists?
(lambda (x)
(unless (string? x)
(die 'file-exists? "filename is not a string" x))
(let ([v (foreign-call "ikrt_file_exists"
(string->utf8 x))])
(cond
[(boolean? v) v]
[else
(raise
(condition
(make-who-condition 'file-exists?)
(make-message-condition
(case v
[(1) "file path contains a non-directory"]
[(2) "file path is too long"]
[(3) "file path is not accessible"]
[(4) "file path contains too many symbolic links"]
[(5) "internal access error while accessing file"]
[(6) "IO error encountered while accessing file"]
[else "Unknown error while testing file"]))
(make-i/o-filename-error x)))]))))
(case-lambda
[(path) (file-exists? path #t)]
[(path follow)
(and (stat path follow 'file-exists?) #t)]))
(define file-regular?
(case-lambda
[(path) (file-regular? path #t)]
[(path follow)
(eq? 'regular (stat path follow 'file-regular?))]))
(define file-directory?
(case-lambda
[(path) (file-directory? path #t)]
[(path follow)
(eq? 'directory (stat path follow 'file-directory?))]))
(define file-symbolic-link?
(lambda (path)
(eq? 'symlink (stat path #f 'file-symbolic-link?))))
(define delete-file
(lambda (x)
(define who 'delete-file)
(unless (string? x)
(die 'delete-file "filename is not a string" x))
(die who "filename is not a string" x))
(let ([v (foreign-call "ikrt_delete_file"
(string->utf8 x))])
(case v
[(0) (void)]
[else
(raise
(condition
(make-who-condition 'delete-file)
(make-message-condition
(case v
[(1) "file path contains a non-directory"]
[(2) "file path is too long"]
[(3) "file does not exist"]
[(4) "file path is not accessible"]
[(5) "file path contains too many symbolic links"]
[(6) "you do not have permissions to delete file"]
[(7) "device is busy"]
[(8) "IO error encountered while deleting"]
[(9) "file is in a read-only file system"]
[(10) "internal access error while deleting"]
[else "Unknown error while deleting file"]))
(make-i/o-filename-error x)))]))))
(unless (eq? v #t)
(raise/strerror who v x)))))
(define directory-list
(lambda (path)
(define who 'directory-list)
(unless (string? path)
(die who "not a string" path))
(let ([r (foreign-call "ikrt_directory_list" (string->utf8 path))])
(if (fixnum? r)
(raise/strerror who r path)
(map utf8->string (reverse r))))))
(define make-directory
(case-lambda
[(path) (make-directory path #o755)]
[(path mode)
(define who 'make-directory)
(unless (string? path)
(die who "not a string" path))
(unless (fixnum? mode)
(die who "not a fixnum" mode))
(let ([r (foreign-call "ikrt_mkdir" (string->utf8 path) mode)])
(unless (eq? r #t)
(raise/strerror who r path)))]))
(define delete-directory
(case-lambda
[(path) (delete-directory path #f)]
[(path want-error?)
(define who 'delete-directory)
(unless (string? path)
(die who "not a string" path))
(let ([r (foreign-call "ikrt_rmdir" (string->utf8 path))])
(if want-error?
(unless (eq? r #t) (raise/strerror who r path))
(eq? r #t)))]))
(define change-mode
(lambda (path mode)
(define who 'change-mode)
(unless (string? path)
(die who "not a string" path))
(unless (fixnum? mode)
(die who "not a fixnum" mode))
(let ([r (foreign-call "ikrt_chmod" (string->utf8 path) mode)])
(unless (eq? r #t)
(raise/strerror who r path)))))
(define make-symbolic-link
(lambda (to path)
(define who 'make-symbolic-link)
(unless (and (string? to) (string? path))
(die who "not a string" (if (string? to) path to)))
(let ([r (foreign-call "ikrt_symlink"
(string->utf8 to) (string->utf8 path))])
(unless (eq? r #t)
(raise/strerror who r path)))))
(define (file-ctime x)
(define who 'file-ctime)
@ -111,12 +170,7 @@
(let ([v (foreign-call "ikrt_file_ctime" (string->utf8 x) p)])
(case v
[(0) (+ (* (car p) #e1e9) (cdr p))]
[else
(raise
(condition
(make-who-condition who)
(make-message-condition "cannot stat a file")
(make-i/o-filename-error x)))]))))
[else (raise/strerror who v x)]))))
(define ($getenv-bv key)
@ -189,17 +243,43 @@
(case-lambda
[()
(let ([v (foreign-call "ikrt_getcwd")])
(if (bytevector? v)
(utf8->string v)
(die 'current-directory
"failed to get current directory")))]
(if (eq? v #t)
(raise/strerror 'current-directory v)
(utf8->string v)))]
[(x)
(if (string? x)
(let ([rv (foreign-call "ikrt_chdir" (string->utf8 x))])
(unless (eq? rv 0)
(die 'current-directory
"failed to set current directory")))
(unless (eq? rv #t)
(raise/strerror 'current-directory rv x)))
(die 'current-directory "not a string" x))]))
(define raise/strerror
(case-lambda
[(who errno-code)
(raise/strerror who errno-code #f)]
[(who errno-code filename)
(raise
(condition
(make-who-condition who)
(make-message-condition (strerror errno-code))
(if filename
(make-i/o-filename-error filename)
(condition))))]))
(define strerror
(lambda (errno-code)
(define who 'strerror)
(unless (fixnum? errno-code)
(die who "not a fixnum" errno-code))
(let ([emsg (foreign-call "ikrt_strerror" errno-code)])
(if emsg
(let ([errno-name
(foreign-call "ikrt_errno_code_to_name" errno-code)])
(assert errno-name)
(format "~a: ~a"
(utf8->string errno-name)
(utf8->string emsg)))
(format "Ikarus's ~a: don't know Ikarus errno code ~s"
who errno-code)))))
)

View File

@ -1 +1 @@
1491
1492

View File

@ -70,6 +70,7 @@
"ikarus.command-line.ss"
"ikarus.codecs.ss"
"ikarus.bytevectors.ss"
"ikarus.posix.ss"
"ikarus.io.ss"
"ikarus.hash-tables.ss"
"ikarus.pretty-formats.ss"
@ -94,7 +95,6 @@
"ikarus.load.ss"
"ikarus.pretty-print.ss"
"ikarus.cafe.ss"
"ikarus.posix.ss"
"ikarus.timer.ss"
"ikarus.time-and-date.ss"
"ikarus.sort.ss"
@ -361,6 +361,7 @@
[make-parameter i parameters]
[call/cf i]
[print-error i]
[strerror i]
[interrupt-handler i]
[engine-handler i]
[assembler-output i]
@ -1215,7 +1216,15 @@
[vector-sort! i r sr]
[file-exists? i r fi]
[delete-file i r fi]
[file-regular? i]
[file-directory? i]
[file-symbolic-link? i]
[current-directory i]
[directory-list i]
[make-directory i]
[delete-directory i]
[change-mode i]
[make-symbolic-link i]
[file-ctime i]
[define-record-type i r rs]
[fields i r rs]

View File

@ -6,7 +6,8 @@ ikarus_SOURCES = ikarus-collect.c ikarus-exec.c ikarus-fasl.c \
ikarus-runtime.c ikarus-symbol-table.c ikarus-verify-integrity.c \
ikarus-weak-pairs.c ikarus-winmmap.c ikarus-data.h \
ikarus-winmmap.h ikarus-enter.S cpu_has_sse2.S ikarus-io.c \
ikarus-process.c ikarus-getaddrinfo.h ikarus-getaddrinfo.c
ikarus-process.c ikarus-getaddrinfo.h ikarus-getaddrinfo.c \
ikarus-errno.c
scheme_script_SOURCES = scheme-script.c

View File

@ -54,7 +54,8 @@ am_ikarus_OBJECTS = ikarus-collect.$(OBJEXT) ikarus-exec.$(OBJEXT) \
ikarus-verify-integrity.$(OBJEXT) ikarus-weak-pairs.$(OBJEXT) \
ikarus-winmmap.$(OBJEXT) ikarus-enter.$(OBJEXT) \
cpu_has_sse2.$(OBJEXT) ikarus-io.$(OBJEXT) \
ikarus-process.$(OBJEXT) ikarus-getaddrinfo.$(OBJEXT)
ikarus-process.$(OBJEXT) ikarus-getaddrinfo.$(OBJEXT) \
ikarus-errno.$(OBJEXT)
nodist_ikarus_OBJECTS =
ikarus_OBJECTS = $(am_ikarus_OBJECTS) $(nodist_ikarus_OBJECTS)
ikarus_LDADD = $(LDADD)
@ -181,7 +182,8 @@ ikarus_SOURCES = ikarus-collect.c ikarus-exec.c ikarus-fasl.c \
ikarus-runtime.c ikarus-symbol-table.c ikarus-verify-integrity.c \
ikarus-weak-pairs.c ikarus-winmmap.c ikarus-data.h \
ikarus-winmmap.h ikarus-enter.S cpu_has_sse2.S ikarus-io.c \
ikarus-process.c ikarus-getaddrinfo.h ikarus-getaddrinfo.c
ikarus-process.c ikarus-getaddrinfo.h ikarus-getaddrinfo.c \
ikarus-errno.c
scheme_script_SOURCES = scheme-script.c
nodist_ikarus_SOURCES = bootfileloc.h
@ -260,6 +262,7 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/cpu_has_sse2.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-collect.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-enter.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-errno.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-exec.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-fasl.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-flonums.Po@am__quote@

View File

@ -29,48 +29,13 @@
#include <netinet/in.h>
#include "ikarus-data.h"
ikptr
ikrt_io_error(){
int err = errno;
#if 0
fprintf(stderr, "errno=%d %s\n", err, strerror(err));
#endif
switch(err){
case EBADF : return fix(-2);
case EINTR : return fix(-3);
case ENOTDIR : return fix(-4);
case ENAMETOOLONG : return fix(-5);
case ENOENT : return fix(-6);
case EACCES : return fix(-7);
case ELOOP : return fix(-8);
case EISDIR : return fix(-9);
case EROFS : return fix(-10);
case EMFILE : return fix(-11);
case ENFILE : return fix(-12);
case ENXIO : return fix(-13);
case EOPNOTSUPP : return fix(-14);
case ENOSPC : return fix(-15);
case EDQUOT : return fix(-16);
case EIO : return fix(-17);
case ETXTBSY : return fix(-18);
case EFAULT : return fix(-19);
case EEXIST : return fix(-20);
case EINVAL : return fix(-21);
case EAGAIN : return fix(-22); /* hardcoded in ikarus.io.ss */
case EPIPE : return fix(-23);
case ECONNREFUSED : return fix(-24);
case ENOTSOCK : return fix(-25);
case ENOBUFS : return fix(-26);
}
return fix(-1);
}
extern ikptr ik_errno_to_code();
ikptr
ikrt_close_fd(ikptr fd, ikpcb* pcb){
int err = close(unfix(fd));
if(err == -1){
return ikrt_io_error();
return ik_errno_to_code();
} else {
return false_object;;
}
@ -79,10 +44,10 @@ ikrt_close_fd(ikptr fd, ikpcb* pcb){
ikptr
ikrt_open_input_fd(ikptr fn, ikpcb* pcb){
int fh = open((char*)(long)(fn+off_bytevector_data), O_RDONLY, 0);
if(fh > 0){
if(fh >= 0){
return fix(fh);
} else {
return ikrt_io_error();
return ik_errno_to_code();
}
}
@ -107,10 +72,10 @@ ikrt_open_output_fd(ikptr fn, ikptr ikopts, ikpcb* pcb){
int fh = open((char*)(long)(fn+off_bytevector_data),
mode,
S_IRUSR | S_IWUSR | S_IRGRP | S_IROTH);
if(fh > 0){
if(fh >= 0){
return fix(fh);
} else {
return ikrt_io_error();
return ik_errno_to_code();
}
}
@ -130,7 +95,7 @@ ikrt_read_fd(ikptr fd, ikptr bv, ikptr off, ikptr cnt, ikpcb* pcb){
if(bytes >= 0){
return fix(bytes);
} else {
return ikrt_io_error();
return ik_errno_to_code();
}
}
@ -159,7 +124,7 @@ ikrt_write_fd(ikptr fd, ikptr bv, ikptr off, ikptr cnt, ikpcb* pcb){
if(bytes >= 0){
return fix(bytes);
} else {
return ikrt_io_error();
return ik_errno_to_code();
}
}
@ -173,22 +138,25 @@ do_connect(ikptr host, ikptr srvc, int socket_type){
0,
&info);
if(err){
return fix(-1);
switch(err){
case EAI_SYSTEM: return ik_errno_to_code();
default: return false_object;
}
}
struct addrinfo* i = info;
ikptr sock = fix(-1);
ikptr sock = false_object;
while(i){
if(i->ai_socktype != socket_type){
i = i->ai_next;
} else {
int s = socket(i->ai_family, i->ai_socktype, i->ai_protocol);
if(s < 0){
sock = ikrt_io_error();
sock = ik_errno_to_code();
i = i->ai_next;
} else {
int err = connect(s, i->ai_addr, i->ai_addrlen);
if(err < 0){
sock = ikrt_io_error();
sock = ik_errno_to_code();
i = i->ai_next;
} else {
sock = fix(s);
@ -216,7 +184,7 @@ ikrt_make_fd_nonblocking(ikptr fdptr, ikpcb* pcb){
int fd = unfix(fdptr);
int err = fcntl(fd, F_SETFL, O_NONBLOCK);
if(err == -1){
return ikrt_io_error();
return ik_errno_to_code();
}
return 0;
}
@ -229,7 +197,7 @@ ikrt_select(ikptr fds, ikptr rfds, ikptr wfds, ikptr xfds, ikpcb* pcb){
(fd_set*)(xfds + off_bytevector_data),
NULL);
if(rv < 0){
return ikrt_io_error();
return ik_errno_to_code();
}
return fix(rv);
}
@ -239,7 +207,7 @@ ikrt_listen(ikptr port, ikpcb* pcb){
int sock = socket(AF_INET, SOCK_STREAM, 0);
if(sock < 0){
return ikrt_io_error();
return ik_errno_to_code();
}
struct sockaddr_in servaddr;
@ -253,18 +221,18 @@ ikrt_listen(ikptr port, ikpcb* pcb){
int reuse = 1;
err = setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, &reuse, sizeof(int));
if(err < 0){
return ikrt_io_error();
return ik_errno_to_code();
}
err = bind(sock, (struct sockaddr *)&servaddr, sizeof(servaddr));
if(err < 0){
return ikrt_io_error();
return ik_errno_to_code();
}
err = listen(sock, 1024);
if(err < 0){
return ikrt_io_error();
return ik_errno_to_code();
}
return fix(sock);
}
@ -283,7 +251,7 @@ ikrt_getsockname(ikptr s, ikpcb* pcb){
ref(bv, off_bytevector_length) = fix(size);
return bv;
} else {
return ikrt_io_error();
return ik_errno_to_code();
}
}
#endif
@ -297,7 +265,7 @@ ikrt_accept(ikptr s, ikptr bv, ikpcb* pcb){
(struct sockaddr*) (bv+off_bytevector_data),
&addrlen);
if(sock < 0){
return ikrt_io_error();
return ik_errno_to_code();
}
ref(bv, off_bytevector_length) = fix(addrlen);
return fix(sock);
@ -311,7 +279,7 @@ ikrt_shutdown(ikptr s, ikpcb* pcb){
int err = shutdown(unfix(s), SHUT_RDWR);
#endif
if(err < 0){
return ikrt_io_error();
return ik_errno_to_code();
}
return 0;
}
@ -322,7 +290,7 @@ ikrt_file_ctime(ikptr filename, ikptr res){
struct stat s;
int err = stat((char*)(filename + off_bytevector_data), &s);
if(err) {
return fix(errno);
return ik_errno_to_code();
}
ref(res, off_car) = fix(s.st_ctime);

View File

@ -25,7 +25,7 @@
#include <errno.h>
#include "ikarus-data.h"
extern ikptr ikrt_io_error();
extern ikptr ik_errno_to_code();
static int
list_length(ikptr x){
@ -56,9 +56,9 @@ ikrt_process(ikptr rvec, ikptr cmd, ikptr argv, ikpcb* pcb){
int infds[2];
int outfds[2];
int errfds[2];
if(pipe(infds)) return ikrt_io_error();
if(pipe(outfds)) return ikrt_io_error();
if(pipe(errfds)) return ikrt_io_error();
if(pipe(infds)) return ik_errno_to_code();
if(pipe(outfds)) return ik_errno_to_code();
if(pipe(errfds)) return ik_errno_to_code();
pid_t pid = fork();
if(pid == 0){
/* child */
@ -87,13 +87,18 @@ ikrt_process(ikptr rvec, ikptr cmd, ikptr argv, ikpcb* pcb){
ref(rvec,off_vector_data+3*wordsize) = fix(errfds[0]);
return rvec;
} else {
return ikrt_io_error();
return ik_errno_to_code();
}
}
ikptr
ikrt_waitpid(ikptr pid, ikpcb* pcb){
int status;
waitpid(unfix(pid), &status, 0);
return fix(status);
pid_t r = waitpid(unfix(pid), &status, 0);
if(r >= 0){
return fix(status);
} else {
return ik_errno_to_code();
}
}

View File

@ -33,11 +33,14 @@
#include <sys/resource.h>
#include <sys/wait.h>
#include <sys/param.h>
#include <dirent.h>
#ifdef __CYGWIN__
#include "ikarus-winmmap.h"
#endif
extern ikptr ik_errno_to_code();
int total_allocated_pages = 0;
extern char **environ;
@ -553,97 +556,48 @@ ikptr ik_uuid(ikptr bv){
}
/*
#include <sys/types.h>
#include <sys/stat.h>
int
stat(const char *path, struct stat *sb);
ERRORS
Stat() and lstat() will fail if:
[ENOTDIR] A component of the path prefix is not a directory.
[ENAMETOOLONG] A component of a pathname exceeded {NAME_MAX} charac-
ters, or an entire path name exceeded {PATH_MAX} char-
acters.
[ENOENT] The named file does not exist.
[EACCES] Search permission is denied for a component of the
path prefix.
[ELOOP] Too many symbolic links were encountered in translat-
ing the pathname.
[EFAULT] Sb or name points to an invalid address.
[EIO] An I/O error occurred while reading from or writing to
the file system.
*/
ikptr
ikrt_file_exists(ikptr filename){
char* str;
if(tagof(filename) == bytevector_tag){
str = (char*)(long)(filename + off_bytevector_data);
} else {
fprintf(stderr, "bug in ikrt_file_exists\n");
exit(-1);
ikptr
ikrt_stat(ikptr filename, ikptr follow, ikpcb* pcb){
char* fn = (char*)(filename + off_bytevector_data);
struct stat s;
int r;
if(follow == false_object){
r = lstat(fn, &s);
} else{
r = stat(fn, &s);
}
struct stat sb;
int st = stat(str, &sb);
if(st == 0){
/* success */
return true_object;
} else {
int err = errno;
if(err == ENOENT){
return false_object;
}
else if(err == ENOTDIR){
if(r == 0){
if(S_ISREG(s.st_mode)){
return fix(1);
}
else if(err == ENAMETOOLONG){
else if(S_ISDIR(s.st_mode)){
return fix(2);
}
else if(err == EACCES){
return fix(3);
}
else if(err == ELOOP){
return fix(4);
}
else if(err == EFAULT){
return fix(5);
}
else if(err == EIO){
return fix(6);
}
else {
return fix(-1);
}
}
else if(S_ISLNK(s.st_mode)){
return fix(3);
}
else {
return fix(0);
}
}
return ik_errno_to_code();
}
/*
[ENOTDIR] A component of the path prefix is not a directory.
[ENAMETOOLONG] A component of a pathname exceeded {NAME_MAX} charac-
ters, or an entire path name exceeded {PATH_MAX} char-
acters.
[ENOENT] The named file does not exist.
[EACCES] Search permission is denied for a component of the
path prefix.
[EACCES] Write permission is denied on the directory containing
the link to be removed.
[ELOOP] Too many symbolic links were encountered in translat-
ing the pathname.
[EPERM] The named file is a directory and the effective user
ID of the process is not the super-user.
[EPERM] The directory containing the file is marked sticky,
and neither the containing directory nor the file to
be removed are owned by the effective user ID.
[EBUSY] The entry to be unlinked is the mount point for a
mounted file system.
[EIO] An I/O error occurred while deleting the directory
entry or deallocating the inode.
[EROFS] The named file resides on a read-only file system.
[EFAULT] Path points outside the process's allocated address
space.
*/
/* ikrt_file_exists needs to be removed.
This is here only to be able to use old ikarus.boot.prebuilt */
ikptr
ikrt_file_exists(ikptr filename, ikpcb* pcb){
switch (ikrt_stat(filename, true_object, pcb)){
case fix(0):
case fix(1):
case fix(2):
case fix(3):
return true_object;
default:
return false_object;
}
}
ikptr
ikrt_delete_file(ikptr filename){
@ -656,30 +610,89 @@ ikrt_delete_file(ikptr filename){
}
int err = unlink(str);
if(err == 0){
return 0;
return true_object;
}
switch (errno){
case ENOTDIR: return fix(1);
case ENAMETOOLONG: return fix(2);
case ENOENT: return fix(3);
case EACCES: return fix(4);
case ELOOP: return fix(5);
case EPERM: return fix(6);
case EBUSY: return fix(7);
case EIO: return fix(8);
case EROFS: return fix(9);
case EFAULT: return fix(10);
}
return fix(-1);
return ik_errno_to_code();
}
ikptr
ikrt_directory_list(ikptr filename, ikpcb* pcb){
DIR* dir;
struct dirent* de;
if((dir = opendir((char*)(filename + off_bytevector_data))) == NULL){
return ik_errno_to_code();
}
ikptr ac = null_object;
pcb->root0 = &ac;
while(1){
errno = 0;
de = readdir(dir);
if(de == NULL){
pcb->root0 = 0;
pcb->root1 = 0;
ikptr retval = (errno ? ik_errno_to_code() : ac);
closedir(dir);
return retval;
}
int len = strlen(de->d_name);
ikptr bv = ik_safe_alloc(pcb, align(disp_bytevector_data+len+1))
+ bytevector_tag;
ref(bv, off_bytevector_length) = fix(len);
memcpy((char*)(bv+off_bytevector_data), de->d_name, len+1);
pcb->root1 = &bv;
ikptr p = ik_safe_alloc(pcb, pair_size) + pair_tag;
ref(p, off_car) = bv;
ref(p, off_cdr) = ac;
ac = p;
}
}
ikptr
ikrt_mkdir(ikptr path, ikptr mode, ikpcb* pcb){
int r = mkdir((char*)(path+off_bytevector_data), unfix(mode));
if(r == 0){
return true_object;
}
return ik_errno_to_code();
}
ikptr
ikrt_rmdir(ikptr path, ikpcb* pcb){
int r = rmdir((char*)(path+off_bytevector_data));
if(r == 0){
return true_object;
}
return ik_errno_to_code();
}
ikptr
ikrt_chmod(ikptr path, ikptr mode, ikpcb* pcb){
int r = chmod((char*)(path+off_bytevector_data), (mode_t)unfix(mode));
if(r == 0){
return true_object;
}
return ik_errno_to_code();
}
ikptr
ikrt_symlink(ikptr to, ikptr path, ikpcb* pcb){
int r = symlink((char*)(to+off_bytevector_data), (char*)(path+off_bytevector_data));
if(r == 0){
return true_object;
}
return ik_errno_to_code();
}
ikptr
ik_system(ikptr str){
if(tagof(str) == bytevector_tag){
return fix(system((char*)(long)(str+off_bytevector_data)));
int r = system((char*)(long)(str+off_bytevector_data));
if(r >= 0) {
return fix(r);
} else {
return ik_errno_to_code();
}
} else {
fprintf(stderr, "bug in ik_system\n");
exit(-1);
@ -817,9 +830,6 @@ ikrt_register_guardian(ikptr tc, ikptr obj, ikpcb* pcb){
return ikrt_register_guardian_pair(p0, pcb);
}
ikptr
ikrt_stats_now(ikptr t, ikpcb* pcb){
struct rusage r;
@ -881,7 +891,11 @@ ikrt_gmt_offset(ikptr t){
ikptr
ikrt_fork(){
int pid = fork();
return fix(pid);
if(pid >= 0){
return fix(pid);
} else {
return ik_errno_to_code();
}
}
@ -898,6 +912,7 @@ ikrt_getenv(ikptr bv, ikpcb* pcb){
return s;
}
else {
/* empty bv */
ikptr s = ik_safe_alloc(pcb, align(disp_bytevector_data+1))
+ bytevector_tag;
ref(s, -bytevector_tag) = fix(0);
@ -995,7 +1010,10 @@ ikrt_nanosleep(ikptr secs, ikptr nsecs, ikpcb* pcb){
ikptr
ikrt_chdir(ikptr pathbv, ikpcb* pcb){
int err = chdir(off_bytevector_data+(char*)pathbv);
return fix(err); /* FIXME: provide more meaninful result */
if(err == 0){
return true_object;
}
return ik_errno_to_code();
}
ikptr
@ -1003,12 +1021,12 @@ ikrt_getcwd(ikpcb* pcb){
char buff[MAXPATHLEN+1];
char* path = getcwd(buff, MAXPATHLEN);
if(! path){
return fix(-1); /* FIXME: provide more meaninful result */
return ik_errno_to_code();
}
int len = strlen(path);
ikptr bv = ik_safe_alloc(pcb, align(disp_bytevector_data+len+1));
ref(bv,0) = fix(len);
strncpy(disp_bytevector_data+(char*)(bv), path, len);
memcpy(disp_bytevector_data+(char*)(bv), path, len+1);
return bv+bytevector_tag;
}