Initial import of Calc 2.02f.

1 files changed, 2924 insertions, 0 deletions

diff --git a/lisp/calc/calc-arith.el b/lisp/calc/calc-arith.el
new file mode 100644
index 0000000000..6673238187
--- /dev/null
+++ b/lisp/calc/calc-arith.el
@@ -0,0 +1,2924 @@
+;; Calculator for GNU Emacs, part II [calc-arith.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY.  No author or distributor
+;; accepts responsibility to anyone for the consequences of using it
+;; or for whether it serves any particular purpose or works at all,
+;; unless he says so in writing.  Refer to the GNU Emacs General Public
+;; License for full details.
+
+;; Everyone is granted permission to copy, modify and redistribute
+;; GNU Emacs, but only under the conditions described in the
+;; GNU Emacs General Public License.   A copy of this license is
+;; supposed to have been given to you along with GNU Emacs so you
+;; can know your rights and responsibilities.  It should be in a
+;; file named COPYING.  Among other things, the copyright notice
+;; and this notice must be preserved on all copies.
+
+
+
+;; This file is autoloaded from calc-ext.el.
+(require 'calc-ext)
+
+(require 'calc-macs)
+
+(defun calc-Need-calc-arith () nil)
+
+
+;;; Arithmetic.
+
+(defun calc-min (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (calc-binary-op "min" 'calcFunc-min arg '(var inf var-inf)))
+)
+
+(defun calc-max (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (calc-binary-op "max" 'calcFunc-max arg '(neg (var inf var-inf))))
+)
+
+(defun calc-abs (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (calc-unary-op "abs" 'calcFunc-abs arg))
+)
+
+
+(defun calc-idiv (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (calc-binary-op "\\" 'calcFunc-idiv arg 1))
+)
+
+
+(defun calc-floor (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (if (calc-is-inverse)
+       (if (calc-is-hyperbolic)
+	   (calc-unary-op "ceil" 'calcFunc-fceil arg)
+	 (calc-unary-op "ceil" 'calcFunc-ceil arg))
+     (if (calc-is-hyperbolic)
+	 (calc-unary-op "flor" 'calcFunc-ffloor arg)
+       (calc-unary-op "flor" 'calcFunc-floor arg))))
+)
+
+(defun calc-ceiling (arg)
+  (interactive "P")
+  (calc-invert-func)
+  (calc-floor arg)
+)
+
+(defun calc-round (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (if (calc-is-inverse)
+       (if (calc-is-hyperbolic)
+	   (calc-unary-op "trnc" 'calcFunc-ftrunc arg)
+	 (calc-unary-op "trnc" 'calcFunc-trunc arg))
+     (if (calc-is-hyperbolic)
+	 (calc-unary-op "rond" 'calcFunc-fround arg)
+       (calc-unary-op "rond" 'calcFunc-round arg))))
+)
+
+(defun calc-trunc (arg)
+  (interactive "P")
+  (calc-invert-func)
+  (calc-round arg)
+)
+
+(defun calc-mant-part (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (calc-unary-op "mant" 'calcFunc-mant arg))
+)
+
+(defun calc-xpon-part (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (calc-unary-op "xpon" 'calcFunc-xpon arg))
+)
+
+(defun calc-scale-float (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (calc-binary-op "scal" 'calcFunc-scf arg))
+)
+
+(defun calc-abssqr (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (calc-unary-op "absq" 'calcFunc-abssqr arg))
+)
+
+(defun calc-sign (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (calc-unary-op "sign" 'calcFunc-sign arg))
+)
+
+(defun calc-increment (arg)
+  (interactive "p")
+  (calc-wrapper
+   (calc-enter-result 1 "incr" (list 'calcFunc-incr (calc-top-n 1) arg)))
+)
+
+(defun calc-decrement (arg)
+  (interactive "p")
+  (calc-wrapper
+   (calc-enter-result 1 "decr" (list 'calcFunc-decr (calc-top-n 1) arg)))
+)
+
+
+(defun math-abs-approx (a)
+  (cond ((Math-negp a)
+	 (math-neg a))
+	((Math-anglep a)
+	 a)
+	((eq (car a) 'cplx)
+	 (math-add (math-abs (nth 1 a)) (math-abs (nth 2 a))))
+	((eq (car a) 'polar)
+	 (nth 1 a))
+	((eq (car a) 'sdev)
+	 (math-abs-approx (nth 1 a)))
+	((eq (car a) 'intv)
+	 (math-max (math-abs (nth 2 a)) (math-abs (nth 3 a))))
+	((eq (car a) 'date)
+	 a)
+	((eq (car a) 'vec)
+	 (math-reduce-vec 'math-add-abs-approx a))
+	((eq (car a) 'calcFunc-abs)
+	 (car a))
+	(t a))
+)
+
+(defun math-add-abs-approx (a b)
+  (math-add (math-abs-approx a) (math-abs-approx b))
+)
+
+
+;;;; Declarations.
+
+(setq math-decls-cache-tag nil)
+(setq math-decls-cache nil)
+(setq math-decls-all nil)
+
+;;; Math-decls-cache is an a-list where each entry is a list of the form:
+;;;   (VAR TYPES RANGE)
+;;; where VAR is a variable name (with var- prefix) or function name;
+;;;       TYPES is a list of type symbols (any, int, frac, ...)
+;;;	  RANGE is a sorted vector of intervals describing the range.
+
+(defun math-setup-declarations ()
+  (or (eq math-decls-cache-tag (calc-var-value 'var-Decls))
+      (let ((p (calc-var-value 'var-Decls))
+	    vec type range)
+	(setq math-decls-cache-tag p
+	      math-decls-cache nil)
+	(and (eq (car-safe p) 'vec)
+	     (while (setq p (cdr p))
+	       (and (eq (car-safe (car p)) 'vec)
+		    (setq vec (nth 2 (car p)))
+		    (condition-case err
+			(let ((v (nth 1 (car p))))
+			  (setq type nil range nil)
+			  (or (eq (car-safe vec) 'vec)
+			      (setq vec (list 'vec vec)))
+			  (while (and (setq vec (cdr vec))
+				      (not (Math-objectp (car vec))))
+			    (and (eq (car-safe (car vec)) 'var)
+				 (let ((st (assq (nth 1 (car vec))
+						 math-super-types)))
+				   (cond (st (setq type (append type st)))
+					 ((eq (nth 1 (car vec)) 'pos)
+					  (setq type (append type
+							     '(real number))
+						range
+						'(intv 1 0 (var inf var-inf))))
+					 ((eq (nth 1 (car vec)) 'nonneg)
+					  (setq type (append type
+							     '(real number))
+						range
+						'(intv 3 0
+						       (var inf var-inf))))))))
+			  (if vec
+			      (setq type (append type '(real number))
+				    range (math-prepare-set (cons 'vec vec))))
+			  (setq type (list type range))
+			  (or (eq (car-safe v) 'vec)
+			      (setq v (list 'vec v)))
+			  (while (setq v (cdr v))
+			    (if (or (eq (car-safe (car v)) 'var)
+				    (not (Math-primp (car v))))
+				(setq math-decls-cache
+				      (cons (cons (if (eq (car (car v)) 'var)
+						      (nth 2 (car v))
+						    (car (car v)))
+						  type)
+					    math-decls-cache)))))
+		      (error nil)))))
+	(setq math-decls-all (assq 'var-All math-decls-cache))))
+)
+
+(defvar math-super-types
+  '( ( int     numint rat real number )
+     ( numint  real number )
+     ( frac    rat real number )
+     ( rat     real number )
+     ( float   real number )
+     ( real    number )
+     ( number  )
+     ( scalar  )
+     ( matrix  vector )
+     ( vector )
+     ( const )
+))
+
+
+(defun math-known-scalarp (a &optional assume-scalar)
+  (math-setup-declarations)
+  (if (if calc-matrix-mode
+	  (eq calc-matrix-mode 'scalar)
+	assume-scalar)
+      (not (math-check-known-matrixp a))
+    (math-check-known-scalarp a))
+)
+
+(defun math-known-matrixp (a)
+  (and (not (Math-scalarp a))
+       (not (math-known-scalarp a t)))
+)
+
+;;; Try to prove that A is a scalar (i.e., a non-vector).
+(defun math-check-known-scalarp (a)
+  (cond ((Math-objectp a) t)
+	((memq (car a) math-scalar-functions)
+	 t)
+	((memq (car a) math-real-scalar-functions)
+	 t)
+	((memq (car a) math-scalar-if-args-functions)
+	 (while (and (setq a (cdr a))
+		     (math-check-known-scalarp (car a))))
+	 (null a))
+	((eq (car a) '^)
+	 (math-check-known-scalarp (nth 1 a)))
+	((math-const-var a) t)
+	(t
+	 (let ((decl (if (eq (car a) 'var)
+			 (or (assq (nth 2 a) math-decls-cache)
+			     math-decls-all)
+		       (assq (car a) math-decls-cache))))
+	   (memq 'scalar (nth 1 decl)))))
+)
+
+;;; Try to prove that A is *not* a scalar.
+(defun math-check-known-matrixp (a)
+  (cond ((Math-objectp a) nil)
+	((memq (car a) math-nonscalar-functions)
+	 t)
+	((memq (car a) math-scalar-if-args-functions)
+	 (while (and (setq a (cdr a))
+		     (not (math-check-known-matrixp (car a)))))
+	 a)
+	((eq (car a) '^)
+	 (math-check-known-matrixp (nth 1 a)))
+	((math-const-var a) nil)
+	(t
+	 (let ((decl (if (eq (car a) 'var)
+			 (or (assq (nth 2 a) math-decls-cache)
+			     math-decls-all)
+		       (assq (car a) math-decls-cache))))
+	   (memq 'vector (nth 1 decl)))))
+)
+
+
+;;; Try to prove that A is a real (i.e., not complex).
+(defun math-known-realp (a)
+  (< (math-possible-signs a) 8)
+)
+
+;;; Try to prove that A is real and positive.
+(defun math-known-posp (a)
+  (eq (math-possible-signs a) 4)
+)
+
+;;; Try to prove that A is real and negative.
+(defun math-known-negp (a)
+  (eq (math-possible-signs a) 1)
+)
+
+;;; Try to prove that A is real and nonnegative.
+(defun math-known-nonnegp (a)
+  (memq (math-possible-signs a) '(2 4 6))
+)
+
+;;; Try to prove that A is real and nonpositive.
+(defun math-known-nonposp (a)
+  (memq (math-possible-signs a) '(1 2 3))
+)
+
+;;; Try to prove that A is nonzero.
+(defun math-known-nonzerop (a)
+  (memq (math-possible-signs a) '(1 4 5 8 9 12 13))
+)
+
+;;; Return true if A is negative, or looks negative but we don't know.
+(defun math-guess-if-neg (a)
+  (let ((sgn (math-possible-signs a)))
+    (if (memq sgn '(1 3))
+	t
+      (if (memq sgn '(2 4 6))
+	  nil
+	(math-looks-negp a))))
+)
+
+;;; Find the possible signs of A, assuming A is a number of some kind.
+;;; Returns an integer with bits:  1  may be negative,
+;;;				   2  may be zero,
+;;;				   4  may be positive,
+;;;				   8  may be nonreal.
+
+(defun math-possible-signs (a &optional origin)
+  (cond ((Math-objectp a)
+	 (if origin (setq a (math-sub a origin)))
+	 (cond ((Math-posp a) 4)
+	       ((Math-negp a) 1)
+	       ((Math-zerop a) 2)
+	       ((eq (car a) 'intv)
+		(cond ((Math-zerop (nth 2 a)) 6)
+		      ((Math-zerop (nth 3 a)) 3)
+		      (t 7)))
+	       ((eq (car a) 'sdev)
+		(if (math-known-realp (nth 1 a)) 7 15))
+	       (t 8)))
+	((memq (car a) '(+ -))
+	 (cond ((Math-realp (nth 1 a))
+		(if (eq (car a) '-)
+		    (math-neg-signs
+		     (math-possible-signs (nth 2 a)
+					  (if origin
+					      (math-add origin (nth 1 a))
+					    (nth 1 a))))
+		  (math-possible-signs (nth 2 a)
+				       (if origin
+					   (math-sub origin (nth 1 a))
+					 (math-neg (nth 1 a))))))
+	       ((Math-realp (nth 2 a))
+		(let ((org (if (eq (car a) '-)
+			       (nth 2 a)
+			     (math-neg (nth 2 a)))))
+		  (math-possible-signs (nth 1 a)
+				       (if origin
+					   (math-add origin org)
+					 org))))
+	       (t
+		(let ((s1 (math-possible-signs (nth 1 a) origin))
+		      (s2 (math-possible-signs (nth 2 a))))
+		  (if (eq (car a) '-) (setq s2 (math-neg-signs s2)))
+		  (cond ((eq s1 s2) s1)
+			((eq s1 2) s2)
+			((eq s2 2) s1)
+			((>= s1 8) 15)
+			((>= s2 8) 15)
+			((and (eq s1 4) (eq s2 6)) 4)
+			((and (eq s2 4) (eq s1 6)) 4)
+			((and (eq s1 1) (eq s2 3)) 1)
+			((and (eq s2 1) (eq s1 3)) 1)
+			(t 7))))))
+	((eq (car a) 'neg)
+	 (math-neg-signs (math-possible-signs
+			  (nth 1 a)
+			  (and origin (math-neg origin)))))
+	((and origin (Math-zerop origin) (setq origin nil)
+	      nil))
+	((and (or (eq (car a) '*)
+		  (and (eq (car a) '/) origin))
+	      (Math-realp (nth 1 a)))
+	 (let ((s (if (eq (car a) '*)
+		      (if (Math-zerop (nth 1 a))
+			  (math-possible-signs 0 origin)
+			(math-possible-signs (nth 2 a)
+					     (math-div (or origin 0)
+						       (nth 1 a))))
+		    (math-neg-signs
+		     (math-possible-signs (nth 2 a)
+					  (math-div (nth 1 a)
+						    origin))))))
+	   (if (Math-negp (nth 1 a)) (math-neg-signs s) s)))
+	((and (memq (car a) '(* /)) (Math-realp (nth 2 a)))
+	 (let ((s (math-possible-signs (nth 1 a)
+				       (if (eq (car a) '*)
+					   (math-mul (or origin 0) (nth 2 a))
+					 (math-div (or origin 0) (nth 2 a))))))
+	   (if (Math-negp (nth 2 a)) (math-neg-signs s) s)))
+	((eq (car a) 'vec)
+	 (let ((signs 0))
+	   (while (and (setq a (cdr a)) (< signs 15))
+	     (setq signs (logior signs (math-possible-signs
+					(car a) origin))))
+	   signs))
+	(t (let ((sign
+		  (cond
+		   ((memq (car a) '(* /))
+		    (let ((s1 (math-possible-signs (nth 1 a)))
+			  (s2 (math-possible-signs (nth 2 a))))
+		      (cond ((>= s1 8) 15)
+			    ((>= s2 8) 15)
+			    ((and (eq (car a) '/) (memq s2 '(2 3 6 7))) 15)
+			    (t
+			     (logior (if (memq s1 '(4 5 6 7)) s2 0)
+				     (if (memq s1 '(2 3 6 7)) 2 0)
+				     (if (memq s1 '(1 3 5 7))
+					 (math-neg-signs s2) 0))))))
+		   ((eq (car a) '^)
+		    (let ((s1 (math-possible-signs (nth 1 a)))
+			  (s2 (math-possible-signs (nth 2 a))))
+		      (cond ((>= s1 8) 15)
+			    ((>= s2 8) 15)
+			    ((eq s1 4) 4)
+			    ((eq s1 2) (if (eq s2 4) 2 15))
+			    ((eq s2 2) (if (memq s1 '(1 5)) 2 15))
+			    ((Math-integerp (nth 2 a))
+			     (if (math-evenp (nth 2 a))
+				 (if (memq s1 '(3 6 7)) 6 4)
+			       s1))
+			    ((eq s1 6) (if (eq s2 4) 6 15))
+			    (t 7))))
+		   ((eq (car a) '%)
+		    (let ((s2 (math-possible-signs (nth 2 a))))
+		      (cond ((>= s2 8) 7)
+			    ((eq s2 2) 2)
+			    ((memq s2 '(4 6)) 6)
+			    ((memq s2 '(1 3)) 3)
+			    (t 7))))
+		   ((and (memq (car a) '(calcFunc-abs calcFunc-abssqr))
+			 (= (length a) 2))
+		    (let ((s1 (math-possible-signs (nth 1 a))))
+		      (cond ((eq s1 2) 2)
+			    ((memq s1 '(1 4 5)) 4)
+			    (t 6))))
+		   ((and (eq (car a) 'calcFunc-exp) (= (length a) 2))
+		    (let ((s1 (math-possible-signs (nth 1 a))))
+		      (if (>= s1 8)
+			  15
+			(if (or (not origin) (math-negp origin))
+			    4
+			  (setq origin (math-sub (or origin 0) 1))
+			  (if (Math-zerop origin) (setq origin nil))
+			  s1))))
+		   ((or (and (memq (car a) '(calcFunc-ln calcFunc-log10))
+			     (= (length a) 2))
+			(and (eq (car a) 'calcFunc-log)
+			     (= (length a) 3)
+			     (math-known-posp (nth 2 a))))
+		    (if (math-known-nonnegp (nth 1 a))
+			(math-possible-signs (nth 1 a) 1)
+		      15))
+		   ((and (eq (car a) 'calcFunc-sqrt) (= (length a) 2))
+		    (let ((s1 (math-possible-signs (nth 1 a))))
+		      (if (memq s1 '(2 4 6)) s1 15)))
+		   ((memq (car a) math-nonnegative-functions) 6)
+		   ((memq (car a) math-positive-functions) 4)
+		   ((memq (car a) math-real-functions) 7)
+		   ((memq (car a) math-real-scalar-functions) 7)
+		   ((and (memq (car a) math-real-if-arg-functions)
+			 (= (length a) 2))
+		    (if (math-known-realp (nth 1 a)) 7 15)))))
+	     (cond (sign
+		    (if origin
+			(+ (logand sign 8)
+			   (if (Math-posp origin)
+			       (if (memq sign '(1 2 3 8 9 10 11)) 1 7)
+			     (if (memq sign '(2 4 6 8 10 12 14)) 4 7)))
+		      sign))
+		   ((math-const-var a)
+		    (cond ((eq (nth 2 a) 'var-pi)
+			   (if origin
+			       (math-possible-signs (math-pi) origin)
+			     4))
+			  ((eq (nth 2 a) 'var-e)
+			   (if origin
+			       (math-possible-signs (math-e) origin)
+			     4))
+			  ((eq (nth 2 a) 'var-inf) 4)
+			  ((eq (nth 2 a) 'var-uinf) 13)
+			  ((eq (nth 2 a) 'var-i) 8)
+			  (t 15)))
+		   (t
+		    (math-setup-declarations)
+		    (let ((decl (if (eq (car a) 'var)
+				    (or (assq (nth 2 a) math-decls-cache)
+					math-decls-all)
+				  (assq (car a) math-decls-cache))))
+		      (if (and origin
+			       (memq 'int (nth 1 decl))
+			       (not (Math-num-integerp origin)))
+			  5
+			(if (nth 2 decl)
+			    (math-possible-signs (nth 2 decl) origin)
+			  (if (memq 'real (nth 1 decl))
+			      7
+			    15)))))))))
+)
+
+(defun math-neg-signs (s1)
+  (if (>= s1 8)
+      (+ 8 (math-neg-signs (- s1 8)))
+    (+ (if (memq s1 '(1 3 5 7)) 4 0)
+       (if (memq s1 '(2 3 6 7)) 2 0)
+       (if (memq s1 '(4 5 6 7)) 1 0)))
+)
+
+
+;;; Try to prove that A is an integer.
+(defun math-known-integerp (a)
+  (eq (math-possible-types a) 1)
+)
+
+(defun math-known-num-integerp (a)
+  (<= (math-possible-types a t) 3)
+)
+
+(defun math-known-imagp (a)
+  (= (math-possible-types a) 16)
+)
+
+
+;;; Find the possible types of A.
+;;; Returns an integer with bits:  1  may be integer.
+;;;				   2  may be integer-valued float.
+;;;				   4  may be fraction.
+;;;				   8  may be non-integer-valued float.
+;;;				  16  may be imaginary.
+;;;				  32  may be non-real, non-imaginary.
+;;; Real infinities count as integers for the purposes of this function.
+(defun math-possible-types (a &optional num)
+  (cond ((Math-objectp a)
+	 (cond ((Math-integerp a) (if num 3 1))
+	       ((Math-messy-integerp a) (if num 3 2))
+	       ((eq (car a) 'frac) (if num 12 4))
+	       ((eq (car a) 'float) (if num 12 8))
+	       ((eq (car a) 'intv)
+		(if (equal (nth 2 a) (nth 3 a))
+		    (math-possible-types (nth 2 a))
+		  15))
+	       ((eq (car a) 'sdev)
+		(if (math-known-realp (nth 1 a)) 15 63))
+	       ((eq (car a) 'cplx)
+		(if (math-zerop (nth 1 a)) 16 32))
+	       ((eq (car a) 'polar)
+		(if (or (Math-equal (nth 2 a) (math-quarter-circle nil))
+			(Math-equal (nth 2 a)
+				    (math-neg (math-quarter-circle nil))))
+		    16 48))
+	       (t 63)))
+	((eq (car a) '/)
+	 (let* ((t1 (math-possible-types (nth 1 a) num))
+		(t2 (math-possible-types (nth 2 a) num))
+		(t12 (logior t1 t2)))
+	   (if (< t12 16)
+	       (if (> (logand t12 10) 0)
+		   10
+		 (if (or (= t1 4) (= t2 4) calc-prefer-frac)
+		     5
+		   15))
+	     (if (< t12 32)
+		 (if (= t1 16)
+		     (if (= t2 16) 15
+		       (if (< t2 16) 16 31))
+		   (if (= t2 16)
+		       (if (< t1 16) 16 31)
+		     31))
+	       63))))
+	((memq (car a) '(+ - * %))
+	 (let* ((t1 (math-possible-types (nth 1 a) num))
+		(t2 (math-possible-types (nth 2 a) num))
+		(t12 (logior t1 t2)))
+	   (if (eq (car a) '%)
+	       (setq t1 (logand t1 15) t2 (logand t2 15) t12 (logand t12 15)))
+	   (if (< t12 16)
+	       (let ((mask (if (<= t12 3)
+			       1
+			     (if (and (or (and (<= t1 3) (= (logand t2 3) 0))
+					  (and (<= t2 3) (= (logand t1 3) 0)))
+				      (memq (car a) '(+ -)))
+				 4
+			       5))))
+		 (if num
+		     (* mask 3)
+		   (logior (if (and (> (logand t1 5) 0) (> (logand t2 5) 0))
+			       mask 0)
+			   (if (> (logand t12 10) 0)
+			       (* mask 2) 0))))
+	     (if (< t12 32)
+		 (if (eq (car a) '*)
+		     (if (= t1 16)
+			 (if (= t2 16) 15
+			   (if (< t2 16) 16 31))
+		       (if (= t2 16)
+			   (if (< t1 16) 16 31)
+			 31))
+		   (if (= t12 16) 16
+		     (if (or (and (= t1 16) (< t2 16))
+			     (and (= t2 16) (< t1 16))) 32 63)))
+	       63))))
+	((eq (car a) 'neg)
+	 (math-possible-types (nth 1 a)))
+	((eq (car a) '^)
+	 (let* ((t1 (math-possible-types (nth 1 a) num))
+		(t2 (math-possible-types (nth 2 a) num))
+		(t12 (logior t1 t2)))
+	   (if (and (<= t2 3) (math-known-nonnegp (nth 2 a)) (< t1 16))
+	       (let ((mask (logior (if (> (logand t1 3) 0) 1 0)
+				   (logand t1 4)
+				   (if (> (logand t1 12) 0) 5 0))))
+		 (if num
+		     (* mask 3)
+		   (logior (if (and (> (logand t1 5) 0) (> (logand t2 5) 0))
+			       mask 0)
+			   (if (> (logand t12 10) 0)
+			       (* mask 2) 0))))
+	     (if (and (math-known-nonnegp (nth 1 a))
+		      (math-known-posp (nth 2 a)))
+		 15
+	       63))))
+	((eq (car a) 'calcFunc-sqrt)
+	 (let ((t1 (math-possible-signs (nth 1 a))))
+	   (logior (if (> (logand t1 2) 0) 3 0)
+		   (if (> (logand t1 1) 0) 16 0)
+		   (if (> (logand t1 4) 0) 15 0)
+		   (if (> (logand t1 8) 0) 32 0))))
+	((eq (car a) 'vec)
+	 (let ((types 0))
+	   (while (and (setq a (cdr a)) (< types 63))
+	     (setq types (logior types (math-possible-types (car a) t))))
+	   types))
+	((or (memq (car a) math-integer-functions)
+	     (and (memq (car a) math-rounding-functions)
+		  (math-known-nonnegp (or (nth 2 a) 0))))
+	 1)
+	((or (memq (car a) math-num-integer-functions)
+	     (and (memq (car a) math-float-rounding-functions)
+		  (math-known-nonnegp (or (nth 2 a) 0))))
+	 2)
+	((eq (car a) 'calcFunc-frac)
+	 5)
+	((and (eq (car a) 'calcFunc-float) (= (length a) 2))
+	 (let ((t1 (math-possible-types (nth 1 a))))
+	   (logior (if (> (logand t1 3) 0) 2 0)
+		   (if (> (logand t1 12) 0) 8 0)
+		   (logand t1 48))))
+	((and (memq (car a) '(calcFunc-abs calcFunc-abssqr))
+	      (= (length a) 2))
+	 (let ((t1 (math-possible-types (nth 1 a))))
+	   (if (>= t1 16)
+	       15
+	     t1)))
+	((math-const-var a)
+	 (cond ((memq (nth 2 a) '(var-e var-pi var-phi var-gamma)) 8)
+	       ((eq (nth 2 a) 'var-inf) 1)
+	       ((eq (nth 2 a) 'var-i) 16)
+	       (t 63)))
+	(t
+	 (math-setup-declarations)
+	 (let ((decl (if (eq (car a) 'var)
+			 (or (assq (nth 2 a) math-decls-cache)
+			     math-decls-all)
+		       (assq (car a) math-decls-cache))))
+	   (cond ((memq 'int (nth 1 decl))
+		  1)
+		 ((memq 'numint (nth 1 decl))
+		  3)
+		 ((memq 'frac (nth 1 decl))
+		  4)
+		 ((memq 'rat (nth 1 decl))
+		  5)
+		 ((memq 'float (nth 1 decl))
+		  10)
+		 ((nth 2 decl)
+		  (math-possible-types (nth 2 decl)))
+		 ((memq 'real (nth 1 decl))
+		  15)
+		 (t 63)))))
+)
+
+(defun math-known-evenp (a)
+  (cond ((Math-integerp a)
+	 (math-evenp a))
+	((Math-messy-integerp a)
+	 (or (> (nth 2 a) 0)
+	     (math-evenp (math-trunc a))))
+	((eq (car a) '*)
+	 (if (math-known-evenp (nth 1 a))
+	     (math-known-num-integerp (nth 2 a))
+	   (if (math-known-num-integerp (nth 1 a))
+	       (math-known-evenp (nth 2 a)))))
+	((memq (car a) '(+ -))
+	 (or (and (math-known-evenp (nth 1 a))
+		  (math-known-evenp (nth 2 a)))
+	     (and (math-known-oddp (nth 1 a))
+		  (math-known-oddp (nth 2 a)))))
+	((eq (car a) 'neg)
+	 (math-known-evenp (nth 1 a))))
+)
+
+(defun math-known-oddp (a)
+  (cond ((Math-integerp a)
+	 (math-oddp a))
+	((Math-messy-integerp a)
+	 (and (<= (nth 2 a) 0)
+	      (math-oddp (math-trunc a))))
+	((memq (car a) '(+ -))
+	 (or (and (math-known-evenp (nth 1 a))
+		  (math-known-oddp (nth 2 a)))
+	     (and (math-known-oddp (nth 1 a))
+		  (math-known-evenp (nth 2 a)))))
+	((eq (car a) 'neg)
+	 (math-known-oddp (nth 1 a))))
+)
+
+
+(defun calcFunc-dreal (expr)
+  (let ((types (math-possible-types expr)))
+    (if (< types 16) 1
+      (if (= (logand types 15) 0) 0
+	(math-reject-arg expr 'realp 'quiet))))
+)
+
+(defun calcFunc-dimag (expr)
+  (let ((types (math-possible-types expr)))
+    (if (= types 16) 1
+      (if (= (logand types 16) 0) 0
+	(math-reject-arg expr "Expected an imaginary number"))))
+)
+
+(defun calcFunc-dpos (expr)
+  (let ((signs (math-possible-signs expr)))
+    (if (eq signs 4) 1
+      (if (memq signs '(1 2 3)) 0
+	(math-reject-arg expr 'posp 'quiet))))
+)
+
+(defun calcFunc-dneg (expr)
+  (let ((signs (math-possible-signs expr)))
+    (if (eq signs 1) 1
+      (if (memq signs '(2 4 6)) 0
+	(math-reject-arg expr 'negp 'quiet))))
+)
+
+(defun calcFunc-dnonneg (expr)
+  (let ((signs (math-possible-signs expr)))
+    (if (memq signs '(2 4 6)) 1
+      (if (eq signs 1) 0
+	(math-reject-arg expr 'posp 'quiet))))
+)
+
+(defun calcFunc-dnonzero (expr)
+  (let ((signs (math-possible-signs expr)))
+    (if (memq signs '(1 4 5 8 9 12 13)) 1
+      (if (eq signs 2) 0
+	(math-reject-arg expr 'nonzerop 'quiet))))
+)
+
+(defun calcFunc-dint (expr)
+  (let ((types (math-possible-types expr)))
+    (if (= types 1) 1
+      (if (= (logand types 1) 0) 0
+	(math-reject-arg expr 'integerp 'quiet))))
+)
+
+(defun calcFunc-dnumint (expr)
+  (let ((types (math-possible-types expr t)))
+    (if (<= types 3) 1
+      (if (= (logand types 3) 0) 0
+	(math-reject-arg expr 'integerp 'quiet))))
+)
+
+(defun calcFunc-dnatnum (expr)
+  (let ((res (calcFunc-dint expr)))
+    (if (eq res 1)
+	(calcFunc-dnonneg expr)
+      res))
+)
+
+(defun calcFunc-deven (expr)
+  (if (math-known-evenp expr)
+      1
+    (if (or (math-known-oddp expr)
+	    (= (logand (math-possible-types expr) 3) 0))
+	0
+      (math-reject-arg expr "Can't tell if expression is odd or even")))
+)
+
+(defun calcFunc-dodd (expr)
+  (if (math-known-oddp expr)
+      1
+    (if (or (math-known-evenp expr)
+	    (= (logand (math-possible-types expr) 3) 0))
+	0
+      (math-reject-arg expr "Can't tell if expression is odd or even")))
+)
+
+(defun calcFunc-drat (expr)
+  (let ((types (math-possible-types expr)))
+    (if (memq types '(1 4 5)) 1
+      (if (= (logand types 5) 0) 0
+	(math-reject-arg expr "Rational number expected"))))
+)
+
+(defun calcFunc-drange (expr)
+  (math-setup-declarations)
+  (let (range)
+    (if (Math-realp expr)
+	(list 'vec expr)
+      (if (eq (car-safe expr) 'intv)
+	  expr
+	(if (eq (car-safe expr) 'var)
+	    (setq range (nth 2 (or (assq (nth 2 expr) math-decls-cache)
+				   math-decls-all)))
+	  (setq range (nth 2 (assq (car-safe expr) math-decls-cache))))
+	(if range
+	    (math-clean-set (copy-sequence range))
+	  (setq range (math-possible-signs expr))
+	  (if (< range 8)
+	      (aref [(vec)
+		     (intv 2 (neg (var inf var-inf)) 0)
+		     (vec 0)
+		     (intv 3 (neg (var inf var-inf)) 0)
+		     (intv 1 0 (var inf var-inf))
+		     (vec (intv 2 (neg (var inf var-inf)) 0)
+			  (intv 1 0 (var inf var-inf)))
+		     (intv 3 0 (var inf var-inf))
+		     (intv 3 (neg (var inf var-inf)) (var inf var-inf))] range)
+	    (math-reject-arg expr 'realp 'quiet))))))
+)
+
+(defun calcFunc-dscalar (a)
+  (if (math-known-scalarp a) 1
+    (if (math-known-matrixp a) 0
+      (math-reject-arg a 'objectp 'quiet)))
+)
+
+
+;;; The following lists are not exhaustive.
+(defvar math-scalar-functions '(calcFunc-det
+				calcFunc-cnorm calcFunc-rnorm
+				calcFunc-vlen calcFunc-vcount
+				calcFunc-vsum calcFunc-vprod
+				calcFunc-vmin calcFunc-vmax
+))
+
+(defvar math-nonscalar-functions '(vec calcFunc-idn calcFunc-diag
+				       calcFunc-cvec calcFunc-index
+				       calcFunc-trn
+				       | calcFunc-append
+				       calcFunc-cons calcFunc-rcons
+				       calcFunc-tail calcFunc-rhead
+))
+
+(defvar math-scalar-if-args-functions '(+ - * / neg))
+
+(defvar math-real-functions '(calcFunc-arg
+			      calcFunc-re calcFunc-im
+			      calcFunc-floor calcFunc-ceil
+			      calcFunc-trunc calcFunc-round
+			      calcFunc-rounde calcFunc-roundu
+			      calcFunc-ffloor calcFunc-fceil
+			      calcFunc-ftrunc calcFunc-fround
+			      calcFunc-frounde calcFunc-froundu
+))
+
+(defvar math-positive-functions '(
+))
+
+(defvar math-nonnegative-functions '(calcFunc-cnorm calcFunc-rnorm
+				     calcFunc-vlen calcFunc-vcount
+))
+
+(defvar math-real-scalar-functions '(% calcFunc-idiv calcFunc-abs
+				       calcFunc-choose calcFunc-perm
+				       calcFunc-eq calcFunc-neq
+				       calcFunc-lt calcFunc-gt
+				       calcFunc-leq calcFunc-geq
+				       calcFunc-lnot
+				       calcFunc-max calcFunc-min
+))
+
+(defvar math-real-if-arg-functions '(calcFunc-sin calcFunc-cos
+				     calcFunc-tan calcFunc-arctan
+				     calcFunc-sinh calcFunc-cosh
+				     calcFunc-tanh calcFunc-exp
+				     calcFunc-gamma calcFunc-fact
+))
+
+(defvar math-integer-functions '(calcFunc-idiv
+				 calcFunc-isqrt calcFunc-ilog
+				 calcFunc-vlen calcFunc-vcount
+))
+
+(defvar math-num-integer-functions '(
+))
+
+(defvar math-rounding-functions '(calcFunc-floor
+				  calcFunc-ceil
+				  calcFunc-round calcFunc-trunc
+				  calcFunc-rounde calcFunc-roundu
+))
+
+(defvar math-float-rounding-functions '(calcFunc-ffloor
+					calcFunc-fceil
+					calcFunc-fround calcFunc-ftrunc
+					calcFunc-frounde calcFunc-froundu
+))
+
+(defvar math-integer-if-args-functions '(+ - * % neg calcFunc-abs
+					   calcFunc-min calcFunc-max
+					   calcFunc-choose calcFunc-perm
+))
+
+
+;;;; Arithmetic.
+
+(defun calcFunc-neg (a)
+  (math-normalize (list 'neg a))
+)
+
+(defun math-neg-fancy (a)
+  (cond ((eq (car a) 'polar)
+	 (list 'polar
+	       (nth 1 a)
+	       (if (math-posp (nth 2 a))
+		   (math-sub (nth 2 a) (math-half-circle nil))
+		 (math-add (nth 2 a) (math-half-circle nil)))))
+	((eq (car a) 'mod)
+	 (if (math-zerop (nth 1 a))
+	     a
+	   (list 'mod (math-sub (nth 2 a) (nth 1 a)) (nth 2 a))))
+	((eq (car a) 'sdev)
+	 (list 'sdev (math-neg (nth 1 a)) (nth 2 a)))
+	((eq (car a) 'intv)
+	 (math-make-intv (aref [0 2 1 3] (nth 1 a))
+			 (math-neg (nth 3 a))
+			 (math-neg (nth 2 a))))
+	((and math-simplify-only
+	      (not (equal a math-simplify-only)))
+	 (list 'neg a))
+	((eq (car a) '+)
+	 (math-sub (math-neg (nth 1 a)) (nth 2 a)))
+	((eq (car a) '-)
+	 (math-sub (nth 2 a) (nth 1 a)))
+	((and (memq (car a) '(* /))
+	      (math-okay-neg (nth 1 a)))
+	 (list (car a) (math-neg (nth 1 a)) (nth 2 a)))
+	((and (memq (car a) '(* /))
+	      (math-okay-neg (nth 2 a)))
+	 (list (car a) (nth 1 a) (math-neg (nth 2 a))))
+	((and (memq (car a) '(* /))
+	      (or (math-objectp (nth 1 a))
+		  (and (eq (car (nth 1 a)) '*)
+		       (math-objectp (nth 1 (nth 1 a))))))
+	 (list (car a) (math-neg (nth 1 a)) (nth 2 a)))
+	((and (eq (car a) '/)
+	      (or (math-objectp (nth 2 a))
+		  (and (eq (car (nth 2 a)) '*)
+		       (math-objectp (nth 1 (nth 2 a))))))
+	 (list (car a) (nth 1 a) (math-neg (nth 2 a))))
+	((and (eq (car a) 'var) (memq (nth 2 a) '(var-uinf var-nan)))
+	 a)
+	((eq (car a) 'neg)
+	 (nth 1 a))
+	(t (list 'neg a)))
+)
+
+(defun math-okay-neg (a)
+  (or (math-looks-negp a)
+      (eq (car-safe a) '-))
+)
+
+(defun math-neg-float (a)
+  (list 'float (Math-integer-neg (nth 1 a)) (nth 2 a))
+)
+
+
+(defun calcFunc-add (&rest rest)
+  (if rest
+      (let ((a (car rest)))
+	(while (setq rest (cdr rest))
+	  (setq a (list '+ a (car rest))))
+	(math-normalize a))
+    0)
+)
+
+(defun calcFunc-sub (&rest rest)
+  (if rest
+      (let ((a (car rest)))
+	(while (setq rest (cdr rest))
+	  (setq a (list '- a (car rest))))
+	(math-normalize a))
+    0)
+)
+
+(defun math-add-objects-fancy (a b)
+  (cond ((and (Math-numberp a) (Math-numberp b))
+	 (let ((aa (math-complex a))
+	       (bb (math-complex b)))
+	   (math-normalize
+	    (let ((res (list 'cplx
+			     (math-add (nth 1 aa) (nth 1 bb))
+			     (math-add (nth 2 aa) (nth 2 bb)))))
+	      (if (math-want-polar a b)
+		  (math-polar res)
+		res)))))
+	((or (Math-vectorp a) (Math-vectorp b))
+	 (math-map-vec-2 'math-add a b))
+	((eq (car-safe a) 'sdev)
+	 (if (eq (car-safe b) 'sdev)
+	     (math-make-sdev (math-add (nth 1 a) (nth 1 b))
+			     (math-hypot (nth 2 a) (nth 2 b)))
+	   (and (or (Math-scalarp b)
+		    (not (Math-objvecp b)))
+		(math-make-sdev (math-add (nth 1 a) b) (nth 2 a)))))
+	((and (eq (car-safe b) 'sdev)
+	      (or (Math-scalarp a)
+		  (not (Math-objvecp a))))
+	 (math-make-sdev (math-add a (nth 1 b)) (nth 2 b)))
+	((eq (car-safe a) 'intv)
+	 (if (eq (car-safe b) 'intv)
+	     (math-make-intv (logior (logand (nth 1 a) (nth 1 b))
+				     (if (equal (nth 2 a)
+						'(neg (var inf var-inf)))
+					 (logand (nth 1 a) 2) 0)
+				     (if (equal (nth 2 b)
+						'(neg (var inf var-inf)))
+					 (logand (nth 1 b) 2) 0)
+				     (if (equal (nth 3 a) '(var inf var-inf))
+					 (logand (nth 1 a) 1) 0)
+				     (if (equal (nth 3 b) '(var inf var-inf))
+					 (logand (nth 1 b) 1) 0))
+			     (math-add (nth 2 a) (nth 2 b))
+			     (math-add (nth 3 a) (nth 3 b)))
+	   (and (or (Math-anglep b)
+		    (eq (car b) 'date)
+		    (not (Math-objvecp b)))
+		(math-make-intv (nth 1 a)
+				(math-add (nth 2 a) b)
+				(math-add (nth 3 a) b)))))
+	((and (eq (car-safe b) 'intv)
+	      (or (Math-anglep a)
+		  (eq (car a) 'date)
+		  (not (Math-objvecp a))))
+	 (math-make-intv (nth 1 b)
+			 (math-add a (nth 2 b))
+			 (math-add a (nth 3 b))))
+	((eq (car-safe a) 'date)
+	 (cond ((eq (car-safe b) 'date)
+		(math-add (nth 1 a) (nth 1 b)))
+	       ((eq (car-safe b) 'hms)
+		(let ((parts (math-date-parts (nth 1 a))))
+		  (list 'date
+			(math-add (car parts)   ; this minimizes roundoff
+				  (math-div (math-add
+					     (math-add (nth 1 parts)
+						       (nth 2 parts))
+					     (math-add
+					      (math-mul (nth 1 b) 3600)
+					      (math-add (math-mul (nth 2 b) 60)
+							(nth 3 b))))
+					    86400)))))
+	       ((Math-realp b)
+		(list 'date (math-add (nth 1 a) b)))
+	       (t nil)))
+	((eq (car-safe b) 'date)
+	 (math-add-objects-fancy b a))
+	((and (eq (car-safe a) 'mod)
+	      (eq (car-safe b) 'mod)
+	      (equal (nth 2 a) (nth 2 b)))
+	 (math-make-mod (math-add (nth 1 a) (nth 1 b)) (nth 2 a)))
+	((and (eq (car-safe a) 'mod)
+	      (Math-anglep b))
+	 (math-make-mod (math-add (nth 1 a) b) (nth 2 a)))
+	((and (eq (car-safe b) 'mod)
+	      (Math-anglep a))
+	 (math-make-mod (math-add a (nth 1 b)) (nth 2 b)))
+	((and (or (eq (car-safe a) 'hms) (eq (car-safe b) 'hms))
+	      (and (Math-anglep a) (Math-anglep b)))
+	 (or (eq (car-safe a) 'hms) (setq a (math-to-hms a)))
+	 (or (eq (car-safe b) 'hms) (setq b (math-to-hms b)))
+	 (math-normalize
+	  (if (math-negp a)
+	      (math-neg (math-add (math-neg a) (math-neg b)))
+	    (if (math-negp b)
+		(let* ((s (math-add (nth 3 a) (nth 3 b)))
+		       (m (math-add (nth 2 a) (nth 2 b)))
+		       (h (math-add (nth 1 a) (nth 1 b))))
+		  (if (math-negp s)
+		      (setq s (math-add s 60)
+			    m (math-add m -1)))
+		  (if (math-negp m)
+		      (setq m (math-add m 60)
+			    h (math-add h -1)))
+		  (if (math-negp h)
+		      (math-add b a)
+		    (list 'hms h m s)))
+	      (let* ((s (math-add (nth 3 a) (nth 3 b)))
+		     (m (math-add (nth 2 a) (nth 2 b)))
+		     (h (math-add (nth 1 a) (nth 1 b))))
+		(list 'hms h m s))))))
+	(t (calc-record-why "*Incompatible arguments for +" a b)))
+)
+
+(defun math-add-symb-fancy (a b)
+  (or (and math-simplify-only
+	   (not (equal a math-simplify-only))
+	   (list '+ a b))
+      (and (eq (car-safe b) '+)
+	   (math-add (math-add a (nth 1 b))
+		     (nth 2 b)))
+      (and (eq (car-safe b) '-)
+	   (math-sub (math-add a (nth 1 b))
+		     (nth 2 b)))
+      (and (eq (car-safe b) 'neg)
+	   (eq (car-safe (nth 1 b)) '+)
+	   (math-sub (math-sub a (nth 1 (nth 1 b)))
+		     (nth 2 (nth 1 b))))
+      (and (or (and (Math-vectorp a) (math-known-scalarp b))
+	       (and (Math-vectorp b) (math-known-scalarp a)))
+	   (math-map-vec-2 'math-add a b))
+      (let ((inf (math-infinitep a)))
+	(cond
+	 (inf
+	  (let ((inf2 (math-infinitep b)))
+	    (if inf2
+		(if (or (memq (nth 2 inf) '(var-uinf var-nan))
+			(memq (nth 2 inf2) '(var-uinf var-nan)))
+		    '(var nan var-nan)
+		  (let ((dir (math-infinite-dir a inf))
+			(dir2 (math-infinite-dir b inf2)))
+		    (if (and (Math-objectp dir) (Math-objectp dir2))
+			(if (Math-equal dir dir2)
+			    a
+			  '(var nan var-nan)))))
+	      (if (and (equal a '(var inf var-inf))
+		       (eq (car-safe b) 'intv)
+		       (memq (nth 1 b) '(2 3))
+		       (equal (nth 2 b) '(neg (var inf var-inf))))
+		  (list 'intv 3 (nth 2 b) a)
+		(if (and (equal a '(neg (var inf var-inf)))
+			 (eq (car-safe b) 'intv)
+			 (memq (nth 1 b) '(1 3))
+			 (equal (nth 3 b) '(var inf var-inf)))
+		    (list 'intv 3 a (nth 3 b))
+		  a)))))
+	 ((math-infinitep b)
+	  (if (eq (car-safe a) 'intv)
+	      (math-add b a)
+	    b))
+	 ((eq (car-safe a) '+)
+	  (let ((temp (math-combine-sum (nth 2 a) b nil nil t)))
+	    (and temp
+		 (math-add (nth 1 a) temp))))
+	 ((eq (car-safe a) '-)
+	  (let ((temp (math-combine-sum (nth 2 a) b t nil t)))
+	    (and temp
+		 (math-add (nth 1 a) temp))))
+	 ((and (Math-objectp a) (Math-objectp b))
+	  nil)
+	 (t
+	  (math-combine-sum a b nil nil nil))))
+      (and (Math-looks-negp b)
+	   (list '- a (math-neg b)))
+      (and (Math-looks-negp a)
+	   (list '- b (math-neg a)))
+      (and (eq (car-safe a) 'calcFunc-idn)
+	   (= (length a) 2)
+	   (or (and (eq (car-safe b) 'calcFunc-idn)
+		    (= (length b) 2)
+		    (list 'calcFunc-idn (math-add (nth 1 a) (nth 1 b))))
+	       (and (math-square-matrixp b)
+		    (math-add (math-mimic-ident (nth 1 a) b) b))
+	       (and (math-known-scalarp b)
+		    (math-add (nth 1 a) b))))
+      (and (eq (car-safe b) 'calcFunc-idn)
+	   (= (length a) 2)
+	   (or (and (math-square-matrixp a)
+		    (math-add a (math-mimic-ident (nth 1 b) a)))
+	       (and (math-known-scalarp a)
+		    (math-add a (nth 1 b)))))
+      (list '+ a b))
+)
+
+
+(defun calcFunc-mul (&rest rest)
+  (if rest
+      (let ((a (car rest)))
+	(while (setq rest (cdr rest))
+	  (setq a (list '* a (car rest))))
+	(math-normalize a))
+    1)
+)
+
+(defun math-mul-objects-fancy (a b)
+  (cond ((and (Math-numberp a) (Math-numberp b))
+	 (math-normalize
+	  (if (math-want-polar a b)
+	      (let ((a (math-polar a))
+		    (b (math-polar b)))
+		(list 'polar
+		      (math-mul (nth 1 a) (nth 1 b))
+		      (math-fix-circular (math-add (nth 2 a) (nth 2 b)))))
+	    (setq a (math-complex a)
+		  b (math-complex b))
+	    (list 'cplx
+		  (math-sub (math-mul (nth 1 a) (nth 1 b))
+			    (math-mul (nth 2 a) (nth 2 b)))
+		  (math-add (math-mul (nth 1 a) (nth 2 b))
+			    (math-mul (nth 2 a) (nth 1 b)))))))
+	((Math-vectorp a)
+	 (if (Math-vectorp b)
+	     (if (math-matrixp a)
+		 (if (math-matrixp b)
+		     (if (= (length (nth 1 a)) (length b))
+			 (math-mul-mats a b)
+		       (math-dimension-error))
+		   (if (= (length (nth 1 a)) 2)
+		       (if (= (length a) (length b))
+			   (math-mul-mats a (list 'vec b))
+			 (math-dimension-error))
+		     (if (= (length (nth 1 a)) (length b))
+			 (math-mul-mat-vec a b)
+		       (math-dimension-error))))
+	       (if (math-matrixp b)
+		   (if (= (length a) (length b))
+		       (nth 1 (math-mul-mats (list 'vec a) b))
+		     (math-dimension-error))
+		 (if (= (length a) (length b))
+		     (math-dot-product a b)
+		   (math-dimension-error))))
+	   (math-map-vec-2 'math-mul a b)))
+	((Math-vectorp b)
+	 (math-map-vec-2 'math-mul a b))
+	((eq (car-safe a) 'sdev)
+	 (if (eq (car-safe b) 'sdev)
+	     (math-make-sdev (math-mul (nth 1 a) (nth 1 b))
+			     (math-hypot (math-mul (nth 2 a) (nth 1 b))
+					 (math-mul (nth 2 b) (nth 1 a))))
+	   (and (or (Math-scalarp b)
+		    (not (Math-objvecp b)))
+		(math-make-sdev (math-mul (nth 1 a) b)
+				(math-mul (nth 2 a) b)))))
+	((and (eq (car-safe b) 'sdev)
+	      (or (Math-scalarp a)
+		  (not (Math-objvecp a))))
+	 (math-make-sdev (math-mul a (nth 1 b)) (math-mul a (nth 2 b))))
+	((and (eq (car-safe a) 'intv) (Math-anglep b))
+	 (if (Math-negp b)
+	     (math-neg (math-mul a (math-neg b)))
+	   (math-make-intv (nth 1 a)
+			   (math-mul (nth 2 a) b)
+			   (math-mul (nth 3 a) b))))
+	((and (eq (car-safe b) 'intv) (Math-anglep a))
+	 (math-mul b a))
+	((and (eq (car-safe a) 'intv) (math-intv-constp a)
+	      (eq (car-safe b) 'intv) (math-intv-constp b))
+	 (let ((lo (math-mul a (nth 2 b)))
+	       (hi (math-mul a (nth 3 b))))
+	   (or (eq (car-safe lo) 'intv)
+	       (setq lo (list 'intv (if (memq (nth 1 b) '(2 3)) 3 0) lo lo)))
+	   (or (eq (car-safe hi) 'intv)
+	       (setq hi (list 'intv (if (memq (nth 1 b) '(1 3)) 3 0) hi hi)))
+	   (math-combine-intervals
+	    (nth 2 lo) (and (or (memq (nth 1 b) '(2 3))
+				(math-infinitep (nth 2 lo)))
+			    (memq (nth 1 lo) '(2 3)))
+	    (nth 3 lo) (and (or (memq (nth 1 b) '(2 3))
+				(math-infinitep (nth 3 lo)))
+			    (memq (nth 1 lo) '(1 3)))
+	    (nth 2 hi) (and (or (memq (nth 1 b) '(1 3))
+				(math-infinitep (nth 2 hi)))
+			    (memq (nth 1 hi) '(2 3)))
+	    (nth 3 hi) (and (or (memq (nth 1 b) '(1 3))
+				(math-infinitep (nth 3 hi)))
+			    (memq (nth 1 hi) '(1 3))))))
+	((and (eq (car-safe a) 'mod)
+	      (eq (car-safe b) 'mod)
+	      (equal (nth 2 a) (nth 2 b)))
+	 (math-make-mod (math-mul (nth 1 a) (nth 1 b)) (nth 2 a)))
+	((and (eq (car-safe a) 'mod)
+	      (Math-anglep b))
+	 (math-make-mod (math-mul (nth 1 a) b) (nth 2 a)))
+	((and (eq (car-safe b) 'mod)
+	      (Math-anglep a))
+	 (math-make-mod (math-mul a (nth 1 b)) (nth 2 b)))
+	((and (eq (car-safe a) 'hms) (Math-realp b))
+	 (math-with-extra-prec 2
+	   (math-to-hms (math-mul (math-from-hms a 'deg) b) 'deg)))
+	((and (eq (car-safe b) 'hms) (Math-realp a))
+	 (math-mul b a))
+	(t (calc-record-why "*Incompatible arguments for *" a b)))
+)
+
+;;; Fast function to multiply floating-point numbers.
+(defun math-mul-float (a b)   ; [F F F]
+  (math-make-float (math-mul (nth 1 a) (nth 1 b))
+		   (+ (nth 2 a) (nth 2 b)))
+)
+
+(defun math-sqr-float (a)   ; [F F]
+  (math-make-float (math-mul (nth 1 a) (nth 1 a))
+		   (+ (nth 2 a) (nth 2 a)))
+)
+
+(defun math-intv-constp (a &optional finite)
+  (and (or (Math-anglep (nth 2 a))
+	   (and (equal (nth 2 a) '(neg (var inf var-inf)))
+		(or (not finite)
+		    (memq (nth 1 a) '(0 1)))))
+       (or (Math-anglep (nth 3 a))
+	   (and (equal (nth 3 a) '(var inf var-inf))
+		(or (not finite)
+		    (memq (nth 1 a) '(0 2))))))
+)
+
+(defun math-mul-zero (a b)
+  (if (math-known-matrixp b)
+      (if (math-vectorp b)
+	  (math-map-vec-2 'math-mul a b)
+	(math-mimic-ident 0 b))
+    (if (math-infinitep b)
+	'(var nan var-nan)
+      (let ((aa nil) (bb nil))
+	(if (and (eq (car-safe b) 'intv)
+		 (progn
+		   (and (equal (nth 2 b) '(neg (var inf var-inf)))
+			(memq (nth 1 b) '(2 3))
+			(setq aa (nth 2 b)))
+		   (and (equal (nth 3 b) '(var inf var-inf))
+			(memq (nth 1 b) '(1 3))
+			(setq bb (nth 3 b)))
+		   (or aa bb)))
+	    (if (or (math-posp a)
+		    (and (math-zerop a)
+			 (or (memq calc-infinite-mode '(-1 1))
+			     (setq aa '(neg (var inf var-inf))
+				   bb '(var inf var-inf)))))
+		(list 'intv 3 (or aa 0) (or bb 0))
+	      (if (math-negp a)
+		  (math-neg (list 'intv 3 (or aa 0) (or bb 0)))
+		'(var nan var-nan)))
+	  (if (or (math-floatp a) (math-floatp b)) '(float 0 0) 0)))))
+)
+
+
+(defun math-mul-symb-fancy (a b)
+  (or (and math-simplify-only
+	   (not (equal a math-simplify-only))
+	   (list '* a b))
+      (and (Math-equal-int a 1)
+	   b)
+      (and (Math-equal-int a -1)
+	   (math-neg b))
+      (and (or (and (Math-vectorp a) (math-known-scalarp b))
+	       (and (Math-vectorp b) (math-known-scalarp a)))
+	   (math-map-vec-2 'math-mul a b))
+      (and (Math-objectp b) (not (Math-objectp a))
+	   (math-mul b a))
+      (and (eq (car-safe a) 'neg)
+	   (math-neg (math-mul (nth 1 a) b)))
+      (and (eq (car-safe b) 'neg)
+	   (math-neg (math-mul a (nth 1 b))))
+      (and (eq (car-safe a) '*)
+	   (math-mul (nth 1 a)
+		     (math-mul (nth 2 a) b)))
+      (and (eq (car-safe a) '^)
+	   (Math-looks-negp (nth 2 a))
+	   (not (and (eq (car-safe b) '^) (Math-looks-negp (nth 2 b))))
+	   (math-known-scalarp b t)
+	   (math-div b (math-normalize
+			(list '^ (nth 1 a) (math-neg (nth 2 a))))))
+      (and (eq (car-safe b) '^)
+	   (Math-looks-negp (nth 2 b))
+	   (not (and (eq (car-safe a) '^) (Math-looks-negp (nth 2 a))))
+	   (math-div a (math-normalize
+			(list '^ (nth 1 b) (math-neg (nth 2 b))))))
+      (and (eq (car-safe a) '/)
+	   (or (math-known-scalarp a t) (math-known-scalarp b t))
+	   (let ((temp (math-combine-prod (nth 2 a) b t nil t)))
+	     (if temp
+		 (math-mul (nth 1 a) temp)
+	       (math-div (math-mul (nth 1 a) b) (nth 2 a)))))
+      (and (eq (car-safe b) '/)
+	   (math-div (math-mul a (nth 1 b)) (nth 2 b)))
+      (and (eq (car-safe b) '+)
+	   (Math-numberp a)
+	   (or (Math-numberp (nth 1 b))
+	       (Math-numberp (nth 2 b)))
+	   (math-add (math-mul a (nth 1 b))
+		     (math-mul a (nth 2 b))))
+      (and (eq (car-safe b) '-)
+	   (Math-numberp a)
+	   (or (Math-numberp (nth 1 b))
+	       (Math-numberp (nth 2 b)))
+	   (math-sub (math-mul a (nth 1 b))
+		     (math-mul a (nth 2 b))))
+      (and (eq (car-safe b) '*)
+	   (Math-numberp (nth 1 b))
+	   (not (Math-numberp a))
+	   (math-mul (nth 1 b) (math-mul a (nth 2 b))))
+      (and (eq (car-safe a) 'calcFunc-idn)
+	   (= (length a) 2)
+	   (or (and (eq (car-safe b) 'calcFunc-idn)
+		    (= (length b) 2)
+		    (list 'calcFunc-idn (math-mul (nth 1 a) (nth 1 b))))
+	       (and (math-known-scalarp b)
+		    (list 'calcFunc-idn (math-mul (nth 1 a) b)))
+	       (and (math-known-matrixp b)
+		    (math-mul (nth 1 a) b))))
+      (and (eq (car-safe b) 'calcFunc-idn)
+	   (= (length b) 2)
+	   (or (and (math-known-scalarp a)
+		    (list 'calcFunc-idn (math-mul a (nth 1 b))))
+	       (and (math-known-matrixp a)
+		    (math-mul a (nth 1 b)))))
+      (and (math-looks-negp b)
+	   (math-mul (math-neg a) (math-neg b)))
+      (and (eq (car-safe b) '-)
+	   (math-looks-negp a)
+	   (math-mul (math-neg a) (math-neg b)))
+      (cond
+       ((eq (car-safe b) '*)
+	(let ((temp (math-combine-prod a (nth 1 b) nil nil t)))
+	  (and temp
+	       (math-mul temp (nth 2 b)))))
+       (t
+	(math-combine-prod a b nil nil nil)))
+      (and (equal a '(var nan var-nan))
+	   a)
+      (and (equal b '(var nan var-nan))
+	   b)
+      (and (equal a '(var uinf var-uinf))
+	   a)
+      (and (equal b '(var uinf var-uinf))
+	   b)
+      (and (equal b '(var inf var-inf))
+	   (let ((s1 (math-possible-signs a)))
+	     (cond ((eq s1 4)
+		    b)
+		   ((eq s1 6)
+		    '(intv 3 0 (var inf var-inf)))
+		   ((eq s1 1)
+		    (math-neg b))
+		   ((eq s1 3)
+		    '(intv 3 (neg (var inf var-inf)) 0))
+		   ((and (eq (car a) 'intv) (math-intv-constp a))
+		    '(intv 3 (neg (var inf var-inf)) (var inf var-inf)))
+		   ((and (eq (car a) 'cplx)
+			 (math-zerop (nth 1 a)))
+		    (list '* (list 'cplx 0 (calcFunc-sign (nth 2 a))) b))
+		   ((eq (car a) 'polar)
+		    (list '* (list 'polar 1 (nth 2 a)) b)))))
+      (and (equal a '(var inf var-inf))
+	   (math-mul b a))
+      (list '* a b))
+)
+
+
+(defun calcFunc-div (a &rest rest)
+  (while rest
+    (setq a (list '/ a (car rest))
+	  rest (cdr rest)))
+  (math-normalize a)
+)
+
+(defun math-div-objects-fancy (a b)
+  (cond ((and (Math-numberp a) (Math-numberp b))
+	 (math-normalize
+	  (cond ((math-want-polar a b)
+		 (let ((a (math-polar a))
+		       (b (math-polar b)))
+		   (list 'polar
+			 (math-div (nth 1 a) (nth 1 b))
+			 (math-fix-circular (math-sub (nth 2 a)
+						      (nth 2 b))))))
+		((Math-realp b)
+		 (setq a (math-complex a))
+		 (list 'cplx (math-div (nth 1 a) b)
+		       (math-div (nth 2 a) b)))
+		(t
+		 (setq a (math-complex a)
+		       b (math-complex b))
+		 (math-div
+		  (list 'cplx
+			(math-add (math-mul (nth 1 a) (nth 1 b))
+				  (math-mul (nth 2 a) (nth 2 b)))
+			(math-sub (math-mul (nth 2 a) (nth 1 b))
+				  (math-mul (nth 1 a) (nth 2 b))))
+		  (math-add (math-sqr (nth 1 b))
+			    (math-sqr (nth 2 b))))))))
+	((math-matrixp b)
+	 (if (math-square-matrixp b)
+	     (let ((n1 (length b)))
+	       (if (Math-vectorp a)
+		   (if (math-matrixp a)
+		       (if (= (length a) n1)
+			   (math-lud-solve (math-matrix-lud b) a b)
+			 (if (= (length (nth 1 a)) n1)
+			     (math-transpose
+			      (math-lud-solve (math-matrix-lud
+					       (math-transpose b))
+					      (math-transpose a) b))
+			   (math-dimension-error)))
+		     (if (= (length a) n1)
+			 (math-mat-col (math-lud-solve (math-matrix-lud b)
+						       (math-col-matrix a) b)
+				       1)
+		       (math-dimension-error)))
+		 (if (Math-equal-int a 1)
+		     (calcFunc-inv b)
+		   (math-mul a (calcFunc-inv b)))))
+	   (math-reject-arg b 'square-matrixp)))
+	((and (Math-vectorp a) (Math-objectp b))
+	 (math-map-vec-2 'math-div a b))
+	((eq (car-safe a) 'sdev)
+	 (if (eq (car-safe b) 'sdev)
+	     (let ((x (math-div (nth 1 a) (nth 1 b))))
+	       (math-make-sdev x
+			       (math-div (math-hypot (nth 2 a)
+						     (math-mul (nth 2 b) x))
+					 (nth 1 b))))
+	   (if (or (Math-scalarp b)
+		   (not (Math-objvecp b)))
+	       (math-make-sdev (math-div (nth 1 a) b) (math-div (nth 2 a) b))
+	     (math-reject-arg 'realp b))))
+	((and (eq (car-safe b) 'sdev)
+	      (or (Math-scalarp a)
+		  (not (Math-objvecp a))))
+	 (let ((x (math-div a (nth 1 b))))
+	   (math-make-sdev x
+			   (math-div (math-mul (nth 2 b) x) (nth 1 b)))))
+	((and (eq (car-safe a) 'intv) (Math-anglep b))
+	 (if (Math-negp b)
+	     (math-neg (math-div a (math-neg b)))
+	   (math-make-intv (nth 1 a)
+			   (math-div (nth 2 a) b)
+			   (math-div (nth 3 a) b))))
+	((and (eq (car-safe b) 'intv) (Math-anglep a))
+	 (if (or (Math-posp (nth 2 b))
+		 (and (Math-zerop (nth 2 b)) (or (memq (nth 1 b) '(0 1))
+						 calc-infinite-mode)))
+	     (if (Math-negp a)
+		 (math-neg (math-div (math-neg a) b))
+	       (let ((calc-infinite-mode 1))
+		 (math-make-intv (aref [0 2 1 3] (nth 1 b))
+				 (math-div a (nth 3 b))
+				 (math-div a (nth 2 b)))))
+	   (if (or (Math-negp (nth 3 b))
+		   (and (Math-zerop (nth 3 b)) (or (memq (nth 1 b) '(0 2))
+						   calc-infinite-mode)))
+	       (math-neg (math-div a (math-neg b)))
+	     (if calc-infinite-mode
+		 '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
+	       (math-reject-arg b "*Division by zero")))))
+	((and (eq (car-safe a) 'intv) (math-intv-constp a)
+	      (eq (car-safe b) 'intv) (math-intv-constp b))
+	 (if (or (Math-posp (nth 2 b))
+		 (and (Math-zerop (nth 2 b)) (or (memq (nth 1 b) '(0 1))
+						 calc-infinite-mode)))
+	     (let* ((calc-infinite-mode 1)
+		    (lo (math-div a (nth 2 b)))
+		    (hi (math-div a (nth 3 b))))
+	       (or (eq (car-safe lo) 'intv)
+		   (setq lo (list 'intv (if (memq (nth 1 b) '(2 3)) 3 0)
+				  lo lo)))
+	       (or (eq (car-safe hi) 'intv)
+		   (setq hi (list 'intv (if (memq (nth 1 b) '(1 3)) 3 0)
+				  hi hi)))
+	       (math-combine-intervals
+		(nth 2 lo) (and (or (memq (nth 1 b) '(2 3))
+				    (and (math-infinitep (nth 2 lo))
+					 (not (math-zerop (nth 2 b)))))
+				(memq (nth 1 lo) '(2 3)))
+		(nth 3 lo) (and (or (memq (nth 1 b) '(2 3))
+				    (and (math-infinitep (nth 3 lo))
+					 (not (math-zerop (nth 2 b)))))
+				(memq (nth 1 lo) '(1 3)))
+		(nth 2 hi) (and (or (memq (nth 1 b) '(1 3))
+				    (and (math-infinitep (nth 2 hi))
+					 (not (math-zerop (nth 3 b)))))
+				(memq (nth 1 hi) '(2 3)))
+		(nth 3 hi) (and (or (memq (nth 1 b) '(1 3))
+				    (and (math-infinitep (nth 3 hi))
+					 (not (math-zerop (nth 3 b)))))
+				(memq (nth 1 hi) '(1 3)))))
+	   (if (or (Math-negp (nth 3 b))
+		   (and (Math-zerop (nth 3 b)) (or (memq (nth 1 b) '(0 2))
+						   calc-infinite-mode)))
+	       (math-neg (math-div a (math-neg b)))
+	     (if calc-infinite-mode
+		 '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
+	       (math-reject-arg b "*Division by zero")))))
+	((and (eq (car-safe a) 'mod)
+	      (eq (car-safe b) 'mod)
+	      (equal (nth 2 a) (nth 2 b)))
+	 (math-make-mod (math-div-mod (nth 1 a) (nth 1 b) (nth 2 a))
+			(nth 2 a)))
+	((and (eq (car-safe a) 'mod)
+	      (Math-anglep b))
+	 (math-make-mod (math-div-mod (nth 1 a) b (nth 2 a)) (nth 2 a)))
+	((and (eq (car-safe b) 'mod)
+	      (Math-anglep a))
+	 (math-make-mod (math-div-mod a (nth 1 b) (nth 2 b)) (nth 2 b)))
+	((eq (car-safe a) 'hms)
+	 (if (eq (car-safe b) 'hms)
+	     (math-with-extra-prec 1
+	       (math-div (math-from-hms a 'deg)
+			 (math-from-hms b 'deg)))
+	   (math-with-extra-prec 2
+	     (math-to-hms (math-div (math-from-hms a 'deg) b) 'deg))))
+	(t (calc-record-why "*Incompatible arguments for /" a b)))
+)
+
+(defun math-div-by-zero (a b)
+  (if (math-infinitep a)
+      (if (or (equal a '(var nan var-nan))
+	      (equal b '(var uinf var-uinf))
+	      (memq calc-infinite-mode '(-1 1)))
+	  a
+	'(var uinf var-uinf))
+    (if calc-infinite-mode
+	(if (math-zerop a)
+	    '(var nan var-nan)
+	  (if (eq calc-infinite-mode 1)
+	      (math-mul a '(var inf var-inf))
+	    (if (eq calc-infinite-mode -1)
+		(math-mul a '(neg (var inf var-inf)))
+	      (if (eq (car-safe a) 'intv)
+		  '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
+		'(var uinf var-uinf)))))
+      (math-reject-arg a "*Division by zero")))
+)
+
+(defun math-div-zero (a b)
+  (if (math-known-matrixp b)
+      (if (math-vectorp b)
+	  (math-map-vec-2 'math-div a b)
+	(math-mimic-ident 0 b))
+    (if (equal b '(var nan var-nan))
+	b
+      (if (and (eq (car-safe b) 'intv) (math-intv-constp b)
+	       (not (math-posp b)) (not (math-negp b)))
+	  (if calc-infinite-mode
+	      (list 'intv 3
+		    (if (and (math-zerop (nth 2 b))
+			     (memq calc-infinite-mode '(1 -1)))
+			(nth 2 b) '(neg (var inf var-inf)))
+		    (if (and (math-zerop (nth 3 b))
+			     (memq calc-infinite-mode '(1 -1)))
+			(nth 3 b) '(var inf var-inf)))
+	    (math-reject-arg b "*Division by zero"))
+	a)))
+)
+
+(defun math-div-symb-fancy (a b)
+  (or (and math-simplify-only
+	   (not (equal a math-simplify-only))
+	   (list '/ a b))
+      (and (Math-equal-int b 1) a)
+      (and (Math-equal-int b -1) (math-neg a))
+      (and (Math-vectorp a) (math-known-scalarp b)
+	   (math-map-vec-2 'math-div a b))
+      (and (eq (car-safe b) '^)
+	   (or (Math-looks-negp (nth 2 b)) (Math-equal-int a 1))
+	   (math-mul a (math-normalize
+			(list '^ (nth 1 b) (math-neg (nth 2 b))))))
+      (and (eq (car-safe a) 'neg)
+	   (math-neg (math-div (nth 1 a) b)))
+      (and (eq (car-safe b) 'neg)
+	   (math-neg (math-div a (nth 1 b))))
+      (and (eq (car-safe a) '/)
+	   (math-div (nth 1 a) (math-mul (nth 2 a) b)))
+      (and (eq (car-safe b) '/)
+	   (or (math-known-scalarp (nth 1 b) t)
+	       (math-known-scalarp (nth 2 b) t))
+	   (math-div (math-mul a (nth 2 b)) (nth 1 b)))
+      (and (eq (car-safe b) 'frac)
+	   (math-mul (math-make-frac (nth 2 b) (nth 1 b)) a))
+      (and (eq (car-safe a) '+)
+	   (or (Math-numberp (nth 1 a))
+	       (Math-numberp (nth 2 a)))
+	   (Math-numberp b)
+	   (math-add (math-div (nth 1 a) b)
+		     (math-div (nth 2 a) b)))
+      (and (eq (car-safe a) '-)
+	   (or (Math-numberp (nth 1 a))
+	       (Math-numberp (nth 2 a)))
+	   (Math-numberp b)
+	   (math-sub (math-div (nth 1 a) b)
+		     (math-div (nth 2 a) b)))
+      (and (or (eq (car-safe a) '-)
+	       (math-looks-negp a))
+	   (math-looks-negp b)
+	   (math-div (math-neg a) (math-neg b)))
+      (and (eq (car-safe b) '-)
+	   (math-looks-negp a)
+	   (math-div (math-neg a) (math-neg b)))
+      (and (eq (car-safe a) 'calcFunc-idn)
+	   (= (length a) 2)
+	   (or (and (eq (car-safe b) 'calcFunc-idn)
+		    (= (length b) 2)
+		    (list 'calcFunc-idn (math-div (nth 1 a) (nth 1 b))))
+	       (and (math-known-scalarp b)
+		    (list 'calcFunc-idn (math-div (nth 1 a) b)))
+	       (and (math-known-matrixp b)
+		    (math-div (nth 1 a) b))))
+      (and (eq (car-safe b) 'calcFunc-idn)
+	   (= (length b) 2)
+	   (or (and (math-known-scalarp a)
+		    (list 'calcFunc-idn (math-div a (nth 1 b))))
+	       (and (math-known-matrixp a)
+		    (math-div a (nth 1 b)))))
+      (if (and calc-matrix-mode
+	       (or (math-known-matrixp a) (math-known-matrixp b)))
+	  (math-combine-prod a b nil t nil)
+	(if (eq (car-safe a) '*)
+	    (if (eq (car-safe b) '*)
+		(let ((c (math-combine-prod (nth 1 a) (nth 1 b) nil t t)))
+		  (and c
+		       (math-div (math-mul c (nth 2 a)) (nth 2 b))))
+	      (let ((c (math-combine-prod (nth 1 a) b nil t t)))
+		(and c
+		     (math-mul c (nth 2 a)))))
+	  (if (eq (car-safe b) '*)
+	      (let ((c (math-combine-prod a (nth 1 b) nil t t)))
+		(and c
+		     (math-div c (nth 2 b))))
+	    (math-combine-prod a b nil t nil))))
+      (and (math-infinitep a)
+	   (if (math-infinitep b)
+	       '(var nan var-nan)
+	     (if (or (equal a '(var nan var-nan))
+		     (equal a '(var uinf var-uinf)))
+		 a
+	       (if (equal a '(var inf var-inf))
+		   (if (or (math-posp b)
+			   (and (eq (car-safe b) 'intv)
+				(math-zerop (nth 2 b))))
+		       (if (and (eq (car-safe b) 'intv)
+				(not (math-intv-constp b t)))
+			   '(intv 3 0 (var inf var-inf))
+			 a)
+		     (if (or (math-negp b)
+			     (and (eq (car-safe b) 'intv)
+			      (math-zerop (nth 3 b))))
+			 (if (and (eq (car-safe b) 'intv)
+				  (not (math-intv-constp b t)))
+			     '(intv 3 (neg (var inf var-inf)) 0)
+			   (math-neg a))
+		       (if (and (eq (car-safe b) 'intv)
+				(math-negp (nth 2 b)) (math-posp (nth 3 b)))
+			   '(intv 3 (neg (var inf var-inf))
+				  (var inf var-inf)))))))))
+      (and (math-infinitep b)
+	   (if (equal b '(var nan var-nan))
+	       b
+	     (let ((calc-infinite-mode 1))
+	       (math-mul-zero b a))))
+      (list '/ a b))
+)
+
+
+(defun calcFunc-mod (a b)
+  (math-normalize (list '% a b))
+)
+
+(defun math-mod-fancy (a b)
+  (cond ((equal b '(var inf var-inf))
+	 (if (or (math-posp a) (math-zerop a))
+	     a
+	   (if (math-negp a)
+	       b
+	     (if (eq (car-safe a) 'intv)
+		 (if (math-negp (nth 2 a))
+		     '(intv 3 0 (var inf var-inf))
+		   a)
+	       (list '% a b)))))
+	((and (eq (car-safe a) 'mod) (Math-realp b) (math-posp b))
+	 (math-make-mod (nth 1 a) b))
+	((and (eq (car-safe a) 'intv) (math-intv-constp a t) (math-posp b))
+	 (math-mod-intv a b))
+	(t
+	 (if (Math-anglep a)
+	     (calc-record-why 'anglep b)
+	   (calc-record-why 'anglep a))
+	 (list '% a b)))
+)
+
+
+(defun calcFunc-pow (a b)
+  (math-normalize (list '^ a b))
+)
+
+(defun math-pow-of-zero (a b)
+  (if (Math-zerop b)
+      (if calc-infinite-mode
+	  '(var nan var-nan)
+	(math-reject-arg (list '^ a b) "*Indeterminate form"))
+    (if (math-floatp b) (setq a (math-float a)))
+    (if (math-posp b)
+	a
+      (if (math-negp b)
+	  (math-div 1 a)
+	(if (math-infinitep b)
+	    '(var nan var-nan)
+	  (if (and (eq (car b) 'intv) (math-intv-constp b)
+		   calc-infinite-mode)
+	      '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
+	    (if (math-objectp b)
+		(list '^ a b)
+	      a))))))
+)
+
+(defun math-pow-zero (a b)
+  (if (eq (car-safe a) 'mod)
+      (math-make-mod 1 (nth 2 a))
+    (if (math-known-matrixp a)
+	(math-mimic-ident 1 a)
+      (if (math-infinitep a)
+	  '(var nan var-nan)
+	(if (and (eq (car a) 'intv) (math-intv-constp a)
+		 (or (and (not (math-posp a)) (not (math-negp a)))
+		     (not (math-intv-constp a t))))
+	    '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
+	  (if (or (math-floatp a) (math-floatp b))
+	      '(float 1 0) 1)))))
+)
+
+(defun math-pow-fancy (a b)
+  (cond ((and (Math-numberp a) (Math-numberp b))
+	 (or (if (memq (math-quarter-integer b) '(1 2 3))
+		 (let ((sqrt (math-sqrt (if (math-floatp b)
+					    (math-float a) a))))
+		   (and (Math-numberp sqrt)
+			(math-pow sqrt (math-mul 2 b))))
+	       (and (eq (car b) 'frac)
+		    (integerp (nth 2 b))
+		    (<= (nth 2 b) 10)
+		    (let ((root (math-nth-root a (nth 2 b))))
+		      (and root (math-ipow root (nth 1 b))))))
+	     (and (or (eq a 10) (equal a '(float 1 1)))
+		  (math-num-integerp b)
+		  (calcFunc-scf '(float 1 0) b))
+	     (and calc-symbolic-mode
+		  (list '^ a b))
+	     (math-with-extra-prec 2
+	       (math-exp-raw
+		(math-float (math-mul b (math-ln-raw (math-float a))))))))
+	((or (not (Math-objvecp a))
+	     (not (Math-objectp b)))
+	 (let (temp)
+	   (cond ((and math-simplify-only
+		       (not (equal a math-simplify-only)))
+		  (list '^ a b))
+		 ((and (eq (car-safe a) '*)
+		       (or (math-known-num-integerp b)
+			   (math-known-nonnegp (nth 1 a))
+			   (math-known-nonnegp (nth 2 a))))
+		  (math-mul (math-pow (nth 1 a) b)
+			    (math-pow (nth 2 a) b)))
+		 ((and (eq (car-safe a) '/)
+		       (or (math-known-num-integerp b)
+			   (math-known-nonnegp (nth 2 a))))
+		  (math-div (math-pow (nth 1 a) b)
+			    (math-pow (nth 2 a) b)))
+		 ((and (eq (car-safe a) '/)
+		       (math-known-nonnegp (nth 1 a))
+		       (not (math-equal-int (nth 1 a) 1)))
+		  (math-mul (math-pow (nth 1 a) b)
+			    (math-pow (math-div 1 (nth 2 a)) b)))
+		 ((and (eq (car-safe a) '^)
+		       (or (math-known-num-integerp b)
+			   (math-known-nonnegp (nth 1 a))))
+		  (math-pow (nth 1 a) (math-mul (nth 2 a) b)))
+		 ((and (eq (car-safe a) 'calcFunc-sqrt)
+		       (or (math-known-num-integerp b)
+			   (math-known-nonnegp (nth 1 a))))
+		  (math-pow (nth 1 a) (math-div b 2)))
+		 ((and (eq (car-safe a) '^)
+		       (math-known-evenp (nth 2 a))
+		       (memq (math-quarter-integer b) '(1 2 3))
+		       (math-known-realp (nth 1 a)))
+		  (math-abs (math-pow (nth 1 a) (math-mul (nth 2 a) b))))
+		 ((and (math-looks-negp a)
+		       (math-known-integerp b)
+		       (setq temp (or (and (math-known-evenp b)
+					   (math-pow (math-neg a) b))
+				      (and (math-known-oddp b)
+					   (math-neg (math-pow (math-neg a)
+							       b))))))
+		  temp)
+		 ((and (eq (car-safe a) 'calcFunc-abs)
+		       (math-known-realp (nth 1 a))
+		       (math-known-evenp b))
+		  (math-pow (nth 1 a) b))
+		 ((math-infinitep a)
+		  (cond ((equal a '(var nan var-nan))
+			 a)
+			((eq (car a) 'neg)
+			 (math-mul (math-pow -1 b) (math-pow (nth 1 a) b)))
+			((math-posp b)
+			 a)
+			((math-negp b)
+			 (if (math-floatp b) '(float 0 0) 0))
+			((and (eq (car-safe b) 'intv)
+			      (math-intv-constp b))
+			 '(intv 3 0 (var inf var-inf)))
+			(t
+			 '(var nan var-nan))))
+		 ((math-infinitep b)
+		  (let (scale)
+		    (cond ((math-negp b)
+			   (math-pow (math-div 1 a) (math-neg b)))
+			  ((not (math-posp b))
+			   '(var nan var-nan))
+			  ((math-equal-int (setq scale (calcFunc-abssqr a)) 1)
+			   '(var nan var-nan))
+			  ((Math-lessp scale 1)
+			   (if (math-floatp a) '(float 0 0) 0))
+			  ((Math-lessp 1 a)
+			   b)
+			  ((Math-lessp a -1)
+			   '(var uinf var-uinf))
+			  ((and (eq (car a) 'intv)
+				(math-intv-constp a))
+			   (if (Math-lessp -1 a)
+			       (if (math-equal-int (nth 3 a) 1)
+				   '(intv 3 0 1)
+				 '(intv 3 0 (var inf var-inf)))
+			     '(intv 3 (neg (var inf var-inf))
+				    (var inf var-inf))))
+			  (t (list '^ a b)))))
+		 ((and (eq (car-safe a) 'calcFunc-idn)
+		       (= (length a) 2)
+		       (math-known-num-integerp b))
+		  (list 'calcFunc-idn (math-pow (nth 1 a) b)))
+		 (t (if (Math-objectp a)
+			(calc-record-why 'objectp b)
+		      (calc-record-why 'objectp a))
+		    (list '^ a b)))))
+	((and (eq (car-safe a) 'sdev) (eq (car-safe b) 'sdev))
+	 (if (and (math-constp a) (math-constp b))
+	     (math-with-extra-prec 2
+	       (let* ((ln (math-ln-raw (math-float (nth 1 a))))
+		      (pow (math-exp-raw
+			    (math-float (math-mul (nth 1 b) ln)))))
+		 (math-make-sdev
+		  pow
+		  (math-mul
+		   pow
+		   (math-hypot (math-mul (nth 2 a)
+					 (math-div (nth 1 b) (nth 1 a)))
+			       (math-mul (nth 2 b) ln))))))
+	   (let ((pow (math-pow (nth 1 a) (nth 1 b))))
+	     (math-make-sdev
+	      pow
+	      (math-mul pow
+			(math-hypot (math-mul (nth 2 a)
+					      (math-div (nth 1 b) (nth 1 a)))
+				    (math-mul (nth 2 b) (calcFunc-ln
+							 (nth 1 a)))))))))
+	((and (eq (car-safe a) 'sdev) (Math-numberp b))
+	 (if (math-constp a)
+	     (math-with-extra-prec 2
+	       (let ((pow (math-pow (nth 1 a) (math-sub b 1))))
+		 (math-make-sdev (math-mul pow (nth 1 a))
+				 (math-mul pow (math-mul (nth 2 a) b)))))
+	   (math-make-sdev (math-pow (nth 1 a) b)
+			   (math-mul (math-pow (nth 1 a) (math-add b -1))
+				     (math-mul (nth 2 a) b)))))
+	((and (eq (car-safe b) 'sdev) (Math-numberp a))
+	 (math-with-extra-prec 2
+	   (let* ((ln (math-ln-raw (math-float a)))
+		  (pow (calcFunc-exp (math-mul (nth 1 b) ln))))
+	     (math-make-sdev pow (math-mul pow (math-mul (nth 2 b) ln))))))
+	((and (eq (car-safe a) 'intv) (math-intv-constp a)
+	      (Math-realp b)
+	      (or (Math-natnump b)
+		  (Math-posp (nth 2 a))
+		  (and (math-zerop (nth 2 a))
+		       (or (Math-posp b)
+			   (and (Math-integerp b) calc-infinite-mode)))
+		  (Math-negp (nth 3 a))
+		  (and (math-zerop (nth 3 a))
+		       (or (Math-posp b)
+			   (and (Math-integerp b) calc-infinite-mode)))))
+	 (if (math-evenp b)
+	     (setq a (math-abs a)))
+	 (let ((calc-infinite-mode (if (math-zerop (nth 3 a)) -1 1)))
+	   (math-sort-intv (nth 1 a)
+			   (math-pow (nth 2 a) b)
+			   (math-pow (nth 3 a) b))))
+	((and (eq (car-safe b) 'intv) (math-intv-constp b)
+	      (Math-realp a) (Math-posp a))
+	 (math-sort-intv (nth 1 b)
+			 (math-pow a (nth 2 b))
+			 (math-pow a (nth 3 b))))
+	((and (eq (car-safe a) 'intv) (math-intv-constp a)
+	      (eq (car-safe b) 'intv) (math-intv-constp b)
+	      (or (and (not (Math-negp (nth 2 a)))
+		       (not (Math-negp (nth 2 b))))
+		  (and (Math-posp (nth 2 a))
+		       (not (Math-posp (nth 3 b))))))
+	 (let ((lo (math-pow a (nth 2 b)))
+	       (hi (math-pow a (nth 3 b))))
+	   (or (eq (car-safe lo) 'intv)
+	       (setq lo (list 'intv (if (memq (nth 1 b) '(2 3)) 3 0) lo lo)))
+	   (or (eq (car-safe hi) 'intv)
+	       (setq hi (list 'intv (if (memq (nth 1 b) '(1 3)) 3 0) hi hi)))
+	   (math-combine-intervals
+	    (nth 2 lo) (and (or (memq (nth 1 b) '(2 3))
+				(math-infinitep (nth 2 lo)))
+			    (memq (nth 1 lo) '(2 3)))
+	    (nth 3 lo) (and (or (memq (nth 1 b) '(2 3))
+				(math-infinitep (nth 3 lo)))
+			    (memq (nth 1 lo) '(1 3)))
+	    (nth 2 hi) (and (or (memq (nth 1 b) '(1 3))
+				(math-infinitep (nth 2 hi)))
+			    (memq (nth 1 hi) '(2 3)))
+	    (nth 3 hi) (and (or (memq (nth 1 b) '(1 3))
+				(math-infinitep (nth 3 hi)))
+			    (memq (nth 1 hi) '(1 3))))))
+	((and (eq (car-safe a) 'mod) (eq (car-safe b) 'mod)
+	      (equal (nth 2 a) (nth 2 b)))
+	 (math-make-mod (math-pow-mod (nth 1 a) (nth 1 b) (nth 2 a))
+			(nth 2 a)))
+	((and (eq (car-safe a) 'mod) (Math-anglep b))
+	 (math-make-mod (math-pow-mod (nth 1 a) b (nth 2 a)) (nth 2 a)))
+	((and (eq (car-safe b) 'mod) (Math-anglep a))
+	 (math-make-mod (math-pow-mod a (nth 1 b) (nth 2 b)) (nth 2 b)))
+	((not (Math-numberp a))
+	 (math-reject-arg a 'numberp))
+	(t
+	 (math-reject-arg b 'numberp)))
+)
+
+(defun math-quarter-integer (x)
+  (if (Math-integerp x)
+      0
+    (if (math-negp x)
+	(progn
+	  (setq x (math-quarter-integer (math-neg x)))
+	  (and x (- 4 x)))
+      (if (eq (car x) 'frac)
+	  (if (eq (nth 2 x) 2)
+	      2
+	    (and (eq (nth 2 x) 4)
+		 (progn
+		   (setq x (nth 1 x))
+		   (% (if (consp x) (nth 1 x) x) 4))))
+	(if (eq (car x) 'float)
+	    (if (>= (nth 2 x) 0)
+		0
+	      (if (= (nth 2 x) -1)
+		  (progn
+		    (setq x (nth 1 x))
+		    (and (= (% (if (consp x) (nth 1 x) x) 10) 5) 2))
+		(if (= (nth 2 x) -2)
+		    (progn
+		      (setq x (nth 1 x)
+			    x (% (if (consp x) (nth 1 x) x) 100))
+		      (if (= x 25) 1
+			(if (= x 75) 3))))))))))
+)
+
+;;; This assumes A < M and M > 0.
+(defun math-pow-mod (a b m)   ; [R R R R]
+  (if (and (Math-integerp a) (Math-integerp b) (Math-integerp m))
+      (if (Math-negp b)
+	  (math-div-mod 1 (math-pow-mod a (Math-integer-neg b) m) m)
+	(if (eq m 1)
+	    0
+	  (math-pow-mod-step a b m)))
+    (math-mod (math-pow a b) m))
+)
+
+(defun math-pow-mod-step (a n m)   ; [I I I I]
+  (math-working "pow" a)
+  (let ((val (cond
+	      ((eq n 0) 1)
+	      ((eq n 1) a)
+	      (t
+	       (let ((rest (math-pow-mod-step
+			    (math-imod (math-mul a a) m)
+			    (math-div2 n)
+			    m)))
+		 (if (math-evenp n)
+		     rest
+		   (math-mod (math-mul a rest) m)))))))
+    (math-working "pow" val)
+    val)
+)
+
+
+;;; Compute the minimum of two real numbers.  [R R R] [Public]
+(defun math-min (a b)
+  (if (and (consp a) (eq (car a) 'intv))
+      (if (and (consp b) (eq (car b) 'intv))
+	  (let ((lo (nth 2 a))
+		(lom (memq (nth 1 a) '(2 3)))
+		(hi (nth 3 a))
+		(him (memq (nth 1 a) '(1 3)))
+		res)
+	    (if (= (setq res (math-compare (nth 2 b) lo)) -1)
+		(setq lo (nth 2 b) lom (memq (nth 1 b) '(2 3)))
+	      (if (= res 0)
+		  (setq lom (or lom (memq (nth 1 b) '(2 3))))))
+	    (if (= (setq res (math-compare (nth 3 b) hi)) -1)
+		(setq hi (nth 3 b) him (memq (nth 1 b) '(1 3)))
+	      (if (= res 0)
+		  (setq him (or him (memq (nth 1 b) '(1 3))))))
+	    (math-make-intv (+ (if lom 2 0) (if him 1 0)) lo hi))
+	(math-min a (list 'intv 3 b b)))
+    (if (and (consp b) (eq (car b) 'intv))
+	(math-min (list 'intv 3 a a) b)
+      (let ((res (math-compare a b)))
+	(if (= res 1)
+	    b
+	  (if (= res 2)
+	      '(var nan var-nan)
+	    a)))))
+)
+
+(defun calcFunc-min (&optional a &rest b)
+  (if (not a)
+      '(var inf var-inf)
+    (if (not (or (Math-anglep a) (eq (car a) 'date)
+		 (and (eq (car a) 'intv) (math-intv-constp a))
+		 (math-infinitep a)))
+	(math-reject-arg a 'anglep))
+    (math-min-list a b))
+)
+
+(defun math-min-list (a b)
+  (if b
+      (if (or (Math-anglep (car b)) (eq (car b) 'date)
+	      (and (eq (car (car b)) 'intv) (math-intv-constp (car b)))
+	      (math-infinitep (car b)))
+	  (math-min-list (math-min a (car b)) (cdr b))
+	(math-reject-arg (car b) 'anglep))
+    a)
+)
+
+;;; Compute the maximum of two real numbers.  [R R R] [Public]
+(defun math-max (a b)
+  (if (or (and (consp a) (eq (car a) 'intv))
+	  (and (consp b) (eq (car b) 'intv)))
+      (math-neg (math-min (math-neg a) (math-neg b)))
+    (let ((res (math-compare a b)))
+      (if (= res -1)
+	  b
+	(if (= res 2)
+	      '(var nan var-nan)
+	  a))))
+)
+
+(defun calcFunc-max (&optional a &rest b)
+  (if (not a)
+      '(neg (var inf var-inf))
+    (if (not (or (Math-anglep a) (eq (car a) 'date)
+		 (and (eq (car a) 'intv) (math-intv-constp a))
+		 (math-infinitep a)))
+	(math-reject-arg a 'anglep))
+    (math-max-list a b))
+)
+
+(defun math-max-list (a b)
+  (if b
+      (if (or (Math-anglep (car b)) (eq (car b) 'date)
+	      (and (eq (car (car b)) 'intv) (math-intv-constp (car b)))
+	      (math-infinitep (car b)))
+	  (math-max-list (math-max a (car b)) (cdr b))
+	(math-reject-arg (car b) 'anglep))
+    a)
+)
+
+
+;;; Compute the absolute value of A.  [O O; r r] [Public]
+(defun math-abs (a)
+  (cond ((Math-negp a)
+	 (math-neg a))
+	((Math-anglep a)
+	 a)
+	((eq (car a) 'cplx)
+	 (math-hypot (nth 1 a) (nth 2 a)))
+	((eq (car a) 'polar)
+	 (nth 1 a))
+	((eq (car a) 'vec)
+	 (if (cdr (cdr (cdr a)))
+	     (math-sqrt (calcFunc-abssqr a))
+	   (if (cdr (cdr a))
+	       (math-hypot (nth 1 a) (nth 2 a))
+	     (if (cdr a)
+		 (math-abs (nth 1 a))
+	       a))))
+	((eq (car a) 'sdev)
+	 (list 'sdev (math-abs (nth 1 a)) (nth 2 a)))
+	((and (eq (car a) 'intv) (math-intv-constp a))
+	 (if (Math-posp a)
+	     a
+	   (let* ((nlo (math-neg (nth 2 a)))
+		  (res (math-compare nlo (nth 3 a))))
+	     (cond ((= res 1)
+		    (math-make-intv (if (memq (nth 1 a) '(0 1)) 2 3) 0 nlo))
+		   ((= res 0)
+		    (math-make-intv (if (eq (nth 1 a) 0) 2 3) 0 nlo))
+		   (t
+		    (math-make-intv (if (memq (nth 1 a) '(0 2)) 2 3)
+				    0 (nth 3 a)))))))
+	((math-looks-negp a)
+	 (list 'calcFunc-abs (math-neg a)))
+	((let ((signs (math-possible-signs a)))
+	   (or (and (memq signs '(2 4 6)) a)
+	       (and (memq signs '(1 3)) (math-neg a)))))
+	((let ((inf (math-infinitep a)))
+	   (and inf
+		(if (equal inf '(var nan var-nan))
+		    inf
+		  '(var inf var-inf)))))
+	(t (calc-record-why 'numvecp a)
+	   (list 'calcFunc-abs a)))
+)
+(fset 'calcFunc-abs (symbol-function 'math-abs))
+
+
+(defun math-float-fancy (a)
+  (cond ((eq (car a) 'intv)
+	 (cons (car a) (cons (nth 1 a) (mapcar 'math-float (nthcdr 2 a)))))
+	((and (memq (car a) '(* /))
+	      (math-numberp (nth 1 a)))
+	 (list (car a) (math-float (nth 1 a))
+	       (list 'calcFunc-float (nth 2 a))))
+	((and (eq (car a) '/)
+	      (eq (car (nth 1 a)) '*)
+	      (math-numberp (nth 1 (nth 1 a))))
+	 (list '* (math-float (nth 1 (nth 1 a)))
+	       (list 'calcFunc-float (list '/ (nth 2 (nth 1 a)) (nth 2 a)))))
+	((math-infinitep a) a)
+	((eq (car a) 'calcFunc-float) a)
+	((let ((func (assq (car a) '((calcFunc-floor  . calcFunc-ffloor)
+				     (calcFunc-ceil   . calcFunc-fceil)
+				     (calcFunc-trunc  . calcFunc-ftrunc)
+				     (calcFunc-round  . calcFunc-fround)
+				     (calcFunc-rounde . calcFunc-frounde)
+				     (calcFunc-roundu . calcFunc-froundu)))))
+	   (and func (cons (cdr func) (cdr a)))))
+	(t (math-reject-arg a 'objectp)))
+)
+(fset 'calcFunc-float (symbol-function 'math-float))
+
+
+(defun math-trunc-fancy (a)
+  (cond ((eq (car a) 'frac) (math-quotient (nth 1 a) (nth 2 a)))
+	((eq (car a) 'cplx) (math-trunc (nth 1 a)))
+	((eq (car a) 'polar) (math-trunc (math-complex a)))
+	((eq (car a) 'hms) (list 'hms (nth 1 a) 0 0))
+	((eq (car a) 'date) (list 'date (math-trunc (nth 1 a))))
+	((eq (car a) 'mod)
+	 (if (math-messy-integerp (nth 2 a))
+	     (math-trunc (math-make-mod (nth 1 a) (math-trunc (nth 2 a))))
+	   (math-make-mod (math-trunc (nth 1 a)) (nth 2 a))))
+	((eq (car a) 'intv)
+	 (math-make-intv (+ (if (and (equal (nth 2 a) '(neg (var inf var-inf)))
+				     (memq (nth 1 a) '(0 1)))
+				0 2)
+			    (if (and (equal (nth 3 a) '(var inf var-inf))
+				     (memq (nth 1 a) '(0 2)))
+				0 1))
+			 (if (and (Math-negp (nth 2 a))
+				  (Math-num-integerp (nth 2 a))
+				  (memq (nth 1 a) '(0 1)))
+			     (math-add (math-trunc (nth 2 a)) 1)
+			   (math-trunc (nth 2 a)))
+			 (if (and (Math-posp (nth 3 a))
+				  (Math-num-integerp (nth 3 a))
+				  (memq (nth 1 a) '(0 2)))
+			     (math-add (math-trunc (nth 3 a)) -1)
+			   (math-trunc (nth 3 a)))))
+	((math-provably-integerp a) a)
+	((Math-vectorp a)
+	 (math-map-vec (function (lambda (x) (math-trunc x prec))) a))
+	((math-infinitep a)
+	 (if (or (math-posp a) (math-negp a))
+	     a
+	   '(var nan var-nan)))
+	((math-to-integer a))
+	(t (math-reject-arg a 'numberp)))
+)
+
+(defun math-trunc-special (a prec)
+  (if (Math-messy-integerp prec)
+      (setq prec (math-trunc prec)))
+  (or (integerp prec)
+      (math-reject-arg prec 'fixnump))
+  (if (and (<= prec 0)
+	   (math-provably-integerp a))
+      a
+    (calcFunc-scf (math-trunc (let ((calc-prefer-frac t))
+				(calcFunc-scf a prec)))
+		  (- prec)))
+)
+
+(defun math-to-integer (a)
+  (let ((func (assq (car-safe a) '((calcFunc-ffloor  . calcFunc-floor)
+				   (calcFunc-fceil   . calcFunc-ceil)
+				   (calcFunc-ftrunc  . calcFunc-trunc)
+				   (calcFunc-fround  . calcFunc-round)
+				   (calcFunc-frounde . calcFunc-rounde)
+				   (calcFunc-froundu . calcFunc-roundu)))))
+    (and func (= (length a) 2)
+	 (cons (cdr func) (cdr a))))
+)
+
+(defun calcFunc-ftrunc (a &optional prec)
+  (if (and (Math-messy-integerp a)
+	   (or (not prec) (and (integerp prec)
+			       (<= prec 0))))
+      a
+    (math-float (math-trunc a prec)))
+)
+
+(defun math-floor-fancy (a)
+  (cond ((math-provably-integerp a) a)
+	((eq (car a) 'hms)
+	 (if (or (math-posp a)
+		 (and (math-zerop (nth 2 a))
+		      (math-zerop (nth 3 a))))
+	     (math-trunc a)
+	   (math-add (math-trunc a) -1)))
+	((eq (car a) 'date) (list 'date (math-floor (nth 1 a))))
+	((eq (car a) 'intv)
+	 (math-make-intv (+ (if (and (equal (nth 2 a) '(neg (var inf var-inf)))
+				     (memq (nth 1 a) '(0 1)))
+				0 2)
+			    (if (and (equal (nth 3 a) '(var inf var-inf))
+				     (memq (nth 1 a) '(0 2)))
+				0 1))
+			 (math-floor (nth 2 a))
+			 (if (and (Math-num-integerp (nth 3 a))
+				  (memq (nth 1 a) '(0 2)))
+			     (math-add (math-floor (nth 3 a)) -1)
+			   (math-floor (nth 3 a)))))
+	((Math-vectorp a)
+	 (math-map-vec (function (lambda (x) (math-floor x prec))) a))
+	((math-infinitep a)
+	 (if (or (math-posp a) (math-negp a))
+	     a
+	   '(var nan var-nan)))
+	((math-to-integer a))
+	(t (math-reject-arg a 'anglep)))
+)
+
+(defun math-floor-special (a prec)
+  (if (Math-messy-integerp prec)
+      (setq prec (math-trunc prec)))
+  (or (integerp prec)
+      (math-reject-arg prec 'fixnump))
+  (if (and (<= prec 0)
+	   (math-provably-integerp a))
+      a
+    (calcFunc-scf (math-floor (let ((calc-prefer-frac t))
+				(calcFunc-scf a prec)))
+		  (- prec)))
+)
+
+(defun calcFunc-ffloor (a &optional prec)
+  (if (and (Math-messy-integerp a)
+	   (or (not prec) (and (integerp prec)
+			       (<= prec 0))))
+      a
+    (math-float (math-floor a prec)))
+)
+
+;;; Coerce A to be an integer (by truncation toward plus infinity).  [I N]
+(defun math-ceiling (a &optional prec)   ;  [Public]
+  (cond (prec
+	 (if (Math-messy-integerp prec)
+	     (setq prec (math-trunc prec)))
+	 (or (integerp prec)
+	     (math-reject-arg prec 'fixnump))
+	 (if (and (<= prec 0)
+		  (math-provably-integerp a))
+	     a
+	   (calcFunc-scf (math-ceiling (let ((calc-prefer-frac t))
+					 (calcFunc-scf a prec)))
+			 (- prec))))
+	((Math-integerp a) a)
+	((Math-messy-integerp a) (math-trunc a))
+	((Math-realp a)
+	 (if (Math-posp a)
+	     (math-add (math-trunc a) 1)
+	   (math-trunc a)))
+	((math-provably-integerp a) a)
+	((eq (car a) 'hms)
+	 (if (or (math-negp a)
+		 (and (math-zerop (nth 2 a))
+		      (math-zerop (nth 3 a))))
+	     (math-trunc a)
+	   (math-add (math-trunc a) 1)))
+	((eq (car a) 'date) (list 'date (math-ceiling (nth 1 a))))
+	((eq (car a) 'intv)
+	 (math-make-intv (+ (if (and (equal (nth 2 a) '(neg (var inf var-inf)))
+				     (memq (nth 1 a) '(0 1)))
+				0 2)
+			    (if (and (equal (nth 3 a) '(var inf var-inf))
+				     (memq (nth 1 a) '(0 2)))
+				0 1))
+			 (if (and (Math-num-integerp (nth 2 a))
+				  (memq (nth 1 a) '(0 1)))
+			     (math-add (math-floor (nth 2 a)) 1)
+			   (math-ceiling (nth 2 a)))
+			 (math-ceiling (nth 3 a))))
+	((Math-vectorp a)
+	 (math-map-vec (function (lambda (x) (math-ceiling x prec))) a))
+	((math-infinitep a)
+	 (if (or (math-posp a) (math-negp a))
+	     a
+	   '(var nan var-nan)))
+	((math-to-integer a))
+	(t (math-reject-arg a 'anglep)))
+)
+(fset 'calcFunc-ceil (symbol-function 'math-ceiling))
+
+(defun calcFunc-fceil (a &optional prec)
+  (if (and (Math-messy-integerp a)
+	   (or (not prec) (and (integerp prec)
+			       (<= prec 0))))
+      a
+    (math-float (math-ceiling a prec)))
+)
+
+(setq math-rounding-mode nil)
+
+;;; Coerce A to be an integer (by rounding to nearest integer).  [I N] [Public]
+(defun math-round (a &optional prec)
+  (cond (prec
+	 (if (Math-messy-integerp prec)
+	     (setq prec (math-trunc prec)))
+	 (or (integerp prec)
+	     (math-reject-arg prec 'fixnump))
+	 (if (and (<= prec 0)
+		  (math-provably-integerp a))
+	     a
+	   (calcFunc-scf (math-round (let ((calc-prefer-frac t))
+				       (calcFunc-scf a prec)))
+			 (- prec))))
+	((Math-anglep a)
+	 (if (Math-num-integerp a)
+	     (math-trunc a)
+	   (if (and (Math-negp a) (not (eq math-rounding-mode 'up)))
+	       (math-neg (math-round (math-neg a)))
+	     (setq a (let ((calc-angle-mode 'deg))   ; in case of HMS forms
+		       (math-add a (if (Math-ratp a)
+				       '(frac 1 2)
+				     '(float 5 -1)))))
+	     (if (and (Math-num-integerp a) (eq math-rounding-mode 'even))
+		 (progn
+		   (setq a (math-floor a))
+		   (or (math-evenp a)
+		       (setq a (math-sub a 1)))
+		   a)
+	       (math-floor a)))))
+	((math-provably-integerp a) a)
+	((eq (car a) 'date) (list 'date (math-round (nth 1 a))))
+	((eq (car a) 'intv)
+	 (math-floor (math-add a '(frac 1 2))))
+	((Math-vectorp a)
+	 (math-map-vec (function (lambda (x) (math-round x prec))) a))
+	((math-infinitep a)
+	 (if (or (math-posp a) (math-negp a))
+	     a
+	   '(var nan var-nan)))
+	((math-to-integer a))
+	(t (math-reject-arg a 'anglep)))
+)
+(fset 'calcFunc-round (symbol-function 'math-round))
+
+(defun calcFunc-rounde (a &optional prec)
+  (let ((math-rounding-mode 'even))
+    (math-round a prec))
+)
+
+(defun calcFunc-roundu (a &optional prec)
+  (let ((math-rounding-mode 'up))
+    (math-round a prec))
+)
+
+(defun calcFunc-fround (a &optional prec)
+  (if (and (Math-messy-integerp a)
+	   (or (not prec) (and (integerp prec)
+			       (<= prec 0))))
+      a
+    (math-float (math-round a prec)))
+)
+
+(defun calcFunc-frounde (a &optional prec)
+  (let ((math-rounding-mode 'even))
+    (calcFunc-fround a prec))
+)
+
+(defun calcFunc-froundu (a &optional prec)
+  (let ((math-rounding-mode 'up))
+    (calcFunc-fround a prec))
+)
+
+
+;;; Pull floating-point values apart into mantissa and exponent.
+(defun calcFunc-mant (x)
+  (if (Math-realp x)
+      (if (or (Math-ratp x)
+	      (eq (nth 1 x) 0))
+	  x
+	(list 'float (nth 1 x) (- 1 (math-numdigs (nth 1 x)))))
+    (calc-record-why 'realp x)
+    (list 'calcFunc-mant x))
+)
+
+(defun calcFunc-xpon (x)
+  (if (Math-realp x)
+      (if (or (Math-ratp x)
+	      (eq (nth 1 x) 0))
+	  0
+	(math-normalize (+ (nth 2 x) (1- (math-numdigs (nth 1 x))))))
+    (calc-record-why 'realp x)
+    (list 'calcFunc-xpon x))
+)
+
+(defun calcFunc-scf (x n)
+  (if (integerp n)
+      (cond ((eq n 0)
+	     x)
+	    ((Math-integerp x)
+	     (if (> n 0)
+		 (math-scale-int x n)
+	       (math-div x (math-scale-int 1 (- n)))))
+	    ((eq (car x) 'frac)
+	     (if (> n 0)
+		 (math-make-frac (math-scale-int (nth 1 x) n) (nth 2 x))
+	       (math-make-frac (nth 1 x) (math-scale-int (nth 2 x) (- n)))))
+	    ((eq (car x) 'float)
+	     (math-make-float (nth 1 x) (+ (nth 2 x) n)))
+	    ((memq (car x) '(cplx sdev))
+	     (math-normalize
+	      (list (car x)
+		    (calcFunc-scf (nth 1 x) n)
+		    (calcFunc-scf (nth 2 x) n))))
+	    ((memq (car x) '(polar mod))
+	     (math-normalize
+	      (list (car x)
+		    (calcFunc-scf (nth 1 x) n)
+		    (nth 2 x))))
+	    ((eq (car x) 'intv)
+	     (math-normalize
+	      (list (car x)
+		    (nth 1 x)
+		    (calcFunc-scf (nth 2 x) n)
+		    (calcFunc-scf (nth 3 x) n))))
+	    ((eq (car x) 'vec)
+	     (math-map-vec (function (lambda (x) (calcFunc-scf x n))) x))
+	    ((math-infinitep x)
+	     x)
+	    (t
+	     (calc-record-why 'realp x)
+	     (list 'calcFunc-scf x n)))
+    (if (math-messy-integerp n)
+	(if (< (nth 2 n) 10)
+	    (calcFunc-scf x (math-trunc n))
+	  (math-overflow n))
+      (if (math-integerp n)
+	  (math-overflow n)
+	(calc-record-why 'integerp n)
+	(list 'calcFunc-scf x n))))
+)
+
+
+(defun calcFunc-incr (x &optional step relative-to)
+  (or step (setq step 1))
+  (cond ((not (Math-integerp step))
+	 (math-reject-arg step 'integerp))
+	((Math-integerp x)
+	 (math-add x step))
+	((eq (car x) 'float)
+	 (if (and (math-zerop x)
+		  (eq (car-safe relative-to) 'float))
+	     (math-mul step
+		       (calcFunc-scf relative-to (- 1 calc-internal-prec)))
+	   (math-add-float x (math-make-float
+			      step
+			      (+ (nth 2 x)
+				 (- (math-numdigs (nth 1 x))
+				    calc-internal-prec))))))
+	((eq (car x) 'date)
+	 (if (Math-integerp (nth 1 x))
+	     (math-add x step)
+	   (math-add x (list 'hms 0 0 step))))
+	(t
+	 (math-reject-arg x 'realp)))
+)
+
+(defun calcFunc-decr (x &optional step relative-to)
+  (calcFunc-incr x (math-neg (or step 1)) relative-to)
+)
+
+
+(defun calcFunc-percent (x)
+  (if (math-objectp x)
+      (let ((calc-prefer-frac nil))
+	(math-div x 100))
+    (list 'calcFunc-percent x))
+)
+
+(defun calcFunc-relch (x y)
+  (if (and (math-objectp x) (math-objectp y))
+      (math-div (math-sub y x) x)
+    (list 'calcFunc-relch x y))
+)
+
+
+
+;;; Compute the absolute value squared of A.  [F N] [Public]
+(defun calcFunc-abssqr (a)
+  (cond ((Math-realp a)
+	 (math-mul a a))
+	((eq (car a) 'cplx)
+	 (math-add (math-sqr (nth 1 a))
+		   (math-sqr (nth 2 a))))
+	((eq (car a) 'polar)
+	 (math-sqr (nth 1 a)))
+	((and (memq (car a) '(sdev intv)) (math-constp a))
+	 (math-sqr (math-abs a)))
+	((eq (car a) 'vec)
+	 (math-reduce-vec 'math-add (math-map-vec 'calcFunc-abssqr a)))
+	((math-known-realp a)
+	 (math-pow a 2))
+	((let ((inf (math-infinitep a)))
+	   (and inf
+		(math-mul (calcFunc-abssqr (math-infinite-dir a inf)) inf))))
+	(t (calc-record-why 'numvecp a)
+	   (list 'calcFunc-abssqr a)))
+)
+(defun math-sqr (a)
+  (math-mul a a)
+)
+
+
+;;;; Number theory.
+
+(defun calcFunc-idiv (a b)   ; [I I I] [Public]
+  (cond ((and (Math-natnump a) (Math-natnump b) (not (eq b 0)))
+	 (math-quotient a b))
+	((Math-realp a)
+	 (if (Math-realp b)
+	     (let ((calc-prefer-frac t))
+	       (math-floor (math-div a b)))
+	   (math-reject-arg b 'realp)))
+	((eq (car-safe a) 'hms)
+	 (if (eq (car-safe b) 'hms)
+	     (let ((calc-prefer-frac t))
+	       (math-floor (math-div a b)))
+	   (math-reject-arg b 'hmsp)))
+	((and (or (eq (car-safe a) 'intv) (Math-realp a))
+	      (or (eq (car-safe b) 'intv) (Math-realp b)))
+	 (math-floor (math-div a b)))
+	((or (math-infinitep a)
+	     (math-infinitep b))
+	 (math-div a b))
+	(t (math-reject-arg a 'anglep)))
+)
+
+
+;;; Combine two terms being added, if possible.
+(defun math-combine-sum (a b nega negb scalar-okay)
+  (if (and scalar-okay (Math-objvecp a) (Math-objvecp b))
+      (math-add-or-sub a b nega negb)
+    (let ((amult 1) (bmult 1))
+      (and (consp a)
+	   (cond ((and (eq (car a) '*)
+		       (Math-objectp (nth 1 a)))
+		  (setq amult (nth 1 a)
+			a (nth 2 a)))
+		 ((and (eq (car a) '/)
+		       (Math-objectp (nth 2 a)))
+		  (setq amult (if (Math-integerp (nth 2 a))
+				  (list 'frac 1 (nth 2 a))
+				(math-div 1 (nth 2 a)))
+			a (nth 1 a)))
+		 ((eq (car a) 'neg)
+		  (setq amult -1
+			a (nth 1 a)))))
+      (and (consp b)
+	   (cond ((and (eq (car b) '*)
+		       (Math-objectp (nth 1 b)))
+		  (setq bmult (nth 1 b)
+			b (nth 2 b)))
+		 ((and (eq (car b) '/)
+		       (Math-objectp (nth 2 b)))
+		  (setq bmult (if (Math-integerp (nth 2 b))
+				  (list 'frac 1 (nth 2 b))
+				(math-div 1 (nth 2 b)))
+			b (nth 1 b)))
+		 ((eq (car b) 'neg)
+		  (setq bmult -1
+			b (nth 1 b)))))
+      (and (if math-simplifying
+	       (Math-equal a b)
+	     (equal a b))
+	   (progn
+	     (if nega (setq amult (math-neg amult)))
+	     (if negb (setq bmult (math-neg bmult)))
+	     (setq amult (math-add amult bmult))
+	     (math-mul amult a)))))
+)
+
+(defun math-add-or-sub (a b aneg bneg)
+  (if aneg (setq a (math-neg a)))
+  (if bneg (setq b (math-neg b)))
+  (if (or (Math-vectorp a) (Math-vectorp b))
+      (math-normalize (list '+ a b))
+    (math-add a b))
+)
+
+;;; The following is expanded out four ways for speed.
+(defun math-combine-prod (a b inva invb scalar-okay)
+  (cond
+   ((or (and inva (Math-zerop a))
+	(and invb (Math-zerop b)))
+    nil)
+   ((and scalar-okay (Math-objvecp a) (Math-objvecp b))
+    (setq a (math-mul-or-div a b inva invb))
+    (and (Math-objvecp a)
+	 a))
+   ((and (eq (car-safe a) '^)
+	 inva
+	 (math-looks-negp (nth 2 a)))
+    (math-mul (math-pow (nth 1 a) (math-neg (nth 2 a))) b))
+   ((and (eq (car-safe b) '^)
+	 invb
+	 (math-looks-negp (nth 2 b)))
+    (math-mul a (math-pow (nth 1 b) (math-neg (nth 2 b)))))
+   (t (let ((apow 1) (bpow 1))
+	(and (consp a)
+	     (cond ((and (eq (car a) '^)
+			 (or math-simplifying
+			     (Math-numberp (nth 2 a))))
+		    (setq apow (nth 2 a)
+			  a (nth 1 a)))
+		   ((eq (car a) 'calcFunc-sqrt)
+		    (setq apow '(frac 1 2)
+			  a (nth 1 a)))
+		   ((and (eq (car a) 'calcFunc-exp)
+			 (or math-simplifying
+			     (Math-numberp (nth 1 a))))
+		    (setq apow (nth 1 a)
+			  a math-combine-prod-e))))
+	(and (consp a) (eq (car a) 'frac)
+	     (Math-lessp (nth 1 a) (nth 2 a))
+	     (setq a (math-div 1 a) apow (math-neg apow)))
+	(and (consp b)
+	     (cond ((and (eq (car b) '^)
+			 (or math-simplifying
+			     (Math-numberp (nth 2 b))))
+		    (setq bpow (nth 2 b)
+			  b (nth 1 b)))
+		   ((eq (car b) 'calcFunc-sqrt)
+		    (setq bpow '(frac 1 2)
+			  b (nth 1 b)))
+		   ((and (eq (car b) 'calcFunc-exp)
+			 (or math-simplifying
+			     (Math-numberp (nth 1 b))))
+		    (setq bpow (nth 1 b)
+			  b math-combine-prod-e))))
+	(and (consp b) (eq (car b) 'frac)
+	     (Math-lessp (nth 1 b) (nth 2 b))
+	     (setq b (math-div 1 b) bpow (math-neg bpow)))
+	(if inva (setq apow (math-neg apow)))
+	(if invb (setq bpow (math-neg bpow)))
+	(or (and (if math-simplifying
+		     (math-commutative-equal a b)
+		   (equal a b))
+		 (let ((sumpow (math-add apow bpow)))
+		   (and (or (not (Math-integerp a))
+			    (Math-zerop sumpow)
+			    (eq (eq (car-safe apow) 'frac)
+				(eq (car-safe bpow) 'frac)))
+			(progn
+			  (and (math-looks-negp sumpow)
+			       (Math-ratp a) (Math-posp a)
+			       (setq a (math-div 1 a)
+				     sumpow (math-neg sumpow)))
+			  (cond ((equal sumpow '(frac 1 2))
+				 (list 'calcFunc-sqrt a))
+				((equal sumpow '(frac -1 2))
+				 (math-div 1 (list 'calcFunc-sqrt a)))
+				((and (eq a math-combine-prod-e)
+				      (eq a b))
+				 (list 'calcFunc-exp sumpow))
+				(t
+				 (condition-case err
+				     (math-pow a sumpow)
+				   (inexact-result (list '^ a sumpow)))))))))
+	    (and math-simplifying-units
+		 math-combining-units
+		 (let* ((ua (math-check-unit-name a))
+			ub)
+		   (and ua
+			(eq ua (setq ub (math-check-unit-name b)))
+			(progn
+			  (setq ua (if (eq (nth 1 a) (car ua))
+				       1
+				     (nth 1 (assq (aref (symbol-name (nth 1 a))
+							0)
+						  math-unit-prefixes)))
+				ub (if (eq (nth 1 b) (car ub))
+				       1
+				     (nth 1 (assq (aref (symbol-name (nth 1 b))
+							0)
+						  math-unit-prefixes))))
+			  (if (Math-lessp ua ub)
+			      (let (temp)
+				(setq temp a a b b temp
+				      temp ua ua ub ub temp
+				      temp apow apow bpow bpow temp)))
+			  (math-mul (math-pow (math-div ua ub) apow)
+				    (math-pow b (math-add apow bpow)))))))
+	    (and (equal apow bpow)
+		 (Math-natnump a) (Math-natnump b)
+		 (cond ((equal apow '(frac 1 2))
+			(list 'calcFunc-sqrt (math-mul a b)))
+		       ((equal apow '(frac -1 2))
+			(math-div 1 (list 'calcFunc-sqrt (math-mul a b))))
+		       (t
+			(setq a (math-mul a b))
+			(condition-case err
+			    (math-pow a apow)
+			  (inexact-result (list '^ a apow))))))))))
+)
+(setq math-combine-prod-e '(var e var-e))
+
+(defun math-mul-or-div (a b ainv binv)
+  (if (or (Math-vectorp a) (Math-vectorp b))
+      (math-normalize
+       (if ainv
+	   (if binv
+	       (list '/ (math-div 1 a) b)
+	     (list '/ b a))
+	 (if binv
+	     (list '/ a b)
+	   (list '* a b))))
+    (if ainv
+	(if binv
+	    (math-div (math-div 1 a) b)
+	  (math-div b a))
+      (if binv
+	  (math-div a b)
+	(math-mul a b))))
+)
+
+(defun math-commutative-equal (a b)
+  (if (memq (car-safe a) '(+ -))
+      (and (memq (car-safe b) '(+ -))
+	   (let ((bterms nil) aterms p)
+	     (math-commutative-collect b nil)
+	     (setq aterms bterms bterms nil)
+	     (math-commutative-collect a nil)
+	     (and (= (length aterms) (length bterms))
+		  (progn
+		    (while (and aterms
+				(progn
+				  (setq p bterms)
+				  (while (and p (not (equal (car aterms)
+							    (car p))))
+				    (setq p (cdr p)))
+				  p))
+		      (setq bterms (delq (car p) bterms)
+			    aterms (cdr aterms)))
+		    (not aterms)))))
+    (equal a b))
+)
+
+(defun math-commutative-collect (b neg)
+  (if (eq (car-safe b) '+)
+      (progn
+	(math-commutative-collect (nth 1 b) neg)
+	(math-commutative-collect (nth 2 b) neg))
+    (if (eq (car-safe b) '-)
+	(progn
+	  (math-commutative-collect (nth 1 b) neg)
+	  (math-commutative-collect (nth 2 b) (not neg)))
+      (setq bterms (cons (if neg (math-neg b) b) bterms))))
+)
+
+