139 lines
4.2 KiB
Scheme
139 lines
4.2 KiB
Scheme
|
|
(library (tests pointers)
|
|
(export run-tests)
|
|
(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)])
|
|
(unless (= (bitwise-and n mask) (bitwise-and m mask))
|
|
(error 'test "failed/got" n m
|
|
(bitwise-and n mask) (bitwise-and m mask)))))
|
|
(test-pointer 0)
|
|
(test-pointer 100)
|
|
(test-pointer -100)
|
|
(test-pointer (greatest-fixnum))
|
|
(test-pointer (least-fixnum))
|
|
(test-pointer (+ 1 (greatest-fixnum)))
|
|
(test-pointer (+ 1 (least-fixnum)))
|
|
(test-pointer (- 1 (greatest-fixnum)))
|
|
(test-pointer (- 1 (least-fixnum)))
|
|
(test-pointer (+ -1 (greatest-fixnum)))
|
|
(test-pointer (+ -1 (least-fixnum)))
|
|
(test-pointer (- -1 (greatest-fixnum)))
|
|
(test-pointer (- -1 (least-fixnum)))
|
|
(test-pointer (* 2 (greatest-fixnum)))
|
|
(test-pointer (* 2 (least-fixnum)))
|
|
(test-pointer (* 4 (greatest-fixnum)))
|
|
(test-pointer (* 4 (least-fixnum)))
|
|
(test-pointer (* 8 (greatest-fixnum)))
|
|
(test-pointer (* 8 (least-fixnum)))
|
|
(test-pointer (* 16 (greatest-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 (or* ls1 ls2)
|
|
(apply append
|
|
(map
|
|
(lambda (n1)
|
|
(map
|
|
(lambda (n2)
|
|
(bitwise-ior n1 n2))
|
|
ls2))
|
|
ls1)))
|
|
(let ([n (min bits n)])
|
|
(let* ([ls1 (one-bit-combinations n)]
|
|
[ls2 (or* ls1 ls1)]
|
|
[ls3 (or* ls2 ls1)])
|
|
(append
|
|
(list 0 (sub1 (sll 1 (- n 1))) (sub1 (sll 1 n)))
|
|
ls1 ls2 ls3))))
|
|
|
|
(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 (t-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 (run-tests)
|
|
(for-each check-combinations '(8 16 32 64))
|
|
|
|
(test-pointer-values)
|
|
(t-ref/set 'char (s* 8) pointer-ref-c-signed-char pointer-set-c-char!)
|
|
(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!)
|
|
)
|
|
|
|
|
|
|
|
)
|
|
|
|
|
|
|