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

[oct-cvs] Oct commit: oct qd-class.lisp qd-complex.lisp qd-methods.lisp
by rtoy 31 Aug '07

31 Aug '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv16229 Modified Files: qd-class.lisp qd-complex.lisp qd-methods.lisp Log Message: qd-class.lisp: o Oops. Forgot to rename the defgenerics. qd-complex.lisp: o QLOG no longer exists. Use LOG. qd-methods.lisp: o QLOG no longer exists. Use LOG. --- /project/oct/cvsroot/oct/qd-class.lisp 2007/08/30 23:41:10 1.23 +++ /project/oct/cvsroot/oct/qd-class.lisp 2007/08/31 21:13:36 1.24 @@ -173,40 +173,40 @@ (defgeneric qscale-float (x n) (:documentation "Multiply the float X by 2^N")) -(defgeneric qabs (x) +(defgeneric abs (x) (:documentation "Absolute value of X")) -(defgeneric qexp (x) +(defgeneric exp (x) (:documentation "Exponential of X")) -(defgeneric qsin (x) +(defgeneric sin (x) (:documentation "Sine of X")) -(defgeneric qcos (x) +(defgeneric cos (x) (:documentation "Cosine of X")) -(defgeneric qtan (x) +(defgeneric tan (x) (:documentation "Tangent of X")) -(defgeneric qsinh (x) +(defgeneric sinh (x) (:documentation "Hyperbolic sine of X")) -(defgeneric qcosh (x) +(defgeneric cosh (x) (:documentation "Hyperbolic cosine of X")) -(defgeneric qtanh (x) +(defgeneric tanh (x) (:documentation "Hyperbolic tangent of X")) -(defgeneric qsqrt (x) +(defgeneric sqrt (x) (:documentation "Square root of X")) -(defgeneric qlog (a &optional b) +(defgeneric log (a &optional b) (:documentation "Log of A base B. If B not given, then natural log")) (defgeneric log1p (x) (:documentation "log(1+x)")) -(defgeneric qatan (y &optional x) +(defgeneric atan (y &optional x) (:documentation "If X not given, atan(y). If X is given, atan(y/x), taking the quadrant into account")) @@ -231,22 +231,22 @@ (defgeneric qfloat-sign (a &optional b) (:documentation "Transfer sign of A to B. If B not given, assume 1")) -(defgeneric qasin (x) +(defgeneric asin (x) (:documentation "Inverse sine of X")) -(defgeneric qacos (x) +(defgeneric acos (x) (:documentation "Inverse cosine of X")) -(defgeneric qacosh (x) +(defgeneric acosh (x) (:documentation "Inverse hyperbolic cosine of X")) -(defgeneric qatanh (x) +(defgeneric atanh (x) (:documentation "Inverse hyperbolic tangent of X")) -(defgeneric qcis (x) +(defgeneric cis (x) (:documentation "(complex (cos x) (sin x))")) -(defgeneric qphase (x) +(defgeneric phase (x) (:documentation "Phase of X")) (defgeneric coerce (x type) --- /project/oct/cvsroot/oct/qd-complex.lisp 2007/08/31 03:11:00 1.34 +++ /project/oct/cvsroot/oct/qd-complex.lisp 2007/08/31 21:13:36 1.35 @@ -732,7 +732,7 @@ (defmethod log ((a qd-complex) &optional b) (if b - (/ (qlog a) (qlog b)) + (/ (log a) (log b)) (complex (log (abs a)) (atan (imagpart a) (realpart a))))) --- /project/oct/cvsroot/oct/qd-methods.lisp 2007/08/31 19:34:00 1.54 +++ /project/oct/cvsroot/oct/qd-methods.lisp 2007/08/31 21:13:36 1.55 @@ -423,7 +423,7 @@ (defmethod log ((a qd-real) &optional b) (if b - (/ (qlog a) (qlog b)) + (/ (log a) (log b)) (if (minusp (float-sign a)) (make-instance 'qd-complex :real (log-qd (abs-qd (qd-value a)))

