summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/autoload.el5
-rw-r--r--lisp/emacs-lisp/byte-run.el3
-rw-r--r--lisp/emacs-lisp/bytecomp.el21
-rw-r--r--lisp/emacs-lisp/cconv.el15
-rw-r--r--lisp/emacs-lisp/cl-indent.el1
-rw-r--r--lisp/emacs-lisp/cl-macs.el21
-rw-r--r--lisp/emacs-lisp/ert.el111
-rw-r--r--lisp/emacs-lisp/gv.el4
-rw-r--r--lisp/emacs-lisp/helpers.el42
-rw-r--r--lisp/emacs-lisp/lisp-mode.el19
-rw-r--r--lisp/emacs-lisp/nadvice.el2
-rw-r--r--lisp/emacs-lisp/package.el37
-rw-r--r--lisp/emacs-lisp/smie.el372
13 files changed, 568 insertions, 85 deletions
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el
index e531bc0bdae..f94f74a5652 100644
--- a/lisp/emacs-lisp/autoload.el
+++ b/lisp/emacs-lisp/autoload.el
@@ -528,6 +528,9 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE
(if (stringp generated-autoload-load-name)
generated-autoload-load-name
(autoload-file-load-name absfile)))
+ ;; FIXME? Comparing file-names for equality with just equal
+ ;; is fragile, eg if one has an automounter prefix and one
+ ;; does not, but both refer to the same physical file.
(when (and outfile
(not
(if (memq system-type '(ms-dos windows-nt))
@@ -553,7 +556,7 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE
(princ `(push (purecopy
',(cons (intern package) version))
package--builtin-versions))
- (newline)))))
+ (princ "\n")))))
(goto-char (point-min))
(while (not (eobp))
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 0bb04950dfd..7ec24cc2aad 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -118,6 +118,7 @@ the FUN corresponding to PROP is called with the function name
and the VALUES and should return the code to use to set this property.")
(put 'defmacro 'doc-string-elt 3)
+(put 'defmacro 'lisp-indent-function 2)
(defalias 'defmacro
(cons
'macro
@@ -179,7 +180,7 @@ The return value is undefined.
;; (defun foo (arg) (toto) nil)
;; from
;; (defun foo (arg) (toto)).
- (declare (doc-string 3))
+ (declare (doc-string 3) (indent 2))
(let ((decls (cond
((eq (car-safe docstring) 'declare)
(prog1 (cdr docstring) (setq docstring nil)))
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 35c7c391870..e0d474bbb9f 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -3175,6 +3175,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
'((0 . byte-compile-no-args)
(1 . byte-compile-one-arg)
(2 . byte-compile-two-args)
+ (2-and . byte-compile-and-folded)
(3 . byte-compile-three-args)
(0-1 . byte-compile-zero-or-one-arg)
(1-2 . byte-compile-one-or-two-args)
@@ -3256,11 +3257,11 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
(byte-defop-compiler cons 2)
(byte-defop-compiler aref 2)
(byte-defop-compiler set 2)
-(byte-defop-compiler (= byte-eqlsign) 2)
-(byte-defop-compiler (< byte-lss) 2)
-(byte-defop-compiler (> byte-gtr) 2)
-(byte-defop-compiler (<= byte-leq) 2)
-(byte-defop-compiler (>= byte-geq) 2)
+(byte-defop-compiler (= byte-eqlsign) 2-and)
+(byte-defop-compiler (< byte-lss) 2-and)
+(byte-defop-compiler (> byte-gtr) 2-and)
+(byte-defop-compiler (<= byte-leq) 2-and)
+(byte-defop-compiler (>= byte-geq) 2-and)
(byte-defop-compiler get 2)
(byte-defop-compiler nth 2)
(byte-defop-compiler substring 2-3)
@@ -3324,6 +3325,16 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
(byte-compile-form (nth 2 form))
(byte-compile-out (get (car form) 'byte-opcode) 0)))
+(defun byte-compile-and-folded (form)
+ "Compile calls to functions like `<='.
+These implicitly `and' together a bunch of two-arg bytecodes."
+ (let ((l (length form)))
+ (cond
+ ((< l 3) (byte-compile-form `(progn ,(nth 1 form) t)))
+ ((= l 3) (byte-compile-two-args form))
+ (t (byte-compile-form `(and (,(car form) ,(nth 1 form) ,(nth 2 form))
+ (,(car form) ,@(nthcdr 2 form))))))))
+
(defun byte-compile-three-args (form)
(if (not (= (length form) 4))
(byte-compile-subr-wrong-args form 3)
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index f24e503fd6d..f4f55667729 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -289,12 +289,15 @@ places where they originally did not directly appear."
(dolist (binder binders)
(let* ((value nil)
- (var (if (not (consp binder))
- (prog1 binder (setq binder (list binder)))
- (setq value (cadr binder))
- (car binder)))
- (new-val
- (cond
+ (var (if (not (consp binder))
+ (prog1 binder (setq binder (list binder)))
+ (when (cddr binder)
+ (byte-compile-log-warning
+ (format "Malformed `%S' binding: %S" letsym binder)))
+ (setq value (cadr binder))
+ (car binder)))
+ (new-val
+ (cond
;; Check if var is a candidate for lambda lifting.
((and (member (cons binder form) cconv-lambda-candidates)
(progn
diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el
index bbfe9ec6424..cc7d2a88e61 100644
--- a/lisp/emacs-lisp/cl-indent.el
+++ b/lisp/emacs-lisp/cl-indent.el
@@ -756,6 +756,7 @@ optional\\|rest\\|key\\|allow-other-keys\\|aux\\|whole\\|body\\|environment\
(when 1)
(with-accessors . multiple-value-bind)
(with-condition-restarts . multiple-value-bind)
+ (with-compilation-unit (&lambda &body))
(with-output-to-string (4 2))
(with-slots . multiple-value-bind)
(with-standard-io-syntax (2)))))
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 60fdc09c053..2209297d553 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -1992,11 +1992,18 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
(unwind-protect
(progn
(fset 'macroexpand #'cl--sm-macroexpand)
- ;; FIXME: For N bindings, this will traverse `body' N times!
- (macroexpand-all (cons 'progn body)
- (cons (list (symbol-name (caar bindings))
- (cl-cadar bindings))
- macroexpand-all-environment)))
+ (let ((expansion
+ ;; FIXME: For N bindings, this will traverse `body' N times!
+ (macroexpand-all (macroexp-progn body)
+ (cons (list (symbol-name (caar bindings))
+ (cl-cadar bindings))
+ macroexpand-all-environment))))
+ (if (or (null (cdar bindings)) (cl-cddar bindings))
+ (macroexp--warn-and-return
+ (format "Malformed `cl-symbol-macrolet' binding: %S"
+ (car bindings))
+ expansion)
+ expansion)))
(fset 'macroexpand previous-macroexpand))))))
;;; Multiple values.
@@ -2726,12 +2733,12 @@ macro that returns its `&whole' argument."
(let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil))
(cl--active-block-names (cons cl-entry cl--active-block-names))
(cl-body (macroexpand-all ;Performs compiler-macro expansions.
- (cons 'progn (cddr cl-form))
+ (macroexp-progn (cddr cl-form))
macroexpand-all-environment)))
;; FIXME: To avoid re-applying macroexpand-all, we'd like to be able
;; to indicate that this return value is already fully expanded.
(if (cdr cl-entry)
- `(catch ,(nth 1 cl-form) ,@(cdr cl-body))
+ `(catch ,(nth 1 cl-form) ,@(macroexp-unprogn cl-body))
cl-body)))
(cl-define-compiler-macro cl--block-throw (cl-tag cl-value)
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 409e4faf4d5..a131f48c488 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -34,14 +34,17 @@
;; `ert-run-tests-batch-and-exit' for non-interactive use.
;;
;; The body of `ert-deftest' forms resembles a function body, but the
-;; additional operators `should', `should-not' and `should-error' are
-;; available. `should' is similar to cl's `assert', but signals a
-;; different error when its condition is violated that is caught and
-;; processed by ERT. In addition, it analyzes its argument form and
-;; records information that helps debugging (`assert' tries to do
-;; something similar when its second argument SHOW-ARGS is true, but
-;; `should' is more sophisticated). For information on `should-not'
-;; and `should-error', see their docstrings.
+;; additional operators `should', `should-not', `should-error' and
+;; `skip-unless' are available. `should' is similar to cl's `assert',
+;; but signals a different error when its condition is violated that
+;; is caught and processed by ERT. In addition, it analyzes its
+;; argument form and records information that helps debugging
+;; (`assert' tries to do something similar when its second argument
+;; SHOW-ARGS is true, but `should' is more sophisticated). For
+;; information on `should-not' and `should-error', see their
+;; docstrings. `skip-unless' skips the test immediately without
+;; processing further, this is useful for checking the test
+;; environment (like availability of features, external binaries, etc).
;;
;; See ERT's info manual as well as the docstrings for more details.
;; To compile the manual, run `makeinfo ert.texinfo' in the ERT
@@ -174,8 +177,8 @@ and the body."
BODY is evaluated as a `progn' when the test is run. It should
signal a condition on failure or just return if the test passes.
-`should', `should-not' and `should-error' are useful for
-assertions in BODY.
+`should', `should-not', `should-error' and `skip-unless' are
+useful for assertions in BODY.
Use `ert' to run tests interactively.
@@ -200,7 +203,7 @@ description of valid values for RESULT-TYPE.
(tags nil tags-supplied-p))
body)
(ert--parse-keys-and-body docstring-keys-and-body)
- `(progn
+ `(cl-macrolet ((skip-unless (form) `(ert--skip-unless ,form)))
(ert-set-test ',name
(make-ert-test
:name ',name
@@ -237,6 +240,7 @@ description of valid values for RESULT-TYPE.
(define-error 'ert-test-failed "Test failed")
+(define-error 'ert-test-skipped "Test skipped")
(defun ert-pass ()
"Terminate the current test and mark it passed. Does not return."
@@ -247,6 +251,11 @@ description of valid values for RESULT-TYPE.
DATA is displayed to the user and should state the reason of the failure."
(signal 'ert-test-failed (list data)))
+(defun ert-skip (data)
+ "Terminate the current test and mark it skipped. Does not return.
+DATA is displayed to the user and should state the reason for skipping."
+ (signal 'ert-test-skipped (list data)))
+
;;; The `should' macros.
@@ -425,6 +434,15 @@ failed."
(list
:fail-reason "did not signal an error")))))))))
+(cl-defmacro ert--skip-unless (form)
+ "Evaluate FORM. If it returns nil, skip the current test.
+Errors during evaluation are caught and handled like nil."
+ (declare (debug t))
+ (ert--expand-should `(skip-unless ,form) form
+ (lambda (inner-form form-description-form _value-var)
+ `(unless (ignore-errors ,inner-form)
+ (ert-skip ,form-description-form)))))
+
;;; Explanation of `should' failures.
@@ -644,6 +662,7 @@ and is displayed in front of the value of MESSAGE-FORM."
(infos (cl-assert nil)))
(cl-defstruct (ert-test-quit (:include ert-test-result-with-condition)))
(cl-defstruct (ert-test-failed (:include ert-test-result-with-condition)))
+(cl-defstruct (ert-test-skipped (:include ert-test-result-with-condition)))
(cl-defstruct (ert-test-aborted-with-non-local-exit
(:include ert-test-result)))
@@ -728,6 +747,7 @@ run. ARGS are the arguments to `debugger'."
(let* ((condition (car more-debugger-args))
(type (cl-case (car condition)
((quit) 'quit)
+ ((ert-test-skipped) 'skipped)
(otherwise 'failed)))
(backtrace (ert--record-backtrace))
(infos (reverse ert--infos)))
@@ -737,6 +757,10 @@ run. ARGS are the arguments to `debugger'."
(make-ert-test-quit :condition condition
:backtrace backtrace
:infos infos))
+ (skipped
+ (make-ert-test-skipped :condition condition
+ :backtrace backtrace
+ :infos infos))
(failed
(make-ert-test-failed :condition condition
:backtrace backtrace
@@ -862,7 +886,7 @@ Valid result types:
nil -- Never matches.
t -- Always matches.
-:failed, :passed -- Matches corresponding results.
+:failed, :passed, :skipped -- Matches corresponding results.
\(and TYPES...\) -- Matches if all TYPES match.
\(or TYPES...\) -- Matches if some TYPES match.
\(not TYPE\) -- Matches if TYPE does not match.
@@ -875,6 +899,7 @@ t -- Always matches.
((member t) t)
((member :failed) (ert-test-failed-p result))
((member :passed) (ert-test-passed-p result))
+ ((member :skipped) (ert-test-skipped-p result))
(cons
(cl-destructuring-bind (operator &rest operands) result-type
(cl-ecase operator
@@ -899,7 +924,9 @@ t -- Always matches.
(defun ert-test-result-expected-p (test result)
"Return non-nil if TEST's expected result type matches RESULT."
- (ert-test-result-type-p result (ert-test-expected-result-type test)))
+ (or
+ (ert-test-result-type-p result :skipped)
+ (ert-test-result-type-p result (ert-test-expected-result-type test))))
(defun ert-select-tests (selector universe)
"Return a list of tests that match SELECTOR.
@@ -1085,6 +1112,7 @@ contained in UNIVERSE."
(passed-unexpected 0)
(failed-expected 0)
(failed-unexpected 0)
+ (skipped 0)
(start-time nil)
(end-time nil)
(aborted-p nil)
@@ -1103,10 +1131,15 @@ contained in UNIVERSE."
(+ (ert--stats-passed-unexpected stats)
(ert--stats-failed-unexpected stats)))
+(defun ert-stats-skipped (stats)
+ "Number of tests in STATS that have skipped."
+ (ert--stats-skipped stats))
+
(defun ert-stats-completed (stats)
"Number of tests in STATS that have run so far."
(+ (ert-stats-completed-expected stats)
- (ert-stats-completed-unexpected stats)))
+ (ert-stats-completed-unexpected stats)
+ (ert-stats-skipped stats)))
(defun ert-stats-total (stats)
"Number of tests in STATS, regardless of whether they have run yet."
@@ -1138,6 +1171,8 @@ Also changes the counters in STATS to match."
(cl-incf (ert--stats-passed-expected stats) d))
(ert-test-failed
(cl-incf (ert--stats-failed-expected stats) d))
+ (ert-test-skipped
+ (cl-incf (ert--stats-skipped stats) d))
(null)
(ert-test-aborted-with-non-local-exit)
(ert-test-quit))
@@ -1146,6 +1181,8 @@ Also changes the counters in STATS to match."
(cl-incf (ert--stats-passed-unexpected stats) d))
(ert-test-failed
(cl-incf (ert--stats-failed-unexpected stats) d))
+ (ert-test-skipped
+ (cl-incf (ert--stats-skipped stats) d))
(null)
(ert-test-aborted-with-non-local-exit)
(ert-test-quit)))))
@@ -1240,6 +1277,7 @@ EXPECTEDP specifies whether the result was expected."
(let ((s (cl-etypecase result
(ert-test-passed ".P")
(ert-test-failed "fF")
+ (ert-test-skipped "sS")
(null "--")
(ert-test-aborted-with-non-local-exit "aA")
(ert-test-quit "qQ"))))
@@ -1252,6 +1290,7 @@ EXPECTEDP specifies whether the result was expected."
(let ((s (cl-etypecase result
(ert-test-passed '("passed" "PASSED"))
(ert-test-failed '("failed" "FAILED"))
+ (ert-test-skipped '("skipped" "SKIPPED"))
(null '("unknown" "UNKNOWN"))
(ert-test-aborted-with-non-local-exit '("aborted" "ABORTED"))
(ert-test-quit '("quit" "QUIT")))))
@@ -1318,8 +1357,9 @@ Returns the stats object."
(run-ended
(cl-destructuring-bind (stats abortedp) event-args
(let ((unexpected (ert-stats-completed-unexpected stats))
- (expected-failures (ert--stats-failed-expected stats)))
- (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n"
+ (skipped (ert-stats-skipped stats))
+ (expected-failures (ert--stats-failed-expected stats)))
+ (message "\n%sRan %s tests, %s results as expected%s%s (%s)%s\n"
(if (not abortedp)
""
"Aborted: ")
@@ -1328,6 +1368,9 @@ Returns the stats object."
(if (zerop unexpected)
""
(format ", %s unexpected" unexpected))
+ (if (zerop skipped)
+ ""
+ (format ", %s skipped" skipped))
(ert--format-time-iso8601 (ert--stats-end-time stats))
(if (zerop expected-failures)
""
@@ -1340,6 +1383,15 @@ Returns the stats object."
(message "%9s %S"
(ert-string-for-test-result result nil)
(ert-test-name test))))
+ (message "%s" ""))
+ (unless (zerop skipped)
+ (message "%s skipped results:" skipped)
+ (cl-loop for test across (ert--stats-tests stats)
+ for result = (ert-test-most-recent-result test) do
+ (when (ert-test-result-type-p result :skipped)
+ (message "%9s %S"
+ (ert-string-for-test-result result nil)
+ (ert-test-name test))))
(message "%s" "")))))
(test-started
)
@@ -1562,15 +1614,17 @@ Also sets `ert--results-progress-bar-button-begin'."
(ert--insert-human-readable-selector (ert--stats-selector stats))
(insert "\n")
(insert
- (format (concat "Passed: %s\n"
- "Failed: %s\n"
- "Total: %s/%s\n\n")
+ (format (concat "Passed: %s\n"
+ "Failed: %s\n"
+ "Skipped: %s\n"
+ "Total: %s/%s\n\n")
(ert--results-format-expected-unexpected
(ert--stats-passed-expected stats)
(ert--stats-passed-unexpected stats))
(ert--results-format-expected-unexpected
(ert--stats-failed-expected stats)
(ert--stats-failed-unexpected stats))
+ (ert-stats-skipped stats)
run-count
(ert-stats-total stats)))
(insert
@@ -1827,11 +1881,11 @@ and how to display message."
;; defined without cl.
(car ert--selector-history)
"t")))
- (read-from-minibuffer (if (null default)
- "Run tests: "
- (format "Run tests (default %s): " default))
- nil nil t 'ert--selector-history
- default nil))
+ (completing-read (if (null default)
+ "Run tests: "
+ (format "Run tests (default %s): " default))
+ obarray #'ert-test-boundp nil nil
+ 'ert--selector-history default nil))
nil))
(unless message-fn (setq message-fn 'message))
(let ((output-buffer-name output-buffer-name)
@@ -1850,7 +1904,7 @@ and how to display message."
(run-ended
(cl-destructuring-bind (stats abortedp) event-args
(funcall message-fn
- "%sRan %s tests, %s results were as expected%s"
+ "%sRan %s tests, %s results were as expected%s%s"
(if (not abortedp)
""
"Aborted: ")
@@ -1860,7 +1914,12 @@ and how to display message."
(ert-stats-completed-unexpected stats)))
(if (zerop unexpected)
""
- (format ", %s unexpected" unexpected))))
+ (format ", %s unexpected" unexpected)))
+ (let ((skipped
+ (ert-stats-skipped stats)))
+ (if (zerop skipped)
+ ""
+ (format ", %s skipped" skipped))))
(ert--results-update-stats-display (with-current-buffer buffer
ert--results-ewoc)
stats)))
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index 8a5841a5fad..1a3800597a6 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -346,6 +346,10 @@ The return value is the last VAL in the list.
(gv-define-simple-setter window-point set-window-point)
(gv-define-simple-setter window-start set-window-start)
+(gv-define-setter buffer-local-value (val var buf)
+ (macroexp-let2 nil v val
+ `(with-current-buffer ,buf (set (make-local-variable ,var) ,v))))
+
;;; Some occasionally handy extensions.
;; While several of the "places" below are not terribly useful for direct use,
diff --git a/lisp/emacs-lisp/helpers.el b/lisp/emacs-lisp/helpers.el
new file mode 100644
index 00000000000..73c2ff1c15c
--- /dev/null
+++ b/lisp/emacs-lisp/helpers.el
@@ -0,0 +1,42 @@
+;;; helpers.el --- Some non-essential library extensions -*- lexical-binding:t -*-
+
+;; Copyright (C) 2013 Free Software Foundation, Inc.
+
+;; Maintainer: FSF
+;; Keywords: convenience
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(defsubst hash-table-keys (hash-table)
+ "Return a list of keys in HASH-TABLE."
+ (let ((keys '()))
+ (maphash (lambda (k _v) (push k keys)) hash-table)
+ keys))
+
+(defsubst hash-table-values (hash-table)
+ "Return a list of values in HASH-TABLE."
+ (let ((values '()))
+ (maphash (lambda (_k v) (push v values)) hash-table)
+ values))
+
+(provide 'helpers)
+
+;;; helpers.el ends here
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 0b82efab122..f4e9b311acc 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -251,9 +251,7 @@ It has `lisp-mode-abbrev-table' as its parent."
(cons "go" (mapcar (lambda (s) (concat "cl-" s))
(remove "go" cl-lib-kw))))
t)
- (regexp-opt (append lisp-kw el-kw eieio-kw
- (cons "go" (mapcar (lambda (s) (concat "cl-" s))
- (remove "go" cl-kw))))
+ (regexp-opt (append lisp-kw cl-kw eieio-kw cl-lib-kw)
t)
;; Elisp and Common Lisp "errors".
@@ -360,7 +358,7 @@ It has `lisp-mode-abbrev-table' as its parent."
;; Control structures. Common Lisp forms.
(,(concat "(" cl-kws-re "\\_>") . 1)
;; Exit/Feature symbols as constants.
- (,(concat "(\\(catch\\|throw\\|featurep\\|provide\\|require\\)\\_>"
+ (,(concat "(\\(catch\\|throw\\|provide\\|require\\)\\_>"
"[ \t']*\\(\\(?:\\sw\\|\\s_\\)+\\)?")
(1 font-lock-keyword-face)
(2 font-lock-constant-face nil t))
@@ -702,9 +700,7 @@ Commands:
Delete converts tabs to spaces as it moves back.
Blank lines separate paragraphs. Semicolons start comments.
-\\{emacs-lisp-mode-map}
-Entry to this mode calls the value of `emacs-lisp-mode-hook'
-if that value is non-nil."
+\\{emacs-lisp-mode-map}"
:group 'lisp
(lisp-mode-variables nil nil 'elisp)
(setq imenu-case-fold-search nil)
@@ -794,10 +790,7 @@ Blank lines separate paragraphs. Semicolons start comments.
\\{lisp-mode-map}
Note that `run-lisp' may be used either to start an inferior Lisp job
-or to switch back to an existing one.
-
-Entry to this mode calls the value of `lisp-mode-hook'
-if that value is non-nil."
+or to switch back to an existing one."
(lisp-mode-variables nil t)
(setq-local find-tag-default-function 'lisp-find-tag-default)
(setq-local comment-start-skip
@@ -862,9 +855,7 @@ Delete converts tabs to spaces as it moves back.
Paragraphs are separated only by blank lines.
Semicolons start comments.
-\\{lisp-interaction-mode-map}
-Entry to this mode calls the value of `lisp-interaction-mode-hook'
-if that value is non-nil."
+\\{lisp-interaction-mode-map}"
:abbrev-table nil)
(defun eval-print-last-sexp ()
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
index 576e72088e9..0352164caf5 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -284,7 +284,7 @@ of the piece of advice."
(cond ((eq 'local (car-safe place))
(setq place `(advice--buffer-local ,@(cdr place))))
((symbolp place)
- (error "Use (default-value '%S) or (local '%S)" place place)))
+ (setq place `(default-value ',place))))
(gv-letplace (getter setter) place
(macroexp-let2 nil new `(advice--remove-function ,getter ,function)
`(unless (eq ,new ,getter) ,(funcall setter new)))))
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index cdf210498ce..e8768ea6ac9 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -429,7 +429,7 @@ This is, approximately, the inverse of `version-to-list'.
((>= num 0)
(push (int-to-string num) str-list)
(push "." str-list))
- ((< num -3)
+ ((< num -4)
(error "Invalid version list `%s'" vlist))
(t
;; pre, or beta, or alpha
@@ -439,7 +439,8 @@ This is, approximately, the inverse of `version-to-list'.
(error "Invalid version list `%s'" vlist)))
(push (cond ((= num -1) "pre")
((= num -2) "beta")
- ((= num -3) "alpha"))
+ ((= num -3) "alpha")
+ ((= num -4) "snapshot"))
str-list))))
(if (equal "." (car str-list))
(pop str-list))
@@ -1101,6 +1102,8 @@ Otherwise return nil."
str)
(error nil))))
+(declare-function lm-homepage "lisp-mnt" (&optional file))
+
(defun package-buffer-info ()
"Return a `package-desc' describing the package in the current buffer.
@@ -1238,7 +1241,8 @@ similar to an entry in `package-alist'. Save the cached copy to
(when (listp (read buffer))
(make-directory dir t)
(setq buffer-file-name (expand-file-name file dir))
- (let ((version-control 'never))
+ (let ((version-control 'never)
+ (require-final-newline nil))
(save-buffer))))
(when good-signatures
;; Write out good signatures into archive-contents.signed file.
@@ -1472,15 +1476,17 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages."
;; For elpa packages, try downloading the commentary. If that
;; fails, try an existing readme file in `package-user-dir'.
(cond ((condition-case nil
- (package--with-work-buffer
- (package-archive-base desc)
- (format "%s-readme.txt" name)
- (setq buffer-file-name
- (expand-file-name readme package-user-dir))
- (let ((version-control 'never))
- (save-buffer))
- (setq readme-string (buffer-string))
- t)
+ (save-excursion
+ (package--with-work-buffer
+ (package-archive-base desc)
+ (format "%s-readme.txt" name)
+ (setq buffer-file-name
+ (expand-file-name readme package-user-dir))
+ (let ((version-control 'never)
+ (require-final-newline t))
+ (save-buffer))
+ (setq readme-string (buffer-string))
+ t))
(error nil))
(insert readme-string))
((file-readable-p readme)
@@ -1575,6 +1581,7 @@ Letters do not insert themselves; instead, they are commands.
(setq tabulated-list-format [("Package" 18 package-menu--name-predicate)
("Version" 12 nil)
("Status" 10 package-menu--status-predicate)
+ ("Archive" 10 package-menu--archive-predicate)
("Description" 0 nil)])
(setq tabulated-list-padding 2)
(setq tabulated-list-sort-key (cons "Status" nil))
@@ -1697,6 +1704,8 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])."
(package-desc-version pkg-desc))
'font-lock-face face)
(propertize status 'font-lock-face face)
+ (propertize (or (package-desc-archive pkg-desc) "")
+ 'font-lock-face face)
(propertize (package-desc-summary pkg-desc)
'font-lock-face face)))))
@@ -1913,6 +1922,10 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm."
(string< (symbol-name (package-desc-name (car A)))
(symbol-name (package-desc-name (car B)))))
+(defun package-menu--archive-predicate (A B)
+ (string< (or (package-desc-archive (car A)) "")
+ (or (package-desc-archive (car B)) "")))
+
;;;###autoload
(defun list-packages (&optional no-fetch)
"Display a list of packages.
diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el
index ebb82f4bf54..f025a8b400b 100644
--- a/lisp/emacs-lisp/smie.el
+++ b/lisp/emacs-lisp/smie.el
@@ -1236,14 +1236,7 @@ Only meaningful when called from within `smie-rules-function'."
(goto-char (cadr (smie-indent--parent)))
(cons 'column
(+ (or offset 0)
- ;; Use smie-indent-virtual when indenting relative to an opener:
- ;; this will also by default use current-column unless
- ;; that opener is hanging, but will additionally consult
- ;; rules-function, so it gives it a chance to tweak
- ;; indentation (e.g. by forcing indentation relative to
- ;; its own parent, as in fn a => fn b => fn c =>).
- (if (or (listp (car smie--parent)) (smie-indent--hanging-p))
- (smie-indent-virtual) (current-column))))))
+ (smie-indent-virtual)))))
(defvar smie-rule-separator-outdent 2)
@@ -1369,9 +1362,9 @@ BASE-POS is the position relative to which offsets should be applied."
((< 0 (length tok)) (assoc tok smie-grammar))
((looking-at "\\s(\\|\\s)\\(\\)")
(forward-char 1)
- (cons (buffer-substring (1- (point)) (point))
+ (cons (buffer-substring-no-properties (1- (point)) (point))
(if (match-end 1) '(0 nil) '(nil 0))))
- ((looking-at "\\s\"")
+ ((looking-at "\\s\"\\|\\s|")
(forward-sexp 1)
nil)
((eobp) nil)
@@ -1386,9 +1379,9 @@ BASE-POS is the position relative to which offsets should be applied."
;; 4 == open paren syntax, 5 == close.
((memq (setq class (syntax-class (syntax-after (1- (point))))) '(4 5))
(forward-char -1)
- (cons (buffer-substring (point) (1+ (point)))
+ (cons (buffer-substring-no-properties (point) (1+ (point)))
(if (eq class 4) '(nil 0) '(0 nil))))
- ((eq class 7)
+ ((memq class '(7 15))
(backward-sexp 1)
nil)
((bobp) nil)
@@ -1828,6 +1821,361 @@ KEYWORDS are additional arguments, which can use the following keywords:
(append smie-blink-matching-triggers
(delete-dups triggers)))))))
+(defun smie-edebug ()
+ "Instrument the `smie-rules-function' for Edebug."
+ (interactive)
+ (require 'edebug)
+ (if (symbolp smie-rules-function)
+ (edebug-instrument-function smie-rules-function)
+ (error "Sorry, don't know how to instrument a lambda expression")))
+
+(defun smie--next-indent-change ()
+ "Go to the next line that needs to be reindented (and reindent it)."
+ (interactive)
+ (while
+ (let ((tick (buffer-chars-modified-tick)))
+ (indent-according-to-mode)
+ (eq tick (buffer-chars-modified-tick)))
+ (forward-line 1)))
+
+;;; User configuration
+
+;; This is designed to be a completely independent "module", so we can play
+;; with various kinds of smie-config modules without having to change the core.
+
+;; This smie-config module is fairly primitive and suffers from serious
+;; restrictions:
+;; - You can only change a returned offset, so you can't change the offset
+;; passed to smie-rule-parent, nor can you change the object with which
+;; to align (in general).
+;; - The rewrite rule can only distinguish cases based on the kind+token arg
+;; and smie-rules-function's return value, so you can't distinguish cases
+;; where smie-rules-function returns the same value.
+;; - Since config-rules depend on the return value of smie-rules-function, any
+;; config change that modifies this return value (e.g. changing
+;; foo-indent-basic) ends up invalidating config-rules.
+;; This last one is a serious problem since it means that file-local
+;; config-rules will only work if the user hasn't changed foo-indent-basic.
+;; One possible way to change it is to modify smie-rules-functions so they can
+;; return special symbols like +, ++, -, etc. Or make them use a new
+;; smie-rule-basic function which can then be used to know when a returned
+;; offset was computed based on foo-indent-basic.
+
+(defvar-local smie-config--mode-local nil
+ "Indentation config rules installed for this major mode.
+Typically manipulated from the major-mode's hook.")
+(defvar-local smie-config--buffer-local nil
+ "Indentation config rules installed for this very buffer.
+E.g. provided via a file-local call to `smie-config-local'.")
+(defvar smie-config--trace nil
+ "Variable used to trace calls to `smie-rules-function'.")
+
+(defun smie-config--advice (orig kind token)
+ (let* ((ret (funcall orig kind token))
+ (sig (list kind token ret))
+ (brule (rassoc sig smie-config--buffer-local))
+ (mrule (rassoc sig smie-config--mode-local)))
+ (when smie-config--trace
+ (setq smie-config--trace (or brule mrule)))
+ (cond
+ (brule (car brule))
+ (mrule (car mrule))
+ (t ret))))
+
+(defun smie-config--mode-hook (rules)
+ (setq smie-config--mode-local
+ (append rules smie-config--mode-local))
+ (add-function :around (local 'smie-rules-function) #'smie-config--advice))
+
+(defvar smie-config--modefuns nil)
+
+(defun smie-config--setter (var value)
+ (setq-default var value)
+ (let ((old-modefuns smie-config--modefuns))
+ (setq smie-config--modefuns nil)
+ (pcase-dolist (`(,mode . ,rules) value)
+ (let ((modefunname (intern (format "smie-config--modefun-%s" mode))))
+ (fset modefunname (lambda () (smie-config--mode-hook rules)))
+ (push modefunname smie-config--modefuns)
+ (add-hook (intern (format "%s-hook" mode)) modefunname)))
+ ;; Neuter any left-over previously installed hook.
+ (dolist (modefun old-modefuns)
+ (unless (memq modefun smie-config--modefuns)
+ (fset modefun #'ignore)))))
+
+(defcustom smie-config nil
+ ;; FIXME: there should be a file-local equivalent.
+ "User configuration of SMIE indentation.
+This is a list of elements (MODE . RULES), where RULES is a list
+of elements describing when and how to change the indentation rules.
+Each RULE element should be of the form (NEW KIND TOKEN NORMAL),
+where KIND and TOKEN are the elements passed to `smie-rules-function',
+NORMAL is the value returned by `smie-rules-function' and NEW is the
+value with which to replace it."
+ :set #'smie-config--setter)
+
+(defun smie-config-local (rules)
+ "Add RULES as local indentation rules to use in this buffer.
+These replace any previous local rules, but supplement the rules
+specified in `smie-config'."
+ (setq smie-config--buffer-local rules)
+ (add-function :around (local 'smie-rules-function) #'smie-config--advice))
+
+;; Make it so we can set those in the file-local block.
+;; FIXME: Better would be to be able to write "smie-config-local: (...)" rather
+;; than "eval: (smie-config-local '(...))".
+(put 'smie-config-local 'safe-local-eval-function t)
+
+(defun smie-config--get-trace ()
+ (save-excursion
+ (forward-line 0)
+ (skip-chars-forward " \t")
+ (let* ((trace ())
+ (srf-fun (lambda (orig kind token)
+ (let* ((pos (point))
+ (smie-config--trace t)
+ (res (funcall orig kind token)))
+ (push (if (consp smie-config--trace)
+ (list pos kind token res smie-config--trace)
+ (list pos kind token res))
+ trace)
+ res))))
+ (unwind-protect
+ (progn
+ (add-function :around (local 'smie-rules-function) srf-fun)
+ (cons (smie-indent-calculate)
+ trace))
+ (remove-function (local 'smie-rules-function) srf-fun)))))
+
+(defun smie-config-show-indent (&optional arg)
+ "Display the SMIE rules that are used to indent the current line.
+If prefix ARG is given, then move briefly point to the buffer
+position corresponding to each rule."
+ (interactive "P")
+ (let ((trace (cdr (smie-config--get-trace))))
+ (cond
+ ((null trace) (message "No SMIE rules involved"))
+ ((not arg)
+ (message "Rules used: %s"
+ (mapconcat (lambda (elem)
+ (pcase-let ((`(,_pos ,kind ,token ,res ,rewrite)
+ elem))
+ (format "%S %S -> %S%s" kind token res
+ (if (null rewrite) ""
+ (format "(via %S)" (nth 3 rewrite))))))
+ trace
+ ", ")))
+ (t
+ (save-excursion
+ (pcase-dolist (`(,pos ,kind ,token ,res ,rewrite) trace)
+ (message "%S %S -> %S%s" kind token res
+ (if (null rewrite) ""
+ (format "(via %S)" (nth 3 rewrite))))
+ (goto-char pos)
+ (sit-for blink-matching-delay)))))))
+
+(defun smie-config--guess-value (sig)
+ (add-function :around (local 'smie-rules-function) #'smie-config--advice)
+ (let* ((rule (cons 0 sig))
+ (smie-config--buffer-local (cons rule smie-config--buffer-local))
+ (goal (current-indentation))
+ (cur (smie-indent-calculate)))
+ (cond
+ ((and (eq goal
+ (progn (setf (car rule) (- goal cur))
+ (smie-indent-calculate))))
+ (- goal cur)))))
+
+(defun smie-config-set-indent ()
+ "Add a rule to adjust the indentation of current line."
+ (interactive)
+ (let* ((trace (cdr (smie-config--get-trace)))
+ (_ (unless trace (error "No SMIE rules involved")))
+ (sig (if (null (cdr trace))
+ (pcase-let* ((elem (car trace))
+ (`(,_pos ,kind ,token ,res ,rewrite) elem))
+ (list kind token (or (nth 3 rewrite) res)))
+ (let* ((choicestr
+ (completing-read
+ "Adjust rule: "
+ (mapcar (lambda (elem)
+ (format "%s %S"
+ (substring (symbol-name (cadr elem))
+ 1)
+ (nth 2 elem)))
+ trace)
+ nil t nil nil
+ nil)) ;FIXME: Provide good default!
+ (choicelst (car (read-from-string
+ (concat "(:" choicestr ")")))))
+ (catch 'found
+ (pcase-dolist (`(,_pos ,kind ,token ,res ,rewrite) trace)
+ (when (and (eq kind (car choicelst))
+ (equal token (nth 1 choicelst)))
+ (throw 'found (list kind token
+ (or (nth 3 rewrite) res)))))))))
+ (default-new (smie-config--guess-value sig))
+ (newstr (read-string (format "Adjust rule (%S %S -> %S) to%s: "
+ (nth 0 sig) (nth 1 sig) (nth 2 sig)
+ (if (not default-new) ""
+ (format " (default %S)" default-new)))
+ nil nil (format "%S" default-new)))
+ (new (car (read-from-string newstr))))
+ (let ((old (rassoc sig smie-config--buffer-local)))
+ (when old
+ (setq smie-config--buffer-local
+ (remove old smie-config--buffer-local))))
+ (push (cons new sig) smie-config--buffer-local)
+ (message "Added rule %S %S -> %S (via %S)"
+ (nth 0 sig) (nth 1 sig) new (nth 2 sig))
+ (add-function :around (local 'smie-rules-function) #'smie-config--advice)))
+
+(defun smie-config--guess (beg end)
+ (let ((otraces (make-hash-table :test #'equal))
+ (smie-config--buffer-local nil)
+ (smie-config--mode-local nil)
+ (pr (make-progress-reporter "Analyzing the buffer" beg end)))
+
+ ;; First, lets get the indentation traces and offsets for the region.
+ (save-excursion
+ (goto-char beg)
+ (forward-line 0)
+ (while (< (point) end)
+ (skip-chars-forward " \t")
+ (unless (eolp) ;Skip empty lines.
+ (progress-reporter-update pr (point))
+ (let* ((itrace (smie-config--get-trace))
+ (nindent (car itrace))
+ (trace (mapcar #'cdr (cdr itrace)))
+ (cur (current-indentation)))
+ (when (numberp nindent) ;Skip `noindent' and friends.
+ (cl-incf (gethash (cons (- cur nindent) trace) otraces 0)))))
+ (forward-line 1)))
+ (progress-reporter-done pr)
+
+ ;; Second, compile the data. Our algorithm only knows how to adjust rules
+ ;; where the smie-rules-function returns an integer. We call those
+ ;; "adjustable sigs". We build a table mapping each adjustable sig
+ ;; to its data, describing the total number of times we encountered it,
+ ;; the offsets found, and the traces in which it was found.
+ (message "Guessing...")
+ (let ((sigs (make-hash-table :test #'equal)))
+ (maphash (lambda (otrace count)
+ (let ((offset (car otrace))
+ (trace (cdr otrace))
+ (double nil))
+ (let ((sigs trace))
+ (while sigs
+ (let ((sig (pop sigs)))
+ (if (and (integerp (nth 2 sig)) (member sig sigs))
+ (setq double t)))))
+ (if double
+ ;; Disregard those traces where an adjustable sig
+ ;; appears twice, because the rest of the code assumes
+ ;; that adding a rule to add an offset N will change the
+ ;; end result by N rather than 2*N or more.
+ nil
+ (dolist (sig trace)
+ (if (not (integerp (nth 2 sig)))
+ ;; Disregard those sigs that return nil or a column,
+ ;; because our algorithm doesn't know how to adjust
+ ;; them anyway.
+ nil
+ (let ((sig-data (or (gethash sig sigs)
+ (let ((data (list 0 nil nil)))
+ (puthash sig data sigs)
+ data))))
+ (cl-incf (nth 0 sig-data) count)
+ (push (cons count otrace) (nth 2 sig-data))
+ (let ((sig-off-data
+ (or (assq offset (nth 1 sig-data))
+ (let ((off-data (cons offset 0)))
+ (push off-data (nth 1 sig-data))
+ off-data))))
+ (cl-incf (cdr sig-off-data) count))))))))
+ otraces)
+
+ ;; Finally, guess the indentation rules.
+ (let ((ssigs nil)
+ (rules nil))
+ ;; Sort the sigs by frequency of occurrence.
+ (maphash (lambda (sig sig-data) (push (cons sig sig-data) ssigs)) sigs)
+ (setq ssigs (sort ssigs (lambda (sd1 sd2) (> (cadr sd1) (cadr sd2)))))
+ (while ssigs
+ (pcase-let ((`(,sig ,total ,off-alist ,cotraces) (pop ssigs)))
+ (cl-assert (= total (apply #'+ (mapcar #'cdr off-alist))))
+ (let* ((sorted-off-alist
+ (sort off-alist (lambda (x y) (> (cdr x) (cdr y)))))
+ (offset (caar sorted-off-alist)))
+ (if (zerop offset)
+ ;; Nothing to do with this sig; indentation is
+ ;; correct already.
+ nil
+ (push (cons (+ offset (nth 2 sig)) sig) rules)
+ ;; Adjust the rest of the data.
+ (pcase-dolist ((and cotrace `(,count ,toffset ,trace))
+ cotraces)
+ (setf (nth 1 cotrace) (- toffset offset))
+ (dolist (sig trace)
+ (let ((sig-data (cdr (assq sig ssigs))))
+ (when sig-data
+ (let* ((ooff-data (assq toffset (nth 1 sig-data)))
+ (noffset (- toffset offset))
+ (noff-data
+ (or (assq noffset (nth 1 sig-data))
+ (let ((off-data (cons noffset 0)))
+ (push off-data (nth 1 sig-data))
+ off-data))))
+ (cl-assert (>= (cdr ooff-data) count))
+ (cl-decf (cdr ooff-data) count)
+ (cl-incf (cdr noff-data) count))))))))))
+ (message "Guessing...done")
+ rules))))
+
+(defun smie-config-guess ()
+ "Try and figure out this buffer's indentation settings."
+ (interactive)
+ (let ((config (smie-config--guess (point-min) (point-max))))
+ (cond
+ ((null config) (message "Nothing to change"))
+ ((null smie-config--buffer-local)
+ (message "Local rules set")
+ (setq smie-config--buffer-local config))
+ ((y-or-n-p "Replace existing local config? ")
+ (message "Local rules replaced")
+ (setq smie-config--buffer-local config))
+ ((y-or-n-p "Merge with existing local config? ")
+ (message "Local rules adjusted")
+ (setq smie-config--buffer-local
+ (append config smie-config--buffer-local)))
+ (t
+ (message "Rules guessed: %S" config)))))
+
+(defun smie-config-save ()
+ "Save local rules for use with this major mode."
+ (interactive)
+ (cond
+ ((null smie-config--buffer-local)
+ (message "No local rules to save"))
+ (t
+ (let* ((existing (assq major-mode smie-config))
+ (config
+ (cond ((null existing)
+ (message "Local rules saved in `smie-config'")
+ smie-config--buffer-local)
+ ((y-or-n-p "Replace the existing mode's config? ")
+ (message "Mode rules replaced in `smie-config'")
+ smie-config--buffer-local)
+ ((y-or-n-p "Merge with existing mode's config? ")
+ (message "Mode rules adjusted in `smie-config'")
+ (append smie-config--buffer-local (cdr existing)))
+ (t (error "Abort")))))
+ (if existing
+ (setcdr existing config)
+ (push (cons major-mode config) smie-config))
+ (setq smie-config--mode-local config)
+ (kill-local-variable smie-config--buffer-local)
+ (customize-mark-as-set 'smie-config)))))
(provide 'smie)
;;; smie.el ends here
generated by cgit v1.2.3 (git 2.39.1) at 2025-06-26 18:28:00 +0000