ikarus/scheme/tests/pointers.ss

139 lines
4.2 KiB
Scheme
Raw Normal View History

(library (tests pointers)
2008-10-18 13:03:17 -04:00
(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)))
2008-10-18 13:03:17 -04:00
(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!)
)
)