conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

added pointer-ref-{unsigned-,}long-long

This commit is contained in:
Abdulaziz Ghuloum 2008-11-21 05:56:51 -05:00
parent f216ed5893
commit 6922b0d9c2
6 changed files with 139 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
lib/ikarus/foreign.ss
View File

@ -13,10 +13,12 @@
pointer-ref-c-signed-short
pointer-ref-c-signed-int
pointer-ref-c-signed-long
pointer-ref-c-signed-long-long
pointer-ref-c-unsigned-char
pointer-ref-c-unsigned-short
pointer-ref-c-unsigned-int
pointer-ref-c-unsigned-long
pointer-ref-c-unsigned-long-long
pointer-ref-c-pointer
pointer-ref-c-float
pointer-ref-c-double

42
scheme/ikarus.pointers.ss
View File

@ -6,10 +6,12 @@
pointer-ref-c-signed-short
pointer-ref-c-signed-int
pointer-ref-c-signed-long
pointer-ref-c-signed-long-long
pointer-ref-c-unsigned-char
pointer-ref-c-unsigned-short
pointer-ref-c-unsigned-int
pointer-ref-c-unsigned-long
pointer-ref-c-unsigned-long-long
pointer-ref-c-float
pointer-ref-c-double
pointer-ref-c-pointer
@ -17,6 +19,7 @@
pointer-set-c-short!
pointer-set-c-int!
pointer-set-c-long!
pointer-set-c-long-long!
pointer-set-c-pointer!
pointer-set-c-float!
pointer-set-c-double!
@ -126,25 +129,28 @@
(define (int? x) (or (fixnum? x) (bignum? x)))
(define-getter pointer-ref-c-signed-char "ikrt_ref_char")
(define-getter pointer-ref-c-signed-short "ikrt_ref_short")
(define-getter pointer-ref-c-signed-int "ikrt_ref_int")
(define-getter pointer-ref-c-signed-long "ikrt_ref_long")
(define-getter pointer-ref-c-unsigned-char "ikrt_ref_uchar")
(define-getter pointer-ref-c-unsigned-short "ikrt_ref_ushort")
(define-getter pointer-ref-c-unsigned-int "ikrt_ref_uint")
(define-getter pointer-ref-c-unsigned-long "ikrt_ref_ulong")
(define-getter pointer-ref-c-float "ikrt_ref_float")
(define-getter pointer-ref-c-double "ikrt_ref_double")
(define-getter pointer-ref-c-pointer "ikrt_ref_pointer")
(define-getter pointer-ref-c-signed-char "ikrt_ref_char")
(define-getter pointer-ref-c-signed-short "ikrt_ref_short")
(define-getter pointer-ref-c-signed-int "ikrt_ref_int")
(define-getter pointer-ref-c-signed-long "ikrt_ref_long")
(define-getter pointer-ref-c-signed-long-long "ikrt_ref_longlong")
(define-getter pointer-ref-c-unsigned-char "ikrt_ref_uchar")
(define-getter pointer-ref-c-unsigned-short "ikrt_ref_ushort")
(define-getter pointer-ref-c-unsigned-int "ikrt_ref_uint")
(define-getter pointer-ref-c-unsigned-long "ikrt_ref_ulong")
(define-getter pointer-ref-c-unsigned-long-long "ikrt_ref_ulonglong")
(define-getter pointer-ref-c-float "ikrt_ref_float")
(define-getter pointer-ref-c-double "ikrt_ref_double")
(define-getter pointer-ref-c-pointer "ikrt_ref_pointer")
(define-setter pointer-set-c-char! int? "ikrt_set_char")
(define-setter pointer-set-c-short! int? "ikrt_set_short")
(define-setter pointer-set-c-int! int? "ikrt_set_int")
(define-setter pointer-set-c-long! int? "ikrt_set_long")
(define-setter pointer-set-c-float! flonum? "ikrt_set_float")
(define-setter pointer-set-c-double! flonum? "ikrt_set_double")
(define-setter pointer-set-c-pointer! pointer? "ikrt_set_pointer")
(define-setter pointer-set-c-char! int? "ikrt_set_char")
(define-setter pointer-set-c-short! int? "ikrt_set_short")
(define-setter pointer-set-c-int! int? "ikrt_set_int")
(define-setter pointer-set-c-long! int? "ikrt_set_long")
(define-setter pointer-set-c-long-long! int? "ikrt_set_longlong")
(define-setter pointer-set-c-float! flonum? "ikrt_set_float")
(define-setter pointer-set-c-double! flonum? "ikrt_set_double")
(define-setter pointer-set-c-pointer! pointer? "ikrt_set_pointer")
;;; libffi interface

