diff --git a/scheme/ikarus.pointers.ss b/scheme/ikarus.pointers.ss index 2f223ee..b94348e 100644 --- a/scheme/ikarus.pointers.ss +++ b/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))) + + + ) diff --git a/scheme/last-revision b/scheme/last-revision index 6afcd4b..99814ce 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1594 +1595 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 02ee228..d0b5c3d 100755 --- a/scheme/makefile.ss +++ b/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) diff --git a/src/ikarus-data.h b/src/ikarus-data.h index 76a2f60..8b5b6b2 100644 --- a/src/ikarus-data.h +++ b/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 diff --git a/src/ikarus-pointers.c b/src/ikarus-pointers.c index 7738497..61dd919 100644 --- a/src/ikarus-pointers.c +++ b/src/ikarus-pointers.c @@ -1,5 +1,8 @@ #include "ikarus-data.h" +#include +#include +#include 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; +} +