diff options
author | Andrea Corallo <akrl@sdf.org> | 2020-10-14 11:04:55 +0200 |
---|---|---|
committer | Andrea Corallo <akrl@sdf.org> | 2020-10-14 11:04:55 +0200 |
commit | f8505fd3d43dd95492855eac88922b5b27201e7a (patch) | |
tree | 5e2de987d295fb3a34e52ea7930265351ce45f2b /lisp | |
parent | 03e98f93f72c8a158a3584355bca174e2c63dce6 (diff) | |
parent | b13e0c1501a21e942692718194c634e01a13928a (diff) | |
download | emacs-f8505fd3d43dd95492855eac88922b5b27201e7a.tar.gz |
Merge remote-tracking branch 'savannah/master' into HEAD
Diffstat (limited to 'lisp')
66 files changed, 2107 insertions, 683 deletions
diff --git a/lisp/calc/calc-aent.el b/lisp/calc/calc-aent.el index 55ce9711986..6c162b55f7b 100644 --- a/lisp/calc/calc-aent.el +++ b/lisp/calc/calc-aent.el @@ -1,4 +1,4 @@ -;;; calc-aent.el --- algebraic entry functions for Calc +;;; calc-aent.el --- algebraic entry functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -158,7 +158,7 @@ (setq strp (cdr (cdr strp)))) (calc-do-calc-eval (car str) separator args))) ((eq separator 'eval) - (eval str)) + (eval str t)) ((eq separator 'macro) (require 'calc-ext) (let* ((calc-buffer (current-buffer)) @@ -285,6 +285,8 @@ The value t means abort and give an error message.") (defvar calc-alg-entry-history nil "History for algebraic entry.") +(defvar calc-plain-entry nil) + ;;;###autoload (defun calc-alg-entry (&optional initial prompt) (let* ((calc-dollar-values (mapcar #'calc-get-stack-element @@ -401,7 +403,6 @@ The value t means abort and give an error message.") (use-local-map calc-mode-map)) (calcAlg-enter)) -(defvar calc-plain-entry nil) (defun calcAlg-edit () (interactive) (if (or (not calc-plain-entry) @@ -576,8 +577,9 @@ in Calc algebraic input.") (defvar math-expr-data) ;;;###autoload -(defun math-read-exprs (math-exp-str) - (let ((math-exp-pos 0) +(defun math-read-exprs (str) + (let ((math-exp-str str) + (math-exp-pos 0) (math-exp-old-pos 0) (math-exp-keep-spaces nil) math-exp-token math-expr-data) @@ -738,8 +740,8 @@ in Calc algebraic input.") math-exp-pos (match-end 0))) ((and (setq adfn (assq ch (get calc-language 'math-lang-read-symbol))) - (eval (nth 1 adfn))) - (eval (nth 2 adfn))) + (eval (nth 1 adfn) t)) + (eval (nth 2 adfn) t)) ((eq ch ?\$) (if (eq (string-match "\\$\\([1-9][0-9]*\\)" math-exp-str math-exp-pos) math-exp-pos) @@ -771,8 +773,8 @@ in Calc algebraic input.") math-expr-data (math-match-substring math-exp-str 1) math-exp-pos (match-end 0))) ((and (setq adfn (get calc-language 'math-lang-read)) - (eval (nth 0 adfn)) - (eval (nth 1 adfn)))) + (eval (nth 0 adfn) t) + (eval (nth 1 adfn) t))) ((eq (string-match "%%.*$" math-exp-str math-exp-pos) math-exp-pos) (setq math-exp-pos (match-end 0)) (math-read-token)) diff --git a/lisp/calc/calc-arith.el b/lisp/calc/calc-arith.el index b487aae6883..ae397c4f2c4 100644 --- a/lisp/calc/calc-arith.el +++ b/lisp/calc/calc-arith.el @@ -1,4 +1,4 @@ -;;; calc-arith.el --- arithmetic functions for Calc +;;; calc-arith.el --- arithmetic functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -250,44 +250,43 @@ (while (setq p (cdr p)) (and (eq (car-safe (car p)) 'vec) (setq vec (nth 2 (car p))) - (condition-case err - (let ((v (nth 1 (car p)))) - (setq type nil range nil) - (or (eq (car-safe vec) 'vec) - (setq vec (list 'vec vec))) - (while (and (setq vec (cdr vec)) - (not (Math-objectp (car vec)))) - (and (eq (car-safe (car vec)) 'var) - (let ((st (assq (nth 1 (car vec)) - math-super-types))) - (cond (st (setq type (append type st))) - ((eq (nth 1 (car vec)) 'pos) - (setq type (append type - '(real number)) - range - '(intv 1 0 (var inf var-inf)))) - ((eq (nth 1 (car vec)) 'nonneg) - (setq type (append type - '(real number)) - range - '(intv 3 0 - (var inf var-inf)))))))) - (if vec - (setq type (append type '(real number)) - range (math-prepare-set (cons 'vec vec)))) - (setq type (list type range)) - (or (eq (car-safe v) 'vec) - (setq v (list 'vec v))) - (while (setq v (cdr v)) - (if (or (eq (car-safe (car v)) 'var) - (not (Math-primp (car v)))) - (setq math-decls-cache - (cons (cons (if (eq (car (car v)) 'var) - (nth 2 (car v)) - (car (car v))) - type) - math-decls-cache))))) - (error nil))))) + (ignore-errors + (let ((v (nth 1 (car p)))) + (setq type nil range nil) + (or (eq (car-safe vec) 'vec) + (setq vec (list 'vec vec))) + (while (and (setq vec (cdr vec)) + (not (Math-objectp (car vec)))) + (and (eq (car-safe (car vec)) 'var) + (let ((st (assq (nth 1 (car vec)) + math-super-types))) + (cond (st (setq type (append type st))) + ((eq (nth 1 (car vec)) 'pos) + (setq type (append type + '(real number)) + range + '(intv 1 0 (var inf var-inf)))) + ((eq (nth 1 (car vec)) 'nonneg) + (setq type (append type + '(real number)) + range + '(intv 3 0 + (var inf var-inf)))))))) + (if vec + (setq type (append type '(real number)) + range (math-prepare-set (cons 'vec vec)))) + (setq type (list type range)) + (or (eq (car-safe v) 'vec) + (setq v (list 'vec v))) + (while (setq v (cdr v)) + (if (or (eq (car-safe (car v)) 'var) + (not (Math-primp (car v)))) + (setq math-decls-cache + (cons (cons (if (eq (car (car v)) 'var) + (nth 2 (car v)) + (car (car v))) + type) + math-decls-cache))))))))) (setq math-decls-all (assq 'var-All math-decls-cache))))) (defun math-known-scalarp (a &optional assume-scalar) @@ -2892,7 +2891,7 @@ (eq a b)) (list 'calcFunc-exp sumpow)) (t - (condition-case err + (condition-case nil (math-pow a sumpow) (inexact-result (list '^ a sumpow))))))))) (and math-simplifying-units @@ -2927,7 +2926,7 @@ (math-div 1 (list 'calcFunc-sqrt (math-mul a b)))) (t (setq a (math-mul a b)) - (condition-case err + (condition-case nil (math-pow a apow) (inexact-result (list '^ a apow))))))))))) diff --git a/lisp/calc/calc-bin.el b/lisp/calc/calc-bin.el index aa10d55e52c..60dd17e5ed2 100644 --- a/lisp/calc/calc-bin.el +++ b/lisp/calc/calc-bin.el @@ -1,4 +1,4 @@ -;;; calc-bin.el --- binary functions for Calc +;;; calc-bin.el --- binary functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -145,9 +145,10 @@ (setq math-half-2-word-size (math-power-of-2 (1- (math-abs n)))) (calc-do-refresh) (calc-refresh-evaltos) - (if (< n 0) - (message "Binary word size is %d bits (two's complement)" (- n)) - (message "Binary word size is %d bits" n)))) + (cond + ((< n 0) (message "Binary word size is %d bits (two's complement)" (- n))) + ((> n 0) (message "Binary word size is %d bits" n)) + (t (message "No fixed binary word size"))))) @@ -262,9 +263,10 @@ (defun math-binary-arg (a w) (if (not (Math-integerp a)) (setq a (math-trunc a))) - (if (< a 0) - (logand a (1- (ash 1 (if w (math-trunc w) calc-word-size)))) - a)) + (let ((w (if w (math-trunc w) calc-word-size))) + (if (and (< a 0) (not (zerop w))) + (logand a (1- (ash 1 w))) + a))) (defun math-binary-modulo-args (f a b w) (let (mod) @@ -285,7 +287,7 @@ (let ((bits (math-integer-log2 mod))) (if bits (if w - (if (/= w bits) + (if (and (/= w bits) (not (zerop w))) (calc-record-why "*Warning: Modulus inconsistent with word size")) (setq w bits)) @@ -371,11 +373,12 @@ (math-clip (calcFunc-lsh a n (- w)) w) (if (Math-integer-negp a) (setq a (math-clip a w))) - (cond ((or (Math-lessp n (- w)) - (Math-lessp w n)) + (cond ((and (or (Math-lessp n (- w)) + (Math-lessp w n)) + (not (zerop w))) 0) ((< n 0) - (math-quotient (math-clip a w) (math-power-of-2 (- n)))) + (ash (math-clip a w) n)) (t (math-clip (math-mul a (math-power-of-2 n)) w)))))) @@ -403,7 +406,8 @@ (setq a (math-clip a w))) (let ((two-to-sizem1 (math-power-of-2 (1- w))) (sh (calcFunc-lsh a n w))) - (cond ((zerop (logand a two-to-sizem1)) + (cond ((or (zerop w) + (zerop (logand a two-to-sizem1))) sh) ((Math-lessp n (- 1 w)) (math-add (math-mul two-to-sizem1 2) -1)) @@ -421,6 +425,8 @@ (if (eq (car-safe a) 'mod) (math-binary-modulo-args 'calcFunc-rot a n w) (setq w (if w (math-trunc w) calc-word-size)) + (when (zerop w) + (error "Rotation requires a nonzero word size")) (or (integerp w) (math-reject-arg w 'fixnump)) (or (Math-integerp a) @@ -452,6 +458,8 @@ (if (Math-natnum-lessp a (math-power-of-2 (- -1 w))) a (math-sub a (math-power-of-2 (- w))))) + ((math-zerop w) + a) ((Math-negp a) (math-binary-arg a w)) ((integerp a) @@ -682,6 +690,8 @@ (defun math-format-twos-complement (a) "Format an integer in two's complement mode." + (when (zerop calc-word-size) + (error "Nonzero word size required")) (let* (;(calc-leading-zeros t) (num (cond diff --git a/lisp/calc/calc-comb.el b/lisp/calc/calc-comb.el index f7e29c6e52c..5aeb8cba0df 100644 --- a/lisp/calc/calc-comb.el +++ b/lisp/calc/calc-comb.el @@ -1,4 +1,4 @@ -;;; calc-comb.el --- combinatoric functions for Calc +;;; calc-comb.el --- combinatoric functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-cplx.el b/lisp/calc/calc-cplx.el index f4324dcbf1e..7438f63a90d 100644 --- a/lisp/calc/calc-cplx.el +++ b/lisp/calc/calc-cplx.el @@ -1,4 +1,4 @@ -;;; calc-cplx.el --- Complex number functions for Calc +;;; calc-cplx.el --- Complex number functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-embed.el b/lisp/calc/calc-embed.el index 220213e0fbb..f9c5281c263 100644 --- a/lisp/calc/calc-embed.el +++ b/lisp/calc/calc-embed.el @@ -1,4 +1,4 @@ -;;; calc-embed.el --- embed Calc in a buffer +;;; calc-embed.el --- embed Calc in a buffer -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -219,13 +219,17 @@ (defvar calc-override-minor-modes (cons t calc-override-minor-modes-map)) -(defun calc-do-embedded (calc-embed-arg end obeg oend) +(defvar calc-embedded-no-reselect nil) + +(defun calc-do-embedded (embed-arg end obeg oend) + (let ((calc-embed-arg embed-arg)) (if calc-embedded-info ;; Turn embedded mode off or switch to a new buffer. (cond ((eq (current-buffer) (aref calc-embedded-info 1)) (let ((calcbuf (current-buffer)) - (buf (aref calc-embedded-info 0))) + ;; (buf (aref calc-embedded-info 0)) + ) (calc-embedded-original-buffer t) (calc-embedded nil) (switch-to-buffer calcbuf))) @@ -291,7 +295,7 @@ (calc-embedded-info info) (calc-embedded-no-reselect t)) (calc-wrapper - (let* ((okay nil) + (let* (;; (okay nil) (calc-no-refresh-evaltos t)) (if (aref info 8) (progn @@ -336,7 +340,7 @@ "Type `C-x * x'" "Give this command again") " to return to normal"))))) - (scroll-down 0)) ; fix a bug which occurs when truncate-lines is changed. + (scroll-down 0))) ; fix a bug which occurs when truncate-lines is changed. (defun calc-embedded-select (arg) @@ -353,9 +357,10 @@ (calc-select-part 2))) -(defun calc-embedded-update-formula (calc-embed-arg) +(defun calc-embedded-update-formula (embed-arg) (interactive "P") - (if calc-embed-arg + (let ((calc-embed-arg embed-arg)) + (if embed-arg (let ((entry (assq (current-buffer) calc-embedded-active))) (while (setq entry (cdr entry)) (and (eq (car-safe (aref (car entry) 8)) 'calcFunc-evalto) @@ -376,12 +381,13 @@ (progn (save-excursion (calc-embedded-update info 14 'eval t)) - (goto-char (+ (aref info 4) pt)))))))) + (goto-char (+ (aref info 4) pt))))))))) -(defun calc-embedded-edit (calc-embed-arg) +(defun calc-embedded-edit (embed-arg) (interactive "P") - (let ((info (calc-embedded-make-info (point) nil t calc-embed-arg)) + (let ((calc-embed-arg embed-arg)) + (let ((info (calc-embedded-make-info (point) nil t embed-arg)) str) (if (eq (car-safe (aref info 8)) 'error) (progn @@ -392,15 +398,14 @@ (math-format-nice-expr (aref info 8) (frame-width)))) (calc-edit-mode (list 'calc-embedded-finish-edit info)) (insert str "\n"))) - (calc-show-edit-buffer)) + (calc-show-edit-buffer))) (defvar calc-original-buffer) (defvar calc-edit-top) (defun calc-embedded-finish-edit (info) (let ((buf (current-buffer)) (str (buffer-substring calc-edit-top (point-max))) - (start (point)) - pos) + (start (point))) ;; pos (switch-to-buffer calc-original-buffer) (let ((val (with-current-buffer (aref info 1) (let ((calc-language nil) @@ -416,7 +421,8 @@ (calc-embedded-update info 14 t t)))) ;;;###autoload -(defun calc-do-embedded-activate (calc-embed-arg cbuf) +(defun calc-do-embedded-activate (embed-arg cbuf) + (let ((calc-embed-arg embed-arg)) (calc-plain-buffer-only) (if calc-embed-arg (calc-embedded-forget)) @@ -443,7 +449,7 @@ (or (eq (car-safe (aref info 8)) 'error) (goto-char (aref info 5)))))) (message "Activating %s for Calc Embedded mode...done" (buffer-name))) - (calc-embedded-active-state t)) + (calc-embedded-active-state t))) (defun calc-plain-buffer-only () (if (memq major-mode '(calc-mode calc-trail-mode calc-edit-mode)) @@ -735,13 +741,13 @@ The command \\[yank] can retrieve it from there." (defun calc-find-globals () (interactive) - (and (eq major-mode 'calc-mode) + (and (derived-mode-p 'calc-mode) (error "This command should be used in a normal editing buffer")) (make-local-variable 'calc-embedded-globals) (let ((case-fold-search nil) (modes nil) (save-pt (point)) - found value) + found) ;; value (goto-char (point-min)) (while (re-search-forward "\\[calc-global-mode: *\\([-a-z]+\\): *\\(\"\\([^\"\n\\]\\|\\\\.\\)*\"\\|[- ()a-zA-Z0-9]+\\)\\]" nil t) (and (setq found (assoc (buffer-substring (match-beginning 1) @@ -764,7 +770,7 @@ The command \\[yank] can retrieve it from there." (modes nil) (emodes nil) (pmodes nil) - found value) + found) ;; value (while (and no-defaults (search-backward "[calc-" nil t)) (forward-char 6) (or (and (looking-at "mode: *\\([-a-z]+\\): *\\(\"\\([^\"\n\\]\\|\\\\.\\)*\"\\|[- ()a-zA-Z0-9]+\\)]") @@ -817,9 +823,13 @@ The command \\[yank] can retrieve it from there." (defvar calc-embed-vars-used) (defun calc-embedded-make-info (point cbuf fresh &optional - calc-embed-top calc-embed-bot - calc-embed-outer-top calc-embed-outer-bot) - (let* ((bufentry (assq (current-buffer) calc-embedded-active)) + embed-top embed-bot + embed-outer-top embed-outer-bot) + (let* ((calc-embed-top embed-top) + (calc-embed-bot embed-bot) + (calc-embed-outer-top embed-outer-top) + (calc-embed-outer-bot embed-outer-bot) + (bufentry (assq (current-buffer) calc-embedded-active)) (found bufentry) (force (and fresh calc-embed-top (null (equal calc-embed-top '(t))))) (fixed calc-embed-top) @@ -1175,7 +1185,6 @@ The command \\[yank] can retrieve it from there." ;;; These are hooks called by the main part of Calc. -(defvar calc-embedded-no-reselect nil) (defun calc-embedded-select-buffer () (if (eq (current-buffer) (aref calc-embedded-info 0)) (let ((info calc-embedded-info) @@ -1240,7 +1249,7 @@ The command \\[yank] can retrieve it from there." (with-current-buffer (aref calc-embedded-info 1) (let* ((info calc-embedded-info) (extra-line (if (eq calc-language 'big) 1 0)) - (the-point (point)) + ;; (the-point (point)) (empty (= (calc-stack-size) 0)) (entry (if empty (list '(var empty var-empty) 1 nil) @@ -1274,6 +1283,7 @@ The command \\[yank] can retrieve it from there." (set-buffer-modified-p (buffer-modified-p))))) (defun calc-embedded-modes-change (vars) + (defvar the-language) (defvar the-display-just) (if (eq (car vars) 'calc-language) (setq vars '(the-language))) (if (eq (car vars) 'calc-display-just) (setq vars '(the-display-just))) (while (and vars diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el index 5c11554d5d7..fc0a2c88fea 100644 --- a/lisp/calc/calc-ext.el +++ b/lisp/calc/calc-ext.el @@ -1398,9 +1398,8 @@ calc-kill calc-kill-region calc-yank)))) (defun calc-scroll-up (n) (interactive "P") - (condition-case nil - (scroll-up (or n (/ (window-height) 2))) - (error nil)) + (ignore-errors + (scroll-up (or n (/ (window-height) 2)))) (if (pos-visible-in-window-p (max 1 (- (point-max) 2))) (if (eq major-mode 'calc-mode) (calc-realign) diff --git a/lisp/calc/calc-fin.el b/lisp/calc/calc-fin.el index d1525939b11..ea1ef24bb19 100644 --- a/lisp/calc/calc-fin.el +++ b/lisp/calc/calc-fin.el @@ -1,4 +1,4 @@ -;;; calc-fin.el --- financial functions for Calc +;;; calc-fin.el --- financial functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el index a2f66968665..465d4520b05 100644 --- a/lisp/calc/calc-forms.el +++ b/lisp/calc/calc-forms.el @@ -1,4 +1,4 @@ -;;; calc-forms.el --- data format conversion functions for Calc +;;; calc-forms.el --- data format conversion functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -678,10 +678,11 @@ in the Gregorian calendar." (defvar math-fd-isoweek) (defvar math-fd-isoweekday) -(defun math-format-date (math-fd-date) - (if (eq (car-safe math-fd-date) 'date) - (setq math-fd-date (nth 1 math-fd-date))) - (let ((entry (list math-fd-date calc-internal-prec calc-date-format))) +(defun math-format-date (fd-date) + (let* ((math-fd-date (if (eq (car-safe fd-date) 'date) + (nth 1 fd-date) + fd-date)) + (entry (list math-fd-date calc-internal-prec calc-date-format))) (or (cdr (assoc entry math-format-date-cache)) (let* ((math-fd-dt nil) (math-fd-iso-dt nil) @@ -914,15 +915,16 @@ to Jan 1, 1970 AD.") ;; which is called by math-parse-date and math-parse-standard-date. (defvar math-pd-str) -(defun math-parse-date (math-pd-str) +(defun math-parse-date (pd-str) (catch 'syntax - (or (math-parse-standard-date math-pd-str t) - (math-parse-standard-date math-pd-str nil) - (and (string-match "W[0-9][0-9]" math-pd-str) - (math-parse-iso-date math-pd-str)) - (and (string-match "\\`[^-+/0-9a-zA-Z]*\\([-+]?[0-9]+\\.?[0-9]*\\([eE][-+]?[0-9]+\\)?\\)[^-+/0-9a-zA-Z]*\\'" math-pd-str) - (list 'date (math-read-number (math-match-substring math-pd-str 1)))) + (or (math-parse-standard-date pd-str t) + (math-parse-standard-date pd-str nil) + (and (string-match "W[0-9][0-9]" pd-str) + (math-parse-iso-date pd-str)) + (and (string-match "\\`[^-+/0-9a-zA-Z]*\\([-+]?[0-9]+\\.?[0-9]*\\([eE][-+]?[0-9]+\\)?\\)[^-+/0-9a-zA-Z]*\\'" pd-str) + (list 'date (math-read-number (math-match-substring pd-str 1)))) (let ((case-fold-search t) + (math-pd-str pd-str) (year nil) (month nil) (day nil) (weekday nil) (hour nil) (minute nil) (second nil) (bc-flag nil) (a nil) (b nil) (c nil) (bigyear nil) temp) @@ -1128,8 +1130,9 @@ to Jan 1, 1970 AD.") (substring math-pd-str (match-end 0)))) n)))) -(defun math-parse-standard-date (math-pd-str with-time) - (let ((case-fold-search t) +(defun math-parse-standard-date (pd-str with-time) + (let ((math-pd-str pd-str) + (case-fold-search t) (okay t) num (fmt calc-date-format) this next (gnext nil) (isoyear nil) (isoweek nil) (isoweekday nil) @@ -1306,9 +1309,10 @@ to Jan 1, 1970 AD.") (setq day (math-add day (1- yearday)))) day)))))) -(defun math-parse-iso-date (math-pd-str) - "Parse MATH-PD-STR as an ISO week date, or return nil." - (let ((case-fold-search t) +(defun math-parse-iso-date (pd-str) + "Parse PD-STR as an ISO week date, or return nil." + (let ((math-pd-str pd-str) + (case-fold-search t) (isoyear nil) (isoweek nil) (isoweekday nil) (hour nil) (minute nil) (second nil)) ;; Extract the time, if any. @@ -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-new date dt zone bump))) -(defun math-std-daylight-savings-new (date dt zone bump) +(defun math-std-daylight-savings-new (date dt _zone bump) "Standard North American daylight saving algorithm as of 2007. This implements the rules for the U.S. and Canada. Daylight saving begins on the second Sunday of March at 2 a.m., @@ -1634,7 +1638,7 @@ and ends on the first Sunday of November at 2 a.m." (t 0)))) (t 0))) -(defun math-std-daylight-savings-old (date dt zone bump) +(defun math-std-daylight-savings-old (date dt _zone bump) "Standard North American daylight saving algorithm before 2007. This implements the rules for the U.S. and Canada. Daylight saving begins on the first Sunday of April at 2 a.m., @@ -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 ;;; day of the given month. -(defun math-prev-weekday-in-month (date dt day wday) +(defun math-prev-weekday-in-month (date dt day _wday) (or day (setq day (nth 2 dt))) (if (> day (math-days-in-month (car dt) (nth 1 dt))) (setq day (math-days-in-month (car dt) (nth 1 dt)))) @@ -2036,18 +2040,18 @@ and ends on the last Sunday of October at 2 a.m." nil))) (or done (setq math-holidays-cache-tag t)))))) -(defun math-setup-year-holidays (math-sh-year) - (let ((exprs (nth 2 math-holidays-cache))) - (while exprs +(defun math-setup-year-holidays (sh-year) + (let ((math-sh-year sh-year)) + (dolist (expr (nth 2 math-holidays-cache)) + (defvar var-y) (defvar var-m) (let* ((var-y math-sh-year) (var-m nil) - (expr (math-evaluate-expr (car exprs)))) + (expr (math-evaluate-expr expr))) (if (math-expr-contains expr '(var m var-m)) (let ((var-m 0)) (while (<= (setq var-m (1+ var-m)) 12) (math-setup-add-holidays (math-evaluate-expr expr)))) - (math-setup-add-holidays expr))) - (setq exprs (cdr exprs))))) + (math-setup-add-holidays expr)))))) (defun math-setup-add-holidays (days) ; uses "math-sh-year" (cond ((eq (car-safe days) 'vec) diff --git a/lisp/calc/calc-frac.el b/lisp/calc/calc-frac.el index 33c1fbaab8d..86a4808c5ad 100644 --- a/lisp/calc/calc-frac.el +++ b/lisp/calc/calc-frac.el @@ -1,4 +1,4 @@ -;;; calc-frac.el --- fraction functions for Calc +;;; calc-frac.el --- fraction functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-funcs.el b/lisp/calc/calc-funcs.el index 14f5e321080..5c179ff05d4 100644 --- a/lisp/calc/calc-funcs.el +++ b/lisp/calc/calc-funcs.el @@ -1,4 +1,4 @@ -;;; calc-funcs.el --- well-known functions for Calc +;;; calc-funcs.el --- well-known functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-graph.el b/lisp/calc/calc-graph.el index 4cdfdbd4b92..82e93357164 100644 --- a/lisp/calc/calc-graph.el +++ b/lisp/calc/calc-graph.el @@ -1,4 +1,4 @@ -;;; calc-graph.el --- graph output functions for Calc +;;; calc-graph.el --- graph output functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -216,7 +216,7 @@ (or (and (Math-num-integerp pstyle) (math-trunc pstyle)) (if (eq (car-safe (calc-var-value (nth 2 ydata))) 'vec) 0 -1)) - (math-contains-sdev-p (eval (nth 2 ydata)))))) + (math-contains-sdev-p (eval (nth 2 ydata) t))))) (defun calc-graph-lookup (thing) (if (and (eq (car-safe thing) 'var) @@ -319,7 +319,6 @@ (calc-slow-wrapper (let ((calcbuf (current-buffer)) (tempbuf (get-buffer-create "*Gnuplot Temp-2*")) - (tempbuftop 1) (tempoutfile nil) (calc-graph-curve-num 0) (calc-graph-refine (and flag (> (prefix-numeric-value flag) 0))) @@ -403,7 +402,7 @@ (and (equal output "tty") (setq tty-output t))) (setq tempoutfile (calc-temp-file-name -1) output tempoutfile)) - (setq output (eval output))) + (setq output (eval output t))) (or (equal device calc-graph-last-device) (progn (setq calc-graph-last-device device) @@ -480,9 +479,11 @@ (calc-graph-xp calc-graph-xvalue) (calc-graph-yp calc-graph-yvalue) (calc-graph-zp nil) - (calc-graph-xlow nil) (calc-graph-xhigh nil) (y3low nil) (y3high nil) + (calc-graph-xlow nil) (calc-graph-xhigh nil) + ;; (y3low nil) (y3high nil) calc-graph-xvec calc-graph-xval calc-graph-xstep var-DUMMY - y3val calc-graph-y3step var-DUMMY2 (calc-graph-zval nil) + ;; y3val + calc-graph-y3step var-DUMMY2 (calc-graph-zval nil) calc-graph-yvec calc-graph-yval calc-graph-ycache calc-graph-ycacheptr calc-graph-yvector calc-graph-numsteps calc-graph-numsteps3 (calc-graph-keep-file (and (not calc-graph-is-splot) (file-exists-p filename))) @@ -562,7 +563,7 @@ calc-gnuplot-print-output))) (if (symbolp command) (funcall command output) - (eval command)))))))))) + (eval command t)))))))))) (defun calc-graph-compute-2d () (if (setq calc-graph-yvec (eq (car-safe calc-graph-yvalue) 'vec)) @@ -905,16 +906,15 @@ (while calc-graph-file-cache (and (car calc-graph-file-cache) (file-exists-p (car (car calc-graph-file-cache))) - (condition-case err - (delete-file (car (car calc-graph-file-cache))) - (error nil))) + (ignore-errors + (delete-file (car (car calc-graph-file-cache))))) (setq calc-graph-file-cache (cdr calc-graph-file-cache)))) (defun calc-graph-kill-hook () (calc-graph-delete-temps)) (defun calc-graph-show-tty (output) - "Default calc-gnuplot-plot-command for \"tty\" output mode. + "Default `calc-gnuplot-plot-command' for \"tty\" output mode. This is useful for tek40xx and other graphics-terminal types." (call-process shell-file-name nil calc-gnuplot-buffer nil shell-command-switch @@ -923,7 +923,7 @@ This is useful for tek40xx and other graphics-terminal types." (defvar calc-dumb-map nil "The keymap for the \"dumb\" terminal plot.") -(defun calc-graph-show-dumb (&optional output) +(defun calc-graph-show-dumb (&optional _output) "Default calc-gnuplot-plot-command for Pinard's \"dumb\" terminal type. This \"dumb\" driver will be present in Gnuplot 3.0." (interactive) @@ -1116,14 +1116,14 @@ This \"dumb\" driver will be present in Gnuplot 3.0." (delete-region start end) (goto-char start) (setq errform - (condition-case nil - (math-contains-sdev-p - (eval (intern - (concat "var-" - (save-excursion - (re-search-backward ":\\(.*\\)}") - (match-string 1)))))) - (error nil))) + (ignore-errors + (math-contains-sdev-p + (symbol-value + (intern + (concat "var-" + (save-excursion + (re-search-backward ":\\(.*\\)}") + (match-string 1)))))))) (if yerr (insert " with yerrorbars") (insert " with " @@ -1165,7 +1165,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0." (or (calc-graph-find-plot nil nil) (error "No data points have been set!")) (let ((base (point)) - start + ;; start end) (re-search-forward "[,\n]\\|[ \t]+with") (setq end (match-beginning 0)) @@ -1462,7 +1462,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0." (match-beginning 1) (match-end 1)))) (setq calc-gnuplot-version 1)))) - (condition-case err + (condition-case nil (let ((args (append (and calc-gnuplot-display (not (equal calc-gnuplot-display (getenv "DISPLAY"))) diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el index 72cf90a7587..0b327e8d0f6 100644 --- a/lisp/calc/calc-help.el +++ b/lisp/calc/calc-help.el @@ -1,4 +1,4 @@ -;;; calc-help.el --- help display functions for Calc, +;;; calc-help.el --- help display functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -33,8 +33,8 @@ (declare-function Info-last "info" ()) -(defun calc-help-prefix (arg) - "This key is the prefix for Calc help functions. See calc-help-for-help." +(defun calc-help-prefix (&optional _arg) + "This key is the prefix for Calc help functions. See `calc-help-for-help'." (interactive "P") (or calc-dispatch-help (sit-for echo-keystrokes)) (let ((key (calc-read-key-sequence @@ -79,7 +79,7 @@ C-w Describe how there is no warranty for Calc." (message "Calc Help options: Help, Info, ... press SPC, DEL to scroll, C-g to cancel") (memq (setq key (read-event)) '(? ?\C-h ?\C-? ?\C-v ?\M-v))) - (condition-case err + (condition-case nil (if (memq key '(? ?\C-v)) (scroll-up) (scroll-down)) @@ -302,21 +302,19 @@ C-w Describe how there is no warranty for Calc." (let ((entrylist '()) entry) (require 'info nil t) - (while indices - (condition-case nil - (with-temp-buffer - (Info-mode) - (Info-goto-node (concat "(Calc)" (car indices) " Index")) - (goto-char (point-min)) - (while (re-search-forward "\n\\* \\(.*\\): " nil t) - (setq entry (match-string 1)) - (if (and (not (string-match "<[1-9]+>" entry)) - (not (string-match "(.*)" entry)) - (not (string= entry "Menu"))) - (unless (assoc entry entrylist) - (setq entrylist (cons entry entrylist)))))) - (error nil)) - (setq indices (cdr indices))) + (dolist (indice indices) + (ignore-errors + (with-temp-buffer + (Info-mode) + (Info-goto-node (concat "(Calc)" indice " Index")) + (goto-char (point-min)) + (while (re-search-forward "\n\\* \\(.*\\): " nil t) + (setq entry (match-string 1)) + (if (and (not (string-match "<[1-9]+>" entry)) + (not (string-match "(.*)" entry)) + (not (string= entry "Menu"))) + (unless (assoc entry entrylist) + (setq entrylist (cons entry entrylist)))))))) entrylist)) (defun calc-describe-function (&optional func) @@ -409,9 +407,7 @@ C-w Describe how there is no warranty for Calc." (substitute-command-keys x))))) (nreverse (cdr (reverse (cdr (calc-help)))))) (mapc (function (lambda (prefix) - (let ((msgs (condition-case err - (funcall prefix) - (error nil)))) + (let ((msgs (ignore-errors (funcall prefix)))) (if (car msgs) (princ (if (eq (nth 2 msgs) ?v) diff --git a/lisp/calc/calc-incom.el b/lisp/calc/calc-incom.el index c6264d1f5f9..2c7a4f0561e 100644 --- a/lisp/calc/calc-incom.el +++ b/lisp/calc/calc-incom.el @@ -1,4 +1,4 @@ -;;; calc-incom.el --- complex data type input functions for Calc +;;; calc-incom.el --- complex data type input functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-keypd.el b/lisp/calc/calc-keypd.el index ecf43a12b0c..47917dcac7e 100644 --- a/lisp/calc/calc-keypd.el +++ b/lisp/calc/calc-keypd.el @@ -1,4 +1,4 @@ -;;; calc-keypd.el --- mouse-capable keypad input for Calc +;;; calc-keypd.el --- mouse-capable keypad input for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -35,17 +35,17 @@ (defvar calc-keypad-prev-input nil) (defvar calc-keypad-said-hello nil) -;;; |----+----+----+----+----+----| -;;; | ENTER |+/- |EEX |UNDO| <- | -;;; |-----+---+-+--+--+-+---++----| -;;; | INV | 7 | 8 | 9 | / | -;;; |-----+-----+-----+-----+-----| -;;; | HYP | 4 | 5 | 6 | * | -;;; |-----+-----+-----+-----+-----| -;;; |EXEC | 1 | 2 | 3 | - | -;;; |-----+-----+-----+-----+-----| -;;; | OFF | 0 | . | PI | + | -;;; |-----+-----+-----+-----+-----| +;; |----+----+----+----+----+----| +;; | ENTER |+/- |EEX |UNDO| <- | +;; |-----+---+-+--+--+-+---++----| +;; | INV | 7 | 8 | 9 | / | +;; |-----+-----+-----+-----+-----| +;; | HYP | 4 | 5 | 6 | * | +;; |-----+-----+-----+-----+-----| +;; |EXEC | 1 | 2 | 3 | - | +;; |-----+-----+-----+-----+-----| +;; | OFF | 0 | . | PI | + | +;; |-----+-----+-----+-----+-----| (defvar calc-keypad-layout '( ( ( "ENTER" calc-enter calc-roll-down calc-roll-up calc-over ) ( "ENTER" calc-enter calc-roll-down calc-roll-up calc-over ) @@ -83,12 +83,12 @@ calc-keypad-modes-menu calc-keypad-user-menu ) ) -;;; |----+----+----+----+----+----| -;;; |FLR |CEIL|RND |TRNC|CLN2|FLT | -;;; |----+----+----+----+----+----| -;;; | LN |EXP | |ABS |IDIV|MOD | -;;; |----+----+----+----+----+----| -;;; |SIN |COS |TAN |SQRT|y^x |1/x | +;; |----+----+----+----+----+----| +;; |FLR |CEIL|RND |TRNC|CLN2|FLT | +;; |----+----+----+----+----+----| +;; | LN |EXP | |ABS |IDIV|MOD | +;; |----+----+----+----+----+----| +;; |SIN |COS |TAN |SQRT|y^x |1/x | (defvar calc-keypad-math-menu '( ( ( "FLR" calc-floor ) @@ -110,12 +110,12 @@ ( "y^x" calc-power ) ( "1/x" calc-inv ) ) )) -;;; |----+----+----+----+----+----| -;;; |IGAM|BETA|IBET|ERF |BESJ|BESY| -;;; |----+----+----+----+----+----| -;;; |IMAG|CONJ| RE |ATN2|RAND|RAGN| -;;; |----+----+----+----+----+----| -;;; |GCD |FACT|DFCT|BNOM|PERM|NXTP| +;; |----+----+----+----+----+----| +;; |IGAM|BETA|IBET|ERF |BESJ|BESY| +;; |----+----+----+----+----+----| +;; |IMAG|CONJ| RE |ATN2|RAND|RAGN| +;; |----+----+----+----+----+----| +;; |GCD |FACT|DFCT|BNOM|PERM|NXTP| (defvar calc-keypad-funcs-menu '( ( ( "IGAM" calc-inc-gamma ) @@ -137,12 +137,12 @@ ( "PERM" calc-perm ) ( "NXTP" calc-next-prime calc-prev-prime ) ) )) -;;; |----+----+----+----+----+----| -;;; |AND | OR |XOR |NOT |LSH |RSH | -;;; |----+----+----+----+----+----| -;;; |DEC |HEX |OCT |BIN |WSIZ|ARSH| -;;; |----+----+----+----+----+----| -;;; | A | B | C | D | E | F | +;; |----+----+----+----+----+----| +;; |AND | OR |XOR |NOT |LSH |RSH | +;; |----+----+----+----+----+----| +;; |DEC |HEX |OCT |BIN |WSIZ|ARSH| +;; |----+----+----+----+----+----| +;; | A | B | C | D | E | F | (defvar calc-keypad-binary-menu '( ( ( "AND" calc-and calc-diff ) @@ -164,12 +164,12 @@ ( "E" ("E") ) ( "F" ("F") ) ) )) -;;; |----+----+----+----+----+----| -;;; |SUM |PROD|MAX |MAP*|MAP^|MAP$| -;;; |----+----+----+----+----+----| -;;; |INV |DET |TRN |IDNT|CRSS|"x" | -;;; |----+----+----+----+----+----| -;;; |PACK|UNPK|INDX|BLD |LEN |... | +;; |----+----+----+----+----+----| +;; |SUM |PROD|MAX |MAP*|MAP^|MAP$| +;; |----+----+----+----+----+----| +;; |INV |DET |TRN |IDNT|CRSS|"x" | +;; |----+----+----+----+----+----| +;; |PACK|UNPK|INDX|BLD |LEN |... | (defvar calc-keypad-vector-menu '( ( ( "SUM" calc-vector-sum calc-vector-alt-sum calc-vector-mean ) @@ -196,12 +196,12 @@ ( "LEN" calc-vlength ) ( "..." calc-full-vectors ) ) )) -;;; |----+----+----+----+----+----| -;;; |FLT |FIX |SCI |ENG |GRP | | -;;; |----+----+----+----+----+----| -;;; |RAD |DEG |FRAC|POLR|SYMB|PREC| -;;; |----+----+----+----+----+----| -;;; |SWAP|RLL3|RLL4|OVER|STO |RCL | +;; |----+----+----+----+----+----| +;; |FLT |FIX |SCI |ENG |GRP | | +;; |----+----+----+----+----+----| +;; |RAD |DEG |FRAC|POLR|SYMB|PREC| +;; |----+----+----+----+----+----| +;; |SWAP|RLL3|RLL4|OVER|STO |RCL | (defvar calc-keypad-modes-menu '( ( ( "FLT" calc-normal-notation diff --git a/lisp/calc/calc-lang.el b/lisp/calc/calc-lang.el index 4bbe850273d..bde5abe649f 100644 --- a/lisp/calc/calc-lang.el +++ b/lisp/calc/calc-lang.el @@ -1,4 +1,4 @@ -;;; calc-lang.el --- calc language functions +;;; calc-lang.el --- calc language functions -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -45,6 +45,8 @@ (defvar math-comp-comma) (defvar math-comp-vector-prec) +(defvar math-exp-str) ;; Dyn scoped + ;;; Alternate entry/display languages. (defun calc-set-language (lang &optional option no-refresh) @@ -144,7 +146,7 @@ ( y1 . (math-C-parse-bess)) ( tgamma . calcFunc-gamma ))) -(defun math-C-parse-bess (f val) +(defun math-C-parse-bess (_f val) "Parse C's j0, j1, y0, y1 functions." (let ((args (math-read-expr-list))) (math-read-token) @@ -155,7 +157,7 @@ ((eq val 'y1) '(calcFunc-besY 1))) args))) -(defun math-C-parse-fma (f val) +(defun math-C-parse-fma (_f _val) "Parse C's fma function fma(x,y,z) => (x * y + z)." (let ((args (math-read-expr-list))) (math-read-token) @@ -372,14 +374,14 @@ (defvar math-exp-old-pos) (defvar math-parsing-fortran-vector nil) -(defun math-parse-fortran-vector (op) +(defun math-parse-fortran-vector (_op) (let ((math-parsing-fortran-vector '(end . "\000"))) (prog1 (math-read-brackets t "]") (setq math-exp-token (car math-parsing-fortran-vector) math-expr-data (cdr math-parsing-fortran-vector))))) -(defun math-parse-fortran-vector-end (x op) +(defun math-parse-fortran-vector-end (x _op) (if math-parsing-fortran-vector (progn (setq math-parsing-fortran-vector (cons math-exp-token math-expr-data) @@ -466,10 +468,10 @@ ( "\\times" * 191 190 ) ( "*" * 191 190 ) ( "2x" * 191 190 ) + ( "/" / 185 186 ) ( "+" + 180 181 ) ( "-" - 180 181 ) ( "\\over" / 170 171 ) - ( "/" / 170 171 ) ( "\\choose" calcFunc-choose 170 171 ) ( "\\mod" % 170 171 ) ( "<" calcFunc-lt 160 161 ) @@ -692,7 +694,7 @@ "_{" (math-compose-expr (nth 2 a) 0) "}{" (math-compose-expr (nth 1 a) 0) "}")))) -(defun math-parse-tex-sum (f val) +(defun math-parse-tex-sum (f _val) (let (low high save) (or (equal math-expr-data "_") (throw 'syntax "Expected `_'")) (math-read-token) @@ -727,14 +729,15 @@ (math-compose-expr (nth 3 a) 0) (if (memq (nth 1 a) '(0 2)) ")" "]"))) -(defun math-compose-tex-var (a prec) +(defun math-compose-tex-var (a _prec) (if (and calc-language-option (not (= calc-language-option 0)) (string-match "\\`[a-zA-Zα-ωΑ-Ω][a-zA-Zα-ωΑ-Ω0-9]+\\'" (symbol-name (nth 1 a)))) - (if (eq calc-language 'latex) - (format "\\text{%s}" (symbol-name (nth 1 a))) - (format "\\hbox{%s}" (symbol-name (nth 1 a)))) + (format (if (eq calc-language 'latex) + "\\text{%s}" + "\\hbox{%s}") + (symbol-name (nth 1 a))) (math-compose-var a))) (defun math-compose-tex-func (func a) @@ -906,7 +909,7 @@ (setq math-exp-str (copy-sequence math-exp-str)) (aset math-exp-str right ?\])))))))))) -(defun math-latex-parse-frac (f val) +(defun math-latex-parse-frac (_f _val) (let (numer denom) (setq numer (car (math-read-expr-list))) (math-read-token) @@ -916,7 +919,7 @@ (list 'frac numer denom) (list '/ numer denom)))) -(defun math-latex-parse-two-args (f val) +(defun math-latex-parse-two-args (f _val) (let (first second) (setq first (car (math-read-expr-list))) (math-read-token) @@ -931,7 +934,7 @@ (put 'latex 'math-input-filter 'math-tex-input-filter) -(defun calc-eqn-language (n) +(defun calc-eqn-language (_n) (interactive "P") (calc-wrapper (calc-set-language 'eqn) @@ -1159,7 +1162,7 @@ (math-compose-eqn-matrix (cdr a))))))) nil)) -(defun math-parse-eqn-matrix (f sym) +(defun math-parse-eqn-matrix (_f _sym) (let ((vec nil)) (while (assoc math-expr-data '(("ccol") ("lcol") ("rcol"))) (math-read-token) @@ -1175,7 +1178,7 @@ (math-read-token) (math-transpose (cons 'vec (nreverse vec))))) -(defun math-parse-eqn-prime (x sym) +(defun math-parse-eqn-prime (x _sym) (if (eq (car-safe x) 'var) (if (equal math-expr-data calc-function-open) (progn @@ -1363,7 +1366,7 @@ (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." (let ((args (math-read-expr-list))) (math-read-token) @@ -1512,7 +1515,7 @@ ( substitute . (math-maxima-parse-subst)) ( taylor . (math-maxima-parse-taylor)))) -(defun math-maxima-parse-subst (f val) +(defun math-maxima-parse-subst (_f _val) "Read in the arguments to \"subst\" in Calc's Maxima mode." (let ((args (math-read-expr-list))) (math-read-token) @@ -1521,7 +1524,7 @@ (nth 2 args) (nth 0 args)))) -(defun math-maxima-parse-taylor (f val) +(defun math-maxima-parse-taylor (_f _val) "Read in the arguments to \"taylor\" in Calc's Maxima mode." (let ((args (math-read-expr-list))) (math-read-token) @@ -1762,7 +1765,7 @@ ( contains . (math-lang-switch-args calcFunc-in)) ( has . (math-lang-switch-args calcFunc-refers)))) -(defun math-lang-switch-args (f val) +(defun math-lang-switch-args (f _val) "Read the arguments to a Calc function in reverse order. This is used for various language modes which have functions in reverse order to Calc's." @@ -1805,15 +1808,15 @@ order to Calc's." (put 'giac 'math-compose-subscr (function (lambda (a) - (let ((args (cdr (cdr a)))) + ;; (let ((args (cdr (cdr a)))) (list 'horiz (math-compose-expr (nth 1 a) 1000) "[" (math-compose-expr (calc-normalize (list '- (nth 2 a) 1)) 0) - "]"))))) + "]")))) ;;) -(defun math-read-giac-subscr (x op) +(defun math-read-giac-subscr (x _op) (let ((idx (math-read-expr-level 0))) (or (equal math-expr-data "]") (throw 'syntax "Expected `]'")) @@ -1947,7 +1950,7 @@ order to Calc's." (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))) (or (and (equal math-expr-data "]") (progn @@ -2094,10 +2097,13 @@ order to Calc's." (defvar math-rb-v1) (defvar math-rb-v2) -(defun math-read-big-rec (math-rb-h1 math-rb-v1 math-rb-h2 math-rb-v2 +(defun math-read-big-rec (rb-h1 rb-v1 rb-h2 rb-v2 &optional baseline prec short) (or prec (setq prec 0)) - + (let ((math-rb-h1 rb-h1) + (math-rb-v1 rb-v1) + (math-rb-h2 rb-h2) + (math-rb-v2 rb-v2)) ;; Clip whitespace above or below. (while (and (< math-rb-v1 math-rb-v2) (math-read-big-emptyp math-rb-h1 math-rb-v1 math-rb-h2 (1+ math-rb-v1))) @@ -2449,7 +2455,7 @@ order to Calc's." math-read-big-h2 h) (or short (= math-read-big-h2 math-rb-h2) (math-read-big-error h baseline)) - p))) + p)))) (defun math-read-big-char (h v) (or (and (>= h math-rb-h1) diff --git a/lisp/calc/calc-macs.el b/lisp/calc/calc-macs.el index 257d369b87a..5aaa5f48d6c 100644 --- a/lisp/calc/calc-macs.el +++ b/lisp/calc/calc-macs.el @@ -61,6 +61,7 @@ (defmacro calc-with-trail-buffer (&rest body) `(let ((save-buf (current-buffer)) (calc-command-flags nil)) + (ignore save-buf) ;FIXME: Use a name less conflict-prone! (with-current-buffer (calc-trail-display t) (progn (goto-char calc-trail-pointer) diff --git a/lisp/calc/calc-map.el b/lisp/calc/calc-map.el index 139ba5b8e38..57483fc6590 100644 --- a/lisp/calc/calc-map.el +++ b/lisp/calc/calc-map.el @@ -1,4 +1,4 @@ -;;; calc-map.el --- higher-order functions for Calc +;;; calc-map.el --- higher-order functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -48,6 +48,8 @@ (math-calcFunc-to-var (nth 1 oper)) expr))))) +(defvar calc-mapping-dir nil) + (defun calc-reduce (&optional oper accum) (interactive) (calc-wrapper @@ -136,7 +138,6 @@ (1+ calc-dollar-used)))))))) (defvar calc-verify-arglist t) -(defvar calc-mapping-dir nil) (defun calc-map-stack () "This is meant to be called by calc-keypad mode." (interactive) @@ -853,7 +854,7 @@ (i -1) (math-working-step 0) (math-working-step-2 nil) - len cols obj expr) + len obj expr) ;; cols (if (eq mode 'eqn) (setq mode 'elems heads '(calcFunc-eq calcFunc-neq calcFunc-lt calcFunc-gt @@ -1023,22 +1024,21 @@ (let ((expr (car (setq vec (cdr vec))))) (if expr (progn - (condition-case err - (and (symbolp func) - (let ((lfunc (or (cdr (assq func - '( (calcFunc-add . math-add) - (calcFunc-sub . math-sub) - (calcFunc-mul . math-mul) - (calcFunc-div . math-div) - (calcFunc-pow . math-pow) - (calcFunc-mod . math-mod) - (calcFunc-vconcat . - math-concat) ))) - func))) - (while (cdr vec) - (setq expr (funcall lfunc expr (nth 1 vec)) - vec (cdr vec))))) - (error nil)) + (ignore-errors + (and (symbolp func) + (let ((lfunc (or (cdr (assq func + '( (calcFunc-add . math-add) + (calcFunc-sub . math-sub) + (calcFunc-mul . math-mul) + (calcFunc-div . math-div) + (calcFunc-pow . math-pow) + (calcFunc-mod . math-mod) + (calcFunc-vconcat + . math-concat) ))) + func))) + (while (cdr vec) + (setq expr (funcall lfunc expr (nth 1 vec)) + vec (cdr vec)))))) (while (setq vec (cdr vec)) (setq expr (math-build-call func (list expr (car vec))))) (math-normalize expr)) @@ -1229,9 +1229,11 @@ (defvar math-inner-mul-func) (defvar math-inner-add-func) -(defun calcFunc-inner (math-inner-mul-func math-inner-add-func a b) +(defun calcFunc-inner (inner-mul-func inner-add-func a b) (or (math-vectorp a) (math-reject-arg a 'vectorp)) (or (math-vectorp b) (math-reject-arg b 'vectorp)) + (let ((math-inner-mul-func inner-mul-func) + (math-inner-add-func inner-add-func)) (if (math-matrixp a) (if (math-matrixp b) (if (= (length (nth 1 a)) (length b)) @@ -1247,12 +1249,12 @@ (math-dimension-error)))) (if (math-matrixp b) (nth 1 (math-inner-mats (list 'vec a) b)) - (calcFunc-reduce math-inner-add-func (calcFunc-map math-inner-mul-func a b))))) + (calcFunc-reduce math-inner-add-func (calcFunc-map math-inner-mul-func a b)))))) (defun math-inner-mats (a b) (let ((mat nil) (cols (length (nth 1 b))) - row col ap bp accum) + row col) ;; ap bp accum (while (setq a (cdr a)) (setq col cols row nil) diff --git a/lisp/calc/calc-math.el b/lisp/calc/calc-math.el index 6bbd2f574e5..46172d1b7f6 100644 --- a/lisp/calc/calc-math.el +++ b/lisp/calc/calc-math.el @@ -1,4 +1,4 @@ -;;; calc-math.el --- mathematical functions for Calc +;;; calc-math.el --- mathematical functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -60,33 +60,23 @@ pow (< pow 1.0e+INF)) (setq x (* 2 x)) - (setq pow (condition-case nil - (expt 10.0 (* 2 x)) - (error nil)))) + (setq pow (ignore-errors (expt 10.0 (* 2 x))))) ;; The following loop should stop when 10^(x+1) is too large. - (setq pow (condition-case nil - (expt 10.0 (1+ x)) - (error nil))) + (setq pow (ignore-errors (expt 10.0 (1+ x)))) (while (and pow (< pow 1.0e+INF)) (setq x (1+ x)) - (setq pow (condition-case nil - (expt 10.0 (1+ x)) - (error nil)))) + (setq pow (ignore-errors (expt 10.0 (1+ x))))) (1- x)) "The largest exponent which Calc will convert to an Emacs float.") (defvar math-smallest-emacs-expt (let ((x -1)) - (while (condition-case nil - (> (expt 10.0 x) 0.0) - (error nil)) + (while (ignore-errors (> (expt 10.0 x) 0.0)) (setq x (* 2 x))) (setq x (/ x 2)) - (while (condition-case nil - (> (expt 10.0 x) 0.0) - (error nil)) + (while (ignore-errors (> (expt 10.0 x) 0.0)) (setq x (1- x))) (+ x 2)) "The smallest exponent which Calc will convert to an Emacs float.") @@ -100,19 +90,18 @@ If this can't be done, return NIL." (let* ((xpon (+ (nth 2 x) (1- (math-numdigs (nth 1 x)))))) (and (<= math-smallest-emacs-expt xpon) (<= xpon math-largest-emacs-expt) - (condition-case nil - (math-read-number - (number-to-string - (funcall fn - (string-to-number - (let - ((calc-number-radix 10) - (calc-twos-complement-mode nil) - (calc-float-format (list 'float calc-internal-prec)) - (calc-group-digits nil) - (calc-point-char ".")) - (math-format-number (math-float x))))))) - (error nil)))))) + (ignore-errors + (math-read-number + (number-to-string + (funcall fn + (string-to-number + (let + ((calc-number-radix 10) + (calc-twos-complement-mode nil) + (calc-float-format (list 'float calc-internal-prec)) + (calc-group-digits nil) + (calc-point-char ".")) + (math-format-number (math-float x)))))))))))) (defun calc-sqrt (arg) (interactive "P") @@ -638,11 +627,11 @@ If this can't be done, return NIL." (defvar math-nrf-nf) (defvar math-nrf-nfm1) -(defun math-nth-root-float (a math-nrf-n &optional guess) +(defun math-nth-root-float (a nrf-n &optional guess) (math-inexact-result) (math-with-extra-prec 1 - (let ((math-nrf-nf (math-float math-nrf-n)) - (math-nrf-nfm1 (math-float (1- math-nrf-n)))) + (let ((math-nrf-nf (math-float nrf-n)) + (math-nrf-nfm1 (math-float (1- nrf-n)))) (math-nth-root-float-iter a (or guess (math-make-float 1 (/ (+ (math-numdigs (nth 1 a)) @@ -665,11 +654,12 @@ If this can't be done, return NIL." ;; math-nth-root-int. (defvar math-nri-n) -(defun math-nth-root-integer (a math-nri-n &optional guess) ; [I I S] - (math-nth-root-int-iter a (or guess - (math-scale-int 1 (/ (+ (math-numdigs a) - (1- math-nri-n)) - math-nri-n))))) +(defun math-nth-root-integer (a nri-n &optional guess) ; [I I S] + (let ((math-nri-n nri-n)) + (math-nth-root-int-iter a (or guess + (math-scale-int 1 (/ (+ (math-numdigs a) + (1- nri-n)) + nri-n)))))) (defun math-nth-root-int-iter (a guess) (math-working "root" guess) @@ -693,13 +683,13 @@ If this can't be done, return NIL." ;;;; Transcendental functions. -;;; All of these functions are defined on the complex plane. -;;; (Branch cuts, etc. follow Steele's Common Lisp book.) +;; All of these functions are defined on the complex plane. +;; (Branch cuts, etc. follow Steele's Common Lisp book.) -;;; Most functions increase calc-internal-prec by 2 digits, then round -;;; down afterward. "-raw" functions use the current precision, require -;;; their arguments to be in float (or complex float) format, and always -;;; work in radians (where applicable). +;; Most functions increase calc-internal-prec by 2 digits, then round +;; down afterward. "-raw" functions use the current precision, require +;; their arguments to be in float (or complex float) format, and always +;; work in radians (where applicable). (defun math-to-radians (a) ; [N N] (cond ((eq (car-safe a) 'hms) @@ -1126,9 +1116,9 @@ If this can't be done, return NIL." (math-div-float (cdr sc) (car sc))))))) -;;; This could use a smarter method: Reduce x as in math-sin-raw, then -;;; compute either sin(x) or cos(x), whichever is smaller, and compute -;;; the other using the identity sin(x)^2 + cos(x)^2 = 1. +;; This could use a smarter method: Reduce x as in math-sin-raw, then +;; compute either sin(x) or cos(x), whichever is smaller, and compute +;; the other using the identity sin(x)^2 + cos(x)^2 = 1. (defun math-sin-cos-raw (x) ; [F.F F] (result is (sin x . cos x)) (cons (math-sin-raw x) (math-cos-raw x))) @@ -2072,7 +2062,7 @@ If this can't be done, return NIL." (put 'calcFunc-arctanh 'math-expandable t) -;;; Convert A from HMS or degrees to radians. +;; Convert A from HMS or degrees to radians. (defun calcFunc-rad (a) ; [R R] [Public] (cond ((or (Math-numberp a) (eq (car a) 'intv)) @@ -2089,7 +2079,7 @@ If this can't be done, return NIL." (t (list 'calcFunc-rad a)))) (put 'calcFunc-rad 'math-expandable t) -;;; Convert A from HMS or radians to degrees. +;; Convert A from HMS or radians to degrees. (defun calcFunc-deg (a) ; [R R] [Public] (cond ((or (Math-numberp a) (eq (car a) 'intv)) diff --git a/lisp/calc/calc-menu.el b/lisp/calc/calc-menu.el index 3cc98ef59c3..d593eddb315 100644 --- a/lisp/calc/calc-menu.el +++ b/lisp/calc/calc-menu.el @@ -1,4 +1,4 @@ -;;; calc-menu.el --- a menu for Calc +;;; calc-menu.el --- a menu for Calc -*- lexical-binding:t -*- ;; Copyright (C) 2007-2020 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el index a8f65ffe752..7c97dc6a9a0 100644 --- a/lisp/calc/calc-misc.el +++ b/lisp/calc/calc-misc.el @@ -1,4 +1,4 @@ -;;; calc-misc.el --- miscellaneous functions for Calc +;;; calc-misc.el --- miscellaneous functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-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 ;; 4 <-- point ;; 5 <-- bot-line = 5 - (dotimes (i mid-line) + (dotimes (_ mid-line) (setq mid-cell old-top-list old-top-list (cdr old-top-list)) (setcdr mid-cell new-top-list) @@ -519,7 +519,7 @@ With argument 0, switch line point is in with line mark is in." ;; 2 ;; 1 (setq prev-mid-cell old-top-list) - (dotimes (i (- bot-line mid-line)) + (dotimes (_ (- bot-line mid-line)) (setq bot-cell old-top-list old-top-list (cdr old-top-list)) (setcdr bot-cell new-top-list) diff --git a/lisp/calc/calc-mode.el b/lisp/calc/calc-mode.el index ff99ccc466c..e109233a825 100644 --- a/lisp/calc/calc-mode.el +++ b/lisp/calc/calc-mode.el @@ -1,4 +1,4 @@ -;;; calc-mode.el --- calculator modes for Calc +;;; calc-mode.el --- calculator modes for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -424,8 +424,8 @@ (t "Not recording mode changes permanently"))))) -(defun calc-total-algebraic-mode (flag) - (interactive "P") +(defun calc-total-algebraic-mode (&optional _flag) + (interactive) (calc-wrapper (if (eq calc-algebraic-mode 'total) (calc-algebraic-mode nil) diff --git a/lisp/calc/calc-mtx.el b/lisp/calc/calc-mtx.el index 2850b33721b..8deef7dc4fd 100644 --- a/lisp/calc/calc-mtx.el +++ b/lisp/calc/calc-mtx.el @@ -1,4 +1,4 @@ -;;; calc-mtx.el --- matrix functions for Calc +;;; calc-mtx.el --- matrix functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-nlfit.el b/lisp/calc/calc-nlfit.el index 0fe955b28d1..6f2a601cd99 100644 --- a/lisp/calc/calc-nlfit.el +++ b/lisp/calc/calc-nlfit.el @@ -1,4 +1,4 @@ -;;; calc-nlfit.el --- nonlinear curve fitting for Calc +;;; calc-nlfit.el --- nonlinear curve fitting for Calc -*- lexical-binding:t -*- ;; Copyright (C) 2007-2020 Free Software Foundation, Inc. @@ -104,19 +104,19 @@ (list 'vec C12 C22)))) (list A B))))) -;;; The methods described by de Sousa require the cumulative data qdata -;;; and the rates pdata. We will assume that we are given either -;;; qdata and the corresponding times tdata, or pdata and the corresponding -;;; tdata. The following two functions will find pdata or qdata, -;;; given the other.. +;; The methods described by de Sousa require the cumulative data qdata +;; and the rates pdata. We will assume that we are given either +;; qdata and the corresponding times tdata, or pdata and the corresponding +;; tdata. The following two functions will find pdata or qdata, +;; given the other.. -;;; First, given two lists; one of values q0, q1, ..., qn and one of -;;; corresponding times t0, t1, ..., tn; return a list -;;; p0, p1, ..., pn of the rates of change of the qi with respect to t. -;;; p0 is the right hand derivative (q1 - q0)/(t1 - t0). -;;; pn is the left hand derivative (qn - q(n-1))/(tn - t(n-1)). -;;; The other pis are the averages of the two: -;;; (1/2)((qi - q(i-1))/(ti - t(i-1)) + (q(i+1) - qi)/(t(i+1) - ti)). +;; First, given two lists; one of values q0, q1, ..., qn and one of +;; corresponding times t0, t1, ..., tn; return a list +;; p0, p1, ..., pn of the rates of change of the qi with respect to t. +;; p0 is the right hand derivative (q1 - q0)/(t1 - t0). +;; pn is the left hand derivative (qn - q(n-1))/(tn - t(n-1)). +;; The other pis are the averages of the two: +;; (1/2)((qi - q(i-1))/(ti - t(i-1)) + (q(i+1) - qi)/(t(i+1) - ti)). (defun math-nlfit-get-rates-from-cumul (tdata qdata) (let ((pdata (list @@ -153,12 +153,12 @@ pdata)) (reverse pdata))) -;;; Next, given two lists -- one of rates p0, p1, ..., pn and one of -;;; corresponding times t0, t1, ..., tn -- and an initial values q0, -;;; return a list q0, q1, ..., qn of the cumulative values. -;;; q0 is the initial value given. -;;; For i>0, qi is computed using the trapezoid rule: -;;; qi = q(i-1) + (1/2)(pi + p(i-1))(ti - t(i-1)) +;; Next, given two lists -- one of rates p0, p1, ..., pn and one of +;; corresponding times t0, t1, ..., tn -- and an initial values q0, +;; return a list q0, q1, ..., qn of the cumulative values. +;; q0 is the initial value given. +;; For i>0, qi is computed using the trapezoid rule: +;; qi = q(i-1) + (1/2)(pi + p(i-1))(ti - t(i-1)) (defun math-nlfit-get-cumul-from-rates (tdata pdata q0) (let* ((qdata (list q0))) @@ -177,16 +177,16 @@ (setq tdata (cdr tdata))) (reverse qdata))) -;;; Given the qdata, pdata and tdata, find the parameters -;;; a, b and c that fit q = a/(1+b*exp(c*t)). -;;; a is found using the method described by de Sousa. -;;; b and c are found using least squares on the linearization -;;; log((a/q)-1) = log(b) + c*t -;;; In some cases (where the logistic curve may well be the wrong -;;; model), the computed a will be less than or equal to the maximum -;;; value of q in qdata; in which case the above linearization won't work. -;;; In this case, a will be replaced by a number slightly above -;;; the maximum value of q. +;; Given the qdata, pdata and tdata, find the parameters +;; a, b and c that fit q = a/(1+b*exp(c*t)). +;; a is found using the method described by de Sousa. +;; b and c are found using least squares on the linearization +;; log((a/q)-1) = log(b) + c*t +;; In some cases (where the logistic curve may well be the wrong +;; model), the computed a will be less than or equal to the maximum +;; value of q in qdata; in which case the above linearization won't work. +;; In this case, a will be replaced by a number slightly above +;; the maximum value of q. (defun math-nlfit-find-qmax (qdata pdata tdata) (let* ((ratios (math-map-binop 'math-div pdata qdata)) @@ -208,12 +208,12 @@ (calcFunc-exp (nth 0 bandc)) (nth 1 bandc)))) -;;; Next, given the pdata and tdata, we can find the qdata if we know q0. -;;; We first try to find q0, using the fact that when p takes on its largest -;;; value, q is half of its maximum value. So we'll find the maximum value -;;; of q given various q0, and use bisection to approximate the correct q0. +;; Next, given the pdata and tdata, we can find the qdata if we know q0. +;; We first try to find q0, using the fact that when p takes on its largest +;; value, q is half of its maximum value. So we'll find the maximum value +;; of q given various q0, and use bisection to approximate the correct q0. -;;; First, given pdata and tdata, find what half of qmax would be if q0=0. +;; First, given pdata and tdata, find what half of qmax would be if q0=0. (defun math-nlfit-find-qmaxhalf (pdata tdata) (let ((pmax (math-max-list (car pdata) (cdr pdata))) @@ -231,7 +231,7 @@ (setq tdata (cdr tdata))) qmh)) -;;; Next, given pdata and tdata, approximate q0. +;; Next, given pdata and tdata, approximate q0. (defun math-nlfit-find-q0 (pdata tdata) (let* ((qhalf (math-nlfit-find-qmaxhalf pdata tdata)) @@ -250,7 +250,7 @@ (setq q0 (math-add q0 qhalf))) (let* ((qmin (math-sub q0 qhalf)) (qmax q0) - (qt (math-nlfit-find-qmax + (_qt (math-nlfit-find-qmax (mapcar (lambda (q) (math-add q0 q)) qdata) @@ -270,20 +270,20 @@ (setq i (1+ i))) (math-mul '(float 5 -1) (math-add qmin qmax))))) -;;; To improve the approximations to the parameters, we can use -;;; Marquardt method as described in Schwarz's book. +;; To improve the approximations to the parameters, we can use +;; Marquardt method as described in Schwarz's book. -;;; Small numbers used in the Givens algorithm +;; Small numbers used in the Givens algorithm (defvar math-nlfit-delta '(float 1 -8)) (defvar math-nlfit-epsilon '(float 1 -5)) -;;; Maximum number of iterations +;; Maximum number of iterations (defvar math-nlfit-max-its 100) -;;; Next, we need some functions for dealing with vectors and -;;; matrices. For convenience, we'll work with Emacs lists -;;; as vectors, rather than Calc's vectors. +;; Next, we need some functions for dealing with vectors and +;; matrices. For convenience, we'll work with Emacs lists +;; as vectors, rather than Calc's vectors. (defun math-nlfit-set-elt (vec i x) (setcar (nthcdr (1- i) vec) x)) @@ -589,7 +589,7 @@ (calcFunc-trn j) j)) (calcFunc-inv j))) -(defun math-nlfit-get-sigmas (grad xlist pparms chisq) +(defun math-nlfit-get-sigmas (grad xlist pparms _chisq) (let* ((sgs nil) (covar (math-nlfit-find-covar grad xlist pparms)) (n (1- (length covar))) @@ -664,6 +664,8 @@ (calc-pop-push-record-list n prefix vals) (calc-handle-whys)) +(defvar calc-curve-nvars) + (defun math-nlfit-fit-curve (fn grad solnexpr initparms &optional sdv) (calc-slow-wrapper (let* ((sdevv (or (eq sdv 'calcFunc-efit) (eq sdv 'calcFunc-xfit))) @@ -678,7 +680,7 @@ (calc-curve-varnames nil) (calc-curve-coefnames nil) (calc-curve-nvars 1) - (fitvars (calc-get-fit-variables 1 3)) + (_fitvars (calc-get-fit-variables 1 3)) (var (nth 1 calc-curve-varnames)) (parms (cdr calc-curve-coefnames)) (parmguess @@ -763,7 +765,7 @@ (calc-curve-varnames nil) (calc-curve-coefnames nil) (calc-curve-nvars 1) - (fitvars (calc-get-fit-variables 1 2)) + (_fitvars (calc-get-fit-variables 1 2)) (var (nth 1 calc-curve-varnames)) (parms (cdr calc-curve-coefnames)) (soln (list '* (nth 0 finalparms) diff --git a/lisp/calc/calc-prog.el b/lisp/calc/calc-prog.el index 6db5de4c96c..ea9c49748e2 100644 --- a/lisp/calc/calc-prog.el +++ b/lisp/calc/calc-prog.el @@ -1,4 +1,4 @@ -;;; calc-prog.el --- user programmability functions for Calc +;;; calc-prog.el --- user programmability functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -111,10 +111,15 @@ "Not reporting timing of commands")))) (defun calc-pass-errors () + ;; FIXME: This is broken at least since Emacs-26. + ;; AFAICT the immediate purpose of this code is to hack the + ;; `condition-case' in `calc-do' so it doesn't catch errors any + ;; more. I'm not sure why/whatfor this was designed, but I suspect + ;; that `condition-case-unless-debug' would cover the same needs. (interactive) ;; The following two cases are for the new, optimizing byte compiler ;; or the standard 18.57 byte compiler, respectively. - (condition-case err + (condition-case nil (let ((place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 15))) (or (memq (car-safe (car-safe place)) '(error xxxerror)) (setq place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 27))) @@ -165,6 +170,7 @@ ;; calc-user-define-composition and calc-finish-formula-edit, ;; but is used by calc-fix-user-formula. (defvar calc-user-formula-alist) +(defvar math-arglist) ; dynamically bound in all callers (defun calc-user-define-formula () (interactive) @@ -328,7 +334,6 @@ (setcdr kmap (cons (cons key cmd) (cdr kmap))))))) (message ""))) -(defvar math-arglist) ; dynamically bound in all callers (defun calc-default-formula-arglist (form) (if (consp form) (if (eq (car form) 'var) @@ -511,8 +516,9 @@ ;; is called (indirectly) by calc-read-parse-table. (defvar calc-lang) -(defun calc-write-parse-table (tab calc-lang) - (let ((p tab)) +(defun calc-write-parse-table (tab lang) + (let ((calc-lang lang) + (p tab)) (while p (calc-write-parse-table-part (car (car p))) (insert ":= " @@ -551,8 +557,9 @@ (insert " ")))) (setq p (cdr p)))) -(defun calc-read-parse-table (calc-buf calc-lang) - (let ((tab nil)) +(defun calc-read-parse-table (calc-buf lang) + (let ((calc-lang lang) + (tab nil)) (while (progn (skip-chars-forward "\n\t ") (not (eobp))) @@ -860,7 +867,7 @@ (defun calc-edit-macro-combine-digits () "Put an entire sequence of digits on a single line." (let ((line (calc-edit-macro-command)) - curline) + ) ;; curline (goto-char (line-beginning-position)) (kill-line 1) (while (string-equal (calc-edit-macro-command-type) "calcDigit-start") @@ -1038,7 +1045,7 @@ Redefine the corresponding command." (let* ((cmd (cdr def)) (fcmd (and cmd (symbolp cmd) (symbol-function cmd))) (func nil) - (pt (point)) + ;; (pt (point)) (fill-column 70) (fill-prefix nil) str q-ok) @@ -1945,8 +1952,9 @@ Redefine the corresponding command." ;; by math-define-body. (defvar math-exp-env) -(defun math-define-body (body math-exp-env) - (math-define-list body)) +(defun math-define-body (body exp-env) + (let ((math-exp-env exp-env)) + (math-define-list body))) (defun math-define-list (body &optional quote) (cond ((null body) diff --git a/lisp/calc/calc-rewr.el b/lisp/calc/calc-rewr.el index bb909e728e1..2cc7b6beef0 100644 --- a/lisp/calc/calc-rewr.el +++ b/lisp/calc/calc-rewr.el @@ -1,4 +1,4 @@ -;;; calc-rewr.el --- rewriting functions for Calc +;;; calc-rewr.el --- rewriting functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -142,7 +142,7 @@ (calc-pop-push-record-list n "rwrt" (list expr))) (calc-handle-whys))) -(defun calc-match (pat &optional interactive) +(defun calc-match (pat &optional _interactive) (interactive "sPattern: \np") (calc-slow-wrapper (let (n expr) @@ -158,9 +158,9 @@ (setq expr (calc-top-n 1) n 1)) (or (math-vectorp expr) (error "Argument must be a vector")) - (if (calc-is-inverse) - (calc-enter-result n "mtcn" (math-match-patterns pat expr t)) - (calc-enter-result n "mtch" (math-match-patterns pat expr nil)))))) + (calc-enter-result n "mtcn" + (math-match-patterns pat expr + (not (not (calc-is-inverse)))))))) (defvar math-mt-many) @@ -169,8 +169,10 @@ ;; but is used by math-rewrite-phase (defvar math-rewrite-whole-expr) -(defun math-rewrite (math-rewrite-whole-expr rules &optional math-mt-many) - (let* ((crules (math-compile-rewrites rules)) +(defun math-rewrite (rewrite-whole-expr rules &optional mt-many) + (let* ((math-rewrite-whole-expr rewrite-whole-expr) + (math-mt-many mt-many) + (crules (math-compile-rewrites rules)) (heads (math-rewrite-heads math-rewrite-whole-expr)) (trace-buffer (get-buffer "*Trace*")) (calc-display-just 'center) @@ -211,6 +213,8 @@ ":\n" fmt "\n")))) math-rewrite-whole-expr)) +(defvar math-rewrite-phase 1) + (defun math-rewrite-phase (sched) (while (and sched (/= math-mt-many 0)) (if (listp (car sched)) @@ -464,6 +468,8 @@ ;;; whole match the name v. Beware of circular structures! ;;; +(defvar math-rewrite-whole nil) + (defun math-compile-patterns (pats) (if (and (eq (car-safe pats) 'var) (calc-var-value (nth 2 pats))) @@ -485,7 +491,6 @@ (cdr pats) (list pats))))))))) -(defvar math-rewrite-whole nil) (defvar math-make-import-list nil) ;; The variable math-import-list is local to part of math-compile-rewrites, @@ -580,7 +585,7 @@ (let ((rule-set nil) (all-heads nil) (nil-rules nil) - (rule-count 0) + ;; (rule-count 0) (math-schedule nil) (math-iterations nil) (math-phases nil) @@ -831,14 +836,16 @@ (defvar math-rwcomp-subst-new-func) (defvar math-rwcomp-subst-old-func) -(defun math-rwcomp-substitute (expr math-rwcomp-subst-old math-rwcomp-subst-new) - (if (and (eq (car-safe math-rwcomp-subst-old) 'var) - (memq (car-safe math-rwcomp-subst-new) '(var calcFunc-lambda))) - (let ((math-rwcomp-subst-old-func (math-var-to-calcFunc math-rwcomp-subst-old)) - (math-rwcomp-subst-new-func (math-var-to-calcFunc math-rwcomp-subst-new))) +(defun math-rwcomp-substitute (expr rwcomp-subst-old rwcomp-subst-new) + (let ((math-rwcomp-subst-old rwcomp-subst-old) + (math-rwcomp-subst-new rwcomp-subst-new)) + (if (and (eq (car-safe rwcomp-subst-old) 'var) + (memq (car-safe rwcomp-subst-new) '(var calcFunc-lambda))) + (let ((math-rwcomp-subst-old-func (math-var-to-calcFunc rwcomp-subst-old)) + (math-rwcomp-subst-new-func (math-var-to-calcFunc rwcomp-subst-new))) (math-rwcomp-subst-rec expr)) (let ((math-rwcomp-subst-old-func nil)) - (math-rwcomp-subst-rec expr)))) + (math-rwcomp-subst-rec expr))))) (defun math-rwcomp-subst-rec (expr) (cond ((equal expr math-rwcomp-subst-old) math-rwcomp-subst-new) @@ -1452,8 +1459,6 @@ ,form (setcar rules orig)))) -(defvar math-rewrite-phase 1) - ;; The variable math-apply-rw-regs is local to math-apply-rewrites, ;; but is used by math-rwapply-replace-regs and math-rwapply-reg-looks-negp ;; which are called by math-apply-rewrites. @@ -1463,11 +1468,12 @@ ;; but is used by math-rwapply-remember. (defvar math-apply-rw-ruleset) -(defun math-apply-rewrites (expr rules &optional heads math-apply-rw-ruleset) +(defun math-apply-rewrites (expr rules &optional heads apply-rw-ruleset) (and (setq rules (cdr (or (assq (car-safe expr) rules) (assq nil rules)))) - (let ((result nil) + (let ((math-apply-rw-ruleset apply-rw-ruleset) + (result nil) op math-apply-rw-regs inst part pc mark btrack (tracing math-rwcomp-tracing) (phase math-rewrite-phase)) diff --git a/lisp/calc/calc-rules.el b/lisp/calc/calc-rules.el index 1b7526c3c9e..fe0e8a1e479 100644 --- a/lisp/calc/calc-rules.el +++ b/lisp/calc/calc-rules.el @@ -1,4 +1,4 @@ -;;; calc-rules.el --- rules for simplifying algebraic expressions in Calc +;;; calc-rules.el --- rules for simplifying algebraic expressions in Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-sel.el b/lisp/calc/calc-sel.el index 0342a0ae48c..d2944488870 100644 --- a/lisp/calc/calc-sel.el +++ b/lisp/calc/calc-sel.el @@ -1,4 +1,4 @@ -;;; calc-sel.el --- data selection functions for Calc +;;; calc-sel.el --- data selection functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -146,7 +146,8 @@ (defvar calc-fnp-op) (defvar calc-fnp-num) -(defun calc-find-nth-part (expr calc-fnp-num) +(defun calc-find-nth-part (expr fnp-num) + (let ((calc-fnp-num fnp-num)) (if (and calc-assoc-selections (assq (car-safe expr) calc-assoc-ops)) (let (calc-fnp-op) @@ -154,7 +155,7 @@ (if (eq (car-safe expr) 'intv) (and (>= calc-fnp-num 1) (<= calc-fnp-num 2) (nth (1+ calc-fnp-num) expr)) (and (not (Math-primp expr)) (>= calc-fnp-num 1) (< calc-fnp-num (length expr)) - (nth calc-fnp-num expr))))) + (nth calc-fnp-num expr)))))) (defun calc-find-nth-part-rec (expr) ; uses num, op (or (if (and (setq calc-fnp-op (assq (car-safe (nth 1 expr)) calc-assoc-ops)) @@ -381,7 +382,7 @@ ;; (if (or (< num 1) (> num (calc-stack-size))) ;; (error "Cursor must be positioned on a stack element")) (let* ((entry (calc-top num 'entry)) - ww w) + ) ;; ww w (or (equal entry calc-selection-cache-entry) (progn (setcar entry (calc-encase-atoms (car entry))) @@ -481,8 +482,9 @@ (defvar calc-rsf-old) (defvar calc-rsf-new) -(defun calc-replace-sub-formula (expr calc-rsf-old calc-rsf-new) - (setq calc-rsf-new (calc-encase-atoms calc-rsf-new)) +(defun calc-replace-sub-formula (expr rsf-old rsf-new) + (let ((calc-rsf-old rsf-old) + (calc-rsf-new (calc-encase-atoms rsf-new)))) (calc-replace-sub-formula-rec expr)) (defun calc-replace-sub-formula-rec (expr) @@ -671,7 +673,7 @@ (entry (calc-top num 'entry)) (expr (car entry)) (sel (or (calc-auto-selection entry) expr)) - alg) + ) ;; alg (let ((str (math-showing-full-precision (math-format-nice-expr sel (frame-width))))) (calc-edit-mode (list 'calc-finish-selection-edit diff --git a/lisp/calc/calc-stat.el b/lisp/calc/calc-stat.el index 09d3ce921c4..196f743fc1a 100644 --- a/lisp/calc/calc-stat.el +++ b/lisp/calc/calc-stat.el @@ -1,4 +1,4 @@ -;;; calc-stat.el --- statistical functions for Calc +;;; calc-stat.el --- statistical functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-store.el b/lisp/calc/calc-store.el index 79e6cf5c00c..a1e385cb406 100644 --- a/lisp/calc/calc-store.el +++ b/lisp/calc/calc-store.el @@ -1,4 +1,4 @@ -;;; calc-store.el --- value storage functions for Calc +;;; calc-store.el --- value storage functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -184,10 +184,11 @@ (defvar calc-read-var-name-history nil "History for reading variable names.") -(defun calc-read-var-name (prompt &optional calc-store-opers) +(defun calc-read-var-name (prompt &optional store-opers) (setq calc-given-value nil calc-aborted-prefix nil) - (let ((var (concat + (let* ((calc-store-opers store-opers) + (var (concat "var-" (let ((minibuffer-completion-table (mapcar (lambda (x) (substring x 4)) @@ -504,7 +505,7 @@ (calc-wrapper (or var (setq var (calc-read-var-name "Declare: " 0))) (or var (setq var 'var-All)) - (let* (dp decl def row rp) + (let* (dp decl row rp) ;; def (or (and (calc-var-value 'var-Decls) (eq (car-safe var-Decls) 'vec)) (setq var-Decls (list 'vec))) diff --git a/lisp/calc/calc-stuff.el b/lisp/calc/calc-stuff.el index bbd61a2c4a8..58b81faee50 100644 --- a/lisp/calc/calc-stuff.el +++ b/lisp/calc/calc-stuff.el @@ -1,4 +1,4 @@ -;;; calc-stuff.el --- miscellaneous functions for Calc +;;; calc-stuff.el --- miscellaneous functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-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. (defvar math-moc-func) -(defun math-map-over-constants (math-moc-func expr) - (math-map-over-constants-rec expr)) +(defun math-map-over-constants (moc-func expr) + (let ((math-moc-func moc-func)) + (math-map-over-constants-rec expr))) (defun math-map-over-constants-rec (expr) (cond ((or (Math-primp expr) diff --git a/lisp/calc/calc-trail.el b/lisp/calc/calc-trail.el index 9f289f21b00..de7205ee3ca 100644 --- a/lisp/calc/calc-trail.el +++ b/lisp/calc/calc-trail.el @@ -1,4 +1,4 @@ -;;; calc-trail.el --- functions for manipulating the Calc "trail" +;;; calc-trail.el --- functions for manipulating the Calc "trail" -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-undo.el b/lisp/calc/calc-undo.el index 92682baa87a..47971e8ab0d 100644 --- a/lisp/calc/calc-undo.el +++ b/lisp/calc/calc-undo.el @@ -1,4 +1,4 @@ -;;; calc-undo.el --- undo functions for Calc +;;; calc-undo.el --- undo functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/calc/calc-vec.el b/lisp/calc/calc-vec.el index 6850ded717b..875414595cf 100644 --- a/lisp/calc/calc-vec.el +++ b/lisp/calc/calc-vec.el @@ -1,4 +1,4 @@ -;;; calc-vec.el --- vector functions for Calc +;;; calc-vec.el --- vector functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -1111,18 +1111,20 @@ ;; by calcFunc-grade and calcFunc-rgrade. (defvar math-grade-vec) -(defun calcFunc-grade (math-grade-vec) - (if (math-vectorp math-grade-vec) - (let* ((len (1- (length math-grade-vec)))) - (cons 'vec (sort (cdr (calcFunc-index len)) 'math-grade-beforep))) - (math-reject-arg math-grade-vec 'vectorp))) - -(defun calcFunc-rgrade (math-grade-vec) - (if (math-vectorp math-grade-vec) - (let* ((len (1- (length math-grade-vec)))) +(defun calcFunc-grade (grade-vec) + (if (math-vectorp grade-vec) + (let* ((math-grade-vec grade-vec) + (len (1- (length grade-vec)))) + (cons 'vec (sort (cdr (calcFunc-index len)) #'math-grade-beforep))) + (math-reject-arg grade-vec #'vectorp))) + +(defun calcFunc-rgrade (grade-vec) + (if (math-vectorp grade-vec) + (let* ((math-grade-vec grade-vec) + (len (1- (length grade-vec)))) (cons 'vec (nreverse (sort (cdr (calcFunc-index len)) - 'math-grade-beforep)))) - (math-reject-arg math-grade-vec 'vectorp))) + #'math-grade-beforep)))) + (math-reject-arg grade-vec #'vectorp))) (defun math-grade-beforep (i j) (math-beforep (nth i math-grade-vec) (nth j math-grade-vec))) @@ -1556,7 +1558,8 @@ of two matrices is a matrix." (defvar math-exp-keep-spaces) (defvar math-expr-data) -(defun math-read-brackets (space-sep math-rb-close) +(defun math-read-brackets (space-sep rb-close) + (let ((math-rb-close rb-close)) (and space-sep (setq space-sep (not (math-check-for-commas)))) (math-read-token) (while (eq math-exp-token 'space) @@ -1624,7 +1627,7 @@ of two matrices is a matrix." (throw 'syntax "Expected `]'"))) (or (eq math-exp-token 'end) (math-read-token)) - vals))) + vals)))) (defun math-check-for-commas (&optional balancing) (let ((count 0) diff --git a/lisp/calc/calc-yank.el b/lisp/calc/calc-yank.el index 690aaf2687f..e03c00243c4 100644 --- a/lisp/calc/calc-yank.el +++ b/lisp/calc/calc-yank.el @@ -1,4 +1,4 @@ -;;; calc-yank.el --- kill-ring functionality for Calc +;;; calc-yank.el --- kill-ring functionality for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -401,7 +401,7 @@ Interactively, reads the register using `register-read-with-preview'." (let* ((from-buffer (current-buffer)) (calc-was-started (get-buffer-window "*Calculator*")) (single nil) - data vals pos) + data vals) ;; pos (if arg (if (consp arg) (setq single t) @@ -776,7 +776,7 @@ To cancel the edit, simply kill the *Calc Edit* buffer." (error "Original calculator buffer has been corrupted"))) (goto-char calc-edit-top) (if (buffer-modified-p) - (eval calc-edit-handler)) + (eval calc-edit-handler t)) (if (and one-window (not (one-window-p t))) (delete-window)) (if (get-buffer-window return) diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index bf8b006d7c6..bde7bd4e2bd 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -2313,7 +2313,7 @@ the United States." ((eq last-command-event ?@) "0@ ") (t (char-to-string last-command-event)))) -(defvar calc-buffer) +(defvar calc-buffer nil) (defvar calc-prev-char) (defvar calc-prev-prev-char) (defvar calc-digit-value) @@ -2353,7 +2353,7 @@ the United States." (defun calcDigit-nondigit () (interactive) ;; Exercise for the reader: Figure out why this is a good precaution! - (or (boundp 'calc-buffer) + (or calc-buffer (use-local-map minibuffer-local-map)) (let ((str (minibuffer-contents))) (setq calc-digit-value (with-current-buffer calc-buffer diff --git a/lisp/calc/calcalg2.el b/lisp/calc/calcalg2.el index bcfa77dad94..99d0549ca88 100644 --- a/lisp/calc/calcalg2.el +++ b/lisp/calc/calcalg2.el @@ -1,4 +1,4 @@ -;;; calcalg2.el --- more algebraic functions for Calc +;;; calcalg2.el --- more algebraic functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -333,8 +333,10 @@ (setq n (1+ n))) accum)))))) -(defun calcFunc-deriv (expr math-deriv-var &optional deriv-value math-deriv-symb) - (let* ((math-deriv-total nil) +(defun calcFunc-deriv (expr deriv-var &optional deriv-value deriv-symb) + (let* ((math-deriv-var deriv-var) + (math-deriv-symb deriv-symb) + (math-deriv-total nil) (res (catch 'math-deriv (math-derivative expr)))) (or (eq (car-safe res) 'calcFunc-deriv) (null res) @@ -344,9 +346,11 @@ (math-expr-subst res math-deriv-var deriv-value) res)))) -(defun calcFunc-tderiv (expr math-deriv-var &optional deriv-value math-deriv-symb) +(defun calcFunc-tderiv (expr deriv-var &optional deriv-value deriv-symb) (math-setup-declarations) - (let* ((math-deriv-total t) + (let* ((math-deriv-var deriv-var) + (math-deriv-symb deriv-symb) + (math-deriv-total t) (res (catch 'math-deriv (math-derivative expr)))) (or (eq (car-safe res) 'calcFunc-tderiv) (null res) @@ -363,10 +367,10 @@ (function (lambda (u) (math-div 1 (math-mul 2 (list 'calcFunc-sqrt u)))))) (put 'calcFunc-deg\' 'math-derivative-1 - (function (lambda (u) (math-div-float '(float 18 1) (math-pi))))) + (function (lambda (_) (math-div-float '(float 18 1) (math-pi))))) (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 (function (lambda (u) (math-div 1 u)))) @@ -1079,8 +1083,9 @@ ;; math-integ-try-substitutions. (defvar math-integ-expr) -(defun math-do-integral-methods (math-integ-expr) - (let ((math-so-far math-integ-var-list-list) +(defun math-do-integral-methods (integ-expr) + (let ((math-integ-expr integ-expr) + (math-so-far math-integ-var-list-list) rat-in) ;; Integration by substitution, for various likely sub-expressions. @@ -1195,10 +1200,11 @@ (defvar math-good-parts) -(defun math-integ-try-parts (expr &optional math-good-parts) +(defun math-integ-try-parts (expr &optional good-parts) ;; Integration by parts: ;; integ(f(x) g(x),x) = f(x) h(x) - integ(h(x) f'(x),x) ;; where h(x) = integ(g(x),x). + (let ((math-good-parts good-parts)) (or (let ((exp (calcFunc-expand expr))) (and (not (equal exp expr)) (math-integral exp))) @@ -1219,14 +1225,14 @@ (and (eq (car expr) '^) (math-integrate-by-parts (math-pow (nth 1 expr) (math-sub (nth 2 expr) 1)) - (nth 1 expr))))) + (nth 1 expr)))))) (defun math-integrate-by-parts (u vprime) (let ((math-integ-level (if (or math-good-parts (math-polynomial-p u math-integ-var)) math-integ-level (1- math-integ-level))) - (math-doing-parts t) + ;; (math-doing-parts t) ;Unused v temp) (and (>= math-integ-level 0) (unwind-protect @@ -1532,7 +1538,7 @@ (math-any-substs t) (math-enable-subst nil) (math-prev-parts-v nil) - (math-doing-parts nil) + ;; (math-doing-parts nil) ;Unused (math-good-parts nil) (res (if trace-buffer @@ -1883,7 +1889,10 @@ (defvar calc-high) (defvar math-var) -(defun calcFunc-table (expr math-var &optional calc-low calc-high step) +(defun calcFunc-table (expr var &optional low high step) + (let ((math-var var) + (calc-high high) + (calc-low low)) (or calc-low (setq calc-low '(neg (var inf var-inf)) calc-high '(var inf var-inf))) (or calc-high (setq calc-high calc-low calc-low 1)) @@ -1894,8 +1903,7 @@ (let ((known (+ (if (Math-objectp calc-low) 1 0) (if (Math-objectp calc-high) 1 0) (if (or (null step) (Math-objectp step)) 1 0))) - (count '(var inf var-inf)) - vec) + (count '(var inf var-inf))) ;; vec (or (= known 2) ; handy optimization (equal calc-high '(var inf var-inf)) (progn @@ -1906,6 +1914,7 @@ (setq count (math-trunc count))))) (if (Math-negp count) (setq count -1)) + (defvar var-DUMMY) (if (integerp count) (let ((var-DUMMY nil) (vec math-tabulate-initial) @@ -1939,7 +1948,7 @@ (and (not (and (equal calc-low '(neg (var inf var-inf))) (equal calc-high '(var inf var-inf)))) (list calc-low calc-high)) - (and step (list step)))))) + (and step (list step))))))) (defun math-scan-for-limits (x) (cond ((Math-primp x)) @@ -1951,8 +1960,10 @@ (high-val (math-solve-for (nth 2 x) (1- (length (nth 1 x))) math-var nil)) temp) - (and low-val (math-realp low-val) - high-val (math-realp high-val)) + ;; FIXME: The below is a no-op, but I suspect its result + ;; was meant to be used, tho I don't know what for. + ;; (and low-val (math-realp low-val) + ;; high-val (math-realp high-val)) (and (Math-lessp high-val low-val) (setq temp low-val low-val high-val high-val temp)) (setq calc-low (math-max calc-low (math-ceiling low-val)) @@ -2361,8 +2372,11 @@ (defvar math-try-solve-sign) (defun math-try-solve-for - (math-solve-lhs math-solve-rhs &optional math-try-solve-sign no-poly) - (let (math-t1 math-t2 math-t3) + (solve-lhs solve-rhs &optional try-solve-sign no-poly) + (let ((math-solve-lhs solve-lhs) + (math-solve-rhs solve-rhs) + (math-try-solve-sign try-solve-sign) + math-t1 math-t2 math-t3) (cond ((equal math-solve-lhs math-solve-var) (setq math-solve-sign math-try-solve-sign) (if (eq math-solve-full 'all) @@ -2721,14 +2735,17 @@ (cons 'vec d) (math-reject-arg expr "Expected a polynomial")))) -(defun math-decompose-poly (math-solve-lhs math-solve-var degree sub-rhs) - (let ((math-solve-rhs (or sub-rhs 1)) +(defun math-decompose-poly (solve-lhs solve-var degree sub-rhs) + (let ((math-solve-lhs solve-lhs) + (math-solve-var solve-var) + (math-solve-rhs (or sub-rhs 1)) math-t1 math-t2 math-t3) (setq math-t2 (math-polynomial-base math-solve-lhs (function - (lambda (math-solve-b) - (let ((math-poly-neg-powers '(1)) + (lambda (solve-b) + (let ((math-solve-b solve-b) + (math-poly-neg-powers '(1)) (math-poly-mult-powers nil) (math-poly-frac-powers 1) (math-poly-exp-base t)) @@ -2964,7 +2981,7 @@ (math-poly-integer-root (car roots)) (setq roots (cdr roots))) (list math-int-factors (nreverse math-int-coefs) math-int-scale)) - (let ((vec nil) res) + (let ((vec nil)) ;; res (while roots (let ((root (car roots)) (math-solve-full (and math-solve-full 'all))) @@ -3109,7 +3126,7 @@ (iters 0) (m (1- (length p))) (try-newt (not polish)) - (tried-newt nil) + ;; (tried-newt nil) b d f x1 dx dxold) (while (and (or (< (setq iters (1+ iters)) 50) @@ -3146,7 +3163,7 @@ (math-lessp (math-abs-approx dx) (calcFunc-scf (math-abs-approx x) -3))) (let ((newt (math-poly-newton-root p x1 7))) - (setq tried-newt t + (setq ;; tried-newt t try-newt nil) (if (math-zerop (cdr newt)) (setq x (car newt) x1 x) @@ -3160,7 +3177,8 @@ (math-nearly-equal x x1)))) (let ((cdx (math-abs-approx dx))) (setq x x1 - tried-newt nil) + ;; tried-newt nil + ) (prog1 (or (<= iters 6) (math-lessp cdx dxold) @@ -3227,7 +3245,9 @@ ;; and math-solve-system-rec, but is used by math-solve-system-subst. (defvar math-solve-simplifying) -(defun math-solve-system (exprs math-solve-vars math-solve-full) +(defun math-solve-system (exprs solve-vars solve-full) + (let ((math-solve-vars solve-vars) + (math-solve-full solve-full)) (setq exprs (mapcar 'list (if (Math-vectorp exprs) (cdr exprs) (list exprs))) @@ -3237,7 +3257,7 @@ (or (let ((math-solve-simplifying nil)) (math-solve-system-rec exprs math-solve-vars nil)) (let ((math-solve-simplifying t)) - (math-solve-system-rec exprs math-solve-vars nil)))) + (math-solve-system-rec exprs math-solve-vars nil))))) ;;; The following backtracking solver works by choosing a variable ;;; and equation, and trying to solve the equation for the variable. @@ -3437,10 +3457,12 @@ (if (memq (car expr) '(* /)) (math-looks-evenp (nth 1 expr))))) -(defun math-solve-for (lhs rhs math-solve-var math-solve-full &optional sign) - (if (math-expr-contains rhs math-solve-var) - (math-solve-for (math-sub lhs rhs) 0 math-solve-var math-solve-full) - (and (math-expr-contains lhs math-solve-var) +(defun math-solve-for (lhs rhs solve-var solve-full &optional sign) + (let ((math-solve-var solve-var) + (math-solve-full solve-full)) + (if (math-expr-contains rhs solve-var) + (math-solve-for (math-sub lhs rhs) 0 solve-var solve-full) + (and (math-expr-contains lhs solve-var) (math-with-extra-prec 1 (let* ((math-poly-base-variable math-solve-var) (res (math-try-solve-for lhs rhs sign))) @@ -3462,7 +3484,7 @@ (format "*Omitted %d complex solutions" (- old-len new-len))))))) - res))))) + res)))))) (defun math-solve-eqn (expr var full) (if (memq (car-safe expr) '(calcFunc-neq calcFunc-lt calcFunc-gt diff --git a/lisp/calc/calcalg3.el b/lisp/calc/calcalg3.el index 2d38c9c45bc..f1f67211b84 100644 --- a/lisp/calc/calcalg3.el +++ b/lisp/calc/calcalg3.el @@ -1,4 +1,4 @@ -;;; calcalg3.el --- more algebraic functions for Calc +;;; calcalg3.el --- more algebraic functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -120,18 +120,24 @@ (defvar calc-curve-fit-history nil "History for calc-curve-fit.") -(defun calc-curve-fit (arg &optional calc-curve-model - calc-curve-coefnames calc-curve-varnames) +(defvar calc-graph-no-auto-view) +(defvar calc-fit-to-trail nil) + +(defun calc-curve-fit (arg &optional curve-model + curve-coefnames curve-varnames) (interactive "P") (calc-slow-wrapper (setq calc-aborted-prefix nil) - (let ((func (if (calc-is-inverse) 'calcFunc-xfit + (let ((calc-curve-model curve-model) + (calc-curve-coefnames curve-coefnames) + (calc-curve-varnames curve-varnames) + (func (if (calc-is-inverse) 'calcFunc-xfit (if (calc-is-hyperbolic) 'calcFunc-efit 'calcFunc-fit))) key (which 0) (nonlinear nil) (plot nil) - n calc-curve-nvars temp data + n calc-curve-nvars data ;; temp (homog nil) (msgs '( "(Press ? for help)" "1 = linear or multilinear" @@ -321,7 +327,7 @@ (calc-get-fit-variables 1 (1- (length calc-curve-coefnames)) (and homog 1))) ((memq key '(?\$ ?\' ?u ?U)) - (let* ((defvars nil) + (let* (;; (defvars nil) (record-entry nil)) (if (eq key ?\') (let* ((calc-dollar-values calc-arg-values) @@ -708,7 +714,7 @@ "*Unable to find a sign change in this interval")))) ;;; "rtbis" (but we should be using Brent's method) -(defun math-bisect-root (expr low vlow high vhigh) +(defun math-bisect-root (expr low _vlow high vhigh) (let ((step (math-sub-float high low)) (pos (Math-posp vhigh)) var-DUMMY @@ -726,7 +732,8 @@ (setq high mid vhigh vmid) (setq low mid - vlow vmid))) + ;; vlow vmid + ))) (list 'vec mid vmid))) ;;; "mnewt" @@ -758,7 +765,8 @@ (list 'vec next expr-val)))) -(defun math-find-root (expr var guess math-root-widen) +(defun math-find-root (expr var guess root-widen) + (let ((math-root-widen root-widen)) (if (eq (car-safe expr) 'vec) (let ((n (1- (length expr))) (calc-symbolic-mode nil) @@ -871,7 +879,7 @@ (not (Math-numberp vlow)) (not (Math-numberp vhigh))) (math-search-root expr deriv low vlow high vhigh) - (math-bisect-root expr low vlow high vhigh)))))))))) + (math-bisect-root expr low vlow high vhigh))))))))))) (defun calcFunc-root (expr var guess) (math-find-root expr var guess nil)) @@ -1019,7 +1027,7 @@ math-min-or-max)))))) ;;; "brent" -(defun math-brent-min (expr prec a va x vx b vb) +(defun math-brent-min (expr prec a _va x vx b _vb) (let ((iters (+ 20 (* 5 prec))) (w x) (vw vx) @@ -1181,7 +1189,7 @@ (list 'calcFunc-mrow '(var line-p line-p) (1+ m))))) (math-evaluate-expr expr))) -(defun math-line-min (f1dim line-p line-xi n prec) +(defun math-line-min (f1dim line-p line-xi _n prec) (let* ((var-DUMMY nil) (expr (math-evaluate-expr f1dim)) (params (math-widen-min expr '(float 0 0) '(float 1 0))) @@ -1195,7 +1203,7 @@ (n 0) (var-DUMMY nil) (isvec (math-vectorp var)) - g guesses) + guesses) ;; g (or (math-vectorp var) (setq var (list 'vec var))) (or (math-vectorp guess) @@ -1493,7 +1501,8 @@ (defun math-ninteg-midpoint (expr lo hi mode) ; uses "math-ninteg-temp" (if (eq mode 'inf) - (let ((math-infinite-mode t) temp) + (let (;; (math-infinite-mode t) ;Unused! + temp) (setq temp (math-div 1 lo) lo (math-div 1 hi) hi temp))) @@ -1547,7 +1556,6 @@ (setq math-dummy-counter (1+ math-dummy-counter)))) (defvar math-in-fit 0) -(defvar calc-fit-to-trail nil) (defun calcFunc-fit (expr vars &optional coefs data) (let ((math-in-fit 10)) @@ -1573,6 +1581,7 @@ (defvar math-fit-new-coefs) (defun math-general-fit (expr vars coefs data mode) + (defvar var-YVAL) (defvar var-YVALX) (let ((calc-simplify-mode nil) (math-dummy-counter math-dummy-counter) (math-in-fit 1) @@ -1591,7 +1600,7 @@ (weights nil) (var-YVAL nil) (var-YVALX nil) covar beta - n nn m mm v dummy p) + n m mm v dummy p) ;; nn ;; Validate and parse arguments. (or data @@ -1687,7 +1696,7 @@ (isigsq 1) (xvals (make-vector mm 0)) (i 0) - j k xval yval sigmasqr wt covj covjk covk betaj lud) + j k xval yval sigmasqr wt covj covjk covk betaj) ;; lud (while (<= (setq i (1+ i)) n) ;; Assign various independent variables for this data point. diff --git a/lisp/calc/calcsel2.el b/lisp/calc/calcsel2.el index c8a714900dc..faec2309394 100644 --- a/lisp/calc/calcsel2.el +++ b/lisp/calc/calcsel2.el @@ -1,4 +1,4 @@ -;;; calcsel2.el --- selection functions for Calc +;;; calcsel2.el --- selection functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index da98e44926e..fbc13f59b2a 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el @@ -1092,7 +1092,9 @@ This is an option for `diary-display-function'." (if (calendar-date-equal date (car h)) (setq date-holiday-list (append date-holiday-list (cdr h))))) - (insert (if (bobp) "" ?\n) (calendar-date-string date)) + (insert (if (bobp) "" ?\n) + (propertize (calendar-date-string date) + 'font-lock-face 'diary)) (if date-holiday-list (insert ": ")) (setq cc (current-column)) (insert (mapconcat (lambda (x) @@ -1100,7 +1102,10 @@ This is an option for `diary-display-function'." x) date-holiday-list (concat "\n" (make-string cc ?\s)))) - (insert ?\n (make-string (+ cc longest) ?=) ?\n))) + (insert ?\n + (propertize (make-string (+ cc longest) ?=) + 'font-lock-face 'diary) + ?\n))) (let ((this-entry (cadr entry)) this-loc marks temp-face) (unless (zerop (length this-entry)) @@ -2394,6 +2399,7 @@ return a font-lock pattern matching array of MONTHS and marking SYMBOL." (defun diary-fancy-date-pattern () "Return a regexp matching the first line of a fancy diary date header. This depends on the calendar date style." + (declare (obsolete nil "28.1")) (concat (calendar-dlet* ((dayname (diary-name-pattern calendar-day-name-array nil t)) @@ -2414,15 +2420,17 @@ This depends on the calendar date style." (defun diary-fancy-date-matcher (limit) "Search for a fancy diary data header, up to LIMIT." + (declare (obsolete nil "28.1")) ;; Any number of " other holiday name" lines, followed by "==" line. - (when (re-search-forward - (format "%s\\(\n +.*\\)*\n=+$" (diary-fancy-date-pattern)) limit t) - (put-text-property (match-beginning 0) (match-end 0) 'font-lock-multiline t) - t)) + (with-suppressed-warnings ((obsolete diary-fancy-date-pattern)) + (when (re-search-forward + (format "%s\\(\n +.*\\)*\n=+$" (diary-fancy-date-pattern)) limit t) + (put-text-property (match-beginning 0) (match-end 0) + 'font-lock-multiline t) + t))) (defvar diary-fancy-font-lock-keywords - `((diary-fancy-date-matcher . 'diary) - ("^.*\\([aA]nniversary\\|[bB]irthday\\).*$" . 'diary-anniversary) + `(("^.*\\([aA]nniversary\\|[bB]irthday\\).*$" . 'diary-anniversary) ("^.*Yahrzeit.*$" . font-lock-constant-face) ("^\\(Erev \\)?Rosh Hodesh.*" . font-lock-function-name-face) ("^Day.*omer.*$" . font-lock-builtin-face) @@ -2443,9 +2451,6 @@ Fontify the region between BEG and END, quietly unless VERBOSE is non-nil." (if (looking-at "=+$") (forward-line -1)) (while (and (looking-at " +[^ ]") (zerop (forward-line -1)))) - ;; This check not essential. - (if (looking-at (diary-fancy-date-pattern)) - (setq beg (line-beginning-position))) (goto-char end) (forward-line 0) (while (and (looking-at " +[^ ]") diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 9c5d89f89ff..3c937534958 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -4681,15 +4681,12 @@ This function does not save the buffer." (setq pos (line-beginning-position)))) (goto-char pos))))) -(defvar sort-fold-case) ; defined in sort.el - (defun custom-save-variables () "Save all customized variables in `custom-file'." (save-excursion (custom-save-delete 'custom-set-variables) (let ((standard-output (current-buffer)) - (saved-list (make-list 1 0)) - sort-fold-case) + (saved-list (make-list 1 0))) ;; First create a sorted list of saved variables. (mapatoms (lambda (symbol) @@ -4771,8 +4768,7 @@ This function does not save the buffer." (custom-save-delete 'custom-reset-faces) (custom-save-delete 'custom-set-faces) (let ((standard-output (current-buffer)) - (saved-list (make-list 1 0)) - sort-fold-case) + (saved-list (make-list 1 0))) ;; First create a sorted list of saved faces. (mapatoms (lambda (symbol) diff --git a/lisp/dired-x.el b/lisp/dired-x.el index b09ef900c1d..55077e71882 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -1483,7 +1483,9 @@ a prefix argument, when it offers the filename near point as a default." ;;; Internal functions. ;; Fixme: This should probably use `thing-at-point'. -- fx -(defun dired-filename-at-point () +(define-obsolete-function-alias 'dired-filename-at-point + #'dired-x-guess-file-name-at-point "28.1") +(defun dired-x-guess-file-name-at-point () "Return the filename closest to point, expanded. Point should be in or after a filename." (save-excursion @@ -1517,7 +1519,7 @@ Point should be in or after a filename." "Return filename prompting with PROMPT with completion. If `current-prefix-arg' is non-nil, uses name at point as guess." (if current-prefix-arg - (let ((guess (dired-filename-at-point))) + (let ((guess (dired-x-guess-file-name-at-point))) (read-file-name prompt (file-name-directory guess) guess diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index fdc1233540e..8c1e5b227a6 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -137,6 +137,10 @@ appear in DOC, a paragraph is added to DOC explaining usage of the mode argument. Optional INIT-VALUE is the initial value of the mode's variable. + Note that the minor mode function won't be called by setting + this option, so the value *reflects* the minor mode's natural + initial state, rather than *setting* it. + In the vast majority of cases it should be nil. Optional LIGHTER is displayed in the mode line when the mode is on. Optional KEYMAP is the default keymap bound to the mode keymap. If non-nil, it should be a variable name (whose value is a keymap), diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index c0125e64727..724e89df1e4 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2640,8 +2640,7 @@ Used for the `action' property of buttons in the buffer created by (when (y-or-n-p (format-message "Install package `%s'? " (package-desc-full-name pkg-desc))) (package-install pkg-desc nil) - (revert-buffer nil t) - (goto-char (point-min))))) + (describe-package (package-desc-name pkg-desc))))) (defun package-delete-button-action (button) "Run `package-delete' on the package BUTTON points to. @@ -2651,8 +2650,7 @@ Used for the `action' property of buttons in the buffer created by (when (y-or-n-p (format-message "Delete package `%s'? " (package-desc-full-name pkg-desc))) (package-delete pkg-desc) - (revert-buffer nil t) - (goto-char (point-min))))) + (describe-package (package-desc-name pkg-desc))))) (defun package-keyword-button-action (button) "Show filtered \"*Packages*\" buffer for BUTTON. diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el new file mode 100644 index 00000000000..f6309c7652e --- /dev/null +++ b/lisp/emacs-lisp/shortdoc.el @@ -0,0 +1,1106 @@ +;;; shortdoc.el --- Short function summaries -*- lexical-binding: t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Keywords: lisp, help +;; Package: emacs + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'macroexp) +(require 'seq) +(eval-when-compile (require 'cl-lib)) + +(defgroup shortdoc nil + "Short documentation." + :group 'lisp) + +(defface shortdoc-section + '((((class color) (background dark)) + (:inherit variable-pitch + :background "#303030" :extend t)) + (((class color) (background light)) + (:inherit variable-pitch + :background "#f0f0f0" :extend t))) + "Face used for a section.") + +(defface shortdoc-example + '((((class color) (background dark)) + (:background "#202020" :extend t)) + (((class color) (background light)) + (:background "#e8e8e8" :extend t))) + "Face used for examples.") + +(defvar shortdoc--groups nil) + +(defmacro define-short-documentation-group (group &rest functions) + "Add GROUP to the list of defined documentation groups. +FUNCTIONS is a list of elements on the form: + + (fun + :no-manual BOOL + :args ARGS + :eval EXAMPLE-FORM + :no-eval EXAMPLE-FORM + :no-value EXAMPLE-FORM + :result RESULT-FORM + :eg-result RESULT-FORM + :eg-result-string RESULT-FORM) + +BOOL should be non-nil if the function isn't documented in the +manual. + +ARGS is optional; the function's signature is displayed if ARGS +is not present. + +If EVAL isn't a string, it will be printed with `prin1', and then +evaluated to give a result, which is also printed. If it's a +string, it'll be inserted as is, then the string will be `read', +and then evaluated. + +There can be any number of :example/:result elements." + `(progn + (setq shortdoc--groups (delq (assq ',group shortdoc--groups) + shortdoc--groups)) + (push (cons ',group ',functions) shortdoc--groups))) + +(define-short-documentation-group string + "Making Strings" + (make-string + :args (length init) + :eval "(make-string 5 ?x)") + (string + :eval "(string ?a ?b ?c)") + (concat + :eval (concat "foo" "bar" "zot")) + (string-join + :no-manual t + :eval (string-join '("foo" "bar" "zot") " ")) + (mapconcat + :eval (mapconcat (lambda (a) (concat "[" a "]")) + '("foo" "bar" "zot") " ")) + (mapcar + :eval (mapcar #'identity "123")) + (format + :eval (format "This number is %d" 4)) + "Manipulating Strings" + (substring + :eval (substring "foobar" 0 3) + :eval (substring "foobar" 3)) + (split-string + :eval (split-string "foo bar") + :eval (split-string "|foo|bar|" "|") + :eval (split-string "|foo|bar|" "|" t)) + (string-replace + :eval (string-replace "foo" "bar" "foozot")) + (replace-regexp-in-string + :eval (replace-regexp-in-string "[a-z]+" "_" "*foo*")) + (string-trim + :no-manual t + :args (string) + :doc "Trim STRING of leading and trailing white space." + :eval (string-trim " foo ")) + (string-trim-left + :no-manual t + :eval (string-trim-left "oofoo" "o+")) + (string-trim-right + :no-manual t + :eval (string-trim-right "barkss" "s+")) + (string-truncate-left + :no-manual t + :eval (string-truncate-left "longstring" 8)) + (string-remove-suffix + :no-manual t + :eval (string-remove-suffix "bar" "foobar")) + (string-remove-prefix + :no-manual t + :eval (string-remove-prefix "foo" "foobar")) + (reverse + :eval (reverse "foo")) + (substring-no-properties + :eval (substring-no-properties (propertize "foobar" 'face 'bold) 0 3)) + "Predicates for Strings" + (string-equal + :eval (string-equal "foo" "foo")) + (eq + :eval (eq "foo" "foo")) + (eql + :eval (eql "foo" "foo")) + (equal + :eval (equal "foo" "foo")) + (cl-equalp + :eval (cl-equalp "Foo" "foo")) + (stringp + :eval "(stringp ?a)") + (string-empty-p + :no-manual t + :eval (string-empty-p "")) + (string-blank-p + :no-manual t + :eval (string-blank-p " \n")) + (string-lessp + :eval (string-lessp "foo" "bar")) + (string-greaterp + :eval (string-greaterp "foo" "bar")) + (string-version-lessp + :eval (string-lessp "foo32.png" "bar4.png")) + (string-prefix-p + :eval (string-prefix-p "foo" "foobar")) + (string-suffix-p + :eval (string-suffix-p "bar" "foobar")) + "Case Manipulation" + (upcase + :eval (upcase "foo")) + (downcase + :eval (downcase "FOObar")) + (capitalize + :eval (capitalize "foo bar zot")) + (upcase-initials + :eval (upcase-initials "The CAT in the hAt")) + "Converting Strings" + (string-to-number + :eval (string-to-number "42") + :eval (string-to-number "deadbeef" 16)) + (number-to-string + :eval (number-to-string 42)) + "Data About Strings" + (length + :eval (length "foo")) + (string-search + :eval (string-search "bar" "foobarzot")) + (assoc-string + :eval (assoc-string "foo" '(("a" 1) (foo 2)))) + (seq-position + :eval "(seq-position \"foobarzot\" ?z)")) + +(define-short-documentation-group file-name + "File Name Manipulation" + (file-name-directory + :eval (file-name-directory "/tmp/foo") + :eval (file-name-directory "/tmp/foo/")) + (file-name-nondirectory + :eval (file-name-nondirectory "/tmp/foo") + :eval (file-name-nondirectory "/tmp/foo/")) + (file-name-sans-versions + :args (filename) + :eval (file-name-sans-versions "/tmp/foo~")) + (file-name-extension + :eval (file-name-extension "/tmp/foo.txt")) + (file-name-sans-extension + :eval (file-name-sans-extension "/tmp/foo.txt")) + (file-name-base + :eval (file-name-base "/tmp/foo.txt")) + (file-relative-name + :eval (file-relative-name "/tmp/foo" "/tmp")) + (make-temp-name + :eval (make-temp-name "/tmp/foo-")) + (expand-file-name + :eval (expand-file-name "foo" "/tmp/")) + (substitute-in-file-name + :eval (substitute-in-file-name "$HOME/foo")) + "Directory Functions" + (file-name-as-directory + :eval (file-name-as-directory "/tmp/foo")) + (directory-file-name + :eval (directory-file-name "/tmp/foo/")) + (abbreviate-file-name + :no-eval (abbreviate-file-name "/home/some-user") + :eg-result "~some-user") + "Quoted File Names" + (file-name-quote + :args (name) + :eval (file-name-quote "/tmp/foo")) + (file-name-unquote + :args (name) + :eval (file-name-unquote "/:/tmp/foo")) + "Predicates" + (file-name-absolute-p + :eval (file-name-absolute-p "/tmp/foo") + :eval (file-name-absolute-p "foo")) + (directory-name-p + :eval (directory-name-p "/tmp/foo/")) + (file-name-quoted-p + :eval (file-name-quoted-p "/:/tmp/foo"))) + +(define-short-documentation-group file + "Inserting Contents" + (insert-file-contents + :no-eval (insert-file-contents "/tmp/foo") + :eg-result ("/tmp/foo" 6)) + (insert-file-contents-literally + :no-eval (insert-file-contents-literally "/tmp/foo") + :eg-result ("/tmp/foo" 6)) + (find-file + :no-eval (find-file "/tmp/foo") + :eg-result-string "#<buffer foo>") + "Predicates" + (file-symlink-p + :no-eval (file-symlink-p "/tmp/foo") + :eg-result t) + (file-directory-p + :no-eval (file-directory-p "/tmp") + :eg-result t) + (file-regular-p + :no-eval (file-regular-p "/tmp/foo") + :eg-result t) + (file-exists-p + :no-eval (file-exists-p "/tmp/foo") + :eg-result t) + (file-readable-p + :no-eval (file-readable-p "/tmp/foo") + :eg-result t) + (file-writeable-p + :no-eval (file-writeable-p "/tmp/foo") + :eg-result t) + (file-accessible-directory-p + :no-eval (file-accessible-directory-p "/tmp") + :eg-result t) + (file-executable-p + :no-eval (file-executable-p "/bin/cat") + :eg-result t) + (file-newer-than-file-p + :no-eval (file-newer-than-file-p "/tmp/foo" "/tmp/bar") + :eg-result nil) + (file-equal-p + :no-eval (file-equal-p "/tmp/foo" "/tmp/bar") + :eg-result nil) + (file-in-directory-p + :no-eval (file-in-directory-p "/tmp/foo" "/tmp/") + :eg-result t) + (file-locked-p + :no-eval (file-locked-p "/tmp/foo") + :eg-result nil) + "Information" + (file-attributes + :no-eval* (file-attributes "/tmp")) + (file-truename + :no-eval (file-truename "/tmp/foo/bar") + :eg-result "/tmp/foo/zot") + (file-chase-links + :no-eval (file-chase-links "/tmp/foo/bar") + :eg-result "/tmp/foo/zot") + (vc-responsible-backend + :args (file &optional no-error) + :no-eval (vc-responsible-backend "/src/foo/bar.c") + :eg-result Git) + (file-acl + :no-eval (file-acl "/tmp/foo") + :eg-result "user::rw-\ngroup::r--\nother::r--\n") + (file-extended-attributes + :no-eval* (file-extended-attributes "/tmp/foo")) + (file-selinux-context + :no-eval* (file-selinux-context "/tmp/foo")) + (locate-file + :no-eval (locate-file "syslog" '("/var/log" "/usr/bin")) + :eg-result "/var/log/syslog") + (executable-find + :no-eval (executable-find "ls") + :eg-result "/usr/bin/ls") + "Creating" + (make-temp-file + :no-eval (make-temp-file "/tmp/foo-") + :eg-result "/tmp/foo-ZcXFMj") + (make-nearby-temp-file + :no-eval (make-nearby-temp-file "/tmp/foo-") + :eg-result "/tmp/foo-xe8iON") + (write-region + :no-value (write-region (point-min) (point-max) "/tmp/foo")) + "Directories" + (make-directory + :no-value (make-directory "/tmp/bar/zot/" t)) + (directory-files + :no-eval (directory-files "/tmp/") + :eg-result ("." ".." ".ICE-unix" ".Test-unix")) + (directory-files-recursively + :no-eval (directory-files-recursively "/tmp/" "\\.png\\'") + :eg-result ("/tmp/foo.png" "/tmp/zot.png" "/tmp/bar/foobar.png")) + (directory-files-and-attributes + :no-eval* (directory-files-and-attributes "/tmp/foo")) + (file-expand-wildcards + :no-eval (file-expand-wildcards "/tmp/*.png") + :eg-result ("/tmp/foo.png" "/tmp/zot.png")) + (locate-dominating-file + :no-eval (locate-dominating-file "foo.png" "/tmp/foo/bar/zot") + :eg-result "/tmp/foo.png") + (copy-directory + :no-value (copy-directory "/tmp/bar/" "/tmp/barcopy")) + (delete-directory + :no-value (delete-directory "/tmp/bar/")) + "File Operations" + (rename-file + :no-value (rename-file "/tmp/foo" "/tmp/newname")) + (copy-file + :no-value (copy-file "/tmp/foo" "/tmp/foocopy")) + (delete-file + :no-value (delete-file "/tmp/foo")) + (make-empty-file + :no-value (make-empty-file "/tmp/foo")) + (make-symbolic-link + :no-value (make-symbolic-link "/tmp/foo" "/tmp/foosymlink")) + (add-name-to-file + :no-value (add-name-to-file "/tmp/foo" "/tmp/bar")) + (set-file-modes + :no-value "(set-file-modes \"/tmp/foo\" #o644)") + (set-file-times + :no-value (set-file-times "/tmp/foo" (current-time))) + "File Modes" + (set-default-file-modes + :no-value "(set-default-file-modes #o755)") + (default-file-modes + :no-eval (default-file-modes) + :eg-result-string "#o755") + (file-modes-symbolic-to-number + :no-eval (file-modes-symbolic-to-number "a+r") + :eg-result-string "#o444") + (file-modes-number-to-symbolic + :eval "(file-modes-number-to-symbolic #o444)") + (set-file-extended-attributes + :no-eval (set-file-extended-attributes + "/tmp/foo" '((acl . "group::rxx"))) + :eg-result t) + (set-file-selinux-context + :no-eval (set-file-selinux-context + "/tmp/foo" '(unconfined_u object_r user_home_t s0)) + :eg-result t) + (set-file-acl + :no-eval (set-file-acl "/tmp/foo" "group::rxx") + :eg-result t)) + + +(define-short-documentation-group list + "Making Lists" + (make-list + :eval (make-list 5 'a)) + (cons + :eval (cons 1 '(2 3 4))) + (list + :eval (list 1 2 3)) + (number-sequence + :eval (number-sequence 5 8)) + "Operations on Lists" + (append + :eval (append '("foo" "bar") '("zot"))) + (copy-tree + :eval (copy-tree '(1 (2 3) 4))) + (flatten-tree + :eval (flatten-tree '(1 (2 3) 4))) + (car + :eval (car '(one two three))) + (cdr + :eval (cdr '(one two three))) + (last + :eval (last '(one two three))) + (butlast + :eval (butlast '(one two three))) + (nbutlast + :eval (nbutlast (list 'one 'two 'three))) + (nth + :eval (nth 1 '(one two three))) + (nthcdr + :eval (nthcdr 1 '(one two three))) + (elt + :eval (elt '(one two three) 1)) + (car-safe + :eval (car-safe '(one two three))) + (cdr-safe + :eval (cdr-safe '(one two three))) + (push + :no-eval* (push 'a list)) + (pop + :no-eval* (pop list)) + (setcar + :no-eval (setcar list 'c) + :result c) + (setcdr + :no-eval (setcdr list (list c)) + :result '(c)) + (nconc + :eval (nconc (list 1) (list 2 3 4))) + (delq + :eval (delq 2 (list 1 2 3 4)) + :eval (delq "a" (list "a" "b" "c" "d"))) + (delete + :eval (delete 2 (list 1 2 3 4)) + :eval (delete "a" (list "a" "b" "c" "d"))) + (remove + :eval (remove 2 '(1 2 3 4)) + :eval (remove "a" '("a" "b" "c" "d"))) + (delete-dups + :eval (delete-dups (list 1 2 4 3 2 4))) + "Mapping Over Lists" + (mapcar + :eval (mapcar #'list '(1 2 3))) + (mapcan + :eval (mapcan #'list '(1 2 3))) + (mapc + :eval (mapc #'insert '("1" "2" "3"))) + (reduce + :eval (reduce #'+ '(1 2 3))) + (mapconcat + :eval (mapconcat #'identity '("foo" "bar") "|")) + "Predicates" + (listp + :eval (listp '(1 2 3)) + :eval (listp nil) + :eval (listp '(1 . 2))) + (consp + :eval (consp '(1 2 3)) + :eval (consp nil)) + (proper-list-p + :eval (proper-list-p '(1 2 3)) + :eval (proper-list-p nil) + :eval (proper-list-p '(1 . 2))) + (null + :eval (null nil)) + (atom + :eval (atom 'a)) + (nlistp + :eval (nlistp '(1 2 3)) + :eval (nlistp t) + :eval (nlistp '(1 . 2))) + "Finding Elements" + (memq + :eval (memq 2 '(1 2 3)) + :eval (memq 2.0 '(1.0 2.0 3.0)) + :eval (memq "b" '("a" "b" "c"))) + (member + :eval (member 2 '(1 2 3)) + :eval (member "b" '("a" "b" "c"))) + (remq + :eval (remq 2 '(1 2 3 2 4 2)) + :eval (remq "b" '("a" "b" "c"))) + (memql + :eval (memql 2.0 '(1.0 2.0 3.0))) + (member-ignore-case + :eval (member-ignore-case "foo" '("bar" "Foo" "zot"))) + "Association Lists" + (assoc + :eval (assoc 'b '((a 1) (b 2)))) + (rassoc + :eval (rassoc '2 '((a . 1) (b . 2)))) + (assq + :eval (assq 'b '((a 1) (b 2))) + :eval (assq "a" '(("a" 1) ("b" 2)))) + (rassq + :eval (rassq '2 '((a . 1) (b . 2)))) + (assoc-string + :eval (assoc-string "foo" '(("a" 1) (foo 2)))) + (alist-get + :eval (alist-get 2 '((1 . a) (2 . b)))) + (assoc-default + :eval (assoc-default 2 '((1 . a) (2 . b) #'=))) + (copy-alist + :eval (copy-alist '((1 . a) (2 . b)))) + (assq-delete-all + :eval (assq-delete-all 2 (list '(1 . a) '(2 . b) '(2 . c)))) + (assoc-delete-all + :eval (assoc-delete-all "b" (list '("a" . a) '("b" . b) '("b" . c)))) + "Property Lists" + (plist-get + :eval (plist-get '(a 1 b 2 c 3) 'b)) + (plist-put + :no-eval (setq plist (plist-put plist 'd 4)) + :eq-result (a 1 b 2 c 3 d 4)) + (lax-plist-get + :eval (lax-plist-get '("a" 1 "b" 2 "c" 3) "b")) + (lax-plist-put + :no-eval (setq plist (plist-put plist "d" 4)) + :eq-result '("a" 1 "b" 2 "c" 3 "d" 4)) + (plist-member + :eval (plist-member '(a 1 b 2 c 3) 'b)) + "Data About Lists" + (length + :eval (length '(a b c))) + (safe-length + :eval (safe-length '(a b c)))) + + +(define-short-documentation-group vector + (make-vector + :eval (make-vector 5 "foo")) + (vector + :eval (vector 1 "b" 3)) + (vectorp + :eval (vectorp [1]) + :eval (vectorp "1")) + (vconcat + :eval (vconcat '(1 2) [3 4])) + (append + :eval (append [1 2] nil)) + (length + :eval (length [1 2 3])) + (mapcar + :eval (mapcar #'identity [1 2 3])) + (reduce + :eval (reduce #'+ [1 2 3])) + (seq-subseq + :eval (seq-subseq [1 2 3 4 5] 1 3) + :eval (seq-subseq [1 2 3 4 5] 1))) + +(define-short-documentation-group regexp + "Matching Strings" + (replace-regexp-in-string + :eval (replace-regexp-in-string "[a-z]+" "_" "*foo*")) + (string-match-p + :eval (string-match-p "^[fo]+" "foobar")) + (match-string + :eval (and (string-match "^\\([fo]+\\)b" "foobar") + (match-string 0 "foobar"))) + (match-beginning + :no-eval (match-beginning 1) + :eg-result 0) + (match-end + :no-eval (match-end 1) + :eg-result 3) + "Looking in Buffers" + (re-search-forward + :no-eval (re-search-forward "^foo$" nil t) + :eg-result 43) + (re-search-backward + :no-eval (re-search-backward "^foo$" nil t) + :eg-result 43) + (looking-at-p + :no-eval (looking-at "f[0-9]") + :eg-result t) + "Utilities" + (regexp-quote + :eval (regexp-quote "foo.*bar")) + (regexp-opt + :eval (regexp-opt '("foo" "bar"))) + (regexp-opt-depth + :eval (regexp-opt-depth "\\(a\\(b\\)\\)")) + (regexp-opt-charset + :eval (regexp-opt-charset '(?a ?b ?c ?d ?e)))) + +(define-short-documentation-group sequence + "Sequence Predicates" + (seq-contains-p + :eval (seq-contains '(a b c) 'b) + :eval (seq-contains '(a b c) 'd)) + (seq-every-p + :eval (seq-every-p #'numberp '(1 2 3))) + (seq-empty-p + :eval (seq-empty-p [])) + (seq-set-equal-p + :eval (seq-set-equal-p '(1 2 3) '(3 1 2))) + (seq-some + :eval (seq-some #'cl-evenp '(1 2 3))) + "Building Sequences" + (seq-concatenate + :eval (seq-concatenate 'vector '(1 2) '(c d))) + (seq-copy + :eval (seq-copy '(a 2))) + (seq-into + :eval (seq-into '(1 2 3) 'vector)) + "Utility Functions" + (seq-count + :eval (seq-count #'numberp '(1 b c 4))) + (seq-elt + :eval (seq-elt '(a b c) 1)) + (seq-random-elt + :no-eval (seq-random-elt '(a b c)) + :eg-result c) + (seq-find + :eval (seq-find #'numberp '(a b 3 4 f 6))) + (seq-position + :eval (seq-position '(a b c) 'c)) + (seq-length + :eval (seq-length "abcde")) + (seq-max + :eval (seq-max [1 2 3])) + (seq-min + :eval (seq-min [1 2 3])) + (seq-first + :eval (seq-first [a b c])) + (seq-rest + :eval (seq-rest '[1 2 3])) + (seq-reverse + :eval (seq-reverse '(1 2 3))) + (seq-sort + :eval (seq-sort #'> '(1 2 3))) + (seq-sort-by + :eval (seq-sort-by (lambda (a) (/ 1.0 a)) #'< '(1 2 3))) + "Mapping Over Sequences" + (seq-map + :eval (seq-map #'1+ '(1 2 3))) + (seq-map-indexed + :eval (seq-map-indexed (lambda (a i) (cons i a)) '(a b c))) + (seq-mapcat + :eval (seq-mapcat #'upcase '("a" "b" "c") 'string)) + (seq-do + :no-eval (seq-do (lambda (a) (insert a)) '("foo" "bar")) + :eg-result ("foo" "bar")) + (seq-do-indexed + :no-eval (seq-do-indexed + (lambda (a index) (message "%s:%s" index a)) + '("foo" "bar")) + :eg-result nil) + (seq-reduce + :eval (seq-reduce #'* [1 2 3] 2)) + "Excerpting Sequences" + (seq-drop + :eval (seq-drop '(a b c) 2)) + (seq-drop-while + :eval (seq-drop-while #'numberp '(1 2 c d 5))) + (seq-filter + :eval (seq-filter #'numberp '(a b 3 4 f 6))) + (seq-remove + :eval (seq-remove #'numberp '(1 2 c d 5))) + (seq-group-by + :eval (seq-group-by #'cl-plusp '(-1 2 3 -4 -5 6))) + (seq-difference + :eval (seq-difference '(1 2 3) '(2 3 4))) + (seq-intersection + :eval (seq-intersection '(1 2 3) '(2 3 4))) + (seq-partition + :eval (seq-partition '(a b c d e f g h) 3)) + (seq-subseq + :eval (seq-subseq '(a b c d e) 2 4)) + (seq-take + :eval (seq-take '(a b c d e) 3)) + (seq-take-while + :eval (seq-take-while #'cl-evenp [2 4 9 6 5])) + (seq-uniq + :eval (seq-uniq '(a b d b a c)))) + +(define-short-documentation-group buffer + "Buffer Basics" + (current-buffer + :no-eval (current-buffer) + :eg-result-string "#<buffer shortdoc.el>") + (bufferp + :eval (bufferp 23)) + (buffer-live-p + :no-eval (buffer-live-p some-buffer) + :eg-result t) + (buffer-modified-p + :eval (buffer-modified-p (current-buffer))) + (buffer-name + :eval (buffer-name)) + (window-buffer + :eval (window-buffer)) + "Selecting Buffers" + (get-buffer-create + :no-eval (get-buffer-create "*foo*") + :eg-result-string "#<buffer *foo*>") + (pop-to-buffer + :no-eval (pop-to-buffer "*foo*") + :eg-result-string "#<buffer *foo*>") + (with-current-buffer + :no-eval* (with-current-buffer buffer (buffer-size))) + "Points and Positions" + (point + :eval (point)) + (point-min + :eval (point-max)) + (point-max + :eval (point-max)) + (line-beginning-position + :eval (line-beginning-position)) + (line-end-position + :eval (line-end-position)) + (buffer-size + :eval (buffer-size)) + "Moving Around" + (goto-char + :no-eval (goto-char (point-max)) + :eg-result 342) + (search-forward + :no-eval (search-forward "some-string" nil t) + :eg-result 245) + (re-search-forward + :no-eval (re-search-forward "some-s.*g" nil t) + :eg-result 245) + (forward-line + :no-eval (forward-line 1) + :eg-result 0 + :no-eval (forward-line -2) + :eg-result 0) + "Strings from Buffers" + (buffer-string + :no-eval* (buffer-string)) + (buffer-substring + :eval (buffer-substring (point-min) (+ (point-min) 10))) + (buffer-substring-no-properties + :eval (buffer-substring-no-properties (point-min) (+ (point-min) 10))) + (following-char + :no-eval (following-char) + :eg-result 67) + (char-after + :eval (char-after 45)) + "Altering Buffers" + (delete-region + :no-value (delete-region (point-min) (point-max))) + (erase-buffer + :no-value (erase-buffer)) + (insert + :no-value (insert "This string will be inserted in the buffer\n")) + "Locking" + (lock-buffer + :no-value (lock-buffer "/tmp/foo")) + (unlock-buffer + :no-value (lock-buffer))) + +(define-short-documentation-group process + (make-process + :no-eval (make-process :name "foo" :command '("cat" "/tmp/foo")) + :eg-result-string "#<process foo>") + (processp + :eval (processp t)) + (delete-process + :no-value (delete-process process)) + (kill-process + :no-value (kill-process process)) + (set-process-sentinel + :no-value (set-process-sentinel process (lambda (proc string)))) + (process-buffer + :no-eval (process-buffer process) + :eg-result-string "#<buffer *foo*>") + (get-buffer-process + :no-eval (get-buffer-process buffer) + :eg-result-string "#<process foo>") + (process-live-p + :no-eval (process-live-p process) + :eg-result t)) + +(define-short-documentation-group number + "Arithmetic" + (+ + :args (&rest numbers) + :eval (+ 1 2) + :eval (+ 1 2 3 4)) + (- + :args (&rest numbers) + :eval (- 3 2) + :eval (- 6 3 2)) + (* + :args (&rest numbers) + :eval (* 3 4 5)) + (/ + :eval (/ 10 5) + :eval (/ 10 6) + :eval (/ 10.0 6) + :eval (/ 10.0 3 3)) + (% + :eval (% 10 5) + :eval (% 10 6)) + (mod + :eval (mod 10 5) + :eval (mod 10 6) + :eval (mod 10.5 6)) + (1+ + :eval (1+ 2)) + (1- + :eval (1- 4)) + "Predicates" + (= + :args (number &rest numbers) + :eval (= 4 4) + :eval (= 4.0 4.0) + :eval (= 4 5 6 7)) + (eq + :eval (eq 4 4) + :eval (eq 4.0 4.0)) + (eql + :eval (eql 4 4) + :eval (eql 4 "4") + :eval (eql 4.0 4.0)) + (/= + :eval (/= 4 4)) + (< + :args (number &rest numbers) + :eval (< 4 4) + :eval (< 1 2 3)) + (<= + :args (number &rest numbers) + :eval (<= 4 4) + :eval (<= 1 2 3)) + (> + :args (number &rest numbers) + :eval (> 4 4) + :eval (> 1 2 3)) + (>= + :args (number &rest numbers) + :eval (>= 4 4) + :eval (>= 1 2 3)) + (zerop + :eval (zerop 0)) + (cl-plusp + :eval (cl-plusp 0) + :eval (cl-plusp 1)) + (cl-minusp + :eval (cl-minusp 0) + :eval (cl-minusp -1)) + (cl-oddp + :eval (cl-oddp 3)) + (cl-evenp + :eval (cl-evenp 6)) + (natnump + :eval (natnump -1) + :eval (natnump 23)) + (bignump + :eval (bignump 4) + :eval (bignump (expt 2 90))) + (fixnump + :eval (fixnump 4) + :eval (fixnump (expt 2 90))) + (floatp + :eval (floatp 5.4)) + (integerp + :eval (integerp 5.4)) + (numberp + :eval (numberp "5.4")) + (cl-digit-char-p + :eval (cl-digit-char-p ?5 10) + :eval (cl-digit-char-p ?f 16)) + "Operations" + (max + :args (number &rest numbers) + :eval (max 7 9 3)) + (min + :args (number &rest numbers) + :eval (min 7 9 3)) + (abs + :eval (abs -4)) + (float + :eval (float 2)) + (truncate + :eval (truncate 1.2) + :eval (truncate -1.2) + :eval (truncate 5.4 2)) + (floor + :eval (floor 1.2) + :eval (floor -1.2) + :eval (floor 5.4 2)) + (ceiling + :eval (ceiling 1.2) + :eval (ceiling -1.2) + :eval (ceiling 5.4 2)) + (round + :eval (round 1.2) + :eval (round -1.2) + :eval (round 5.4 2)) + (random + :eval (random 6)) + "Bit Operations" + (ash + :eval (ash 1 4) + :eval (ash 16 -1)) + (lsh + :eval (lsh 1 4) + :eval (lsh 16 -1)) + (logand + :no-eval "(logand #b10 #b111)" + :result-string "#b10") + (logior + :eval (logior 4 16)) + (logxor + :eval (logxor 4 16)) + (lognot + :eval (lognot 5)) + (logcount + :eval (logcount 5)) + "Floating Point" + (isnan + :eval (isnan 5.0)) + (frexp + :eval (frexp 5.7)) + (ldexp + :eval (ldexp 0.7125 3)) + (logb + :eval (logb 10.5)) + (ffloor + :eval (floor 1.2)) + (fceiling + :eval (fceiling 1.2)) + (ftruncate + :eval (ftruncate 1.2)) + (fround + :eval (fround 1.2)) + "Standard Math Functions" + (sin + :eval (sin float-pi)) + (cos + :eval (cos float-pi)) + (tan + :eval (tan float-pi)) + (asin + :eval (asin float-pi)) + (acos + :eval (acos float-pi)) + (atan + :eval (atan float-pi)) + (exp + :eval (exp 4)) + (log + :eval (log 54.59)) + (expt + :eval (expt 2 16)) + (sqrt + :eval (sqrt -1))) + +;;;###autoload +(defun shortdoc-display-group (group) + "Pop to a buffer with short documentation summary for functions in GROUP." + (interactive (list (completing-read "Show summary for functions in: " + (mapcar #'car shortdoc--groups)))) + (when (stringp group) + (setq group (intern group))) + (unless (assq group shortdoc--groups) + (error "No such documentation group %s" group)) + (pop-to-buffer (format "*Shortdoc %s*" group)) + (let ((inhibit-read-only t)) + (erase-buffer) + (special-mode) + (button-mode) + (mapc + (lambda (data) + (cond + ((stringp data) + (insert (propertize + (concat data "\n\n") + 'face '(variable-pitch (:height 1.3 :weight bold))))) + ;; There may be functions not yet defined in the data. + ((fboundp (car data)) + (shortdoc--display-function data)))) + (cdr (assq group shortdoc--groups)))) + (goto-char (point-min))) + +(defun shortdoc--display-function (data) + (let ((function (pop data)) + (start-section (point)) + arglist-start) + ;; Function calling convention. + (insert "(") + (if (plist-get data :no-manual) + (insert (symbol-name function)) + (insert-text-button + (symbol-name function) + 'face 'button + 'action (lambda (_) + (info-lookup-symbol function 'emacs-lisp-mode)))) + (setq arglist-start (point)) + (insert ")\n") + ;; Doc string. + (insert " " + (or (plist-get data :doc) + (car (split-string (documentation function) "\n")))) + (insert "\n") + (add-face-text-property start-section (point) 'shortdoc-section t) + (let ((start (point)) + (print-escape-newlines t) + (double-arrow (if (char-displayable-p ?⇒) + "⇒" + "=>")) + (single-arrow (if (char-displayable-p ?→) + "→" + "->"))) + (cl-loop for (type value) on data by #'cddr + do + (cl-case type + (:eval + (if (stringp value) + (insert " " value "\n") + (insert " ") + (prin1 value (current-buffer)) + (insert "\n") + (insert " " double-arrow " ") + (prin1 (eval value) (current-buffer)) + (insert "\n"))) + (:no-eval* + (if (stringp value) + (insert " " value "\n") + (insert " ") + (prin1 value (current-buffer))) + (insert "\n " single-arrow " " + (propertize "[it depends]" + 'face 'variable-pitch) + "\n")) + (:no-value + (if (stringp value) + (insert " " value) + (insert " ") + (prin1 value (current-buffer))) + (insert "\n")) + (:no-eval + (if (stringp value) + (insert " " value) + (insert " ") + (prin1 value (current-buffer))) + (insert "\n")) + (:result + (insert " " double-arrow " ") + (prin1 value (current-buffer)) + (insert "\n")) + (:result-string + (insert " " double-arrow " ") + (princ value (current-buffer)) + (insert "\n")) + (:eg-result + (insert " eg. " double-arrow " ") + (prin1 value (current-buffer)) + (insert "\n")) + (:eg-result-string + (insert " eg. " double-arrow " ") + (princ value (current-buffer)) + (insert "\n")))) + (put-text-property start (point) 'face 'shortdoc-example)) + (insert "\n") + ;; Insert the arglist after doing the evals, in case that's pulled + ;; in the function definition. + (save-excursion + (goto-char arglist-start) + (dolist (param (or (plist-get data :args) + (help-function-arglist function t))) + (insert " " (symbol-name param))) + (add-face-text-property arglist-start (point) 'shortdoc-section t)))) + +(defun shortdoc-function-groups (function) + "Return all shortdoc groups FUNCTION appears in." + (cl-loop for group in shortdoc--groups + when (assq function (cdr group)) + collect (car group))) + +(defun shortdoc-add-function (group section elem) + "Add ELEM to shortdoc GROUP in SECTION. +If GROUP doesn't exist, it will be created. +If SECTION doesn't exist, it will be added. + +Example: + + (shortdoc-add-function + 'file \"Predicates\" + '(file-locked-p :no-eval (file-locked-p \"/tmp\")))" + (let ((glist (assq group shortdoc--groups))) + (unless glist + (setq glist (list group)) + (setq shortdoc--groups (append shortdoc--groups (list glist)))) + (let ((slist (member section glist))) + (unless slist + (setq slist (list section)) + (setq slist (append glist slist))) + (while (and (cdr slist) + (not (stringp (cadr slist)))) + (setq slist (cdr slist))) + (setcdr slist (cons elem (cdr slist)))))) + +(provide 'shortdoc) + +;;; shortdoc.el ends here diff --git a/lisp/faces.el b/lisp/faces.el index 5b7e0a5aee2..0ce95322703 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -2637,9 +2637,9 @@ Use the face `mode-line-highlight' for features that can be selected." :version "21.1" :group 'basic-faces) -(defface header-line-highlight '((t :inherit highlight)) +(defface header-line-highlight '((t :inherit mode-line-highlight)) "Basic header line face for highlighting." - :version "26.1" + :version "28.1" :group 'basic-faces) (defface vertical-border diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index 7d4fa6c35cc..d7e35c55875 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -180,8 +180,10 @@ (or (member (attendee-name prop) name-or-email) (let ((att-email (attendee-email prop))) (gnus-icalendar-find-if - (lambda (email) - (string-match email att-email)) + (lambda (str-or-fun) + (if (functionp str-or-fun) + (funcall str-or-fun att-email) + (string-match str-or-fun att-email))) name-or-email)))))) (gnus-icalendar-find-if #'attendee-prop-matches-p event-props)))) @@ -763,9 +765,8 @@ These will be used to retrieve the RSVP information from ical events." (lambda (x) (if (listp x) x (list x))) (list user-full-name (regexp-quote user-mail-address) ;; NOTE: these can be lists - gnus-ignored-from-addresses ; already regexp-quoted - (unless (functionp message-alternative-emails) ; String or function. - message-alternative-emails) + gnus-ignored-from-addresses ; String or function. + message-alternative-emails ; String or function. (mapcar #'regexp-quote gnus-icalendar-additional-identities))))) ;; TODO: make the template customizable diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index a906e56aac6..7d897391973 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -3615,7 +3615,14 @@ Message buffers and is not meant to be called directly." (do-auto-fill)))) (defun message-insert-signature (&optional force) - "Insert a signature. See documentation for variable `message-signature'." + "Insert a signature at the end of the buffer. + +See the documentation for the `message-signature' variable for +more information. + +If FORCE is 0 (or when called interactively), the global values +of the signature variables will be consulted if the local ones +are null." (interactive (list 0)) (let ((message-signature message-signature) (message-signature-file message-signature-file)) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index d797e893f51..8a88e0e6e64 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -1772,11 +1772,6 @@ If LIMIT, first try to limit the search to the N last articles." ;; read it. (subst-char-in-region (point-min) (point-max) ?\\ ?% t) - ;; Remove any MODSEQ entries in the buffer, because they may contain - ;; numbers that are too large for 32-bit Emacsen. - (while (re-search-forward " MODSEQ ([0-9]+)" nil t) - (replace-match "" t t)) - (goto-char (point-min)) (let (start end articles groups uidnext elems permanent-flags uidvalidity vanished highestmodseq) (dolist (elem sequences) @@ -1803,8 +1798,9 @@ If LIMIT, first try to limit the search to the N last articles." (setq uidvalidity (and (re-search-forward "UIDVALIDITY \\([0-9]+\\)" end t) - ;; Store UIDVALIDITY as a string, as it's - ;; too big for 32-bit Emacsen, usually. + ;; Store UIDVALIDITY as a string; before bignums, + ;; it was usually too big for 32-bit Emacsen, + ;; and we don't want to change the format now. (match-string 1))) (goto-char start) (setq vanished diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 8287fab3152..a4c0431aa44 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -40,8 +40,8 @@ (defvar help-fns-describe-function-functions nil "List of functions to run in help buffer in `describe-function'. Those functions will be run after the header line and argument -list was inserted, and before the documentation will be inserted. -The functions will receive the function name as argument. +list was inserted, and before the documentation is inserted. +The functions will be called with one argument: the function's symbol. They can assume that a newline was output just before they were called, and they should terminate any of their own output with a newline. By convention they should indent their output by 2 spaces.") @@ -659,6 +659,39 @@ FILE is the file where FUNCTION was probably defined." (insert (format " Probably introduced at or before Emacs version %s.\n" first)))))) +(declare-function shortdoc-display-group "shortdoc") +(declare-function shortdoc-function-groups "shortdoc") + +(add-hook 'help-fns-describe-function-functions + #'help-fns--mention-shortdoc-groups) +(defun help-fns--mention-shortdoc-groups (object) + (require 'shortdoc) + (when-let ((groups (and (symbolp object) + (shortdoc-function-groups object)))) + (let ((start (point)) + (times 0)) + (with-current-buffer standard-output + (insert " Other relevant functions are documented in the ") + (mapc + (lambda (group) + (when (> times 0) + (insert (if (= times (1- (length groups))) + " and " + ", "))) + (setq times (1+ times)) + (insert-text-button + (symbol-name group) + 'action (lambda (_) + (shortdoc-display-group group)))) + groups) + (insert (if (= (length groups) 1) + " group.\n" + " groups.\n"))) + (save-restriction + (narrow-to-region start (point)) + (fill-region-as-paragraph (point-min) (point-max)) + (goto-char (point-max)))))) + (defun help-fns-short-filename (filename) (let* ((abbrev (abbreviate-file-name filename)) (short abbrev)) diff --git a/lisp/help.el b/lisp/help.el index 1a3fd35e44e..d7a53f53641 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -101,6 +101,7 @@ (define-key map "p" 'finder-by-keyword) (define-key map "P" 'describe-package) (define-key map "r" 'info-emacs-manual) + (define-key map "R" 'info-display-manual) (define-key map "s" 'describe-syntax) (define-key map "t" 'help-with-tutorial) (define-key map "w" 'where-is) @@ -223,6 +224,7 @@ o SYMBOL Display the given function or variable's documentation and value. p TOPIC Find packages matching a given topic keyword. P PACKAGE Describe the given Emacs Lisp package. r Display the Emacs manual in Info mode. +R Prompt for a manual and then display it in Info mode. s Display contents of current syntax table, plus explanations. S SYMBOL Show the section for the given symbol in the Info manual for the programming language used in this buffer. diff --git a/lisp/hexl.el b/lisp/hexl.el index 0c31d964577..5d813c410c2 100644 --- a/lisp/hexl.el +++ b/lisp/hexl.el @@ -93,7 +93,15 @@ as that will override any bit grouping options set here." "Face used in address area of Hexl mode buffer.") (defface hexl-ascii-region - '((t (:inherit header-line))) + ;; Copied from `header-line`. We used to inherit from it, but that + ;; looks awful when the headerline is given a variable-pitch font or + ;; (even worse) a 3D look. + '((((class color grayscale) (background light)) + :background "grey90" :foreground "grey20" + :box nil) + (((class color grayscale) (background dark)) + :background "grey20" :foreground "grey90" + :box nil)) "Face used in ASCII area of Hexl mode buffer.") (defvar-local hexl-max-address 0 @@ -209,10 +217,14 @@ as that will override any bit grouping options set here." (make-variable-buffer-local 'hexl-ascii-overlay) (defvar hexl-font-lock-keywords - '(("^\\([0-9a-f]+:\\).\\{40\\} \\(.+$\\)" - ;; "^\\([0-9a-f]+:\\).+ \\(.+$\\)" + '(("^\\([0-9a-f]+:\\)\\( \\).\\{39\\}\\( \\)\\(.+$\\)" + ;; "^\\([0-9a-f]+:\\).+ \\(.+$\\)"v (1 'hexl-address-region t t) - (2 'hexl-ascii-region t t))) + ;; If `hexl-address-region' is using a variable-pitch font, the + ;; rest of the line isn't naturally aligned, so align them by hand. + (2 '(face nil display (space :align-to 10))) + (3 '(face nil display (space :align-to 51))) + (4 'hexl-ascii-region t t))) "Font lock keywords used in `hexl-mode'.") (defun hexl-rulerize (string bits) @@ -362,6 +374,7 @@ You can use \\[hexl-find-file] to visit a file in Hexl mode. (setq-local font-lock-defaults '(hexl-font-lock-keywords t)) + (setq-local font-lock-extra-managed-props '(display)) (setq-local revert-buffer-function #'hexl-revert-buffer-function) (add-hook 'change-major-mode-hook #'hexl-maybe-dehexlify-buffer nil t) diff --git a/lisp/indent.el b/lisp/indent.el index 0a0dd99ce08..e436d140e79 100644 --- a/lisp/indent.el +++ b/lisp/indent.el @@ -52,6 +52,8 @@ or in the line's indentation, otherwise it inserts a \"real\" TAB character. If `complete', TAB first tries to indent the current line, and if the line was already indented, then try to complete the thing at point. +Also see `tab-first-completion'. + Some programming language modes have their own variable to control this, e.g., `c-tab-always-indent', and do not respect this variable." :group 'indent @@ -60,6 +62,27 @@ e.g., `c-tab-always-indent', and do not respect this variable." (const :tag "Indent if inside indentation, else TAB" nil) (const :tag "Indent, or if already indented complete" complete))) +(defcustom tab-first-completion nil + "Governs the behavior of TAB completion on the first press of the key. +When nil, complete. When `eol', only complete if point is at the +end of a line. When `word', complete unless the next character +has word syntax (according to `syntax-after'). When +`word-or-paren', complete unless the next character is part of a +word or a parenthesis. When `word-or-paren-or-punct', complete +unless the next character is part of a word, parenthesis, or +punctuation. Typing TAB a second time always results in +completion. + +This variable has no effect unless `tab-always-indent' is `complete'." + :group 'indent + :type '(choice + (const :tag "Always complete" nil) + (const :tag "Unless at the end of a line" 'eol) + (const :tag "Unless looking at a word" 'word) + (const :tag "Unless at a word or parenthesis" 'word-or-paren) + (const :tag "Unless at a word, parenthesis, or punctuation." 'word-or-paren-or-punct)) + :version "27.1") + (defun indent-according-to-mode () "Indent line in proper way for current major mode. @@ -113,7 +136,7 @@ or performs symbol completion, depending on `tab-always-indent'. The function called to actually indent the line or insert a tab is given by the variable `indent-line-function'. -If a prefix argument is given, after this function indents the +If a prefix argument is given (ARG), after this function indents the current line or inserts a tab, it also rigidly indents the entire balanced expression which starts at the beginning of the current line, to reflect the current line's indentation. @@ -141,7 +164,8 @@ prefix argument is ignored." (t (let ((old-tick (buffer-chars-modified-tick)) (old-point (point)) - (old-indent (current-indentation))) + (old-indent (current-indentation)) + (syn `(,(syntax-after (point))))) ;; Indent the line. (or (not (eq (indent--funcall-widened indent-line-function) 'noindent)) @@ -154,7 +178,20 @@ prefix argument is ignored." ;; If the text was already indented right, try completion. ((and (eq tab-always-indent 'complete) (eq old-point (point)) - (eq old-tick (buffer-chars-modified-tick))) + (eq old-tick (buffer-chars-modified-tick)) + (or (null tab-first-completion) + (eq last-command this-command) + (and (equal tab-first-completion 'eol) + (eolp)) + (and (member tab-first-completion + '(word word-or-paren word-or-paren-or-punct)) + (not (member 2 syn))) + (and (member tab-first-completion + '(word-or-paren word-or-paren-or-punct)) + (not (or (member 4 syn) + (member 5 syn)))) + (and (equal tab-first-completion 'word-or-paren-or-punct) + (not (member 1 syn))))) (completion-at-point)) ;; If a prefix argument was given, rigidly indent the following diff --git a/lisp/isearch.el b/lisp/isearch.el index f39de79303d..0879f948cff 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -2535,6 +2535,8 @@ is bound to outside of Isearch." (let ((pasted-text (nth 1 event))) (isearch-yank-string pasted-text)))) +(defvar isearch--yank-prev-point nil) + (defun isearch-yank-internal (jumpform) "Pull the text from point to the point reached by JUMPFORM. JUMPFORM is a lambda expression that takes no arguments and returns @@ -2545,7 +2547,14 @@ or it might return the position of the end of the line." (save-excursion (and (not isearch-forward) isearch-other-end (goto-char isearch-other-end)) - (buffer-substring-no-properties (point) (funcall jumpform))))) + (and (not isearch-success) isearch--yank-prev-point + (goto-char isearch--yank-prev-point)) + (buffer-substring-no-properties + (point) + (prog1 + (setq isearch--yank-prev-point (funcall jumpform)) + (when isearch-success + (setq isearch--yank-prev-point nil))))))) (defun isearch-yank-char-in-minibuffer (&optional arg) "Pull next character from buffer into end of search string in minibuffer." @@ -3442,10 +3451,10 @@ Optional third argument, if t, means if fail just return nil (no error). (match-beginning 0) (match-end 0))) (setq retry nil))) (setq isearch-just-started nil) - (setq isearch-match-data (match-data t)) - (if isearch-success - (setq isearch-other-end - (if isearch-forward (match-beginning 0) (match-end 0))))) + (when isearch-success + (setq isearch-other-end + (if isearch-forward (match-beginning 0) (match-end 0))) + (setq isearch-match-data (match-data t)))) (quit (isearch-unread ?\C-g) (setq isearch-success nil)) diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index 1b3e102cfa7..da4ad9799bd 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -1881,6 +1881,9 @@ they ran")) (bindings--define-key menu [describe-function] '(menu-item "Describe Function..." describe-function :help "Display documentation of function/command")) + (bindings--define-key menu [shortdoc-display-group] + '(menu-item "Function Group Overview..." shortdoc-display-group + :help "Display a function overview for a specific topic")) (bindings--define-key menu [describe-key-1] '(menu-item "Describe Key or Mouse Operation..." describe-key ;; Users typically don't identify keys and menu items... diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 77ba5266dcb..bb2420e1f49 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -1740,6 +1740,7 @@ clients from discovering the still incomplete interface. (when emits-signal (dbus-send-signal bus service path dbus-interface-properties "PropertiesChanged" + interface ;; changed_properties. (if (eq access :write) '(:array: :signature "{sv}") @@ -1818,6 +1819,7 @@ It will be registered for all objects created by `dbus-register-property'." (when (nth 1 object) (dbus-send-signal bus service path dbus-interface-properties "PropertiesChanged" + interface ;; changed_properties. (if (eq :write (car object)) '(:array: :signature "{sv}") diff --git a/lisp/outline.el b/lisp/outline.el index 6158ed594e9..a4ce9afb445 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -179,6 +179,12 @@ in the file it applies to.") (let ((map (make-sparse-keymap))) (define-key map "\C-c" outline-mode-prefix-map) (define-key map [menu-bar] outline-mode-menu-bar-map) + ;; Only takes effect if point is on a heading. + (define-key map (kbd "TAB") + `(menu-item "" outline-cycle + :filter ,(lambda (cmd) + (when (outline-on-heading-p) cmd)))) + (define-key map (kbd "<backtab>") #'outline-cycle-buffer) map)) (defvar outline-font-lock-keywords @@ -1125,6 +1131,83 @@ convenient way to make a table of contents of the buffer." (insert "\n\n")))))) (kill-new (buffer-string))))))) +(defun outline--cycle-state () + "Return the cycle state of current heading. +Return either 'hide-all, 'headings-only, or 'show-all." + (save-excursion + (let (start end ov-list heading-end) + (outline-back-to-heading) + (setq start (point)) + (outline-end-of-heading) + (setq heading-end (point)) + (outline-end-of-subtree) + (setq end (point)) + (setq ov-list (cl-remove-if-not + (lambda (o) (eq (overlay-get o 'invisible) 'outline)) + (overlays-in start end))) + (cond ((eq ov-list nil) 'show-all) + ;; (eq (length ov-list) 1) wouldn’t work: what if there is + ;; one folded subheading? + ((and (eq (overlay-end (car ov-list)) end) + (eq (overlay-start (car ov-list)) heading-end)) + 'hide-all) + (t 'headings-only))))) + +(defun outline-has-subheading-p () + "Return t if this heading has subheadings, nil otherwise." + (save-excursion + (outline-back-to-heading) + (< (save-excursion (outline-next-heading) (point)) + (save-excursion (outline-end-of-subtree) (point))))) + +(defun outline-cycle () + "Cycle between `hide all', `headings only' and `show all'. + +`Hide all' means hide all subheadings and their bodies. +`Headings only' means show sub headings but not their bodies. +`Show all' means show all subheadings and their bodies." + (interactive) + (pcase (outline--cycle-state) + ('hide-all + (if (outline-has-subheading-p) + (progn (outline-show-children) + (message "Only headings")) + (outline-show-subtree) + (message "Show all"))) + ('headings-only + (outline-show-subtree) + (message "Show all")) + ('show-all + (outline-hide-subtree) + (message "Hide all")))) + +(defvar-local outline--cycle-buffer-state 'show-all + "Internal variable used for tracking buffer cycle state.") + +(defun outline-cycle-buffer () + "Cycle the whole buffer like in `outline-cycle'." + (interactive) + (pcase outline--cycle-buffer-state + ('show-all + (save-excursion + (let ((start-point (point))) + (while (not (eq (point) start-point)) + (outline-up-heading 1)) + (outline-hide-sublevels + (progn (outline-back-to-heading) + (funcall 'outline-level))))) + (setq outline--cycle-buffer-state 'top-level) + (message "Top level headings")) + ('top-level + (outline-show-all) + (outline-hide-region-body (point-min) (point-max)) + (setq outline--cycle-buffer-state 'all-heading) + (message "All headings")) + ('all-heading + (outline-show-all) + (setq outline--cycle-buffer-state 'show-all) + (message "Show all")))) + (provide 'outline) (provide 'noutline) diff --git a/lisp/proced.el b/lisp/proced.el index ff2db33afb6..203d70331ce 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -1,4 +1,4 @@ -;;; proced.el --- operate on system processes like dired +;;; proced.el --- operate on system processes like dired -*- lexical-binding:t -*- ;; Copyright (C) 2008-2020 Free Software Foundation, Inc. @@ -55,17 +55,15 @@ :group 'unix :prefix "proced-") -(defcustom proced-signal-function 'signal-process +(defcustom proced-signal-function #'signal-process "Name of signal function. It can be an elisp function (usually `signal-process') or a string specifying the external command (usually \"kill\")." - :group 'proced :type '(choice (function :tag "function") (string :tag "command"))) (defcustom proced-renice-command "renice" "Name of renice command." - :group 'proced :version "24.3" :type '(string :tag "command")) @@ -95,7 +93,6 @@ the external command (usually \"kill\")." ("USR1" . " (User-defined signal 1)") ("USR2" . " (User-defined signal 2)")) "List of signals, used for minibuffer completion." - :group 'proced :type '(repeat (cons (string :tag "signal name") (string :tag "description")))) @@ -205,7 +202,6 @@ of point. The function must return a list of PIDs that is used for the refined listing. HELP-ECHO is a string that is shown when mouse is over this field. If REFINER is nil no refinement is done." - :group 'proced :type '(repeat (list :tag "Attribute" (symbol :tag "Key") (string :tag "Header") @@ -239,7 +235,6 @@ of a system process. It returns a cons cell of the form (KEY . VALUE) like `process-attributes'. This cons cell is appended to the list returned by `proced-process-attributes'. If the function returns nil, the value is ignored." - :group 'proced :type '(repeat (function :tag "Attribute"))) ;; Formatting and sorting rules are defined "per attribute". If formatting @@ -263,7 +258,6 @@ The cdr is a list of attribute keys appearing in `proced-grammar-alist'. An element of this list may also be a list of attribute keys that specifies alternatives. If the first attribute is absent for a process, use the second one, etc." - :group 'proced :type '(alist :key-type (symbol :tag "Format Name") :value-type (repeat :tag "Keys" (choice (symbol :tag "") @@ -274,7 +268,6 @@ one, etc." "Current format of Proced listing. It can be the car of an element of `proced-format-alist'. It can also be a list of keys appearing in `proced-grammar-alist'." - :group 'proced :type '(choice (symbol :tag "Format Name") (repeat :tag "Keys" (symbol :tag "")))) (make-variable-buffer-local 'proced-format) @@ -304,7 +297,6 @@ An elementary filter can be one of the following: of each. Accept the process if FUN returns non-nil. \(fun-all . FUN) Apply function FUN to entire process list. FUN must return the filtered list." - :group 'proced :type '(repeat (cons :tag "Filter" (symbol :tag "Filter Name") (repeat :tag "Filters" @@ -318,7 +310,6 @@ An elementary filter can be one of the following: It can be the car of an element of `proced-filter-alist'. It can also be a list of elementary filters as in the cdrs of the elements of `proced-filter-alist'." - :group 'proced :type '(choice (symbol :tag "Filter Name") (repeat :tag "Filters" (choice (cons :tag "Key . Regexp" (symbol :tag "Key") regexp) @@ -332,38 +323,32 @@ of `proced-filter-alist'." It must be the KEY of an element of `proced-grammar-alist'. It can also be a list of KEYs as in the SORT-SCHEMEs of the elements of `proced-grammar-alist'." - :group 'proced :type '(choice (symbol :tag "Sort Scheme") (repeat :tag "Key List" (symbol :tag "Key")))) (make-variable-buffer-local 'proced-sort) (defcustom proced-descend t "Non-nil if proced listing is sorted in descending order." - :group 'proced :type '(boolean :tag "Descending Sort Order")) (make-variable-buffer-local 'proced-descend) (defcustom proced-goal-attribute 'args "If non-nil, key of the attribute that defines the `goal-column'." - :group 'proced :type '(choice (const :tag "none" nil) (symbol :tag "key"))) (defcustom proced-auto-update-interval 5 "Time interval in seconds for auto updating Proced buffers." - :group 'proced :type 'integer) (defcustom proced-auto-update-flag nil "Non-nil for auto update of a Proced buffer. Can be changed interactively via `proced-toggle-auto-update'." - :group 'proced :type 'boolean) (make-variable-buffer-local 'proced-auto-update-flag) (defcustom proced-tree-flag nil "Non-nil for display of Proced buffer as process tree." - :group 'proced :type 'boolean) (make-variable-buffer-local 'proced-tree-flag) @@ -371,26 +356,23 @@ Can be changed interactively via `proced-toggle-auto-update'." "Normal hook run after displaying or updating a Proced buffer. May be used to adapt the window size via `fit-window-to-buffer'." :type 'hook - :options '(fit-window-to-buffer) - :group 'proced) + :options '(fit-window-to-buffer)) (defcustom proced-after-send-signal-hook nil "Normal hook run after sending a signal to processes by `proced-send-signal'. May be used to revert the process listing." :type 'hook - :options '(proced-revert) - :group 'proced) + :options '(proced-revert)) ;; Internal variables (defvar proced-available (not (null (list-system-processes))) "Non-nil means Proced is known to work on this system.") -(defvar proced-process-alist nil +(defvar-local proced-process-alist nil "Alist of processes displayed by Proced. The car of each element is the PID, and the cdr is a list of cons pairs, see `proced-process-attributes'.") -(make-variable-buffer-local 'proced-process-alist) (defvar proced-sort-internal nil "Sort scheme for listing (internal format). @@ -408,26 +390,22 @@ It is a list of lists (KEY PREDICATE REVERSE).") (defface proced-mark '((t (:inherit font-lock-constant-face))) - "Face used for Proced marks." - :group 'proced-faces) + "Face used for Proced marks.") (defface proced-marked '((t (:inherit error))) - "Face used for marked processes." - :group 'proced-faces) + "Face used for marked processes.") (defface proced-sort-header '((t (:inherit font-lock-keyword-face))) - "Face used for header of attribute used for sorting." - :group 'proced-faces) + "Face used for header of attribute used for sorting.") (defvar proced-re-mark "^[^ \n]" "Regexp matching a marked line. Important: the match ends just after the marker.") -(defvar proced-header-line nil +(defvar-local proced-header-line nil "Headers in Proced buffer as a string.") -(make-variable-buffer-local 'proced-header-line) (defvar proced-temp-alist nil "Temporary alist (internal variable).") @@ -615,14 +593,23 @@ Important: the match ends just after the marker.") (defun proced-header-line () "Return header line for Proced buffer." - (list (propertize " " - 'display - (list 'space :align-to - (line-number-display-width 'columns))) - (if (<= (window-hscroll) (length proced-header-line)) - (replace-regexp-in-string ;; preserve text properties - "\\(%\\)" "\\1\\1" - (substring proced-header-line (window-hscroll)))))) + (let ((base (line-number-display-width 'columns)) + (hl (if (<= (window-hscroll) (length proced-header-line)) + (substring proced-header-line (window-hscroll))))) + (when hl + ;; From buff-menu.el: Turn whitespace chars in the header into + ;; stretch specs so they work regardless of the header-line face. + (let ((pos 0)) + (while (string-match "[ \t\n]+" hl pos) + (setq pos (match-end 0)) + (put-text-property (match-beginning 0) pos 'display + `(space :align-to ,(+ pos base)) + hl))) + (setq hl (replace-regexp-in-string ;; preserve text properties + "\\(%\\)" "\\1\\1" + hl))) + (list (propertize " " 'display `(space :align-to ,base)) + hl))) (defun proced-pid-at-point () "Return pid of system process at point. @@ -676,8 +663,8 @@ After displaying or updating a Proced buffer, Proced runs the normal hook (setq buffer-read-only t truncate-lines t header-line-format '(:eval (proced-header-line))) - (add-hook 'post-command-hook 'force-mode-line-update nil t) - (set (make-local-variable 'revert-buffer-function) 'proced-revert) + (add-hook 'post-command-hook #'force-mode-line-update nil t) ;; FIXME: Why? + (set (make-local-variable 'revert-buffer-function) #'proced-revert) (set (make-local-variable 'font-lock-defaults) '(proced-font-lock-keywords t nil nil beginning-of-line)) (if (and (not proced-auto-update-timer) proced-auto-update-interval) @@ -940,11 +927,12 @@ Return the filtered process list." (if (funcall (car filter) (cdr process)) (push process new-alist)))) (t ;; apply predicate to specified attribute - (let ((fun (if (stringp (cdr filter)) - `(lambda (val) - (string-match ,(cdr filter) val)) - (cdr filter))) - value) + (let* ((cdrfilter (cdr filter)) + (fun (if (stringp cdrfilter) + (lambda (val) + (string-match cdrfilter val)) + cdrfilter)) + value) (dolist (process process-alist) (setq value (cdr (assq (car filter) (cdr process)))) (if (and value (funcall fun value)) @@ -1023,7 +1011,7 @@ The list of children does not include grandchildren." "Return list of children PIDs of PPID (including PPID)." (let ((cpids (cdr (assq ppid proced-temp-alist)))) (if cpids - (cons ppid (apply 'append (mapcar 'proced-children-pids cpids))) + (cons ppid (apply #'append (mapcar #'proced-children-pids cpids))) (list ppid)))) (defun proced-process-tree (process-alist) @@ -1114,7 +1102,7 @@ Return the rearranged process list." proced-process-tree) (if (cdr process-tree) (let ((proced-tree-depth (1+ proced-tree-depth))) - (mapc 'proced-tree-insert (cdr process-tree)))))) + (mapc #'proced-tree-insert (cdr process-tree)))))) ;; Refining @@ -1207,7 +1195,7 @@ Return `equal' if T1 equals T2. Return nil otherwise." ;;; Sorting -(define-obsolete-function-alias 'proced-xor 'xor "27.1") +(define-obsolete-function-alias 'proced-xor #'xor "27.1") (defun proced-sort-p (p1 p2) "Predicate for sorting processes P1 and P2." @@ -1436,10 +1424,11 @@ Replace newline characters by \"^J\" (two characters)." ;; Loop over all attributes (while (setq grammar (assq (pop format) proced-grammar-alist)) (let* ((key (car grammar)) - (fun (cond ((stringp (nth 2 grammar)) - `(lambda (arg) (format ,(nth 2 grammar) arg))) - ((not (nth 2 grammar)) 'identity) - ( t (nth 2 grammar)))) + (nth2grm (nth 2 grammar)) + (fun (cond ((stringp nth2grm) + (lambda (arg) (format nth2grm arg))) + ((not nth2grm) #'identity) + (t nth2grm))) (whitespace (if format whitespace "")) ;; Text properties: ;; We use the text property `proced-key' to store in each @@ -1479,13 +1468,13 @@ Replace newline characters by \"^J\" (two characters)." (end-of-line) (setq value (cdr (assq key (cdr process)))) (insert (if value - (apply 'propertize (funcall fun value) fprops) + (apply #'propertize (funcall fun value) fprops) (format (concat "%" (number-to-string (nth 3 grammar)) "s") unknown)) whitespace) (forward-line)) (push (format (concat "%" (number-to-string (nth 3 grammar)) "s") - (apply 'propertize (nth 1 grammar) hprops)) + (apply #'propertize (nth 1 grammar) hprops)) header-list)) ( ;; last field left-justified @@ -1493,10 +1482,10 @@ Replace newline characters by \"^J\" (two characters)." (dolist (process process-alist) (end-of-line) (setq value (cdr (assq key (cdr process)))) - (insert (if value (apply 'propertize (funcall fun value) fprops) + (insert (if value (apply #'propertize (funcall fun value) fprops) unknown)) (forward-line)) - (push (apply 'propertize (nth 1 grammar) hprops) header-list)) + (push (apply #'propertize (nth 1 grammar) hprops) header-list)) (t ;; calculated field width (let ((width (length (nth 1 grammar))) @@ -1504,14 +1493,14 @@ Replace newline characters by \"^J\" (two characters)." (dolist (process process-alist) (setq value (cdr (assq key (cdr process)))) (if value - (setq value (apply 'propertize (funcall fun value) fprops) + (setq value (apply #'propertize (funcall fun value) fprops) width (max width (length value)) field-list (cons value field-list)) (push unknown field-list) (setq width (max width (length unknown))))) (let ((afmt (concat "%" (if (eq 'left (nth 3 grammar)) "-" "") (number-to-string width) "s"))) - (push (format afmt (apply 'propertize (nth 1 grammar) hprops)) + (push (format afmt (apply #'propertize (nth 1 grammar) hprops)) header-list) (dolist (value (nreverse field-list)) (end-of-line) @@ -1527,7 +1516,7 @@ Replace newline characters by \"^J\" (two characters)." (forward-line)) ;; Set header line (setq proced-header-line - (mapconcat 'identity (nreverse header-list) whitespace)) + (mapconcat #'identity (nreverse header-list) whitespace)) (if (string-match "[ \t]+$" proced-header-line) (setq proced-header-line (substring proced-header-line 0 (match-beginning 0)))) @@ -1742,7 +1731,7 @@ The value returned is the value of the last form in BODY." (setq truncate-lines t proced-header-line header-line ; inherit header line header-line-format '(:eval (proced-header-line))) - (add-hook 'post-command-hook 'force-mode-line-update nil t) + (add-hook 'post-command-hook #'force-mode-line-update nil t) ;FIXME: Why? (let ((inhibit-read-only t)) (erase-buffer) (buffer-disable-undo) @@ -1780,8 +1769,8 @@ supported but discouraged. It will be removed in a future version of Emacs." (format "%d processes" (length process-alist)))) (completion-ignore-case t) (completion-extra-properties - '(:annotation-function - (lambda (s) (cdr (assoc s proced-signal-list)))))) + `(:annotation-function + ,(lambda (s) (cdr (assoc s proced-signal-list)))))) (proced-with-processes-buffer process-alist (list (completing-read (concat "Send signal [" pnum "] (default TERM): ") @@ -1805,8 +1794,8 @@ supported but discouraged. It will be removed in a future version of Emacs." (format "%d processes" (length process-alist)))) (completion-ignore-case t) (completion-extra-properties - '(:annotation-function - (lambda (s) (cdr (assoc s proced-signal-list)))))) + `(:annotation-function + ,(lambda (s) (cdr (assoc s proced-signal-list)))))) (proced-with-processes-buffer process-alist (setq signal (completing-read (concat "Send signal [" pnum "] (default TERM): ") diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index f028a4279d1..96838269749 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -959,10 +959,10 @@ The substitution is based on variables bound dynamically, and these include `opts', `dir', `files', `null-device', `excl' and `regexp'.") -(defun grep-expand-template (template &optional regexp files dir excl) +(defun grep-expand-template (template &optional regexp files dir excl more-opts) "Expand grep COMMAND string replacing <C>, <D>, <F>, <R>, and <X>." (let* ((command template) - (env `((opts . ,(let (opts) + (env `((opts . ,(let ((opts more-opts)) (when (and case-fold-search (isearch-no-upper-case-p regexp t)) (push "-i" opts)) @@ -1058,6 +1058,8 @@ REGEXP is used as a string in the prompt." (or (cdr (assoc files grep-files-aliases)) files)))) +(defvar grep-use-directories-skip 'auto-detect) + ;;;###autoload (defun lgrep (regexp &optional files dir confirm) "Run grep, searching for REGEXP in FILES in directory DIR. @@ -1103,6 +1105,12 @@ command before it's run." (if (string= command grep-command) (setq command nil)) (setq dir (file-name-as-directory (expand-file-name dir))) + (unless (or (not grep-use-directories-skip) (eq grep-use-directories-skip t)) + (setq grep-use-directories-skip + (grep-probe grep-program + `(nil nil nil "--directories=skip" "foo" + ,null-device) + nil 1))) (setq command (grep-expand-template grep-template regexp @@ -1119,13 +1127,10 @@ command before it's run." (shell-quote-argument (cdr ignore)))))) grep-find-ignored-files - " --exclude="))))) + " --exclude="))) + (and (eq grep-use-directories-skip t) + '("--directories=skip")))) (when command - (when (grep-probe grep-program - `(nil nil nil "--directories=skip" "foo" - ,null-device) - nil 1) - (setq command (concat command " --directories=skip"))) (if confirm (setq command (read-from-minibuffer "Confirm: " diff --git a/lisp/simple.el b/lisp/simple.el index b6d4e0603ee..a24f2844aa3 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -118,6 +118,23 @@ If non-nil, the value is passed directly to `recenter'." :group 'next-error :version "23.1") +(defcustom next-error-message-highlight nil + "If non-nil, highlight the current error message in the `next-error' buffer." + :type 'boolean + :group 'next-error + :version "28.1") + +(defface next-error-message + '((t (:inherit highlight))) + "Face used to highlight the current error message in the `next-error' buffer." + :group 'next-error + :version "28.1") + +(defvar next-error--message-highlight-overlay + nil + "Overlay highlighting the current error message in the `next-error' buffer.") +(make-variable-buffer-local 'next-error--message-highlight-overlay) + (defcustom next-error-hook nil "List of hook functions run by `next-error' after visiting source file." :type 'hook @@ -376,6 +393,7 @@ and TO-BUFFER is a target buffer." (when next-error-recenter (recenter next-error-recenter)) (funcall next-error-found-function from-buffer to-buffer) + (next-error-message-highlight) (run-hooks 'next-error-hook)) (defun next-error-select-buffer (buffer) @@ -460,6 +478,21 @@ buffer causes automatic display of the corresponding source code location." (next-error-no-select 0)) (error t)))) +(defun next-error-message-highlight () + "Highlight the current error message in the ‘next-error’ buffer." + (when next-error-message-highlight + (with-current-buffer next-error-last-buffer + (when next-error--message-highlight-overlay + (delete-overlay next-error--message-highlight-overlay)) + (save-excursion + (goto-char compilation-current-error) + (let ((ol (make-overlay (line-beginning-position) (line-end-position)))) + ;; do not override region highlighting + (overlay-put ol 'priority -50) + (overlay-put ol 'face 'next-error-message) + (overlay-put ol 'window (get-buffer-window)) + (setf next-error--message-highlight-overlay ol)))))) + ;;; diff --git a/lisp/subr.el b/lisp/subr.el index bd8dd07b30e..54089057de6 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -1372,7 +1372,8 @@ EVENT is nil, the value of `posn-at-point' is used instead. The following accessor functions are used to access the elements of the position: -`posn-window': The window the event is in. +`posn-window': The window of the event end, or its frame if the +event end point belongs to no window. `posn-area': A symbol identifying the area the event occurred in, or nil if the event occurred in the text area. `posn-point': The buffer position of the event. @@ -1428,8 +1429,9 @@ than a window, return nil." (defsubst posn-window (position) "Return the window in POSITION. -POSITION should be a list of the form returned by the `event-start' -and `event-end' functions." +If POSITION is outside the frame where the event was initiated, +return that frame instead. POSITION should be a list of the form +returned by the `event-start' and `event-end' functions." (nth 0 position)) (defsubst posn-area (position) @@ -1456,9 +1458,14 @@ a click on a scroll bar)." (defun posn-set-point (position) "Move point to POSITION. Select the corresponding window as well." - (if (not (windowp (posn-window position))) + (if (framep (posn-window position)) + (progn + (unless (windowp (frame-selected-window (posn-window position))) + (error "Position not in text area of window")) + (select-window (frame-selected-window (posn-window position)))) + (unless (windowp (posn-window position)) (error "Position not in text area of window")) - (select-window (posn-window position)) + (select-window (posn-window position))) (if (numberp (posn-point position)) (goto-char (posn-point position)))) @@ -2620,7 +2627,15 @@ keyboard-quit events while waiting for a valid input." (unless (get-text-property 0 'face prompt) (setq prompt (propertize prompt 'face 'minibuffer-prompt))) (setq char (let ((inhibit-quit inhibit-keyboard-quit)) - (read-key prompt))) + (read-char-from-minibuffer + prompt + ;; If we have a dynamically bound `help-form' + ;; here, then the `C-h' (i.e., `help-char') + ;; character should output that instead of + ;; being a command char. + (if help-form + (cons help-char chars) + chars)))) (and show-help (buffer-live-p (get-buffer helpbuf)) (kill-buffer helpbuf)) (cond diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el index dd0a986572d..cc7a3762b4a 100644 --- a/lisp/term/ns-win.el +++ b/lisp/term/ns-win.el @@ -511,15 +511,9 @@ string dropped into the current buffer." (set-frame-selected-window nil window) (raise-frame) (setq window (selected-window)) - (cond ((memq 'ns-drag-operation-generic operations) - ;; Perform the default action for the type. - (if (eq type 'file) - (dolist (data objects) - (dnd-handle-one-url window 'private (concat "file:" data))) - (dnd-insert-text window 'private string))) - ((memq 'ns-drag-operation-copy operations) - ;; Try to open the file/URL. If type is nil, try to open - ;; it as a URL anyway. + (cond ((or (memq 'ns-drag-operation-generic operations) + (memq 'ns-drag-operation-copy operations)) + ;; Perform the default/copy action. (dolist (data objects) (dnd-handle-one-url window 'private (if (eq type 'file) (concat "file:" data) diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index 65702d081f1..2757074f9f8 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -539,7 +539,6 @@ in your init file. ispell-dictionary "--") 0 2))) - face bold help-echo "mouse-1: Change dictionary" local-map (keymap (mode-line keymap diff --git a/lisp/tooltip.el b/lisp/tooltip.el index 5f5a4788b26..ffc3d499e30 100644 --- a/lisp/tooltip.el +++ b/lisp/tooltip.el @@ -1,4 +1,4 @@ -;;; tooltip.el --- show tooltip windows +;;; tooltip.el --- show tooltip windows -*- lexical-binding:t -*- ;; Copyright (C) 1997, 1999-2020 Free Software Foundation, Inc. @@ -70,24 +70,20 @@ echo area, instead of making a pop-up window." (defcustom tooltip-delay 0.7 "Seconds to wait before displaying a tooltip the first time." - :type 'number - :group 'tooltip) + :type 'number) (defcustom tooltip-short-delay 0.1 "Seconds to wait between subsequent tooltips on different items." - :type 'number - :group 'tooltip) + :type 'number) (defcustom tooltip-recent-seconds 1 "Display tooltips if changing tip items within this many seconds. Do so after `tooltip-short-delay'." - :type 'number - :group 'tooltip) + :type 'number) (defcustom tooltip-hide-delay 10 "Hide tooltips automatically after this many seconds." - :type 'number - :group 'tooltip) + :type 'number) (defcustom tooltip-x-offset 5 "X offset, in pixels, for the display of tooltips. @@ -98,8 +94,7 @@ interfere with clicking where you wish. If `tooltip-frame-parameters' includes the `left' parameter, the value of `tooltip-x-offset' is ignored." - :type 'integer - :group 'tooltip) + :type 'integer) (defcustom tooltip-y-offset +20 "Y offset, in pixels, for the display of tooltips. @@ -110,8 +105,7 @@ interfere with clicking where you wish. If `tooltip-frame-parameters' includes the `top' parameter, the value of `tooltip-y-offset' is ignored." - :type 'integer - :group 'tooltip) + :type 'integer) (defcustom tooltip-frame-parameters '((name . "tooltip") @@ -127,8 +121,7 @@ Note that font and color parameters are ignored, and the attributes of the `tooltip' face are used instead." :type '(repeat (cons :format "%v" (symbol :tag "Parameter") - (sexp :tag "Value"))) - :group 'tooltip + (sexp :tag "Value"))) :version "26.1") (defface tooltip @@ -139,15 +132,13 @@ of the `tooltip' face are used instead." (t :inherit variable-pitch)) "Face for tooltips." - :group 'tooltip :group 'basic-faces) (defcustom tooltip-use-echo-area nil "Use the echo area instead of tooltip frames for help and GUD tooltips. This variable is obsolete; instead of setting it to t, disable `tooltip-mode' (which has a similar effect)." - :type 'boolean - :group 'tooltip) + :type 'boolean) (make-obsolete-variable 'tooltip-use-echo-area "disable Tooltip mode instead" "24.1" 'set) @@ -161,7 +152,6 @@ the echo area is resized as needed to accommodate the full text of the tooltip. This variable has effect only on GUI frames." :type 'boolean - :group 'tooltip :version "27.1") diff --git a/lisp/url/url-domsuf.el b/lisp/url/url-domsuf.el index fa57815e204..c1cdf901d6c 100644 --- a/lisp/url/url-domsuf.el +++ b/lisp/url/url-domsuf.el @@ -1,4 +1,4 @@ -;;; url-domsuf.el --- Say what domain names can have cookies set. +;;; url-domsuf.el --- Say what domain names can have cookies set. -*- lexical-binding:t -*- ;; Copyright (C) 2012-2020 Free Software Foundation, Inc. @@ -24,7 +24,7 @@ ;;; Commentary: ;; The rules for what domains can have cookies set is defined here: -;; http://publicsuffix.org/list/ +;; https://publicsuffix.org/list/ ;;; Code: @@ -87,17 +87,6 @@ (setq allowedp nil)))) allowedp)) -;; Tests: - -;; TODO convert to a proper test. -;; (url-domsuf-cookie-allowed-p "com") => nil -;; (url-domsuf-cookie-allowed-p "foo.bar.bd") => t -;; (url-domsuf-cookie-allowed-p "bar.bd") => nil -;; (url-domsuf-cookie-allowed-p "co.uk") => nil -;; (url-domsuf-cookie-allowed-p "foo.bar.hokkaido.jo") => t -;; (url-domsuf-cookie-allowed-p "bar.yokohama.jp") => nil -;; (url-domsuf-cookie-allowed-p "city.yokohama.jp") => t - (provide 'url-domsuf) ;;; url-domsuf.el ends here diff --git a/lisp/wdired.el b/lisp/wdired.el index 40f4cd97190..da162b7bb29 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -255,7 +255,7 @@ See `wdired-mode'." (setq buffer-read-only nil) (dired-unadvertise default-directory) (add-hook 'kill-buffer-hook 'wdired-check-kill-buffer nil t) - (add-hook 'after-change-functions 'wdired--restore-dired-filename-prop nil t) + (add-hook 'after-change-functions 'wdired--restore-properties nil t) (setq major-mode 'wdired-mode) (setq mode-name "Editable Dired") (setq revert-buffer-function 'wdired-revert) @@ -266,7 +266,7 @@ See `wdired-mode'." (wdired-preprocess-files) (if wdired-allow-to-change-permissions (wdired-preprocess-perms)) - (if (and wdired-allow-to-redirect-links (fboundp 'make-symbolic-link)) + (if (fboundp 'make-symbolic-link) (wdired-preprocess-symlinks)) (buffer-enable-undo) ; Performance hack. See above. (set-buffer-modified-p nil) @@ -288,6 +288,7 @@ or \\[wdired-abort-changes] to abort changes"))) (save-excursion (goto-char (point-min)) (let ((b-protection (point)) + (used-F (dired-check-switches dired-actual-switches "F" "classify")) filename) (while (not (eobp)) (setq filename (dired-get-filename nil t)) @@ -299,8 +300,16 @@ or \\[wdired-abort-changes] to abort changes"))) (add-text-properties (1- (point)) (point) `(old-name ,filename rear-nonsticky (read-only))) (put-text-property b-protection (point) 'read-only t) - (setq b-protection (dired-move-to-end-of-filename t)) + (dired-move-to-end-of-filename t) (put-text-property (point) (1+ (point)) 'end-name t)) + (when (and used-F (looking-at "[*/@|=>]$")) (forward-char)) + (when (save-excursion + (and (re-search-backward + dired-permission-flags-regexp nil t) + (looking-at "l") + (search-forward " -> " (line-end-position) t))) + (goto-char (line-end-position))) + (setq b-protection (point)) (forward-line)) (put-text-property b-protection (point-max) 'read-only t)))) @@ -327,7 +336,8 @@ relies on WDired buffer's properties. Optional arg NO-DIR with value non-nil means don't include directory. Optional arg OLD with value non-nil means return old filename." ;; FIXME: Use dired-get-filename's new properties. - (let (beg end file) + (let ((used-F (dired-check-switches dired-actual-switches "F" "classify")) + beg end file) (save-excursion (setq end (line-end-position)) (beginning-of-line) @@ -339,7 +349,20 @@ non-nil means return old filename." ;; the filename end is found even when the filename is empty. ;; Fixes error and spurious newlines when marking files for ;; deletion. - (setq end (next-single-property-change beg 'end-name)) + (setq end (next-single-property-change beg 'end-name nil end)) + (when (save-excursion + (and (re-search-forward + dired-permission-flags-regexp nil t) + (goto-char (match-beginning 0)) + (looking-at "l") + (search-forward " -> " (line-end-position) t))) + (goto-char (match-beginning 0)) + (setq end (point))) + (when (and used-F + (save-excursion + (goto-char end) + (looking-back "[*/@|=>]$" (1- (point))))) + (setq end (1- end))) (setq file (buffer-substring-no-properties (1+ beg) end))) ;; Don't unquote the old name, it wasn't quoted in the first place (and file (setq file (wdired-normalize-filename file (not old))))) @@ -366,7 +389,7 @@ non-nil means return old filename." (setq mode-name "Dired") (dired-advertise) (remove-hook 'kill-buffer-hook 'wdired-check-kill-buffer t) - (remove-hook 'after-change-functions 'wdired--restore-dired-filename-prop t) + (remove-hook 'after-change-functions 'wdired--restore-properties t) (set (make-local-variable 'revert-buffer-function) 'dired-revert)) @@ -427,9 +450,9 @@ non-nil means return old filename." (when files-renamed (setq errors (+ errors (wdired-do-renames files-renamed)))) ;; We have to be in wdired-mode when wdired-do-renames is executed - ;; so that wdired--restore-dired-filename-prop runs, but we have - ;; to change back to dired-mode before reverting the buffer to - ;; avoid using wdired-revert, which changes back to wdired-mode. + ;; so that wdired--restore-properties runs, but we have to change + ;; back to dired-mode before reverting the buffer to avoid using + ;; wdired-revert, which changes back to wdired-mode. (wdired-change-to-dired-mode) (if changes (progn @@ -451,7 +474,11 @@ non-nil means return old filename." '(old-name nil end-name nil old-link nil end-link nil end-perm nil old-perm nil perm-changed nil)) - (message "(No changes to be performed)"))) + (message "(No changes to be performed)") + ;; Deleting file indicator characters or editing the symlink + ;; arrow in WDired are noops, so redisplay them immediately on + ;; returning to Dired. + (revert-buffer))) (when files-deleted (wdired-flag-for-deletion files-deleted)) (when (> errors 0) @@ -609,14 +636,24 @@ Optional arguments are ignored." ;; dired-filename text property, which allows functions that look for ;; this property (e.g. dired-isearch-filenames) to work in wdired-mode ;; and also avoids an error with non-nil wdired-use-interactive-rename -;; (bug#32173). -(defun wdired--restore-dired-filename-prop (beg end _len) +;; (bug#32173). Also prevents editing the symlink arrow (which is a +;; noop) from corrupting the link name (see bug#18475 for elaboration). +(defun wdired--restore-properties (beg end _len) (save-match-data (save-excursion (let ((lep (line-end-position)) (used-F (dired-check-switches dired-actual-switches "F" "classify"))) + ;; Deleting the space between the link name and the arrow (a + ;; noop) also deletes the end-name property, so restore it. + (when (and (save-excursion + (re-search-backward dired-permission-flags-regexp nil t) + (looking-at "l")) + (get-text-property (1- (point)) 'dired-filename) + (not (get-text-property (point) 'dired-filename)) + (not (get-text-property (point) 'end-name))) + (put-text-property (point) (1+ (point)) 'end-name t)) (beginning-of-line) (when (re-search-forward directory-listing-before-filename-regexp lep t) @@ -680,33 +717,36 @@ says how many lines to move; default is one line." (save-excursion (goto-char (point-min)) (while (not (eobp)) - (if (looking-at dired-re-sym) - (progn - (re-search-forward " -> \\(.*\\)$") - (put-text-property (- (match-beginning 1) 2) - (1- (match-beginning 1)) 'old-link - (match-string-no-properties 1)) - (put-text-property (match-end 1) (1+ (match-end 1)) 'end-link t) - (put-text-property (1- (match-beginning 1)) - (match-beginning 1) - 'rear-nonsticky '(read-only)) - (put-text-property (match-beginning 1) - (match-end 1) 'read-only nil))) + (when (looking-at dired-re-sym) + (re-search-forward " -> \\(.*\\)$") + (put-text-property (1- (match-beginning 1)) + (match-beginning 1) 'old-link + (match-string-no-properties 1)) + (put-text-property (match-end 1) (1+ (match-end 1)) 'end-link t) + (unless wdired-allow-to-redirect-links + (put-text-property (match-beginning 0) + (match-end 1) 'read-only t))) (forward-line))))) - (defun wdired-get-previous-link (&optional old move) "Return the next symlink target. If OLD, return the old target. If MOVE, move point before it." (let (beg end target) (setq beg (previous-single-property-change (point) 'old-link nil)) - (if beg - (progn - (if old - (setq target (get-text-property (1- beg) 'old-link)) - (setq end (next-single-property-change beg 'end-link)) - (setq target (buffer-substring-no-properties (1+ beg) end))) - (if move (goto-char (1- beg))))) + (when beg + (when (save-excursion + (goto-char beg) + (and (looking-at " ") + (looking-back " ->" (line-beginning-position)))) + (setq beg (1+ beg))) + (if old + (setq target (get-text-property (1- beg) 'old-link)) + (setq end (save-excursion + (goto-char beg) + (next-single-property-change beg 'end-link nil + (line-end-position)))) + (setq target (buffer-substring-no-properties beg end))) + (if move (goto-char (1- beg)))) (and target (wdired-normalize-filename target t)))) (declare-function make-symbolic-link "fileio.c") |