[oct-cvs] Oct commit: oct oct.system qd-fun.lisp qd-rep.lisp qd.lisp
rtoy
rtoy at common-lisp.net
Wed Nov 28 20:00:29 UTC 2007
Update of /project/oct/cvsroot/oct
In directory clnet:/tmp/cvs-serv14440
Modified Files:
oct.system qd-fun.lisp qd-rep.lisp qd.lisp
Log Message:
Adjust code so that CMUCL can use arrays to store quad-doubles instead
of using a (complex double-double-float).
With these changes, CMUCL uses arrays and (rt:do-tests) passes
successfully.
oct.system:
o Push :oct-array onto *FEATURES* to use arrays. This is the default
if not building on CMUCL.
qd-fun.lisp:
o Fix two erroneous uses of zerop on a quad-double in sinh-qd and
tanh-qd.
o Fix two erroneous uses of + on %quad-double; they should have used
ADD-QD instead.
qd-rep.lisp:
o Change conditionalization to allow arrays for CMUCL.
o Update compiler macros appropriately.
qd.lisp:
o Adjust optional target arg appropriately for oct-array feature.
o Clean up IGNORE declarations.
o Add some more declarations for the target to make CMUCL happier.
--- /project/oct/cvsroot/oct/oct.system 2007/09/16 05:00:00 1.22
+++ /project/oct/cvsroot/oct/oct.system 2007/11/28 20:00:28 1.23
@@ -44,6 +44,16 @@
(eval-when (:load-toplevel :compile-toplevel :execute)
(setf ext:*inline-expansion-limit* 1600))
+;;
+;; For all Lisps other than CMUCL, oct uses arrays to store the
+;; quad-double values. This is denoted by the feature :oct-array.
+;; For CMUCL, quad-doubles can be stored in a (complex
+;; double-double-float) object, which is an extension in CMUCL.
+;; If you want CMUCL to use an array too, add :oct-array to *features*.
+;;#-cmu
+(pushnew :oct-array *features*)
+
+
(mk:defsystem oct
:source-pathname (make-pathname :directory (pathname-directory *load-pathname*))
:components
--- /project/oct/cvsroot/oct/qd-fun.lisp 2007/11/07 21:38:10 1.91
+++ /project/oct/cvsroot/oct/qd-fun.lisp 2007/11/28 20:00:28 1.92
@@ -1140,7 +1140,7 @@
(declare (type %quad-double a))
;; Hart et al. suggests sinh(x) = 1/2*(D(x) + D(x)/(D(x)+1))
;; where D(x) = exp(x) - 1. This helps for x near 0.
- (cond ((zerop a)
+ (cond ((zerop (qd-0 a))
a)
((float-infinity-p (qd-0 a))
a)
@@ -1166,7 +1166,7 @@
"Tanh(a)"
(declare (type %quad-double a))
;; Hart et al. suggests tanh(x) = D(2*x)/(2+D(2*x))
- (cond ((zerop a)
+ (cond ((zerop (qd-0 a))
a)
((> (abs (qd-0 a)) (/ (+ (log most-positive-double-float)
(log 2d0))
@@ -1262,8 +1262,8 @@
(if (minusp-qd a)
(neg-qd (asinh-qd (neg-qd a)))
(let ((1/a (div-qd (make-qd-d 1d0) a)))
- (+ (log-qd a)
- (log1p-qd (sqrt-qd (add-qd-d (sqr-qd 1/a) 1d0)))))))))
+ (add-qd (log-qd a)
+ (log1p-qd (sqrt-qd (add-qd-d (sqr-qd 1/a) 1d0)))))))))
(defun acosh-qd (a)
"Acosh(a)"
@@ -1297,9 +1297,9 @@
a)
(t
(let ((1/a (div-qd (make-qd-d 1d0) a)))
- (+ (log-qd a)
- (log1p-qd (mul-qd (sqrt-qd (sub-d-qd 1d0 1/a))
- (sqrt-qd (add-d-qd 1d0 1/a)))))))))
+ (add-qd (log-qd a)
+ (log1p-qd (mul-qd (sqrt-qd (sub-d-qd 1d0 1/a))
+ (sqrt-qd (add-d-qd 1d0 1/a)))))))))
(defun atanh-qd (a)
"Atanh(a)"
--- /project/oct/cvsroot/oct/qd-rep.lisp 2007/11/23 03:42:24 1.12
+++ /project/oct/cvsroot/oct/qd-rep.lisp 2007/11/28 20:00:28 1.13
@@ -35,11 +35,13 @@
;;; return all four values at once.
;; All of the following functions should be inline to reduce consing.
+#+(and cmu (not oct-array))
(declaim (inline
qd-0 qd-1 qd-2 qd-3
%make-qd-d
qd-parts))
-#+cmu
+
+#+(and cmu (not oct-array))
(progn
;; For CMUCL (at least recent enough versions that support
;; double-double-float), we can use a (complex double-double-float) to
@@ -98,7 +100,7 @@
) ; end progn
-#-cmu
+#+oct-array
(progn
;; For Lisp's without a double-double-float type, I think the best we
;; can do is a simple-array of four double-floats. Even with
@@ -175,6 +177,7 @@
(defmacro %store-qd-d (target q0 q1 q2 q3)
(let ((dest (gensym "TARGET-")))
`(let ((,dest ,target))
+ (declare (type %quad-double ,dest))
(setf (aref ,dest 0) ,q0)
(setf (aref ,dest 1) ,q1)
(setf (aref ,dest 2) ,q2)
@@ -237,12 +240,12 @@
(macrolet
((frob (qd qd-t)
- #+cmu
+ #-oct-array
`(define-compiler-macro ,qd (a b &optional c)
(if c
`(setf ,c (,',qd-t ,a ,b nil))
`(,',qd-t ,a ,b nil)))
- #-cmu
+ #+oct-array
`(define-compiler-macro ,qd (a b &optional c)
(if c
`(,',qd-t ,a ,b ,c)
@@ -253,73 +256,73 @@
(frob add-qd-d add-qd-d-t)
(frob mul-qd-d mul-qd-d-t))
-#+cmu
+#+(and cmu (not oct-array))
(define-compiler-macro sub-qd (a b &optional c)
(if c
`(setf ,c (add-qd-t ,a (neg-qd ,b) nil))
`(add-qd-t ,a (neg-qd ,b) nil)))
-#-cmu
+#-(and cmu (not oct-array))
(define-compiler-macro sub-qd (a b &optional c)
(if c
`(add-qd-t ,a (neg-qd ,b) ,c)
`(add-qd-t ,a (neg-qd ,b) (%make-qd-d 0d0 0d0 0d0 0d0))))
-#+cmu
+#+(and cmu (not oct-array))
(define-compiler-macro sqr-qd (a &optional c)
(if c
`(setf ,c (sqr-qd-t ,a nil))
`(sqr-qd-t ,a nil)))
-#-cmu
+#-(and cmu (not oct-array))
(define-compiler-macro sqr-qd (a &optional c)
(if c
`(sqr-qd-t ,a ,c)
`(sqr-qd-t ,a (%make-qd-d 0d0 0d0 0d0 0d0))))
-#+cmu
+#+(and cmu (not oct-array))
(define-compiler-macro add-d-qd (a b &optional c)
(if c
`(setf ,c (add-qd-d ,b ,a))
`(add-qd-d ,b ,a)))
-#-cmu
+#-(and cmu (not oct-array))
(define-compiler-macro add-d-qd (a b &optional c)
(if c
`(add-qd-d ,b ,a ,c)
`(add-qd-d ,b ,a (%make-qd-d 0d0 0d0 0d0 0d0))))
-#+cmu
+#+(and cmu (not oct-array))
(define-compiler-macro sub-qd-d (a b &optional c)
(if c
`(setf ,c (add-qd-d ,a (cl:- ,b)))
`(add-qd-d ,a (cl:- ,b))))
-#-cmu
+#-(and cmu (not oct-array))
(define-compiler-macro sub-qd-d (a b &optional c)
(if c
`(add-qd-d ,a (cl:- ,b) ,c)
`(add-qd-d ,a (cl:- ,b) (%make-qd-d 0d0 0d0 0d0 0d0))))
-#+cmu
+#+(and cmu (not oct-array))
(define-compiler-macro sub-d-qd (a b &optional c)
(if c
`(setf ,c (add-d-qd ,a (neg-qd ,b)))
`(add-d-qd ,a (neg-qd ,b))))
-#-cmu
+#-(and cmu (not oct-array))
(define-compiler-macro sub-d-qd (a b &optional c)
(if c
`(add-d-qd ,a (neg-qd ,b) ,c)
`(add-d-qd ,a (neg-qd ,b) (%make-qd-d 0d0 0d0 0d0 0d0))))
-#+cmu
+#+(and cmu (not oct-array))
(define-compiler-macro neg-qd (a &optional c)
(if c
`(setf ,c (neg-qd-t ,a nil))
`(neg-qd-t ,a nil)))
-#-cmu
+#-(and cmu (not oct-array))
(define-compiler-macro neg-qd (a &optional c)
(if c
`(neg-qd-t ,a ,c)
--- /project/oct/cvsroot/oct/qd.lisp 2007/11/16 19:44:06 1.63
+++ /project/oct/cvsroot/oct/qd.lisp 2007/11/28 20:00:28 1.64
@@ -306,17 +306,17 @@
;;;; Addition
;; Quad-double + double
-(defun add-qd-d (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
+(defun add-qd-d (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0)))
(add-qd-d-t a b target))
(defun add-qd-d-t (a b target)
"Add a quad-double A and a double-float B"
- (declare (type %quad-double a)
+ (declare (type %quad-double a target)
(double-float b)
(optimize (speed 3)
(space 0))
(inline float-infinity-p)
- #+cmu (ignore target))
+ #+(and cmu (not oct-array)) (ignore target))
(let* ((c0 0d0)
(e c0)
(c1 c0)
@@ -336,12 +336,12 @@
(%store-qd-d target c0 0d0 0d0 0d0)
(%store-qd-d target r0 r1 r2 r3)))))
-(defun add-d-qd (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
+(defun add-d-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0)))
(declare (double-float a)
(type %quad-double b)
(optimize (speed 3))
#+cmu (ignore target))
- (add-qd-d b a #-cmu target))
+ (add-qd-d b a #+oct-array target))
#+cmu
(defun add-qd-dd (a b)
@@ -403,15 +403,15 @@
;; which don't do a very good job with dataflow. CMUCL is one of
;; those compilers.
-(defun add-qd (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
+(defun add-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0)))
(add-qd-t a b target))
(defun add-qd-t (a b target)
- (declare (type %quad-double a b)
+ (declare (type %quad-double a b target)
(optimize (speed 3)
(space 0))
- #+cmu
+ #+(and cmu (not oct-array))
(ignore target))
;; This is the version that is NOT IEEE. Should we use the IEEE
;; version? It's quite a bit more complicated.
@@ -472,18 +472,18 @@
;; directly. For CMU, we always replace the parameter C with NIL
;; because we don't use it. For other Lisps, we create the necessary
;; object and call add-qd-t.
-(defun neg-qd (a &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
+(defun neg-qd (a &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0)))
(neg-qd-t a target))
(defun neg-qd-t (a target)
- (declare (type %quad-double a)
- #+cmu (ignore target))
+ (declare (type %quad-double a target)
+ #+(and cmu (not oct-array)) (ignore target))
(with-qd-parts (a0 a1 a2 a3)
a
(declare (double-float a0 a1 a2 a3))
(%store-qd-d target (cl:- a0) (cl:- a1) (cl:- a2) (cl:- a3))))
-(defun sub-qd (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
+(defun sub-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0)))
(declare (type %quad-double a b))
(add-qd-t a (neg-qd b) target))
@@ -493,18 +493,18 @@
(type double-double-float b))
(add-qd-dd a (cl:- b)))
-(defun sub-qd-d (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
+(defun sub-qd-d (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0)))
(declare (type %quad-double a)
(type double-float b)
#+cmu (ignore target))
- (add-qd-d a (cl:- b) #-cmu target))
+ (add-qd-d a (cl:- b) #+oct-array target))
-(defun sub-d-qd (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
+(defun sub-d-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0)))
(declare (type double-float a)
(type %quad-double b)
- #+cmu (ignore target))
+ #+(and cmu (not oct-array)) (ignore target))
;; a - b = a + (-b)
- (add-d-qd a (neg-qd b) #-cmu target))
+ (add-d-qd a (neg-qd b) #+oct-array target))
;; Works
@@ -514,17 +514,17 @@
;; Clisp says
;; 14.142135623730950488016887242096980785696718753769480731766797379908L0
;;
-(defun mul-qd-d (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
+(defun mul-qd-d (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0)))
(mul-qd-d-t a b target))
(defun mul-qd-d-t (a b target)
"Multiply quad-double A with B"
- (declare (type %quad-double a)
+ (declare (type %quad-double a target)
(double-float b)
(optimize (speed 3)
(space 0))
(inline float-infinity-p)
- #+cmu (ignore target))
+ #+(and cmu (not oct-array)) (ignore target))
(multiple-value-bind (p0 q0)
(two-prod (qd-0 a) b)
@@ -641,15 +641,15 @@
;; Clisp says
;; 14.142135623730950488016887242096980785696718753769480731766797379908L0
-(defun mul-qd (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
+(defun mul-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0)))
(mul-qd-t a b target))
(defun mul-qd-t (a b target)
- (declare (type %quad-double a b)
+ (declare (type %quad-double a b target)
(optimize (speed 3)
(space 0))
(inline float-infinity-p)
- #+cmu
+ #+(and cmu (not oct-array))
(ignore target))
(with-qd-parts (a0 a1 a2 a3)
a
@@ -811,15 +811,15 @@
(multiple-value-call #'%make-qd-d
(renorm-5 p0 p1 s0 t0 t1))))))))))))))))))))
-(defun sqr-qd (a &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
+(defun sqr-qd (a &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0)))
(sqr-qd-t a target))
(defun sqr-qd-t (a target)
"Square A"
- (declare (type %quad-double a)
+ (declare (type %quad-double a target)
(optimize (speed 3)
(space 0))
- #+cmu
+ #+(and cmu (not oct-array))
(ignore target))
(multiple-value-bind (p0 q0)
(two-sqr (qd-0 a))
@@ -863,7 +863,7 @@
(%store-qd-d target a0 a1 a2 a3)))))))))
-(defun div-qd (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
+(defun div-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0)))
(div-qd-t a b target))
#+nil
@@ -891,11 +891,11 @@
(%store-qd-d target q0 q1 q2 q3)))))))
(defun div-qd-t (a b target)
- (declare (type %quad-double a b)
+ (declare (type %quad-double a b target)
(optimize (speed 3)
(space 0))
(inline float-infinity-p)
- #+cmu
+ #+(and cmu (not oct-array))
(ignore target))
(let ((a0 (qd-0 a))
(b0 (qd-0 b)))
More information about the oct-cvs
mailing list