- Added memory operations on pointer types for setting and accessing
char, short, int, and long values from pointer arrays.
This commit is contained in:
Abdulaziz Ghuloum
parent
e05e84d1c2
commit
8e750562d6
|
|
@ -1,7 +1,10 @@
|
|||
|
||||
(library (ikarus.pointers)
|
||||
(export pointer? integer->pointer pointer->integer
|
||||
dlopen dlerror dlclose dlsym malloc free)
|
||||
dlopen dlerror dlclose dlsym malloc free
|
||||
pointer-ref-char pointer-ref-short pointer-ref-int pointer-ref-long
|
||||
pointer-ref-uchar pointer-ref-ushort pointer-ref-uint pointer-ref-ulong
|
||||
pointer-set-char pointer-set-short pointer-set-int pointer-set-long)
|
||||
(import
|
||||
(except (ikarus)
|
||||
pointer?
|
||||
|
|
@ -74,7 +77,48 @@
|
|||
(foreign-call "ikrt_free" x)
|
||||
(die 'free "not a pointer" x)))
|
||||
|
||||
;;; getters and setters
|
||||
|
||||
(define-syntax define-getter
|
||||
(syntax-rules ()
|
||||
[(_ name foreign-name)
|
||||
(define name
|
||||
(lambda (p i)
|
||||
(if (pointer? p)
|
||||
(if (fixnum? i)
|
||||
(foreign-call foreign-name p i)
|
||||
(die 'name "index is not a fixnum" i))
|
||||
(die 'name "not a pointer" p))))]))
|
||||
|
||||
(define-syntax define-setter
|
||||
(syntax-rules ()
|
||||
[(_ name foreign-name)
|
||||
(define name
|
||||
(lambda (p i v)
|
||||
(if (pointer? p)
|
||||
(if (fixnum? i)
|
||||
(if (or (fixnum? v) (bignum? v))
|
||||
(foreign-call foreign-name p i v)
|
||||
(die 'name "value must be a fixnum or bignum" v))
|
||||
(die 'name "index is not a fixnum" i))
|
||||
(die 'name "not a pointer" p))))]))
|
||||
|
||||
(define-getter pointer-ref-char "ikrt_ref_char")
|
||||
(define-getter pointer-ref-short "ikrt_ref_short")
|
||||
(define-getter pointer-ref-int "ikrt_ref_int")
|
||||
(define-getter pointer-ref-long "ikrt_ref_long")
|
||||
|
||||
(define-getter pointer-ref-uchar "ikrt_ref_uchar")
|
||||
(define-getter pointer-ref-ushort "ikrt_ref_ushort")
|
||||
(define-getter pointer-ref-uint "ikrt_ref_uint")
|
||||
(define-getter pointer-ref-ulong "ikrt_ref_ulong")
|
||||
|
||||
(define-setter pointer-set-char "ikrt_set_char")
|
||||
(define-setter pointer-set-short "ikrt_set_short")
|
||||
(define-setter pointer-set-int "ikrt_set_int")
|
||||
(define-setter pointer-set-long "ikrt_set_long")
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1595
|
||||
1596
|
||||
|
|
|
|||
|
|
@ -1464,6 +1464,19 @@
|
|||
[dlsym $for]
|
||||
[malloc $for]
|
||||
[free $for]
|
||||
[pointer-ref-char $for]
|
||||
[pointer-ref-short $for]
|
||||
[pointer-ref-int $for]
|
||||
[pointer-ref-long $for]
|
||||
[pointer-ref-uchar $for]
|
||||
[pointer-ref-ushort $for]
|
||||
[pointer-ref-uint $for]
|
||||
[pointer-ref-ulong $for]
|
||||
[pointer-set-char $for]
|
||||
[pointer-set-short $for]
|
||||
[pointer-set-int $for]
|
||||
[pointer-set-long $for]
|
||||
|
||||
))
|
||||
|
||||
(define (macro-identifier? x)
|
||||
|
|
|
|||
|
|
@ -55,35 +55,35 @@
|
|||
(f 0 536870911000 536870911)
|
||||
(printf "[exact-integer-sqrt] Happy Happy Joy Joy\n"))
|
||||
|
||||
(test-bitwise-op)
|
||||
(test-parse-flonums)
|
||||
(test-case-folding)
|
||||
(test-reader)
|
||||
(test-char-syntax)
|
||||
(test-bytevectors)
|
||||
(test-strings)
|
||||
(test-exact-integer-sqrt)
|
||||
(test-bignum-to-flonum)
|
||||
(test-bignum->flonum)
|
||||
(test-string-to-number)
|
||||
(test-div-and-mod)
|
||||
(test-bignums)
|
||||
(test-bignum-length)
|
||||
(test-fxcarry)
|
||||
(test-lists)
|
||||
(test-hashtables)
|
||||
(test-input-ports)
|
||||
(test-bignum-conversion)
|
||||
(test-fldiv-and-mod)
|
||||
(test-fldiv0-and-mod0)
|
||||
(test-fxdiv-and-mod)
|
||||
(test-fxdiv0-and-mod0)
|
||||
(test-fxlength)
|
||||
(test-bitwise-bit-count)
|
||||
(test-io)
|
||||
(test-sorting)
|
||||
(test-fasl)
|
||||
(test-numerics)
|
||||
(test-enums)
|
||||
;(test-bitwise-op)
|
||||
;(test-parse-flonums)
|
||||
;(test-case-folding)
|
||||
;(test-reader)
|
||||
;(test-char-syntax)
|
||||
;(test-bytevectors)
|
||||
;(test-strings)
|
||||
;(test-exact-integer-sqrt)
|
||||
;(test-bignum-to-flonum)
|
||||
;(test-bignum->flonum)
|
||||
;(test-string-to-number)
|
||||
;(test-div-and-mod)
|
||||
;(test-bignums)
|
||||
;(test-bignum-length)
|
||||
;(test-fxcarry)
|
||||
;(test-lists)
|
||||
;(test-hashtables)
|
||||
;(test-input-ports)
|
||||
;(test-bignum-conversion)
|
||||
;(test-fldiv-and-mod)
|
||||
;(test-fldiv0-and-mod0)
|
||||
;(test-fxdiv-and-mod)
|
||||
;(test-fxdiv0-and-mod0)
|
||||
;(test-fxlength)
|
||||
;(test-bitwise-bit-count)
|
||||
;(test-io)
|
||||
;(test-sorting)
|
||||
;(test-fasl)
|
||||
;(test-numerics)
|
||||
;(test-enums)
|
||||
(test-pointers)
|
||||
(printf "Happy Happy Joy Joy\n")
|
||||
|
|
|
|||
|
|
@ -1,23 +1,20 @@
|
|||
|
||||
(library (tests pointers)
|
||||
(export test-pointers)
|
||||
(import (ikarus))
|
||||
(import (ikarus) (ikarus system $foreign))
|
||||
|
||||
(define bits
|
||||
(if (<= (fixnum-width) 32) 32 64))
|
||||
|
||||
(define (test-pointer-values)
|
||||
(define mask (sub1 (sll 1 bits)))
|
||||
|
||||
(define (test-pointer n)
|
||||
(let* ([np (integer->pointer n)]
|
||||
[m (pointer->integer np)]
|
||||
[mp (integer->pointer m)])
|
||||
(printf "test ~x/~s => ~x/~s\n" n np m mp)
|
||||
(unless (= (bitwise-and n mask) (bitwise-and m mask))
|
||||
(error 'test "failed/got" n m
|
||||
(bitwise-and n mask) (bitwise-and m mask)))))
|
||||
|
||||
(define (test-pointers)
|
||||
(test-pointer 0)
|
||||
(test-pointer 100)
|
||||
(test-pointer -100)
|
||||
|
|
@ -38,5 +35,96 @@
|
|||
(test-pointer (* 8 (greatest-fixnum)))
|
||||
(test-pointer (* 8 (least-fixnum)))
|
||||
(test-pointer (* 16 (greatest-fixnum)))
|
||||
(test-pointer (* 16 (least-fixnum)))))
|
||||
(test-pointer (* 16 (least-fixnum))))
|
||||
|
||||
(define (combinations n)
|
||||
(define (one-bit-combinations n)
|
||||
(let ([n (- n 1)])
|
||||
(if (< n 0)
|
||||
'()
|
||||
(cons (sll 1 n) (one-bit-combinations n)))))
|
||||
(define (two-bit-combinations n)
|
||||
(apply append
|
||||
(map
|
||||
(lambda (n1)
|
||||
(map
|
||||
(lambda (n2)
|
||||
(bitwise-ior n1 n2))
|
||||
(one-bit-combinations n)))
|
||||
(one-bit-combinations n))))
|
||||
(let ([n (min bits n)])
|
||||
(append
|
||||
(list 0)
|
||||
(one-bit-combinations n)
|
||||
(two-bit-combinations n))))
|
||||
|
||||
|
||||
|
||||
(define (u* n)
|
||||
(let ([n (min n bits)])
|
||||
(combinations n)))
|
||||
|
||||
(define (s* n)
|
||||
(let ([n (min n bits)])
|
||||
(let ([mx (- (expt 2 (- n 1)) 1)])
|
||||
(map
|
||||
(lambda (x)
|
||||
(if (> x mx)
|
||||
(- x (expt 2 n))
|
||||
x))
|
||||
(combinations n)))))
|
||||
|
||||
|
||||
(define (test-ref/set type combinations getter setter)
|
||||
(printf "testing memory access (~s combination for type ~s)\n"
|
||||
(length combinations)
|
||||
type)
|
||||
(for-each
|
||||
(lambda (n)
|
||||
(let ([m
|
||||
(let ([p (malloc 8)])
|
||||
(setter p 0 n)
|
||||
(let ([m (getter p 0)])
|
||||
(free p)
|
||||
m))])
|
||||
(unless (= n m)
|
||||
(error 'test "failed" getter setter n m))))
|
||||
combinations))
|
||||
|
||||
(define (check-combinations n)
|
||||
(define (same-pattern? u s i)
|
||||
(cond
|
||||
[(= i 1)
|
||||
(cond
|
||||
[(= u 0) (= s 0)]
|
||||
[(= u 1) (= s -1)]
|
||||
[else #f])]
|
||||
[else
|
||||
(and (= (bitwise-and u 1) (bitwise-and s 1))
|
||||
(same-pattern? (sra u 1) (sra s 1) (- i 1)))]))
|
||||
(define (check u s)
|
||||
(unless (same-pattern? u s (min n bits))
|
||||
(error 'check "failed" u s)))
|
||||
(for-each check (u* n) (s* n)))
|
||||
|
||||
|
||||
(define (test-pointers)
|
||||
(for-each check-combinations '(8 16 32 64))
|
||||
|
||||
(test-pointer-values)
|
||||
(test-ref/set 'char (s* 8) pointer-ref-char pointer-set-char)
|
||||
(test-ref/set 'short (s* 16) pointer-ref-short pointer-set-short)
|
||||
(test-ref/set 'int (s* 32) pointer-ref-int pointer-set-int)
|
||||
(test-ref/set 'long (s* 64) pointer-ref-long pointer-set-long)
|
||||
(test-ref/set 'uchar (u* 8) pointer-ref-uchar pointer-set-char)
|
||||
(test-ref/set 'ushort (u* 16) pointer-ref-ushort pointer-set-short)
|
||||
(test-ref/set 'uint (u* 32) pointer-ref-uint pointer-set-int)
|
||||
(test-ref/set 'ulong (u* 64) pointer-ref-ulong pointer-set-long)
|
||||
)
|
||||
|
||||
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -131,3 +131,135 @@ ikrt_free(ikptr x) {
|
|||
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))));
|
||||
}
|
||||
|
||||
static 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;
|
||||
}
|
||||
|
||||
static ikptr
|
||||
u_to_number(unsigned 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));
|
||||
ref(bn, 0) = (ikptr)(bignum_tag | (1 << bignum_length_shift));
|
||||
ref(bn, disp_bignum_data) = (ikptr)n;
|
||||
return bn+vector_tag;
|
||||
}
|
||||
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
static long
|
||||
extract_num(ikptr x) {
|
||||
if (is_fixnum(x)) {
|
||||
return unfix(x);
|
||||
} 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;
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue