diff options
Diffstat (limited to 'lisp/emacs-lisp')
41 files changed, 918 insertions, 582 deletions
diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index 4f98bf3f4f5..4ffe6f573c6 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -209,7 +209,6 @@ frames where the source code location is known.") "v" #'backtrace-toggle-locals "#" #'backtrace-toggle-print-circle ":" #'backtrace-toggle-print-gensym - "s" #'backtrace-goto-source "RET" #'backtrace-help-follow-symbol "+" #'backtrace-multi-line "-" #'backtrace-single-line @@ -591,7 +590,7 @@ content of the sexp." (begin (previous-single-property-change end 'backtrace-form nil (point-min)))) (unless tag - (when (or (= end (point-max)) (> end (point-at-eol))) + (when (or (= end (point-max)) (> end (line-end-position))) (user-error "No form here to reformat")) (goto-char end) (setq pos end diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index 882b1d68c48..4bf61abe54c 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -31,6 +31,7 @@ ;;; Code: +(require 'cl-lib) (eval-when-compile (require 'subr-x)) ;For `named-let'. (defmacro benchmark-elapse (&rest forms) @@ -70,7 +71,7 @@ number of repetitions actually used." (defun benchmark--adaptive (func time) "Measure the run time of FUNC, calling it enough times to last TIME seconds. -Result is (REPETITIONS . DATA) where DATA is as returned by `branchmark-call'." +Result is (REPETITIONS . DATA) where DATA is as returned by `benchmark-call'." (named-let loop ((repetitions 1) (data (let ((x (list 0))) (setcdr x x) x))) ;; (message "Running %d iteration" repetitions) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index bbe8135f04a..5ef2d7fe827 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -728,17 +728,20 @@ for speeding up processing.") (while (let ((head (car-safe form))) (cond ((memq head '( progn inline save-excursion save-restriction save-current-buffer)) - (setq form (car (last form))) + (setq form (car (last (cdr form)))) t) - ((memq head '(let let* setq setcar setcdr)) + ((memq head '(let let*)) (setq form (car (last (cddr form)))) t) ((memq head '( prog1 unwind-protect copy-sequence identity reverse nreverse sort)) (setq form (nth 1 form)) t) - ((eq head 'mapc) + ((memq head '(mapc setq setcar setcdr puthash set)) (setq form (nth 2 form)) + t) + ((memq head '(aset put function-put)) + (setq form (nth 3 form)) t)))) form) @@ -753,22 +756,45 @@ for speeding up processing.") ((memq head ;; FIXME: Replace this list with a function property? '( length safe-length cons lambda - string make-string format concat + string unibyte-string make-string concat + format format-message substring substring-no-properties string-replace replace-regexp-in-string symbol-name make-symbol + compare-strings string-distance mapconcat vector make-vector vconcat make-record record regexp-quote regexp-opt buffer-string buffer-substring buffer-substring-no-properties - current-buffer buffer-size - point point-min point-max - following-char preceding-char max-char - + - * / % 1+ 1- min max abs - logand logior lorxor lognot ash + current-buffer buffer-size get-buffer-create + point point-min point-max buffer-end count-lines + following-char preceding-char get-byte max-char + region-beginning region-end + line-beginning-position line-end-position + pos-bol pos-eol + + - * / % 1+ 1- min max abs mod expt logb + logand logior logxor lognot ash logcount + floor ceiling round truncate + sqrt sin cos tan asin acos atan exp log copysign + ffloor fceiling fround ftruncate float + ldexp frexp number-to-string string-to-number - int-to-string char-to-string prin1-to-string + int-to-string char-to-string + prin1-to-string read-from-string byte-to-string string-to-vector string-to-char + capitalize upcase downcase + propertize + string-as-multibyte string-as-unibyte + string-to-multibyte string-to-unibyte + string-make-multibyte string-make-unibyte + string-width char-width + make-hash-table hash-table-count + unibyte-char-to-multibyte multibyte-char-to-unibyte + sxhash sxhash-equal sxhash-eq sxhash-eql + sxhash-equal-including-properties + make-marker copy-marker point-marker mark-marker + set-marker + kbd key-description always)) t) ((eq head 'if) @@ -786,7 +812,7 @@ for speeding up processing.") (defun byte-compile-nilconstp (form) "Return non-nil if FORM always evaluates to a nil value." (setq form (byte-opt--bool-value-form form)) - (or (not form) ; assume (quote nil) always being normalised to nil + (or (not form) ; assume (quote nil) always being normalized to nil (and (consp form) (let ((head (car form))) ;; FIXME: There are many other expressions that are statically nil. @@ -1158,7 +1184,7 @@ See Info node `(elisp) Integer Basics'." (if (equal new-args (cdr form)) ;; Input is unchanged: keep original form, and don't represent ;; a nil result explicitly because that would lead to infinite - ;; growth when the optimiser is iterated. + ;; growth when the optimizer is iterated. (setq nil-result nil) (setq form (cons (car form) new-args))) @@ -1298,9 +1324,6 @@ See Info node `(elisp) Integer Basics'." (list 'progn condition nil))))) (defun byte-optimize-while (form) - ;; FIXME: This check does not belong here, move! - (when (< (length form) 2) - (byte-compile-warn-x form "too few arguments for `while'")) (let ((condition (nth 1 form))) (if (byte-compile-nilconstp condition) condition @@ -1509,15 +1532,16 @@ See Info node `(elisp) Integer Basics'." (put 'set 'byte-optimizer #'byte-optimize-set) (defun byte-optimize-set (form) - (let ((var (car-safe (cdr-safe form)))) - (cond - ((and (eq (car-safe var) 'quote) (consp (cdr var))) - `(setq ,(cadr var) ,@(cddr form))) - ((and (eq (car-safe var) 'make-local-variable) - (eq (car-safe (setq var (car-safe (cdr var)))) 'quote) - (consp (cdr var))) - `(progn ,(cadr form) (setq ,(cadr var) ,@(cddr form)))) - (t form)))) + (pcase (cdr form) + ;; Make sure we only turn `set' into `setq' for dynamic variables. + (`((quote ,(and var (guard (and (symbolp var) + (not (macroexp--const-symbol-p var)) + (not (assq var byte-optimize--lexvars)))))) + ,newval) + `(setq ,var ,newval)) + (`(,(and ml `(make-local-variable ,(and v `(quote ,_)))) ,newval) + `(progn ,ml (,(car form) ,v ,newval))) + (_ form))) ;; enumerating those functions which need not be called if the returned ;; value is not used. That is, something like @@ -1570,7 +1594,7 @@ See Info node `(elisp) Integer Basics'." keymap-parent lax-plist-get ldexp length length< length> length= - line-beginning-position line-end-position + line-beginning-position line-end-position pos-bol pos-eol local-variable-if-set-p local-variable-p locale-info log log10 logand logb logcount logior lognot logxor lsh make-byte-code make-list make-string make-symbol mark marker-buffer max @@ -1977,20 +2001,20 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setq keep-going t) (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) (setq rest (cdr rest)) - (cond ((= tmp 1) + (cond ((eql tmp 1) (byte-compile-log-lap " %s discard\t-->\t<deleted>" lap0) (setq lap (delq lap0 (delq lap1 lap)))) - ((= tmp 0) + ((eql tmp 0) (byte-compile-log-lap " %s discard\t-->\t<deleted> discard" lap0) (setq lap (delq lap0 lap))) - ((= tmp -1) + ((eql tmp -1) (byte-compile-log-lap " %s discard\t-->\tdiscard discard" lap0) (setcar lap0 'byte-discard) (setcdr lap0 0)) - ((error "Optimizer error: too much on the stack")))) + (t (error "Optimizer error: too much on the stack")))) ;; ;; goto*-X X: --> X: ;; diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 4a2860cd43d..9db84c31b88 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -112,44 +112,6 @@ So far, FUNCTION can only be a symbol, not a lambda expression." (function-put 'defmacro 'doc-string-elt 3) (function-put 'defmacro 'lisp-indent-function 2) -;; `macro-declaration-function' are both obsolete (as marked at the end of this -;; file) but used in many .elc files. - -;; We don't use #' here, because it's an obsolete function, and we -;; can't use `with-suppressed-warnings' here due to how this file is -;; used in the bootstrapping process. -(defvar macro-declaration-function 'macro-declaration-function - "Function to process declarations in a macro definition. -The function will be called with two args MACRO and DECL. -MACRO is the name of the macro being defined. -DECL is a list `(declare ...)' containing the declarations. -The value the function returns is not used.") - -(defalias 'macro-declaration-function - #'(lambda (macro decl) - "Process a declaration found in a macro definition. -This is set as the value of the variable `macro-declaration-function'. -MACRO is the name of the macro being defined. -DECL is a list `(declare ...)' containing the declarations. -The return value of this function is not used." - ;; We can't use `dolist' or `cadr' yet for bootstrapping reasons. - (let (d) - ;; Ignore the first element of `decl' (it's always `declare'). - (while (setq decl (cdr decl)) - (setq d (car decl)) - (if (and (consp d) - (listp (cdr d)) - (null (cdr (cdr d)))) - (cond ((eq (car d) 'indent) - (put macro 'lisp-indent-function (car (cdr d)))) - ((eq (car d) 'debug) - (put macro 'edebug-form-spec (car (cdr d)))) - ((eq (car d) 'doc-string) - (put macro 'doc-string-elt (car (cdr d)))) - (t - (message "Unknown declaration %s" d))) - (message "Invalid declaration %s" d)))))) - ;; We define macro-declaration-alist here because it is needed to ;; handle declarations in macro definitions and this is the first file ;; loaded by loadup.el that uses declarations in macros. We specify @@ -568,7 +530,6 @@ ACCESS-TYPE if non-nil should specify the kind of access that will trigger (purecopy (list current-name access-type when))) obsolete-name) - (defmacro define-obsolete-variable-alias ( obsolete-name current-name when &optional docstring) "Make OBSOLETE-NAME a variable alias for CURRENT-NAME and mark it obsolete. @@ -772,9 +733,4 @@ type is. This defaults to \"INFO\"." ;; (file-format emacs19))" ;; nil) -(make-obsolete-variable 'macro-declaration-function - 'macro-declarations-alist "24.3") -(make-obsolete 'macro-declaration-function - 'macro-declarations-alist "24.3") - ;;; byte-run.el ends here diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index a5bd2bca8a2..ec45f488971 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1235,7 +1235,8 @@ Order is by depth-first search." (let (new-l new-c) (save-excursion (goto-char offset) - (setq new-l (1+ (count-lines (point-min) (point-at-bol))) + (setq new-l (1+ (count-lines (point-min) + (line-beginning-position))) new-c (1+ (current-column))) (format "%d:%d:" new-l new-c)))) "")) @@ -1355,16 +1356,23 @@ FORMAT and ARGS are as in `byte-compile-warn'." (let ((byte-compile-form-stack (cons arg byte-compile-form-stack))) (apply #'byte-compile-warn format args))) -(defun byte-compile-warn-obsolete (symbol) - "Warn that SYMBOL (a variable or function) is obsolete." +;;;###autoload +(defun byte-compile-warn-obsolete (symbol type) + "Warn that SYMBOL (a variable, function or generalized variable) is obsolete. +TYPE is a string that say which one of these three types it is." (when (byte-compile-warning-enabled-p 'obsolete symbol) - (let* ((funcp (get symbol 'byte-obsolete-info)) - (msg (macroexp--obsolete-warning - symbol - (or funcp (get symbol 'byte-obsolete-variable)) - (if funcp "function" "variable")))) - (unless (and funcp (memq symbol byte-compile-not-obsolete-funcs)) - (byte-compile-warn-x symbol "%s" msg))))) + (byte-compile-warn-x + symbol "%s" + (macroexp--obsolete-warning + symbol + (pcase type + ("function" + (get symbol 'byte-obsolete-info)) + ("variable" + (get symbol 'byte-obsolete-variable)) + ("generalized variable" + (get symbol 'byte-obsolete-generalized-variable))) + type)))) (defun byte-compile-report-error (error-info &optional fill) "Report Lisp error in compilation. @@ -1461,15 +1469,17 @@ when printing the error message." (defun byte-compile-arglist-signature-string (signature) (cond ((null (cdr signature)) - (format "%d+" (car signature))) + (format "%d or more" (car signature))) ((= (car signature) (cdr signature)) (format "%d" (car signature))) + ((= (1+ (car signature)) (cdr signature)) + (format "%d or %d" (car signature) (cdr signature))) (t (format "%d-%d" (car signature) (cdr signature))))) (defun byte-compile-function-warn (f nargs def) (when (and (get f 'byte-obsolete-info) - (byte-compile-warning-enabled-p 'obsolete f)) - (byte-compile-warn-obsolete f)) + (not (memq f byte-compile-not-obsolete-funcs))) + (byte-compile-warn-obsolete f "function")) ;; Check to see if the function will be available at runtime ;; and/or remember its arity if it's unknown. @@ -1697,12 +1707,12 @@ URLs." (+ " " (or ;; Arguments. (+ (or (syntax symbol) - (any word "-/:[]&=().?^\\#'"))) + (any word "-/:[]&=()<>.,?^\\#*'\""))) ;; Argument that is a list. (seq "(" (* (not ")")) ")"))) ")"))) "" - ;; Heuristic: We can't reliably do `subsititute-command-keys' + ;; Heuristic: We can't reliably do `substitute-command-keys' ;; substitutions, since the value of a keymap in general can't be ;; known at compile time. So instead, we assume that these ;; substitutions are of some length N. @@ -3108,8 +3118,8 @@ lambda-expression." ;; Check that the bit after the `interactive' spec is ;; just a list of symbols (i.e., modes). (unless (seq-every-p #'symbolp (cdr (cdr int))) - (byte-compile-warn-x int "malformed interactive specc: %s" - int)) + (byte-compile-warn-x + int "malformed `interactive' specification: %s" int)) (setq command-modes (cdr (cdr int))) ;; If the interactive spec is a call to `list', don't ;; compile it, because `call-interactively' looks at the @@ -3616,7 +3626,7 @@ lambda-expression." ('set (not (eq access-type 'reference))) ('get (eq access-type 'reference)) (_ t)))) - (byte-compile-warn-obsolete var)))) + (byte-compile-warn-obsolete var "variable")))) (defsubst byte-compile-dynamic-variable-op (base-op var) (let ((tmp (assq var byte-compile-variables))) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 7f95fa94fa1..23d0f121948 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -137,6 +137,11 @@ is less than this number.") ;; Alist associating to each function body the list of its free variables. ) +(defvar cconv--interactive-form-funs + ;; Table used to hold the functions we create internally for + ;; interactive forms. + (make-hash-table :test #'eq :weakness 'key)) + ;;;###autoload (defun cconv-closure-convert (form) "Main entry point for closure conversion. @@ -503,9 +508,23 @@ places where they originally did not directly appear." cond-forms))) (`(function (lambda ,args . ,body) . ,_) - (let ((docstring (if (eq :documentation (car-safe (car body))) - (cconv-convert (cadr (pop body)) env extend)))) - (cconv--convert-function args body env form docstring))) + (let* ((docstring (if (eq :documentation (car-safe (car body))) + (cconv-convert (cadr (pop body)) env extend))) + (bf (if (stringp (car body)) (cdr body) body)) + (if (when (eq 'interactive (car-safe (car bf))) + (gethash form cconv--interactive-form-funs))) + (cif (when if (cconv-convert if env extend))) + (_ (pcase cif + (`#'(lambda () ,form) (setf (cadr (car bf)) form) (setq cif nil)) + ('nil nil) + ;; The interactive form needs special treatment, so the form + ;; inside the `interactive' won't be used any further. + (_ (setf (cadr (car bf)) nil)))) + (cf (cconv--convert-function args body env form docstring))) + (if (not cif) + ;; Normal case, the interactive form needs no special treatment. + cf + `(cconv--interactive-helper ,cf ,cif)))) (`(internal-make-closure . ,_) (byte-compile-report-error @@ -589,12 +608,12 @@ places where they originally did not directly appear." (cconv-convert arg env extend)) (cons fun args))))))) - (`(interactive . ,forms) - `(,(car form) . ,(mapcar (lambda (form) - (cconv-convert form nil nil)) - forms))) + ;; The form (if any) is converted beforehand as part of the `lambda' case. + (`(interactive . ,_) form) - (`(declare . ,_) form) ;The args don't contain code. + ;; `declare' should now be macro-expanded away (and if they're not, we're + ;; in trouble because they *can* contain code nowadays). + ;; (`(declare . ,_) form) ;The args don't contain code. (`(oclosure--fix-type (ignore . ,vars) ,exp) (dolist (var vars) @@ -739,6 +758,13 @@ This function does not return anything but instead fills the (`(function (lambda ,vrs . ,body-forms)) (when (eq :documentation (car-safe (car body-forms))) (cconv-analyze-form (cadr (pop body-forms)) env)) + (let ((bf (if (stringp (car body-forms)) (cdr body-forms) body-forms))) + (when (eq 'interactive (car-safe (car bf))) + (let ((if (cadr (car bf)))) + (unless (macroexp-const-p if) ;Optimize this common case. + (let ((f `#'(lambda () ,if))) + (setf (gethash form cconv--interactive-form-funs) f) + (cconv-analyze-form f env)))))) (cconv--analyze-function vrs body-forms env form)) (`(setq ,var ,expr) @@ -803,13 +829,8 @@ This function does not return anything but instead fills the (cconv-analyze-form fun env))) (dolist (form args) (cconv-analyze-form form env))) - (`(interactive . ,forms) - ;; These appear within the function body but they don't have access - ;; to the function's arguments. - ;; We could extend this to allow interactive specs to refer to - ;; variables in the function's enclosing environment, but it doesn't - ;; seem worth the trouble. - (dolist (form forms) (cconv-analyze-form form nil))) + ;; The form (if any) is converted beforehand as part of the `lambda' case. + (`(interactive . ,_) nil) ;; `declare' should now be macro-expanded away (and if they're not, we're ;; in trouble because they *can* contain code nowadays). diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index ac6cbb53a56..9ff893b75b6 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -112,7 +112,7 @@ too much in text characters anyways.") (set-face-foreground nf "black") (if (and chart-face-use-pixmaps pl) (condition-case nil - (set-face-background-pixmap nf (car pl)) + (set-face-stipple nf (car pl)) (error (message "Cannot set background pixmap %s" (car pl))))) (push nf faces) (setq cl (cdr cl) @@ -526,9 +526,9 @@ cons cells of the form (NAME . NUM). See `sort' for more details." (defun chart-zap-chars (n) "Zap up to N chars without deleting EOLs." (if (not (eobp)) - (if (< n (- (point-at-eol) (point))) + (if (< n (- (line-end-position) (point))) (delete-char n) - (delete-region (point) (point-at-eol))))) + (delete-region (point) (line-end-position))))) (defun chart-display-label (label dir zone start end &optional face) "Display LABEL in direction DIR in column/row ZONE between START and END. diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 04ead562f2f..3f9bc28e0b0 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -250,7 +250,7 @@ with these words enabled." (defvar checkdoc-ispell-lisp-words '("alist" "emacs" "etags" "keymap" "paren" "regexp" "sexp") "List of words that are correct when spell-checking Lisp documentation.") -;;;###autoload(put 'checkdoc-ispell-list-words 'safe-local-variable #'checkdoc-list-of-strings-p) +;;;###autoload(put 'checkdoc-ispell-list-words 'safe-local-variable #'list-of-strings-p) (defcustom checkdoc-max-keyref-before-warn nil "If non-nil, number of \\\\=[command-to-keystroke] tokens allowed in a doc string. @@ -281,8 +281,6 @@ Currently, all recognized keywords must be on `finder-known-keywords'." :version "25.1" :type 'boolean) -(define-obsolete-variable-alias 'checkdoc-style-hooks - 'checkdoc-style-functions "24.3") (defvar checkdoc-style-functions nil "Hook run after the standard style check is completed. All functions must return nil or a string representing the error found. @@ -292,8 +290,6 @@ Each hook is called with two parameters, (DEFUNINFO ENDPOINT). DEFUNINFO is the return value of `checkdoc-defun-info'. ENDPOINT is the location of end of the documentation string.") -(define-obsolete-variable-alias 'checkdoc-comment-style-hooks - 'checkdoc-comment-style-functions "24.3") (defvar checkdoc-comment-style-functions nil "Hook run after the standard comment style check is completed. Must return nil if no errors are found, or a string describing the @@ -324,7 +320,7 @@ These words are ignored when unquoted symbols are searched for. This should be set in an Emacs Lisp file's local variables." :type '(repeat (string :tag "Word")) :version "28.1") -;;;###autoload(put 'checkdoc-symbol-words 'safe-local-variable #'checkdoc-list-of-strings-p) +;;;###autoload(put 'checkdoc-symbol-words 'safe-local-variable #'list-of-strings-p) (defcustom checkdoc-column-zero-backslash-before-paren t "Non-nil means to warn if there is no \"\\\" before \"(\" in column zero. @@ -364,9 +360,9 @@ large number of libraries means it is impractical to fix all of these warnings masse. In almost any other case, setting this to anything but t is likely to be counter-productive.") -;;;###autoload (defun checkdoc-list-of-strings-p (obj) "Return t when OBJ is a list of strings." + (declare (obsolete list-of-strings-p "29.1")) ;; this is a function so it might be shared by checkdoc-proper-noun-list ;; and/or checkdoc-ispell-lisp-words in the future (and (listp obj) @@ -2232,7 +2228,6 @@ nil." (progn (ispell-set-spellchecker-params) ; Initialize variables and dict alists. (ispell-accept-buffer-local-defs) ; Use the correct dictionary. - ;; This code copied in part from ispell.el Emacs 19.34 (dolist (w checkdoc-ispell-lisp-words) (process-send-string ispell-process (concat "@" w "\n")))) (error (setq checkdoc-spellcheck-documentation-flag nil))))) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 607810ee141..7c7f027d777 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -772,7 +772,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (help-insert-xref-button (help-fns-short-filename location) 'cl-type-definition type location 'define-type) - (insert (substitute-command-keys "'"))) + (insert (substitute-quotes "'"))) (insert ".\n") ;; Parents. @@ -782,7 +782,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (insert " Inherits from ") (while (setq cur (pop pl)) (setq cur (cl--class-name cur)) - (insert (substitute-command-keys "`")) + (insert (substitute-quotes "`")) (help-insert-xref-button (symbol-name cur) 'cl-help-type cur) (insert (substitute-command-keys (if pl "', " "'")))) @@ -796,7 +796,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (when ch (insert " Children ") (while (setq cur (pop ch)) - (insert (substitute-command-keys "`")) + (insert (substitute-quotes "`")) (help-insert-xref-button (symbol-name cur) 'cl-help-type cur) (insert (substitute-command-keys (if ch "', " "'")))) @@ -815,10 +815,10 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (when generics (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) (dolist (generic generics) - (insert (substitute-command-keys "`")) + (insert (substitute-quotes "`")) (help-insert-xref-button (symbol-name generic) 'help-function generic) - (insert (substitute-command-keys "'")) + (insert (substitute-quotes "'")) (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 0560ddda268..b3ade3b8943 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -94,11 +94,6 @@ ;; This second one is closely related to what we do here (and that's ;; the name "generalizer" comes from). -;; The autoloads.el mechanism which adds package--builtin-versions -;; maintenance to loaddefs.el doesn't work for preloaded packages (such -;; as this one), so we have to do it by hand! -(push (purecopy '(cl-generic 1 0)) package--builtin-versions) - ;; Note: For generic functions that dispatch on several arguments (i.e. those ;; which use the multiple-dispatch feature), we always use the same "tagcodes" ;; and the same set of arguments on which to dispatch. This works, but is @@ -425,11 +420,13 @@ the specializer used will be the one returned by BODY." ;; only called with explicit arguments. (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody)) (Ī»-lift (mapcar #'car uses-cnm))) - (if (not uses-cnm) - (cons nil - `#'(lambda (,@args) - ,@(car parsed-body) - ,nbody)) + (cond + ((not uses-cnm) + (cons nil + `#'(lambda (,@args) + ,@(car parsed-body) + ,nbody))) + (lexical-binding (cons 'curried `#'(lambda (,nm) ;Called when constructing the effective method. (let ((,nmp (if (cl--generic-isnot-nnm-p ,nm) @@ -465,7 +462,20 @@ the specializer used will be the one returned by BODY." ;; A destructuring-bind would do the trick ;; as well when/if it's more efficient. (apply (lambda (,@Ī»-lift ,@args) ,nbody) - ,@Ī»-lift ,arglist))))))))) + ,@Ī»-lift ,arglist))))))) + (t + (cons t + `#'(lambda (,cnm ,@args) + ,@(car parsed-body) + ,(macroexp-warn-and-return + "cl-defmethod used without lexical-binding" + (if (not (assq nmp uses-cnm)) + nbody + `(let ((,nmp (lambda () + (cl--generic-isnot-nnm-p ,cnm)))) + ,nbody)) + 'lexical t))))) + )) (f (error "Unexpected macroexpansion result: %S" f)))))) (put 'cl-defmethod 'function-documentation diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index a54fa21fa96..b83b44974d3 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -90,12 +90,6 @@ (defvar cl--optimize-safety 1) ;;;###autoload -(define-obsolete-variable-alias - ;; This alias is needed for compatibility with .elc files that use defstruct - ;; and were compiled with Emacs<24.3. - 'custom-print-functions 'cl-custom-print-functions "24.3") - -;;;###autoload (defvar cl-custom-print-functions nil "This is a list of functions that format user objects for printing. Each function is called in turn with three arguments: the object, the diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 80ca43c902a..beafee1d631 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -775,14 +775,34 @@ compared by `eql'. \(fn EXPR (KEYLIST BODY...)...)" (declare (indent 1) (debug (form &rest (sexp body)))) (macroexp-let2 macroexp-copyable-p temp expr - (let* ((head-list nil)) + (let* ((head-list nil) + (has-otherwise nil)) `(cond ,@(mapcar (lambda (c) - (cons (cond ((memq (car c) '(t otherwise)) t) + (cons (cond (has-otherwise + (error "Misplaced t or `otherwise' clause")) + ((memq (car c) '(t otherwise)) + (setq has-otherwise t) + t) ((eq (car c) 'cl--ecase-error-flag) `(error "cl-ecase failed: %s, %s" ,temp ',(reverse head-list))) + ((null (car c)) + (macroexp-warn-and-return + "Case nil will never match" + nil 'suspicious)) + ((and (consp (car c)) (cdar c) (not (cddar c)) + (memq (caar c) '(quote function))) + (macroexp-warn-and-return + (format-message + (concat "Case %s will match `%s'. If " + "that's intended, write %s " + "instead. Otherwise, don't " + "quote `%s'.") + (car c) (caar c) (list (cadar c) (caar c)) + (cadar c)) + `(cl-member ,temp ',(car c)) 'suspicious)) ((listp (car c)) (setq head-list (append (car c) head-list)) `(cl-member ,temp ',(car c))) @@ -2261,139 +2281,131 @@ This is like `cl-flet', but for macros instead of functions. (eval `(function (lambda ,@res)) t)) macroexpand-all-environment)))))) -(defun cl--sm-macroexpand (orig-fun exp &optional env) +(defun cl--sm-macroexpand (exp &optional env) + "Special macro expander used inside `cl-symbol-macrolet'." + ;; FIXME: Arguably, this should be the official definition of `macroexpand'. + (while (not (eq exp (setq exp (macroexpand-1 exp env))))) + exp) + +(defun cl--sm-macroexpand-1 (orig-fun exp &optional env) "Special macro expander advice used inside `cl-symbol-macrolet'. -This function extends `macroexpand' during macro expansion +This function extends `macroexpand-1' during macro expansion of `cl-symbol-macrolet' to additionally expand symbol macros." - (let ((macroexpand-all-environment env) + (let ((exp (funcall orig-fun exp env)) (venv (alist-get :cl-symbol-macros env))) - (while - (progn - (setq exp (funcall orig-fun exp env)) - (pcase exp - ((pred symbolp) - ;; Perform symbol-macro expansion. - (let ((symval (assq exp venv))) - (when symval - (setq exp (cadr symval))))) - (`(setq . ,args) - ;; Convert setq to setf if required by symbol-macro expansion. - (let ((convert nil) - (rargs nil)) - (while args - (let ((place (pop args))) - ;; Here, we know `place' should be a symbol. - (while - (let ((symval (assq place venv))) - (when symval - (setq place (cadr symval)) - (if (symbolp place) - t ;Repeat. - (setq convert t) - nil)))) - (push place rargs) - (push (pop args) rargs))) - (setq exp (cons (if convert 'setf 'setq) - (nreverse rargs))) - convert)) - ;; CL's symbol-macrolet used to treat re-bindings as candidates for - ;; expansion (turning the let into a letf if needed), contrary to - ;; Common-Lisp where such re-bindings hide the symbol-macro. - ;; Not sure if there actually is code out there which depends - ;; on this behavior (haven't found any yet). - ;; Such code should explicitly use `cl-letf' instead, I think. - ;; - ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) pcase--dontcare)) - ;; (let ((letf nil) (found nil) (nbs ())) - ;; (dolist (binding bindings) - ;; (let* ((var (if (symbolp binding) binding (car binding))) - ;; (sm (assq var venv))) - ;; (push (if (not (cdr sm)) - ;; binding - ;; (let ((nexp (cadr sm))) - ;; (setq found t) - ;; (unless (symbolp nexp) (setq letf t)) - ;; (cons nexp (cdr-safe binding)))) - ;; nbs))) - ;; (when found - ;; (setq exp `(,(if letf - ;; (if (eq (car exp) 'let) 'cl-letf 'cl-letf*) - ;; (car exp)) - ;; ,(nreverse nbs) - ;; ,@body))))) - ;; - ;; We implement the Common-Lisp behavior, instead (see bug#26073): - ;; The behavior of CL made sense in a dynamically scoped - ;; language, but nowadays, lexical scoping semantics is more often - ;; expected. - (`(,(or 'let 'let*) . ,(or `(,bindings . ,body) pcase--dontcare)) - (let ((nbs ()) (found nil)) - (dolist (binding bindings) - (let* ((var (if (symbolp binding) binding (car binding))) - (val (and found (consp binding) (eq 'let* (car exp)) - (list (macroexpand-all (cadr binding) - env))))) - (push (if (assq var venv) - ;; This binding should hide "its" surrounding - ;; symbol-macro, but given the way macroexpand-all - ;; works (i.e. the `env' we receive as input will - ;; be (re)applied to the code we return), we can't - ;; prevent application of `env' to the - ;; sub-expressions, so we need to Ī±-rename this - ;; variable instead. - (let ((nvar (make-symbol (symbol-name var)))) - (setq found t) - (push (list var nvar) venv) - (push (cons :cl-symbol-macros venv) env) - (cons nvar (or val (cdr-safe binding)))) - (if val (cons var val) binding)) - nbs))) - (when found - (setq exp `(,(car exp) - ,(nreverse nbs) - ,@(macroexp-unprogn - (macroexpand-all (macroexp-progn body) - env))))) - nil)) - ;; Do the same as for `let' but for variables introduced - ;; via other means, such as `lambda' and `condition-case'. - (`(function (lambda ,args . ,body)) - (let ((nargs ()) (found nil)) - (dolist (var args) - (push (cond - ((memq var '(&optional &rest)) var) - ((assq var venv) - (let ((nvar (make-symbol (symbol-name var)))) - (setq found t) - (push (list var nvar) venv) - (push (cons :cl-symbol-macros venv) env) - nvar)) - (t var)) - nargs)) - (when found - (setq exp `(function - (lambda ,(nreverse nargs) - . ,(mapcar (lambda (exp) - (macroexpand-all exp env)) - body))))) - nil)) - ((and `(condition-case ,var ,exp . ,clauses) - (guard (assq var venv))) - (let ((nvar (make-symbol (symbol-name var)))) - (push (list var nvar) venv) - (push (cons :cl-symbol-macros venv) env) - (setq exp - `(condition-case ,nvar ,(macroexpand-all exp env) - . ,(mapcar - (lambda (clause) - `(,(car clause) - . ,(mapcar (lambda (exp) - (macroexpand-all exp env)) - (cdr clause)))) - clauses))) - nil)) - ))) - exp)) + (pcase exp + ((pred symbolp) + ;; Try symbol-macro expansion. + (let ((symval (assq exp venv))) + (if symval (cadr symval) exp))) + (`(setq . ,args) + ;; Convert setq to setf if required by symbol-macro expansion. + (let ((convert nil)) + (while args + (let* ((place (pop args)) + ;; Here, we know `place' should be a symbol. + (symval (assq place venv))) + (pop args) + (when symval + (setq convert t)))) + (if convert + (cons 'setf (cdr exp)) + exp))) + ;; CL's symbol-macrolet used to treat re-bindings as candidates for + ;; expansion (turning the let into a letf if needed), contrary to + ;; Common-Lisp where such re-bindings hide the symbol-macro. + ;; Not sure if there actually is code out there which depends + ;; on this behavior (haven't found any yet). + ;; Such code should explicitly use `cl-letf' instead, I think. + ;; + ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) pcase--dontcare)) + ;; (let ((letf nil) (found nil) (nbs ())) + ;; (dolist (binding bindings) + ;; (let* ((var (if (symbolp binding) binding (car binding))) + ;; (sm (assq var venv))) + ;; (push (if (not (cdr sm)) + ;; binding + ;; (let ((nexp (cadr sm))) + ;; (setq found t) + ;; (unless (symbolp nexp) (setq letf t)) + ;; (cons nexp (cdr-safe binding)))) + ;; nbs))) + ;; (when found + ;; (setq exp `(,(if letf + ;; (if (eq (car exp) 'let) 'cl-letf 'cl-letf*) + ;; (car exp)) + ;; ,(nreverse nbs) + ;; ,@body))))) + ;; + ;; We implement the Common-Lisp behavior, instead (see bug#26073): + ;; The behavior of CL made sense in a dynamically scoped + ;; language, but nowadays, lexical scoping semantics is more often + ;; expected. + (`(,(or 'let 'let*) . ,(or `(,bindings . ,body) pcase--dontcare)) + (let ((nbs ()) (found nil)) + (dolist (binding bindings) + (let* ((var (if (symbolp binding) binding (car binding))) + (val (and found (consp binding) (eq 'let* (car exp)) + (list (macroexpand-all (cadr binding) + env))))) + (push (if (assq var venv) + ;; This binding should hide "its" surrounding + ;; symbol-macro, but given the way macroexpand-all + ;; works (i.e. the `env' we receive as input will + ;; be (re)applied to the code we return), we can't + ;; prevent application of `env' to the + ;; sub-expressions, so we need to Ī±-rename this + ;; variable instead. + (let ((nvar (make-symbol (symbol-name var)))) + (setq found t) + (push (list var nvar) venv) + (push (cons :cl-symbol-macros venv) env) + (cons nvar (or val (cdr-safe binding)))) + (if val (cons var val) binding)) + nbs))) + (if found + `(,(car exp) + ,(nreverse nbs) + ,@(macroexp-unprogn + (macroexpand-all (macroexp-progn body) + env))) + exp))) + ;; Do the same as for `let' but for variables introduced + ;; via other means, such as `lambda' and `condition-case'. + (`(function (lambda ,args . ,body)) + (let ((nargs ()) (found nil)) + (dolist (var args) + (push (cond + ((memq var '(&optional &rest)) var) + ((assq var venv) + (let ((nvar (make-symbol (symbol-name var)))) + (setq found t) + (push (list var nvar) venv) + (push (cons :cl-symbol-macros venv) env) + nvar)) + (t var)) + nargs)) + (if found + `(function + (lambda ,(nreverse nargs) + . ,(mapcar (lambda (exp) + (macroexpand-all exp env)) + body))) + exp))) + ((and `(condition-case ,var ,exp . ,clauses) + (guard (assq var venv))) + (let ((nvar (make-symbol (symbol-name var)))) + (push (list var nvar) venv) + (push (cons :cl-symbol-macros venv) env) + `(condition-case ,nvar ,(macroexpand-all exp env) + . ,(mapcar + (lambda (clause) + `(,(car clause) + . ,(mapcar (lambda (exp) + (macroexpand-all exp env)) + (cdr clause)))) + clauses)))) + (_ exp)))) ;;;###autoload (defmacro cl-symbol-macrolet (bindings &rest body) @@ -2412,7 +2424,8 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (unwind-protect (progn (unless advised - (advice-add 'macroexpand :around #'cl--sm-macroexpand)) + (advice-add 'macroexpand :override #'cl--sm-macroexpand) + (advice-add 'macroexpand-1 :around #'cl--sm-macroexpand-1)) (let* ((venv (cdr (assq :cl-symbol-macros macroexpand-all-environment))) (expansion @@ -2428,7 +2441,8 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). expansion nil nil rev-malformed-bindings)) expansion))) (unless advised - (advice-remove 'macroexpand #'cl--sm-macroexpand))))) + (advice-remove 'macroexpand #'cl--sm-macroexpand) + (advice-remove 'macroexpand-1 #'cl--sm-macroexpand-1))))) ;;;###autoload (defmacro cl-with-gensyms (names &rest body) @@ -2762,11 +2776,17 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. (funcall setter vold))) binds)))) (let* ((binding (car bindings)) - (place (macroexpand (car binding) macroexpand-all-environment))) + (place (car binding))) (gv-letplace (getter setter) place (macroexp-let2 nil vnew (cadr binding) - (if (symbolp place) + (if (and (symbolp place) + ;; `place' could be some symbol-macro. + (eq place getter)) ;; Special-case for simple variables. + ;; FIXME: We currently only use this special case when `place' + ;; is a simple var. Should we also use it when the + ;; macroexpansion of `place' is a simple var (i.e. when + ;; getter+setter is the same as that of a simple var)? (cl--letf (cdr bindings) (cons `(,getter ,(if (cdr binding) vnew getter)) simplebinds) @@ -3105,7 +3125,7 @@ To see the documentation for a defined struct type, use `(and ,pred-form t))) forms) (push `(eval-and-compile - (put ',name 'cl-deftype-satisfies ',predicate)) + (define-symbol-prop ',name 'cl-deftype-satisfies ',predicate)) forms)) (let ((pos 0) (descp descs)) (while descp @@ -3570,7 +3590,7 @@ and then returning foo." (cl-defun ,fname ,(if (memq '&whole args) (delq '&whole args) (cons '_cl-whole-arg args)) ,@body) - (put ',func 'compiler-macro #',fname)))) + (define-symbol-prop ',func 'compiler-macro #',fname)))) ;;;###autoload (defun cl-compiler-macroexpand (form) @@ -3679,8 +3699,8 @@ macro that returns its `&whole' argument." The type name can then be used in `cl-typecase', `cl-check-type', etc." (declare (debug cl-defmacro) (doc-string 3) (indent 2)) `(cl-eval-when (compile load eval) - (put ',name 'cl-deftype-handler - (cl-function (lambda (&cl-defs ('*) ,@arglist) ,@body))))) + (define-symbol-prop ',name 'cl-deftype-handler + (cl-function (lambda (&cl-defs ('*) ,@arglist) ,@body))))) (cl-deftype extended-char () '(and character (not base-char))) ;; Define fixnum so `cl-typep' recognize it and the type check emitted diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 64ae05bf2a0..60e204eaf51 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -139,6 +139,10 @@ only case where FUNCTION is called with fewer than two arguments. If SEQ contains exactly one element and no :INITIAL-VALUE is specified, then return that element and FUNCTION is not called. +If :FROM-END is non-nil, the reduction occurs from the back of +the SEQ moving forward, and the order of arguments to the +FUNCTION is also reversed. + \n(fn FUNCTION SEQ [KEYWORD VALUE]...)" (cl--parsing-keywords (:from-end (:start 0) :end :initial-value :key) () (or (listp cl-seq) (setq cl-seq (append cl-seq nil))) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 6451e34c42f..8cff06a383a 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -37,16 +37,12 @@ (require 'cl-lib) -(defconst comp--typeof-types (mapcar (lambda (x) - (append x '(t))) - cl--typeof-types) +(defconst comp--typeof-builtin-types (mapcar (lambda (x) + (append x '(t))) + cl--typeof-types) ;; TODO can we just add t in `cl--typeof-types'? "Like `cl--typeof-types' but with t as common supertype.") -(defconst comp--all-builtin-types - (append cl--all-builtin-types '(t)) - "Likewise like `cl--all-builtin-types' but with t as common supertype.") - (cl-defstruct (comp-cstr (:constructor comp-type-to-cstr (type &aux (null (eq type 'null)) @@ -234,7 +230,7 @@ Return them as multiple value." (cl-loop named outer with found = nil - for l in comp--typeof-types + for l in comp--typeof-builtin-types do (cl-loop for x in l for i from (length l) downto 0 @@ -277,7 +273,7 @@ Return them as multiple value." (cl-loop with types = (apply #'append typesets) with res = '() - for lane in comp--typeof-types + for lane in comp--typeof-builtin-types do (cl-loop with last = nil for x in lane diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5ee10fcbca2..6656b7e57c1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -178,14 +178,15 @@ and above." :type '(repeat string) :version "28.1") -(defcustom native-comp-driver-options nil +(defcustom native-comp-driver-options (when (eq system-type 'darwin) + '("-Wl,-w")) "Options passed verbatim to the native compiler's back-end driver. Note that not all options are meaningful; typically only the options affecting the assembler and linker are likely to be useful. Passing these options is only available in libgccjit version 9 and above." - :type '(repeat string) ; FIXME is this right? + :type '(repeat string) :version "28.1") (defcustom comp-libgccjit-reproducer nil @@ -304,7 +305,7 @@ Useful to hook into pass checkers.") (bool-vector-subsetp (function (bool-vector bool-vector) boolean)) (boundp (function (symbol) boolean)) (buffer-end (function ((or number marker)) integer)) - (buffer-file-name (function (&optional buffer) string)) + (buffer-file-name (function (&optional buffer) (or string null))) (buffer-list (function (&optional frame) list)) (buffer-local-variables (function (&optional buffer) list)) (buffer-modified-p (function (&optional buffer) boolean)) @@ -321,8 +322,8 @@ Useful to hook into pass checkers.") (cdr (function (list) t)) (cdr-safe (function (t) t)) (ceiling (function (number &optional number) integer)) - (char-after (function (&optional (or marker integer)) fixnum)) - (char-before (function (&optional (or marker integer)) fixnum)) + (char-after (function (&optional (or marker integer)) (or fixnum null))) + (char-before (function (&optional (or marker integer)) (or fixnum null))) (char-equal (function (integer integer) boolean)) (char-or-string-p (function (t) boolean)) (char-to-string (function (fixnum) string)) @@ -344,14 +345,21 @@ Useful to hook into pass checkers.") (current-buffer (function () buffer)) (current-global-map (function () cons)) (current-indentation (function () integer)) - (current-local-map (function () cons)) - (current-minor-mode-maps (function () cons)) + (current-local-map (function () (or cons null))) + (current-minor-mode-maps (function () (or cons null))) (current-time (function () cons)) - (current-time-string (function (&optional string boolean) string)) - (current-time-zone (function (&optional string boolean) cons)) + (current-time-string (function (&optional (or number list) + (or symbol string cons integer)) + string)) + (current-time-zone (function (&optional (or number list) + (or symbol string cons integer)) + cons)) (custom-variable-p (function (symbol) boolean)) (decode-char (function (cons t) (or fixnum null))) - (decode-time (function (&optional string symbol symbol) cons)) + (decode-time (function (&optional (or number list) + (or symbol string cons integer) + symbol) + cons)) (default-boundp (function (symbol) boolean)) (default-value (function (symbol) t)) (degrees-to-radians (function (number) float)) @@ -383,12 +391,14 @@ Useful to hook into pass checkers.") (file-writable-p (function (string) boolean)) (fixnump (function (t) boolean)) (float (function (number) float)) - (float-time (function (&optional cons) float)) + (float-time (function (&optional (or number list)) float)) (floatp (function (t) boolean)) (floor (function (number &optional number) integer)) (following-char (function () fixnum)) (format (function (string &rest t) string)) - (format-time-string (function (string &optional cons symbol) string)) + (format-time-string (function (string &optional (or number list) + (or symbol string cons integer)) + string)) (frame-first-window (function ((or frame window)) window)) (frame-root-window (function (&optional (or frame window)) window)) (frame-selected-window (function (&optional (or frame window)) window)) @@ -400,8 +410,8 @@ Useful to hook into pass checkers.") (get-buffer (function ((or buffer string)) (or buffer null))) (get-buffer-window (function (&optional (or buffer string) (or symbol (integer 0 0))) (or null window))) (get-file-buffer (function (string) (or null buffer))) - (get-largest-window (function (&optional t t t) window)) - (get-lru-window (function (&optional t t t) window)) + (get-largest-window (function (&optional t t t) (or window null))) + (get-lru-window (function (&optional t t t) (or window null))) (getenv (function (string &optional frame) (or null string))) (gethash (function (t hash-table &optional t) t)) (hash-table-count (function (hash-table) integer)) @@ -450,16 +460,16 @@ Useful to hook into pass checkers.") (make-symbol (function (string) symbol)) (mark (function (&optional t) (or integer null))) (mark-marker (function () marker)) - (marker-buffer (function (marker) buffer)) + (marker-buffer (function (marker) (or buffer null))) (markerp (function (t) boolean)) (max (function ((or number marker) &rest (or number marker)) number)) - (max-char (function () fixnum)) + (max-char (function (&optional t) fixnum)) (member (function (t list) list)) (memory-limit (function () integer)) (memq (function (t list) list)) (memql (function (t list) list)) (min (function ((or number marker) &rest (or number marker)) number)) - (minibuffer-selected-window (function () window)) + (minibuffer-selected-window (function () (or window null))) (minibuffer-window (function (&optional frame) window)) (mod (function ((or number marker) (or number marker)) (or (integer 0 *) (float 0 *)))) (mouse-movement-p (function (t) boolean)) @@ -487,7 +497,7 @@ Useful to hook into pass checkers.") (previous-window (function (&optional window t t) window)) (prin1-to-string (function (t &optional t t) string)) (processp (function (t) boolean)) - (proper-list-p (function (t) integer)) + (proper-list-p (function (t) boolean)) (propertize (function (string &rest t) string)) (radians-to-degrees (function (number) float)) (rassoc (function (t list) list)) @@ -520,7 +530,7 @@ Useful to hook into pass checkers.") (string-to-char (function (string) fixnum)) (string-to-multibyte (function (string) string)) (string-to-number (function (string &optional integer) number)) - (string-to-syntax (function (string) cons)) + (string-to-syntax (function (string) (or cons null))) (string< (function ((or string symbol) (or string symbol)) boolean)) (string= (function ((or string symbol) (or string symbol)) boolean)) (stringp (function (t) boolean)) @@ -542,7 +552,8 @@ Useful to hook into pass checkers.") (this-command-keys-vector (function () vector)) (this-single-command-keys (function () vector)) (this-single-command-raw-keys (function () vector)) - (time-convert (function (t &optional (or boolean integer)) cons)) + (time-convert (function ((or number list) &optional (or symbol integer)) + (or cons number))) (truncate (function (number &optional number) integer)) (type-of (function (t) symbol)) (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum @@ -3790,22 +3801,25 @@ Return the trampoline if found or nil otherwise." (lexical-binding t)) (comp--native-compile form nil - (cl-loop - for dir in (if native-compile-target-directory - (list (expand-file-name comp-native-version-dir - native-compile-target-directory)) - (comp-eln-load-path-eff)) - for f = (expand-file-name - (comp-trampoline-filename subr-name) - dir) - unless (file-exists-p dir) - do (ignore-errors - (make-directory dir t) - (cl-return f)) - when (file-writable-p f) - do (cl-return f) - finally (error "Cannot find suitable directory for output in \ -`native-comp-eln-load-path'"))))) + ;; If we've disabled nativecomp, don't write the trampolines to + ;; the eln cache (but create them). + (and (not inhibit-automatic-native-compilation) + (cl-loop + for dir in (if native-compile-target-directory + (list (expand-file-name comp-native-version-dir + native-compile-target-directory)) + (comp-eln-load-path-eff)) + for f = (expand-file-name + (comp-trampoline-filename subr-name) + dir) + unless (file-exists-p dir) + do (ignore-errors + (make-directory dir t) + (cl-return f)) + when (file-writable-p f) + do (cl-return f) + finally (error "Cannot find suitable directory for output in \ +`native-comp-eln-load-path'")))))) ;; Some entry point support code. @@ -3925,8 +3939,11 @@ display a message." when (or native-comp-always-compile load ; Always compile when the compilation is ; commanded for late load. - (file-newer-than-file-p - source-file (comp-el-to-eln-filename source-file))) + ;; Skip compilation if `comp-el-to-eln-filename' fails + ;; to find a writable directory. + (with-demoted-errors "Async compilation :%S" + (file-newer-than-file-p + source-file (comp-el-to-eln-filename source-file)))) do (let* ((expr `((require 'comp) (setq comp-async-compilation t) (setq warning-fill-column most-positive-fixnum) @@ -4031,7 +4048,6 @@ the deferred compilation mechanism." (list "Not a function symbol or file" function-or-file))) (catch 'no-native-compile (let* ((print-symbols-bare t) - (max-specpdl-size (max max-specpdl-size 5000)) (data function-or-file) (comp-native-compiling t) (byte-native-qualities nil) @@ -4094,6 +4110,7 @@ the deferred compilation mechanism." comp-ctxt (comp-ctxt-output comp-ctxt) (file-exists-p (comp-ctxt-output comp-ctxt))) + (message "Deleting %s" (comp-ctxt-output comp-ctxt)) (delete-file (comp-ctxt-output comp-ctxt))))))) (defun native-compile-async-skip-p (file load selector) diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 460057b3afd..f78d44cf98e 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -110,10 +110,6 @@ The value used here is passed to `quit-restore-window'." (defvar debugger-previous-window-height nil "The last recorded height of `debugger-previous-window'.") -(defvar debugger-previous-backtrace nil - "The contents of the previous backtrace (including text properties). -This is to optimize `debugger-make-xrefs'.") - (defvar debugger-outer-match-data) (defvar debugger-will-be-back nil "Non-nil if we expect to get back in the debugger soon.") @@ -836,6 +832,10 @@ To specify a nil argument interactively, exit with an empty minibuffer." ;;;###autoload (defalias 'cancel-debug-watch #'cancel-debug-on-variable-change) +(make-obsolete-variable 'debugger-previous-backtrace + "no longer used." "29.1") +(defvar debugger-previous-backtrace nil) + (provide 'debug) ;;; debug.el ends here diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index c3a4e9fc7ab..7d54a84687b 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -417,7 +417,12 @@ No problems result if this variable is not bound. `(defvar ,keymap-sym (let ((m ,keymap)) (cond ((keymapp m) m) - ((listp m) (easy-mmode-define-keymap m)) + ;; FIXME: `easy-mmode-define-keymap' is obsolete, + ;; so this form should also be obsolete somehow. + ((listp m) + (with-suppressed-warnings ((obsolete + easy-mmode-define-keymap)) + (easy-mmode-define-keymap m))) (t (error "Invalid keymap %S" m)))) ,(format "Keymap for `%s'." mode-name))) @@ -679,6 +684,7 @@ Valid keywords and arguments are: :group Ignored. :suppress Non-nil to call `suppress-keymap' on keymap, `nodigits' to suppress digits as prefix arguments." + (declare (obsolete define-keymap "29.1")) (let (inherit dense suppress) (while args (let ((key (pop args)) @@ -719,9 +725,7 @@ The M, BS, and ARGS arguments are as per that function. DOC is the constant's documentation. This macro is deprecated; use `defvar-keymap' instead." - ;; FIXME: Declare obsolete in favor of `defvar-keymap'. It is still - ;; used for `gud-menu-map' and `gud-minor-mode-map', so fix that first. - (declare (doc-string 3) (indent 1)) + (declare (doc-string 3) (indent 1) (obsolete defvar-keymap "29.1")) `(defconst ,m (easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args)) ,doc)) diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el index 43ce1872f9b..41e3a197af4 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -492,25 +492,11 @@ To implement dynamic menus, either call this from `menu-bar-update-hook' or use a menu filter." (easy-menu-add-item map path (easy-menu-create-menu name items) before)) -(defalias 'easy-menu-remove #'ignore - "Remove MENU from the current menu bar. -Contrary to XEmacs, this is a nop on Emacs since menus are automatically -\(de)activated when the corresponding keymap is (de)activated. - -\(fn MENU)") +(defalias 'easy-menu-remove #'ignore) (make-obsolete 'easy-menu-remove "this was always a no-op in Emacs \ and can be safely removed." "28.1") -(defalias 'easy-menu-add #'ignore - "Add the menu to the menubar. -On Emacs this is a nop, because menus are already automatically -activated when the corresponding keymap is activated. On XEmacs -this is needed to actually add the menu to the current menubar. - -You should call this once the menu and keybindings are set up -completely and menu filter functions can be expected to work. - -\(fn MENU &optional MAP)") +(defalias 'easy-menu-add #'ignore) (make-obsolete 'easy-menu-add "this was always a no-op in Emacs \ and can be safely removed." "28.1") diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index dff16df0029..67704bdb51c 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -129,7 +129,7 @@ contains an infinite loop. When Edebug is instrumenting code containing very large quoted lists, it may reach this limit and give the error message \"Too deep - perhaps infinite loop in spec?\". Make this limit larger to countermand that, but you may also need to -increase `max-lisp-eval-depth' and `max-specpdl-size'." +increase `max-lisp-eval-depth'." :type 'integer :version "26.1") @@ -1107,8 +1107,7 @@ purpose by adding an entry to this alist, and setting edebug-best-error edebug-error-point ;; Do this once here instead of several times. - (max-lisp-eval-depth (+ 800 max-lisp-eval-depth)) - (max-specpdl-size (+ 2000 max-specpdl-size))) + (max-lisp-eval-depth (+ 800 max-lisp-eval-depth))) (let ((no-match (catch 'no-match (setq result (edebug-read-and-maybe-wrap-form1)) @@ -2317,7 +2316,6 @@ and run its entry function, and set up `edebug-before' and ;; but not inside an unwind-protect. ;; Doing it here also keeps it from growing too large. (max-lisp-eval-depth (+ 100 max-lisp-eval-depth)) ; too much?? - (max-specpdl-size (+ 200 max-specpdl-size)) (debugger edebug-debugger) ; only while edebug is active. (edebug-outside-debug-on-error debug-on-error) @@ -2861,7 +2859,6 @@ See `edebug-behavior-alist' for implementations.") (this-command this-command) (current-prefix-arg nil) - ;; More for Emacs 19 (last-input-event nil) (last-command-event nil) (last-event-frame nil) @@ -3792,9 +3789,6 @@ limited by `edebug-print-length' or `edebug-print-level'." ;;; Edebug Minor Mode -(define-obsolete-variable-alias 'gud-inhibit-global-bindings - 'edebug-inhibit-emacs-lisp-mode-bindings "24.3") - (defvar edebug-inhibit-emacs-lisp-mode-bindings nil "If non-nil, inhibit Edebug bindings on the C-x C-a key. By default, loading the `edebug' library causes these bindings to @@ -4183,6 +4177,7 @@ from Edebug instrumentation found in the backtrace." (backtrace-mode) (add-hook 'backtrace-goto-source-functions #'edebug--backtrace-goto-source nil t)) + (edebug-backtrace-mode) (setq edebug-instrumented-backtrace-frames (backtrace-get-frames 'edebug-debugger :constructor #'edebug--make-frame) @@ -4259,6 +4254,14 @@ Save DEF-NAME, BEFORE-INDEX and AFTER-INDEX in FRAME." (setf (edebug--frame-before-index frame) before-index) (setf (edebug--frame-after-index frame) after-index)) +(defvar-keymap edebug-backtrace-mode-map + "s" #'backtrace-goto-source) + +(define-minor-mode edebug-backtrace-mode + "Minor mode for showing backtraces from edebug." + :lighter nil + :interactive nil) + (defun edebug--backtrace-goto-source () (let* ((index (backtrace-get-index)) (frame (nth index backtrace-frames))) @@ -4568,6 +4571,12 @@ With prefix argument, make it a temporary breakpoint." (was-macro `(macro . ,unwrapped)) (t unwrapped)))))) +(defun edebug--strip-plist (symbol) + "Remove edebug related properties from plist for SYMBOL." + (dolist (prop '( edebug edebug-behavior edebug-coverage + edebug-freq-count ghost-edebug)) + (cl-remprop symbol prop))) + (defun edebug-remove-instrumentation (functions) "Remove Edebug instrumentation from FUNCTIONS. Interactively, the user is prompted for the function to remove @@ -4599,6 +4608,7 @@ instrumentation for, defaulting to all functions." (dolist (symbol functions) (when-let ((unwrapped (edebug--unwrap*-symbol-function symbol))) + (edebug--strip-plist symbol) (defalias symbol unwrapped))) (message "Removed edebug instrumentation from %s" (mapconcat #'symbol-name functions ", "))) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 5e7b5cbfb2f..65aa6aa6df7 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -249,16 +249,22 @@ use '%s or turn off `eieio-backward-compatibility' instead" cname) (defun eieio-make-class-predicate (class) (lambda (obj) (:documentation - (format "Return non-nil if OBJ is an object of type `%S'.\n\n(fn OBJ)" - class)) + (concat + (internal--format-docstring-line + "Return non-nil if OBJ is an object of type `%S'." + class) + "\n\n(fn OBJ)")) (and (eieio-object-p obj) (same-class-p obj class)))) (defun eieio-make-child-predicate (class) (lambda (obj) (:documentation - (format "Return non-nil if OBJ is an object of type `%S' or a subclass. -\n(fn OBJ)" class)) + (concat + (internal--format-docstring-line + "Return non-nil if OBJ is an object of type `%S' or a subclass." + class) + "\n\n(fn OBJ)")) (and (eieio-object-p obj) (object-of-class-p obj class)))) @@ -353,8 +359,8 @@ See `defclass' for more information." (defalias csym (lambda (obj) (:documentation - (format - "Test OBJ to see if it a list of objects which are a child of type %s" + (internal--format-docstring-line + "Test OBJ to see if it a list of objects which are a child of type `%s'." cname)) (when (listp obj) (let ((ans t)) ;; nil is valid diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 5f67263f177..b599aabb7f7 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -153,7 +153,7 @@ are not abstract." (help-insert-xref-button (help-fns-short-filename location) 'cl-type-definition ctr location 'define-type) - (insert (substitute-command-keys "'"))) + (insert (substitute-quotes "'"))) (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 984166b593a..8351d97b13d 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -136,6 +136,7 @@ and reference them using the function `class-option'." (accessors ())) ;; Collect the accessors we need to define. + (setq slots (mapcar (lambda (x) (if (consp x) x (list x))) slots)) (pcase-dolist (`(,sname . ,soptions) slots) (let* ((acces (plist-get soptions :accessor)) (initarg (plist-get soptions :initarg)) @@ -217,10 +218,11 @@ and reference them using the function `class-option'." (when (and eieio-backward-compatibility (eq alloc :class)) ;; FIXME: How could I declare this *method* as obsolete. (push `(cl-defmethod ,acces ((this (subclass ,name))) - ,(format - "Retrieve the class slot `%S' from a class `%S'. -This method is obsolete." - sname name) + ,(concat + (internal--format-docstring-line + "Retrieve the class slot `%S' from a class `%S'." + sname name) + "\nThis method is obsolete.") (if (slot-boundp this ',sname) (eieio-oref-default this ',sname))) accessors))) @@ -229,16 +231,18 @@ This method is obsolete." ;; name whose purpose is to set the value of the slot. (if writer (push `(cl-defmethod ,writer ((this ,name) value) - ,(format "Set the slot `%S' of an object of class `%S'." - sname name) + ,(internal--format-docstring-line + "Set the slot `%S' of an object of class `%S'." + sname name) (setf (slot-value this ',sname) value)) accessors)) ;; If a reader is defined, then create a generic method ;; of that name whose purpose is to access this slot value. (if reader (push `(cl-defmethod ,reader ((this ,name)) - ,(format "Access the slot `%S' from object of class `%S'." - sname name) + ,(internal--format-docstring-line + "Access the slot `%S' from object of class `%S'." + sname name) (slot-value this ',sname)) accessors)) )) diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index 03c5b94e3b4..cbf38e7dd88 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -111,7 +111,7 @@ ;; provide the functionality or interface that I wanted, so I wrote ;; this. -;; Unlike previous profilers, elp uses Emacs 19's built-in function +;; Unlike previous profilers, elp uses the built-in function ;; current-time to return interval times. This obviates the need for ;; both an external C program and Emacs processes to communicate with ;; such a program, and thus simplifies the package as a whole. diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 4436d0a4b16..a891f068a70 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -102,6 +102,43 @@ the name of the test and the result of NAME-FORM." (indent 1)) `(ert--call-with-test-buffer ,name-form (lambda () ,@body))) +(cl-defmacro ert-with-test-buffer-selected ((&key name) + &body body) + "Create a test buffer, switch to it, and run BODY. + +This extends `ert-with-test-buffer' by displaying the test +buffer (whose name is derived from NAME) in a temporary window. +The temporary window becomes the `selected-window' before BODY is +evaluated. The modification hooks `before-change-functions' and +`after-change-functions' are not inhibited during the evaluation +of BODY, which makes it easier to use `execute-kbd-macro' to +simulate user interaction. The window configuration is restored +before returning, even if BODY exits nonlocally. The return +value is the last form in BODY." + (declare (debug ((":name" form) def-body)) + (indent 1)) + (let ((ret (make-symbol "ert--with-test-buffer-selected-ret"))) + `(save-window-excursion + (let (,ret) + (ert-with-test-buffer (:name ,name) + (with-current-buffer-window (current-buffer) + `(display-buffer-below-selected + (body-function + . ,(lambda (window) + (select-window window t) + ;; body-function is intended to initialize the + ;; contents of a temporary read-only buffer, so + ;; it is executed with some convenience + ;; changes. Undo those changes so that the + ;; test buffer behaves more like an ordinary + ;; buffer while the body executes. + (let ((inhibit-modification-hooks nil) + (inhibit-read-only nil) + (buffer-read-only nil)) + (setq ,ret (progn ,@body)))))) + nil)) + ,ret)))) + ;;;###autoload (defun ert-kill-all-test-buffers () "Kill all test buffers that are still live." @@ -422,6 +459,10 @@ The following keyword arguments are supported: :text STRING If non-nil, pass STRING to `make-temp-file' as the TEXT argument. +:buffer SYMBOL Open the temporary file using `find-file-noselect' + and bind SYMBOL to the buffer. Kill the buffer + after BODY exits normally or non-locally. + :coding CODING If non-nil, bind `coding-system-for-write' to CODING when executing BODY. This is handy when STRING includes non-ASCII characters or the temporary file must have a @@ -430,14 +471,17 @@ The following keyword arguments are supported: See also `ert-with-temp-directory'." (declare (indent 1) (debug (symbolp body))) (cl-check-type name symbol) - (let (keyw prefix suffix directory text extra-keywords coding) + (let (keyw prefix suffix directory text extra-keywords buffer coding) (while (keywordp (setq keyw (car body))) (setq body (cdr body)) (pcase keyw (:prefix (setq prefix (pop body))) (:suffix (setq suffix (pop body))) + ;; This is only for internal use by `ert-with-temp-directory' + ;; and is therefore not documented. (:directory (setq directory (pop body))) (:text (setq text (pop body))) + (:buffer (setq buffer (pop body))) (:coding (setq coding (pop body))) (_ (push keyw extra-keywords) (pop body)))) (when extra-keywords @@ -452,10 +496,17 @@ See also `ert-with-temp-directory'." (make-temp-file ,prefix ,directory ,suffix ,text))) (,name ,(if directory `(file-name-as-directory ,temp-file) - temp-file))) + temp-file)) + ,@(when buffer + (list `(,buffer (find-file-literally ,temp-file))))) (unwind-protect (progn ,@body) (ignore-errors + ,@(when buffer + (list `(with-current-buffer buf + (set-buffer-modified-p nil)) + `(kill-buffer ,buffer)))) + (ignore-errors ,(if directory `(delete-directory ,temp-file :recursive) `(delete-file ,temp-file)))))))) @@ -517,7 +568,7 @@ The same keyword arguments are supported as in `("\\`mock\\'" nil ,(system-name))) ;; Emacs's Makefile sets $HOME to a nonexistent value. Needed ;; in batch mode only, therefore. - (unless (and (null noninteractive) (file-directory-p "~/")) + (when (and noninteractive (not (file-directory-p "~/"))) (setenv "HOME" temporary-file-directory)) (format "/mock::%s" temporary-file-directory)))) "Temporary directory for remote file tests.") diff --git a/lisp/emacs-lisp/generate-lisp-file.el b/lisp/emacs-lisp/generate-lisp-file.el index 8896a3f7019..7b087a4ecbd 100644 --- a/lisp/emacs-lisp/generate-lisp-file.el +++ b/lisp/emacs-lisp/generate-lisp-file.el @@ -63,12 +63,12 @@ inserted." (cl-defun generate-lisp-file-trailer (file &key version inhibit-provide (coding 'utf-8-emacs-unix) autoloads - compile provide) + compile provide inhibit-native-compile) "Insert a standard trailer for FILE. By default, this trailer inhibits version control, byte compilation, updating autoloads, and uses a `utf-8-emacs-unix' coding system. These can be inhibited by providing non-nil -values to the VERSION, NO-PROVIDE, AUTOLOADS and COMPILE +values to the VERSION, AUTOLOADS, COMPILE and NATIVE-COMPILE keyword arguments. CODING defaults to `utf-8-emacs-unix'. Use a nil value to @@ -79,7 +79,11 @@ If PROVIDE is non-nil, use that in the `provide' statement instead of using FILE as the basis. If `standard-output' is bound to a buffer, insert in that buffer. -If no, insert at point in the current buffer." +If no, insert at point in the current buffer. + +If INHITBIT-NATIVE-COMPILE is non-nil, add a cookie to inhibit +native compilation. (By default, a file will be native-compiled +if it's also byte-compiled)." (with-current-buffer (if (bufferp standard-output) standard-output (current-buffer)) @@ -96,9 +100,11 @@ If no, insert at point in the current buffer." (unless version (insert ";; version-control: never\n")) (unless compile - (insert ";; no-byte-" "compile: t\n")) ;; #$ is byte-compiled into nil. + (insert ";; no-byte-" "compile: t\n")) (unless autoloads (insert ";; no-update-autoloads: t\n")) + (when inhibit-native-compile + (insert ";; no-native-" "compile: t\n")) (when coding (insert (format ";; coding: %s\n" (if (eq coding t) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 54ddc7ac757..a96fa19a3ff 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -87,11 +87,18 @@ with a (not necessarily copyable) Elisp expression that returns the value to set it to. DO must return an Elisp expression." (cond - ((symbolp place) (funcall do place (lambda (v) `(setq ,place ,v)))) + ((symbolp place) + (let ((me (macroexpand-1 place macroexpand-all-environment))) + (if (eq me place) + (funcall do place (lambda (v) `(setq ,place ,v))) + (gv-get me do)))) ((not (consp place)) (signal 'gv-invalid-place (list place))) (t (let* ((head (car place)) (gf (function-get head 'gv-expander 'autoload))) + (when (and (symbolp head) + (get head 'byte-obsolete-generalized-variable)) + (byte-compile-warn-obsolete head "generalized variable")) (if gf (apply gf do (cdr place)) (let ((me (macroexpand-1 place ;; (append macroexpand-all-environment @@ -166,6 +173,18 @@ arguments as NAME. DO is a function as defined in `gv-get'." ;; (`(expand ,expander) `(gv-define-expand ,name ,expander)) (_ (message "Unknown %s declaration %S" symbol handler) nil)))) +(defun make-obsolete-generalized-variable (obsolete-name current-name when) + "Make byte-compiler warn that generalized variable OBSOLETE-NAME is obsolete. +The warning will say that CURRENT-NAME should be used instead. + +If CURRENT-NAME is a string, that is the `use instead' message. + +WHEN should be a string indicating when the variable was first +made obsolete, for example a date or a release number." + (put obsolete-name 'byte-obsolete-generalized-variable + (purecopy (list current-name when))) + obsolete-name) + ;; Additions for `declare'. We specify the values as named aliases so ;; that `describe-variable' prints something useful; cf. Bug#40491. @@ -392,6 +411,7 @@ The return value is the last VAL in the list. (gv-define-setter buffer-local-value (val var buf) (macroexp-let2 nil v val `(with-current-buffer ,buf (set (make-local-variable ,var) ,v)))) +(make-obsolete-generalized-variable 'buffer-local-value nil "29.1") (gv-define-expander alist-get (lambda (do key alist &optional default remove testfn) @@ -516,13 +536,15 @@ The return value is the last VAL in the list. (funcall do `(error . ,args) (lambda (v) `(progn ,v (error . ,args)))))) -(defmacro gv-synthetic-place (getter setter) +(defun gv-synthetic-place (getter setter) "Special place described by its setter and getter. GETTER and SETTER (typically obtained via `gv-letplace') get and -set that place. I.e. This macro allows you to do the \"reverse\" of what -`gv-letplace' does. -This macro only makes sense when used in a place." - (declare (gv-expander funcall)) +set that place. I.e. this function allows you to do the +\"reverse\" of what `gv-letplace' does. + +This function is only useful when used in conjunction with +generalized variables in place forms." + (declare (gv-expander funcall) (compiler-macro (lambda (_) getter))) (ignore setter) getter) @@ -618,71 +640,160 @@ REF must have been previously obtained with `gv-ref'." ;; Some Emacs-related place types. (gv-define-simple-setter buffer-file-name set-visited-file-name t) +(make-obsolete-generalized-variable + 'buffer-file-name 'set-visited-file-name "29.1") + (gv-define-setter buffer-modified-p (flag &optional buf) (macroexp-let2 nil buffer `(or ,buf (current-buffer)) `(with-current-buffer ,buffer (set-buffer-modified-p ,flag)))) +(make-obsolete-generalized-variable + 'buffer-modified-p 'set-buffer-modified-p "29.1") + (gv-define-simple-setter buffer-name rename-buffer t) +(make-obsolete-generalized-variable 'buffer-name 'rename-buffer "29.1") + (gv-define-setter buffer-string (store) `(insert (prog1 ,store (erase-buffer)))) +(make-obsolete-generalized-variable 'buffer-string nil "29.1") + (gv-define-simple-setter buffer-substring cl--set-buffer-substring) +(make-obsolete-generalized-variable 'buffer-substring nil "29.1") + (gv-define-simple-setter current-buffer set-buffer) +(make-obsolete-generalized-variable 'current-buffer 'set-buffer "29.1") + (gv-define-simple-setter current-column move-to-column t) +(make-obsolete-generalized-variable 'current-column 'move-to-column "29.1") + (gv-define-simple-setter current-global-map use-global-map t) +(make-obsolete-generalized-variable 'current-global-map 'use-global-map "29.1") + (gv-define-setter current-input-mode (store) `(progn (apply #'set-input-mode ,store) ,store)) +(make-obsolete-generalized-variable 'current-input-mode nil "29.1") + (gv-define-simple-setter current-local-map use-local-map t) +(make-obsolete-generalized-variable 'current-local-map 'use-local-map "29.1") + (gv-define-simple-setter current-window-configuration set-window-configuration t) +(make-obsolete-generalized-variable + 'current-window-configuration 'set-window-configuration "29.1") + (gv-define-simple-setter default-file-modes set-default-file-modes t) +(make-obsolete-generalized-variable + 'default-file-modes 'set-default-file-modes "29.1") + (gv-define-simple-setter documentation-property put) +(make-obsolete-generalized-variable 'documentation-property 'put "29.1") + (gv-define-setter face-background (x f &optional s) `(set-face-background ,f ,x ,s)) (gv-define-setter face-background-pixmap (x f &optional s) - `(set-face-background-pixmap ,f ,x ,s)) + `(set-face-stipple ,f ,x ,s)) +(make-obsolete-generalized-variable 'face-background-pixmap 'face-stipple "29.1") +(gv-define-setter face-stipple (x f &optional s) + `(set-face-stipple ,f ,x ,s)) (gv-define-setter face-font (x f &optional s) `(set-face-font ,f ,x ,s)) (gv-define-setter face-foreground (x f &optional s) `(set-face-foreground ,f ,x ,s)) (gv-define-setter face-underline-p (x f &optional s) `(set-face-underline ,f ,x ,s)) (gv-define-simple-setter file-modes set-file-modes t) + (gv-define-setter frame-height (x &optional frame) `(set-frame-height (or ,frame (selected-frame)) ,x)) +(make-obsolete-generalized-variable 'frame-height 'set-frame-height "29.1") + (gv-define-simple-setter frame-parameters modify-frame-parameters t) (gv-define-simple-setter frame-visible-p cl--set-frame-visible-p) +(make-obsolete-generalized-variable 'frame-visible-p nil "29.1") + (gv-define-setter frame-width (x &optional frame) `(set-frame-width (or ,frame (selected-frame)) ,x)) +(make-obsolete-generalized-variable 'frame-width 'set-frame-width "29.1") + (gv-define-simple-setter getenv setenv t) (gv-define-simple-setter get-register set-register) + (gv-define-simple-setter global-key-binding global-set-key) +(make-obsolete-generalized-variable 'global-key-binding 'global-set-key "29.1") + (gv-define-simple-setter local-key-binding local-set-key) +(make-obsolete-generalized-variable 'local-key-binding 'local-set-key "29.1") + (gv-define-simple-setter mark set-mark t) +(make-obsolete-generalized-variable 'mark 'set-mark "29.1") + (gv-define-simple-setter mark-marker set-mark t) +(make-obsolete-generalized-variable 'mark-marker 'set-mark "29.1") + (gv-define-simple-setter marker-position set-marker t) +(make-obsolete-generalized-variable 'marker-position 'set-marker "29.1") + (gv-define-setter mouse-position (store scr) `(set-mouse-position ,scr (car ,store) (cadr ,store) (cddr ,store))) +(make-obsolete-generalized-variable 'mouse-position 'set-mouse-position "29.1") + (gv-define-simple-setter point goto-char) +(make-obsolete-generalized-variable 'point 'goto-char "29.1") + (gv-define-simple-setter point-marker goto-char t) +(make-obsolete-generalized-variable 'point-marker 'goto-char "29.1") + (gv-define-setter point-max (store) `(progn (narrow-to-region (point-min) ,store) ,store)) +(make-obsolete-generalized-variable 'point-max 'narrow-to-region "29.1") + (gv-define-setter point-min (store) `(progn (narrow-to-region ,store (point-max)) ,store)) +(make-obsolete-generalized-variable 'point-min 'narrow-to-region "29.1") + (gv-define-setter read-mouse-position (store scr) `(set-mouse-position ,scr (car ,store) (cdr ,store))) +(make-obsolete-generalized-variable + 'read-mouse-position 'set-mouse-position "29.1") + (gv-define-simple-setter screen-height set-screen-height t) +(make-obsolete-generalized-variable 'screen-height 'set-screen-height "29.1") + (gv-define-simple-setter screen-width set-screen-width t) +(make-obsolete-generalized-variable 'screen-width 'set-screen-width "29.1") + (gv-define-simple-setter selected-window select-window) +(make-obsolete-generalized-variable 'selected-window 'select-window "29.1") + (gv-define-simple-setter selected-screen select-screen) +(make-obsolete-generalized-variable 'selected-screen 'select-screen "29.1") + (gv-define-simple-setter selected-frame select-frame) +(make-obsolete-generalized-variable 'selected-frame 'select-frame "29.1") + (gv-define-simple-setter standard-case-table set-standard-case-table) +(make-obsolete-generalized-variable + 'standard-case-table 'set-standard-case-table "29.1") + (gv-define-simple-setter syntax-table set-syntax-table) +(make-obsolete-generalized-variable 'syntax-table 'set-syntax-table "29.1") + (gv-define-simple-setter visited-file-modtime set-visited-file-modtime t) +(make-obsolete-generalized-variable + 'visited-file-modtime 'set-visited-file-modtime "29.1") + (gv-define-setter window-height (store) `(progn (enlarge-window (- ,store (window-height))) ,store)) +(make-obsolete-generalized-variable 'window-height 'enlarge-window "29.1") + (gv-define-setter window-width (store) `(progn (enlarge-window (- ,store (window-width)) t) ,store)) +(make-obsolete-generalized-variable 'window-width 'enlarge-window "29.1") + (gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t) +(make-obsolete-generalized-variable + 'x-get-secondary-selection 'x-own-secondary-selection "29.1") + ;; More complex setf-methods. @@ -701,6 +812,7 @@ REF must have been previously obtained with `gv-ref'." `(cond (,v ,(funcall setter val)) ((eq ,getter ,val) ,(funcall setter `(not ,val)))))))))) +(make-obsolete-generalized-variable 'eq nil "29.1") (gv-define-expander substring (lambda (do place from &optional to) diff --git a/lisp/emacs-lisp/icons.el b/lisp/emacs-lisp/icons.el index 277b285c2ef..a08ac7463ce 100644 --- a/lisp/emacs-lisp/icons.el +++ b/lisp/emacs-lisp/icons.el @@ -189,8 +189,10 @@ present if the icon is represented by an image." (cl-defmethod icons--create ((_type (eql 'image)) icon keywords) (let ((file (if (file-name-absolute-p icon) icon - (image-search-load-path icon)))) + (and (fboundp 'image-search-load-path) + (image-search-load-path icon))))) (and (display-images-p) + (fboundp 'image-supported-file-p) (image-supported-file-p file) (propertize " " 'display @@ -200,7 +202,11 @@ present if the icon is represented by an image." :height (if (eq height 'line) (window-default-line-height) height) - :scale 1) + :scale 1 + :rotation (or (plist-get keywords :rotation) 0) + :ascent (if (plist-member keywords :ascent) + (plist-get keywords :ascent) + 'center)) (create-image file)))))) (cl-defmethod icons--create ((_type (eql 'emoji)) icon _keywords) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index c56a9660e7c..7e39a77aed5 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -325,6 +325,20 @@ This will generate compile-time constants from BINDINGS." (throw 'matched t))) (throw 'matched nil))))) +(defun lisp-mode--search-key (char bound) + (catch 'found + (while (re-search-forward + (concat "\\_<" char (rx lisp-mode-symbol) "\\_>") + bound t) + (when (or (< (match-beginning 0) (+ (point-min) 2)) + ;; A quoted white space before the &/: means that this + ;; is not the start of a :keyword or an &option. + (not (eql (char-after (- (match-beginning 0) 2)) + ?\\)) + (not (memq (char-after (- (match-beginning 0) 1)) + '(?\s ?\n ?\t)))) + (throw 'found t))))) + (let-when-compile ((lisp-fdefs '("defmacro" "defun")) (lisp-vdefs '("defvar")) @@ -496,11 +510,11 @@ This will generate compile-time constants from BINDINGS." (,(rx "\\\\=") (0 font-lock-builtin-face prepend)) ;; Constant values. - (,(concat "\\_<:" (rx lisp-mode-symbol) "\\_>") + (,(lambda (bound) (lisp-mode--search-key ":" bound)) (0 font-lock-builtin-face)) ;; ELisp and CLisp `&' keywords as types. - (,(concat "\\_<&" (rx lisp-mode-symbol) "\\_>") - . font-lock-type-face) + (,(lambda (bound) (lisp-mode--search-key "&" bound)) + (0 font-lock-builtin-face)) ;; ELisp regexp grouping constructs (,(lambda (bound) (catch 'found @@ -549,11 +563,12 @@ This will generate compile-time constants from BINDINGS." ;; must come before keywords below to have effect (,(concat "#:" (rx lisp-mode-symbol) "") 0 font-lock-builtin-face) ;; Constant values. - (,(concat "\\_<:" (rx lisp-mode-symbol) "\\_>") + (,(lambda (bound) (lisp-mode--search-key ":" bound)) (0 font-lock-builtin-face)) ;; ELisp and CLisp `&' keywords as types. - (,(concat "\\_<&" (rx lisp-mode-symbol) "\\_>") - . font-lock-type-face) + (,(lambda (bound) (lisp-mode--search-key "&" bound)) + (0 font-lock-builtin-face)) + ;; ELisp regexp grouping constructs ;; This is too general -- rms. ;; A user complained that he has functions whose names start with `do' ;; and that they get the wrong color. @@ -728,67 +743,30 @@ font-lock keywords will not be case sensitive." len)))) (defun lisp-current-defun-name () - "Return the name of the defun at point. -If there is no defun at point, return the first symbol from the -top-level form. If there is no top-level form, return nil. - -(\"defun\" here means \"form that defines something\", and is -decided heuristically.)" + "Return the name of the defun at point, or nil." (save-excursion - (let ((location (point)) - name) + (let ((location (point))) ;; If we are now precisely at the beginning of a defun, make sure ;; beginning-of-defun finds that one rather than the previous one. - (unless (eobp) - (forward-char 1)) + (or (eobp) (forward-char 1)) (beginning-of-defun) ;; Make sure we are really inside the defun found, not after it. - (when (and (looking-at "(") - (progn - (end-of-defun) - (< location (point))) - (progn - (forward-sexp -1) - (>= location (point)))) - (when (looking-at "(") - (forward-char 1)) - ;; Read the defining construct name, typically "defun" or + (when (and (looking-at "\\s(") + (progn (end-of-defun) + (< location (point))) + (progn (forward-sexp -1) + (>= location (point)))) + (if (looking-at "\\s(") + (forward-char 1)) + ;; Skip the defining construct name, typically "defun" or ;; "defvar". - (let ((symbol (ignore-errors (read (current-buffer))))) - (when (and symbol (not (symbolp symbol))) - (setq symbol nil)) - ;; If there's an edebug spec, use that to determine what the - ;; name is. - (when symbol - (let ((spec (or (get symbol 'edebug-form-spec) - (and (eq (get symbol 'lisp-indent-function) 'defun) - (get 'defun 'edebug-form-spec))))) - (save-excursion - (when (and (eq (car-safe spec) '&define) - (memq 'name spec)) - (pop spec) - (while (and spec (not name)) - (let ((candidate (ignore-errors (read (current-buffer))))) - (when (eq (pop spec) 'name) - (when (and (consp candidate) - (symbolp (car (delete 'quote candidate)))) - (setq candidate (car (delete 'quote candidate)))) - (setq name candidate - spec nil)))))))) - ;; We didn't have an edebug spec (or couldn't find the - ;; name). If the symbol starts with \"def\", then it's - ;; likely that the next symbol is the name. - (when (and (not name) - (string-match-p "\\(\\`\\|-\\)def" (symbol-name symbol))) - (when-let ((candidate (ignore-errors (read (current-buffer))))) - (cond - ((symbolp candidate) - (setq name candidate)) - ((and (consp candidate) - (symbolp (car (delete 'quote candidate)))) - (setq name (car (delete 'quote candidate))))))) - (when-let ((result (or name symbol))) - (and (symbolp result) (symbol-name result)))))))) + (forward-sexp 1) + ;; The second element is usually a symbol being defined. If it + ;; is not, use the first symbol in it. + (skip-chars-forward " \t\n'(") + (buffer-substring-no-properties (point) + (progn (forward-sexp 1) + (point))))))) (defvar-keymap lisp-mode-shared-map :doc "Keymap for commands shared by all sorts of Lisp modes." diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index 8413373e5d4..964d23c770e 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -287,10 +287,14 @@ expression, in which case we want to handle forms differently." ;; In Emacs this is normally handled separately by cus-dep.el, but for ;; third party packages, it can be convenient to explicitly autoload ;; a group. - (let ((groupname (nth 1 form))) + (let ((groupname (nth 1 form)) + (parent (eval (plist-get form :group) t))) `(let ((loads (get ',groupname 'custom-loads))) (if (member ',file loads) nil - (put ',groupname 'custom-loads (cons ',file loads)))))) + (put ',groupname 'custom-loads (cons ',file loads)) + ,@(when parent + `((put ',parent 'custom-loads + (cons ',groupname (get ',parent 'custom-loads))))))))) ;; When processing a macro expansion, any expression ;; before a :autoload-end should be included. These are typically (put @@ -504,6 +508,7 @@ If COMPILE, don't include a \"don't compile\" cookie." (generate-lisp-file-trailer file :provide (and (stringp feature) feature) :compile compile + :inhibit-native-compile t :inhibit-provide (not feature)) (buffer-string)))) @@ -511,7 +516,7 @@ If COMPILE, don't include a \"don't compile\" cookie." (defun loaddefs-generate (dir output-file &optional excluded-files extra-data include-package-version generate-full) - "Generate loaddefs files for Lisp files in the directories DIRS. + "Generate loaddefs files for Lisp files in one or more directories given by DIR. DIR can be either a single directory or a list of directories. The autoloads will be written to OUTPUT-FILE. If any Lisp file @@ -519,7 +524,7 @@ binds `generated-autoload-file' as a file-local variable, write its autoloads into the specified file instead. The function does NOT recursively descend into subdirectories of the -directory or directories specified by DIRS. +directories specified by DIR. Optional argument EXCLUDED-FILES, if non-nil, should be a list of files, such as preloaded files, whose autoloads should not be written @@ -627,7 +632,7 @@ instead of just updating them with the new/changed autoloads." ;; It's a new file; put the data at the end. (progn (goto-char (point-max)) - (search-backward "\f\n")) + (search-backward "\f\n" nil t)) ;; Delete the old version of the section. (delete-region (match-beginning 0) (and (search-forward "\n\f\n;;;") @@ -645,7 +650,8 @@ instead of just updating them with the new/changed autoloads." (unless (equal (buffer-hash) hash) (write-region (point-min) (point-max) loaddefs-file nil 'silent) (byte-compile-info - (file-relative-name loaddefs-file lisp-directory) t "GEN")))))))) + (file-relative-name loaddefs-file (car (ensure-list dir))) + t "GEN")))))))) (defun loaddefs-generate--print-form (def) "Print DEF in a format that makes sense for version control." diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 5ae9d8368f0..f4df40249de 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -110,7 +110,8 @@ each clause." (let ((symbols-with-pos-enabled t)) (apply handler form (cdr form))) (error - (message "Compiler-macro error for %S: Handler: %S\n%S" (car form) handler err) + (message "Warning: Optimization failure for %S: Handler: %S\n%S" + (car form) handler err) form))) (defun macroexp--funcall-if-compiled (_form) @@ -187,13 +188,15 @@ It should normally be a symbol with position and it defaults to FORM." msg)) form))) -(defun macroexp--obsolete-warning (fun obsolescence-data type) +(defun macroexp--obsolete-warning (fun obsolescence-data type &optional key) (let ((instead (car obsolescence-data)) (asof (nth 2 obsolescence-data))) (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))) + ((and instead key) + (format-message "; use `%s' (%s) instead." instead key)) (instead (format-message "; use `%s' instead." instead)) (t "."))))) @@ -369,6 +372,11 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexp--all-forms body)) (cdr form)) form))) + (`(while) + (macroexp-warn-and-return + "missing `while' condition" + `(signal 'wrong-number-of-arguments '(while 0)) + nil 'compile-only form)) (`(setq ,(and var (pred symbolp) (pred (not booleanp)) (pred (not keywordp))) ,expr) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index a9a20ab5abf..429052bfdf3 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -4,6 +4,7 @@ ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: extensions, lisp, tools +;; Version: 1.0 ;; This file is part of GNU Emacs. @@ -37,11 +38,6 @@ ;;; Code: -;; The autoloads.el mechanism which adds package--builtin-versions -;; maintenance to loaddefs.el doesn't work for preloaded packages (such -;; as this one), so we have to do it by hand! -(push (purecopy '(nadvice 1 0)) package--builtin-versions) - (oclosure-define (advice (:predicate advice--p) (:copier advice--cons (cdr)) @@ -108,19 +104,26 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") (format "%s\n%s" name doc) (format "%s" name)) (or doc "No documentation"))))) - "\n"))) + "\n" + (and + (eq how :override) + (concat + (format-message + "\nThis is an :override advice, which means that `%s' isn't\n" function) + "run at all, and the documentation below may be irrelevant.\n"))))) (defun advice--make-docstring (function) "Build the raw docstring for FUNCTION, presumably advised." (let* ((flist (indirect-function function)) (docfun nil) (macrop (eq 'macro (car-safe flist))) - (docstring nil)) + (before nil) + (after nil)) (when macrop (setq flist (cdr flist))) (if (and (autoloadp flist) (get function 'advice--pending)) - (setq docstring + (setq after (advice--make-single-doc (get function 'advice--pending) function macrop)) (while (advice--p flist) @@ -130,9 +133,13 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") ;; object instead! So here we try to undo the damage. (when (integerp (aref flist 4)) (setq docfun flist)) - (setq docstring (concat docstring (advice--make-single-doc - flist function macrop)) - flist (advice--cdr flist)))) + (let ((doc-bit (advice--make-single-doc flist function macrop))) + ;; We want :overrides to go to the front, because they mean + ;; that the doc string may be irrelevant. + (if (eq (advice--how flist) :override) + (setq before (concat before doc-bit)) + (setq after (concat after doc-bit)))) + (setq flist (advice--cdr flist)))) (unless docfun (setq docfun flist)) (let* ((origdoc (unless (eq function docfun) ;Avoid inf-loops. @@ -145,12 +152,18 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") (if (stringp arglist) t (help--make-usage-docstring function arglist))) (setq origdoc (cdr usage)) (car usage))) - (help-add-fundoc-usage (concat origdoc - (if (string-suffix-p "\n" origdoc) - "\n" - "\n\n") - docstring) - usage)))) + (help-add-fundoc-usage + (with-temp-buffer + (when before + (insert before) + (ensure-empty-lines 1)) + (when origdoc + (insert origdoc)) + (when after + (ensure-empty-lines 1) + (insert after)) + (buffer-string)) + usage)))) (defun advice-eval-interactive-spec (spec) "Evaluate the interactive spec SPEC." diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 9775e8cc656..c77ac151d77 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -557,6 +557,21 @@ This has 2 uses: (oclosure-define (save-some-buffers-function (:predicate save-some-buffers-function--p))) +;; This OClosure type is used internally by `cconv.el' to handle +;; the case where we need to build a closure whose `interactive' spec +;; captures variables from the context. +;; It arguably belongs with `cconv.el' but is needed at runtime, +;; so we placed it here. +(oclosure-define (cconv--interactive-helper) fun if) +(defun cconv--interactive-helper (fun if) + "Add interactive \"form\" IF to FUN. +Returns a new command that otherwise behaves like FUN. +IF should actually not be a form but a function of no arguments." + (oclosure-lambda (cconv--interactive-helper (fun fun) (if if)) + (&rest args) + (apply (if (called-interactively-p 'any) + #'funcall-interactively #'funcall) + fun args))) (provide 'oclosure) ;;; oclosure.el ends here diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index e0fb4b05723..b0659cd585f 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -346,21 +346,28 @@ default directory." (defcustom package-check-signature 'allow-unsigned "Non-nil means to check package signatures when installing. -More specifically the value can be: -- nil: package signatures are ignored. -- `allow-unsigned': install a package even if it is unsigned, but - if it is signed, we have the key for it, and OpenGPG is - installed, verify the signature. -- t: accept a package only if it comes with at least one verified signature. -- `all': same as t, except when the package has several signatures, - in which case we verify all the signatures. This also applies to the \"archive-contents\" file that lists the -contents of the archive." +contents of the archive. + +The value can be one of: + + t Accept a package only if it comes with at least + one verified signature. + + `all' Same as t, but verify all signatures if there + are more than one. + + `allow-unsigned' Install a package even if it is unsigned, + but verify the signature if possible (that + is, if it is signed, we have the key for it, + and GnuPG is installed). + + nil Package signatures are ignored." :type '(choice (const :value nil :tag "Never") (const :value allow-unsigned :tag "Allow unsigned") (const :value t :tag "Check always") - (const :value all :tag "Check all signatures")) + (const :value all :tag "Check always (all signatures)")) :risky t :version "27.1") @@ -2236,8 +2243,8 @@ to install it but still mark it as selected." (assq (car elt) package-archive-contents))) (and available (version-list-< - (package-desc-priority-version (cadr elt)) - (package-desc-priority-version (cadr available)))))) + (package-desc-version (cadr elt)) + (package-desc-version (cadr available)))))) package-alist))) ;;;###autoload @@ -2483,10 +2490,14 @@ If NOSAVE is non-nil, the package is not removed from "Reinstall package PKG. PKG should be either a symbol, the package name, or a `package-desc' object." - (interactive (list (intern (completing-read - "Reinstall package: " - (mapcar #'symbol-name - (mapcar #'car package-alist)))))) + (interactive + (progn + (package--archives-initialize) + (list (intern (completing-read + "Reinstall package: " + (mapcar #'symbol-name + (mapcar #'car package-alist))))))) + (package--archives-initialize) (package-delete (if (package-desc-p pkg) pkg (cadr (assq pkg package-alist))) 'force 'nosave) @@ -2698,7 +2709,7 @@ Helper function for `describe-package'." "',\n shadowing a ") (propertize "built-in package" 'font-lock-face 'package-status-built-in)) - (insert (substitute-command-keys "'"))) + (insert (substitute-quotes "'"))) (if signed (insert ".") (insert " (unsigned).")) @@ -3773,30 +3784,34 @@ objects removed." `((delete . ,del) (install . ,ins) (upgrade . ,upg)))) (defun package-menu--perform-transaction (install-list delete-list) - "Install packages in INSTALL-LIST and delete DELETE-LIST." - (if install-list - (let ((status-format (format ":Installing %%d/%d" - (length install-list))) - (i 0) - (package-menu--transaction-status)) - (dolist (pkg install-list) - (setq package-menu--transaction-status - (format status-format (cl-incf i))) - (force-mode-line-update) - (redisplay 'force) - ;; Don't mark as selected, `package-menu-execute' already - ;; does that. - (package-install pkg 'dont-select)))) - (let ((package-menu--transaction-status ":Deleting")) - (force-mode-line-update) - (redisplay 'force) - (dolist (elt (package--sort-by-dependence delete-list)) - (condition-case-unless-debug err - (let ((inhibit-message (or inhibit-message package-menu-async))) - (package-delete elt nil 'nosave)) - (error (message "Error trying to delete `%s': %S" - (package-desc-full-name elt) - err)))))) + "Install packages in INSTALL-LIST and delete DELETE-LIST. +Return nil if there were no errors; non-nil otherwise." + (let ((errors nil)) + (if install-list + (let ((status-format (format ":Installing %%d/%d" + (length install-list))) + (i 0) + (package-menu--transaction-status)) + (dolist (pkg install-list) + (setq package-menu--transaction-status + (format status-format (cl-incf i))) + (force-mode-line-update) + (redisplay 'force) + ;; Don't mark as selected, `package-menu-execute' already + ;; does that. + (package-install pkg 'dont-select)))) + (let ((package-menu--transaction-status ":Deleting")) + (force-mode-line-update) + (redisplay 'force) + (dolist (elt (package--sort-by-dependence delete-list)) + (condition-case-unless-debug err + (let ((inhibit-message (or inhibit-message package-menu-async))) + (package-delete elt nil 'nosave)) + (error + (push (package-desc-full-name elt) errors) + (message "Error trying to delete `%s': %S" + (package-desc-full-name elt) err))))) + errors)) (defun package--update-selected-packages (add remove) "Update the `package-selected-packages' list according to ADD and REMOVE. @@ -3869,8 +3884,8 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (message "Operation %s started" message-template) ;; Packages being upgraded are not marked as selected. (package--update-selected-packages .install .delete) - (package-menu--perform-transaction install-list delete-list) - (when package-selected-packages + (unless (package-menu--perform-transaction install-list delete-list) + ;; If there weren't errors, output data. (if-let* ((removable (package--removable-packages))) (message "Operation finished. Packages that are no longer needed: %d. Type `%s' to remove them" (length removable) diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index 46b429ce6fe..897c35b5b19 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -369,7 +369,8 @@ provided in the Commentary section of this library." (get-buffer-create reb-buffer) `((display-buffer-in-direction) (direction . ,dir) - (dedicated . t)))))) + (dedicated . t) + (window-height . fit-window-to-buffer)))))) (font-lock-mode 1) (reb-initialize-buffer))) @@ -497,7 +498,8 @@ Optional argument SYNTAX must be specified if called non-interactively." (setq reb-re-syntax syntax) (when buffer (with-current-buffer buffer - (reb-initialize-buffer)))) + (reb-initialize-buffer)) + (message "Switched syntax to `%s'" reb-re-syntax))) (error "Invalid syntax: %s" syntax))) @@ -737,8 +739,7 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions." (let ((face (get-text-property (1- (point)) 'face))) (when (or (and (listp face) (memq 'font-lock-string-face face)) - (eq 'font-lock-string-face face) - t) + (eq 'font-lock-string-face face)) (throw 'found t)))))))) (defface reb-regexp-grouping-backslash @@ -819,7 +820,6 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions." (defun reb-restart-font-lock () "Restart `font-lock-mode' to fit current regexp format." - (message "reb-restart-font-lock re-re-syntax=%s" reb-re-syntax) (with-current-buffer (get-buffer reb-buffer) (let ((font-lock-is-on font-lock-mode)) (font-lock-mode -1) diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index cae5dd00d1d..4d5a39458d2 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -133,7 +133,6 @@ usually more efficient than that of a simplified version: (save-match-data ;; Recurse on the sorted list. (let* ((max-lisp-eval-depth 10000) - (max-specpdl-size 10000) (completion-ignore-case nil) (completion-regexp-list nil) (open (cond ((stringp paren) paren) (paren "\\("))) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index b6f0f66e5b1..82ade0ac0c3 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -347,6 +347,20 @@ list." sequence)) ;;;###autoload +(cl-defgeneric seq-remove-at-position (sequence n) + "Return a copy of SEQUENCE where the element at N got removed. + +N is the (zero-based) index of the element that should not be in +the result. + +The result is a sequence of the same type as SEQUENCE." + (seq-concatenate + (let ((type (type-of sequence))) + (if (eq type 'cons) 'list type)) + (seq-subseq sequence 0 n) + (seq-subseq sequence (1+ n)))) + +;;;###autoload (cl-defgeneric seq-reduce (function sequence initial-value) "Reduce the function FUNCTION across SEQUENCE, starting with INITIAL-VALUE. @@ -409,7 +423,7 @@ found or not." (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." +Equality is defined by the function TESTFN, which defaults to `equal'." (declare (obsolete seq-contains-p "27.1")) (seq-some (lambda (e) (when (funcall (or testfn #'equal) elt e) @@ -418,7 +432,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." (cl-defgeneric seq-contains-p (sequence elt &optional testfn) "Return non-nil if SEQUENCE contains an element equal to ELT. -Equality is defined by TESTFN if non-nil or by `equal' if nil." +Equality is defined by the function TESTFN, which defaults to `equal'." (catch 'seq--break (seq-doseq (e sequence) (let ((r (funcall (or testfn #'equal) e elt))) @@ -429,14 +443,14 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." (cl-defgeneric seq-set-equal-p (sequence1 sequence2 &optional testfn) "Return non-nil if SEQUENCE1 and SEQUENCE2 contain the same elements. This does not depend on the order of the elements. -Equality is defined by TESTFN if non-nil or by `equal' if nil." +Equality is defined by the function TESTFN, which defaults to `equal'." (and (seq-every-p (lambda (item1) (seq-contains-p sequence2 item1 testfn)) sequence1) (seq-every-p (lambda (item2) (seq-contains-p sequence1 item2 testfn)) sequence2))) ;;;###autoload (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." + "Return the (zero-based) index of the first element in SEQUENCE equal to ELT. +Equality is defined by the function TESTFN, which defaults to `equal'." (let ((index 0)) (catch 'seq--break (seq-doseq (e sequence) @@ -446,6 +460,23 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." nil))) ;;;###autoload +(cl-defgeneric seq-positions (sequence elt &optional testfn) + "Return indices for which (TESTFN (seq-elt SEQUENCE index) ELT) is non-nil. + +TESTFN is a two-argument function which is passed each element of +SEQUENCE as first argument and ELT as second. TESTFN defaults to +`equal'. + +The result is a list of (zero-based) indices." + (let ((result '())) + (seq-do-indexed + (lambda (e index) + (when (funcall (or testfn #'equal) e elt) + (push index result))) + sequence) + (nreverse result))) + +;;;###autoload (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." @@ -502,7 +533,7 @@ negative integer or 0, nil is returned." ;;;###autoload (cl-defgeneric seq-union (sequence1 sequence2 &optional testfn) "Return a list of all elements that appear in either SEQUENCE1 or SEQUENCE2. -Equality is defined by TESTFN if non-nil or by `equal' if nil." +Equality is defined by the function TESTFN, which defaults to `equal'." (let* ((accum (lambda (acc elt) (if (seq-contains-p acc elt testfn) acc @@ -514,7 +545,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." ;;;###autoload (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." +Equality is defined by the function TESTFN, which defaults to `equal'." (seq-reduce (lambda (acc elt) (if (seq-contains-p sequence2 elt testfn) (cons elt acc) @@ -524,7 +555,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." (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." +Equality is defined by the function TESTFN, which defaults to `equal'." (seq-reduce (lambda (acc elt) (if (seq-contains-p sequence2 elt testfn) acc @@ -618,13 +649,7 @@ Signal an error if SEQUENCE is empty." (cl-defmethod seq-take ((list list) n) "Optimized implementation of `seq-take' for lists." - (if (eval-when-compile (fboundp 'take)) - (take n list) - (let ((result '())) - (while (and list (> n 0)) - (setq n (1- n)) - (push (pop list) result)) - (nreverse result)))) + (take n list)) (cl-defmethod seq-drop-while (pred (list list)) "Optimized implementation of `seq-drop-while' for lists." @@ -655,16 +680,6 @@ Signal an error if SEQUENCE is empty." sequence (concat sequence))) -(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\\>"))) - -(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. - (add-hook 'emacs-lisp-mode-hook #'seq--activate-font-lock-keywords)) - (defun seq-split (sequence length) "Split SEQUENCE into a list of sub-sequences of at most LENGTH. All the sub-sequences will be of LENGTH, except the last one, @@ -680,5 +695,9 @@ which may be shorter." result)) (nreverse result))) +(defun seq-keep (function sequence) + "Apply FUNCTION to SEQUENCE and return all non-nil results." + (delq nil (seq-map function sequence))) + (provide 'seq) ;;; seq.el ends here diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index d187af9ac83..4cfd658e10d 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -22,6 +22,15 @@ ;;; Commentary: +;; This package lists functions based on various groupings. +;; +;; For instance, `string-trim' and `mapconcat' are `string' functions, +;; so `M-x shortdoc RET string RET' will give an overview of functions +;; that operate on strings. +;; +;; The documentation groups are created with the +;; `define-short-documentation-group' macro. + ;;; Code: (require 'seq) @@ -355,13 +364,11 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), (abbreviate-file-name :no-eval (abbreviate-file-name "/home/some-user") :eg-result "~some-user") - (file-parent-directory - :eval (file-parent-directory "/foo/bar") - :eval (file-parent-directory "~") - :eval (file-parent-directory "/tmp/") - :eval (file-parent-directory "foo/bar") - :eval (file-parent-directory "foo") - :eval (file-parent-directory "/")) + (file-name-parent-directory + :eval (file-name-parent-directory "/foo/bar") + :eval (file-name-parent-directory "/foo/") + :eval (file-name-parent-directory "foo/bar") + :eval (file-name-parent-directory "foo")) "Quoted File Names" (file-name-quote :args (name) @@ -846,6 +853,10 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (seq-find #'numberp '(a b 3 4 f 6))) (seq-position :eval (seq-position '(a b c) 'c)) + (seq-positions + :eval (seq-positions '(a b c a d) 'a) + :eval (seq-positions '(a b c a d) 'z) + :eval (seq-positions '(11 5 7 12 9 15) 10 #'>=)) (seq-length :eval (seq-length "abcde")) (seq-max @@ -888,6 +899,9 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (seq-filter #'numberp '(a b 3 4 f 6))) (seq-remove :eval (seq-remove #'numberp '(1 2 c d 5))) + (seq-remove-at-position + :eval (seq-remove-at-position '(a b c d e) 3) + :eval (seq-remove-at-position [a b c d e] 0)) (seq-group-by :eval (seq-group-by #'cl-plusp '(-1 2 3 -4 -5 6))) (seq-union @@ -941,12 +955,24 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (point-min)) (point-max :eval (point-max)) + (pos-bol + :eval (pos-bol)) + (pos-eol + :eval (pos-eol)) + (bolp + :eval (bolp)) + (eolp + :eval (eolp)) (line-beginning-position :eval (line-beginning-position)) (line-end-position :eval (line-end-position)) (buffer-size :eval (buffer-size)) + (bobp + :eval (bobp)) + (eobp + :eval (eobp)) "Moving Around" (goto-char :no-eval (goto-char (point-max)) @@ -972,8 +998,13 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), (following-char :no-eval (following-char) :eg-result 67) + (preceding-char + :no-eval (preceding-char) + :eg-result 38) (char-after :eval (char-after 45)) + (char-before + :eval (char-before 13)) (get-byte :no-eval (get-byte 45) :eg-result-string "#xff") @@ -982,6 +1013,8 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :no-value (delete-region (point-min) (point-max))) (erase-buffer :no-value (erase-buffer)) + (delete-line + :no-value (delete-line)) (insert :no-value (insert "This string will be inserted in the buffer\n")) (subst-char-in-region @@ -1488,8 +1521,11 @@ Example: :doc "Keymap for `shortdoc-mode'." "n" #'shortdoc-next "p" #'shortdoc-previous + "N" #'shortdoc-next-section + "P" #'shortdoc-previous-section "C-c C-n" #'shortdoc-next-section - "C-c C-p" #'shortdoc-previous-section) + "C-c C-p" #'shortdoc-previous-section + "w" #'shortdoc-copy-function-as-kill) (define-derived-mode shortdoc-mode special-mode "shortdoc" "Mode for shortdoc." @@ -1502,35 +1538,49 @@ Example: (funcall (if reverse 'text-property-search-backward 'text-property-search-forward) - sym nil t t) + sym nil t) (setq arg (1- arg)))) (defun shortdoc-next (&optional arg) - "Move cursor to the next function. -With ARG, do it that many times." + "Move point to the next function. +With prefix numeric argument ARG, do it that many times." (interactive "p" shortdoc-mode) (shortdoc--goto-section arg 'shortdoc-function)) (defun shortdoc-previous (&optional arg) - "Move cursor to the previous function. -With ARG, do it that many times." + "Move point to the previous function. +With prefix numeric argument ARG, do it that many times." (interactive "p" shortdoc-mode) (shortdoc--goto-section arg 'shortdoc-function t) (backward-char 1)) (defun shortdoc-next-section (&optional arg) - "Move cursor to the next section. -With ARG, do it that many times." + "Move point to the next section. +With prefix numeric argument ARG, do it that many times." (interactive "p" shortdoc-mode) (shortdoc--goto-section arg 'shortdoc-section)) (defun shortdoc-previous-section (&optional arg) - "Move cursor to the previous section. -With ARG, do it that many times." + "Move point to the previous section. +With prefix numeric argument ARG, do it that many times." (interactive "p" shortdoc-mode) (shortdoc--goto-section arg 'shortdoc-section t) (forward-line -2)) +(defun shortdoc-copy-function-as-kill () + "Copy name of the function near point into the kill ring." + (interactive) + (save-excursion + (goto-char (pos-bol)) + (when-let* ((re (rx bol "(" (group (+ (not (in " ")))))) + (string + (and (or (looking-at re) + (re-search-backward re nil t)) + (match-string 1)))) + (set-text-properties 0 (length string) nil string) + (kill-new string) + (message string)))) + (provide 'shortdoc) ;;; shortdoc.el ends here diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index bd7c3c82f97..6e4d88b4df3 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -97,6 +97,7 @@ threading." (maphash (lambda (_ v) (push v values)) hash-table) values)) +;;;###autoload (defsubst string-join (strings &optional separator) "Join all STRINGS using SEPARATOR. Optional argument SEPARATOR must be a string, a vector, or a list of diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 9868d8c4ec0..c01f3fd4fec 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -465,7 +465,7 @@ changing `tabulated-list-sort-key'." (let* ((elt (car entries)) (tabulated-list--near-rows (list - (or (tabulated-list-get-entry (point-at-bol 0)) (cadr elt)) + (or (tabulated-list-get-entry (pos-bol 0)) (cadr elt)) (cadr elt) (or (cadr (cadr entries)) (cadr elt)))) (id (car elt))) @@ -519,7 +519,7 @@ of column descriptors." (insert (make-string x ?\s))) (let ((tabulated-list--near-rows ; Bind it if not bound yet (Bug#25506). (or (bound-and-true-p tabulated-list--near-rows) - (list (or (tabulated-list-get-entry (point-at-bol 0)) + (list (or (tabulated-list-get-entry (pos-bol 0)) cols) cols)))) (dotimes (n ncols) @@ -611,7 +611,7 @@ This function only changes the buffer contents; it does not alter (cols (tabulated-list-get-entry)) (inhibit-read-only t)) (when cols - (delete-region (line-beginning-position) (1+ (line-end-position))) + (delete-region (pos-bol) (1+ (pos-eol))) (list id cols)))) (defun tabulated-list-set-col (col desc &optional change-entry-data) @@ -625,8 +625,8 @@ by setting the appropriate slot of the vector originally used to print this entry. If `tabulated-list-entries' has a list value, this is the vector stored within it." (let* ((opoint (point)) - (eol (line-end-position)) - (pos (line-beginning-position)) + (eol (pos-eol)) + (pos (pos-bol)) (id (tabulated-list-get-id pos)) (entry (tabulated-list-get-entry pos)) (prop 'tabulated-list-column-name) @@ -651,9 +651,9 @@ this is the vector stored within it." (goto-char pos) (let ((tabulated-list--near-rows (list - (tabulated-list-get-entry (point-at-bol 0)) + (tabulated-list-get-entry (pos-bol 0)) entry - (or (tabulated-list-get-entry (point-at-bol 2)) entry)))) + (or (tabulated-list-get-entry (pos-bol 2)) entry)))) (tabulated-list-print-col col desc (current-column))) (if change-entry-data (aset entry col desc)) @@ -785,7 +785,7 @@ If ARG is provided, move that many columns." (let ((prev (or (previous-single-property-change (point) 'tabulated-list-column-name) 1))) - (unless (< prev (line-beginning-position)) + (unless (< prev (pos-bol)) (goto-char prev))))) ;;; The mode definition: diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index cd2e388ce42..760063d1f9d 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -637,8 +637,7 @@ argument is maybe, return maybe. Return 1value only if both arguments are 1value." (cl-case val (testcover-1value result) - (maybe (and result 'maybe)) - (nil nil))) + (maybe (and result 'maybe)))) (defun testcover-analyze-coverage-compose (forms func) "Analyze a list of FORMS for code coverage using FUNC. diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 61265c97c28..9bdf90bf1d6 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -770,7 +770,8 @@ If NEXT, do the next column." ((string-match "\\([0-9.]+\\)px" spec) (string-to-number (match-string 1 spec))) ((string-match "\\([0-9.]+\\)%" spec) - (* (string-to-number (match-string 1 spec)) (window-width nil t))) + (/ (* (string-to-number (match-string 1 spec)) (window-width nil t)) + 100)) (t (error "Invalid spec: %s" spec)))) |