[oct-cvs] Oct commit: oct qd-rep.lisp qd.lisp
rtoy
rtoy at common-lisp.net
Wed Nov 7 03:08:29 UTC 2007
Update of /project/oct/cvsroot/oct
In directory clnet:/tmp/cvs-serv7195
Modified Files:
Tag: THREE-ARG-BRANCH
qd-rep.lisp qd.lisp
Log Message:
o Add 3-arg forms for add-qd-d, mul-qd-d, add-d-qd, sub-qd-d,
sub-d-qd, and neg-qd.
o Correct the compiler macros for CMUCL for sub-qd and sqr-qd.
--- /project/oct/cvsroot/oct/qd-rep.lisp 2007/11/04 03:00:56 1.10.2.4
+++ /project/oct/cvsroot/oct/qd-rep.lisp 2007/11/07 03:08:26 1.10.2.5
@@ -247,7 +247,9 @@
`(,',qd-t ,a ,b ,c))))
(frob add-qd add-qd-t)
(frob mul-qd mul-qd-t)
- (frob div-qd div-qd-t))
+ (frob div-qd div-qd-t)
+ (frob add-qd-d add-qd-d-t)
+ (frob mul-qd-d mul-qd-d-t))
#+cmu
(define-compiler-macro sub-qd (a b &optional c)
@@ -256,7 +258,7 @@
`(add-qd-t ,a (neg-qd ,b) nil)))
#-cmu
-(define-compiler-macro sub-qd (a b &optional c)
+(define-compiler-macro sub-qd (a b &optional (c #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
`(add-qd-t ,a (neg-qd ,b) ,c))
#+cmu
@@ -266,6 +268,46 @@
`(sqr-qd-t ,a nil)))
#-cmu
-(define-compiler-macro sqr-qd (a b &optional c)
+(define-compiler-macro sqr-qd (a &optional (c #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
`(sqr-qd-t ,a ,c))
+#+cmu
+(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
+(define-compiler-macro add-d-qd (a b &optional (c #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
+ `(add-qd-d ,b ,a ,c))
+
+#+cmu
+(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
+(define-compiler-macro sub-qd-d (a b &optional (c #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
+ `(add-qd-d ,a (cl:- ,b) ,c))
+
+#+cmu
+(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
+(define-compiler-macro sub-d-qd (a b &optional (c #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
+ `(add-d-qd a (neg-qd ,b) ,c))
+
+#+cmu
+(define-compiler-macro neg-qd (a &optional c)
+ (if c
+ `(setf ,c (neg-qd-t ,a nil))
+ `(neg-qd-t ,a nil)))
+
+#-cmu
+(define-compiler-macro neg-qd (a &optional (c #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
+ `(neg-qd-t ,a ,c))
+
--- /project/oct/cvsroot/oct/qd.lisp 2007/11/05 16:00:39 1.60.2.5
+++ /project/oct/cvsroot/oct/qd.lisp 2007/11/07 03:08:26 1.60.2.6
@@ -132,6 +132,7 @@
add-d-qd
add-dd-qd
neg-qd
+ neg-qd-t
sub-qd
sub-qd-dd
sub-qd-d
@@ -159,10 +160,12 @@
renorm-4
renorm-5
add-qd-d
+ add-qd-d-t
add-qd-dd
add-qd
add-qd-t
mul-qd-d
+ mul-qd-d-t
mul-qd-dd
mul-qd
mul-qd-t
@@ -300,13 +303,17 @@
;;;; Addition
;; Quad-double + double
-(defun add-qd-d (a b)
+(defun add-qd-d (a b &optional (target #-cmu (%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)
(double-float b)
(optimize (speed 3)
(space 0))
- (inline float-infinity-p))
+ (inline float-infinity-p)
+ #+cmu (ignore target))
(let* ((c0 0d0)
(e c0)
(c1 c0)
@@ -316,21 +323,22 @@
(two-sum c0 e (qd-0 a) b)
(when (float-infinity-p c0)
- (return-from add-qd-d (%make-qd-d c0 0d0 0d0 0d0)))
+ (return-from add-qd-d-t (%store-qd-d target c0 0d0 0d0 0d0)))
(two-sum c1 e (qd-1 a) e)
(two-sum c2 e (qd-2 a) e)
(two-sum c3 e (qd-3 a) e)
(multiple-value-bind (r0 r1 r2 r3)
(renorm-5 c0 c1 c2 c3 e)
(if (and (zerop (qd-0 a)) (zerop b))
- (%make-qd-d c0 0d0 0d0 0d0)
- (%make-qd-d r0 r1 r2 r3)))))
+ (%store-qd-d target c0 0d0 0d0 0d0)
+ (%store-qd-d target r0 r1 r2 r3)))))
-(defun add-d-qd (a b)
+(defun add-d-qd (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
(declare (double-float a)
(type %quad-double b)
- (optimize (speed 3)))
- (add-qd-d b a))
+ (optimize (speed 3))
+ #+cmu (ignore target))
+ (add-qd-d b a #-cmu target))
#+cmu
(defun add-qd-dd (a b)
@@ -461,12 +469,16 @@
;; 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)
- (declare (type %quad-double a))
+(defun neg-qd (a &optional (target #-cmu (%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))
(with-qd-parts (a0 a1 a2 a3)
a
(declare (double-float a0 a1 a2 a3))
- (%make-qd-d (cl:- a0) (cl:- a1) (cl:- a2) (cl:- 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)))
(declare (type %quad-double a b))
@@ -478,16 +490,18 @@
(type double-double-float b))
(add-qd-dd a (cl:- b)))
-(defun sub-qd-d (a b)
+(defun sub-qd-d (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
(declare (type %quad-double a)
- (type double-float b))
- (add-qd-d a (cl:- b)))
+ (type double-float b)
+ #+cmu (ignore target))
+ (add-qd-d a (cl:- b) #-cmu target))
-(defun sub-d-qd (a b)
+(defun sub-d-qd (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
(declare (type double-float a)
- (type %quad-double b))
+ (type %quad-double b)
+ #+cmu (ignore target))
;; a - b = a + (-b)
- (add-d-qd a (neg-qd b)))
+ (add-d-qd a (neg-qd b) #-cmu target))
;; Works
@@ -497,18 +511,22 @@
;; Clisp says
;; 14.142135623730950488016887242096980785696718753769480731766797379908L0
;;
-(defun mul-qd-d (a b)
+(defun mul-qd-d (a b &optional (target #-cmu (%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)
(double-float b)
(optimize (speed 3)
(space 0))
- (inline float-infinity-p))
+ (inline float-infinity-p)
+ #+cmu (ignore target))
(multiple-value-bind (p0 q0)
(two-prod (qd-0 a) b)
(when (float-infinity-p p0)
- (return-from mul-qd-d (%make-qd-d p0 0d0 0d0 0d0)))
+ (return-from mul-qd-d-t (%store-qd-d target p0 0d0 0d0 0d0)))
(multiple-value-bind (p1 q1)
(two-prod (qd-1 a) b)
(declare (double-float p1 q1))
@@ -528,8 +546,8 @@
(multiple-value-bind (s0 s1 s2 s3)
(renorm-5 s0 s1 s2 s3 s4)
(if (zerop s0)
- (%make-qd-d (float-sign p0 0d0) 0d0 0d0 0d0)
- (%make-qd-d s0 s1 s2 s3)))))))))
+ (%store-qd-d target (float-sign p0 0d0) 0d0 0d0 0d0)
+ (%store-qd-d target s0 s1 s2 s3)))))))))
;; a0 * b0 0
;; a0 * b1 1
More information about the oct-cvs
mailing list