1 0

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

31 Aug '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv2308 Modified Files: qd-methods.lisp Log Message: Oops. Forgot to convert qabs to abs. --- /project/oct/cvsroot/oct/qd-methods.lisp 2007/08/31 03:11:00 1.53 +++ /project/oct/cvsroot/oct/qd-methods.lisp 2007/08/31 19:34:00 1.54 @@ -409,7 +409,7 @@ (scale-float (make-instance 'qd-real :value (sqrt abs^2)) rho))) -(defmethod qabs ((z qd-complex)) +(defmethod abs ((z qd-complex)) ;; sqrt(x^2+y^2) ;; If |x| > |y| then sqrt(x^2+y^2) = |x|*sqrt(1+(y/x)^2) (make-instance 'qd-real

1 0

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

31 Aug '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv9259 Modified Files: qd-complex.lisp qd-methods.lisp Log Message: Get rid of the extra layer of function calls and define the special functions as methods directly. --- /project/oct/cvsroot/oct/qd-complex.lisp 2007/08/30 23:42:24 1.33 +++ /project/oct/cvsroot/oct/qd-complex.lisp 2007/08/31 03:11:00 1.34 @@ -668,69 +668,69 @@ (- (realpart result))))) ;; End of implementation of complex functions from CMUCL. -(defmethod qasin ((x qd-complex)) +(defmethod asin ((x qd-complex)) (qd-complex-asin x)) -(defmethod qacos ((x qd-complex)) +(defmethod acos ((x qd-complex)) (qd-complex-acos x)) -(defmethod qacosh ((x qd-complex)) +(defmethod acosh ((x qd-complex)) (qd-complex-acosh x)) -(defmethod qatanh ((x qd-complex)) +(defmethod atanh ((x qd-complex)) (qd-complex-atanh x)) -(defmethod qsin ((z qd-complex)) +(defmethod sin ((z qd-complex)) (let ((x (realpart z)) (y (imagpart z))) (complex (* (sin x) (cosh y)) (* (cos x) (sinh y))))) -(defmethod qcos ((z qd-complex)) +(defmethod cos ((z qd-complex)) (let ((x (realpart z)) (y (imagpart z))) (complex (* (cos x) (cosh y)) (- (* (sin x) (sinh y)))))) -(defmethod qtan ((z qd-complex)) +(defmethod tan ((z qd-complex)) (qd-complex-tan z)) -(defmethod qsinh ((z qd-complex)) +(defmethod sinh ((z qd-complex)) (let ((x (realpart z)) (y (imagpart z))) (complex (* (sinh x) (cos y)) (* (cosh x) (sin y))))) -(defmethod qcosh ((z qd-complex)) +(defmethod cosh ((z qd-complex)) (let ((x (realpart z)) (y (imagpart z))) (complex (* (cosh x) (cos y)) (* (sinh x) (sin y))))) -(defmethod qtanh ((z qd-complex)) +(defmethod tanh ((z qd-complex)) (qd-complex-tanh z)) -(defmethod qsqrt ((z qd-complex)) +(defmethod sqrt ((z qd-complex)) (qd-complex-sqrt z)) -(defmethod qatan ((y qd-complex) &optional x) +(defmethod atan ((y qd-complex) &optional x) (if x (error "First arg of 2-arg ATAN must be real") (qd-complex-atan y))) -(defmethod qatan ((y cl:complex) &optional x) +(defmethod atan ((y cl:complex) &optional x) (if x (error "First arg of 2-arg ATAN must be real") (cl:atan y))) -(defmethod qexp ((z qd-complex)) +(defmethod exp ((z qd-complex)) (let* ((x (realpart z)) (y (imagpart z)) (ex (exp x))) (complex (* ex (cos y)) (* ex (sin y))))) -(defmethod qlog ((a qd-complex) &optional b) +(defmethod log ((a qd-complex) &optional b) (if b (/ (qlog a) (qlog b)) (complex (log (abs a)) @@ -745,7 +745,7 @@ (defmethod qexpt ((x qd-complex) (y qd-complex)) (exp (* y (log x)))) -(defmethod qphase ((z qd-complex)) +(defmethod phase ((z qd-complex)) (atan (imagpart z) (realpart z))) (defun realp (x) --- /project/oct/cvsroot/oct/qd-methods.lisp 2007/08/29 14:37:20 1.52 +++ /project/oct/cvsroot/oct/qd-methods.lisp 2007/08/31 03:11:00 1.53 @@ -356,13 +356,10 @@ (cl-name (intern (symbol-name name) :cl)) (qd-name (intern (concatenate 'string (symbol-name name) "-QD")))) `(progn - (defmethod ,method-name ((x number)) + (defmethod ,name ((x number)) (,cl-name x)) - (defmethod ,method-name ((x qd-real)) - (make-instance 'qd-real :value (,qd-name (qd-value x)))) - (declaim (inline ,name)) - (defun ,name (x) - (,method-name x)))))) + (defmethod ,name ((x qd-real)) + (make-instance 'qd-real :value (,qd-name (qd-value x)))))))) (frob abs) (frob exp) (frob sin) @@ -378,19 +375,16 @@ ;;(frob atanh) ) -(defmethod qsqrt ((x number)) +(defmethod sqrt ((x number)) (cl:sqrt x)) -(defmethod qsqrt ((x qd-real)) +(defmethod sqrt ((x qd-real)) (if (minusp x) (make-instance 'qd-complex :real +qd-zero+ :imag (sqrt-qd (neg-qd (qd-value x)))) (make-instance 'qd-real :value (sqrt-qd (qd-value x))))) -(defun sqrt (x) - (qsqrt x)) - (defun scalb (x n) "Compute 2^N * X without compute 2^N first (use properties of the underlying floating-point format" @@ -422,12 +416,12 @@ :value (hypot-qd (qd-value (realpart z)) (qd-value (imagpart z))))) -(defmethod qlog ((a number) &optional b) +(defmethod log ((a number) &optional b) (if b (cl:log a b) (cl:log a))) -(defmethod qlog ((a qd-real) &optional b) +(defmethod log ((a qd-real) &optional b) (if b (/ (qlog a) (qlog b)) (if (minusp (float-sign a)) @@ -436,15 +430,10 @@ :imag +qd-pi+) (make-instance 'qd-real :value (log-qd (qd-value a)))))) -(declaim (inline log)) -(defun log (a &optional b) - (qlog a b)) - - (defmethod log1p ((a qd-real)) (make-instance 'qd-real :value (log1p-qd (qd-value a)))) -(defmethod qatan ((y real) &optional x) +(defmethod atan ((y real) &optional x) (cond (x (cond ((typep x 'qd-real) (make-instance 'qd-real @@ -454,17 +443,13 @@ (t (cl:atan y)))) -(defmethod qatan ((y qd-real) &optional x) +(defmethod atan ((y qd-real) &optional x) (make-instance 'qd-real :value (if x (atan2-qd (qd-value y) (qd-value x)) (atan-qd (qd-value y))))) -(defun atan (y &optional x) - (qatan y x)) - - (defmethod qexpt ((x number) (y number)) (cl:expt x y)) @@ -732,83 +717,57 @@ (if (< (car nlist) result) (setq result (car nlist))))) -(defmethod qasin ((x number)) +(defmethod asin ((x number)) (cl:asin x)) -(defmethod qasin ((x qd-real)) +(defmethod asin ((x qd-real)) (if (<= -1 x 1) (make-instance 'qd-real :value (asin-qd (qd-value x))) (qd-complex-asin x))) -(declaim (inline asin)) -(defun asin (x) - (qasin x)) - -(defmethod qacos ((x number)) +(defmethod acos ((x number)) (cl:acos x)) -(defmethod qacos ((x qd-real)) +(defmethod acos ((x qd-real)) (cond ((> (abs x) 1) (qd-complex-acos x)) (t (make-instance 'qd-real :value (acos-qd (qd-value x)))))) -(declaim (inline acos)) -(defun acos (x) - (qacos x)) - -(defmethod qacosh ((x number)) +(defmethod acosh ((x number)) (cl:acosh x)) -(defmethod qacosh ((x qd-real)) +(defmethod acosh ((x qd-real)) (if (< x 1) (qd-complex-acosh x) (make-instance 'qd-real :value (acosh-qd (qd-value x))))) - -(declaim (inline acosh)) -(defun acosh (x) - (qacosh x)) - -(defmethod qatanh ((x number)) +(defmethod atanh ((x number)) (cl:atanh x)) -(defmethod qatanh ((x qd-real)) +(defmethod atanh ((x qd-real)) (if (> (abs x) 1) (qd-complex-atanh x) (make-instance 'qd-real :value (atanh-qd (qd-value x))))) - -(declaim (inline atanh)) -(defun atanh (x) - (qatanh x)) - -(defmethod qcis ((x real)) +(defmethod cis ((x real)) (cl:cis x)) -(defmethod qcis ((x qd-real)) +(defmethod cis ((x qd-real)) (multiple-value-bind (s c) (sincos-qd (qd-value x)) (make-instance 'qd-complex :real c :imag s))) -(declaim (inline cis)) -(defun cis (x) - (qcis x)) - -(defmethod qphase ((x number)) +(defmethod phase ((x number)) (cl:phase x)) -(defmethod qphase ((x qd-real)) +(defmethod phase ((x qd-real)) (if (minusp x) (- +pi+) (make-instance 'qd-real :value (make-qd-d 0d0)))) -(declaim (inline phase)) -(defun phase (x) - (qphase x)) - (defun signum (number) "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER))." (if (zerop number)

1 0

[oct-cvs] Oct commit: oct qd-complex.lisp
by rtoy 30 Aug '07

30 Aug '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv12895 Modified Files: qd-complex.lisp Log Message: Add methods to handle QD-REAL and CL:COMPLEX and vice-versa for the four basic arithmetic operations. --- /project/oct/cvsroot/oct/qd-complex.lisp 2007/08/28 16:01:08 1.32 +++ /project/oct/cvsroot/oct/qd-complex.lisp 2007/08/30 23:42:24 1.33 @@ -213,6 +213,39 @@ (complex (/ (+ (* rx r) ix) dn) (/ (- (* ix r) rx) dn)))))) +(defmethod two-arg-+ ((a qd-real) (b cl:complex)) + (complex (+ a (realpart b)) + (imagpart b))) + +(defmethod two-arg-+ ((a cl:complex) (b qd-real)) + (complex (+ (realpart a) b) + (imagpart a))) + +(defmethod two-arg-- ((a qd-real) (b cl:complex)) + (complex (- a (realpart b)) + (- (imagpart b)))) + +(defmethod two-arg-- ((a cl:complex) (b qd-real)) + (complex (- (realpart a) b) + (imagpart a))) + +(defmethod two-arg-* ((a qd-real) (b cl:complex)) + (complex (* a (realpart b)) + (* a (imagpart b)))) + +(defmethod two-arg-* ((a cl:complex) (b qd-real)) + (complex (* (realpart a) b) + (* (imagpart a) b))) + + +(defmethod two-arg-/ ((a qd-real) (b cl:complex)) + (two-arg-/ a (coerce b 'qd-complex))) + +(defmethod two-arg-/ ((a cl:complex) (b qd-real)) + (complex (/ (realpart a) b) + (/ (imagpart a) b))) + + (defmethod unary-divide ((a qd-complex)) (two-arg-/ #q1 a))

1 0

[oct-cvs] Oct commit: oct qd-class.lisp
by rtoy 30 Aug '07

30 Aug '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv12848 Modified Files: qd-class.lisp Log Message: Change QD-COMPLEX printer to split the real and imaginary parts onto separate lines if necessary. --- /project/oct/cvsroot/oct/qd-class.lisp 2007/08/27 19:12:22 1.22 +++ /project/oct/cvsroot/oct/qd-class.lisp 2007/08/30 23:41:10 1.23 @@ -67,10 +67,11 @@ (make-instance 'qd-real :value (qd-value x))) (defmethod print-object ((qd qd-complex) stream) - (format stream "#q(~/qdi::qd-format/ ~/qdi::qd-format/)" - (qd-real qd) - (qd-imag qd))) + (format stream "#q(~<~/qdi::qd-format/ ~/qdi::qd-format/~:@>)" + (list (qd-real qd) + (qd-imag qd)))) +#+(or) (defmethod print-object ((qd qd-complex) stream) (write-string "#q(" stream) (print-qd (qd-real qd) stream)

1 0

[oct-cvs] Oct commit: oct qd-format.lisp
by rtoy 29 Aug '07

29 Aug '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv15853 Modified Files: qd-format.lisp Log Message: Add CL package qualifier for DECF and INCF. --- /project/oct/cvsroot/oct/qd-format.lisp 2007/08/27 17:49:19 1.5 +++ /project/oct/cvsroot/oct/qd-format.lisp 2007/08/29 14:37:42 1.6 @@ -73,7 +73,7 @@ (qdi::qd-to-string (qd-value num) spaceleft fdig k fmin) (when (and d (zerop d)) (setq tpoint nil)) (when w - (decf spaceleft flen) + (cl:decf spaceleft flen) ;; See CLHS 22.3.3.2. "If the parameter d is ;; omitted, ... [and] if the fraction to be ;; printed is zero then a single zero digit should @@ -82,10 +82,10 @@ ;; add an extra 0 digit later. (when (and (null d) (char= (aref fstr (1- flen)) #\.)) (setf add-zero-p t) - (decf spaceleft)) + (cl:decf spaceleft)) (when lpoint (if (or (> spaceleft 0) tpoint) - (decf spaceleft) + (cl:decf spaceleft) (setq lpoint nil))) (when (and tpoint (<= spaceleft 0)) (setq tpoint nil)))

1 0

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

29 Aug '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv15798 Modified Files: qd-methods.lisp Log Message: Oops. Last change went to the wrong spot. Only valid for =. --- /project/oct/cvsroot/oct/qd-methods.lisp 2007/08/29 14:22:42 1.51 +++ /project/oct/cvsroot/oct/qd-methods.lisp 2007/08/29 14:37:20 1.52 @@ -333,12 +333,6 @@ (,qd-fun (make-qd-d (cl:float a 1d0)) (qd-value b))) (defmethod ,method ((a qd-real) (b qd-real)) (,qd-fun (qd-value a) (qd-value b))) - (defmethod ,method ((a qd-complex) b) - (and (,method (realpart a) (realpart b)) - (,method (imagpart a) (imagpart b)))) - (defmethod ,method (a (b qd-complex)) - (and (,method (realpart a) (realpart b)) - (,method (imagpart a) (imagpart b)))) (defun ,op (number &rest more-numbers) "Returns T if its arguments are in strictly increasing order, NIL otherwise." (declare (optimize (safety 2)) @@ -519,6 +513,15 @@ (qd-= (make-qd-d (cl:float a 1d0)) (qd-value b)) nil)) +(defmethod two-arg-= ((a qd-complex) b) + (and (two-arg-= (realpart a) (realpart b)) + (two-arg-= (imagpart a) (imagpart b)))) + +(defmethod two-arg-= (a (b qd-complex)) + (and (two-arg-= (realpart a) (realpart b)) + (two-arg-= (imagpart a) (imagpart b)))) + + (defmethod two-arg-= ((a qd-real) (b qd-real)) (qd-= (qd-value a) (qd-value b)))

1 0

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

29 Aug '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv14024 Modified Files: qd-methods.lisp Log Message: Forgot to handle comparisons of QD-COMPLEX and another number. --- /project/oct/cvsroot/oct/qd-methods.lisp 2007/08/29 01:22:03 1.50 +++ /project/oct/cvsroot/oct/qd-methods.lisp 2007/08/29 14:22:42 1.51 @@ -328,9 +328,17 @@ (defmethod ,method ((a qd-real) (b real)) (,qd-fun (qd-value a) (make-qd-d (cl:float b 1d0)))) (defmethod ,method ((a real) (b qd-real)) + ;; This is not really right if A is a rational. We're + ;; supposed to compare them as rationals. (,qd-fun (make-qd-d (cl:float a 1d0)) (qd-value b))) (defmethod ,method ((a qd-real) (b qd-real)) (,qd-fun (qd-value a) (qd-value b))) + (defmethod ,method ((a qd-complex) b) + (and (,method (realpart a) (realpart b)) + (,method (imagpart a) (imagpart b)))) + (defmethod ,method (a (b qd-complex)) + (and (,method (realpart a) (realpart b)) + (,method (imagpart a) (imagpart b)))) (defun ,op (number &rest more-numbers) "Returns T if its arguments are in strictly increasing order, NIL otherwise." (declare (optimize (safety 2)) @@ -345,18 +353,22 @@ (frob <=) (frob >=)) -(macrolet ((frob (name) - (let ((method-name (intern (concatenate 'string "Q" (symbol-name name)))) - (cl-name (intern (symbol-name name) :cl)) - (qd-name (intern (concatenate 'string (symbol-name name) "-QD")))) - `(progn - (defmethod ,method-name ((x number)) - (,cl-name x)) - (defmethod ,method-name ((x qd-real)) - (make-instance 'qd-real :value (,qd-name (qd-value x)))) - (declaim (inline ,name)) - (defun ,name (x) - (,method-name x)))))) +;; Handle the special functions for a real argument. Complex args are +;; handled elsewhere. +(macrolet + ((frob (name) + (let ((method-name + (intern (concatenate 'string "Q" (symbol-name name)))) + (cl-name (intern (symbol-name name) :cl)) + (qd-name (intern (concatenate 'string (symbol-name name) "-QD")))) + `(progn + (defmethod ,method-name ((x number)) + (,cl-name x)) + (defmethod ,method-name ((x qd-real)) + (make-instance 'qd-real :value (,qd-name (qd-value x)))) + (declaim (inline ,name)) + (defun ,name (x) + (,method-name x)))))) (frob abs) (frob exp) (frob sin) @@ -496,12 +508,14 @@ (defmethod two-arg-= ((a number) (b number)) (cl:= a b)) + (defmethod two-arg-= ((a qd-real) (b number)) - (if (realp b) + (if (cl:realp b) (qd-= (qd-value a) (make-qd-d (cl:float b 1d0))) nil)) + (defmethod two-arg-= ((a number) (b qd-real)) - (if (realp a) + (if (cl:realp a) (qd-= (make-qd-d (cl:float a 1d0)) (qd-value b)) nil))

1 0

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

29 Aug '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv14357 Modified Files: qd-methods.lisp qd-package.lisp Log Message: qd-package.lisp: o Shadow FLOAT-DIGITS qd-methods.lisp: o Add FLOAT-DIGITS method. --- /project/oct/cvsroot/oct/qd-methods.lisp 2007/08/27 17:49:19 1.49 +++ /project/oct/cvsroot/oct/qd-methods.lisp 2007/08/29 01:22:03 1.50 @@ -806,6 +806,13 @@ (defmethod random ((x qd-real) &optional (state *random-state*)) (* x (make-instance 'qd-real :value (qdi:random-qd state)))) + +(defmethod float-digits ((x cl:real)) + (cl:float-digits x)) + +(defmethod float-digits ((x qd-real)) + (* 4 (float-digits 1d0))) + (define-compiler-macro + (&whole form &rest args) (if (null args) --- /project/oct/cvsroot/oct/qd-package.lisp 2007/08/28 16:01:08 1.35 +++ /project/oct/cvsroot/oct/qd-package.lisp 2007/08/29 01:22:03 1.36 @@ -162,6 +162,7 @@ #:numberp #:incf #:decf + #:float-digits ) (:export #:+ #:- @@ -225,6 +226,7 @@ #:numberp #:incf #:decf + #:float-digits ) ;; Constants (:export #:+pi+)

1 0

[oct-cvs] Oct commit: oct qd-complex.lisp qd-package.lisp
by rtoy 28 Aug '07

28 Aug '07

Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv28331 Modified Files: qd-complex.lisp qd-package.lisp Log Message: qd-complex.lisp: o Add ADD1 and SUB1 methods so we can use 1+ and 1- on quad-doubles. o Add INCF and DECF macros to support quad-doubles. qd-package.lisp: o Forgot to shadow REALP, COMPLEXP, and NUMBERP, previously. o Shadow and export INCF and DECF. --- /project/oct/cvsroot/oct/qd-complex.lisp 2007/08/28 14:12:53 1.31 +++ /project/oct/cvsroot/oct/qd-complex.lisp 2007/08/28 16:01:08 1.32 @@ -23,14 +23,16 @@ ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR ;;;; OTHER DEALINGS IN THE SOFTWARE. -;; Most of this code taken from CMUCL and slightly modified to support -;; QD-COMPLEX. - (in-package #:qd) (defmethod add1 ((a qd-complex)) (make-instance 'qd-complex - :real (qd-value (add1 (realpart a))) + :real (add-qd-d (qd-value (realpart a)) 1d0) + :imag (qd-value (imagpart a)))) + +(defmethod sub1 ((a qd-complex)) + (make-instance 'qd-complex + :real (sub-qd-d (qd-value (realpart a)) 1d0) :imag (qd-value (imagpart a)))) (defmethod two-arg-/ ((a qd-real) (b rational)) @@ -230,6 +232,33 @@ (defmethod coerce ((number qd-complex) (type (eql 'qd-complex))) number) +;; These two macros are borrowed from CMUCL. +(defmacro incf (place &optional (delta 1) &environment env) + "The first argument is some location holding a number. This number is + incremented by the second argument, DELTA, which defaults to 1." + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place env) + (let ((d (gensym))) + `(let* (,@(mapcar #'list dummies vals) + (,d ,delta) + (,(car newval) (+ ,getter ,d))) + ,setter)))) + +(defmacro decf (place &optional (delta 1) &environment env) + "The first argument is some location holding a number. This number is + decremented by the second argument, DELTA, which defaults to 1." + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place env) + (let ((d (gensym))) + `(let* (,@(mapcar #'list dummies vals) + (,d ,delta) + (,(car newval) (- ,getter ,d))) + ,setter)))) + + +;; Most of this code taken from CMUCL and slightly modified to support +;; QD-COMPLEX. + (declaim (inline square)) (defun square (x) (declare (type qd-real x)) @@ -604,6 +633,7 @@ (result (qd-complex-tanh iz))) (complex (imagpart result) (- (realpart result))))) +;; End of implementation of complex functions from CMUCL. (defmethod qasin ((x qd-complex)) (qd-complex-asin x)) --- /project/oct/cvsroot/oct/qd-package.lisp 2007/08/28 00:56:18 1.34 +++ /project/oct/cvsroot/oct/qd-package.lisp 2007/08/28 16:01:08 1.35 @@ -157,6 +157,11 @@ #:signum #:coerce #:random + #:realp + #:complexp + #:numberp + #:incf + #:decf ) (:export #:+ #:- @@ -218,6 +223,8 @@ #:realp #:complexp #:numberp + #:incf + #:decf ) ;; Constants (:export #:+pi+)

1 0