diff options
Diffstat (limited to 'lisp/emacs-lisp')
48 files changed, 1267 insertions, 912 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 1915d94e97b..4ee830023fc 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -168,7 +168,8 @@ ;; "Switch to non-existing buffers only upon confirmation." ;; (interactive "BSwitch to buffer: ") ;; (if (or (get-buffer (ad-get-arg 0)) -;; (y-or-n-p (format "`%s' does not exist, create? " (ad-get-arg 0)))) +;; (y-or-n-p (format-message "`%s' does not exist, create? " +;; (ad-get-arg 0)))) ;; ad-do-it)) ;; ;;(defadvice find-file (before existing-files-only activate) @@ -2412,14 +2413,14 @@ The assignment starts at position INDEX." ;; The mapping should work for any two argument lists. (defun ad-map-arglists (source-arglist target-arglist) - "Make ‘funcall/apply’ form to map SOURCE-ARGLIST to TARGET-ARGLIST. + "Make `funcall/apply' form to map SOURCE-ARGLIST to TARGET-ARGLIST. The arguments supplied to TARGET-ARGLIST will be taken from SOURCE-ARGLIST just as if they had been supplied to a function with TARGET-ARGLIST directly. Excess source arguments will be neglected, missing source arguments will be -supplied as nil. Returns a ‘funcall’ or ‘apply’ form with the second element -being ‘function’ which has to be replaced by an actual function argument. -Example: ‘(ad-map-arglists '(a &rest args) '(w x y z))’ will return - ‘(funcall ad--addoit-function a (car args) (car (cdr args)) (nth 2 args))’." +supplied as nil. Returns a `funcall' or `apply' form with the second element +being `function' which has to be replaced by an actual function argument. +Example: (ad-map-arglists '(a &rest args) '(w x y z)) will return + (funcall ad--addoit-function a (car args) (car (cdr args)) (nth 2 args))." (let* ((parsed-source-arglist (ad-parse-arglist source-arglist)) (source-reqopt-args (append (nth 0 parsed-source-arglist) (nth 1 parsed-source-arglist))) @@ -3106,7 +3107,7 @@ deactivation, which might run hooks and get into other trouble." "Define a piece of advice for FUNCTION (a symbol). The syntax of `defadvice' is as follows: - \(defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) + (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) [DOCSTRING] [INTERACTIVE-FORM] BODY...) diff --git a/lisp/emacs-lisp/avl-tree.el b/lisp/emacs-lisp/avl-tree.el index e3d83eb127f..99a329b021e 100644 --- a/lisp/emacs-lisp/avl-tree.el +++ b/lisp/emacs-lisp/avl-tree.el @@ -615,7 +615,7 @@ is more efficient." of all elements of TREE. If REVERSE is non-nil, the stack is sorted in reverse order. -\(See also `avl-tree-stack-pop'\). +\(See also `avl-tree-stack-pop'). Note that any modification to TREE *immediately* invalidates all avl-tree-stacks created before the modification (in particular, diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 1a34fa78aef..c3c61d6c81e 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -192,7 +192,7 @@ ;; (if (aref byte-code-vector 0) ;; (error "The old version of the disassembler is loaded. Reload new-bytecomp as well")) (byte-compile-log-1 - (apply 'format format + (apply #'format-message format (let (c a) (mapcar (lambda (arg) (if (not (consp arg)) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 081ea3183b9..73c2977e8eb 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -355,12 +355,12 @@ was first made obsolete, for example a date or a release number." &optional when docstring) "Set OBSOLETE-NAME's function definition to CURRENT-NAME and mark it obsolete. -\(define-obsolete-function-alias 'old-fun 'new-fun \"22.1\" \"old-fun's doc.\") +\(define-obsolete-function-alias \\='old-fun \\='new-fun \"22.1\" \"old-fun's doc.\") is equivalent to the following two lines of code: -\(defalias 'old-fun 'new-fun \"old-fun's doc.\") -\(make-obsolete 'old-fun 'new-fun \"22.1\") +\(defalias \\='old-fun \\='new-fun \"old-fun's doc.\") +\(make-obsolete \\='old-fun \\='new-fun \"22.1\") See the docstrings of `defalias' and `make-obsolete' for more details." (declare (doc-string 4) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 197df3b8815..db200f3c504 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -397,7 +397,7 @@ invoked interactively are excluded from this list." "Alist of functions and their call tree. Each element looks like - \(FUNCTION CALLERS CALLS\) + (FUNCTION CALLERS CALLS) where CALLERS is a list of functions that call FUNCTION, and CALLS is a list of functions for which calls were generated while compiling @@ -973,7 +973,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (print-level 4) (print-length 4)) (byte-compile-log-1 - (format + (format-message ,format-string ,@(mapcar (lambda (x) (if (symbolp x) (list 'prin1-to-string x) x)) @@ -1120,7 +1120,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." pt) (when dir (unless was-same - (insert (format "Leaving directory `%s'\n" default-directory)))) + (insert (format-message "Leaving directory `%s'\n" + default-directory)))) (unless (bolp) (insert "\n")) (setq pt (point-marker)) @@ -1135,8 +1136,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (when dir (setq default-directory dir) (unless was-same - (insert (format "Entering directory `%s'\n" - default-directory)))) + (insert (format-message "Entering directory `%s'\n" + default-directory)))) (setq byte-compile-last-logged-file byte-compile-current-file byte-compile-last-warned-form nil) ;; Do this after setting default-directory. @@ -1154,7 +1155,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (defun byte-compile-warn (format &rest args) "Issue a byte compiler warning; use (format FORMAT ARGS...) for message." - (setq format (apply 'format format args)) + (setq format (apply #'format-message format args)) (if byte-compile-error-on-warn (error "%s" format) ; byte-compile-file catches and logs it (byte-compile-log-warning format t :warning))) @@ -1900,7 +1901,10 @@ With argument ARG, insert value in current buffer after the form." (let ((read-with-symbol-positions (current-buffer)) (read-symbol-positions-list nil)) (displaying-byte-compile-warnings - (byte-compile-sexp (read (current-buffer))))) + (byte-compile-sexp + (eval-sexp-add-defvars + (read (current-buffer)) + byte-compile-read-position)))) lexical-binding))) (cond (arg (message "Compiling from buffer... done.") @@ -2584,7 +2588,9 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if (symbolp form) form "provided")) fun) (t - (when (symbolp form) + (when (or (symbolp form) (eq (car-safe fun) 'closure)) + ;; `fun' is a function *value*, so try to recover its corresponding + ;; source code. (setq lexical-binding (eq (car fun) 'closure)) (setq fun (byte-compile--reify-function fun))) ;; Expand macros. @@ -2979,7 +2985,7 @@ for symbols generated by the byte compiler itself." (`(',var . ,_) (when (assq var byte-compile-lexical-variables) (byte-compile-log-warning - (format "%s cannot use lexical var `%s'" fn var) + (format-message "%s cannot use lexical var `%s'" fn var) nil :error))))) (when (macroexp--const-symbol-p fn) (byte-compile-warn "`%s' called as a function" fn)) @@ -2988,11 +2994,13 @@ for symbols generated by the byte compiler itself." (byte-compile-warn "`%s' is for interactive use only%s" fn (cond ((stringp interactive-only) - (format "; %s" interactive-only)) + (format "; %s" + (substitute-command-keys + interactive-only))) ((and (symbolp 'interactive-only) (not (eq interactive-only t))) - (format "; use `%s' instead." - interactive-only)) + (format-message "; use `%s' instead." + interactive-only)) (t ".")))) (if (eq (car-safe (symbol-function (car form))) 'macro) (byte-compile-log-warning @@ -3124,7 +3132,7 @@ for symbols generated by the byte compiler itself." (cond ((or (not (symbolp var)) (macroexp--const-symbol-p var)) (when (byte-compile-warning-enabled-p 'constants) (byte-compile-warn (if (eq access-type 'let-bind) - "attempt to let-bind %s `%s`" + "attempt to let-bind %s `%s'" "variable reference to %s `%s'") (if (symbolp var) "constant" "nonvariable") (prin1-to-string var)))) @@ -3612,8 +3620,8 @@ discarding." (defun byte-compile-quo (form) (let ((len (length form))) - (cond ((<= len 2) - (byte-compile-subr-wrong-args form "2 or more")) + (cond ((< len 2) + (byte-compile-subr-wrong-args form "1 or more")) ((= len 3) (byte-compile-two-args form)) (t @@ -3824,11 +3832,11 @@ discarding." "Execute forms in BODY, potentially guarded by CONDITION. CONDITION is a variable whose value is a test in an `if' or `cond'. BODY is the code to compile in the first arm of the if or the body of -the cond clause. If CONDITION's value is of the form (fboundp 'foo) -or (boundp 'foo), the relevant warnings from BODY about foo's +the cond clause. If CONDITION's value is of the form (fboundp \\='foo) +or (boundp \\='foo), the relevant warnings from BODY about foo's being undefined (or obsolete) will be suppressed. -If CONDITION's value is (not (featurep 'emacs)) or (featurep 'xemacs), +If CONDITION's value is (not (featurep \\='emacs)) or (featurep \\='xemacs), that suppresses all warnings during execution of BODY." (declare (indent 1) (debug t)) `(let* ((fbound-list (byte-compile-find-bound-condition @@ -4524,11 +4532,11 @@ whose definitions have been compiled in this Emacs session, as well as all functions called by those functions. The call graph does not include macros, inline functions, or -primitives that the byte-code interpreter knows about directly \(eq, -cons, etc.\). +primitives that the byte-code interpreter knows about directly +\(`eq', `cons', etc.). The call tree also lists those functions which are not known to be called -\(that is, to which no calls have been compiled\), and which cannot be +\(that is, to which no calls have been compiled), and which cannot be invoked interactively." (interactive) (message "Generating call tree...") diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index fa824075933..efa9a3da011 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -1,4 +1,4 @@ -;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t; coding: utf-8 -*- +;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t -*- ;; Copyright (C) 2011-2015 Free Software Foundation, Inc. @@ -300,7 +300,8 @@ places where they originally did not directly appear." (prog1 binder (setq binder (list binder))) (when (cddr binder) (byte-compile-log-warning - (format "Malformed `%S' binding: %S" letsym binder))) + (format-message "Malformed `%S' binding: %S" + letsym binder))) (setq value (cadr binder)) (car binder))) (new-val @@ -545,7 +546,7 @@ FORM is the parent form that binds this var." (`((,(and var (guard (eq ?_ (aref (symbol-name var) 0)))) . ,_) ,_ ,_ ,_ ,_) (byte-compile-log-warning - (format "%s `%S' not left unused" varkind var)))) + (format-message "%s `%S' not left unused" varkind var)))) (pcase vardata (`((,var . ,_) nil ,_ ,_ nil) ;; FIXME: This gives warnings in the wrong order, with imprecise line @@ -557,8 +558,8 @@ FORM is the parent form that binds this var." (eq ?_ (aref (symbol-name var) 0)) ;; As a special exception, ignore "ignore". (eq var 'ignored)) - (byte-compile-log-warning (format "Unused lexical %s `%S'" - varkind var)))) + (byte-compile-log-warning (format-message "Unused lexical %s `%S'" + varkind var)))) ;; If it's unused, there's no point converting it into a cons-cell, even if ;; it's captured and mutated. (`(,binder ,_ t t ,_) @@ -678,7 +679,7 @@ and updates the data stored in ENV." ;; ((and `(quote ,v . ,_) (guard (assq v env))) ;; (byte-compile-log-warning - ;; (format "Possible confusion variable/symbol for `%S'" v))) + ;; (format-message "Possible confusion variable/symbol for `%S'" v))) (`(quote . ,_) nil) ; quote form (`(function . ,_) nil) ; same as quote diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index ea865f22f57..536e4186c41 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -162,7 +162,7 @@ def\\(?:un\\|subst\\|foo\\|method\\|class\\|\ ine-\\(?:derived\\|generic\\|\\(?:global\\(?:ized\\)?-\\)?minor\\)-mode\\|\ \\(?:ine-obsolete-function-\\)?alias[ \t]+'\\|\ ine-overloadable-function\\)\\)\ -\[ \t]*%s\\([ \t;]+\\|$\\)") +[ \t]*%s\\([ \t;]+\\|$\\)") (regexp-opt (mapcar 'cadr fnlist) t))) (while (re-search-forward re nil t) (skip-chars-forward " \t\n") @@ -279,8 +279,8 @@ TYPE is a string giving the nature of the error. Warning is displayed in entry)) (warning-fill-prefix " ")) (display-warning 'check-declare - (format "said `%s' was defined in %s: %s" - fn (file-name-nondirectory fnfile) type) + (format-message "said `%s' was defined in %s: %s" + fn (file-name-nondirectory fnfile) type) nil check-declare-warning-buffer))) (declare-function compilation-forget-errors "compile" ()) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index c22aff4cbca..bf1a21acaf1 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -1419,7 +1419,7 @@ regexp short cuts work. FP is the function defun information." (when (re-search-forward "^(" e t) (if (checkdoc-autofix-ask-replace (match-beginning 0) (match-end 0) - "Escape this '('? " + (format-message "Escape this `('? ") "\\(") nil (checkdoc-create-error @@ -1714,7 +1714,7 @@ function,command,variable,option or symbol." ms1)))))) e t)) (if (checkdoc-autofix-ask-replace (match-beginning 1) (match-end 1) - (format + (format-message "If this is the argument `%s', it should appear as %s. Fix? " (car args) (upcase (car args))) (upcase (car args)) t) @@ -1740,7 +1740,7 @@ function,command,variable,option or symbol." ms1)))))) (insert ".")) nil) (checkdoc-create-error - (format + (format-message "Argument `%s' should appear (as %s) in the doc string" (car args) (upcase (car args))) s (marker-position e))) @@ -1824,16 +1824,16 @@ Replace with \"%s\"? " original replace) (setq found (intern-soft ms)) (or (boundp found) (fboundp found))) (progn - (setq msg (format "Add quotes around Lisp symbol `%s'? " - ms)) + (setq msg (format-message + "Add quotes around Lisp symbol `%s'? " ms)) (if (checkdoc-autofix-ask-replace (match-beginning 1) (+ (match-beginning 1) (length ms)) - msg (concat "‘" ms "’") t) + msg (format-message "`%s'" ms) t) (setq msg nil) (setq msg - (format "Lisp symbol `%s' should appear in quotes" - ms)))))) + (format-message + "Lisp symbol `%s' should appear in quotes" ms)))))) (if msg (checkdoc-create-error msg (match-beginning 1) (+ (match-beginning 1) @@ -1849,7 +1849,7 @@ Replace with \"%s\"? " original replace) (match-string 2) t) nil (checkdoc-create-error - "Symbols t and nil should not appear in `...' quotes" + "Symbols t and nil should not appear in single quotes" (match-beginning 1) (match-end 1))))) ;; Here is some basic sentence formatting (checkdoc-sentencespace-region-engine (point) e) @@ -1954,7 +1954,7 @@ from the comment." "Return non-nil if the current point is in a code fragment. A code fragment is identified by an open parenthesis followed by a symbol which is a valid function or a word in all CAPS, or a parenthesis -that is quoted with the ' character. Only the region from START to LIMIT +that is quoted with the \\=' character. Only the region from START to LIMIT is allowed while searching for the bounding parenthesis." (save-match-data (save-restriction @@ -2487,7 +2487,8 @@ Argument TYPE specifies the type of question, such as `error' or `y-or-n-p'." ;; If we see a ?, then replace with "? ". (if (checkdoc-autofix-ask-replace (match-beginning 0) (match-end 0) - "`y-or-n-p' argument should end with \"? \". Fix? " + (format-message + "`y-or-n-p' argument should end with \"? \". Fix? ") "? " t) nil (checkdoc-create-error @@ -2498,7 +2499,8 @@ Argument TYPE specifies the type of question, such as `error' or `y-or-n-p'." (looking-at " ")) (if (checkdoc-autofix-ask-replace (match-beginning 0) (match-end 0) - "`y-or-n-p' argument should end with \"? \". Fix? " + (format-message + "`y-or-n-p' argument should end with \"? \". Fix? ") "? " t) nil (checkdoc-create-error @@ -2510,7 +2512,8 @@ Argument TYPE specifies the type of question, such as `error' or `y-or-n-p'." (looking-at "\"")) (checkdoc-autofix-ask-replace (match-beginning 0) (match-end 0) - "`y-or-n-p' argument should end with \"? \". Fix? " + (format-message + "`y-or-n-p' argument should end with \"? \". Fix? ") "? \"" t)) nil (checkdoc-create-error diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 101864d3721..afa021dffc7 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -38,7 +38,6 @@ ;;; Code: (require 'cl-lib) -(require 'seq) ;;; Type coercion. @@ -498,7 +497,7 @@ This sets the values of: `cl-most-positive-float', `cl-most-negative-float', (setq cl-least-positive-normalized-float y cl-least-negative-normalized-float (- y)) ;; Divide down until value underflows to zero. - (setq x (/ 1 z) y x) + (setq x (/ z) y x) (while (condition-case _ (> (/ x 2) 0) (arith-error nil)) (setq x (/ x 2))) (setq cl-least-positive-float x @@ -518,19 +517,44 @@ This sets the values of: `cl-most-positive-float', `cl-most-negative-float', (defun cl-subseq (seq start &optional end) "Return the subsequence of SEQ from START to END. If END is omitted, it defaults to the length of the sequence. -If START or END is negative, it counts from the end." +If START or END is negative, it counts from the end. +Signal an error if START or END are outside of the sequence (i.e +too large if positive or too small if negative)." (declare (gv-setter (lambda (new) (macroexp-let2 nil new new `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end) ,new))))) - (seq-subseq seq start end)) - -;;;###autoload -(defalias 'cl-concatenate #'seq-concatenate + (cond ((or (stringp seq) (vectorp seq)) (substring seq start end)) + ((listp seq) + (let (len + (errtext (format "Bad bounding indices: %s, %s" start end))) + (and end (< end 0) (setq end (+ end (setq len (length seq))))) + (if (< start 0) (setq start (+ start (or len (setq len (length seq)))))) + (unless (>= start 0) + (error "%s" errtext)) + (when (> start 0) + (setq seq (nthcdr (1- start) seq)) + (or seq (error "%s" errtext)) + (setq seq (cdr seq))) + (if end + (let ((res nil)) + (while (and (>= (setq end (1- end)) start) seq) + (push (pop seq) res)) + (or (= (1+ end) start) (error "%s" errtext)) + (nreverse res)) + (copy-sequence seq)))) + (t (error "Unsupported sequence: %s" seq)))) + +;;;###autoload +(defun cl-concatenate (type &rest sequences) "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. -\n(fn TYPE SEQUENCE...)") - +\n(fn TYPE SEQUENCE...)" + (pcase type + (`vector (apply #'vconcat sequences)) + (`string (apply #'concat sequences)) + (`list (apply #'append (append sequences '(nil)))) + (_ (error "Not a sequence type name: %S" type)))) ;;; List functions. @@ -750,16 +774,16 @@ including `cl-block' and `cl-eval-when'." ;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch. (metatype (cl--class-name (symbol-value (aref class 0))))) (insert (symbol-name type) - (substitute-command-keys " is a type (of kind ‘")) + (substitute-command-keys " is a type (of kind `")) (help-insert-xref-button (symbol-name metatype) 'cl-help-type metatype) - (insert (substitute-command-keys "’)")) + (insert (substitute-command-keys "')")) (when location - (insert (substitute-command-keys " in ‘")) + (insert (substitute-command-keys " in `")) (help-insert-xref-button (help-fns-short-filename location) 'cl-type-definition type location 'define-type) - (insert (substitute-command-keys "’"))) + (insert (substitute-command-keys "'"))) (insert ".\n") ;; Parents. @@ -769,10 +793,10 @@ including `cl-block' and `cl-eval-when'." (insert " Inherits from ") (while (setq cur (pop pl)) (setq cur (cl--class-name cur)) - (insert (substitute-command-keys "‘")) + (insert (substitute-command-keys "`")) (help-insert-xref-button (symbol-name cur) 'cl-help-type cur) - (insert (substitute-command-keys (if pl "’, " "’")))) + (insert (substitute-command-keys (if pl "', " "'")))) (insert ".\n"))) ;; Children, if available. ¡For EIEIO! @@ -783,10 +807,10 @@ including `cl-block' and `cl-eval-when'." (when ch (insert " Children ") (while (setq cur (pop ch)) - (insert (substitute-command-keys "‘")) + (insert (substitute-command-keys "`")) (help-insert-xref-button (symbol-name cur) 'cl-help-type cur) - (insert (substitute-command-keys (if ch "’, " "’")))) + (insert (substitute-command-keys (if ch "', " "'")))) (insert ".\n"))) ;; Type's documentation. @@ -802,10 +826,10 @@ including `cl-block' and `cl-eval-when'." (when generics (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) (dolist (generic generics) - (insert (substitute-command-keys "‘")) + (insert (substitute-command-keys "`")) (help-insert-xref-button (symbol-name generic) 'help-function generic) - (insert (substitute-command-keys "’")) + (insert (substitute-command-keys "'")) (pcase-dolist (`(,qualifiers ,args ,doc) (cl--generic-method-documentation generic type)) (insert (format " %s%S\n" qualifiers args) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 619428d46bd..9e6102c7300 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -80,7 +80,7 @@ ;; TODO: ;; -;; - A generic "filter" generalizer (e.g. could be used to cleanly adds methods +;; - A generic "filter" generalizer (e.g. could be used to cleanly add methods ;; to cl-generic-combine-methods with a specializer that says it applies only ;; when some particular qualifier is used). ;; - A way to dispatch on the context (e.g. the major-mode, some global @@ -101,14 +101,33 @@ (cl-defstruct (cl--generic-generalizer (:constructor nil) (:constructor cl-generic-make-generalizer - (priority tagcode-function specializers-function))) + (name priority tagcode-function specializers-function))) + (name nil :type string) (priority nil :type integer) tagcode-function specializers-function) -(defconst cl--generic-t-generalizer - (cl-generic-make-generalizer - 0 (lambda (_name) nil) (lambda (_tag) '(t)))) + +(defmacro cl-generic-define-generalizer + (name priority tagcode-function specializers-function) + "Define a new kind of generalizer. +NAME is the name of the variable that will hold it. +PRIORITY defines which generalizer takes precedence. + The catch-all generalizer has priority 0. + Then `eql' generalizer has priority 100. +TAGCODE-FUNCTION takes as first argument a varname and should return + a chunk of code that computes the tag of the value held in that variable. + Further arguments are reserved for future use. +SPECIALIZERS-FUNCTION takes as first argument a tag value TAG + and should return a list of specializers that match TAG. + Further arguments are reserved for future use." + (declare (indent 1) (debug (symbolp body))) + `(defconst ,name + (cl-generic-make-generalizer + ',name ,priority ,tagcode-function ,specializers-function))) + +(cl-generic-define-generalizer cl--generic-t-generalizer + 0 (lambda (_name &rest _) nil) (lambda (_tag &rest _) '(t))) (cl-defstruct (cl--generic-method (:constructor nil) @@ -144,16 +163,18 @@ (defmacro cl--generic (name) `(get ,name 'cl--generic)) -(defun cl-generic-ensure-function (name) +(defun cl-generic-ensure-function (name &optional noerror) (let (generic (origname name)) (while (and (null (setq generic (cl--generic name))) (fboundp name) + (null noerror) (symbolp (symbol-function name))) (setq name (symbol-function name))) (unless (or (not (fboundp name)) (autoloadp (symbol-function name)) - (and (functionp name) generic)) + (and (functionp name) generic) + noerror) (error "%s is already defined as something else than a generic function" origname)) (if generic @@ -220,7 +241,7 @@ BODY, if present, is used as the body of a default method. ;;;###autoload (defun cl-generic-define (name args options) - (pcase-let* ((generic (cl-generic-ensure-function name)) + (pcase-let* ((generic (cl-generic-ensure-function name 'noerror)) (`(,spec-args . ,_) (cl--generic-split-args args)) (mandatory (mapcar #'car spec-args)) (apo (assq :argument-precedence-order options))) @@ -245,6 +266,15 @@ BODY, if present, is used as the body of a default method. This macro can only be used within the lexical scope of a cl-generic method." (error "cl-generic-current-method-specializers used outside of a method")) +(defmacro cl-generic-define-context-rewriter (name args &rest body) + "Define a special kind of context named NAME. +Whenever a context specializer of the form (NAME . ARGS) appears, +the specializer used will be the one returned by BODY." + (declare (debug (&define name lambda-list def-body)) (indent defun)) + `(eval-and-compile + (put ',name 'cl-generic--context-rewriter + (lambda ,args ,@body)))) + (eval-and-compile ;Needed while compiling the cl-defmethod calls below! (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el. "Check which of the symbols VARS appear in SEXP." @@ -271,6 +301,11 @@ This macro can only be used within the lexical scope of a cl-generic method." ((let 'context mandatory) (unless (consp arg) (error "Invalid &context arg: %S" arg)) + (let* ((name (car arg)) + (rewriter + (and (symbolp name) + (get name 'cl-generic--context-rewriter)))) + (if rewriter (setq arg (apply rewriter (cdr arg))))) (push `((&context . ,(car arg)) . ,(cadr arg)) specializers) nil) (`(,name . ,type) @@ -418,8 +453,12 @@ which case this method will be invoked when the argument is `eql' to VAL. (setq i (1+ i)))) ;; We used to (setcar me method), but that can cause false positives in ;; the hash-consing table of the method-builder (bug#20644). - ;; See the related FIXME in cl--generic-build-combined-method. - (setf (cl--generic-method-table generic) (cons method (delq (car me) mt))) + ;; See also the related FIXME in cl--generic-build-combined-method. + (setf (cl--generic-method-table generic) + (if (null me) + (cons method mt) + ;; Keep the ordering; important for methods with :extra qualifiers. + (mapcar (lambda (x) (if (eq x (car me)) method x)) mt))) (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers)) current-load-list :test #'equal) ;; FIXME: Try to avoid re-constructing a new function if the old one @@ -623,16 +662,19 @@ FUN is the function that should be called when METHOD calls (setq fun (cl-generic-call-method generic method fun))) fun))))) +(defun cl--generic-arg-specializer (method dispatch-arg) + (or (if (integerp dispatch-arg) + (nth dispatch-arg + (cl--generic-method-specializers method)) + (cdr (assoc dispatch-arg + (cl--generic-method-specializers method)))) + t)) + (defun cl--generic-cache-miss (generic dispatch-arg dispatches-left methods-left types) (let ((methods '())) (dolist (method methods-left) - (let* ((specializer (or (if (integerp dispatch-arg) - (nth dispatch-arg - (cl--generic-method-specializers method)) - (cdr (assoc dispatch-arg - (cl--generic-method-specializers method)))) - t)) + (let* ((specializer (cl--generic-arg-specializer method dispatch-arg)) (m (member specializer types))) (when m (push (cons (length m) method) methods)))) @@ -682,10 +724,12 @@ The METHODS list is sorted from most specific first to most generic last. The function can use `cl-generic-call-method' to create functions that call those methods.") -;; Temporary definition to let the next defmethod succeed. -(fset 'cl-generic-generalizers - (lambda (_specializer) (list cl--generic-t-generalizer))) -(fset 'cl-generic-combine-methods #'cl--generic-standard-method-combination) +(unless (ignore-errors (cl-generic-generalizers t)) + ;; Temporary definition to let the next defmethod succeed. + (fset 'cl-generic-generalizers + (lambda (specializer) + (if (eq t specializer) (list cl--generic-t-generalizer)))) + (fset 'cl-generic-combine-methods #'cl--generic-standard-method-combination)) (cl-defmethod cl-generic-generalizers (specializer) "Support for the catch-all t specializer." @@ -791,6 +835,8 @@ Can only be used from within the lexical body of a primary or around method." ;;; Add support for describe-function (defun cl--generic-search-method (met-name) + "For `find-function-regexp-alist'. Searches for a cl-defmethod. +MET-NAME is a cons (SYMBOL . SPECIALIZERS)." (let ((base-re (concat "(\\(?:cl-\\)?defmethod[ \t]+" (regexp-quote (format "%s" (car met-name))) "\\_>"))) @@ -806,11 +852,15 @@ Can only be used from within the lexical body of a primary or around method." nil t) (re-search-forward base-re nil t)))) +;; WORKAROUND: This can't be a defconst due to bug#21237. +(defvar cl--generic-find-defgeneric-regexp "(\\(?:cl-\\)?defgeneric[ \t]+%s\\>") (with-eval-after-load 'find-func (defvar find-function-regexp-alist) (add-to-list 'find-function-regexp-alist - `(cl-defmethod . ,#'cl--generic-search-method))) + `(cl-defmethod . ,#'cl--generic-search-method)) + (add-to-list 'find-function-regexp-alist + `(cl-defgeneric . cl--generic-find-defgeneric-regexp))) (defun cl--generic-method-info (method) (let* ((specializers (cl--generic-method-specializers method)) @@ -858,11 +908,11 @@ Can only be used from within the lexical body of a primary or around method." (cl--generic-method-specializers method))) (file (find-lisp-object-file-name met-name 'cl-defmethod))) (when file - (insert (substitute-command-keys " in ‘")) + (insert (substitute-command-keys " in `")) (help-insert-xref-button (help-fns-short-filename file) 'help-function-def met-name file 'cl-defmethod) - (insert (substitute-command-keys "’.\n")))) + (insert (substitute-command-keys "'.\n")))) (insert "\n" (or (nth 2 info) "Undocumented") "\n\n"))))))) (defun cl--generic-specializers-apply-to-type-p (specializers type) @@ -934,10 +984,9 @@ The value returned is a list of elements of the form (defvar cl--generic-head-used (make-hash-table :test #'eql)) -(defconst cl--generic-head-generalizer - (cl-generic-make-generalizer - 80 (lambda (name) `(gethash (car-safe ,name) cl--generic-head-used)) - (lambda (tag) (if (eq (car-safe tag) 'head) (list tag))))) +(cl-generic-define-generalizer cl--generic-head-generalizer + 80 (lambda (name &rest _) `(gethash (car-safe ,name) cl--generic-head-used)) + (lambda (tag &rest _) (if (eq (car-safe tag) 'head) (list tag)))) (cl-defmethod cl-generic-generalizers :extra "head" (specializer) "Support for the `(head VAL)' specializers." @@ -955,10 +1004,9 @@ The value returned is a list of elements of the form (defvar cl--generic-eql-used (make-hash-table :test #'eql)) -(defconst cl--generic-eql-generalizer - (cl-generic-make-generalizer - 100 (lambda (name) `(gethash ,name cl--generic-eql-used)) - (lambda (tag) (if (eq (car-safe tag) 'eql) (list tag))))) +(cl-generic-define-generalizer cl--generic-eql-generalizer + 100 (lambda (name &rest _) `(gethash ,name cl--generic-eql-used)) + (lambda (tag &rest _) (if (eq (car-safe tag) 'eql) (list tag)))) (cl-defmethod cl-generic-generalizers ((specializer (head eql))) "Support for the `(eql VAL)' specializers." @@ -970,7 +1018,7 @@ The value returned is a list of elements of the form ;;; Support for cl-defstructs specializers. -(defun cl--generic-struct-tag (name) +(defun cl--generic-struct-tag (name &rest _) ;; It's tempting to use (and (vectorp ,name) (aref ,name 0)) ;; but that would suffer from some problems: ;; - the vector may have size 0. @@ -986,8 +1034,9 @@ The value returned is a list of elements of the form `(and (vectorp ,name) (> (length ,name) 0) (let ((tag (aref ,name 0))) - (if (eq (symbol-function tag) :quick-object-witness-check) - tag)))) + (and (symbolp tag) + (eq (symbol-function tag) :quick-object-witness-check) + tag)))) (defun cl--generic-class-parents (class) (let ((parents ()) @@ -1000,16 +1049,15 @@ The value returned is a list of elements of the form (cl--class-parents class))))) (nreverse parents))) -(defun cl--generic-struct-specializers (tag) +(defun cl--generic-struct-specializers (tag &rest _) (and (symbolp tag) (boundp tag) (let ((class (symbol-value tag))) (when (cl-typep class 'cl-structure-class) (cl--generic-class-parents class))))) -(defconst cl--generic-struct-generalizer - (cl-generic-make-generalizer - 50 #'cl--generic-struct-tag - #'cl--generic-struct-specializers)) +(cl-generic-define-generalizer cl--generic-struct-generalizer + 50 #'cl--generic-struct-tag + #'cl--generic-struct-specializers) (cl-defmethod cl-generic-generalizers :extra "cl-struct" (type) "Support for dispatch on cl-struct types." @@ -1049,11 +1097,11 @@ The value returned is a list of elements of the form (sequence) (number))) -(defconst cl--generic-typeof-generalizer - (cl-generic-make-generalizer - ;; FIXME: We could also change `type-of' to return `null' for nil. - 10 (lambda (name) `(if ,name (type-of ,name) 'null)) - (lambda (tag) (and (symbolp tag) (assq tag cl--generic-typeof-types))))) +(cl-generic-define-generalizer cl--generic-typeof-generalizer + ;; FIXME: We could also change `type-of' to return `null' for nil. + 10 (lambda (name &rest _) `(if ,name (type-of ,name) 'null)) + (lambda (tag &rest _) + (and (symbolp tag) (assq tag cl--generic-typeof-types)))) (cl-defmethod cl-generic-generalizers :extra "typeof" (type) "Support for dispatch on builtin types." @@ -1062,13 +1110,47 @@ The value returned is a list of elements of the form (or (and (assq type cl--generic-typeof-types) (progn - (if (memq type '(vector array sequence)) - (message "`%S' also matches CL structs and EIEIO classes" type)) + ;; FIXME: While this wrinkle in the semantics can be occasionally + ;; problematic, this warning is more often annoying than helpful. + ;;(if (memq type '(vector array sequence)) + ;; (message "`%S' also matches CL structs and EIEIO classes" + ;; type)) (list cl--generic-typeof-generalizer))) (cl-call-next-method))) (cl--generic-prefill-dispatchers 0 integer) +;;; Dispatch on major mode. + +;; Two parts: +;; - first define a specializer (derived-mode <mode>) to match symbols +;; representing major modes, while obeying the major mode hierarchy. +;; - then define a context-rewriter so you can write +;; "&context (major-mode c-mode)" rather than +;; "&context (major-mode (derived-mode c-mode))". + +(defun cl--generic-derived-specializers (mode &rest _) + ;; FIXME: Handle (derived-mode <mode1> ... <modeN>) + (let ((specializers ())) + (while mode + (push `(derived-mode ,mode) specializers) + (setq mode (get mode 'derived-mode-parent))) + (nreverse specializers))) + +(cl-generic-define-generalizer cl--generic-derived-generalizer + 90 (lambda (name) `(and (symbolp ,name) (functionp ,name) ,name)) + #'cl--generic-derived-specializers) + +(cl-defmethod cl-generic-generalizers ((_specializer (head derived-mode))) + "Support for the `(derived-mode MODE)' specializers." + (list cl--generic-derived-generalizer)) + +(cl-generic-define-context-rewriter major-mode (mode &rest modes) + `(major-mode ,(if (consp mode) + ;;E.g. could be (eql ...) + (progn (cl-assert (null modes)) mode) + `(derived-mode ,mode . ,modes)))) + ;; Local variables: ;; generated-autoload-file: "cl-loaddefs.el" ;; End: diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index f5e1ffb0008..80f0cd73cee 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1,4 +1,4 @@ -;;; cl-macs.el --- Common Lisp macros -*- lexical-binding: t; coding: utf-8 -*- +;;; cl-macs.el --- Common Lisp macros -*- lexical-binding: t -*- ;; Copyright (C) 1993, 2001-2015 Free Software Foundation, Inc. @@ -2101,8 +2101,8 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). macroexpand-all-environment)))) (if (or (null (cdar bindings)) (cl-cddar bindings)) (macroexp--warn-and-return - (format "Malformed `cl-symbol-macrolet' binding: %S" - (car bindings)) + (format-message "Malformed `cl-symbol-macrolet' binding: %S" + (car bindings)) expansion) expansion))) (fset 'macroexpand previous-macroexpand)))))) @@ -2730,7 +2730,7 @@ non-nil value, that slot cannot be set via `setf'. slots defaults))) (push `(cl-defsubst ,cname (&cl-defs (nil ,@descs) ,@args) - ,(if (stringp doc) (list doc) + ,(if (stringp doc) doc (format "Constructor for objects of type `%s'." name)) ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) '((declare (side-effect-free t)))) @@ -2777,10 +2777,10 @@ non-nil value, that slot cannot be set via `setf'. ;;;###autoload (pcase-defmacro cl-struct (type &rest fields) "Pcase patterns to match cl-structs. -Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of -field NAME is matched against UPAT, or they can be of the form NAME which +Elements of FIELDS can be of the form (NAME PAT) in which case the contents of +field NAME is matched against PAT, or they can be of the form NAME which is a shorthand for (NAME NAME)." - (declare (debug (sexp &rest [&or (sexp pcase-UPAT) sexp]))) + (declare (debug (sexp &rest [&or (sexp pcase-PAT) sexp]))) `(and (pred (pcase--flip cl-typep ',type)) ,@(mapcar (lambda (field) diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 3aea67ad11b..5f0f0881210 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -849,7 +849,7 @@ to avoid corrupting the original LIST1 and LIST2. (memq (car cl-list1) cl-list2)) (push (car cl-list1) cl-res)) (pop cl-list1)) - cl-res)))) + (nreverse cl-res))))) ;;;###autoload (defun cl-nset-difference (cl-list1 cl-list2 &rest cl-keys) diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index c966ace3852..46472ccd257 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -568,7 +568,7 @@ may be bound to temporary variables which are introduced automatically to preserve proper execution order of the arguments. For example: - (defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v)) + (defsetf nth (n x) (v) \\=`(setcar (nthcdr ,n ,x) ,v)) You can replace this form with `gv-define-setter'. diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index 1317d699d25..50f880d7b33 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -375,9 +375,4 @@ If FIX is non-nil, run `copyright-fix-years' instead." (provide 'copyright) -;; For the copyright sign: -;; Local Variables: -;; coding: utf-8 -;; End: - ;;; copyright.el ends here diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index f516e78c8cf..61cb3c3af4e 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -128,8 +128,8 @@ A value of nil specifies `try-completion'. A value of t specifies `all-completions'. A value of lambda specifies a test for an exact match. For more information on STRING, PREDICATE, and FLAG, see the Elisp -Reference sections on 'Programmed Completion' and 'Basic Completion -Functions'." +Reference sections on “Programmed Completion” and “Basic Completion +Functions”." (let ((beg 0)) (while (string-match crm-separator string beg) (setq beg (match-end 0))) diff --git a/lisp/emacs-lisp/cursor-sensor.el b/lisp/emacs-lisp/cursor-sensor.el index 1d1780baed0..2fc7a0d1513 100644 --- a/lisp/emacs-lisp/cursor-sensor.el +++ b/lisp/emacs-lisp/cursor-sensor.el @@ -113,7 +113,7 @@ ;; non-sticky on both ends, but that means get-pos-property might ;; never see it. (new (or (get-char-property point 'cursor-sensor-functions) - (unless (bobp) + (unless (= point 1) (get-char-property (1- point) 'cursor-sensor-functions)))) (old (window-parameter window 'cursor-sensor--last-state)) (oldposmark (car old)) diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 15489fc2015..12cf605cce9 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -1,4 +1,4 @@ -;;; disass.el --- disassembler for compiled Emacs Lisp code +;;; disass.el --- disassembler for compiled Emacs Lisp code -*- lexical-binding:t -*- ;; Copyright (C) 1986, 1991, 2002-2015 Free Software Foundation, Inc. @@ -37,9 +37,9 @@ (require 'macroexp) -;;; The variable byte-code-vector is defined by the new bytecomp.el. -;;; The function byte-decompile-lapcode is defined in byte-opt.el. -;;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt. +;; The variable byte-code-vector is defined by the new bytecomp.el. +;; The function byte-decompile-lapcode is defined in byte-opt.el. +;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt. (require 'byte-compile "bytecomp") (defvar disassemble-column-1-indent 8 "*") @@ -57,8 +57,8 @@ redefine OBJECT if it is a symbol." (interactive (list (intern (completing-read "Disassemble function: " obarray 'fboundp t)) nil 0 t)) - (if (and (consp object) (not (eq (car object) 'lambda))) - (setq object (list 'lambda () object))) + (if (and (consp object) (not (functionp object))) + (setq object `(lambda () ,object))) (or indent (setq indent 0)) ;Default indent to zero (save-excursion (if (or interactive-p (null buffer)) @@ -72,37 +72,34 @@ redefine OBJECT if it is a symbol." (defun disassemble-internal (obj indent interactive-p) (let ((macro 'nil) - (name 'nil) - (doc 'nil) + (name (when (symbolp obj) + (prog1 obj + (setq obj (indirect-function obj))))) args) - (while (symbolp obj) - (setq name obj - obj (symbol-function obj))) + (setq obj (autoload-do-load obj name)) (if (subrp obj) (error "Can't disassemble #<subr %s>" name)) - (setq obj (autoload-do-load obj name)) (if (eq (car-safe obj) 'macro) ;Handle macros. (setq macro t obj (cdr obj))) - (if (and (listp obj) (eq (car obj) 'byte-code)) - (setq obj (list 'lambda nil obj))) - (if (and (listp obj) (not (eq (car obj) 'lambda))) - (error "not a function")) - (if (consp obj) - (if (assq 'byte-code obj) - nil - (if interactive-p (message (if name - "Compiling %s's definition..." - "Compiling definition...") - name)) - (setq obj (byte-compile obj)) - (if interactive-p (message "Done compiling. Disassembling...")))) + (if (eq (car-safe obj) 'byte-code) + (setq obj `(lambda () ,obj))) + (when (consp obj) + (unless (functionp obj) (error "not a function")) + (if (assq 'byte-code obj) + nil + (if interactive-p (message (if name + "Compiling %s's definition..." + "Compiling definition...") + name)) + (setq obj (byte-compile obj)) + (if interactive-p (message "Done compiling. Disassembling...")))) (cond ((consp obj) + (setq args (help-function-arglist obj)) ;save arg list (setq obj (cdr obj)) ;throw lambda away - (setq args (car obj)) ;save arg list (setq obj (cdr obj))) ((byte-code-function-p obj) - (setq args (aref obj 0))) + (setq args (help-function-arglist obj))) (t (error "Compilation failed"))) (if (zerop indent) ; not a nested function (progn @@ -127,10 +124,7 @@ redefine OBJECT if it is a symbol." (insert " args: ") (prin1 args (current-buffer)) (insert "\n") - (let ((interactive (cond ((consp obj) - (assq 'interactive obj)) - ((> (length obj) 5) - (list 'interactive (aref obj 5)))))) + (let ((interactive (interactive-form obj))) (if interactive (progn (setq interactive (nth 1 interactive)) @@ -226,15 +220,16 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." ;; but if the value of the constant is compiled code, then ;; recursively disassemble it. (cond ((or (byte-code-function-p arg) - (and (eq (car-safe arg) 'lambda) + (and (consp arg) (functionp arg) (assq 'byte-code arg)) (and (eq (car-safe arg) 'macro) (or (byte-code-function-p (cdr arg)) - (and (eq (car-safe (cdr arg)) 'lambda) + (and (consp (cdr arg)) + (functionp (cdr arg)) (assq 'byte-code (cdr arg)))))) (cond ((byte-code-function-p arg) (insert "<compiled-function>\n")) - ((eq (car-safe arg) 'lambda) + ((functionp arg) (insert "<compiled lambda>")) (t (insert "<compiled macro>\n"))) (disassemble-internal diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index eab22b67cd7..56f95111ab8 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -136,7 +136,7 @@ BODY contains code to execute each time the mode is enabled or disabled. :variable PLACE The location to use instead of the variable MODE to store the state of the mode. This can be simply a different named variable, or a generalized variable. - PLACE can also be of the form \(GET . SET), where GET is + PLACE can also be of the form (GET . SET), where GET is an expression that returns the current state, and SET is a function that takes one argument, the new state, and sets it. If you specify a :variable, this function does diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index b5b68d268f6..a3e3b567cc4 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -85,7 +85,7 @@ This applies to `eval-defun', `eval-region', `eval-buffer', and You can use the command `edebug-all-defs' to toggle the value of this variable. You may wish to make it local to each buffer with -\(make-local-variable 'edebug-all-defs) in your +\(make-local-variable \\='edebug-all-defs) in your `emacs-lisp-mode-hook'." :type 'boolean :group 'edebug) @@ -3162,12 +3162,12 @@ Do this when stopped before the form or it will be too late. One side effect of using this command is that the next time the function or macro is called, Edebug will be called there as well." (interactive) - (if (not (looking-at "\(")) + (if (not (looking-at "(")) (error "You must be before a list form") (let ((func (save-excursion (down-list 1) - (if (looking-at "\(") + (if (looking-at "(") (edebug--form-data-name (edebug-get-form-data-entry (point))) (read (current-buffer)))))) @@ -3216,57 +3216,45 @@ This is useful for exiting even if `unwind-protect' code may be executed." (setq edebug-execution-mode 'Go-nonstop) (top-level)) - ;;(defun edebug-exit-out () ;; "Go until the current function exits." ;; (interactive) ;; (edebug-set-mode 'exiting "Exit...")) - -;;; The following initial mode setting definitions are not used yet. - -'(defconst edebug-initial-mode-alist - '((edebug-Continue-fast . Continue-fast) - (edebug-Trace-fast . Trace-fast) - (edebug-continue . continue) - (edebug-trace . trace) - (edebug-go . go) - (edebug-step-through . step) - (edebug-Go-nonstop . Go-nonstop) - ) +(defconst edebug-initial-mode-alist + '((edebug-step-mode . step) + (edebug-next-mode . next) + (edebug-trace-mode . trace) + (edebug-Trace-fast-mode . Trace-fast) + (edebug-go-mode . go) + (edebug-continue-mode . continue) + (edebug-Continue-fast-mode . Continue-fast) + (edebug-Go-nonstop-mode . Go-nonstop)) "Association list between commands and the modes they set.") +(defvar edebug-mode-map) ; will be defined fully later. -'(defun edebug-set-initial-mode () - "Ask for the initial mode of the enclosing function. +(defun edebug-set-initial-mode () + "Set the initial execution mode of Edebug. The mode is requested via the key that would be used to set the mode in edebug-mode." (interactive) - (let* ((this-function (edebug-which-function)) - (keymap (if (eq edebug-mode-map (current-local-map)) - edebug-mode-map)) - (old-mode (or (get this-function 'edebug-initial-mode) - edebug-initial-mode)) + (let* ((old-mode edebug-initial-mode) (key (read-key-sequence (format - "Change initial edebug mode for %s from %s (%s) to (enter key): " - this-function - old-mode - (where-is-internal - (car (rassq old-mode edebug-initial-mode-alist)) - keymap 'firstonly - )))) - (mode (cdr (assq (key-binding key) edebug-initial-mode-alist))) - ) - (if (and mode - (or (get this-function 'edebug-initial-mode) - (not (eq mode edebug-initial-mode)))) + "Change initial edebug mode from %s (%c) to (enter key): " + old-mode + (aref (where-is-internal + (car (rassq old-mode edebug-initial-mode-alist)) + edebug-mode-map 'firstonly) + 0)))) + (mode (cdr (assq (lookup-key edebug-mode-map key) + edebug-initial-mode-alist)))) + (if mode (progn - (put this-function 'edebug-initial-mode mode) - (message "Initial mode for %s is now: %s" - this-function mode)) - (error "Key must map to one of the mode changing commands") - ))) + (setq edebug-initial-mode mode) + (message "Edebug's initial mode is now: %s" mode)) + (error "Key must map to one of the mode changing commands")))) ;;; Evaluation of expressions @@ -3373,7 +3361,7 @@ Return the result of the last expression." (defalias 'edebug-prin1 'prin1) (defalias 'edebug-print 'print) (defalias 'edebug-prin1-to-string 'prin1-to-string) -(defalias 'edebug-format 'format) +(defalias 'edebug-format 'format-message) (defalias 'edebug-message 'message) (defun edebug-eval-expression (expr) @@ -3425,7 +3413,9 @@ be installed in `emacs-lisp-mode-map'.") (define-key emacs-lisp-mode-map "\C-x\C-a\C-s" 'edebug-step-mode) (define-key emacs-lisp-mode-map "\C-x\C-a\C-n" 'edebug-next-mode) (define-key emacs-lisp-mode-map "\C-x\C-a\C-c" 'edebug-go-mode) - (define-key emacs-lisp-mode-map "\C-x\C-a\C-l" 'edebug-where)) + (define-key emacs-lisp-mode-map "\C-x\C-a\C-l" 'edebug-where) + ;; The following isn't a GUD binding. + (define-key emacs-lisp-mode-map "\C-x\C-a\C-m" 'edebug-set-initial-mode)) (defvar edebug-mode-map (let ((map (copy-keymap emacs-lisp-mode-map))) @@ -3790,10 +3780,10 @@ Otherwise call `debug' normally." (if t (progn ;; Delete interspersed edebug internals. - (while (re-search-forward "^ \(?edebug" nil t) + (while (re-search-forward "^ (?edebug" nil t) (beginning-of-line) (cond - ((looking-at "^ \(edebug-after") + ((looking-at "^ (edebug-after") ;; Previous lines may contain code, so just delete this line. (setq last-ok-point (point)) (forward-line 1) diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index 386ff2f7449..06e65b9df80 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el @@ -124,7 +124,7 @@ Summary: (defgeneric ,method ,args) (eieio--defmethod ',method ',key ',class #',code)))) -(defun eieio--generic-static-symbol-specializers (tag) +(defun eieio--generic-static-symbol-specializers (tag &rest _) (cl-assert (or (null tag) (eieio--class-p tag))) (when (eieio--class-p tag) (let ((superclasses (eieio--generic-subclass-specializers tag)) @@ -134,27 +134,25 @@ Summary: (push `(eieio--static ,(cadr superclass)) specializers)) (nreverse specializers)))) -(defconst eieio--generic-static-symbol-generalizer - (cl-generic-make-generalizer - ;; Give it a slightly higher priority than `subclass' so that the - ;; interleaved list comes before subclass's non-interleaved list. - 61 (lambda (name) `(and (symbolp ,name) (cl--find-class ,name))) - #'eieio--generic-static-symbol-specializers)) -(defconst eieio--generic-static-object-generalizer - (cl-generic-make-generalizer - ;; Give it a slightly higher priority than `class' so that the - ;; interleaved list comes before the class's non-interleaved list. - 51 #'cl--generic-struct-tag - (lambda (tag) - (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag)) - (eieio--class-p tag) - (let ((superclasses (eieio--class-precedence-list tag)) - (specializers ())) - (dolist (superclass superclasses) - (setq superclass (eieio--class-name superclass)) - (push superclass specializers) - (push `(eieio--static ,superclass) specializers)) - (nreverse specializers)))))) +(cl-generic-define-generalizer eieio--generic-static-symbol-generalizer + ;; Give it a slightly higher priority than `subclass' so that the + ;; interleaved list comes before subclass's non-interleaved list. + 61 (lambda (name &rest _) `(and (symbolp ,name) (cl--find-class ,name))) + #'eieio--generic-static-symbol-specializers) +(cl-generic-define-generalizer eieio--generic-static-object-generalizer + ;; Give it a slightly higher priority than `class' so that the + ;; interleaved list comes before the class's non-interleaved list. + 51 #'cl--generic-struct-tag + (lambda (tag &rest _) + (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag)) + (eieio--class-p tag) + (let ((superclasses (eieio--class-precedence-list tag)) + (specializers ())) + (dolist (superclass superclasses) + (setq superclass (eieio--class-name superclass)) + (push superclass specializers) + (push `(eieio--static ,superclass) specializers)) + (nreverse specializers))))) (cl-defmethod cl-generic-generalizers ((_specializer (head eieio--static))) (list eieio--generic-static-symbol-generalizer diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 7fcf85c1ced..dcaaab69cf5 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -135,10 +135,10 @@ Currently under control of this var: (or (cl--find-class class) class) class)) -(defun class-p (class) - "Return non-nil if CLASS is a valid class vector. -CLASS is a symbol." ;FIXME: Is it a vector or a symbol? - (and (symbolp class) (eieio--class-p (cl--find-class class)))) +(defun class-p (x) + "Return non-nil if X is a valid class vector. +X can also be is a symbol." + (eieio--class-p (if (symbolp x) (cl--find-class x) x))) (defun eieio--class-print-name (class) "Return a printed representation of CLASS." @@ -219,7 +219,8 @@ It creates an autoload function for CNAME's constructor." ;; turn this into a usable self-pointing symbol (when eieio-backward-compatibility (set cname cname) - (make-obsolete-variable cname (format "use '%s instead" cname) "25.1")) + (make-obsolete-variable cname (format "use \\='%s instead" cname) + "25.1")) ;; Store the new class vector definition into the symbol. We need to ;; do this first so that we can call defmethod for the accessor. @@ -338,7 +339,8 @@ See `defclass' for more information." ;; turn this into a usable self-pointing symbol; FIXME: Why? (when eieio-backward-compatibility (set cname cname) - (make-obsolete-variable cname (format "use '%s instead" cname) "25.1")) + (make-obsolete-variable cname (format "use \\='%s instead" cname) + "25.1")) ;; Create a handy list of the class test too (when eieio-backward-compatibility @@ -357,8 +359,9 @@ See `defclass' for more information." (object-of-class-p (car obj) ,cname))) (setq obj (cdr obj))) ans)))) - (make-obsolete csym (format "use (cl-typep ... '(list-of %s)) instead" - cname) + (make-obsolete csym (format + "use (cl-typep ... \\='(list-of %s)) instead" + cname) "25.1"))) ;; Before adding new slots, let's add all the methods and classes @@ -407,7 +410,7 @@ See `defclass' for more information." (progn (set initarg initarg) (make-obsolete-variable - initarg (format "use '%s instead" initarg) "25.1")))) + initarg (format "use \\='%s instead" initarg) "25.1")))) ;; The customgroup should be a list of symbols. (cond ((and (null customg) custom) @@ -733,7 +736,7 @@ Argument FN is the function calling this verifier." ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) (macroexp--warn-and-return - (format "Unknown slot `%S'" name) exp 'compile-only)) + (format-message "Unknown slot `%S'" name) exp 'compile-only)) (_ exp))))) (cl-check-type slot symbol) (cl-check-type obj (or eieio-object class)) @@ -766,7 +769,8 @@ Fills in OBJ's SLOT with its default value." (cl-check-type obj (or eieio-object class)) (cl-check-type slot symbol) (let* ((cl (cond ((symbolp obj) (cl--find-class obj)) - (t (eieio--object-class obj)))) + ((eieio-object-p obj) (eieio--object-class obj)) + (t obj))) (c (eieio--slot-name-index cl slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. @@ -1055,16 +1059,15 @@ method invocation orders of the involved classes." ;;;; General support to dispatch based on the type of the argument. -(defconst eieio--generic-generalizer - (cl-generic-make-generalizer - ;; Use the exact same tagcode as for cl-struct, so that methods - ;; that dispatch on both kinds of objects get to share this - ;; part of the dispatch code. - 50 #'cl--generic-struct-tag - (lambda (tag) - (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag)) - (mapcar #'eieio--class-name - (eieio--class-precedence-list (symbol-value tag))))))) +(cl-generic-define-generalizer eieio--generic-generalizer + ;; Use the exact same tagcode as for cl-struct, so that methods + ;; that dispatch on both kinds of objects get to share this + ;; part of the dispatch code. + 50 #'cl--generic-struct-tag + (lambda (tag &rest _) + (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag)) + (mapcar #'eieio--class-name + (eieio--class-precedence-list (symbol-value tag)))))) (cl-defmethod cl-generic-generalizers :extra "class" (specializer) ;; CLHS says: @@ -1084,22 +1087,21 @@ method invocation orders of the involved classes." ;; would not make much sense (e.g. to which argument should it apply?). ;; Instead, we add a new "subclass" specializer. -(defun eieio--generic-subclass-specializers (tag) +(defun eieio--generic-subclass-specializers (tag &rest _) (when (eieio--class-p tag) (mapcar (lambda (class) `(subclass ,(eieio--class-name class))) (eieio--class-precedence-list tag)))) -(defconst eieio--generic-subclass-generalizer - (cl-generic-make-generalizer - 60 (lambda (name) `(and (symbolp ,name) (cl--find-class ,name))) - #'eieio--generic-subclass-specializers)) +(cl-generic-define-generalizer eieio--generic-subclass-generalizer + 60 (lambda (name &rest _) `(and (symbolp ,name) (cl--find-class ,name))) + #'eieio--generic-subclass-specializers) (cl-defmethod cl-generic-generalizers ((_specializer (head subclass))) (list eieio--generic-subclass-generalizer)) -;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "ea8c7f24ed47c6b71ac37cbdae1c9931") +;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "11dd361fd4c1c625de90a39977936236") ;;; Generated autoloads from eieio-compat.el (autoload 'eieio--defalias "eieio-compat" "\ diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 0b003360ed5..a5d8b6fcf89 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -141,11 +141,11 @@ are not abstract." (setq location (find-lisp-object-file-name ctr def))) (when location - (insert (substitute-command-keys " in ‘")) + (insert (substitute-command-keys " in `")) (help-insert-xref-button (help-fns-short-filename location) 'cl-type-definition ctr location 'define-type) - (insert (substitute-command-keys "’"))) + (insert (substitute-command-keys "'"))) (insert ".\nCreates an object of class " (symbol-name ctr) ".") (goto-char (point-max)) (if (autoloadp def) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index db96e6eb2dc..790e8bc9e0e 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -235,7 +235,8 @@ This method is obsolete." (let ((f (intern (format "%s-child-p" name)))) `((defalias ',f ',testsym2) (make-obsolete - ',f ,(format "use (cl-typep ... '%s) instead" name) "25.1")))) + ',f ,(format "use (cl-typep ... \\='%s) instead" name) + "25.1")))) ;; When using typep, (typep OBJ 'myclass) returns t for objects which ;; are subclasses of myclass. For our predicates, however, it is @@ -348,10 +349,10 @@ variable name of the same name as the slot." (pcase-defmacro eieio (&rest fields) "Pcase patterns to match EIEIO objects. -Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of -field NAME is matched against UPAT, or they can be of the form NAME which +Elements of FIELDS can be of the form (NAME PAT) in which case the contents of +field NAME is matched against PAT, or they can be of the form NAME which is a shorthand for (NAME NAME)." - (declare (debug (&rest [&or (sexp pcase-UPAT) sexp]))) + (declare (debug (&rest [&or (sexp pcase-PAT) sexp]))) (let ((is (make-symbol "table"))) ;; FIXME: This generates a horrendous mess of redundant let bindings. ;; `pcase' needs to be improved somehow to introduce let-bindings more @@ -683,12 +684,12 @@ This class is not stored in the `parent' slot of a class vector." "Make a new instance of CLASS based on INITARGS. For example: - (make-instance 'foo) + (make-instance \\='foo) INITARGS is a property list with keywords based on the `:initarg' for each slot. For example: - (make-instance 'foo :slot1 value1 :slotN valueN)") + (make-instance \\='foo :slot1 value1 :slotN valueN)") (define-obsolete-function-alias 'constructor #'make-instance "25.1") @@ -983,7 +984,7 @@ Optional argument GROUP is the sub-group of slots to display. ;;;*** -;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "694d44fcd869546592d35f3321f62667") +;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "d00419c898056fadf2f8e491f864aa1e") ;;; Generated autoloads from eieio-opt.el (autoload 'eieio-browse "eieio-opt" "\ diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 032cdec066d..bbc8e153f74 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -261,7 +261,7 @@ Otherwise work like `message'." mode-line-format))) (setq eldoc-mode-line-string (when (stringp format-string) - (apply 'format format-string args))) + (apply #'format-message format-string args))) (force-mode-line-update))) (apply 'message format-string args))) @@ -274,7 +274,7 @@ Otherwise work like `message'." ;; eldoc-last-message so eq test above might succeed on ;; subsequent calls. ((null (cdr args)) (car args)) - (t (apply 'format args)))) + (t (apply #'format-message args)))) ;; In emacs 19.29 and later, and XEmacs 19.13 and later, all messages ;; are recorded in a log. Do not put eldoc messages in that log since ;; they are Legion. @@ -337,8 +337,8 @@ and the face `eldoc-highlight-function-argument', if they are to have any effect. Major modes should modify this variable using `add-function', for example: - (add-function :before-until (local 'eldoc-documentation-function) - #'foo-mode-eldoc-function) + (add-function :before-until (local \\='eldoc-documentation-function) + #\\='foo-mode-eldoc-function) so that the global documentation function (i.e. the default value of the variable) is taken into account if the major mode specific function does not return any documentation.") @@ -410,6 +410,7 @@ return any documentation.") ;; Prime the command list. (eldoc-add-command-completions + "back-to-indentation" "backward-" "beginning-of-" "delete-other-windows" "delete-window" "down-list" "end-of-" "exchange-point-and-mark" "forward-" "goto-" "handle-select-window" "indent-for-tab-command" "left-" "mark-page" diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index fc66c82c81d..64d65c05902 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -249,9 +249,9 @@ This environment can be passed to `macroexpand'." (elint-set-mode-line t) (with-current-buffer elint-log-buffer (unless (string-equal default-directory dir) - (elint-log-message (format " \nLeaving directory `%s'" - default-directory) t) - (elint-log-message (format "Entering directory `%s'" dir) t) + (elint-log-message (format-message " \nLeaving directory `%s'" + default-directory) t) + (elint-log-message (format-message "Entering directory `%s'" dir) t) (setq default-directory dir)))) (let ((str (format "Linting file %s" file))) (message "%s..." str) @@ -374,7 +374,7 @@ Returns the forms." ;; quoted check cannot be elsewhere, since quotes skipped. (if (looking-back "'" (1- (point))) ;; Eg cust-print.el uses ' as a comment syntax. - (elint-warning "Skipping quoted form `'%.20s...'" + (elint-warning "Skipping quoted form `%c%.20s...'" ?\' (read (current-buffer))) (condition-case nil (setq tops (cons @@ -383,7 +383,7 @@ Returns the forms." tops)) (end-of-file (goto-char elint-current-pos) - (error "Missing ')' in top form: %s" + (error "Missing `)' in top form: %s" (buffer-substring elint-current-pos (line-end-position)))))))) (nreverse tops)))) @@ -520,7 +520,7 @@ Return nil if there are no more forms, t otherwise." ;;; (with-syntax-table emacs-lisp-mode-syntax-table ;;; (elint-update-env)) ;;; (setq env (elint-env-add-env env elint-buffer-env)))) - ;;(message "Elint processed (require '%s)" name)) + ;;(message "%s" (format "Elint processed (require '%s)" name)) (error "%s.el not found in load-path" libname))) (error (message "Can't get variables from require'd library %s: %s" @@ -982,7 +982,7 @@ Does basic handling of `featurep' tests." (line-beginning-position)))) 0) ; unknown position type - (apply 'format string args)))) + (apply #'format-message string args)))) (defun elint-error (string &rest args) "Report a linting error. diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 647784b8552..f899f40fb80 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -137,7 +137,7 @@ the name of the test and the result of NAME-FORM." This effectively executes - \(apply (car COMMAND) (cdr COMMAND)\) + (apply (car COMMAND) (cdr COMMAND)) and returns the same value, but additionally runs hooks like `pre-command-hook' and `post-command-hook', and sets variables @@ -189,7 +189,7 @@ test for `called-interactively' in the command will fail." "Return a copy of S with all matches of REGEXPS removed. Elements of REGEXPS may also be two-element lists \(REGEXP -SUBEXP\), where SUBEXP is the number of a subexpression in +SUBEXP), where SUBEXP is the number of a subexpression in REGEXP. In that case, only that subexpression will be removed rather than the entire match." ;; Use a temporary buffer since replace-match copies strings, which @@ -214,8 +214,8 @@ property list, or no properties if there is no plist before it. As a simple example, -\(ert-propertized-string \"foo \" '(face italic) \"bar\" \" baz\" nil \ -\" quux\"\) +\(ert-propertized-string \"foo \" \\='(face italic) \"bar\" \" baz\" nil \ +\" quux\") would return the string \"foo bar baz quux\" where the substring \"bar baz\" has a `face' property with the value `italic'. diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 99c5ede33a0..21c1f1be394 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -64,7 +64,7 @@ (require 'ewoc) (require 'find-func) (require 'help) - +(require 'pp) ;;; UI customization options. @@ -187,7 +187,7 @@ using :expected-result. See `ert-test-result-type-p' for a description of valid values for RESULT-TYPE. \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ -\[:tags '(TAG...)] BODY...)" +[:tags '(TAG...)] BODY...)" (declare (debug (&define :name test name sexp [&optional stringp] [&rest keywordp sexp] def-body)) @@ -887,10 +887,10 @@ Valid result types: nil -- Never matches. t -- Always matches. :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. -\(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with +\(and TYPES...) -- Matches if all TYPES match. +\(or TYPES...) -- Matches if some TYPES match. +\(not TYPE) -- Matches if TYPE does not match. +\(satisfies PREDICATE) -- Matches if PREDICATE returns true when called with RESULT." ;; It would be easy to add `member' and `eql' types etc., but I ;; haven't bothered yet. @@ -946,7 +946,7 @@ a test -- (i.e., an object of the ert-test data-type) Selects that test. a symbol -- Selects the test that the symbol names, errors if none. \(member TESTS...) -- Selects the elements of TESTS, a list of tests or symbols naming tests. -\(eql TEST\) -- Selects TEST, a test or a symbol naming a test. +\(eql TEST) -- Selects TEST, a test or a symbol naming a test. \(and SELECTORS...) -- Selects the tests that match all SELECTORS. \(or SELECTORS...) -- Selects the tests that match any of the SELECTORS. \(not SELECTOR) -- Selects all tests that do not match SELECTOR. @@ -1300,7 +1300,8 @@ EXPECTEDP specifies whether the result was expected." (defun ert--pp-with-indentation-and-newline (object) "Pretty-print OBJECT, indenting it to the current column of point. Ensures a final newline is inserted." - (let ((begin (point))) + (let ((begin (point)) + (pp-escape-newlines nil)) (pp object (current-buffer)) (unless (bolp) (insert "\n")) (save-excursion @@ -2065,7 +2066,7 @@ and how to display message." "--" ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point] ["Show messages" ert-results-pop-to-messages-for-test-at-point] - ["Show ‘should’ forms" ert-results-pop-to-should-forms-for-test-at-point] + ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point] ["Describe test" ert-results-describe-test-at-point] "--" ["Delete test" ert-delete-test] @@ -2377,9 +2378,9 @@ To be used in the ERT results buffer." (ert--print-backtrace backtrace) (debugger-make-xrefs) (goto-char (point-min)) - (insert "Backtrace for test ‘") + (insert (substitute-command-keys "Backtrace for test `")) (ert-insert-test-name-button (ert-test-name test)) - (insert "’:\n"))))))) + (insert (substitute-command-keys "':\n")))))))) (defun ert-results-pop-to-messages-for-test-at-point () "Display the part of the *Messages* buffer generated during the test at point. @@ -2398,9 +2399,9 @@ To be used in the ERT results buffer." (ert-simple-view-mode) (insert (ert-test-result-messages result)) (goto-char (point-min)) - (insert "Messages for test ‘") + (insert (substitute-command-keys "Messages for test `")) (ert-insert-test-name-button (ert-test-name test)) - (insert "’:\n"))))) + (insert (substitute-command-keys "':\n")))))) (defun ert-results-pop-to-should-forms-for-test-at-point () "Display the list of `should' forms executed during the test at point. @@ -2428,9 +2429,10 @@ To be used in the ERT results buffer." (ert--pp-with-indentation-and-newline form-description) (ert--make-xrefs-region begin (point))))) (goto-char (point-min)) - (insert "‘should’ forms executed during test ‘") + (insert (substitute-command-keys + "`should' forms executed during test `")) (ert-insert-test-name-button (ert-test-name test)) - (insert "’:\n") + (insert (substitute-command-keys "':\n")) (insert "\n") (insert (concat "(Values are shallow copies and may have " "looked different during the test if they\n" @@ -2507,9 +2509,11 @@ To be used in the ERT results buffer." (let ((file-name (and test-name (symbol-file test-name 'ert-deftest)))) (when file-name - (insert " defined in ‘" (file-name-nondirectory file-name) "’") + (insert (format-message " defined in `%s'" + (file-name-nondirectory file-name))) (save-excursion - (re-search-backward "‘\\([^‘’]+\\)’" nil t) + (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") + nil t) (help-xref-button 1 'help-function-def test-name file-name))) (insert ".") (fill-region-as-paragraph (point-min) (point)) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index cd23cd77f4a..69d545560d4 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -62,7 +62,7 @@ ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ foo\\|\\(?:[^icfgv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ menu-bar-make-toggle\\)" find-function-space-re - "\\('\\|\(quote \\)?%s\\(\\s-\\|$\\|\(\\|\)\\)") + "\\('\\|(quote \\)?%s\\(\\s-\\|$\\|[()]\\)") "The regexp used by `find-function' to search for a function definition. Note it must contain a `%s' at the place where `format' should insert the function name. The default value avoids `defconst', @@ -100,10 +100,34 @@ Please send improvements and fixes to the maintainer." :group 'find-function :version "22.1") +(defcustom find-feature-regexp + (concat ";;; Code:") + "The regexp used by `xref-find-definitions' when searching for a feature definition. +Note it must contain a `%s' at the place where `format' +should insert the feature name." + ;; We search for ";;; Code" rather than (feature '%s) because the + ;; former is near the start of the code, and the latter is very + ;; uninteresting. If the regexp is not found, just goes to + ;; (point-min), which is acceptable in this case. + :type 'regexp + :group 'xref + :version "25.0") + +(defcustom find-alias-regexp + "(defalias +'%s" + "The regexp used by `xref-find-definitions' to search for an alias definition. +Note it must contain a `%s' at the place where `format' +should insert the feature name." + :type 'regexp + :group 'xref + :version "25.0") + (defvar find-function-regexp-alist '((nil . find-function-regexp) (defvar . find-variable-regexp) - (defface . find-face-regexp)) + (defface . find-face-regexp) + (feature . find-feature-regexp) + (defalias . find-alias-regexp)) "Alist mapping definition types into regexp variables. Each regexp variable's value should actually be a format string to be used to substitute the desired symbol name into the regexp. @@ -343,10 +367,11 @@ message about the whole chain of aliases." (not verbose) (setq aliases (if aliases (concat aliases - (format ", which is an alias for `%s'" - (symbol-name def))) - (format "`%s' is an alias for `%s'" - function (symbol-name def))))) + (format-message + ", which is an alias for `%s'" + (symbol-name def))) + (format-message "`%s' is an alias for `%s'" + function (symbol-name def))))) (setq function (find-function-advised-original function) def (find-function-advised-original function))) (if aliases diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index e67888cc060..94fe6c3d441 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -218,7 +218,7 @@ return a Lisp form that does the assignment. The first arg in ARGLIST (the one that receives VAL) receives an expression which can do arbitrary things, whereas the other arguments are all guaranteed to be pure and copyable. Example use: - (gv-define-setter aref (v a i) `(aset ,a ,i ,v))" + (gv-define-setter aref (v a i) \\=`(aset ,a ,i ,v))" (declare (indent 2) (debug (&define name sexp body))) `(gv-define-expander ,name (lambda (do &rest args) @@ -233,7 +233,7 @@ turned into calls of the form (SETTER ARGS... VAL). If FIX-RETURN is non-nil, then SETTER is not assumed to return VAL and instead the assignment is turned into something equivalent to - \(let ((temp VAL)) + (let ((temp VAL)) (SETTER ARGS... temp) temp) so as to preserve the semantics of `setf'." diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index 104c23c2102..393f0dd99e8 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -265,16 +265,17 @@ a section." (defun lm-header (header) "Return the contents of the header named HEADER." - (goto-char (point-min)) - (let ((case-fold-search t)) - (when (and (re-search-forward (lm-get-header-re header) (lm-code-mark) t) - ;; RCS ident likes format "$identifier: data$" - (looking-at - (if (save-excursion - (skip-chars-backward "^$" (match-beginning 0)) - (= (point) (match-beginning 0))) - "[^\n]+" "[^$\n]+"))) - (match-string-no-properties 0)))) + (save-excursion + (goto-char (point-min)) + (let ((case-fold-search t)) + (when (and (re-search-forward (lm-get-header-re header) (lm-code-mark) t) + ;; RCS ident likes format "$identifier: data$" + (looking-at + (if (save-excursion + (skip-chars-backward "^$" (match-beginning 0)) + (= (point) (match-beginning 0))) + "[^\n]+" "[^$\n]+"))) + (match-string-no-properties 0))))) (defun lm-header-multiline (header) "Return the contents of the header named HEADER, with continuation lines. @@ -551,11 +552,11 @@ copyright notice is allowed." ((not (lm-keywords-finder-p)) "`Keywords:' has no valid finder keywords (see `finder-known-keywords')") ((not (lm-commentary-mark)) - "Can't find a 'Commentary' section marker") + "Can't find a `Commentary' section marker") ((not (lm-history-mark)) - "Can't find a 'History' section marker") + "Can't find a `History' section marker") ((not (lm-code-mark)) - "Can't find a 'Code' section marker") + "Can't find a `Code' section marker") ((progn (goto-char (point-max)) (not diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 8aa34c7bef9..9ce0dfd49e8 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -28,6 +28,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defvar font-lock-comment-face) (defvar font-lock-doc-face) (defvar font-lock-keywords-case-fold-search) @@ -87,6 +89,9 @@ table) "Syntax table used in `lisp-mode'.") +(eval-and-compile + (defconst lisp-mode-symbol-regexp "\\(?:\\sw\\|\\s_\\|\\\\.\\)+")) + (defvar lisp-imenu-generic-expression (list (list nil @@ -110,7 +115,7 @@ ;; CLOS and EIEIO "defgeneric" "defmethod") t)) - "\\s-+\\(\\(\\sw\\|\\s_\\)+\\)")) + "\\s-+\\(" lisp-mode-symbol-regexp "\\)")) 2) (list (purecopy "Variables") (purecopy (concat "^\\s-*(" @@ -122,11 +127,11 @@ "defconstant" "defparameter" "define-symbol-macro") t)) - "\\s-+\\(\\(\\sw\\|\\s_\\)+\\)")) + "\\s-+\\(" lisp-mode-symbol-regexp "\\)")) 2) ;; For `defvar', we ignore (defvar FOO) constructs. (list (purecopy "Variables") - (purecopy (concat "^\\s-*(defvar\\s-+\\(\\(\\sw\\|\\s_\\)+\\)" + (purecopy (concat "^\\s-*(defvar\\s-+\\(" lisp-mode-symbol-regexp "\\)" "[[:space:]\n]+[^)]")) 1) (list (purecopy "Types") @@ -143,7 +148,7 @@ ;; CLOS and EIEIO "defclass") t)) - "\\s-+'?\\(\\(\\sw\\|\\s_\\)+\\)")) + "\\s-+'?\\(" lisp-mode-symbol-regexp "\\)")) 2)) "Imenu generic expression for Lisp mode. See `imenu-generic-expression'.") @@ -220,7 +225,10 @@ (defun lisp--el-match-keyword (limit) ;; FIXME: Move to elisp-mode.el. (catch 'found - (while (re-search-forward "(\\(\\(?:\\sw\\|\\s_\\)+\\)\\_>" limit t) + (while (re-search-forward + (eval-when-compile + (concat "(\\(" lisp-mode-symbol-regexp "\\)\\_>")) + limit t) (let ((sym (intern-soft (match-string 1)))) (when (or (special-form-p sym) (and (macrop sym) @@ -229,6 +237,23 @@ (match-beginning 0))))) (throw 'found t)))))) +(defmacro let-when-compile (bindings &rest body) + "Like `let*', but allow for compile time optimization. +Use BINDINGS as in regular `let*', but in BODY each usage should +be wrapped in `eval-when-compile'. +This will generate compile-time constants from BINDINGS." + (declare (indent 1) (debug let)) + (letrec ((loop + (lambda (bindings) + (if (null bindings) + (macroexpand-all (macroexp-progn body) + macroexpand-all-environment) + (let ((binding (pop bindings))) + (cl-progv (list (car binding)) + (list (eval (nth 1 binding) t)) + (funcall loop bindings))))))) + (funcall loop bindings))) + (let-when-compile ((lisp-fdefs '("defmacro" "defun")) (lisp-vdefs '("defvar")) @@ -249,39 +274,13 @@ (el-vdefs '("defconst" "defcustom" "defvaralias" "defvar-local" "defface")) (el-tdefs '("defgroup" "deftheme")) - (el-kw '("while-no-input" "letrec" "pcase" "pcase-exhaustive" - "pcase-lambda" "pcase-let" "pcase-let*" "save-restriction" - "save-excursion" "save-selected-window" - ;; "eval-after-load" "eval-next-after-load" - "save-window-excursion" "save-current-buffer" - "save-match-data" "combine-after-change-calls" - "condition-case-unless-debug" "track-mouse" - "eval-and-compile" "eval-when-compile" "with-case-table" - "with-category-table" "with-coding-priority" - "with-current-buffer" "with-demoted-errors" - "with-electric-help" "with-eval-after-load" - "with-file-modes" - "with-local-quit" "with-no-warnings" - "with-output-to-temp-buffer" "with-selected-window" - "with-selected-frame" "with-silent-modifications" - "with-syntax-table" "with-temp-buffer" "with-temp-file" - "with-temp-message" "with-timeout" - "with-timeout-handler")) (el-errs '("user-error")) ;; Common-Lisp constructs supported by EIEIO. FIXME: namespace. (eieio-fdefs '("defgeneric" "defmethod")) (eieio-tdefs '("defclass")) - (eieio-kw '("with-slots")) ;; Common-Lisp constructs supported by cl-lib. - (cl-lib-fdefs '("defmacro" "defsubst" "defun" "defmethod")) + (cl-lib-fdefs '("defmacro" "defsubst" "defun" "defmethod" "defgeneric")) (cl-lib-tdefs '("defstruct" "deftype")) - (cl-lib-kw '("progv" "eval-when" "case" "ecase" "typecase" - "etypecase" "ccase" "ctypecase" "loop" "do" "do*" - "the" "locally" "proclaim" "declaim" "letf" "go" - ;; "lexical-let" "lexical-let*" - "symbol-macrolet" "flet" "flet*" "destructuring-bind" - "labels" "macrolet" "tagbody" "multiple-value-bind" - "block" "return" "return-from")) (cl-lib-errs '("assert" "check-type")) ;; Common-Lisp constructs not supported by cl-lib. (cl-fdefs '("defsetf" "define-method-combination" @@ -290,14 +289,20 @@ "define-compiler-macro" "define-modify-macro")) (cl-vdefs '("define-symbol-macro" "defconstant" "defparameter")) (cl-tdefs '("defpackage" "defstruct" "deftype")) - (cl-kw '("prog" "prog*" "handler-case" "handler-bind" - "in-package" "restart-case" ;; "inline" - "restart-bind" "break" "multiple-value-prog1" - "compiler-let" "with-accessors" "with-compilation-unit" + (cl-kw '("block" "break" "case" "ccase" "compiler-let" "ctypecase" + "declaim" "destructuring-bind" "do" "do*" + "ecase" "etypecase" "eval-when" "flet" "flet*" + "go" "handler-case" "handler-bind" "in-package" ;; "inline" + "labels" "letf" "locally" "loop" + "macrolet" "multiple-value-bind" "multiple-value-prog1" + "proclaim" "prog" "prog*" "progv" + "restart-case" "restart-bind" "return" "return-from" + "symbol-macrolet" "tagbody" "the" "typecase" + "with-accessors" "with-compilation-unit" "with-condition-restarts" "with-hash-table-iterator" "with-input-from-string" "with-open-file" "with-open-stream" "with-package-iterator" - "with-simple-restart" "with-standard-io-syntax")) + "with-simple-restart" "with-slots" "with-standard-io-syntax")) (cl-errs '("abort" "cerror"))) (let ((vdefs (eval-when-compile (append lisp-vdefs el-vdefs cl-vdefs))) @@ -318,16 +323,9 @@ eieio-fdefs eieio-tdefs cl-fdefs cl-vdefs cl-tdefs) t))) - ;; Elisp and Common Lisp keywords. - ;; (el-kws-re (eval-when-compile - ;; (regexp-opt (append - ;; lisp-kw el-kw eieio-kw - ;; (cons "go" (mapcar (lambda (s) (concat "cl-" s)) - ;; (remove "go" cl-lib-kw)))) - ;; t))) + ;; Common Lisp keywords (Elisp keywords are handled dynamically). (cl-kws-re (eval-when-compile - (regexp-opt (append lisp-kw cl-kw eieio-kw cl-lib-kw) - t))) + (regexp-opt (append lisp-kw cl-kw) t))) ;; Elisp and Common Lisp "errors". (el-errs-re (eval-when-compile (regexp-opt (append (mapcar (lambda (s) (concat "cl-" s)) @@ -349,7 +347,8 @@ ;; Any whitespace and defined object. "[ \t']*" "\\(([ \t']*\\)?" ;; An opening paren. - "\\(\\(setf\\)[ \t]+\\(?:\\sw\\|\\s_\\)+\\|\\(?:\\sw\\|\\s_\\)+\\)?") + "\\(\\(setf\\)[ \t]+" lisp-mode-symbol-regexp + "\\|" lisp-mode-symbol-regexp "\\)?") (1 font-lock-keyword-face) (3 (let ((type (get (intern-soft (match-string 1)) 'lisp-define-type))) (cond ((eq type 'var) font-lock-variable-name-face) @@ -360,7 +359,8 @@ ;; defmethod with (setf foo) as name. ((or (not (match-string 2)) ;; Normal defun. (and (match-string 2) ;; Setf method. - (match-string 4))) font-lock-function-name-face))) + (match-string 4))) + font-lock-function-name-face))) nil t)) ;; Emacs Lisp autoload cookies. Supports the slightly different ;; forms used by mh-e, calendar, etc. @@ -373,7 +373,8 @@ ;; Any whitespace and defined object. "[ \t']*" "\\(([ \t']*\\)?" ;; An opening paren. - "\\(\\(setf\\)[ \t]+\\(?:\\sw\\|\\s_\\)+\\|\\(?:\\sw\\|\\s_\\)+\\)?") + "\\(\\(setf\\)[ \t]+" lisp-mode-symbol-regexp + "\\|" lisp-mode-symbol-regexp "\\)?") (1 font-lock-keyword-face) (3 (let ((type (get (intern-soft (match-string 1)) 'lisp-define-type))) (cond ((eq type 'var) font-lock-variable-name-face) @@ -395,22 +396,25 @@ (lisp--el-match-keyword . 1) ;; Exit/Feature symbols as constants. (,(concat "(\\(catch\\|throw\\|featurep\\|provide\\|require\\)\\_>" - "[ \t']*\\(\\(?:\\sw\\|\\s_\\)+\\)?") + "[ \t']*\\(" lisp-mode-symbol-regexp "\\)?") (1 font-lock-keyword-face) (2 font-lock-constant-face nil t)) ;; Erroneous structures. (,(concat "(" el-errs-re "\\_>") (1 font-lock-warning-face)) ;; Words inside \\[] tend to be for `substitute-command-keys'. - ("\\\\\\\\\\[\\(\\(?:\\sw\\|\\s_\\)+\\)\\]" + (,(concat "\\\\\\\\\\[\\(" lisp-mode-symbol-regexp "\\)\\]") (1 font-lock-constant-face prepend)) ;; Words inside ‘’ and '' and `' tend to be symbol names. - ("['`‘]\\(\\(?:\\sw\\|\\s_\\)\\(?:\\sw\\|\\s_\\)+\\)['’]" + (,(concat "['`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)" + lisp-mode-symbol-regexp "\\)['’]") (1 font-lock-constant-face prepend)) ;; Constant values. - ("\\_<:\\(?:\\sw\\|\\s_\\)+\\_>" 0 font-lock-builtin-face) + (,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>") + (0 font-lock-builtin-face)) ;; ELisp and CLisp `&' keywords as types. - ("\\_<\\&\\(?:\\sw\\|\\s_\\)+\\_>" . font-lock-type-face) + (,(concat "\\_<\\&" lisp-mode-symbol-regexp "\\_>") + . font-lock-type-face) ;; ELisp regexp grouping constructs (,(lambda (bound) (catch 'found @@ -447,19 +451,22 @@ (,(concat "(" cl-kws-re "\\_>") . 1) ;; Exit/Feature symbols as constants. (,(concat "(\\(catch\\|throw\\|provide\\|require\\)\\_>" - "[ \t']*\\(\\(?:\\sw\\|\\s_\\)+\\)?") + "[ \t']*\\(" lisp-mode-symbol-regexp "\\)?") (1 font-lock-keyword-face) (2 font-lock-constant-face nil t)) ;; Erroneous structures. (,(concat "(" cl-errs-re "\\_>") (1 font-lock-warning-face)) ;; Words inside ‘’ and '' and `' tend to be symbol names. - ("['`‘]\\(\\(?:\\sw\\|\\s_\\)\\(?:\\sw\\|\\s_\\)+\\)['’]" + (,(concat "['`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)" + lisp-mode-symbol-regexp "\\)['’]") (1 font-lock-constant-face prepend)) ;; Constant values. - ("\\_<:\\(?:\\sw\\|\\s_\\)+\\_>" 0 font-lock-builtin-face) + (,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>") + (0 font-lock-builtin-face)) ;; ELisp and CLisp `&' keywords as types. - ("\\_<\\&\\(?:\\sw\\|\\s_\\)+\\_>" . font-lock-type-face) + (,(concat "\\_<\\&" lisp-mode-symbol-regexp "\\_>") + . font-lock-type-face) ;; This is too general -- rms. ;; A user complained that he has functions whose names start with `do' ;; and that they get the wrong color. @@ -482,7 +489,10 @@ (let* ((firstsym (and listbeg (save-excursion (goto-char listbeg) - (and (looking-at "([ \t\n]*\\(\\(\\sw\\|\\s_\\)+\\)") + (and (looking-at + (eval-when-compile + (concat "([ \t\n]*\\(" + lisp-mode-symbol-regexp "\\)"))) (match-string 1))))) (docelt (and firstsym (function-get (intern-soft firstsym) @@ -898,7 +908,7 @@ property `lisp-indent-function' (or the deprecated `lisp-indent-hook'), it specifies how to indent. The property value can be: * `defun', meaning indent `defun'-style - \(this is also the case if there is no property and the function + (this is also the case if there is no property and the function has a name that begins with \"def\", and three or more arguments); * an integer N, meaning indent the first N arguments specially diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 7b7b48c66de..ca977db4b1d 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -364,8 +364,7 @@ is called as a function to find the defun's beginning." (arg-+ve (> arg 0))) (save-restriction (widen) - (let ((ppss (let (syntax-begin-function - font-lock-beginning-of-syntax-function) + (let ((ppss (let (syntax-begin-function) (syntax-ppss))) ;; position of least enclosing paren, or nil. encl-pos) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index ffc6585e191..8983454d318 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -1,4 +1,4 @@ -;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t; coding: utf-8 -*- +;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t -*- ;; ;; Copyright (C) 2004-2015 Free Software Foundation, Inc. ;; @@ -146,11 +146,12 @@ and also to avoid outputting the warning during normal execution." (defun macroexp--obsolete-warning (fun obsolescence-data type) (let ((instead (car obsolescence-data)) (asof (nth 2 obsolescence-data))) - (format "`%s' is an obsolete %s%s%s" fun type - (if asof (concat " (as of " asof ")") "") - (cond ((stringp instead) (concat "; " instead)) - (instead (format "; use `%s' instead." instead)) - (t "."))))) + (format-message + "`%s' is an obsolete %s%s%s" fun type + (if asof (concat " (as of " asof ")") "") + (cond ((stringp instead) (concat "; " (substitute-command-keys instead))) + (instead (format-message "; use `%s' instead." instead)) + (t "."))))) (defun macroexpand-1 (form &optional environment) "Perform (at most) one step of macroexpansion." @@ -321,8 +322,9 @@ definitions to shadow the loaded ones for use in file byte-compilation." (if (cdr exps) `(progn ,@exps) (car exps))) (defun macroexp-unprogn (exp) - "Turn EXP into a list of expressions to execute in sequence." - (if (eq (car-safe exp) 'progn) (cdr exp) (list exp))) + "Turn EXP into a list of expressions to execute in sequence. +Never returns an empty list." + (if (eq (car-safe exp) 'progn) (or (cdr exp) '(nil)) (list exp))) (defun macroexp-let* (bindings exp) "Return an expression equivalent to `(let* ,bindings ,exp)." @@ -332,22 +334,33 @@ definitions to shadow the loaded ones for use in file byte-compilation." (t `(let* ,bindings ,exp)))) (defun macroexp-if (test then else) - "Return an expression equivalent to `(if ,test ,then ,else)." + "Return an expression equivalent to `(if ,TEST ,THEN ,ELSE)." (cond ((eq (car-safe else) 'if) - (if (equal test (nth 1 else)) - ;; Doing a test a second time: get rid of the redundancy. - `(if ,test ,then ,@(nthcdr 3 else)) - `(cond (,test ,then) - (,(nth 1 else) ,(nth 2 else)) - (t ,@(nthcdr 3 else))))) + (cond + ;; Drop this optimization: It's unsafe (it assumes that `test' is + ;; pure, or at least idempotent), and it's not used even a single + ;; time while compiling Emacs's sources. + ;;((equal test (nth 1 else)) + ;; ;; Doing a test a second time: get rid of the redundancy. + ;; (message "macroexp-if: sharing 'test' %S" test) + ;; `(if ,test ,then ,@(nthcdr 3 else))) + ((equal then (nth 2 else)) + ;; (message "macroexp-if: sharing 'then' %S" then) + `(if (or ,test ,(nth 1 else)) ,then ,@(nthcdr 3 else))) + ((equal (macroexp-unprogn then) (nthcdr 3 else)) + ;; (message "macroexp-if: sharing 'then' with not %S" then) + `(if (or ,test (not ,(nth 1 else))) + ,then ,@(macroexp-unprogn (nth 2 else)))) + (t + `(cond (,test ,@(macroexp-unprogn then)) + (,(nth 1 else) ,@(macroexp-unprogn (nth 2 else))) + (t ,@(nthcdr 3 else)))))) ((eq (car-safe else) 'cond) - `(cond (,test ,then) - ;; Doing a test a second time: get rid of the redundancy, as above. - ,@(remove (assoc test else) (cdr else)))) + `(cond (,test ,@(macroexp-unprogn then)) ,@(cdr else))) ;; Invert the test if that lets us reduce the depth of the tree. ((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then)) - (t `(if ,test ,then ,else)))) + (t `(if ,test ,then ,@(macroexp-unprogn else))))) (defmacro macroexp-let2 (test sym exp &rest body) "Evaluate BODY with SYM bound to an expression for EXP's value. diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index 08b34fbe2fe..b8fb540d6cb 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -44,7 +44,7 @@ Takes args PROMPTER ACTOR LIST, and optional args HELP and ACTION-ALIST. LIST is a list of objects, or a function of no arguments to return the next object or nil. -If PROMPTER is a string, the prompt is \(format PROMPTER OBJECT\). If not +If PROMPTER is a string, the prompt is \(format PROMPTER OBJECT). If not a string, PROMPTER is a function of one arg (an object from LIST), which returns a string to be used as the prompt for that object. If the return value is not a string, it may be nil to ignore the object or non-nil to act @@ -56,7 +56,7 @@ which gets called with each object that the user answers `yes' for. If HELP is given, it is a list (OBJECT OBJECTS ACTION), where OBJECT is a string giving the singular noun for an elt of LIST; OBJECTS is the plural noun for elts of LIST, and ACTION is a transitive -verb describing ACTOR. The default is \(\"object\" \"objects\" \"act on\"\). +verb describing ACTOR. The default is \(\"object\" \"objects\" \"act on\"). At the prompts, the user may enter y, Y, or SPC to act on that object; n, N, or DEL to skip that object; ! to act on all following objects; @@ -198,7 +198,8 @@ Returns the number of actions taken." (objects (if help (nth 1 help) "objects")) (action (if help (nth 2 help) "act on"))) (concat - (format "Type SPC or `y' to %s the current %s; + (format-message "\ +Type SPC or `y' to %s the current %s; DEL or `n' to skip the current %s; RET or `q' to give up on the %s (skip all remaining %s); C-g to quit (cancel the whole command); diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index 5014571a37b..98a3565f2c7 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -45,16 +45,20 @@ (require 'seq) (pcase-defmacro map (&rest args) - "pcase pattern matching map elements. -Matches if the object is a map (list, hash-table or array), and -binds values from ARGS to their corresponding elements of the map. + "Build a `pcase' pattern matching map elements. -ARGS can be a list elements of the form (KEY PAT), in which case -KEY in an unquoted form. +The `pcase' pattern will match each element of PATTERN against +the corresponding elements of the map. + +Extra elements of the map are ignored if fewer ARGS are +given, and the match does not fail. + +ARGS can be a list of the form (KEY PAT), in which case KEY in an +unquoted form. ARGS can also be a list of symbols, which stands for ('SYMBOL SYMBOL)." - `(and (pred map-p) + `(and (pred mapp) ,@(map--make-pcase-bindings args))) (defmacro map-let (keys map &rest body) @@ -88,7 +92,7 @@ Return RESULT if non-nil or the result of evaluation of the form." (t (error "Unsupported map: %s" ,map-var))))) (defun map-elt (map key &optional default) - "Perform a lookup in MAP of KEY and return its associated value. + "Lookup KEY in MAP and return its associated value. If KEY is not found, return DEFAULT which defaults to nil. If MAP is a list, `eql' is used to lookup KEY. @@ -118,7 +122,7 @@ MAP can be a list, hash-table or array." default))) (defmacro map-put (map key value) - "In MAP, associate KEY with VALUE and return MAP. + "Associate KEY with VALUE in MAP and return MAP. If KEY is already present in MAP, replace the associated value with VALUE. @@ -129,8 +133,9 @@ MAP can be a list, hash-table or array." ,map))) (defmacro map-delete (map key) - "In MAP, delete the key KEY if present and return MAP. -If MAP is an array, store nil at the index KEY. + "Delete KEY from MAP and return MAP. +No error is signaled if KEY is not a key of MAP. If MAP is an +array, store nil at the index KEY. MAP can be a list, hash-table or array." (declare (debug t)) @@ -150,7 +155,7 @@ MAP can be a list, hash-table or array." Map can be a nested map composed of alists, hash-tables and arrays." (or (seq-reduce (lambda (acc key) - (when (map-p acc) + (when (mapp acc) (map-elt acc key))) keys map) @@ -234,14 +239,14 @@ MAP can be a list, hash-table or array." (map-filter (lambda (key val) (not (funcall pred key val))) map)) -(defun map-p (map) +(defun mapp (map) "Return non-nil if MAP is a map (list, hash-table or array)." (or (listp map) (hash-table-p map) (arrayp map))) (defun map-empty-p (map) - "Return non-nil is MAP is empty. + "Return non-nil if MAP is empty. MAP can be a list, hash-table or array." (map--dispatch map @@ -249,21 +254,22 @@ MAP can be a list, hash-table or array." :array (seq-empty-p map) :hash-table (zerop (hash-table-count map)))) -(defun map-contains-key-p (map key &optional testfn) - "Return non-nil if MAP contain the key KEY, nil otherwise. +(defun map-contains-key (map key &optional testfn) + "Return non-nil if MAP contain KEY, nil otherwise. Equality is defined by TESTFN if non-nil or by `equal' if nil. MAP can be a list, hash-table or array." - (seq-contains-p (map-keys map) key testfn)) + (seq-contains (map-keys map) key testfn)) -(defun map-some-p (pred map) - "Return a key/value pair for which (PRED key val) is non-nil in MAP. +(defun map-some (pred map) + "Return a non-nil if (PRED key val) is non-nil for any key/value pair in MAP. MAP can be a list, hash-table or array." (catch 'map--break (map-apply (lambda (key value) - (when (funcall pred key value) - (throw 'map--break (cons key value)))) + (let ((result (funcall pred key value))) + (when result + (throw 'map--break result)))) map) nil)) @@ -273,20 +279,35 @@ MAP can be a list, hash-table or array." MAP can be a list, hash-table or array." (catch 'map--break (map-apply (lambda (key value) - (or (funcall pred key value) - (throw 'map--break nil))) - map) + (or (funcall pred key value) + (throw 'map--break nil))) + map) t)) (defun map-merge (type &rest maps) - "Merge into a map of type TYPE all the key/value pairs in the maps MAPS. + "Merge into a map of type TYPE all the key/value pairs in MAPS. + +MAP can be a list, hash-table or array." + (let (result) + (while maps + (map-apply (lambda (key value) + (setf (map-elt result key) value)) + (pop maps))) + (map-into result type))) +(defun map-merge-with (type function &rest maps) + "Merge into a map of type TYPE all the key/value pairs in MAPS. +When two maps contain the same key, call FUNCTION on the two +values and use the value returned by it. MAP can be a list, hash-table or array." (let (result) (while maps (map-apply (lambda (key value) - (setf (map-elt result key) value)) - (pop maps))) + (setf (map-elt result key) + (if (map-contains-key result key) + (funcall function (map-elt result key) value) + value))) + (pop maps))) (map-into result type))) (defun map-into (map type) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 5a59a980feb..2cd34e12810 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -95,7 +95,7 @@ Each element has the form (WHERE BYTECODE STACK) where: (propertize (format "%s advice: " where) 'face 'warning) (let ((fun (advice--car flist))) - (if (symbolp fun) (format "`%S'" fun) + (if (symbolp fun) (format-message "`%S'" fun) (let* ((name (cdr (assq 'name (advice--props flist)))) (doc (documentation fun t)) (usage (help-split-fundoc doc function))) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 967720881f6..2962da5a917 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -234,7 +234,7 @@ of it available such that: This variable has three possible values: nil: no packages are hidden; - archive: only criteria (a) is used; + `archive': only criteria (a) is used; t: both criteria are used. This variable has no effect if `package-menu--hide-packages' is @@ -639,6 +639,28 @@ specifying the minimum acceptable version." (require 'finder-inf nil t) ; For `package--builtins'. (assq package package--builtins)))))) +(defun package--autoloads-file-name (pkg-desc) + "Return the absolute name of the autoloads file, sans extension. +PKG-DESC is a `package-desc' object." + (expand-file-name + (format "%s-autoloads" (package-desc-name pkg-desc)) + (package-desc-dir pkg-desc))) + +(defun package--activate-autoloads-and-load-path (pkg-desc) + "Load the autoloads file and add package dir to `load-path'. +PKG-DESC is a `package-desc' object." + (let* ((old-lp load-path) + (pkg-dir (package-desc-dir pkg-desc)) + (pkg-dir-dir (file-name-as-directory pkg-dir))) + (with-demoted-errors "Error loading autoloads: %s" + (load (package--autoloads-file-name pkg-desc) nil t)) + (when (and (eq old-lp load-path) + (not (or (member pkg-dir load-path) + (member pkg-dir-dir load-path)))) + ;; Old packages don't add themselves to the `load-path', so we have to + ;; do it ourselves. + (push pkg-dir load-path)))) + (defvar Info-directory-list) (declare-function info-initialize "info" ()) @@ -648,24 +670,14 @@ If RELOAD is non-nil, also `load' any files inside the package which correspond to previously loaded files (those returned by `package--list-loaded-files')." (let* ((name (package-desc-name pkg-desc)) - (pkg-dir (package-desc-dir pkg-desc)) - (pkg-dir-dir (file-name-as-directory pkg-dir))) + (pkg-dir (package-desc-dir pkg-desc))) (unless pkg-dir (error "Internal error: unable to find directory for `%s'" (package-desc-full-name pkg-desc))) - ;; Add to load path, add autoloads, and activate the package. - (let* ((old-lp load-path) - (autoloads-file (expand-file-name - (format "%s-autoloads" name) pkg-dir)) - (loaded-files-list (and reload (package--list-loaded-files pkg-dir)))) - (with-demoted-errors "Error in package-activate-1: %s" - (load autoloads-file nil t)) - (when (and (eq old-lp load-path) - (not (or (member pkg-dir load-path) - (member pkg-dir-dir load-path)))) - ;; Old packages don't add themselves to the `load-path', so we have to - ;; do it ourselves. - (push pkg-dir load-path)) + (let* ((loaded-files-list (when reload + (package--list-loaded-files pkg-dir)))) + ;; Add to load path, add autoloads, and activate the package. + (package--activate-autoloads-and-load-path pkg-desc) ;; Call `load' on all files in `pkg-dir' already present in ;; `load-history'. This is done so that macros in these files are updated ;; to their new definitions. If another package is being installed which @@ -674,7 +686,8 @@ correspond to previously loaded files (those returned by (with-demoted-errors "Error in package-activate-1: %s" (mapc (lambda (feature) (load feature nil t)) ;; Skip autoloads file since we already evaluated it above. - (remove (file-truename autoloads-file) loaded-files-list)))) + (remove (file-truename (package--autoloads-file-name pkg-desc)) + loaded-files-list)))) ;; Add info node. (when (file-exists-p (expand-file-name "dir" pkg-dir)) ;; FIXME: not the friendliest, but simple. @@ -876,7 +889,8 @@ untar into a directory named DIR; otherwise, signal an error." " --- automatically extracted autoloads\n" ";;\n" ";;; Code:\n" - "(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))\n" + ;; `load-path' should contain only directory names + "(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))\n" " \n;; Local Variables:\n" ";; version-control: never\n" ";; no-byte-compile: t\n" @@ -919,8 +933,9 @@ untar into a directory named DIR; otherwise, signal an error." (defun package--compile (pkg-desc) "Byte-compile installed package PKG-DESC." (let ((warning-minimum-level :error) - (save-silently inhibit-message)) - (package-activate-1 pkg-desc) + (save-silently inhibit-message) + (load-path load-path)) + (package--activate-autoloads-and-load-path pkg-desc) (byte-recompile-directory (package-desc-dir pkg-desc) 0 t))) ;;;; Inferring package from current buffer @@ -1350,10 +1365,18 @@ If the archive version is too new, signal an error." (dolist (package contents) (package--add-to-archive-contents package archive))))) +(defvar package--old-archive-priorities nil + "Store currently used `package-archive-priorities'. +This is the value of `package-archive-priorities' last time +`package-read-all-archive-contents' was called. It can be used +by arbitrary functions to decide whether it is necessary to call +it again.") + (defun package-read-all-archive-contents () "Re-read `archive-contents', if it exists. If successful, set `package-archive-contents'." (setq package-archive-contents nil) + (setq package--old-archive-priorities package-archive-priorities) (dolist (archive package-archives) (package-read-archive-contents (car archive)))) @@ -1372,13 +1395,18 @@ If successful, set `package-archive-contents'." The variable `package-load-list' controls which packages to load. If optional arg NO-ACTIVATE is non-nil, don't activate packages. If `user-init-file' does not mention `(package-initialize)', add -it to the file." +it to the file. +If called as part of loading `user-init-file', set +`package-enable-at-startup' to nil, to prevent accidentally +loading packages twice." (interactive) (setq package-alist nil) (if (equal user-init-file load-file-name) ;; If `package-initialize' is being called as part of loading ;; the init file, it's obvious we don't need to ensure-init. - (setq package--init-file-ensured t) + (setq package--init-file-ensured t + ;; And likely we don't need to run it again after init. + package-enable-at-startup nil) (package--ensure-init-file)) (package-load-all-descriptors) (package-read-all-archive-contents) @@ -1592,11 +1620,12 @@ SEEN is used internally to detect infinite recursion." (unless problem (setq problem (if (stringp disabled) - (format "Package `%s' held at version %s, but version %s required" - next-pkg disabled - (package-version-join next-version)) - (format "Required package '%s' is disabled" - next-pkg))))) + (format-message + "Package `%s' held at version %s, but version %s required" + next-pkg disabled + (package-version-join next-version)) + (format-message "Required package `%s' is disabled" + next-pkg))))) (t (setq found pkg-desc))))) (unless found (cond @@ -1832,12 +1861,12 @@ add a call to it along with some explanatory comments." (save-restriction (widen) (goto-char (point-min)) - (search-forward "(package-initialize)" nil 'noerror)))) + (re-search-forward "(package-initialize\\_>" nil 'noerror)))) ;; Don't visit the file if we don't have to. (with-temp-buffer (insert-file-contents user-init-file) (goto-char (point-min)) - (search-forward "(package-initialize)" nil 'noerror))))) + (re-search-forward "(package-initialize\\_>" nil 'noerror))))) (unless contains-init (with-current-buffer (or buffer (let ((delay-mode-hooks t)) @@ -1867,7 +1896,7 @@ add a call to it along with some explanatory comments." ;;;###autoload (defun package-install (pkg &optional dont-select) "Install the package PKG. -PKG can be a package-desc or the package name of one the available packages +PKG can be a package-desc or a symbol naming one of the available packages in an archive in `package-archives'. Interactively, prompt for its name. If called interactively or if DONT-SELECT nil, add PKG to @@ -1898,15 +1927,15 @@ to install it but still mark it as selected." pkg))) (unless (or dont-select (package--user-selected-p name)) (package--save-selected-packages - (cons name package-selected-packages)))) - (if-let ((transaction - (if (package-desc-p pkg) - (unless (package-installed-p pkg) - (package-compute-transaction (list pkg) - (package-desc-reqs pkg))) - (package-compute-transaction () (list (list pkg)))))) - (package-download-transaction transaction) - (message "`%s' is already installed" (package-desc-full-name pkg)))) + (cons name package-selected-packages))) + (if-let ((transaction + (if (package-desc-p pkg) + (unless (package-installed-p pkg) + (package-compute-transaction (list pkg) + (package-desc-reqs pkg))) + (package-compute-transaction () (list (list pkg)))))) + (package-download-transaction transaction) + (message "`%s' is already installed" name)))) (defun package-strip-rcs-id (str) "Strip RCS version ID from the version string STR. @@ -2096,7 +2125,8 @@ will be deleted." ;; do absolutely nothing. (when (or package-selected-packages (yes-or-no-p - "`package-selected-packages' is empty! Really remove ALL packages? ")) + (format-message + "`package-selected-packages' is empty! Really remove ALL packages? "))) (let ((removable (package--removable-packages))) (if removable (when (y-or-n-p @@ -2143,7 +2173,7 @@ will be deleted." (with-current-buffer standard-output (describe-package-1 package))))) -(defface package-help-section-name-face +(defface package-help-section-name '((t :inherit (bold font-lock-function-name-face))) "Face used on section names in package description buffers." :version "25.1") @@ -2154,7 +2184,7 @@ If more STRINGS are provided, insert them followed by a newline. Otherwise no newline is inserted." (declare (indent 1)) (insert (make-string (max 0 (- 11 (string-width name))) ?\s) - (propertize (concat name ": ") 'font-lock-face 'package-help-section-name-face)) + (propertize (concat name ": ") 'font-lock-face 'package-help-section-name)) (when strings (apply #'insert strings) (insert "\n"))) @@ -2204,7 +2234,7 @@ Otherwise no newline is inserted." "Installed" (capitalize status)) 'font-lock-face 'package-status-builtin-face)) - (insert (substitute-command-keys " in ‘")) + (insert (substitute-command-keys " in `")) (let ((dir (abbreviate-file-name (file-name-as-directory (if (file-in-directory-p pkg-dir package-user-dir) @@ -2214,10 +2244,10 @@ Otherwise no newline is inserted." (if (and (package-built-in-p name) (not (package-built-in-p name version))) (insert (substitute-command-keys - "’,\n shadowing a ") + "',\n shadowing a ") (propertize "built-in package" 'font-lock-face 'package-status-builtin-face)) - (insert (substitute-command-keys "’"))) + (insert (substitute-command-keys "'"))) (if signed (insert ".") (insert " (unsigned).")) @@ -2365,16 +2395,16 @@ Otherwise no newline is inserted." (defun package-install-button-action (button) (let ((pkg-desc (button-get button 'package-desc))) - (when (y-or-n-p (format "Install package `%s'? " - (package-desc-full-name pkg-desc))) + (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))))) (defun package-delete-button-action (button) (let ((pkg-desc (button-get button 'package-desc))) - (when (y-or-n-p (format "Delete package `%s'? " - (package-desc-full-name pkg-desc))) + (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))))) @@ -2654,6 +2684,8 @@ KEYWORDS should be nil or a list of keywords." (push pkg info-list))))) ;; Available and disabled packages: + (unless (equal package--old-archive-priorities package-archive-priorities) + (package-read-all-archive-contents)) (dolist (elt package-archive-contents) (let ((name (car elt))) ;; To be displayed it must be in PACKAGES; @@ -2758,68 +2790,68 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." ;;; Package menu faces -(defface package-name-face +(defface package-name '((t :inherit link)) "Face used on package names in the package menu." :version "25.1") -(defface package-description-face +(defface package-description '((t :inherit default)) "Face used on package description summaries in the package menu." :version "25.1") -(defface package-status-built-in-face +(defface package-status-built-in '((t :inherit font-lock-builtin-face)) "Face used on the status and version of built-in packages." :version "25.1") -(defface package-status-external-face +(defface package-status-external '((t :inherit package-status-builtin-face)) "Face used on the status and version of external packages." :version "25.1") -(defface package-status-available-face +(defface package-status-available '((t :inherit default)) "Face used on the status and version of available packages." :version "25.1") -(defface package-status-new-face - '((t :inherit (bold package-status-available-face))) +(defface package-status-new + '((t :inherit (bold package-status-available))) "Face used on the status and version of new packages." :version "25.1") -(defface package-status-held-face +(defface package-status-held '((t :inherit font-lock-constant-face)) "Face used on the status and version of held packages." :version "25.1") -(defface package-status-disabled-face +(defface package-status-disabled '((t :inherit font-lock-warning-face)) "Face used on the status and version of disabled packages." :version "25.1") -(defface package-status-installed-face +(defface package-status-installed '((t :inherit font-lock-comment-face)) "Face used on the status and version of installed packages." :version "25.1") -(defface package-status-dependency-face - '((t :inherit package-status-installed-face)) +(defface package-status-dependency + '((t :inherit package-status-installed)) "Face used on the status and version of dependency packages." :version "25.1") -(defface package-status-unsigned-face +(defface package-status-unsigned '((t :inherit font-lock-warning-face)) "Face used on the status and version of unsigned packages." :version "25.1") -(defface package-status-incompat-face +(defface package-status-incompat '((t :inherit font-lock-comment-face)) "Face used on the status and version of incompat packages." :version "25.1") -(defface package-status-avail-obso-face - '((t :inherit package-status-incompat-face)) +(defface package-status-avail-obso + '((t :inherit package-status-incompat)) "Face used on the status and version of avail-obso packages." :version "25.1") @@ -2831,22 +2863,22 @@ PKG is a package-desc object. Return (PKG-DESC [NAME VERSION STATUS DOC])." (let* ((status (package-desc-status pkg)) (face (pcase status - (`"built-in" 'package-status-built-in-face) - (`"external" 'package-status-external-face) - (`"available" 'package-status-available-face) - (`"avail-obso" 'package-status-avail-obso-face) - (`"new" 'package-status-new-face) - (`"held" 'package-status-held-face) - (`"disabled" 'package-status-disabled-face) - (`"installed" 'package-status-installed-face) - (`"dependency" 'package-status-dependency-face) - (`"unsigned" 'package-status-unsigned-face) - (`"incompat" 'package-status-incompat-face) + (`"built-in" 'package-status-built-in) + (`"external" 'package-status-external) + (`"available" 'package-status-available) + (`"avail-obso" 'package-status-avail-obso) + (`"new" 'package-status-new) + (`"held" 'package-status-held) + (`"disabled" 'package-status-disabled) + (`"installed" 'package-status-installed) + (`"dependency" 'package-status-dependency) + (`"unsigned" 'package-status-unsigned) + (`"incompat" 'package-status-incompat) (_ 'font-lock-warning-face)))) ; obsolete. (list pkg `[(,(symbol-name (package-desc-name pkg)) - face package-name-face - font-lock-face package-name-face + face package-name + font-lock-face package-name follow-link t package-desc ,pkg action package-menu-describe-package) @@ -2858,7 +2890,7 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." (list (propertize (or (package-desc-archive pkg) "") 'font-lock-face face))) ,(propertize (package-desc-summary pkg) - 'font-lock-face 'package-description-face)]))) + 'font-lock-face 'package-description)]))) (defvar package-menu--old-archive-contents nil "`package-archive-contents' before the latest refresh.") @@ -3077,8 +3109,8 @@ prompt (see `package-menu--prompt-transaction-p')." (length packages) (mapconcat #'package-desc-full-name packages ", "))) ;; Exactly 1 - (t (format "package `%s'" - (package-desc-full-name (car packages)))))) + (t (format-message "package `%s'" + (package-desc-full-name (car packages)))))) (defun package-menu--prompt-transaction-p (delete install upgrade) "Prompt the user about DELETE, INSTALL, and UPGRADE. @@ -3194,7 +3226,8 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (if-let ((removable (package--removable-packages))) (message "Package menu: Operation finished. %d packages %s" (length removable) - "are no longer needed, type `M-x package-autoremove' to remove them") + (substitute-command-keys + "are no longer needed, type `\\[package-autoremove]' to remove them")) (message (replace-regexp-in-string "__" "ed" message-template) "finished")))))))) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 50a25072128..bf6550dfa3d 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -1,4 +1,4 @@ -;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t; coding: utf-8 -*- +;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*- ;; Copyright (C) 2010-2015 Free Software Foundation, Inc. @@ -107,7 +107,7 @@ ;;;###autoload (defmacro pcase (exp &rest cases) - "Perform ML-style pattern matching on EXP. + "Eval EXP and perform ML-style pattern matching on that value. CASES is a list of elements of the form (PATTERN CODE...). Patterns can take the following forms: @@ -115,8 +115,8 @@ Patterns can take the following forms: SYMBOL matches anything and binds it to SYMBOL. (or PAT...) matches if any of the patterns matches. (and PAT...) matches if all the patterns match. - 'VAL matches if the object is `equal' to VAL - ATOM is a shorthand for 'ATOM. + \\='VAL matches if the object is `equal' to VAL. + ATOM is a shorthand for \\='ATOM. ATOM can be a keyword, an integer, or a string. (pred FUN) matches if FUN applied to the object returns non-nil. (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. @@ -131,11 +131,11 @@ FUN can take the form which is the value being matched. So a FUN of the form SYMBOL is equivalent to one of the form (FUN). FUN can refer to variables bound earlier in the pattern. -FUN is assumed to be pure, i.e. it can be dropped if its result is not used, -and two identical calls can be merged into one. E.g. you can match pairs where the cdr is larger than the car with a pattern like \\=`(,a . ,(pred (< a))) or, with more checks: \\=`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a)))) +FUN is assumed to be pure, i.e. it can be dropped if its result is not used, +and two identical calls can be merged into one. Additional patterns can be defined via `pcase-defmacro'. Currently, the following patterns are provided this way:" @@ -164,7 +164,7 @@ Currently, the following patterns are provided this way:" expansion)))) (declare-function help-fns--signature "help-fns" - (function doc real-def real-function raw)) + (function doc real-def real-function buffer)) ;; FIXME: Obviously, this will collide with nadvice's use of ;; function-documentation if we happen to advise `pcase'. @@ -184,7 +184,7 @@ Currently, the following patterns are provided this way:" (insert "\n\n-- ") (let* ((doc (documentation me 'raw))) (setq doc (help-fns--signature symbol doc me - (indirect-function me) t)) + (indirect-function me) nil)) (insert "\n" (or doc "Not documented."))))))) (let ((combined-doc (buffer-string))) (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))))) diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index b0fb23dbcc9..e315733e222 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -92,7 +92,7 @@ is enclosed by at least one regexp grouping construct. The returned regexp is typically more efficient than the equivalent regexp: (let ((open (if PAREN \"\\\\(\" \"\")) (close (if PAREN \"\\\\)\" \"\"))) - (concat open (mapconcat 'regexp-quote STRINGS \"\\\\|\") close)) + (concat open (mapconcat \\='regexp-quote STRINGS \"\\\\|\") close)) If PAREN is `words', then the resulting regexp is additionally surrounded by \\=\\< and \\>. @@ -143,7 +143,7 @@ If LAX non-nil, don't output parentheses if it doesn't require them. Merges keywords to avoid backtracking in Emacs's regexp matcher." ;; The basic idea is to find the shortest common prefix or suffix, remove it ;; and recurse. If there is no prefix, we divide the list into two so that - ;; \(at least) one half will have at least a one-character common prefix. + ;; (at least) one half will have at least a one-character common prefix. ;; Also we delay the addition of grouping parenthesis as long as possible ;; until we're sure we need them, and try to remove one-character sequences diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index 520210614f5..a5ff9722698 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -768,8 +768,8 @@ of all atomic regexps." ((= l 3) (string-match "\\`\\(?:\\\\[cCsS_]\\|\\[[^^]\\]\\)" r)) ((null lax) (cond - ((string-match "\\`\\[^?\]?\\(?:\\[:[a-z]+:]\\|[^\]]\\)*\\]\\'" r)) - ((string-match "\\`\\\\(\\(?:[^\\]\\|\\\\[^\)]\\)*\\\\)\\'" r))))))) + ((string-match "\\`\\[^?\]?\\(?:\\[:[a-z]+:]\\|[^]]\\)*\\]\\'" r)) + ((string-match "\\`\\\\(\\(?:[^\\]\\|\\\\[^)]\\)*\\\\)\\'" r))))))) (defun rx-syntax (form) @@ -815,9 +815,9 @@ of all atomic regexps." (defun rx-greedy (form) "Parse and produce code from FORM. -If FORM is '(minimal-match FORM1)', non-greedy versions of `*', +If FORM is `(minimal-match FORM1)', non-greedy versions of `*', `+', and `?' operators will be used in FORM1. If FORM is -'(maximal-match FORM1)', greedy operators will be used." +`(maximal-match FORM1)', greedy operators will be used." (rx-check form) (let ((rx-greedy-flag (eq (car form) 'maximal-match))) (rx-form (cadr form) rx-parent))) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 9eed36eb68c..456efd077db 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -4,7 +4,7 @@ ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Keywords: sequences -;; Version: 1.8 +;; Version: 2.3 ;; Package: seq ;; Maintainer: emacs-devel@gnu.org @@ -38,259 +38,348 @@ ;; the sequence as their second argument. All other functions take ;; the sequence as their first argument. ;; +;; While seq.el version 1.8 is in GNU ELPA for convenience, seq.el +;; version 2.0 requires Emacs>=25.1. +;; +;; seq.el can be extended to support new type of sequences. Here are +;; the generic functions that must be implemented by new seq types: +;; - `seq-elt' +;; - `seq-length' +;; - `seq-do' +;; - `seqp' +;; - `seq-subseq' +;; - `seq-into-sequence' +;; - `seq-copy' +;; - `seq-into' +;; ;; All functions are tested in test/automated/seq-tests.el ;;; Code: +(eval-when-compile (require 'cl-generic)) +(require 'cl-extra) ;; for cl-subseq + (defmacro seq-doseq (spec &rest body) "Loop over a sequence. -Similar to `dolist' but can be applied to lists, strings, and vectors. +Evaluate BODY with VAR bound to each element of SEQUENCE, in turn. -Evaluate BODY with VAR bound to each element of SEQ, in turn. +Similar to `dolist' but can be applied to lists, strings, and vectors. -\(fn (VAR SEQ) BODY...)" +\(fn (VAR SEQUENCE) BODY...)" (declare (indent 1) (debug ((symbolp form &optional form) body))) - (let ((length (make-symbol "length")) - (seq (make-symbol "seq")) - (index (make-symbol "index"))) - `(let* ((,seq ,(cadr spec)) - (,length (if (listp ,seq) nil (seq-length ,seq))) - (,index (if ,length 0 ,seq))) - (while (if ,length - (< ,index ,length) - (consp ,index)) - (let ((,(car spec) (if ,length - (prog1 (seq-elt ,seq ,index) - (setq ,index (+ ,index 1))) - (pop ,index)))) - ,@body))))) - -(if (fboundp 'pcase-defmacro) - ;; Implementation of `seq-let' based on a `pcase' - ;; pattern. Requires Emacs>=25.1. - (progn - (pcase-defmacro seq (&rest args) - "pcase pattern matching sequence elements. -Matches if the object is a sequence (list, string or vector), and -binds each element of ARGS to the corresponding element of the -sequence." - `(and (pred seq-p) - ,@(seq--make-pcase-bindings args))) - - (defmacro seq-let (args seq &rest body) - "Bind the variables in ARGS to the elements of SEQ then evaluate BODY. + `(seq-do (lambda (,(car spec)) + ,@body) + ,(cadr spec))) -ARGS can also include the `&rest' marker followed by a variable -name to be bound to the rest of SEQ." - (declare (indent 2) (debug t)) - `(pcase-let ((,(seq--make-pcase-patterns args) ,seq)) - ,@body))) +(pcase-defmacro seq (&rest patterns) + "Build a `pcase' pattern that matches elements of SEQUENCE. + +The `pcase' pattern will match each element of PATTERNS against the +corresponding element of SEQUENCE. - ;; Implementation of `seq-let' compatible with Emacs<25.1. - (defmacro seq-let (args seq &rest body) - "Bind the variables in ARGS to the elements of SEQ then evaluate BODY. +Extra elements of the sequence are ignored if fewer PATTERNS are +given, and the match does not fail." + `(and (pred seqp) + ,@(seq--make-pcase-bindings patterns))) + +(defmacro seq-let (args sequence &rest body) + "Bind the variables in ARGS to the elements of SEQUENCE, then evaluate BODY. ARGS can also include the `&rest' marker followed by a variable -name to be bound to the rest of SEQ." - (declare (indent 2) (debug t)) - (let ((seq-var (make-symbol "seq"))) - `(let* ((,seq-var ,seq) - ,@(seq--make-bindings args seq-var)) - ,@body)))) - -(defun seq-drop (seq n) - "Return a subsequence of SEQ without its first N elements. -The result is a sequence of the same type as SEQ. - -If N is a negative integer or zero, SEQ is returned." +name to be bound to the rest of SEQUENCE." + (declare (indent 2) (debug t)) + `(pcase-let ((,(seq--make-pcase-patterns args) ,sequence)) + ,@body)) + + +;;; Basic seq functions that have to be implemented by new sequence types +(cl-defgeneric seq-elt (sequence n) + "Return Nth element of SEQUENCE." + (elt sequence n)) + +;; Default gv setters for `seq-elt'. +;; It can be a good idea for new sequence implementations to provide a +;; "gv-setter" for `seq-elt'. +(cl-defmethod (setf seq-elt) (store (sequence array) n) + (aset sequence n store)) + +(cl-defmethod (setf seq-elt) (store (sequence cons) n) + (setcar (nthcdr n sequence) store)) + +(cl-defgeneric seq-length (sequence) + "Return the number of elements of SEQUENCE." + (length sequence)) + +(cl-defgeneric seq-do (function sequence) + "Apply FUNCTION to each element of SEQUENCE, presumably for side effects. +Return SEQUENCE." + (mapc function sequence)) + +(defalias 'seq-each #'seq-do) + +(cl-defgeneric seqp (sequence) + "Return non-nil if SEQUENCE is a sequence, nil otherwise." + (sequencep sequence)) + +(cl-defgeneric seq-copy (sequence) + "Return a shallow copy of SEQUENCE." + (copy-sequence sequence)) + +(cl-defgeneric seq-subseq (sequence start &optional end) + "Return the sequence of elements of SEQUENCE from START to END. +END is inclusive. + +If END is omitted, it defaults to the length of the sequence. If +START or END is negative, it counts from the end. Signal an +error if START or END are outside of the sequence (i.e too large +if positive or too small if negative)." + (cl-subseq sequence start end)) + + +(cl-defgeneric seq-map (function sequence) + "Return the result of applying FUNCTION to each element of SEQUENCE." + (let (result) + (seq-do (lambda (elt) + (push (funcall function elt) result)) + sequence) + (nreverse result))) + +;; faster implementation for sequences (sequencep) +(cl-defmethod seq-map (function (sequence sequence)) + (mapcar function sequence)) + +(cl-defgeneric seq-mapn (function sequence &rest sequences) + "Like `seq-map' but FUNCTION is mapped over all SEQUENCES. +The arity of FUNCTION must match the number of SEQUENCES, and the +mapping stops on the shortest sequence. +Return a list of the results. + +\(fn FUNCTION SEQUENCES...)" + (let ((result nil) + (sequences (seq-map (lambda (s) (seq-into s 'list)) + (cons sequence sequences)))) + (while (not (memq nil sequences)) + (push (apply function (seq-map #'car sequences)) result) + (setq sequences (seq-map #'cdr sequences))) + (nreverse result))) + +(cl-defgeneric seq-drop (sequence n) + "Remove the first N elements of SEQUENCE and return the result. +The result is a sequence of the same type as SEQUENCE. + +If N is a negative integer or zero, SEQUENCE is returned." (if (<= n 0) - seq - (if (listp seq) - (seq--drop-list seq n) - (let ((length (seq-length seq))) - (seq-subseq seq (min n length) length))))) + sequence + (let ((length (seq-length sequence))) + (seq-subseq sequence (min n length) length)))) -(defun seq-take (seq n) - "Return a subsequence of SEQ with its first N elements. -The result is a sequence of the same type as SEQ. +(cl-defgeneric seq-take (sequence n) + "Take the first N elements of SEQUENCE and return the result. +The result is a sequence of the same type as SEQUENCE. If N is a negative integer or zero, an empty sequence is returned." - (if (listp seq) - (seq--take-list seq n) - (seq-subseq seq 0 (min (max n 0) (seq-length seq))))) - -(defun seq-drop-while (pred seq) - "Return a sequence from the first element for which (PRED element) is nil in SEQ. -The result is a sequence of the same type as SEQ." - (if (listp seq) - (seq--drop-while-list pred seq) - (seq-drop seq (seq--count-successive pred seq)))) - -(defun seq-take-while (pred seq) - "Return the successive elements for which (PRED element) is non-nil in SEQ. -The result is a sequence of the same type as SEQ." - (if (listp seq) - (seq--take-while-list pred seq) - (seq-take seq (seq--count-successive pred seq)))) - -(defun seq-filter (pred seq) - "Return a list of all the elements for which (PRED element) is non-nil in SEQ." + (seq-subseq sequence 0 (min (max n 0) (seq-length sequence)))) + +(cl-defgeneric seq-drop-while (pred sequence) + "Remove the successive elements of SEQUENCE for which PRED returns non-nil. +PRED is a function of one argument. The result is a sequence of +the same type as SEQUENCE." + (seq-drop sequence (seq--count-successive pred sequence))) + +(cl-defgeneric seq-take-while (pred sequence) + "Take the successive elements of SEQUENCE for which PRED returns non-nil. +PRED is a function of one argument. The result is a sequence of +the same type as SEQUENCE." + (seq-take sequence (seq--count-successive pred sequence))) + +(cl-defgeneric seq-empty-p (sequence) + "Return non-nil if the SEQUENCE is empty, nil otherwise." + (= 0 (seq-length sequence))) + +(cl-defgeneric seq-sort (pred sequence) + "Sort SEQUENCE using PRED as comparison function. +The result is a sequence of the same type as SEQUENCE." + (let ((result (seq-sort pred (append sequence nil)))) + (seq-into result (type-of sequence)))) + +(cl-defmethod seq-sort (pred (list list)) + (sort (seq-copy list) pred)) + +(cl-defgeneric seq-reverse (sequence) + "Return a sequence with elements of SEQUENCE in reverse order." + (let ((result '())) + (seq-map (lambda (elt) + (push elt result)) + sequence) + (seq-into result (type-of sequence)))) + +;; faster implementation for sequences (sequencep) +(cl-defmethod seq-reverse ((sequence sequence)) + (reverse sequence)) + +(cl-defgeneric seq-concatenate (type &rest sequences) + "Concatenate SEQUENCES into a single sequence of type TYPE. +TYPE must be one of following symbols: vector, string or list. + +\n(fn TYPE SEQUENCE...)" + (apply #'cl-concatenate type (seq-map #'seq-into-sequence sequences))) + +(cl-defgeneric seq-into-sequence (sequence) + "Convert SEQUENCE into a sequence. + +The default implementation is to signal an error if SEQUENCE is not a +sequence, specific functions should be implemented for new types +of sequence." + (unless (sequencep sequence) + (error "Cannot convert %S into a sequence" sequence)) + sequence) + +(cl-defgeneric seq-into (sequence type) + "Concatenate the elements of SEQUENCE into a sequence of type TYPE. +TYPE can be one of the following symbols: vector, string or +list." + (pcase type + (`vector (vconcat sequence)) + (`string (concat sequence)) + (`list (append sequence nil)) + (_ (error "Not a sequence type name: %S" type)))) + +(cl-defgeneric seq-filter (pred sequence) + "Return a list of all the elements for which (PRED element) is non-nil in SEQUENCE." (let ((exclude (make-symbol "exclude"))) (delq exclude (seq-map (lambda (elt) (if (funcall pred elt) elt exclude)) - seq)))) + sequence)))) -(defun seq-remove (pred seq) - "Return a list of all the elements for which (PRED element) is nil in SEQ." +(cl-defgeneric seq-remove (pred sequence) + "Return a list of all the elements for which (PRED element) is nil in SEQUENCE." (seq-filter (lambda (elt) (not (funcall pred elt))) - seq)) + sequence)) -(defun seq-reduce (function seq initial-value) - "Reduce the function FUNCTION across SEQ, starting with INITIAL-VALUE. +(cl-defgeneric seq-reduce (function sequence initial-value) + "Reduce the function FUNCTION across SEQUENCE, starting with INITIAL-VALUE. Return the result of calling FUNCTION with INITIAL-VALUE and the -first element of SEQ, then calling FUNCTION with that result and -the second element of SEQ, then with that result and the third -element of SEQ, etc. +first element of SEQUENCE, then calling FUNCTION with that result and +the second element of SEQUENCE, then with that result and the third +element of SEQUENCE, etc. -If SEQ is empty, return INITIAL-VALUE and FUNCTION is not called." - (if (seq-empty-p seq) +If SEQUENCE is empty, return INITIAL-VALUE and FUNCTION is not called." + (if (seq-empty-p sequence) initial-value (let ((acc initial-value)) - (seq-doseq (elt seq) + (seq-doseq (elt sequence) (setq acc (funcall function acc elt))) acc))) -(defun seq-some-p (pred seq) - "Return any element for which (PRED element) is non-nil in SEQ, nil otherwise." +(cl-defgeneric seq-every-p (pred sequence) + "Return non-nil if (PRED element) is non-nil for all elements of SEQUENCE." (catch 'seq--break - (seq-doseq (elt seq) - (when (funcall pred elt) - (throw 'seq--break elt))) - nil)) - -(defun seq-every-p (pred seq) - "Return non-nil if (PRED element) is non-nil for all elements of the sequence SEQ." - (catch 'seq--break - (seq-doseq (elt seq) + (seq-doseq (elt sequence) (or (funcall pred elt) (throw 'seq--break nil))) t)) -(defun seq-count (pred seq) - "Return the number of elements for which (PRED element) is non-nil in SEQ." +(cl-defgeneric seq-some (pred sequence) + "Return the first value for which if (PRED element) is non-nil for in SEQUENCE." + (catch 'seq--break + (seq-doseq (elt sequence) + (let ((result (funcall pred elt))) + (when result + (throw 'seq--break result)))) + nil)) + +(cl-defgeneric seq-find (pred sequence &optional default) + "Return the first element for which (PRED element) is non-nil in SEQUENCE. +If no element is found, return DEFAULT. + +Note that `seq-find' has an ambiguity if the found element is +identical to DEFAULT, as it cannot be known if an element was +found or not." + (catch 'seq--break + (seq-doseq (elt sequence) + (when (funcall pred elt) + (throw 'seq--break elt))) + default)) + +(cl-defgeneric seq-count (pred sequence) + "Return the number of elements for which (PRED element) is non-nil in SEQUENCE." (let ((count 0)) - (seq-doseq (elt seq) + (seq-doseq (elt sequence) (when (funcall pred elt) (setq count (+ 1 count)))) count)) -(defun seq-empty-p (seq) - "Return non-nil if the sequence SEQ is empty, nil otherwise." - (if (listp seq) - (null seq) - (= 0 (seq-length seq)))) - -(defun seq-sort (pred seq) - "Return a sorted sequence comparing using PRED the elements of SEQ. -The result is a sequence of the same type as SEQ." - (if (listp seq) - (sort (seq-copy seq) pred) - (let ((result (seq-sort pred (append seq nil)))) - (seq-into result (type-of seq))))) - -(defun seq-contains-p (seq elt &optional testfn) - "Return the first element in SEQ that equals to ELT. +(cl-defgeneric seq-contains (sequence elt &optional testfn) + "Return the first element in SEQUENCE that is equal to ELT. Equality is defined by TESTFN if non-nil or by `equal' if nil." - (seq-some-p (lambda (e) - (funcall (or testfn #'equal) elt e)) - seq)) + (seq-some (lambda (e) + (funcall (or testfn #'equal) elt e)) + sequence)) -(defun seq-uniq (seq &optional testfn) - "Return a list of the elements of SEQ with duplicates removed. +(cl-defgeneric seq-position (sequence elt &optional testfn) + "Return the index of the first element in SEQUENCE that is equal to ELT. +Equality is defined by TESTFN if non-nil or by `equal' if nil." + (let ((index 0)) + (catch 'seq--break + (seq-doseq (e sequence) + (when (funcall (or testfn #'equal) e elt) + (throw 'seq--break index)) + (setq index (1+ index))) + nil))) + +(cl-defgeneric seq-uniq (sequence &optional testfn) + "Return a list of the elements of SEQUENCE with duplicates removed. TESTFN is used to compare elements, or `equal' if TESTFN is nil." (let ((result '())) - (seq-doseq (elt seq) - (unless (seq-contains-p result elt testfn) + (seq-doseq (elt sequence) + (unless (seq-contains result elt testfn) (setq result (cons elt result)))) (nreverse result))) -(defun seq-subseq (seq start &optional end) - "Return the subsequence of SEQ from START to END. -If END is omitted, it defaults to the length of the sequence. -If START or END is negative, it counts from the end." - (cond ((or (stringp seq) (vectorp seq)) (substring seq start end)) - ((listp seq) - (let (len (errtext (format "Bad bounding indices: %s, %s" start end))) - (and end (< end 0) (setq end (+ end (setq len (seq-length seq))))) - (if (< start 0) (setq start (+ start (or len (setq len (seq-length seq)))))) - (when (> start 0) - (setq seq (nthcdr (1- start) seq)) - (or seq (error "%s" errtext)) - (setq seq (cdr seq))) - (if end - (let ((res nil)) - (while (and (>= (setq end (1- end)) start) seq) - (push (pop seq) res)) - (or (= (1+ end) start) (error "%s" errtext)) - (nreverse res)) - (seq-copy seq)))) - (t (error "Unsupported sequence: %s" seq)))) - -(defun seq-concatenate (type &rest seqs) - "Concatenate, into a sequence of type TYPE, the sequences SEQS. -TYPE must be one of following symbols: vector, string or list. - -\n(fn TYPE SEQUENCE...)" - (pcase type - (`vector (apply #'vconcat seqs)) - (`string (apply #'concat seqs)) - (`list (apply #'append (append seqs '(nil)))) - (_ (error "Not a sequence type name: %S" type)))) - -(defun seq-mapcat (function seq &optional type) - "Concatenate the result of applying FUNCTION to each element of SEQ. +(cl-defgeneric seq-mapcat (function sequence &optional type) + "Concatenate the result of applying FUNCTION to each element of SEQUENCE. The result is a sequence of type TYPE, or a list if TYPE is nil." (apply #'seq-concatenate (or type 'list) - (seq-map function seq))) + (seq-map function sequence))) -(defun seq-partition (seq n) - "Return a list of the elements of SEQ grouped into sub-sequences of length N. +(cl-defgeneric seq-partition (sequence n) + "Return a list of the elements of SEQUENCE grouped into sub-sequences of length N. The last sequence may contain less than N elements. If N is a negative integer or 0, nil is returned." (unless (< n 1) (let ((result '())) - (while (not (seq-empty-p seq)) - (push (seq-take seq n) result) - (setq seq (seq-drop seq n))) + (while (not (seq-empty-p sequence)) + (push (seq-take sequence n) result) + (setq sequence (seq-drop sequence n))) (nreverse result)))) -(defun seq-intersection (seq1 seq2 &optional testfn) - "Return a list of the elements that appear in both SEQ1 and SEQ2. +(cl-defgeneric seq-intersection (sequence1 sequence2 &optional testfn) + "Return a list of the elements that appear in both SEQUENCE1 and SEQUENCE2. Equality is defined by TESTFN if non-nil or by `equal' if nil." (seq-reduce (lambda (acc elt) - (if (seq-contains-p seq2 elt testfn) + (if (seq-contains sequence2 elt testfn) (cons elt acc) acc)) - (seq-reverse seq1) + (seq-reverse sequence1) '())) -(defun seq-difference (seq1 seq2 &optional testfn) - "Return a list of the elements that appear in SEQ1 but not in SEQ2. +(cl-defgeneric seq-difference (sequence1 sequence2 &optional testfn) + "Return a list of the elements that appear in SEQUENCE1 but not in SEQUENCE2. Equality is defined by TESTFN if non-nil or by `equal' if nil." (seq-reduce (lambda (acc elt) - (if (not (seq-contains-p seq2 elt testfn)) + (if (not (seq-contains sequence2 elt testfn)) (cons elt acc) acc)) - (seq-reverse seq1) + (seq-reverse sequence1) '())) -(defun seq-group-by (function seq) - "Apply FUNCTION to each element of SEQ. -Separate the elements of SEQ into an alist using the results as +(cl-defgeneric seq-group-by (function sequence) + "Apply FUNCTION to each element of SEQUENCE. +Separate the elements of SEQUENCE into an alist using the results as keys. Keys are compared using `equal'." (seq-reduce (lambda (acc elt) @@ -300,79 +389,25 @@ keys. Keys are compared using `equal'." (setcdr cell (push elt (cdr cell))) (push (list key elt) acc)) acc)) - (seq-reverse seq) + (seq-reverse sequence) nil)) -(defalias 'seq-reverse - (if (ignore-errors (reverse [1 2])) - #'reverse - (lambda (seq) - "Return the reversed copy of list, vector, or string SEQ. -See also the function `nreverse', which is used more often." - (let ((result '())) - (seq-map (lambda (elt) (push elt result)) - seq) - (if (listp seq) - result - (seq-into result (type-of seq))))))) - -(defun seq-into (seq type) - "Convert the sequence SEQ into a sequence of type TYPE. -TYPE can be one of the following symbols: vector, string or list." - (pcase type - (`vector (vconcat seq)) - (`string (concat seq)) - (`list (append seq nil)) - (_ (error "Not a sequence type name: %S" type)))) - -(defun seq-min (seq) - "Return the smallest element of SEQ. -SEQ must be a sequence of numbers or markers." - (apply #'min (seq-into seq 'list))) +(cl-defgeneric seq-min (sequence) + "Return the smallest element of SEQUENCE. +SEQUENCE must be a sequence of numbers or markers." + (apply #'min (seq-into sequence 'list))) -(defun seq-max (seq) - "Return the largest element of SEQ. -SEQ must be a sequence of numbers or markers." - (apply #'max (seq-into seq 'list))) +(cl-defgeneric seq-max (sequence) + "Return the largest element of SEQUENCE. +SEQUENCE must be a sequence of numbers or markers." + (apply #'max (seq-into sequence 'list))) -(defun seq--drop-list (list n) - "Return a list from LIST without its first N elements. -This is an optimization for lists in `seq-drop'." - (while (and list (> n 0)) - (setq list (cdr list) - n (1- n))) - list) - -(defun seq--take-list (list n) - "Return a list from LIST made of its first N elements. -This is an optimization for lists in `seq-take'." - (let ((result '())) - (while (and list (> n 0)) - (setq n (1- n)) - (push (pop list) result)) - (nreverse result))) - -(defun seq--drop-while-list (pred list) - "Return a list from the first element for which (PRED element) is nil in LIST. -This is an optimization for lists in `seq-drop-while'." - (while (and list (funcall pred (car list))) - (setq list (cdr list))) - list) - -(defun seq--take-while-list (pred list) - "Return the successive elements for which (PRED element) is non-nil in LIST. -This is an optimization for lists in `seq-take-while'." - (let ((result '())) - (while (and list (funcall pred (car list))) - (push (pop list) result)) - (nreverse result))) - -(defun seq--count-successive (pred seq) - "Return the number of successive elements for which (PRED element) is non-nil in SEQ." +(defun seq--count-successive (pred sequence) + "Return the number of successive elements for which (PRED element) is non-nil in SEQUENCE." (let ((n 0) - (len (seq-length seq))) + (len (seq-length sequence))) (while (and (< n len) - (funcall pred (seq-elt seq n))) + (funcall pred (seq-elt sequence n))) (setq n (+ 1 n))) n)) @@ -398,57 +433,51 @@ This is an optimization for lists in `seq-take-while'." "Return a list of `(seq ...)' pcase patterns from the argument list ARGS." (cons 'seq (seq-map (lambda (elt) - (if (seq-p elt) + (if (seqp elt) (seq--make-pcase-patterns elt) elt)) args))) -;; Helper function for the Backward-compatible version of `seq-let' -;; for Emacs<25.1. -(defun seq--make-bindings (args seq &optional bindings) - "Return a list of bindings of the variables in ARGS to the elements of a sequence. -if BINDINGS is non-nil, append new bindings to it, and return -BINDINGS." - (let ((index 0) - (rest-marker nil)) - (seq-doseq (name args) - (unless rest-marker - (pcase name - ((pred seq-p) - (setq bindings (seq--make-bindings (seq--elt-safe args index) - `(seq--elt-safe ,seq ,index) - bindings))) - (`&rest - (progn (push `(,(seq--elt-safe args (1+ index)) - (seq-drop ,seq ,index)) - bindings) - (setq rest-marker t))) - (_ - (push `(,name (seq--elt-safe ,seq ,index)) bindings)))) - (setq index (1+ index))) - bindings)) - -(defun seq--elt-safe (seq n) - "Return element of SEQ at the index N. +;; TODO: make public? +(defun seq--elt-safe (sequence n) + "Return element of SEQUENCE at the index N. If no element is found, return nil." - (when (or (listp seq) - (and (sequencep seq) - (> (seq-length seq) n))) - (seq-elt seq n))) + (ignore-errors (seq-elt sequence n))) + + +;;; Optimized implementations for lists + +(cl-defmethod seq-drop ((list list) n) + "Optimized implementation of `seq-drop' for lists." + (while (and list (> n 0)) + (setq list (cdr list) + n (1- n))) + list) + +(cl-defmethod seq-take ((list list) n) + "Optimized implementation of `seq-take' for lists." + (let ((result '())) + (while (and list (> n 0)) + (setq n (1- n)) + (push (pop list) result)) + (nreverse result))) + +(cl-defmethod seq-drop-while (pred (list list)) + "Optimized implementation of `seq-drop-while' for lists." + (while (and list (funcall pred (car list))) + (setq list (cdr list))) + list) + +(cl-defmethod seq-empty-p ((list list)) + "Optimized implementation of `seq-empty-p' for lists." + (null list)) + (defun seq--activate-font-lock-keywords () "Activate font-lock keywords for some symbols defined in seq." (font-lock-add-keywords 'emacs-lisp-mode '("\\<seq-doseq\\>" "\\<seq-let\\>"))) -(defalias 'seq-copy #'copy-sequence) -(defalias 'seq-elt #'elt) -(defalias 'seq-length #'length) -(defalias 'seq-do #'mapc) -(defalias 'seq-each #'seq-do) -(defalias 'seq-map #'mapcar) -(defalias 'seq-p #'sequencep) - (unless (fboundp 'elisp--font-lock-flush-elisp-buffers) ;; In Emacs≥25, (via elisp--font-lock-flush-elisp-buffers and a few others) ;; we automatically highlight macros. diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index 59bf6345f88..229bb587488 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -68,9 +68,9 @@ This is slower, but filters out some innocuous shadowing." "Return a list of Emacs Lisp files that create shadows. This function does the work for `list-load-path-shadows'. -We traverse PATH looking for shadows, and return a \(possibly empty\) +We traverse PATH looking for shadows, and return a \(possibly empty) even-length list of files. A file in this list at position 2i shadows -the file in position 2i+1. Emacs Lisp file suffixes \(.el and .elc\) +the file in position 2i+1. Emacs Lisp file suffixes \(.el and .elc) are stripped from the file names in the list. See the documentation for `list-load-path-shadows' for further information." @@ -213,7 +213,7 @@ For example, suppose `load-path' is set to and that each of these directories contains a file called XXX.el. Then XXX.el in the site-lisp directory is referred to by all of: -\(require 'XXX), (autoload .... \"XXX\"), (load-library \"XXX\") etc. +\(require \\='XXX), (autoload .... \"XXX\"), (load-library \"XXX\") etc. The first XXX.el file prevents Emacs from seeing the second (unless the second is loaded explicitly via `load-file'). @@ -286,7 +286,3 @@ version unless you know what you are doing.\n") (provide 'shadow) ;;; shadow.el ends here - -;; Local Variables: -;; coding: utf-8 -;; End: diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 1bc5eb28720..738bdddcddf 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -169,13 +169,13 @@ (cl-incf smie-warning-count)) (puthash key val table)))) -(put 'smie-precs->prec2 'pure t) (defun smie-precs->prec2 (precs) "Compute a 2D precedence table from a list of precedences. PRECS should be a list, sorted by precedence (e.g. \"+\" will come before \"*\"), of elements of the form \(left OP ...) or (right OP ...) or (nonassoc OP ...) or (assoc OP ...). All operators in one of those elements share the same precedence level and associativity." + (declare (pure t)) (let ((prec2-table (make-hash-table :test 'equal))) (dolist (prec precs) (dolist (op (cdr prec)) @@ -193,8 +193,8 @@ one of those elements share the same precedence level and associativity." (smie-set-prec2tab prec2-table other-op op op1))))))) prec2-table)) -(put 'smie-merge-prec2s 'pure t) (defun smie-merge-prec2s (&rest tables) + (declare (pure t)) (if (null (cdr tables)) (car tables) (let ((prec2 (make-hash-table :test 'equal))) @@ -209,11 +209,10 @@ one of those elements share the same precedence level and associativity." table)) prec2))) -(put 'smie-bnf->prec2 'pure t) (defun smie-bnf->prec2 (bnf &rest resolvers) "Convert the BNF grammar into a prec2 table. BNF is a list of nonterminal definitions of the form: - \(NONTERM RHS1 RHS2 ...) + (NONTERM RHS1 RHS2 ...) where each RHS is a (non-empty) list of terminals (aka tokens) or non-terminals. Not all grammars are accepted: - an RHS cannot be an empty list (this is not needed, since SMIE allows all @@ -232,6 +231,7 @@ Conflicts can be resolved via RESOLVERS, which is a list of elements that can be either: - a precs table (see `smie-precs->prec2') to resolve conflicting constraints, - a constraint (T1 REL T2) where REL is one of = < or >." + (declare (pure t)) ;; FIXME: Add repetition operator like (repeat <separator> <elems>). ;; Maybe also add (or <elem1> <elem2>...) for things like ;; (exp (exp (or "+" "*" "=" ..) exp)). @@ -503,11 +503,11 @@ CSTS is a list of pairs representing arcs in a graph." ;; (t (cl-assert (eq v '=)))))))) ;; prec2)) -(put 'smie-prec2->grammar 'pure t) (defun smie-prec2->grammar (prec2) "Take a 2D precedence table and turn it into an alist of precedence levels. PREC2 is a table as returned by `smie-precs->prec2' or `smie-bnf->prec2'." + (declare (pure t)) ;; For each operator, we create two "variables" (corresponding to ;; the left and right precedence level), which are represented by ;; cons cells. Those are the very cons cells that appear in the @@ -1136,6 +1136,8 @@ METHOD can be: - :elem, in which case the function should return either: - the offset to use to indent function arguments (ARG = `arg') - the basic indentation step (ARG = `basic'). + - the token to use (when ARG = `empty-line-token') when we don't know how + to indent an empty line. - :list-intro, in which case ARG is a token and the function should return non-nil if TOKEN is followed by a list of expressions (not separated by any token) rather than an expression. @@ -1198,6 +1200,21 @@ Comments are treated as spaces." (forward-comment (- (point))) (<= (point) bol)))) +(defun smie-indent--current-column () + "Like `current-column', but if there's a comment before us, use that." + ;; This is used, so that when we align elements, we don't get + ;; toto = { /* foo, */ a, + ;; b } + ;; but + ;; toto = { /* foo, */ a, + ;; b } + (let ((pos (point)) + (lbp (line-beginning-position))) + (save-excursion + (unless (and (forward-comment -1) (>= (point) lbp)) + (goto-char pos)) + (current-column)))) + ;; Dynamically scoped. (defvar smie--parent) (defvar smie--after) (defvar smie--token) @@ -1577,7 +1594,9 @@ should not be computed on the basis of the following token." ;; So we use a heuristic here, which is that we only use virtual ;; if the parent is tightly linked to the child token (they're ;; part of the same BNF rule). - (if (car parent) (current-column) (smie-indent-virtual))))))))))) + (if (car parent) + (smie-indent--current-column) + (smie-indent-virtual))))))))))) (defun smie-indent-comment () "Compute indentation of a comment." @@ -1669,6 +1688,19 @@ should not be computed on the basis of the following token." (+ (smie-indent-virtual) (smie-indent--offset 'basic))) ; (t (smie-indent-virtual)))))) ;An infix. +(defun smie-indent-empty-line () + "Indentation rule when there's nothing yet on the line." + ;; Without this rule, SMIE assumes that an empty line will be filled with an + ;; argument (since it falls back to smie-indent-sexps), which tends + ;; to indent far too deeply. + (when (eolp) + (let ((token (or (funcall smie-rules-function :elem 'empty-line-token) + ;; FIXME: Should we default to ";"? + ;; ";" + ))) + (when (assoc token smie-grammar) + (smie-indent-keyword token))))) + (defun smie-indent-exps () ;; Indentation of sequences of simple expressions without ;; intervening keywords or operators. E.g. "a b c" or "g (balbla) f". @@ -1707,12 +1739,12 @@ should not be computed on the basis of the following token." ;; There's a previous element, and it's not special (it's not ;; the function), so let's just align with that one. (goto-char (car positions)) - (current-column)) + (smie-indent--current-column)) ((cdr positions) ;; We skipped some args plus the function and bumped into something. ;; Align with the first arg. (goto-char (cadr positions)) - (current-column)) + (smie-indent--current-column)) (positions ;; We're the first arg. (goto-char (car positions)) @@ -1720,14 +1752,14 @@ should not be computed on the basis of the following token." ;; We used to use (smie-indent-virtual), but that ;; doesn't seem right since it might then indent args less than ;; the function itself. - (current-column))))))) + (smie-indent--current-column))))))) (defvar smie-indent-functions '(smie-indent-fixindent smie-indent-bob smie-indent-close smie-indent-comment smie-indent-comment-continue smie-indent-comment-close smie-indent-comment-inside smie-indent-inside-string smie-indent-keyword smie-indent-after-keyword - smie-indent-exps) + smie-indent-empty-line smie-indent-exps) "Functions to compute the indentation. Each function is called with no argument, shouldn't move point, and should return either nil if it has no opinion, or an integer representing the column diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index 05dd7d57503..d446a2c0af7 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -43,8 +43,6 @@ (eval-when-compile (require 'cl-lib)) -(defvar font-lock-beginning-of-syntax-function) - ;;; Applying syntax-table properties where needed. (defvar syntax-propertize-function nil @@ -106,10 +104,6 @@ Put first the functions more likely to cause a change and cheaper to compute.") (point-max)))) (cons beg end)) -(defvar syntax-propertize--done -1 - "Position up to which syntax-table properties have been set.") -(make-variable-buffer-local 'syntax-propertize--done) - (defun syntax-propertize--shift-groups (re n) (replace-regexp-in-string "\\\\(\\?\\([0-9]+\\):" @@ -290,39 +284,60 @@ The return value is a function suitable for `syntax-propertize-function'." (defun syntax-propertize (pos) "Ensure that syntax-table properties are set until POS." - (when (and syntax-propertize-function - (< syntax-propertize--done pos)) - ;; (message "Needs to syntax-propertize from %s to %s" - ;; syntax-propertize--done pos) - (set (make-local-variable 'parse-sexp-lookup-properties) t) - (save-excursion - (with-silent-modifications - (let* ((start (max syntax-propertize--done (point-min))) - (end (max pos - (min (point-max) - (+ start syntax-propertize-chunk-size)))) - (funs syntax-propertize-extend-region-functions)) - (while funs - (let ((new (funcall (pop funs) start end))) - (if (or (null new) - (and (>= (car new) start) (<= (cdr new) end))) - nil - (setq start (car new)) - (setq end (cdr new)) - ;; If there's been a change, we should go through the - ;; list again since this new position may - ;; warrant a different answer from one of the funs we've - ;; already seen. - (unless (eq funs - (cdr syntax-propertize-extend-region-functions)) - (setq funs syntax-propertize-extend-region-functions))))) - ;; Move the limit before calling the function, so the function - ;; can use syntax-ppss. - (setq syntax-propertize--done end) - ;; (message "syntax-propertizing from %s to %s" start end) - (remove-text-properties start end - '(syntax-table nil syntax-multiline nil)) - (funcall syntax-propertize-function start end)))))) + (when (< syntax-propertize--done pos) + (if (null syntax-propertize-function) + (setq syntax-propertize--done (max (point-max) pos)) + ;; (message "Needs to syntax-propertize from %s to %s" + ;; syntax-propertize--done pos) + (set (make-local-variable 'parse-sexp-lookup-properties) t) + (save-excursion + (with-silent-modifications + (make-local-variable 'syntax-propertize--done) ;Just in case! + (let* ((start (max (min syntax-propertize--done (point-max)) + (point-min))) + (end (max pos + (min (point-max) + (+ start syntax-propertize-chunk-size)))) + (funs syntax-propertize-extend-region-functions)) + (while funs + (let ((new (funcall (pop funs) start end)) + ;; Avoid recursion! + (syntax-propertize--done most-positive-fixnum)) + (if (or (null new) + (and (>= (car new) start) (<= (cdr new) end))) + nil + (setq start (car new)) + (setq end (cdr new)) + ;; If there's been a change, we should go through the + ;; list again since this new position may + ;; warrant a different answer from one of the funs we've + ;; already seen. + (unless (eq funs + (cdr syntax-propertize-extend-region-functions)) + (setq funs syntax-propertize-extend-region-functions))))) + ;; Move the limit before calling the function, so the function + ;; can use syntax-ppss. + (setq syntax-propertize--done end) + ;; (message "syntax-propertizing from %s to %s" start end) + (remove-text-properties start end + '(syntax-table nil syntax-multiline nil)) + ;; Avoid recursion! + (let ((syntax-propertize--done most-positive-fixnum)) + (funcall syntax-propertize-function start end)))))))) + +;;; Link syntax-propertize with syntax.c. + +(defvar syntax-propertize-chunks + ;; We're not sure how far we'll go. In my tests, using chunks of 2000 + ;; brings to overhead to something negligible. Passing ‘charpos’ directly + ;; also works (basically works line-by-line) but results in an overhead which + ;; I thought was a bit too high (like around 50%). + 2000) + +(defun internal--syntax-propertize (charpos) + ;; FIXME: Called directly from C. + (save-match-data + (syntax-propertize (min (+ syntax-propertize-chunks charpos) (point-max))))) ;;; Incrementally compute and memoize parser state. @@ -360,13 +375,12 @@ from each other, to avoid keeping too much useless info.") "Function to move back outside of any comment/string/paren. This function should move the cursor back to some syntactically safe point (where the PPSS is equivalent to nil).") +(make-obsolete-variable 'syntax-begin-function nil "25.1") -(defvar syntax-ppss-cache nil +(defvar-local syntax-ppss-cache nil "List of (POS . PPSS) pairs, in decreasing POS order.") -(make-variable-buffer-local 'syntax-ppss-cache) -(defvar syntax-ppss-last nil +(defvar-local syntax-ppss-last nil "Cache of (LAST-POS . LAST-PPSS).") -(make-variable-buffer-local 'syntax-ppss-last) (defalias 'syntax-ppss-after-change-function 'syntax-ppss-flush-cache) (defun syntax-ppss-flush-cache (beg &rest ignored) @@ -487,11 +501,6 @@ running the hook." ;; - The function might be slow. ;; - If this function almost always finds a safe nearby spot, ;; the cache won't be populated, so consulting it is cheap. - (when (and (not syntax-begin-function) - (boundp 'font-lock-beginning-of-syntax-function) - font-lock-beginning-of-syntax-function) - (set (make-local-variable 'syntax-begin-function) - font-lock-beginning-of-syntax-function)) (when (and syntax-begin-function (progn (goto-char pos) (funcall syntax-begin-function) diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index cd61eb9ae56..4bd8a19937d 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -520,7 +520,9 @@ With a numeric prefix argument N, sort the Nth column." (car (aref tabulated-list-format n)) (get-text-property (point) 'tabulated-list-column-name)))) - (tabulated-list--sort-by-column-name name))) + (if (nth 2 (assoc name (append tabulated-list-format nil))) + (tabulated-list--sort-by-column-name name) + (user-error "Cannot sort by %s" name)))) (defun tabulated-list--sort-by-column-name (name) (when (and name (derived-mode-p 'tabulated-list-mode)) @@ -581,8 +583,4 @@ as the ewoc pretty-printer." (provide 'tabulated-list) -;; Local Variables: -;; coding: utf-8 -;; End: - ;;; tabulated-list.el ends here diff --git a/lisp/emacs-lisp/thunk.el b/lisp/emacs-lisp/thunk.el new file mode 100644 index 00000000000..0c5816a616d --- /dev/null +++ b/lisp/emacs-lisp/thunk.el @@ -0,0 +1,74 @@ +;;; thunk.el --- Lazy form evaluation -*- lexical-binding: t -*- + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Nicolas Petton <nicolas@petton.fr> +;; Keywords: sequences +;; Version: 1.0 +;; Package: thunk + +;; Maintainer: emacs-devel@gnu.org + +;; 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: +;; +;; Thunk provides functions and macros to delay the evaluation of +;; forms. +;; +;; Use `thunk-delay' to delay the evaluation of a form, and +;; `thunk-force' to evaluate it. The result of the evaluation is +;; cached, and only happens once. +;; +;; Here is an example of a form which evaluation is delayed: +;; +;; (setq delayed (thunk-delay (message "this message is delayed"))) +;; +;; `delayed' is not evaluated until `thunk-force' is called, like the +;; following: +;; +;; (thunk-force delayed) + +;; Tests are located at test/automated/thunk-tests.el + +;;; Code: + +(defmacro thunk-delay (&rest body) + "Delay the evaluation of BODY." + (declare (debug t)) + (let ((forced (make-symbol "forced")) + (val (make-symbol "val"))) + `(let (,forced ,val) + (lambda (&optional check) + (if check + ,forced + (unless ,forced + (setf ,val (progn ,@body)) + (setf ,forced t)) + ,val))))) + +(defun thunk-force (delayed) + "Force the evaluation of DELAYED. +The result is cached and will be returned on subsequent calls +with the same DELAYED argument." + (funcall delayed)) + +(defun thunk-evaluated-p (delayed) + "Return non-nil if DELAYED has been evaluated." + (funcall delayed t)) + +(provide 'thunk) +;;; thunk.el ends here diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 9ae11b71e5e..c9e3fbe4f7d 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -205,7 +205,7 @@ timers). If nil, allocate a new cell." "Insert TIMER into `timer-idle-list'. This arranges to activate TIMER whenever Emacs is next idle. If optional argument DONT-WAIT is non-nil, set TIMER to activate -immediately \(see below\), or at the right time, if Emacs is +immediately \(see below), or at the right time, if Emacs is already idle. REUSE-CELL, if non-nil, is a cons cell to reuse when inserting @@ -324,7 +324,8 @@ This function is called, by name, directly by the C code." (apply (timer--function timer) (timer--args timer))) (error (message "Error running timer%s: %S" (if (symbolp (timer--function timer)) - (format " `%s'" (timer--function timer)) "") + (format-message " `%s'" (timer--function timer)) + "") err))) (when (and retrigger ;; If the timer's been canceled, don't "retrigger" it @@ -344,18 +345,26 @@ This function is called, by name, directly by the C code." (defun run-at-time (time repeat function &rest args) "Perform an action at time TIME. Repeat the action every REPEAT seconds, if REPEAT is non-nil. -TIME should be one of: a string giving an absolute time like -\"11:23pm\" (the acceptable formats are those recognized by -`diary-entry-time'; note that such times are interpreted as times -today, even if in the past); a string giving a relative time like -\"2 hours 35 minutes\" (the acceptable formats are those -recognized by `timer-duration'); nil meaning now; a number of -seconds from now; a value from `encode-time'; or t (with non-nil -REPEAT) meaning the next integral multiple of REPEAT. REPEAT may -be an integer or floating point number. The action is to call -FUNCTION with arguments ARGS. +REPEAT may be an integer or floating point number. +TIME should be one of: +- a string giving today's time like \"11:23pm\" + (the acceptable formats are HHMM, H:MM, HH:MM, HHam, HHAM, + HHpm, HHPM, HH:MMam, HH:MMAM, HH:MMpm, or HH:MMPM; + a period `.' can be used instead of a colon `:' to separate + the hour and minute parts); +- a string giving a relative time like \"90\" or \"2 hours 35 minutes\" + (the acceptable forms are a number of seconds without units + or some combination of values using units in `timer-duration-words'); +- nil, meaning now; +- a number of seconds from now; +- a value from `encode-time'; +- or t (with non-nil REPEAT) meaning the next integral + multiple of REPEAT. -This function returns a timer object which you can use in `cancel-timer'." +The action is to call FUNCTION with arguments ARGS. + +This function returns a timer object which you can use in +`cancel-timer'." (interactive "sRun at time: \nNRepeat interval: \naFunction: ") (or (null repeat) diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 44a9876a078..b88af1dbe1a 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -314,9 +314,9 @@ See also `warning-series', `warning-prefix-function' and ;; Any keymap that is defined will do. ;;;###autoload (defun lwarn (type level message &rest args) - "Display a warning message made from (format MESSAGE ARGS...). + "Display a warning message made from (format-message MESSAGE ARGS...). \\<special-mode-map> -Aside from generating the message with `format', +Aside from generating the message with `format-message', this is equivalent to `display-warning'. TYPE is the warning type: either a custom group name (a symbol), @@ -332,15 +332,15 @@ LEVEL should be either :debug, :warning, :error, or :emergency :error -- invalid data or circumstances. :warning -- suspicious data or circumstances. :debug -- info for debugging only." - (display-warning type (apply 'format message args) level)) + (display-warning type (apply #'format-message message args) level)) ;;;###autoload (defun warn (message &rest args) - "Display a warning message made from (format MESSAGE ARGS...). -Aside from generating the message with `format', + "Display a warning message made from (format-message MESSAGE ARGS...). +Aside from generating the message with `format-message', this is equivalent to `display-warning', using `emacs' as the type and `:warning' as the level." - (display-warning 'emacs (apply 'format message args))) + (display-warning 'emacs (apply #'format-message message args))) (provide 'warnings) |