mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
223 lines
10 KiB
Common Lisp
223 lines
10 KiB
Common Lisp
;;;; This software is part of the SBCL system. See the README file for
|
|
;;;; more information.
|
|
;;;;
|
|
;;;; While most of SBCL is derived from the CMU CL system, the test
|
|
;;;; files (like this one) were written from scratch after the fork
|
|
;;;; from CMU CL.
|
|
;;;;
|
|
;;;; This software is in the public domain and is provided with
|
|
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
|
;;;; more information.
|
|
|
|
(with-test (:name :ranges)
|
|
(let* ((ops '(< > <= >=))
|
|
(ranges (list 0 1 -1 -2 2 most-positive-fixnum most-negative-fixnum))
|
|
(ns (append ranges
|
|
(list most-positive-double-float most-negative-double-float
|
|
least-positive-double-float least-negative-double-float
|
|
most-positive-single-float most-negative-single-float
|
|
least-positive-single-float least-negative-single-float
|
|
0.0 -0.0 0d0 -0.0
|
|
1.0 -1.0 0.5 -0.5 1.2 -1.2
|
|
1.0d0 -1.0d0 0.5d0 -0.5d0 1.2d0 -1.2d0
|
|
1/2 -1/2
|
|
4/3 -4/3
|
|
(expt 2 300)
|
|
(- (expt 2 300))
|
|
(/ (expt 2 300))
|
|
(/ (- (expt 2 300)))
|
|
(/ 3 (expt 2 300))
|
|
(/ 3 (- (expt 2 300)))
|
|
(1- (expt 2 sb-vm:n-word-bits))
|
|
(1- (expt 2 (1- sb-vm:n-word-bits)))
|
|
(- (expt 2 (1- sb-vm:n-word-bits))))))
|
|
#+(and slow sb-thread)
|
|
threads)
|
|
(macrolet ((thread (&body body)
|
|
(or #+(and slow sb-thread)
|
|
`(push (sb-thread:make-thread (lambda () ,@body))
|
|
threads)
|
|
`(progn ,@body))))
|
|
(loop
|
|
for logical in '(and #+slow or)
|
|
do
|
|
(loop
|
|
for op1 in ops
|
|
do
|
|
(let ((op1 op1)
|
|
(logical logical))
|
|
(thread
|
|
(loop
|
|
for op1-not in '(progn #+slow not)
|
|
do
|
|
(loop
|
|
for op2 in ops
|
|
do
|
|
(loop
|
|
for op2-not in '(progn #+slow not)
|
|
do
|
|
(loop
|
|
for l in (list* 'l ranges)
|
|
do
|
|
(loop
|
|
for h in (list* 'h ranges)
|
|
do
|
|
(loop
|
|
for args1 in (list (list l 'n)
|
|
#+slow (list 'n l))
|
|
do
|
|
(loop
|
|
for args2 in (list (list h 'n)
|
|
#+slow (list 'n h))
|
|
do
|
|
(loop
|
|
for type in `(t #+slow ,@'(integer fixnum unsigned-byte (and fixnum unsigned-byte)
|
|
sb-vm:signed-word
|
|
sb-vm:word))
|
|
do
|
|
(loop
|
|
for l-type in (if (integerp l)
|
|
'(t)
|
|
`(fixnum #+slow ,@'((and unsigned-byte fixnum)
|
|
(and (integer * -1) fixnum)
|
|
sb-vm:signed-word
|
|
sb-vm:word)))
|
|
do
|
|
(loop
|
|
for h-type in (if (integerp h)
|
|
'(t)
|
|
`(fixnum #+slow ,@'((and unsigned-byte fixnum)
|
|
(and (integer * -1) fixnum)
|
|
sb-vm:signed-word
|
|
sb-vm:word)))
|
|
do
|
|
(let* ((form `(lambda (l n h)
|
|
(declare (,l-type l)
|
|
(,h-type h)
|
|
(,type n)
|
|
(ignorable l h))
|
|
(,logical
|
|
(,op1-not (,op1 ,@args1))
|
|
(,op2-not (,op2 ,@args2)))))
|
|
(fun1 (checked-compile form))
|
|
(fun2 (checked-compile
|
|
`(lambda (l n h)
|
|
(declare (ignorable l h)
|
|
(notinline ,@ops))
|
|
(,logical
|
|
(,op1-not (,op1 ,@args1))
|
|
(,op2-not (,op2 ,@args2)))))))
|
|
(loop
|
|
for l in ranges
|
|
when (typep l l-type)
|
|
do
|
|
(loop
|
|
for h in ranges
|
|
when (typep h h-type)
|
|
do
|
|
(loop
|
|
for n in ns
|
|
when (typep n type)
|
|
do
|
|
(unless (eql (funcall fun1 l n h)
|
|
(funcall fun2 l n h))
|
|
(error "~a" (list form
|
|
l n h))))))))))))))))))))))
|
|
#+(and slow sb-thread)
|
|
(mapc #'sb-thread:join-thread threads)))
|
|
|
|
(with-test (:name :ranges-to-fixnump)
|
|
(let* ((ops '(< > <= >=))
|
|
(ranges (list 0 1 -1 -2 2 most-positive-fixnum most-negative-fixnum
|
|
(1- (expt 2 sb-vm:n-word-bits))
|
|
(1- (expt 2 (1- sb-vm:n-word-bits)))
|
|
(- (expt 2 (1- sb-vm:n-word-bits)))))
|
|
(ranges (or (append ranges
|
|
(loop for i in '(1 -1 -2 2)
|
|
collect (+ most-positive-fixnum i)
|
|
collect (+ most-negative-fixnum i)))
|
|
ranges))
|
|
(ns (append ranges
|
|
(list 20 -20
|
|
(expt 2 300)
|
|
(- (expt 2 300))
|
|
(1- (expt 2 sb-vm:n-word-bits))
|
|
(1- (expt 2 (1- sb-vm:n-word-bits)))
|
|
(- (expt 2 (1- sb-vm:n-word-bits)))))))
|
|
(loop
|
|
for op1 in ops
|
|
do
|
|
(loop
|
|
for op2 in ops
|
|
do
|
|
(loop
|
|
for l in ranges
|
|
do
|
|
(loop
|
|
for h in ranges
|
|
do
|
|
(loop
|
|
for args1 in (list (list l 'n)
|
|
#+slow (list 'n l))
|
|
do
|
|
(loop
|
|
for args2 in (list (list h 'n)
|
|
#+slow (list 'n h))
|
|
do
|
|
(let* ((form `(lambda (n)
|
|
(declare (integer n))
|
|
(and
|
|
(,op1 ,@args1)
|
|
(,op2 ,@args2))))
|
|
(fun1 (checked-compile form))
|
|
(fun2 (checked-compile
|
|
`(lambda (n)
|
|
(declare (notinline ,@ops))
|
|
(and
|
|
(,op1 ,@args1)
|
|
(,op2 ,@args2))))))
|
|
(loop
|
|
for n in ns
|
|
do
|
|
(unless (eql (funcall fun1 n)
|
|
(funcall fun2 n))
|
|
(error "~a" (list form n)))))))))))))
|
|
|
|
(with-test (:name :cmp-constant-fraction)
|
|
(let* ((ops '(< > <= >=))
|
|
(rational (list 0 1 -1 -2 2 most-positive-fixnum most-negative-fixnum
|
|
1/2 -1/2
|
|
4/3 -4/3
|
|
(expt 2 300)
|
|
(- (expt 2 300))
|
|
(/ (expt 2 300))
|
|
(/ (- (expt 2 300)))
|
|
(/ 3 (expt 2 300))
|
|
(/ 3 (- (expt 2 300)))
|
|
(1- (expt 2 sb-vm:n-word-bits))
|
|
(1- (expt 2 (1- sb-vm:n-word-bits)))
|
|
(- (expt 2 (1- sb-vm:n-word-bits)))))
|
|
(constants (list* most-positive-double-float most-negative-double-float
|
|
least-positive-double-float least-negative-double-float
|
|
most-positive-single-float most-negative-single-float
|
|
least-positive-single-float least-negative-single-float
|
|
0.0 -0.0 0d0 -0.0
|
|
1.0 -1.0 0.5 -0.5 1.2 -1.2
|
|
1.0d0 -1.0d0 0.5d0 -0.5d0 1.2d0 -1.2d0 rational)))
|
|
(loop for op in ops
|
|
do
|
|
(loop for constant in constants
|
|
do
|
|
(loop for type in '(integer rational)
|
|
do
|
|
(let* ((form `(lambda (x)
|
|
(declare (,type x))
|
|
(,op x ,constant)))
|
|
(fun (checked-compile form)))
|
|
(loop for arg in rational
|
|
when (typep arg type)
|
|
do
|
|
(unless (eq (funcall fun arg)
|
|
(funcall op arg constant))
|
|
(error "~a" (list form arg))))))))))
|