ikarus/src/ikarus-pointers.c

356 lines
8.1 KiB
C

#include "ikarus-data.h"
#include <dlfcn.h>
#include <string.h>
#include <stdlib.h>
ikptr
ikrt_isapointer(ikptr x, ikpcb* pcb){
if ((tagof(x) == vector_tag) && (ref(x, -vector_tag) == pointer_tag)) {
return true_object;
} else {
return false_object;
}
}
ikptr
ikrt_pointer_to_int(ikptr x, ikpcb* pcb) {
long int p = (long int) ref(x, wordsize-vector_tag);
ikptr pfx = fix(p);
if (unfix(pfx) == p) {
return pfx;
} else {
ikptr bn = ik_safe_alloc(pcb, align(wordsize+disp_bignum_data));
if (p > 0){
ref(bn, 0) = (ikptr)(bignum_tag | (1 << bignum_length_shift));
ref(bn, disp_bignum_data) = (ikptr)p;
} else {
ref(bn, 0) =
(ikptr)(bignum_tag |
(1 << bignum_length_shift) |
(1 << bignum_sign_shift));
ref(bn, disp_bignum_data) = (ikptr)-p;
}
return bn+vector_tag;
}
}
ikptr
make_pointer(long int x, ikpcb* pcb) {
ikptr r = ik_safe_alloc(pcb, pointer_size);
ref(r, 0) = pointer_tag;
ref(r, wordsize) = (ikptr)x;
return r+vector_tag;
}
#define bnfst_negative(x) \
(((unsigned long int)(x)) & bignum_sign_mask)
static long
integer_to_long(ikptr x) {
if (is_fixnum(x)) {
return ((long)x) >> fx_shift;
} else {
if(bnfst_negative(ref(x, -vector_tag))){
return -(long)ref(x, wordsize-vector_tag);
} else {
return (long)ref(x, wordsize-vector_tag);
}
}
}
ikptr
ikrt_fx_to_pointer(ikptr x, ikpcb* pcb) {
return make_pointer(unfix(x), pcb);
}
ikptr
ikrt_bn_to_pointer(ikptr x, ikpcb* pcb) {
if(bnfst_negative(ref(x, -vector_tag))){
return make_pointer(-ref(x, wordsize-vector_tag), pcb);
} else {
return make_pointer(ref(x, wordsize-vector_tag), 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;
}
#ifndef RTLD_LOCAL
#define RTLD_LOCAL 0 /* for cygwin, possibly incorrect */
#endif
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;
}
ikptr
ikrt_ref_char(ikptr p, ikptr off /*, ikpcb* pcb*/) {
return fix(*((signed char*)(((long)ref(p, off_pointer_data)) + unfix(off))));
}
ikptr
ikrt_ref_uchar(ikptr p, ikptr off /*, ikpcb* pcb*/) {
return fix(*((unsigned char*)(((long)ref(p, off_pointer_data)) + unfix(off))));
}
ikptr
ikrt_ref_short(ikptr p, ikptr off /*, ikpcb* pcb*/) {
return fix(*((signed short*)(((long)ref(p, off_pointer_data)) + unfix(off))));
}
ikptr
ikrt_ref_ushort(ikptr p, ikptr off /*, ikpcb* pcb*/) {
return fix(*((unsigned short*)(((long)ref(p, off_pointer_data)) + unfix(off))));
}
ikptr
ikrt_ref_pointer(ikptr p, ikptr off, ikpcb* pcb) {
long idx = integer_to_long(off);
void* ptr = (void*)ref(p, off_pointer_data);
return make_pointer(ref(ptr, idx), pcb);
}
ikptr
ikrt_set_pointer(ikptr p, ikptr off, ikptr v /*, ikpcb* pcb*/) {
long idx = integer_to_long(off);
void* ptr = (void*)ref(p, off_pointer_data);
ref(ptr, idx) = ref(v, off_pointer_data);
return void_object;
}
static ikptr
double_to_flonum(double x, ikpcb* pcb){
ikptr r = ik_safe_alloc(pcb, flonum_size) + vector_tag;
ref(r, -vector_tag) = flonum_tag;
flonum_data(r) = x;
return r;
}
ikptr
ikrt_set_float(ikptr p, ikptr off, ikptr v /*, ikpcb* pcb*/) {
long idx = integer_to_long(off);
ikptr ptr = ref(p, off_pointer_data);
*((float*)(ptr+idx)) = flonum_data(v);
return void_object;
}
ikptr
ikrt_ref_float(ikptr p, ikptr off, ikpcb* pcb) {
long idx = integer_to_long(off);
ikptr ptr = ref(p, off_pointer_data);
double v = *((float*)(ptr+idx));
return double_to_flonum(v, pcb);
}
ikptr
ikrt_set_double(ikptr p, ikptr off, ikptr v /*, ikpcb* pcb*/) {
long idx = integer_to_long(off);
ikptr ptr = ref(p, off_pointer_data);
*((double*)(ptr+idx)) = flonum_data(v);
return void_object;
}
ikptr
ikrt_ref_double(ikptr p, ikptr off, ikpcb* pcb) {
long idx = integer_to_long(off);
ikptr ptr = ref(p, off_pointer_data);
double v = *((double*)(ptr+idx));
return double_to_flonum(v, pcb);
}
ikptr
s_to_number(signed long n, ikpcb* pcb) {
ikptr fx = fix(n);
if (unfix(fx) == n) {
return fx;
}
ikptr bn = ik_safe_alloc(pcb, align(wordsize+disp_bignum_data));
if (n > 0){
ref(bn, 0) = (ikptr)(bignum_tag | (1 << bignum_length_shift));
ref(bn, disp_bignum_data) = (ikptr)n;
} else {
ref(bn, 0) =
(ikptr)(bignum_tag |
(1 << bignum_length_shift) |
(1 << bignum_sign_shift));
ref(bn, disp_bignum_data) = (ikptr)-n;
}
return bn+vector_tag;
}
ikptr
u_to_number(unsigned long n, ikpcb* pcb) {
unsigned long mxn = ((unsigned long)-1)>>(fx_shift+1);
if (n <= mxn) {
return fix(n);
}
ikptr bn = ik_safe_alloc(pcb, align(wordsize+disp_bignum_data));
ref(bn, 0) = (ikptr)(bignum_tag | (1 << bignum_length_shift));
ref(bn, disp_bignum_data) = (ikptr)n;
return bn+vector_tag;
}
ikptr
d_to_number(double n, ikpcb* pcb) {
ikptr x = ik_safe_alloc(pcb, flonum_size) + vector_tag;
ref(x, -vector_tag) = flonum_tag;
flonum_data(x) = n;
return x;
}
ikptr
ikrt_ref_int(ikptr p, ikptr off , ikpcb* pcb) {
signed int r =
*((signed int*)(((long)ref(p, off_pointer_data)) + unfix(off)));
if (wordsize == 8) {
return fix(r);
} else {
return s_to_number(r, pcb);
}
}
ikptr
ikrt_ref_uint(ikptr p, ikptr off , ikpcb* pcb) {
unsigned int r =
*((unsigned int*)(((long)ref(p, off_pointer_data)) + unfix(off)));
if (wordsize == 8) {
return fix(r);
} else {
return u_to_number(r, pcb);
}
}
ikptr
ikrt_ref_long(ikptr p, ikptr off , ikpcb* pcb) {
signed long r =
*((signed long*)(((long)ref(p, off_pointer_data)) + unfix(off)));
return s_to_number(r, pcb);
}
ikptr
ikrt_ref_ulong(ikptr p, ikptr off , ikpcb* pcb) {
unsigned long r =
*((unsigned long*)(((long)ref(p, off_pointer_data)) + unfix(off)));
return u_to_number(r, pcb);
}
long
extract_num(ikptr x) {
if (is_fixnum(x)) {
return unfix(x);
} else if (x == void_object) {
return 0;
} else {
if (bnfst_negative(ref(x, -vector_tag))){
return (long)(-ref(x, wordsize-vector_tag));
} else {
return (long)(ref(x, wordsize-vector_tag));
}
}
}
ikptr
ikrt_set_char(ikptr p, ikptr off, ikptr v/*, ikpcb* pcb*/) {
*((signed char*)(((long)ref(p, off_pointer_data)) + unfix(off))) =
extract_num(v);
return void_object;
}
ikptr
ikrt_set_short(ikptr p, ikptr off, ikptr v/*, ikpcb* pcb*/) {
*((signed short*)(((long)ref(p, off_pointer_data)) + unfix(off))) =
extract_num(v);
return void_object;
}
ikptr
ikrt_set_int(ikptr p, ikptr off, ikptr v/*, ikpcb* pcb*/) {
*((signed int*)(((long)ref(p, off_pointer_data)) + unfix(off))) =
extract_num(v);
return void_object;
}
ikptr
ikrt_set_long(ikptr p, ikptr off, ikptr v/*, ikpcb* pcb*/) {
*((signed long*)(((long)ref(p, off_pointer_data)) + unfix(off))) =
extract_num(v);
return void_object;
}