2
scheme/last-revision
View File

@ -1 +1 @@
1687
1688

61
scheme/makefile.ss
View File

@ -1466,35 +1466,38 @@
[cp0-effort-limit i]
[tag-analysis-output i]
[perform-tag-analysis i]
[pointer? $for]
[pointer->integer $for]
[integer->pointer $for]
[dlopen $for]
[dlerror $for]
[dlclose $for]
[dlsym $for]
[malloc $for]
[free $for]
[pointer-ref-c-signed-char $for]
[pointer-ref-c-signed-short $for]
[pointer-ref-c-signed-int $for]
[pointer-ref-c-signed-long $for]
[pointer-ref-c-unsigned-char $for]
[pointer-ref-c-unsigned-short $for]
[pointer-ref-c-unsigned-int $for]
[pointer-ref-c-unsigned-long $for]
[pointer-ref-c-float $for]
[pointer-ref-c-double $for]
[pointer-ref-c-pointer $for]
[pointer-set-c-char! $for]
[pointer-set-c-short! $for]
[pointer-set-c-int! $for]
[pointer-set-c-long! $for]
[pointer-set-c-pointer! $for]
[pointer-set-c-float! $for]
[pointer-set-c-double! $for]
[make-c-callout $for]
[make-c-callback $for]
[pointer? $for]
[pointer->integer $for]
[integer->pointer $for]
[dlopen $for]
[dlerror $for]
[dlclose $for]
[dlsym $for]
[malloc $for]
[free $for]
[pointer-ref-c-signed-char $for]
[pointer-ref-c-signed-short $for]
[pointer-ref-c-signed-int $for]
[pointer-ref-c-signed-long $for]
[pointer-ref-c-signed-long-long $for]
[pointer-ref-c-unsigned-char $for]
[pointer-ref-c-unsigned-short $for]
[pointer-ref-c-unsigned-int $for]
[pointer-ref-c-unsigned-long $for]
[pointer-ref-c-unsigned-long-long $for]
[pointer-ref-c-float $for]
[pointer-ref-c-double $for]
[pointer-ref-c-pointer $for]
[pointer-set-c-char! $for]
[pointer-set-c-short! $for]
[pointer-set-c-int! $for]
[pointer-set-c-long! $for]
[pointer-set-c-long-long! $for]
[pointer-set-c-pointer! $for]
[pointer-set-c-float! $for]
[pointer-set-c-double! $for]
[make-c-callout $for]
[make-c-callback $for]
[host-info i]
))

11
scheme/tests/pointers.ss
View File

