v13i028: Emacs Calculator 1.01, part 02/19

David Gillespie daveg at csvax.caltech.edu
Wed Jun 6 09:29:18 AEST 1990


Posting-number: Volume 13, Issue 28
Submitted-by: daveg at csvax.caltech.edu (David Gillespie)
Archive-name: gmcalc/part02

---- Cut Here and unpack ----
#!/bin/sh
# this is part 2 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc.el continued
#
CurArch=2
if test ! -r s2_seq_.tmp
then echo "Please unpack part 1 first!"
     exit 1; fi
( read Scheck
  if test "$Scheck" != $CurArch
  then echo "Please unpack part $Scheck next!"
       exit 1;
  else exit 0; fi
) < s2_seq_.tmp || exit 1
echo "x - Continuing file calc.el"
sed 's/^X//' << 'SHAR_EOF' >> calc.el
X)
X
X(defun calc-record (val &optional prefix)
X  (or calc-executing-macro
X      (let* ((mainbuf (current-buffer))
X	     (buf (get-buffer-create "*Calc Trail*"))
X	     (calc-display-raw (eq calc-display-raw t))
X	     (fval (if val
X		       (if (stringp val)
X			   val
X			 (math-showing-full-precision
X			  (math-format-flat-expr val 0)))
X		     "")))
X	(save-excursion
X	  (set-buffer buf)
X	  (if (not (eq major-mode 'calc-trail-mode))
X	      (calc-trail-mode mainbuf))
X	  (let ((aligned (calc-check-trail-aligned))
X		(buffer-read-only nil))
X	    (goto-char (point-max))
X	    (cond ((null prefix) (insert "     "))
X		  ((> (length prefix) 5) (insert (substring prefix 0 5) " "))
X		  (t (insert (format "%4s " prefix))))
X	    (insert fval "\n")
X	    (let ((win (get-buffer-window buf)))
X	      (if (and aligned win (not (memq 'hold-trail calc-command-flags)))
X		  (progn
X		    (calc-trail-here))))
X	    (goto-char (1- (point-max)))))))
X  val
X)
X
X(defun calc-record-list (vals &optional prefix)
X  (while vals
X    (or (eq (car vals) 'top-of-stack)
X	(progn
X	  (calc-record (car vals) prefix)
X	  (setq prefix "...")))
X    (setq vals (cdr vals)))
X)
X
X(defun calc-trail-display (flag &optional no-refresh)
X  "Turn the Trail display on or off.
XWith prefix argument 1, turn it on; with argument 0, turn it off."
X  (interactive "P")
X  (let* ((trail (get-buffer-create "*Calc Trail*"))
X	 (win (get-buffer-window trail)))
X    (if (setq calc-display-trail
X	      (not (if flag (memq flag '(nil 0)) win)))
X	(if (null win)
X	    (progn
X	      (if (and (boundp 'calc-trail-window-hook) calc-trail-window-hook)
X		  (run-hooks 'calc-trail-window-hook)
X		(let ((w (split-window nil (/ (* (window-width) 2) 3) t)))
X		  (set-window-buffer w trail)))
X	      (calc-wrapper
X	       (or no-refresh
X		   (calc-refresh)))))
X      (if win
X	  (progn
X	    (delete-window win)
X	    (calc-wrapper
X	     (or no-refresh
X		 (calc-refresh)))))
X      (if (and (boundp 'overlay-arrow-position)
X	       (eq overlay-arrow-position calc-trail-pointer))
X	  (setq overlay-arrow-position nil)))
X    trail)
X)
X
X(defun calc-trail-here ()
X  "Move the trail pointer to the current cursor line."
X  (interactive)
X  (if (eq major-mode 'calc-trail-mode)
X      (progn
X	(beginning-of-line)
X	(if (bobp)
X	    (forward-line 1)
X	  (if (eobp)
X	      (forward-line -1)))
X	(if (or (bobp) (eobp))
X	    (setq overlay-arrow-position nil)   ; trail is empty
X	  (set-marker calc-trail-pointer (point) (current-buffer))
X	  (setq overlay-arrow-string (concat (buffer-substring (point)
X							       (+ (point) 4))
X					     ">")
X		overlay-arrow-position calc-trail-pointer)
X	  (forward-char 4)
X	  (let ((win (get-buffer-window (current-buffer))))
X	    (if win
X		(save-excursion
X		  (forward-line (/ (window-height) 2))
X		  (forward-line (- 1 (window-height)))
X		  (set-window-start win (point))
X		  (set-window-point win (+ calc-trail-pointer 4)))))))
X    (error "Not in Calc Trail buffer"))
X)
X
X
X
X
X;;;; The Undo list.
X
X(defun calc-record-undo (rec)
X  (or calc-executing-macro
X      (if (memq 'undo calc-command-flags)
X	  (setq calc-undo-list (cons (cons rec (car calc-undo-list))
X				     (cdr calc-undo-list)))
X	(setq calc-undo-list (cons (list rec) calc-undo-list)
X	      calc-redo-list nil)
X	(calc-set-command-flag 'undo)))
X)
X
X
X
X;;; Arithmetic commands.
X
X(defun calc-binary-op (name func arg &optional ident unary)
X  (if (null arg)
X      (calc-enter-result 2 name (cons func (calc-top-list-n 2)))
X    (calc-extensions)
X    (calc-binary-op-fancy name func arg ident unary))
X)
X
X(defun calc-unary-op (name func arg)
X  (if (null arg)
X      (calc-enter-result 1 name (list func (calc-top-n 1)))
X    (calc-extensions)
X    (calc-unary-op-fancy name func arg))
X)
X
X
X(defun calc-plus (arg)
X  "Add the top two elements of the Calculator stack."
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-binary-op "+" 'calcFunc-add arg 0))
X)
X
X(defun calc-minus (arg)
X  "Subtract the top two elements of the Calculator stack."
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-binary-op "-" 'calcFunc-sub arg 0 'calcFunc-neg))
X)
X
X(defun calc-times (arg)
X  "Multiply the top two elements of the Calculator stack."
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-binary-op "*" 'calcFunc-mul arg 1))
X)
X
X(defun calc-divide (arg)
X  "Divide the top two elements of the Calculator stack."
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-binary-op "/" 'calcFunc-div arg 0 'calcFunc-inv))
X)
X
X(defun calc-power (arg)
X  "Compute y^x for the top two elements of the Calculator stack."
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-binary-op "^" 'calcFunc-pow arg))
X)
X
X(defun calc-mod (arg)
X  "Compute the modulo of the top two elements of the Calculator stack."
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-binary-op "%" 'calcFunc-mod arg))
X)
X
X(defun calc-inv (arg)
X  "Invert the number or square matrix on the top of the stack."
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-unary-op "inv" 'calcFunc-inv arg))
X)
X
X(defun calc-change-sign (arg)
X  "Change the sign of the top element of the Calculator stack."
X  (interactive "P")
X  (calc-wrapper
X   (calc-unary-op "chs" 'calcFunc-neg arg))
X)
X
X
X
X;;; Stack management commands.
X
X(defun calc-enter (n)
X  "Duplicate the top N elements of the Calculator stack.
XWith a negative argument -N, duplicate the Nth element of the stack."
X  (interactive "p")
X  (calc-wrapper
X   (cond ((< n 0)
X	  (calc-push (calc-top (- n))))
X	 ((= n 0)
X	  (calc-push-list (calc-top-list (calc-stack-size))))
X	 (t
X	  (calc-push-list (calc-top-list n)))))
X)
X
X(defun calc-over (n)
X  "Duplicate the Nth element of the Calculator stack.
XWith a negative argument -N, duplicate the top N elements of the stack."
X  (interactive "P")
X  (if n
X      (calc-enter (- (prefix-numeric-value n)))
X    (calc-enter -2))
X)
X
X(defun calc-pop (n)
X  "Pop (and discard) the top N elements of the stack.
XWith a negative argument -N, remove the Nth element from the stack."
X  (interactive "P")
X  (calc-wrapper
X   (let* ((nn (prefix-numeric-value n))
X	  (top (and (null n) (calc-top 1))))
X     (cond ((and (null n)
X		 (eq (car-safe top) 'incomplete)
X		 (> (length top) (if (eq (nth 1 top) 'intv) 3 2)))
X	    (calc-pop-push 1 (let ((tt (copy-sequence top)))
X			       (setcdr (nthcdr (- (length tt) 2) tt) nil)
X			       tt)))
X	   ((< nn 0)
X	    (calc-pop-stack 1 (- nn)))
X	   ((= nn 0)
X	    (calc-pop-stack (calc-stack-size)))
X	   (t
X	    (calc-pop-stack nn)))))
X)
X
X(defun calc-roll-down (n)
X  "Exchange the top two elements of the Calculator stack.
XWith a numeric prefix, roll down the top N elements."
X  (interactive "P")
X  (calc-wrapper
X   (let ((nn (prefix-numeric-value n)))
X     (cond ((null n)
X	    (calc-roll-down-stack 2))
X	   ((> nn 0)
X	    (calc-roll-down-stack nn))
X	   ((= nn 0)
X	    (calc-pop-push-list (calc-stack-size)
X				(reverse
X				 (calc-top-list (calc-stack-size)))))
X	   (t
X	    (calc-roll-down-stack (calc-stack-size) (- nn))))))
X)
X
X(defun calc-roll-up (n)
X  "Roll up the top three elements of the Calculator stack.
XWith a numeric prefix, roll up the top N elements."
X  (interactive "P")
X  (calc-wrapper
X   (let ((nn (prefix-numeric-value n)))
X     (cond ((null n)
X	    (calc-roll-up-stack 3))
X	   ((> nn 0)
X	    (calc-roll-up-stack nn))
X	   ((= nn 0)
X	    (calc-pop-push-list (calc-stack-size)
X				(reverse
X				 (calc-top-list (calc-stack-size)))))
X	   (t
X	    (calc-roll-up-stack (calc-stack-size) (- nn))))))
X)
X
X
X
X
X;;; Miscellaneous commands.
X
X(defun calc-precision (n)
X  "Display current float precision for Calculator, or set precision to N digits."
X  (interactive "NPrecision: ")
X  (calc-wrapper
X   (if (< (prefix-numeric-value n) 3)
X       (error "Precision must be at least 3 digits.")
X     (setq calc-internal-prec (prefix-numeric-value n))
X     (calc-record calc-internal-prec "prec"))
X   (message "Floating-point precision is %d digits." calc-internal-prec))
X)
X
X
X(defun calc-num-prefix-name (n)
X  (cond ((eq n '-) "- ")
X	((equal n '(4)) "C-u ")
X	((consp n) (format "%d " (car n)))
X	((integerp n) (format "%d " n))
X	(t ""))
X)
X
X(defun calc-missing-key (n)
X  "This is a placeholder for a command which needs to be loaded from calc-ext.
XWhen this key is used, calc-ext (the Calculator extensions module) will be
Xloaded and the keystroke automatically re-typed."
X  (interactive "P")
X  (calc-extensions)
X  (if (keymapp (key-binding (char-to-string last-command-char)))
X      (message "%s%c-" (calc-num-prefix-name n) last-command-char))
X  (setq unread-command-char last-command-char
X	prefix-arg n)
X)
X
X(defun calc-why ()
X  "Explain why the last result was unusual."
X  (interactive)
X  (if (not (eq this-command last-command))
X      (setq calc-which-why calc-why))
X  (if calc-which-why
X      (progn
X	(calc-explain-why (car calc-which-why))
X	(setq calc-which-why (cdr calc-which-why)))
X    (if calc-why
X	(progn
X	  (message "(No further explanations available)")
X	  (setq calc-which-why calc-why))
X      (message "No explanations available")))
X)
X(setq calc-which-why nil)
X
X(defun calc-flush-caches ()
X  "Clear all caches used internally by the Calculator, such as the values of
Xpi and e.  These values will be recomputed next time they are requested."
X  (interactive)
X  (calc-wrapper
X   (setq math-lud-cache nil
X	 math-log2-cache nil
X	 math-max-digits-cache nil
X	 math-integral-cache nil
X	 math-units-table nil)
X   (mapcar (function (lambda (x) (set x -100))) math-cache-list)
X   (message "All internal calculator caches have been reset."))
X)
X(setq math-cache-list nil)
X
X
X
X;;;; Reading an expression in algebraic form.
X
X(defun calc-algebraic-entry ()
X  "Read an algebraic expression (e.g., 1+2*3) and push the result on the stack."
X  (interactive)
X  (calc-wrapper
X   (calc-alg-entry))
X)
X
X(defun calc-auto-alg-entry ()
X  "Begin entering an algebraic expression with a '$' or '\"' character."
X  (interactive)
X  (calc-wrapper
X   (calc-alg-entry (char-to-string last-command-char)))
X)
X
X(defun calc-alg-entry (&optional initial prompt)
X  (let* ((calc-dollar-values (mapcar 'car-safe
X				     (nthcdr calc-stack-top calc-stack)))
X	 (calc-dollar-used 0)
X	 (alg-exp (calc-do-alg-entry initial prompt t)))
X    (let ((nvals (mapcar 'calc-normalize alg-exp)))
X      (while alg-exp
X	(calc-record (car alg-exp) "alg'")
X	(calc-pop-push-record calc-dollar-used "" (car nvals))
X	(setq alg-exp (cdr alg-exp)
X	      nvals (cdr nvals)
X	      calc-dollar-used 0)))
X    (calc-handle-whys))
X)
X
X(defun calc-do-alg-entry (&optional initial prompt no-normalize)
X  (let* ((alg-exp 'error)
X	 (alg (read-from-minibuffer (or prompt "Algebraic: ")
X				    (or initial "")
X				    calc-alg-ent-map nil)))
X    (if (eq alg-exp 'error)
X	(if (eq (car (setq alg-exp (math-read-exprs alg)))
X		'error)
X	    (error "Error: %s" (or (nth 2 exp) "Bad format"))))
X    (or no-normalize
X	(setq alg-exp (mapcar 'calc-normalize alg-exp)))
X    alg-exp)
X)
X
X(defvar calc-alg-ent-map nil "Keymap for use by the calc-algebraic-entry command.")
X(if calc-alg-ent-map
X    ()
X  (setq calc-alg-ent-map (copy-keymap minibuffer-local-map))
X  (define-key calc-alg-ent-map "'" 'calcAlg-previous)
X  (define-key calc-alg-ent-map "\ep" 'calcAlg-plus-minus)
X  (define-key calc-alg-ent-map "\em" 'calcAlg-mod)
X  (define-key calc-alg-ent-map "\C-m" 'calcAlg-enter)
X  (define-key calc-alg-ent-map "\C-j" 'calcAlg-enter)
X)
X
X(defun calcAlg-plus-minus ()
X  (interactive)
X  (if (calc-minibuffer-contains ".* \\'")
X      (insert "+/- ")
X    (insert " +/- "))
X)
X
X(defun calcAlg-mod ()
X  (interactive)
X  (if (not (calc-minibuffer-contains ".* \\'"))
X      (insert " "))
X  (if (calc-minibuffer-contains ".* mod +\\'")
X      (if calc-previous-modulo
X	  (insert (math-format-flat-expr calc-previous-modulo 0))
X	(beep))
X    (insert "mod "))
X)
X
X(defun calcAlg-previous ()
X  (interactive)
X  (if (calc-minibuffer-contains "\\`\\'")
X      (if calc-previous-alg-entry
X	  (insert calc-previous-alg-entry)
X	(beep))
X    (insert "'"))
X)
X
X(defun calcAlg-enter ()
X  (interactive)
X  (let ((exp (and (> (buffer-size) 0)
X		  (math-read-exprs (buffer-string)))))
X    (if (eq (car-safe exp) 'error)
X	(progn
X	  (goto-char (point-min))
X	  (forward-char (nth 1 exp))
X	  (beep)
X	  (calc-temp-minibuffer-message
X	   (concat " [" (or (nth 2 exp) "Error") "]"))
X	  (setq unread-command-char -1))
X      (setq alg-exp (if (calc-minibuffer-contains "\\` *\\[ *\\'")
X			'((incomplete vec))
X		      exp)
X	    calc-previous-alg-entry (buffer-string))
X      (exit-minibuffer)))
X)
X
X
X
X;;;; Reading a number using the minibuffer.
X
X(defun calcDigit-start ()
X  "Begin digit entry in the Calculator."
X  (interactive)
X  (calc-wrapper
X   (if calc-algebraic-mode
X       (cond ((eq last-command-char ?e) (calc-alg-entry "1e"))
X	     ((eq last-command-char ?#) (calc-alg-entry
X					 (format "%d#" calc-number-radix)))
X	     ((eq last-command-char ?_) (calc-alg-entry "-"))
X	     ((eq last-command-char ?@) (calc-alg-entry "0@ "))
X	     (t (calc-alg-entry (char-to-string last-command-char))))
X     (let ((calc-digit-value 'yow)
X	   (calc-prev-char nil)
X	   (calc-prev-prev-char nil))
X       (setq unread-command-char last-command-char)
X       (let ((str (read-from-minibuffer "Calc: " ""
X					calc-digit-map)))
X	 (if (eq calc-digit-value 'yow)
X	     (setq calc-digit-value (math-read-number str))))
X       (if (stringp calc-digit-value)
X	   (calc-alg-entry calc-digit-value)
X	 (if calc-digit-value
X	     (calc-push (calc-record (calc-normalize calc-digit-value)))))
X       (if (eq calc-prev-char 'dots)
X	   (progn
X	     (calc-extensions)
X	     (calc-dots))))))
X)
X
X(defun calcDigit-nondigit ()
X  (interactive)
X  (setq calc-digit-value (math-read-number (buffer-string)))
X  (if (and (null calc-digit-value) (> (buffer-size) 0))
X      (progn
X	(beep)
X	(calc-temp-minibuffer-message " [Bad format]"))
X    (or (memq last-command-char '(32 10 13))
X	(setq prefix-arg current-prefix-arg
X	      unread-command-char last-command-char))
X    (exit-minibuffer))
X)
X
X(defun calcDigit-algebraic ()
X  (interactive)
X  (if (calc-minibuffer-contains ".*[@oh] *[^'m ]+[^'m]*\\'")
X      (calcDigit-key)
X    (setq calc-digit-value (buffer-string))
X    (exit-minibuffer))
X)
X
X(defun calc-minibuffer-contains (rex)
X  (save-excursion
X    (goto-char (point-min))
X    (looking-at rex))
X)
X
X(defun calcDigit-key ()
X  (interactive)
X  (goto-char (point-max))
X  (if (or (and (memq last-command-char '(?+ ?-))
X	       (> (buffer-size) 0)
X	       (/= (preceding-char) ?e))
X	  (and (memq last-command-char '(?m ?s))
X	       (not (calc-minibuffer-contains "[-+]?[0-9]+\\.?0*[@oh].*"))
X	       (not (calc-minibuffer-contains "[-+]?\\(1[1-9]\\|[2-9][0-9]\\)#.*"))))
X      (calcDigit-nondigit)
X    (if (calc-minibuffer-contains "\\([-+]?\\|.* \\)\\'")
X	(cond ((memq last-command-char '(?. ?@)) (insert "0"))
X	      ((and (memq last-command-char '(?o ?h ?m))
X		    (not (calc-minibuffer-contains ".*#.*"))) (insert "0"))
X	      ((memq last-command-char '(?: ?e)) (insert "1"))
X	      ((eq last-command-char ?#)
X	       (insert (int-to-string calc-number-radix)))))
X    (if (and (calc-minibuffer-contains "\\([-+]?[0-9]+#\\|[^:]*:\\)\\'")
X	     (eq last-command-char ?:))
X	(insert "1"))
X    (if (or (and (memq last-command-char '(?e ?h ?o ?m ?s ?p))
X		 (calc-minibuffer-contains ".*#.*"))
X	    (and (eq last-command-char ?n)
X		 (calc-minibuffer-contains "[-+]?\\(2[4-9]\\|[3-9][0-9]\\)#.*")))
X	(setq last-command-char (upcase last-command-char)))
X    (cond
X     ((memq last-command-char '(?_ ?n))
X      (goto-char (point-min))
X      (if (and (search-forward " +/- " nil t)
X	       (not (search-forward "e" nil t)))
X	  (beep)
X	(and (not (calc-minibuffer-contains ".*#.*"))
X	     (search-forward "e" nil t))
X	(if (looking-at "+")
X	    (delete-char 1))
X	(if (looking-at "-")
X	    (delete-char 1)
X	  (insert "-")))
X      (goto-char (point-max)))
X     ((eq last-command-char ?p)
X      (if (or (calc-minibuffer-contains ".*\\+/-.*")
X	      (calc-minibuffer-contains ".*mod.*")
X	      (calc-minibuffer-contains ".*#.*")
X	      (calc-minibuffer-contains ".*[-+e:]\\'"))
X	  (beep)
X	(if (not (calc-minibuffer-contains ".* \\'"))
X	    (insert " "))
X	(insert "+/- ")))
X     ((and (eq last-command-char ?M)
X	   (not (calc-minibuffer-contains
X		 "[-+]?\\(2[3-9]\\|[3-9][0-9]\\)#.*")))
X      (if (or (calc-minibuffer-contains ".*\\+/-.*")
X	      (calc-minibuffer-contains ".*mod *[^ ]+")
X	      (calc-minibuffer-contains ".*[-+e:]\\'"))
X	  (beep)
X	(if (calc-minibuffer-contains ".*mod \\'")
X	    (if calc-previous-modulo
X		(insert (math-format-flat-expr calc-previous-modulo 0))
X	      (beep))
X	  (if (not (calc-minibuffer-contains ".* \\'"))
X	      (insert " "))
X	  (insert "mod "))))
X     (t
X      (insert (char-to-string last-command-char))
X      (if (or (and (calc-minibuffer-contains "[-+]?\\(.*\\+/- *\\|.*mod *\\)?\\([0-9][0-9]?\\)#[0-9a-zA-Z]*\\(:[0-9a-zA-Z]*\\)?\\(:[0-9a-zA-Z]*\\)?\\'")
X		   (let ((radix (string-to-int
X				 (buffer-substring
X				  (match-beginning 2) (match-end 2)))))
X		     (and (>= radix 2)
X			  (<= radix 36)
X			  (or (memq last-command-char '(?# ?:))
X			      (let ((dig (math-read-radix-digit
X					  (upcase last-command-char))))
X				(and dig
X				     (< dig radix)))))))
X	      (save-excursion
X		(goto-char (point-min))
X         	(looking-at
X		 "[-+]?\\(.*\\+/- *\\|.*mod *\\)?\\([0-9]+\\.?0*[@oh] *\\)?\\([0-9]+\\.?0*['m] *\\)?[0-9]*\\(\\.?[0-9]*\\(e[-+]?[0-9]*\\)?\\|[0-9]:\\([0-9]+:\\)?[0-9]*\\)?[\"s]?\\'")))
X	  (if (and (memq last-command-char '(?@ ?o ?h ?\' ?m))
X		   (string-match " " calc-hms-format))
X	      (insert " "))
X	(if (and (eq this-command last-command)
X		 (eq last-command-char ?.))
X	    (if (eq calc-prev-char ?.)
X		(progn
X		  (delete-backward-char 1)
X		  (if (calc-minibuffer-contains ".*\\.\\'")
X		      (delete-backward-char 1))
X		  (setq calc-prev-char 'dots
X			last-command-char 32)
X		  (if calc-prev-prev-char
X		      (calcDigit-nondigit)
X		    (setq calc-digit-value nil)
X		    (exit-minibuffer)))
X	      ;; just ignore extra decimal point, anticipating ".."
X	      (delete-backward-char 1))
X	  (delete-backward-char 1)
X	  (beep)
X	  (calc-temp-minibuffer-message " [Bad format]"))))))
X  (setq calc-prev-prev-char calc-prev-char
X	calc-prev-char last-command-char)
X)
X
X(defun calcDigit-letter ()
X  (interactive)
X  (if (calc-minibuffer-contains "[-+]?\\(1[1-9]\\|[2-9][0-9]\\)#.*")
X      (progn
X	(setq last-command-char (upcase last-command-char))
X	(calcDigit-key))
X    (calcDigit-nondigit))
X)
X
X(defun calcDigit-backspace ()
X  (interactive)
X  (goto-char (point-max))
X  (cond ((calc-minibuffer-contains ".* \\+/- \\'")
X	 (backward-delete-char 5))
X	((calc-minibuffer-contains ".* mod \\'")
X	 (backward-delete-char 5))
X	((calc-minibuffer-contains ".* \\'")
X	 (backward-delete-char 2))
X	(t (backward-delete-char 1)))
X  (if (= (buffer-size) 0)
X      (progn
X	(setq last-command-char 10)
X	(calcDigit-nondigit)))
X)
X
X(defun calc-temp-minibuffer-message (m)
X  "A Lisp version of temp_minibuffer_message from minibuf.c."
X  (let ((savemax (point-max)))
X    (save-excursion
X      (goto-char (point-max))
X      (insert m))
X    (let ((inhibit-quit t))
X      (sit-for 2)
X      (delete-region savemax (point-max))
X      (if quit-flag
X	  (setq quit-flag nil
X		unread-command-char 7))))
X)
X
X
X
X
X
X
X
X;;;; Arithmetic routines.
X;;;
X;;; An object as manipulated by one of these routines may take any of the
X;;; following forms:
X;;;
X;;; integer                 An integer.  For normalized numbers, this format
X;;;			    is used only for -999999 ... 999999.
X;;;
X;;; (bigpos N0 N1 N2 ...)   A big positive integer, N0 + N1*1000 + N2*10^6 ...
X;;; (bigneg N0 N1 N2 ...)   A big negative integer, - N0 - N1*1000 ...
X;;;			    Each digit N is in the range 0 ... 999.
X;;;			    Normalized, always at least three N present,
X;;;			    and the most significant N is nonzero.
X;;;
X;;; (frac NUM DEN)          A fraction.  NUM and DEN are small or big integers.
X;;;                         Normalized, DEN > 1.
X;;;
X;;; (float NUM EXP)         A floating-point number, NUM * 10^EXP;
X;;;                         NUM is a small or big integer, EXP is a small int.
X;;;			    Normalized, NUM is not a multiple of 10, and
X;;;			    abs(NUM) < 10^calc-internal-prec.
X;;;			    Normalized zero is stored as (float 0 0).
X;;;
X;;; (cplx REAL IMAG)        A complex number; REAL and IMAG are any of above.
X;;;			    Normalized, IMAG is nonzero.
X;;;
X;;; (polar R THETA)         Polar complex number.  Normalized, R > 0 and THETA
X;;;                         is neither zero nor 180 degrees (pi radians).
X;;;
X;;; (vec A B C ...)         Vector of objects A, B, C, ...  A matrix is a
X;;;                         vector of vectors.
X;;;
X;;; (hms H M S)             Angle in hours-minutes-seconds form.  All three
X;;;                         components have the same sign; H and M must be
X;;;                         numerically integers; M and S are expected to
X;;;                         lie in the range [0,60).
X;;;
X;;; (sdev X SIGMA)          Error form, X +/- SIGMA.  When normalized,
X;;;                         SIGMA > 0.  X and SIGMA are any real numbers,
X;;;                         or symbolic expressions which are assumed real.
X;;;
X;;; (intv MASK LO HI)       Interval form.  MASK is 0=(), 1=(], 2=[), or 3=[].
X;;;                         LO and HI are any real numbers, or symbolic
X;;;			    expressions which are assumed real, and LO < HI.
X;;;			    For [LO..HI], if LO = HI normalization produces LO,
X;;;			    and if LO > HI normalization produces [LO..LO).
X;;;			    For other intervals, if LO > HI normalization
X;;;			    sets HI equal to LO.
X;;;
X;;; (mod N M)	    	    Number modulo M.  When normalized, 0 <= N < M.
X;;;			    N and M are real numbers.
X;;;
X;;; (var V S)		    Symbolic variable.  V is a Lisp symbol which
X;;;			    represents the variable's visible name.  S is
X;;;			    the symbol which actually stores the variable's
X;;;			    value:  (var pi var-pi).
X;;;
X;;; In general, combining rational numbers in a calculation always produces
X;;; a rational result, but if either argument is a float, result is a float.
X
X;;; In the following comments, [x y z] means result is x, args must be y, z,
X;;; respectively, where the code letters are:
X;;;
X;;;    O  Normalized object (vector or number)
X;;;    V  Normalized vector
X;;;    N  Normalized number of any type
X;;;    N  Normalized complex number
X;;;    R  Normalized real number (float or rational)
X;;;    F  Normalized floating-point number
X;;;    T  Normalized rational number
X;;;    I  Normalized integer
X;;;    B  Normalized big integer
X;;;    S  Normalized small integer
X;;;    D  Digit (small integer, 0..999)
X;;;    L  Normalized bignum digit list (without "bigpos" or "bigneg" symbol)
X;;;       or normalized vector element list (without "vec")
X;;;    P  Predicate (truth value)
X;;;    X  Any Lisp object
X;;;    Z  "nil"
X;;;
X;;; Lower-case letters signify possibly un-normalized values.
X;;; "L.D" means a cons of an L and a D.
X;;; [N N; n n] means result will be normalized if argument is.
X;;; Also, [Public] marks routines intended to be called from outside.
X;;; [This notation has been neglected in many recent routines.]
X
X;;; Reduce an object to canonical (normalized) form.  [O o; Z Z] [Public]
X(defun math-normalize (a)
X  (cond
X   ((not (consp a))
X    (if (integerp a)
X	(if (or (>= a 1000000) (<= a -1000000))
X	    (math-bignum a)
X	  a)
X      a))
X   ((eq (car a) 'bigpos)
X    (if (eq (nth (1- (length a)) a) 0)
X	(let* ((last (setq a (copy-sequence a))) (digs a))
X	  (while (setq digs (cdr digs))
X	    (or (eq (car digs) 0) (setq last digs)))
X	  (setcdr last nil)))
X    (if (cdr (cdr (cdr a)))
X	a
X      (cond
X       ((cdr (cdr a)) (+ (nth 1 a) (* (nth 2 a) 1000)))
X       ((cdr a) (nth 1 a))
X       (t 0))))
X   ((eq (car a) 'bigneg)
X    (if (eq (nth (1- (length a)) a) 0)
X	(let* ((last (setq a (copy-sequence a))) (digs a))
X	  (while (setq digs (cdr digs))
X	    (or (eq (car digs) 0) (setq last digs)))
X	  (setcdr last nil)))
X    (if (cdr (cdr (cdr a)))
X	a
X      (cond
X       ((cdr (cdr a)) (- (+ (nth 1 a) (* (nth 2 a) 1000))))
X       ((cdr a) (- (nth 1 a)))
X       (t 0))))
X   ((eq (car a) 'frac)
X    (math-make-frac (math-normalize (nth 1 a))
X		    (math-normalize (nth 2 a))))
X   ((eq (car a) 'float)
X    (math-make-float (math-normalize (nth 1 a)) (nth 2 a)))
X   ((eq (car a) 'cplx)
X    (let ((real (math-normalize (nth 1 a)))
X	  (imag (math-normalize (nth 2 a))))
X      (if (math-zerop imag) real (list 'cplx real imag))))
X   ((eq (car a) 'polar)
X    (calc-extensions)
X    (math-normalize-polar a))
X   ((eq (car a) 'hms)
X    (calc-extensions)
X    (math-normalize-hms a))
X   ((eq (car a) 'mod)
X    (calc-extensions)
X    (math-normalize-mod a))
X   ((eq (car a) 'sdev)
X    (calc-extensions)
X    (math-make-sdev (math-normalize (nth 1 a))
X		    (math-normalize (nth 2 a))))
X   ((eq (car a) 'intv)
X    (calc-extensions)
X    (math-make-intv (nth 1 a)
X		    (math-normalize (nth 2 a))
X		    (math-normalize (nth 3 a))))
X   ((eq (car a) 'vec)
X    (cons 'vec (mapcar 'math-normalize (cdr a))))
X   ((memq (car a) '(quote special-const))
X    (math-normalize (nth 1 a)))
X   ((eq (car a) 'var)
X    a)
X   ((or (integerp (car a)) (and (consp (car a))
X				(not (eq (car (car a)) 'lambda))))
X    (if (null (cdr a))
X	(math-normalize (car a))
X      (error "Can't use multi-valued function in an expression")))
X   ((eq (car a) 'calcFunc-if)
X    (calc-extensions)
X    (math-normalize-logical-op a))
X   (t
X    (let ((args (mapcar 'math-normalize (cdr a))))
X      (or (and calc-simplify-mode
X	       (symbolp (car a))
X	       (or (eq calc-simplify-mode 'none)
X		   (and (eq calc-simplify-mode 'num)
X			(let ((aptr args))
X			  (while (and aptr (or (math-scalarp (car aptr))
X					       (eq (car-safe (car aptr))
X						   'mod)))
X			    (setq aptr (cdr aptr)))
X			  aptr)))
X	       (cons (car a) args))
X	  (condition-case err
X	      (let ((func (assq (car a) '( ( + . math-add )
X					   ( - . math-sub )
X					   ( * . math-mul )
X					   ( / . math-div )
X					   ( % . math-mod )
X					   ( ^ . math-pow )
X					   ( neg . math-neg )
X					   ( | . math-concat ) ))))
X		(if func
X		    (apply (cdr func) args)
X		  (and (or (consp (car a))
X			   (fboundp (car a))
X			   (and (not calc-extensions-loaded)
X				(calc-extensions)
X				(fboundp (car a))))
X		       (apply (car a) args))))
X	    (wrong-number-of-arguments
X	     (calc-record-why "Wrong number of arguments") nil)
X	    (wrong-type-argument
X	     (or calc-next-why (calc-record-why "Wrong type of argument"))
X	     nil)
X	    (args-out-of-range
X	     (calc-record-why "Argument out of range") nil)
X	    (inexact-result
X	     (calc-record-why "No exact representation for result") nil))
X	  (if (consp (car a))
X	      (math-dimension-error)
X	    (cons (car a) args))))))
X)
X
X(defmacro math-with-extra-prec (delta &rest body)
X  (` (math-normalize
X      (let ((calc-internal-prec (+ calc-internal-prec (, delta))))
X	(,@ body))))
X)
X(put 'math-with-extra-prec 'lisp-indent-hook 1)
X
X;;; Define "inexact-result" as an e-lisp error symbol.
X(put 'inexact-result 'error-conditions '(error inexact-result calc-error))
X(put 'inexact-result 'error-message "Calc internal error (inexact-result)")
X
X;;; Normalize a bignum digit list by trimming high-end zeros.  [L l]
X(defun math-norm-bignum (a)
X  (let ((digs a) (last nil))
X    (while digs
X      (or (eq (car digs) 0) (setq last digs))
X      (setq digs (cdr digs)))
X    (and last
X	 (progn
X	   (setcdr last nil)
X	   a)))
X)
X
X
X;;; Concatenate two vectors, or a vector and an object.  [V O O] [Public]
X(defun math-concat (v1 v2)
X  (if (stringp v1)
X      (concat v1 v2)
X    (calc-extensions)
X    (if (and (math-objvecp v1) (math-objvecp v2))
X	(append (if (and (math-vectorp v1)
X			 (or (math-matrixp v1)
X			     (not (math-matrixp v2))))
X		    v1
X		  (list 'vec v1))
X		(if (and (math-vectorp v2)
X			 (or (math-matrixp v2)
X			     (not (math-matrixp v1))))
X		    (cdr v2)
X		  (list v2)))
X      (list '| v1 v2)))
X)
X(defun calcFunc-vconcat (a b)
X  (math-normalize (list '| a b))
X)
X
X
X;;; True if A is zero.  Works for un-normalized values.  [P n] [Public]
X(defun math-zerop (a)
X  (if (consp a)
X      (cond ((memq (car a) '(bigpos bigneg))
X	     (while (eq (car (setq a (cdr a))) 0))
X	     (null a))
X	    ((memq (car a) '(frac float polar mod))
X	     (math-zerop (nth 1 a)))
X	    ((eq (car a) 'cplx)
X	     (and (math-zerop (nth 1 a)) (math-zerop (nth 2 a))))
X	    ((eq (car a) 'hms)
X	     (and (math-zerop (nth 1 a))
X		  (math-zerop (nth 2 a))
X		  (math-zerop (nth 3 a)))))
X    (eq a 0))
X)
X;;; Faster in-line version zerop, normalized values only.
X(defmacro Math-zerop (a)   ; [P N]
X  (` (if (consp (, a))
X	 (and (not (memq (car (, a)) '(bigpos bigneg)))
X	      (if (eq (car (, a)) 'float)
X		  (eq (nth 1 (, a)) 0)
X		(math-zerop (, a))))
X       (eq (, a) 0)))
X)
X
X(defun math-zerop-bignum (a)
X  (and (eq (car a) 0)
X       (progn
X	 (while (eq (car (setq a (cdr a))) 0))
X	 (null a)))
X)
X
X(defmacro Math-natnum-lessp (a b)
X  (` (if (consp (, a))
X	 (and (consp (, b))
X	      (= (math-compare-bignum (cdr (, a)) (cdr (, b))) -1))
X       (or (consp (, b))
X	   (< (, a) (, b)))))
X)
X
X(defmacro Math-integer-negp (a)
X  (` (if (consp (, a))
X	 (eq (car (, a)) 'bigneg)
X       (< (, a) 0)))
X)
X
X(defmacro Math-integer-posp (a)
X  (` (if (consp (, a))
X	 (eq (car (, a)) 'bigpos)
X       (> (, a) 0)))
X)
X
X;;; True if A is real and negative.  [P n] [Public]
X(defun math-negp (a)
X  (if (consp a)
X      (cond ((eq (car a) 'bigpos) nil)
X	    ((eq (car a) 'bigneg) (cdr a))
X	    ((eq (car a) 'frac)
X	     (if (Math-integer-negp (nth 2 a))
X		 (Math-integer-posp (nth 1 a))
X	       (Math-integer-negp (nth 1 a))))
X	    ((eq (car a) 'float)
X	     (Math-integer-negp (nth 1 a)))
X	    ((eq (car a) 'hms)
X	     (if (math-zerop (nth 1 a))
X		 (if (math-zerop (nth 2 a))
X		     (math-negp (nth 3 a))
X		   (math-negp (nth 2 a)))
X	       (math-negp (nth 1 a))))
X	    ((eq (car a) 'intv)
X	     (or (math-negp (nth 3 a))
X		 (and (math-zerop (nth 3 a))
X		      (memq (nth 1 a) '(0 2))))))
X    (< a 0))
X)
X(defmacro Math-negp (a)
X  (` (if (consp (, a))
X	 (or (eq (car (, a)) 'bigneg)
X	     (and (not (eq (car (, a)) 'bigpos))
X		  (if (memq (car (, a)) '(frac float))
X		      (Math-integer-negp (nth 1 (, a)))
X		    (math-negp (, a)))))
X       (< (, a) 0)))
X)
X
X;;; True if A is a negative number or an expression the starts with '-'.
X(defun math-looks-negp (a)   ; [P x] [Public]
X  (or (Math-negp a)
X      (eq (car-safe a) 'neg)
X      (and (memq (car-safe a) '(* /))
X	   (or (math-looks-negp (nth 1 a))
X	       (math-looks-negp (nth 2 a)))))
X)
X(defmacro Math-looks-negp (a)   ; [P x] [Public]
X  (` (or (Math-negp (, a))
X	 (and (consp (, a)) (or (eq (car (, a)) 'neg)
X				(and (memq (car (, a)) '(* /))
X				     (or (math-looks-negp (nth 1 (, a)))
X					 (math-looks-negp (nth 2 (, a)))))))))
X)
X
X;;; True if A is real and positive.  [P n] [Public]
X(defun math-posp (a)
X  (if (consp a)
X      (cond ((eq (car a) 'bigpos) (cdr a))
X	    ((eq (car a) 'bigneg) nil)
X	    ((eq (car a) 'frac)
X	     (if (Math-integer-negp (nth 2 a))
X		 (Math-integer-negp (nth 1 a))
X	       (Math-integer-posp (nth 1 a))))
X	    ((eq (car a) 'float)
X	     (Math-integer-posp (nth 1 a)))
X	    ((eq (car a) 'hms)
X	     (if (math-zerop (nth 1 a))
X		 (if (math-zerop (nth 2 a))
X		     (math-posp (nth 3 a))
X		   (math-posp (nth 2 a)))
X	       (math-posp (nth 1 a))))
X	    ((eq (car a) 'mod)
X	     (not (math-zerop (nth 1 a))))
X	    ((eq (car a) 'intv)
X	     (or (math-posp (nth 2 a))
X		 (and (math-zerop (nth 2 a))
X		      (memq (nth 1 a) '(0 1))))))
X    (> a 0))
X)
X(defmacro Math-posp (a)
X  (` (if (consp (, a))
X	 (or (eq (car (, a)) 'bigpos)
X	     (and (not (eq (car (, a)) 'bigneg))
X		  (if (memq (car (, a)) '(frac float))
X		      (Math-integer-posp (nth 1 (, a)))
X		    (math-posp (, a)))))
X       (> (, a) 0)))
X)
X
X;;; True if A is a small or big integer.  [P x] [Public]
X(defun math-integerp (a)
X  (or (integerp a)
X      (memq (car-safe a) '(bigpos bigneg)))
X)
X(defmacro Math-integerp (a)
X  (` (or (not (consp (, a)))
X	 (memq (car (, a)) '(bigpos bigneg))))
X)
X
X(fset 'math-fixnump (symbol-function 'integerp))
X(fset 'math-fixnatnump (symbol-function 'natnump))
X
X;;; True if A is (numerically) a non-negative integer.  [P N] [Public]
X(defun math-natnump (a)
X  (or (natnump a)
X      (eq (car-safe a) 'bigpos))
X)
X(defmacro Math-natnump (a)
X  (` (if (consp (, a))
X	 (eq (car (, a)) 'bigpos)
X       (>= (, a) 0)))
X)
X
X;;; True if A is a rational (or integer).  [P x] [Public]
X(defun math-ratp (a)
X  (or (integerp a)
X      (memq (car-safe a) '(bigpos bigneg frac)))
X)
X(defmacro Math-ratp (a)
X  (` (or (not (consp (, a)))
X	 (memq (car (, a)) '(bigpos bigneg frac))))
X)
X
X;;; True if A is a real (or rational).  [P x] [Public]
X(defun math-realp (a)
X  (or (integerp a)
X      (memq (car-safe a) '(bigpos bigneg frac float)))
X)
X(defmacro Math-realp (a)
X  (` (or (not (consp (, a)))
X	 (memq (car (, a)) '(bigpos bigneg frac float))))
X)
X
X;;; True if A is a real or HMS form.  [P x] [Public]
X(defun math-anglep (a)
X  (or (integerp a)
X      (memq (car-safe a) '(bigpos bigneg frac float hms)))
X)
X(defmacro Math-anglep (a)
X  (` (or (not (consp (, a)))
X	 (memq (car (, a)) '(bigpos bigneg frac float hms))))
X)
X
X;;; True if A is a floating-point real or complex number.  [P x] [Public]
X(defun math-floatp (a)
X  (or (eq (car-safe a) 'float)
X      (and (memq (car-safe a) '(cplx polar mod sdev intv))
X	   (or (math-floatp (nth 1 a))
X	       (math-floatp (nth 2 a))
X	       (and (eq (car a) 'intv) (math-floatp (nth 3 a))))))
X)
X
X;;; True if A is a number of any kind.  [P x] [Public]
X(defun math-numberp (a)
X  (or (integerp a)
X      (memq (car-safe a) '(bigpos bigneg frac float cplx polar)))
X)
X(defmacro Math-numberp (a)
X  (` (or (not (consp (, a)))
X	 (memq (car (, a)) '(bigpos bigneg frac float cplx polar))))
X)
X
X;;; True if A is a complex number or angle.  [P x] [Public]
X(defun math-scalarp (a)
X  (or (integerp a)
X      (memq (car-safe a) '(bigpos bigneg frac float cplx polar hms)))
X)
X(defmacro Math-scalarp (a)
X  (` (or (not (consp (, a)))
X	 (memq (car (, a)) '(bigpos bigneg frac float cplx polar hms))))
X)
X
X;;; True if A is a vector.  [P x] [Public]
X(defun math-vectorp (a)
X  (eq (car-safe a) 'vec)
X)
X(defmacro Math-vectorp (a)
X  (` (and (consp (, a)) (eq (car (, a)) 'vec)))
X)
X
X;;; True if A is a number or a vector.  [P x] [Public]
X(defun math-numvecp (a)
X  (or (Math-numberp a)
X      (Math-vectorp a))
X)
X
X;;; True if A is numerically (but not literally) an integer.  [P x] [Public]
X(defun math-messy-integerp (a)
X  (cond
X   ((eq (car-safe a) 'float) (>= (nth 2 a) 0))
X   ((eq (car-safe a) 'frac) (Math-integerp (math-normalize a))))
X)
X(defmacro Math-messy-integerp (a)
X  (` (and (consp (, a))
X	  (eq (car (, a)) 'float)
X	  (>= (nth 2 (, a)) 0)))
X)
X
X;;; True if A is any scalar data object.  [P x]
X(defun math-objectp (a)    ;  [Public]
X  (or (integerp a)
X      (memq (car-safe a) '(bigpos bigneg frac float cplx
X				  polar hms sdev intv mod)))
X)
X(defmacro Math-objectp (a)    ;  [Public]
X  (` (or (not (consp (, a)))
X	 (memq (car (, a))
X	       '(bigpos bigneg frac float cplx polar hms sdev intv mod))))
X)
X
X;;; True if A is any vector or scalar data object.  [P x]
X(defun math-objvecp (a)    ;  [Public]
X  (or (integerp a)
X      (memq (car-safe a) '(bigpos bigneg frac float cplx polar
X				  hms sdev intv mod vec incomplete)))
X)
X(defmacro Math-objvecp (a)    ;  [Public]
X  (` (or (not (consp (, a)))
X	 (memq (car (, a))
X	       '(bigpos bigneg frac float cplx polar hms sdev intv mod vec))))
X)
X
X
X;;; True if A is an even integer.  [P R R] [Public]
X(defun math-evenp (a)
X  (if (consp a)
X      (and (memq (car a) '(bigpos bigneg))
X	   (= (% (nth 1 a) 2) 0))
X    (= (% a 2) 0))
X)
X
X;;; Compute A / 2, for small or big integer A.  [I i]
X;;; If A is negative, type of truncation is undefined.
X(defun math-div2 (a)
X  (if (consp a)
X      (if (cdr a)
X	  (math-normalize (cons (car a) (math-div2-bignum (cdr a))))
X	0)
X    (/ a 2))
X)
X
X(defun math-div2-bignum (a)   ; [l l]
X  (cond
X   ((null (cdr a)) (list (/ (car a) 2)))
X   (t (cons (+ (/ (car a) 2) (* (% (nth 1 a) 2) 500))
X	    (math-div2-bignum (cdr a)))))
X)
X
X
X;;; Verify that A is a complete object and return A.  [x x] [Public]
X(defun math-check-complete (a)
X  (cond ((integerp a) a)
X	((eq (car-safe a) 'incomplete)
X	 (cond ((memq (nth 1 a) '(cplx polar))
X		(error "Complex number is incomplete"))
X	       ((eq (nth 1 a) 'vec)
X		(error "Vector is incomplete"))
X	       ((eq (nth 1 a) 'intv)
X		(error "Interval form is incomplete"))
X	       (t (error "Object is incomplete"))))
X	((consp a) a)
X	(t (error "Invalid data object encountered")))
X)
X
X;;; Reject an argument to a calculator function.  [Public]
X(defun math-reject-arg (&optional a p)
X  (calc-record-why p a)
X  (signal 'wrong-type-argument (and a (if p (list p a) (list a))))
X)
X
X
X;;; Coerce A to be an integer (by truncation toward zero).  [I N] [Public]
X(defun math-trunc (a)
X  (cond ((Math-integerp a) a)
X	((Math-looks-negp a)
X	 (math-neg (math-trunc (math-neg a))))
X	((eq (car a) 'float) (math-scale-int (nth 1 a) (nth 2 a)))
X	((eq (car a) 'frac) (math-quotient (nth 1 a) (nth 2 a)))
X	(t (calc-extensions)
X	   (math-trunc-fancy a)))
X)
X(fset 'calcFunc-trunc (symbol-function 'math-trunc))
X
X;;; Coerce A to be an integer (by truncation toward minus infinity).  [I N]
X(defun math-floor (a)    ;  [Public]
X  (cond ((Math-integerp a) a)
X	((Math-messy-integerp a) (math-trunc a))
X	((Math-realp a)
X	 (if (Math-negp a)
X	     (math-add (math-trunc a) -1)
X	   (math-trunc a)))
X	(t (calc-extensions)
X	   (math-floor-fancy a)))
X)
X(fset 'calcFunc-floor (symbol-function 'math-floor))
X
X
X;;; Coerce integer A to be a bignum.  [B S]
X(defun math-bignum (a)
X  (if (>= a 0)
X      (cons 'bigpos (math-bignum-big a))
X    (cons 'bigneg (math-bignum-big (- a))))
X)
X
X(defun math-bignum-big (a)   ; [L s]
X  (if (= a 0)
X      nil
X    (cons (% a 1000) (math-bignum-big (/ a 1000))))
X)
X
X
X;;; Build a normalized fraction.  [R I I]
X;;; (This could probably be implemented more efficiently than using the
X;;;  the plain gcd algorithm.)
X(defun math-make-frac (num den)
X  (if (Math-integer-negp den)
X      (setq num (math-neg num)
X	    den (math-neg den)))
X  (let ((gcd (math-gcd num den)))
X    (if (eq gcd 1)
X	(if (eq den 1)
X	    num
X	  (list 'frac num den))
X      (if (equal gcd den)
X	  (math-quotient num gcd)
X	(list 'frac (math-quotient num gcd) (math-quotient den gcd)))))
X)
X
X;;; Build a normalized floating-point number.  [F I S]
X(defun math-make-float (mant exp)
X  (if (eq mant 0)
X      '(float 0 0)
X    (let* ((ldiff (- calc-internal-prec (math-numdigs mant))))
X      (if (< ldiff 0)
X	  (setq mant (math-scale-rounding mant ldiff)
X		exp (- exp ldiff))))
X    (if (consp mant)
X	(let ((digs (cdr mant)))
X	  (if (= (% (car digs) 10) 0)
X	      (progn
X		(while (= (car digs) 0)
X		  (setq digs (cdr digs)
X			exp (+ exp 3)))
X		(while (= (% (car digs) 10) 0)
X		  (setq digs (math-div10-bignum digs)
X			exp (1+ exp)))
X		(setq mant (math-normalize (cons (car mant) digs))))))
X      (while (= (% mant 10) 0)
X	(setq mant (/ mant 10)
X	      exp (1+ exp))))
X    (list 'float mant exp))
X)
X
X(defun math-div10-bignum (a)   ; [l l]
X  (cond
X   ((null (cdr a)) (list (/ (car a) 10)))
X   (t (cons (+ (/ (car a) 10) (* (% (nth 1 a) 10) 100))
X	    (math-div10-bignum (cdr a)))))
X)
X
X;;; Coerce A to be a float.  [F N; V V] [Public]
X(defun math-float (a)
X  (cond ((Math-integerp a) (math-make-float a 0))
X	((eq (car a) 'frac) (math-div (math-float (nth 1 a)) (nth 2 a)))
X	((eq (car a) 'float) a)
X	((memq (car a) '(cplx polar vec hms sdev intv mod))
X	 (cons (car a) (mapcar 'math-float (cdr a))))
X	(t (math-reject-arg a 'objectp)))
X)
X(fset 'calcFunc-float (symbol-function 'math-float))
X
X
X;;; Compute the negative of A.  [O O; o o] [Public]
X(defmacro Math-integer-neg (a)
X  (` (if (consp (, a))
X	 (if (eq (car (, a)) 'bigpos)
X	     (cons 'bigneg (cdr (, a)))
X	   (cons 'bigpos (cdr (, a))))
X       (- (, a))))
X)
X(defun math-neg (a)
X  (cond ((not (consp a)) (- a))
X	((eq (car a) 'bigpos) (cons 'bigneg (cdr a)))
X	((eq (car a) 'bigneg) (cons 'bigpos (cdr a)))
X	((memq (car a) '(frac float))
X	 (list (car a) (Math-integer-neg (nth 1 a)) (nth 2 a)))
X	((memq (car a) '(cplx vec hms))
X	 (cons (car a) (mapcar 'math-neg (cdr a))))
X	(t (math-neg-fancy a)))
X)
X(defun calcFunc-neg (a)
X  (math-normalize (list 'neg a))
X)
X
X
X;;; Compute the number of decimal digits in integer A.  [S I]
X(defun math-numdigs (a)
X  (if (consp a)
X      (if (cdr a)
X	  (let* ((len (1- (length a)))
X		 (top (nth len a)))
X	    (+ (* len 3) (cond ((>= top 100) 0) ((>= top 10) -1) (t -2))))
X	0)
X    (cond ((>= a 100) (+ (math-numdigs (/ a 1000)) 3))
X	  ((>= a 10) 2)
X	  ((>= a 1) 1)
X	  ((= a 0) 0)
X	  ((> a -10) 1)
X	  ((> a -100) 2)
X	  (t (math-numdigs (- a)))))
X)
X
X;;; Multiply (with truncation toward 0) the integer A by 10^N.  [I i S]
X(defun math-scale-int (a n)
X  (cond ((= n 0) a)
X	((> n 0) (math-scale-left a n))
X	(t (math-normalize (math-scale-right a (- n)))))
X)
X
X(defun math-scale-left (a n)   ; [I I S]
X  (if (= n 0)
X      a
X    (if (consp a)
X	(cons (car a) (math-scale-left-bignum (cdr a) n))
X      (if (>= n 3)
X	  (if (or (>= a 1000) (<= a -1000))
X	      (math-scale-left (math-bignum a) n)
X	    (math-scale-left (* a 1000) (- n 3)))
X	(if (= n 2)
X	    (if (or (>= a 10000) (<= a -10000))
X		(math-scale-left (math-bignum a) 2)
X	      (* a 100))
X	  (if (or (>= a 100000) (<= a -100000))
X	      (math-scale-left (math-bignum a) 1)
X	    (* a 10))))))
X)
X
X(defun math-scale-left-bignum (a n)
X  (if (>= n 3)
X      (while (>= (setq a (cons 0 a)
X		       n (- n 3)) 3)))
X  (if (> n 0)
X      (math-mul-bignum-digit a (if (= n 2) 100 10) 0)
X    a)
X)
X
X(defun math-scale-right (a n)   ; [i i S]
X  (if (= n 0)
X      a
X    (if (consp a)
X	(cons (car a) (math-scale-right-bignum (cdr a) n))
X      (if (<= a 0)
X	  (if (= a 0)
X	      0
X	    (- (math-scale-right (- a) n)))
X	(if (>= n 3)
X	    (while (and (> (setq a (/ a 1000)) 0)
X			(>= (setq n (- n 3)) 3))))
X	(if (= n 2)
X	    (/ a 100)
X	  (if (= n 1)
X	      (/ a 10)
X	    a)))))
X)
X
X(defun math-scale-right-bignum (a n)   ; [L L S; l l S]
X  (if (>= n 3)
X      (setq a (nthcdr (/ n 3) a)
X	    n (% n 3)))
X  (if (> n 0)
X      (cdr (math-mul-bignum-digit a (if (= n 2) 10 100) 0))
X    a)
X)
X
X;;; Multiply (with rounding) the integer A by 10^N.   [I i S]
X(defun math-scale-rounding (a n)
X  (cond ((>= n 0)
X	 (math-scale-left a n))
X	((consp a)
X	 (math-normalize
X	  (cons (car a)
X		(let ((val (if (< n -3)
X			       (math-scale-right-bignum (cdr a) (- -3 n))
X			     (if (= n -2)
X				 (math-mul-bignum-digit (cdr a) 10 0)
X			       (if (= n -1)
X				   (math-mul-bignum-digit (cdr a) 100 0)
X				 (cdr a))))))  ; n = -3
X		  (if (and val (>= (car val) 500))
X		      (if (cdr val)
X			  (if (eq (car (cdr val)) 999)
X			      (math-add-bignum (cdr val) '(1))
X			    (cons (1+ (car (cdr val))) (cdr (cdr val))))
X			'(1))
X		    (cdr val))))))
X	(t
X	 (if (< a 0)
X	     (- (math-scale-rounding (- a) n))
X	   (if (= n -1)
X	       (/ (+ a 5) 10)
X	     (/ (+ (math-scale-right a (- -1 n)) 5) 10)))))
X)
X
X
X;;; Compute the sum of A and B.  [O O O] [Public]
X(defun math-add (a b)
X  (or
X   (and (not (or (consp a) (consp b)))
X	(progn
X	  (setq a (+ a b))
X	  (if (or (<= a -1000000) (>= a 1000000))
X	      (math-bignum a)
X	    a)))
X   (and (Math-zerop a) (not (eq (car-safe a) 'mod))
X	(if (and (math-floatp a) (Math-ratp b)) (math-float b) b))
X   (and (Math-zerop b) (not (eq (car-safe b) 'mod))
X	(if (and (math-floatp b) (Math-ratp a)) (math-float a) a))
X   (and (Math-objvecp a) (Math-objvecp b)
X	(or
X	 (and (Math-integerp a) (Math-integerp b)
X	      (progn
X		(or (consp a) (setq a (math-bignum a)))
X		(or (consp b) (setq b (math-bignum b)))
X		(if (eq (car a) 'bigneg)
X		    (if (eq (car b) 'bigneg)
X			(cons 'bigneg (math-add-bignum (cdr a) (cdr b)))
X		      (math-normalize
X		       (let ((diff (math-sub-bignum (cdr b) (cdr a))))
X			 (if (eq diff 'neg)
X			     (cons 'bigneg (math-sub-bignum (cdr a) (cdr b)))
X			   (cons 'bigpos diff)))))
X		  (if (eq (car b) 'bigneg)
X		      (math-normalize
X		       (let ((diff (math-sub-bignum (cdr a) (cdr b))))
X			 (if (eq diff 'neg)
X			     (cons 'bigneg (math-sub-bignum (cdr b) (cdr a)))
X			   (cons 'bigpos diff))))
X		    (cons 'bigpos (math-add-bignum (cdr a) (cdr b)))))))
X	 (and (Math-ratp a) (Math-ratp b)
X	      (if (eq (car-safe a) 'frac)
X		  (if (eq (car-safe b) 'frac)
X		      (math-make-frac (math-add (math-mul (nth 1 a) (nth 2 b))
X						(math-mul (nth 2 a) (nth 1 b)))
X				      (math-mul (nth 2 a) (nth 2 b)))
X		    (math-make-frac (math-add (nth 1 a)
X					      (math-mul (nth 2 a) b))
X				    (nth 2 a)))
X		(math-make-frac (math-add (math-mul a (nth 2 b))
X					  (nth 1 b))
X				(nth 2 b))))
X	 (and (Math-realp a) (Math-realp b)
X	      (progn
X		(or (and (consp a) (eq (car a) 'float))
X		    (setq a (math-float a)))
X		(or (and (consp b) (eq (car b) 'float))
X		    (setq b (math-float b)))
X		(math-add-float a b)))
X	 (and (calc-extensions)
X	      (math-add-objects-fancy a b))))
X   (and (calc-extensions)
X	(math-add-symb-fancy a b)))
X)
X(defun calcFunc-add (&rest rest)
X  (if rest
X      (let ((a (car rest)))
X	(while (setq rest (cdr rest))
X	  (setq a (list '+ a (car rest))))
X	(math-normalize a))
X    0)
X)
X
X(defun math-add-bignum (a b)   ; [L L L; l l l]
X  (if a
X      (if b
X	  (let* ((a (copy-sequence a)) (aa a) (carry nil) sum)
X	    (while (and aa b)
X	      (if carry
X		  (if (< (setq sum (+ (car aa) (car b))) 999)
X		      (progn
X			(setcar aa (1+ sum))
X			(setq carry nil))
X		    (setcar aa (+ sum -999)))
X		(if (< (setq sum (+ (car aa) (car b))) 1000)
X		    (setcar aa sum)
X		  (setcar aa (+ sum -1000))
X		  (setq carry t)))
X	      (setq aa (cdr aa)
X		    b (cdr b)))
X	    (if carry
X		(if b
X		    (nconc a (math-add-bignum b '(1)))
X		  (while (eq (car aa) 999)
X		    (setcar aa 0)
X		    (setq aa (cdr aa)))
X		  (if aa
X		      (progn
X			(setcar aa (1+ (car aa)))
X			a)
X		    (nconc a '(1))))
X	      (if b
X		  (nconc a b)
X		a)))
X	a)
X    b)
X)
X
X(defun math-sub-bignum (a b)   ; [l l l]
X  (if b
X      (if a
X	  (let* ((a (copy-sequence a)) (aa a) (borrow nil) sum)
X	    (while (and aa b)
X	      (if borrow
X		  (if (>= (setq diff (- (car aa) (car b))) 1)
X		      (progn
X			(setcar aa (1- diff))
X			(setq borrow nil))
X		    (setcar aa (+ diff 999)))
X		(if (>= (setq diff (- (car aa) (car b))) 0)
X		    (setcar aa diff)
X		  (setcar aa (+ diff 1000))
X		  (setq borrow t)))
X	      (setq aa (cdr aa)
X		    b (cdr b)))
X	    (if borrow
X		(progn
X		  (while (eq (car aa) 0)
X		    (setcar aa 999)
X		    (setq aa (cdr aa)))
X		  (if aa
X		      (progn
X			(setcar aa (1- (car aa)))
X			a)
X		    'neg))
X	      (while (eq (car b) 0)
X		(setq b (cdr b)))
X	      (if b
X		  'neg
X		a)))
X	(while (eq (car b) 0)
X	  (setq b (cdr b)))
X	(and b
X	     'neg))
X    a)
X)
X
X(defun math-add-float (a b)   ; [F F F]
X  (let ((ediff (- (nth 2 a) (nth 2 b))))
X    (if (>= ediff 0)
X	(if (>= ediff (+ calc-internal-prec calc-internal-prec))
X	    a
X	  (math-make-float (math-add (nth 1 b)
X				     (math-scale-int (nth 1 a) ediff))
X			   (nth 2 b)))
X      (if (>= (setq ediff (- ediff))
X	      (+ calc-internal-prec calc-internal-prec))
X	  b
X	(math-make-float (math-add (nth 1 a)
X				   (math-scale-int (nth 1 b) ediff))
X			 (nth 2 a)))))
X)
X
X;;; Compute the difference of A and B.  [O O O] [Public]
X(defun math-sub (a b)
X  (if (or (consp a) (consp b))
X      (math-add a (math-neg b))
X    (setq a (- a b))
X    (if (or (<= a -1000000) (>= a 1000000))
X	(math-bignum a)
X      a))
X)
X(defun calcFunc-sub (&rest rest)
X  (if rest
X      (let ((a (car rest)))
X	(while (setq rest (cdr rest))
X	  (setq a (list '- a (car rest))))
X	(math-normalize a))
X    0)
X)
X
X(defun math-sub-float (a b)   ; [F F F]
X  (let ((ediff (- (nth 2 a) (nth 2 b))))
X    (if (>= ediff 0)
X	(if (>= ediff (+ calc-internal-prec calc-internal-prec))
X	    a
X	  (math-make-float (math-add (Math-integer-neg (nth 1 b))
X				     (math-scale-int (nth 1 a) ediff))
X			   (nth 2 b)))
X      (if (>= (setq ediff (- ediff))
X	      (+ calc-internal-prec calc-internal-prec))
X	  b
X	(math-make-float (math-add (nth 1 a)
X				   (Math-integer-neg
X				    (math-scale-int (nth 1 b) ediff)))
X			 (nth 2 a)))))
X)
X
X
X;;; Compute the product of A and B.  [O O O] [Public]
X(defun math-mul (a b)
X  (or
X   (and (not (consp a)) (not (consp b))
X	(< a 1000) (> a -1000) (< b 1000) (> b -1000)
X	(* a b))
X   (and (Math-zerop a) (not (eq (car-safe b) 'mod))
X	(if (and (math-floatp b) (Math-ratp a)) (math-float a) a))
X   (and (Math-zerop b) (not (eq (car-safe a) 'mod))
X	(if (and (math-floatp a) (Math-ratp b)) (math-float b) b))
X   (and (Math-objvecp a) (Math-objvecp b)
X	(or
X	 (and (Math-integerp a) (Math-integerp b)
X	      (progn
X		(or (consp a) (setq a (math-bignum a)))
X		(or (consp b) (setq b (math-bignum b)))
X		(math-normalize
X		 (cons (if (eq (car a) (car b)) 'bigpos 'bigneg)
X		       (if (cdr (cdr a))
X			   (if (cdr (cdr b))
X			       (math-mul-bignum (cdr a) (cdr b))
X			     (math-mul-bignum-digit (cdr a) (nth 1 b) 0))
X			 (math-mul-bignum-digit (cdr b) (nth 1 a) 0))))))
X	 (and (Math-ratp a) (Math-ratp b)
X	      (if (eq (car-safe a) 'frac)
X		  (if (eq (car-safe b) 'frac)
X		      (math-make-frac (math-mul (nth 1 a) (nth 1 b))
X				      (math-mul (nth 2 a) (nth 2 b)))
X		    (math-make-frac (math-mul (nth 1 a) b)
X				    (nth 2 a)))
X		(math-make-frac (math-mul a (nth 1 b))
X				(nth 2 b))))
X	 (and (Math-realp a) (Math-realp b)
X	      (progn
X		(or (and (consp a) (eq (car a) 'float))
X		    (setq a (math-float a)))
X		(or (and (consp b) (eq (car b) 'float))
X		    (setq b (math-float b)))
X		(math-make-float (math-mul (nth 1 a) (nth 1 b))
X				 (+ (nth 2 a) (nth 2 b)))))
X	 (and (calc-extensions)
X	      (math-mul-objects-fancy a b))))
X   (and (calc-extensions)
X	(math-mul-symb-fancy a b)))
X)
X
X(defun calcFunc-mul (&rest rest)
X  (if rest
X      (let ((a (car rest)))
X	(while (setq rest (cdr rest))
X	  (setq a (list '* a (car rest))))
X	(math-normalize a))
X    1)
X)
X
X;;; Multiply digit lists A and B.  [L L L; l l l]
X(defun math-mul-bignum (a b)
X  (and a b
X       (let* ((sum (if (<= (car b) 1)
X		       (if (= (car b) 0)
X			   (list 0)
X			 (copy-sequence a))
X		     (math-mul-bignum-digit a (car b) 0)))
X	      (sump sum) c d aa prod)
X	 (while (setq b (cdr b))
X	   (setq ss (setq sump (or (cdr sump) (setcdr sump (list 0))))
X		 d (car b)
X		 c 0
X		 aa a)
X	   (while (progn
X		    (setcar ss (% (setq prod (+ (+ (car ss) (* (car aa) d))
X						c)) 1000))
X		    (setq aa (cdr aa)))
X	     (setq c (/ prod 1000)
X		   ss (or (cdr ss) (setcdr ss (list 0)))))
X	   (if (>= prod 1000)
X	       (if (cdr ss)
X		   (setcar (cdr ss) (+ (/ prod 1000) (car (cdr ss))))
X		 (setcdr ss (list (/ prod 1000))))))
X	 sum))
X)
X
X;;; Multiply digit list A by digit D.  [L L D D; l l D D]
X(defun math-mul-bignum-digit (a d c)
X  (and a
X       (if (<= d 1)
X	   (and (= d 1) a)
X	 (let* ((a (copy-sequence a)) (aa a) prod)
X	   (while (progn
X		    (setcar aa (% (setq prod (+ (* (car aa) d) c)) 1000))
X		    (cdr aa))
X	     (setq aa (cdr aa)
X		   c (/ prod 1000)))
X	   (if (>= prod 1000)
X	       (setcdr aa (list (/ prod 1000))))
X	   a)))
X)
X
X
X;;; Compute the square of A.  [O O] [Public]
X(defun math-sqr (a)
X  (if (eq (car-safe a) 'calcFunc-sqrt)
X      (nth 1 a)
X    (math-mul a a))
X)
X
X
X;;; Compute the integer (quotient . remainder) of A and B, which may be
X;;; small or big integers.  Type and consistency of truncation is undefined
X;;; if A or B is negative.  B must be nonzero.  [I.I I I] [Public]
X(defun math-idivmod (a b)
X  (if (eq b 0)
X      (math-reject-arg a "Division by zero"))
X  (if (or (consp a) (consp b))
X      (if (and (natnump b) (< b 1000))
X	  (let ((res (math-div-bignum-digit (cdr a) b)))
X	    (cons
X	     (math-normalize (cons (car a) (car res)))
X	     (cdr res)))
X	(or (consp a) (setq a (math-bignum a)))
X	(or (consp b) (setq b (math-bignum b)))
X	(let ((res (math-div-bignum (cdr a) (cdr b))))
X	  (cons
X	   (math-normalize (cons (if (eq (car a) (car b)) 'bigpos 'bigneg)
X				 (car res)))
X	   (math-normalize (cons (car a) (cdr res))))))
X    (cons (/ a b) (% a b)))
X)
X
X(defun math-quotient (a b)   ; [I I I] [Public]
X  (if (and (not (consp a)) (not (consp b)))
X      (if (= b 0)
X	  (math-reject-arg a "Division by zero")
X	(/ a b))
X    (if (and (natnump b) (< b 1000))
X	(if (= b 0)
X	    (math-reject-arg a "Division by zero")
X	  (math-normalize (cons (car a)
X				(car (math-div-bignum-digit (cdr a) b)))))
X      (or (consp a) (setq a (math-bignum a)))
X      (or (consp b) (setq b (math-bignum b)))
X      (let* ((alen (1- (length a)))
X	     (blen (1- (length b)))
X	     (d (/ 1000 (1+ (nth (1- blen) (cdr b)))))
X	     (res (math-div-bignum-big (math-mul-bignum-digit (cdr a) d 0)
X				       (math-mul-bignum-digit (cdr b) d 0)
X				       alen blen)))
X	(math-normalize (cons (if (eq (car a) (car b)) 'bigpos 'bigneg)
X			      (car res))))))
X)
X
X(defun math-imod (a b)   ; [I I I] [Public]
X  (if (and (not (consp a)) (not (consp b)))
X      (if (= b 0)
X	  (math-reject-arg a "Division by zero")
X	(% a b))
X    (cdr (math-idivmod a b)))
X)
X
X;;; Divide a bignum digit list by another.  [l.l l L]
X;;; The following division algorithm is borrowed from Knuth vol. II, sec. 4.3.1
X(defun math-div-bignum (a b)
X  (if (null (cdr b))
X      (let ((res (math-div-bignum-digit a (car b))))
X	(cons (car res) (list (cdr res))))
X    (let* ((alen (length a))
X	   (blen (length b))
X	   (d (/ 1000 (1+ (nth (1- blen) b))))
X	   (res (math-div-bignum-big (math-mul-bignum-digit a d 0)
X				     (math-mul-bignum-digit b d 0)
X				     alen blen)))
X      (if (= d 1)
X	  res
X	(cons (car res)
X	      (car (math-div-bignum-digit (cdr res) d))))))
X)
X
X;;; Divide a bignum digit list by a digit.  [l.D l D]
X(defun math-div-bignum-digit (a b)
X  (if (null a)
X      '(nil . 0)
X    (let* ((res (math-div-bignum-digit (cdr a) b))
X	   (num (+ (* (cdr res) 1000) (car a))))
X      (cons
X       (cons (/ num b) (car res))
X       (% num b))))
X)
X
X(defun math-div-bignum-big (a b alen blen)   ; [l.l l L]
X  (if (< alen blen)
X      (cons nil a)
X    (let* ((res (math-div-bignum-big (cdr a) b (1- alen) blen))
X	   (num (cons (car a) (cdr res)))
X	   (res2 (math-div-bignum-part num b blen)))
X      (cons
X       (cons (car res2) (car res))
X       (cdr res2))))
X)
X
X(defun math-div-bignum-part (a b blen)   ; a < b*1000  [D.l l L]
X  (let* ((num (+ (* (or (nth blen a) 0) 1000) (or (nth (1- blen) a) 0)))
X	 (den (nth (1- blen) b))
X	 (guess (min (/ num den) 999)))
X    (math-div-bignum-try a b (math-mul-bignum-digit b guess 0) guess))
X)
X
X(defun math-div-bignum-try (a b c guess)   ; [D.l l l D]
X  (let ((rem (math-sub-bignum a c)))
X    (if (eq rem 'neg)
X	(math-div-bignum-try a b (math-sub-bignum c b) (1- guess))
X      (cons guess rem)))
X)
X
X
X;;; Compute the quotient of A and B.  [O O N] [Public]
X(defun math-div (a b)
X  (or
X   (and (Math-zerop b)
X	(math-reject-arg a "Division by zero"))
X   (and (Math-zerop a) (not (eq (car-safe b) 'mod))
X	(if (and (math-floatp b) (Math-ratp a)) (math-float a) a))
X   (and (Math-objvecp a) (Math-objvecp b)
X	(or
X	 (and (Math-integerp a) (Math-integerp b)
X	      (if calc-prefer-frac
X		  (math-make-frac a b)
X		(let ((q (math-idivmod a b)))
X		  (if (eq (cdr q) 0)
X		      (car q)
X		    (math-div-float (math-make-float a 0)
X				    (math-make-float b 0))))))
X	 (and (Math-ratp a) (Math-ratp b)
X	      (if (eq (car-safe a) 'frac)
X		  (if (eq (car-safe b) 'frac)
X		      (math-make-frac (math-mul (nth 1 a) (nth 2 b))
X				      (math-mul (nth 2 a) (nth 1 b)))
X		    (math-make-frac (nth 1 a)
X				    (math-mul (nth 2 a) b)))
X		(math-make-frac (math-mul a (nth 2 b))
X				(nth 1 b))))
X	 (and (Math-realp a) (Math-realp b)
X	      (progn
X		(or (and (consp a) (eq (car a) 'float))
X		    (setq a (math-float a)))
X		(or (and (consp b) (eq (car b) 'float))
X		    (setq b (math-float b)))
X		(math-div-float a b)))
X	 (and (calc-extensions)
X	      (math-div-objects-fancy a b))))
X   (and (calc-extensions)
X	(math-div-symb-fancy a b)))
X)
X(defun calcFunc-div (a &rest rest)
X  (while rest
X    (setq a (list '/ a (car rest))
X	  rest (cdr rest)))
X  (math-normalize a)
X)
X
X(defun math-div-float (a b)   ; [F F F]
X  (let ((ldiff (max (- (1+ calc-internal-prec)
X		       (- (math-numdigs (nth 1 a)) (math-numdigs (nth 1 b))))
SHAR_EOF
echo "End of part 2"
echo "File calc.el is continued in part 3"
echo "3" > s2_seq_.tmp
exit 0



More information about the Comp.sources.misc mailing list