[oct-cvs] Oct commit: oct qd-rep.lisp qd.lisp

[rtoy]

Update of /project/oct/cvsroot/oct
In directory clnet:/tmp/cvs-serv10089

Modified Files:
      Tag: THREE-ARG-BRANCH
	qd-rep.lisp qd.lisp 
Log Message:
o Add support for SQR-QD-T
o Add compiler macro for SQR-QD.


--- /project/oct/cvsroot/oct/qd-rep.lisp	2007/11/04 02:45:01	1.10.2.3
+++ /project/oct/cvsroot/oct/qd-rep.lisp	2007/11/04 03:00:56	1.10.2.4
@@ -258,3 +258,14 @@
 #-cmu
 (define-compiler-macro sub-qd (a b &optional c)
   `(add-qd-t ,a (neg-qd ,b) ,c))
+
+#+cmu
+(define-compiler-macro sqr-qd (a &optional c)
+  (if c
+      `(setf ,c (sqr-qd-t ,a nil))
+      `(sqr-qd-t ,a nil)))
+
+#-cmu
+(define-compiler-macro sqr-qd (a b &optional c)
+  `(sqr-qd-t ,a ,c))
+
--- /project/oct/cvsroot/oct/qd.lisp	2007/11/04 02:45:01	1.60.2.2
+++ /project/oct/cvsroot/oct/qd.lisp	2007/11/04 03:00:56	1.60.2.3
@@ -626,7 +626,9 @@
   (declare (type %quad-double a b)
 	   (optimize (speed 3)
 		     (space 0))
-	   (inline float-infinity-p))
+	   (inline float-infinity-p)
+	   #+cmu
+	   (ignore target))
   (with-qd-parts (a0 a1 a2 a3)
       a
     (declare (double-float a0 a1 a2 a3))
@@ -787,11 +789,16 @@
 				    (multiple-value-call #'%make-qd-d
 				      (renorm-5 p0 p1 s0 t0 t1))))))))))))))))))))
 
-(defun sqr-qd (a)
+(defun sqr-qd (a &optional (target #-cmu (%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)
 	   (optimize (speed 3)
-		     (space 0)))
+		     (space 0))
+	   #+cmu
+	   (ignore target))
   (multiple-value-bind (p0 q0)
       (two-sqr (qd-0 a))
     (multiple-value-bind (p1 q1)
@@ -831,7 +838,7 @@
 
 	      (multiple-value-bind (a0 a1 a2 a3)
 		  (renorm-5 p0 p1 p2 p3 p4)
-		(%make-qd-d a0 a1 a2 a3)))))))))
+		(%store-qd-d target a0 a1 a2 a3)))))))))
 	      
 
 (defun div-qd (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))