@ -60,9 +60,6 @@
(list 0 (sub1 (sll 1 (- n 1))) (sub1 (sll 1 n)))
ls1 ls2 ls3))))
(define (u* n)
(let ([n (min n bits)])
(combinations n)))
@ -119,10 +116,18 @@
(t-ref/set 'short (s* 16) pointer-ref-c-signed-short pointer-set-c-short!)
(t-ref/set 'int (s* 32) pointer-ref-c-signed-int pointer-set-c-int!)
(t-ref/set 'long (s* 64) pointer-ref-c-signed-long pointer-set-c-long!)
(t-ref/set 'long-long
(s* 64)
pointer-ref-c-signed-long-long
pointer-set-c-long-long!)
(t-ref/set 'uchar (u* 8) pointer-ref-c-unsigned-char pointer-set-c-char!)
(t-ref/set 'ushort (u* 16) pointer-ref-c-unsigned-short pointer-set-c-short!)
(t-ref/set 'uint (u* 32) pointer-ref-c-unsigned-int pointer-set-c-int!)
(t-ref/set 'ulong (u* 64) pointer-ref-c-unsigned-long pointer-set-c-long!)
(t-ref/set 'ulong-long
(u* 64)
pointer-ref-c-unsigned-long-long
pointer-set-c-long-long!)
)

81
src/ikarus-pointers.c
View File

@ -251,6 +251,26 @@ s_to_number(signed long n, ikpcb* pcb) {
return bn+vector_tag;
}
static ikptr
sll_to_number(signed long long n, ikpcb* pcb) {
if (((signed long long)(signed long) n) == n) {
return s_to_number(n, pcb);
}
ikptr bn = ik_safe_alloc(pcb, align(sizeof(long long)+disp_bignum_data));
if (n > 0){
ref(bn, 0) = (ikptr)(bignum_tag | (1 << bignum_length_shift));
*((long long*)(bn+disp_bignum_data)) = n;
} else {
ref(bn, 0) =
(ikptr)(bignum_tag |
(1 << bignum_length_shift) |
(1 << bignum_sign_shift));
*((long long*)(bn+disp_bignum_data)) = -n;
}
return bn+vector_tag;
}
ikptr
u_to_number(unsigned long n, ikpcb* pcb) {
unsigned long mxn = ((unsigned long)-1)>>(fx_shift+1);
@ -266,9 +286,8 @@ u_to_number(unsigned long n, ikpcb* pcb) {
ikptr
ull_to_number(unsigned long long n, ikpcb* pcb) {
unsigned long long mxn = ((unsigned long)-1)>>(fx_shift+1);
if (n <= mxn) {
return fix(n);
if (((unsigned long long)(unsigned long) n) == n) {
return u_to_number(n, pcb);
}
ikptr bn = ik_safe_alloc(pcb, align(disp_bignum_data+sizeof(long long)));
bcopy((char*)(&n), (char*)(bn+disp_bignum_data), sizeof(long long));
@ -283,8 +302,6 @@ d_to_number(double n, ikpcb* pcb) {
return x;
}
ikptr
ikrt_ref_int(ikptr p, ikptr off , ikpcb* pcb) {
signed int r =
@ -321,6 +338,20 @@ ikrt_ref_ulong(ikptr p, ikptr off , ikpcb* pcb) {
return u_to_number(r, pcb);
}
ikptr
ikrt_ref_longlong(ikptr p, ikptr off , ikpcb* pcb) {
signed long long r =
*((signed long long*)(((long)ref(p, off_pointer_data)) + unfix(off)));
return sll_to_number(r, pcb);
}
ikptr
ikrt_ref_ulonglong(ikptr p, ikptr off , ikpcb* pcb) {
unsigned long long r =
*((unsigned long long*)(((long)ref(p, off_pointer_data)) + unfix(off)));
return ull_to_number(r, pcb);
}
long
extract_num(ikptr x) {
if (is_fixnum(x)) {
@ -336,33 +367,65 @@ extract_num(ikptr x) {
}
}
long long
extract_num_longlong(ikptr x) {
if (is_fixnum(x)) {
return unfix(x);
} else if (x == void_object) {
return 0;
} else {
ikptr fst = ref(x, -vector_tag);
ikptr pos_one_limb_tag =
(ikptr)(bignum_tag | (1 << bignum_length_shift));
ikptr neg_one_limb_tag =
(ikptr)(pos_one_limb_tag | (1 << bignum_sign_shift));
if (fst == pos_one_limb_tag) {
return (unsigned long)ref(x, wordsize-vector_tag);
} else if (fst == neg_one_limb_tag) {
return -(signed long)ref(x, wordsize-vector_tag);
} else if (bnfst_negative(fst)) {
return -(*((long long*)(x+wordsize-vector_tag)));
} else {
return *((long long*)(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))) =
*((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))) =
*((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))) =
*((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))) =
*((long*)(((long)ref(p, off_pointer_data)) + unfix(off))) =
extract_num(v);
return void_object;
}
ikptr
ikrt_set_longlong(ikptr p, ikptr off, ikptr v/*, ikpcb* pcb*/) {
*((long long*)(((long)ref(p, off_pointer_data)) + unfix(off))) =
extract_num_longlong(v);
return void_object;
}