~ chicken-core (chicken-5) /tests/locative-stress-test.scm

 1;;; locative-stress-test.scm - by Kon Lovett
 2
 3(declare (usual-integrations))
 4
 5(import (chicken fixnum)
 6	(only (chicken process-context) command-line-arguments))
 7
 8;(set-gc-report! #t)
 9
10#>
11long *ptrs[10];
12
13/*#define check(n)  ptrs[n] = o##n; if(!C_in_stackp((C_word)o##n) && !C_in_fromspacep((C_word)o##n)) C_dbg_hook(0);*/
14#define check(n)
15
16long fill_10(long i, long *o0, long *o1, long *o2, long *o3, long *o4,
17                     long *o5, long *o6, long *o7, long *o8, long *o9)
18{
19 check(0)
20 check(1)
21 check(2)
22 check(3)
23 check(4)
24 check(5)
25 check(6)
26 check(7)
27 check(8)
28 check(9)
29 *o0=*o1=*o2=*o3=*o4=*o5=*o6=*o7=*o8=*o9=i;
30 return i;
31}
32<#
33
34(define fill-10!
35  (foreign-lambda long "fill_10" long 
36                  (c-pointer long) (c-pointer long) (c-pointer long)
37                  (c-pointer long) (c-pointer long) (c-pointer long)
38                  (c-pointer long) (c-pointer long) (c-pointer long)
39                  (c-pointer long)))
40
41(define (make-list n x)
42  (list-tabulate n (lambda _ x)))
43
44(define (list-tabulate n proc)
45  (let loop ((i 0))
46    (if (fx>= i n)
47	'()
48	(cons (proc i) (loop (fx+ i 1))))))
49
50(let* ((el 1)
51       (expected (make-list 10 el)))
52  (let loop
53      ((i (string->number (optional (command-line-arguments) "100000"))))
54    (unless (eq? i 0)
55      (let-location ((o0 long) (o1 long) (o2 long) (o3 long) (o4 long)
56		     (o5 long) (o6 long) (o7 long) (o8 long) (o9 long))
57	(fill-10! el #$o0 #$o1 #$o2 #$o3 #$o4 #$o5 #$o6 #$o7 #$o8 #$o9)
58	(let ((result (list o0 o1 o2 o3 o4 o5 o6 o7 o8 o9)))
59	  (if (not (equal? result expected))
60	      (error "strange values: " result)
61	      (loop (fx- i 1))))))))