[oct-cvs] Oct commit: oct qd-class.lisp qd-methods.lisp
rtoy
rtoy at common-lisp.net
Wed Sep 19 17:30:05 UTC 2007
Update of /project/oct/cvsroot/oct
In directory clnet:/tmp/cvs-serv18474
Modified Files:
qd-class.lisp qd-methods.lisp
Log Message:
MAKE-QD should handle rationals better instead of converting them to
doubles and then converting the qd-real. Convert the numerator and
denominator to qd-real, and the divide. (This should be done better.)
qd-class.lisp:
o Change method to work on floats, instead of reals.
qd-methods.lisp:
o Add method to handle rationals.
--- /project/oct/cvsroot/oct/qd-class.lisp 2007/09/06 02:58:38 1.25
+++ /project/oct/cvsroot/oct/qd-class.lisp 2007/09/19 17:30:04 1.26
@@ -60,7 +60,7 @@
(defmethod print-object ((qd qd-real) stream)
(print-qd (qd-value qd) stream))
-(defmethod make-qd ((x real))
+(defmethod make-qd ((x cl:float))
(make-instance 'qd-real :value (make-qd-d (float x 1d0))))
(defmethod make-qd ((x qd-real))
--- /project/oct/cvsroot/oct/qd-methods.lisp 2007/09/18 12:46:36 1.58
+++ /project/oct/cvsroot/oct/qd-methods.lisp 2007/09/19 17:30:04 1.59
@@ -76,6 +76,16 @@
(defconstant +qd-real-one+
(make-instance 'qd-real :value (make-qd-d 1d0)))
+
+(defmethod make-qd ((x cl:rational))
+ ;; We should do something better than this.
+ (let ((top (numerator x))
+ (bot (denominator x)))
+ (make-instance 'qd-real
+ :value (div-qd (qdi::make-float (signum top) (abs top) 0 0 0)
+ (qdi::make-float (signum bot) (abs bot) 0 0 0)))))
+
+
(defmethod add1 ((a number))
(cl::1+ a))
@@ -824,8 +834,10 @@
(cl:rational x1)
(cl:rational x2)
(cl:rational x3))))
+
(define-compiler-macro + (&whole form &rest args)
+ (declare (ignore form))
(if (null args)
0
(do ((args (cdr args) (cdr args))
@@ -834,6 +846,7 @@
((null args) res))))
(define-compiler-macro - (&whole form number &rest more-numbers)
+ (declare (ignore form))
(if more-numbers
(do ((nlist more-numbers (cdr nlist))
(result number))
@@ -843,6 +856,7 @@
`(unary-minus ,number)))
(define-compiler-macro * (&whole form &rest args)
+ (declare (ignore form))
(if (null args)
1
(do ((args (cdr args) (cdr args))
More information about the oct-cvs
mailing list