diff options
Diffstat (limited to 'lisp/calc')
43 files changed, 1687 insertions, 1643 deletions
diff --git a/lisp/calc/calc-aent.el b/lisp/calc/calc-aent.el index 35f33b6929a..1e31c3cadc0 100644 --- a/lisp/calc/calc-aent.el +++ b/lisp/calc/calc-aent.el @@ -1,4 +1,4 @@ -;;; calc-aent.el --- algebraic entry functions for Calc +;;; calc-aent.el --- algebraic entry functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -76,8 +76,8 @@ (calc-refresh-evaltos (nth 2 (nth 1 (car alg-exp)))) (setq alg-exp (list (nth 2 (car alg-exp))))) (setq calc-quick-prev-results alg-exp - buf (mapconcat (function (lambda (x) - (math-format-value x 1000))) + buf (mapconcat (lambda (x) + (math-format-value x 1000)) alg-exp " ") shortbuf buf) @@ -158,7 +158,7 @@ (setq strp (cdr (cdr strp)))) (calc-do-calc-eval (car str) separator args))) ((eq separator 'eval) - (eval str)) + (eval str t)) ((eq separator 'macro) (require 'calc-ext) (let* ((calc-buffer (current-buffer)) @@ -197,18 +197,17 @@ (calc-language (if (memq calc-language '(nil big)) 'flat calc-language)) (calc-dollar-values (mapcar - (function - (lambda (x) - (if (stringp x) - (progn - (setq x (math-read-exprs x)) - (if (eq (car-safe x) - 'error) - (throw 'calc-error - (calc-eval-error - (cdr x))) - (car x))) - x))) + (lambda (x) + (if (stringp x) + (progn + (setq x (math-read-exprs x)) + (if (eq (car-safe x) + 'error) + (throw 'calc-error + (calc-eval-error + (cdr x))) + (car x))) + x)) args)) (calc-dollar-used 0) (res (if (stringp str) @@ -285,6 +284,8 @@ The value t means abort and give an error message.") (defvar calc-alg-entry-history nil "History for algebraic entry.") +(defvar calc-plain-entry nil) + ;;;###autoload (defun calc-alg-entry (&optional initial prompt) (let* ((calc-dollar-values (mapcar #'calc-get-stack-element @@ -401,7 +402,6 @@ The value t means abort and give an error message.") (use-local-map calc-mode-map)) (calcAlg-enter)) -(defvar calc-plain-entry nil) (defun calcAlg-edit () (interactive) (if (or (not calc-plain-entry) @@ -576,8 +576,9 @@ in Calc algebraic input.") (defvar math-expr-data) ;;;###autoload -(defun math-read-exprs (math-exp-str) - (let ((math-exp-pos 0) +(defun math-read-exprs (str) + (let ((math-exp-str str) + (math-exp-pos 0) (math-exp-old-pos 0) (math-exp-keep-spaces nil) math-exp-token math-expr-data) @@ -638,10 +639,10 @@ in Calc algebraic input.") (math-find-user-tokens (car (car p))) (setq p (cdr p))) (setq calc-user-tokens (mapconcat 'identity - (sort (mapcar 'car math-toks) - (function (lambda (x y) - (> (length x) - (length y))))) + (sort (mapcar #'car math-toks) + (lambda (x y) + (> (length x) + (length y)))) "\\|") calc-last-main-parse-table mtab calc-last-user-lang-parse-table ltab @@ -738,8 +739,8 @@ in Calc algebraic input.") math-exp-pos (match-end 0))) ((and (setq adfn (assq ch (get calc-language 'math-lang-read-symbol))) - (eval (nth 1 adfn))) - (eval (nth 2 adfn))) + (eval (nth 1 adfn) t)) + (eval (nth 2 adfn) t)) ((eq ch ?\$) (if (eq (string-match "\\$\\([1-9][0-9]*\\)" math-exp-str math-exp-pos) math-exp-pos) @@ -771,8 +772,8 @@ in Calc algebraic input.") math-expr-data (math-match-substring math-exp-str 1) math-exp-pos (match-end 0))) ((and (setq adfn (get calc-language 'math-lang-read)) - (eval (nth 0 adfn)) - (eval (nth 1 adfn)))) + (eval (nth 0 adfn) t) + (eval (nth 1 adfn) t))) ((eq (string-match "%%.*$" math-exp-str math-exp-pos) math-exp-pos) (setq math-exp-pos (match-end 0)) (math-read-token)) diff --git a/lisp/calc/calc-alg.el b/lisp/calc/calc-alg.el index 95e91496277..1327cf0a39b 100644 --- a/lisp/calc/calc-alg.el +++ b/lisp/calc/calc-alg.el @@ -1785,7 +1785,7 @@ and should return the simplified expression to use (or nil)." (cons (nth 2 expr) math-poly-neg-powers)))) (not (Math-zerop (nth 2 expr))) (let ((p1 (math-is-poly-rec (nth 1 expr) negpow))) - (mapcar (function (lambda (x) (math-div x (nth 2 expr)))) + (mapcar (lambda (x) (math-div x (nth 2 expr))) p1)))) ((and (eq (car expr) 'calcFunc-exp) (equal math-var '(var e var-e))) @@ -1838,8 +1838,9 @@ and should return the simplified expression to use (or nil)." (defun math-polynomial-base (top-expr &optional pred) "Find the variable (or sub-expression) which is the base of polynomial expr." (let ((math-poly-base-pred - (or pred (function (lambda (base) (math-polynomial-p - top-expr base)))))) + (or pred (lambda (base) + (math-polynomial-p + top-expr base))))) (or (let ((math-poly-base-const-ok nil)) (math-polynomial-base-rec top-expr)) (let ((math-poly-base-const-ok t)) diff --git a/lisp/calc/calc-arith.el b/lisp/calc/calc-arith.el index a8afd1d26ef..9787fe0d609 100644 --- a/lisp/calc/calc-arith.el +++ b/lisp/calc/calc-arith.el @@ -1,4 +1,4 @@ -;;; calc-arith.el --- arithmetic functions for Calc +;;; calc-arith.el --- arithmetic functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -250,44 +250,43 @@ (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))))) + (ignore-errors + (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))))))))) (setq math-decls-all (assq 'var-All math-decls-cache))))) (defun math-known-scalarp (a &optional assume-scalar) @@ -2391,7 +2390,7 @@ (math-trunc (nth 3 a))))) ((math-provably-integerp a) a) ((Math-vectorp a) - (math-map-vec (function (lambda (x) (math-trunc x math-trunc-prec))) a)) + (math-map-vec (lambda (x) (math-trunc x math-trunc-prec)) a)) ((math-infinitep a) (if (or (math-posp a) (math-negp a)) a @@ -2454,7 +2453,7 @@ (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 math-floor-prec))) a)) + (math-map-vec (lambda (x) (math-floor x math-floor-prec)) a)) ((math-infinitep a) (if (or (math-posp a) (math-negp a)) a @@ -2521,7 +2520,7 @@ (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-map-vec (lambda (x) (math-ceiling x prec)) a)) ((math-infinitep a) (if (or (math-posp a) (math-negp a)) a @@ -2574,7 +2573,7 @@ ((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-map-vec (lambda (x) (math-round x prec)) a)) ((math-infinitep a) (if (or (math-posp a) (math-negp a)) a @@ -2657,7 +2656,7 @@ (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-map-vec (lambda (x) (calcFunc-scf x n)) x)) ((math-infinitep x) x) (t @@ -2892,7 +2891,7 @@ (eq a b)) (list 'calcFunc-exp sumpow)) (t - (condition-case err + (condition-case nil (math-pow a sumpow) (inexact-result (list '^ a sumpow))))))))) (and math-simplifying-units @@ -2927,7 +2926,7 @@ (math-div 1 (list 'calcFunc-sqrt (math-mul a b)))) (t (setq a (math-mul a b)) - (condition-case err + (condition-case nil (math-pow a apow) (inexact-result (list '^ a apow))))))))))) diff --git a/lisp/calc/calc-bin.el b/lisp/calc/calc-bin.el index 8ab35365eba..503ed777029 100644 --- a/lisp/calc/calc-bin.el +++ b/lisp/calc/calc-bin.el @@ -1,4 +1,4 @@ -;;; calc-bin.el --- binary functions for Calc +;;; calc-bin.el --- binary functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -126,8 +126,8 @@ (defun calc-word-size (n) (interactive "P") (calc-wrapper - (or n (setq n (read-string (format "Binary word size: (default %d) " - calc-word-size)))) + (or n (setq n (read-string (format-prompt "Binary word size" + calc-word-size)))) (setq n (if (stringp n) (if (equal n "") calc-word-size @@ -145,9 +145,10 @@ (setq math-half-2-word-size (math-power-of-2 (1- (math-abs n)))) (calc-do-refresh) (calc-refresh-evaltos) - (if (< n 0) - (message "Binary word size is %d bits (two's complement)" (- n)) - (message "Binary word size is %d bits" n)))) + (cond + ((< n 0) (message "Binary word size is %d bits (two's complement)" (- n))) + ((> n 0) (message "Binary word size is %d bits" n)) + (t (message "No fixed binary word size"))))) @@ -198,48 +199,16 @@ (message "Omitting leading zeros on integers")))) -(defvar math-power-of-2-cache (list 1 2 4 8 16 32 64 128 256 512 1024)) -(defvar math-big-power-of-2-cache nil) (defun math-power-of-2 (n) ; [I I] [Public] - (if (and (natnump n) (<= n 100)) - (or (nth n math-power-of-2-cache) - (let* ((i (length math-power-of-2-cache)) - (val (nth (1- i) math-power-of-2-cache))) - (while (<= i n) - (setq val (math-mul val 2) - math-power-of-2-cache (nconc math-power-of-2-cache - (list val)) - i (1+ i))) - val)) - (let ((found (assq n math-big-power-of-2-cache))) - (if found - (cdr found) - (let ((po2 (math-ipow 2 n))) - (setq math-big-power-of-2-cache - (cons (cons n po2) math-big-power-of-2-cache)) - po2))))) + (if (natnump n) + (ash 1 n) + (error "argument must be a natural number"))) (defun math-integer-log2 (n) ; [I I] [Public] - (let ((i 0) - (p math-power-of-2-cache) - val) - (while (and p (Math-natnum-lessp (setq val (car p)) n)) - (setq p (cdr p) - i (1+ i))) - (if p - (and (equal val n) - i) - (while (Math-natnum-lessp - (prog1 - (setq val (math-mul val 2)) - (setq math-power-of-2-cache (nconc math-power-of-2-cache - (list val)))) - n) - (setq i (1+ i))) - (and (equal val n) - i)))) - - + (and (natnump n) + (not (zerop n)) + (zerop (logand n (1- n))) + (logb n))) ;;; Bitwise operations. @@ -262,9 +231,10 @@ (defun math-binary-arg (a w) (if (not (Math-integerp a)) (setq a (math-trunc a))) - (if (< a 0) - (logand a (1- (ash 1 (if w (math-trunc w) calc-word-size)))) - a)) + (let ((w (if w (math-trunc w) calc-word-size))) + (if (and (< a 0) (not (zerop w))) + (logand a (1- (ash 1 w))) + a))) (defun math-binary-modulo-args (f a b w) (let (mod) @@ -285,7 +255,7 @@ (let ((bits (math-integer-log2 mod))) (if bits (if w - (if (/= w bits) + (if (and (/= w bits) (not (zerop w))) (calc-record-why "*Warning: Modulus inconsistent with word size")) (setq w bits)) @@ -371,11 +341,12 @@ (math-clip (calcFunc-lsh a n (- w)) w) (if (Math-integer-negp a) (setq a (math-clip a w))) - (cond ((or (Math-lessp n (- w)) - (Math-lessp w n)) + (cond ((and (or (Math-lessp n (- w)) + (Math-lessp w n)) + (not (zerop w))) 0) ((< n 0) - (math-quotient (math-clip a w) (math-power-of-2 (- n)))) + (ash (math-clip a w) n)) (t (math-clip (math-mul a (math-power-of-2 n)) w)))))) @@ -401,9 +372,10 @@ (math-clip (calcFunc-ash a n (- w)) w) (if (Math-integer-negp a) (setq a (math-clip a w))) - (let ((two-to-sizem1 (math-power-of-2 (1- w))) + (let ((two-to-sizem1 (and (not (zerop w)) (math-power-of-2 (1- w)))) (sh (calcFunc-lsh a n w))) - (cond ((Math-natnum-lessp a two-to-sizem1) + (cond ((or (zerop w) + (zerop (logand a two-to-sizem1))) sh) ((Math-lessp n (- 1 w)) (math-add (math-mul two-to-sizem1 2) -1)) @@ -421,6 +393,8 @@ (if (eq (car-safe a) 'mod) (math-binary-modulo-args 'calcFunc-rot a n w) (setq w (if w (math-trunc w) calc-word-size)) + (when (zerop w) + (error "Rotation requires a nonzero word size")) (or (integerp w) (math-reject-arg w 'fixnump)) (or (Math-integerp a) @@ -432,7 +406,7 @@ (if (Math-integer-negp a) (setq a (math-clip a w))) (cond ((or (Math-integer-negp n) - (not (Math-natnum-lessp n w))) + (>= n w)) (calcFunc-rot a (math-mod n w) w)) (t (math-add (calcFunc-lsh a (- n w) w) @@ -449,9 +423,11 @@ (math-reject-arg a 'integerp)) ((< (or w (setq w calc-word-size)) 0) (setq a (math-clip a (- w))) - (if (Math-natnum-lessp a (math-power-of-2 (- -1 w))) + (if (< a (math-power-of-2 (- -1 w))) a (math-sub a (math-power-of-2 (- w))))) + ((math-zerop w) + a) ((Math-negp a) (math-binary-arg a w)) ((integerp a) @@ -682,6 +658,8 @@ (defun math-format-twos-complement (a) "Format an integer in two's complement mode." + (when (zerop calc-word-size) + (error "Nonzero word size required")) (let* (;(calc-leading-zeros t) (num (cond diff --git a/lisp/calc/calc-comb.el b/lisp/calc/calc-comb.el index cb84173c018..dc952213507 100644 --- a/lisp/calc/calc-comb.el +++ b/lisp/calc/calc-comb.el @@ -1,4 +1,4 @@ -;;; calc-comb.el --- combinatoric functions for Calc +;;; calc-comb.el --- combinatoric functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -241,8 +241,8 @@ (calcFunc-gcd (math-neg a) b)) ((Math-looks-negp b) (calcFunc-gcd a (math-neg b))) - ((Math-zerop a) b) - ((Math-zerop b) a) + ((Math-zerop a) (math-abs b)) + ((Math-zerop b) (math-abs a)) ((and (Math-ratp a) (Math-ratp b)) (math-make-frac (math-gcd (if (eq (car-safe a) 'frac) (nth 1 a) a) @@ -292,15 +292,9 @@ (defconst math-small-factorial-table (vector 1 1 2 6 24 120 720 5040 40320 362880 3628800 39916800 - (math-read-number-simple "479001600") - (math-read-number-simple "6227020800") - (math-read-number-simple "87178291200") - (math-read-number-simple "1307674368000") - (math-read-number-simple "20922789888000") - (math-read-number-simple "355687428096000") - (math-read-number-simple "6402373705728000") - (math-read-number-simple "121645100408832000") - (math-read-number-simple "2432902008176640000"))) + 479001600 6227020800 87178291200 1307674368000 20922789888000 + 355687428096000 6402373705728000 121645100408832000 + 2432902008176640000)) (defun calcFunc-fact (n) ; [I I] [F F] [Public] (let (temp) @@ -445,12 +439,25 @@ (math-div (calcFunc-fact (math-float n)) (math-mul (calcFunc-fact m) (calcFunc-fact (math-sub n m)))))) - ((math-negp m) 0) - ((math-negp n) - (let ((val (calcFunc-choose (math-add (math-add n m) -1) m))) + ;; For the extension to negative integer arguments we follow + ;; M. J. Kronenburg, The Binomial Coefficient for Negative Arguments, + ;; arXiv:1105.3689v2 + ((and (math-negp n) (not (math-negp m))) + ;; n<0≤m: (n choose m) = (-1)^m (-n+m-1 choose m) + (let ((val (calcFunc-choose (math-add (math-sub m n) -1) m))) (if (math-evenp (math-trunc m)) val (math-neg val)))) + ((and (math-negp n) (math-num-integerp n)) + (if (math-lessp n m) + 0 + ;; m≤n<0: (n choose m) = (-1)^(n-m) (-m-1 choose n-m) + (let ((val (calcFunc-choose (math-sub (math-neg m) 1) + (math-sub n m)))) + (if (math-evenp (math-sub n m)) + val + (math-neg val))))) + ((math-negp m) 0) ((and (math-num-integerp n) (Math-lessp n m)) 0) @@ -467,20 +474,23 @@ (math-choose-float-iter tm n 1 1))))))) (defun math-choose-iter (m n i c) - (if (and (= (% i 5) 1) (> i 5)) + (while (<= i m) + (when (and (= (% i 5) 1) (> i 5)) (math-working (format "choose(%d)" (1- i)) c)) - (if (<= i m) - (math-choose-iter m (1- n) (1+ i) - (math-quotient (math-mul c n) i)) - c)) + (setq c (math-quotient (math-mul c n) i)) + (setq n (1- n)) + (setq i (1+ i))) + c) (defun math-choose-float-iter (count n i c) - (if (= (% i 5) 1) + (while (> count 0) + (when (= (% i 5) 1) (math-working (format "choose(%d)" (1- i)) c)) - (if (> count 0) - (math-choose-float-iter (1- count) (math-sub n 1) (1+ i) - (math-div (math-mul c n) i)) - c)) + (setq c (math-div (math-mul c n) i)) + (setq n (math-sub n 1)) + (setq i (1+ i)) + (setq count (1- count))) + c) ;;; Stirling numbers. @@ -805,7 +815,7 @@ (error "Argument must be an integer")) ((Math-integer-negp n) '(nil)) - ((Math-natnum-lessp n 8000000) + ((< n 8000000) (let ((i -1) v) (while (and (> (% n (setq v (aref math-primes-table (setq i (1+ i))))) @@ -903,7 +913,7 @@ (if (Math-messy-integerp n) (setq n (math-trunc n))) (if (Math-natnump n) - (if (Math-natnum-lessp 2 n) + (if (< 2 n) (let (factors res p (i 0)) (while (and (not (eq n 1)) (< i (length math-primes-table))) @@ -917,7 +927,7 @@ (setq factors (nconc factors (list p)) n (car res))) (or (eq n 1) - (Math-natnum-lessp p (car res)) + (< p (car res)) (setq factors (nconc factors (list n)) n 1)) (setq i (1+ i))) @@ -936,7 +946,7 @@ (if (Math-messy-integerp n) (setq n (math-trunc n))) (if (Math-natnump n) - (if (Math-natnum-lessp n 2) + (if (< n 2) (if (Math-negp n) (calcFunc-totient (math-abs n)) n) @@ -959,7 +969,7 @@ (if (Math-messy-integerp n) (setq n (math-trunc n))) (if (and (Math-natnump n) (not (eq n 0))) - (if (Math-natnum-lessp n 2) + (if (< n 2) (if (Math-negp n) (calcFunc-moebius (math-abs n)) 1) diff --git a/lisp/calc/calc-cplx.el b/lisp/calc/calc-cplx.el index da36c7cfe2e..03462020ea2 100644 --- a/lisp/calc/calc-cplx.el +++ b/lisp/calc/calc-cplx.el @@ -1,4 +1,4 @@ -;;; calc-cplx.el --- Complex number functions for Calc +;;; calc-cplx.el --- Complex number functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-embed.el b/lisp/calc/calc-embed.el index 1e5880370bb..ea79bfa69a0 100644 --- a/lisp/calc/calc-embed.el +++ b/lisp/calc/calc-embed.el @@ -1,4 +1,4 @@ -;;; calc-embed.el --- embed Calc in a buffer +;;; calc-embed.el --- embed Calc in a buffer -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -219,13 +219,17 @@ (defvar calc-override-minor-modes (cons t calc-override-minor-modes-map)) -(defun calc-do-embedded (calc-embed-arg end obeg oend) +(defvar calc-embedded-no-reselect nil) + +(defun calc-do-embedded (embed-arg end obeg oend) + (let ((calc-embed-arg embed-arg)) (if calc-embedded-info ;; Turn embedded mode off or switch to a new buffer. (cond ((eq (current-buffer) (aref calc-embedded-info 1)) (let ((calcbuf (current-buffer)) - (buf (aref calc-embedded-info 0))) + ;; (buf (aref calc-embedded-info 0)) + ) (calc-embedded-original-buffer t) (calc-embedded nil) (switch-to-buffer calcbuf))) @@ -291,7 +295,7 @@ (calc-embedded-info info) (calc-embedded-no-reselect t)) (calc-wrapper - (let* ((okay nil) + (let* (;; (okay nil) (calc-no-refresh-evaltos t)) (if (aref info 8) (progn @@ -336,7 +340,7 @@ "Type `C-x * x'" "Give this command again") " to return to normal"))))) - (scroll-down 0)) ; fix a bug which occurs when truncate-lines is changed. + (scroll-down 0))) ; fix a bug which occurs when truncate-lines is changed. (defun calc-embedded-select (arg) @@ -353,9 +357,10 @@ (calc-select-part 2))) -(defun calc-embedded-update-formula (calc-embed-arg) +(defun calc-embedded-update-formula (embed-arg) (interactive "P") - (if calc-embed-arg + (let ((calc-embed-arg embed-arg)) + (if embed-arg (let ((entry (assq (current-buffer) calc-embedded-active))) (while (setq entry (cdr entry)) (and (eq (car-safe (aref (car entry) 8)) 'calcFunc-evalto) @@ -376,12 +381,13 @@ (progn (save-excursion (calc-embedded-update info 14 'eval t)) - (goto-char (+ (aref info 4) pt)))))))) + (goto-char (+ (aref info 4) pt))))))))) -(defun calc-embedded-edit (calc-embed-arg) +(defun calc-embedded-edit (embed-arg) (interactive "P") - (let ((info (calc-embedded-make-info (point) nil t calc-embed-arg)) + (let ((calc-embed-arg embed-arg)) + (let ((info (calc-embedded-make-info (point) nil t embed-arg)) str) (if (eq (car-safe (aref info 8)) 'error) (progn @@ -390,17 +396,16 @@ (calc-wrapper (setq str (math-showing-full-precision (math-format-nice-expr (aref info 8) (frame-width)))) - (calc-edit-mode (list 'calc-embedded-finish-edit info)) + (calc--edit-mode (lambda () (calc-embedded-finish-edit info))) (insert str "\n"))) - (calc-show-edit-buffer)) + (calc-show-edit-buffer))) (defvar calc-original-buffer) (defvar calc-edit-top) (defun calc-embedded-finish-edit (info) (let ((buf (current-buffer)) (str (buffer-substring calc-edit-top (point-max))) - (start (point)) - pos) + (start (point))) ;; pos (switch-to-buffer calc-original-buffer) (let ((val (with-current-buffer (aref info 1) (let ((calc-language nil) @@ -416,7 +421,8 @@ (calc-embedded-update info 14 t t)))) ;;;###autoload -(defun calc-do-embedded-activate (calc-embed-arg cbuf) +(defun calc-do-embedded-activate (embed-arg cbuf) + (let ((calc-embed-arg embed-arg)) (calc-plain-buffer-only) (if calc-embed-arg (calc-embedded-forget)) @@ -443,7 +449,7 @@ (or (eq (car-safe (aref info 8)) 'error) (goto-char (aref info 5)))))) (message "Activating %s for Calc Embedded mode...done" (buffer-name))) - (calc-embedded-active-state t)) + (calc-embedded-active-state t))) (defun calc-plain-buffer-only () (if (memq major-mode '(calc-mode calc-trail-mode calc-edit-mode)) @@ -735,13 +741,13 @@ The command \\[yank] can retrieve it from there." (defun calc-find-globals () (interactive) - (and (eq major-mode 'calc-mode) + (and (derived-mode-p 'calc-mode) (error "This command should be used in a normal editing buffer")) (make-local-variable 'calc-embedded-globals) (let ((case-fold-search nil) (modes nil) (save-pt (point)) - found value) + found) ;; value (goto-char (point-min)) (while (re-search-forward "\\[calc-global-mode: *\\([-a-z]+\\): *\\(\"\\([^\"\n\\]\\|\\\\.\\)*\"\\|[- ()a-zA-Z0-9]+\\)\\]" nil t) (and (setq found (assoc (buffer-substring (match-beginning 1) @@ -764,7 +770,7 @@ The command \\[yank] can retrieve it from there." (modes nil) (emodes nil) (pmodes nil) - found value) + found) ;; value (while (and no-defaults (search-backward "[calc-" nil t)) (forward-char 6) (or (and (looking-at "mode: *\\([-a-z]+\\): *\\(\"\\([^\"\n\\]\\|\\\\.\\)*\"\\|[- ()a-zA-Z0-9]+\\)]") @@ -817,9 +823,13 @@ The command \\[yank] can retrieve it from there." (defvar calc-embed-vars-used) (defun calc-embedded-make-info (point cbuf fresh &optional - calc-embed-top calc-embed-bot - calc-embed-outer-top calc-embed-outer-bot) - (let* ((bufentry (assq (current-buffer) calc-embedded-active)) + embed-top embed-bot + embed-outer-top embed-outer-bot) + (let* ((calc-embed-top embed-top) + (calc-embed-bot embed-bot) + (calc-embed-outer-top embed-outer-top) + (calc-embed-outer-bot embed-outer-bot) + (bufentry (assq (current-buffer) calc-embedded-active)) (found bufentry) (force (and fresh calc-embed-top (null (equal calc-embed-top '(t))))) (fixed calc-embed-top) @@ -1175,7 +1185,6 @@ The command \\[yank] can retrieve it from there." ;;; These are hooks called by the main part of Calc. -(defvar calc-embedded-no-reselect nil) (defun calc-embedded-select-buffer () (if (eq (current-buffer) (aref calc-embedded-info 0)) (let ((info calc-embedded-info) @@ -1240,7 +1249,7 @@ The command \\[yank] can retrieve it from there." (with-current-buffer (aref calc-embedded-info 1) (let* ((info calc-embedded-info) (extra-line (if (eq calc-language 'big) 1 0)) - (the-point (point)) + ;; (the-point (point)) (empty (= (calc-stack-size) 0)) (entry (if empty (list '(var empty var-empty) 1 nil) @@ -1274,6 +1283,7 @@ The command \\[yank] can retrieve it from there." (set-buffer-modified-p (buffer-modified-p))))) (defun calc-embedded-modes-change (vars) + (defvar the-language) (defvar the-display-just) (if (eq (car vars) 'calc-language) (setq vars '(the-language))) (if (eq (car vars) 'calc-display-just) (setq vars '(the-display-just))) (while (and vars diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el index 1949ecb1380..f4ddb840b50 100644 --- a/lisp/calc/calc-ext.el +++ b/lisp/calc/calc-ext.el @@ -678,14 +678,13 @@ (calc-init-prefixes) - (mapc (function - (lambda (x) + (mapc (lambda (x) (define-key calc-mode-map (format "c%c" x) 'calc-clean-num) (define-key calc-mode-map (format "j%c" x) 'calc-select-part) (define-key calc-mode-map (format "r%c" x) 'calc-recall-quick) (define-key calc-mode-map (format "s%c" x) 'calc-store-quick) (define-key calc-mode-map (format "t%c" x) 'calc-store-into-quick) - (define-key calc-mode-map (format "u%c" x) 'calc-quick-units))) + (define-key calc-mode-map (format "u%c" x) 'calc-quick-units)) "0123456789") (let ((i ?A)) @@ -711,9 +710,9 @@ (define-key calc-alg-map "\e\177" 'calc-pop-above) ;;;; (Autoloads here) - (mapc (function (lambda (x) - (mapcar (function (lambda (func) (autoload func (car x)))) - (cdr x)))) + (mapc (lambda (x) + (mapcar (lambda (func) (autoload func (car x))) + (cdr x))) '( ("calc-alg" calc-has-rules math-defsimplify @@ -980,9 +979,9 @@ 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 (lambda (x) + (mapcar (lambda (cmd) (autoload cmd (car x) nil t)) + (cdr x))) '( ("calc-alg" calc-alg-evaluate calc-apart calc-collect calc-expand @@ -1196,7 +1195,7 @@ calc-set-xor calc-sort calc-subvector calc-tail calc-transpose calc-unpack calc-unpack-bits calc-vector-find calc-vlength) ("calc-yank" calc-copy-as-kill calc-copy-region-as-kill -calc-copy-to-buffer calc-edit calc-edit-cancel calc-edit-mode +calc-copy-to-buffer calc-edit calc-edit-cancel calc--edit-mode calc-kill calc-kill-region calc-yank)))) (defun calc-init-prefixes () @@ -1358,7 +1357,7 @@ calc-kill calc-kill-region calc-yank)))) calc-redo-list nil) (let (calc-stack calc-user-parse-tables calc-standard-date-formats calc-invocation-macro) - (mapc (function (lambda (v) (set v nil))) calc-local-var-list) + (mapc (lambda (v) (set v nil)) calc-local-var-list) (if (and arg (<= arg 0)) (calc-mode-var-list-restore-default-values) (calc-mode-var-list-restore-saved-values))) @@ -1398,9 +1397,8 @@ calc-kill calc-kill-region calc-yank)))) (defun calc-scroll-up (n) (interactive "P") - (condition-case nil - (scroll-up (or n (/ (window-height) 2))) - (error nil)) + (ignore-errors + (scroll-up (or n (/ (window-height) 2)))) (if (pos-visible-in-window-p (max 1 (- (point-max) 2))) (if (eq major-mode 'calc-mode) (calc-realign) @@ -1659,7 +1657,7 @@ calc-kill calc-kill-region calc-yank)))) (calc-pop-stack n 1 t) (calc-push-list (mapcar #'car entries) 1 - (mapcar (function (lambda (x) (nth 2 x))) + (mapcar (lambda (x) (nth 2 x)) entries))))))) (defvar calc-refreshing-evaltos nil) @@ -1925,11 +1923,10 @@ calc-kill calc-kill-region calc-yank)))) (let* ((calc-z-prefix-msgs nil) (calc-z-prefix-buf "") (kmap (sort (copy-sequence (calc-user-key-map)) - (function (lambda (x y) (< (car x) (car y)))))) + (lambda (x y) (< (car x) (car y))))) (flags (apply #'logior - (mapcar (function - (lambda (k) - (calc-user-function-classify (car k)))) + (mapcar (lambda (k) + (calc-user-function-classify (car k))) kmap)))) (if (= (logand flags 8) 0) (calc-user-function-list kmap 7) @@ -2420,17 +2417,6 @@ If X is not an error form, return 1." (mapcar #'math-normalize (cdr a)))))) -;;; Normalize a bignum digit list by trimming high-end zeros. [L l] -(defun math-norm-bignum (a) - (let ((digs a) (last nil)) - (while digs - (or (eq (car digs) 0) (setq last digs)) - (setq digs (cdr digs))) - (and last - (progn - (setcdr last nil) - 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))) @@ -2545,23 +2531,6 @@ If X is not an error form, return 1." 0 2)))) -;;; Compare two bignum digit lists, return -1 for A<B, 0 for A=B, 1 for A>B. -(defun math-compare-bignum (a b) ; [S l l] - (let ((res 0)) - (while (and a b) - (if (< (car a) (car b)) - (setq res -1) - (if (> (car a) (car b)) - (setq res 1))) - (setq a (cdr a) - b (cdr b))) - (if a - (progn - (while (eq (car a) 0) (setq a (cdr a))) - (if a 1 res)) - (while (eq (car b) 0) (setq b (cdr b))) - (if b -1 res)))) - (defun math-compare-lists (a b) (cond ((null a) (null b)) ((null b) nil) @@ -2634,9 +2603,8 @@ If X is not an error form, return 1." (let ((rhs (calc-top-n 1))) (calc-enter-result (- 1 n) name - (mapcar (function - (lambda (x) - (list func x rhs))) + (mapcar (lambda (x) + (list func x rhs)) (calc-top-list-n (- n) 2)))))))) (defun calc-unary-op-fancy (name func arg) @@ -2645,9 +2613,8 @@ If X is not an error form, return 1." (cond ((> n 0) (calc-enter-result n name - (mapcar (function - (lambda (x) - (list func x))) + (mapcar (lambda (x) + (list func x)) (calc-top-list-n n)))) ((< n 0) (calc-enter-result 1 @@ -2690,7 +2657,7 @@ If X is not an error form, return 1." (if (Math-integer-negp a) (setq a (math-neg a))) (if (Math-integer-negp b) (setq b (math-neg b))) (let (c) - (if (Math-natnum-lessp a b) + (if (< a b) (setq c b b a a c)) (while (and (consp a) (not (eq b 0))) (setq c b @@ -3095,6 +3062,7 @@ If X is not an error form, return 1." (defvar math-read-big-baseline) (defvar math-read-big-h2) (defvar math-read-big-err-msg) +(defvar math-read-big-lines) (defun math-read-big-expr (str) (and (> (length calc-left-label) 0) @@ -3139,41 +3107,42 @@ If X is not an error form, return 1." (defvar math-rb-h2) -(defun math-read-big-bigp (math-read-big-lines) - (and (cdr math-read-big-lines) - (let ((matrix nil) - (v 0) - (height (if (> (length (car math-read-big-lines)) 0) 1 0))) - (while (and (cdr math-read-big-lines) - (let* ((i 0) - j - (l1 (car math-read-big-lines)) - (l2 (nth 1 math-read-big-lines)) - (len (min (length l1) (length l2)))) - (if (> (length l2) 0) - (setq height (1+ height))) - (while (and (< i len) - (or (memq (aref l1 i) '(?\ ?\- ?\_)) - (memq (aref l2 i) '(?\ ?\-)) - (and (memq (aref l1 i) '(?\| ?\,)) - (= (aref l2 i) (aref l1 i))) - (and (eq (aref l1 i) ?\[) - (eq (aref l2 i) ?\[) - (let ((math-rb-h2 (length l1))) - (setq j (math-read-big-balance - (1+ i) v "["))) - (setq i (1- j))))) - (setq i (1+ i))) - (or (= i len) - (and (eq (aref l1 i) ?\[) - (eq (aref l2 i) ?\[) - (setq matrix t) - nil)))) - (setq math-read-big-lines (cdr math-read-big-lines) - v (1+ v))) - (or (and (> height 1) - (not (cdr math-read-big-lines))) - matrix)))) +(defun math-read-big-bigp (read-big-lines) + (when (cdr read-big-lines) + (let ((math-read-big-lines read-big-lines) + (matrix nil) + (v 0) + (height (if (> (length (car read-big-lines)) 0) 1 0))) + (while (and (cdr math-read-big-lines) + (let* ((i 0) + j + (l1 (car math-read-big-lines)) + (l2 (nth 1 math-read-big-lines)) + (len (min (length l1) (length l2)))) + (if (> (length l2) 0) + (setq height (1+ height))) + (while (and (< i len) + (or (memq (aref l1 i) '(?\ ?\- ?\_)) + (memq (aref l2 i) '(?\ ?\-)) + (and (memq (aref l1 i) '(?\| ?\,)) + (= (aref l2 i) (aref l1 i))) + (and (eq (aref l1 i) ?\[) + (eq (aref l2 i) ?\[) + (let ((math-rb-h2 (length l1))) + (setq j (math-read-big-balance + (1+ i) v "["))) + (setq i (1- j))))) + (setq i (1+ i))) + (or (= i len) + (and (eq (aref l1 i) ?\[) + (eq (aref l2 i) ?\[) + (setq matrix t) + nil)))) + (setq math-read-big-lines (cdr math-read-big-lines) + v (1+ v))) + (or (and (> height 1) + (not (cdr math-read-big-lines))) + matrix)))) ;;; Nontrivial "flat" formatting. @@ -3457,6 +3426,8 @@ A command spec is a command name symbol, a keyboard macro string, a list containing a numeric entry string, or nil. A key may contain additional specs for Inverse, Hyperbolic, and Inv+Hyp.") +(make-obsolete-variable 'calc-ext-load-hook + "use `with-eval-after-load' instead." "28.1") (run-hooks 'calc-ext-load-hook) (provide 'calc-ext) diff --git a/lisp/calc/calc-fin.el b/lisp/calc/calc-fin.el index 799b4b863e9..76bb53e7b10 100644 --- a/lisp/calc/calc-fin.el +++ b/lisp/calc/calc-fin.el @@ -1,4 +1,4 @@ -;;; calc-fin.el --- financial functions for Calc +;;; calc-fin.el --- financial functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el index 19badd42ec3..ee53b94cd64 100644 --- a/lisp/calc/calc-forms.el +++ b/lisp/calc/calc-forms.el @@ -1,4 +1,4 @@ -;;; calc-forms.el --- data format conversion functions for Calc +;;; calc-forms.el --- data format conversion functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -678,10 +678,11 @@ in the Gregorian calendar." (defvar math-fd-isoweek) (defvar math-fd-isoweekday) -(defun math-format-date (math-fd-date) - (if (eq (car-safe math-fd-date) 'date) - (setq math-fd-date (nth 1 math-fd-date))) - (let ((entry (list math-fd-date calc-internal-prec calc-date-format))) +(defun math-format-date (fd-date) + (let* ((math-fd-date (if (eq (car-safe fd-date) 'date) + (nth 1 fd-date) + fd-date)) + (entry (list math-fd-date calc-internal-prec calc-date-format))) (or (cdr (assoc entry math-format-date-cache)) (let* ((math-fd-dt nil) (math-fd-iso-dt nil) @@ -709,6 +710,10 @@ as measured in the number of days before December 31, 1 BC (Gregorian).") "The beginning of the Julian date calendar, as measured in the integer number of days before December 31, 1 BC (Gregorian).") +(defconst math-unix-epoch 719163 + "The beginning of Unix time: days from December 31, 1 BC (Gregorian) +to Jan 1, 1970 AD.") + (defun math-format-date-part (x) (cond ((stringp x) x) @@ -730,7 +735,8 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)." (math-floor math-fd-date) math-julian-date-beginning-int))) ((eq x 'U) - (math-format-number (nth 1 (math-date-parts math-fd-date 719164)))) + (math-format-number (nth 1 (math-date-parts math-fd-date + math-unix-epoch)))) ((memq x '(IYYY Iww w)) (progn (or math-fd-iso-dt @@ -909,15 +915,16 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)." ;; which is called by math-parse-date and math-parse-standard-date. (defvar math-pd-str) -(defun math-parse-date (math-pd-str) +(defun math-parse-date (pd-str) (catch 'syntax - (or (math-parse-standard-date math-pd-str t) - (math-parse-standard-date math-pd-str nil) - (and (string-match "W[0-9][0-9]" math-pd-str) - (math-parse-iso-date math-pd-str)) - (and (string-match "\\`[^-+/0-9a-zA-Z]*\\([-+]?[0-9]+\\.?[0-9]*\\([eE][-+]?[0-9]+\\)?\\)[^-+/0-9a-zA-Z]*\\'" math-pd-str) - (list 'date (math-read-number (math-match-substring math-pd-str 1)))) + (or (math-parse-standard-date pd-str t) + (math-parse-standard-date pd-str nil) + (and (string-match "W[0-9][0-9]" pd-str) + (math-parse-iso-date pd-str)) + (and (string-match "\\`[^-+/0-9a-zA-Z]*\\([-+]?[0-9]+\\.?[0-9]*\\([eE][-+]?[0-9]+\\)?\\)[^-+/0-9a-zA-Z]*\\'" pd-str) + (list 'date (math-read-number (math-match-substring pd-str 1)))) (let ((case-fold-search t) + (math-pd-str pd-str) (year nil) (month nil) (day nil) (weekday nil) (hour nil) (minute nil) (second nil) (bc-flag nil) (a nil) (b nil) (c nil) (bigyear nil) temp) @@ -1123,8 +1130,9 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)." (substring math-pd-str (match-end 0)))) n)))) -(defun math-parse-standard-date (math-pd-str with-time) - (let ((case-fold-search t) +(defun math-parse-standard-date (pd-str with-time) + (let ((math-pd-str pd-str) + (case-fold-search t) (okay t) num (fmt calc-date-format) this next (gnext nil) (isoyear nil) (isoweek nil) (isoweekday nil) @@ -1173,7 +1181,7 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)." (setq num (math-match-substring math-pd-str 0) math-pd-str (substring math-pd-str (match-end 0)) num (math-date-to-dt - (math-add 719164 + (math-add math-unix-epoch (math-div (math-read-number num) '(float 864 2)))) hour (nth 3 num) @@ -1301,9 +1309,10 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)." (setq day (math-add day (1- yearday)))) day)))))) -(defun math-parse-iso-date (math-pd-str) - "Parse MATH-PD-STR as an ISO week date, or return nil." - (let ((case-fold-search t) +(defun math-parse-iso-date (pd-str) + "Parse PD-STR as an ISO week date, or return nil." + (let ((math-pd-str pd-str) + (case-fold-search t) (isoyear nil) (isoweek nil) (isoweekday nil) (hour nil) (minute nil) (second nil)) ;; Extract the time, if any. @@ -1434,11 +1443,11 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)." (defun calcFunc-unixtime (date &optional zone) (if (math-realp date) (progn - (setq date (math-add 719163 (math-div date '(float 864 2)))) + (setq date (math-add math-unix-epoch (math-div date '(float 864 2)))) (list 'date (math-sub date (math-div (calcFunc-tzone zone date) '(float 864 2))))) (if (eq (car date) 'date) - (math-add (nth 1 (math-date-parts (nth 1 date) 719163)) + (math-add (nth 1 (math-date-parts (nth 1 date) math-unix-epoch)) (calcFunc-tzone zone date)) (math-reject-arg date 'datep)))) @@ -1608,7 +1617,7 @@ and ends on the first Sunday of November at 2 a.m." (math-std-daylight-savings-old date dt zone bump) (math-std-daylight-savings-new date dt zone bump))) -(defun math-std-daylight-savings-new (date dt zone bump) +(defun math-std-daylight-savings-new (date dt _zone bump) "Standard North American daylight saving algorithm as of 2007. This implements the rules for the U.S. and Canada. Daylight saving begins on the second Sunday of March at 2 a.m., @@ -1629,7 +1638,7 @@ and ends on the first Sunday of November at 2 a.m." (t 0)))) (t 0))) -(defun math-std-daylight-savings-old (date dt zone bump) +(defun math-std-daylight-savings-old (date dt _zone bump) "Standard North American daylight saving algorithm before 2007. This implements the rules for the U.S. and Canada. Daylight saving begins on the first Sunday of April at 2 a.m., @@ -1652,7 +1661,7 @@ and ends on the last Sunday of October at 2 a.m." ;;; Compute the day (1-31) of the WDAY (0-6) on or preceding the given ;;; day of the given month. -(defun math-prev-weekday-in-month (date dt day wday) +(defun math-prev-weekday-in-month (date dt day _wday) (or day (setq day (nth 2 dt))) (if (> day (math-days-in-month (car dt) (nth 1 dt))) (setq day (math-days-in-month (car dt) (nth 1 dt)))) @@ -1870,8 +1879,8 @@ and ends on the last Sunday of October at 2 a.m." (and days (= day (car days)) (setq holiday t))) (let* ((weekdays (nth 3 math-holidays-cache)) - (weeks (1- (/ (+ day 6) 7))) - (wkday (- day 1 (* weeks 7)))) + (weeks (/ day 7)) + (wkday (mod day 7))) ; Day of week: 0=Sunday, 6=Saturday (setq delta (+ delta (* weeks (length weekdays)))) (while (and weekdays (< (car weekdays) wkday)) (setq weekdays (cdr weekdays) @@ -1905,14 +1914,15 @@ and ends on the last Sunday of October at 2 a.m." (setq delta (1+ delta))) (setq day (+ day delta))) (let* ((weekdays (nth 3 math-holidays-cache)) - (bweek (- 7 (length weekdays))) - (weeks (1- (/ (+ day (1- bweek)) bweek))) - (wkday (- day 1 (* weeks bweek))) + (bweek (- 7 (length weekdays))) ; Business days in a week, 1..7. + (weeks (/ day bweek)) ; Whole weeks. + (wkday (mod day bweek)) ; Business day in last week, 0..bweek-1 (w 0)) (setq day (+ day (* weeks (length weekdays)))) + ;; Add business days in the last week; `w' is weekday, 0..6. (while (if (memq w weekdays) (setq day (1+ day)) - (> (setq wkday (1- wkday)) 0)) + (>= (setq wkday (1- wkday)) 0)) (setq w (1+ w))) (let ((hours (nth 7 math-holidays-cache))) (if hours @@ -2030,18 +2040,18 @@ and ends on the last Sunday of October at 2 a.m." nil))) (or done (setq math-holidays-cache-tag t)))))) -(defun math-setup-year-holidays (math-sh-year) - (let ((exprs (nth 2 math-holidays-cache))) - (while exprs +(defun math-setup-year-holidays (sh-year) + (let ((math-sh-year sh-year)) + (dolist (expr (nth 2 math-holidays-cache)) + (defvar var-y) (defvar var-m) (let* ((var-y math-sh-year) (var-m nil) - (expr (math-evaluate-expr (car exprs)))) + (expr (math-evaluate-expr expr))) (if (math-expr-contains expr '(var m var-m)) (let ((var-m 0)) (while (<= (setq var-m (1+ var-m)) 12) (math-setup-add-holidays (math-evaluate-expr expr)))) - (math-setup-add-holidays expr))) - (setq exprs (cdr exprs))))) + (math-setup-add-holidays expr)))))) (defun math-setup-add-holidays (days) ; uses "math-sh-year" (cond ((eq (car-safe days) 'vec) @@ -2119,7 +2129,7 @@ and ends on the last Sunday of October at 2 a.m." ((memq (car n) '(+ - / vec neg)) (math-normalize (cons (car n) - (mapcar (function (lambda (x) (math-make-mod x m))) + (mapcar (lambda (x) (math-make-mod x m)) (cdr n))))) ((and (eq (car n) '*) (Math-anglep (nth 1 n))) (math-mul (math-make-mod (nth 1 n) m) (nth 2 n))) diff --git a/lisp/calc/calc-frac.el b/lisp/calc/calc-frac.el index 3d289421caf..bf3c16816db 100644 --- a/lisp/calc/calc-frac.el +++ b/lisp/calc/calc-frac.el @@ -1,4 +1,4 @@ -;;; calc-frac.el --- fraction functions for Calc +;;; calc-frac.el --- fraction functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -132,9 +132,8 @@ (cond ((Math-ratp a) a) ((memq (car a) '(cplx polar vec hms date sdev intv mod)) - (cons (car a) (mapcar (function - (lambda (x) - (calcFunc-frac x tol))) + (cons (car a) (mapcar (lambda (x) + (calcFunc-frac x tol)) (cdr a)))) ((Math-messy-integerp a) (math-trunc a)) diff --git a/lisp/calc/calc-funcs.el b/lisp/calc/calc-funcs.el index cdf291aa1d0..053fa2e5851 100644 --- a/lisp/calc/calc-funcs.el +++ b/lisp/calc/calc-funcs.el @@ -1,4 +1,4 @@ -;;; calc-funcs.el --- well-known functions for Calc +;;; calc-funcs.el --- well-known functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -410,7 +410,7 @@ ((and (math-num-integerp b) (if (math-negp b) (math-reject-arg b 'range) - (Math-natnum-lessp (setq b (math-trunc b)) 20))) + (< (setq b (math-trunc b)) 20))) (and calc-symbolic-mode (or (math-floatp a) (math-floatp b)) (math-inexact-result)) (math-mul @@ -427,7 +427,7 @@ ((and (math-num-integerp a) (if (math-negp a) (math-reject-arg a 'range) - (Math-natnum-lessp (setq a (math-trunc a)) 20))) + (< (setq a (math-trunc a)) 20))) (math-sub (or math-current-beta-value (calcFunc-beta a b)) (calcFunc-betaB (math-sub 1 x) b a))) (t @@ -797,12 +797,11 @@ (math-reduce-vec 'math-add (cons 'vec - (mapcar (function - (lambda (c) - (setq k (1+ k)) - (math-mul (math-mul fac c) - (math-sub (math-pow x1 k) - (math-pow x2 k))))) + (mapcar (lambda (c) + (setq k (1+ k)) + (math-mul (math-mul fac c) + (math-sub (math-pow x1 k) + (math-pow x2 k)))) coefs))) x))) (math-mul (math-pow 2 n) @@ -816,25 +815,25 @@ (list (list 'frac -174611 - (math-read-number-simple "802857662698291200000")) + 802857662698291200000) (list 'frac 43867 - (math-read-number-simple "5109094217170944000")) + 5109094217170944000) (list 'frac -3617 - (math-read-number-simple "10670622842880000")) + 10670622842880000) (list 'frac 1 - (math-read-number-simple "74724249600")) + 74724249600) (list 'frac -691 - (math-read-number-simple "1307674368000")) + 1307674368000) (list 'frac 1 - (math-read-number-simple "47900160")) + 47900160) (list 'frac -1 - (math-read-number-simple "1209600")) + 1209600) (list 'frac 1 30240) diff --git a/lisp/calc/calc-graph.el b/lisp/calc/calc-graph.el index aa18c7d4fb1..4785fb7fba2 100644 --- a/lisp/calc/calc-graph.el +++ b/lisp/calc/calc-graph.el @@ -1,4 +1,4 @@ -;;; calc-graph.el --- graph output functions for Calc +;;; calc-graph.el --- graph output functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -216,7 +216,7 @@ (or (and (Math-num-integerp pstyle) (math-trunc pstyle)) (if (eq (car-safe (calc-var-value (nth 2 ydata))) 'vec) 0 -1)) - (math-contains-sdev-p (eval (nth 2 ydata)))))) + (math-contains-sdev-p (eval (nth 2 ydata) t))))) (defun calc-graph-lookup (thing) (if (and (eq (car-safe thing) 'var) @@ -313,13 +313,13 @@ (defvar calc-graph-blank) (defvar calc-graph-non-blank) (defvar calc-graph-curve-num) +(defvar math-arglist) (defun calc-graph-plot (flag &optional printing) (interactive "P") (calc-slow-wrapper (let ((calcbuf (current-buffer)) (tempbuf (get-buffer-create "*Gnuplot Temp-2*")) - (tempbuftop 1) (tempoutfile nil) (calc-graph-curve-num 0) (calc-graph-refine (and flag (> (prefix-numeric-value flag) 0))) @@ -351,7 +351,7 @@ (if (>= ver 3) (insert "set surface\nset nocontour\n" "set " (if calc-graph-is-splot "" "no") "parametric\n" - "set notime\nset border\nset ztics\nset zeroaxis\n" + "set notimestamp\nset border\nset ztics\nset zeroaxis\n" "set view 60,30,1,1\nset offsets 0,0,0,0\n")) (setq samples-pos (point)) (insert "\n\n" str)) @@ -403,7 +403,7 @@ (and (equal output "tty") (setq tty-output t))) (setq tempoutfile (calc-temp-file-name -1) output tempoutfile)) - (setq output (eval output))) + (setq output (eval output t))) (or (equal device calc-graph-last-device) (progn (setq calc-graph-last-device device) @@ -480,9 +480,11 @@ (calc-graph-xp calc-graph-xvalue) (calc-graph-yp calc-graph-yvalue) (calc-graph-zp nil) - (calc-graph-xlow nil) (calc-graph-xhigh nil) (y3low nil) (y3high nil) + (calc-graph-xlow nil) (calc-graph-xhigh nil) + ;; (y3low nil) (y3high nil) calc-graph-xvec calc-graph-xval calc-graph-xstep var-DUMMY - y3val calc-graph-y3step var-DUMMY2 (calc-graph-zval nil) + ;; y3val + calc-graph-y3step var-DUMMY2 (calc-graph-zval nil) calc-graph-yvec calc-graph-yval calc-graph-ycache calc-graph-ycacheptr calc-graph-yvector calc-graph-numsteps calc-graph-numsteps3 (calc-graph-keep-file (and (not calc-graph-is-splot) (file-exists-p filename))) @@ -562,7 +564,7 @@ calc-gnuplot-print-output))) (if (symbolp command) (funcall command output) - (eval command)))))))))) + (eval command t)))))))))) (defun calc-graph-compute-2d () (if (setq calc-graph-yvec (eq (car-safe calc-graph-yvalue) 'vec)) @@ -905,16 +907,15 @@ (while calc-graph-file-cache (and (car calc-graph-file-cache) (file-exists-p (car (car calc-graph-file-cache))) - (condition-case err - (delete-file (car (car calc-graph-file-cache))) - (error nil))) + (ignore-errors + (delete-file (car (car calc-graph-file-cache))))) (setq calc-graph-file-cache (cdr calc-graph-file-cache)))) (defun calc-graph-kill-hook () (calc-graph-delete-temps)) (defun calc-graph-show-tty (output) - "Default calc-gnuplot-plot-command for \"tty\" output mode. + "Default `calc-gnuplot-plot-command' for \"tty\" output mode. This is useful for tek40xx and other graphics-terminal types." (call-process shell-file-name nil calc-gnuplot-buffer nil shell-command-switch @@ -923,7 +924,7 @@ This is useful for tek40xx and other graphics-terminal types." (defvar calc-dumb-map nil "The keymap for the \"dumb\" terminal plot.") -(defun calc-graph-show-dumb (&optional output) +(defun calc-graph-show-dumb (&optional _output) "Default calc-gnuplot-plot-command for Pinard's \"dumb\" terminal type. This \"dumb\" driver will be present in Gnuplot 3.0." (interactive) @@ -1116,14 +1117,14 @@ This \"dumb\" driver will be present in Gnuplot 3.0." (delete-region start end) (goto-char start) (setq errform - (condition-case nil - (math-contains-sdev-p - (eval (intern - (concat "var-" - (save-excursion - (re-search-backward ":\\(.*\\)}") - (match-string 1)))))) - (error nil))) + (ignore-errors + (math-contains-sdev-p + (symbol-value + (intern + (concat "var-" + (save-excursion + (re-search-backward ":\\(.*\\)}") + (match-string 1)))))))) (if yerr (insert " with yerrorbars") (insert " with " @@ -1165,7 +1166,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0." (or (calc-graph-find-plot nil nil) (error "No data points have been set!")) (let ((base (point)) - start + ;; start end) (re-search-forward "[,\n]\\|[ \t]+with") (setq end (match-beginning 0)) @@ -1462,7 +1463,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0." (match-beginning 1) (match-end 1)))) (setq calc-gnuplot-version 1)))) - (condition-case err + (condition-case nil (let ((args (append (and calc-gnuplot-display (not (equal calc-gnuplot-display (getenv "DISPLAY"))) diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el index fc7f5f8b355..dd5063f27d5 100644 --- a/lisp/calc/calc-help.el +++ b/lisp/calc/calc-help.el @@ -1,4 +1,4 @@ -;;; calc-help.el --- help display functions for Calc, +;;; calc-help.el --- help display functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -33,8 +33,8 @@ (declare-function Info-last "info" ()) -(defun calc-help-prefix (arg) - "This key is the prefix for Calc help functions. See calc-help-for-help." +(defun calc-help-prefix (&optional _arg) + "This key is the prefix for Calc help functions. See `calc-help-for-help'." (interactive "P") (or calc-dispatch-help (sit-for echo-keystrokes)) (let ((key (calc-read-key-sequence @@ -79,7 +79,7 @@ C-w Describe how there is no warranty for Calc." (message "Calc Help options: Help, Info, ... press SPC, DEL to scroll, C-g to cancel") (memq (setq key (read-event)) '(? ?\C-h ?\C-? ?\C-v ?\M-v))) - (condition-case err + (condition-case nil (if (memq key '(? ?\C-v)) (scroll-up) (scroll-down)) @@ -302,21 +302,19 @@ C-w Describe how there is no warranty for Calc." (let ((entrylist '()) entry) (require 'info nil t) - (while indices - (condition-case nil - (with-temp-buffer - (Info-mode) - (Info-goto-node (concat "(Calc)" (car indices) " Index")) - (goto-char (point-min)) - (while (re-search-forward "\n\\* \\(.*\\): " nil t) - (setq entry (match-string 1)) - (if (and (not (string-match "<[1-9]+>" entry)) - (not (string-match "(.*)" entry)) - (not (string= entry "Menu"))) - (unless (assoc entry entrylist) - (setq entrylist (cons entry entrylist)))))) - (error nil)) - (setq indices (cdr indices))) + (dolist (indice indices) + (ignore-errors + (with-temp-buffer + (Info-mode) + (Info-goto-node (concat "(Calc)" indice " Index")) + (goto-char (point-min)) + (while (re-search-forward "\n\\* \\(.*\\): " nil t) + (setq entry (match-string 1)) + (if (and (not (string-match "<[1-9]+>" entry)) + (not (string-match "(.*)" entry)) + (not (string= entry "Menu"))) + (unless (assoc entry entrylist) + (setq entrylist (cons entry entrylist)))))))) entrylist)) (defun calc-describe-function (&optional func) @@ -404,34 +402,32 @@ C-w Describe how there is no warranty for Calc." "Or type `h i' to read the full Calc manual on-line.\n\n")) (princ "Basic keys:\n") (let* ((calc-full-help-flag t)) - (mapc (function (lambda (x) (princ (format - " %s\n" - (substitute-command-keys x))))) + (mapc (lambda (x) + (princ (format + " %s\n" + (substitute-command-keys x)))) (nreverse (cdr (reverse (cdr (calc-help)))))) - (mapc (function (lambda (prefix) - (let ((msgs (condition-case err - (funcall prefix) - (error nil)))) - (if (car msgs) - (princ - (if (eq (nth 2 msgs) ?v) - (format-message - "\n`v' or `V' prefix (vector/matrix) keys: \n") - (if (nth 2 msgs) - (format-message - "\n`%c' prefix (%s) keys:\n" - (nth 2 msgs) - (or (cdr (assq (nth 2 msgs) - calc-help-long-names)) - (nth 1 msgs))) - (format "\n%s-modified keys:\n" - (capitalize (nth 1 msgs))))))) - (mapcar (function - (lambda (x) - (princ (format - " %s\n" - (substitute-command-keys x))))) - (car msgs))))) + (mapc (lambda (prefix) + (let ((msgs (ignore-errors (funcall prefix)))) + (if (car msgs) + (princ + (if (eq (nth 2 msgs) ?v) + (format-message + "\n`v' or `V' prefix (vector/matrix) keys: \n") + (if (nth 2 msgs) + (format-message + "\n`%c' prefix (%s) keys:\n" + (nth 2 msgs) + (or (cdr (assq (nth 2 msgs) + calc-help-long-names)) + (nth 1 msgs))) + (format "\n%s-modified keys:\n" + (capitalize (nth 1 msgs))))))) + (mapcar (lambda (x) + (princ (format + " %s\n" + (substitute-command-keys x)))) + (car msgs)))) '(calc-inverse-prefix-help calc-hyperbolic-prefix-help calc-inv-hyp-prefix-help diff --git a/lisp/calc/calc-incom.el b/lisp/calc/calc-incom.el index 6d490dbe516..e27d65092eb 100644 --- a/lisp/calc/calc-incom.el +++ b/lisp/calc/calc-incom.el @@ -1,4 +1,4 @@ -;;; calc-incom.el --- complex data type input functions for Calc +;;; calc-incom.el --- complex data type input functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-keypd.el b/lisp/calc/calc-keypd.el index e0820912207..1902a4f3f29 100644 --- a/lisp/calc/calc-keypd.el +++ b/lisp/calc/calc-keypd.el @@ -1,4 +1,4 @@ -;;; calc-keypd.el --- mouse-capable keypad input for Calc +;;; calc-keypd.el --- mouse-capable keypad input for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -35,17 +35,17 @@ (defvar calc-keypad-prev-input nil) (defvar calc-keypad-said-hello nil) -;;; |----+----+----+----+----+----| -;;; | ENTER |+/- |EEX |UNDO| <- | -;;; |-----+---+-+--+--+-+---++----| -;;; | INV | 7 | 8 | 9 | / | -;;; |-----+-----+-----+-----+-----| -;;; | HYP | 4 | 5 | 6 | * | -;;; |-----+-----+-----+-----+-----| -;;; |EXEC | 1 | 2 | 3 | - | -;;; |-----+-----+-----+-----+-----| -;;; | OFF | 0 | . | PI | + | -;;; |-----+-----+-----+-----+-----| +;; |----+----+----+----+----+----| +;; | ENTER |+/- |EEX |UNDO| <- | +;; |-----+---+-+--+--+-+---++----| +;; | INV | 7 | 8 | 9 | / | +;; |-----+-----+-----+-----+-----| +;; | HYP | 4 | 5 | 6 | * | +;; |-----+-----+-----+-----+-----| +;; |EXEC | 1 | 2 | 3 | - | +;; |-----+-----+-----+-----+-----| +;; | OFF | 0 | . | PI | + | +;; |-----+-----+-----+-----+-----| (defvar calc-keypad-layout '( ( ( "ENTER" calc-enter calc-roll-down calc-roll-up calc-over ) ( "ENTER" calc-enter calc-roll-down calc-roll-up calc-over ) @@ -83,12 +83,12 @@ calc-keypad-modes-menu calc-keypad-user-menu ) ) -;;; |----+----+----+----+----+----| -;;; |FLR |CEIL|RND |TRNC|CLN2|FLT | -;;; |----+----+----+----+----+----| -;;; | LN |EXP | |ABS |IDIV|MOD | -;;; |----+----+----+----+----+----| -;;; |SIN |COS |TAN |SQRT|y^x |1/x | +;; |----+----+----+----+----+----| +;; |FLR |CEIL|RND |TRNC|CLN2|FLT | +;; |----+----+----+----+----+----| +;; | LN |EXP | |ABS |IDIV|MOD | +;; |----+----+----+----+----+----| +;; |SIN |COS |TAN |SQRT|y^x |1/x | (defvar calc-keypad-math-menu '( ( ( "FLR" calc-floor ) @@ -110,12 +110,12 @@ ( "y^x" calc-power ) ( "1/x" calc-inv ) ) )) -;;; |----+----+----+----+----+----| -;;; |IGAM|BETA|IBET|ERF |BESJ|BESY| -;;; |----+----+----+----+----+----| -;;; |IMAG|CONJ| RE |ATN2|RAND|RAGN| -;;; |----+----+----+----+----+----| -;;; |GCD |FACT|DFCT|BNOM|PERM|NXTP| +;; |----+----+----+----+----+----| +;; |IGAM|BETA|IBET|ERF |BESJ|BESY| +;; |----+----+----+----+----+----| +;; |IMAG|CONJ| RE |ATN2|RAND|RAGN| +;; |----+----+----+----+----+----| +;; |GCD |FACT|DFCT|BNOM|PERM|NXTP| (defvar calc-keypad-funcs-menu '( ( ( "IGAM" calc-inc-gamma ) @@ -137,12 +137,12 @@ ( "PERM" calc-perm ) ( "NXTP" calc-next-prime calc-prev-prime ) ) )) -;;; |----+----+----+----+----+----| -;;; |AND | OR |XOR |NOT |LSH |RSH | -;;; |----+----+----+----+----+----| -;;; |DEC |HEX |OCT |BIN |WSIZ|ARSH| -;;; |----+----+----+----+----+----| -;;; | A | B | C | D | E | F | +;; |----+----+----+----+----+----| +;; |AND | OR |XOR |NOT |LSH |RSH | +;; |----+----+----+----+----+----| +;; |DEC |HEX |OCT |BIN |WSIZ|ARSH| +;; |----+----+----+----+----+----| +;; | A | B | C | D | E | F | (defvar calc-keypad-binary-menu '( ( ( "AND" calc-and calc-diff ) @@ -164,12 +164,12 @@ ( "E" ("E") ) ( "F" ("F") ) ) )) -;;; |----+----+----+----+----+----| -;;; |SUM |PROD|MAX |MAP*|MAP^|MAP$| -;;; |----+----+----+----+----+----| -;;; |INV |DET |TRN |IDNT|CRSS|"x" | -;;; |----+----+----+----+----+----| -;;; |PACK|UNPK|INDX|BLD |LEN |... | +;; |----+----+----+----+----+----| +;; |SUM |PROD|MAX |MAP*|MAP^|MAP$| +;; |----+----+----+----+----+----| +;; |INV |DET |TRN |IDNT|CRSS|"x" | +;; |----+----+----+----+----+----| +;; |PACK|UNPK|INDX|BLD |LEN |... | (defvar calc-keypad-vector-menu '( ( ( "SUM" calc-vector-sum calc-vector-alt-sum calc-vector-mean ) @@ -196,12 +196,12 @@ ( "LEN" calc-vlength ) ( "..." calc-full-vectors ) ) )) -;;; |----+----+----+----+----+----| -;;; |FLT |FIX |SCI |ENG |GRP | | -;;; |----+----+----+----+----+----| -;;; |RAD |DEG |FRAC|POLR|SYMB|PREC| -;;; |----+----+----+----+----+----| -;;; |SWAP|RLL3|RLL4|OVER|STO |RCL | +;; |----+----+----+----+----+----| +;; |FLT |FIX |SCI |ENG |GRP | | +;; |----+----+----+----+----+----| +;; |RAD |DEG |FRAC|POLR|SYMB|PREC| +;; |----+----+----+----+----+----| +;; |SWAP|RLL3|RLL4|OVER|STO |RCL | (defvar calc-keypad-modes-menu '( ( ( "FLT" calc-normal-notation diff --git a/lisp/calc/calc-lang.el b/lisp/calc/calc-lang.el index 4e10cc17288..b4b2d4cc4f4 100644 --- a/lisp/calc/calc-lang.el +++ b/lisp/calc/calc-lang.el @@ -1,4 +1,4 @@ -;;; calc-lang.el --- calc language functions +;;; calc-lang.el --- calc language functions -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -45,6 +45,8 @@ (defvar math-comp-comma) (defvar math-comp-vector-prec) +(defvar math-exp-str) ;; Dyn scoped + ;;; Alternate entry/display languages. (defun calc-set-language (lang &optional option no-refresh) @@ -144,7 +146,7 @@ ( y1 . (math-C-parse-bess)) ( tgamma . calcFunc-gamma ))) -(defun math-C-parse-bess (f val) +(defun math-C-parse-bess (_f val) "Parse C's j0, j1, y0, y1 functions." (let ((args (math-read-expr-list))) (math-read-token) @@ -155,7 +157,7 @@ ((eq val 'y1) '(calcFunc-besY 1))) args))) -(defun math-C-parse-fma (f val) +(defun math-C-parse-fma (_f _val) "Parse C's fma function fma(x,y,z) => (x * y + z)." (let ((args (math-read-expr-list))) (math-read-token) @@ -173,20 +175,19 @@ (put 'c 'math-vector-brackets "{}") (put 'c 'math-radix-formatter - (function (lambda (r s) - (if (= r 16) (format "0x%s" s) - (if (= r 8) (format "0%s" s) - (format "%d#%s" r s)))))) + (lambda (r s) + (if (= r 16) (format "0x%s" s) + (if (= r 8) (format "0%s" s) + (format "%d#%s" r s))))) (put 'c 'math-compose-subscr - (function - (lambda (a) - (let ((args (cdr (cdr a)))) - (list 'horiz - (math-compose-expr (nth 1 a) 1000) - "[" - (math-compose-vector args ", " 0) - "]"))))) + (lambda (a) + (let ((args (cdr (cdr a)))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[" + (math-compose-vector args ", " 0) + "]")))) (add-to-list 'calc-lang-slash-idiv 'c) (add-to-list 'calc-lang-allow-underscores 'c) @@ -236,9 +237,9 @@ (put 'pascal 'math-output-filter 'calc-output-case-filter) (put 'pascal 'math-radix-formatter - (function (lambda (r s) - (if (= r 16) (format "$%s" s) - (format "%d#%s" r s))))) + (lambda (r s) + (if (= r 16) (format "$%s" s) + (format "%d#%s" r s)))) (put 'pascal 'math-lang-read-symbol '((?\$ @@ -251,17 +252,16 @@ math-exp-pos (match-end 1))))) (put 'pascal 'math-compose-subscr - (function - (lambda (a) - (let ((args (cdr (cdr a)))) - (while (eq (car-safe (nth 1 a)) 'calcFunc-subscr) - (setq args (append (cdr (cdr (nth 1 a))) args) - a (nth 1 a))) - (list 'horiz - (math-compose-expr (nth 1 a) 1000) - "[" - (math-compose-vector args ", " 0) - "]"))))) + (lambda (a) + (let ((args (cdr (cdr a)))) + (while (eq (car-safe (nth 1 a)) 'calcFunc-subscr) + (setq args (append (cdr (cdr (nth 1 a))) args) + a (nth 1 a))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[" + (math-compose-vector args ", " 0) + "]")))) (add-to-list 'calc-lang-allow-underscores 'pascal) (add-to-list 'calc-lang-brackets-are-subscripts 'pascal) @@ -348,17 +348,16 @@ math-exp-pos (match-end 0))))) (put 'fortran 'math-compose-subscr - (function - (lambda (a) - (let ((args (cdr (cdr a)))) - (while (eq (car-safe (nth 1 a)) 'calcFunc-subscr) - (setq args (append (cdr (cdr (nth 1 a))) args) - a (nth 1 a))) - (list 'horiz - (math-compose-expr (nth 1 a) 1000) - "(" - (math-compose-vector args ", " 0) - ")"))))) + (lambda (a) + (let ((args (cdr (cdr a)))) + (while (eq (car-safe (nth 1 a)) 'calcFunc-subscr) + (setq args (append (cdr (cdr (nth 1 a))) args) + a (nth 1 a))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "(" + (math-compose-vector args ", " 0) + ")")))) (add-to-list 'calc-lang-slash-idiv 'fortran) (add-to-list 'calc-lang-allow-underscores 'fortran) @@ -372,14 +371,14 @@ (defvar math-exp-old-pos) (defvar math-parsing-fortran-vector nil) -(defun math-parse-fortran-vector (op) +(defun math-parse-fortran-vector (_op) (let ((math-parsing-fortran-vector '(end . "\000"))) (prog1 (math-read-brackets t "]") (setq math-exp-token (car math-parsing-fortran-vector) math-expr-data (cdr math-parsing-fortran-vector))))) -(defun math-parse-fortran-vector-end (x op) +(defun math-parse-fortran-vector-end (x _op) (if math-parsing-fortran-vector (progn (setq math-parsing-fortran-vector (cons math-exp-token math-expr-data) @@ -466,10 +465,10 @@ ( "\\times" * 191 190 ) ( "*" * 191 190 ) ( "2x" * 191 190 ) + ( "/" / 185 186 ) ( "+" + 180 181 ) ( "-" - 180 181 ) ( "\\over" / 170 171 ) - ( "/" / 170 171 ) ( "\\choose" calcFunc-choose 170 171 ) ( "\\mod" % 170 171 ) ( "<" calcFunc-lt 160 161 ) @@ -596,18 +595,17 @@ (put 'tex 'math-input-filter 'math-tex-input-filter) (put 'tex 'math-matrix-formatter - (function - (lambda (a) - (if (and (integerp calc-language-option) - (or (= calc-language-option 0) - (> calc-language-option 1) - (< calc-language-option -1))) - (append '(vleft 0 "\\matrix{") - (math-compose-tex-matrix (cdr a)) - '("}")) - (append '(horiz "\\matrix{ ") - (math-compose-tex-matrix (cdr a)) - '(" }")))))) + (lambda (a) + (if (and (integerp calc-language-option) + (or (= calc-language-option 0) + (> calc-language-option 1) + (< calc-language-option -1))) + (append '(vleft 0 "\\matrix{") + (math-compose-tex-matrix (cdr a)) + '("}")) + (append '(horiz "\\matrix{ ") + (math-compose-tex-matrix (cdr a)) + '(" }"))))) (put 'tex 'math-var-formatter 'math-compose-tex-var) @@ -692,7 +690,7 @@ "_{" (math-compose-expr (nth 2 a) 0) "}{" (math-compose-expr (nth 1 a) 0) "}")))) -(defun math-parse-tex-sum (f val) +(defun math-parse-tex-sum (f _val) (let (low high save) (or (equal math-expr-data "_") (throw 'syntax "Expected `_'")) (math-read-token) @@ -727,14 +725,15 @@ (math-compose-expr (nth 3 a) 0) (if (memq (nth 1 a) '(0 2)) ")" "]"))) -(defun math-compose-tex-var (a prec) +(defun math-compose-tex-var (a _prec) (if (and calc-language-option (not (= calc-language-option 0)) (string-match "\\`[a-zA-Zα-ωΑ-Ω][a-zA-Zα-ωΑ-Ω0-9]+\\'" (symbol-name (nth 1 a)))) - (if (eq calc-language 'latex) - (format "\\text{%s}" (symbol-name (nth 1 a))) - (format "\\hbox{%s}" (symbol-name (nth 1 a)))) + (format (if (eq calc-language 'latex) + "\\text{%s}" + "\\hbox{%s}") + (symbol-name (nth 1 a))) (math-compose-var a))) (defun math-compose-tex-func (func a) @@ -836,18 +835,17 @@ (put 'latex 'math-complex-format 'i) (put 'latex 'math-matrix-formatter - (function - (lambda (a) - (if (and (integerp calc-language-option) - (or (= calc-language-option 0) - (> calc-language-option 1) - (< calc-language-option -1))) - (append '(vleft 0 "\\begin{pmatrix}") - (math-compose-tex-matrix (cdr a) t) - '("\\end{pmatrix}")) - (append '(horiz "\\begin{pmatrix} ") - (math-compose-tex-matrix (cdr a) t) - '(" \\end{pmatrix}")))))) + (lambda (a) + (if (and (integerp calc-language-option) + (or (= calc-language-option 0) + (> calc-language-option 1) + (< calc-language-option -1))) + (append '(vleft 0 "\\begin{pmatrix}") + (math-compose-tex-matrix (cdr a) t) + '("\\end{pmatrix}")) + (append '(horiz "\\begin{pmatrix} ") + (math-compose-tex-matrix (cdr a) t) + '(" \\end{pmatrix}"))))) (put 'latex 'math-var-formatter 'math-compose-tex-var) @@ -906,7 +904,7 @@ (setq math-exp-str (copy-sequence math-exp-str)) (aset math-exp-str right ?\])))))))))) -(defun math-latex-parse-frac (f val) +(defun math-latex-parse-frac (_f _val) (let (numer denom) (setq numer (car (math-read-expr-list))) (math-read-token) @@ -916,7 +914,7 @@ (list 'frac numer denom) (list '/ numer denom)))) -(defun math-latex-parse-two-args (f val) +(defun math-latex-parse-two-args (f _val) (let (first second) (setq first (car (math-read-expr-list))) (math-read-token) @@ -931,7 +929,7 @@ (put 'latex 'math-input-filter 'math-tex-input-filter) -(defun calc-eqn-language (n) +(defun calc-eqn-language (_n) (interactive "P") (calc-wrapper (calc-set-language 'eqn) @@ -1020,36 +1018,34 @@ (put 'eqn 'math-evalto '("evalto " . " -> ")) (put 'eqn 'math-matrix-formatter - (function - (lambda (a) - (append '(horiz "matrix { ") - (math-compose-eqn-matrix - (cdr (math-transpose a))) - '("}"))))) + (lambda (a) + (append '(horiz "matrix { ") + (math-compose-eqn-matrix + (cdr (math-transpose a))) + '("}")))) (put 'eqn 'math-var-formatter - (function - (lambda (a prec) - (let (v) - (if (and math-compose-hash-args - (let ((p calc-arg-values)) - (setq v 1) - (while (and p (not (equal (car p) a))) - (setq p (and (eq math-compose-hash-args t) (cdr p)) - v (1+ v))) - p)) - (if (eq math-compose-hash-args 1) - "#" - (format "#%d" v)) - (if (string-match ".'\\'" (symbol-name (nth 2 a))) - (math-compose-expr - (list 'calcFunc-Prime - (list - 'var - (intern (substring (symbol-name (nth 1 a)) 0 -1)) - (intern (substring (symbol-name (nth 2 a)) 0 -1)))) - prec) - (symbol-name (nth 1 a)))))))) + (lambda (a prec) + (let (v) + (if (and math-compose-hash-args + (let ((p calc-arg-values)) + (setq v 1) + (while (and p (not (equal (car p) a))) + (setq p (and (eq math-compose-hash-args t) (cdr p)) + v (1+ v))) + p)) + (if (eq math-compose-hash-args 1) + "#" + (format "#%d" v)) + (if (string-match ".'\\'" (symbol-name (nth 2 a))) + (math-compose-expr + (list 'calcFunc-Prime + (list + 'var + (intern (substring (symbol-name (nth 1 a)) 0 -1)) + (intern (substring (symbol-name (nth 2 a)) 0 -1)))) + prec) + (symbol-name (nth 1 a))))))) (defconst math-eqn-special-funcs '( calcFunc-log @@ -1062,31 +1058,30 @@ calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh)) (put 'eqn 'math-func-formatter - (function - (lambda (func a) - (let (left right) - (if (string-match "[^']'+\\'" func) - (let ((n (- (length func) (match-beginning 0) 1))) - (setq func (substring func 0 (- n))) - (while (>= (setq n (1- n)) 0) - (setq func (concat func " prime"))))) - (cond ((or (> (length a) 2) - (not (math-tex-expr-is-flat (nth 1 a)))) - (setq left "{left ( " - right " right )}")) - - ((and - (memq (car a) math-eqn-special-funcs) - (= (length a) 2) - (or (Math-realp (nth 1 a)) - (memq (car (nth 1 a)) '(var *)))) - (setq left "~{" right "}")) - (t - (setq left " ( " - right " )"))) - (list 'horiz func left - (math-compose-vector (cdr a) " , " 0) - right))))) + (lambda (func a) + (let (left right) + (if (string-match "[^']'+\\'" func) + (let ((n (- (length func) (match-beginning 0) 1))) + (setq func (substring func 0 (- n))) + (while (>= (setq n (1- n)) 0) + (setq func (concat func " prime"))))) + (cond ((or (> (length a) 2) + (not (math-tex-expr-is-flat (nth 1 a)))) + (setq left "{left ( " + right " right )}")) + + ((and + (memq (car a) math-eqn-special-funcs) + (= (length a) 2) + (or (Math-realp (nth 1 a)) + (memq (car (nth 1 a)) '(var *)))) + (setq left "~{" right "}")) + (t + (setq left " ( " + right " )"))) + (list 'horiz func left + (math-compose-vector (cdr a) " , " 0) + right)))) (put 'eqn 'math-lang-read-symbol '((?\" @@ -1108,23 +1103,22 @@ ("above" punc ","))) (put 'eqn 'math-lang-adjust-words - (function - (lambda () - (let ((code (assoc math-expr-data math-eqn-ignore-words))) - (cond ((null code)) - ((null (cdr code)) - (math-read-token)) - ((consp (nth 1 code)) - (math-read-token) - (if (assoc math-expr-data (cdr code)) - (setq math-expr-data (format "%s %s" - (car code) math-expr-data)))) - ((eq (nth 1 code) 'punc) - (setq math-exp-token 'punc - math-expr-data (nth 2 code))) - (t - (math-read-token) - (math-read-token))))))) + (lambda () + (let ((code (assoc math-expr-data math-eqn-ignore-words))) + (cond ((null code)) + ((null (cdr code)) + (math-read-token)) + ((consp (nth 1 code)) + (math-read-token) + (if (assoc math-expr-data (cdr code)) + (setq math-expr-data (format "%s %s" + (car code) math-expr-data)))) + ((eq (nth 1 code) 'punc) + (setq math-exp-token 'punc + math-expr-data (nth 2 code))) + (t + (math-read-token) + (math-read-token)))))) (put 'eqn 'math-lang-read '((eq (string-match "->\\|<-\\|\\+-\\|\\\\dots\\|~\\|\\^" @@ -1159,7 +1153,7 @@ (math-compose-eqn-matrix (cdr a))))))) nil)) -(defun math-parse-eqn-matrix (f sym) +(defun math-parse-eqn-matrix (_f _sym) (let ((vec nil)) (while (assoc math-expr-data '(("ccol") ("lcol") ("rcol"))) (math-read-token) @@ -1175,7 +1169,7 @@ (math-read-token) (math-transpose (cons 'vec (nreverse vec))))) -(defun math-parse-eqn-prime (x sym) +(defun math-parse-eqn-prime (x _sym) (if (eq (car-safe x) 'var) (if (equal math-expr-data calc-function-open) (progn @@ -1354,16 +1348,15 @@ ( calcFunc-in . (math-lang-compose-switch-args "Contains")))) (put 'yacas 'math-compose-subscr - (function - (lambda (a) - (let ((args (cdr (cdr a)))) - (list 'horiz - (math-compose-expr (nth 1 a) 1000) - "[" - (math-compose-vector args ", " 0) - "]"))))) - -(defun math-yacas-parse-Sum (f val) + (lambda (a) + (let ((args (cdr (cdr a)))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[" + (math-compose-vector args ", " 0) + "]")))) + +(defun math-yacas-parse-Sum (f _val) "Read in the arguments to \"Sum\" in Calc's Yacas mode." (let ((args (math-read-expr-list))) (math-read-token) @@ -1512,7 +1505,7 @@ ( substitute . (math-maxima-parse-subst)) ( taylor . (math-maxima-parse-taylor)))) -(defun math-maxima-parse-subst (f val) +(defun math-maxima-parse-subst (_f _val) "Read in the arguments to \"subst\" in Calc's Maxima mode." (let ((args (math-read-expr-list))) (math-read-token) @@ -1521,7 +1514,7 @@ (nth 2 args) (nth 0 args)))) -(defun math-maxima-parse-taylor (f val) +(defun math-maxima-parse-taylor (_f _val) "Read in the arguments to \"taylor\" in Calc's Maxima mode." (let ((args (math-read-expr-list))) (math-read-token) @@ -1597,24 +1590,22 @@ (add-to-list 'calc-lang-brackets-are-subscripts 'maxima) (put 'maxima 'math-compose-subscr - (function - (lambda (a) - (let ((args (cdr (cdr a)))) - (list 'horiz - (math-compose-expr (nth 1 a) 1000) - "[" - (math-compose-vector args ", " 0) - "]"))))) + (lambda (a) + (let ((args (cdr (cdr a)))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[" + (math-compose-vector args ", " 0) + "]")))) (put 'maxima 'math-matrix-formatter - (function - (lambda (a) - (list 'horiz - "matrix(" - (math-compose-vector (cdr a) - (concat math-comp-comma " ") - math-comp-vector-prec) - ")")))) + (lambda (a) + (list 'horiz + "matrix(" + (math-compose-vector (cdr a) + (concat math-comp-comma " ") + math-comp-vector-prec) + ")"))) ;;; Giac @@ -1762,7 +1753,7 @@ ( contains . (math-lang-switch-args calcFunc-in)) ( has . (math-lang-switch-args calcFunc-refers)))) -(defun math-lang-switch-args (f val) +(defun math-lang-switch-args (f _val) "Read the arguments to a Calc function in reverse order. This is used for various language modes which have functions in reverse order to Calc's." @@ -1803,17 +1794,16 @@ order to Calc's." (add-to-list 'calc-lang-allow-underscores 'giac) (put 'giac 'math-compose-subscr - (function - (lambda (a) - (let ((args (cdr (cdr a)))) - (list 'horiz - (math-compose-expr (nth 1 a) 1000) - "[" - (math-compose-expr - (calc-normalize (list '- (nth 2 a) 1)) 0) - "]"))))) - -(defun math-read-giac-subscr (x op) + (lambda (a) + ;; (let ((args (cdr (cdr a)))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[" + (math-compose-expr + (calc-normalize (list '- (nth 2 a) 1)) 0) + "]"))) ;;) + +(defun math-read-giac-subscr (x _op) (let ((idx (math-read-expr-level 0))) (or (equal math-expr-data "]") (throw 'syntax "Expected `]'")) @@ -1929,7 +1919,7 @@ order to Calc's." (put 'math 'math-function-close "]") (put 'math 'math-radix-formatter - (function (lambda (r s) (format "%d^^%s" r s)))) + (lambda (r s) (format "%d^^%s" r s))) (put 'math 'math-lang-read '((eq (string-match "\\[\\[\\|->\\|:>" math-exp-str math-exp-pos) @@ -1939,15 +1929,14 @@ order to Calc's." math-exp-pos (match-end 0)))) (put 'math 'math-compose-subscr - (function - (lambda (a) - (list 'horiz - (math-compose-expr (nth 1 a) 1000) - "[[" - (math-compose-expr (nth 2 a) 0) - "]]")))) - -(defun math-read-math-subscr (x op) + (lambda (a) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[[" + (math-compose-expr (nth 2 a) 0) + "]]"))) + +(defun math-read-math-subscr (x _op) (let ((idx (math-read-expr-level 0))) (or (and (equal math-expr-data "]") (progn @@ -2035,26 +2024,24 @@ order to Calc's." (put 'maple 'math-complex-format 'I) (put 'maple 'math-matrix-formatter - (function - (lambda (a) - (list 'horiz - "matrix(" - math-comp-left-bracket - (math-compose-vector (cdr a) - (concat math-comp-comma " ") - math-comp-vector-prec) - math-comp-right-bracket - ")")))) + (lambda (a) + (list 'horiz + "matrix(" + math-comp-left-bracket + (math-compose-vector (cdr a) + (concat math-comp-comma " ") + math-comp-vector-prec) + math-comp-right-bracket + ")"))) (put 'maple 'math-compose-subscr - (function - (lambda (a) - (let ((args (cdr (cdr a)))) - (list 'horiz - (math-compose-expr (nth 1 a) 1000) - "[" - (math-compose-vector args ", " 0) - "]"))))) + (lambda (a) + (let ((args (cdr (cdr a)))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[" + (math-compose-vector args ", " 0) + "]")))) (add-to-list 'calc-lang-allow-underscores 'maple) (add-to-list 'calc-lang-brackets-are-subscripts 'maple) @@ -2094,10 +2081,13 @@ order to Calc's." (defvar math-rb-v1) (defvar math-rb-v2) -(defun math-read-big-rec (math-rb-h1 math-rb-v1 math-rb-h2 math-rb-v2 +(defun math-read-big-rec (rb-h1 rb-v1 rb-h2 rb-v2 &optional baseline prec short) (or prec (setq prec 0)) - + (let ((math-rb-h1 rb-h1) + (math-rb-v1 rb-v1) + (math-rb-h2 rb-h2) + (math-rb-v2 rb-v2)) ;; Clip whitespace above or below. (while (and (< math-rb-v1 math-rb-v2) (math-read-big-emptyp math-rb-h1 math-rb-v1 math-rb-h2 (1+ math-rb-v1))) @@ -2449,7 +2439,7 @@ order to Calc's." math-read-big-h2 h) (or short (= math-read-big-h2 math-rb-h2) (math-read-big-error h baseline)) - p))) + p)))) (defun math-read-big-char (h v) (or (and (>= h math-rb-h1) diff --git a/lisp/calc/calc-macs.el b/lisp/calc/calc-macs.el index fad622cf3a5..63258cde507 100644 --- a/lisp/calc/calc-macs.el +++ b/lisp/calc/calc-macs.el @@ -29,16 +29,15 @@ (declare-function math-looks-negp "calc-misc" (a)) (declare-function math-posp "calc-misc" (a)) (declare-function math-compare "calc-ext" (a b)) -(declare-function math-compare-bignum "calc-ext" (a b)) (defmacro calc-wrapper (&rest body) - `(calc-do (function (lambda () - ,@body)))) + `(calc-do (lambda () + ,@body))) (defmacro calc-slow-wrapper (&rest body) `(calc-do - (function (lambda () ,@body)) (point))) + (lambda () ,@body) (point))) (defmacro math-showing-full-precision (form) `(let ((calc-float-format calc-full-float-format)) @@ -61,6 +60,7 @@ (defmacro calc-with-trail-buffer (&rest body) `(let ((save-buf (current-buffer)) (calc-command-flags nil)) + (ignore save-buf) ;FIXME: Use a name less conflict-prone! (with-current-buffer (calc-trail-display t) (progn (goto-char calc-trail-pointer) @@ -173,13 +173,6 @@ (eq (nth 1 a) b) (= (nth 2 a) 0)))) -(defsubst Math-natnum-lessp (a b) - (if (consp a) - (and (consp b) - (= (math-compare-bignum (cdr a) (cdr b)) -1)) - (or (consp b) - (< a b)))) - (provide 'calc-macs) ;;; calc-macs.el ends here diff --git a/lisp/calc/calc-map.el b/lisp/calc/calc-map.el index 280b3c20ecf..16a2bd89cac 100644 --- a/lisp/calc/calc-map.el +++ b/lisp/calc/calc-map.el @@ -1,4 +1,4 @@ -;;; calc-map.el --- higher-order functions for Calc +;;; calc-map.el --- higher-order functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -48,6 +48,8 @@ (math-calcFunc-to-var (nth 1 oper)) expr))))) +(defvar calc-mapping-dir nil) + (defun calc-reduce (&optional oper accum) (interactive) (calc-wrapper @@ -136,7 +138,6 @@ (1+ calc-dollar-used)))))))) (defvar calc-verify-arglist t) -(defvar calc-mapping-dir nil) (defun calc-map-stack () "This is meant to be called by calc-keypad mode." (interactive) @@ -492,6 +493,8 @@ (defvar calc-get-operator-history nil "History for calc-get-operator.") +(defvar math-arglist) + (defun calc-get-operator (msg &optional nargs) (setq calc-aborted-prefix nil) (let ((inv nil) (hyp nil) (prefix nil) (forcenargs nil) @@ -609,14 +612,13 @@ "()") minibuffer-local-map t))) - (setq math-arglist (mapcar (function - (lambda (x) - (list 'var - x - (intern - (concat - "var-" - (symbol-name x)))))) + (setq math-arglist (mapcar (lambda (x) + (list 'var + x + (intern + (concat + "var-" + (symbol-name x))))) math-arglist)))) (setq oper (list "$" (length math-arglist) @@ -853,7 +855,7 @@ (i -1) (math-working-step 0) (math-working-step-2 nil) - len cols obj expr) + len obj expr) ;; cols (if (eq mode 'eqn) (setq mode 'elems heads '(calcFunc-eq calcFunc-neq calcFunc-lt calcFunc-gt @@ -959,12 +961,12 @@ (apply 'calcFunc-mapeqp func args))) (defun calcFunc-mapeqr (func &rest args) - (setq args (mapcar (function (lambda (x) - (let ((func (assq (car-safe x) - calc-tweak-eqn-table))) - (if func - (cons (nth 1 func) (cdr x)) - x)))) + (setq args (mapcar (lambda (x) + (let ((func (assq (car-safe x) + calc-tweak-eqn-table))) + (if func + (cons (nth 1 func) (cdr x)) + x))) args)) (apply 'calcFunc-mapeqp func args)) @@ -1023,22 +1025,21 @@ (let ((expr (car (setq vec (cdr vec))))) (if expr (progn - (condition-case err - (and (symbolp func) - (let ((lfunc (or (cdr (assq func - '( (calcFunc-add . math-add) - (calcFunc-sub . math-sub) - (calcFunc-mul . math-mul) - (calcFunc-div . math-div) - (calcFunc-pow . math-pow) - (calcFunc-mod . math-mod) - (calcFunc-vconcat . - math-concat) ))) - func))) - (while (cdr vec) - (setq expr (funcall lfunc expr (nth 1 vec)) - vec (cdr vec))))) - (error nil)) + (ignore-errors + (and (symbolp func) + (let ((lfunc (or (cdr (assq func + '( (calcFunc-add . math-add) + (calcFunc-sub . math-sub) + (calcFunc-mul . math-mul) + (calcFunc-div . math-div) + (calcFunc-pow . math-pow) + (calcFunc-mod . math-mod) + (calcFunc-vconcat + . math-concat) ))) + func))) + (while (cdr vec) + (setq expr (funcall lfunc expr (nth 1 vec)) + vec (cdr vec)))))) (while (setq vec (cdr vec)) (setq expr (math-build-call func (list expr (car vec))))) (math-normalize expr)) @@ -1090,28 +1091,28 @@ (defun calcFunc-reducea (func vec) (if (math-matrixp vec) (cons 'vec - (mapcar (function (lambda (x) (calcFunc-reducer func x))) + (mapcar (lambda (x) (calcFunc-reducer func x)) (cdr vec))) (calcFunc-reducer func vec))) (defun calcFunc-rreducea (func vec) (if (math-matrixp vec) (cons 'vec - (mapcar (function (lambda (x) (calcFunc-rreducer func x))) + (mapcar (lambda (x) (calcFunc-rreducer func x)) (cdr vec))) (calcFunc-rreducer func vec))) (defun calcFunc-reduced (func vec) (if (math-matrixp vec) (cons 'vec - (mapcar (function (lambda (x) (calcFunc-reducer func x))) + (mapcar (lambda (x) (calcFunc-reducer func x)) (cdr (math-transpose vec)))) (calcFunc-reducer func vec))) (defun calcFunc-rreduced (func vec) (if (math-matrixp vec) (cons 'vec - (mapcar (function (lambda (x) (calcFunc-rreducer func x))) + (mapcar (lambda (x) (calcFunc-rreducer func x)) (cdr (math-transpose vec)))) (calcFunc-rreducer func vec))) @@ -1214,10 +1215,10 @@ (let ((mat nil)) (while (setq a (cdr a)) (setq mat (cons (cons 'vec - (mapcar (function (lambda (x) - (math-build-call func - (list (car a) - x)))) + (mapcar (lambda (x) + (math-build-call func + (list (car a) + x))) (cdr b))) mat))) (math-normalize (cons 'vec (nreverse mat))))) @@ -1229,9 +1230,11 @@ (defvar math-inner-mul-func) (defvar math-inner-add-func) -(defun calcFunc-inner (math-inner-mul-func math-inner-add-func a b) +(defun calcFunc-inner (inner-mul-func inner-add-func a b) (or (math-vectorp a) (math-reject-arg a 'vectorp)) (or (math-vectorp b) (math-reject-arg b 'vectorp)) + (let ((math-inner-mul-func inner-mul-func) + (math-inner-add-func inner-add-func)) (if (math-matrixp a) (if (math-matrixp b) (if (= (length (nth 1 a)) (length b)) @@ -1247,12 +1250,12 @@ (math-dimension-error)))) (if (math-matrixp b) (nth 1 (math-inner-mats (list 'vec a) b)) - (calcFunc-reduce math-inner-add-func (calcFunc-map math-inner-mul-func a b))))) + (calcFunc-reduce math-inner-add-func (calcFunc-map math-inner-mul-func a b)))))) (defun math-inner-mats (a b) (let ((mat nil) (cols (length (nth 1 b))) - row col ap bp accum) + row col) ;; ap bp accum (while (setq a (cdr a)) (setq col cols row nil) diff --git a/lisp/calc/calc-math.el b/lisp/calc/calc-math.el index ede9daa5039..1c2e7bcf2bc 100644 --- a/lisp/calc/calc-math.el +++ b/lisp/calc/calc-math.el @@ -1,4 +1,4 @@ -;;; calc-math.el --- mathematical functions for Calc +;;; calc-math.el --- mathematical functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -60,33 +60,23 @@ pow (< pow 1.0e+INF)) (setq x (* 2 x)) - (setq pow (condition-case nil - (expt 10.0 (* 2 x)) - (error nil)))) + (setq pow (ignore-errors (expt 10.0 (* 2 x))))) ;; The following loop should stop when 10^(x+1) is too large. - (setq pow (condition-case nil - (expt 10.0 (1+ x)) - (error nil))) + (setq pow (ignore-errors (expt 10.0 (1+ x)))) (while (and pow (< pow 1.0e+INF)) (setq x (1+ x)) - (setq pow (condition-case nil - (expt 10.0 (1+ x)) - (error nil)))) + (setq pow (ignore-errors (expt 10.0 (1+ x))))) (1- x)) "The largest exponent which Calc will convert to an Emacs float.") (defvar math-smallest-emacs-expt (let ((x -1)) - (while (condition-case nil - (> (expt 10.0 x) 0.0) - (error nil)) + (while (ignore-errors (> (expt 10.0 x) 0.0)) (setq x (* 2 x))) (setq x (/ x 2)) - (while (condition-case nil - (> (expt 10.0 x) 0.0) - (error nil)) + (while (ignore-errors (> (expt 10.0 x) 0.0)) (setq x (1- x))) (+ x 2)) "The smallest exponent which Calc will convert to an Emacs float.") @@ -100,19 +90,18 @@ If this can't be done, return NIL." (let* ((xpon (+ (nth 2 x) (1- (math-numdigs (nth 1 x)))))) (and (<= math-smallest-emacs-expt xpon) (<= xpon math-largest-emacs-expt) - (condition-case nil - (math-read-number - (number-to-string - (funcall fn - (string-to-number - (let - ((calc-number-radix 10) - (calc-twos-complement-mode nil) - (calc-float-format (list 'float calc-internal-prec)) - (calc-group-digits nil) - (calc-point-char ".")) - (math-format-number (math-float x))))))) - (error nil)))))) + (ignore-errors + (math-read-number + (number-to-string + (funcall fn + (string-to-number + (let + ((calc-number-radix 10) + (calc-twos-complement-mode nil) + (calc-float-format (list 'float calc-internal-prec)) + (calc-group-digits nil) + (calc-point-char ".")) + (math-format-number (math-float x)))))))))))) (defun calc-sqrt (arg) (interactive "P") @@ -381,18 +370,6 @@ If this can't be done, return NIL." (math-isqrt (math-floor a)) (math-floor (math-sqrt a)))) -(defun math-zerop-bignum (a) - (and (eq (car a) 0) - (progn - (while (eq (car (setq a (cdr a))) 0)) - (null a)))) - -(defun math-scale-bignum-digit-size (a n) ; [L L S] - (while (> n 0) - (setq a (cons 0 a) - n (1- n))) - a) - ;;; Compute the square root of a number. ;;; [T N] if possible, else [F N] if possible, else [C N]. [Public] (defun math-sqrt (a) @@ -638,11 +615,11 @@ If this can't be done, return NIL." (defvar math-nrf-nf) (defvar math-nrf-nfm1) -(defun math-nth-root-float (a math-nrf-n &optional guess) +(defun math-nth-root-float (a nrf-n &optional guess) (math-inexact-result) (math-with-extra-prec 1 - (let ((math-nrf-nf (math-float math-nrf-n)) - (math-nrf-nfm1 (math-float (1- math-nrf-n)))) + (let ((math-nrf-nf (math-float nrf-n)) + (math-nrf-nfm1 (math-float (1- nrf-n)))) (math-nth-root-float-iter a (or guess (math-make-float 1 (/ (+ (math-numdigs (nth 1 a)) @@ -665,18 +642,19 @@ If this can't be done, return NIL." ;; math-nth-root-int. (defvar math-nri-n) -(defun math-nth-root-integer (a math-nri-n &optional guess) ; [I I S] - (math-nth-root-int-iter a (or guess - (math-scale-int 1 (/ (+ (math-numdigs a) - (1- math-nri-n)) - math-nri-n))))) +(defun math-nth-root-integer (a nri-n &optional guess) ; [I I S] + (let ((math-nri-n nri-n)) + (math-nth-root-int-iter a (or guess + (math-scale-int 1 (/ (+ (math-numdigs a) + (1- nri-n)) + nri-n)))))) (defun math-nth-root-int-iter (a guess) (math-working "root" guess) (let* ((q (math-idivmod a (math-ipow guess (1- math-nri-n)))) (s (math-add (car q) (math-mul (1- math-nri-n) guess))) (g2 (math-idivmod s math-nri-n))) - (if (Math-natnum-lessp (car g2) guess) + (if (< (car g2) guess) (math-nth-root-int-iter a (car g2)) (cons (and (equal (car g2) guess) (eq (cdr q) 0) @@ -693,13 +671,13 @@ If this can't be done, return NIL." ;;;; Transcendental functions. -;;; All of these functions are defined on the complex plane. -;;; (Branch cuts, etc. follow Steele's Common Lisp book.) +;; All of these functions are defined on the complex plane. +;; (Branch cuts, etc. follow Steele's Common Lisp book.) -;;; Most functions increase calc-internal-prec by 2 digits, then round -;;; down afterward. "-raw" functions use the current precision, require -;;; their arguments to be in float (or complex float) format, and always -;;; work in radians (where applicable). +;; Most functions increase calc-internal-prec by 2 digits, then round +;; down afterward. "-raw" functions use the current precision, require +;; their arguments to be in float (or complex float) format, and always +;; work in radians (where applicable). (defun math-to-radians (a) ; [N N] (cond ((eq (car-safe a) 'hms) @@ -1126,9 +1104,9 @@ If this can't be done, return NIL." (math-div-float (cdr sc) (car sc))))))) -;;; This could use a smarter method: Reduce x as in math-sin-raw, then -;;; compute either sin(x) or cos(x), whichever is smaller, and compute -;;; the other using the identity sin(x)^2 + cos(x)^2 = 1. +;; This could use a smarter method: Reduce x as in math-sin-raw, then +;; compute either sin(x) or cos(x), whichever is smaller, and compute +;; the other using the identity sin(x)^2 + cos(x)^2 = 1. (defun math-sin-cos-raw (x) ; [F.F F] (result is (sin x . cos x)) (cons (math-sin-raw x) (math-cos-raw x))) @@ -1625,7 +1603,7 @@ If this can't be done, return NIL." (math-natnump b) (not (eq b 0))) (if (eq b 1) (math-reject-arg x "*Logarithm base one") - (if (Math-natnum-lessp x b) + (if (< x b) 0 (cdr (math-integer-log x b)))) (math-floor (calcFunc-log x b)))) @@ -2072,7 +2050,7 @@ If this can't be done, return NIL." (put 'calcFunc-arctanh 'math-expandable t) -;;; Convert A from HMS or degrees to radians. +;; Convert A from HMS or degrees to radians. (defun calcFunc-rad (a) ; [R R] [Public] (cond ((or (Math-numberp a) (eq (car a) 'intv)) @@ -2089,7 +2067,7 @@ If this can't be done, return NIL." (t (list 'calcFunc-rad a)))) (put 'calcFunc-rad 'math-expandable t) -;;; Convert A from HMS or radians to degrees. +;; Convert A from HMS or radians to degrees. (defun calcFunc-deg (a) ; [R R] [Public] (cond ((or (Math-numberp a) (eq (car a) 'intv)) diff --git a/lisp/calc/calc-menu.el b/lisp/calc/calc-menu.el index 7aa8d7f2b80..16cca055330 100644 --- a/lisp/calc/calc-menu.el +++ b/lisp/calc/calc-menu.el @@ -1,4 +1,4 @@ -;;; calc-menu.el --- a menu for Calc +;;; calc-menu.el --- a menu for Calc -*- lexical-binding:t -*- ;; Copyright (C) 2007-2021 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el index fa081872e8b..b573c53f418 100644 --- a/lisp/calc/calc-misc.el +++ b/lisp/calc/calc-misc.el @@ -1,4 +1,4 @@ -;;; calc-misc.el --- miscellaneous functions for Calc +;;; calc-misc.el --- miscellaneous functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -176,9 +176,9 @@ Calc user interface as before (either C-x * C or C-x * K; initially C-x * C). "Create another, independent Calculator buffer." (interactive) (if (eq major-mode 'calc-mode) - (mapc (function - (lambda (v) - (set-default v (symbol-value v)))) calc-local-var-list)) + (mapc (lambda (v) + (set-default v (symbol-value v))) + calc-local-var-list)) (set-buffer (generate-new-buffer "*Calculator*")) (pop-to-buffer (current-buffer)) (calc-mode)) @@ -274,9 +274,8 @@ Calc user interface as before (either C-x * C or C-x * K; initially C-x * C). ;;;###autoload (defun calc-do-handle-whys () (setq calc-why (sort calc-next-why - (function - (lambda (x y) - (and (eq (car x) '*) (not (eq (car y) '*)))))) + (lambda (x y) + (and (eq (car x) '*) (not (eq (car y) '*))))) calc-next-why nil) (if (and calc-why (or (eq calc-auto-why t) (and (eq (car (car calc-why)) '*) @@ -505,7 +504,7 @@ With argument 0, switch line point is in with line mark is in." ;; 3 <-- mid-line = 3 ;; 4 <-- point ;; 5 <-- bot-line = 5 - (dotimes (i mid-line) + (dotimes (_ mid-line) (setq mid-cell old-top-list old-top-list (cdr old-top-list)) (setcdr mid-cell new-top-list) @@ -519,7 +518,7 @@ With argument 0, switch line point is in with line mark is in." ;; 2 ;; 1 (setq prev-mid-cell old-top-list) - (dotimes (i (- bot-line mid-line)) + (dotimes (_ (- bot-line mid-line)) (setq bot-cell old-top-list old-top-list (cdr old-top-list)) (setcdr bot-cell new-top-list) @@ -757,19 +756,21 @@ loaded and the keystroke automatically re-typed." ;; The variable math-trunc-prec is local to math-trunc, but used by ;; math-trunc-fancy in calc-arith.el, which is called by math-trunc. +(defvar math-trunc-prec) ;;;###autoload -(defun math-trunc (a &optional math-trunc-prec) - (cond (math-trunc-prec +(defun math-trunc (a &optional trunc-prec) + (cond (trunc-prec (require 'calc-ext) - (math-trunc-special a math-trunc-prec)) + (math-trunc-special a trunc-prec)) ((Math-integerp a) a) ((Math-looks-negp a) (math-neg (math-trunc (math-neg a)))) ((eq (car a) 'float) (math-scale-int (nth 1 a) (nth 2 a))) (t (require 'calc-ext) - (math-trunc-fancy a)))) + (let ((math-trunc-prec trunc-prec)) + (math-trunc-fancy a))))) ;;;###autoload (defalias 'calcFunc-trunc 'math-trunc) @@ -777,12 +778,13 @@ loaded and the keystroke automatically re-typed." ;; The variable math-floor-prec is local to math-floor, but used by ;; math-floor-fancy in calc-arith.el, which is called by math-floor. +(defvar math-floor-prec) ;;;###autoload -(defun math-floor (a &optional math-floor-prec) ; [Public] - (cond (math-floor-prec +(defun math-floor (a &optional floor-prec) ; [Public] + (cond (floor-prec (require 'calc-ext) - (math-floor-special a math-floor-prec)) + (math-floor-special a floor-prec)) ((Math-integerp a) a) ((Math-messy-integerp a) (math-trunc a)) ((Math-realp a) @@ -790,7 +792,9 @@ loaded and the keystroke automatically re-typed." (math-add (math-trunc a) -1) (math-trunc a))) (t (require 'calc-ext) - (math-floor-fancy a)))) + (let ((math-floor-prec floor-prec)) + (math-floor-fancy a))))) + ;;;###autoload (defalias 'calcFunc-floor 'math-floor) diff --git a/lisp/calc/calc-mode.el b/lisp/calc/calc-mode.el index 93be713da48..68c8b90ac3b 100644 --- a/lisp/calc/calc-mode.el +++ b/lisp/calc/calc-mode.el @@ -1,4 +1,4 @@ -;;; calc-mode.el --- calculator modes for Calc +;;; calc-mode.el --- calculator modes for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -268,7 +268,7 @@ (interactive) (calc-wrapper (let (pos - (vals (mapcar (function (lambda (v) (symbol-value (car v)))) + (vals (mapcar (lambda (v) (symbol-value (car v))) calc-mode-var-list))) (unless calc-settings-file (error "No `calc-settings-file' specified")) @@ -424,8 +424,8 @@ (t "Not recording mode changes permanently"))))) -(defun calc-total-algebraic-mode (flag) - (interactive "P") +(defun calc-total-algebraic-mode (&optional _flag) + (interactive) (calc-wrapper (if (eq calc-algebraic-mode 'total) (calc-algebraic-mode nil) diff --git a/lisp/calc/calc-mtx.el b/lisp/calc/calc-mtx.el index c7ea228c5c2..9a08b8cb76a 100644 --- a/lisp/calc/calc-mtx.el +++ b/lisp/calc/calc-mtx.el @@ -1,4 +1,4 @@ -;;; calc-mtx.el --- matrix functions for Calc +;;; calc-mtx.el --- matrix functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -55,7 +55,7 @@ (defun math-col-matrix (a) (if (and (Math-vectorp a) (not (math-matrixp a))) - (cons 'vec (mapcar (function (lambda (x) (list 'vec x))) (cdr a))) + (cons 'vec (mapcar (lambda (x) (list 'vec x)) (cdr a))) a)) @@ -79,8 +79,8 @@ (cons 'vec (nreverse mat)))) (defun math-mul-mat-vec (a b) - (cons 'vec (mapcar (function (lambda (row) - (math-dot-product row b))) + (cons 'vec (mapcar (lambda (row) + (math-dot-product row b)) (cdr a)))) @@ -275,7 +275,7 @@ in LUD decomposition." k (1+ k))) (setcar (nthcdr j (nth i lu)) sum) (let ((dum (math-lud-pivot-check sum))) - (if (Math-lessp big dum) + (if (or (math-zerop big) (Math-lessp big dum)) (setq big dum imax i))) (setq i (1+ i))) diff --git a/lisp/calc/calc-nlfit.el b/lisp/calc/calc-nlfit.el index 8cfc2824b54..11867f15e5b 100644 --- a/lisp/calc/calc-nlfit.el +++ b/lisp/calc/calc-nlfit.el @@ -1,4 +1,4 @@ -;;; calc-nlfit.el --- nonlinear curve fitting for Calc +;;; calc-nlfit.el --- nonlinear curve fitting for Calc -*- lexical-binding:t -*- ;; Copyright (C) 2007-2021 Free Software Foundation, Inc. @@ -104,19 +104,19 @@ (list 'vec C12 C22)))) (list A B))))) -;;; The methods described by de Sousa require the cumulative data qdata -;;; and the rates pdata. We will assume that we are given either -;;; qdata and the corresponding times tdata, or pdata and the corresponding -;;; tdata. The following two functions will find pdata or qdata, -;;; given the other.. +;; The methods described by de Sousa require the cumulative data qdata +;; and the rates pdata. We will assume that we are given either +;; qdata and the corresponding times tdata, or pdata and the corresponding +;; tdata. The following two functions will find pdata or qdata, +;; given the other.. -;;; First, given two lists; one of values q0, q1, ..., qn and one of -;;; corresponding times t0, t1, ..., tn; return a list -;;; p0, p1, ..., pn of the rates of change of the qi with respect to t. -;;; p0 is the right hand derivative (q1 - q0)/(t1 - t0). -;;; pn is the left hand derivative (qn - q(n-1))/(tn - t(n-1)). -;;; The other pis are the averages of the two: -;;; (1/2)((qi - q(i-1))/(ti - t(i-1)) + (q(i+1) - qi)/(t(i+1) - ti)). +;; First, given two lists; one of values q0, q1, ..., qn and one of +;; corresponding times t0, t1, ..., tn; return a list +;; p0, p1, ..., pn of the rates of change of the qi with respect to t. +;; p0 is the right hand derivative (q1 - q0)/(t1 - t0). +;; pn is the left hand derivative (qn - q(n-1))/(tn - t(n-1)). +;; The other pis are the averages of the two: +;; (1/2)((qi - q(i-1))/(ti - t(i-1)) + (q(i+1) - qi)/(t(i+1) - ti)). (defun math-nlfit-get-rates-from-cumul (tdata qdata) (let ((pdata (list @@ -153,12 +153,12 @@ pdata)) (reverse pdata))) -;;; Next, given two lists -- one of rates p0, p1, ..., pn and one of -;;; corresponding times t0, t1, ..., tn -- and an initial values q0, -;;; return a list q0, q1, ..., qn of the cumulative values. -;;; q0 is the initial value given. -;;; For i>0, qi is computed using the trapezoid rule: -;;; qi = q(i-1) + (1/2)(pi + p(i-1))(ti - t(i-1)) +;; Next, given two lists -- one of rates p0, p1, ..., pn and one of +;; corresponding times t0, t1, ..., tn -- and an initial values q0, +;; return a list q0, q1, ..., qn of the cumulative values. +;; q0 is the initial value given. +;; For i>0, qi is computed using the trapezoid rule: +;; qi = q(i-1) + (1/2)(pi + p(i-1))(ti - t(i-1)) (defun math-nlfit-get-cumul-from-rates (tdata pdata q0) (let* ((qdata (list q0))) @@ -177,16 +177,16 @@ (setq tdata (cdr tdata))) (reverse qdata))) -;;; Given the qdata, pdata and tdata, find the parameters -;;; a, b and c that fit q = a/(1+b*exp(c*t)). -;;; a is found using the method described by de Sousa. -;;; b and c are found using least squares on the linearization -;;; log((a/q)-1) = log(b) + c*t -;;; In some cases (where the logistic curve may well be the wrong -;;; model), the computed a will be less than or equal to the maximum -;;; value of q in qdata; in which case the above linearization won't work. -;;; In this case, a will be replaced by a number slightly above -;;; the maximum value of q. +;; Given the qdata, pdata and tdata, find the parameters +;; a, b and c that fit q = a/(1+b*exp(c*t)). +;; a is found using the method described by de Sousa. +;; b and c are found using least squares on the linearization +;; log((a/q)-1) = log(b) + c*t +;; In some cases (where the logistic curve may well be the wrong +;; model), the computed a will be less than or equal to the maximum +;; value of q in qdata; in which case the above linearization won't work. +;; In this case, a will be replaced by a number slightly above +;; the maximum value of q. (defun math-nlfit-find-qmax (qdata pdata tdata) (let* ((ratios (math-map-binop 'math-div pdata qdata)) @@ -208,12 +208,12 @@ (calcFunc-exp (nth 0 bandc)) (nth 1 bandc)))) -;;; Next, given the pdata and tdata, we can find the qdata if we know q0. -;;; We first try to find q0, using the fact that when p takes on its largest -;;; value, q is half of its maximum value. So we'll find the maximum value -;;; of q given various q0, and use bisection to approximate the correct q0. +;; Next, given the pdata and tdata, we can find the qdata if we know q0. +;; We first try to find q0, using the fact that when p takes on its largest +;; value, q is half of its maximum value. So we'll find the maximum value +;; of q given various q0, and use bisection to approximate the correct q0. -;;; First, given pdata and tdata, find what half of qmax would be if q0=0. +;; First, given pdata and tdata, find what half of qmax would be if q0=0. (defun math-nlfit-find-qmaxhalf (pdata tdata) (let ((pmax (math-max-list (car pdata) (cdr pdata))) @@ -231,7 +231,7 @@ (setq tdata (cdr tdata))) qmh)) -;;; Next, given pdata and tdata, approximate q0. +;; Next, given pdata and tdata, approximate q0. (defun math-nlfit-find-q0 (pdata tdata) (let* ((qhalf (math-nlfit-find-qmaxhalf pdata tdata)) @@ -250,7 +250,7 @@ (setq q0 (math-add q0 qhalf))) (let* ((qmin (math-sub q0 qhalf)) (qmax q0) - (qt (math-nlfit-find-qmax + (_qt (math-nlfit-find-qmax (mapcar (lambda (q) (math-add q0 q)) qdata) @@ -270,20 +270,20 @@ (setq i (1+ i))) (math-mul '(float 5 -1) (math-add qmin qmax))))) -;;; To improve the approximations to the parameters, we can use -;;; Marquardt method as described in Schwarz's book. +;; To improve the approximations to the parameters, we can use +;; Marquardt method as described in Schwarz's book. -;;; Small numbers used in the Givens algorithm +;; Small numbers used in the Givens algorithm (defvar math-nlfit-delta '(float 1 -8)) (defvar math-nlfit-epsilon '(float 1 -5)) -;;; Maximum number of iterations +;; Maximum number of iterations (defvar math-nlfit-max-its 100) -;;; Next, we need some functions for dealing with vectors and -;;; matrices. For convenience, we'll work with Emacs lists -;;; as vectors, rather than Calc's vectors. +;; Next, we need some functions for dealing with vectors and +;; matrices. For convenience, we'll work with Emacs lists +;; as vectors, rather than Calc's vectors. (defun math-nlfit-set-elt (vec i x) (setcar (nthcdr (1- i) vec) x)) @@ -589,7 +589,7 @@ (calcFunc-trn j) j)) (calcFunc-inv j))) -(defun math-nlfit-get-sigmas (grad xlist pparms chisq) +(defun math-nlfit-get-sigmas (grad xlist pparms _chisq) (let* ((sgs nil) (covar (math-nlfit-find-covar grad xlist pparms)) (n (1- (length covar))) @@ -664,6 +664,10 @@ (calc-pop-push-record-list n prefix vals) (calc-handle-whys)) +(defvar calc-curve-nvars) +(defvar calc-curve-varnames) +(defvar calc-curve-coefnames) + (defun math-nlfit-fit-curve (fn grad solnexpr initparms &optional sdv) (calc-slow-wrapper (let* ((sdevv (or (eq sdv 'calcFunc-efit) (eq sdv 'calcFunc-xfit))) @@ -678,7 +682,7 @@ (calc-curve-varnames nil) (calc-curve-coefnames nil) (calc-curve-nvars 1) - (fitvars (calc-get-fit-variables 1 3)) + (_fitvars (calc-get-fit-variables 1 3)) (var (nth 1 calc-curve-varnames)) (parms (cdr calc-curve-coefnames)) (parmguess @@ -763,7 +767,7 @@ (calc-curve-varnames nil) (calc-curve-coefnames nil) (calc-curve-nvars 1) - (fitvars (calc-get-fit-variables 1 2)) + (_fitvars (calc-get-fit-variables 1 2)) (var (nth 1 calc-curve-varnames)) (parms (cdr calc-curve-coefnames)) (soln (list '* (nth 0 finalparms) diff --git a/lisp/calc/calc-poly.el b/lisp/calc/calc-poly.el index b3e1c1e073d..77587cc4b86 100644 --- a/lisp/calc/calc-poly.el +++ b/lisp/calc/calc-poly.el @@ -202,7 +202,7 @@ (if (memq (car-safe expr) '(+ -)) (math-list-to-sum (sort (math-sum-to-list expr) - (function (lambda (a b) (math-beforep (car a) (car b)))))) + (lambda (a b) (math-beforep (car a) (car b))))) expr)) (defun math-list-to-sum (lst) @@ -387,7 +387,7 @@ This returns only the remainder from the pseudo-division." lst (if (eq a -1) (math-mul-list lst a) - (mapcar (function (lambda (x) (math-poly-div-exact x a))) lst)))) + (mapcar (lambda (x) (math-poly-div-exact x a)) lst)))) (defun math-mul-list (lst a) (if (eq a 1) @@ -395,7 +395,7 @@ This returns only the remainder from the pseudo-division." (if (eq a -1) (mapcar 'math-neg lst) (and (not (eq a 0)) - (mapcar (function (lambda (x) (math-mul x a))) lst))))) + (mapcar (lambda (x) (math-mul x a)) lst))))) ;;; Run GCD on all elements in a list. (defun math-poly-gcd-list (lst) @@ -502,10 +502,10 @@ Take the base that has the highest degree considering both a and b. (defun math-sort-poly-base-list (lst) "Sort a list of polynomial bases." - (sort lst (function (lambda (a b) - (or (> (nth 1 a) (nth 1 b)) - (and (= (nth 1 a) (nth 1 b)) - (math-beforep (car a) (car b)))))))) + (sort lst (lambda (a b) + (or (> (nth 1 a) (nth 1 b)) + (and (= (nth 1 a) (nth 1 b)) + (math-beforep (car a) (car b))))))) ;;; Given an expression find all variables that are polynomial bases. ;;; Return list in the form '( (var1 degree1) (var2 degree2) ... ). @@ -1033,10 +1033,9 @@ If no partial fraction representation can be found, return nil." (math-transpose (cons 'vec (mapcar - (function - (lambda (x) - (cons 'vec (math-padded-polynomial - x var tdeg)))) + (lambda (x) + (cons 'vec (math-padded-polynomial + x var tdeg))) (cdr eqns)))))) (and (math-vectorp eqns) (let ((res 0) diff --git a/lisp/calc/calc-prog.el b/lisp/calc/calc-prog.el index 7755a71bace..3097b09b013 100644 --- a/lisp/calc/calc-prog.el +++ b/lisp/calc/calc-prog.el @@ -1,4 +1,4 @@ -;;; calc-prog.el --- user programmability functions for Calc +;;; calc-prog.el --- user programmability functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -111,10 +111,15 @@ "Not reporting timing of commands")))) (defun calc-pass-errors () + ;; FIXME: This is broken at least since Emacs-26. + ;; AFAICT the immediate purpose of this code is to hack the + ;; `condition-case' in `calc-do' so it doesn't catch errors any + ;; more. I'm not sure why/whatfor this was designed, but I suspect + ;; that `condition-case-unless-debug' would cover the same needs. (interactive) ;; The following two cases are for the new, optimizing byte compiler ;; or the standard 18.57 byte compiler, respectively. - (condition-case err + (condition-case nil (let ((place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 15))) (or (memq (car-safe (car-safe place)) '(error xxxerror)) (setq place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 27))) @@ -165,6 +170,7 @@ ;; calc-user-define-composition and calc-finish-formula-edit, ;; but is used by calc-fix-user-formula. (defvar calc-user-formula-alist) +(defvar math-arglist) ; dynamically bound in all callers (defun calc-user-define-formula () (interactive) @@ -176,7 +182,7 @@ odef key keyname cmd cmd-base cmd-base-default func calc-user-formula-alist is-symb) (if is-lambda - (setq math-arglist (mapcar (function (lambda (x) (nth 1 x))) + (setq math-arglist (mapcar (lambda (x) (nth 1 x)) (nreverse (cdr (reverse (cdr form))))) form (nth (1- (length form)) form)) (calc-default-formula-arglist form) @@ -284,10 +290,10 @@ (y-or-n-p "Leave it symbolic for non-constant arguments? "))) (setq calc-user-formula-alist - (mapcar (function (lambda (x) - (or (cdr (assq x '((nil . arg-nil) - (t . arg-t)))) - x))) calc-user-formula-alist)) + (mapcar (lambda (x) + (or (cdr (assq x '((nil . arg-nil) + (t . arg-t)))) + x)) calc-user-formula-alist)) (if cmd (progn (require 'calc-macs) @@ -313,8 +319,8 @@ (append (list 'lambda calc-user-formula-alist) (and is-symb - (mapcar (function (lambda (v) - (list 'math-check-const v t))) + (mapcar (lambda (v) + (list 'math-check-const v t)) calc-user-formula-alist)) (list body)))) (put func 'calc-user-defn form) @@ -328,7 +334,6 @@ (setcdr kmap (cons (cons key cmd) (cdr kmap))))))) (message ""))) -(defvar math-arglist) ; dynamically bound in all callers (defun calc-default-formula-arglist (form) (if (consp form) (if (eq (car form) 'var) @@ -478,13 +483,13 @@ (interactive) (calc-wrapper (let ((lang calc-language)) - (calc-edit-mode (list 'calc-finish-user-syntax-edit (list 'quote lang)) - t - (format "Editing %s-Mode Syntax Table. " - (cond ((null lang) "Normal") - ((eq lang 'tex) "TeX") - ((eq lang 'latex) "LaTeX") - (t (capitalize (symbol-name lang)))))) + (calc--edit-mode (lambda () (calc-finish-user-syntax-edit lang)) + t + (format "Editing %s-Mode Syntax Table. " + (cond ((null lang) "Normal") + ((eq lang 'tex) "TeX") + ((eq lang 'latex) "LaTeX") + (t (capitalize (symbol-name lang)))))) (calc-write-parse-table (cdr (assq lang calc-user-parse-tables)) lang))) (calc-show-edit-buffer)) @@ -511,8 +516,9 @@ ;; is called (indirectly) by calc-read-parse-table. (defvar calc-lang) -(defun calc-write-parse-table (tab calc-lang) - (let ((p tab)) +(defun calc-write-parse-table (tab lang) + (let ((calc-lang lang) + (p tab)) (while p (calc-write-parse-table-part (car (car p))) (insert ":= " @@ -551,8 +557,9 @@ (insert " ")))) (setq p (cdr p)))) -(defun calc-read-parse-table (calc-buf calc-lang) - (let ((tab nil)) +(defun calc-read-parse-table (calc-buf lang) + (let ((calc-lang lang) + (tab nil)) (while (progn (skip-chars-forward "\n\t ") (not (eobp))) @@ -689,12 +696,13 @@ (setq cmd (symbol-function cmd))) (cond ((or (stringp cmd) (and (consp cmd) - (eq (car-safe (nth 3 cmd)) 'calc-execute-kbd-macro))) + (eq (car-safe (nth 3 cmd)) #'calc-execute-kbd-macro))) + ;; FIXME: Won't (nth 3 cmd) fail when (stringp cmd)? (let* ((mac (elt (nth 1 (nth 3 cmd)) 1)) (str (edmacro-format-keys mac t)) (kys (nth 3 (nth 3 cmd)))) - (calc-edit-mode - (list 'calc-edit-macro-finish-edit cmdname kys) + (calc--edit-mode + (lambda () (calc-edit-macro-finish-edit cmdname kys)) t (format (concat "Editing keyboard macro (%s, bound to %s).\n" "Original keys: %s \n") @@ -712,8 +720,8 @@ (if (and defn (calc-valid-formula-func func)) (let ((niceexpr (math-format-nice-expr defn (frame-width)))) (calc-wrapper - (calc-edit-mode - (list 'calc-finish-formula-edit (list 'quote func)) + (calc--edit-mode + (lambda () (calc-finish-formula-edit func)) nil (format (concat "Editing formula (%s, %s, bound to %s).\n" @@ -860,7 +868,7 @@ (defun calc-edit-macro-combine-digits () "Put an entire sequence of digits on a single line." (let ((line (calc-edit-macro-command)) - curline) + ) ;; curline (goto-char (line-beginning-position)) (kill-line 1) (while (string-equal (calc-edit-macro-command-type) "calcDigit-start") @@ -1038,7 +1046,7 @@ Redefine the corresponding command." (let* ((cmd (cdr def)) (fcmd (and cmd (symbolp cmd) (symbol-function cmd))) (func nil) - (pt (point)) + ;; (pt (point)) (fill-column 70) (fill-prefix nil) str q-ok) @@ -1945,8 +1953,9 @@ Redefine the corresponding command." ;; by math-define-body. (defvar math-exp-env) -(defun math-define-body (body math-exp-env) - (math-define-list body)) +(defun math-define-body (body exp-env) + (let ((math-exp-env exp-env)) + (math-define-list body))) (defun math-define-list (body &optional quote) (cond ((null body) diff --git a/lisp/calc/calc-rewr.el b/lisp/calc/calc-rewr.el index f364b064ae8..e3d4852a721 100644 --- a/lisp/calc/calc-rewr.el +++ b/lisp/calc/calc-rewr.el @@ -1,4 +1,4 @@ -;;; calc-rewr.el --- rewriting functions for Calc +;;; calc-rewr.el --- rewriting functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -142,7 +142,7 @@ (calc-pop-push-record-list n "rwrt" (list expr))) (calc-handle-whys))) -(defun calc-match (pat &optional interactive) +(defun calc-match (pat &optional _interactive) (interactive "sPattern: \np") (calc-slow-wrapper (let (n expr) @@ -158,9 +158,9 @@ (setq expr (calc-top-n 1) n 1)) (or (math-vectorp expr) (error "Argument must be a vector")) - (if (calc-is-inverse) - (calc-enter-result n "mtcn" (math-match-patterns pat expr t)) - (calc-enter-result n "mtch" (math-match-patterns pat expr nil)))))) + (calc-enter-result n "mtcn" + (math-match-patterns pat expr + (not (not (calc-is-inverse)))))))) (defvar math-mt-many) @@ -169,8 +169,10 @@ ;; but is used by math-rewrite-phase (defvar math-rewrite-whole-expr) -(defun math-rewrite (math-rewrite-whole-expr rules &optional math-mt-many) - (let* ((crules (math-compile-rewrites rules)) +(defun math-rewrite (rewrite-whole-expr rules &optional mt-many) + (let* ((math-rewrite-whole-expr rewrite-whole-expr) + (math-mt-many mt-many) + (crules (math-compile-rewrites rules)) (heads (math-rewrite-heads math-rewrite-whole-expr)) (trace-buffer (get-buffer "*Trace*")) (calc-display-just 'center) @@ -179,19 +181,18 @@ (calc-line-numbering nil) (calc-show-selections t) (calc-why nil) - (math-mt-func (function - (lambda (x) - (let ((result (math-apply-rewrites x (cdr crules) - heads crules))) - (if result - (progn - (if trace-buffer - (let ((fmt (math-format-stack-value - (list result nil nil)))) - (with-current-buffer trace-buffer - (insert "\nrewrite to\n" fmt "\n")))) - (setq heads (math-rewrite-heads result heads t)))) - result))))) + (math-mt-func (lambda (x) + (let ((result (math-apply-rewrites x (cdr crules) + heads crules))) + (if result + (progn + (if trace-buffer + (let ((fmt (math-format-stack-value + (list result nil nil)))) + (with-current-buffer trace-buffer + (insert "\nrewrite to\n" fmt "\n")))) + (setq heads (math-rewrite-heads result heads t)))) + result)))) (if trace-buffer (let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil)))) (with-current-buffer trace-buffer @@ -211,6 +212,8 @@ ":\n" fmt "\n")))) math-rewrite-whole-expr)) +(defvar math-rewrite-phase 1) + (defun math-rewrite-phase (sched) (while (and sched (/= math-mt-many 0)) (if (listp (car sched)) @@ -464,6 +467,8 @@ ;;; whole match the name v. Beware of circular structures! ;;; +(defvar math-rewrite-whole nil) + (defun math-compile-patterns (pats) (if (and (eq (car-safe pats) 'var) (calc-var-value (nth 2 pats))) @@ -479,13 +484,12 @@ (let ((math-rewrite-whole t)) (cdr (math-compile-rewrites (cons 'vec - (mapcar (function (lambda (x) - (list 'vec x t))) + (mapcar (lambda (x) + (list 'vec x t)) (if (eq (car-safe pats) 'vec) (cdr pats) (list pats))))))))) -(defvar math-rewrite-whole nil) (defvar math-make-import-list nil) ;; The variable math-import-list is local to part of math-compile-rewrites, @@ -580,7 +584,7 @@ (let ((rule-set nil) (all-heads nil) (nil-rules nil) - (rule-count 0) + ;; (rule-count 0) (math-schedule nil) (math-iterations nil) (math-phases nil) @@ -651,15 +655,14 @@ nil (nreverse (mapcar - (function - (lambda (v) - (and (car v) - (list - 'calcFunc-assign - (math-build-var-name - (car v)) - (math-rwcomp-register-expr - (nth 1 v)))))) + (lambda (v) + (and (car v) + (list + 'calcFunc-assign + (math-build-var-name + (car v)) + (math-rwcomp-register-expr + (nth 1 v))))) math-regs)))) (math-rwcomp-match-vars math-rhs)) math-remembering) @@ -667,7 +670,7 @@ (let* ((heads (math-rewrite-heads math-pattern)) (rule (list (vconcat (nreverse - (mapcar (function (lambda (x) (nth 3 x))) + (mapcar (lambda (x) (nth 3 x)) math-regs))) math-prog heads @@ -719,10 +722,9 @@ (setq rules (cdr rules))) (if nil-rules (setq rule-set (cons (cons nil nil-rules) rule-set))) - (setq all-heads (mapcar 'car - (sort all-heads (function - (lambda (x y) - (< (cdr x) (cdr y))))))) + (setq all-heads (mapcar #'car + (sort all-heads (lambda (x y) + (< (cdr x) (cdr y)))))) (let ((set rule-set) rule heads ptr) (while set @@ -785,15 +787,14 @@ (math-rewrite-heads-rec (car expr))))))) (defun math-parse-schedule (sched) - (mapcar (function - (lambda (s) - (if (integerp s) - s - (if (math-vectorp s) - (math-parse-schedule (cdr s)) - (if (eq (car-safe s) 'var) - (math-var-to-calcFunc s) - (error "Improper component in rewrite schedule")))))) + (mapcar (lambda (s) + (if (integerp s) + s + (if (math-vectorp s) + (math-parse-schedule (cdr s)) + (if (eq (car-safe s) 'var) + (math-var-to-calcFunc s) + (error "Improper component in rewrite schedule"))))) sched)) (defun math-rwcomp-match-vars (expr) @@ -831,14 +832,16 @@ (defvar math-rwcomp-subst-new-func) (defvar math-rwcomp-subst-old-func) -(defun math-rwcomp-substitute (expr math-rwcomp-subst-old math-rwcomp-subst-new) - (if (and (eq (car-safe math-rwcomp-subst-old) 'var) - (memq (car-safe math-rwcomp-subst-new) '(var calcFunc-lambda))) - (let ((math-rwcomp-subst-old-func (math-var-to-calcFunc math-rwcomp-subst-old)) - (math-rwcomp-subst-new-func (math-var-to-calcFunc math-rwcomp-subst-new))) +(defun math-rwcomp-substitute (expr rwcomp-subst-old rwcomp-subst-new) + (let ((math-rwcomp-subst-old rwcomp-subst-old) + (math-rwcomp-subst-new rwcomp-subst-new)) + (if (and (eq (car-safe rwcomp-subst-old) 'var) + (memq (car-safe rwcomp-subst-new) '(var calcFunc-lambda))) + (let ((math-rwcomp-subst-old-func (math-var-to-calcFunc rwcomp-subst-old)) + (math-rwcomp-subst-new-func (math-var-to-calcFunc rwcomp-subst-new))) (math-rwcomp-subst-rec expr)) (let ((math-rwcomp-subst-old-func nil)) - (math-rwcomp-subst-rec expr)))) + (math-rwcomp-subst-rec expr))))) (defun math-rwcomp-subst-rec (expr) (cond ((equal expr math-rwcomp-subst-old) math-rwcomp-subst-new) @@ -1173,9 +1176,8 @@ (list 'calcFunc-register reg2)))) (math-rwcomp-pattern (car arg2) (cdr arg2)))) - (let* ((args (mapcar (function - (lambda (x) - (cons x (math-rwcomp-best-reg x)))) + (let* ((args (mapcar (lambda (x) + (cons x (math-rwcomp-best-reg x))) (cdr expr))) (args2 (copy-sequence args)) (argp (reverse args2)) @@ -1452,8 +1454,6 @@ ,form (setcar rules orig)))) -(defvar math-rewrite-phase 1) - ;; The variable math-apply-rw-regs is local to math-apply-rewrites, ;; but is used by math-rwapply-replace-regs and math-rwapply-reg-looks-negp ;; which are called by math-apply-rewrites. @@ -1463,11 +1463,12 @@ ;; but is used by math-rwapply-remember. (defvar math-apply-rw-ruleset) -(defun math-apply-rewrites (expr rules &optional heads math-apply-rw-ruleset) +(defun math-apply-rewrites (expr rules &optional heads apply-rw-ruleset) (and (setq rules (cdr (or (assq (car-safe expr) rules) (assq nil rules)))) - (let ((result nil) + (let ((math-apply-rw-ruleset apply-rw-ruleset) + (result nil) op math-apply-rw-regs inst part pc mark btrack (tracing math-rwcomp-tracing) (phase math-rewrite-phase)) diff --git a/lisp/calc/calc-rules.el b/lisp/calc/calc-rules.el index 089a7bf0d62..00080b69891 100644 --- a/lisp/calc/calc-rules.el +++ b/lisp/calc/calc-rules.el @@ -1,4 +1,4 @@ -;;; calc-rules.el --- rules for simplifying algebraic expressions in Calc +;;; calc-rules.el --- rules for simplifying algebraic expressions in Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-sel.el b/lisp/calc/calc-sel.el index c378f474d88..2b317ac3696 100644 --- a/lisp/calc/calc-sel.el +++ b/lisp/calc/calc-sel.el @@ -1,4 +1,4 @@ -;;; calc-sel.el --- data selection functions for Calc +;;; calc-sel.el --- data selection functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -146,7 +146,8 @@ (defvar calc-fnp-op) (defvar calc-fnp-num) -(defun calc-find-nth-part (expr calc-fnp-num) +(defun calc-find-nth-part (expr fnp-num) + (let ((calc-fnp-num fnp-num)) (if (and calc-assoc-selections (assq (car-safe expr) calc-assoc-ops)) (let (calc-fnp-op) @@ -154,7 +155,7 @@ (if (eq (car-safe expr) 'intv) (and (>= calc-fnp-num 1) (<= calc-fnp-num 2) (nth (1+ calc-fnp-num) expr)) (and (not (Math-primp expr)) (>= calc-fnp-num 1) (< calc-fnp-num (length expr)) - (nth calc-fnp-num expr))))) + (nth calc-fnp-num expr)))))) (defun calc-find-nth-part-rec (expr) ; uses num, op (or (if (and (setq calc-fnp-op (assq (car-safe (nth 1 expr)) calc-assoc-ops)) @@ -381,7 +382,7 @@ ;; (if (or (< num 1) (> num (calc-stack-size))) ;; (error "Cursor must be positioned on a stack element")) (let* ((entry (calc-top num 'entry)) - ww w) + ) ;; ww w (or (equal entry calc-selection-cache-entry) (progn (setcar entry (calc-encase-atoms (car entry))) @@ -418,6 +419,7 @@ ;; The variable math-comp-sel-tag is local to calc-find-selected-part, ;; but is used by math-comp-sel-flat-term and math-comp-add-string-sel ;; in calccomp.el, which are called (indirectly) by calc-find-selected-part. +(defvar math-comp-sel-tag) (defun calc-find-selected-part () (let* ((math-comp-sel-hpos (- (current-column) calc-selection-cache-offset)) @@ -436,7 +438,8 @@ (current-indentation)) lcount (1+ lcount))) (- lcount (math-comp-ascent - calc-selection-cache-comp) -1)))) + calc-selection-cache-comp) + -1)))) (math-comp-sel-cpos (- (point) toppt calc-selection-cache-offset spaces lcount)) (math-comp-sel-tag nil)) @@ -481,8 +484,9 @@ (defvar calc-rsf-old) (defvar calc-rsf-new) -(defun calc-replace-sub-formula (expr calc-rsf-old calc-rsf-new) - (setq calc-rsf-new (calc-encase-atoms calc-rsf-new)) +(defun calc-replace-sub-formula (expr rsf-old rsf-new) + (let ((calc-rsf-old rsf-old) + (calc-rsf-new (calc-encase-atoms rsf-new)))) (calc-replace-sub-formula-rec expr)) (defun calc-replace-sub-formula-rec (expr) @@ -671,12 +675,12 @@ (entry (calc-top num 'entry)) (expr (car entry)) (sel (or (calc-auto-selection entry) expr)) - alg) - (let ((str (math-showing-full-precision - (math-format-nice-expr sel (frame-width))))) - (calc-edit-mode (list 'calc-finish-selection-edit - num (list 'quote sel) calc-sel-reselect)) - (insert str "\n")))) + ;; alg + (str (math-showing-full-precision + (math-format-nice-expr sel (frame-width)))) + (csr calc-sel-reselect)) + (calc--edit-mode (lambda () (calc-finish-selection-edit num sel csr))) + (insert str "\n"))) (calc-show-edit-buffer)) (defvar calc-original-buffer) diff --git a/lisp/calc/calc-stat.el b/lisp/calc/calc-stat.el index 75aa9b5ac4f..3cf9bec8346 100644 --- a/lisp/calc/calc-stat.el +++ b/lisp/calc/calc-stat.el @@ -1,4 +1,4 @@ -;;; calc-stat.el --- statistical functions for Calc +;;; calc-stat.el --- statistical functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-store.el b/lisp/calc/calc-store.el index b018dcd9836..ee29c440fe4 100644 --- a/lisp/calc/calc-store.el +++ b/lisp/calc/calc-store.el @@ -1,4 +1,4 @@ -;;; calc-store.el --- value storage functions for Calc +;;; calc-store.el --- value storage functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -168,15 +168,13 @@ () (setq calc-var-name-map (copy-keymap minibuffer-local-completion-map)) (define-key calc-var-name-map " " 'self-insert-command) - (mapc (function - (lambda (x) + (mapc (lambda (x) (define-key calc-var-name-map (char-to-string x) - 'calcVar-digit))) + 'calcVar-digit)) "0123456789") - (mapc (function - (lambda (x) + (mapc (lambda (x) (define-key calc-var-name-map (char-to-string x) - 'calcVar-oper))) + 'calcVar-oper)) "+-*/^|")) (defvar calc-store-opers) @@ -184,10 +182,11 @@ (defvar calc-read-var-name-history nil "History for reading variable names.") -(defun calc-read-var-name (prompt &optional calc-store-opers) +(defun calc-read-var-name (prompt &optional store-opers) (setq calc-given-value nil calc-aborted-prefix nil) - (let ((var (concat + (let* ((calc-store-opers store-opers) + (var (concat "var-" (let ((minibuffer-completion-table (mapcar (lambda (x) (substring x 4)) @@ -323,10 +322,9 @@ (calc-pop-push-record (1+ calc-given-value-flag) (concat "=" (calc-var-name (car (car var)))) - (let ((saved-val (mapcar (function - (lambda (v) - (and (boundp (car v)) - (symbol-value (car v))))) + (let ((saved-val (mapcar (lambda (v) + (and (boundp (car v)) + (symbol-value (car v)))) var))) (unwind-protect (let ((vv var)) @@ -428,21 +426,21 @@ (defun calc-edit-variable (&optional var) (interactive) (calc-wrapper - (or var (setq var (calc-read-var-name - (if calc-last-edited-variable - (format "Edit (default %s): " - (calc-var-name calc-last-edited-variable)) - "Edit: ")))) + (unless var + (setq var (calc-read-var-name + (format-prompt "Edit" (and calc-last-edited-variable + (calc-var-name + calc-last-edited-variable)))))) (or var (setq var calc-last-edited-variable)) (if var (let* ((value (calc-var-value var))) (if (eq (car-safe value) 'special-const) (error "%s is a special constant" var)) (setq calc-last-edited-variable var) - (calc-edit-mode (list 'calc-finish-stack-edit (list 'quote var)) - t - (format-message - "Editing variable `%s'" (calc-var-name var))) + (calc--edit-mode (lambda () (calc-finish-stack-edit var)) + t + (format-message + "Editing variable `%s'" (calc-var-name var))) (and value (insert (math-format-nice-expr value (frame-width)) "\n"))))) (calc-show-edit-buffer)) @@ -504,7 +502,7 @@ (calc-wrapper (or var (setq var (calc-read-var-name "Declare: " 0))) (or var (setq var 'var-All)) - (let* (dp decl def row rp) + (let* (dp decl row rp) ;; def (or (and (calc-var-value 'var-Decls) (eq (car-safe var-Decls) 'vec)) (setq var-Decls (list 'vec))) @@ -596,13 +594,12 @@ calc-settings-file))) (if var (calc-insert-permanent-variable var) - (mapatoms (function - (lambda (x) - (and (string-match "\\`var-" (symbol-name x)) - (not (memq x calc-dont-insert-variables)) - (calc-var-value x) - (not (eq (car-safe (symbol-value x)) 'special-const)) - (calc-insert-permanent-variable x)))))) + (mapatoms (lambda (x) + (and (string-match "\\`var-" (symbol-name x)) + (not (memq x calc-dont-insert-variables)) + (calc-var-value x) + (not (eq (car-safe (symbol-value x)) 'special-const)) + (calc-insert-permanent-variable x))))) (save-buffer)))) @@ -637,27 +634,26 @@ (defun calc-insert-variables (buf) (interactive "bBuffer in which to save variable values: ") (with-current-buffer buf - (mapatoms (function - (lambda (x) - (and (string-match "\\`var-" (symbol-name x)) - (not (memq x calc-dont-insert-variables)) - (calc-var-value x) - (not (eq (car-safe (symbol-value x)) 'special-const)) - (or (not (eq x 'var-Decls)) - (not (equal var-Decls '(vec)))) - (or (not (eq x 'var-Holidays)) - (not (equal var-Holidays '(vec (var sat var-sat) - (var sun var-sun))))) - (insert "(setq " - (symbol-name x) - " " - (prin1-to-string - (let ((calc-language - (if (memq calc-language '(nil big)) - 'flat - calc-language))) - (math-format-value (symbol-value x) 100000))) - ")\n"))))))) + (mapatoms (lambda (x) + (and (string-match "\\`var-" (symbol-name x)) + (not (memq x calc-dont-insert-variables)) + (calc-var-value x) + (not (eq (car-safe (symbol-value x)) 'special-const)) + (or (not (eq x 'var-Decls)) + (not (equal var-Decls '(vec)))) + (or (not (eq x 'var-Holidays)) + (not (equal var-Holidays '(vec (var sat var-sat) + (var sun var-sun))))) + (insert "(setq " + (symbol-name x) + " " + (prin1-to-string + (let ((calc-language + (if (memq calc-language '(nil big)) + 'flat + calc-language))) + (math-format-value (symbol-value x) 100000))) + ")\n")))))) (defun calc-assign (arg) (interactive "P") diff --git a/lisp/calc/calc-stuff.el b/lisp/calc/calc-stuff.el index b233ec75249..9281666c3b6 100644 --- a/lisp/calc/calc-stuff.el +++ b/lisp/calc/calc-stuff.el @@ -1,4 +1,4 @@ -;;; calc-stuff.el --- miscellaneous functions for Calc +;;; calc-stuff.el --- miscellaneous functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -182,7 +182,7 @@ With a prefix, push that prefix as a number onto the stack." math-eval-rules-cache-tag t math-format-date-cache nil math-holidays-cache-tag t) - (mapc (function (lambda (x) (set x -100))) math-cache-list) + (mapc (lambda (x) (set x -100)) math-cache-list) (unless inhibit-msg (message "All internal calculator caches have been reset")))) @@ -258,14 +258,14 @@ With a prefix, push that prefix as a number onto the stack." (t (list 'calcFunc-clean a))))) (defun calcFunc-pclean (a &optional prec) - (math-map-over-constants (function (lambda (x) (calcFunc-clean x prec))) + (math-map-over-constants (lambda (x) (calcFunc-clean x prec)) a)) (defun calcFunc-pfloat (a) (math-map-over-constants 'math-float a)) (defun calcFunc-pfrac (a &optional tol) - (math-map-over-constants (function (lambda (x) (calcFunc-frac x tol))) + (math-map-over-constants (lambda (x) (calcFunc-frac x tol)) a)) ;; The variable math-moc-func is local to math-map-over-constants, @@ -273,8 +273,9 @@ With a prefix, push that prefix as a number onto the stack." ;; math-map-over-constants. (defvar math-moc-func) -(defun math-map-over-constants (math-moc-func expr) - (math-map-over-constants-rec expr)) +(defun math-map-over-constants (moc-func expr) + (let ((math-moc-func moc-func)) + (math-map-over-constants-rec expr))) (defun math-map-over-constants-rec (expr) (cond ((or (Math-primp expr) diff --git a/lisp/calc/calc-trail.el b/lisp/calc/calc-trail.el index 65db5ffae08..2cf5160d5d3 100644 --- a/lisp/calc/calc-trail.el +++ b/lisp/calc/calc-trail.el @@ -1,4 +1,4 @@ -;;; calc-trail.el --- functions for manipulating the Calc "trail" +;;; calc-trail.el --- functions for manipulating the Calc "trail" -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-undo.el b/lisp/calc/calc-undo.el index 60ed4310100..4add99a250f 100644 --- a/lisp/calc/calc-undo.el +++ b/lisp/calc/calc-undo.el @@ -1,4 +1,4 @@ -;;; calc-undo.el --- undo functions for Calc +;;; calc-undo.el --- undo functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-units.el b/lisp/calc/calc-units.el index 505bff1d241..c3adc3db02a 100644 --- a/lisp/calc/calc-units.el +++ b/lisp/calc/calc-units.el @@ -37,14 +37,14 @@ ;;; Updated April 2002 by Jochen Küpper ;;; Updated August 2007, using -;;; CODATA (http://physics.nist.gov/cuu/Constants/index.html) -;;; NIST (http://physics.nist.gov/Pubs/SP811/appenB9.html) +;;; CODATA (https://physics.nist.gov/cuu/Constants/index.html) +;;; NIST (https://physics.nist.gov/Pubs/SP811/appenB9.html) ;;; ESUWM (Encyclopaedia of Scientific Units, Weights and ;;; Measures, by François Cardarelli) ;;; All conversions are exact unless otherwise noted. ;; CODATA values updated February 2016, using 2014 adjustment -;; http://arxiv.org/pdf/1507.07956.pdf +;; https://arxiv.org/pdf/1507.07956.pdf ;; Updated November 2018 for the redefinition of the SI ;; https://www.bipm.org/utils/en/pdf/CGPM/Draft-Resolution-A-EN.pdf @@ -59,7 +59,7 @@ ( mi "5280 ft" "Mile" ) ( au "149597870691. m" "Astronomical Unit" nil "149597870691 m (*)") - ;; (approx) NASA JPL (http://neo.jpl.nasa.gov/glossary/au.html) + ;; (approx) NASA JPL (https://neo.jpl.nasa.gov/glossary/au.html) ( lyr "c yr" "Light Year" ) ( pc "3.0856775854*10^16 m" "Parsec (**)" nil "3.0856775854 10^16 m (*)") ;; (approx) ESUWM @@ -860,23 +860,22 @@ If COMP or STD is non-nil, put that in the units table instead." tab) (message "Building units table...") (setq math-units-table-buffer-valid nil) - (setq tab (mapcar (function - (lambda (x) - (list (car x) - (and (nth 1 x) - (if (stringp (nth 1 x)) - (let ((exp (math-read-plain-expr - (nth 1 x)))) - (if (eq (car-safe exp) 'error) - (error "Format error in definition of %s in units table: %s" - (car x) (nth 2 exp)) - exp)) - (nth 1 x))) - (nth 2 x) - (nth 3 x) - (and (not (nth 1 x)) - (list (cons (car x) 1))) - (nth 4 x)))) + (setq tab (mapcar (lambda (x) + (list (car x) + (and (nth 1 x) + (if (stringp (nth 1 x)) + (let ((exp (math-read-plain-expr + (nth 1 x)))) + (if (eq (car-safe exp) 'error) + (error "Format error in definition of %s in units table: %s" + (car x) (nth 2 exp)) + exp)) + (nth 1 x))) + (nth 2 x) + (nth 3 x) + (and (not (nth 1 x)) + (list (cons (car x) 1))) + (nth 4 x))) combined-units)) (let ((math-units-table tab)) (mapc #'math-find-base-units tab)) @@ -1100,10 +1099,9 @@ If COMP or STD is non-nil, put that in the units table instead." (setq math-decompose-units-cache (cons entry (sort ulist - (function - (lambda (x y) - (not (Math-lessp (nth 1 x) - (nth 1 y)))))))))) + (lambda (x y) + (not (Math-lessp (nth 1 x) + (nth 1 y))))))))) (cdr math-decompose-units-cache)))) (defun math-decompose-unit-part (unit) @@ -2159,7 +2157,7 @@ If non-nil, return a list consisting of the note and the cents coefficient." (calc-unary-op "midi" 'calcFunc-midi arg))) (defun calc-spn (arg) - "Return the scientific pitch notation corresponding to the expression on the stack." + "Return scientific pitch notation corresponding to the expression on the stack." (interactive "P") (calc-slow-wrapper (calc-unary-op "spn" 'calcFunc-spn arg))) diff --git a/lisp/calc/calc-vec.el b/lisp/calc/calc-vec.el index 90431c7bd48..73783dd2c2c 100644 --- a/lisp/calc/calc-vec.el +++ b/lisp/calc/calc-vec.el @@ -1,4 +1,4 @@ -;;; calc-vec.el --- vector functions for Calc +;;; calc-vec.el --- vector functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -744,7 +744,7 @@ ;;; Get the Nth row of a matrix. (defun calcFunc-mrow (mat n) ; [Public] (if (Math-vectorp n) - (math-map-vec (function (lambda (x) (calcFunc-mrow mat x))) n) + (math-map-vec (lambda (x) (calcFunc-mrow mat x)) n) (if (and (eq (car-safe n) 'intv) (math-constp n)) (calcFunc-subvec mat (math-add (nth 2 n) (if (memq (nth 1 n) '(2 3)) 0 1)) @@ -768,15 +768,15 @@ ;;; Get the Nth column of a matrix. (defun math-mat-col (mat n) - (cons 'vec (mapcar (function (lambda (x) (elt x n))) (cdr mat)))) + (cons 'vec (mapcar (lambda (x) (elt x n)) (cdr mat)))) (defun calcFunc-mcol (mat n) ; [Public] (if (Math-vectorp n) (calcFunc-trn - (math-map-vec (function (lambda (x) (calcFunc-mcol mat x))) n)) + (math-map-vec (lambda (x) (calcFunc-mcol mat x)) n)) (if (and (eq (car-safe n) 'intv) (math-constp n)) (if (math-matrixp mat) - (math-map-vec (function (lambda (x) (calcFunc-mrow x n))) mat) + (math-map-vec (lambda (x) (calcFunc-mrow x n)) mat) (calcFunc-mrow mat n)) (or (and (integerp (setq n (math-check-integer n))) (> n 0)) @@ -804,7 +804,7 @@ ;;; Remove the Nth column from a matrix. (defun math-mat-less-col (mat n) - (cons 'vec (mapcar (function (lambda (x) (math-mat-less-row x n))) + (cons 'vec (mapcar (lambda (x) (math-mat-less-row x n)) (cdr mat)))) (defun calcFunc-mrcol (mat n) ; [Public] @@ -939,10 +939,10 @@ (calcFunc-idn a (1- (length m))) (if (math-vectorp m) (if (math-zerop a) - (cons 'vec (mapcar (function (lambda (x) - (if (math-vectorp x) - (math-mimic-ident a x) - a))) + (cons 'vec (mapcar (lambda (x) + (if (math-vectorp x) + (math-mimic-ident a x) + a)) (cdr m))) (math-dimension-error)) (calcFunc-idn a)))) @@ -1111,18 +1111,20 @@ ;; by calcFunc-grade and calcFunc-rgrade. (defvar math-grade-vec) -(defun calcFunc-grade (math-grade-vec) - (if (math-vectorp math-grade-vec) - (let* ((len (1- (length math-grade-vec)))) - (cons 'vec (sort (cdr (calcFunc-index len)) 'math-grade-beforep))) - (math-reject-arg math-grade-vec 'vectorp))) - -(defun calcFunc-rgrade (math-grade-vec) - (if (math-vectorp math-grade-vec) - (let* ((len (1- (length math-grade-vec)))) +(defun calcFunc-grade (grade-vec) + (if (math-vectorp grade-vec) + (let* ((math-grade-vec grade-vec) + (len (1- (length grade-vec)))) + (cons 'vec (sort (cdr (calcFunc-index len)) #'math-grade-beforep))) + (math-reject-arg grade-vec #'vectorp))) + +(defun calcFunc-rgrade (grade-vec) + (if (math-vectorp grade-vec) + (let* ((math-grade-vec grade-vec) + (len (1- (length grade-vec)))) (cons 'vec (nreverse (sort (cdr (calcFunc-index len)) - 'math-grade-beforep)))) - (math-reject-arg math-grade-vec 'vectorp))) + #'math-grade-beforep)))) + (math-reject-arg grade-vec #'vectorp))) (defun math-grade-beforep (i j) (math-beforep (nth i math-grade-vec) (nth j math-grade-vec))) @@ -1556,7 +1558,8 @@ of two matrices is a matrix." (defvar math-exp-keep-spaces) (defvar math-expr-data) -(defun math-read-brackets (space-sep math-rb-close) +(defun math-read-brackets (space-sep rb-close) + (let ((math-rb-close rb-close)) (and space-sep (setq space-sep (not (math-check-for-commas)))) (math-read-token) (while (eq math-exp-token 'space) @@ -1624,7 +1627,7 @@ of two matrices is a matrix." (throw 'syntax "Expected `]'"))) (or (eq math-exp-token 'end) (math-read-token)) - vals))) + vals)))) (defun math-check-for-commas (&optional balancing) (let ((count 0) diff --git a/lisp/calc/calc-yank.el b/lisp/calc/calc-yank.el index 99cfd0483b0..e5f05236f3a 100644 --- a/lisp/calc/calc-yank.el +++ b/lisp/calc/calc-yank.el @@ -1,4 +1,4 @@ -;;; calc-yank.el --- kill-ring functionality for Calc +;;; calc-yank.el --- kill-ring functionality for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -150,34 +150,16 @@ ;; otherwise it just parses the yanked string. ;; Modified to use Emacs 19 extended concept of kill-ring. -- daveg 12/15/96 ;;;###autoload -(defun calc-yank (radix) - "Yank a value into the Calculator buffer. - -Valid numeric prefixes for RADIX: 0, 2, 6, 8 -No radix notation is prepended for any other numeric prefix. - -If RADIX is 2, prepend \"2#\" - Binary. -If RADIX is 8, prepend \"8#\" - Octal. -If RADIX is 0, prepend \"10#\" - Decimal. -If RADIX is 6, prepend \"16#\" - Hexadecimal. - -If RADIX is a non-nil list (created using \\[universal-argument]), the user -will be prompted to enter the radix in the minibuffer. +(defun calc-yank-internal (radix thing-raw) + "Internal common implementation for yank functions. -If RADIX is nil or if the yanked string already has a calc radix prefix, the -yanked string will be passed on directly to the Calculator buffer without any -alteration." - (interactive "P") +This function is used by both `calc-yank' and `calc-yank-mouse-primary'." (calc-wrapper (calc-pop-push-record-list 0 "yank" (let* (radix-num radix-notation valid-num-regexp - (thing-raw - (if (fboundp 'current-kill) - (current-kill 0 t) - (car kill-ring-yank-pointer))) (thing (if (or (null radix) ;; Match examples: -2#10, 10\n(10#10,01) @@ -232,6 +214,38 @@ alteration." val)) val)))))))) +;;;###autoload +(defun calc-yank-mouse-primary (radix) + "Yank the current primary selection into the Calculator buffer. +See `calc-yank' for details about RADIX." + (interactive "P") + (if (or select-enable-primary + select-enable-clipboard) + (calc-yank-internal radix (gui-get-primary-selection)) + ;; Yank from the kill ring. + (calc-yank radix))) + +;;;###autoload +(defun calc-yank (radix) + "Yank a value into the Calculator buffer. + +Valid numeric prefixes for RADIX: 0, 2, 6, 8 +No radix notation is prepended for any other numeric prefix. + +If RADIX is 2, prepend \"2#\" - Binary. +If RADIX is 8, prepend \"8#\" - Octal. +If RADIX is 0, prepend \"10#\" - Decimal. +If RADIX is 6, prepend \"16#\" - Hexadecimal. + +If RADIX is a non-nil list (created using \\[universal-argument]), the user +will be prompted to enter the radix in the minibuffer. + +If RADIX is nil or if the yanked string already has a calc radix prefix, the +yanked string will be passed on directly to the Calculator buffer without any +alteration." + (interactive "P") + (calc-yank-internal radix (current-kill 0 t))) + ;;; The Calc set- and get-register commands are modified versions of functions ;;; in register.el @@ -387,7 +401,7 @@ Interactively, reads the register using `register-read-with-preview'." (let* ((from-buffer (current-buffer)) (calc-was-started (get-buffer-window "*Calculator*")) (single nil) - data vals pos) + data vals) ;; pos (if arg (if (consp arg) (setq single t) @@ -629,23 +643,22 @@ Interactively, reads the register using `register-read-with-preview'." (allow-ret (> n 1)) (list (math-showing-full-precision (mapcar (if (> n 1) - (function (lambda (x) - (math-format-flat-expr x 0))) - (function - (lambda (x) - (if (math-vectorp x) (setq allow-ret t)) - (math-format-nice-expr x (frame-width))))) + (lambda (x) + (math-format-flat-expr x 0)) + (lambda (x) + (if (math-vectorp x) (setq allow-ret t)) + (math-format-nice-expr x (frame-width)))) (if (> n 0) (calc-top-list n) (calc-top-list 1 (- n))))))) - (calc-edit-mode (list 'calc-finish-stack-edit (or flag n)) allow-ret) + (calc--edit-mode (lambda () (calc-finish-stack-edit (or flag n))) allow-ret) (while list (insert (car list) "\n") (setq list (cdr list))))) (calc-show-edit-buffer)) (defun calc-alg-edit (str) - (calc-edit-mode '(calc-finish-stack-edit 0)) + (calc--edit-mode (lambda () (calc-finish-stack-edit 0))) (calc-show-edit-buffer) (insert str "\n") (backward-char 1) @@ -653,54 +666,47 @@ Interactively, reads the register using `register-read-with-preview'." (defvar calc-edit-mode-map (let ((map (make-sparse-keymap))) - (define-key map "\n" 'calc-edit-finish) - (define-key map "\r" 'calc-edit-return) - (define-key map "\C-c\C-c" 'calc-edit-finish) + (define-key map "\n" #'calc-edit-finish) + (define-key map "\r" #'calc-edit-return) + (define-key map "\C-c\C-c" #'calc-edit-finish) map) - "Keymap for use by the calc-edit command.") + "Keymap for use by the `calc-edit' command.") -(defvar calc-original-buffer) -(defvar calc-return-buffer) -(defvar calc-one-window) -(defvar calc-edit-handler) -(defvar calc-restore-trail) -(defvar calc-allow-ret) -(defvar calc-edit-top) +(defvar calc-original-buffer nil) +(defvar calc-return-buffer nil) +(defvar calc-one-window nil) +(defvar calc-edit-handler nil) +(defvar calc-restore-trail nil) +(defvar calc-allow-ret nil) +(defvar calc-edit-top nil) -(defun calc-edit-mode (&optional handler allow-ret title) +(put 'calc-edit-mode 'mode-class 'special) +(define-derived-mode calc-edit-mode nil "Calc Edit" "Calculator editing mode. Press RET, LFD, or C-c C-c to finish. To cancel the edit, simply kill the *Calc Edit* buffer." - (interactive) + (setq-local buffer-read-only nil) + (setq-local truncate-lines nil)) + +(defun calc--edit-mode (handler &optional allow-ret title) (unless handler (error "This command can be used only indirectly through calc-edit")) (let ((oldbuf (current-buffer)) (buf (get-buffer-create "*Calc Edit*"))) (set-buffer buf) - (kill-all-local-variables) - (use-local-map calc-edit-mode-map) - (setq buffer-read-only nil) - (setq truncate-lines nil) - (setq major-mode 'calc-edit-mode) - (setq mode-name "Calc Edit") - (run-mode-hooks 'calc-edit-mode-hook) - (make-local-variable 'calc-original-buffer) - (setq calc-original-buffer oldbuf) - (make-local-variable 'calc-return-buffer) - (setq calc-return-buffer oldbuf) - (make-local-variable 'calc-one-window) - (setq calc-one-window (and (one-window-p t) pop-up-windows)) - (make-local-variable 'calc-edit-handler) - (setq calc-edit-handler handler) - (make-local-variable 'calc-restore-trail) - (setq calc-restore-trail (get-buffer-window (calc-trail-buffer))) - (make-local-variable 'calc-allow-ret) - (setq calc-allow-ret allow-ret) + (calc-edit-mode) + (setq-local calc-original-buffer oldbuf) + (setq-local calc-return-buffer oldbuf) + (setq-local calc-one-window (and (one-window-p t) pop-up-windows)) + (setq-local calc-edit-handler handler) + (setq-local calc-restore-trail (get-buffer-window (calc-trail-buffer))) + (setq-local calc-allow-ret allow-ret) (let ((inhibit-read-only t)) (erase-buffer)) (add-hook 'kill-buffer-hook (lambda () (let ((calc-edit-handler nil)) (calc-edit-finish t)) - (message "(Canceled)")) t t) + (message "(Canceled)")) + t t) (insert (propertize (concat (or title title "Calc Edit Mode. ") @@ -708,9 +714,7 @@ To cancel the edit, simply kill the *Calc Edit* buffer." (if allow-ret "" " or RET") (format-message " to finish, `C-x k RET' to cancel.\n\n")) 'font-lock-face 'italic 'read-only t 'rear-nonsticky t 'front-sticky t)) - (make-local-variable 'calc-edit-top) - (setq calc-edit-top (point)))) -(put 'calc-edit-mode 'mode-class 'special) + (setq-local calc-edit-top (point)))) (defun calc-show-edit-buffer () (let ((buf (current-buffer))) @@ -730,24 +734,19 @@ To cancel the edit, simply kill the *Calc Edit* buffer." (defun calc-edit-return () (interactive) - (if (and (boundp 'calc-allow-ret) calc-allow-ret) + (if calc-allow-ret (newline) (calc-edit-finish))) -;; The variable calc-edit-disp-trail is local to calc-edit finish, but -;; is used by calc-finish-selection-edit and calc-finish-stack-edit. +;; The variable `calc-edit-disp-trail' is local to `calc-edit-finish', but +;; is used by `calc-finish-selection-edit' and `calc-finish-stack-edit'. (defvar calc-edit-disp-trail) (defun calc-edit-finish (&optional keep) - "Finish calc-edit mode. Parse buffer contents and push them on the stack." + "Finish `calc-edit' mode. Parse buffer contents and push them on the stack." (interactive "P") (message "Working...") - (or (and (boundp 'calc-original-buffer) - (boundp 'calc-return-buffer) - (boundp 'calc-one-window) - (boundp 'calc-edit-handler) - (boundp 'calc-restore-trail) - (eq major-mode 'calc-edit-mode)) + (or (derived-mode-p 'calc-edit-mode) (error "This command is valid only in buffers created by calc-edit")) (let ((buf (current-buffer)) (original calc-original-buffer) @@ -762,7 +761,11 @@ To cancel the edit, simply kill the *Calc Edit* buffer." (error "Original calculator buffer has been corrupted"))) (goto-char calc-edit-top) (if (buffer-modified-p) - (eval calc-edit-handler)) + (if (functionp calc-edit-handler) + (funcall calc-edit-handler) + (message "Deprecated handler expression in calc-edit-handler: %S" + calc-edit-handler) + (eval calc-edit-handler t))) (if (and one-window (not (one-window-p t))) (delete-window)) (if (get-buffer-window return) diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index 1ddd62429f6..d684c7ba97f 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -266,18 +266,18 @@ (sgml-mode . "<!-- Embed -->\n\\(<!-- .* -->\n\\)*") (xml-mode . "<!-- Embed -->\n\\(<!-- .* -->\n\\)*") (texinfo-mode . "@c Embed\n\\(@c .*\n\\)*")) - "Alist of major modes with appropriate values for `calc-embedded-announce-formula'." + "Alist of major modes for `calc-embedded-announce-formula'." :type '(alist :key-type (symbol :tag "Major mode") :value-type (regexp :tag "Regexp to announce formula"))) (defcustom calc-embedded-open-formula "\\`\\|^\n\\|\\$\\$?\\|\\\\\\[\\|^\\\\begin[^{].*\n\\|^\\\\begin{.*[^x]}.*\n\\|^@.*\n\\|^\\.EQ.*\n\\|\\\\(\\|^%\n\\|^\\.\\\\\"\n" - "A regular expression for the opening delimiter of a formula used by calc-embedded." + "Regexp for the opening delimiter of a formula used by `calc-embedded'." :type '(regexp)) (defcustom calc-embedded-close-formula "\\'\\|\n$\\|\\$\\$?\\|\\\\]\\|^\\\\end[^{].*\n\\|^\\\\end{.*[^x]}.*\n\\|^@.*\n\\|^\\.EN.*\n\\|\\\\)\\|\n%\n\\|^\\.\\\\\"\n" - "A regular expression for the closing delimiter of a formula used by calc-embedded." + "Regexp for the closing delimiter of a formula used by calc-embedded." :type '(regexp)) (defcustom calc-embedded-open-close-formula-alist @@ -506,7 +506,7 @@ The variable VAR will be added to `calc-mode-var-list'." (defun calc-mode-var-list-restore-default-values () "Restore the default values of the variables in `calc-mode-var-list'." - (mapcar (function (lambda (v) (set (car v) (nth 1 v)))) + (mapcar (lambda (v) (set (car v) (nth 1 v))) calc-mode-var-list)) (defun calc-mode-var-list-restore-saved-values () @@ -535,7 +535,7 @@ The variable VAR will be added to `calc-mode-var-list'." newvarlist))) (setq varlist (cdr varlist))))))) (if newvarlist - (mapcar (function (lambda (v) (set (car v) (nth 1 v)))) + (mapcar (lambda (v) (set (car v) (nth 1 v))) newvarlist) (calc-mode-var-list-restore-default-values)))) @@ -721,7 +721,8 @@ If nil, computations on numbers always yield numbers where possible.") (defcalcmodevar calc-matrix-mode nil "If `matrix', variables are assumed to be matrix-valued. If a number, variables are assumed to be NxN matrices. -If `sqmatrix', variables are assumed to be square matrices of an unspecified size. +If `sqmatrix', variables are assumed to be square matrices of an + unspecified size. If `scalar', variables are assumed to be scalar-valued. If nil, symbolic math routines make no assumptions about variables.") @@ -884,6 +885,8 @@ Used by `calc-user-invocation'.") (defvar calc-load-hook nil "Hook run when calc.el is loaded.") +(make-obsolete-variable 'calc-load-hook + "use `with-eval-after-load' instead." "28.1") (defvar calc-window-hook nil "Hook called to create the Calc window.") @@ -1085,8 +1088,18 @@ Used by `calc-user-invocation'.") (append (where-is-internal 'delete-backward-char global-map) (where-is-internal 'backward-delete-char global-map) (where-is-internal 'backward-delete-char-untabify global-map) - '("\C-d")) - '("\177" "\C-d"))) + '("\177")) + '("\177"))) + +(mapc (lambda (x) + (ignore-errors + (define-key calc-digit-map x 'calcDigit-delchar) + (define-key calc-mode-map x 'calc-pop) + (define-key calc-mode-map (vconcat "\e" x) 'calc-pop-above))) + (if calc-scan-for-dels + (append (where-is-internal 'delete-forward-char global-map) + '("\C-d")) + '("\C-d"))) (defvar calc-dispatch-map (let ((map (make-keymap))) @@ -1295,8 +1308,9 @@ Notations: 3.14e6 3.14 * 10^6 \\{calc-mode-map} " (interactive) - (mapc (function ;FIXME: Why (set-default v (symbol-value v)) ?!?!? - (lambda (v) (set-default v (symbol-value v)))) + (mapc (lambda (v) + ;; FIXME: Why (set-default v (symbol-value v)) ?!?!? + (set-default v (symbol-value v))) calc-local-var-list) (kill-all-local-variables) (use-local-map (if (eq calc-algebraic-mode 'total) @@ -1362,6 +1376,29 @@ Notations: 3.14e6 3.14 * 10^6 (set-keymap-parent map calc-mode-map) map)) +(defun calc--header-line (long short width &optional fudge) + "Return a Calc header line appropriate for the buffer width. + +LONG is a desired text for a wide window, SHORT is a desired +abbreviated text, and width is the buffer width, which will be +some fraction of the 'parent' window width (At the time of +writing, 2/3 for calc, 1/3 for trail). The optional FUDGE is a +trial-and-error adjustment number for the edge-cases at the +border of the two cases." + ;; TODO: This could be called as part of a 'window-resize' hook. + (setq header-line-format + (let* ((len-long (length long)) + (len-short (length short)) + (fudge (or fudge 0)) + ;; fudge for trail is: -3 (added to len-long) + ;; (width ) for trail + (factor (if (> width (+ len-long fudge)) len-long len-short)) + (size (max (/ (- width factor) 2) 0)) + (fill (make-string size ?-)) + (pre (replace-regexp-in-string ".$" " " fill)) + (post (replace-regexp-in-string "^." " " fill))) + (concat pre (if (= factor len-long) long short) post)))) + (define-derived-mode calc-trail-mode fundamental-mode "Calc Trail" "Calc Trail mode. This mode is used by the *Calc Trail* buffer, which records all results @@ -1376,9 +1413,9 @@ commands given here will actually operate on the *Calculator* stack." (setq buffer-read-only t) (make-local-variable 'overlay-arrow-position) (make-local-variable 'overlay-arrow-string) - (when (= (buffer-size) 0) - (let ((inhibit-read-only t)) - (insert (propertize "Emacs Calculator Trail\n" 'face 'italic))))) + (when calc-show-banner + (calc--header-line "Emacs Calculator Trail" "Calc Trail" + (/ (window-width) 3) -3))) (defun calc-create-buffer () "Create and initialize a buffer for the Calculator." @@ -1392,6 +1429,12 @@ commands given here will actually operate on the *Calculator* stack." (require 'calc-ext) (calc-set-language calc-language calc-language-option t))) +(defcustom calc-make-windows-dedicated t + "If non-nil, windows displaying Calc buffers will be marked dedicated. +See `window-dedicated-p' for what that means." + :version "28.1" + :type 'boolean) + ;;;###autoload (defun calc (&optional arg full-display interactive) "The Emacs Calculator. Full documentation is listed under `calc-mode'." @@ -1431,13 +1474,14 @@ commands given here will actually operate on the *Calculator* stack." (pop-to-buffer (current-buffer))))))) (with-current-buffer (calc-trail-buffer) (and calc-display-trail - (= (window-width) (frame-width)) (calc-trail-display 1 t))) (message "Welcome to the GNU Emacs Calculator! Press `?' or `h' for help, `q' to quit") (run-hooks 'calc-start-hook) (and (windowp full-display) (window-point full-display) (select-window full-display)) + (and calc-make-windows-dedicated + (set-window-dedicated-p nil t)) (calc-check-defines) (when (and calc-said-hello interactive) (sit-for 2) @@ -1487,7 +1531,7 @@ commands given here will actually operate on the *Calculator* stack." (let ((tail (nthcdr (1- calc-undo-length) calc-undo-list))) (if tail (setcdr tail nil))) (setq calc-redo-list nil)))) - (mapc (function (lambda (v) (set-default v (symbol-value v)))) + (mapc (lambda (v) (set-default v (symbol-value v))) calc-local-var-list) (let ((buf (current-buffer)) (win (get-buffer-window (current-buffer))) @@ -1966,13 +2010,11 @@ See calc-keypad for details." (calc-any-evaltos nil)) (setq calc-any-selections nil) (erase-buffer) - (when calc-show-banner - (insert (propertize "--- Emacs Calculator Mode ---\n" - 'face 'italic))) + (when calc-show-banner + (calc--header-line "Emacs Calculator Mode" "Emacs Calc" + (* 2 (/ (window-width) 3)) -3)) (while thing (goto-char (point-min)) - (when calc-show-banner - (forward-line 1)) (insert (math-format-stack-value (car thing)) "\n") (setq thing (cdr thing))) (calc-renumber-stack) @@ -2051,12 +2093,11 @@ the United States." (set-buffer calc-trail-buffer) (unless (derived-mode-p 'calc-trail-mode) (calc-trail-mode) - (set (make-local-variable 'calc-main-buffer) buf))))) + (setq-local calc-main-buffer buf))))) (or (and calc-trail-pointer (eq (marker-buffer calc-trail-pointer) calc-trail-buffer)) (with-current-buffer calc-trail-buffer (goto-char (point-min)) - (forward-line 1) (setq calc-trail-pointer (point-marker)))) calc-trail-buffer) @@ -2101,7 +2142,9 @@ the United States." (if calc-trail-window-hook (run-hooks 'calc-trail-window-hook) (let ((w (split-window nil (/ (* (window-width) 2) 3) t))) - (set-window-buffer w calc-trail-buffer))) + (set-window-buffer w calc-trail-buffer) + (and calc-make-windows-dedicated + (set-window-dedicated-p nil t)))) (calc-wrapper (setq overlay-arrow-string calc-trail-overlay overlay-arrow-position calc-trail-pointer) @@ -2124,10 +2167,8 @@ the United States." (if (derived-mode-p 'calc-trail-mode) (progn (beginning-of-line) - (if (bobp) - (forward-line 1) - (if (eobp) - (forward-line -1))) + (if (eobp) + (forward-line -1)) (if (or (bobp) (eobp)) (setq overlay-arrow-position nil) ; trail is empty (set-marker calc-trail-pointer (point) (current-buffer)) @@ -2141,7 +2182,7 @@ the United States." (if win (save-excursion (forward-line (/ (window-height win) 2)) - (forward-line (- 1 (window-height win))) + (forward-line (- 2 (window-height win))) (set-window-start win (point)) (set-window-point win (+ calc-trail-pointer 4)) (set-buffer calc-main-buffer) @@ -2276,7 +2317,7 @@ the United States." ((eq last-command-event ?@) "0@ ") (t (char-to-string last-command-event)))) -(defvar calc-buffer) +(defvar calc-buffer nil) (defvar calc-prev-char) (defvar calc-prev-prev-char) (defvar calc-digit-value) @@ -2316,7 +2357,7 @@ the United States." (defun calcDigit-nondigit () (interactive) ;; Exercise for the reader: Figure out why this is a good precaution! - (or (boundp 'calc-buffer) + (or calc-buffer (use-local-map minibuffer-local-map)) (let ((str (minibuffer-contents))) (setq calc-digit-value (with-current-buffer calc-buffer @@ -2341,7 +2382,6 @@ the United States." (defun calcDigit-key () (interactive) - (goto-char (point-max)) (if (or (and (memq last-command-event '(?+ ?-)) (> (buffer-size) 0) (/= (preceding-char) ?e)) @@ -2384,8 +2424,7 @@ the United States." (delete-char 1)) (if (looking-at "-") (delete-char 1) - (insert "-"))) - (goto-char (point-max))) + (insert "-")))) ((eq last-command-event ?p) (if (or (calc-minibuffer-contains ".*\\+/-.*") (calc-minibuffer-contains ".*mod.*") @@ -2427,7 +2466,7 @@ the United States." (if (and (memq last-command-event '(?@ ?o ?h ?\' ?m)) (string-match " " calc-hms-format)) (insert " ")) - (if (and (eq this-command last-command) + (if (and (memq last-command '(calcDigit-start calcDigit-key)) (eq last-command-event ?.)) (progn (require 'calc-ext) @@ -2438,17 +2477,9 @@ the United States." (setq calc-prev-prev-char calc-prev-char calc-prev-char last-command-event)) - (defun calcDigit-backspace () (interactive) - (goto-char (point-max)) - (cond ((calc-minibuffer-contains ".* \\+/- \\'") - (backward-delete-char 5)) - ((calc-minibuffer-contains ".* mod \\'") - (backward-delete-char 5)) - ((calc-minibuffer-contains ".* \\'") - (backward-delete-char 2)) - ((eq last-command 'calcDigit-start) + (cond ((eq last-command 'calcDigit-start) (erase-buffer)) (t (backward-delete-char 1))) (if (= (calc-minibuffer-size) 0) @@ -2923,6 +2954,20 @@ the United States." (- (- (nth 2 a) (nth 2 b)) ldiff)))) +(defun calcDigit-delchar () + (interactive) + (cond ((looking-at-p " \\+/- \\'") + (delete-char 5)) + ((looking-at-p " mod \\'") + (delete-char 5)) + ((looking-at-p " \\'") + (delete-char 2)) + ((eq last-command 'calcDigit-start) + (erase-buffer)) + (t (unless (eobp) (delete-char 1)))) + (when (= (calc-minibuffer-size) 0) + (setq last-command-event 13) + (calcDigit-nondigit))) (defvar math-comp-selected) @@ -3411,12 +3456,10 @@ See Info node `(calc)Defining Functions'." (defun calc-clear-unread-commands () (setq unread-command-events nil)) -(defcalcmodevar math-2-word-size - (math-read-number-simple "4294967296") +(defcalcmodevar math-2-word-size 4294967296 "Two to the power of `calc-word-size'.") -(defcalcmodevar math-half-2-word-size - (math-read-number-simple "2147483648") +(defcalcmodevar math-half-2-word-size 2147483648 "One-half of two to the power of `calc-word-size'.") (when calc-always-load-extensions diff --git a/lisp/calc/calcalg2.el b/lisp/calc/calcalg2.el index 3ede525cd67..fc6eb74e9f1 100644 --- a/lisp/calc/calcalg2.el +++ b/lisp/calc/calcalg2.el @@ -1,4 +1,4 @@ -;;; calcalg2.el --- more algebraic functions for Calc +;;; calcalg2.el --- more algebraic functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -333,8 +333,10 @@ (setq n (1+ n))) accum)))))) -(defun calcFunc-deriv (expr math-deriv-var &optional deriv-value math-deriv-symb) - (let* ((math-deriv-total nil) +(defun calcFunc-deriv (expr deriv-var &optional deriv-value deriv-symb) + (let* ((math-deriv-var deriv-var) + (math-deriv-symb deriv-symb) + (math-deriv-total nil) (res (catch 'math-deriv (math-derivative expr)))) (or (eq (car-safe res) 'calcFunc-deriv) (null res) @@ -344,9 +346,11 @@ (math-expr-subst res math-deriv-var deriv-value) res)))) -(defun calcFunc-tderiv (expr math-deriv-var &optional deriv-value math-deriv-symb) +(defun calcFunc-tderiv (expr deriv-var &optional deriv-value deriv-symb) (math-setup-declarations) - (let* ((math-deriv-total t) + (let* ((math-deriv-var deriv-var) + (math-deriv-symb deriv-symb) + (math-deriv-total t) (res (catch 'math-deriv (math-derivative expr)))) (or (eq (car-safe res) 'calcFunc-tderiv) (null res) @@ -357,175 +361,175 @@ res)))) (put 'calcFunc-inv\' 'math-derivative-1 - (function (lambda (u) (math-neg (math-div 1 (math-sqr u)))))) + (lambda (u) (math-neg (math-div 1 (math-sqr u))))) (put 'calcFunc-sqrt\' 'math-derivative-1 - (function (lambda (u) (math-div 1 (math-mul 2 (list 'calcFunc-sqrt u)))))) + (lambda (u) (math-div 1 (math-mul 2 (list 'calcFunc-sqrt u))))) (put 'calcFunc-deg\' 'math-derivative-1 - (function (lambda (u) (math-div-float '(float 18 1) (math-pi))))) + (lambda (_) (math-div-float '(float 18 1) (math-pi)))) (put 'calcFunc-rad\' 'math-derivative-1 - (function (lambda (u) (math-pi-over-180)))) + (lambda (_) (math-pi-over-180))) (put 'calcFunc-ln\' 'math-derivative-1 - (function (lambda (u) (math-div 1 u)))) + (lambda (u) (math-div 1 u))) (put 'calcFunc-log10\' 'math-derivative-1 - (function (lambda (u) - (math-div (math-div 1 (math-normalize '(calcFunc-ln 10))) - u)))) + (lambda (u) + (math-div (math-div 1 (math-normalize '(calcFunc-ln 10))) + u))) (put 'calcFunc-lnp1\' 'math-derivative-1 - (function (lambda (u) (math-div 1 (math-add u 1))))) + (lambda (u) (math-div 1 (math-add u 1)))) (put 'calcFunc-log\' 'math-derivative-2 - (function (lambda (x b) - (and (not (Math-zerop b)) - (let ((lnv (math-normalize - (list 'calcFunc-ln b)))) - (math-div 1 (math-mul lnv x))))))) + (lambda (x b) + (and (not (Math-zerop b)) + (let ((lnv (math-normalize + (list 'calcFunc-ln b)))) + (math-div 1 (math-mul lnv x)))))) (put 'calcFunc-log\'2 'math-derivative-2 - (function (lambda (x b) - (let ((lnv (list 'calcFunc-ln b))) - (math-neg (math-div (list 'calcFunc-log x b) - (math-mul lnv b))))))) + (lambda (x b) + (let ((lnv (list 'calcFunc-ln b))) + (math-neg (math-div (list 'calcFunc-log x b) + (math-mul lnv b)))))) (put 'calcFunc-exp\' 'math-derivative-1 - (function (lambda (u) (math-normalize (list 'calcFunc-exp u))))) + (lambda (u) (math-normalize (list 'calcFunc-exp u)))) (put 'calcFunc-expm1\' 'math-derivative-1 - (function (lambda (u) (math-normalize (list 'calcFunc-expm1 u))))) + (lambda (u) (math-normalize (list 'calcFunc-expm1 u)))) (put 'calcFunc-sin\' 'math-derivative-1 - (function (lambda (u) (math-to-radians-2 (math-normalize - (list 'calcFunc-cos u)) t)))) + (lambda (u) (math-to-radians-2 (math-normalize + (list 'calcFunc-cos u)) t))) (put 'calcFunc-cos\' 'math-derivative-1 - (function (lambda (u) (math-neg (math-to-radians-2 - (math-normalize - (list 'calcFunc-sin u)) t))))) + (lambda (u) (math-neg (math-to-radians-2 + (math-normalize + (list 'calcFunc-sin u)) t)))) (put 'calcFunc-tan\' 'math-derivative-1 - (function (lambda (u) (math-to-radians-2 - (math-sqr - (math-normalize - (list 'calcFunc-sec u))) t)))) + (lambda (u) (math-to-radians-2 + (math-sqr + (math-normalize + (list 'calcFunc-sec u))) t))) (put 'calcFunc-sec\' 'math-derivative-1 - (function (lambda (u) (math-to-radians-2 - (math-mul - (math-normalize - (list 'calcFunc-sec u)) - (math-normalize - (list 'calcFunc-tan u))) t)))) + (lambda (u) (math-to-radians-2 + (math-mul + (math-normalize + (list 'calcFunc-sec u)) + (math-normalize + (list 'calcFunc-tan u))) t))) (put 'calcFunc-csc\' 'math-derivative-1 - (function (lambda (u) (math-neg - (math-to-radians-2 - (math-mul - (math-normalize - (list 'calcFunc-csc u)) - (math-normalize - (list 'calcFunc-cot u))) t))))) + (lambda (u) (math-neg + (math-to-radians-2 + (math-mul + (math-normalize + (list 'calcFunc-csc u)) + (math-normalize + (list 'calcFunc-cot u))) t)))) (put 'calcFunc-cot\' 'math-derivative-1 - (function (lambda (u) (math-neg - (math-to-radians-2 - (math-sqr - (math-normalize - (list 'calcFunc-csc u))) t))))) + (lambda (u) (math-neg + (math-to-radians-2 + (math-sqr + (math-normalize + (list 'calcFunc-csc u))) t)))) (put 'calcFunc-arcsin\' 'math-derivative-1 - (function (lambda (u) - (math-from-radians-2 - (math-div 1 (math-normalize - (list 'calcFunc-sqrt - (math-sub 1 (math-sqr u))))) t)))) + (lambda (u) + (math-from-radians-2 + (math-div 1 (math-normalize + (list 'calcFunc-sqrt + (math-sub 1 (math-sqr u))))) t))) (put 'calcFunc-arccos\' 'math-derivative-1 - (function (lambda (u) - (math-from-radians-2 - (math-div -1 (math-normalize - (list 'calcFunc-sqrt - (math-sub 1 (math-sqr u))))) t)))) + (lambda (u) + (math-from-radians-2 + (math-div -1 (math-normalize + (list 'calcFunc-sqrt + (math-sub 1 (math-sqr u))))) t))) (put 'calcFunc-arctan\' 'math-derivative-1 - (function (lambda (u) (math-from-radians-2 - (math-div 1 (math-add 1 (math-sqr u))) t)))) + (lambda (u) (math-from-radians-2 + (math-div 1 (math-add 1 (math-sqr u))) t))) (put 'calcFunc-sinh\' 'math-derivative-1 - (function (lambda (u) (math-normalize (list 'calcFunc-cosh u))))) + (lambda (u) (math-normalize (list 'calcFunc-cosh u)))) (put 'calcFunc-cosh\' 'math-derivative-1 - (function (lambda (u) (math-normalize (list 'calcFunc-sinh u))))) + (lambda (u) (math-normalize (list 'calcFunc-sinh u)))) (put 'calcFunc-tanh\' 'math-derivative-1 - (function (lambda (u) (math-sqr - (math-normalize - (list 'calcFunc-sech u)))))) + (lambda (u) (math-sqr + (math-normalize + (list 'calcFunc-sech u))))) (put 'calcFunc-sech\' 'math-derivative-1 - (function (lambda (u) (math-neg - (math-mul - (math-normalize (list 'calcFunc-sech u)) - (math-normalize (list 'calcFunc-tanh u))))))) + (lambda (u) (math-neg + (math-mul + (math-normalize (list 'calcFunc-sech u)) + (math-normalize (list 'calcFunc-tanh u)))))) (put 'calcFunc-csch\' 'math-derivative-1 - (function (lambda (u) (math-neg - (math-mul - (math-normalize (list 'calcFunc-csch u)) - (math-normalize (list 'calcFunc-coth u))))))) + (lambda (u) (math-neg + (math-mul + (math-normalize (list 'calcFunc-csch u)) + (math-normalize (list 'calcFunc-coth u)))))) (put 'calcFunc-coth\' 'math-derivative-1 - (function (lambda (u) (math-neg - (math-sqr - (math-normalize - (list 'calcFunc-csch u))))))) + (lambda (u) (math-neg + (math-sqr + (math-normalize + (list 'calcFunc-csch u)))))) (put 'calcFunc-arcsinh\' 'math-derivative-1 - (function (lambda (u) - (math-div 1 (math-normalize - (list 'calcFunc-sqrt - (math-add (math-sqr u) 1))))))) + (lambda (u) + (math-div 1 (math-normalize + (list 'calcFunc-sqrt + (math-add (math-sqr u) 1)))))) (put 'calcFunc-arccosh\' 'math-derivative-1 - (function (lambda (u) - (math-div 1 (math-normalize - (list 'calcFunc-sqrt - (math-add (math-sqr u) -1))))))) + (lambda (u) + (math-div 1 (math-normalize + (list 'calcFunc-sqrt + (math-add (math-sqr u) -1)))))) (put 'calcFunc-arctanh\' 'math-derivative-1 - (function (lambda (u) (math-div 1 (math-sub 1 (math-sqr u)))))) + (lambda (u) (math-div 1 (math-sub 1 (math-sqr u))))) (put 'calcFunc-bern\'2 'math-derivative-2 - (function (lambda (n x) - (math-mul n (list 'calcFunc-bern (math-add n -1) x))))) + (lambda (n x) + (math-mul n (list 'calcFunc-bern (math-add n -1) x)))) (put 'calcFunc-euler\'2 'math-derivative-2 - (function (lambda (n x) - (math-mul n (list 'calcFunc-euler (math-add n -1) x))))) + (lambda (n x) + (math-mul n (list 'calcFunc-euler (math-add n -1) x)))) (put 'calcFunc-gammag\'2 'math-derivative-2 - (function (lambda (a x) (math-deriv-gamma a x 1)))) + (lambda (a x) (math-deriv-gamma a x 1))) (put 'calcFunc-gammaG\'2 'math-derivative-2 - (function (lambda (a x) (math-deriv-gamma a x -1)))) + (lambda (a x) (math-deriv-gamma a x -1))) (put 'calcFunc-gammaP\'2 'math-derivative-2 - (function (lambda (a x) (math-deriv-gamma a x - (math-div - 1 (math-normalize - (list 'calcFunc-gamma - a))))))) + (lambda (a x) (math-deriv-gamma a x + (math-div + 1 (math-normalize + (list 'calcFunc-gamma + a)))))) (put 'calcFunc-gammaQ\'2 'math-derivative-2 - (function (lambda (a x) (math-deriv-gamma a x - (math-div - -1 (math-normalize - (list 'calcFunc-gamma - a))))))) + (lambda (a x) (math-deriv-gamma a x + (math-div + -1 (math-normalize + (list 'calcFunc-gamma + a)))))) (defun math-deriv-gamma (a x scale) (math-mul scale @@ -533,13 +537,13 @@ (list 'calcFunc-exp (math-neg x))))) (put 'calcFunc-betaB\' 'math-derivative-3 - (function (lambda (x a b) (math-deriv-beta x a b 1)))) + (lambda (x a b) (math-deriv-beta x a b 1))) (put 'calcFunc-betaI\' 'math-derivative-3 - (function (lambda (x a b) (math-deriv-beta x a b - (math-div - 1 (list 'calcFunc-beta - a b)))))) + (lambda (x a b) (math-deriv-beta x a b + (math-div + 1 (list 'calcFunc-beta + a b))))) (defun math-deriv-beta (x a b scale) (math-mul (math-mul (math-pow x (math-add a -1)) @@ -547,101 +551,96 @@ scale)) (put 'calcFunc-erf\' 'math-derivative-1 - (function (lambda (x) (math-div 2 - (math-mul (list 'calcFunc-exp - (math-sqr x)) - (if calc-symbolic-mode - '(calcFunc-sqrt - (var pi var-pi)) - (math-sqrt-pi))))))) + (lambda (x) (math-div 2 + (math-mul (list 'calcFunc-exp + (math-sqr x)) + (if calc-symbolic-mode + '(calcFunc-sqrt + (var pi var-pi)) + (math-sqrt-pi)))))) (put 'calcFunc-erfc\' 'math-derivative-1 - (function (lambda (x) (math-div -2 - (math-mul (list 'calcFunc-exp - (math-sqr x)) - (if calc-symbolic-mode - '(calcFunc-sqrt - (var pi var-pi)) - (math-sqrt-pi))))))) + (lambda (x) (math-div -2 + (math-mul (list 'calcFunc-exp + (math-sqr x)) + (if calc-symbolic-mode + '(calcFunc-sqrt + (var pi var-pi)) + (math-sqrt-pi)))))) (put 'calcFunc-besJ\'2 'math-derivative-2 - (function (lambda (v z) (math-div (math-sub (list 'calcFunc-besJ - (math-add v -1) - z) - (list 'calcFunc-besJ - (math-add v 1) - z)) - 2)))) + (lambda (v z) (math-div (math-sub (list 'calcFunc-besJ + (math-add v -1) + z) + (list 'calcFunc-besJ + (math-add v 1) + z)) + 2))) (put 'calcFunc-besY\'2 'math-derivative-2 - (function (lambda (v z) (math-div (math-sub (list 'calcFunc-besY - (math-add v -1) - z) - (list 'calcFunc-besY - (math-add v 1) - z)) - 2)))) + (lambda (v z) (math-div (math-sub (list 'calcFunc-besY + (math-add v -1) + z) + (list 'calcFunc-besY + (math-add v 1) + z)) + 2))) (put 'calcFunc-sum 'math-derivative-n - (function - (lambda (expr) - (if (math-expr-contains (cons 'vec (cdr (cdr expr))) math-deriv-var) - (throw 'math-deriv nil) - (cons 'calcFunc-sum - (cons (math-derivative (nth 1 expr)) - (cdr (cdr expr)))))))) + (lambda (expr) + (if (math-expr-contains (cons 'vec (cdr (cdr expr))) math-deriv-var) + (throw 'math-deriv nil) + (cons 'calcFunc-sum + (cons (math-derivative (nth 1 expr)) + (cdr (cdr expr))))))) (put 'calcFunc-prod 'math-derivative-n - (function - (lambda (expr) - (if (math-expr-contains (cons 'vec (cdr (cdr expr))) math-deriv-var) - (throw 'math-deriv nil) - (math-mul expr - (cons 'calcFunc-sum - (cons (math-div (math-derivative (nth 1 expr)) - (nth 1 expr)) - (cdr (cdr expr))))))))) + (lambda (expr) + (if (math-expr-contains (cons 'vec (cdr (cdr expr))) math-deriv-var) + (throw 'math-deriv nil) + (math-mul expr + (cons 'calcFunc-sum + (cons (math-div (math-derivative (nth 1 expr)) + (nth 1 expr)) + (cdr (cdr expr)))))))) (put 'calcFunc-integ 'math-derivative-n - (function - (lambda (expr) - (if (= (length expr) 3) - (if (equal (nth 2 expr) math-deriv-var) - (nth 1 expr) - (math-normalize - (list 'calcFunc-integ - (math-derivative (nth 1 expr)) - (nth 2 expr)))) - (if (= (length expr) 5) - (let ((lower (math-expr-subst (nth 1 expr) (nth 2 expr) - (nth 3 expr))) - (upper (math-expr-subst (nth 1 expr) (nth 2 expr) - (nth 4 expr)))) - (math-add (math-sub (math-mul upper - (math-derivative (nth 4 expr))) - (math-mul lower - (math-derivative (nth 3 expr)))) - (if (equal (nth 2 expr) math-deriv-var) - 0 - (math-normalize - (list 'calcFunc-integ - (math-derivative (nth 1 expr)) (nth 2 expr) - (nth 3 expr) (nth 4 expr))))))))))) + (lambda (expr) + (if (= (length expr) 3) + (if (equal (nth 2 expr) math-deriv-var) + (nth 1 expr) + (math-normalize + (list 'calcFunc-integ + (math-derivative (nth 1 expr)) + (nth 2 expr)))) + (if (= (length expr) 5) + (let ((lower (math-expr-subst (nth 1 expr) (nth 2 expr) + (nth 3 expr))) + (upper (math-expr-subst (nth 1 expr) (nth 2 expr) + (nth 4 expr)))) + (math-add (math-sub (math-mul upper + (math-derivative (nth 4 expr))) + (math-mul lower + (math-derivative (nth 3 expr)))) + (if (equal (nth 2 expr) math-deriv-var) + 0 + (math-normalize + (list 'calcFunc-integ + (math-derivative (nth 1 expr)) (nth 2 expr) + (nth 3 expr) (nth 4 expr)))))))))) (put 'calcFunc-if 'math-derivative-n - (function - (lambda (expr) - (and (= (length expr) 4) - (list 'calcFunc-if (nth 1 expr) - (math-derivative (nth 2 expr)) - (math-derivative (nth 3 expr))))))) + (lambda (expr) + (and (= (length expr) 4) + (list 'calcFunc-if (nth 1 expr) + (math-derivative (nth 2 expr)) + (math-derivative (nth 3 expr)))))) (put 'calcFunc-subscr 'math-derivative-n - (function - (lambda (expr) - (and (= (length expr) 3) - (list 'calcFunc-subscr (nth 1 expr) - (math-derivative (nth 2 expr))))))) + (lambda (expr) + (and (= (length expr) 3) + (list 'calcFunc-subscr (nth 1 expr) + (math-derivative (nth 2 expr)))))) (defvar math-integ-var '(var X ---)) @@ -1011,11 +1010,10 @@ res '(calcFunc-integsubst))) (and (memq (length part) '(3 4 5)) (let ((parts (mapcar - (function - (lambda (x) - (math-expr-subst - x (nth 2 part) - math-integ-var))) + (lambda (x) + (math-expr-subst + x (nth 2 part) + math-integ-var)) (cdr part)))) (math-integrate-by-substitution expr (car parts) t @@ -1079,8 +1077,9 @@ ;; math-integ-try-substitutions. (defvar math-integ-expr) -(defun math-do-integral-methods (math-integ-expr) - (let ((math-so-far math-integ-var-list-list) +(defun math-do-integral-methods (integ-expr) + (let ((math-integ-expr integ-expr) + (math-so-far math-integ-var-list-list) rat-in) ;; Integration by substitution, for various likely sub-expressions. @@ -1195,10 +1194,11 @@ (defvar math-good-parts) -(defun math-integ-try-parts (expr &optional math-good-parts) +(defun math-integ-try-parts (expr &optional good-parts) ;; Integration by parts: ;; integ(f(x) g(x),x) = f(x) h(x) - integ(h(x) f'(x),x) ;; where h(x) = integ(g(x),x). + (let ((math-good-parts good-parts)) (or (let ((exp (calcFunc-expand expr))) (and (not (equal exp expr)) (math-integral exp))) @@ -1219,14 +1219,14 @@ (and (eq (car expr) '^) (math-integrate-by-parts (math-pow (nth 1 expr) (math-sub (nth 2 expr) 1)) - (nth 1 expr))))) + (nth 1 expr)))))) (defun math-integrate-by-parts (u vprime) (let ((math-integ-level (if (or math-good-parts (math-polynomial-p u math-integ-var)) math-integ-level (1- math-integ-level))) - (math-doing-parts t) + ;; (math-doing-parts t) ;Unused v temp) (and (>= math-integ-level 0) (unwind-protect @@ -1510,7 +1510,7 @@ var low high) (nth 2 (nth 2 expr)))) ((eq (car-safe expr) 'vec) - (cons 'vec (mapcar (function (lambda (x) (calcFunc-integ x var low high))) + (cons 'vec (mapcar (lambda (x) (calcFunc-integ x var low high)) (cdr expr)))) (t (let ((state (list calc-angle-mode @@ -1532,7 +1532,7 @@ (math-any-substs t) (math-enable-subst nil) (math-prev-parts-v nil) - (math-doing-parts nil) + ;; (math-doing-parts nil) ;Unused (math-good-parts nil) (res (if trace-buffer @@ -1883,7 +1883,10 @@ (defvar calc-high) (defvar math-var) -(defun calcFunc-table (expr math-var &optional calc-low calc-high step) +(defun calcFunc-table (expr var &optional low high step) + (let ((math-var var) + (calc-high high) + (calc-low low)) (or calc-low (setq calc-low '(neg (var inf var-inf)) calc-high '(var inf var-inf))) (or calc-high (setq calc-high calc-low calc-low 1)) @@ -1894,8 +1897,7 @@ (let ((known (+ (if (Math-objectp calc-low) 1 0) (if (Math-objectp calc-high) 1 0) (if (or (null step) (Math-objectp step)) 1 0))) - (count '(var inf var-inf)) - vec) + (count '(var inf var-inf))) ;; vec (or (= known 2) ; handy optimization (equal calc-high '(var inf var-inf)) (progn @@ -1906,6 +1908,7 @@ (setq count (math-trunc count))))) (if (Math-negp count) (setq count -1)) + (defvar var-DUMMY) (if (integerp count) (let ((var-DUMMY nil) (vec math-tabulate-initial) @@ -1939,7 +1942,7 @@ (and (not (and (equal calc-low '(neg (var inf var-inf))) (equal calc-high '(var inf var-inf)))) (list calc-low calc-high)) - (and step (list step)))))) + (and step (list step))))))) (defun math-scan-for-limits (x) (cond ((Math-primp x)) @@ -1951,8 +1954,10 @@ (high-val (math-solve-for (nth 2 x) (1- (length (nth 1 x))) math-var nil)) temp) - (and low-val (math-realp low-val) - high-val (math-realp high-val)) + ;; FIXME: The below is a no-op, but I suspect its result + ;; was meant to be used, tho I don't know what for. + ;; (and low-val (math-realp low-val) + ;; high-val (math-realp high-val)) (and (Math-lessp high-val low-val) (setq temp low-val low-val high-val high-val temp)) (setq calc-low (math-max calc-low (math-ceiling low-val)) @@ -2361,8 +2366,11 @@ (defvar math-try-solve-sign) (defun math-try-solve-for - (math-solve-lhs math-solve-rhs &optional math-try-solve-sign no-poly) - (let (math-t1 math-t2 math-t3) + (solve-lhs solve-rhs &optional try-solve-sign no-poly) + (let ((math-solve-lhs solve-lhs) + (math-solve-rhs solve-rhs) + (math-try-solve-sign try-solve-sign) + math-t1 math-t2 math-t3) (cond ((equal math-solve-lhs math-solve-var) (setq math-solve-sign math-try-solve-sign) (if (eq math-solve-full 'all) @@ -2721,32 +2729,34 @@ (cons 'vec d) (math-reject-arg expr "Expected a polynomial")))) -(defun math-decompose-poly (math-solve-lhs math-solve-var degree sub-rhs) - (let ((math-solve-rhs (or sub-rhs 1)) +(defun math-decompose-poly (solve-lhs solve-var degree sub-rhs) + (let ((math-solve-lhs solve-lhs) + (math-solve-var solve-var) + (math-solve-rhs (or sub-rhs 1)) math-t1 math-t2 math-t3) (setq math-t2 (math-polynomial-base math-solve-lhs - (function - (lambda (math-solve-b) - (let ((math-poly-neg-powers '(1)) - (math-poly-mult-powers nil) - (math-poly-frac-powers 1) - (math-poly-exp-base t)) - (and (not (equal math-solve-b math-solve-lhs)) - (or (not (memq (car-safe math-solve-b) '(+ -))) sub-rhs) - (setq math-t3 '(1 0) math-t2 1 - math-t1 (math-is-polynomial math-solve-lhs - math-solve-b 50)) - (if (and (equal math-poly-neg-powers '(1)) - (memq math-poly-mult-powers '(nil 1)) - (eq math-poly-frac-powers 1) - sub-rhs) - (setq math-t1 (cons (math-sub (car math-t1) math-solve-rhs) - (cdr math-t1))) - (math-solve-poly-funny-powers sub-rhs)) - (math-solve-crunch-poly degree) - (or (math-expr-contains math-solve-b math-solve-var) - (math-expr-contains (car math-t3) math-solve-var)))))))) + (lambda (solve-b) + (let ((math-solve-b solve-b) + (math-poly-neg-powers '(1)) + (math-poly-mult-powers nil) + (math-poly-frac-powers 1) + (math-poly-exp-base t)) + (and (not (equal math-solve-b math-solve-lhs)) + (or (not (memq (car-safe math-solve-b) '(+ -))) sub-rhs) + (setq math-t3 '(1 0) math-t2 1 + math-t1 (math-is-polynomial math-solve-lhs + math-solve-b 50)) + (if (and (equal math-poly-neg-powers '(1)) + (memq math-poly-mult-powers '(nil 1)) + (eq math-poly-frac-powers 1) + sub-rhs) + (setq math-t1 (cons (math-sub (car math-t1) math-solve-rhs) + (cdr math-t1))) + (math-solve-poly-funny-powers sub-rhs)) + (math-solve-crunch-poly degree) + (or (math-expr-contains math-solve-b math-solve-var) + (math-expr-contains (car math-t3) math-solve-var))))))) (if math-t2 (list (math-pow math-t2 (car math-t3)) (cons 'vec math-t1) @@ -2964,7 +2974,7 @@ (math-poly-integer-root (car roots)) (setq roots (cdr roots))) (list math-int-factors (nreverse math-int-coefs) math-int-scale)) - (let ((vec nil) res) + (let ((vec nil)) ;; res (while roots (let ((root (car roots)) (math-solve-full (and math-solve-full 'all))) @@ -3109,7 +3119,7 @@ (iters 0) (m (1- (length p))) (try-newt (not polish)) - (tried-newt nil) + ;; (tried-newt nil) b d f x1 dx dxold) (while (and (or (< (setq iters (1+ iters)) 50) @@ -3146,7 +3156,7 @@ (math-lessp (math-abs-approx dx) (calcFunc-scf (math-abs-approx x) -3))) (let ((newt (math-poly-newton-root p x1 7))) - (setq tried-newt t + (setq ;; tried-newt t try-newt nil) (if (math-zerop (cdr newt)) (setq x (car newt) x1 x) @@ -3160,7 +3170,8 @@ (math-nearly-equal x x1)))) (let ((cdx (math-abs-approx dx))) (setq x x1 - tried-newt nil) + ;; tried-newt nil + ) (prog1 (or (<= iters 6) (math-lessp cdx dxold) @@ -3227,7 +3238,9 @@ ;; and math-solve-system-rec, but is used by math-solve-system-subst. (defvar math-solve-simplifying) -(defun math-solve-system (exprs math-solve-vars math-solve-full) +(defun math-solve-system (exprs solve-vars solve-full) + (let ((math-solve-vars solve-vars) + (math-solve-full solve-full)) (setq exprs (mapcar 'list (if (Math-vectorp exprs) (cdr exprs) (list exprs))) @@ -3237,18 +3250,18 @@ (or (let ((math-solve-simplifying nil)) (math-solve-system-rec exprs math-solve-vars nil)) (let ((math-solve-simplifying t)) - (math-solve-system-rec exprs math-solve-vars nil)))) + (math-solve-system-rec exprs math-solve-vars nil))))) -;;; The following backtracking solver works by choosing a variable -;;; and equation, and trying to solve the equation for the variable. -;;; If it succeeds it calls itself recursively with that variable and -;;; equation removed from their respective lists, and with the solution -;;; added to solns as well as being substituted into all existing -;;; equations. The algorithm terminates when any solution path -;;; manages to remove all the variables from var-list. +;; The following backtracking solver works by choosing a variable +;; and equation, and trying to solve the equation for the variable. +;; If it succeeds it calls itself recursively with that variable and +;; equation removed from their respective lists, and with the solution +;; added to solns as well as being substituted into all existing +;; equations. The algorithm terminates when any solution path +;; manages to remove all the variables from `var-list'. -;;; To support calcFunc-roots, entries in eqn-list and solns are -;;; actually lists of equations. +;; To support calcFunc-roots, entries in eqn-list and solns are +;; actually lists of equations. ;; The variables math-solve-system-res and math-solve-system-vv are ;; local to math-solve-system-rec, but are used by math-solve-system-subst. @@ -3306,12 +3319,11 @@ (delq (car v) (copy-sequence var-list)) (let ((math-solve-simplifying nil) (s (mapcar - (function - (lambda (x) - (cons - (car x) - (math-solve-system-subst - (cdr x))))) + (lambda (x) + (cons + (car x) + (math-solve-system-subst + (cdr x)))) solns))) (if elim s @@ -3327,35 +3339,33 @@ ;; Eliminated all variables, so now put solution into the proper format. (setq solns (sort solns - (function - (lambda (x y) - (not (memq (car x) (memq (car y) math-solve-vars))))))) + (lambda (x y) + (not (memq (car x) (memq (car y) math-solve-vars)))))) (if (eq math-solve-full 'all) (math-transpose (math-normalize (cons 'vec (if solns - (mapcar (function (lambda (x) (cons 'vec (cdr x)))) solns) - (mapcar (function (lambda (x) (cons 'vec x))) eqn-list))))) + (mapcar (lambda (x) (cons 'vec (cdr x))) solns) + (mapcar (lambda (x) (cons 'vec x)) eqn-list))))) (math-normalize (cons 'vec (if solns - (mapcar (function (lambda (x) (cons 'calcFunc-eq x))) solns) - (mapcar 'car eqn-list))))))) + (mapcar (lambda (x) (cons 'calcFunc-eq x)) solns) + (mapcar #'car eqn-list))))))) (defun math-solve-system-subst (x) ; uses "res" and "v" (let ((accum nil) (res2 math-solve-system-res)) (while x (setq accum (nconc accum - (mapcar (function - (lambda (r) - (if math-solve-simplifying - (math-simplify - (math-expr-subst - (car x) math-solve-system-vv r)) - (math-expr-subst - (car x) math-solve-system-vv r)))) + (mapcar (lambda (r) + (if math-solve-simplifying + (math-simplify + (math-expr-subst + (car x) math-solve-system-vv r)) + (math-expr-subst + (car x) math-solve-system-vv r))) (car res2))) x (cdr x) res2 (cdr res2))) @@ -3437,10 +3447,12 @@ (if (memq (car expr) '(* /)) (math-looks-evenp (nth 1 expr))))) -(defun math-solve-for (lhs rhs math-solve-var math-solve-full &optional sign) - (if (math-expr-contains rhs math-solve-var) - (math-solve-for (math-sub lhs rhs) 0 math-solve-var math-solve-full) - (and (math-expr-contains lhs math-solve-var) +(defun math-solve-for (lhs rhs solve-var solve-full &optional sign) + (let ((math-solve-var solve-var) + (math-solve-full solve-full)) + (if (math-expr-contains rhs solve-var) + (math-solve-for (math-sub lhs rhs) 0 solve-var solve-full) + (and (math-expr-contains lhs solve-var) (math-with-extra-prec 1 (let* ((math-poly-base-variable math-solve-var) (res (math-try-solve-for lhs rhs sign))) @@ -3449,11 +3461,10 @@ (let ((old-len (length res)) new-len) (setq res (delq nil - (mapcar (function - (lambda (x) - (and (not (memq (car-safe x) - '(cplx polar))) - x))) + (mapcar (lambda (x) + (and (not (memq (car-safe x) + '(cplx polar))) + x)) res)) new-len (length res)) (if (< new-len old-len) @@ -3462,7 +3473,7 @@ (format "*Omitted %d complex solutions" (- old-len new-len))))))) - res))))) + res)))))) (defun math-solve-eqn (expr var full) (if (memq (car-safe expr) '(calcFunc-neq calcFunc-lt calcFunc-gt @@ -3523,119 +3534,119 @@ (put 'calcFunc-inv 'math-inverse - (function (lambda (x) (math-div 1 x)))) + (lambda (x) (math-div 1 x))) (put 'calcFunc-inv 'math-inverse-sign -1) (put 'calcFunc-sqrt 'math-inverse - (function (lambda (x) (math-sqr x)))) + (lambda (x) (math-sqr x))) (put 'calcFunc-conj 'math-inverse - (function (lambda (x) (list 'calcFunc-conj x)))) + (lambda (x) (list 'calcFunc-conj x))) (put 'calcFunc-abs 'math-inverse - (function (lambda (x) (math-solve-get-sign x)))) + (lambda (x) (math-solve-get-sign x))) (put 'calcFunc-deg 'math-inverse - (function (lambda (x) (list 'calcFunc-rad x)))) + (lambda (x) (list 'calcFunc-rad x))) (put 'calcFunc-deg 'math-inverse-sign 1) (put 'calcFunc-rad 'math-inverse - (function (lambda (x) (list 'calcFunc-deg x)))) + (lambda (x) (list 'calcFunc-deg x))) (put 'calcFunc-rad 'math-inverse-sign 1) (put 'calcFunc-ln 'math-inverse - (function (lambda (x) (list 'calcFunc-exp x)))) + (lambda (x) (list 'calcFunc-exp x))) (put 'calcFunc-ln 'math-inverse-sign 1) (put 'calcFunc-log10 'math-inverse - (function (lambda (x) (list 'calcFunc-exp10 x)))) + (lambda (x) (list 'calcFunc-exp10 x))) (put 'calcFunc-log10 'math-inverse-sign 1) (put 'calcFunc-lnp1 'math-inverse - (function (lambda (x) (list 'calcFunc-expm1 x)))) + (lambda (x) (list 'calcFunc-expm1 x))) (put 'calcFunc-lnp1 'math-inverse-sign 1) (put 'calcFunc-exp 'math-inverse - (function (lambda (x) (math-add (math-normalize (list 'calcFunc-ln x)) - (math-mul 2 - (math-mul '(var pi var-pi) - (math-solve-get-int - '(var i var-i)))))))) + (lambda (x) (math-add (math-normalize (list 'calcFunc-ln x)) + (math-mul 2 + (math-mul '(var pi var-pi) + (math-solve-get-int + '(var i var-i))))))) (put 'calcFunc-exp 'math-inverse-sign 1) (put 'calcFunc-expm1 'math-inverse - (function (lambda (x) (math-add (math-normalize (list 'calcFunc-lnp1 x)) - (math-mul 2 - (math-mul '(var pi var-pi) - (math-solve-get-int - '(var i var-i)))))))) + (lambda (x) (math-add (math-normalize (list 'calcFunc-lnp1 x)) + (math-mul 2 + (math-mul '(var pi var-pi) + (math-solve-get-int + '(var i var-i))))))) (put 'calcFunc-expm1 'math-inverse-sign 1) (put 'calcFunc-sin 'math-inverse - (function (lambda (x) (let ((n (math-solve-get-int 1))) - (math-add (math-mul (math-normalize - (list 'calcFunc-arcsin x)) - (math-pow -1 n)) - (math-mul (math-half-circle t) - n)))))) + (lambda (x) (let ((n (math-solve-get-int 1))) + (math-add (math-mul (math-normalize + (list 'calcFunc-arcsin x)) + (math-pow -1 n)) + (math-mul (math-half-circle t) + n))))) (put 'calcFunc-cos 'math-inverse - (function (lambda (x) (math-add (math-solve-get-sign - (math-normalize - (list 'calcFunc-arccos x))) - (math-solve-get-int - (math-full-circle t)))))) + (lambda (x) (math-add (math-solve-get-sign + (math-normalize + (list 'calcFunc-arccos x))) + (math-solve-get-int + (math-full-circle t))))) (put 'calcFunc-tan 'math-inverse - (function (lambda (x) (math-add (math-normalize (list 'calcFunc-arctan x)) - (math-solve-get-int - (math-half-circle t)))))) + (lambda (x) (math-add (math-normalize (list 'calcFunc-arctan x)) + (math-solve-get-int + (math-half-circle t))))) (put 'calcFunc-arcsin 'math-inverse - (function (lambda (x) (math-normalize (list 'calcFunc-sin x))))) + (lambda (x) (math-normalize (list 'calcFunc-sin x)))) (put 'calcFunc-arccos 'math-inverse - (function (lambda (x) (math-normalize (list 'calcFunc-cos x))))) + (lambda (x) (math-normalize (list 'calcFunc-cos x)))) (put 'calcFunc-arctan 'math-inverse - (function (lambda (x) (math-normalize (list 'calcFunc-tan x))))) + (lambda (x) (math-normalize (list 'calcFunc-tan x)))) (put 'calcFunc-sinh 'math-inverse - (function (lambda (x) (let ((n (math-solve-get-int 1))) - (math-add (math-mul (math-normalize - (list 'calcFunc-arcsinh x)) - (math-pow -1 n)) - (math-mul (math-half-circle t) - (math-mul - '(var i var-i) - n))))))) + (lambda (x) (let ((n (math-solve-get-int 1))) + (math-add (math-mul (math-normalize + (list 'calcFunc-arcsinh x)) + (math-pow -1 n)) + (math-mul (math-half-circle t) + (math-mul + '(var i var-i) + n)))))) (put 'calcFunc-sinh 'math-inverse-sign 1) (put 'calcFunc-cosh 'math-inverse - (function (lambda (x) (math-add (math-solve-get-sign - (math-normalize - (list 'calcFunc-arccosh x))) - (math-mul (math-full-circle t) - (math-solve-get-int - '(var i var-i))))))) + (lambda (x) (math-add (math-solve-get-sign + (math-normalize + (list 'calcFunc-arccosh x))) + (math-mul (math-full-circle t) + (math-solve-get-int + '(var i var-i)))))) (put 'calcFunc-tanh 'math-inverse - (function (lambda (x) (math-add (math-normalize - (list 'calcFunc-arctanh x)) - (math-mul (math-half-circle t) - (math-solve-get-int - '(var i var-i))))))) + (lambda (x) (math-add (math-normalize + (list 'calcFunc-arctanh x)) + (math-mul (math-half-circle t) + (math-solve-get-int + '(var i var-i)))))) (put 'calcFunc-tanh 'math-inverse-sign 1) (put 'calcFunc-arcsinh 'math-inverse - (function (lambda (x) (math-normalize (list 'calcFunc-sinh x))))) + (lambda (x) (math-normalize (list 'calcFunc-sinh x)))) (put 'calcFunc-arcsinh 'math-inverse-sign 1) (put 'calcFunc-arccosh 'math-inverse - (function (lambda (x) (math-normalize (list 'calcFunc-cosh x))))) + (lambda (x) (math-normalize (list 'calcFunc-cosh x)))) (put 'calcFunc-arctanh 'math-inverse - (function (lambda (x) (math-normalize (list 'calcFunc-tanh x))))) + (lambda (x) (math-normalize (list 'calcFunc-tanh x)))) (put 'calcFunc-arctanh 'math-inverse-sign 1) diff --git a/lisp/calc/calcalg3.el b/lisp/calc/calcalg3.el index a914b8aec40..ee3ae0a4c1f 100644 --- a/lisp/calc/calcalg3.el +++ b/lisp/calc/calcalg3.el @@ -1,4 +1,4 @@ -;;; calcalg3.el --- more algebraic functions for Calc +;;; calcalg3.el --- more algebraic functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -120,18 +120,24 @@ (defvar calc-curve-fit-history nil "History for calc-curve-fit.") -(defun calc-curve-fit (arg &optional calc-curve-model - calc-curve-coefnames calc-curve-varnames) +(defvar calc-graph-no-auto-view) +(defvar calc-fit-to-trail nil) + +(defun calc-curve-fit (arg &optional curve-model + curve-coefnames curve-varnames) (interactive "P") (calc-slow-wrapper (setq calc-aborted-prefix nil) - (let ((func (if (calc-is-inverse) 'calcFunc-xfit + (let ((calc-curve-model curve-model) + (calc-curve-coefnames curve-coefnames) + (calc-curve-varnames curve-varnames) + (func (if (calc-is-inverse) 'calcFunc-xfit (if (calc-is-hyperbolic) 'calcFunc-efit 'calcFunc-fit))) key (which 0) (nonlinear nil) (plot nil) - n calc-curve-nvars temp data + n calc-curve-nvars data ;; temp (homog nil) (msgs '( "(Press ? for help)" "1 = linear or multilinear" @@ -321,7 +327,7 @@ (calc-get-fit-variables 1 (1- (length calc-curve-coefnames)) (and homog 1))) ((memq key '(?\$ ?\' ?u ?U)) - (let* ((defvars nil) + (let* (;; (defvars nil) (record-entry nil)) (if (eq key ?\') (let* ((calc-dollar-values calc-arg-values) @@ -470,17 +476,19 @@ (setq defv (calc-invent-independent-variables nv))) (or defc (setq defc (calc-invent-parameter-variables nc defv))) - (let ((vars (read-string (format "Fitting variables (default %s; %s): " - (mapconcat 'symbol-name - (mapcar (function (lambda (v) - (nth 1 v))) - defv) - ",") - (mapconcat 'symbol-name - (mapcar (function (lambda (v) - (nth 1 v))) - defc) - ",")))) + (let ((vars (read-string (format-prompt + "Fitting variables" + (format "%s; %s" + (mapconcat 'symbol-name + (mapcar (lambda (v) + (nth 1 v)) + defv) + ",") + (mapconcat 'symbol-name + (mapcar (lambda (v) + (nth 1 v)) + defc) + ","))))) (coefs nil)) (setq vars (if (string-match "\\[" vars) (math-read-expr vars) @@ -706,7 +714,7 @@ "*Unable to find a sign change in this interval")))) ;;; "rtbis" (but we should be using Brent's method) -(defun math-bisect-root (expr low vlow high vhigh) +(defun math-bisect-root (expr low _vlow high vhigh) (let ((step (math-sub-float high low)) (pos (Math-posp vhigh)) var-DUMMY @@ -724,7 +732,8 @@ (setq high mid vhigh vmid) (setq low mid - vlow vmid))) + ;; vlow vmid + ))) (list 'vec mid vmid))) ;;; "mnewt" @@ -756,7 +765,8 @@ (list 'vec next expr-val)))) -(defun math-find-root (expr var guess math-root-widen) +(defun math-find-root (expr var guess root-widen) + (let ((math-root-widen root-widen)) (if (eq (car-safe expr) 'vec) (let ((n (1- (length expr))) (calc-symbolic-mode nil) @@ -869,7 +879,7 @@ (not (Math-numberp vlow)) (not (Math-numberp vhigh))) (math-search-root expr deriv low vlow high vhigh) - (math-bisect-root expr low vlow high vhigh)))))))))) + (math-bisect-root expr low vlow high vhigh))))))))))) (defun calcFunc-root (expr var guess) (math-find-root expr var guess nil)) @@ -1017,7 +1027,7 @@ math-min-or-max)))))) ;;; "brent" -(defun math-brent-min (expr prec a va x vx b vb) +(defun math-brent-min (expr prec a _va x vx b _vb) (let ((iters (+ 20 (* 5 prec))) (w x) (vw vx) @@ -1179,7 +1189,7 @@ (list 'calcFunc-mrow '(var line-p line-p) (1+ m))))) (math-evaluate-expr expr))) -(defun math-line-min (f1dim line-p line-xi n prec) +(defun math-line-min (f1dim line-p line-xi _n prec) (let* ((var-DUMMY nil) (expr (math-evaluate-expr f1dim)) (params (math-widen-min expr '(float 0 0) '(float 1 0))) @@ -1193,7 +1203,7 @@ (n 0) (var-DUMMY nil) (isvec (math-vectorp var)) - g guesses) + guesses) ;; g (or (math-vectorp var) (setq var (list 'vec var))) (or (math-vectorp guess) @@ -1326,7 +1336,7 @@ (or (> (length (nth 1 data)) 2) (math-reject-arg data "*Too few data points")) (if (and (math-vectorp x) (or (math-constp x) math-expand-formulas)) - (cons 'vec (mapcar (function (lambda (x) (calcFunc-polint data x))) + (cons 'vec (mapcar (lambda (x) (calcFunc-polint data x)) (cdr x))) (or (math-objectp x) math-expand-formulas (math-reject-arg x 'objectp)) (math-with-extra-prec 2 @@ -1342,7 +1352,7 @@ (or (> (length (nth 1 data)) 2) (math-reject-arg data "*Too few data points")) (if (and (math-vectorp x) (or (math-constp x) math-expand-formulas)) - (cons 'vec (mapcar (function (lambda (x) (calcFunc-ratint data x))) + (cons 'vec (mapcar (lambda (x) (calcFunc-ratint data x)) (cdr x))) (or (math-objectp x) math-expand-formulas (math-reject-arg x 'objectp)) (math-with-extra-prec 2 @@ -1491,7 +1501,8 @@ (defun math-ninteg-midpoint (expr lo hi mode) ; uses "math-ninteg-temp" (if (eq mode 'inf) - (let ((math-infinite-mode t) temp) + (let (;; (math-infinite-mode t) ;Unused! + temp) (setq temp (math-div 1 lo) lo (math-div 1 hi) hi temp))) @@ -1545,7 +1556,6 @@ (setq math-dummy-counter (1+ math-dummy-counter)))) (defvar math-in-fit 0) -(defvar calc-fit-to-trail nil) (defun calcFunc-fit (expr vars &optional coefs data) (let ((math-in-fit 10)) @@ -1571,6 +1581,7 @@ (defvar math-fit-new-coefs) (defun math-general-fit (expr vars coefs data mode) + (defvar var-YVAL) (defvar var-YVALX) (let ((calc-simplify-mode nil) (math-dummy-counter math-dummy-counter) (math-in-fit 1) @@ -1589,7 +1600,7 @@ (weights nil) (var-YVAL nil) (var-YVALX nil) covar beta - n nn m mm v dummy p) + n m mm v dummy p) ;; nn ;; Validate and parse arguments. (or data @@ -1685,7 +1696,7 @@ (isigsq 1) (xvals (make-vector mm 0)) (i 0) - j k xval yval sigmasqr wt covj covjk covk betaj lud) + j k xval yval sigmasqr wt covj covjk covk betaj) ;; lud (while (<= (setq i (1+ i)) n) ;; Assign various independent variables for this data point. @@ -1899,8 +1910,8 @@ (while p (setq vars (delq (assoc (car-safe p) vars) vars) p (cdr p))) - (sort (mapcar 'car vars) - (function (lambda (x y) (string< (nth 1 x) (nth 1 y))))))) + (sort (mapcar #'car vars) + (lambda (x y) (string< (nth 1 x) (nth 1 y)))))) ;; The variables math-all-vars-vars (the vars for math-all-vars) and ;; math-all-vars-found are local to math-all-vars-in, but are used by diff --git a/lisp/calc/calccomp.el b/lisp/calc/calccomp.el index ea0a95d1506..07e70cad0a8 100644 --- a/lisp/calc/calccomp.el +++ b/lisp/calc/calccomp.el @@ -464,14 +464,13 @@ (math-compose-vector (cdr (nth 1 a)) (math-vector-to-string sep nil) (or cprec prec)) - (cons 'horiz (mapcar (function - (lambda (x) - (if (eq (car-safe x) 'calcFunc-bstring) - (prog1 - (math-compose-expr - x (or bprec cprec prec)) - (setq bprec -123)) - (math-compose-expr x (or cprec prec))))) + (cons 'horiz (mapcar (lambda (x) + (if (eq (car-safe x) 'calcFunc-bstring) + (prog1 + (math-compose-expr + x (or bprec cprec prec)) + (setq bprec -123)) + (math-compose-expr x (or cprec prec)))) (cdr (nth 1 a))))))) ((and (memq (car a) '(calcFunc-cvert calcFunc-clvert calcFunc-crvert)) (not (eq calc-language 'unform)) @@ -482,47 +481,46 @@ (let* ((base 0) (v 0) (prec (or (nth 2 a) prec)) - (c (mapcar (function - (lambda (x) - (let ((b nil) (cc nil) a d) - (if (and (memq (car-safe x) '(calcFunc-cbase - calcFunc-ctbase - calcFunc-cbbase)) - (memq (length x) '(1 2))) - (setq b (car x) - x (nth 1 x))) - (if (and (eq (car-safe x) 'calcFunc-crule) - (memq (length x) '(1 2)) - (or (null (nth 1 x)) - (and (math-vectorp (nth 1 x)) - (= (length (nth 1 x)) 2) - (math-vector-is-string - (nth 1 x))) - (and (natnump (nth 1 x)) - (<= (nth 1 x) 255)))) - (setq cc (list - 'rule - (if (math-vectorp (nth 1 x)) - (aref (math-vector-to-string - (nth 1 x) nil) 0) - (or (nth 1 x) ?-)))) - (or (and (memq (car-safe x) '(calcFunc-cvspace - calcFunc-ctspace - calcFunc-cbspace)) - (memq (length x) '(2 3)) - (eq (nth 1 x) 0)) - (null x) - (setq cc (math-compose-expr x prec)))) - (setq a (if cc (math-comp-ascent cc) 0) - d (if cc (math-comp-descent cc) 0)) - (if (eq b 'calcFunc-cbase) - (setq base (+ v a -1)) - (if (eq b 'calcFunc-ctbase) - (setq base v) - (if (eq b 'calcFunc-cbbase) - (setq base (+ v a d -1))))) - (setq v (+ v a d)) - cc))) + (c (mapcar (lambda (x) + (let ((b nil) (cc nil) a d) + (if (and (memq (car-safe x) '(calcFunc-cbase + calcFunc-ctbase + calcFunc-cbbase)) + (memq (length x) '(1 2))) + (setq b (car x) + x (nth 1 x))) + (if (and (eq (car-safe x) 'calcFunc-crule) + (memq (length x) '(1 2)) + (or (null (nth 1 x)) + (and (math-vectorp (nth 1 x)) + (= (length (nth 1 x)) 2) + (math-vector-is-string + (nth 1 x))) + (and (natnump (nth 1 x)) + (<= (nth 1 x) 255)))) + (setq cc (list + 'rule + (if (math-vectorp (nth 1 x)) + (aref (math-vector-to-string + (nth 1 x) nil) 0) + (or (nth 1 x) ?-)))) + (or (and (memq (car-safe x) '(calcFunc-cvspace + calcFunc-ctspace + calcFunc-cbspace)) + (memq (length x) '(2 3)) + (eq (nth 1 x) 0)) + (null x) + (setq cc (math-compose-expr x prec)))) + (setq a (if cc (math-comp-ascent cc) 0) + d (if cc (math-comp-descent cc) 0)) + (if (eq b 'calcFunc-cbase) + (setq base (+ v a -1)) + (if (eq b 'calcFunc-ctbase) + (setq base v) + (if (eq b 'calcFunc-cbbase) + (setq base (+ v a d -1))))) + (setq v (+ v a d)) + cc)) (cdr (nth 1 a))))) (setq c (delq nil c)) (if c @@ -865,16 +863,15 @@ (while (<= (setq col (1+ col)) cols) (setq res (cons (cons math-comp-just (cons base - (mapcar (function - (lambda (r) - (list 'horiz - (math-compose-expr - (nth col r) - math-comp-vector-prec) - (if (= col cols) - "" - (concat - math-comp-comma-spc " "))))) + (mapcar (lambda (r) + (list 'horiz + (math-compose-expr + (nth col r) + math-comp-vector-prec) + (if (= col cols) + "" + (concat + math-comp-comma-spc " ")))) a))) res))) (nreverse res))) @@ -923,7 +920,7 @@ ( ?\^? . "\\^?" ))) (defun math-vector-to-string (a &optional quoted) - (setq a (concat (mapcar (function (lambda (x) (if (consp x) (nth 1 x) x))) + (setq a (concat (mapcar (lambda (x) (if (consp x) (nth 1 x) x)) (cdr a)))) (if (string-match "[\000-\037\177\\\"]" a) (let ((p 0) @@ -1018,7 +1015,8 @@ (make-string (+ w 2) ?\_)) (list 'horiz (if (= h 1) - "V" + (if (char-displayable-p ?√) + "√" "V") (append (list 'vleft (1- a)) (make-list (1- h) " |") '("\\|"))) @@ -1056,17 +1054,36 @@ (nth 1 a)) 185)) (calc-language 'flat) (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0))) - (high (and (nth 4 a) (math-compose-expr (nth 4 a) 0)))) + (high (and (nth 4 a) (math-compose-expr (nth 4 a) 0))) + ;; Check if we have Unicode integral top/bottom parts. + (fancy (and (char-displayable-p ?⌠) + (char-displayable-p ?⌡))) + ;; If we do, find the most suitable middle part. + (fancy-stem (cond ((not fancy)) + ;; U+23AE INTEGRAL EXTENSION + ((char-displayable-p ?⎮) "⎮ ") + ;; U+2502 BOX DRAWINGS LIGHT VERTICAL + ((char-displayable-p ?│) "│ ") + ;; U+007C VERTICAL LINE + (t "| ")))) (list 'horiz (if parens "(" "") - (append (list 'vcent (if high 3 2)) - (and high (list (list 'horiz " " high))) - '(" /" - " | " - " | " - " | " - "/ ") - (and low (list (list 'horiz low " ")))) + (append (list 'vcent (if fancy + (if high 2 1) + (if high 3 2))) + (and high (list (if fancy + (list 'horiz high " ") + (list 'horiz " " high)))) + (if fancy + (list "⌠ " fancy-stem "⌡ ") + '(" /" + " | " + " | " + " | " + "/ ")) + (and low (list (if fancy + (list 'horiz low " ") + (list 'horiz low " "))))) expr (if over "" diff --git a/lisp/calc/calcsel2.el b/lisp/calc/calcsel2.el index ad418ad7dbf..9c2ac975f0b 100644 --- a/lisp/calc/calcsel2.el +++ b/lisp/calc/calcsel2.el @@ -1,4 +1,4 @@ -;;; calcsel2.el --- selection functions for Calc +;;; calcsel2.el --- selection functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc. @@ -34,6 +34,7 @@ ;; The variable calc-sel-reselect is local to the methods below, ;; but is used by some functions in calc-sel.el which are called ;; by the functions below. +(defvar calc-sel-reselect) (defun calc-commute-left (arg) (interactive "p") |