153 lines
5.5 KiB
Scheme
153 lines
5.5 KiB
Scheme
(load-relative "loadtest.ss")
|
|
(Section 'fixnum)
|
|
(require scheme/fixnum
|
|
scheme/unsafe/ops
|
|
(prefix-in r6: rnrs/arithmetic/fixnums-6))
|
|
|
|
(define unary-table
|
|
(list (list fxnot unsafe-fxnot)
|
|
(list fxabs unsafe-fxabs)
|
|
(list fx->fl unsafe-fx->fl)))
|
|
|
|
(define binary-table
|
|
(list (list fx+ unsafe-fx+)
|
|
(list fx- unsafe-fx-)
|
|
(list fx* unsafe-fx*)
|
|
|
|
(list fxquotient unsafe-fxquotient)
|
|
(list fxremainder unsafe-fxremainder)
|
|
(list fxmodulo unsafe-fxmodulo)
|
|
|
|
(list fxand unsafe-fxand)
|
|
(list fxior unsafe-fxior)
|
|
(list fxxor unsafe-fxxor)
|
|
|
|
(list fx>= unsafe-fx>=)
|
|
(list fx> unsafe-fx>)
|
|
(list fx= unsafe-fx=)
|
|
(list fx<= unsafe-fx<=)
|
|
(list fx< unsafe-fx<)
|
|
(list fxmin unsafe-fxmin)
|
|
(list fxmax unsafe-fxmax)))
|
|
|
|
(define binary/small-second-arg-table
|
|
(list (list fxlshift unsafe-fxlshift)
|
|
(list fxrshift unsafe-fxrshift)))
|
|
|
|
(define nary-table
|
|
(list))
|
|
|
|
(define table (append binary/small-second-arg-table binary-table unary-table nary-table))
|
|
|
|
(define (normalize-arity a)
|
|
(cond
|
|
[(list? a)
|
|
(let ([at-least (ormap (λ (x) (and (arity-at-least? x) x)) a)])
|
|
(if at-least
|
|
(let ([new-a
|
|
(filter (λ (x) (or (not (number? x))
|
|
(< x (arity-at-least-value at-least))))
|
|
a)])
|
|
(if (pair? (cdr new-a))
|
|
new-a
|
|
(car new-a)))
|
|
(if (pair? (cdr a))
|
|
a
|
|
(car a))))]
|
|
[else a]))
|
|
|
|
(define (check-arity fx unsafe-fx)
|
|
(let ([same-arities? (λ (x y) (equal? (normalize-arity (procedure-arity x))
|
|
(normalize-arity (procedure-arity y))))])
|
|
(test #t
|
|
same-arities?
|
|
fx
|
|
unsafe-fx)))
|
|
|
|
|
|
;; same-results : (fixnum ... -> any) (fixnum ... -> any) (listof fixnum) -> #t
|
|
;; applies fx to args; if it raises an error, the function returns #t.
|
|
;; if it returns a result, the function applies args
|
|
;; to unsafe-fx and makes sure the results are either eq? or
|
|
;; (if the results are flonums), =
|
|
;; raises an exception when it finds a bug.
|
|
(define (same-results fx unsafe-fx args)
|
|
(let/ec k
|
|
(let* ([fx-result (with-handlers ((exn:fail? (λ (x) (k #t))))
|
|
(apply fx args))]
|
|
[unsafe-result (apply unsafe-fx args)]
|
|
[ans
|
|
(or (eq? fx-result unsafe-result)
|
|
(and (flonum? fx-result)
|
|
(flonum? unsafe-result)
|
|
(= fx-result unsafe-result)))])
|
|
(unless ans
|
|
(newline)
|
|
(error 'same-results "better die now, rather than continue, what with unsafe ops around:\n fx-result ~s\n unsafe-result ~s"
|
|
fx-result
|
|
unsafe-result))
|
|
#t)))
|
|
|
|
(define (flonum? x) (inexact-real? x))
|
|
|
|
(define (same-results/range/table)
|
|
(for ([line (in-list unary-table)])
|
|
(for ([i (in-range (- (expt 2 8)) (expt 2 8))])
|
|
(test #t same-results (list-ref line 0) (list-ref line 1) (list i))))
|
|
|
|
(for ([line (in-list (append binary/small-second-arg-table
|
|
binary-table
|
|
nary-table))])
|
|
(for ([i (in-range (- (expt 2 4)) (expt 2 4))])
|
|
(for ([j (in-range (- (expt 2 4)) (expt 2 4))])
|
|
(test #t same-results (list-ref line 0) (list-ref line 1) (list i j))))))
|
|
|
|
(define (same-results/extremum)
|
|
(let ([interesting-values (list (r6:least-fixnum) -1 0 1 (r6:greatest-fixnum))])
|
|
(for ([line (in-list unary-table)])
|
|
(for ([i (in-list interesting-values)])
|
|
(test #t same-results (list-ref line 0) (list-ref line 1) (list i))))
|
|
|
|
(for ([line (in-list (append binary/small-second-arg-table
|
|
binary-table
|
|
nary-table))])
|
|
(for ([i (in-list interesting-values)])
|
|
(for ([j (in-list interesting-values)])
|
|
(test #t same-results (list-ref line 0) (list-ref line 1) (list i j)))))))
|
|
|
|
(define (same-results/random/table)
|
|
(for ([ignore (in-range 0 800)])
|
|
(let ([i (random-fixnum)]
|
|
[j (random-fixnum)]
|
|
[k (inexact->exact (floor (* (random) (+ 1 (r6:fixnum-width)))))]
|
|
[more-fixnums (build-list (random 20) (λ (i) (random-fixnum)))])
|
|
(for ([line (in-list unary-table)])
|
|
(test #t same-results (list-ref line 0) (list-ref line 1) (list i)))
|
|
(for ([line (in-list binary-table)])
|
|
(test #t same-results (list-ref line 0) (list-ref line 1) (list i j)))
|
|
(for ([line (in-list binary/small-second-arg-table)])
|
|
(test #t same-results (list-ref line 0) (list-ref line 1) (list i k)))
|
|
(for ([line (in-list nary-table)])
|
|
(test #t same-results (list-ref line 0) (list-ref line 1) (list i))
|
|
(test #t same-results (list-ref line 0) (list-ref line 1) (list i j))
|
|
(test #t same-results (list-ref line 0) (list-ref line 1) (list i j k))
|
|
(test #t same-results (list-ref line 0) (list-ref line 1) (list i k j))
|
|
(test #t same-results (list-ref line 0) (list-ref line 1) more-fixnums)))))
|
|
|
|
(define (random-fixnum)
|
|
(inexact->exact (floor (+ (r6:least-fixnum) (* (random) (+ (- (r6:greatest-fixnum) (r6:least-fixnum)) 1))))))
|
|
|
|
;; check the arities
|
|
(for-each (λ (x) (apply check-arity x)) table)
|
|
|
|
;; check the extreme values (against themselves and few other values)
|
|
(same-results/extremum)
|
|
|
|
;; check randomly
|
|
(same-results/random/table)
|
|
|
|
;; check a small range
|
|
(same-results/range/table)
|
|
|
|
(report-errs)
|