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-short
pointer-ref-c-signed-int pointer-ref-c-signed-int
pointer-ref-c-signed-long pointer-ref-c-signed-long
pointer-ref-c-signed-long-long
pointer-ref-c-unsigned-char pointer-ref-c-unsigned-char
pointer-ref-c-unsigned-short pointer-ref-c-unsigned-short
pointer-ref-c-unsigned-int pointer-ref-c-unsigned-int
pointer-ref-c-unsigned-long pointer-ref-c-unsigned-long
pointer-ref-c-unsigned-long-long
pointer-ref-c-pointer pointer-ref-c-pointer
pointer-ref-c-float pointer-ref-c-float
pointer-ref-c-double pointer-ref-c-double

42
scheme/ikarus.pointers.ss
View File

@ -6,10 +6,12 @@
pointer-ref-c-signed-short pointer-ref-c-signed-short
pointer-ref-c-signed-int pointer-ref-c-signed-int
pointer-ref-c-signed-long pointer-ref-c-signed-long
pointer-ref-c-signed-long-long
pointer-ref-c-unsigned-char pointer-ref-c-unsigned-char
pointer-ref-c-unsigned-short pointer-ref-c-unsigned-short
pointer-ref-c-unsigned-int pointer-ref-c-unsigned-int
pointer-ref-c-unsigned-long pointer-ref-c-unsigned-long
pointer-ref-c-unsigned-long-long
pointer-ref-c-float pointer-ref-c-float
pointer-ref-c-double pointer-ref-c-double
pointer-ref-c-pointer pointer-ref-c-pointer
@ -17,6 +19,7 @@
pointer-set-c-short! pointer-set-c-short!
pointer-set-c-int! pointer-set-c-int!
pointer-set-c-long! pointer-set-c-long!
pointer-set-c-long-long!
pointer-set-c-pointer! pointer-set-c-pointer!
pointer-set-c-float! pointer-set-c-float!
pointer-set-c-double! pointer-set-c-double!
@ -126,25 +129,28 @@
(define (int? x) (or (fixnum? x) (bignum? x))) (define (int? x) (or (fixnum? x) (bignum? x)))
(define-getter pointer-ref-c-signed-char "ikrt_ref_char") (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-short "ikrt_ref_short")
(define-getter pointer-ref-c-signed-int "ikrt_ref_int") (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 "ikrt_ref_long")
(define-getter pointer-ref-c-unsigned-char "ikrt_ref_uchar") (define-getter pointer-ref-c-signed-long-long "ikrt_ref_longlong")
(define-getter pointer-ref-c-unsigned-short "ikrt_ref_ushort") (define-getter pointer-ref-c-unsigned-char "ikrt_ref_uchar")
(define-getter pointer-ref-c-unsigned-int "ikrt_ref_uint") (define-getter pointer-ref-c-unsigned-short "ikrt_ref_ushort")
(define-getter pointer-ref-c-unsigned-long "ikrt_ref_ulong") (define-getter pointer-ref-c-unsigned-int "ikrt_ref_uint")
(define-getter pointer-ref-c-float "ikrt_ref_float") (define-getter pointer-ref-c-unsigned-long "ikrt_ref_ulong")
(define-getter pointer-ref-c-double "ikrt_ref_double") (define-getter pointer-ref-c-unsigned-long-long "ikrt_ref_ulonglong")
(define-getter pointer-ref-c-pointer "ikrt_ref_pointer") (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-char! int? "ikrt_set_char")
(define-setter pointer-set-c-short! int? "ikrt_set_short") (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-int! int? "ikrt_set_int")
(define-setter pointer-set-c-long! int? "ikrt_set_long") (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-long-long! int? "ikrt_set_longlong")
(define-setter pointer-set-c-double! flonum? "ikrt_set_double") (define-setter pointer-set-c-float! flonum? "ikrt_set_float")
(define-setter pointer-set-c-pointer! pointer? "ikrt_set_pointer") (define-setter pointer-set-c-double! flonum? "ikrt_set_double")
(define-setter pointer-set-c-pointer! pointer? "ikrt_set_pointer")
;;; libffi interface ;;; 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] [cp0-effort-limit i]
[tag-analysis-output i] [tag-analysis-output i]
[perform-tag-analysis i] [perform-tag-analysis i]
[pointer? $for] [pointer? $for]
[pointer->integer $for] [pointer->integer $for]
[integer->pointer $for] [integer->pointer $for]
[dlopen $for] [dlopen $for]
[dlerror $for] [dlerror $for]
[dlclose $for] [dlclose $for]
[dlsym $for] [dlsym $for]
[malloc $for] [malloc $for]
[free $for] [free $for]
[pointer-ref-c-signed-char $for] [pointer-ref-c-signed-char $for]
[pointer-ref-c-signed-short $for] [pointer-ref-c-signed-short $for]
[pointer-ref-c-signed-int $for] [pointer-ref-c-signed-int $for]
[pointer-ref-c-signed-long $for] [pointer-ref-c-signed-long $for]
[pointer-ref-c-unsigned-char $for] [pointer-ref-c-signed-long-long $for]
[pointer-ref-c-unsigned-short $for] [pointer-ref-c-unsigned-char $for]
[pointer-ref-c-unsigned-int $for] [pointer-ref-c-unsigned-short $for]
[pointer-ref-c-unsigned-long $for] [pointer-ref-c-unsigned-int $for]
[pointer-ref-c-float $for] [pointer-ref-c-unsigned-long $for]
[pointer-ref-c-double $for] [pointer-ref-c-unsigned-long-long $for]
[pointer-ref-c-pointer $for] [pointer-ref-c-float $for]
[pointer-set-c-char! $for] [pointer-ref-c-double $for]
[pointer-set-c-short! $for] [pointer-ref-c-pointer $for]
[pointer-set-c-int! $for] [pointer-set-c-char! $for]
[pointer-set-c-long! $for] [pointer-set-c-short! $for]
[pointer-set-c-pointer! $for] [pointer-set-c-int! $for]
[pointer-set-c-float! $for] [pointer-set-c-long! $for]
[pointer-set-c-double! $for] [pointer-set-c-long-long! $for]
[make-c-callout $for] [pointer-set-c-pointer! $for]
[make-c-callback $for] [pointer-set-c-float! $for]
[pointer-set-c-double! $for]
[make-c-callout $for]
[make-c-callback $for]
[host-info i] [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))) (list 0 (sub1 (sll 1 (- n 1))) (sub1 (sll 1 n)))
ls1 ls2 ls3)))) ls1 ls2 ls3))))
(define (u* n) (define (u* n)
(let ([n (min n bits)]) (let ([n (min n bits)])
(combinations n))) (combinations n)))
@ -119,10 +116,18 @@
(t-ref/set 'short (s* 16) pointer-ref-c-signed-short pointer-set-c-short!) (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 '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 (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 '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 '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 '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 (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; 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 ikptr
u_to_number(unsigned long n, ikpcb* pcb) { u_to_number(unsigned long n, ikpcb* pcb) {
unsigned long mxn = ((unsigned long)-1)>>(fx_shift+1); unsigned long mxn = ((unsigned long)-1)>>(fx_shift+1);
@ -266,9 +286,8 @@ u_to_number(unsigned long n, ikpcb* pcb) {
ikptr ikptr
ull_to_number(unsigned long long n, ikpcb* pcb) { ull_to_number(unsigned long long n, ikpcb* pcb) {
unsigned long long mxn = ((unsigned long)-1)>>(fx_shift+1); if (((unsigned long long)(unsigned long) n) == n) {
if (n <= mxn) { return u_to_number(n, pcb);
return fix(n);
} }
ikptr bn = ik_safe_alloc(pcb, align(disp_bignum_data+sizeof(long long))); ikptr bn = ik_safe_alloc(pcb, align(disp_bignum_data+sizeof(long long)));
bcopy((char*)(&n), (char*)(bn+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; return x;
} }
ikptr ikptr
ikrt_ref_int(ikptr p, ikptr off , ikpcb* pcb) { ikrt_ref_int(ikptr p, ikptr off , ikpcb* pcb) {
signed int r = signed int r =
@ -321,6 +338,20 @@ ikrt_ref_ulong(ikptr p, ikptr off , ikpcb* pcb) {
return u_to_number(r, 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 long
extract_num(ikptr x) { extract_num(ikptr x) {
if (is_fixnum(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 ikptr
ikrt_set_char(ikptr p, ikptr off, ikptr v/*, ikpcb* pcb*/) { 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); extract_num(v);
return void_object; return void_object;
} }
ikptr ikptr
ikrt_set_short(ikptr p, ikptr off, ikptr v/*, ikpcb* pcb*/) { 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); extract_num(v);
return void_object; return void_object;
} }
ikptr ikptr
ikrt_set_int(ikptr p, ikptr off, ikptr v/*, ikpcb* pcb*/) { 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); extract_num(v);
return void_object; return void_object;
} }
ikptr ikptr
ikrt_set_long(ikptr p, ikptr off, ikptr v/*, ikpcb* pcb*/) { 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); extract_num(v);
return void_object; 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;
}