andros/emacs-gpu
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* lisp/calc/: Use lexical scoping in all the files

Browse source 
Includes the following pervasive changes:
- Move some defvars earlier in the file so they cover earlier let-bindings
- Change dynamically scoped `calc-FOO` or `math-FOO` function arguments
  to just FOO and then let-bind the `calc-FOO` or `math-FOO` variable
  explicitly in the body of the function.  In some cases, the
  beginning of the function was changed to refer to FOO so as to delay
  the binding to a nearby `let` when I could ensure that it did
  not make a difference.
- Add an underscore in front of unused vars or comment them out altogether.
- Replace unused `err` arg to `condition-case` with nil.

Plus the additional itemized changes below.

* lisp/calc/calc-map.el (calcFunc-reducer):
* lisp/calc/calc-arith.el (math-setup-declarations):
* lisp/calc/calc-help.el (calc-full-help, calc-help-index-entries)
(calc-full-help): Use `ignore-errors`.

* lisp/calc/calc-embed.el (calc-embedded-modes-change):
Declare `the-language` and `the-display-just` as dynamically scoped.

* lisp/calc/calc-forms.el (math-setup-year-holidays): Use `dolist`.

* lisp/calc/calc-graph.el (calc-graph-set-styles): Use `symbol-value`
rather than `eval.`
(calc-graph-delete-temps, calc-graph-set-styles): Use ignore-errors.

* lisp/calc/calc-macs.el (calc-with-trail-buffer): Add artificial use
of `save-buf` to silence compiler warnings in all the cases where
`body` doesn't make use of it.

* lisp/calc/calc-math.el (math-largest-emacs-expt)
(math-smallest-emacs-expt, math-use-emacs-fn): Use ignore-errors.

* lisp/calc/calc-mode.el (calc-total-algebraic-mode): Remove "P" from
interactive spec since it's not used anyway.

* lisp/calc/calc-rewr.el (calc-match): Simplify.

* lisp/calc/calc.el (calc-buffer): Give it a global nil value,
so it's automatically declared dynbound in any file that requires `calc`.
(calcDigit-nondigit): Adjust accordingly.

* lisp/calc/calcalg2.el (calcFunc-table): Declare `var-dummy` as dynbound.
(math-scan-for-limits): Comment out dead code.

* lisp/calc/calcalg3.el (math-general-fit): Declare `var-YVAL` and
`var-YVALX` as dynbound.
This commit is contained in:
Stefan Monnier 2020-10-10 16:00:51 -04:00
parent 46c0f28c0e
commit f342b7c969
39 changed files with 528 additions and 465 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
lisp/calc/calc-aent.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -158,7 +158,7 @@
(setq strp (cdr (cdr strp)))) (setq strp (cdr (cdr strp))))
(calc-do-calc-eval (car str) separator args))) (calc-do-calc-eval (car str) separator args)))
((eq separator 'eval) ((eq separator 'eval)
(eval str)) (eval str t))
((eq separator 'macro) ((eq separator 'macro)
(require 'calc-ext) (require 'calc-ext)
(let* ((calc-buffer (current-buffer)) (let* ((calc-buffer (current-buffer))
@ -285,6 +285,8 @@ The value t means abort and give an error message.")
(defvar calc-alg-entry-history nil (defvar calc-alg-entry-history nil
"History for algebraic entry.") "History for algebraic entry.")
(defvar calc-plain-entry nil)
;;;###autoload ;;;###autoload
(defun calc-alg-entry (&optional initial prompt) (defun calc-alg-entry (&optional initial prompt)
(let* ((calc-dollar-values (mapcar #'calc-get-stack-element (let* ((calc-dollar-values (mapcar #'calc-get-stack-element
@ -401,7 +403,6 @@ The value t means abort and give an error message.")
(use-local-map calc-mode-map)) (use-local-map calc-mode-map))
(calcAlg-enter)) (calcAlg-enter))
(defvar calc-plain-entry nil)
(defun calcAlg-edit () (defun calcAlg-edit ()
(interactive) (interactive)
(if (or (not calc-plain-entry) (if (or (not calc-plain-entry)
@ -576,8 +577,9 @@ in Calc algebraic input.")
(defvar math-expr-data) (defvar math-expr-data)
;;;###autoload ;;;###autoload
(defun math-read-exprs (math-exp-str) (defun math-read-exprs (str)
(let ((math-exp-pos 0) (let ((math-exp-str str)
(math-exp-pos 0)
(math-exp-old-pos 0) (math-exp-old-pos 0)
(math-exp-keep-spaces nil) (math-exp-keep-spaces nil)
math-exp-token math-expr-data) math-exp-token math-expr-data)
@ -738,8 +740,8 @@ in Calc algebraic input.")
math-exp-pos (match-end 0))) math-exp-pos (match-end 0)))
((and (setq adfn ((and (setq adfn
(assq ch (get calc-language 'math-lang-read-symbol))) (assq ch (get calc-language 'math-lang-read-symbol)))
(eval (nth 1 adfn))) (eval (nth 1 adfn) t))
(eval (nth 2 adfn))) (eval (nth 2 adfn) t))
((eq ch ?\$) ((eq ch ?\$)
(if (eq (string-match "\\$\\([1-9][0-9]*\\)" math-exp-str math-exp-pos) (if (eq (string-match "\\$\\([1-9][0-9]*\\)" math-exp-str math-exp-pos)
math-exp-pos) math-exp-pos)
@ -771,8 +773,8 @@ in Calc algebraic input.")
math-expr-data (math-match-substring math-exp-str 1) math-expr-data (math-match-substring math-exp-str 1)
math-exp-pos (match-end 0))) math-exp-pos (match-end 0)))
((and (setq adfn (get calc-language 'math-lang-read)) ((and (setq adfn (get calc-language 'math-lang-read))
(eval (nth 0 adfn)) (eval (nth 0 adfn) t)
(eval (nth 1 adfn)))) (eval (nth 1 adfn) t)))
((eq (string-match "%%.*$" math-exp-str math-exp-pos) math-exp-pos) ((eq (string-match "%%.*$" math-exp-str math-exp-pos) math-exp-pos)
(setq math-exp-pos (match-end 0)) (setq math-exp-pos (match-end 0))
(math-read-token)) (math-read-token))

11
lisp/calc/calc-arith.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -250,7 +250,7 @@
(while (setq p (cdr p)) (while (setq p (cdr p))
(and (eq (car-safe (car p)) 'vec) (and (eq (car-safe (car p)) 'vec)
(setq vec (nth 2 (car p))) (setq vec (nth 2 (car p)))
(condition-case err (ignore-errors
(let ((v (nth 1 (car p)))) (let ((v (nth 1 (car p))))
(setq type nil range nil) (setq type nil range nil)
(or (eq (car-safe vec) 'vec) (or (eq (car-safe vec) 'vec)
@ -286,8 +286,7 @@
(nth 2 (car v)) (nth 2 (car v))
(car (car v))) (car (car v)))
type) type)
math-decls-cache))))) math-decls-cache)))))))))
(error nil)))))
(setq math-decls-all (assq 'var-All math-decls-cache))))) (setq math-decls-all (assq 'var-All math-decls-cache)))))
(defun math-known-scalarp (a &optional assume-scalar) (defun math-known-scalarp (a &optional assume-scalar)
@ -2892,7 +2891,7 @@
(eq a b)) (eq a b))
(list 'calcFunc-exp sumpow)) (list 'calcFunc-exp sumpow))
(t (t
(condition-case err (condition-case nil
(math-pow a sumpow) (math-pow a sumpow)
(inexact-result (list '^ a sumpow))))))))) (inexact-result (list '^ a sumpow)))))))))
(and math-simplifying-units (and math-simplifying-units
@ -2927,7 +2926,7 @@
(math-div 1 (list 'calcFunc-sqrt (math-mul a b)))) (math-div 1 (list 'calcFunc-sqrt (math-mul a b))))
(t (t
(setq a (math-mul a b)) (setq a (math-mul a b))
(condition-case err (condition-case nil
(math-pow a apow) (math-pow a apow)
(inexact-result (list '^ a apow))))))))))) (inexact-result (list '^ a apow)))))))))))

2
lisp/calc/calc-bin.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.

2
lisp/calc/calc-comb.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.

2
lisp/calc/calc-cplx.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.

