added file-exists? and delete-file operations to libposix.ss and ikarus-runtime.c

runtime/ikarus-collect.c

@@ -11,7 +11,7 @@
 #include <errno.h>
 
 #define forward_ptr ((ikp)-1)
-#define DEBUG_STACK 0
+//#define DEBUG_STACK 0
 #define minimum_heap_size (pagesize * 1024 * 4)
 #define maximum_heap_size (pagesize * 1024 * 8)
 #define minimum_stack_size (pagesize * 128)
@@ -231,7 +231,7 @@ gc_tconc_push(gc_t* gc, ikp tcbucket){
   }
 }
 
-static ikp add_object(gc_t* gc, ikp x);
+static ikp add_object(gc_t* gc, ikp x, char* caller);
 static void collect_stack(gc_t*, ikp top, ikp base);
 static void collect_loop(gc_t*);
 static void fix_weak_pointers(gc_t*);
@@ -306,8 +306,8 @@ ik_collect(int req, ikpcb* pcb){
    */
   scan_dirty_pages(&gc);
   collect_stack(&gc, pcb->frame_pointer, pcb->frame_base - wordsize);
-  pcb->next_k = add_object(&gc, pcb->next_k); 
+  pcb->next_k = add_object(&gc, pcb->next_k, "main"); 
-  pcb->oblist = add_object(&gc, pcb->oblist); 
+  pcb->oblist = add_object(&gc, pcb->oblist, "main"); 
   /* now we trace all live objects */
   collect_loop(&gc);
 
@@ -539,7 +539,7 @@ static void collect_stack(gc_t* gc, ikp top, ikp end){
       }
       ikp base = top + framesize - wordsize;
       while(base > top){
-        ikp new_obj = add_object(gc,ref(base,0));
+        ikp new_obj = add_object(gc,ref(base,0), "frame");
         ref(base,0) = new_obj;
         base -= wordsize;
       }
@@ -552,14 +552,17 @@ static void collect_stack(gc_t* gc, ikp top, ikp end){
       int i;
       for(i=0; i<bytes_in_mask; i++, fp-=8){
         unsigned char m = mask[i];
-        if(m & 0x01) { fp[-0] = add_object(gc, fp[-0]); }
+#if DEBUG_STACK
-        if(m & 0x02) { fp[-1] = add_object(gc, fp[-1]); }
+        fprintf(stderr, "m=0x%x\n", m);
-        if(m & 0x04) { fp[-2] = add_object(gc, fp[-2]); }
+#endif
-        if(m & 0x08) { fp[-3] = add_object(gc, fp[-3]); }
+        if(m & 0x01) { fp[-0] = add_object(gc, fp[-0], "frame2"); }
-        if(m & 0x10) { fp[-4] = add_object(gc, fp[-4]); }
+        if(m & 0x02) { fp[-1] = add_object(gc, fp[-1], "frame3"); }
-        if(m & 0x20) { fp[-5] = add_object(gc, fp[-5]); }
+        if(m & 0x04) { fp[-2] = add_object(gc, fp[-2], "frame4"); }
-        if(m & 0x40) { fp[-6] = add_object(gc, fp[-6]); }
+        if(m & 0x08) { fp[-3] = add_object(gc, fp[-3], "frame5"); }
-        if(m & 0x80) { fp[-7] = add_object(gc, fp[-7]); }
+        if(m & 0x10) { fp[-4] = add_object(gc, fp[-4], "frame6"); }
+        if(m & 0x20) { fp[-5] = add_object(gc, fp[-5], "frame7"); }
+        if(m & 0x40) { fp[-6] = add_object(gc, fp[-6], "framea"); }
+        if(m & 0x80) { fp[-7] = add_object(gc, fp[-7], "frameb"); }
       }
     }
     top += framesize;
@@ -621,7 +624,7 @@ add_list(gc_t* gc, unsigned int t, int gen, ikp x, ikp* loc){
       return;
     }
     else {
-      ref(y, off_cdr) = add_object(gc, snd);
+      ref(y, off_cdr) = add_object(gc, snd, "add_list");
       return;
     }
   }
