Added dlopen, dlclose, dlerror, dlsym, malloc, and free to

(ikarus system $foreign).

scheme/ikarus.pointers.ss

@@ -1,7 +1,14 @@
 
 (library (ikarus.pointers)
-  (export pointer? integer->pointer pointer->integer)
-  (import (except (ikarus) pointer? integer->pointer pointer->integer))
+  (export pointer? integer->pointer pointer->integer 
+          dlopen dlerror dlclose dlsym malloc free)
+  (import 
+    (except (ikarus) 
+      pointer? 
+      integer->pointer pointer->integer
+      dlopen dlerror dlclose dlsym malloc free))
+
+  ;;; pointer manipulation procedures 
 
   (define (pointer? x)
     (foreign-call "ikrt_isapointer" x))
@@ -20,6 +27,54 @@
       [(pointer? x) 
        (foreign-call "ikrt_pointer_to_int" x)]
       [else 
-       (die 'pointer->integer "not a pointer" x)])))
+       (die 'pointer->integer "not a pointer" x)]))
+
+  ;;; dynamic loading procedures 
+
+  (define dlerror 
+    (lambda ()
+      (let ([p (foreign-call "ikrt_dlerror")])
+        (and p (utf8->string p)))))
+
+  (define dlopen 
+    (case-lambda 
+      [(x) (dlopen x #t #t)]
+      [(x lazy? global?) 
+       (define (open x)
+         (foreign-call "ikrt_dlopen" x lazy? global?))
+       (cond
+         [(not x) (open #f)]
+         [(string? x) (open (string->utf8 x))]
+         [else (die 'dlopen "name should be a string or #f" x)])]))
+
+  (define dlclose
+    (lambda (x)
+      (if (pointer? x)
+          (foreign-call "ikrt_dlclose" x)
+          (die 'dlclose "not a pointer" x))))
+
+  (define dlsym
+    (lambda (handle name)
+      (define who 'dlsym)
+      (if (pointer? handle)
+          (if (string? name) 
+              (foreign-call "ikrt_dlsym" handle (string->utf8 name))
+              (die who "invalid symbol name" name))
+          (die who "handle is not a pointer" handle))))
+
+  ;;; explicit memory management
+
+  (define (malloc len) 
+    (if (and (fixnum? len) (fx>? len 0))
+        (foreign-call "ikrt_malloc" len)
+        (die 'malloc "not a positive fixnum" len)))
+
+  (define (free x)
+    (if (pointer? x)
+        (foreign-call "ikrt_free" x)
+        (die 'free "not a pointer" x)))
+
+
+  )
 
 

scheme/last-revision

@@ -1 +1 @@
-1594
+1595

scheme/makefile.ss

@@ -271,6 +271,7 @@
     [$stack      (ikarus system $stack)                #f     #t]
     [$interrupts (ikarus system $interrupts)           #f     #t]
     [$io         (ikarus system $io)                   #f     #t]
+    [$for        (ikarus system $foreign)              #f     #f]
     [$all        (psyntax system $all)                 #f     #t]
     [$boot       (psyntax system $bootstrap)           #f     #t]
     [ne          (psyntax null-environment-5)          #f     #f]
@@ -1454,9 +1455,15 @@
     [cp0-effort-limit i]
     [tag-analysis-output i]
     [perform-tag-analysis i]
-    [pointer? i]
-    [pointer->integer i]
-    [integer->pointer i]
+    [pointer?         $for]
+    [pointer->integer $for]
+    [integer->pointer $for]
+    [dlopen           $for]
+    [dlerror          $for]
+    [dlclose          $for]
+    [dlsym            $for]
+    [malloc           $for]
+    [free             $for]
   ))
 
 (define (macro-identifier? x) 

src/ikarus-data.h

@@ -407,6 +407,8 @@ ikptr ik_safe_alloc(ikpcb* pcb, int size);
 #define page_index(x) (((unsigned long int)(x)) >> pageshift)
 
 #define pointer_tag           ((ikptr) 0x107)
+#define disp_pointer_data     (1 * wordsize)
 #define pointer_size          (2 * wordsize)
+#define off_pointer_data      (disp_pointer_data - vector_tag)
 
 #endif

src/ikarus-pointers.c

@@ -1,5 +1,8 @@
 
 #include "ikarus-data.h"
+#include <dlfcn.h>
+#include <string.h>
+#include <stdlib.h>
 
 ikptr
 ikrt_isapointer(ikptr x, ikpcb* pcb){
@@ -56,3 +59,75 @@ ikrt_bn_to_pointer(ikptr x, ikpcb* pcb) {
   }
 }
 
+#if 0
+ikptr
+ikrt_pointer_null(ikptr x /*, ikpcb* pcb*/) {
+  return ref(x, off_pointer_data) ? true_object : false_object;
+}
+#endif
+
+ikptr 
+ikrt_dlerror(ikpcb* pcb) {
+  char* str = dlerror();
+  if (str == NULL) {
+    return false_object;
+  }
+  int len = strlen(str);
+  ikptr bv = ik_safe_alloc(pcb, align(disp_bytevector_data + len + 1));
+  ref(bv, 0) = fix(len);
+  memcpy((void*)(bv+disp_bytevector_data), str, len+1);
+  return bv+bytevector_tag;
+}
+
+ikptr
+ikrt_dlopen(ikptr x, ikptr load_lazy, ikptr load_global, ikpcb* pcb) {
+  int flags = 
+    ((load_lazy == false_object) ? RTLD_NOW : RTLD_LAZY) |
+    ((load_global == false_object) ? RTLD_LOCAL : RTLD_GLOBAL);
+  char* name = 
+    (x == false_object) 
+      ? NULL 
+      : (char*)(x + off_bytevector_data);
+  void* p = dlopen(name, flags);
+  if (p == NULL) {
+    return false_object;
+  } else {
+    return make_pointer((long int) p, pcb);
+  }
+}
+
+ikptr
+ikrt_dlclose(ikptr x /*, ikpcb* pcb*/) {
+  int r = dlclose((void*) ref(x, off_pointer_data));
+  return (r == 0) ? true_object : false_object;
+}
+
+
+ikptr
+ikrt_dlsym(ikptr handle, ikptr sym, ikpcb* pcb) {
+  void* p = dlsym((void*)ref(handle, off_pointer_data), 
+                  ((char*)sym) + off_bytevector_data);
+  if (p == NULL) {
+    return false_object;
+  } else {
+    return make_pointer((long int) p, pcb);
+  }
+}
+
+
+ikptr
+ikrt_malloc(ikptr len, ikpcb* pcb) {
+  void* p = malloc(unfix(len));
+  if (p == NULL) {
+    return false_object;
+  } else {
+    return make_pointer((long int) p, pcb);
+  }
+}
+
+ikptr
+ikrt_free(ikptr x) {
+  free((void*) ref(x, off_pointer_data));
+  return void_object;
+}
+