October 2007 - oct-cvs - mailman3.common-lisp.net

[oct-cvs] Oct commit: oct qd-extra.lisp
by rtoy 26 Oct '07

26 Oct '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv1229 Modified Files: qd-extra.lisp Log Message: Add Pade approximation for exp. From Richard Fateman. Experiments show that it is 25% faster than exp-qd/reduce. However, it loses 3 bits of accuracy compared with exp-qd/reduce. --- /project/oct/cvsroot/oct/qd-extra.lisp 2007/10/15 18:54:02 1.4 +++ /project/oct/cvsroot/oct/qd-extra.lisp 2007/10/26 15:48:15 1.5 @@ -1018,6 +1018,71 @@ (mul-qd +cordic-scale+ y)))) +;; Evaluate the polynomial poly at the point q. The polynomial is +;; a list of the coefficients arranged in descending powers. +(defun poly-eval-qd (q poly) + (let ((sum (%make-qd-d 0d0 0d0 0d0 0d0))) + (dolist (c poly) + (setf sum (add-qd (mul-qd q sum) c))) + sum)) + +;; Like poly-eval-qd, except the polynomial is a list of double-floats +(defun poly-eval-qd-d (q poly) + (let ((sum (%make-qd-d 0d0 0d0 0d0 0d0))) + (dolist (c poly) + (setf sum (add-qd-d (mul-qd q sum) c))) + sum)) + + +;; This idea is from Richard Fateman. I've added a few additional +;; notes, but these are mostly from Richard. +;; +;; We can evaluate exp(x) for |x|< 0.01, say, by a pade approximation, +;; computed using Maxima: +;; +;; taylor(exp(x), x, 0, 20)$ +;; +;; pade(%, 10, 10) -> +;; +;; [(x^10+110*x^9+5940*x^8+205920*x^7+5045040*x^6+90810720*x^5+1210809600*x^4 +;; +11762150400*x^3+79394515200*x^2+335221286400*x^+670442572800) +;; /(x^10-110*x^9+ +;; 5940*x^8-205920*x^7+5045040*x^6-90810720*x^5+1210809600*x^4-11762150400*x^3+ +;; 79394515200*x^2-335221286400*x^+670442572800)] +;; +;; The numerator and denominator have the same coefficients with +;; different signs on odd terms. so we note that num and den here can +;; be evaluated as f(x^2)+x*g(x^2) and f(x^2)-x*g(x^2) respectively using +;; half the number of multiplies. + +(defconstant f-exp-pade + '(1.0d0 5940.0d0 5045040.0d0 1.2108096d+9 + 7.93945152d+10 6.704425728d+11)) + +(defconstant g-exp-pade + '(110.0d0 205920.0d0 9.081072d+7 + 1.17621504d+10 3.352212864d+11 )) + +(defun exp-qd/pade-small (x) + ;; exp(x) = (f(x^2) + x*g(x^2))/(f(x^2) - x*g(x^2)) + (let* ((x^2 (sqr-qd x)) + (fx (poly-eval-qd-d x^2 f-exp-pade)) + (x*gx (mul-qd x (poly-eval-qd-d x^2 g-exp-pade)))) + (div-qd (add-qd fx x*gx) + (sub-qd fx x*gx)))) + +(defun exp-qd/pade (a) + ;; Same idea as in exp-qd/reduce, except we use our Pade + ;; approximation instead of a Taylor series. + (let* ((k 256) + (z (truncate (qd-0 (nint-qd (div-qd a +qd-log2+))))) + (r (div-qd-d (sub-qd a (mul-qd-d +qd-log2+ (float z 1d0))) + (float k 1d0))) + + (e (exp-qd/pade-small r))) + (scale-float-qd (npow e k) z))) + + ;; Some timing and consing tests. ;; ;; The tests are run using the following: @@ -1035,11 +1100,13 @@ ;; exp-qd/reduce 2.06 3.18 10.46 2.76 6.12 ;; expm1-qd/series 8.81 12.24 18.87 3.26 29.0 ;; expm1-qd/dup 5.68 4.34 18.47 3.64 18.78 +;; exp-qd/pade 1.53 ;; ;; Consing (MB) Sparc ;; exp-qd/reduce 45 45 638 44.4 45 ;; expm1-qd/series 519 519 1201 14.8 519 ;; expm1-qd/dup 32 32 1224 32.0 32 +;; exp-qd/pade 44 ;; ;; Speeds seem to vary quite a bit between architectures. ;; @@ -1066,17 +1133,22 @@ (fixnum n)) (let ((y +qd-zero+)) (declare (type %quad-double y)) - #+cmu (gc :full t) + #+cmu (ext:gc :full t) (format t "exp-qd/reduce~%") (time (dotimes (k n) (declare (fixnum k)) (setf y (exp-qd/reduce x)))) - #+cmu (gc :full t) + #+cmu (ext:gc :full t) + (format t "exp-qd/pade~%") + (time (dotimes (k n) + (declare (fixnum k)) + (setf y (exp-qd/pade x)))) + #+cmu (ext:gc :full t) (format t "expm1-qd/series~%") (time (dotimes (k n) (declare (fixnum k)) (setf y (expm1-qd/series x)))) - #+cmu (gc :full t) + #+cmu (ext:gc :full t) (format t "expm1-qd/duplication~%") (time (dotimes (k n) (declare (fixnum k)) @@ -1084,6 +1156,87 @@ )) +#|| + +;; This bit of code is meant to be run with Clisp, which has arbitrary +;; precision long floats. +;; +;; We use this to compare the accuracy of exp-qd/reduce and +;; exp-qd/pade against Clisp's exp implementation. +;; +;; Some results: +;; +;; k = 159000 +;; pade min = 4.733L-68 +;; pade max = 5.153L-61 +;; pade sumsq = 7.899L-119 +;; red min = 3.838L-69 +;; red max = 4.318L-62 +;; red sumsq = 6.076L-120 +;; +;; So, worst case error is: +;; +;; exp-qd/reduce: 4.318L-62 (203.8 bits) +;; exp-qd/pade: 5.153L-61 (200.3 bits) +;; +;; We lose 3 bits for Pade. exp-qd/reduce is "missing" 8 bits of +;; accuracy. Bummer. + +(in-package #:oct) + +;; 240 bit fractions for long-floats. I hope this is accurate enough +;; compared against our 212 bit fractions for quad-doubles. +(setf (ext:long-float-digits) 240) +(defun compare-exp (n &optional verbose) + (let ((pade-max -1L0) + (pade-min 1L100) + (pade-sum 0L0) + (red-max -1L0) + (red-min 1L100) + (red-sum 0L0)) + (dotimes (k n) + (let* ((f (random (make-qd 1/256))) + (pade-exp (octi::exp-qd/pade (qd-value f))) + (red-exp (octi::exp-qd/reduce (qd-value f)))) + (flet ((qd-to-lf (qd) + (octi:with-qd-parts (q0 q1 q2 q3) + qd + (+ (float q0 1L0) + (float q1 1L0) + (float q2 1L0) + (float q3 1L0))))) + (let* ((lf (qd-to-lf (qd-value f))) + (l-exp (exp lf)) + (pade-exp-lf (qd-to-lf pade-exp)) + (red-exp-lf (qd-to-lf red-exp)) + (pade-diff (abs (- l-exp pade-exp-lf))) + (red-diff (abs (- l-exp red-exp-lf)))) + (when verbose + (format t "f = ~S~%" f) + (format t "pade-exp = ~A~%" (make-instance 'qd-real :value pade-exp)) + (format t "l-exp = ~A~%" l-exp) + (format t "diff = ~A~%" pade-diff)) + (when (and (plusp k) (zerop (mod k 1000))) + (format t "k = ~A~%" k) + (format t "pade min = ~15,3g~%" pade-min) + (format t "pade max = ~15,3g~%" pade-max) + (format t "pade sumsq = ~15,3g~%" pade-sum) + (format t "red min = ~15,3g~%" red-min) + (format t "red max = ~15,3g~%" red-max) + (format t "red sumsq = ~15,3g~%" red-sum)) + (setf pade-max (max pade-max pade-diff)) + (setf pade-min (min pade-min pade-diff)) + (incf pade-sum (* pade-diff pade-diff)) + (setf red-max (max red-max red-diff)) + (setf red-min (min red-min red-diff)) + (incf red-sum (* red-diff red-diff))) + ))) + (values pade-max pade-min pade-sum + red-max red-min red-sum + ))) + +||# + ;; (time-log #c(3w0 0) 50000) ;; ;; Time (s) Sparc PPC x86 PPC (fma) Sparc2 @@ -1147,33 +1300,33 @@ (fixnum n)) (let ((y +qd-zero+)) (declare (type %quad-double y)) - #+cmu (gc :full t) + #+cmu (ext:gc :full t) (format t "log-qd/newton~%") (time (dotimes (k n) (declare (fixnum k)) (setf y (log-qd/newton x)))) - #+cmu (gc :full t) + #+cmu (ext:gc :full t) (format t "log1p-qd/duplication~%") (time (dotimes (k n) (declare (fixnum k)) (setf y (log1p-qd/duplication x)))) - #+cmu (gc :full t) + #+cmu (ext:gc :full t) (format t "log-qd/agm~%") (time (dotimes (k n) (declare (fixnum k)) (setf y (log-qd/agm x)))) - #+cmu (gc :full t) + #+cmu (ext:gc :full t) (format t "log-qd/agm2~%") (time (dotimes (k n) (declare (fixnum k)) (setf y (log-qd/agm2 x)))) - #+cmu (gc :full t) + #+cmu (ext:gc :full t) (format t "log-qd/agm3~%") (time (dotimes (k n) (declare (fixnum k)) (setf y (log-qd/agm3 x)))) - #+cmu (gc :full t) + #+cmu (ext:gc :full t) (format t "log-qd/halley~%") (time (dotimes (k n) (declare (fixnum k)) @@ -1217,17 +1370,17 @@ (fixnum n)) (let ((y +qd-zero+) (one +qd-one+)) - #+cmu (gc :full t) + #+cmu (ext:gc :full t) (format t "atan2-qd/newton~%") (time (dotimes (k n) (declare (fixnum k)) (setf y (atan2-qd/newton x one)))) - #+cmu (gc :full t) + #+cmu (ext:gc :full t) (format t "atan2-qd/cordic~%") (time (dotimes (k n) (declare (fixnum k)) (setf y (atan2-qd/cordic x one)))) - #+cmu (gc :full t) + #+cmu (ext:gc :full t) (format t "atan-qd/duplication~%") (time (dotimes (k n) (declare (fixnum k)) @@ -1260,12 +1413,12 @@ (declare (type %quad-double x) (fixnum n)) (let ((y +qd-zero+)) - #+cmu (gc :full t) + #+cmu (ext:gc :full t) (format t "tan-qd/cordic~%") (time (dotimes (k n) (declare (fixnum k)) (setf y (tan-qd/cordic x)))) - #+cmu (gc :full t) + #+cmu (ext:gc :full t) (format t "tan-qd/sincos~%") (time (dotimes (k n) (declare (fixnum k))

1 0

[oct-cvs] Oct commit: oct qd-fun.lisp
by rtoy 18 Oct '07

18 Oct '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv27836 Modified Files: qd-fun.lisp Log Message: Compare against pi/4 quad-double, not double-float. --- /project/oct/cvsroot/oct/qd-fun.lisp 2007/10/17 03:44:12 1.89 +++ /project/oct/cvsroot/oct/qd-fun.lisp 2007/10/18 14:38:56 1.90 @@ -678,7 +678,7 @@ ;; We want the remainder part to be <= pi/4 because the trig ;; functions want that. So if the fraction is too big, adjust ;; it, and mod value. - (if (<= (abs (qd-0 f)) (/ pi 4)) + (if (qd-<= (abs-qd f) +qd-pi/4+) (values mod f) (values (mod (1+ mod) 4) (sub-qd f +qd-pi/2+)))))) @@ -723,7 +723,7 @@ +qd-pi/2+))) ;; If we did this right, (ash prod (- frac-bits)) should be 2 ;; bits long at most. - (if (<= (abs (qd-0 f)) (/ pi 4)) + (if (qd-<= (abs-qd f) +qd-pi/4+) (values mod f) (values (mod (1+ mod) 4) (sub-qd f +qd-pi/2+))))))

1 0

[oct-cvs] Oct commit: oct qd.lisp
by rtoy 18 Oct '07

18 Oct '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv27776 Modified Files: qd.lisp Log Message: MAKE-QD-DD is only defined for CMUCL, so don't unconditionally inline it. --- /project/oct/cvsroot/oct/qd.lisp 2007/10/16 17:05:13 1.59 +++ /project/oct/cvsroot/oct/qd.lisp 2007/10/18 14:38:11 1.60 @@ -136,6 +136,7 @@ sub-qd-dd sub-qd-d sub-d-qd + #+cmu make-qd-dd abs-qd qd-> @@ -833,6 +834,32 @@ (renorm-4 q0 q1 q2 q3) (%make-qd-d q0 q1 q2 q3))))))) +(declaim (inline invert-qd)) + +(defun invert-qd(v) ;; a quartic newton iteration for 1/v + ;; to invert v, start with a good guess, x. + ;; let h= 1-v*x ;; h is small + ;; return x+ x*(h+h^2+h^3) . compute h3 in double-float + ;; enough accuracy. + + (let* + ((x (%make-qd-d (cl:/ (qd-0 v)) 0d0 0d0 0d0)) + (h (add-qd-d (neg-qd (mul-qd v x)) + 1.0d0)) + (h2 (mul-qd h h)) ;also use h2 for target + (h3 (* (qd-0 h) (qd-0 h2)))) + (declare (type %quad-double v h h2) + (double-float h3)) + (add-qd x + (mul-qd x + (add-qd h (add-qd-d h2 h3)))))) + +(defun div-qd-i (a b) + (declare (type %quad-double a b) + (optimize (speed 3) + (space 0))) + (mul-qd a (invert-qd b))) + ;; Non-sloppy divide #+(or) (defun div-qd (a b)

1 0

[oct-cvs] Oct commit: oct qd-fun.lisp
by rtoy 17 Oct '07

17 Oct '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv23871 Modified Files: qd-fun.lisp Log Message: Add another implementation of REM-PI/2-INT. This extracts just the part of 2/pi that is needed to compute the desired result instead of multiplying by all l584 bits of 2/pi. Not yet used. --- /project/oct/cvsroot/oct/qd-fun.lisp 2007/10/16 17:09:46 1.88 +++ /project/oct/cvsroot/oct/qd-fun.lisp 2007/10/17 03:44:12 1.89 @@ -682,6 +682,52 @@ (values mod f) (values (mod (1+ mod) 4) (sub-qd f +qd-pi/2+)))))) +(defun rem-pi/2-int-b (qd) + (declare (type %quad-double qd)) + (multiple-value-bind (i e s) + (integer-decode-qd qd) + ;; This computes qd = k*pi/2+s. And because of the 2*pi + ;; periodicity of trig functions, we really only need mod(k, 4), + ;; the least 2 bits of k. + ;; + ;; Write qd = 2^e*i. Write the value 2/pi as sum f[k]*2^(-k), k = + ;; 0, 1, 2,... and f[k] is 0 or 1. Then the product, p, is + ;; + ;; p = sum i*f[k]*2^(e-k). + ;; + ;; Assume 2^m <= i < 2^(m+1). Then it's obvious that + ;; i*f[k]*2^(e-k) is greater than 2 if e-k+m > 1, or k < e+m-1. + ;; Thus we can ignore the bits of 2/pi for k < e+m-1, because the + ;; contribution is greater than 2. For k >= e+m-1, we will have + ;; the product that is between 0 and 4, which is the part we want. + ;; We just need to select how many fraction bits we want. + ;; 4*53=212 seems a little low, and 5*53=265 should be more than + ;; enough. Let's choose 220. + ;; + ;; This code would be faster if we knew how many bits are in i. + ;; You might think it should be 212 (4*53), but no. Consider #q1 + ;; + #q1q-100. This has way more than 212 bits. + (let* ((qd-bits 220) + (m (integer-length i)) + (frac-bits (+ qd-bits (- m 2))) + (bits (ldb (byte qd-bits + (- (integer-length +2/pi-bits+) e frac-bits)) + +2/pi-bits+)) + ;; Multiply these together. + (prod (* s i bits)) + ;; Extract out the integer and fractional parts + (frac (ldb (byte frac-bits 0) prod)) + (mod (ldb (byte 2 frac-bits) prod)) + ;;(mod (ash prod (- frac-bits))) + (f (mul-qd (scale-float-qd (rational-to-qd frac) (- frac-bits)) + +qd-pi/2+))) + ;; If we did this right, (ash prod (- frac-bits)) should be 2 + ;; bits long at most. + (if (<= (abs (qd-0 f)) (/ pi 4)) + (values mod f) + (values (mod (1+ mod) 4) + (sub-qd f +qd-pi/2+)))))) + (defun rem-pi/2 (a) ;; If the number is small enough, we don't need to use the full ;; precision algorithm to compute the remainder. The value of 1024

1 0

[oct-cvs] Oct commit: oct qd-fun.lisp qd-rep.lisp
by rtoy 16 Oct '07

16 Oct '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv31292 Modified Files: qd-fun.lisp qd-rep.lisp Log Message: qd-fun.lisp: o Remove extra rem-pi/2-int. qd-rep.lisp: o Fix typo in float-infinity-p for Allegro. o Ignore var in float-infinity-p and friends. --- /project/oct/cvsroot/oct/qd-fun.lisp 2007/10/16 17:05:13 1.87 +++ /project/oct/cvsroot/oct/qd-fun.lisp 2007/10/16 17:09:46 1.88 @@ -619,6 +619,7 @@ ;; accurate argument reduction using 1584 bits of 2/pi. This makes ;; sin and cos more expensive, of course. +#+(or) (defun rem-pi/2-int (qd) ;; Compute qd rem pi/2 = k*pi/2+y. So we compute k + y*2/pi = ;; qd*2/pi. --- /project/oct/cvsroot/oct/qd-rep.lisp 2007/10/16 17:05:13 1.9 +++ /project/oct/cvsroot/oct/qd-rep.lisp 2007/10/16 17:09:46 1.10 @@ -197,7 +197,7 @@ #+allegro (progn (defmacro float-infinity-p (x) - (= (abs ,x) #.excl::*infinity-double*)) + `(= (abs ,x) #.excl::*infinity-double*)) (defun float-nan-p (x) (excl::nan-p x)) @@ -212,9 +212,12 @@ #-(or cmu allegro) (progn (defun float-infinity-p (x) + (declare (ignore x)) nil) (defun float-nan-p (x) + (declare (ignore x)) nil) (defun float-trapping-nan-p (x) + (declare (ignore x)) nil) ) ; end progn

1 0

[oct-cvs] Oct commit: oct qd-fun.lisp qd-io.lisp qd-rep.lisp qd.lisp
by rtoy 16 Oct '07

16 Oct '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv31151 Modified Files: qd-fun.lisp qd-io.lisp qd-rep.lisp qd.lisp Log Message: o Add default implementation of float-infinity-p, float-nan-p, float-trapping-nan-p. These return NIL by default, unless the Lisp implementation has a suitable version. o Remove CMU conditionalization for float-infinity-p, float-nan-p, float-trapping-nan-p. --- /project/oct/cvsroot/oct/qd-fun.lisp 2007/10/16 02:39:22 1.86 +++ /project/oct/cvsroot/oct/qd-fun.lisp 2007/10/16 17:05:13 1.87 @@ -62,7 +62,6 @@ ;; 2^k*sqrt(f), and sqrt(f) doesn't have round-off problems. (when (zerop-qd a) (return-from sqrt-qd a)) - #+cmu (when (float-infinity-p (qd-0 a)) (return-from sqrt-qd a)) @@ -215,7 +214,7 @@ (defun expm1-qd (a) "exp(a) - 1, done accurately" (declare (type %quad-double a)) - #+cmu + (when (float-infinity-p (qd-0 a)) (return-from expm1-qd (if (minusp (float-sign (qd-0 a))) @@ -310,7 +309,7 @@ "log1p(x) = log(1+x), done more accurately than just evaluating log(1+x)" (declare (type %quad-double x)) - #+cmu + (when (float-infinity-p (qd-0 x)) x) (log1p-qd/duplication x)) @@ -323,7 +322,6 @@ ((and (zerop-qd a) (plusp (float-sign (qd-0 a)))) (%make-qd-d (/ -1d0 (qd-0 a)) 0d0 0d0 0d0)) - #+cmu ((float-infinity-p (qd-0 a)) a) ((minusp (float-sign (qd-0 a))) @@ -1055,12 +1053,10 @@ ;; where D(x) = exp(x) - 1. This helps for x near 0. (cond ((zerop a) a) - #+cmu ((float-infinity-p (qd-0 a)) a) (t (let ((d (expm1-qd a))) - #+cmu (when (float-infinity-p (qd-0 d)) (return-from sinh-qd d)) (scale-float-qd (add-qd d @@ -1072,7 +1068,6 @@ (declare (type %quad-double a)) ;; cosh(x) = 1/2*(exp(x)+exp(-x)) (let ((e (exp-qd a))) - #+cmu (when (float-infinity-p (qd-0 e)) (return-from cosh-qd e)) (scale-float-qd (add-qd e (div-qd +qd-one+ e)) @@ -1172,7 +1167,6 @@ (add-qd (scale-float-qd (log1p-qd a^2) -1) (log1p-qd (div-qd a (sqrt-qd (add-qd-d a^2 1d0))))))) - #+cmu ((float-infinity-p (qd-0 a)) a) (t @@ -1210,7 +1204,6 @@ (cond ((< (abs (qd-0 a)) (sqrt most-positive-double-float)) (let ((y (sub-qd-d a 1d0))) (log1p-qd (add-qd y (sqrt-qd (mul-qd y (add-qd-d y 2d0))))))) - #+cmu ((float-infinity-p (qd-0 a)) a) (t --- /project/oct/cvsroot/oct/qd-io.lisp 2007/10/15 18:53:44 1.20 +++ /project/oct/cvsroot/oct/qd-io.lisp 2007/10/16 17:05:13 1.21 @@ -298,7 +298,7 @@ (stream stream)) ;; We should do something with colon-p and at-sign-p (declare (ignore colon-p at-sign-p par)) - (cond ((ext:float-infinity-p (qd-0 arg)) + (cond ((float-infinity-p (qd-0 arg)) (qd-output-infinity arg stream)) ((ext:float-nan-p (qd-0 arg)) (qd-output-nan arg stream)) --- /project/oct/cvsroot/oct/qd-rep.lisp 2007/10/15 18:53:44 1.8 +++ /project/oct/cvsroot/oct/qd-rep.lisp 2007/10/16 17:05:13 1.9 @@ -189,3 +189,32 @@ (,a3 (qd-3 ,q))) ,@body))) + +;; Some simple support for infinity and NaN. For CMUCL, we can import +;; the desired functions from the EXTENSIONS package. + +;; Implementation for Allegro +#+allegro +(progn +(defmacro float-infinity-p (x) + (= (abs ,x) #.excl::*infinity-double*)) + +(defun float-nan-p (x) + (excl::nan-p x)) + +(defun float-trapping-nan-p (x) + nil) +) ; end progn + + +;; Default implementation. Assume we can't recognize any of these. + +#-(or cmu allegro) +(progn +(defun float-infinity-p (x) + nil) +(defun float-nan-p (x) + nil) +(defun float-trapping-nan-p (x) + nil) +) ; end progn --- /project/oct/cvsroot/oct/qd.lisp 2007/10/16 02:39:22 1.58 +++ /project/oct/cvsroot/oct/qd.lisp 2007/10/16 17:05:13 1.59 @@ -298,8 +298,7 @@ (double-float b) (optimize (speed 3) (space 0)) - #+cmu - (inline ext:float-infinity-p)) + (inline float-infinity-p)) (let* ((c0 0d0) (e c0) (c1 c0) @@ -307,7 +306,7 @@ (c3 c0)) (declare (double-float e c0 c1 c2 c3)) (two-sum c0 e (qd-0 a) b) - #+cmu + (when (float-infinity-p c0) (return-from add-qd-d (%make-qd-d c0 0d0 0d0 0d0))) (two-sum c1 e (qd-1 a) e) @@ -404,9 +403,8 @@ (s2 (cl:+ a2 b2)) (s3 (cl:+ a3 b3))) (declare (double-float s0 s1 s2 s3) - #+cmu - (inline ext:float-infinity-p)) - #+cmu + (inline float-infinity-p)) + (when (float-infinity-p s0) (return-from add-qd (%make-qd-d s0 0d0 0d0 0d0))) (let ((v0 (cl:- s0 a0)) @@ -487,11 +485,10 @@ (double-float b) (optimize (speed 3) (space 0)) - #+cmu - (inline ext:float-infinity-p)) + (inline float-infinity-p)) (multiple-value-bind (p0 q0) (two-prod (qd-0 a) b) - #+cmu + (when (float-infinity-p p0) (return-from mul-qd-d (%make-qd-d p0 0d0 0d0 0d0))) (multiple-value-bind (p1 q1) @@ -608,8 +605,7 @@ (declare (type %quad-double a b) (optimize (speed 3) (space 0)) - #+cmu - (inline ext:float-infinity-p)) + (inline float-infinity-p)) (with-qd-parts (a0 a1 a2 a3) a (declare (double-float a0 a1 a2 a3)) @@ -820,14 +816,13 @@ (declare (type %quad-double a b) (optimize (speed 3) (space 0)) - #+cmu - (inline ext:float-infinity-p)) + (inline float-infinity-p)) (let ((a0 (qd-0 a)) (b0 (qd-0 b))) (let* ((q0 (cl:/ a0 b0)) (r (sub-qd a (mul-qd-d b q0))) (q1 (cl:/ (qd-0 r) b0))) - #+cmu + (when (float-infinity-p q0) (return-from div-qd (%make-qd-d q0 0d0 0d0 0d0))) (setf r (sub-qd r (mul-qd-d b q1))) @@ -863,13 +858,12 @@ (double-float b) (optimize (speed 3) (space 0)) - #+cmu - (inline ext:float-infinity-p)) + (inline float-infinity-p)) ;; Compute approximate quotient using high order doubles, then ;; correct it 3 times using the remainder. Analogous to long ;; division. (let ((q0 (cl:/ (qd-0 a) b))) - #+cmu + (when (float-infinity-p q0) (return-from div-qd-d (%make-qd-d q0 0d0 0d0 0d0))) @@ -901,8 +895,7 @@ (double-double-float b) (optimize (speed 3) (space 0)) - #+cmu - (inline ext:float-infinity-p)) + (inline float-infinity-p)) (let* ((q0 (cl:/ (qd-0 a) (kernel:double-double-hi b))) (r (sub-qd-dd a (cl:* b q0)))) (when (float-infinity-p q0)

1 0

[oct-cvs] Oct commit: oct timing2.lisp
by rtoy 16 Oct '07

16 Oct '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv7497 Modified Files: timing2.lisp Log Message: Remove duplicate TIME-MUL. --- /project/oct/cvsroot/oct/timing2.lisp 2007/10/13 02:14:43 1.3 +++ /project/oct/cvsroot/oct/timing2.lisp 2007/10/16 14:21:13 1.4 @@ -53,18 +53,6 @@ (format t "n = ~D~%" n) (format t "b = ~W~%" b))) -(defun time-mul (&optional (n 100000)) - (declare (fixnum n) - (optimize (speed 3))) - (let ((a (+ 1 (/ (float n #q1)))) - (b #q1)) - (declare (type qd-real a b)) - (time (dotimes (k n) - (declare (fixnum k)) - (setf b (* a b)))) - (format t "n = ~D~%" n) - (format t "b = ~W~%" b))) - (defun time-div (&optional (n 100000)) (declare (fixnum n) (optimize (speed 3)))

1 0

[oct-cvs] Oct commit: oct qd-methods.lisp
by rtoy 16 Oct '07

16 Oct '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv2327 Modified Files: qd-methods.lisp Log Message: Oops. QDI package no longer exists. Use OCTI. --- /project/oct/cvsroot/oct/qd-methods.lisp 2007/10/15 18:21:47 1.64 +++ /project/oct/cvsroot/oct/qd-methods.lisp 2007/10/16 13:46:01 1.65 @@ -343,7 +343,7 @@ (symbol-name op)))) (cl-fun (find-symbol (symbol-name op) :cl)) (qd-fun (intern (concatenate 'string (string '#:qd-) (symbol-name op)) - (find-package :qdi)))) + '#:octi))) `(progn (defmethod ,method ((a real) (b real)) (,cl-fun a b))

1 0

[oct-cvs] Oct commit: oct qd-const.lisp
by rtoy 16 Oct '07

16 Oct '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv2164 Modified Files: qd-const.lisp Log Message: Oops. %MAKE-QD-D is a macro and not a function for some Lisps, so we can't multiple-value-call it. Rearrange code accordingly. --- /project/oct/cvsroot/oct/qd-const.lisp 2007/10/15 18:53:43 1.19 +++ /project/oct/cvsroot/oct/qd-const.lisp 2007/10/16 13:44:00 1.20 @@ -40,72 +40,79 @@ ;; 3.1415926535897932384626433832795028841971693993751058209749445923078L0 ;; #q3.1415926535897932384626433832795028841971693993751058209749445923q0 (defconstant +qd-pi+ - (multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 7074237752028440 1.0d0) -51) - (scale-float (float 4967757600021511 1.0d0) -105) - (scale-float (float -8753721960665020 1.0d0) -161) - (scale-float (float 5857755168774013 1.0d0) -215) - (scale-float (float 5380502254059520 1.0d0) -269)))) + (multiple-value-bind (q0 q1 q2 q3) + (renorm-5 (scale-float (float 7074237752028440 1.0d0) -51) + (scale-float (float 4967757600021511 1.0d0) -105) + (scale-float (float -8753721960665020 1.0d0) -161) + (scale-float (float 5857755168774013 1.0d0) -215) + (scale-float (float 5380502254059520 1.0d0) -269)) + (%make-qd-d q0 q1 q2 q3))) ;; 6.2831853071795864769252867665590057683943387987502116419498891846156328125724L0 ;; #q6.2831853071795864769252867665590057683943387987502116419498891846q0 (defconstant +qd-2pi+ - (multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 7074237752028440 1.0d0) -50) - (scale-float (float 4967757600021511 1.0d0) -104) - (scale-float (float -8753721960665020 1.0d0) -160) - (scale-float (float 5857755168774013 1.0d0) -214) - (scale-float (float 5380502254059520 1.0d0) -268)))) + (multiple-value-bind (q0 q1 q2 q3) + (renorm-5 (scale-float (float 7074237752028440 1.0d0) -50) + (scale-float (float 4967757600021511 1.0d0) -104) + (scale-float (float -8753721960665020 1.0d0) -160) + (scale-float (float 5857755168774013 1.0d0) -214) + (scale-float (float 5380502254059520 1.0d0) -268)) + (%make-qd-d q0 q1 q2 q3))) ;; 1.5707963267948966192313216916397514420985846996875529104874722961539082031431L0 ;; #q1.57079632679489661923132169163975144209858469968755291048747229615q0 (defconstant +qd-pi/2+ - (multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 7074237752028440 1.0d0) -52) - (scale-float (float 4967757600021511 1.0d0) -106) - (scale-float (float -8753721960665020 1.0d0) -162) - (scale-float (float 5857755168774013 1.0d0) -216) - (scale-float (float 5380502254059520 1.0d0) -270)))) + (multiple-value-bind (q0 q1 q2 q3) + (renorm-5 (scale-float (float 7074237752028440 1.0d0) -52) + (scale-float (float 4967757600021511 1.0d0) -106) + (scale-float (float -8753721960665020 1.0d0) -162) + (scale-float (float 5857755168774013 1.0d0) -216) + (scale-float (float 5380502254059520 1.0d0) -270)) + (%make-qd-d q0 q1 q2 q3))) ;; 0.78539816339744830961566084581987572104929234984377645524373614807695410157155L0 ;; #q0.785398163397448309615660845819875721049292349843776455243736148076q0 (defconstant +qd-pi/4+ - (multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 7074237752028440 1.0d0) -53) - (scale-float (float 4967757600021511 1.0d0) -107) - (scale-float (float -8753721960665020 1.0d0) -163) - (scale-float (float 5857755168774013 1.0d0) -217) - (scale-float (float 5380502254059520 1.0d0) -271)))) + (multiple-value-bind (q0 q1 q2 q3) + (renorm-5 (scale-float (float 7074237752028440 1.0d0) -53) + (scale-float (float 4967757600021511 1.0d0) -107) + (scale-float (float -8753721960665020 1.0d0) -163) + (scale-float (float 5857755168774013 1.0d0) -217) + (scale-float (float 5380502254059520 1.0d0) -271)) + (%make-qd-d q0 q1 q2 q3))) ;; 2.35619449019234492884698253745962716314787704953132936573120844423086230471467L0 ;; #q2.35619449019234492884698253745962716314787704953132936573120844423q0 (defconstant +qd-3pi/4+ - (multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 5305678314021330 1.0d0) -51) - (scale-float (float 7451636400032266 1.0d0) -106) - (scale-float (float 5724553519491610 1.0d0) -160) - (scale-float (float -6810541066450737 1.0d0) -214) - (scale-float (float -7491566988951552 1.0d0) -273)))) + (multiple-value-bind (q0 q1 q2 q3) + (renorm-5 (scale-float (float 5305678314021330 1.0d0) -51) + (scale-float (float 7451636400032266 1.0d0) -106) + (scale-float (float 5724553519491610 1.0d0) -160) + (scale-float (float -6810541066450737 1.0d0) -214) + (scale-float (float -7491566988951552 1.0d0) -273)) + (%make-qd-d q0 q1 q2 q3))) ;; 0.00306796157577128245943617517898388953534879824157725177829584432842560195926387L0 ;; #q0.00306796157577128245943617517898388953534879824157725177829584432842q0 (defconstant +qd-pi/1024+ - (multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 7074237752028440 1.0d0) -61) - (scale-float (float 4967757600021511 1.0d0) -115) - (scale-float (float -8753721960665020 1.0d0) -171) - (scale-float (float 5857755168774013 1.0d0) -225) - (scale-float (float 5380502254059520 1.0d0) -279)))) + (multiple-value-bind (q0 q1 q2 q3) + (renorm-5 (scale-float (float 7074237752028440 1.0d0) -61) + (scale-float (float 4967757600021511 1.0d0) -115) + (scale-float (float -8753721960665020 1.0d0) -171) + (scale-float (float 5857755168774013 1.0d0) -225) + (scale-float (float 5380502254059520 1.0d0) -279)) + (%make-qd-d q0 q1 q2 q3))) ;; 2.71828182845904523536028747135266249775724709369995957496696762772407663035355L0 ;; #q2.71828182845904523536028747135266249775724709369995957496696762773q0 (defconstant +qd-e+ - (multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 6121026514868073 1.0d0) -51) - (scale-float (float 5864240480059706 1.0d0) -105) - (scale-float (float -6219324074349538 1.0d0) -161) - (scale-float (float 7980724272743021 1.0d0) -215) - (scale-float (float -8855251465666560 1.0d0) -269)))) + (multiple-value-bind (q0 q1 q2 q3) + (renorm-5 (scale-float (float 6121026514868073 1.0d0) -51) + (scale-float (float 5864240480059706 1.0d0) -105) + (scale-float (float -6219324074349538 1.0d0) -161) + (scale-float (float 7980724272743021 1.0d0) -215) + (scale-float (float -8855251465666560 1.0d0) -269)) + (%make-qd-d q0 q1 q2 q3))) ;; 0.693147180559945309417232121458176568075500134360255254120680009493393621969696L0 ;; #q0.693147180559945309417232121458176568075500134360255254120680009495q0 @@ -132,12 +139,13 @@ ;; 2.30258509299404568401799145468436420760110148862877297603332790096757260967737L0 ;; #q2.30258509299404568401799145468436420760110148862877297603332790095q0 (defconstant +qd-log10+ - (multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 5184960683398422 1.0d0) -51) - (scale-float (float -8805633374462953 1.0d0) -105) - (scale-float (float -7296007962371596 1.0d0) -159) - (scale-float (float -5296362421624049 1.0d0) -213) - (scale-float (float 4574234754834432 1.0d0) -267)))) + (multiple-value-bind (q0 q1 q2 q3) + (renorm-5 (scale-float (float 5184960683398422 1.0d0) -51) + (scale-float (float -8805633374462953 1.0d0) -105) + (scale-float (float -7296007962371596 1.0d0) -159) + (scale-float (float -5296362421624049 1.0d0) -213) + (scale-float (float 4574234754834432 1.0d0) -267)) + (%make-qd-d q0 q1 q2 q3))) (defconstant +qd-eps+ (scale-float 1d0 -209)) @@ -145,3083 +153,3595 @@ (defconstant +qd-sin-table+ (make-array 256 :initial-contents (list - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 7074226654454970 1.0d0) -61) - (scale-float (float 5271335698347442 1.0d0) -115) - (scale-float (float 7913822574154586 1.0d0) -170) - (scale-float (float -4804352564403217 1.0d0) -224) - (scale-float (float 6064389487591424 1.0d0) -278))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 7074193361797233 1.0d0) -60) - (scale-float (float 7522205695703707 1.0d0) -116) - (scale-float (float 7787047147324868 1.0d0) -175) - (scale-float (float -6728650631839117 1.0d0) -232) - (scale-float (float 5184626653921280 1.0d0) -286))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 5305603405682435 1.0d0) -59) - (scale-float (float -5041342953893321 1.0d0) -115) - (scale-float (float 8335474310793984 1.0d0) -170) - (scale-float (float 6743025479788607 1.0d0) -225) - (scale-float (float -6023389004300288 1.0d0) -279))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 7074060192106372 1.0d0) -59) - (scale-float (float 7185921569156509 1.0d0) -113) - (scale-float (float -6016799991653399 1.0d0) -170) - (scale-float (float -5577663458559350 1.0d0) -224) - (scale-float (float -7969393573560320 1.0d0) -278))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 8842450394781643 1.0d0) -59) - (scale-float (float -8771095658131507 1.0d0) -113) - (scale-float (float 8705573170983202 1.0d0) -167) - (scale-float (float -4692271881407162 1.0d0) -221) - (scale-float (float 8141919777882112 1.0d0) -275))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 5305378684473085 1.0d0) -58) - (scale-float (float 7704904742673764 1.0d0) -113) - (scale-float (float 7308626221243388 1.0d0) -167) - (scale-float (float 4905810005485122 1.0d0) -223) - (scale-float (float -5326632406941696 1.0d0) -277))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 6189482235310630 1.0d0) -58) - (scale-float (float -4715432182777116 1.0d0) -113) - (scale-float (float -8243063834437948 1.0d0) -168) - (scale-float (float 8566398131092182 1.0d0) -222) - (scale-float (float -6086611201163264 1.0d0) -277))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 7073527528384126 1.0d0) -58) - (scale-float (float -7632135562854704 1.0d0) -116) - (scale-float (float 7289253486557291 1.0d0) -170) - (scale-float (float -7590289326531904 1.0d0) -224) - (scale-float (float 7722148853710848 1.0d0) -279))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 7957506242722589 1.0d0) -58) - (scale-float (float -8272553670927212 1.0d0) -112) - (scale-float (float -6591995918745221 1.0d0) -166) - (scale-float (float -4636857096009409 1.0d0) -220) - (scale-float (float 7183488739295232 1.0d0) -275))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 8841410057981697 1.0d0) -58) - (scale-float (float -5627969559234247 1.0d0) -118) - (scale-float (float 6018105389463175 1.0d0) -172) - (scale-float (float 7544891264015395 1.0d0) -230) - (scale-float (float 6209179752595456 1.0d0) -284))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 4862615327261055 1.0d0) -57) - (scale-float (float -5217239170857332 1.0d0) -111) - (scale-float (float -6336246586437174 1.0d0) -165) - (scale-float (float 5522987872330073 1.0d0) -219) - (scale-float (float -5649337847988224 1.0d0) -273))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 5304479856743885 1.0d0) -57) - (scale-float (float 6340842145528512 1.0d0) -113) - (scale-float (float -7566831660699656 1.0d0) -167) - (scale-float (float -7114412056121165 1.0d0) -221) - (scale-float (float -8974201406881792 1.0d0) -279))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 5746294458442105 1.0d0) -57) - (scale-float (float 4845186982751657 1.0d0) -113) - (scale-float (float 6382779118838290 1.0d0) -167) - (scale-float (float 8090523197847278 1.0d0) -221) - (scale-float (float 6384881576181760 1.0d0) -276))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 6188054973828419 1.0d0) -57) - (scale-float (float 7360584602593505 1.0d0) -111) - (scale-float (float 7946504576809704 1.0d0) -165) - (scale-float (float 5731224328660037 1.0d0) -219) - (scale-float (float 6575748996808704 1.0d0) -273))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 6629757244884614 1.0d0) -57) - (scale-float (float -5806448969106076 1.0d0) -112) - (scale-float (float 7037190739826080 1.0d0) -166) - (scale-float (float 5552037724818900 1.0d0) -223) - (scale-float (float 6596791471308800 1.0d0) -277))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 7071397114140692 1.0d0) -57) - (scale-float (float -7057477599664784 1.0d0) -113) - (scale-float (float -8290828586102809 1.0d0) -167) - (scale-float (float -6697971486035361 1.0d0) -222) - (scale-float (float -7883618700230656 1.0d0) -277))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 7512970424714007 1.0d0) -57) - (scale-float (float -6294023145184360 1.0d0) -111) - (scale-float (float -6395720725273163 1.0d0) -165) - (scale-float (float -7071774105018818 1.0d0) -219) - (scale-float (float -5298326162341888 1.0d0) -274))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 7954473020348387 1.0d0) -57) - (scale-float (float -6926679705961747 1.0d0) -112) - (scale-float (float -6427721451859560 1.0d0) -167) - (scale-float (float 8028310015339695 1.0d0) -222) - (scale-float (float 6198625664499712 1.0d0) -277))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 8395900745453257 1.0d0) -57) - (scale-float (float 4839201044457661 1.0d0) -114) - (scale-float (float 5799570435052711 1.0d0) -171) - (scale-float (float -5529353034270453 1.0d0) -226) - (scale-float (float 6823048531410944 1.0d0) -280))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 8837249445142752 1.0d0) -57) - (scale-float (float -5314952832401406 1.0d0) -113) - (scale-float (float -7992910057771694 1.0d0) -167) - (scale-float (float 8886165424019995 1.0d0) -221) - (scale-float (float 8017893964447744 1.0d0) -276))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 4639257482637412 1.0d0) -56) - (scale-float (float -5494228531443205 1.0d0) -110) - (scale-float (float 6222043711193090 1.0d0) -167) - (scale-float (float 4966112393074763 1.0d0) -221) - (scale-float (float 6647651906093056 1.0d0) -275))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 4859846576245171 1.0d0) -56) - (scale-float (float -8985502920124077 1.0d0) -110) - (scale-float (float 7440463379940699 1.0d0) -165) - (scale-float (float -6641325637598524 1.0d0) -219) - (scale-float (float -5163628344082432 1.0d0) -273))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 5080389927126093 1.0d0) -56) - (scale-float (float -8898661047761268 1.0d0) -110) - (scale-float (float -4667727006484474 1.0d0) -164) - (scale-float (float 8478536563323652 1.0d0) -218) - (scale-float (float 8774483460931584 1.0d0) -273))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 5300885459442166 1.0d0) -56) - (scale-float (float -7213383224879916 1.0d0) -111) - (scale-float (float -8534269322822802 1.0d0) -166) - (scale-float (float -6601733372219099 1.0d0) -221) - (scale-float (float 8396826690453504 1.0d0) -278))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 5521331097805465 1.0d0) -56) - (scale-float (float 4829604598179156 1.0d0) -114) - (scale-float (float -7893599535446481 1.0d0) -172) - (scale-float (float -5384211130874634 1.0d0) -226) - (scale-float (float -5250039492378624 1.0d0) -282))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 5741724767297686 1.0d0) -56) - (scale-float (float -5824155811343436 1.0d0) -110) - (scale-float (float 6673985610265747 1.0d0) -164) - (scale-float (float 4800782739249759 1.0d0) -220) - (scale-float (float 7109827096051712 1.0d0) -274))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 5962064393489674 1.0d0) -56) - (scale-float (float 7651360099479755 1.0d0) -112) - (scale-float (float 6974817744235260 1.0d0) -167) - (scale-float (float 7824970858345265 1.0d0) -224) - (scale-float (float -7627319001219072 1.0d0) -278))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 6182347902460953 1.0d0) -56) - (scale-float (float -8796242544913562 1.0d0) -111) - (scale-float (float -7546272905440146 1.0d0) -165) - (scale-float (float 6512061516709508 1.0d0) -219) - (scale-float (float 5909873078861824 1.0d0) -273))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 6402573220819241 1.0d0) -56) - (scale-float (float -4868008820827392 1.0d0) -110) - (scale-float (float 8779206749884591 1.0d0) -164) - (scale-float (float -8648470131210884 1.0d0) -218) - (scale-float (float -7064277529821184 1.0d0) -273))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 6622738275719969 1.0d0) -56) - (scale-float (float 6182934508221337 1.0d0) -110) - (scale-float (float 7353282250945404 1.0d0) -165) - (scale-float (float -8166192353391047 1.0d0) -220) - (scale-float (float -8567002520092672 1.0d0) -277))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 6842840994885793 1.0d0) -56) - (scale-float (float -8552477024466766 1.0d0) -110) - (scale-float (float -4997427595980002 1.0d0) -164) - (scale-float (float 5821398332046138 1.0d0) -218) - (scale-float (float 6922342312886272 1.0d0) -273))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 7062879306626092 1.0d0) -56) - (scale-float (float -8487236864497288 1.0d0) -112) - (scale-float (float -4942162982072151 1.0d0) -168) - (scale-float (float -4811145377091453 1.0d0) -223) - (scale-float (float -8730216008515584 1.0d0) -284))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 7282851139856476 1.0d0) -56) - (scale-float (float 8609951212389606 1.0d0) -111) - (scale-float (float -5614142183842944 1.0d0) -165) - (scale-float (float 6068416796043208 1.0d0) -219) - (scale-float (float 8196791178133504 1.0d0) -273))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 7502754424118275 1.0d0) -56) - (scale-float (float 8536169017599928 1.0d0) -110) - (scale-float (float 7981550951145323 1.0d0) -165) - (scale-float (float -8340622458345952 1.0d0) -220) - (scale-float (float 6285858857648128 1.0d0) -274))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 7722587089598028 1.0d0) -56) - (scale-float (float 8362719068102409 1.0d0) -110) - (scale-float (float -7853008551658302 1.0d0) -166) - (scale-float (float -6852498985157079 1.0d0) -220) - (scale-float (float -4875056737550336 1.0d0) -274))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 7942347067146965 1.0d0) -56) - (scale-float (float -5897359216343841 1.0d0) -113) - (scale-float (float 7767443765766550 1.0d0) -169) - (scale-float (float 8203371449514667 1.0d0) -225) - (scale-float (float -8271467659657216 1.0d0) -279))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 8162032288300481 1.0d0) -56) - (scale-float (float 7035687121204020 1.0d0) -111) - (scale-float (float 5733124558862890 1.0d0) -168) - (scale-float (float 6681272325774503 1.0d0) -223) - (scale-float (float 8561939877724160 1.0d0) -281))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 8381640685297609 1.0d0) -56) - (scale-float (float 5345425417737710 1.0d0) -112) - (scale-float (float -8790124191829010 1.0d0) -166) - (scale-float (float 7297964455931531 1.0d0) -225) - (scale-float (float 6532791441293312 1.0d0) -279))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 8601170191100479 1.0d0) -56) - (scale-float (float -5127404751534987 1.0d0) -110) - (scale-float (float 8258618371098839 1.0d0) -164) - (scale-float (float 6354475203379338 1.0d0) -221) - (scale-float (float 6679197895688192 1.0d0) -275))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 8820618739413774 1.0d0) -56) - (scale-float (float 7361249450583405 1.0d0) -111) - (scale-float (float 8489175872343797 1.0d0) -165) - (scale-float (float -4838736209868180 1.0d0) -220) - (scale-float (float -8316549956370432 1.0d0) -277))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 4519992132352091 1.0d0) -55) - (scale-float (float 6319901705801489 1.0d0) -110) - (scale-float (float 5600764727998866 1.0d0) -166) - (scale-float (float -5650573825026412 1.0d0) -220) - (scale-float (float 8973806114308096 1.0d0) -274))) - #.(multiple-value-call #'%make-qd-d - (renorm-5 (scale-float (float 4629632351109917 1.0d0) -55) - (scale-float (float 4958462282897610 1.0d0) -110) - (scale-float (float -8711719640720475 1.0d0) -165) - (scale-float (float -8191834096705166 1.0d0) -221) - (scale-float (float -5689038166556672 1.0d0) -275))) [6432 lines skipped]

1 0

[oct-cvs] Oct commit: oct branch-test.lisp
by rtoy 16 Oct '07

16 Oct '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv2116 Modified Files: branch-test.lisp Log Message: Remove CMUCL'isms. --- /project/oct/cvsroot/oct/branch-test.lisp 2007/10/13 02:14:43 1.2 +++ /project/oct/cvsroot/oct/branch-test.lisp 2007/10/16 13:42:49 1.3 @@ -57,12 +57,15 @@ (multiple-value-bind (tr ti) (get-signs (asin #c(-2d0 +1d-20))) (check-signs #'asin -2d0 tr ti) + #+cmu (check-signs #'asin -2w0 tr ti) (check-signs #'asin #q-2 tr ti) (check-signs #'asin #c(-2d0 0d0) tr ti) + #+cmu (check-signs #'asin #c(-2w0 0w0) tr ti) (check-signs #'asin #q(-2 0) tr ti) (check-signs #'asin #c(-2d0 -0d0) tr (- ti)) + #+cmu (check-signs #'asin #c(-2w0 -0w0) tr (- ti)) (check-signs #'asin #q(-2 #q-0q0) tr (- ti)) ) @@ -71,9 +74,11 @@ (multiple-value-bind (tr ti) (get-signs (asin #c(2d0 -1d-20))) (check-signs #'asin 2d0 tr ti) + #+cmu (check-signs #'asin 2w0 tr ti) (check-signs #'asin #q2 tr ti) (check-signs #'asin #c(2d0 -0d0) tr ti) + #+cmu (check-signs #'asin #c(2w0 -0w0) tr ti) (check-signs #'asin #q(2 #q-0q0) tr ti))) @@ -84,6 +89,7 @@ (multiple-value-bind (tr ti) (get-signs (acos #c(-2d0 +1d-20))) (check-signs #'acos -2d0 tr ti) + #+cmu (check-signs #'acos -2w0 tr ti) (check-signs #'acos #q-2 tr ti)) @@ -91,6 +97,7 @@ (multiple-value-bind (tr ti) (get-signs (acos #c(2d0 -1d-20))) (check-signs #'acos 2d0 tr ti) + #+cmu (check-signs #'acos 2w0 tr ti) (check-signs #'acos #q2 tr ti))) @@ -102,6 +109,7 @@ (multiple-value-bind (tr ti) (get-signs (atan #c(1d-20 -2d0))) (check-signs #'atan #c(0d0 -2d0) tr ti) + #+cmu (check-signs #'atan #c(0w0 -2w0) tr ti) (check-signs #'atan #q(#q0 #q-2) tr ti)) @@ -109,6 +117,7 @@ (multiple-value-bind (tr ti) (get-signs (atan #c(-1d-20 2d0))) (check-signs #'atan #c(-0d0 2d0) tr ti) + #+cmu (check-signs #'atan #c(-0w0 2w0) tr ti) (check-signs #'atan #q(#q-0 2) tr ti))) @@ -118,6 +127,7 @@ (multiple-value-bind (tr ti) (get-signs (atanh #c(-2d0 -1d-20))) (check-signs #'atanh -2d0 tr ti) + #+cmu (check-signs #'atanh -2w0 tr ti) (check-signs #'atanh #q-2 tr ti)) @@ -125,6 +135,7 @@ (multiple-value-bind (tr ti) (get-signs (atanh #c(2d0 1d-20))) (check-signs #'atanh 2d0 tr ti) + #+cmu (check-signs #'atanh 2w0 tr ti) (check-signs #'atanh #q2 tr ti)))

1 0