20080906 09:01:39 04:00







(library (tests pointers)




(export testpointers)

20080913 10:49:17 04:00



(import (ikarus) (ikarus system $foreign))

20080906 09:01:39 04:00







(define bits




(if (<= (fixnumwidth) 32) 32 64))

20080913 10:49:17 04:00







(define (testpointervalues)




(define mask (sub1 (sll 1 bits)))




(define (testpointer n)




(let* ([np (integer>pointer n)]




[m (pointer>integer np)]




[mp (integer>pointer m)])




(unless (= (bitwiseand n mask) (bitwiseand m mask))




(error 'test "failed/got" n m




(bitwiseand n mask) (bitwiseand m mask)))))

20080906 09:01:39 04:00



(testpointer 0)




(testpointer 100)




(testpointer 100)




(testpointer (greatestfixnum))




(testpointer (leastfixnum))




(testpointer (+ 1 (greatestfixnum)))




(testpointer (+ 1 (leastfixnum)))




(testpointer ( 1 (greatestfixnum)))




(testpointer ( 1 (leastfixnum)))




(testpointer (+ 1 (greatestfixnum)))




(testpointer (+ 1 (leastfixnum)))




(testpointer ( 1 (greatestfixnum)))




(testpointer ( 1 (leastfixnum)))




(testpointer (* 2 (greatestfixnum)))




(testpointer (* 2 (leastfixnum)))




(testpointer (* 4 (greatestfixnum)))




(testpointer (* 4 (leastfixnum)))




(testpointer (* 8 (greatestfixnum)))




(testpointer (* 8 (leastfixnum)))




(testpointer (* 16 (greatestfixnum)))

20080913 10:49:17 04:00



(testpointer (* 16 (leastfixnum))))








(define (combinations n)




(define (onebitcombinations n)




(let ([n ( n 1)])




(if (< n 0)




'()




(cons (sll 1 n) (onebitcombinations n)))))

20080914 03:38:59 04:00



(define (or* ls1 ls2)

20080913 10:49:17 04:00



(apply append




(map




(lambda (n1)




(map




(lambda (n2)




(bitwiseior n1 n2))

20080914 03:38:59 04:00



ls2))




ls1)))

20080913 10:49:17 04:00



(let ([n (min bits n)])

20080914 03:38:59 04:00



(let* ([ls1 (onebitcombinations n)]




[ls2 (or* ls1 ls1)]




[ls3 (or* ls2 ls1)])




(append




(list 0 (sub1 (sll 1 ( n 1))) (sub1 (sll 1 n)))




ls1 ls2 ls3))))





20080913 10:49:17 04:00















(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)))))









20081013 02:40:26 04:00



(define (tref/set type combinations getter setter)

20080913 10:49:17 04:00



(printf "testing memory access (~s combination for type ~s)\n"




(length combinations)




type)




(foreach




(lambda (n)




(let ([m




(let ([p (malloc 8)])




(setter p 0 n)




(let ([m (getter p 0)])




(free p)




m))])

20081006 01:19:27 04:00



(unless (= n m)

20080913 10:49:17 04:00



(error 'test "failed" getter setter n m))))




combinations))








(define (checkcombinations n)




(define (samepattern? u s i)




(cond




[(= i 1)




(cond




[(= u 0) (= s 0)]




[(= u 1) (= s 1)]




[else #f])]




[else




(and (= (bitwiseand u 1) (bitwiseand s 1))




(samepattern? (sra u 1) (sra s 1) ( i 1)))]))




(define (check u s)




(unless (samepattern? u s (min n bits))




(error 'check "failed" u s)))




(foreach check (u* n) (s* n)))












(define (testpointers)




(foreach checkcombinations '(8 16 32 64))








(testpointervalues)

20081013 02:40:26 04:00



(tref/set 'char (s* 8) pointerrefcsignedchar pointersetcchar!)




(tref/set 'short (s* 16) pointerrefcsignedshort pointersetcshort!)




(tref/set 'int (s* 32) pointerrefcsignedint pointersetcint!)




(tref/set 'long (s* 64) pointerrefcsignedlong pointersetclong!)




(tref/set 'uchar (u* 8) pointerrefcunsignedchar pointersetcchar!)




(tref/set 'ushort (u* 16) pointerrefcunsignedshort pointersetcshort!)




(tref/set 'uint (u* 32) pointerrefcunsignedint pointersetcint!)




(tref/set 'ulong (u* 64) pointerrefcunsignedlong pointersetclong!)

20080913 10:49:17 04:00



)
















)









20080906 09:01:39 04:00