56
lisp/calc/calc-embed.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -219,13 +219,17 @@
(defvar calc-override-minor-modes (defvar calc-override-minor-modes
(cons t calc-override-minor-modes-map)) (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 (if calc-embedded-info
;; Turn embedded mode off or switch to a new buffer. ;; Turn embedded mode off or switch to a new buffer.
(cond ((eq (current-buffer) (aref calc-embedded-info 1)) (cond ((eq (current-buffer) (aref calc-embedded-info 1))
(let ((calcbuf (current-buffer)) (let ((calcbuf (current-buffer))
(buf (aref calc-embedded-info 0))) ;; (buf (aref calc-embedded-info 0))
)
(calc-embedded-original-buffer t) (calc-embedded-original-buffer t)
(calc-embedded nil) (calc-embedded nil)
(switch-to-buffer calcbuf))) (switch-to-buffer calcbuf)))
@ -291,7 +295,7 @@
(calc-embedded-info info) (calc-embedded-info info)
(calc-embedded-no-reselect t)) (calc-embedded-no-reselect t))
(calc-wrapper (calc-wrapper
(let* ((okay nil) (let* (;; (okay nil)
(calc-no-refresh-evaltos t)) (calc-no-refresh-evaltos t))
(if (aref info 8) (if (aref info 8)
(progn (progn
@ -336,7 +340,7 @@
"Type `C-x * x'" "Type `C-x * x'"
"Give this command again") "Give this command again")
" to return to normal"))))) " 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) (defun calc-embedded-select (arg)
@ -353,9 +357,10 @@
(calc-select-part 2))) (calc-select-part 2)))
(defun calc-embedded-update-formula (calc-embed-arg) (defun calc-embedded-update-formula (embed-arg)
(interactive "P") (interactive "P")
(if calc-embed-arg (let ((calc-embed-arg embed-arg))
(if embed-arg
(let ((entry (assq (current-buffer) calc-embedded-active))) (let ((entry (assq (current-buffer) calc-embedded-active)))
(while (setq entry (cdr entry)) (while (setq entry (cdr entry))
(and (eq (car-safe (aref (car entry) 8)) 'calcFunc-evalto) (and (eq (car-safe (aref (car entry) 8)) 'calcFunc-evalto)
@ -376,12 +381,13 @@
(progn (progn
(save-excursion (save-excursion
(calc-embedded-update info 14 'eval t)) (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") (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) str)
(if (eq (car-safe (aref info 8)) 'error) (if (eq (car-safe (aref info 8)) 'error)
(progn (progn
@ -392,15 +398,14 @@
(math-format-nice-expr (aref info 8) (frame-width)))) (math-format-nice-expr (aref info 8) (frame-width))))
(calc-edit-mode (list 'calc-embedded-finish-edit info)) (calc-edit-mode (list 'calc-embedded-finish-edit info))
(insert str "\n"))) (insert str "\n")))
(calc-show-edit-buffer)) (calc-show-edit-buffer)))
(defvar calc-original-buffer) (defvar calc-original-buffer)
(defvar calc-edit-top) (defvar calc-edit-top)
(defun calc-embedded-finish-edit (info) (defun calc-embedded-finish-edit (info)
(let ((buf (current-buffer)) (let ((buf (current-buffer))
(str (buffer-substring calc-edit-top (point-max))) (str (buffer-substring calc-edit-top (point-max)))
(start (point)) (start (point))) ;; pos
pos)
(switch-to-buffer calc-original-buffer) (switch-to-buffer calc-original-buffer)
(let ((val (with-current-buffer (aref info 1) (let ((val (with-current-buffer (aref info 1)
(let ((calc-language nil) (let ((calc-language nil)
@ -416,7 +421,8 @@
(calc-embedded-update info 14 t t)))) (calc-embedded-update info 14 t t))))
;;;###autoload ;;;###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) (calc-plain-buffer-only)
(if calc-embed-arg (if calc-embed-arg
(calc-embedded-forget)) (calc-embedded-forget))
@ -443,7 +449,7 @@
(or (eq (car-safe (aref info 8)) 'error) (or (eq (car-safe (aref info 8)) 'error)
(goto-char (aref info 5)))))) (goto-char (aref info 5))))))
(message "Activating %s for Calc Embedded mode...done" (buffer-name))) (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 () (defun calc-plain-buffer-only ()
(if (memq major-mode '(calc-mode calc-trail-mode calc-edit-mode)) (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 () (defun calc-find-globals ()
(interactive) (interactive)
(and (eq major-mode 'calc-mode) (and (derived-mode-p 'calc-mode)
(error "This command should be used in a normal editing buffer")) (error "This command should be used in a normal editing buffer"))
(make-local-variable 'calc-embedded-globals) (make-local-variable 'calc-embedded-globals)
(let ((case-fold-search nil) (let ((case-fold-search nil)
(modes nil) (modes nil)
(save-pt (point)) (save-pt (point))
found value) found) ;; value
(goto-char (point-min)) (goto-char (point-min))
(while (re-search-forward "\\[calc-global-mode: *\\([-a-z]+\\): *\\(\"\\([^\"\n\\]\\|\\\\.\\)*\"\\|[- ()a-zA-Z0-9]+\\)\\]" nil t) (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) (and (setq found (assoc (buffer-substring (match-beginning 1)
@ -764,7 +770,7 @@ The command \\[yank] can retrieve it from there."
(modes nil) (modes nil)
(emodes nil) (emodes nil)
(pmodes nil) (pmodes nil)
found value) found) ;; value
(while (and no-defaults (search-backward "[calc-" nil t)) (while (and no-defaults (search-backward "[calc-" nil t))
(forward-char 6) (forward-char 6)
(or (and (looking-at "mode: *\\([-a-z]+\\): *\\(\"\\([^\"\n\\]\\|\\\\.\\)*\"\\|[- ()a-zA-Z0-9]+\\)]") (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) (defvar calc-embed-vars-used)
(defun calc-embedded-make-info (point cbuf fresh &optional (defun calc-embedded-make-info (point cbuf fresh &optional
calc-embed-top calc-embed-bot embed-top embed-bot
calc-embed-outer-top calc-embed-outer-bot) embed-outer-top embed-outer-bot)
(let* ((bufentry (assq (current-buffer) calc-embedded-active)) (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) (found bufentry)
(force (and fresh calc-embed-top (null (equal calc-embed-top '(t))))) (force (and fresh calc-embed-top (null (equal calc-embed-top '(t)))))
(fixed calc-embed-top) (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. ;;; These are hooks called by the main part of Calc.
(defvar calc-embedded-no-reselect nil)
(defun calc-embedded-select-buffer () (defun calc-embedded-select-buffer ()
(if (eq (current-buffer) (aref calc-embedded-info 0)) (if (eq (current-buffer) (aref calc-embedded-info 0))
(let ((info calc-embedded-info) (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) (with-current-buffer (aref calc-embedded-info 1)
(let* ((info calc-embedded-info) (let* ((info calc-embedded-info)
(extra-line (if (eq calc-language 'big) 1 0)) (extra-line (if (eq calc-language 'big) 1 0))
(the-point (point)) ;; (the-point (point))
(empty (= (calc-stack-size) 0)) (empty (= (calc-stack-size) 0))
(entry (if empty (entry (if empty
(list '(var empty var-empty) 1 nil) (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))))) (set-buffer-modified-p (buffer-modified-p)))))
(defun calc-embedded-modes-change (vars) (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-language) (setq vars '(the-language)))
(if (eq (car vars) 'calc-display-just) (setq vars '(the-display-just))) (if (eq (car vars) 'calc-display-just) (setq vars '(the-display-just)))
(while (and vars (while (and vars

5
lisp/calc/calc-ext.el
View file

@ -1398,9 +1398,8 @@ calc-kill calc-kill-region calc-yank))))
(defun calc-scroll-up (n) (defun calc-scroll-up (n)
(interactive "P") (interactive "P")
(condition-case nil (ignore-errors
(scroll-up (or n (/ (window-height) 2))) (scroll-up (or n (/ (window-height) 2))))
(error nil))
(if (pos-visible-in-window-p (max 1 (- (point-max) 2))) (if (pos-visible-in-window-p (max 1 (- (point-max) 2)))
(if (eq major-mode 'calc-mode) (if (eq major-mode 'calc-mode)
(calc-realign) (calc-realign)

2
lisp/calc/calc-fin.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.

56
lisp/calc/calc-forms.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -678,10 +678,11 @@ in the Gregorian calendar."
(defvar math-fd-isoweek) (defvar math-fd-isoweek)
(defvar math-fd-isoweekday) (defvar math-fd-isoweekday)
(defun math-format-date (math-fd-date) (defun math-format-date (fd-date)
(if (eq (car-safe math-fd-date) 'date) (let* ((math-fd-date (if (eq (car-safe fd-date) 'date)
(setq math-fd-date (nth 1 math-fd-date))) (nth 1 fd-date)
(let ((entry (list math-fd-date calc-internal-prec calc-date-format))) fd-date))
(entry (list math-fd-date calc-internal-prec calc-date-format)))
(or (cdr (assoc entry math-format-date-cache)) (or (cdr (assoc entry math-format-date-cache))
(let* ((math-fd-dt nil) (let* ((math-fd-dt nil)
(math-fd-iso-dt nil) (math-fd-iso-dt nil)
@ -914,15 +915,16 @@ to Jan 1, 1970 AD.")
;; which is called by math-parse-date and math-parse-standard-date. ;; which is called by math-parse-date and math-parse-standard-date.
(defvar math-pd-str) (defvar math-pd-str)
(defun math-parse-date (math-pd-str) (defun math-parse-date (pd-str)
(catch 'syntax (catch 'syntax
(or (math-parse-standard-date math-pd-str t) (or (math-parse-standard-date pd-str t)
(math-parse-standard-date math-pd-str nil) (math-parse-standard-date pd-str nil)
(and (string-match "W[0-9][0-9]" math-pd-str) (and (string-match "W[0-9][0-9]" pd-str)
(math-parse-iso-date math-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]*\\'" math-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 math-pd-str 1)))) (list 'date (math-read-number (math-match-substring pd-str 1))))
(let ((case-fold-search t) (let ((case-fold-search t)
(math-pd-str pd-str)
(year nil) (month nil) (day nil) (weekday nil) (year nil) (month nil) (day nil) (weekday nil)
(hour nil) (minute nil) (second nil) (bc-flag nil) (hour nil) (minute nil) (second nil) (bc-flag nil)
(a nil) (b nil) (c nil) (bigyear nil) temp) (a nil) (b nil) (c nil) (bigyear nil) temp)
@ -1128,8 +1130,9 @@ to Jan 1, 1970 AD.")
(substring math-pd-str (match-end 0)))) (substring math-pd-str (match-end 0))))
n)))) n))))
(defun math-parse-standard-date (math-pd-str with-time) (defun math-parse-standard-date (pd-str with-time)
(let ((case-fold-search t) (let ((math-pd-str pd-str)
(case-fold-search t)
(okay t) num (okay t) num
(fmt calc-date-format) this next (gnext nil) (fmt calc-date-format) this next (gnext nil)
(isoyear nil) (isoweek nil) (isoweekday nil) (isoyear nil) (isoweek nil) (isoweekday nil)
@ -1306,9 +1309,10 @@ to Jan 1, 1970 AD.")
(setq day (math-add day (1- yearday)))) (setq day (math-add day (1- yearday))))
day)))))) day))))))
(defun math-parse-iso-date (math-pd-str) (defun math-parse-iso-date (pd-str)
"Parse MATH-PD-STR as an ISO week date, or return nil." "Parse PD-STR as an ISO week date, or return nil."
(let ((case-fold-search t) (let ((math-pd-str pd-str)
(case-fold-search t)
(isoyear nil) (isoweek nil) (isoweekday nil) (isoyear nil) (isoweek nil) (isoweekday nil)
(hour nil) (minute nil) (second nil)) (hour nil) (minute nil) (second nil))
;; Extract the time, if any. ;; Extract the time, if any.
@ -1613,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-old date dt zone bump)
(math-std-daylight-savings-new 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. "Standard North American daylight saving algorithm as of 2007.
This implements the rules for the U.S. and Canada. This implements the rules for the U.S. and Canada.
Daylight saving begins on the second Sunday of March at 2 a.m., Daylight saving begins on the second Sunday of March at 2 a.m.,
@ -1634,7 +1638,7 @@ and ends on the first Sunday of November at 2 a.m."
(t 0)))) (t 0))))
(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. "Standard North American daylight saving algorithm before 2007.
This implements the rules for the U.S. and Canada. This implements the rules for the U.S. and Canada.
Daylight saving begins on the first Sunday of April at 2 a.m., Daylight saving begins on the first Sunday of April at 2 a.m.,
@ -1657,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 ;;; Compute the day (1-31) of the WDAY (0-6) on or preceding the given
;;; day of the given month. ;;; 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))) (or day (setq day (nth 2 dt)))
(if (> day (math-days-in-month (car dt) (nth 1 dt))) (if (> day (math-days-in-month (car dt) (nth 1 dt)))
(setq day (math-days-in-month (car dt) (nth 1 dt)))) (setq day (math-days-in-month (car dt) (nth 1 dt))))
@ -2036,18 +2040,18 @@ and ends on the last Sunday of October at 2 a.m."
nil))) nil)))
(or done (setq math-holidays-cache-tag t)))))) (or done (setq math-holidays-cache-tag t))))))
(defun math-setup-year-holidays (math-sh-year) (defun math-setup-year-holidays (sh-year)
(let ((exprs (nth 2 math-holidays-cache))) (let ((math-sh-year sh-year))
(while exprs (dolist (expr (nth 2 math-holidays-cache))
(defvar var-y) (defvar var-m)
(let* ((var-y math-sh-year) (let* ((var-y math-sh-year)
(var-m nil) (var-m nil)
(expr (math-evaluate-expr (car exprs)))) (expr (math-evaluate-expr expr)))
(if (math-expr-contains expr '(var m var-m)) (if (math-expr-contains expr '(var m var-m))
(let ((var-m 0)) (let ((var-m 0))
(while (<= (setq var-m (1+ var-m)) 12) (while (<= (setq var-m (1+ var-m)) 12)
(math-setup-add-holidays (math-evaluate-expr expr)))) (math-setup-add-holidays (math-evaluate-expr expr))))
(math-setup-add-holidays expr))) (math-setup-add-holidays expr))))))
(setq exprs (cdr exprs)))))
(defun math-setup-add-holidays (days) ; uses "math-sh-year" (defun math-setup-add-holidays (days) ; uses "math-sh-year"
(cond ((eq (car-safe days) 'vec) (cond ((eq (car-safe days) 'vec)

2
lisp/calc/calc-frac.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.

2
lisp/calc/calc-funcs.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.

36
lisp/calc/calc-graph.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -216,7 +216,7 @@
(or (and (Math-num-integerp pstyle) (math-trunc pstyle)) (or (and (Math-num-integerp pstyle) (math-trunc pstyle))
(if (eq (car-safe (calc-var-value (nth 2 ydata))) 'vec) (if (eq (car-safe (calc-var-value (nth 2 ydata))) 'vec)
0 -1)) 0 -1))
(math-contains-sdev-p (eval (nth 2 ydata)))))) (math-contains-sdev-p (eval (nth 2 ydata) t)))))
(defun calc-graph-lookup (thing) (defun calc-graph-lookup (thing)
(if (and (eq (car-safe thing) 'var) (if (and (eq (car-safe thing) 'var)
@ -319,7 +319,6 @@
(calc-slow-wrapper (calc-slow-wrapper
(let ((calcbuf (current-buffer)) (let ((calcbuf (current-buffer))
(tempbuf (get-buffer-create "*Gnuplot Temp-2*")) (tempbuf (get-buffer-create "*Gnuplot Temp-2*"))
(tempbuftop 1)
(tempoutfile nil) (tempoutfile nil)
(calc-graph-curve-num 0) (calc-graph-curve-num 0)
(calc-graph-refine (and flag (> (prefix-numeric-value flag) 0))) (calc-graph-refine (and flag (> (prefix-numeric-value flag) 0)))
@ -403,7 +402,7 @@
(and (equal output "tty") (setq tty-output t))) (and (equal output "tty") (setq tty-output t)))
(setq tempoutfile (calc-temp-file-name -1) (setq tempoutfile (calc-temp-file-name -1)
output tempoutfile)) output tempoutfile))
(setq output (eval output))) (setq output (eval output t)))
(or (equal device calc-graph-last-device) (or (equal device calc-graph-last-device)
(progn (progn
(setq calc-graph-last-device device) (setq calc-graph-last-device device)
@ -480,9 +479,11 @@
(calc-graph-xp calc-graph-xvalue) (calc-graph-xp calc-graph-xvalue)
(calc-graph-yp calc-graph-yvalue) (calc-graph-yp calc-graph-yvalue)
(calc-graph-zp nil) (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 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-yvec calc-graph-yval calc-graph-ycache calc-graph-ycacheptr calc-graph-yvector
calc-graph-numsteps calc-graph-numsteps3 calc-graph-numsteps calc-graph-numsteps3
(calc-graph-keep-file (and (not calc-graph-is-splot) (file-exists-p filename))) (calc-graph-keep-file (and (not calc-graph-is-splot) (file-exists-p filename)))
@ -562,7 +563,7 @@
calc-gnuplot-print-output))) calc-gnuplot-print-output)))
(if (symbolp command) (if (symbolp command)
(funcall command output) (funcall command output)
(eval command)))))))))) (eval command t))))))))))
(defun calc-graph-compute-2d () (defun calc-graph-compute-2d ()
(if (setq calc-graph-yvec (eq (car-safe calc-graph-yvalue) 'vec)) (if (setq calc-graph-yvec (eq (car-safe calc-graph-yvalue) 'vec))
@ -905,16 +906,15 @@
(while calc-graph-file-cache (while calc-graph-file-cache
(and (car calc-graph-file-cache) (and (car calc-graph-file-cache)
(file-exists-p (car (car calc-graph-file-cache))) (file-exists-p (car (car calc-graph-file-cache)))
(condition-case err (ignore-errors
(delete-file (car (car calc-graph-file-cache))) (delete-file (car (car calc-graph-file-cache)))))
(error nil)))
(setq calc-graph-file-cache (cdr calc-graph-file-cache)))) (setq calc-graph-file-cache (cdr calc-graph-file-cache))))
(defun calc-graph-kill-hook () (defun calc-graph-kill-hook ()
(calc-graph-delete-temps)) (calc-graph-delete-temps))
(defun calc-graph-show-tty (output) (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." This is useful for tek40xx and other graphics-terminal types."
(call-process shell-file-name nil calc-gnuplot-buffer nil (call-process shell-file-name nil calc-gnuplot-buffer nil
shell-command-switch shell-command-switch
@ -923,7 +923,7 @@ This is useful for tek40xx and other graphics-terminal types."
(defvar calc-dumb-map nil (defvar calc-dumb-map nil
"The keymap for the \"dumb\" terminal plot.") "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. "Default calc-gnuplot-plot-command for Pinard's \"dumb\" terminal type.
This \"dumb\" driver will be present in Gnuplot 3.0." This \"dumb\" driver will be present in Gnuplot 3.0."
(interactive) (interactive)
@ -1116,14 +1116,14 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(delete-region start end) (delete-region start end)
(goto-char start) (goto-char start)
(setq errform (setq errform
(condition-case nil (ignore-errors
(math-contains-sdev-p (math-contains-sdev-p
(eval (intern (symbol-value
(intern
(concat "var-" (concat "var-"
(save-excursion (save-excursion
(re-search-backward ":\\(.*\\)}") (re-search-backward ":\\(.*\\)}")
(match-string 1)))))) (match-string 1))))))))
(error nil)))
(if yerr (if yerr
(insert " with yerrorbars") (insert " with yerrorbars")
(insert " with " (insert " with "
@ -1165,7 +1165,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(or (calc-graph-find-plot nil nil) (or (calc-graph-find-plot nil nil)
(error "No data points have been set!")) (error "No data points have been set!"))
(let ((base (point)) (let ((base (point))
start ;; start
end) end)
(re-search-forward "[,\n]\\|[ \t]+with") (re-search-forward "[,\n]\\|[ \t]+with")
(setq end (match-beginning 0)) (setq end (match-beginning 0))
@ -1462,7 +1462,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(match-beginning 1) (match-beginning 1)
(match-end 1)))) (match-end 1))))
(setq calc-gnuplot-version 1)))) (setq calc-gnuplot-version 1))))
(condition-case err (condition-case nil
(let ((args (append (and calc-gnuplot-display (let ((args (append (and calc-gnuplot-display
(not (equal calc-gnuplot-display (not (equal calc-gnuplot-display
(getenv "DISPLAY"))) (getenv "DISPLAY")))

22
lisp/calc/calc-help.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -33,8 +33,8 @@
(declare-function Info-last "info" ()) (declare-function Info-last "info" ())
(defun calc-help-prefix (arg) (defun calc-help-prefix (&optional _arg)
"This key is the prefix for Calc help functions. See calc-help-for-help." "This key is the prefix for Calc help functions. See `calc-help-for-help'."
(interactive "P") (interactive "P")
(or calc-dispatch-help (sit-for echo-keystrokes)) (or calc-dispatch-help (sit-for echo-keystrokes))
(let ((key (calc-read-key-sequence (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") (message "Calc Help options: Help, Info, ... press SPC, DEL to scroll, C-g to cancel")
(memq (setq key (read-event)) (memq (setq key (read-event))
'(? ?\C-h ?\C-? ?\C-v ?\M-v))) '(? ?\C-h ?\C-? ?\C-v ?\M-v)))
(condition-case err (condition-case nil
(if (memq key '(? ?\C-v)) (if (memq key '(? ?\C-v))
(scroll-up) (scroll-up)
(scroll-down)) (scroll-down))
@ -302,11 +302,11 @@ C-w Describe how there is no warranty for Calc."
(let ((entrylist '()) (let ((entrylist '())
entry) entry)
(require 'info nil t) (require 'info nil t)
(while indices (dolist (indice indices)
(condition-case nil (ignore-errors
(with-temp-buffer (with-temp-buffer
(Info-mode) (Info-mode)
(Info-goto-node (concat "(Calc)" (car indices) " Index")) (Info-goto-node (concat "(Calc)" indice " Index"))
(goto-char (point-min)) (goto-char (point-min))
(while (re-search-forward "\n\\* \\(.*\\): " nil t) (while (re-search-forward "\n\\* \\(.*\\): " nil t)
(setq entry (match-string 1)) (setq entry (match-string 1))
@ -314,9 +314,7 @@ C-w Describe how there is no warranty for Calc."
(not (string-match "(.*)" entry)) (not (string-match "(.*)" entry))
(not (string= entry "Menu"))) (not (string= entry "Menu")))
(unless (assoc entry entrylist) (unless (assoc entry entrylist)
(setq entrylist (cons entry entrylist)))))) (setq entrylist (cons entry entrylist))))))))
(error nil))
(setq indices (cdr indices)))
entrylist)) entrylist))
(defun calc-describe-function (&optional func) (defun calc-describe-function (&optional func)
@ -409,9 +407,7 @@ C-w Describe how there is no warranty for Calc."
(substitute-command-keys x))))) (substitute-command-keys x)))))
(nreverse (cdr (reverse (cdr (calc-help)))))) (nreverse (cdr (reverse (cdr (calc-help))))))
(mapc (function (lambda (prefix) (mapc (function (lambda (prefix)
(let ((msgs (condition-case err (let ((msgs (ignore-errors (funcall prefix))))
(funcall prefix)
(error nil))))
(if (car msgs) (if (car msgs)
(princ (princ
(if (eq (nth 2 msgs) ?v) (if (eq (nth 2 msgs) ?v)

2
lisp/calc/calc-incom.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.

84
lisp/calc/calc-keypd.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -35,17 +35,17 @@
(defvar calc-keypad-prev-input nil) (defvar calc-keypad-prev-input nil)
(defvar calc-keypad-said-hello nil) (defvar calc-keypad-said-hello nil)
;;; |----+----+----+----+----+----| ;; |----+----+----+----+----+----|
;;; | ENTER |+/- |EEX |UNDO| <- | ;; | ENTER |+/- |EEX |UNDO| <- |
;;; |-----+---+-+--+--+-+---++----| ;; |-----+---+-+--+--+-+---++----|
;;; | INV | 7 | 8 | 9 | / | ;; | INV | 7 | 8 | 9 | / |
;;; |-----+-----+-----+-----+-----| ;; |-----+-----+-----+-----+-----|
;;; | HYP | 4 | 5 | 6 | * | ;; | HYP | 4 | 5 | 6 | * |
;;; |-----+-----+-----+-----+-----| ;; |-----+-----+-----+-----+-----|
;;; |EXEC | 1 | 2 | 3 | - | ;; |EXEC | 1 | 2 | 3 | - |
;;; |-----+-----+-----+-----+-----| ;; |-----+-----+-----+-----+-----|
;;; | OFF | 0 | . | PI | + | ;; | OFF | 0 | . | PI | + |
;;; |-----+-----+-----+-----+-----| ;; |-----+-----+-----+-----+-----|
(defvar calc-keypad-layout (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 )
( "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-modes-menu
calc-keypad-user-menu ) ) calc-keypad-user-menu ) )
;;; |----+----+----+----+----+----| ;; |----+----+----+----+----+----|
;;; |FLR |CEIL|RND |TRNC|CLN2|FLT | ;; |FLR |CEIL|RND |TRNC|CLN2|FLT |
;;; |----+----+----+----+----+----| ;; |----+----+----+----+----+----|
;;; | LN |EXP | |ABS |IDIV|MOD | ;; | LN |EXP | |ABS |IDIV|MOD |
;;; |----+----+----+----+----+----| ;; |----+----+----+----+----+----|
;;; |SIN |COS |TAN |SQRT|y^x |1/x | ;; |SIN |COS |TAN |SQRT|y^x |1/x |
(defvar calc-keypad-math-menu (defvar calc-keypad-math-menu
'( ( ( "FLR" calc-floor ) '( ( ( "FLR" calc-floor )
@ -110,12 +110,12 @@
( "y^x" calc-power ) ( "y^x" calc-power )
( "1/x" calc-inv ) ) )) ( "1/x" calc-inv ) ) ))
;;; |----+----+----+----+----+----| ;; |----+----+----+----+----+----|
;;; |IGAM|BETA|IBET|ERF |BESJ|BESY| ;; |IGAM|BETA|IBET|ERF |BESJ|BESY|
;;; |----+----+----+----+----+----| ;; |----+----+----+----+----+----|
;;; |IMAG|CONJ| RE |ATN2|RAND|RAGN| ;; |IMAG|CONJ| RE |ATN2|RAND|RAGN|
;;; |----+----+----+----+----+----| ;; |----+----+----+----+----+----|
;;; |GCD |FACT|DFCT|BNOM|PERM|NXTP| ;; |GCD |FACT|DFCT|BNOM|PERM|NXTP|
(defvar calc-keypad-funcs-menu (defvar calc-keypad-funcs-menu
'( ( ( "IGAM" calc-inc-gamma ) '( ( ( "IGAM" calc-inc-gamma )
@ -137,12 +137,12 @@
( "PERM" calc-perm ) ( "PERM" calc-perm )
( "NXTP" calc-next-prime calc-prev-prime ) ) )) ( "NXTP" calc-next-prime calc-prev-prime ) ) ))
;;; |----+----+----+----+----+----| ;; |----+----+----+----+----+----|
;;; |AND | OR |XOR |NOT |LSH |RSH | ;; |AND | OR |XOR |NOT |LSH |RSH |
;;; |----+----+----+----+----+----| ;; |----+----+----+----+----+----|
;;; |DEC |HEX |OCT |BIN |WSIZ|ARSH| ;; |DEC |HEX |OCT |BIN |WSIZ|ARSH|
;;; |----+----+----+----+----+----| ;; |----+----+----+----+----+----|
;;; | A | B | C | D | E | F | ;; | A | B | C | D | E | F |
(defvar calc-keypad-binary-menu (defvar calc-keypad-binary-menu
'( ( ( "AND" calc-and calc-diff ) '( ( ( "AND" calc-and calc-diff )
@ -164,12 +164,12 @@
( "E" ("E") ) ( "E" ("E") )
( "F" ("F") ) ) )) ( "F" ("F") ) ) ))
;;; |----+----+----+----+----+----| ;; |----+----+----+----+----+----|
;;; |SUM |PROD|MAX |MAP*|MAP^|MAP$| ;; |SUM |PROD|MAX |MAP*|MAP^|MAP$|
;;; |----+----+----+----+----+----| ;; |----+----+----+----+----+----|
;;; |INV |DET |TRN |IDNT|CRSS|"x" | ;; |INV |DET |TRN |IDNT|CRSS|"x" |
;;; |----+----+----+----+----+----| ;; |----+----+----+----+----+----|
;;; |PACK|UNPK|INDX|BLD |LEN |... | ;; |PACK|UNPK|INDX|BLD |LEN |... |
(defvar calc-keypad-vector-menu (defvar calc-keypad-vector-menu
'( ( ( "SUM" calc-vector-sum calc-vector-alt-sum calc-vector-mean ) '( ( ( "SUM" calc-vector-sum calc-vector-alt-sum calc-vector-mean )
@ -196,12 +196,12 @@
( "LEN" calc-vlength ) ( "LEN" calc-vlength )
( "..." calc-full-vectors ) ) )) ( "..." calc-full-vectors ) ) ))
;;; |----+----+----+----+----+----| ;; |----+----+----+----+----+----|
;;; |FLT |FIX |SCI |ENG |GRP | | ;; |FLT |FIX |SCI |ENG |GRP | |
;;; |----+----+----+----+----+----| ;; |----+----+----+----+----+----|
;;; |RAD |DEG |FRAC|POLR|SYMB|PREC| ;; |RAD |DEG |FRAC|POLR|SYMB|PREC|
;;; |----+----+----+----+----+----| ;; |----+----+----+----+----+----|
;;; |SWAP|RLL3|RLL4|OVER|STO |RCL | ;; |SWAP|RLL3|RLL4|OVER|STO |RCL |
(defvar calc-keypad-modes-menu (defvar calc-keypad-modes-menu
'( ( ( "FLT" calc-normal-notation '( ( ( "FLT" calc-normal-notation

58
lisp/calc/calc-lang.el
View file

@ -1,4 +1,4 @@
;;; calc-lang.el --- calc language functions ;;; calc-lang.el --- calc language functions -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -45,6 +45,8 @@
(defvar math-comp-comma) (defvar math-comp-comma)
(defvar math-comp-vector-prec) (defvar math-comp-vector-prec)
(defvar math-exp-str) ;; Dyn scoped
;;; Alternate entry/display languages. ;;; Alternate entry/display languages.
(defun calc-set-language (lang &optional option no-refresh) (defun calc-set-language (lang &optional option no-refresh)
@ -144,7 +146,7 @@
( y1 . (math-C-parse-bess)) ( y1 . (math-C-parse-bess))
( tgamma . calcFunc-gamma ))) ( 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." "Parse C's j0, j1, y0, y1 functions."
(let ((args (math-read-expr-list))) (let ((args (math-read-expr-list)))
(math-read-token) (math-read-token)
@ -155,7 +157,7 @@
((eq val 'y1) '(calcFunc-besY 1))) ((eq val 'y1) '(calcFunc-besY 1)))
args))) 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)." "Parse C's fma function fma(x,y,z) => (x * y + z)."
(let ((args (math-read-expr-list))) (let ((args (math-read-expr-list)))
(math-read-token) (math-read-token)
@ -372,14 +374,14 @@
(defvar math-exp-old-pos) (defvar math-exp-old-pos)
(defvar math-parsing-fortran-vector nil) (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"))) (let ((math-parsing-fortran-vector '(end . "\000")))
(prog1 (prog1
(math-read-brackets t "]") (math-read-brackets t "]")
(setq math-exp-token (car math-parsing-fortran-vector) (setq math-exp-token (car math-parsing-fortran-vector)
math-expr-data (cdr 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 (if math-parsing-fortran-vector
(progn (progn
(setq math-parsing-fortran-vector (cons math-exp-token math-expr-data) (setq math-parsing-fortran-vector (cons math-exp-token math-expr-data)
@ -692,7 +694,7 @@
"_{" (math-compose-expr (nth 2 a) 0) "_{" (math-compose-expr (nth 2 a) 0)
"}{" (math-compose-expr (nth 1 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) (let (low high save)
(or (equal math-expr-data "_") (throw 'syntax "Expected `_'")) (or (equal math-expr-data "_") (throw 'syntax "Expected `_'"))
(math-read-token) (math-read-token)
@ -727,14 +729,15 @@
(math-compose-expr (nth 3 a) 0) (math-compose-expr (nth 3 a) 0)
(if (memq (nth 1 a) '(0 2)) ")" "]"))) (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 (if (and calc-language-option
(not (= calc-language-option 0)) (not (= calc-language-option 0))
(string-match "\\`[a-zA-Zα-ωΑ-Ω][a-zA-Zα-ωΑ-Ω0-9]+\\'" (string-match "\\`[a-zA-Zα-ωΑ-Ω][a-zA-Zα-ωΑ-Ω0-9]+\\'"
(symbol-name (nth 1 a)))) (symbol-name (nth 1 a))))
(if (eq calc-language 'latex) (format (if (eq calc-language 'latex)
(format "\\text{%s}" (symbol-name (nth 1 a))) "\\text{%s}"
(format "\\hbox{%s}" (symbol-name (nth 1 a)))) "\\hbox{%s}")
(symbol-name (nth 1 a)))
(math-compose-var a))) (math-compose-var a)))
(defun math-compose-tex-func (func a) (defun math-compose-tex-func (func a)
@ -906,7 +909,7 @@
(setq math-exp-str (copy-sequence math-exp-str)) (setq math-exp-str (copy-sequence math-exp-str))
(aset math-exp-str right ?\])))))))))) (aset math-exp-str right ?\]))))))))))
(defun math-latex-parse-frac (f val) (defun math-latex-parse-frac (_f _val)
(let (numer denom) (let (numer denom)
(setq numer (car (math-read-expr-list))) (setq numer (car (math-read-expr-list)))
(math-read-token) (math-read-token)
@ -916,7 +919,7 @@
(list 'frac numer denom) (list 'frac numer denom)
(list '/ numer denom)))) (list '/ numer denom))))
(defun math-latex-parse-two-args (f val) (defun math-latex-parse-two-args (f _val)
(let (first second) (let (first second)
(setq first (car (math-read-expr-list))) (setq first (car (math-read-expr-list)))
(math-read-token) (math-read-token)
@ -931,7 +934,7 @@
(put 'latex 'math-input-filter 'math-tex-input-filter) (put 'latex 'math-input-filter 'math-tex-input-filter)
(defun calc-eqn-language (n) (defun calc-eqn-language (_n)
(interactive "P") (interactive "P")
(calc-wrapper (calc-wrapper
(calc-set-language 'eqn) (calc-set-language 'eqn)
@ -1159,7 +1162,7 @@
(math-compose-eqn-matrix (cdr a))))))) (math-compose-eqn-matrix (cdr a)))))))
nil)) nil))
(defun math-parse-eqn-matrix (f sym) (defun math-parse-eqn-matrix (_f _sym)
(let ((vec nil)) (let ((vec nil))
(while (assoc math-expr-data '(("ccol") ("lcol") ("rcol"))) (while (assoc math-expr-data '(("ccol") ("lcol") ("rcol")))
(math-read-token) (math-read-token)
@ -1175,7 +1178,7 @@
(math-read-token) (math-read-token)
(math-transpose (cons 'vec (nreverse vec))))) (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 (eq (car-safe x) 'var)
(if (equal math-expr-data calc-function-open) (if (equal math-expr-data calc-function-open)
(progn (progn
@ -1363,7 +1366,7 @@
(math-compose-vector args ", " 0) (math-compose-vector args ", " 0)
"]"))))) "]")))))
(defun math-yacas-parse-Sum (f val) (defun math-yacas-parse-Sum (f _val)
"Read in the arguments to \"Sum\" in Calc's Yacas mode." "Read in the arguments to \"Sum\" in Calc's Yacas mode."
(let ((args (math-read-expr-list))) (let ((args (math-read-expr-list)))
(math-read-token) (math-read-token)
@ -1512,7 +1515,7 @@
( substitute . (math-maxima-parse-subst)) ( substitute . (math-maxima-parse-subst))
( taylor . (math-maxima-parse-taylor)))) ( 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." "Read in the arguments to \"subst\" in Calc's Maxima mode."
(let ((args (math-read-expr-list))) (let ((args (math-read-expr-list)))
(math-read-token) (math-read-token)
@ -1521,7 +1524,7 @@
(nth 2 args) (nth 2 args)
(nth 0 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." "Read in the arguments to \"taylor\" in Calc's Maxima mode."
(let ((args (math-read-expr-list))) (let ((args (math-read-expr-list)))
(math-read-token) (math-read-token)
@ -1762,7 +1765,7 @@
( contains . (math-lang-switch-args calcFunc-in)) ( contains . (math-lang-switch-args calcFunc-in))
( has . (math-lang-switch-args calcFunc-refers)))) ( 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. "Read the arguments to a Calc function in reverse order.
This is used for various language modes which have functions in reverse This is used for various language modes which have functions in reverse
order to Calc's." order to Calc's."
@ -1805,15 +1808,15 @@ order to Calc's."
(put 'giac 'math-compose-subscr (put 'giac 'math-compose-subscr
(function (function
(lambda (a) (lambda (a)
(let ((args (cdr (cdr a)))) ;; (let ((args (cdr (cdr a))))
(list 'horiz (list 'horiz
(math-compose-expr (nth 1 a) 1000) (math-compose-expr (nth 1 a) 1000)
"[" "["
(math-compose-expr (math-compose-expr
(calc-normalize (list '- (nth 2 a) 1)) 0) (calc-normalize (list '- (nth 2 a) 1)) 0)
"]"))))) "]")))) ;;)
(defun math-read-giac-subscr (x op) (defun math-read-giac-subscr (x _op)
(let ((idx (math-read-expr-level 0))) (let ((idx (math-read-expr-level 0)))
(or (equal math-expr-data "]") (or (equal math-expr-data "]")
(throw 'syntax "Expected `]'")) (throw 'syntax "Expected `]'"))
@ -1947,7 +1950,7 @@ order to Calc's."
(math-compose-expr (nth 2 a) 0) (math-compose-expr (nth 2 a) 0)
"]]")))) "]]"))))
(defun math-read-math-subscr (x op) (defun math-read-math-subscr (x _op)
(let ((idx (math-read-expr-level 0))) (let ((idx (math-read-expr-level 0)))
(or (and (equal math-expr-data "]") (or (and (equal math-expr-data "]")
(progn (progn
@ -2094,10 +2097,13 @@ order to Calc's."
(defvar math-rb-v1) (defvar math-rb-v1)
(defvar math-rb-v2) (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) &optional baseline prec short)
(or prec (setq prec 0)) (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. ;; Clip whitespace above or below.
(while (and (< math-rb-v1 math-rb-v2) (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))) (math-read-big-emptyp math-rb-h1 math-rb-v1 math-rb-h2 (1+ math-rb-v1)))
@ -2449,7 +2455,7 @@ order to Calc's."
math-read-big-h2 h) math-read-big-h2 h)
(or short (= math-read-big-h2 math-rb-h2) (or short (= math-read-big-h2 math-rb-h2)
(math-read-big-error h baseline)) (math-read-big-error h baseline))
p))) p))))
(defun math-read-big-char (h v) (defun math-read-big-char (h v)
(or (and (>= h math-rb-h1) (or (and (>= h math-rb-h1)

1
lisp/calc/calc-macs.el
View file

@ -61,6 +61,7 @@
(defmacro calc-with-trail-buffer (&rest body) (defmacro calc-with-trail-buffer (&rest body)
`(let ((save-buf (current-buffer)) `(let ((save-buf (current-buffer))
(calc-command-flags nil)) (calc-command-flags nil))
(ignore save-buf) ;FIXME: Use a name less conflict-prone!
(with-current-buffer (calc-trail-display t) (with-current-buffer (calc-trail-display t)
(progn (progn
(goto-char calc-trail-pointer) (goto-char calc-trail-pointer)

24
lisp/calc/calc-map.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -48,6 +48,8 @@
(math-calcFunc-to-var (nth 1 oper)) (math-calcFunc-to-var (nth 1 oper))
expr))))) expr)))))
(defvar calc-mapping-dir nil)
(defun calc-reduce (&optional oper accum) (defun calc-reduce (&optional oper accum)
(interactive) (interactive)
(calc-wrapper (calc-wrapper
@ -136,7 +138,6 @@
(1+ calc-dollar-used)))))))) (1+ calc-dollar-used))))))))
(defvar calc-verify-arglist t) (defvar calc-verify-arglist t)
(defvar calc-mapping-dir nil)
(defun calc-map-stack () (defun calc-map-stack ()
"This is meant to be called by calc-keypad mode." "This is meant to be called by calc-keypad mode."
(interactive) (interactive)
@ -853,7 +854,7 @@
(i -1) (i -1)
(math-working-step 0) (math-working-step 0)
(math-working-step-2 nil) (math-working-step-2 nil)
len cols obj expr) len obj expr) ;; cols
(if (eq mode 'eqn) (if (eq mode 'eqn)
(setq mode 'elems (setq mode 'elems
heads '(calcFunc-eq calcFunc-neq calcFunc-lt calcFunc-gt heads '(calcFunc-eq calcFunc-neq calcFunc-lt calcFunc-gt
@ -1023,7 +1024,7 @@
(let ((expr (car (setq vec (cdr vec))))) (let ((expr (car (setq vec (cdr vec)))))
(if expr (if expr
(progn (progn
(condition-case err (ignore-errors
(and (symbolp func) (and (symbolp func)
(let ((lfunc (or (cdr (assq func (let ((lfunc (or (cdr (assq func
'( (calcFunc-add . math-add) '( (calcFunc-add . math-add)
@ -1032,13 +1033,12 @@
(calcFunc-div . math-div) (calcFunc-div . math-div)
(calcFunc-pow . math-pow) (calcFunc-pow . math-pow)
(calcFunc-mod . math-mod) (calcFunc-mod . math-mod)
(calcFunc-vconcat . (calcFunc-vconcat
math-concat) ))) . math-concat) )))
func))) func)))
(while (cdr vec) (while (cdr vec)
(setq expr (funcall lfunc expr (nth 1 vec)) (setq expr (funcall lfunc expr (nth 1 vec))
vec (cdr vec))))) vec (cdr vec))))))
(error nil))
(while (setq vec (cdr vec)) (while (setq vec (cdr vec))
(setq expr (math-build-call func (list expr (car vec))))) (setq expr (math-build-call func (list expr (car vec)))))
(math-normalize expr)) (math-normalize expr))
@ -1229,9 +1229,11 @@
(defvar math-inner-mul-func) (defvar math-inner-mul-func)
(defvar math-inner-add-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 a) (math-reject-arg a 'vectorp))
(or (math-vectorp b) (math-reject-arg b '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 a)
(if (math-matrixp b) (if (math-matrixp b)
(if (= (length (nth 1 a)) (length b)) (if (= (length (nth 1 a)) (length b))
@ -1247,12 +1249,12 @@
(math-dimension-error)))) (math-dimension-error))))
(if (math-matrixp b) (if (math-matrixp b)
(nth 1 (math-inner-mats (list 'vec a) 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) (defun math-inner-mats (a b)
(let ((mat nil) (let ((mat nil)
(cols (length (nth 1 b))) (cols (length (nth 1 b)))
row col ap bp accum) row col) ;; ap bp accum
(while (setq a (cdr a)) (while (setq a (cdr a))
(setq col cols (setq col cols
row nil) row nil)

62
lisp/calc/calc-math.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -60,33 +60,23 @@
pow pow
(< pow 1.0e+INF)) (< pow 1.0e+INF))
(setq x (* 2 x)) (setq x (* 2 x))
(setq pow (condition-case nil (setq pow (ignore-errors (expt 10.0 (* 2 x)))))
(expt 10.0 (* 2 x))
(error nil))))
;; The following loop should stop when 10^(x+1) is too large. ;; The following loop should stop when 10^(x+1) is too large.
(setq pow (condition-case nil (setq pow (ignore-errors (expt 10.0 (1+ x))))
(expt 10.0 (1+ x))
(error nil)))
(while (and (while (and
pow pow
(< pow 1.0e+INF)) (< pow 1.0e+INF))
(setq x (1+ x)) (setq x (1+ x))
(setq pow (condition-case nil (setq pow (ignore-errors (expt 10.0 (1+ x)))))
(expt 10.0 (1+ x))
(error nil))))
(1- x)) (1- x))
"The largest exponent which Calc will convert to an Emacs float.") "The largest exponent which Calc will convert to an Emacs float.")
(defvar math-smallest-emacs-expt (defvar math-smallest-emacs-expt
(let ((x -1)) (let ((x -1))
(while (condition-case nil (while (ignore-errors (> (expt 10.0 x) 0.0))
(> (expt 10.0 x) 0.0)
(error nil))
(setq x (* 2 x))) (setq x (* 2 x)))
(setq x (/ x 2)) (setq x (/ x 2))
(while (condition-case nil (while (ignore-errors (> (expt 10.0 x) 0.0))
(> (expt 10.0 x) 0.0)
(error nil))
(setq x (1- x))) (setq x (1- x)))
(+ x 2)) (+ x 2))
"The smallest exponent which Calc will convert to an Emacs float.") "The smallest exponent which Calc will convert to an Emacs float.")
@ -100,7 +90,7 @@ If this can't be done, return NIL."
(let* ((xpon (+ (nth 2 x) (1- (math-numdigs (nth 1 x)))))) (let* ((xpon (+ (nth 2 x) (1- (math-numdigs (nth 1 x))))))
(and (<= math-smallest-emacs-expt xpon) (and (<= math-smallest-emacs-expt xpon)
(<= xpon math-largest-emacs-expt) (<= xpon math-largest-emacs-expt)
(condition-case nil (ignore-errors
(math-read-number (math-read-number
(number-to-string (number-to-string
(funcall fn (funcall fn
@ -111,8 +101,7 @@ If this can't be done, return NIL."
(calc-float-format (list 'float calc-internal-prec)) (calc-float-format (list 'float calc-internal-prec))
(calc-group-digits nil) (calc-group-digits nil)
(calc-point-char ".")) (calc-point-char "."))
(math-format-number (math-float x))))))) (math-format-number (math-float x))))))))))))
(error nil))))))
(defun calc-sqrt (arg) (defun calc-sqrt (arg)
(interactive "P") (interactive "P")
@ -638,11 +627,11 @@ If this can't be done, return NIL."
(defvar math-nrf-nf) (defvar math-nrf-nf)
(defvar math-nrf-nfm1) (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-inexact-result)
(math-with-extra-prec 1 (math-with-extra-prec 1
(let ((math-nrf-nf (math-float math-nrf-n)) (let ((math-nrf-nf (math-float nrf-n))
(math-nrf-nfm1 (math-float (1- math-nrf-n)))) (math-nrf-nfm1 (math-float (1- nrf-n))))
(math-nth-root-float-iter a (or guess (math-nth-root-float-iter a (or guess
(math-make-float (math-make-float
1 (/ (+ (math-numdigs (nth 1 a)) 1 (/ (+ (math-numdigs (nth 1 a))
@ -665,11 +654,12 @@ If this can't be done, return NIL."
;; math-nth-root-int. ;; math-nth-root-int.
(defvar math-nri-n) (defvar math-nri-n)
(defun math-nth-root-integer (a math-nri-n &optional guess) ; [I I S] (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-nth-root-int-iter a (or guess
(math-scale-int 1 (/ (+ (math-numdigs a) (math-scale-int 1 (/ (+ (math-numdigs a)
(1- math-nri-n)) (1- nri-n))
math-nri-n))))) nri-n))))))
(defun math-nth-root-int-iter (a guess) (defun math-nth-root-int-iter (a guess)
(math-working "root" guess) (math-working "root" guess)
@ -693,13 +683,13 @@ If this can't be done, return NIL."
;;;; Transcendental functions. ;;;; Transcendental functions.
;;; All of these functions are defined on the complex plane. ;; All of these functions are defined on the complex plane.
;;; (Branch cuts, etc. follow Steele's Common Lisp book.) ;; (Branch cuts, etc. follow Steele's Common Lisp book.)
;;; Most functions increase calc-internal-prec by 2 digits, then round ;; Most functions increase calc-internal-prec by 2 digits, then round
;;; down afterward. "-raw" functions use the current precision, require ;; down afterward. "-raw" functions use the current precision, require
;;; their arguments to be in float (or complex float) format, and always ;; their arguments to be in float (or complex float) format, and always
;;; work in radians (where applicable). ;; work in radians (where applicable).
(defun math-to-radians (a) ; [N N] (defun math-to-radians (a) ; [N N]
(cond ((eq (car-safe a) 'hms) (cond ((eq (car-safe a) 'hms)
@ -1126,9 +1116,9 @@ If this can't be done, return NIL."
(math-div-float (cdr sc) (car sc))))))) (math-div-float (cdr sc) (car sc)))))))
;;; This could use a smarter method: Reduce x as in math-sin-raw, then ;; 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 ;; compute either sin(x) or cos(x), whichever is smaller, and compute
;;; the other using the identity sin(x)^2 + cos(x)^2 = 1. ;; 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)) (defun math-sin-cos-raw (x) ; [F.F F] (result is (sin x . cos x))
(cons (math-sin-raw x) (math-cos-raw x))) (cons (math-sin-raw x) (math-cos-raw x)))
@ -2072,7 +2062,7 @@ If this can't be done, return NIL."
(put 'calcFunc-arctanh 'math-expandable t) (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] (defun calcFunc-rad (a) ; [R R] [Public]
(cond ((or (Math-numberp a) (cond ((or (Math-numberp a)
(eq (car a) 'intv)) (eq (car a) 'intv))
@ -2089,7 +2079,7 @@ If this can't be done, return NIL."
(t (list 'calcFunc-rad a)))) (t (list 'calcFunc-rad a))))
(put 'calcFunc-rad 'math-expandable t) (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] (defun calcFunc-deg (a) ; [R R] [Public]
(cond ((or (Math-numberp a) (cond ((or (Math-numberp a)
(eq (car a) 'intv)) (eq (car a) 'intv))

2
lisp/calc/calc-menu.el
View file

@ -1,4 +1,4 @@
;;; calc-menu.el --- a menu for Calc ;;; calc-menu.el --- a menu for Calc -*- lexical-binding:t -*-
;; Copyright (C) 2007-2020 Free Software Foundation, Inc. ;; Copyright (C) 2007-2020 Free Software Foundation, Inc.

6
lisp/calc/calc-misc.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -505,7 +505,7 @@ With argument 0, switch line point is in with line mark is in."
;; 3 <-- mid-line = 3 ;; 3 <-- mid-line = 3
;; 4 <-- point ;; 4 <-- point
;; 5 <-- bot-line = 5 ;; 5 <-- bot-line = 5
(dotimes (i mid-line) (dotimes (_ mid-line)
(setq mid-cell old-top-list (setq mid-cell old-top-list
old-top-list (cdr old-top-list)) old-top-list (cdr old-top-list))
(setcdr mid-cell new-top-list) (setcdr mid-cell new-top-list)
@ -519,7 +519,7 @@ With argument 0, switch line point is in with line mark is in."
;; 2 ;; 2
;; 1 ;; 1
(setq prev-mid-cell old-top-list) (setq prev-mid-cell old-top-list)
(dotimes (i (- bot-line mid-line)) (dotimes (_ (- bot-line mid-line))
(setq bot-cell old-top-list (setq bot-cell old-top-list
old-top-list (cdr old-top-list)) old-top-list (cdr old-top-list))
(setcdr bot-cell new-top-list) (setcdr bot-cell new-top-list)

6
lisp/calc/calc-mode.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -424,8 +424,8 @@
(t (t
"Not recording mode changes permanently"))))) "Not recording mode changes permanently")))))
(defun calc-total-algebraic-mode (flag) (defun calc-total-algebraic-mode (&optional _flag)
(interactive "P") (interactive)
(calc-wrapper (calc-wrapper
(if (eq calc-algebraic-mode 'total) (if (eq calc-algebraic-mode 'total)
(calc-algebraic-mode nil) (calc-algebraic-mode nil)

2
lisp/calc/calc-mtx.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.

94
lisp/calc/calc-nlfit.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 2007-2020 Free Software Foundation, Inc.
@ -104,19 +104,19 @@
(list 'vec C12 C22)))) (list 'vec C12 C22))))
(list A B))))) (list A B)))))
;;; The methods described by de Sousa require the cumulative data qdata ;; The methods described by de Sousa require the cumulative data qdata
;;; and the rates pdata. We will assume that we are given either ;; and the rates pdata. We will assume that we are given either
;;; qdata and the corresponding times tdata, or pdata and the corresponding ;; qdata and the corresponding times tdata, or pdata and the corresponding
;;; tdata. The following two functions will find pdata or qdata, ;; tdata. The following two functions will find pdata or qdata,
;;; given the other.. ;; given the other..
;;; First, given two lists; one of values q0, q1, ..., qn and one of ;; First, given two lists; one of values q0, q1, ..., qn and one of
;;; corresponding times t0, t1, ..., tn; return a list ;; corresponding times t0, t1, ..., tn; return a list
;;; p0, p1, ..., pn of the rates of change of the qi with respect to t. ;; 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). ;; p0 is the right hand derivative (q1 - q0)/(t1 - t0).
;;; pn is the left hand derivative (qn - q(n-1))/(tn - t(n-1)). ;; pn is the left hand derivative (qn - q(n-1))/(tn - t(n-1)).
;;; The other pis are the averages of the two: ;; 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)). ;; (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) (defun math-nlfit-get-rates-from-cumul (tdata qdata)
(let ((pdata (list (let ((pdata (list
@ -153,12 +153,12 @@
pdata)) pdata))
(reverse pdata))) (reverse pdata)))
;;; Next, given two lists -- one of rates p0, p1, ..., pn and one of ;; Next, given two lists -- one of rates p0, p1, ..., pn and one of
;;; corresponding times t0, t1, ..., tn -- and an initial values q0, ;; corresponding times t0, t1, ..., tn -- and an initial values q0,
;;; return a list q0, q1, ..., qn of the cumulative values. ;; return a list q0, q1, ..., qn of the cumulative values.
;;; q0 is the initial value given. ;; q0 is the initial value given.
;;; For i>0, qi is computed using the trapezoid rule: ;; For i>0, qi is computed using the trapezoid rule:
;;; qi = q(i-1) + (1/2)(pi + p(i-1))(ti - t(i-1)) ;; qi = q(i-1) + (1/2)(pi + p(i-1))(ti - t(i-1))
(defun math-nlfit-get-cumul-from-rates (tdata pdata q0) (defun math-nlfit-get-cumul-from-rates (tdata pdata q0)
(let* ((qdata (list q0))) (let* ((qdata (list q0)))
@ -177,16 +177,16 @@
(setq tdata (cdr tdata))) (setq tdata (cdr tdata)))
(reverse qdata))) (reverse qdata)))
;;; Given the qdata, pdata and tdata, find the parameters ;; Given the qdata, pdata and tdata, find the parameters
;;; a, b and c that fit q = a/(1+b*exp(c*t)). ;; a, b and c that fit q = a/(1+b*exp(c*t)).
;;; a is found using the method described by de Sousa. ;; a is found using the method described by de Sousa.
;;; b and c are found using least squares on the linearization ;; b and c are found using least squares on the linearization
;;; log((a/q)-1) = log(b) + c*t ;; log((a/q)-1) = log(b) + c*t
;;; In some cases (where the logistic curve may well be the wrong ;; 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 ;; 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. ;; 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 ;; In this case, a will be replaced by a number slightly above
;;; the maximum value of q. ;; the maximum value of q.
(defun math-nlfit-find-qmax (qdata pdata tdata) (defun math-nlfit-find-qmax (qdata pdata tdata)
(let* ((ratios (math-map-binop 'math-div pdata qdata)) (let* ((ratios (math-map-binop 'math-div pdata qdata))
@ -208,12 +208,12 @@
(calcFunc-exp (nth 0 bandc)) (calcFunc-exp (nth 0 bandc))
(nth 1 bandc)))) (nth 1 bandc))))
;;; Next, given the pdata and tdata, we can find the qdata if we know 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 ;; 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 ;; 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. ;; 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) (defun math-nlfit-find-qmaxhalf (pdata tdata)
(let ((pmax (math-max-list (car pdata) (cdr pdata))) (let ((pmax (math-max-list (car pdata) (cdr pdata)))
@ -231,7 +231,7 @@
(setq tdata (cdr tdata))) (setq tdata (cdr tdata)))
qmh)) qmh))
;;; Next, given pdata and tdata, approximate q0. ;; Next, given pdata and tdata, approximate q0.
(defun math-nlfit-find-q0 (pdata tdata) (defun math-nlfit-find-q0 (pdata tdata)
(let* ((qhalf (math-nlfit-find-qmaxhalf pdata tdata)) (let* ((qhalf (math-nlfit-find-qmaxhalf pdata tdata))
@ -250,7 +250,7 @@
(setq q0 (math-add q0 qhalf))) (setq q0 (math-add q0 qhalf)))
(let* ((qmin (math-sub q0 qhalf)) (let* ((qmin (math-sub q0 qhalf))
(qmax q0) (qmax q0)
(qt (math-nlfit-find-qmax (_qt (math-nlfit-find-qmax
(mapcar (mapcar
(lambda (q) (math-add q0 q)) (lambda (q) (math-add q0 q))
qdata) qdata)
@ -270,20 +270,20 @@
(setq i (1+ i))) (setq i (1+ i)))
(math-mul '(float 5 -1) (math-add qmin qmax))))) (math-mul '(float 5 -1) (math-add qmin qmax)))))
;;; To improve the approximations to the parameters, we can use ;; To improve the approximations to the parameters, we can use
;;; Marquardt method as described in Schwarz's book. ;; 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-delta '(float 1 -8))
(defvar math-nlfit-epsilon '(float 1 -5)) (defvar math-nlfit-epsilon '(float 1 -5))
;;; Maximum number of iterations ;; Maximum number of iterations
(defvar math-nlfit-max-its 100) (defvar math-nlfit-max-its 100)
;;; Next, we need some functions for dealing with vectors and ;; Next, we need some functions for dealing with vectors and
;;; matrices. For convenience, we'll work with Emacs lists ;; matrices. For convenience, we'll work with Emacs lists
;;; as vectors, rather than Calc's vectors. ;; as vectors, rather than Calc's vectors.
(defun math-nlfit-set-elt (vec i x) (defun math-nlfit-set-elt (vec i x)
(setcar (nthcdr (1- i) vec) x)) (setcar (nthcdr (1- i) vec) x))
@ -589,7 +589,7 @@
(calcFunc-trn j) j)) (calcFunc-trn j) j))
(calcFunc-inv 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) (let* ((sgs nil)
(covar (math-nlfit-find-covar grad xlist pparms)) (covar (math-nlfit-find-covar grad xlist pparms))
(n (1- (length covar))) (n (1- (length covar)))
@ -664,6 +664,8 @@
(calc-pop-push-record-list n prefix vals) (calc-pop-push-record-list n prefix vals)
(calc-handle-whys)) (calc-handle-whys))
(defvar calc-curve-nvars)
(defun math-nlfit-fit-curve (fn grad solnexpr initparms &optional sdv) (defun math-nlfit-fit-curve (fn grad solnexpr initparms &optional sdv)
(calc-slow-wrapper (calc-slow-wrapper
(let* ((sdevv (or (eq sdv 'calcFunc-efit) (eq sdv 'calcFunc-xfit))) (let* ((sdevv (or (eq sdv 'calcFunc-efit) (eq sdv 'calcFunc-xfit)))
@ -678,7 +680,7 @@
(calc-curve-varnames nil) (calc-curve-varnames nil)
(calc-curve-coefnames nil) (calc-curve-coefnames nil)
(calc-curve-nvars 1) (calc-curve-nvars 1)
(fitvars (calc-get-fit-variables 1 3)) (_fitvars (calc-get-fit-variables 1 3))
(var (nth 1 calc-curve-varnames)) (var (nth 1 calc-curve-varnames))
(parms (cdr calc-curve-coefnames)) (parms (cdr calc-curve-coefnames))
(parmguess (parmguess
@ -763,7 +765,7 @@
(calc-curve-varnames nil) (calc-curve-varnames nil)
(calc-curve-coefnames nil) (calc-curve-coefnames nil)
(calc-curve-nvars 1) (calc-curve-nvars 1)
(fitvars (calc-get-fit-variables 1 2)) (_fitvars (calc-get-fit-variables 1 2))
(var (nth 1 calc-curve-varnames)) (var (nth 1 calc-curve-varnames))
(parms (cdr calc-curve-coefnames)) (parms (cdr calc-curve-coefnames))
(soln (list '* (nth 0 finalparms) (soln (list '* (nth 0 finalparms)

30
lisp/calc/calc-prog.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -111,10 +111,15 @@
"Not reporting timing of commands")))) "Not reporting timing of commands"))))
(defun calc-pass-errors () (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) (interactive)
;; The following two cases are for the new, optimizing byte compiler ;; The following two cases are for the new, optimizing byte compiler
;; or the standard 18.57 byte compiler, respectively. ;; 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))) (let ((place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 15)))
(or (memq (car-safe (car-safe place)) '(error xxxerror)) (or (memq (car-safe (car-safe place)) '(error xxxerror))
(setq place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 27))) (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, ;; calc-user-define-composition and calc-finish-formula-edit,
;; but is used by calc-fix-user-formula. ;; but is used by calc-fix-user-formula.
(defvar calc-user-formula-alist) (defvar calc-user-formula-alist)
(defvar math-arglist) ; dynamically bound in all callers
(defun calc-user-define-formula () (defun calc-user-define-formula ()
(interactive) (interactive)
@ -328,7 +334,6 @@
(setcdr kmap (cons (cons key cmd) (cdr kmap))))))) (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
(message ""))) (message "")))
(defvar math-arglist) ; dynamically bound in all callers
(defun calc-default-formula-arglist (form) (defun calc-default-formula-arglist (form)
(if (consp form) (if (consp form)
(if (eq (car form) 'var) (if (eq (car form) 'var)
@ -511,8 +516,9 @@
;; is called (indirectly) by calc-read-parse-table. ;; is called (indirectly) by calc-read-parse-table.
(defvar calc-lang) (defvar calc-lang)
(defun calc-write-parse-table (tab calc-lang) (defun calc-write-parse-table (tab lang)
(let ((p tab)) (let ((calc-lang lang)
(p tab))
(while p (while p
(calc-write-parse-table-part (car (car p))) (calc-write-parse-table-part (car (car p)))
(insert ":= " (insert ":= "
@ -551,8 +557,9 @@
(insert " ")))) (insert " "))))
(setq p (cdr p)))) (setq p (cdr p))))
(defun calc-read-parse-table (calc-buf calc-lang) (defun calc-read-parse-table (calc-buf lang)
(let ((tab nil)) (let ((calc-lang lang)
(tab nil))
(while (progn (while (progn
(skip-chars-forward "\n\t ") (skip-chars-forward "\n\t ")
(not (eobp))) (not (eobp)))
@ -860,7 +867,7 @@
(defun calc-edit-macro-combine-digits () (defun calc-edit-macro-combine-digits ()
"Put an entire sequence of digits on a single line." "Put an entire sequence of digits on a single line."
(let ((line (calc-edit-macro-command)) (let ((line (calc-edit-macro-command))
curline) ) ;; curline
(goto-char (line-beginning-position)) (goto-char (line-beginning-position))
(kill-line 1) (kill-line 1)
(while (string-equal (calc-edit-macro-command-type) "calcDigit-start") (while (string-equal (calc-edit-macro-command-type) "calcDigit-start")
@ -1038,7 +1045,7 @@ Redefine the corresponding command."
(let* ((cmd (cdr def)) (let* ((cmd (cdr def))
(fcmd (and cmd (symbolp cmd) (symbol-function cmd))) (fcmd (and cmd (symbolp cmd) (symbol-function cmd)))
(func nil) (func nil)
(pt (point)) ;; (pt (point))
(fill-column 70) (fill-column 70)
(fill-prefix nil) (fill-prefix nil)
str q-ok) str q-ok)
@ -1945,8 +1952,9 @@ Redefine the corresponding command."
;; by math-define-body. ;; by math-define-body.
(defvar math-exp-env) (defvar math-exp-env)
(defun math-define-body (body math-exp-env) (defun math-define-body (body exp-env)
(math-define-list body)) (let ((math-exp-env exp-env))
(math-define-list body)))
(defun math-define-list (body &optional quote) (defun math-define-list (body &optional quote)
(cond ((null body) (cond ((null body)

44
lisp/calc/calc-rewr.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -142,7 +142,7 @@
(calc-pop-push-record-list n "rwrt" (list expr))) (calc-pop-push-record-list n "rwrt" (list expr)))
(calc-handle-whys))) (calc-handle-whys)))
(defun calc-match (pat &optional interactive) (defun calc-match (pat &optional _interactive)
(interactive "sPattern: \np") (interactive "sPattern: \np")
(calc-slow-wrapper (calc-slow-wrapper
(let (n expr) (let (n expr)
@ -158,9 +158,9 @@
(setq expr (calc-top-n 1) (setq expr (calc-top-n 1)
n 1)) n 1))
(or (math-vectorp expr) (error "Argument must be a vector")) (or (math-vectorp expr) (error "Argument must be a vector"))
(if (calc-is-inverse) (calc-enter-result n "mtcn"
(calc-enter-result n "mtcn" (math-match-patterns pat expr t)) (math-match-patterns pat expr
(calc-enter-result n "mtch" (math-match-patterns pat expr nil)))))) (not (not (calc-is-inverse))))))))
(defvar math-mt-many) (defvar math-mt-many)
@ -169,8 +169,10 @@
;; but is used by math-rewrite-phase ;; but is used by math-rewrite-phase
(defvar math-rewrite-whole-expr) (defvar math-rewrite-whole-expr)
(defun math-rewrite (math-rewrite-whole-expr rules &optional math-mt-many) (defun math-rewrite (rewrite-whole-expr rules &optional mt-many)
(let* ((crules (math-compile-rewrites rules)) (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)) (heads (math-rewrite-heads math-rewrite-whole-expr))
(trace-buffer (get-buffer "*Trace*")) (trace-buffer (get-buffer "*Trace*"))
(calc-display-just 'center) (calc-display-just 'center)
@ -211,6 +213,8 @@
":\n" fmt "\n")))) ":\n" fmt "\n"))))
math-rewrite-whole-expr)) math-rewrite-whole-expr))
(defvar math-rewrite-phase 1)
(defun math-rewrite-phase (sched) (defun math-rewrite-phase (sched)
(while (and sched (/= math-mt-many 0)) (while (and sched (/= math-mt-many 0))
(if (listp (car sched)) (if (listp (car sched))
@ -464,6 +468,8 @@
;;; whole match the name v. Beware of circular structures! ;;; whole match the name v. Beware of circular structures!
;;; ;;;
(defvar math-rewrite-whole nil)
(defun math-compile-patterns (pats) (defun math-compile-patterns (pats)
(if (and (eq (car-safe pats) 'var) (if (and (eq (car-safe pats) 'var)
(calc-var-value (nth 2 pats))) (calc-var-value (nth 2 pats)))
@ -485,7 +491,6 @@
(cdr pats) (cdr pats)
(list pats))))))))) (list pats)))))))))
(defvar math-rewrite-whole nil)
(defvar math-make-import-list nil) (defvar math-make-import-list nil)
;; The variable math-import-list is local to part of math-compile-rewrites, ;; The variable math-import-list is local to part of math-compile-rewrites,
@ -580,7 +585,7 @@
(let ((rule-set nil) (let ((rule-set nil)
(all-heads nil) (all-heads nil)
(nil-rules nil) (nil-rules nil)
(rule-count 0) ;; (rule-count 0)
(math-schedule nil) (math-schedule nil)
(math-iterations nil) (math-iterations nil)
(math-phases nil) (math-phases nil)
@ -831,14 +836,16 @@
(defvar math-rwcomp-subst-new-func) (defvar math-rwcomp-subst-new-func)
(defvar math-rwcomp-subst-old-func) (defvar math-rwcomp-subst-old-func)
(defun math-rwcomp-substitute (expr math-rwcomp-subst-old math-rwcomp-subst-new) (defun math-rwcomp-substitute (expr rwcomp-subst-old rwcomp-subst-new)
(if (and (eq (car-safe math-rwcomp-subst-old) 'var) (let ((math-rwcomp-subst-old rwcomp-subst-old)
(memq (car-safe math-rwcomp-subst-new) '(var calcFunc-lambda))) (math-rwcomp-subst-new rwcomp-subst-new))
(let ((math-rwcomp-subst-old-func (math-var-to-calcFunc math-rwcomp-subst-old)) (if (and (eq (car-safe rwcomp-subst-old) 'var)
(math-rwcomp-subst-new-func (math-var-to-calcFunc math-rwcomp-subst-new))) (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)) (math-rwcomp-subst-rec expr))
(let ((math-rwcomp-subst-old-func nil)) (let ((math-rwcomp-subst-old-func nil))
(math-rwcomp-subst-rec expr)))) (math-rwcomp-subst-rec expr)))))
(defun math-rwcomp-subst-rec (expr) (defun math-rwcomp-subst-rec (expr)
(cond ((equal expr math-rwcomp-subst-old) math-rwcomp-subst-new) (cond ((equal expr math-rwcomp-subst-old) math-rwcomp-subst-new)
@ -1452,8 +1459,6 @@
,form ,form
(setcar rules orig)))) (setcar rules orig))))
(defvar math-rewrite-phase 1)
;; The variable math-apply-rw-regs is local to math-apply-rewrites, ;; 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 ;; but is used by math-rwapply-replace-regs and math-rwapply-reg-looks-negp
;; which are called by math-apply-rewrites. ;; which are called by math-apply-rewrites.
@ -1463,11 +1468,12 @@
;; but is used by math-rwapply-remember. ;; but is used by math-rwapply-remember.
(defvar math-apply-rw-ruleset) (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 (and
(setq rules (cdr (or (assq (car-safe expr) rules) (setq rules (cdr (or (assq (car-safe expr) rules)
(assq nil 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 op math-apply-rw-regs inst part pc mark btrack
(tracing math-rwcomp-tracing) (tracing math-rwcomp-tracing)
(phase math-rewrite-phase)) (phase math-rewrite-phase))

2
lisp/calc/calc-rules.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.

16
lisp/calc/calc-sel.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -146,7 +146,8 @@
(defvar calc-fnp-op) (defvar calc-fnp-op)
(defvar calc-fnp-num) (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 (if (and calc-assoc-selections
(assq (car-safe expr) calc-assoc-ops)) (assq (car-safe expr) calc-assoc-ops))
(let (calc-fnp-op) (let (calc-fnp-op)
@ -154,7 +155,7 @@
(if (eq (car-safe expr) 'intv) (if (eq (car-safe expr) 'intv)
(and (>= calc-fnp-num 1) (<= calc-fnp-num 2) (nth (1+ calc-fnp-num) expr)) (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)) (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 (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)) (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))) ;; (if (or (< num 1) (> num (calc-stack-size)))
;; (error "Cursor must be positioned on a stack element")) ;; (error "Cursor must be positioned on a stack element"))
(let* ((entry (calc-top num 'entry)) (let* ((entry (calc-top num 'entry))
ww w) ) ;; ww w
(or (equal entry calc-selection-cache-entry) (or (equal entry calc-selection-cache-entry)
(progn (progn
(setcar entry (calc-encase-atoms (car entry))) (setcar entry (calc-encase-atoms (car entry)))
@ -481,8 +482,9 @@
(defvar calc-rsf-old) (defvar calc-rsf-old)
(defvar calc-rsf-new) (defvar calc-rsf-new)
(defun calc-replace-sub-formula (expr calc-rsf-old calc-rsf-new) (defun calc-replace-sub-formula (expr rsf-old rsf-new)
(setq calc-rsf-new (calc-encase-atoms calc-rsf-new)) (let ((calc-rsf-old rsf-old)
(calc-rsf-new (calc-encase-atoms rsf-new))))
(calc-replace-sub-formula-rec expr)) (calc-replace-sub-formula-rec expr))
(defun calc-replace-sub-formula-rec (expr) (defun calc-replace-sub-formula-rec (expr)
@ -671,7 +673,7 @@
(entry (calc-top num 'entry)) (entry (calc-top num 'entry))
(expr (car entry)) (expr (car entry))
(sel (or (calc-auto-selection entry) expr)) (sel (or (calc-auto-selection entry) expr))
alg) ) ;; alg
(let ((str (math-showing-full-precision (let ((str (math-showing-full-precision
(math-format-nice-expr sel (frame-width))))) (math-format-nice-expr sel (frame-width)))))
(calc-edit-mode (list 'calc-finish-selection-edit (calc-edit-mode (list 'calc-finish-selection-edit

2
lisp/calc/calc-stat.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.

9
lisp/calc/calc-store.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -184,10 +184,11 @@
(defvar calc-read-var-name-history nil (defvar calc-read-var-name-history nil
"History for reading variable names.") "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 (setq calc-given-value nil
calc-aborted-prefix nil) calc-aborted-prefix nil)
(let ((var (concat (let* ((calc-store-opers store-opers)
(var (concat
"var-" "var-"
(let ((minibuffer-completion-table (let ((minibuffer-completion-table
(mapcar (lambda (x) (substring x 4)) (mapcar (lambda (x) (substring x 4))
@ -504,7 +505,7 @@
(calc-wrapper (calc-wrapper
(or var (setq var (calc-read-var-name "Declare: " 0))) (or var (setq var (calc-read-var-name "Declare: " 0)))
(or var (setq var 'var-All)) (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) (or (and (calc-var-value 'var-Decls)
(eq (car-safe var-Decls) 'vec)) (eq (car-safe var-Decls) 'vec))
(setq var-Decls (list 'vec))) (setq var-Decls (list 'vec)))

7
lisp/calc/calc-stuff.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -273,8 +273,9 @@ With a prefix, push that prefix as a number onto the stack."
;; math-map-over-constants. ;; math-map-over-constants.
(defvar math-moc-func) (defvar math-moc-func)
(defun math-map-over-constants (math-moc-func expr) (defun math-map-over-constants (moc-func expr)
(math-map-over-constants-rec expr)) (let ((math-moc-func moc-func))
(math-map-over-constants-rec expr)))
(defun math-map-over-constants-rec (expr) (defun math-map-over-constants-rec (expr)
(cond ((or (Math-primp expr) (cond ((or (Math-primp expr)

2
lisp/calc/calc-trail.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.

2
lisp/calc/calc-undo.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.

29
lisp/calc/calc-vec.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -1111,18 +1111,20 @@
;; by calcFunc-grade and calcFunc-rgrade. ;; by calcFunc-grade and calcFunc-rgrade.
(defvar math-grade-vec) (defvar math-grade-vec)
(defun calcFunc-grade (math-grade-vec) (defun calcFunc-grade (grade-vec)
(if (math-vectorp math-grade-vec) (if (math-vectorp grade-vec)
(let* ((len (1- (length math-grade-vec)))) (let* ((math-grade-vec grade-vec)
(cons 'vec (sort (cdr (calcFunc-index len)) 'math-grade-beforep))) (len (1- (length grade-vec))))
(math-reject-arg math-grade-vec 'vectorp))) (cons 'vec (sort (cdr (calcFunc-index len)) #'math-grade-beforep)))
(math-reject-arg grade-vec #'vectorp)))
(defun calcFunc-rgrade (math-grade-vec) (defun calcFunc-rgrade (grade-vec)
(if (math-vectorp math-grade-vec) (if (math-vectorp grade-vec)
(let* ((len (1- (length math-grade-vec)))) (let* ((math-grade-vec grade-vec)
(len (1- (length grade-vec))))
(cons 'vec (nreverse (sort (cdr (calcFunc-index len)) (cons 'vec (nreverse (sort (cdr (calcFunc-index len))
'math-grade-beforep)))) #'math-grade-beforep))))
(math-reject-arg math-grade-vec 'vectorp))) (math-reject-arg grade-vec #'vectorp)))
(defun math-grade-beforep (i j) (defun math-grade-beforep (i j)
(math-beforep (nth i math-grade-vec) (nth j math-grade-vec))) (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-exp-keep-spaces)
(defvar math-expr-data) (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)))) (and space-sep (setq space-sep (not (math-check-for-commas))))
(math-read-token) (math-read-token)
(while (eq math-exp-token 'space) (while (eq math-exp-token 'space)
@ -1624,7 +1627,7 @@ of two matrices is a matrix."
(throw 'syntax "Expected `]'"))) (throw 'syntax "Expected `]'")))
(or (eq math-exp-token 'end) (or (eq math-exp-token 'end)
(math-read-token)) (math-read-token))
vals))) vals))))
(defun math-check-for-commas (&optional balancing) (defun math-check-for-commas (&optional balancing)
(let ((count 0) (let ((count 0)

6
lisp/calc/calc-yank.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -401,7 +401,7 @@ Interactively, reads the register using `register-read-with-preview'."
(let* ((from-buffer (current-buffer)) (let* ((from-buffer (current-buffer))
(calc-was-started (get-buffer-window "*Calculator*")) (calc-was-started (get-buffer-window "*Calculator*"))
(single nil) (single nil)
data vals pos) data vals) ;; pos
(if arg (if arg
(if (consp arg) (if (consp arg)
(setq single t) (setq single t)
@ -776,7 +776,7 @@ To cancel the edit, simply kill the *Calc Edit* buffer."
(error "Original calculator buffer has been corrupted"))) (error "Original calculator buffer has been corrupted")))
(goto-char calc-edit-top) (goto-char calc-edit-top)
(if (buffer-modified-p) (if (buffer-modified-p)
(eval calc-edit-handler)) (eval calc-edit-handler t))
(if (and one-window (not (one-window-p t))) (if (and one-window (not (one-window-p t)))
(delete-window)) (delete-window))
(if (get-buffer-window return) (if (get-buffer-window return)

4
lisp/calc/calc.el
View file

@ -2313,7 +2313,7 @@ the United States."
((eq last-command-event ?@) "0@ ") ((eq last-command-event ?@) "0@ ")
(t (char-to-string last-command-event)))) (t (char-to-string last-command-event))))
(defvar calc-buffer) (defvar calc-buffer nil)
(defvar calc-prev-char) (defvar calc-prev-char)
(defvar calc-prev-prev-char) (defvar calc-prev-prev-char)
(defvar calc-digit-value) (defvar calc-digit-value)
@ -2353,7 +2353,7 @@ the United States."
(defun calcDigit-nondigit () (defun calcDigit-nondigit ()
(interactive) (interactive)
;; Exercise for the reader: Figure out why this is a good precaution! ;; 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)) (use-local-map minibuffer-local-map))
(let ((str (minibuffer-contents))) (let ((str (minibuffer-contents)))
(setq calc-digit-value (with-current-buffer calc-buffer (setq calc-digit-value (with-current-buffer calc-buffer

94
lisp/calc/calcalg2.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -333,8 +333,10 @@
(setq n (1+ n))) (setq n (1+ n)))
accum)))))) accum))))))
(defun calcFunc-deriv (expr math-deriv-var &optional deriv-value math-deriv-symb) (defun calcFunc-deriv (expr deriv-var &optional deriv-value deriv-symb)
(let* ((math-deriv-total nil) (let* ((math-deriv-var deriv-var)
(math-deriv-symb deriv-symb)
(math-deriv-total nil)
(res (catch 'math-deriv (math-derivative expr)))) (res (catch 'math-deriv (math-derivative expr))))
(or (eq (car-safe res) 'calcFunc-deriv) (or (eq (car-safe res) 'calcFunc-deriv)
(null res) (null res)
@ -344,9 +346,11 @@
(math-expr-subst res math-deriv-var deriv-value) (math-expr-subst res math-deriv-var deriv-value)
res)))) 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) (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)))) (res (catch 'math-deriv (math-derivative expr))))
(or (eq (car-safe res) 'calcFunc-tderiv) (or (eq (car-safe res) 'calcFunc-tderiv)
(null res) (null res)
@ -363,10 +367,10 @@
(function (lambda (u) (math-div 1 (math-mul 2 (list 'calcFunc-sqrt u)))))) (function (lambda (u) (math-div 1 (math-mul 2 (list 'calcFunc-sqrt u))))))
(put 'calcFunc-deg\' 'math-derivative-1 (put 'calcFunc-deg\' 'math-derivative-1
(function (lambda (u) (math-div-float '(float 18 1) (math-pi))))) (function (lambda (_) (math-div-float '(float 18 1) (math-pi)))))
(put 'calcFunc-rad\' 'math-derivative-1 (put 'calcFunc-rad\' 'math-derivative-1
(function (lambda (u) (math-pi-over-180)))) (function (lambda (_) (math-pi-over-180))))
(put 'calcFunc-ln\' 'math-derivative-1 (put 'calcFunc-ln\' 'math-derivative-1
(function (lambda (u) (math-div 1 u)))) (function (lambda (u) (math-div 1 u))))
@ -1079,8 +1083,9 @@
;; math-integ-try-substitutions. ;; math-integ-try-substitutions.
(defvar math-integ-expr) (defvar math-integ-expr)
(defun math-do-integral-methods (math-integ-expr) (defun math-do-integral-methods (integ-expr)
(let ((math-so-far math-integ-var-list-list) (let ((math-integ-expr integ-expr)
(math-so-far math-integ-var-list-list)
rat-in) rat-in)
;; Integration by substitution, for various likely sub-expressions. ;; Integration by substitution, for various likely sub-expressions.
@ -1195,10 +1200,11 @@
(defvar math-good-parts) (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: ;; Integration by parts:
;; integ(f(x) g(x),x) = f(x) h(x) - integ(h(x) f'(x),x) ;; integ(f(x) g(x),x) = f(x) h(x) - integ(h(x) f'(x),x)
;; where h(x) = integ(g(x),x). ;; where h(x) = integ(g(x),x).
(let ((math-good-parts good-parts))
(or (let ((exp (calcFunc-expand expr))) (or (let ((exp (calcFunc-expand expr)))
(and (not (equal exp expr)) (and (not (equal exp expr))
(math-integral exp))) (math-integral exp)))
@ -1219,14 +1225,14 @@
(and (eq (car expr) '^) (and (eq (car expr) '^)
(math-integrate-by-parts (math-pow (nth 1 expr) (math-integrate-by-parts (math-pow (nth 1 expr)
(math-sub (nth 2 expr) 1)) (math-sub (nth 2 expr) 1))
(nth 1 expr))))) (nth 1 expr))))))
(defun math-integrate-by-parts (u vprime) (defun math-integrate-by-parts (u vprime)
(let ((math-integ-level (if (or math-good-parts (let ((math-integ-level (if (or math-good-parts
(math-polynomial-p u math-integ-var)) (math-polynomial-p u math-integ-var))
math-integ-level math-integ-level
(1- math-integ-level))) (1- math-integ-level)))
(math-doing-parts t) ;; (math-doing-parts t) ;Unused
v temp) v temp)
(and (>= math-integ-level 0) (and (>= math-integ-level 0)
(unwind-protect (unwind-protect
@ -1532,7 +1538,7 @@
(math-any-substs t) (math-any-substs t)
(math-enable-subst nil) (math-enable-subst nil)
(math-prev-parts-v nil) (math-prev-parts-v nil)
(math-doing-parts nil) ;; (math-doing-parts nil) ;Unused
(math-good-parts nil) (math-good-parts nil)
(res (res
(if trace-buffer (if trace-buffer
@ -1883,7 +1889,10 @@
(defvar calc-high) (defvar calc-high)
(defvar math-var) (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 (or calc-low
(setq calc-low '(neg (var inf var-inf)) calc-high '(var inf var-inf))) (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)) (or calc-high (setq calc-high calc-low calc-low 1))
@ -1894,8 +1903,7 @@
(let ((known (+ (if (Math-objectp calc-low) 1 0) (let ((known (+ (if (Math-objectp calc-low) 1 0)
(if (Math-objectp calc-high) 1 0) (if (Math-objectp calc-high) 1 0)
(if (or (null step) (Math-objectp step)) 1 0))) (if (or (null step) (Math-objectp step)) 1 0)))
(count '(var inf var-inf)) (count '(var inf var-inf))) ;; vec
vec)
(or (= known 2) ; handy optimization (or (= known 2) ; handy optimization
(equal calc-high '(var inf var-inf)) (equal calc-high '(var inf var-inf))
(progn (progn
@ -1906,6 +1914,7 @@
(setq count (math-trunc count))))) (setq count (math-trunc count)))))
(if (Math-negp count) (if (Math-negp count)
(setq count -1)) (setq count -1))
(defvar var-DUMMY)
(if (integerp count) (if (integerp count)
(let ((var-DUMMY nil) (let ((var-DUMMY nil)
(vec math-tabulate-initial) (vec math-tabulate-initial)
@ -1939,7 +1948,7 @@
(and (not (and (equal calc-low '(neg (var inf var-inf))) (and (not (and (equal calc-low '(neg (var inf var-inf)))
(equal calc-high '(var inf var-inf)))) (equal calc-high '(var inf var-inf))))
(list calc-low calc-high)) (list calc-low calc-high))
(and step (list step)))))) (and step (list step)))))))
(defun math-scan-for-limits (x) (defun math-scan-for-limits (x)
(cond ((Math-primp x)) (cond ((Math-primp x))
@ -1951,8 +1960,10 @@
(high-val (math-solve-for (nth 2 x) (1- (length (nth 1 x))) (high-val (math-solve-for (nth 2 x) (1- (length (nth 1 x)))
math-var nil)) math-var nil))
temp) temp)
(and low-val (math-realp low-val) ;; FIXME: The below is a no-op, but I suspect its result
high-val (math-realp high-val)) ;; 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) (and (Math-lessp high-val low-val)
(setq temp low-val low-val high-val high-val temp)) (setq temp low-val low-val high-val high-val temp))
(setq calc-low (math-max calc-low (math-ceiling low-val)) (setq calc-low (math-max calc-low (math-ceiling low-val))
@ -2361,8 +2372,11 @@
(defvar math-try-solve-sign) (defvar math-try-solve-sign)
(defun math-try-solve-for (defun math-try-solve-for
(math-solve-lhs math-solve-rhs &optional math-try-solve-sign no-poly) (solve-lhs solve-rhs &optional try-solve-sign no-poly)
(let (math-t1 math-t2 math-t3) (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) (cond ((equal math-solve-lhs math-solve-var)
(setq math-solve-sign math-try-solve-sign) (setq math-solve-sign math-try-solve-sign)
(if (eq math-solve-full 'all) (if (eq math-solve-full 'all)
@ -2721,14 +2735,17 @@
(cons 'vec d) (cons 'vec d)
(math-reject-arg expr "Expected a polynomial")))) (math-reject-arg expr "Expected a polynomial"))))
(defun math-decompose-poly (math-solve-lhs math-solve-var degree sub-rhs) (defun math-decompose-poly (solve-lhs solve-var degree sub-rhs)
(let ((math-solve-rhs (or sub-rhs 1)) (let ((math-solve-lhs solve-lhs)
(math-solve-var solve-var)
(math-solve-rhs (or sub-rhs 1))
math-t1 math-t2 math-t3) math-t1 math-t2 math-t3)
(setq math-t2 (math-polynomial-base (setq math-t2 (math-polynomial-base
math-solve-lhs math-solve-lhs
(function (function
(lambda (math-solve-b) (lambda (solve-b)
(let ((math-poly-neg-powers '(1)) (let ((math-solve-b solve-b)
(math-poly-neg-powers '(1))
(math-poly-mult-powers nil) (math-poly-mult-powers nil)
(math-poly-frac-powers 1) (math-poly-frac-powers 1)
(math-poly-exp-base t)) (math-poly-exp-base t))
@ -2964,7 +2981,7 @@
(math-poly-integer-root (car roots)) (math-poly-integer-root (car roots))
(setq roots (cdr roots))) (setq roots (cdr roots)))
(list math-int-factors (nreverse math-int-coefs) math-int-scale)) (list math-int-factors (nreverse math-int-coefs) math-int-scale))
(let ((vec nil) res) (let ((vec nil)) ;; res
(while roots (while roots
(let ((root (car roots)) (let ((root (car roots))
(math-solve-full (and math-solve-full 'all))) (math-solve-full (and math-solve-full 'all)))
@ -3109,7 +3126,7 @@
(iters 0) (iters 0)
(m (1- (length p))) (m (1- (length p)))
(try-newt (not polish)) (try-newt (not polish))
(tried-newt nil) ;; (tried-newt nil)
b d f x1 dx dxold) b d f x1 dx dxold)
(while (while
(and (or (< (setq iters (1+ iters)) 50) (and (or (< (setq iters (1+ iters)) 50)
@ -3146,7 +3163,7 @@
(math-lessp (math-abs-approx dx) (math-lessp (math-abs-approx dx)
(calcFunc-scf (math-abs-approx x) -3))) (calcFunc-scf (math-abs-approx x) -3)))
(let ((newt (math-poly-newton-root p x1 7))) (let ((newt (math-poly-newton-root p x1 7)))
(setq tried-newt t (setq ;; tried-newt t
try-newt nil) try-newt nil)
(if (math-zerop (cdr newt)) (if (math-zerop (cdr newt))
(setq x (car newt) x1 x) (setq x (car newt) x1 x)
@ -3160,7 +3177,8 @@
(math-nearly-equal x x1)))) (math-nearly-equal x x1))))
(let ((cdx (math-abs-approx dx))) (let ((cdx (math-abs-approx dx)))
(setq x x1 (setq x x1
tried-newt nil) ;; tried-newt nil
)
(prog1 (prog1
(or (<= iters 6) (or (<= iters 6)
(math-lessp cdx dxold) (math-lessp cdx dxold)
@ -3227,7 +3245,9 @@
;; and math-solve-system-rec, but is used by math-solve-system-subst. ;; and math-solve-system-rec, but is used by math-solve-system-subst.
(defvar math-solve-simplifying) (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) (setq exprs (mapcar 'list (if (Math-vectorp exprs)
(cdr exprs) (cdr exprs)
(list exprs))) (list exprs)))
@ -3237,7 +3257,7 @@
(or (let ((math-solve-simplifying nil)) (or (let ((math-solve-simplifying nil))
(math-solve-system-rec exprs math-solve-vars nil)) (math-solve-system-rec exprs math-solve-vars nil))
(let ((math-solve-simplifying t)) (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 ;;; The following backtracking solver works by choosing a variable
;;; and equation, and trying to solve the equation for the variable. ;;; and equation, and trying to solve the equation for the variable.
@ -3437,10 +3457,12 @@
(if (memq (car expr) '(* /)) (if (memq (car expr) '(* /))
(math-looks-evenp (nth 1 expr))))) (math-looks-evenp (nth 1 expr)))))
(defun math-solve-for (lhs rhs math-solve-var math-solve-full &optional sign) (defun math-solve-for (lhs rhs solve-var solve-full &optional sign)
(if (math-expr-contains rhs math-solve-var) (let ((math-solve-var solve-var)
(math-solve-for (math-sub lhs rhs) 0 math-solve-var math-solve-full) (math-solve-full solve-full))
(and (math-expr-contains lhs math-solve-var) (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 (math-with-extra-prec 1
(let* ((math-poly-base-variable math-solve-var) (let* ((math-poly-base-variable math-solve-var)
(res (math-try-solve-for lhs rhs sign))) (res (math-try-solve-for lhs rhs sign)))
@ -3462,7 +3484,7 @@
(format (format
"*Omitted %d complex solutions" "*Omitted %d complex solutions"
(- old-len new-len))))))) (- old-len new-len)))))))
res))))) res))))))
(defun math-solve-eqn (expr var full) (defun math-solve-eqn (expr var full)
(if (memq (car-safe expr) '(calcFunc-neq calcFunc-lt calcFunc-gt (if (memq (car-safe expr) '(calcFunc-neq calcFunc-lt calcFunc-gt

43
lisp/calc/calcalg3.el
View file

@ -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-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.
@ -120,18 +120,24 @@
(defvar calc-curve-fit-history nil (defvar calc-curve-fit-history nil
"History for calc-curve-fit.") "History for calc-curve-fit.")
(defun calc-curve-fit (arg &optional calc-curve-model (defvar calc-graph-no-auto-view)
calc-curve-coefnames calc-curve-varnames) (defvar calc-fit-to-trail nil)
(defun calc-curve-fit (arg &optional curve-model
curve-coefnames curve-varnames)
(interactive "P") (interactive "P")
(calc-slow-wrapper (calc-slow-wrapper
(setq calc-aborted-prefix nil) (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 (if (calc-is-hyperbolic) 'calcFunc-efit
'calcFunc-fit))) 'calcFunc-fit)))
key (which 0) key (which 0)
(nonlinear nil) (nonlinear nil)
(plot nil) (plot nil)
n calc-curve-nvars temp data n calc-curve-nvars data ;; temp
(homog nil) (homog nil)
(msgs '( "(Press ? for help)" (msgs '( "(Press ? for help)"
"1 = linear or multilinear" "1 = linear or multilinear"
@ -321,7 +327,7 @@
(calc-get-fit-variables 1 (1- (length calc-curve-coefnames)) (calc-get-fit-variables 1 (1- (length calc-curve-coefnames))
(and homog 1))) (and homog 1)))
((memq key '(?\$ ?\' ?u ?U)) ((memq key '(?\$ ?\' ?u ?U))
(let* ((defvars nil) (let* (;; (defvars nil)
(record-entry nil)) (record-entry nil))
(if (eq key ?\') (if (eq key ?\')
(let* ((calc-dollar-values calc-arg-values) (let* ((calc-dollar-values calc-arg-values)
@ -708,7 +714,7 @@
"*Unable to find a sign change in this interval")))) "*Unable to find a sign change in this interval"))))
;;; "rtbis" (but we should be using Brent's method) ;;; "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)) (let ((step (math-sub-float high low))
(pos (Math-posp vhigh)) (pos (Math-posp vhigh))
var-DUMMY var-DUMMY
@ -726,7 +732,8 @@
(setq high mid (setq high mid
vhigh vmid) vhigh vmid)
(setq low mid (setq low mid
vlow vmid))) ;; vlow vmid
)))
(list 'vec mid vmid))) (list 'vec mid vmid)))
;;; "mnewt" ;;; "mnewt"
@ -758,7 +765,8 @@
(list 'vec next expr-val)))) (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) (if (eq (car-safe expr) 'vec)
(let ((n (1- (length expr))) (let ((n (1- (length expr)))
(calc-symbolic-mode nil) (calc-symbolic-mode nil)
@ -871,7 +879,7 @@
(not (Math-numberp vlow)) (not (Math-numberp vlow))
(not (Math-numberp vhigh))) (not (Math-numberp vhigh)))
(math-search-root expr deriv low vlow high 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) (defun calcFunc-root (expr var guess)
(math-find-root expr var guess nil)) (math-find-root expr var guess nil))
@ -1019,7 +1027,7 @@
math-min-or-max)))))) math-min-or-max))))))
;;; "brent" ;;; "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))) (let ((iters (+ 20 (* 5 prec)))
(w x) (w x)
(vw vx) (vw vx)
@ -1181,7 +1189,7 @@
(list 'calcFunc-mrow '(var line-p line-p) (1+ m))))) (list 'calcFunc-mrow '(var line-p line-p) (1+ m)))))
(math-evaluate-expr expr))) (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) (let* ((var-DUMMY nil)
(expr (math-evaluate-expr f1dim)) (expr (math-evaluate-expr f1dim))
(params (math-widen-min expr '(float 0 0) '(float 1 0))) (params (math-widen-min expr '(float 0 0) '(float 1 0)))
@ -1195,7 +1203,7 @@
(n 0) (n 0)
(var-DUMMY nil) (var-DUMMY nil)
(isvec (math-vectorp var)) (isvec (math-vectorp var))
g guesses) guesses) ;; g
(or (math-vectorp var) (or (math-vectorp var)
(setq var (list 'vec var))) (setq var (list 'vec var)))
(or (math-vectorp guess) (or (math-vectorp guess)
@ -1493,7 +1501,8 @@
(defun math-ninteg-midpoint (expr lo hi mode) ; uses "math-ninteg-temp" (defun math-ninteg-midpoint (expr lo hi mode) ; uses "math-ninteg-temp"
(if (eq mode 'inf) (if (eq mode 'inf)
(let ((math-infinite-mode t) temp) (let (;; (math-infinite-mode t) ;Unused!
temp)
(setq temp (math-div 1 lo) (setq temp (math-div 1 lo)
lo (math-div 1 hi) lo (math-div 1 hi)
hi temp))) hi temp)))
@ -1547,7 +1556,6 @@
(setq math-dummy-counter (1+ math-dummy-counter)))) (setq math-dummy-counter (1+ math-dummy-counter))))
(defvar math-in-fit 0) (defvar math-in-fit 0)
(defvar calc-fit-to-trail nil)
(defun calcFunc-fit (expr vars &optional coefs data) (defun calcFunc-fit (expr vars &optional coefs data)
(let ((math-in-fit 10)) (let ((math-in-fit 10))
@ -1573,6 +1581,7 @@
(defvar math-fit-new-coefs) (defvar math-fit-new-coefs)
(defun math-general-fit (expr vars coefs data mode) (defun math-general-fit (expr vars coefs data mode)
(defvar var-YVAL) (defvar var-YVALX)
(let ((calc-simplify-mode nil) (let ((calc-simplify-mode nil)
(math-dummy-counter math-dummy-counter) (math-dummy-counter math-dummy-counter)
(math-in-fit 1) (math-in-fit 1)
@ -1591,7 +1600,7 @@
(weights nil) (weights nil)
(var-YVAL nil) (var-YVALX nil) (var-YVAL nil) (var-YVALX nil)
covar beta covar beta
n nn m mm v dummy p) n m mm v dummy p) ;; nn
;; Validate and parse arguments. ;; Validate and parse arguments.
(or data (or data
@ -1687,7 +1696,7 @@
(isigsq 1) (isigsq 1)
(xvals (make-vector mm 0)) (xvals (make-vector mm 0))
(i 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) (while (<= (setq i (1+ i)) n)
;; Assign various independent variables for this data point. ;; Assign various independent variables for this data point.

2
lisp/calc/calcsel2.el
View file

@ -1,4 +1,4 @@
;;; calcsel2.el --- selection functions for Calc ;;; calcsel2.el --- selection functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc.