From 6922b0d9c2c358553d8ddf9ec42cdb01182efbd8 Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Fri, 21 Nov 2008 05:56:51 -0500 Subject: [PATCH] added pointer-ref-{unsigned-,}long-long --- lib/ikarus/foreign.ss | 2 + scheme/ikarus.pointers.ss | 42 +++++++++++--------- scheme/last-revision | 2 +- scheme/makefile.ss | 61 +++++++++++++++-------------- scheme/tests/pointers.ss | 11 ++++-- src/ikarus-pointers.c | 81 ++++++++++++++++++++++++++++++++++----- 6 files changed, 139 insertions(+), 60 deletions(-) diff --git a/lib/ikarus/foreign.ss b/lib/ikarus/foreign.ss index bfd7ba0..12681d5 100644 --- a/lib/ikarus/foreign.ss +++ b/lib/ikarus/foreign.ss @@ -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 diff --git a/scheme/ikarus.pointers.ss b/scheme/ikarus.pointers.ss index bae3564..2d867d6 100644 --- a/scheme/ikarus.pointers.ss +++ b/scheme/ikarus.pointers.ss @@ -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 diff --git a/scheme/last-revision b/scheme/last-revision index 6aec59a..987568c 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1687 +1688 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 79efd1f..dbd4c79 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -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] )) diff --git a/scheme/tests/pointers.ss b/scheme/tests/pointers.ss index 622accf..eb9390a 100644 --- a/scheme/tests/pointers.ss +++ b/scheme/tests/pointers.ss @@ -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!) ) diff --git a/src/ikarus-pointers.c b/src/ikarus-pointers.c index 85fecf6..b45c7a3 100644 --- a/src/ikarus-pointers.c +++ b/src/ikarus-pointers.c @@ -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; +} +