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

  1;;;; arithmetic-test.scm
  2;
  3; - switches:
  4;
  5; use-numbers
  6; check
  7; fx-ops
  8
  9
 10(cond-expand 
 11  (windows
 12   (begin
 13     (print "this test can not be run on Windows")
 14     (exit)))
 15  (else))
 16
 17
 18(import (chicken condition)
 19	(chicken platform)
 20	(chicken pretty-print)
 21	(chicken random)
 22	(chicken fixnum))
 23
 24(define range 2)
 25(define random-range 32000)
 26(define result '())
 27
 28(define points
 29  (list 0 1 -1 2 -2
 30	most-positive-fixnum most-negative-fixnum
 31	(add1 most-positive-fixnum) (sub1 most-negative-fixnum)
 32	1103515245			; random
 33	631629065			; random
 34	;;697012302412595925 came up in test-case by Jeronimo Pellegrini
 35	9007199254740992   ; but these are sufficient, since they mark
 36	-9007199254740992 ; the precision-limit of IEEE doubles on 64-bit systems
 37	12345				; random
 38	(expt 2 32)))
 39
 40(cond-expand
 41  (fully-random)
 42  (else (set-pseudo-random-seed! "abcdefgh")))
 43
 44(define (push c total opname args res)
 45  (let ((x (list (cons c total) (cons opname args) '-> res)))
 46    #+(not check) (pp x)
 47    (set! result (cons x result))))
 48
 49(define (test-permutations opname op points)
 50  (let* ((np (length points))
 51	 (nr (add1 (* range 2)))
 52	 (total (* np np nr nr))
 53	 (c 1))
 54    (for-each
 55     (lambda (x)
 56       (for-each
 57	(lambda (y)
 58	  (do ((i (- range) (add1 i)))
 59	      ((> i range))
 60	    (do ((j (- range) (add1 j)))
 61		((> j range))
 62	      (let* ((args (list (+ x i) (+ y j)))
 63		     (res 
 64		      (handle-exceptions ex (get-condition-property ex 'exn 'message)
 65			(apply op args))))
 66		(push c total opname args res)
 67		(set! c (add1 c))))))
 68	points))
 69     points)))
 70
 71(define (test-random-permutations opname op points)
 72  (for-each
 73   (lambda (x)
 74     (for-each
 75      (lambda (y)
 76	(do ((i 10 (sub1 i)))
 77	    ((zero? i))
 78	  (let* ((args (list (+ x (pseudo-random-integer random-range)) 
 79                      (+ y (pseudo-random-integer random-range))))
 80		 (res
 81		  (and (cond-expand
 82			 (fx-ops
 83			  (and (fixnum? (car args))
 84			       (fixnum? (cadr args))))
 85			 (else #t))
 86		       (apply op args))))
 87	    (push opname args res))))
 88      points))
 89   points))
 90
 91(for-each
 92 (lambda (oo)
 93   (let ((args (append oo (list points))))
 94     (apply test-permutations args)))
 95 (cond-expand
 96   (fx-ops
 97    `((fx+? ,fx+?)
 98      (fx-? ,fx-?)
 99      (fx*? ,fx*?)
100      (fx/? ,fx/?)))
101   (else
102    `((+ ,+)
103      (- ,-)
104      (* ,*)
105      (/ ,/)))))
106
107(define (same? x y)
108  (cond ((and (number? x) (number? y)) 
109	 (= x y))
110	((pair? x)
111	 (and (pair? y)
112	      (same? (car x) (car y))
113	      (same? (cdr x) (cdr y))))
114	((vector? x)
115	 (and (vector? y)
116	      (same? (vector->list x) (vector->list y))))
117	(else (equal? x y))))
118
119(set! result (reverse result))
120(define errors? #f)
121
122#+check
123(load 
124 (cond-expand
125   (check-numbers "arithmetic-test.numbers.expected")
126   (else
127    (if (feature? #:64bit)
128	"arithmetic-test.64.expected"
129	"arithmetic-test.32.expected")))
130 (lambda (x)
131   (apply
132    (lambda (c/total1 exp1 _ res1)
133      (apply
134       (lambda (c/total2 exp2 _ res2)
135	 (assert (equal? c/total1 c/total2) "output differs in the number of cases"
136		 c/total1 c/total2)
137	 (unless (same? res1 res2)
138	   (set! errors? #t)
139	   (print "FAIL: " c/total1 " " exp1 " -> expected: " res1 ", but got: " res2)))
140       (car result))
141      (set! result (cdr result)))
142    x)))
143
144(exit (if errors? 1 0))