;;;-*- Mode:LISP; Package:NEW-MATH; Readtable:CL; Base:10 -*-

;;Written by WKF 5/26/88

;;This file performs a simple test on floating point numbers.

(defvar half)
(defvar neg-half)
(defvar quarter)
(defvar neg-quarter)
(defvar three-qtr)
(defvar one)
(defvar two)
(defvar zero-float)
(defvar neg-zero)
(defvar one-float)
(defvar two-float)
(defvar eleven-float)
(defvar eight-float)
(defvar one-eighth)
(defvar eighth)
(defvar sev-eith)

(defun time-short-add-with-traps ()
  (time-short-with-traps 1.234s0 4.321s0))

(defun time-short-with-traps (a b)
  (hw:write-microsecond-clock (hw:unboxed-constant 0))
  (li:error "Time short add with traps complete." (dotimes (n 99999 (+ a b))
						    (setq a (+ a b))
						    ;(setq a (- a b))
						    )
	    (hw:read-microsecond-clock)))

(defun time-short-add-without-traps ()
  (time-short-without-traps 1.234s0 4.321s0))

(defun time-short-without-traps (a b)
  (hw:write-microsecond-clock (hw:unboxed-constant 0))
  (li:error "Time short add without traps complete." (dotimes (n 99999 (add-short a b))
						       (setq a (add-short a b))
						       ;(setq a (subtract-short a b))
						       )
	    (hw:read-microsecond-clock)))

(defun test-overflow ()
  (let ((a 2s0))
    (loop (setq a (multiply-short a a)))))

(defun test-div-short ()  ;;This wedges the machine currently 7/13/88
  (let ((h 15s0)
	(q  3s0)
	(c  5s0))
    (let ((ans (divide-short h q)))
      (unless (= c ans)
	(li:error "Divide short and compare failed. (ans q h c)" ans q h c))
      (li:error "Divide short success"))))

(defun test-multiply-short ()
  (let ((h .5s0)
	(q .25s0))
    (let ((ans (* h h)))
      (unless (= q ans)
	(li:error "Multiply short and compare failed. (ans q h)" ans q h))
      (li:error "Multiply short success"))))