@@ -629,7 +632,7 @@ add_list(gc_t* gc, unsigned int t, int gen, ikp x, ikp* loc){
 
 
 static ikp 
-add_object(gc_t* gc, ikp x){
+add_object(gc_t* gc, ikp x, char* caller){
   if(is_fixnum(x)){ 
     return x;
   } 
@@ -825,7 +828,7 @@ add_object(gc_t* gc, ikp x){
 static void
 relocate_new_code(ikp x, gc_t* gc){
   ikp relocvector = ref(x, disp_code_reloc_vector);
-  relocvector = add_object(gc, relocvector);
+  relocvector = add_object(gc, relocvector, "reloc");
   ref(x, disp_code_reloc_vector) = relocvector;
   int relocsize = (int)ref(relocvector, off_vector_length);
   ikp p = relocvector + off_vector_data;
@@ -838,7 +841,7 @@ relocate_new_code(ikp x, gc_t* gc){
     if(tag == 0){
       /* undisplaced pointer */
       ikp old_object = ref(p, wordsize);
-      ikp new_object = add_object(gc, old_object);
+      ikp new_object = add_object(gc, old_object, "reloc");
       ref(code, code_off) = new_object;
       p += (2*wordsize);
     }
@@ -846,14 +849,14 @@ relocate_new_code(ikp x, gc_t* gc){
       /* displaced pointer */
       int obj_off = unfix(ref(p, wordsize));
       ikp old_object = ref(p, 2*wordsize);
-      ikp new_object = add_object(gc, old_object);
+      ikp new_object = add_object(gc, old_object, "reloc");
       ref(code, code_off) = new_object + obj_off;
       p += (3 * wordsize);
     } 
     else if(tag == 3){
       /* displaced relative pointer */
       int obj_off = unfix(ref(p, wordsize));
-      ikp obj = add_object(gc, ref(p, 2*wordsize));
+      ikp obj = add_object(gc, ref(p, 2*wordsize), "reloc");
       ikp displaced_object = obj + obj_off;
       ikp next_word = code + code_off + wordsize;
       ikp relative_distance = displaced_object - (int)next_word;
@@ -876,7 +879,6 @@ relocate_new_code(ikp x, gc_t* gc){
 static void 
 collect_loop(gc_t* gc){
   int done;
-  int scan_ptr_count = 0;
   do{
     done = 1;
     { /* scan the pending pairs pages */
@@ -888,7 +890,7 @@ collect_loop(gc_t* gc){
           ikp p = qu->p;
           ikp q = qu->q;
           while(p < q){
-            ref(p,0) = add_object(gc, ref(p,0));
+            ref(p,0) = add_object(gc, ref(p,0), "loop");
             p += (2*wordsize);
           }
           qupages_t* next = qu->next;
@@ -907,7 +909,7 @@ collect_loop(gc_t* gc){
           ikp p = qu->p;
           ikp q = qu->q;
           while(p < q){
-            ref(p,0) = add_object(gc, ref(p,0));
+            ref(p,0) = add_object(gc, ref(p,0), "pending");
             p += wordsize;
           }
           qupages_t* next = qu->next;
@@ -946,7 +948,7 @@ collect_loop(gc_t* gc){
           do{
             meta->aq = q;
             while(p < q){
-              ref(p,0) = add_object(gc, ref(p,0));
+              ref(p,0) = add_object(gc, ref(p,0), "rem");
               p += (2*wordsize);
             }
             p = meta->aq;
@@ -963,7 +965,7 @@ collect_loop(gc_t* gc){
           do{
             meta->aq = q;
             while(p < q){
-              ref(p,0) = add_object(gc, ref(p,0));
+              ref(p,0) = add_object(gc, ref(p,0), "rem2");
               p += wordsize;
             }
             p = meta->aq;
@@ -1102,7 +1104,7 @@ scan_dirty_pointers_page(gc_t* gc, int page_idx, int mask){
         if(is_fixnum(x) || (tagof(x) == immediate_tag)){
           /* do nothing */
         } else {
-          ikp y = add_object(gc, x);
+          ikp y = add_object(gc, x, "nothing");
           segment_vec = gc->segment_vector;
           ref(p, 0) = y;
           card_d = card_d | segment_vec[page_index(y)];
@@ -1151,7 +1153,7 @@ scan_dirty_code_page(gc_t* gc, int page_idx, unsigned int mask){
         if(is_fixnum(r) || (tagof(r) == immediate_tag)){
           /* do nothing */
         } else {
-          r = add_object(gc, r);
+          r = add_object(gc, r, "nothing2");
           segment_vec = gc->segment_vector;
           code_d = code_d | segment_vec[page_index(r)];
         }
@@ -1186,7 +1188,7 @@ scan_dirty_weak_pointers_page(gc_t* gc, int page_idx, int mask){
         if(is_fixnum(x) || tagof(x) == immediate_tag){
           /* do nothing */
         } else {
-          ikp y = add_object(gc, x);
+          ikp y = add_object(gc, x, "nothing3");
           ref(p, wordsize) = y;
         }
         p += (2*wordsize);

runtime/ikarus-runtime.c

@@ -488,6 +488,115 @@ ikp ik_open_file(ikp str, ikp flagptr){
   return fix(fd);
 }
  
+
+/*
+     #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.
+*/
+ikp 
+ikrt_file_exists(ikp filename){
+  char* str = string_data(filename);
+  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){
+      return fix(1);
+    } 
+    else if(err == ENAMETOOLONG){
+      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);
+    }
+  }
+}
+
+
+/*
+     [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.
+*/
+
+
+ikp
+ikrt_delete_file(ikp filename){
+  char* str = string_data(filename);
+  int err = unlink(str);
+  if(err == 0){
+    return 0;
+  } 
+  switch (err){
+    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);
+}
+
+
 ikp ik_close(ikp fd){
   int err = close(unfix(fd));
   if(err != 0){

src/libposix.ss

@@ -21,3 +21,48 @@
           (error 'system "failed")
           rv))))
 
+(primitive-set! 'file-exists?
+  (lambda (x)
+    (unless (string? x)
+      (error 'file-exists? "filename ~s is not a string" x))
+    (let ([v (foreign-call "ikrt_file_exists" x)])
+      (cond
+        [(boolean? v) v]
+        [else
+         (error 'file-exists?
+                (case v
+                  [(1) "the path ~s contains a non-directory"]
+                  [(2) "the path ~s is too long"]
+                  [(3) "the path ~s is not accessible"]
+                  [(4) "the path ~s contains too many symbolic links"]
+                  [(5) "internal access error while accessing ~s"]
+                  [(6) "IO error encountered while accessing ~s"]
+                  [else "Unknown error in ~s"])
+                x)]))))
+
+(primitive-set! 'delete-file
+  (lambda (x)
+    (unless (string? x)
+      (error 'delete-file "filename ~s is not a string" x))
+    (let ([v (foreign-call "ikrt_delete_file" x)])
+      (case v
+        [(0) (void)]
+        [else
+         (error 'delete-file
+                (case v
+                  [(1) "the path ~s contains a non-directory"]
+                  [(2) "the path ~s is too long"]
+                  [(3) "the file ~s does not exist"]
+                  [(4) "the path ~s is not accessible"]
+                  [(5) "the path ~s contains too many symbolic links"]
+                  [(6) "you do not have permissions to delete ~s"]
+                  [(7) "device ~s is busy"]
+                  [(8) "IO error encountered while deleting ~s"]
+                  [(9) "~s is in a read-only file system"]
+                  [(10) "internal access error while deleting ~s"]
+                  [else "Unknown error while deleting ~s"])
+                x)]))))
+
+
+
+

src/makefile.ss

@@ -108,6 +108,7 @@
     with-output-to-file call-with-output-file
     with-input-from-file call-with-input-file
     date-string
+    file-exists? delete-file
 
     + - add1 sub1 * expt number? positive? negative? zero? number->string
     logand