diff options
Diffstat (limited to 'lisp/calc/calc-ext.el')
| -rw-r--r-- | lisp/calc/calc-ext.el | 235 |
1 files changed, 95 insertions, 140 deletions
diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el index f2e70906e94..0b3c489d453 100644 --- a/lisp/calc/calc-ext.el +++ b/lisp/calc/calc-ext.el @@ -1,4 +1,4 @@ -;;; calc-ext.el --- various extension functions for Calc +;;; calc-ext.el --- various extension functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2019 Free Software Foundation, Inc. @@ -25,6 +25,7 @@ (require 'calc) (require 'calc-macs) +(require 'cl-lib) ;; Declare functions which are defined elsewhere. (declare-function math-clip "calc-bin" (a &optional w)) @@ -62,10 +63,8 @@ (declare-function math-format-radix-float "calc-bin" (a prec)) (declare-function math-compose-expr "calccomp" (a prec &optional div)) (declare-function math-abs "calc-arith" (a)) -(declare-function math-format-bignum-binary "calc-bin" (a)) -(declare-function math-format-bignum-octal "calc-bin" (a)) -(declare-function math-format-bignum-hex "calc-bin" (a)) -(declare-function math-format-bignum-radix "calc-bin" (a)) +(declare-function math-format-binary "calc-bin" (a)) +(declare-function math-format-radix "calc-bin" (a)) (declare-function math-compute-max-digits "calc-bin" (w r)) (declare-function math-map-vec "calc-vec" (f a)) (declare-function math-make-frac "calc-frac" (num den)) @@ -88,7 +87,7 @@ (defvar calc-alg-map) (defvar calc-alg-esc-map) -;;; The following was made a function so that it could be byte-compiled. +;; The following was made a function so that it could be byte-compiled. (defun calc-init-extensions () (define-key calc-mode-map ":" 'calc-fdiv) @@ -714,8 +713,8 @@ ;;;; (Autoloads here) (mapc (function (lambda (x) - (mapcar (function (lambda (func) - (autoload func (car x)))) (cdr x)))) + (mapcar (function (lambda (func) (autoload func (car x)))) + (cdr x)))) '( ("calc-alg" calc-has-rules math-defsimplify @@ -779,8 +778,7 @@ math-sqr-float math-trunc-fancy math-trunc-special) calcFunc-clip calcFunc-diff calcFunc-lsh calcFunc-not calcFunc-or calcFunc-rash calcFunc-rot calcFunc-rsh calcFunc-xor math-clip math-compute-max-digits math-convert-radix-digits math-float-parts -math-format-bignum-binary math-format-bignum-hex -math-format-bignum-octal math-format-bignum-radix math-format-binary +math-format-binary math-format-radix math-format-radix-float math-integer-log2 math-power-of-2 math-radix-float-power) @@ -881,7 +879,7 @@ calcFunc-tanh math-arccos-raw math-arcsin-raw math-arctan-raw math-arctan2-raw math-cos-raw math-cot-raw math-csc-raw math-exp-minus-1-raw math-exp-raw math-from-radians math-from-radians-2 math-hypot math-infinite-dir -math-isqrt-small math-ln-raw math-nearly-equal math-nearly-equal-float +math-ln-raw math-nearly-equal math-nearly-equal-float math-nearly-zerop math-nearly-zerop-float math-nth-root math-sin-cos-raw math-sin-raw math-sqrt math-sqrt-float math-sqrt-raw math-tan-raw math-to-radians math-to-radians-2) @@ -894,8 +892,8 @@ calcFunc-pcont calcFunc-pdeg calcFunc-pdiv calcFunc-pdivide calcFunc-pdivrem calcFunc-pgcd calcFunc-plead calcFunc-pprim calcFunc-prem math-accum-factors math-atomic-factorp math-div-poly-const math-div-thru math-expand-power math-expand-term -math-factor-contains math-factor-expr math-factor-expr-part -math-factor-expr-try math-factor-finish math-factor-poly-coefs +math-factor-contains math-factor-expr +math-factor-finish math-factor-protect math-mul-thru math-padded-polynomial math-partial-fractions math-poly-degree math-poly-deriv-coefs math-poly-gcd-frac-list math-poly-modulus-rec math-ratpoly-p @@ -984,8 +982,8 @@ calc-force-refresh calc-locate-cursor-element calc-show-edit-buffer) )) (mapcar (function (lambda (x) - (mapcar (function (lambda (cmd) - (autoload cmd (car x) nil t))) (cdr x)))) + (mapcar (function (lambda (cmd) (autoload cmd (car x) nil t))) + (cdr x)))) '( ("calc-alg" calc-alg-evaluate calc-apart calc-collect calc-expand @@ -1307,8 +1305,9 @@ calc-kill calc-kill-region calc-yank)))) (message "%s" (if msg (concat group ": " msg ":" (make-string - (- (apply 'max (mapcar 'length msgs)) - (length msg)) 32) + (- (apply #'max (mapcar #'length msgs)) + (length msg)) + ?\s) " [MORE]" (if key (concat " " (char-to-string key) @@ -1334,6 +1333,8 @@ calc-kill calc-kill-region calc-yank)))) ;;; General. +(defvar calc-embedded-quiet) + (defun calc-reset (arg) (interactive "P") (setq arg (if arg (prefix-numeric-value arg) nil)) @@ -1398,7 +1399,7 @@ calc-kill calc-kill-region calc-yank)))) (defun calc-scroll-up (n) (interactive "P") - (condition-case err + (condition-case nil (scroll-up (or n (/ (window-height) 2))) (error nil)) (if (pos-visible-in-window-p (max 1 (- (point-max) 2))) @@ -1484,14 +1485,14 @@ calc-kill calc-kill-region calc-yank)))) (not calc-is-keypad-press) (if (boundp 'overriding-terminal-local-map) (setq overriding-terminal-local-map calc-fancy-prefix-map) - (let ((event (calc-read-key t))) - (if (eq (setq last-command-event (car event)) ?\C-u) + (let ((event (read-event))) + (if (eq (setq last-command-event event) ?\C-u) (universal-argument) (if (or (not (integerp last-command-event)) (and (>= last-command-event 0) (< last-command-event ? ) (not (memq last-command-event '(?\e))))) (calc-wrapper)) ; clear flags if not a Calc command. - (setq last-command-event (cdr event)) + (setq last-command-event event) (if (or (not (integerp last-command-event)) (eq last-command-event ?-)) (calc-unread-command) @@ -1657,7 +1658,7 @@ calc-kill calc-kill-region calc-yank)))) (let ((entries (calc-top-list n 1 'entry)) (calc-undo-list nil) (calc-redo-list nil)) (calc-pop-stack n 1 t) - (calc-push-list (mapcar 'car entries) + (calc-push-list (mapcar #'car entries) 1 (mapcar (function (lambda (x) (nth 2 x))) entries))))))) @@ -1707,7 +1708,7 @@ calc-kill calc-kill-region calc-yank)))) (calc-pop-push-record-list 1 "eval" (math-evaluate-expr (calc-top (- n))) (- n)) - (calc-pop-push-record-list n "eval" (mapcar 'math-evaluate-expr + (calc-pop-push-record-list n "eval" (mapcar #'math-evaluate-expr (calc-top-list n))))) (calc-handle-whys))) @@ -1912,8 +1913,6 @@ calc-kill calc-kill-region calc-yank)))) ;;; User menu. (defun calc-user-key-map () - (if (featurep 'xemacs) - (error "User-defined keys are not supported in XEmacs")) (let ((res (cdr (lookup-key calc-mode-map "z")))) (if (eq (car (car res)) 27) (cdr res) @@ -1928,7 +1927,7 @@ calc-kill calc-kill-region calc-yank)))) (calc-z-prefix-buf "") (kmap (sort (copy-sequence (calc-user-key-map)) (function (lambda (x y) (< (car x) (car y)))))) - (flags (apply 'logior + (flags (apply #'logior (mapcar (function (lambda (k) (calc-user-function-classify (car k)))) @@ -2003,20 +2002,21 @@ calc-kill calc-kill-region calc-yank)))) ;;;; Caches. (defmacro math-defcache (name init form) + (declare (indent 2) (debug (symbolp sexp form))) (let ((cache-prec (intern (concat (symbol-name name) "-cache-prec"))) (cache-val (intern (concat (symbol-name name) "-cache"))) (last-prec (intern (concat (symbol-name name) "-last-prec"))) (last-val (intern (concat (symbol-name name) "-last")))) `(progn -; (defvar ,cache-prec ,(if init (math-numdigs (nth 1 init)) -100)) + ;; (defvar ,cache-prec ,(if init (math-numdigs (nth 1 init)) -100)) (defvar ,cache-prec (cond ((consp ,init) (math-numdigs (nth 1 ,init))) (,init - (nth 1 (math-numdigs (eval ,init)))) + (nth 1 (math-numdigs (eval ,init t)))) (t -100))) (defvar ,cache-val (cond ((consp ,init) ,init) - (,init (eval ,init)) + (,init (eval ,init t)) (t ,init))) (defvar ,last-prec -100) (defvar ,last-val nil) @@ -2037,7 +2037,6 @@ calc-kill calc-kill-region calc-yank)))) ,cache-val)) ,last-prec calc-internal-prec)) ,last-val)))) -(put 'math-defcache 'lisp-indent-hook 2) ;;; Betcha didn't know that pi = 16 atan(1/5) - 4 atan(1/239). [F] [Public] (defconst math-approx-pi @@ -2116,77 +2115,61 @@ calc-kill calc-kill-region calc-yank)))) ;;; True if A is an odd integer. [P R R] [Public] (defun math-oddp (a) - (if (consp a) - (and (memq (car a) '(bigpos bigneg)) - (= (% (nth 1 a) 2) 1)) - (/= (% a 2) 0))) + (and (integerp a) (cl-oddp a))) -;;; True if A is a small or big integer. [P x] [Public] -(defun math-integerp (a) - (or (integerp a) - (memq (car-safe a) '(bigpos bigneg)))) +;;; True if A is an integer. [P x] [Public] +(defalias 'math-integerp #'integerp) ;;; True if A is (numerically) a non-negative integer. [P N] [Public] -(defun math-natnump (a) - (or (natnump a) - (eq (car-safe a) 'bigpos))) +(defalias 'math-natnump #'natnump) ;;; True if A is a rational (or integer). [P x] [Public] -(defun math-ratp (a) - (or (integerp a) - (memq (car-safe a) '(bigpos bigneg frac)))) +(defalias 'math-ratp #'Math-ratp) ;;; True if A is a real (or rational). [P x] [Public] -(defun math-realp (a) - (or (integerp a) - (memq (car-safe a) '(bigpos bigneg frac float)))) +(defalias 'math-realp #'Math-realp) ;;; True if A is a real or HMS form. [P x] [Public] -(defun math-anglep (a) - (or (integerp a) - (memq (car-safe a) '(bigpos bigneg frac float hms)))) +(defalias 'math-anglep #'Math-anglep) ;;; True if A is a number of any kind. [P x] [Public] -(defun math-numberp (a) - (or (integerp a) - (memq (car-safe a) '(bigpos bigneg frac float cplx polar)))) +(defalias 'math-numberp #'Math-numberp) ;;; True if A is a complex number or angle. [P x] [Public] -(defun math-scalarp (a) - (or (integerp a) - (memq (car-safe a) '(bigpos bigneg frac float cplx polar hms)))) +(defalias 'math-scalarp #'Math-scalarp) ;;; True if A is a vector. [P x] [Public] -(defun math-vectorp (a) - (eq (car-safe a) 'vec)) +(defalias 'math-vectorp #'Math-vectorp) ;;; True if A is any vector or scalar data object. [P x] (defun math-objvecp (a) ; [Public] (or (integerp a) - (memq (car-safe a) '(bigpos bigneg frac float cplx polar - hms date sdev intv mod vec incomplete)))) + (memq (car-safe a) '(frac float cplx polar + hms date sdev intv mod vec + ;; FIXME: Math-objvecp does not include this one! + incomplete)))) ;;; True if A is an object not composed of sub-formulas . [P x] [Public] (defun math-primp (a) (or (integerp a) - (memq (car-safe a) '(bigpos bigneg frac float cplx polar - hms date mod var)))) + (memq (car-safe a) '(frac float cplx polar + hms date mod var)))) ;;; True if A is numerically (but not literally) an integer. [P x] [Public] (defun math-messy-integerp (a) (cond ((eq (car-safe a) 'float) (>= (nth 2 a) 0)) + ;; FIXME: Math-messy-integerp does not include this case! ((eq (car-safe a) 'frac) (Math-integerp (math-normalize a))))) ;;; True if A is numerically an integer. [P x] [Public] (defun math-num-integerp (a) - (or (Math-integerp a) + (or (integerp a) (Math-messy-integerp a))) ;;; True if A is (numerically) a non-negative integer. [P N] [Public] (defun math-num-natnump (a) (or (natnump a) - (eq (car-safe a) 'bigpos) (and (eq (car-safe a) 'float) (Math-natnump (nth 1 a)) (>= (nth 2 a) 0)))) @@ -2276,32 +2259,28 @@ calc-kill calc-kill-region calc-yank)))) ;;; True if A is any scalar data object. [P x] (defun math-objectp (a) ; [Public] (or (integerp a) - (memq (car-safe a) '(bigpos bigneg frac float cplx - polar hms date sdev intv mod)))) + (memq (car-safe a) '(frac float cplx + polar hms date sdev intv mod)))) ;;; Verify that A is an integer and return A in integer form. [I N; - x] (defun math-check-integer (a) ; [Public] - (cond ((integerp a) a) ; for speed - ((math-integerp a) a) + (cond ((integerp a) a) ((math-messy-integerp a) (math-trunc a)) (t (math-reject-arg a 'integerp)))) ;;; Verify that A is a small integer and return A in integer form. [S N; - x] (defun math-check-fixnum (a &optional allow-inf) ; [Public] - (cond ((integerp a) a) ; for speed + (cond ((fixnump a) a) ; for speed ((Math-num-integerp a) (let ((a (math-trunc a))) - (if (integerp a) + (if (fixnump a) a - (if (or (Math-lessp (lsh -1 -1) a) - (Math-lessp a (- (lsh -1 -1)))) - (math-reject-arg a 'fixnump) - (math-fixnum a))))) + (math-reject-arg a 'fixnump)))) ((and allow-inf (equal a '(var inf var-inf))) - (lsh -1 -1)) + most-positive-fixnum) ((and allow-inf (equal a '(neg (var inf var-inf)))) - (- (lsh -1 -1))) + (- most-positive-fixnum)) (t (math-reject-arg a 'fixnump)))) ;;; Verify that A is an integer >= 0 and return A in integer form. [I N; - x] @@ -2347,20 +2326,6 @@ If X is not an error form, return 1." (memq t (mapcar (lambda (x) (eq (car-safe x) 'sdev)) ls)))) ;;; Coerce integer A to be a small integer. [S I] -(defun math-fixnum (a) - (if (consp a) - (if (cdr a) - (if (eq (car a) 'bigneg) - (- (math-fixnum-big (cdr a))) - (math-fixnum-big (cdr a))) - 0) - a)) - -(defun math-fixnum-big (a) - (if (cdr a) - (+ (car a) (* (math-fixnum-big (cdr a)) math-bignum-digit-size)) - (car a))) - (defvar math-simplify-only nil) (defun math-normalize-fancy (a) @@ -2400,7 +2365,7 @@ If X is not an error form, return 1." (list 'calcFunc-intv mask lo hi) (math-make-intv mask lo hi)))) ((eq (car a) 'vec) - (cons 'vec (mapcar 'math-normalize (cdr a)))) + (cons 'vec (mapcar #'math-normalize (cdr a)))) ((eq (car a) 'quote) (math-normalize (nth 1 a))) ((eq (car a) 'special-const) @@ -2412,7 +2377,7 @@ If X is not an error form, return 1." (math-normalize-logical-op a)) ((memq (car a) '(calcFunc-lambda calcFunc-quote calcFunc-condition)) (let ((calc-simplify-mode 'none)) - (cons (car a) (mapcar 'math-normalize (cdr a))))) + (cons (car a) (mapcar #'math-normalize (cdr a))))) ((eq (car a) 'calcFunc-evalto) (setq a (or (nth 1 a) 0)) (or calc-refreshing-evaltos @@ -2435,27 +2400,25 @@ If X is not an error form, return 1." ;; The variable math-normalize-a is local to math-normalize in calc.el, ;; but is used by math-normalize-nonstandard, which is called by ;; math-normalize. -(defvar math-normalize-a) - -(defun math-normalize-nonstandard () +(defun math-normalize-nonstandard (a) (if (consp calc-simplify-mode) (progn (setq calc-simplify-mode 'none - math-simplify-only (car-safe (cdr-safe math-normalize-a))) + math-simplify-only (car-safe (cdr-safe a))) nil) - (and (symbolp (car math-normalize-a)) + (and (symbolp (car a)) (or (eq calc-simplify-mode 'none) (and (eq calc-simplify-mode 'num) - (let ((aptr (setq math-normalize-a + (let ((aptr (setq a (cons - (car math-normalize-a) - (mapcar 'math-normalize - (cdr math-normalize-a)))))) + (car a) + (mapcar #'math-normalize + (cdr a)))))) (while (and aptr (math-constp (car aptr))) (setq aptr (cdr aptr))) aptr))) - (cons (car math-normalize-a) - (mapcar 'math-normalize (cdr math-normalize-a)))))) + (cons (car a) + (mapcar #'math-normalize (cdr a)))))) ;;; Normalize a bignum digit list by trimming high-end zeros. [L l] @@ -2469,12 +2432,6 @@ If X is not an error form, return 1." (setcdr last nil) a)))) -(defun math-bignum-test (a) ; [B N; B s; b b] - (if (consp a) - a - (math-bignum a))) - - ;;; Return 0 for zero, -1 for negative, 1 for positive. [S n] [Public] (defun calcFunc-sign (a &optional x) (let ((signs (math-possible-signs a))) @@ -2497,17 +2454,7 @@ If X is not an error form, return 1." 2 0)) ((and (integerp a) (Math-integerp b)) - (if (consp b) - (if (eq (car b) 'bigpos) -1 1) - (if (< a b) -1 1))) - ((and (eq (car-safe a) 'bigpos) (Math-integerp b)) - (if (eq (car-safe b) 'bigpos) - (math-compare-bignum (cdr a) (cdr b)) - 1)) - ((and (eq (car-safe a) 'bigneg) (Math-integerp b)) - (if (eq (car-safe b) 'bigneg) - (math-compare-bignum (cdr b) (cdr a)) - -1)) + (if (< a b) -1 1)) ((eq (car-safe a) 'frac) (if (eq (car-safe b) 'frac) (math-compare (math-mul (nth 1 a) (nth 2 b)) @@ -2808,7 +2755,7 @@ If X is not an error form, return 1." x) (if (Math-primp x) x - (cons (car x) (mapcar 'math-evaluate-expr-rec (cdr x)))))) + (cons (car x) (mapcar #'math-evaluate-expr-rec (cdr x)))))) x)) (defun math-any-floats (expr) @@ -2822,9 +2769,10 @@ If X is not an error form, return 1." (defvar math-mt-many nil) (defvar math-mt-func nil) -(defun math-map-tree (math-mt-func mmt-expr &optional math-mt-many) - (or math-mt-many (setq math-mt-many 1000000)) - (math-map-tree-rec mmt-expr)) +(defun math-map-tree (func mmt-expr &optional many) + (let ((math-mt-func func) + (math-mt-many (or many 1000000))) + (math-map-tree-rec mmt-expr))) (defun math-map-tree-rec (mmt-expr) (or (= math-mt-many 0) @@ -2842,7 +2790,7 @@ If X is not an error form, return 1." (<= math-mt-many 0)) (setq mmt-done t) (setq mmt-nextval (cons (car mmt-expr) - (mapcar 'math-map-tree-rec + (mapcar #'math-map-tree-rec (cdr mmt-expr)))) (if (equal mmt-nextval mmt-expr) (setq mmt-done t) @@ -2867,6 +2815,7 @@ If X is not an error form, return 1." (defvar math-integral-cache) (defmacro math-defintegral (funcs &rest code) + (declare (indent 1) (debug (sexp body))) (setq math-integral-cache nil) (cons 'progn (mapcar #'(lambda (func) @@ -2876,9 +2825,9 @@ If X is not an error form, return 1." (list #'(lambda (u) ,@code))))) (if (symbolp funcs) (list funcs) funcs)))) -(put 'math-defintegral 'lisp-indent-hook 1) (defmacro math-defintegral-2 (funcs &rest code) + (declare (indent 1) (debug (sexp body))) (setq math-integral-cache nil) (cons 'progn (mapcar #'(lambda (func) @@ -2887,7 +2836,6 @@ If X is not an error form, return 1." (get ',func 'math-integral-2) (list #'(lambda (u v) ,@code))))) (if (symbolp funcs) (list funcs) funcs)))) -(put 'math-defintegral-2 'lisp-indent-hook 1) (defvar var-IntegAfterRules 'calc-IntegAfterRules) @@ -3017,13 +2965,13 @@ If X is not an error form, return 1." ;; C language hexadecimal notation ((and (eq calc-language 'c) - (string-match "^0[xX]\\([0-9a-fA-F]+\\)$" s)) + (string-match "^0[xX]\\([[:xdigit:]]+\\)$" s)) (let ((digs (math-match-substring s 1))) (math-read-radix digs 16))) ;; Pascal language hexadecimal notation ((and (eq calc-language 'pascal) - (string-match "^\\$\\([0-9a-fA-F]+\\)$" s)) + (string-match "^\\$\\([[:xdigit:]]+\\)$" s)) (let ((digs (math-match-substring s 1))) (math-read-radix digs 16))) @@ -3097,9 +3045,16 @@ If X is not an error form, return 1." ;;; Expression parsing. (defvar math-expr-data) +(defvar math-exp-pos) +(defvar math-exp-old-pos) +(defvar math-exp-keep-spaces) +(defvar math-exp-token) +(defvar math-expr-data) +(defvar math-exp-str) -(defun math-read-expr (math-exp-str) +(defun math-read-expr (str) (let ((math-exp-pos 0) + (math-exp-str str) (math-exp-old-pos 0) (math-exp-keep-spaces nil) math-exp-token math-expr-data) @@ -3138,6 +3093,10 @@ If X is not an error form, return 1." ;;; They said it couldn't be done... +(defvar math-read-big-baseline) +(defvar math-read-big-h2) +(defvar math-read-big-err-msg) + (defun math-read-big-expr (str) (and (> (length calc-left-label) 0) (string-match (concat "^" (regexp-quote calc-left-label)) str) @@ -3179,6 +3138,8 @@ If X is not an error form, return 1." '(error 0 "Syntax error")) (math-read-expr str))))) +(defvar math-rb-h2) + (defun math-read-big-bigp (math-read-big-lines) (and (cdr math-read-big-lines) (let ((matrix nil) @@ -3438,16 +3399,10 @@ If X is not an error form, return 1." (list 'frac (math-mul (nth 1 a) g) (math-mul (nth 2 a) g)))) a)) -(defun math-format-bignum-fancy (a) ; [X L] - (let ((str (cond ((= calc-number-radix 10) - (math-format-bignum-decimal a)) - ((= calc-number-radix 2) - (math-format-bignum-binary a)) - ((= calc-number-radix 8) - (math-format-bignum-octal a)) - ((= calc-number-radix 16) - (math-format-bignum-hex a)) - (t (math-format-bignum-radix a))))) +(defun math--format-integer-fancy (a) ; [I] + (let ((str (if (= calc-number-radix 10) + (number-to-string a) + (math-format-radix a)))) (if calc-leading-zeros (let* ((calc-internal-prec 6) (digs (math-compute-max-digits (math-abs calc-word-size) |