(defun simple-test1 ()  ;;              exponent mantissa.........
  (init-float)
  (setq half    .5s0   ;;#x14fc0000 #b 0 01111110 00000000000000000
	quarter .25s0) ;;#x14fa0000 #b 0 01111101 00000000000000000
  (let ((ans (+ quarter quarter)))
    (unless (= half ans)
      (li:error "Test 1  failed" ans quarter half 'simple))
    (li:error "Completed simple test.")))

(defun simple-test2 ()
  (setq one      1s0
	half    .5s0)
  (let ((ans (add-short half half)))
    (unless (= one ans)
      (li:error "Test 1  failed" ans half one 'simple))
    (li:error "Completed simple test.")))

(defun simple-test3 ()
  (setq one      1s0
	quarter .25s0
	three-qtr .75s0)
  (let ((ans (add-short quarter three-qtr)))
    (unless (= one ans)
      (li:error "Test 1  failed" ans quarter three-qtr one 'simple))
    (li:error "Completed simple test.")))
  

(defun simple-test4 ()
  (setq sev-eith      .875s0
	eighth .125s0
	three-qtr .75s0)
  (let ((ans (add-short eighth three-qtr)))
    (unless (= sev-eith ans)
      (li:error "Test 1  failed" ans eighth three-qtr sev-eith 'simple))
    (li:error "Completed simple test.")))


(defun single-test1 ()
  (setq one       1.00
	quarter   0.25
	three-qtr 0.75)
  (let ((ans (+ quarter three-qtr)))
    (unless (= one ans)
      (li:error "Single Test 1  failed" ans quarter three-qtr one 'simple))
    (li:error "Completed single test1.")))

(defun init-short-test ()
  (setq half           .5s0
	neg-half      -.5s0
	quarter       .25s0
	neg-quarter  -.25s0
	one-eighth   .125s0
	two           2
	two-float     2.0s0
	zero-float    0.0s0
	neg-zero     -0.0s0
	one-float     1.0s0
	eleven-float 11.0s0
	eight-float   8.0s0))

(defun init-single-test ()
  (setq half           .5
	neg-half      -.5
	quarter       .25
	neg-quarter  -.25
	one-eighth   .125
	two           2
	two-float     2.0
	zero-float    0.0
	neg-zero     -0.0
	one-float     1.0
	eleven-float 11.0
	eight-float   8.0))

(defun init-double-test ()
  (setq half           .5d0
	neg-half      -.5d0
	quarter       .25d0
	neg-quarter  -.25d0
	one-eighth   .125d0
	two           2
	two-float     2.0d0
	zero-float    0.0d0
	neg-zero     -0.0d0
	one-float     1.0d0
	eleven-float 11.0d0
	eight-float   8.0d0))

(defun test ()
  (init-float)
  (init-short-test)
  (test-sweep 'short)
  (test-sweep-short)
  (init-single-test)
  (test-sweep 'single)
  (test-sweep-single)
  (init-double-test)
  (test-sweep 'double)
  (test-sweep-double)
  (li:error "Full Test completed."))

(defun test-short ()
  (init-short-test)
  (test-sweep 'short)
  (test-sweep-short)
  (li:error "Short test complete."))

(defun test-single ()
  (init-single-test)
  (test-sweep 'single)
  (test-sweep-single)
  (li:error "Single test complete."))

(defun test-double ()
  (init-double-test)
  (test-sweep 'double)
  (test-sweep-double)
  (li:error "Double test complete."))

(defun test-sweep (test-type)
  (unless (= half (+ quarter quarter))
    (li:error "Test 1  failed" (+ quarter quarter) test-type))
  (unless (= quarter (- half quarter))
    (li:error "Test 2  failed" (- half quarter) test-type))
  (unless (= quarter (* half half))
    (li:error "Test 3  failed" (* half half) test-type))
  (unless (= half (divide-generic quarter half))
    (li:error "Test 4  failed" (divide-generic quarter half) test-type))
  (unless (= neg-half (- half))
    (li:error "Test 5a failed" (- half) test-type))
  (unless (= (- neg-half) half)
    (li:error "Test 5b failed" (- neg-half) test-type))
  (unless (eq one-float (sign-value quarter))
    (li:error "Test 7  failed" (sign-value quarter) test-type))
  (unless (eq -1.0d0 (sign-value neg-quarter))
    (li:error "Test 8  failed" (sign-value neg-quarter) test-type))
  (unless (zero-floatp zero-float)
    (li:error "Test 9a failed" (zero-floatp zero-float) test-type))
  (unless (zero-floatp neg-zero)
    (li:error "Test 9b failed" (zero-floatp neg-zero) test-type))
  (when (zero-floatp one-float)
    (li:error "Test 10 failed" (zero-floatp one-float) test-type))
  (unless (= one-eighth (scale-mantissa eight-float))
    (li:error "Test 11 failed" (scale-mantissa eight-float) test-type))
  (unless (= 3 (find-exponent eleven-float))
    (li:error "Test 13 failed" (find-exponent eleven-float) test-type))
  (unless (= zero-float neg-zero)
    (li:error "Test 14 failed" (= zero-float neg-zero) test-type))
  (when (eql zero-float neg-zero)
    (li:error "Test 15 failed" (eql zero-float neg-zero) test-type))
  (when (< neg-zero zero-float)
    (li:error "Test 16 failed" (< neg-zero zero-float) test-type))
  (when (> neg-zero zero-float)
    (li:error "Test 17 failed" (> neg-zero zero-float) test-type))
  (unless (minusp neg-half)
    (li:error "Test 18 failed" (minusp neg-half) test-type))
  (when (minusp zero-float)
    (li:error "Test 19 failed" (minusp zero-float) test-type))
  (unless (minusp neg-zero)
    (li:error "Test 20 failed" (minusp neg-zero) test-type))
  )
       
(defun test-sweep-short ()
  (unless (eq half #x14fc0000)
    (li:error "Short 0  failed" half))
  (unless (eq two-float (convert-fixnum-to-short two))
    (li:error "Short 1  failed" (convert-fixnum-to-short two)))
  (unless (= #b101100000000000000 (find-mantissa eleven-float))
    (li:error "Short 2a failed" (find-mantissa eleven-float)))
  (unless (= 3 (find-exponent eleven-float))
    (li:error "Short 2b failed" (find-exponent eleven-float))))

(defun test-sweep-single ()                                      ;;ExponentMantissa.........
  (unless (hw:32= (array:%vm-read32 half 1) (hw:unboxed-constant #b00111111000000000000000000))
    (li:error "Single 0  failed" (array:%vm-read32 half 1)))
  (unless (eql two-float (convert-fixnum-to-single two))
    (li:error "Single 1  failed" (convert-fixnum-to-single two)))
  (unless (= #b101100000000000000000000 (find-mantissa eleven-float))
    (li:error "Single 2a failed" (find-mantissa eleven-float)))
  (unless (= 3 (find-exponent eleven-float))
    (li:error "Single 2b failed" (find-exponent eleven-float)))
  (unless (= half (convert-short-to-single 0.5s0))
    (li:error "Single 3  failed" (convert-short-to-single 0.5s0)))
  (unless (= quarter 0.25s0)
    (li:error "Single 4  failed" (= quarter 0.25s0))))

(defun test-sweep-double ()                                      ;;ExponentMantissa.........
  (unless (hw:32= (array:%vm-read32 half 2) (hw:unboxed-constant #b00111111000000000000000000))
    (li:error "Double 0a failed" (array:%vm-read32 half 2)))
  (unless (hw:32zerop (array:%vm-read32 half 1))
    (li:error "Double 0b failed" (array:%vm-read32 half 1)))
  (unless (eql two-float (convert-fixnum-to-double two))
    (li:error "Double 1  failed" (convert-fixnum-to-double two)))
  (unless (= #b101100000000000000000000000000000000000000000000000000 (find-mantissa eleven-float))
    (li:error "Double 2a failed" (find-mantissa eleven-float)))
  (unless (= 3 (find-exponent eleven-float))
    (li:error "Double 2b failed" (find-exponent eleven-float)))
  (unless (= half (convert-short-to-double 0.5s0))
    (li:error "Double 3a failed" (convert-short-to-double 0.5s0)))
  (unless (= half (convert-single-to-double 0.5))
    (li:error "Double 3b failed" (convert-single-to-double 0.5)))
  (unless (= quarter 0.25s0)
    (li:error "Double 4a failed" (= quarter 0.25s0)))
  (unless (= quarter 0.25)
    (li:error "Double 4b failed" (= quarter 0.25))))