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;

scheme/ikarus.conditions.ss

@@ -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 rf-len
-            (case (vector-length v)
             [(0) (newline p)]
             [(1) 
              (display ": " p)
-               (write ((record-accessor rtd 0) x) p)
+             (write ((record-accessor (caar rf) 0) x) p)
              (newline p)]
             [else
              (display ":\n" p)
-               (let f ([i 0])
+             (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))))]))))
+                     (f (+ i 1) rtd v))))
-          ;; (let ([parent (record-type-parent rtd)])
+               rf)])))          
-          ;;   (when parent (f parent)))))
       (define (print-condition x p)
         (cond
           [(condition? x) 

scheme/ikarus.io.ss

@@ -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 EAGAIN-error-code -6) ;;; from ikarus-errno.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 (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)
+        (make-message-condition (strerror err))
         (case err
-              [(6 9 18) (make-i/o-file-protection-error)]
+          ;; from ikarus-errno.c: EACCES=-2, EFAULT=-21, EROFS=-71, EEXIST=-20,
-              [(19)     (make-i/o-file-already-exists-error id)]
+          ;;                      EIO=-29, ENOENT=-45
-              [else     (condition)])
+          ;; Why is EFAULT included here?
-            (make-message-condition msg)
+          [(-2 -21) (make-i/o-file-protection-error id)]
-            (make-i/o-filename-error id)
+          [(-71)    (make-i/o-file-is-read-only-error id)]
-            other-conditions)))))
+          [(-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
+           (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?))]))
@@ -2253,7 +2225,7 @@
           ;;; do select
           (let ([rv (foreign-call "ikrt_select" n rbv wbv xbv)])
             (when (< rv 0)
-              (die 'select "error selecting from fds")))
+              (io-error 'select #f rv)))
           ;;; go through fds again and see if they're selected
           (for-each 
             (lambda (t) 

scheme/ikarus.posix.ss

@@ -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) 
+          [(fx< pid 0) (raise/strerror 'fork pid)]
-           (die 'fork "failed")]
           [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)
+        (if (fx< rv 0)
-            (die 'system "failed")
+            (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)
+    (case-lambda 
-      (unless (string? x)
+      [(path) (file-exists? path #t)]
-        (die 'file-exists? "filename is not a string" x))
+      [(path follow)
-      (let ([v (foreign-call "ikrt_file_exists" 
+       (and (stat path follow 'file-exists?) #t)]))
-                  (string->utf8 x))])
+  
-        (cond
+  (define file-regular?
-          [(boolean? v) v]
+    (case-lambda
-          [else
+      [(path) (file-regular? path #t)]
-           (raise
+      [(path follow)
-             (condition
+       (eq? 'regular (stat path follow 'file-regular?))]))
-               (make-who-condition 'file-exists?)
+  
-               (make-message-condition
+  (define file-directory?
-                 (case v
+    (case-lambda
-                   [(1) "file path contains a non-directory"]
+      [(path) (file-directory? path #t)]
-                   [(2) "file path is too long"]
+      [(path follow)
-                   [(3) "file path is not accessible"]
+       (eq? 'directory (stat path follow 'file-directory?))]))
-                   [(4) "file path contains too many symbolic links"]
+  
-                   [(5) "internal access error while accessing file"]
+  (define file-symbolic-link?
-                   [(6) "IO error encountered while accessing file"]
+    (lambda (path)
-                   [else "Unknown error while testing file"]))
+      (eq? 'symlink (stat path #f 'file-symbolic-link?))))
-               (make-i/o-filename-error x)))]))))
 
   (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
+        (unless (eq? v #t)
-          [(0) (void)]
+          (raise/strerror who v x)))))
-          [else
+  
-           (raise
+  (define directory-list
-             (condition
+    (lambda (path)
-               (make-who-condition 'delete-file)
+      (define who 'directory-list)
-               (make-message-condition
+      (unless (string? path)
-                 (case v
+        (die who "not a string" path))
-                   [(1) "file path contains a non-directory"]
+      (let ([r (foreign-call "ikrt_directory_list" (string->utf8 path))])
-                   [(2) "file path is too long"]
+        (if (fixnum? r)
-                   [(3) "file does not exist"]
+            (raise/strerror who r path)
-                   [(4) "file path is not accessible"]
+            (map utf8->string (reverse r))))))
-                   [(5) "file path contains too many symbolic links"]
+  
-                   [(6) "you do not have permissions to delete file"]
+  (define make-directory
-                   [(7) "device is busy"]
+    (case-lambda 
-                   [(8) "IO error encountered while deleting"]
+      [(path) (make-directory path #o755)]
-                   [(9) "file is in a read-only file system"]
+      [(path mode)
-                   [(10) "internal access error while deleting"]
+       (define who 'make-directory)
-                   [else "Unknown error while deleting file"]))
+       (unless (string? path)
-               (make-i/o-filename-error x)))]))))
+         (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 
+          [else (raise/strerror who v x)]))))
-           (raise
-             (condition 
-               (make-who-condition who)
-               (make-message-condition "cannot stat a file")
-               (make-i/o-filename-error x)))]))))
 
 
   (define ($getenv-bv key)
@@ -189,17 +243,43 @@
     (case-lambda
       [() 
        (let ([v (foreign-call "ikrt_getcwd")])
-         (if (bytevector? v) 
+         (if (eq? v #t)
-             (utf8->string v)
+             (raise/strerror 'current-directory v) 
-             (die 'current-directory 
+             (utf8->string v)))]
-               "failed to get current directory")))]
       [(x) 
        (if (string? x) 
            (let ([rv (foreign-call "ikrt_chdir" (string->utf8 x))])
-             (unless (eq? rv 0) 
+             (unless (eq? rv #t)
-               (die 'current-directory
+               (raise/strerror 'current-directory rv x)))
-                 "failed to set current directory")))
            (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)))))
 
   )

scheme/last-revision

@@ -1 +1 @@
-1491
+1492

scheme/makefile.ss

@@ -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]

src/Makefile.am

@@ -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
           

src/Makefile.in

@@ -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@

src/ikarus-io.c

@@ -29,48 +29,13 @@
 #include <netinet/in.h>
 #include "ikarus-data.h"
 
-ikptr 
+extern ikptr ik_errno_to_code();
-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);
-}
-
 
 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);

src/ikarus-process.c

@@ -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(infds))  return ik_errno_to_code();
-  if(pipe(outfds)) return ikrt_io_error();
+  if(pipe(outfds)) return ik_errno_to_code();
-  if(pipe(errfds)) return ikrt_io_error();
+  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);
+  pid_t r = waitpid(unfix(pid), &status, 0);
+  if(r >= 0){
     return fix(status);
+  } else {
+    return ik_errno_to_code();
   }
+}
+

src/ikarus-runtime.c

@@ -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){
+ikrt_stat(ikptr filename, ikptr follow, ikpcb* pcb){
-  char* str;
+  char* fn = (char*)(filename + off_bytevector_data);
-  if(tagof(filename) == bytevector_tag){
+  struct stat s;
-    str = (char*)(long)(filename + off_bytevector_data);
+  int r;
+  if(follow == false_object){
+    r = lstat(fn, &s);
   } else{
-    fprintf(stderr, "bug in ikrt_file_exists\n");
+    r = stat(fn, &s);
-    exit(-1);
   }
-  struct stat sb;
+  if(r == 0){
-  int st = stat(str, &sb);
+    if(S_ISREG(s.st_mode)){
-  if(st == 0){
-    /* success */
-    return true_object;
-  } else {
-    int err = errno;
-    if(err == ENOENT){
-      return false_object;
-    } 
-    else if(err == ENOTDIR){
       return fix(1);
     } 
-    else if(err == ENAMETOOLONG){
+    else if(S_ISDIR(s.st_mode)){
       return fix(2);
     }
-    else if(err == EACCES){
+    else if(S_ISLNK(s.st_mode)){
       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);
+      return fix(0);
     }
   }  
+  return ik_errno_to_code();
 }
 
 
-/*
+/* ikrt_file_exists needs to be removed.
-     [ENOTDIR]          A component of the path prefix is not a directory.
+   This is here only to be able to use old ikarus.boot.prebuilt */
-     [ENAMETOOLONG]     A component of a pathname exceeded {NAME_MAX} charac-
+ikptr
-                        ters, or an entire path name exceeded {PATH_MAX} char-
+ikrt_file_exists(ikptr filename, ikpcb* pcb){
-                        acters.
+  switch (ikrt_stat(filename, true_object, pcb)){
-     [ENOENT]           The named file does not exist.
+    case fix(0):
-     [EACCES]           Search permission is denied for a component of the
+    case fix(1):
-                        path prefix.
+    case fix(2):
-     [EACCES]           Write permission is denied on the directory containing
+    case fix(3):
-                        the link to be removed.
+      return true_object;
-     [ELOOP]            Too many symbolic links were encountered in translat-
+    default:
-                        ing the pathname.
+      return false_object;
-     [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.
-*/
-
 
 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){
+  return ik_errno_to_code();
-    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);
 }
 
+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();
+  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;
 }