diff options
Diffstat (limited to 'lisp/emacs-lisp')
55 files changed, 4466 insertions, 1762 deletions
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 756cac6d0b7..d0bf342b842 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -32,7 +32,7 @@ (require 'lisp-mode) ;for `doc-string-elt' properties. (require 'lisp-mnt) -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) (defvar generated-autoload-file nil "File into which to write autoload definitions. @@ -340,7 +340,7 @@ put the output in." (t (let ((doc-string-elt (function-get (car-safe form) 'doc-string-elt)) (outbuf autoload-print-form-outbuf)) - (if (and doc-string-elt (stringp (nth doc-string-elt form))) + (if (and (numberp doc-string-elt) (stringp (nth doc-string-elt form))) ;; We need to hack the printing because the ;; doc-string must be printed specially for ;; make-docfile (sigh). @@ -393,6 +393,8 @@ FILE's name." (concat ";;; " basename " --- automatically extracted " (or type "autoloads") " -*- lexical-binding: t -*-\n" + (when (string-match "/lisp/loaddefs\\.el\\'" file) + ";; This file will be copied to ldefs-boot.el and checked in periodically.\n") ";;\n" ";;; Code:\n\n" (if lp @@ -408,7 +410,7 @@ FILE's name." ";; version-control: never\n" ";; no-byte-compile: t\n" ;; #$ is byte-compiled into nil. ";; no-update-autoloads: t\n" - ";; coding: utf-8\n" + ";; coding: utf-8-emacs-unix\n" ";; End:\n" ";;; " basename " ends here\n"))) @@ -1194,9 +1196,17 @@ directory or directories specified." (goto-char (point-max)) (search-backward "\f" nil t) (autoload-insert-section-header - (current-buffer) nil nil no-autoloads (if autoload-timestamps - no-autoloads-time - autoload--non-timestamp)) + (current-buffer) nil nil + ;; Filter out the other loaddefs files, because it makes + ;; the list unstable (and leads to spurious changes in + ;; ldefs-boot.el) since the loaddef files can be created in + ;; any order. + (seq-filter (lambda (file) + (not (string-match-p "[/-]loaddefs.el" file))) + no-autoloads) + (if autoload-timestamps + no-autoloads-time + autoload--non-timestamp)) (insert generate-autoload-section-trailer))) ;; Don't modify the file if its content has not been changed, so `make' diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index 7b320cd9e02..3231877a30c 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -55,9 +55,9 @@ order to debug the code that does fontification." (defcustom backtrace-line-length 5000 "Target length for lines in Backtrace buffers. Backtrace mode will attempt to abbreviate printing of backtrace -frames to make them shorter than this, but success is not -guaranteed. If set to nil or zero, Backtrace mode will not -abbreviate the forms it prints." +frames by setting `print-level' and `print-length' to make them +shorter than this, but success is not guaranteed. If set to nil +or zero, backtrace mode will not abbreviate the forms it prints." :type 'integer :group 'backtrace :version "27.1") @@ -751,6 +751,13 @@ property for use by navigation." (insert (make-string (- backtrace--flags-width (- (point) beg)) ?\s)) (put-text-property beg (point) 'backtrace-section 'func))) +(defun backtrace--line-length-or-nil () + "Return `backtrace-line-length' if valid, nil else." + ;; mirror the logic in `cl-print-to-string-with-limits' + (and (natnump backtrace-line-length) + (not (zerop backtrace-line-length)) + backtrace-line-length)) + (defun backtrace--print-func-and-args (frame _view) "Print the function, arguments and buffer position of a backtrace FRAME. Format it according to VIEW." @@ -769,11 +776,16 @@ Format it according to VIEW." (if (atom fun) (funcall backtrace-print-function fun) (insert - (backtrace--print-to-string fun (when args (/ backtrace-line-length 2))))) + (backtrace--print-to-string + fun + (when (and args (backtrace--line-length-or-nil)) + (/ backtrace-line-length 2))))) (if args (insert (backtrace--print-to-string - args (max (truncate (/ backtrace-line-length 5)) - (- backtrace-line-length (- (point) beg))))) + args + (if (backtrace--line-length-or-nil) + (max (truncate (/ backtrace-line-length 5)) + (- backtrace-line-length (- (point) beg)))))) ;; The backtrace-form property is so that backtrace-multi-line ;; will find it. backtrace-multi-line doesn't do anything ;; useful with it, just being consistent. diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index c5f621c6c86..882b1d68c48 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -121,7 +121,11 @@ result. The overhead of the `lambda's is accounted for." (unless (or (natnump repetitions) (and repetitions (symbolp repetitions))) (setq forms (cons repetitions forms) repetitions 1)) - `(benchmark-call (byte-compile '(lambda () ,@forms)) ,repetitions)) + `(benchmark-call (,(if (native-comp-available-p) + 'native-compile + 'byte-compile) + '(lambda () ,@forms)) + ,repetitions)) ;;;###autoload (defun benchmark (repetitions form) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 5f83a217061..0a79bf9b797 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -34,128 +34,13 @@ ;; still not going to make it go faster than 70 mph, but it might be easier ;; to get it there. ;; - ;; TO DO: ;; -;; (apply (lambda (x &rest y) ...) 1 (foo)) -;; -;; maintain a list of functions known not to access any global variables -;; (actually, give them a 'dynamically-safe property) and then -;; (let ( v1 v2 ... vM vN ) <...dynamically-safe...> ) ==> -;; (let ( v1 v2 ... vM ) vN <...dynamically-safe...> ) -;; by recursing on this, we might be able to eliminate the entire let. -;; However certain variables should never have their bindings optimized -;; away, because they affect everything. -;; (put 'debug-on-error 'binding-is-magic t) -;; (put 'debug-on-abort 'binding-is-magic t) -;; (put 'debug-on-next-call 'binding-is-magic t) -;; (put 'inhibit-quit 'binding-is-magic t) -;; (put 'quit-flag 'binding-is-magic t) -;; (put 't 'binding-is-magic t) -;; (put 'nil 'binding-is-magic t) -;; possibly also -;; (put 'gc-cons-threshold 'binding-is-magic t) -;; (put 'track-mouse 'binding-is-magic t) -;; others? -;; -;; Simple defsubsts often produce forms like -;; (let ((v1 (f1)) (v2 (f2)) ...) -;; (FN v1 v2 ...)) -;; It would be nice if we could optimize this to -;; (FN (f1) (f2) ...) -;; but we can't unless FN is dynamically-safe (it might be dynamically -;; referring to the bindings that the lambda arglist established.) -;; One of the uncountable lossages introduced by dynamic scope... -;; -;; Maybe there should be a control-structure that says "turn on -;; fast-and-loose type-assumptive optimizations here." Then when -;; we see a form like (car foo) we can from then on assume that -;; the variable foo is of type cons, and optimize based on that. -;; But, this won't win much because of (you guessed it) dynamic -;; scope. Anything down the stack could change the value. -;; (Another reason it doesn't work is that it is perfectly valid -;; to call car with a null argument.) A better approach might -;; be to allow type-specification of the form -;; (put 'foo 'arg-types '(float (list integer) dynamic)) -;; (put 'foo 'result-type 'bool) -;; It should be possible to have these types checked to a certain -;; degree. -;; -;; collapse common subexpressions -;; -;; It would be nice if redundant sequences could be factored out as well, -;; when they are known to have no side-effects: -;; (list (+ a b c) (+ a b c)) --> a b add c add dup list-2 -;; but beware of traps like -;; (cons (list x y) (list x y)) -;; -;; Tail-recursion elimination is not really possible in Emacs Lisp. -;; Tail-recursion elimination is almost always impossible when all variables -;; have dynamic scope, but given that the "return" byteop requires the -;; binding stack to be empty (rather than emptying it itself), there can be -;; no truly tail-recursive Emacs Lisp functions that take any arguments or -;; make any bindings. -;; -;; Here is an example of an Emacs Lisp function which could safely be -;; byte-compiled tail-recursively: -;; -;; (defun tail-map (fn list) -;; (cond (list -;; (funcall fn (car list)) -;; (tail-map fn (cdr list))))) -;; -;; However, if there was even a single let-binding around the COND, -;; it could not be byte-compiled, because there would be an "unbind" -;; byte-op between the final "call" and "return." Adding a -;; Bunbind_all byteop would fix this. -;; -;; (defun foo (x y z) ... (foo a b c)) -;; ... (const foo) (varref a) (varref b) (varref c) (call 3) END: (return) -;; ... (varref a) (varbind x) (varref b) (varbind y) (varref c) (varbind z) (goto 0) END: (unbind-all) (return) -;; ... (varref a) (varset x) (varref b) (varset y) (varref c) (varset z) (goto 0) END: (return) -;; -;; this also can be considered tail recursion: -;; -;; ... (const foo) (varref a) (call 1) (goto X) ... X: (return) -;; could generalize this by doing the optimization -;; (goto X) ... X: (return) --> (return) -;; -;; But this doesn't solve all of the problems: although by doing tail- -;; recursion elimination in this way, the call-stack does not grow, the -;; binding-stack would grow with each recursive step, and would eventually -;; overflow. I don't believe there is any way around this without lexical -;; scope. -;; -;; Wouldn't it be nice if Emacs Lisp had lexical scope. -;; -;; Idea: the form (lexical-scope) in a file means that the file may be -;; compiled lexically. This proclamation is file-local. Then, within -;; that file, "let" would establish lexical bindings, and "let-dynamic" -;; would do things the old way. (Or we could use CL "declare" forms.) -;; We'd have to notice defvars and defconsts, since those variables should -;; always be dynamic, and attempting to do a lexical binding of them -;; should simply do a dynamic binding instead. -;; But! We need to know about variables that were not necessarily defvared -;; in the file being compiled (doing a boundp check isn't good enough.) -;; Fdefvar() would have to be modified to add something to the plist. -;; -;; A major disadvantage of this scheme is that the interpreter and compiler -;; would have different semantics for files compiled with (dynamic-scope). -;; Since this would be a file-local optimization, there would be no way to -;; modify the interpreter to obey this (unless the loader was hacked -;; in some grody way, but that's a really bad idea.) - -;; Other things to consider: - -;; ;; Associative math should recognize subcalls to identical function: -;; (disassemble (lambda (x) (+ (+ (foo) 1) (+ (bar) 2)))) -;; ;; This should generate the same as (1+ x) and (1- x) - -;; (disassemble (lambda (x) (cons (+ x 1) (- x 1)))) ;; ;; An awful lot of functions always return a non-nil value. If they're ;; ;; error free also they may act as true-constants. - +;; ;; (disassemble (lambda (x) (and (point) (foo)))) + ;; ;; When ;; ;; - all but one arguments to a function are constant ;; ;; - the non-constant argument is an if-expression (cond-expression?) @@ -188,10 +73,6 @@ (eval-when-compile (require 'subr-x)) (defun byte-compile-log-lap-1 (format &rest args) - ;; Newer byte codes for stack-ref make the slot 0 non-nil again. - ;; But the "old disassembler" is *really* ancient by now. - ;; (if (aref byte-code-vector 0) - ;; (error "The old version of the disassembler is loaded. Reload new-bytecomp as well")) (byte-compile-log-1 (apply #'format-message format (let (c a) @@ -264,8 +145,9 @@ Earlier variables shadow later ones with the same name.") (cdr (assq name byte-compile-function-environment))))) (pcase fn ('nil - (byte-compile-warn "attempt to inline `%s' before it was defined" - name) + (byte-compile-warn-x name + "attempt to inline `%s' before it was defined" + name) form) (`(autoload . ,_) (error "File `%s' didn't define `%s'" (nth 1 fn) name)) @@ -342,8 +224,12 @@ for speeding up processing.") (numberp expr) (stringp expr) (and (consp expr) - (memq (car expr) '(quote function)) - (symbolp (cadr expr))) + (or (and (memq (car expr) '(quote function)) + (symbolp (cadr expr))) + ;; (internal-get-closed-var N) can be considered constant for + ;; const-prop purposes. + (and (eq (car expr) 'internal-get-closed-var) + (integerp (cadr expr))))) (keywordp expr))) (defmacro byte-optimize--pcase (exp &rest cases) @@ -417,8 +303,8 @@ for speeding up processing.") (t form))) (`(quote . ,v) (if (or (not v) (cdr v)) - (byte-compile-warn "malformed quote form: `%s'" - (prin1-to-string form))) + (byte-compile-warn-x form "malformed quote form: `%s'" + form)) ;; Map (quote nil) to nil to simplify optimizer logic. ;; Map quoted constants to nil if for-effect (just because). (and (car v) @@ -436,8 +322,9 @@ for speeding up processing.") (cons (byte-optimize-form (car clause) nil) (byte-optimize-body (cdr clause) for-effect)) - (byte-compile-warn "malformed cond form: `%s'" - (prin1-to-string clause)) + (byte-compile-warn-x + clause "malformed cond form: `%s'" + clause) clause)) clauses))) (`(progn . ,exps) @@ -513,8 +400,7 @@ for speeding up processing.") `(while ,condition . ,body))) (`(interactive . ,_) - (byte-compile-warn "misplaced interactive spec: `%s'" - (prin1-to-string form)) + (byte-compile-warn-x form "misplaced interactive spec: `%s'" form) nil) (`(function . ,_) @@ -582,7 +468,7 @@ for speeding up processing.") (while args (unless (and (consp args) (symbolp (car args)) (consp (cdr args))) - (byte-compile-warn "malformed setq form: %S" form)) + (byte-compile-warn-x form "malformed setq form: %S" form)) (let* ((var (car args)) (expr (cadr args)) (lexvar (assq var byte-optimize--lexvars)) @@ -615,8 +501,7 @@ for speeding up processing.") (cons fn (mapcar #'byte-optimize-form exps))) (`(,(pred (not symbolp)) . ,_) - (byte-compile-warn "`%s' is a malformed function" - (prin1-to-string fn)) + (byte-compile-warn-x fn "`%s' is a malformed function" fn) form) ((guard (when for-effect @@ -624,8 +509,10 @@ for speeding up processing.") (or byte-compile-delete-errors (eq tmp 'error-free) (progn - (byte-compile-warn "value returned from %s is unused" - (prin1-to-string form)) + (byte-compile-warn-x + form + "value returned from %s is unused" + form) nil))))) (byte-compile-log " %s called for effect; deleted" fn) ;; appending a nil here might not be necessary, but it can't hurt. @@ -821,7 +708,8 @@ for speeding up processing.") (if (symbolp binding) binding (when (or (atom binding) (cddr binding)) - (byte-compile-warn "malformed let binding: `%S'" binding)) + (byte-compile-warn-x + binding "malformed let binding: `%S'" binding)) (list (car binding) (byte-optimize-form (nth 1 binding) nil)))) (car form)) @@ -1261,7 +1149,7 @@ See Info node `(elisp) Integer Basics'." (list 'or (car (car clauses)) (byte-optimize-cond (cons (car form) (cdr (cdr form))))) - form)) + (and clauses form))) form)) (defun byte-optimize-if (form) @@ -1304,7 +1192,7 @@ See Info node `(elisp) Integer Basics'." (defun byte-optimize-while (form) (when (< (length form) 2) - (byte-compile-warn "too few arguments for `while'")) + (byte-compile-warn-x form "too few arguments for `while'")) (if (nth 1 form) form)) @@ -1342,9 +1230,10 @@ See Info node `(elisp) Integer Basics'." (let ((butlast (nreverse (cdr (reverse (cdr (cdr form))))))) (nconc (list 'funcall fn) butlast (mapcar (lambda (x) (list 'quote x)) (nth 1 last)))) - (byte-compile-warn + (byte-compile-warn-x + last "last arg to apply can't be a literal atom: `%s'" - (prin1-to-string last)) + last) nil)) form)))) @@ -1460,6 +1349,7 @@ See Info node `(elisp) Integer Basics'." (let ((side-effect-free-fns '(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan assq + base64-decode-string base64-encode-string base64url-encode-string bool-vector-count-consecutive bool-vector-count-population bool-vector-subsetp boundp buffer-file-name buffer-local-variables buffer-modified-p @@ -1616,6 +1506,7 @@ See Info node `(elisp) Integer Basics'." assq rassq rassoc plist-get lax-plist-get plist-member aref elt + base64-decode-string base64-encode-string base64url-encode-string bool-vector-subsetp bool-vector-count-population bool-vector-count-consecutive ))) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 77e077f0442..384e8cba88f 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -30,6 +30,77 @@ ;;; Code: +(defvar byte-run--ssp-seen nil + "Which conses/vectors/records have been processed in strip-symbol-positions? +The value is a hash table, the key being the old element and the value being +the corresponding new element of the same type. + +The purpose of this is to detect circular structures.") + +(defalias 'byte-run--strip-list + #'(lambda (arg) + "Strip the positions from symbols with position in the list ARG. +This is done by destructively modifying ARG. Return ARG." + (let ((a arg)) + (while + (and + (not (gethash a byte-run--ssp-seen)) + (progn + (puthash a t byte-run--ssp-seen) + (cond + ((symbol-with-pos-p (car a)) + (setcar a (bare-symbol (car a)))) + ((consp (car a)) + (byte-run--strip-list (car a))) + ((or (vectorp (car a)) (recordp (car a))) + (byte-run--strip-vector/record (car a)))) + (consp (cdr a)))) + (setq a (cdr a))) + (cond + ((symbol-with-pos-p (cdr a)) + (setcdr a (bare-symbol (cdr a)))) + ((or (vectorp (cdr a)) (recordp (cdr a))) + (byte-run--strip-vector/record (cdr a)))) + arg))) + +(defalias 'byte-run--strip-vector/record + #'(lambda (arg) + "Strip the positions from symbols with position in the vector/record ARG. +This is done by destructively modifying ARG. Return ARG." + (unless (gethash arg byte-run--ssp-seen) + (let ((len (length arg)) + (i 0) + elt) + (puthash arg t byte-run--ssp-seen) + (while (< i len) + (setq elt (aref arg i)) + (cond + ((symbol-with-pos-p elt) + (aset arg i elt)) + ((consp elt) + (byte-run--strip-list elt)) + ((or (vectorp elt) (recordp elt)) + (byte-run--strip-vector/record elt))) + (setq i (1+ i))))) + arg)) + +(defalias 'byte-run-strip-symbol-positions + #'(lambda (arg) + "Strip all positions from symbols in ARG. +This modifies destructively then returns ARG. + +ARG is any Lisp object, but is usually a list or a vector or a +record, containing symbols with position." + (setq byte-run--ssp-seen (make-hash-table :test 'eq)) + (cond + ((symbol-with-pos-p arg) + (bare-symbol arg)) + ((consp arg) + (byte-run--strip-list arg)) + ((or (vectorp arg) (recordp arg)) + (byte-run--strip-vector/record arg)) + (t arg)))) + (defalias 'function-put ;; We don't want people to just use `put' because we can't conveniently ;; hook into `put' to remap old properties to new ones. But for now, there's @@ -38,7 +109,7 @@ "Set FUNCTION's property PROP to VALUE. The namespace for PROP is shared with symbols. So far, FUNCTION can only be a symbol, not a lambda expression." - (put function prop value))) + (put (bare-symbol function) prop value))) (function-put 'defmacro 'doc-string-elt 3) (function-put 'defmacro 'lisp-indent-function 2) @@ -134,6 +205,7 @@ The return value of this function is not used." :autoload-end (eval-and-compile (defun ,cfname (,@(car data) ,@args) + (ignore ,@(delq '&rest (delq '&optional (copy-sequence args)))) ,@(cdr data)))))))) (defalias 'byte-run--set-doc-string @@ -253,11 +325,11 @@ The return value is undefined. #'(lambda (x) (let ((f (cdr (assq (car x) macro-declarations-alist)))) (if f (apply (car f) name arglist (cdr x)) - (macroexp-warn-and-return + (macroexp-warn-and-return (format-message "Unknown macro property %S in %S" (car x) name) - nil)))) + nil nil nil (car x))))) decls))) ;; Refresh font-lock if this is a new macro, or it is an ;; existing macro whose 'no-font-lock-keyword declaration @@ -329,7 +401,7 @@ The return value is undefined. (macroexp-warn-and-return (format-message "Unknown defun property `%S' in %S" (car x) name) - nil))))) + nil nil nil (car x)))))) decls)) (def (list 'defalias (list 'quote name) @@ -380,7 +452,7 @@ You don't need this. (See bytecomp.el commentary for more details.) "Define an inline function. The syntax is just like that of `defun'. \(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)" - (declare (debug defun) (doc-string 3)) + (declare (debug defun) (doc-string 3) (indent 2)) (or (memq (get name 'byte-optimizer) '(nil byte-compile-inline-expand)) (error "`%s' is a primitive" name)) @@ -434,7 +506,7 @@ WHEN should be a string indicating when the function was first made obsolete, for example a date or a release number. See the docstrings of `defalias' and `make-obsolete' for more details." - (declare (doc-string 4)) + (declare (doc-string 4) (indent defun)) `(progn (defalias ,obsolete-name ,current-name ,docstring) (make-obsolete ,obsolete-name ,current-name ,when))) @@ -483,7 +555,7 @@ For the benefit of Customize, if OBSOLETE-NAME has any of the following properties, they are copied to CURRENT-NAME, if it does not already have them: `saved-value', `saved-variable-comment'." - (declare (doc-string 4)) + (declare (doc-string 4) (indent defun)) `(progn (defvaralias ,obsolete-name ,current-name ,docstring) ;; See Bug#4706. @@ -574,7 +646,7 @@ For the `mapcar' case, only the `mapcar' function can be used in the symbol list. For `suspicious', only `set-buffer' can be used." ;; Note: during compilation, this definition is overridden by the one in ;; byte-compile-initial-macro-environment. - (declare (debug (sexp &optional body)) (indent 1)) + (declare (debug (sexp body)) (indent 1)) (if (not (and (featurep 'macroexp) (boundp 'byte-compile--suppressed-warnings))) ;; If `macroexp' is not yet loaded, we're in the middle of diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 7629e190401..c680437f324 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -299,7 +299,7 @@ The information is logged to `byte-compile-log-buffer'." '(redefine callargs free-vars unresolved obsolete noruntime interactive-only make-local mapcar constants suspicious lexical lexical-dynamic - docstrings) + docstrings not-unused) "The list of warning types used when `byte-compile-warnings' is t.") (defcustom byte-compile-warnings t "List of warnings that the byte-compiler should issue (t for all). @@ -321,6 +321,7 @@ Elements of the list may be: lexically bound variable declared dynamic elsewhere make-local calls to `make-variable-buffer-local' that may be incorrect. mapcar mapcar called for effect. + not-unused warning about using variables with symbol names starting with _. constants let-binding of, or assignment to, constants/nonvariables. docstrings docstrings that are too wide (longer than `byte-compile-docstring-max-column' or @@ -343,6 +344,7 @@ suppress. For example, (not mapcar) will suppress warnings about mapcar." (or (symbolp v) (null (delq nil (mapcar (lambda (x) (not (symbolp x))) v)))))) +;;;###autoload (defun byte-compile-warning-enabled-p (warning &optional symbol) "Return non-nil if WARNING is enabled, according to `byte-compile-warnings'." (let ((suppress nil)) @@ -466,7 +468,8 @@ Return the compile-time value of FORM." ;; 3.2.3.1, "Processing of Top Level Forms". The semantics are very ;; subtle: see test/lisp/emacs-lisp/bytecomp-tests.el for interesting ;; cases. - (setf form (macroexp-macroexpand form byte-compile-macro-environment)) + (let ((print-symbols-bare t)) ; Possibly redundant binding. + (setf form (macroexp-macroexpand form byte-compile-macro-environment))) (if (eq (car-safe form) 'progn) (cons 'progn (mapcar (lambda (subform) @@ -497,8 +500,9 @@ Return the compile-time value of FORM." byte-compile-new-defuns)) (setf result (byte-compile-eval - (byte-compile-top-level - (byte-compile-preprocess form))))))) + (byte-run-strip-symbol-positions + (byte-compile-top-level + (byte-compile-preprocess form)))))))) (list 'quote result)))) (eval-and-compile . ,(lambda (&rest body) (byte-compile-recurse-toplevel @@ -507,10 +511,12 @@ Return the compile-time value of FORM." ;; Don't compile here, since we don't know ;; whether to compile as byte-compile-form ;; or byte-compile-file-form. - (let ((expanded - (macroexpand-all - form - macroexpand-all-environment))) + (let* ((print-symbols-bare t) ; Possibly redundant binding. + (expanded + (byte-run-strip-symbol-positions + (macroexpand--all-toplevel + form + macroexpand-all-environment)))) (eval expanded lexical-binding) expanded))))) (with-suppressed-warnings @@ -613,8 +619,8 @@ Each element is (INDEX . VALUE)") "Hash byte-code -> byte-to-native-lambda.") (defvar byte-to-native-top-level-forms nil "List of top level forms.") -(defvar byte-to-native-output-file nil - "Temporary file containing the byte-compilation output.") +(defvar byte-to-native-output-buffer-file nil + "Pair holding byte-compilation output buffer, elc filename.") (defvar byte-to-native-plist-environment nil "To spill `overriding-plist-environment'.") @@ -792,11 +798,7 @@ the unwind-action") (byte-defop 144 0 byte-temp-output-buffer-setup-OBSOLETE) (byte-defop 145 -1 byte-temp-output-buffer-show-OBSOLETE) -;; these ops are new to v19 - -;; To unbind back to the beginning of this frame. -;; Not used yet, but will be needed for tail-recursion elimination. -(byte-defop 146 0 byte-unbind-all) +;; unused: 146 ;; these ops are new to v19 (byte-defop 147 -2 byte-set-marker) @@ -1031,30 +1033,23 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (hist-nil-orig current-load-list)) (prog1 (eval form lexical-binding) (when (byte-compile-warning-enabled-p 'noruntime) - (let ((hist-new load-history) - (hist-nil-new current-load-list)) + (let* ((hist-new + ;; Get new `current-load-list' for the locally defined funs. + (cons (butlast current-load-list + (length hist-nil-orig)) + load-history))) ;; Go through load-history, look for newly loaded files ;; and mark all the functions defined therein. (while (and hist-new (not (eq hist-new hist-orig))) - (let ((xs (pop hist-new)) - old-autoloads) + (let ((xs (pop hist-new))) ;; Make sure the file was not already loaded before. (unless (assoc (car xs) hist-orig) (dolist (s xs) - (cond - ((and (consp s) (eq t (car s))) - (push (cdr s) old-autoloads)) - ((and (consp s) (memq (car s) '(autoload defun))) - (unless (memq (cdr s) old-autoloads) - (push (cdr s) byte-compile-noruntime-functions)))))))) - ;; Go through current-load-list for the locally defined funs. - (let (old-autoloads) - (while (and hist-nil-new (not (eq hist-nil-new hist-nil-orig))) - (let ((s (pop hist-nil-new))) - (when (and (symbolp s) (not (memq s old-autoloads))) - (push s byte-compile-noruntime-functions)) - (when (and (consp s) (eq t (car s))) - (push (cdr s) old-autoloads)))))))))) + (pcase s + (`(defun . ,f) + (unless (seq-some #'autoloadp + (get (cdr s) 'function-history)) + (push f byte-compile-noruntime-functions))))))))))))) (defun byte-compile-eval-before-compile (form) "Evaluate FORM for `eval-and-compile'." @@ -1145,11 +1140,6 @@ message buffer `default-directory'." (t (insert (format "%s\n" string))))))) -(defvar byte-compile-read-position nil - "Character position we began the last `read' from.") -(defvar byte-compile-last-position nil - "Last known character position in the input.") - ;; copied from gnus-util.el (defsubst byte-compile-delete-first (elt list) (if (eq (car list) elt) @@ -1162,43 +1152,6 @@ message buffer `default-directory'." (setcdr list (cddr list))) total))) -;; The purpose of `byte-compile-set-symbol-position' is to attempt to -;; set `byte-compile-last-position' to the "current position" in the -;; raw source code. This is used for warning and error messages. -;; -;; The function should be called for most occurrences of symbols in -;; the forms being compiled, strictly in the order they occur in the -;; source code. It should never be called twice for any single -;; occurrence, and should not be called for symbols generated by the -;; byte compiler itself. -;; -;; The function works by scanning the elements in the alist -;; `read-symbol-positions-list' for the next match for the symbol -;; after the current value of `byte-compile-last-position', setting -;; that variable to the match's character position, then deleting the -;; matching element from the list. Thus the new value for -;; `byte-compile-last-position' is later than the old value unless, -;; perhaps, ALLOW-PREVIOUS is non-nil. -;; -;; So your're probably asking yourself: Isn't this function a gross -;; hack? And the answer, of course, would be yes. -(defun byte-compile-set-symbol-position (sym &optional allow-previous) - (when byte-compile-read-position - (let ((last byte-compile-last-position) - entry) - (while (progn - (setq entry (assq sym read-symbol-positions-list)) - (when entry - (setq byte-compile-last-position - (+ byte-compile-read-position (cdr entry)) - read-symbol-positions-list - (byte-compile-delete-first - entry read-symbol-positions-list))) - (and entry - (or (and allow-previous - (not (= last byte-compile-last-position))) - (> last byte-compile-last-position)))))))) - (defvar byte-compile-last-warned-form nil) (defvar byte-compile-last-logged-file nil) (defvar byte-compile-root-dir nil @@ -1211,6 +1164,41 @@ message buffer `default-directory'." (f2 (file-relative-name file dir))) (if (< (length f2) (length f1)) f2 f1))) +(defun byte-compile--first-symbol (form) + "Return the \"first\" symbol found in form, or 0 if there is none. +Here, \"first\" is by a depth first search." + (let (sym) + (cond + ((symbolp form) form) + ((consp form) + (or (and (symbolp (setq sym (byte-compile--first-symbol (car form)))) + sym) + (and (symbolp (setq sym (byte-compile--first-symbol (cdr form)))) + sym) + 0)) + ((and (vectorp form) + (> (length form) 0)) + (let ((i 0) + (len (length form)) + elt) + (catch 'sym + (while (< i len) + (when (symbolp + (setq elt (byte-compile--first-symbol (aref form i)))) + (throw 'sym elt)) + (setq i (1+ i))) + 0))) + (t 0)))) + +(defun byte-compile--warning-source-offset () + "Return a source offset from `byte-compile-form-stack'. +Return nil if such is not found." + (catch 'offset + (dolist (form byte-compile-form-stack) + (let ((s (byte-compile--first-symbol form))) + (if (symbol-with-pos-p s) + (throw 'offset (symbol-with-pos-pos s))))))) + ;; This is used as warning-prefix for the compiler. ;; It is always called with the warnings buffer current. (defun byte-compile-warning-prefix (level entry) @@ -1228,16 +1216,16 @@ message buffer `default-directory'." (format "%s:" (byte-compile-abbreviate-file load-file-name dir))) (t ""))) + (offset (byte-compile--warning-source-offset)) (pos (if (and byte-compile-current-file - (integerp byte-compile-read-position)) + (or offset (not symbols-with-pos-enabled))) (with-current-buffer byte-compile-current-buffer - (format "%d:%d:" - (save-excursion - (goto-char byte-compile-last-position) - (1+ (count-lines (point-min) (point-at-bol)))) - (save-excursion - (goto-char byte-compile-last-position) - (1+ (current-column))))) + (let (new-l new-c) + (save-excursion + (goto-char offset) + (setq new-l (1+ (count-lines (point-min) (point-at-bol))) + new-c (1+ (current-column))) + (format "%d:%d:" new-l new-c)))) "")) (form (if (eq byte-compile-current-form :end) "end of data" (or byte-compile-current-form "toplevel form")))) @@ -1312,20 +1300,21 @@ Called with arguments (STRING POSITION FILL LEVEL). STRING is a message describing the problem. POSITION is a buffer position where the problem was detected. FILL is a prefix as in `warning-fill-prefix'. LEVEL is the level of the -problem (`:warning' or `:error'). POSITION, FILL and LEVEL may be -nil.") +problem (`:warning' or `:error'). FILL and LEVEL may be nil.") (defun byte-compile-log-warning (string &optional fill level) "Log a byte-compilation warning. STRING, FILL and LEVEL are as described in `byte-compile-log-warning-function', which see." (funcall byte-compile-log-warning-function - string byte-compile-last-position + string + (or (byte-compile--warning-source-offset) + (point)) fill level)) -(defun byte-compile--log-warning-for-byte-compile (string &optional - _position +(defun byte-compile--log-warning-for-byte-compile (string _position + &optional fill level) "Log a message STRING in `byte-compile-log-buffer'. @@ -1346,6 +1335,14 @@ function directly; use `byte-compile-warn' or (error "%s" format) ; byte-compile-file catches and logs it (byte-compile-log-warning format t :warning))) +(defun byte-compile-warn-x (arg format &rest args) + "Issue a byte compiler warning. +ARG is the source element (likely a symbol with position) central to + the warning, intended to supply source position information. +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." (when (byte-compile-warning-enabled-p 'obsolete symbol) @@ -1355,7 +1352,7 @@ function directly; use `byte-compile-warn' or (or funcp (get symbol 'byte-obsolete-variable)) (if funcp "function" "variable")))) (unless (and funcp (memq symbol byte-compile-not-obsolete-funcs)) - (byte-compile-warn "%s" msg))))) + (byte-compile-warn-x symbol "%s" msg))))) (defun byte-compile-report-error (error-info &optional fill) "Report Lisp error in compilation. @@ -1458,7 +1455,6 @@ when printing the error message." (t (format "%d-%d" (car signature) (cdr signature))))) (defun byte-compile-function-warn (f nargs def) - (byte-compile-set-symbol-position f) (when (and (get f 'byte-obsolete-info) (byte-compile-warning-enabled-p 'obsolete f)) (byte-compile-warn-obsolete f)) @@ -1475,12 +1471,16 @@ when printing the error message." (if cons (or (memq nargs (cddr cons)) (push nargs (cddr cons))) - (push (list f byte-compile-last-position nargs) + (push (list f + (if (symbol-with-pos-p f) + (symbol-with-pos-pos f) + 1) ; Should never happen. + nargs) byte-compile-unresolved-functions))))) (defun byte-compile-emit-callargs-warn (name actual-args min-args max-args) - (byte-compile-set-symbol-position name) - (byte-compile-warn + (byte-compile-warn-x + name "%s called with %d argument%s, but %s %s" name actual-args (if (= 1 actual-args) "" "s") @@ -1546,7 +1546,7 @@ extra args." n))) (nargs (- (length form) 2))) (unless (= nargs nfields) - (byte-compile-warn + (byte-compile-warn-x (car form) "`%s' called with %d args to fill %d format field(s)" (car form) nargs nfields))))) @@ -1560,7 +1560,7 @@ extra args." (when (eq (car-safe name) 'quote) (or (not (eq (car form) 'custom-declare-variable)) (plist-get keyword-args :type) - (byte-compile-warn + (byte-compile-warn-x (cadr name) "defcustom for `%s' fails to specify type" (cadr name))) (if (and (memq (car form) '(custom-declare-face custom-declare-variable)) byte-compile-current-group) @@ -1569,7 +1569,7 @@ extra args." (or (and (eq (car form) 'custom-declare-group) (equal name ''emacs)) (plist-get keyword-args :group) - (byte-compile-warn + (byte-compile-warn-x (cadr name) "%s for `%s' fails to specify containing group" (cdr (assq (car form) '((custom-declare-group . defgroup) @@ -1585,32 +1585,31 @@ extra args." ;; number of arguments. (defun byte-compile-arglist-warn (name arglist macrop) ;; This is the first definition. See if previous calls are compatible. - (let ((calls (assq name byte-compile-unresolved-functions)) - nums sig min max) - (when (and calls macrop) - (byte-compile-warn "macro `%s' defined too late" name)) - (setq byte-compile-unresolved-functions - (delq calls byte-compile-unresolved-functions)) - (setq calls (delq t calls)) ;Ignore higher-order uses of the function. - (when (cddr calls) - (when (and (symbolp name) - (eq (function-get name 'byte-optimizer) - 'byte-compile-inline-expand)) - (byte-compile-warn "defsubst `%s' was used before it was defined" - name)) - (setq sig (byte-compile-arglist-signature arglist) - nums (sort (copy-sequence (cddr calls)) (function <)) - min (car nums) - max (car (nreverse nums))) - (when (or (< min (car sig)) - (and (cdr sig) (> max (cdr sig)))) - (byte-compile-set-symbol-position name) - (byte-compile-warn - "%s being defined to take %s%s, but was previously called with %s" - name - (byte-compile-arglist-signature-string sig) - (if (equal sig '(1 . 1)) " arg" " args") - (byte-compile-arglist-signature-string (cons min max)))))) + (let ((calls (assq name byte-compile-unresolved-functions))) + (when calls + (when macrop + (byte-compile-warn-x name "macro `%s' defined too late" name)) + (setq byte-compile-unresolved-functions + (delq calls byte-compile-unresolved-functions)) + (let ((nums (delq t (cddr calls)))) ; Ignore higher-order uses. + (when nums + (when (and (symbolp name) + (eq (function-get name 'byte-optimizer) + 'byte-compile-inline-expand)) + (byte-compile-warn-x + name "defsubst `%s' was used before it was defined" name)) + (let ((sig (byte-compile-arglist-signature arglist)) + (min (apply #'min nums)) + (max (apply #'max nums))) + (when (or (< min (car sig)) + (and (cdr sig) (> max (cdr sig)))) + (byte-compile-warn-x + name + "%s being defined to take %s%s, but was previously called with %s" + name + (byte-compile-arglist-signature-string sig) + (if (equal sig '(1 . 1)) " arg" " args") + (byte-compile-arglist-signature-string (cons min max))))))))) (let* ((old (byte-compile-fdefinition name macrop)) (initial (and macrop (cdr (assq name @@ -1623,8 +1622,8 @@ extra args." (let ((sig1 (byte-compile--function-signature old)) (sig2 (byte-compile-arglist-signature arglist))) (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) - (byte-compile-set-symbol-position name) - (byte-compile-warn + (byte-compile-warn-x + name "%s %s used to take %s %s, now takes %s" (if macrop "macro" "function") name @@ -1671,9 +1670,14 @@ URLs." ;; known at compile time. So instead, we assume that these ;; substitutions are of some length N. (replace-regexp-in-string - (rx "\\" (or (seq "[" (* (not "]")) "]"))) + (rx "\\[" (* (not "]")) "]") (make-string byte-compile--wide-docstring-substitution-len ?x) - docstring)))) + ;; For literal key sequence substitutions (e.g. "\\`C-h'"), just + ;; remove the markup as `substitute-command-keys' would. + (replace-regexp-in-string + (rx "\\`" (group (* (not "'"))) "'") + "\\1" + docstring))))) (defcustom byte-compile-docstring-max-column 80 "Recommended maximum width of doc string lines. @@ -1705,11 +1709,13 @@ It is too wide if it has any lines longer than the largest of (nth 2 form))))) (when (and (consp name) (eq (car name) 'quote)) (setq name (cadr name))) - (setq name (if name (format " `%s'" name) "")) + (setq name (if name (format " `%s' " name) "")) (when (and kind docs (stringp docs) (byte-compile--wide-docstring-p docs col)) - (byte-compile-warn "%s%s docstring wider than %s characters" - kind name col)))) + (byte-compile-warn-x + name + "%s%sdocstring wider than %s characters" + kind name col)))) form) ;; If we have compiled any calls to functions which are not known to be @@ -1723,10 +1729,10 @@ It is too wide if it has any lines longer than the largest of (dolist (urf byte-compile-unresolved-functions) (let ((f (car urf))) (when (not (memq f byte-compile-new-defuns)) - (let ((byte-compile-last-position (cadr urf))) - (byte-compile-warn - (if (fboundp f) "the function `%s' might not be defined at runtime." "the function `%s' is not known to be defined.") - (car urf)))))))) + (byte-compile-warn-x + f + (if (fboundp f) "the function `%s' might not be defined at runtime." "the function `%s' is not known to be defined.") + (car urf))))))) nil) @@ -1782,7 +1788,8 @@ It is too wide if it has any lines longer than the largest of (warning-series-started (and (markerp warning-series) (eq (marker-buffer warning-series) - (get-buffer byte-compile-log-buffer))))) + (get-buffer byte-compile-log-buffer)))) + (byte-compile-form-stack byte-compile-form-stack)) (if (or (eq warning-series 'byte-compile-warning-series) warning-series-started) ;; warning-series does come from compilation, @@ -1969,6 +1976,42 @@ If compilation is needed, this functions returns the result of (defvar byte-compile-level 0 ; bug#13787 "Depth of a recursive byte compilation.") +(defun byte-write-target-file (buffer target-file) + "Write BUFFER into TARGET-FILE." + (with-current-buffer buffer + ;; We must disable any code conversion here. + (let* ((coding-system-for-write 'no-conversion) + ;; Write to a tempfile so that if another Emacs + ;; process is trying to load target-file (eg in a + ;; parallel bootstrap), it does not risk getting a + ;; half-finished file. (Bug#4196) + (tempfile + (make-temp-file (when (file-writable-p target-file) + (expand-file-name target-file)))) + (default-modes (default-file-modes)) + (temp-modes (logand default-modes #o600)) + (desired-modes (logand default-modes #o666)) + (kill-emacs-hook + (cons (lambda () (ignore-errors + (delete-file tempfile))) + kill-emacs-hook))) + (unless (= temp-modes desired-modes) + (set-file-modes tempfile desired-modes 'nofollow)) + (write-region (point-min) (point-max) tempfile nil 1) + ;; This has the intentional side effect that any + ;; hard-links to target-file continue to + ;; point to the old file (this makes it possible + ;; for installed files to share disk space with + ;; the build tree, without causing problems when + ;; emacs-lisp files in the build tree are + ;; recompiled). Previously this was accomplished by + ;; deleting target-file before writing it. + (if byte-native-compiling + ;; Defer elc final renaming. + (setf byte-to-native-output-buffer-file + (cons tempfile target-file)) + (rename-file tempfile target-file t))))) + ;;;###autoload (defun byte-compile-file (filename &optional load) "Compile a file of Lisp code named FILENAME into a file of byte code. @@ -2100,38 +2143,11 @@ See also `emacs-lisp-byte-compile-and-load'." ;; Need to expand in case TARGET-FILE doesn't ;; include a directory (Bug#45287). (expand-file-name target-file)))) - ;; We must disable any code conversion here. - (let* ((coding-system-for-write 'no-conversion) - ;; Write to a tempfile so that if another Emacs - ;; process is trying to load target-file (eg in a - ;; parallel bootstrap), it does not risk getting a - ;; half-finished file. (Bug#4196) - (tempfile - (make-temp-file (when (file-writable-p target-file) - (expand-file-name target-file)))) - (default-modes (default-file-modes)) - (temp-modes (logand default-modes #o600)) - (desired-modes (logand default-modes #o666)) - (kill-emacs-hook - (cons (lambda () (ignore-errors - (delete-file tempfile))) - kill-emacs-hook))) - (unless (= temp-modes desired-modes) - (set-file-modes tempfile desired-modes 'nofollow)) - (write-region (point-min) (point-max) tempfile nil 1) - ;; This has the intentional side effect that any - ;; hard-links to target-file continue to - ;; point to the old file (this makes it possible - ;; for installed files to share disk space with - ;; the build tree, without causing problems when - ;; emacs-lisp files in the build tree are - ;; recompiled). Previously this was accomplished by - ;; deleting target-file before writing it. - (if byte-native-compiling - ;; Defer elc final renaming. - (setf byte-to-native-output-file - (cons tempfile target-file)) - (rename-file tempfile target-file t))) + (if byte-native-compiling + ;; Defer elc production. + (setf byte-to-native-output-buffer-file + (cons (current-buffer) target-file)) + (byte-write-target-file (current-buffer) target-file)) (or noninteractive byte-native-compiling (message "Wrote %s" target-file))) @@ -2152,7 +2168,8 @@ See also `emacs-lisp-byte-compile-and-load'." "Cannot overwrite file" "Directory not writable or nonexistent") target-file)))))) - (kill-buffer (current-buffer))) + (unless byte-native-compiling + (kill-buffer (current-buffer)))) (if (and byte-compile-generate-call-tree (or (eq t byte-compile-generate-call-tree) (y-or-n-p (format "Report call tree for %s? " @@ -2182,19 +2199,20 @@ With argument ARG, insert value in current buffer after the form." (save-excursion (end-of-defun) (beginning-of-defun) - (let* ((byte-compile-current-file (current-buffer)) + (let* ((print-symbols-bare t) ; For the final `message'. + (byte-compile-current-file (current-buffer)) (byte-compile-current-buffer (current-buffer)) - (byte-compile-read-position (point)) - (byte-compile-last-position byte-compile-read-position) + (start-read-position (point)) (byte-compile-last-warned-form 'nothing) + (symbols-with-pos-enabled t) (value (eval - (let ((read-with-symbol-positions (current-buffer)) - (read-symbol-positions-list nil)) - (displaying-byte-compile-warnings - (byte-compile-sexp + (displaying-byte-compile-warnings + (byte-compile-sexp + (let ((form (read-positioning-symbols (current-buffer)))) + (push form byte-compile-form-stack) (eval-sexp-add-defvars - (read (current-buffer)) - byte-compile-read-position)))) + form + start-read-position)))) lexical-binding))) (cond (arg (message "Compiling from buffer... done.") @@ -2204,13 +2222,12 @@ With argument ARG, insert value in current buffer after the form." (defun byte-compile-from-buffer (inbuffer) (let ((byte-compile-current-buffer inbuffer) - (byte-compile-read-position nil) - (byte-compile-last-position nil) ;; Prevent truncation of flonums and lists as we read and print them (float-output-format nil) (case-fold-search nil) (print-length nil) (print-level nil) + (print-symbols-bare t) ;; Prevent edebug from interfering when we compile ;; and put the output into a file. ;; (edebug-all-defs nil) @@ -2223,13 +2240,9 @@ With argument ARG, insert value in current buffer after the form." (byte-compile-depth 0) (byte-compile-maxdepth 0) (byte-compile-output nil) - ;; This allows us to get the positions of symbols read; it's - ;; new in Emacs 22.1. - (read-with-symbol-positions inbuffer) - (read-symbol-positions-list nil) ;; #### This is bound in b-c-close-variables. ;; (byte-compile-warnings byte-compile-warnings) - ) + (symbols-with-pos-enabled t)) (byte-compile-close-variables (with-current-buffer (setq byte-compile--outbuffer @@ -2275,18 +2288,17 @@ With argument ARG, insert value in current buffer after the form." (= (following-char) ?\;)) (forward-line 1)) (not (eobp))) - (setq byte-compile-read-position (point) - byte-compile-last-position byte-compile-read-position) (let* ((lread--unescaped-character-literals nil) - (form (read inbuffer)) + ;; Don't bind `load-read-function' to + ;; `read-positioning-symbols' here. Calls to `read' + ;; at a lower level must not get symbols with + ;; position. + (form (read-positioning-symbols inbuffer)) (warning (byte-run--unescaped-character-literals-warning))) - (when warning (byte-compile-warn "%s" warning)) + (when warning (byte-compile-warn-x form "%s" warning)) (byte-compile-toplevel-file-form form))) ;; Compile pending forms at end of file. (byte-compile-flush-pending) - ;; Make warnings about unresolved functions - ;; give the end of the file as their position. - (setq byte-compile-last-position (point-max)) (byte-compile-warn-about-unresolved-functions))) byte-compile--outbuffer))) @@ -2344,7 +2356,8 @@ Call from the source buffer." ;; Spill output for the native compiler here (push (make-byte-to-native-top-level :form form :lexical lexical-binding) byte-to-native-top-level-forms)) - (let ((print-escape-newlines t) + (let ((print-symbols-bare t) ; Possibly redundant binding. + (print-escape-newlines t) (print-length nil) (print-level nil) (print-quoted t) @@ -2379,8 +2392,8 @@ list that represents a doc string reference. ;; in the input buffer (now current), not in the output buffer. (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) (with-current-buffer byte-compile--outbuffer - (let (position) - + (let (position + (print-symbols-bare t)) ; Possibly redundant binding. ;; Insert the doc string, and make it a comment with #@LENGTH. (and (>= (nth 1 info) 0) dynamic-docstrings @@ -2490,7 +2503,8 @@ list that represents a doc string reference. byte-compile-jump-tables nil)))) (defun byte-compile-preprocess (form &optional _for-effect) - (setq form (macroexpand-all form byte-compile-macro-environment)) + (let ((print-symbols-bare t)) ; Possibly redundant binding. + (setq form (macroexpand-all form byte-compile-macro-environment))) ;; FIXME: We should run byte-optimize-form here, but it currently does not ;; recurse through all the code, so we'd have to fix this first. ;; Maybe a good fix would be to merge byte-optimize-form into @@ -2503,11 +2517,16 @@ list that represents a doc string reference. ;; byte-hunk-handlers cannot call this! (defun byte-compile-toplevel-file-form (top-level-form) - (byte-compile-recurse-toplevel - top-level-form - (lambda (form) - (let ((byte-compile-current-form nil)) ; close over this for warnings. - (byte-compile-file-form (byte-compile-preprocess form t)))))) + ;; (let ((byte-compile-form-stack + ;; (cons top-level-form byte-compile-form-stack))) + (push top-level-form byte-compile-form-stack) + (prog1 + (byte-compile-recurse-toplevel + top-level-form + (lambda (form) + (let ((byte-compile-current-form nil)) ; close over this for warnings. + (byte-compile-file-form (byte-compile-preprocess form t))))) + (pop byte-compile-form-stack))) ;; byte-hunk-handlers can call this. (defun byte-compile-file-form (form) @@ -2556,7 +2575,8 @@ list that represents a doc string reference. (delq (assq funsym byte-compile-unresolved-functions) byte-compile-unresolved-functions))))) (if (stringp (nth 3 form)) - (prog1 form + (prog1 + form (byte-compile-docstring-length-warn form)) ;; No doc string, so we can compile this as a normal form. (byte-compile-keep-pending form 'byte-compile-normal-call))) @@ -2568,7 +2588,8 @@ list that represents a doc string reference. (when (and (symbolp sym) (not (string-match "[-*/:$]" (symbol-name sym))) (byte-compile-warning-enabled-p 'lexical sym)) - (byte-compile-warn "global/dynamic var `%s' lacks a prefix" sym))) + (byte-compile-warn-x + sym "global/dynamic var `%s' lacks a prefix" sym))) (defun byte-compile--declare-var (sym) (byte-compile--check-prefixed-var sym) @@ -2576,7 +2597,7 @@ list that represents a doc string reference. (setq byte-compile-lexical-variables (delq sym byte-compile-lexical-variables)) (when (byte-compile-warning-enabled-p 'lexical sym) - (byte-compile-warn "Variable `%S' declared after its first use" sym))) + (byte-compile-warn-x sym "Variable `%S' declared after its first use" sym))) (push sym byte-compile-bound-variables) (push sym byte-compile--seen-defvars)) @@ -2589,10 +2610,10 @@ list that represents a doc string reference. (eq (car form) 'defvar)) ;Just a declaration. nil (byte-compile-docstring-length-warn form) - (cond ((consp (nth 2 form)) - (setq form (copy-sequence form)) - (setcar (cdr (cdr form)) - (byte-compile-top-level (nth 2 form) nil 'file)))) + (setq form (copy-sequence form)) + (when (consp (nth 2 form)) + (setcar (cdr (cdr form)) + (byte-compile-top-level (nth 2 form) nil 'file))) form)) (put 'define-abbrev-table 'byte-hunk-handler @@ -2610,7 +2631,8 @@ list that represents a doc string reference. (`(defvaralias ,_ ',newname . ,_) (when (memq newname byte-compile-bound-variables) (if (byte-compile-warning-enabled-p 'suspicious) - (byte-compile-warn + (byte-compile-warn-x + newname "Alias for `%S' should be declared before its referent" newname))))) (byte-compile-docstring-length-warn form) (byte-compile-keep-pending form)) @@ -2624,8 +2646,11 @@ list that represents a doc string reference. (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) (defun byte-compile-file-form-require (form) - (let ((args (mapcar 'eval (cdr form))) - hist-new prov-cons) + (let* ((args (mapcar 'eval (cdr form))) + ;; The following is for the byte-compile-warn in + ;; `do-after-load-evaluation' (in subr.el). + (byte-compile-form-stack (cons (car args) byte-compile-form-stack)) + hist-new prov-cons) (apply 'require args) ;; Record the functions defined by the require in `byte-compile-new-defuns'. @@ -2669,16 +2694,8 @@ list that represents a doc string reference. (put 'make-obsolete 'byte-hunk-handler 'byte-compile-file-form-make-obsolete) (defun byte-compile-file-form-make-obsolete (form) (prog1 (byte-compile-keep-pending form) - (apply 'make-obsolete (mapcar 'eval (cdr form))))) - -;; This handler is not necessary, but it makes the output from dont-compile -;; and similar macros cleaner. -(put 'eval 'byte-hunk-handler 'byte-compile-file-form-eval) -(defun byte-compile-file-form-eval (form) - (if (and (eq (car-safe (nth 1 form)) 'quote) - (equal (nth 2 form) lexical-binding)) - (nth 1 (nth 1 form)) - (byte-compile-keep-pending form))) + (apply 'make-obsolete + (mapcar 'eval (cdr form))))) (defun byte-compile-file-form-defmumble (name macro arglist body rest) "Process a `defalias' for NAME. @@ -2693,23 +2710,23 @@ not to take responsibility for the actual compilation of the code." 'byte-compile-macro-environment)) (this-one (assq name (symbol-value this-kind))) (that-one (assq name (symbol-value that-kind))) + (bare-name (bare-symbol name)) (byte-compile-current-form name)) ; For warnings. - (byte-compile-set-symbol-position name) - (push name byte-compile-new-defuns) + (push bare-name byte-compile-new-defuns) ;; When a function or macro is defined, add it to the call tree so that ;; we can tell when functions are not used. (if byte-compile-generate-call-tree - (or (assq name byte-compile-call-tree) + (or (assq bare-name byte-compile-call-tree) (setq byte-compile-call-tree - (cons (list name nil nil) byte-compile-call-tree)))) + (cons (list bare-name nil nil) byte-compile-call-tree)))) (if (byte-compile-warning-enabled-p 'redefine name) (byte-compile-arglist-warn name arglist macro)) (if byte-compile-verbose (message "Compiling %s... (%s)" - (or byte-compile-current-file "") name)) + (or byte-compile-current-file "") bare-name)) (cond ((not (or macro (listp body))) ;; We do not know positively if the definition is a macro ;; or a function, so we shouldn't emit warnings. @@ -2718,29 +2735,34 @@ not to take responsibility for the actual compilation of the code." (that-one (if (and (byte-compile-warning-enabled-p 'redefine name) ;; Don't warn when compiling the stubs in byte-run... - (not (assq name byte-compile-initial-macro-environment))) - (byte-compile-warn + (not (assq bare-name byte-compile-initial-macro-environment))) + (byte-compile-warn-x + name "`%s' defined multiple times, as both function and macro" - name)) + bare-name)) (setcdr that-one nil)) (this-one (when (and (byte-compile-warning-enabled-p 'redefine name) ;; Hack: Don't warn when compiling the magic internal ;; byte-compiler macros in byte-run.el... - (not (assq name byte-compile-initial-macro-environment))) - (byte-compile-warn "%s `%s' defined multiple times in this file" - (if macro "macro" "function") - name))) - ((eq (car-safe (symbol-function name)) + (not (assq bare-name byte-compile-initial-macro-environment))) + (byte-compile-warn-x + name + "%s `%s' defined multiple times in this file" + (if macro "macro" "function") + bare-name))) + ((eq (car-safe (symbol-function bare-name)) (if macro 'lambda 'macro)) - (when (byte-compile-warning-enabled-p 'redefine name) - (byte-compile-warn "%s `%s' being redefined as a %s" - (if macro "function" "macro") - name - (if macro "macro" "function"))) + (when (byte-compile-warning-enabled-p 'redefine bare-name) + (byte-compile-warn-x + name + "%s `%s' being redefined as a %s" + (if macro "function" "macro") + bare-name + (if macro "macro" "function"))) ;; Shadow existing definition. (set this-kind - (cons (cons name nil) + (cons (cons bare-name nil) (symbol-value this-kind)))) ) @@ -2749,10 +2771,8 @@ not to take responsibility for the actual compilation of the code." (symbolp (car-safe (cdr-safe body))) (car-safe (cdr-safe body)) (stringp (car-safe (cdr-safe (cdr-safe body))))) - ;; FIXME: We've done that already just above, so this looks wrong! - ;;(byte-compile-set-symbol-position name) - (byte-compile-warn "probable `\"' without `\\' in doc string of %s" - name)) + (byte-compile-warn-x + name "probable `\"' without `\\' in doc string of %s" bare-name)) (if (not (listp body)) ;; The precise definition requires evaluation to find out, so it @@ -2760,7 +2780,7 @@ not to take responsibility for the actual compilation of the code." ;; For a macro, that means we can't use that macro in the same file. (progn (unless macro - (push (cons name (if (listp arglist) `(declared ,arglist) t)) + (push (cons bare-name (if (listp arglist) `(declared ,arglist) t)) byte-compile-function-environment)) ;; Tell the caller that we didn't compile it yet. nil) @@ -2770,10 +2790,10 @@ not to take responsibility for the actual compilation of the code." ;; A definition in b-c-initial-m-e should always take precedence ;; during compilation, so don't let it be redefined. (Bug#8647) (or (and macro - (assq name byte-compile-initial-macro-environment)) + (assq bare-name byte-compile-initial-macro-environment)) (setcdr this-one code)) (set this-kind - (cons (cons name code) + (cons (cons bare-name code) (symbol-value this-kind)))) (if rest @@ -2789,18 +2809,19 @@ not to take responsibility for the actual compilation of the code." (if (not (stringp (documentation code t))) -1 4))) (when byte-native-compiling ;; Spill output for the native compiler here. - (push (if macro - (make-byte-to-native-top-level - :form `(defalias ',name '(macro . ,code) nil) - :lexical lexical-binding) - (make-byte-to-native-func-def :name name - :byte-func code)) - byte-to-native-top-level-forms)) + (push + (if macro + (make-byte-to-native-top-level + :form `(defalias ',name '(macro . ,code) nil) + :lexical lexical-binding) + (make-byte-to-native-func-def :name name + :byte-func code)) + byte-to-native-top-level-forms)) ;; Output the form by hand, that's much simpler than having ;; b-c-output-file-form analyze the defalias. (byte-compile-output-docform "\n(defalias '" - name + bare-name (if macro `(" '(macro . #[" ,index "])") `(" #[" ,index "]")) (append code nil) ; Turn byte-code-function-p into list. (and (atom code) byte-compile-dynamic @@ -2883,37 +2904,38 @@ If FORM is a lambda or a macro, byte-compile it as a function." (macro (eq (car-safe fun) 'macro))) (if macro (setq fun (cdr fun))) - (cond - ;; Up until Emacs-24.1, byte-compile silently did nothing when asked to - ;; compile something invalid. So let's tune down the complaint from an - ;; error to a simple message for the known case where signaling an error - ;; causes problems. - ((byte-code-function-p fun) - (message "Function %s is already compiled" - (if (symbolp form) form "provided")) - fun) - (t - (let (final-eval) - (when (or (symbolp form) (eq (car-safe fun) 'closure)) - ;; `fun' is a function *value*, so try to recover its corresponding - ;; source code. - (setq lexical-binding (eq (car fun) 'closure)) - (setq fun (byte-compile--reify-function fun)) - (setq final-eval t)) - ;; Expand macros. - (setq fun (byte-compile-preprocess fun)) - (setq fun (byte-compile-top-level fun nil 'eval)) - (if (symbolp form) - ;; byte-compile-top-level returns an *expression* equivalent to the - ;; `fun' expression, so we need to evaluate it, tho normally - ;; this is not needed because the expression is just a constant - ;; byte-code object, which is self-evaluating. - (setq fun (eval fun t))) - (if final-eval - (setq fun (eval fun t))) - (if macro (push 'macro fun)) - (if (symbolp form) (fset form fun)) - fun))))))) + (prog1 + (cond + ;; Up until Emacs-24.1, byte-compile silently did nothing when asked to + ;; compile something invalid. So let's tune down the complaint from an + ;; error to a simple message for the known case where signaling an error + ;; causes problems. + ((byte-code-function-p fun) + (message "Function %s is already compiled" + (if (symbolp form) form "provided")) + fun) + (t + (let (final-eval) + (when (or (symbolp form) (eq (car-safe fun) 'closure)) + ;; `fun' is a function *value*, so try to recover its corresponding + ;; source code. + (setq lexical-binding (eq (car fun) 'closure)) + (setq fun (byte-compile--reify-function fun)) + (setq final-eval t)) + ;; Expand macros. + (setq fun (byte-compile-preprocess fun)) + (setq fun (byte-compile-top-level fun nil 'eval)) + (if (symbolp form) + ;; byte-compile-top-level returns an *expression* equivalent to the + ;; `fun' expression, so we need to evaluate it, tho normally + ;; this is not needed because the expression is just a constant + ;; byte-code object, which is self-evaluating. + (setq fun (eval fun t))) + (if final-eval + (setq fun (eval fun t))) + (if macro (push 'macro fun)) + (if (symbolp form) (fset form fun)) + fun)))))))) (defun byte-compile-sexp (sexp) "Compile and return SEXP." @@ -2926,8 +2948,6 @@ If FORM is a lambda or a macro, byte-compile it as a function." (let (vars) (while list (let ((arg (car list))) - (when (symbolp arg) - (byte-compile-set-symbol-position arg)) (cond ((or (not (symbolp arg)) (macroexp--const-symbol-p arg t)) (error "Invalid lambda variable %s" arg)) @@ -2944,7 +2964,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." ((and (memq arg vars) ;; Allow repetitions for unused args. (not (string-match "\\`_" (symbol-name arg)))) - (byte-compile-warn "repeated variable %s in lambda-list" arg)) + (byte-compile-warn-x + arg "repeated variable %s in lambda-list" arg)) (t (push arg vars)))) (setq list (cdr list))))) @@ -2987,7 +3008,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (defun byte-compile--warn-lexical-dynamic (var context) (when (byte-compile-warning-enabled-p 'lexical-dynamic var) - (byte-compile-warn + (byte-compile-warn-x + var "`%s' lexically bound in %s here but declared dynamic in: %s" var context (mapconcat #'identity @@ -2999,20 +3021,16 @@ If FORM is a lambda or a macro, byte-compile it as a function." (defun byte-compile-lambda (fun &optional add-lambda reserved-csts) "Byte-compile a lambda-expression and return a valid function. The value is usually a compiled function but may be the original -lambda-expression. -When ADD-LAMBDA is non-nil, the symbol `lambda' is added as head -of the list FUN and `byte-compile-set-symbol-position' is not called. -Use this feature to avoid calling `byte-compile-set-symbol-position' -for symbols generated by the byte compiler itself." +lambda-expression." (if add-lambda (setq fun (cons 'lambda fun)) (unless (eq 'lambda (car-safe fun)) - (error "Not a lambda list: %S" fun)) - (byte-compile-set-symbol-position 'lambda)) + (error "Not a lambda list: %S" fun))) (byte-compile-docstring-length-warn fun) (byte-compile-check-lambda-list (nth 1 fun)) (let* ((arglist (nth 1 fun)) - (arglistvars (byte-compile-arglist-vars arglist)) + (arglistvars (byte-run-strip-symbol-positions + (byte-compile-arglist-vars arglist))) (byte-compile-bound-variables (append (if (not lexical-binding) arglistvars) byte-compile-bound-variables)) @@ -3031,7 +3049,6 @@ for symbols generated by the byte compiler itself." (byte-compile--warn-lexical-dynamic var 'lambda)))) ;; Process the interactive spec. (when int - (byte-compile-set-symbol-position 'interactive) ;; Skip (interactive) if it is in front (the most usual location). (if (eq int (car body)) (setq body (cdr body))) @@ -3039,8 +3056,8 @@ for symbols generated by the byte compiler itself." ;; 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 "malformed interactive specc: %s" - (prin1-to-string int))) + (byte-compile-warn-x int "malformed interactive specc: %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 @@ -3052,16 +3069,16 @@ for symbols generated by the byte compiler itself." (while (consp (cdr form)) (setq form (cdr form))) (setq form (car form))) - (when (or (not (eq (car-safe form) 'list)) - ;; For code using lexical-binding, form is not - ;; valid lisp, but rather an intermediate form - ;; which may include "calls" to - ;; internal-make-closure (Bug#29988). - lexical-binding) - (setq int `(interactive ,newform))))) + (if (or (not (eq (car-safe form) 'list)) + ;; For code using lexical-binding, form is not + ;; valid lisp, but rather an intermediate form + ;; which may include "calls" to + ;; internal-make-closure (Bug#29988). + lexical-binding) + (setq int `(interactive ,newform))))) ((cdr int) ; Invalid (interactive . something). - (byte-compile-warn "malformed interactive spec: %s" - (prin1-to-string int))))) + (byte-compile-warn-x int "malformed interactive spec: %s" + int)))) ;; Process the body. (let ((compiled (byte-compile-top-level (cons 'progn body) nil 'lambda @@ -3072,14 +3089,15 @@ for symbols generated by the byte compiler itself." (and lexical-binding (byte-compile-make-lambda-lexenv arglistvars)) - reserved-csts))) + reserved-csts)) + (bare-arglist arglist)) ;; Build the actual byte-coded function. (cl-assert (eq 'byte-code (car-safe compiled))) (let ((out (apply #'make-byte-code (if lexical-binding (byte-compile-make-args-desc arglist) - arglist) + bare-arglist) (append ;; byte-string, constants-vector, stack depth (cdr compiled) @@ -3087,7 +3105,7 @@ for symbols generated by the byte compiler itself." (cond ((and lexical-binding arglist) ;; byte-compile-make-args-desc lost the args's names, ;; so preserve them in the docstring. - (list (help-add-fundoc-usage doc arglist))) + (list (help-add-fundoc-usage doc bare-arglist))) ((or doc int) (list doc))) ;; optionally, the interactive spec (and the modes the @@ -3292,7 +3310,8 @@ for symbols generated by the byte compiler itself." (setq byte-compile-noruntime-functions (delq fn byte-compile-noruntime-functions)) ;; Delegate the rest to the normal macro definition. - (macroexpand `(declare-function ,fn ,file ,@args))) + (let ((print-symbols-bare t)) ; Possibly redundant binding. + (macroexpand `(declare-function ,fn ,file ,@args)))) ;; This is the recursive entry point for compiling each subform of an @@ -3310,18 +3329,14 @@ for symbols generated by the byte compiler itself." ;; (defun byte-compile-form (form &optional for-effect) (let ((byte-compile--for-effect for-effect)) + (push form byte-compile-form-stack) (cond ((not (consp form)) (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) - (when (symbolp form) - (byte-compile-set-symbol-position form)) (byte-compile-constant form)) ((and byte-compile--for-effect byte-compile-delete-errors) - (when (symbolp form) - (byte-compile-set-symbol-position form)) (setq byte-compile--for-effect nil)) - (t - (byte-compile-variable-ref form)))) + (t (byte-compile-variable-ref form)))) ((symbolp (car form)) (let* ((fn (car form)) (handler (get fn 'byte-compile)) @@ -3344,20 +3359,20 @@ for symbols generated by the byte compiler itself." (byte-compile-check-variable (cadr hook) nil)))) (when (and (byte-compile-warning-enabled-p 'suspicious) (macroexp--const-symbol-p fn)) - (byte-compile-warn "`%s' called as a function" fn)) + (byte-compile-warn-x fn "`%s' called as a function" fn)) (when (and (byte-compile-warning-enabled-p 'interactive-only fn) interactive-only) - (byte-compile-warn "`%s' is for interactive use only%s" - fn - (cond ((stringp interactive-only) - (format "; %s" - (substitute-command-keys - interactive-only))) - ((and (symbolp 'interactive-only) - (not (eq interactive-only t))) - (format-message "; use `%s' instead." - interactive-only)) - (t ".")))) + (byte-compile-warn-x fn "`%s' is for interactive use only%s" + fn + (cond ((stringp interactive-only) + (format "; %s" + (substitute-command-keys + interactive-only))) + ((and (symbolp 'interactive-only) + (not (eq interactive-only t))) + (format-message "; use `%s' instead." + interactive-only)) + (t ".")))) (if (eq (car-safe (symbol-function (car form))) 'macro) (byte-compile-report-error (format "`%s' defined after use in %S (missing `require' of a library file?)" @@ -3382,7 +3397,8 @@ for symbols generated by the byte compiler itself." (setq byte-compile--for-effect nil)) ((byte-compile-normal-call form))) (if byte-compile--for-effect - (byte-compile-discard)))) + (byte-compile-discard)) + (pop byte-compile-form-stack))) (defun byte-compile-normal-call (form) (when (and (symbolp (car form)) @@ -3396,8 +3412,8 @@ for symbols generated by the byte compiler itself." (byte-compile-annotate-call-tree form)) (when (and byte-compile--for-effect (eq (car form) 'mapcar) (byte-compile-warning-enabled-p 'mapcar 'mapcar)) - (byte-compile-set-symbol-position 'mapcar) - (byte-compile-warn + (byte-compile-warn-x + (car form) "`mapcar' called for effect; use `mapc' or `dolist' instead")) (byte-compile-push-constant (car form)) (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. @@ -3528,16 +3544,16 @@ for symbols generated by the byte compiler itself." (defun byte-compile-check-variable (var access-type) "Do various error checks before a use of the variable VAR." - (when (symbolp var) - (byte-compile-set-symbol-position var)) (cond ((or (not (symbolp var)) (macroexp--const-symbol-p var)) (when (byte-compile-warning-enabled-p 'constants (and (symbolp var) var)) - (byte-compile-warn (if (eq access-type 'let-bind) - "attempt to let-bind %s `%s'" - "variable reference to %s `%s'") - (if (symbolp var) "constant" "nonvariable") - (prin1-to-string var)))) + (byte-compile-warn-x + var + (if (eq access-type 'let-bind) + "attempt to let-bind %s `%s'" + "variable reference to %s `%s'") + (if (symbolp var) "constant" "nonvariable") + var))) ((let ((od (get var 'byte-obsolete-variable))) (and od (not (memq var byte-compile-not-obsolete-vars)) @@ -3562,9 +3578,10 @@ for symbols generated by the byte compiler itself." (push var byte-compile-bound-variables) (byte-compile-dynamic-variable-op 'byte-varbind var)) -(defun byte-compile-free-vars-warn (var &optional assignment) +(defun byte-compile-free-vars-warn (arg var &optional assignment) "Warn if symbol VAR refers to a free variable. VAR must not be lexically bound. +ARG is a position argument, used by byte-compile-warn-x. If optional argument ASSIGNMENT is non-nil, this is treated as an assignment (i.e. `setq')." (unless (or (not (byte-compile-warning-enabled-p 'free-vars var)) @@ -3576,9 +3593,9 @@ assignment (i.e. `setq')." (let* ((varname (prin1-to-string var)) (desc (if assignment "assignment" "reference")) (suggestions (help-uni-confusable-suggestions varname))) - (byte-compile-warn "%s to free variable `%s'%s" - desc varname - (if suggestions (concat "\n " suggestions) ""))) + (byte-compile-warn-x arg "%s to free variable `%s'%s" + desc var + (if suggestions (concat "\n " suggestions) ""))) (push var (if assignment byte-compile-free-assignments byte-compile-free-references)))) @@ -3591,7 +3608,7 @@ assignment (i.e. `setq')." ;; VAR is lexically bound (byte-compile-stack-ref (cdr lex-binding)) ;; VAR is dynamically bound - (byte-compile-free-vars-warn var) + (byte-compile-free-vars-warn var var) (byte-compile-dynamic-variable-op 'byte-varref var)))) (defun byte-compile-variable-set (var) @@ -3602,7 +3619,7 @@ assignment (i.e. `setq')." ;; VAR is lexically bound. (byte-compile-stack-set (cdr lex-binding)) ;; VAR is dynamically bound. - (byte-compile-free-vars-warn var t) + (byte-compile-free-vars-warn var var t) (byte-compile-dynamic-variable-op 'byte-varset var)))) (defmacro byte-compile-get-constant (const) @@ -3627,9 +3644,9 @@ assignment (i.e. `setq')." ;; Use this for a constant that is not the value of its containing form. ;; This ignores byte-compile--for-effect. (defun byte-compile-push-constant (const) - (when (symbolp const) - (byte-compile-set-symbol-position const)) - (byte-compile-out 'byte-constant (byte-compile-get-constant const))) + (byte-compile-out + 'byte-constant + (byte-compile-get-constant const))) ;; Compile those primitive ordinary functions ;; which have special byte codes just for speed. @@ -3781,10 +3798,10 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (defun byte-compile-subr-wrong-args (form n) - (byte-compile-set-symbol-position (car form)) - (byte-compile-warn "`%s' called with %d arg%s, but requires %s" - (car form) (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s") n) + (byte-compile-warn-x (car form) + "`%s' called with %d arg%s, but requires %s" + (car form) (length (cdr form)) + (if (= 1 (length (cdr form))) "" "s") n) ;; Get run-time wrong-number-of-args error. (byte-compile-normal-call form)) @@ -4093,7 +4110,8 @@ discarding." (if (eq 'interactive (car-safe (car body))) (setq body (cdr body))) (if (and (consp (car body)) (not (eq 'byte-code (car (car body))))) - (byte-compile-warn + (byte-compile-warn-x + (nth 2 form) "A quoted lambda form is the second argument of `fset'. This is probably not what you want, as that lambda cannot be compiled. Consider using the syntax #'(lambda (...) ...) instead."))))) @@ -4178,10 +4196,11 @@ discarding." (macroexp--const-symbol-p var t)) (byte-compile-warning-enabled-p 'constants (and (symbolp var) var)) - (byte-compile-warn + (byte-compile-warn-x + var "variable assignment to %s `%s'" (if (symbolp var) "constant" "nonvariable") - (prin1-to-string var))))) + var)))) (byte-compile-normal-call form))) (defun byte-compile-quote (form) @@ -4714,7 +4733,6 @@ binding slots have been popped." ;; Even when optimization is off, /= is optimized to (not (= ...)). (defun byte-compile-negation-optimizer (form) ;; an optimizer for forms where <form1> is less efficient than (not <form2>) - (byte-compile-set-symbol-position (car form)) (list 'not (cons (or (get (car form) 'byte-compile-negated-op) (error @@ -4764,18 +4782,17 @@ binding slots have been popped." (cons (byte-compile-make-tag) clause)) failure-handlers)) (endtag (byte-compile-make-tag))) - (byte-compile-set-symbol-position 'condition-case) (unless (symbolp var) - (byte-compile-warn - "`%s' is not a variable-name or nil (in condition-case)" var)) + (byte-compile-warn-x + var "`%s' is not a variable-name or nil (in condition-case)" var)) (dolist (clause (reverse clauses)) (let ((condition (nth 1 clause))) (unless (consp condition) (setq condition (list condition))) (dolist (c condition) (unless (and c (symbolp c)) - (byte-compile-warn - "`%S' is not a condition name (in condition-case)" c)) + (byte-compile-warn-x + c "`%S' is not a condition name (in condition-case)" c)) ;; In reality, the `error-conditions' property is only required ;; for the argument to `signal', not to `condition-case'. ;;(unless (consp (get c 'error-conditions)) @@ -4826,7 +4843,8 @@ binding slots have been popped." (defun byte-compile-save-excursion (form) (if (and (eq 'set-buffer (car-safe (car-safe (cdr form)))) (byte-compile-warning-enabled-p 'suspicious 'set-buffer)) - (byte-compile-warn + (byte-compile-warn-x + form "Use `with-current-buffer' rather than save-excursion+set-buffer")) (byte-compile-out 'byte-save-excursion 0) (byte-compile-body-do-effect (cdr form)) @@ -4867,18 +4885,20 @@ binding slots have been popped." (when (and (symbolp (nth 1 form)) (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) (byte-compile-warning-enabled-p 'lexical (nth 1 form))) - (byte-compile-warn "global/dynamic var `%s' lacks a prefix" - (nth 1 form))) + (byte-compile-warn-x + (nth 1 form) + "global/dynamic var `%s' lacks a prefix" + (nth 1 form))) (byte-compile-docstring-length-warn form) (let ((fun (nth 0 form)) (var (nth 1 form)) (value (nth 2 form)) (string (nth 3 form))) - (byte-compile-set-symbol-position fun) (when (or (> (length form) 4) (and (eq fun 'defconst) (null (cddr form)))) (let ((ncall (length (cdr form)))) - (byte-compile-warn + (byte-compile-warn-x + fun "`%s' called with %d argument%s, but %s %s" fun ncall (if (= 1 ncall) "" "s") @@ -4888,8 +4908,10 @@ binding slots have been popped." (if (eq fun 'defconst) (push var byte-compile-const-variables)) (when (and string (not (stringp string))) - (byte-compile-warn "third arg to `%s %s' is not a string: %s" - fun var string)) + (byte-compile-warn-x + string + "third arg to `%s %s' is not a string: %s" + fun var string)) (byte-compile-form-do-effect (if (cddr form) ; `value' provided ;; Quote with `quote' to prevent byte-compiling the body, @@ -4904,12 +4926,12 @@ binding slots have been popped." `',var))))) (defun byte-compile-autoload (form) - (byte-compile-set-symbol-position 'autoload) (and (macroexp-const-p (nth 1 form)) (macroexp-const-p (nth 5 form)) (memq (eval (nth 5 form)) '(t macro)) ; macro-p (not (fboundp (eval (nth 1 form)))) - (byte-compile-warn + (byte-compile-warn-x + form "The compiler ignores `autoload' except at top level. You should probably put the autoload of the macro `%s' at top-level." (eval (nth 1 form)))) @@ -4918,7 +4940,6 @@ binding slots have been popped." ;; Lambdas in valid places are handled as special cases by various code. ;; The ones that remain are errors. (defun byte-compile-lambda-form (_form) - (byte-compile-set-symbol-position 'lambda) (error "`lambda' used as function name is invalid")) ;; Compile normally, but deal with warnings for the function being defined. @@ -4929,13 +4950,13 @@ binding slots have been popped." ;; if it weren't for the fact that we need to figure out when a defalias ;; defines a macro, so as to add it to byte-compile-macro-environment. ;; - ;; FIXME: we also use this hunk-handler to implement the function's dynamic - ;; docstring feature. We could actually implement it more elegantly in - ;; byte-compile-lambda so it applies to all lambdas, but the problem is that - ;; the resulting .elc format will not be recognized by make-docfile, so - ;; either we stop using DOC for the docstrings of preloaded elc files (at the - ;; cost of around 24KB on 32bit hosts, double on 64bit hosts) or we need to - ;; build DOC in a more clever way (e.g. handle anonymous elements). + ;; FIXME: we also use this hunk-handler to implement the function's + ;; dynamic docstring feature (via byte-compile-file-form-defmumble). + ;; We should actually implement it (more elegantly) in + ;; byte-compile-lambda so it applies to all lambdas. We did it here + ;; so the resulting .elc format was recognizable by make-docfile, + ;; but since then we stopped using DOC for the docstrings of + ;; preloaded elc files so that obstacle is gone. (let ((byte-compile-free-references nil) (byte-compile-free-assignments nil)) (pcase form @@ -4998,7 +5019,8 @@ binding slots have been popped." (defun byte-compile-make-variable-buffer-local (form) (if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote) (byte-compile-warning-enabled-p 'make-local)) - (byte-compile-warn + (byte-compile-warn-x + form "`make-variable-buffer-local' not called at toplevel")) (byte-compile-normal-call form)) (put 'make-variable-buffer-local @@ -5042,6 +5064,8 @@ binding slots have been popped." nil)) (_ (byte-compile-keep-pending form)))) + + ;;; tags @@ -5076,7 +5100,7 @@ binding slots have been popped." OP and OPERAND are as passed to `byte-compile-out'." (if (memq op '(byte-call byte-discardN byte-discardN-preserve-tos)) ;; For calls, OPERAND is the number of args, so we pop OPERAND + 1 - ;; elements, and the push the result, for a total of -OPERAND. + ;; elements, and then push the result, for a total of -OPERAND. ;; For discardN*, of course, we just pop OPERAND elements. (- operand) (or (aref byte-stack+-info (symbol-value op)) @@ -5086,6 +5110,11 @@ OP and OPERAND are as passed to `byte-compile-out'." (- 1 operand)))) (defun byte-compile-out (op &optional operand) + "Push the operation onto `byte-compile-output'. +OP is an opcode, a symbol. OPERAND is either nil or a number or +a one-element list of a lisp form." + (when (and (consp operand) (null (cdr operand))) + (setq operand (byte-run-strip-symbol-positions operand))) (push (cons op operand) byte-compile-output) (if (eq op 'byte-return) ;; This is actually an unnecessary case, because there should be no @@ -5100,24 +5129,26 @@ OP and OPERAND are as passed to `byte-compile-out'." ;;; call tree stuff (defun byte-compile-annotate-call-tree (form) - (let (entry) + (let ((current-form (byte-run-strip-symbol-positions + byte-compile-current-form)) + (bare-car-form (byte-run-strip-symbol-positions (car form))) + entry) ;; annotate the current call - (if (setq entry (assq (car form) byte-compile-call-tree)) - (or (memq byte-compile-current-form (nth 1 entry)) ;callers + (if (setq entry (assq bare-car-form byte-compile-call-tree)) + (or (memq current-form (nth 1 entry)) ;callers (setcar (cdr entry) - (cons byte-compile-current-form (nth 1 entry)))) + (cons current-form (nth 1 entry)))) (setq byte-compile-call-tree - (cons (list (car form) (list byte-compile-current-form) nil) + (cons (list bare-car-form (list current-form) nil) byte-compile-call-tree))) ;; annotate the current function - (if (setq entry (assq byte-compile-current-form byte-compile-call-tree)) - (or (memq (car form) (nth 2 entry)) ;called + (if (setq entry (assq current-form byte-compile-call-tree)) + (or (memq bare-car-form (nth 2 entry)) ;called (setcar (cdr (cdr entry)) - (cons (car form) (nth 2 entry)))) + (cons bare-car-form (nth 2 entry)))) (setq byte-compile-call-tree - (cons (list byte-compile-current-form nil (list (car form))) - byte-compile-call-tree))) - )) + (cons (list current-form nil (list bare-car-form)) + byte-compile-call-tree))))) ;; Renamed from byte-compile-report-call-tree ;; to avoid interfering with completion of byte-compile-file. @@ -5142,14 +5173,15 @@ invoked interactively." (set-buffer "*Call-Tree*") (erase-buffer) (message "Generating call tree... (sorting on %s)" - byte-compile-call-tree-sort) + (remove-pos-from-symbol byte-compile-call-tree-sort)) (insert "Call tree for " (cond ((null byte-compile-current-file) (or filename "???")) ((stringp byte-compile-current-file) byte-compile-current-file) (t (buffer-name byte-compile-current-file))) " sorted on " - (prin1-to-string byte-compile-call-tree-sort) + (prin1-to-string (remove-pos-from-symbol + byte-compile-call-tree-sort)) ":\n\n") (if byte-compile-call-tree-sort (setq byte-compile-call-tree @@ -5169,7 +5201,8 @@ invoked interactively." ('name (lambda (x y) (string< (car x) (car y)))) (_ (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode" - byte-compile-call-tree-sort)))))) + (remove-pos-from-symbol + byte-compile-call-tree-sort))))))) (message "Generating call tree...") (let ((rest byte-compile-call-tree) (b (current-buffer)) @@ -5316,7 +5349,7 @@ already up-to-date." (or (not (file-exists-p dest)) (file-newer-than-file-p source dest)))) (if (null (batch-byte-compile-file (car command-line-args-left))) - (setq error t)))) + (setq error t)))) (setq command-line-args-left (cdr command-line-args-left))) (kill-emacs (if error 1 0)))) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index ccb96d169d5..c16619bc45d 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -258,11 +258,11 @@ Returns a form where all lambdas don't have any free variables." ;; unused vars. (not (intern-soft var)) (eq ?_ (aref (symbol-name var) 0)) - ;; As a special exception, ignore "ignore". + ;; As a special exception, ignore "ignored". (eq var 'ignored)) (let ((suggestions (help-uni-confusable-suggestions (symbol-name var)))) (format "Unused lexical %s `%S'%s" - varkind var + varkind (bare-symbol var) (if suggestions (concat "\n " suggestions) ""))))) (define-inline cconv--var-classification (binder form) @@ -286,24 +286,38 @@ of converted forms." (let (and (pred stringp) msg) (cconv--warn-unused-msg arg "argument"))) (if (assq arg env) (push `(,arg . nil) env)) ;FIXME: Is it needed? - (push (lambda (body) (macroexp--warn-wrap msg body 'lexical)) wrappers)) + (push (lambda (body) (macroexp--warn-wrap arg msg body 'lexical)) wrappers)) (_ (if (assq arg env) (push `(,arg . nil) env))))) (setq funcbody (mapcar (lambda (form) (cconv-convert form env nil)) funcbody)) (if wrappers - (let ((special-forms '())) - ;; Keep special forms at the beginning of the body. - (while (or (and (cdr funcbody) (stringp (car funcbody))) ;docstring. - (memq (car-safe (car funcbody)) - '(interactive declare :documentation))) - (push (pop funcbody) special-forms)) - (let ((body (macroexp-progn funcbody))) + (pcase-let ((`(,decls . ,body) (macroexp-parse-body funcbody))) + (let ((body (macroexp-progn body))) (dolist (wrapper wrappers) (setq body (funcall wrapper body))) - `(,@(nreverse special-forms) ,@(macroexp-unprogn body)))) + `(,@decls ,@(macroexp-unprogn body)))) funcbody))) +(defun cconv--lifted-arg (var env) + "The argument to use for VAR in λ-lifted calls according to ENV. +This is used when VAR is being shadowed; we may still need its value for +such calls." + (let ((mapping (cdr (assq var env)))) + (pcase-exhaustive mapping + (`(internal-get-closed-var . ,_) + ;; The variable is captured. + mapping) + (`(car-safe ,exp) + ;; The variable is mutably captured; skip + ;; the indirection step because the variable is + ;; passed "by reference" to the λ-lifted function. + exp) + (_ + ;; The variable is not captured; use the (shadowed) variable value. + ;; (If the mapping is `(car-safe SYMBOL)', SYMBOL is always VAR. + var)))) + (defun cconv-convert (form env extend) ;; This function actually rewrites the tree. "Return FORM with all its lambdas changed so they are closed. @@ -353,7 +367,8 @@ places where they originally did not directly appear." (var (if (not (consp binder)) (prog1 binder (setq binder (list binder))) (when (cddr binder) - (byte-compile-warn + (byte-compile-warn-x + binder "Malformed `%S' binding: %S" letsym binder)) (setq value (cadr binder)) @@ -361,9 +376,9 @@ places where they originally did not directly appear." (cond ;; Ignore bindings without a valid name. ((not (symbolp var)) - (byte-compile-warn "attempt to let-bind nonvariable `%S'" var)) + (byte-compile-warn-x var "attempt to let-bind nonvariable `%S'" var)) ((or (booleanp var) (keywordp var)) - (byte-compile-warn "attempt to let-bind constant `%S'" var)) + (byte-compile-warn-x var "attempt to let-bind constant `%S'" var)) (t (let ((new-val (pcase (cconv--var-classification binder form) @@ -413,11 +428,14 @@ places where they originally did not directly appear." ;; Declared variable is unused. (if (assq var new-env) (push `(,var) new-env)) ;FIXME:Needed? - (let ((newval - `(ignore ,(cconv-convert value env extend))) - (msg (cconv--warn-unused-msg var "variable"))) + (let* ((Ignore (if (symbol-with-pos-p var) + (position-symbol 'ignore var) + 'ignore)) + (newval `(,Ignore + ,(cconv-convert value env extend))) + (msg (cconv--warn-unused-msg var "variable"))) (if (null msg) newval - (macroexp--warn-wrap msg newval 'lexical)))) + (macroexp--warn-wrap var msg newval 'lexical)))) ;; Normal default case. (_ @@ -428,10 +446,11 @@ places where they originally did not directly appear." ;; One of the lambda-lifted vars is shadowed, so add ;; a reference to the outside binding and arrange to use ;; that reference. - (let ((closedsym (make-symbol (format "closed-%s" var)))) + (let ((var-def (cconv--lifted-arg var env)) + (closedsym (make-symbol (format "closed-%s" var)))) (setq new-env (cconv--remap-llv new-env var closedsym)) (setq new-extend (cons closedsym (remq var new-extend))) - (push `(,closedsym ,var) binders-new))) + (push `(,closedsym ,var-def) binders-new))) ;; We push the element after redefined free variables are ;; processed. This is important to avoid the bug when free @@ -449,14 +468,13 @@ places where they originally did not directly appear." ;; before we know that the var will be in `new-extend' (bug#24171). (dolist (binder binders-new) (when (memq (car-safe binder) new-extend) - ;; One of the lambda-lifted vars is shadowed, so add - ;; a reference to the outside binding and arrange to use - ;; that reference. + ;; One of the lambda-lifted vars is shadowed. (let* ((var (car-safe binder)) + (var-def (cconv--lifted-arg var env)) (closedsym (make-symbol (format "closed-%s" var)))) (setq new-env (cconv--remap-llv new-env var closedsym)) (setq new-extend (cons closedsym (remq var new-extend))) - (push `(,closedsym ,var) binders-new))))) + (push `(,closedsym ,var-def) binders-new))))) `(,letsym ,(nreverse binders-new) . ,(mapcar (lambda (form) @@ -516,7 +534,7 @@ places where they originally did not directly appear." (newprotform (cconv-convert protected-form env extend))) `(condition-case ,var ,(if msg - (macroexp--warn-wrap msg newprotform 'lexical) + (macroexp--warn-wrap var msg newprotform 'lexical) newprotform) ,@(mapcar (lambda (handler) @@ -608,10 +626,10 @@ FORM is the parent form that binds this var." (`((,(and var (guard (eq ?_ (aref (symbol-name var) 0)))) . ,_) ,_ ,_ ,_ ,_) ;; FIXME: Convert this warning to use `macroexp--warn-wrap' - ;; so as to give better position information and obey - ;; `byte-compile-warnings'. - (byte-compile-warn - "%s `%S' not left unused" varkind var)) + ;; so as to give better position information. + (when (byte-compile-warning-enabled-p 'not-unused var) + (byte-compile-warn-x + var "%s `%S' not left unused" varkind var))) ((and (let (or 'let* 'let) (car form)) `((,var) ;; (or `(,var nil) : Too many false positives: bug#47080 t nil ,_ ,_)) @@ -619,7 +637,7 @@ FORM is the parent form that binds this var." ;; so as to give better position information and obey ;; `byte-compile-warnings'. (unless (not (intern-soft var)) - (byte-compile-warn "Variable `%S' left uninitialized" var)))) + (byte-compile-warn-x var "Variable `%S' left uninitialized" var)))) (pcase vardata (`(,binder nil ,_ ,_ nil) (push (cons (cons binder form) :unused) cconv-var-classification)) @@ -648,7 +666,8 @@ FORM is the parent form that binds this var." (dolist (arg args) (cond ((byte-compile-not-lexical-var-p arg) - (byte-compile-warn + (byte-compile-warn-x + arg "Lexical argument shadows the dynamic variable %S" arg)) ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... @@ -731,7 +750,8 @@ This function does not return anything but instead fills the (setq forms (cddr forms)))) (`((lambda . ,_) . ,_) ; First element is lambda expression. - (byte-compile-warn + (byte-compile-warn-x + (nth 1 (car form)) "Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form))) (dolist (exp `((function ,(car form)) . ,(cdr form))) (cconv-analyze-form exp env))) @@ -750,8 +770,8 @@ This function does not return anything but instead fills the (`(condition-case ,var ,protected-form . ,handlers) (cconv-analyze-form protected-form env) (when (and var (symbolp var) (byte-compile-not-lexical-var-p var)) - (byte-compile-warn - "Lexical variable shadows the dynamic variable %S" var)) + (byte-compile-warn-x + var "Lexical variable shadows the dynamic variable %S" var)) (let* ((varstruct (list var nil nil nil nil))) (if var (push varstruct env)) (dolist (handler handlers) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 660b7062d1e..72eb776b993 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -166,7 +166,7 @@ (require 'help-mode) ;; for help-xref-info-regexp (require 'thingatpt) ;; for handy thing-at-point-looking-at (require 'lisp-mode) ;; for lisp-mode-symbol-regexp -(require 'dired) ;; for dired-get-filename and dired-map-over-marks +(eval-when-compile (require 'dired)) ;; for dired-map-over-marks (require 'lisp-mnt) (defvar compilation-error-regexp-alist) @@ -340,6 +340,7 @@ See Info node `(elisp) Documentation Tips' for background." ;; (setq checkdoc--argument-missing-flag nil) ; optional ;; (setq checkdoc--disambiguate-symbol-flag nil) ; optional ;; (setq checkdoc--interactive-docstring-flag nil) ; optional +;; (setq checkdoc-verb-check-experimental-flag nil) ;; Then use `M-x find-dired' ("-name '*.el'") and `M-x checkdoc-dired' (defvar checkdoc--argument-missing-flag t @@ -494,6 +495,9 @@ be re-created.") (defconst checkdoc--help-buffer "*Checkdoc Help*" "Name of buffer used for Checkdoc Help.") +(defvar checkdoc-commentary-header-string "\n;;; Commentary:\n;; \n\n" + "String inserted as commentary marker in `checkdoc-file-comments-engine'.") + ;;; User level commands ;; ;;;###autoload @@ -1113,18 +1117,27 @@ space at the end of each line." ";;; lisp/trampver.el. Generated from trampver.el.in by configure.")) "Regexp that when it matches tells `checkdoc-dired' to skip a file.") +;;;###autoload (defun checkdoc-dired (files) "In Dired, run `checkdoc' on marked files. Skip anything that doesn't have the Emacs Lisp library file extension (\".el\"). When called from Lisp, FILES is a list of filenames." (interactive - (list - (delq nil - (mapcar - ;; skip anything that doesn't look like an Emacs Lisp library - (lambda (f) (if (equal (file-name-extension f) "el") f nil)) - (nreverse (dired-map-over-marks (dired-get-filename) nil))))) + (progn + ;; These Dired functions must be defined since we're in a Dired buffer. + (declare-function dired-get-filename "dired" + (&optional localp no-error-if-not-filep bof)) + ;; These functions are used by the expansion of `dired-map-over-marks'. + (declare-function dired-move-to-filename "dired" + (&optional raise-error eol)) + (declare-function dired-marker-regexp "dired" ()) + (list + (delq nil + (mapcar + ;; skip anything that doesn't look like an Emacs Lisp library + (lambda (f) (if (equal (file-name-extension f) "el") f nil)) + (nreverse (dired-map-over-marks (dired-get-filename) nil)))))) dired-mode) (if (null files) (error "No files to run checkdoc on") @@ -1270,27 +1283,27 @@ TEXT, START, END and UNFIXABLE conform to (let ((map (make-sparse-keymap)) (pmap (make-sparse-keymap))) ;; Override some bindings - (define-key map "\C-\M-x" 'checkdoc-eval-defun) - (define-key map "\C-x`" 'checkdoc-continue) + (define-key map "\C-\M-x" #'checkdoc-eval-defun) + (define-key map "\C-x`" #'checkdoc-continue) (define-key map [menu-bar emacs-lisp eval-buffer] - 'checkdoc-eval-current-buffer) + #'checkdoc-eval-current-buffer) ;; Add some new bindings under C-c ? - (define-key pmap "x" 'checkdoc-defun) - (define-key pmap "X" 'checkdoc-ispell-defun) - (define-key pmap "`" 'checkdoc-continue) - (define-key pmap "~" 'checkdoc-ispell-continue) - (define-key pmap "s" 'checkdoc-start) - (define-key pmap "S" 'checkdoc-ispell-start) - (define-key pmap "d" 'checkdoc) - (define-key pmap "D" 'checkdoc-ispell) - (define-key pmap "b" 'checkdoc-current-buffer) - (define-key pmap "B" 'checkdoc-ispell-current-buffer) - (define-key pmap "e" 'checkdoc-eval-current-buffer) - (define-key pmap "m" 'checkdoc-message-text) - (define-key pmap "M" 'checkdoc-ispell-message-text) - (define-key pmap "c" 'checkdoc-comments) - (define-key pmap "C" 'checkdoc-ispell-comments) - (define-key pmap " " 'checkdoc-rogue-spaces) + (define-key pmap "x" #'checkdoc-defun) + (define-key pmap "X" #'checkdoc-ispell-defun) + (define-key pmap "`" #'checkdoc-continue) + (define-key pmap "~" #'checkdoc-ispell-continue) + (define-key pmap "s" #'checkdoc-start) + (define-key pmap "S" #'checkdoc-ispell-start) + (define-key pmap "d" #'checkdoc) + (define-key pmap "D" #'checkdoc-ispell) + (define-key pmap "b" #'checkdoc-current-buffer) + (define-key pmap "B" #'checkdoc-ispell-current-buffer) + (define-key pmap "e" #'checkdoc-eval-current-buffer) + (define-key pmap "m" #'checkdoc-message-text) + (define-key pmap "M" #'checkdoc-ispell-message-text) + (define-key pmap "c" #'checkdoc-comments) + (define-key pmap "C" #'checkdoc-ispell-comments) + (define-key pmap " " #'checkdoc-rogue-spaces) ;; bind our submap into map (define-key map "\C-c?" pmap) @@ -2126,13 +2139,11 @@ Examples of recognized abbreviations: \"e.g.\", \"i.e.\", \"cf.\"." ;; a part of a list. (rx letter ".") (rx (or - ;; The abbreviations: + ;; The abbreviations (a trailing dot is added below). (seq (any "cC") "f") ; cf. (seq (any "eE") ".g") ; e.g. (seq (any "iI") "." (any "eE")) ; i.e. - "a.k.a" ; a.k.a. - "etc" ; etc. - "vs" ; vs. + "a.k.a" "etc" "vs" "N.B" ;; Some non-standard or less common ones that we ;; might as well accept. "Inc" "Univ" "misc" "resp") @@ -2411,7 +2422,7 @@ Code:, and others referenced in the style guide." nil nil t))) (if (checkdoc-y-or-n-p "You should have a \";;; Commentary:\", add one?") - (insert "\n;;; Commentary:\n;; \n\n") + (insert checkdoc-commentary-header-string) (checkdoc-create-error "You should have a section marked \";;; Commentary:\"" nil nil t))) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index a7e24236a32..295512d51ef 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -86,6 +86,14 @@ ;;; Code: +;; We provide a mechanism to define new specializers. +;; Related work can be found in: +;; - http://www.p-cos.net/documents/filtered-dispatch.pdf +;; - Generalizers: New metaobjects for generalized dispatch +;; http://research.gold.ac.uk/9924/1/els-specializers.pdf +;; 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! @@ -100,6 +108,7 @@ (eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'cl-macs)) ;For cl--find-class. (eval-when-compile (require 'pcase)) +(eval-when-compile (require 'subr-x)) (cl-defstruct (cl--generic-generalizer (:constructor nil) @@ -253,6 +262,16 @@ DEFAULT-BODY, if present, is used as the body of a default method. (declarations nil) (methods ()) (options ()) + (warnings + (let ((nonsymargs + (delq nil (mapcar (lambda (arg) (unless (symbolp arg) arg)) + args)))) + (when nonsymargs + (list + (macroexp-warn-and-return + (format "Non-symbol arguments to cl-defgeneric: %s" + (mapconcat #'prin1-to-string nonsymargs "")) + nil nil nil nonsymargs))))) next-head) (while (progn (setq next-head (car-safe (car options-and-methods))) (or (keywordp next-head) @@ -275,9 +294,12 @@ DEFAULT-BODY, if present, is used as the body of a default method. (setq name (gv-setter (cadr name)))) `(prog1 (progn + ,@warnings (defalias ',name (cl-generic-define ',name ',args ',(nreverse options)) - ,(help-add-fundoc-usage doc args)) + ,(if (consp doc) ;An expression rather than a constant. + `(help-add-fundoc-usage ,doc ',args) + (help-add-fundoc-usage doc args))) :autoload-end ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method)) (nreverse methods))) @@ -370,9 +392,9 @@ the specializer used will be the one returned by BODY." . ,(lambda () spec-args)) macroexpand-all-environment))) (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'. - (when (interactive-form (cadr fun)) - (message "Interactive forms unsupported in generic functions: %S" - (interactive-form (cadr fun)))) + (when (assq 'interactive body) + (message "Interactive forms not supported in generic functions: %S" + (assq 'interactive body))) ;; First macroexpand away the cl-function stuff (e.g. &key and ;; destructuring args, `declare' and whatnot). (pcase (macroexpand fun macroenv) @@ -487,7 +509,8 @@ The set of acceptable TYPEs (also called \"specializers\") is defined cl--generic-edebug-make-name nil] lambda-doc ; documentation string def-body))) ; part to be debugged - (let ((qualifiers nil)) + (let ((qualifiers nil) + (orig-name name)) (while (cl-generic--method-qualifier-p args) (push args qualifiers) (setq args (pop body))) @@ -503,7 +526,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (let* ((obsolete (get name 'byte-obsolete-info))) (macroexp-warn-and-return (macroexp--obsolete-warning name obsolete "generic function") - nil))) + nil (list 'obsolete name) nil orig-name))) ;; You could argue that `defmethod' modifies rather than defines the ;; function, so warnings like "not known to be defined" are fair game. ;; But in practice, it's common to use `cl-defmethod' @@ -589,20 +612,21 @@ The set of acceptable TYPEs (also called \"specializers\") is defined ;; e.g. for tracing/debug-on-entry. (defalias sym gfun))))) -(defmacro cl--generic-with-memoization (place &rest code) - (declare (indent 1) (debug t)) - (gv-letplace (getter setter) place - `(or ,getter - ,(macroexp-let2 nil val (macroexp-progn code) - `(progn - ,(funcall setter val) - ,val))))) - (defvar cl--generic-dispatchers (make-hash-table :test #'equal)) +(defvar cl--generic-compiler + ;; Don't byte-compile the dispatchers if cl-generic itself is not + ;; compiled. Otherwise the byte-compiler and all the code on + ;; which it depends needs to be usable before cl-generic is loaded, + ;; which imposes a significant burden on the bootstrap. + (if (consp (lambda (x) (+ x 1))) + (lambda (exp) (eval exp t)) #'byte-compile)) + (defun cl--generic-get-dispatcher (dispatch) - (cl--generic-with-memoization - (gethash dispatch cl--generic-dispatchers) + (with-memoization + ;; We need `copy-sequence` here because this `dispatch' object might be + ;; modified by side-effect in `cl-generic-define-method' (bug#46722). + (gethash (copy-sequence dispatch) cl--generic-dispatchers) ;; (message "cl--generic-get-dispatcher (%S)" dispatch) (let* ((dispatch-arg (car dispatch)) (generalizers (cdr dispatch)) @@ -642,12 +666,16 @@ The set of acceptable TYPEs (also called \"specializers\") is defined ;; FIXME: For generic functions with a single method (or with 2 methods, ;; one of which always matches), using a tagcode + hash-table is ;; overkill: better just use a `cl-typep' test. - (byte-compile + (funcall + cl--generic-compiler `(lambda (generic dispatches-left methods) + ;; FIXME: We should find a way to expand `with-memoize' once + ;; and forall so we don't need `subr-x' when we get here. + (eval-when-compile (require 'subr-x)) (let ((method-cache (make-hash-table :test #'eql))) (lambda (,@fixedargs &rest args) (let ,bindings - (apply (cl--generic-with-memoization + (apply (with-memoization (gethash ,tag-exp method-cache) (cl--generic-cache-miss generic ',dispatch-arg dispatches-left methods @@ -684,14 +712,14 @@ This is particularly useful when many different tags select the same set of methods, since this table then allows us to share a single combined-method for all those different tags in the method-cache.") -(define-error 'cl--generic-cyclic-definition "Cyclic definition: %S") +(define-error 'cl--generic-cyclic-definition "Cyclic definition") (defun cl--generic-build-combined-method (generic methods) (if (null methods) ;; Special case needed to fix a circularity during bootstrap. (cl--generic-standard-method-combination generic methods) (let ((f - (cl--generic-with-memoization + (with-memoization ;; FIXME: Since the fields of `generic' are modified, this ;; hash-table won't work right, because the hashes will change! ;; It's not terribly serious, but reduces the effectiveness of @@ -867,11 +895,20 @@ those methods.") (setq arg-or-context `(&context . ,arg-or-context))) (unless (fboundp 'cl--generic-get-dispatcher) (require 'cl-generic)) - (let ((fun (cl--generic-get-dispatcher - `(,arg-or-context - ,@(apply #'append - (mapcar #'cl-generic-generalizers specializers)) - ,cl--generic-t-generalizer)))) + (let ((fun + ;; Let-bind cl--generic-dispatchers so we *re*compute the function + ;; from scratch, since the one in the cache may be non-compiled! + (let ((cl--generic-dispatchers (make-hash-table)) + ;; When compiling `cl-generic' during bootstrap, make sure + ;; we prefill with compiled dispatchers even though the loaded + ;; `cl-generic' is still interpreted. + (cl--generic-compiler + (if (featurep 'bytecomp) #'byte-compile cl--generic-compiler))) + (cl--generic-get-dispatcher + `(,arg-or-context + ,@(apply #'append + (mapcar #'cl-generic-generalizers specializers)) + ,cl--generic-t-generalizer))))) ;; Recompute dispatch at run-time, since the generalizers may be slightly ;; different (e.g. byte-compiled rather than interpreted). ;; FIXME: There is a risk that the run-time generalizer is not equivalent @@ -1143,7 +1180,7 @@ These match if the argument is a cons cell whose car is `eql' to VAL." ;; since we can't use the `head' specializer to implement itself. (if (not (eq (car-safe specializer) 'head)) (cl-call-next-method) - (cl--generic-with-memoization + (with-memoization (gethash (cadr specializer) cl--generic-head-used) specializer) (list cl--generic-head-generalizer))) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 8d63a3cccfa..4e60a3c63d0 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -560,4 +560,9 @@ of record objects." (t (advice-remove 'type-of #'cl--old-struct-type-of)))) +(defun cl-constantly (value) + "Return a function that takes any number of arguments, but returns VALUE." + (lambda (&rest _) + value)) + ;;; cl-lib.el ends here diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c27a43f3baf..5d2a7c03ac4 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -301,24 +301,31 @@ FORM is of the form (ARGS . BODY)." (t ;; `simple-args' doesn't handle all the parsing that we need, ;; so we pass the rest to cl--do-arglist which will do ;; "manual" parsing. - (let ((slen (length simple-args))) - (when (memq '&optional simple-args) - (cl-decf slen)) - (setq header + (let ((slen (length simple-args)) + (usage-str ;; Macro expansion can take place in the middle of ;; apparently harmless computation, so it should not ;; touch the match-data. (save-match-data - (cons (help-add-fundoc-usage - (if (stringp (car header)) (pop header)) - ;; Be careful with make-symbol and (back)quote, - ;; see bug#12884. - (help--docstring-quote - (let ((print-gensym nil) (print-quoted t) - (print-escape-newlines t)) - (format "%S" (cons 'fn (cl--make-usage-args - orig-args)))))) - header))) + (help--docstring-quote + (let ((print-gensym nil) (print-quoted t) + (print-escape-newlines t)) + (format "%S" (cons 'fn (cl--make-usage-args + orig-args)))))))) + (when (memq '&optional simple-args) + (cl-decf slen)) + (setq header + (cons + (if (eq :documentation (car-safe (car header))) + `(:documentation (help-add-fundoc-usage + ,(cadr (pop header)) + ,usage-str)) + (help-add-fundoc-usage + (if (stringp (car header)) (pop header)) + ;; Be careful with make-symbol and (back)quote, + ;; see bug#12884. + usage-str)) + header)) ;; FIXME: we'd want to choose an arg name for the &rest param ;; and pass that as `expr' to cl--do-arglist, but that ends up ;; generating code with a redundant let-binding, so we instead @@ -387,11 +394,17 @@ and BODY is implicitly surrounded by (cl-block NAME ...). `(iter-defun ,name ,@(cl--transform-lambda (cons args body) name))) ;; The lambda list for macros is different from that of normal lambdas. -;; Note that &environment is only allowed as first or last items in the + +;; `cl-macro-list' is shared between a few different use cases that +;; don't all support exactly the same set of special keywords: the +;; debug spec accepts hence a superset of what the macros +;; actually support. +;; For example &environment is only allowed as first or last items in the ;; top level list. (def-edebug-elem-spec 'cl-macro-list - '(([&optional "&environment" arg] + '(([&optional "&whole" arg] ; Only for compiler-macros or at lower levels. + [&optional "&environment" arg] ; Only at top-level. [&rest cl-macro-arg] [&optional ["&optional" &rest &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] @@ -403,26 +416,12 @@ and BODY is implicitly surrounded by (cl-block NAME ...). &optional "&allow-other-keys"]] [&optional ["&aux" &rest &or (cl-macro-arg &optional def-form) arg]] - [&optional "&environment" arg] + [&optional "&environment" arg] ; Only at top-level. + . [&or arg nil] ; Only allowed at lower levels. ))) (def-edebug-elem-spec 'cl-macro-arg - '(&or arg cl-macro-list1)) - -(def-edebug-elem-spec 'cl-macro-list1 - '(([&optional "&whole" arg] ;; only allowed at lower levels - [&rest cl-macro-arg] - [&optional ["&optional" &rest - &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] - [&optional [[&or "&rest" "&body"] cl-macro-arg]] - [&optional ["&key" [&rest - [&or ([&or (symbolp cl-macro-arg) arg] - &optional def-form cl-macro-arg) - arg]] - &optional "&allow-other-keys"]] - [&optional ["&aux" &rest - &or (cl-macro-arg &optional def-form) arg]] - . [&or arg nil]))) + '(&or arg cl-macro-list)) ;;;###autoload (defmacro cl-defmacro (name args &rest body) @@ -685,7 +684,7 @@ its argument list allows full Common Lisp conventions." (defmacro cl-destructuring-bind (args expr &rest body) "Bind the variables in ARGS to the result of EXPR and execute BODY." (declare (indent 2) - (debug (&define cl-macro-list1 def-form cl-declarations def-body))) + (debug (&define cl-macro-list def-form cl-declarations def-body))) (let* ((cl--bind-lets nil) (cl--bind-forms nil) (cl--bind-defs nil) @@ -2139,9 +2138,14 @@ Like `cl-flet' but the definitions can refer to previous ones. ;; setq the fresh new `ofargs' vars instead ;-) (let ((shadowings (mapcar (lambda (b) (if (consp b) (car b) b)) bindings))) - ;; If `var' is shadowed, then it clearly can't be - ;; tail-called any more. - (not (memq var shadowings))))) + (and + ;; If `var' is shadowed, then it clearly can't be + ;; tail-called any more. + (not (memq var shadowings)) + ;; If any of the new bindings is a dynamic + ;; variable, the body is not in tail position. + (not (delq nil (mapcar #'macroexp--dynamic-variable-p + shadowings))))))) `(,(car exp) ,bindings . ,(funcall opt-exps exps))) ((and `(condition-case ,err-var ,bodyform . ,handlers) (guard (not (eq err-var var)))) @@ -2417,10 +2421,11 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (append bindings venv)) macroexpand-all-environment)))) (if malformed-bindings - (macroexp-warn-and-return - (format-message "Malformed `cl-symbol-macrolet' binding(s): %S" - (nreverse malformed-bindings)) - expansion) + (let ((rev-malformed-bindings (nreverse malformed-bindings))) + (macroexp-warn-and-return + (format-message "Malformed `cl-symbol-macrolet' binding(s): %S" + rev-malformed-bindings) + expansion nil nil rev-malformed-bindings)) expansion))) (unless advised (advice-remove 'macroexpand #'cl--sm-macroexpand))))) @@ -2896,18 +2901,10 @@ To see the documentation for a defined struct type, use (debug (&define ;Makes top-level form not be wrapped. [&or symbolp - (gate + (gate ;; FIXME: Why? symbolp &rest - [&or symbolp - (&or [":conc-name" symbolp] - [":constructor" symbolp &optional cl-lambda-list] - [":copier" symbolp] - [":predicate" symbolp] - [":include" symbolp &rest sexp] ;; Not finished. - [":print-function" sexp] - [":type" symbolp] - [":named"] - [":initial-offset" natnump])])] + [&or (":constructor" &define name &optional cl-lambda-list) + sexp])] [&optional stringp] ;; All the above is for the following def-form. &rest &or symbolp (symbolp &optional def-form &rest sexp)))) @@ -3050,7 +3047,7 @@ To see the documentation for a defined struct type, use `(,predicate cl-x)))) (when pred-form (push `(,defsym ,predicate (cl-x) - (declare (side-effect-free error-free)) + (declare (side-effect-free error-free) (pure t)) ,(if (eq (car pred-form) 'and) (append pred-form '(t)) `(and ,pred-form t))) @@ -3106,7 +3103,7 @@ To see the documentation for a defined struct type, use (macroexp-warn-and-return (format "Missing value for option `%S' of slot `%s' in struct %s!" (car (last desc)) slot name) - 'nil) + nil nil nil (car (last desc))) forms) (when (and (keywordp (car defaults)) (not (keywordp (car desc)))) @@ -3115,7 +3112,7 @@ To see the documentation for a defined struct type, use (macroexp-warn-and-return (format " I'll take `%s' to be an option rather than a default value." kw) - 'nil) + nil nil nil kw) forms) (push kw desc) (setcar defaults nil)))) @@ -3282,8 +3279,9 @@ the form NAME which is a shorthand for (NAME NAME)." (funcall orig pred1 (cl--defstruct-predicate t2)))) (funcall orig pred1 pred2)))) -(advice-add 'pcase--mutually-exclusive-p - :around #'cl--pcase-mutually-exclusive-p) +(when (fboundp 'advice-add) ;Not available during bootstrap. + (advice-add 'pcase--mutually-exclusive-p + :around #'cl--pcase-mutually-exclusive-p)) (defun cl-struct-sequence-type (struct-type) @@ -3365,6 +3363,7 @@ Of course, we really can't know that for sure, so it's just a heuristic." (integer . integerp) (keyword . keywordp) (list . listp) + (natnum . natnump) (number . numberp) (null . null) (real . numberp) @@ -3487,7 +3486,10 @@ compiler macros are expanded repeatedly until no further expansions are possible. Unlike regular macros, BODY can decide to \"punt\" and leave the original function call alone by declaring an initial `&whole foo' parameter and then returning foo." - (declare (debug cl-defmacro) (indent 2)) + ;; Like `cl-defmacro', but with the `&whole' special case. + (declare (debug (&define name cl-macro-list + cl-declarations-or-string def-body)) + (indent 2)) (let ((p args) (res nil)) (while (consp p) (push (pop p) res)) (setq args (nconc (nreverse res) (and p (list '&rest p))))) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index ef60b266f9e..6aa45526d84 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -1,6 +1,6 @@ ;;; cl-preloaded.el --- Preloaded part of the CL library -*- lexical-binding: t; -*- -;; Copyright (C) 2015-2021 Free Software Foundation, Inc +;; Copyright (C) 2015-2022 Free Software Foundation, Inc ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Package: emacs diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 65710b58c10..9eaf38067f6 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -70,7 +70,7 @@ (irange &aux (range (list irange)) (typeset ()))) - (:copier comp-cstr-shallow-copy)) + (:copier nil)) "Internal representation of a type/value constraint." (typeset '(t) :type list :documentation "List of possible types the mvar can assume. @@ -133,6 +133,14 @@ Integer values are handled in the `range' slot.") :range (copy-tree (range cstr)) :neg (neg cstr)))) +(defsubst comp-cstr-shallow-copy (dst src) + "Copy the content of SRC into DST." + (with-comp-cstr-accessors + (setf (range dst) (range src) + (valset dst) (valset src) + (typeset dst) (typeset src) + (neg dst) (neg src)))) + (defsubst comp-cstr-empty-p (cstr) "Return t if CSTR is equivalent to the nil type specifier or nil otherwise." (with-comp-cstr-accessors @@ -438,10 +446,7 @@ Return them as multiple value." ext-range) ext-range) (neg dst) nil) - (setf (typeset dst) (typeset old-dst) - (valset dst) (valset old-dst) - (range dst) (range old-dst) - (neg dst) (neg old-dst))))) + (comp-cstr-shallow-copy dst old-dst)))) (defmacro comp-cstr-set-range-for-arithm (dst src1 src2 &rest range-body) ;; Prevent some code duplication for `comp-cstr-add-2' @@ -583,10 +588,8 @@ DST is returned." (when (range pos) '(integer))))) (typeset neg))) - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (range pos) - (neg dst) nil) + (comp-cstr-shallow-copy dst pos) + (setf (neg dst) nil) (cl-return-from comp-cstr-union-1-no-mem dst)) ;; Verify disjoint condition between positive types and @@ -633,15 +636,9 @@ DST is returned." (comp-range-negation (range neg)) (range pos)))))) - (if (comp-cstr-empty-p neg) - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (range pos) - (neg dst) nil) - (setf (typeset dst) (typeset neg) - (valset dst) (valset neg) - (range dst) (range neg) - (neg dst) (neg neg))))) + (comp-cstr-shallow-copy dst (if (comp-cstr-empty-p neg) + pos + neg)))) ;; (not null) => t (when (and (neg dst) @@ -665,10 +662,7 @@ DST is returned." (mapcar #'comp-cstr-copy srcs) (apply #'comp-cstr-union-1-no-mem range srcs) mem-h)))) - (setf (typeset dst) (typeset res) - (valset dst) (valset res) - (range dst) (range res) - (neg dst) (neg res)) + (comp-cstr-shallow-copy dst res) res))) (cl-defun comp-cstr-intersection-homogeneous (dst &rest srcs) @@ -755,10 +749,8 @@ Non memoized version of `comp-cstr-intersection-no-mem'." ;; In case pos is not relevant return directly the content ;; of neg. (when (equal (typeset pos) '(t)) - (setf (typeset dst) (typeset neg) - (valset dst) (valset neg) - (range dst) (range neg) - (neg dst) t) + (comp-cstr-shallow-copy dst neg) + (setf (neg dst) t) ;; (not t) => nil (when (and (null (valset dst)) @@ -802,10 +794,8 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (cl-set-difference (valset pos) (valset neg))) ;; Return a non negated form. - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (range pos) - (neg dst) nil))) + (comp-cstr-shallow-copy dst pos) + (setf (neg dst) nil))) dst)))) @@ -885,7 +875,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." "Constraint OP1 being = OP2 setting the result into DST." (with-comp-cstr-accessors (cl-flet ((relax-cstr (cstr) - (setf cstr (comp-cstr-shallow-copy cstr)) + (setf cstr (copy-sequence cstr)) ;; If can be any float extend it to all integers. (when (memq 'float (typeset cstr)) (setf (range cstr) '((- . +)))) @@ -1010,10 +1000,7 @@ DST is returned." (mapcar #'comp-cstr-copy srcs) (apply #'comp-cstr-intersection-no-mem srcs) mem-h)))) - (setf (typeset dst) (typeset res) - (valset dst) (valset res) - (range dst) (range res) - (neg dst) (neg res)) + (comp-cstr-shallow-copy dst res) res))) (defun comp-cstr-intersection-no-hashcons (dst &rest srcs) @@ -1069,10 +1056,9 @@ DST is returned." (valset dst) () (range dst) nil (neg dst) nil)) - (t (setf (typeset dst) (typeset src) - (valset dst) (valset src) - (range dst) (range src) - (neg dst) (not (neg src))))) + (t + (comp-cstr-shallow-copy dst src) + (setf (neg dst) (not (neg src))))) dst)) (defun comp-cstr-value-negation (dst src) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a363bed3642..122638077ce 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1767,6 +1767,7 @@ This is responsible for generating the proper stack adjustment, when known, and the annotation emission." (declare (debug (body)) (indent defun)) + (declare-function comp-body-eff nil (body op-name sp-delta)) `(pcase op ,@(cl-loop for (op . body) in cases for sp-delta = (gethash op comp-op-stack-info) @@ -1945,7 +1946,6 @@ and the annotation emission." (byte-condition-case) ;; Obsolete (byte-temp-output-buffer-setup-OBSOLETE) (byte-temp-output-buffer-show-OBSOLETE) - (byte-unbind-all) ;; Obsolete (byte-set-marker auto) (byte-match-beginning auto) (byte-match-end auto) @@ -3088,13 +3088,6 @@ Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or (`(setimm ,lval ,v) (setf (comp-cstr-imm lval) v)))))) -(defun comp-mvar-propagate (lval rval) - "Propagate into LVAL properties of RVAL." - (setf (comp-mvar-typeset lval) (comp-mvar-typeset rval) - (comp-mvar-valset lval) (comp-mvar-valset rval) - (comp-mvar-range lval) (comp-mvar-range rval) - (comp-mvar-neg lval) (comp-mvar-neg rval))) - (defun comp-function-foldable-p (f args) "Given function F called with ARGS, return non-nil when optimizable." (and (comp-function-pure-p f) @@ -3144,10 +3137,7 @@ Fold the call in case." (when (comp-cstr-empty-p cstr) ;; Store it to be rewritten as non local exit. (setf (comp-block-lap-non-ret-insn comp-block) insn)) - (setf (comp-mvar-range lval) (comp-cstr-range cstr) - (comp-mvar-valset lval) (comp-cstr-valset cstr) - (comp-mvar-typeset lval) (comp-cstr-typeset cstr) - (comp-mvar-neg lval) (comp-cstr-neg cstr)))) + (comp-cstr-shallow-copy lval cstr))) (cl-case f (+ (comp-cstr-add lval args)) (- (comp-cstr-sub lval args)) @@ -3165,9 +3155,9 @@ Fold the call in case." (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) (comp-fwprop-call insn lval f args))) (_ - (comp-mvar-propagate lval rval)))) + (comp-cstr-shallow-copy lval rval)))) (`(assume ,lval ,(and (pred comp-mvar-p) rval)) - (comp-mvar-propagate lval rval)) + (comp-cstr-shallow-copy lval rval)) (`(assume ,lval (,kind . ,operands)) (cl-case kind (and @@ -3580,7 +3570,7 @@ Update all insn accordingly." ;; Symbols imported by C inlined functions. We do this here because ;; is better to add all objs to the relocation containers before we ;; compacting them. - (mapc #'comp-add-const-to-relocs '(nil t consp listp)) + (mapc #'comp-add-const-to-relocs '(nil t consp listp symbol-with-pos-p)) (let* ((d-default (comp-ctxt-d-default comp-ctxt)) (d-default-idx (comp-data-container-idx d-default)) @@ -4016,9 +4006,12 @@ the deferred compilation mechanism." (signal 'native-compiler-error (list "Not a function symbol or file" function-or-file))) (catch 'no-native-compile - (let* ((data function-or-file) + (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) + (symbols-with-pos-enabled t) ;; Have byte compiler signal an error when compilation fails. (byte-compile-debug t) (comp-ctxt (make-comp-ctxt :output output @@ -4062,10 +4055,10 @@ the deferred compilation mechanism." (signal (car err) (if (consp err-val) (cons function-or-file err-val) (list function-or-file err-val))))))) - (if (stringp function-or-file) - data - ;; So we return the compiled function. - (native-elisp-load data))))) + (if (stringp function-or-file) + data + ;; So we return the compiled function. + (native-elisp-load data))))) (defun native-compile-async-skip-p (file load selector) "Return non-nil if FILE's compilation should be skipped. @@ -4205,9 +4198,9 @@ last directory in `native-comp-eln-load-path')." if (or (null byte+native-compile) (cl-notany (lambda (re) (string-match re file)) native-comp-bootstrap-deny-list)) - do (comp--native-compile file) + collect (comp--native-compile file) else - do (byte-compile-file file)))) + collect (byte-compile-file file)))) ;;;###autoload (defun batch-byte+native-compile () @@ -4221,12 +4214,20 @@ variable 'NATIVE_DISABLED' is set, only byte compile." (if (equal (getenv "NATIVE_DISABLED") "1") (batch-byte-compile) (cl-assert (length= command-line-args-left 1)) - (let ((byte+native-compile t) - (byte-to-native-output-file nil)) - (batch-native-compile) - (pcase byte-to-native-output-file - (`(,tempfile . ,target-file) - (rename-file tempfile target-file t)))))) + (let* ((byte+native-compile t) + (byte-to-native-output-buffer-file nil) + (eln-file (car (batch-native-compile)))) + (pcase byte-to-native-output-buffer-file + (`(,temp-buffer . ,target-file) + (unwind-protect + (progn + (byte-write-target-file temp-buffer target-file) + ;; Touch the .eln in order to have it older than the + ;; corresponding .elc. + (when (stringp eln-file) + (set-file-times eln-file))) + (kill-buffer temp-buffer)))) + (setq command-line-args-left (cdr command-line-args-left))))) ;;;###autoload (defun native-compile-async (files &optional recursively load selector) diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index 6b600977823..e5087672ae7 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -313,7 +313,7 @@ independently replaces consecutive years with a range." (> prev-year first-year)) (goto-char range-end) (delete-region range-start range-end) - (insert (format "%c%d" sep prev-year)) + (insert (format "-%d" prev-year)) (goto-char p)) (setq first-year year range-start (point))))) diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index 6bc6d217cef..f3e1981732c 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -244,30 +244,29 @@ contents of the minibuffer are \"alice,bob,eve\" and point is between This function returns a list of the strings that were read, with empty strings removed." - (unwind-protect - (progn - (add-hook 'choose-completion-string-functions - 'crm--choose-completion-string) - (let* ((minibuffer-completion-table #'crm--collection-fn) - (minibuffer-completion-predicate predicate) - ;; see completing_read in src/minibuf.c - (minibuffer-completion-confirm - (unless (eq require-match t) require-match)) - (crm-completion-table table) - (map (if require-match - crm-local-must-match-map - crm-local-completion-map)) - ;; If the user enters empty input, `read-from-minibuffer' - ;; returns the empty string, not DEF. - (input (read-from-minibuffer - prompt initial-input map - nil hist def inherit-input-method))) - (when (and def (string-equal input "")) - (setq input (if (consp def) (car def) def))) - ;; Remove empty strings in the list of read strings. - (split-string input crm-separator t))) - (remove-hook 'choose-completion-string-functions - 'crm--choose-completion-string))) + (let* ((map (if require-match + crm-local-must-match-map + crm-local-completion-map)) + input) + (minibuffer-with-setup-hook + (lambda () + (add-hook 'choose-completion-string-functions + 'crm--choose-completion-string nil 'local) + (setq-local minibuffer-completion-table #'crm--collection-fn) + (setq-local minibuffer-completion-predicate predicate) + ;; see completing_read in src/minibuf.c + (setq-local minibuffer-completion-confirm + (unless (eq require-match t) require-match)) + (setq-local crm-completion-table table)) + (setq input (read-from-minibuffer + prompt initial-input map + nil hist def inherit-input-method))) + ;; If the user enters empty input, `read-from-minibuffer' + ;; returns the empty string, not DEF. + (when (and def (string-equal input "")) + (setq input (if (consp def) (car def) def))) + ;; Remove empty strings in the list of read strings. + (split-string input crm-separator t))) ;; testing and debugging ;; (defun crm-init-test-environ () diff --git a/lisp/emacs-lisp/debug-early.el b/lisp/emacs-lisp/debug-early.el new file mode 100644 index 00000000000..85ed5f2176c --- /dev/null +++ b/lisp/emacs-lisp/debug-early.el @@ -0,0 +1,87 @@ +;;; debug-early.el --- Dump a Lisp backtrace without frills -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: Alan Mackenzie <acm@muc.de> +;; Maintainer: emacs-devel@gnu.org +;; Keywords: internal, backtrace, bootstrap. +;; Package: emacs + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file dumps a backtrace on stderr when an error is thrown. It +;; has no dependencies on any Lisp libraries and is thus used for +;; generating backtraces for bugs in the early parts of bootstrapping. +;; It is also always used in batch model. It was introduced in Emacs +;; 29, before which there was no backtrace available during early +;; bootstrap. + +;;; Code: + +(defalias 'debug-early-backtrace + #'(lambda () + "Print a trace of Lisp function calls currently active. +The output stream used is the value of `standard-output'. + +This is a simplified version of the standard `backtrace' +function, intended for use in debugging the early parts +of the build process." + (princ "\n") + (mapbacktrace + #'(lambda (evald func args _flags) + (let ((args args)) + (if evald + (progn + (princ " ") + (prin1 func) + (princ "(")) + (progn + (princ " (") + (setq args (cons func args)))) + (if args + (while (progn + (prin1 (car args)) + (setq args (cdr args))) + (princ " "))) + (princ ")\n")))))) + +(defalias 'debug-early + #'(lambda (&rest args) + "Print an error message with a backtrace of active Lisp function calls. +The output stream used is the value of `standard-output'. + +The Emacs core calls this function after an error has been +signaled, and supplies two ARGS. These are the symbol +`error' (which is ignored) and a cons of the error symbol and the +error data. + +`debug-early' is a simplified version of `debug', and is +available during the early parts of the build process. It is +superseded by `debug' after enough Lisp has been loaded to +support the latter, except in batch mode which always uses +`debug-early'. + +(In versions of Emacs prior to Emacs 29, no backtrace was +available before `debug' was usable.)" + (princ "\nError: ") + (prin1 (car (car (cdr args)))) ; The error symbol. + (princ " ") + (prin1 (cdr (car (cdr args)))) ; The error data. + (debug-early-backtrace))) + +;;; debug-early.el ends here. diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 2d2da41c0d3..46b0306d64f 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -701,7 +701,8 @@ To specify a nil argument interactively, exit with an empty minibuffer." (interactive (list (let ((name (completing-read - "Cancel debug on entry to function (default all functions): " + (format-prompt "Cancel debug on entry to function" + "all functions") (mapcar #'symbol-name (debug--function-list)) nil t))) (when name (unless (string= name "") @@ -804,7 +805,8 @@ To specify a nil argument interactively, exit with an empty minibuffer." (interactive (list (let ((name (completing-read - "Cancel debug on set for variable (default all variables): " + (format-prompt "Cancel debug on set for variable" + "all variables") (mapcar #'symbol-name (debug--variable-list)) nil t))) (when name (unless (string= name "") diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index 72f49bf3baf..8912eb10cc5 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -175,12 +175,7 @@ See Info node `(elisp)Derived Modes' for more details. (declare (debug (&define name symbolp sexp [&optional stringp] [&rest keywordp sexp] def-body)) (doc-string 4) - ;; Ask not what - ;;(indent 3) - ;; can do for you, ask what it can do to others. IOW, the - ;; missing of indentation setting here is the indentation - ;; setting and not an oversight. - ) + (indent defun)) (when (and docstring (not (stringp docstring))) ;; Some trickiness, since what appears to be the docstring may really be diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 1d93fe48014..688c76e0c54 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -198,6 +198,7 @@ INIT-VALUE LIGHTER KEYMAP. \(fn MODE DOC [KEYWORD VAL ... &rest BODY])" (declare (doc-string 2) + (indent defun) (debug (&define name string-or-null-p [&optional [¬ keywordp] sexp &optional [¬ keywordp] sexp @@ -450,7 +451,7 @@ after running the major mode's hook. However, MODE is not turned on if the hook has explicitly disabled it. \(fn GLOBAL-MODE MODE TURN-ON [KEY VALUE]... BODY...)" - (declare (doc-string 2)) + (declare (doc-string 2) (indent defun)) (let* ((global-mode-name (symbol-name global-mode)) (mode-name (symbol-name mode)) (pretty-name (easy-mmode-pretty-mode-name mode)) @@ -695,8 +696,12 @@ Valid keywords and arguments are: (defmacro easy-mmode-defmap (m bs doc &rest args) "Define a constant M whose value is the result of `easy-mmode-define-keymap'. The M, BS, and ARGS arguments are as per that function. DOC is -the constant's documentation." - (declare (indent 1)) +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)) `(defconst ,m (easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args)) ,doc)) @@ -723,7 +728,7 @@ the constant's documentation." (defmacro easy-mmode-defsyntax (st css doc &rest args) "Define variable ST as a syntax-table. CSS contains a list of syntax specifications of the form (CHAR . SYNTAX)." - (declare (indent 1)) + (declare (doc-string 3) (indent 1)) `(progn (autoload 'easy-mmode-define-syntax "easy-mmode") (defconst ,st (easy-mmode-define-syntax ,css ,(cons 'list args)) ,doc))) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 32dc600a1ab..722283b88ff 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -98,7 +98,11 @@ This applies to `eval-defun', `eval-region', `eval-buffer', and You can use the command `edebug-all-defs' to toggle the value of this variable. You may wish to make it local to each buffer with \(make-local-variable \\='edebug-all-defs) in your -`emacs-lisp-mode-hook'." +`emacs-lisp-mode-hook'. + +Note that this user option has no effect unless the edebug +package has been loaded." + :require 'edebug :type 'boolean) ;;;###autoload @@ -2573,6 +2577,13 @@ See `edebug-behavior-alist' for implementations.") ;; Let's at least show a backtrace so the user can figure out ;; which function we're talking about. (debug)) + ;; If we're in a `track-mouse' setting, then any previous mouse + ;; movements will make `input-pending-p' later return true. So + ;; discard the inputs in that case. (And `discard-input' doesn't + ;; work here.) + (when track-mouse + (while (input-pending-p) + (read-event))) ;; Setup windows for edebug, determine mode, maybe enter recursive-edit. ;; Uses local variables of edebug-enter, edebug-before, edebug-after ;; and edebug-debugger. @@ -3519,7 +3530,8 @@ The removes the effect of `edebug-on-entry'. If FUNCTION is nil, remove `edebug-on-entry' on all functions." (interactive (list (let ((name (completing-read - "Cancel edebug on entry to (default all functions): " + (format-prompt "Cancel edebug on entry to" + "all functions") (let ((functions (edebug--edebug-on-entry-functions))) (unless functions (user-error "No functions have `edebug-on-entry'")) @@ -4548,7 +4560,8 @@ instrumentation for, defaulting to all functions." (user-error "Found no functions to remove instrumentation from")) (let ((name (completing-read - "Remove instrumentation from (default all functions): " + (format-prompt "Remove instrumentation from" + "all functions") functions))) (if (and name (not (equal name ""))) diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el deleted file mode 100644 index 553b84af4fc..00000000000 --- a/lisp/emacs-lisp/eieio-compat.el +++ /dev/null @@ -1,275 +0,0 @@ -;;; eieio-compat.el --- Compatibility with Older EIEIO versions -*- lexical-binding:t -*- - -;; Copyright (C) 1995-1996, 1998-2022 Free Software Foundation, Inc. - -;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Keywords: OO, lisp -;; Package: eieio - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Backward compatibility definition of old EIEIO functions in -;; terms of newer equivalent. - -;; The main elements are the old EIEIO `defmethod' and `defgeneric' which are -;; now implemented on top of cl-generic. The differences we have to -;; accommodate are: -;; - EIEIO's :static methods (turned into a new `eieio--static' specializer). -;; - EIEIO's support for `call-next-method' and `next-method-p' instead of -;; `cl-next-method-p' and `cl-call-next-method' (simple matter of renaming). -;; - Different errors are signaled. -;; - EIEIO's defgeneric does not reset the function. -;; - EIEIO's no-next-method and no-applicable-method can't be aliases of -;; cl-generic's namesakes since they have different calling conventions, -;; which means that packages that (defmethod no-next-method ..) don't work. -;; - EIEIO's `call-next-method' and `next-method-p' had dynamic scope whereas -;; cl-generic's `cl-next-method-p' and `cl-call-next-method' are lexically -;; scoped. - -;;; Code: - -(require 'eieio-core) -(require 'cl-generic) - -(put 'eieio--defalias 'byte-hunk-handler - #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) -;;;###autoload -(defun eieio--defalias (name body) - "Like `defalias', but with less side-effects. -More specifically, it has no side-effects at all when the new function -definition is the same (`eq') as the old one." - (cl-assert (not (symbolp body))) - (while (and (fboundp name) (symbolp (symbol-function name))) - ;; Follow aliases, so methods applied to obsolete aliases still work. - (setq name (symbol-function name))) - (unless (and (fboundp name) - (eq (symbol-function name) body)) - (defalias name body))) - -;;;###autoload -(defmacro defgeneric (method args &optional doc-string) - "Create a generic function METHOD. -DOC-STRING is the base documentation for this class. A generic -function has no body, as its purpose is to decide which method body -is appropriate to use. Uses `defmethod' to create methods, and calls -`defgeneric' for you. With this implementation the ARGS are -currently ignored. You can use `defgeneric' to apply specialized -top level documentation to a method." - (declare (doc-string 3) (obsolete cl-defgeneric "25.1")) - `(eieio--defalias ',method - (eieio--defgeneric-init-form - ',method - ,(if doc-string (help-add-fundoc-usage doc-string args))))) - -;;;###autoload -(defmacro defmethod (method &rest args) - "Create a new METHOD through `defgeneric' with ARGS. - -The optional second argument KEY is a specifier that -modifies how the method is called, including: - :before - Method will be called before the :primary - :primary - The default if not specified - :after - Method will be called after the :primary - :static - First arg could be an object or class -The next argument is the ARGLIST. The ARGLIST specifies the arguments -to the method as with `defun'. The first argument can have a type -specifier, such as: - ((VARNAME CLASS) ARG2 ...) -where VARNAME is the name of the local variable for the method being -created. The CLASS is a class symbol for a class made with `defclass'. -A DOCSTRING comes after the ARGLIST, and is optional. -All the rest of the args are the BODY of the method. A method will -return the value of the last form in the BODY. - -Summary: - - (defmethod mymethod [:before | :primary | :after | :static] - ((typearg class-name) arg2 &optional opt &rest rest) - \"doc-string\" - body)" - (declare (doc-string 3) (obsolete cl-defmethod "25.1") - (debug - (&define ; this means we are defining something - [&name sexp] ;Allow (setf ...) additionally to symbols. - ;; ^^ This is the methods symbol - [ &optional symbolp ] ; this is key :before etc - cl-generic-method-args ; arguments - [ &optional stringp ] ; documentation string - def-body ; part to be debugged - ))) - (let* ((key (if (keywordp (car args)) (pop args))) - (params (car args)) - (arg1 (car params)) - (fargs (if (consp arg1) - (cons (car arg1) (cdr params)) - params)) - (class (if (consp arg1) (nth 1 arg1))) - (code `(lambda ,fargs ,@(cdr args)))) - `(progn - ;; Make sure there is a generic and the byte-compiler sees it. - (defgeneric ,method ,args) - (eieio--defmethod ',method ',key ',class #',code)))) - -(defun eieio--generic-static-symbol-specializers (tag &rest _) - (cl-assert (or (null tag) (eieio--class-p tag))) - (when (eieio--class-p tag) - (let ((superclasses (eieio--generic-subclass-specializers tag)) - (specializers ())) - (dolist (superclass superclasses) - (push superclass specializers) - (push `(eieio--static ,(cadr superclass)) specializers)) - (nreverse specializers)))) - -(cl-generic-define-generalizer eieio--generic-static-symbol-generalizer - ;; Give it a slightly higher priority than `subclass' so that the - ;; interleaved list comes before subclass's non-interleaved list. - 61 (lambda (name &rest _) `(and (symbolp ,name) (cl--find-class ,name))) - #'eieio--generic-static-symbol-specializers) -(cl-generic-define-generalizer eieio--generic-static-object-generalizer - ;; Give it a slightly higher priority than `class' so that the - ;; interleaved list comes before the class's non-interleaved list. - 51 #'cl--generic-struct-tag - (lambda (tag &rest _) - (and (symbolp tag) (setq tag (cl--find-class tag)) - (eieio--class-p tag) - (let ((superclasses (eieio--class-precedence-list tag)) - (specializers ())) - (dolist (superclass superclasses) - (setq superclass (eieio--class-name superclass)) - (push superclass specializers) - (push `(eieio--static ,superclass) specializers)) - (nreverse specializers))))) - -(cl-defmethod cl-generic-generalizers ((_specializer (head eieio--static))) - (list eieio--generic-static-symbol-generalizer - eieio--generic-static-object-generalizer)) - -;;;###autoload -(defun eieio--defgeneric-init-form (method doc-string) - (if doc-string (put method 'function-documentation doc-string)) - (if (memq method '(no-next-method no-applicable-method)) - (symbol-function method) - (let ((generic (cl-generic-ensure-function method))) - (or (symbol-function (cl--generic-name generic)) - (cl--generic-make-function generic))))) - -;;;###autoload -(defun eieio--defmethod (method kind argclass code) - (setq kind (intern (downcase (symbol-name kind)))) - (let* ((specializer (if (not (eq kind :static)) - (or argclass t) - (setq kind nil) - `(eieio--static ,argclass))) - (uses-cnm (not (memq kind '(:before :after)))) - (specializers `((arg ,specializer))) - (code - ;; Backward compatibility for `no-next-method' and - ;; `no-applicable-method', which have slightly different calling - ;; convention than their cl-generic counterpart. - (pcase method - ('no-next-method - (setq method 'cl-no-next-method) - (setq specializers `(generic method ,@specializers)) - (lambda (_generic _method &rest args) (apply code args))) - ('no-applicable-method - (setq method 'cl-no-applicable-method) - (setq specializers `(generic ,@specializers)) - (lambda (generic arg &rest args) - (apply code arg (cl--generic-name generic) (cons arg args)))) - (_ code)))) - (cl-generic-define-method - method (unless (memq kind '(nil :primary)) (list kind)) - specializers uses-cnm - (if uses-cnm - (let* ((docstring (documentation code 'raw)) - (args (help-function-arglist code 'preserve-names)) - (doc-only (if docstring - (let ((split (help-split-fundoc docstring nil))) - (if split (cdr split) docstring))))) - (lambda (cnm &rest args) - (:documentation - (help-add-fundoc-usage doc-only (cons 'cl-cnm args))) - (cl-letf (((symbol-function 'call-next-method) cnm) - ((symbol-function 'next-method-p) - (lambda () (cl--generic-isnot-nnm-p cnm)))) - (apply code args)))) - code)) - ;; The old EIEIO code did not signal an error when there are methods - ;; applicable but only of the before/after kind. So if we add a :before - ;; or :after, make sure there's a matching dummy primary. - (when (and (memq kind '(:before :after)) - ;; FIXME: Use `cl-find-method'? - (not (cl-find-method method () - (mapcar (lambda (arg) - (if (consp arg) (nth 1 arg) t)) - specializers)))) - (cl-generic-define-method method () specializers t - (lambda (cnm &rest args) - (if (cl--generic-isnot-nnm-p cnm) - (apply cnm args))))) - method)) - -;; Compatibility with code which tries to catch `no-method-definition' errors. -(push 'no-method-definition (get 'cl-no-applicable-method 'error-conditions)) - -(defun generic-p (fname) (not (null (cl--generic fname)))) - -(defun no-next-method (&rest args) - (declare (obsolete cl-no-next-method "25.1")) - (apply #'cl-no-next-method 'unknown nil args)) - -(defun no-applicable-method (object method &rest args) - (declare (obsolete cl-no-applicable-method "25.1")) - (apply #'cl-no-applicable-method method object args)) - -(define-obsolete-function-alias 'call-next-method 'cl-call-next-method "25.1") -(defun next-method-p () - (declare (obsolete cl-next-method-p "25.1")) - ;; EIEIO's `next-method-p' just returned nil when called in an - ;; invalid context. - (message "next-method-p called outside of a primary or around method") - nil) - -;;;###autoload -(defun eieio-defmethod (method args) - "Obsolete work part of an old version of the `defmethod' macro." - (declare (obsolete cl-defmethod "24.1")) - (eval `(defmethod ,method ,@args)) - method) - -;;;###autoload -(defun eieio-defgeneric (method doc-string) - "Obsolete work part of an old version of the `defgeneric' macro." - (declare (obsolete cl-defgeneric "24.1")) - (eval `(defgeneric ,method (x) ,@(if doc-string `(,doc-string)))) - ;; Return the method - 'method) - -;;;###autoload -(defun eieio-defclass (cname superclasses slots options) - (declare (obsolete eieio-defclass-internal "25.1")) - (eval `(defclass ,cname ,superclasses ,slots ,@options))) - - -;; Local Variables: -;; generated-autoload-file: "eieio-loaddefs.el" -;; End: - -(provide 'eieio-compat) - -;;; eieio-compat.el ends here diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 196747d71a7..19aa20fa086 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -215,7 +215,7 @@ It creates an autoload function for CNAME's constructor." (when eieio-backward-compatibility (set cname cname) (make-obsolete-variable cname (format "\ -use \\='%s or turn off `eieio-backward-compatibility' instead" cname) +use '%s or turn off `eieio-backward-compatibility' instead" cname) "25.1")) (setf (cl--find-class cname) newc) @@ -340,7 +340,7 @@ See `defclass' for more information." ;; turn this into a usable self-pointing symbol; FIXME: Why? (when eieio-backward-compatibility (set cname cname) - (make-obsolete-variable cname (format "use \\='%s instead" cname) + (make-obsolete-variable cname (format "use '%s instead" cname) "25.1")) ;; Create a handy list of the class test too @@ -362,7 +362,7 @@ See `defclass' for more information." (setq obj (cdr obj))) ans)))) (make-obsolete csym (format - "use (cl-typep ... \\='(list-of %s)) instead" + "use (cl-typep ... '(list-of %s)) instead" cname) "25.1"))) @@ -420,7 +420,7 @@ See `defclass' for more information." (progn (set initarg initarg) (make-obsolete-variable - initarg (format "use \\='%s instead" initarg) "25.1")))) + initarg (format "use '%s instead" initarg) "25.1")))) ;; The customgroup should be a list of symbols. (cond ((and (null customg) custom) @@ -450,7 +450,7 @@ See `defclass' for more information." )) ;; Now that everything has been loaded up, all our lists are backwards! - ;; Fix that up now and then them into vectors. + ;; Fix that up now and turn them into vectors. (cl-callf (lambda (slots) (apply #'vector (nreverse slots))) (eieio--class-slots newc)) (cl-callf nreverse (eieio--class-initarg-tuples newc)) @@ -478,7 +478,8 @@ See `defclass' for more information." ;; (dotimes (cnt (length cslots)) ;; (setf (gethash (cl--slot-descriptor-name (aref cslots cnt)) oa) (- -1 cnt))) (dotimes (cnt (length slots)) - (setf (gethash (cl--slot-descriptor-name (aref slots cnt)) oa) cnt)) + (setf (gethash (cl--slot-descriptor-name (aref slots cnt)) oa) + (+ (eval-when-compile eieio--object-num-slots) cnt))) (setf (eieio--class-index-table newc) oa)) ;; Set up a specialized doc string. @@ -508,6 +509,7 @@ See `defclass' for more information." ;; Create the cached default object. (let ((cache (make-record newc (+ (length (eieio--class-slots newc)) + ;; FIXME: Why +1 -1 ? (eval-when-compile eieio--object-num-slots) -1) nil))) @@ -702,11 +704,15 @@ an error." nil ;; Trim off object IDX junk added in for the object index. (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots))) - (let ((st (cl--slot-descriptor-type (aref (eieio--class-slots class) - slot-idx)))) - (if (not (eieio--perform-slot-validation st value)) - (signal 'invalid-slot-type - (list (eieio--class-name class) slot st value)))))) + (let* ((sd (aref (eieio--class-slots class) + slot-idx)) + (st (cl--slot-descriptor-type sd))) + (cond + ((not (eieio--perform-slot-validation st value)) + (signal 'invalid-slot-type + (list (eieio--class-name class) slot st value))) + ((alist-get :read-only (cl--slot-descriptor-props sd)) + (signal 'eieio-read-only (list (eieio--class-name class) slot))))))) (defun eieio--validate-class-slot-value (class slot-idx value slot) "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. @@ -743,11 +749,11 @@ Argument FN is the function calling this verifier." (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return (format-message "Unknown slot `%S'" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) (_ exp)))) (gv-setter eieio-oset)) (cl-check-type slot symbol) - (cl-check-type obj (or eieio-object class)) + (cl-check-type obj (or eieio-object class cl-structure-object)) (let* ((class (cond ((symbolp obj) (error "eieio-oref called on a class: %s" obj) (eieio--full-class-object obj)) @@ -763,7 +769,7 @@ Argument FN is the function calling this verifier." ;; to intercept missing slot definitions. Since it is also the LAST ;; thing called in this fn, its return value would be retrieved. (slot-missing obj slot 'oref)) - (cl-check-type obj eieio-object) + (cl-check-type obj (or eieio-object cl-structure-object)) (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) @@ -779,12 +785,12 @@ Fills in CLASS's SLOT with its default value." (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return (format-message "Unknown slot `%S'" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-class-slot-names)))) (macroexp-warn-and-return (format-message "Slot `%S' is not class-allocated" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) (_ exp))))) (cl-check-type class (or eieio-object class)) (cl-check-type slot symbol) @@ -811,7 +817,7 @@ Fills in CLASS's SLOT with its default value." (defun eieio-oset (obj slot value) "Do the work for the macro `oset'. Fills in OBJ's SLOT with VALUE." - (cl-check-type obj eieio-object) + (cl-check-type obj (or eieio-object cl-structure-object)) (cl-check-type slot symbol) (let* ((class (eieio--object-class obj)) (c (eieio--slot-name-index class slot))) @@ -841,12 +847,12 @@ Fills in the default value in CLASS' in SLOT with VALUE." (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return (format-message "Unknown slot `%S'" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-class-slot-names)))) (macroexp-warn-and-return (format-message "Slot `%S' is not class-allocated" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) (_ exp))))) (setq class (eieio--class-object class)) (cl-check-type class eieio--class) @@ -892,7 +898,7 @@ reverse-lookup that name, and recurse with the associated slot value." ;; Removed checks to outside this call (let* ((fsi (gethash slot (eieio--class-index-table class)))) (if (integerp fsi) - (+ (eval-when-compile eieio--object-num-slots) fsi) + fsi (let ((fn (eieio--initarg-to-attribute class slot))) (if fn ;; Accessing a slot via its :initarg is accepted by EIEIO @@ -1061,6 +1067,7 @@ method invocation orders of the involved classes." ;; (define-error 'invalid-slot-name "Invalid slot name") (define-error 'invalid-slot-type "Invalid slot type") +(define-error 'eieio-read-only "Read-only slot") (define-error 'unbound-slot "Unbound slot") (define-error 'inconsistent-class-hierarchy "Inconsistent class hierarchy") diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index c7e7384144c..72108f807f9 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -130,6 +130,7 @@ are not abstract." ;;;###autoload (defun eieio-help-constructor (ctr) "Describe CTR if it is a class constructor." + (declare (obsolete "use `describe-function' or `cl--describe-class'." "29.1")) (when (class-p ctr) (erase-buffer) (let ((location (find-lisp-object-file-name ctr 'define-type)) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 3b633e4fa36..1315ca0c627 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -110,7 +110,7 @@ Options in CLOS not supported in EIEIO: Due to the way class options are set up, you can add any tags you wish, and reference them using the function `class-option'." - (declare (doc-string 4)) + (declare (doc-string 4) (indent defun)) (cl-check-type superclasses list) (cond ((and (stringp (car options-and-doc)) @@ -181,9 +181,11 @@ and reference them using the function `class-option'." ;; Is there an initarg, but allocation of class? (when (and initarg (eq alloc :class)) - (push (format "Meaningless :initarg for class allocated slot '%S'" - sname) - warnings)) + (push + (cons sname + (format "Meaningless :initarg for class allocated slot '%S'" + sname)) + warnings)) (let ((init (plist-get soptions :initform))) (unless (or (macroexp-const-p init) @@ -194,8 +196,9 @@ and reference them using the function `class-option'." ;; heuristic says and if it disagrees with normal evaluation ;; then tweak the initform to make it fit and emit ;; a warning accordingly. - (push (format "Ambiguous initform needs quoting: %S" init) - warnings))) + (push + (cons init (format "Ambiguous initform needs quoting: %S" init)) + warnings))) ;; Anyone can have an accessor function. This creates a function ;; of the specified name, and also performs a `defsetf' if applicable @@ -242,7 +245,8 @@ This method is obsolete." `(progn ,@(mapcar (lambda (w) - (macroexp-warn-and-return w `(progn ',w) nil 'compile-only)) + (macroexp-warn-and-return + (cdr w) `(progn ',(cdr w)) nil 'compile-only (car w))) warnings) ;; This test must be created right away so we can have self- ;; referencing classes. ei, a class whose slot can contain only @@ -256,7 +260,7 @@ This method is obsolete." (let ((f (intern (format "%s-child-p" name)))) `((defalias ',f #',testsym2) (make-obsolete - ',f ,(format "use (cl-typep ... \\='%s) instead" name) + ',f ,(format "use (cl-typep ... '%s) instead" name) "25.1")))) ;; When using typep, (typep OBJ 'myclass) returns t for objects which @@ -297,7 +301,8 @@ This method is obsolete." ;; Keep the name arg, for backward compatibility, ;; but hide it so we don't trigger indefinitely. `(,(car whole) (identity ,(car slots)) - ,@(cdr slots))))))) + ,@(cdr slots)) + nil nil (car slots)))))) (apply #'make-instance ',name slots)))))) @@ -359,9 +364,7 @@ variable name of the same name as the slot." (defun eieio-pcase-slot-index-from-index-table (index-table slot) "Find the index to pass to `aref' to access SLOT." - (let ((index (gethash slot index-table))) - (if index (+ (eval-when-compile eieio--object-num-slots) - index)))) + (gethash slot index-table)) (pcase-defmacro eieio (&rest fields) "Pcase patterns that match EIEIO object EXPVAL. @@ -994,11 +997,6 @@ of `eq'." (error "EIEIO: `change-class' is unimplemented")) (define-obsolete-function-alias 'change-class #'eieio-change-class "26.1") -;; Hook ourselves into help system for describing classes and methods. -;; FIXME: This is not actually needed any more since we can click on the -;; hyperlink from the constructor's docstring to see the type definition. -(add-hook 'help-fns-describe-function-functions #'eieio-help-constructor) - (provide 'eieio) ;;; eieio.el ends here diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 5300b0594d2..73713a3dec9 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -380,7 +380,19 @@ Also store it in `eldoc-last-message' and return that value." ;; it undesirable to print eldoc messages right this instant. (defun eldoc-display-message-no-interference-p () "Return nil if displaying a message would cause interference." - (not (or executing-kbd-macro (bound-and-true-p edebug-active)))) + (not (or executing-kbd-macro + (bound-and-true-p edebug-active) + ;; The following configuration shows "Matches..." in the + ;; echo area when point is after a closing bracket, which + ;; conflicts with eldoc. + (and (boundp 'show-paren-context-when-offscreen) + show-paren-context-when-offscreen + ;; There's no conflict with the child-frame and + ;; overlay versions. + (not (memq show-paren-context-when-offscreen + '(child-frame overlay))) + (not (pos-visible-in-window-p + (overlay-end show-paren--overlay))))))) (defvar eldoc-documentation-functions nil diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index 4b20e8f756c..385ddb3f414 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -202,14 +202,13 @@ This variable is set by the master function.") (defvar elp-not-profilable ;; First, the functions used inside each instrumented function: '(called-interactively-p - ;; Then the functions used by the above functions. I used - ;; (delq nil (mapcar (lambda (x) (and (symbolp x) (fboundp x) x)) - ;; (aref (symbol-function 'elp-wrapper) 2))) - ;; to help me find this list. - error call-interactively apply current-time + ;; (delq + ;; nil (mapcar + ;; (lambda (x) (and (symbolp x) (fboundp x) x)) + ;; (aref (aref (aref (symbol-function 'elp--make-wrapper) 2) 1) 2))) + error apply current-time float-time time-subtract ;; Andreas Politz reports problems profiling these (Bug#4233): - + byte-code-function-p functionp byte-code subrp - indirect-function fboundp) + + byte-code-function-p functionp byte-code subrp fboundp) "List of functions that cannot be profiled. Those functions are used internally by the profiling code and profiling them would thus lead to infinite recursion.") @@ -288,7 +287,12 @@ type \"nil\" to use `elp-function-list'." "Instrument for profiling, all functions which start with PREFIX. For example, to instrument all ELP functions, do the following: - \\[elp-instrument-package] RET elp- RET" + \\[elp-instrument-package] RET elp- RET + +Note that only functions that are currently loaded will be +instrumented. If you run this function, and then later load +further functions that start with PREFIX, they will not be +instrumented automatically." (interactive (list (completing-read "Prefix of package to instrument: " obarray 'elp-profilable-p))) @@ -299,10 +303,18 @@ For example, to instrument all ELP functions, do the following: 'intern (all-completions prefix obarray 'elp-profilable-p)))) +(defun elp-restore-package (prefix) + "Remove instrumentation from functions with names starting with PREFIX." + (interactive "SPrefix: ") + (elp-restore-list + (mapcar #'intern + (all-completions (symbol-name prefix) + obarray 'elp-profilable-p)))) + (defun elp-restore-list (&optional list) "Restore the original definitions for all functions in `elp-function-list'. Use optional LIST if provided instead." - (interactive "PList of functions to restore: ") ;FIXME: Doesn't work!? + (interactive) (mapcar #'elp-restore-function (or list elp-function-list))) (defun elp-restore-all () @@ -324,7 +336,7 @@ Use optional LIST if provided instead." (defun elp-reset-list (&optional list) "Reset the profiling information for all functions in `elp-function-list'. Use optional LIST if provided instead." - (interactive "PList of functions to reset: ") ;FIXME: Doesn't work!? + (interactive) (let ((list (or list elp-function-list))) (mapcar 'elp-reset-function list))) diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 17967ae2bfc..0e412a8d34e 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -352,7 +352,6 @@ convert it to a string and pass it to COLLECTOR first." (defvar ert-resource-directory-trim-right-regexp "\\(-tests?\\)?\\.el" "Regexp for `string-trim' (right) used by `ert-resource-directory'.") -;; Has to be a macro for `load-file-name'. (defmacro ert-resource-directory () "Return absolute file name of the resource (test data) directory. @@ -368,17 +367,17 @@ variable `ert-resource-directory-format'. Before formatting, the file name will be trimmed using `string-trim' with arguments `ert-resource-directory-trim-left-regexp' and `ert-resource-directory-trim-right-regexp'." - `(let* ((testfile ,(or (macroexp-file-name) - buffer-file-name)) - (default-directory (file-name-directory testfile))) - (file-truename - (if (file-accessible-directory-p "resources/") - (expand-file-name "resources/") - (expand-file-name - (format ert-resource-directory-format - (string-trim testfile - ert-resource-directory-trim-left-regexp - ert-resource-directory-trim-right-regexp))))))) + `(when-let ((testfile ,(or (macroexp-file-name) + buffer-file-name))) + (let ((default-directory (file-name-directory testfile))) + (file-truename + (if (file-accessible-directory-p "resources/") + (expand-file-name "resources/") + (expand-file-name + (format ert-resource-directory-format + (string-trim testfile + ert-resource-directory-trim-left-regexp + ert-resource-directory-trim-right-regexp)))))))) (defmacro ert-resource-file (file) "Return absolute file name of resource (test data) file named FILE. @@ -386,6 +385,104 @@ A resource file is defined as any file placed in the resource directory as returned by `ert-resource-directory'." `(expand-file-name ,file (ert-resource-directory))) +(defvar ert-temp-file-prefix "emacs-test-" + "Prefix used by `ert-with-temp-file' and `ert-with-temp-directory'.") + +(defvar ert-temp-file-suffix nil + "Suffix used by `ert-with-temp-file' and `ert-with-temp-directory'.") + +(defun ert--with-temp-file-generate-suffix (filename) + "Generate temp file suffix from FILENAME." + (thread-last + (file-name-base filename) + (replace-regexp-in-string (rx string-start + (group (+? not-newline)) + (regexp "-?tests?") + string-end) + "\\1") + (concat "-"))) + +(defmacro ert-with-temp-file (name &rest body) + "Bind NAME to the name of a new temporary file and evaluate BODY. +Delete the temporary file after BODY exits normally or +non-locally. NAME will be bound to the file name of the temporary +file. + +The following keyword arguments are supported: + +:prefix STRING If non-nil, pass STRING to `make-temp-file' as + the PREFIX argument. Otherwise, use the value of + `ert-temp-file-prefix'. + +:suffix STRING If non-nil, pass STRING to `make-temp-file' as the + SUFFIX argument. Otherwise, use the value of + `ert-temp-file-suffix'; if the value of that + variable is nil, generate a suffix based on the + name of the file that `ert-with-temp-file' is + called from. + +:text STRING If non-nil, pass STRING to `make-temp-file' as + the TEXT argument. + +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) + (while (keywordp (setq keyw (car body))) + (setq body (cdr body)) + (pcase keyw + (:prefix (setq prefix (pop body))) + (:suffix (setq suffix (pop body))) + (:directory (setq directory (pop body))) + (:text (setq text (pop body))) + (_ (push keyw extra-keywords) (pop body)))) + (when extra-keywords + (error "Invalid keywords: %s" (mapconcat #'symbol-name extra-keywords " "))) + (let ((temp-file (make-symbol "temp-file")) + (prefix (or prefix ert-temp-file-prefix)) + (suffix (or suffix ert-temp-file-suffix + (ert--with-temp-file-generate-suffix + (or (macroexp-file-name) buffer-file-name))))) + `(let* ((,temp-file (,(if directory 'file-name-as-directory 'identity) + (make-temp-file ,prefix ,directory ,suffix ,text))) + (,name ,(if directory + `(file-name-as-directory ,temp-file) + temp-file))) + (unwind-protect + (progn ,@body) + (ignore-errors + ,(if directory + `(delete-directory ,temp-file :recursive) + `(delete-file ,temp-file)))))))) + +(defmacro ert-with-temp-directory (name &rest body) + "Bind NAME to the name of a new temporary directory and evaluate BODY. +Delete the temporary directory after BODY exits normally or +non-locally. + +NAME is bound to the directory name, not the directory file +name. (In other words, it will end with the directory delimiter; +on Unix-like systems, it will end with \"/\".) + +The same keyword arguments are supported as in +`ert-with-temp-file' (which see), except for :text." + (declare (indent 1) (debug (symbolp body))) + (let ((tail body) keyw) + (while (keywordp (setq keyw (car tail))) + (setq tail (cddr tail)) + (pcase keyw (:text (error "Invalid keyword for directory: :text"))))) + `(ert-with-temp-file ,name + :directory t + ,@body)) + +(defun ert-gcc-is-clang-p () + "Return non-nil if the `gcc' command actually runs the Clang compiler." + ;; Some macOS machines run llvm when you type gcc. (!) + ;; We can't even check if it's a symlink; it's a binary placed in + ;; "/usr/bin/gcc". So we need to check the output. + (string-match "Apple \\(LLVM\\|[Cc]lang\\)\\|Xcode\\.app" + (shell-command-to-string "gcc --version"))) + (provide 'ert-x) ;;; ert-x.el ends here diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 41180f9914a..00da5c718c7 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -39,7 +39,7 @@ ;; but signals a different error when its condition is violated that ;; is caught and processed by ERT. In addition, it analyzes its ;; argument form and records information that helps debugging -;; (`assert' tries to do something similar when its second argument +;; (`cl-assert' tries to do something similar when its second argument ;; SHOW-ARGS is true, but `should' is more sophisticated). For ;; information on `should-not' and `should-error', see their ;; docstrings. `skip-unless' skips the test immediately without @@ -63,6 +63,9 @@ (require 'ewoc) (require 'find-func) (require 'pp) +(require 'map) + +(autoload 'xml-escape-string "xml.el") ;;; UI customization options. @@ -76,6 +79,35 @@ Use nil for no limit (caution: backtrace lines can be very long)." :type '(choice (const :tag "No truncation" nil) integer)) +(defvar ert-batch-print-length 10 + "`print-length' setting used in `ert-run-tests-batch'. + +When formatting lists in test conditions, `print-length' will be +temporarily set to this value. See also +`ert-batch-backtrace-line-length' for its effect on stack +traces.") + +(defvar ert-batch-print-level 5 + "`print-level' setting used in `ert-run-tests-batch'. + +When formatting lists in test conditions, `print-level' will be +temporarily set to this value. See also +`ert-batch-backtrace-line-length' for its effect on stack +traces.") + +(defvar ert-batch-backtrace-line-length t + "Target length for lines in ERT batch backtraces. + +Even modest settings for `print-length' and `print-level' can +produce extremely long lines in backtraces and lengthy delays in +forming them. This variable governs the target maximum line +length by manipulating these two variables while printing stack +traces. Setting this variable to t will re-use the value of +`backtrace-line-length' while printing stack traces in ERT batch +mode. Any other value will be temporarily bound to +`backtrace-line-length' when producing stack traces in batch +mode.") + (defface ert-test-result-expected '((((class color) (background light)) :background "green1") (((class color) (background dark)) @@ -88,23 +120,6 @@ Use nil for no limit (caution: backtrace lines can be very long)." :background "red3")) "Face used for unexpected results in the ERT results buffer.") - -;;; Copies/reimplementations of cl functions. - -(defun ert-equal-including-properties (a b) - "Return t if A and B have similar structure and contents. - -This is like `equal-including-properties' except that it compares -the property values of text properties structurally (by -recursing) rather than with `eq'. Perhaps this is what -`equal-including-properties' should do in the first place; see -Emacs bug 6581 at URL `https://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." - ;; This implementation is inefficient. Rather than making it - ;; efficient, let's hope bug 6581 gets fixed so that we can delete - ;; it altogether. - (not (ert--explain-equal-including-properties a b))) - - ;;; Defining and locating tests. ;; The data structure that represents a test case. @@ -114,7 +129,8 @@ Emacs bug 6581 at URL `https://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." (body (cl-assert nil)) (most-recent-result nil) (expected-result-type ':passed) - (tags '())) + (tags '()) + (file-name nil)) (defun ert-test-boundp (symbol) "Return non-nil if SYMBOL names a test." @@ -136,6 +152,10 @@ Emacs bug 6581 at URL `https://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." ;; Note that nil is still a valid value for the `name' slot in ;; ert-test objects. It designates an anonymous test. (error "Attempt to define a test named nil")) + (when (and noninteractive (get symbol 'ert--test)) + ;; Make sure duplicated tests are discovered since the older test would + ;; be ignored silently otherwise. + (error "Test `%s' redefined" symbol)) (define-symbol-prop symbol 'ert--test definition) definition) @@ -191,6 +211,9 @@ Macros in BODY are expanded when the test is defined, not when it is run. If a macro (possibly with side effects) is to be tested, it has to be wrapped in `(eval (quote ...))'. +If NAME is already defined as a test and Emacs is running +in batch mode, an error is signalled. + \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ [:tags \\='(TAG...)] BODY...)" (declare (debug (&define [&name "test@" symbolp] @@ -218,11 +241,8 @@ it has to be wrapped in `(eval (quote ...))'. `(:expected-result-type ,expected-result)) ,@(when tags-supplied-p `(:tags ,tags)) - :body (lambda () - ;; Use the value of `lexical-binding' in - ;; the source file when evaluating the body. - (let ((lexical-binding ,lexical-binding)) - ,@body)))) + :body (lambda () ,@body) + :file-name ,(or (macroexp-file-name) buffer-file-name))) ',name)))) (defvar ert--find-test-regexp @@ -231,7 +251,6 @@ it has to be wrapped in `(eval (quote ...))'. "%s\\(\\s-\\|$\\)") "The regexp the `find-function' mechanisms use for finding test definitions.") - (define-error 'ert-test-failed "Test failed") (define-error 'ert-test-skipped "Test skipped") @@ -318,15 +337,20 @@ It should only be stopped when ran from inside `ert--run-test-internal'." (unless (eql ,value ',default-value) (list :value ,value)) (unless (eql ,value ',default-value) - (let ((-explainer- - (and (symbolp ',fn-name) - (get ',fn-name 'ert-explainer)))) - (when -explainer- - (list :explanation - (apply -explainer- ,args)))))) + (when-let ((-explainer- + (ert--get-explainer ',fn-name))) + (list :explanation + (apply -explainer- ,args))))) value) ,value)))))))) +(defun ert--get-explainer (fn-name) + (when (symbolp fn-name) + (cl-loop for fn in (cons fn-name (function-alias-p fn-name)) + for explainer = (get fn 'ert-explainer) + when explainer + return explainer))) + (defun ert--expand-should (whole form inner-expander) "Helper function for the `should' macro and its variants. @@ -469,7 +493,7 @@ Errors during evaluation are caught and handled like nil." (defun ert--explain-equal-rec (a b) "Return a programmer-readable explanation of why A and B are not `equal'. -Returns nil if they are." +Return nil if they are." (if (not (eq (type-of a) (type-of b))) `(different-types ,a ,b) (pcase a @@ -602,14 +626,9 @@ If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix." (t (substring s 0 len))))) -;; TODO(ohler): Once bug 6581 is fixed, rename this to -;; `ert--explain-equal-including-properties-rec' and add a fast-path -;; wrapper like `ert--explain-equal'. -(defun ert--explain-equal-including-properties (a b) - "Explainer function for `ert-equal-including-properties'. - -Returns a programmer-readable explanation of why A and B are not -`ert-equal-including-properties', or nil if they are." +(defun ert--explain-equal-including-properties-rec (a b) + "Return explanation of why A and B are not `equal-including-properties'. +Return nil if they are." (if (not (equal a b)) (ert--explain-equal a b) (cl-assert (stringp a) t) @@ -631,15 +650,17 @@ Returns a programmer-readable explanation of why A and B are not ,(ert--abbreviate-string (substring-no-properties a (1+ i)) 10 nil)))) - ;; TODO(ohler): Get `equal-including-properties' fixed in - ;; Emacs, delete `ert-equal-including-properties', and - ;; re-enable this assertion. - ;;finally (cl-assert (equal-including-properties a b) t) - ))) -(put 'ert-equal-including-properties - 'ert-explainer - 'ert--explain-equal-including-properties) + finally (cl-assert (equal-including-properties a b) t)))) +(defun ert--explain-equal-including-properties (a b) + "Explainer function for `equal-including-properties'." + ;; Do a quick comparison in C to avoid running our expensive + ;; comparison when possible. + (if (equal-including-properties a b) + nil + (ert--explain-equal-including-properties-rec a b))) +(put 'equal-including-properties 'ert-explainer + 'ert--explain-equal-including-properties) ;;; Implementation of `ert-info'. @@ -664,7 +685,6 @@ and is displayed in front of the value of MESSAGE-FORM." ,@body)) - ;;; Facilities for running a single test. (defvar ert-debug-on-error nil @@ -779,7 +799,8 @@ This mainly sets up debugger-related bindings." ;; handle ert errors. Once that's done, remove ;; `ert--should-signal-hook'. See Bug#24402 and Bug#11218 for ;; details. - (let ((debugger (lambda (&rest args) + (let ((lexical-binding t) + (debugger (lambda (&rest args) (ert--run-test-debugger test-execution-info args))) (debug-on-error t) @@ -936,7 +957,8 @@ t -- Selects UNIVERSE. :expected, :unexpected -- Select tests according to their most recent result. a string -- A regular expression selecting all tests with matching names. a test -- (i.e., an object of the ert-test data-type) Selects that test. -a symbol -- Selects the test that the symbol names, errors if none. +a symbol -- Selects the test that the symbol names, signals an + `ert-test-unbound' error if none. \(member TESTS...) -- Selects the elements of TESTS, a list of tests or symbols naming tests. \(eql TEST) -- Selects TEST, a test or a symbol naming a test. @@ -998,52 +1020,47 @@ contained in UNIVERSE." universe)))) ((pred ert-test-p) (list selector)) ((pred symbolp) - (cl-assert (ert-test-boundp selector)) + (unless (ert-test-boundp selector) + (signal 'ert-test-unbound (list selector))) (list (ert-get-test selector))) - (`(,operator . ,operands) - (cl-ecase operator - (member - (mapcar (lambda (purported-test) - (pcase-exhaustive purported-test - ((pred symbolp) - (cl-assert (ert-test-boundp purported-test)) - (ert-get-test purported-test)) - ((pred ert-test-p) purported-test))) - operands)) - (eql - (cl-assert (eql (length operands) 1)) - (ert-select-tests `(member ,@operands) universe)) - (and - ;; Do these definitions of AND, NOT and OR satisfy de - ;; Morgan's laws? Should they? - (cl-case (length operands) - (0 (ert-select-tests 't universe)) - (t (ert-select-tests `(and ,@(cdr operands)) - (ert-select-tests (car operands) - universe))))) - (not - (cl-assert (eql (length operands) 1)) - (let ((all-tests (ert-select-tests 't universe))) - (cl-set-difference all-tests - (ert-select-tests (car operands) - all-tests)))) - (or - (cl-case (length operands) - (0 (ert-select-tests 'nil universe)) - (t (cl-union (ert-select-tests (car operands) universe) - (ert-select-tests `(or ,@(cdr operands)) - universe))))) - (tag - (cl-assert (eql (length operands) 1)) - (let ((tag (car operands))) - (ert-select-tests `(satisfies - ,(lambda (test) - (member tag (ert-test-tags test)))) - universe))) - (satisfies - (cl-assert (eql (length operands) 1)) - (cl-remove-if-not (car operands) - (ert-select-tests 't universe))))))) + (`(member . ,operands) + (mapcar (lambda (purported-test) + (pcase-exhaustive purported-test + ((pred symbolp) + (unless (ert-test-boundp purported-test) + (signal 'ert-test-unbound + (list purported-test))) + (ert-get-test purported-test)) + ((pred ert-test-p) purported-test))) + operands)) + (`(eql ,operand) + (ert-select-tests `(member ,operand) universe)) + ;; Do these definitions of AND, NOT and OR satisfy de Morgan's + ;; laws? Should they? + (`(and) + (ert-select-tests 't universe)) + (`(and ,first . ,rest) + (ert-select-tests `(and ,@rest) + (ert-select-tests first universe))) + (`(not ,operand) + (let ((all-tests (ert-select-tests 't universe))) + (cl-set-difference all-tests + (ert-select-tests operand all-tests)))) + (`(or) + (ert-select-tests 'nil universe)) + (`(or ,first . ,rest) + (cl-union (ert-select-tests first universe) + (ert-select-tests `(or ,@rest) universe))) + (`(tag ,tag) + (ert-select-tests `(satisfies + ,(lambda (test) + (member tag (ert-test-tags test)))) + universe)) + (`(satisfies ,predicate) + (cl-remove-if-not predicate + (ert-select-tests 't universe))))) + +(define-error 'ert-test-unbound "ERT test is unbound") (defun ert--insert-human-readable-selector (selector) "Insert a human-readable presentation of SELECTOR into the current buffer." @@ -1355,6 +1372,22 @@ RESULT must be an `ert-test-result-with-condition'." (defvar ert-quiet nil "Non-nil makes ERT only print important information in batch mode.") +(defun ert-test-location (test) + "Return a string description the source location of TEST." + (when-let ((loc + (ignore-errors + (find-function-search-for-symbol + (ert-test-name test) 'ert-deftest (ert-test-file-name test))))) + (let* ((buffer (car loc)) + (point (cdr loc)) + (file (file-relative-name (buffer-file-name buffer))) + (line (with-current-buffer buffer + (line-number-at-pos point)))) + (format "at %s:%s" file line)))) + +(defvar ert-batch-backtrace-right-margin 70 + "The maximum line length for printing backtraces in `ert-run-tests-batch'.") + ;;;###autoload (defun ert-run-tests-batch (&optional selector) "Run the tests specified by SELECTOR, printing results to the terminal. @@ -1408,7 +1441,8 @@ Returns the stats object." (message "%9s %S%s" (ert-string-for-test-result result nil) (ert-test-name test) - (if (getenv "EMACS_TEST_VERBOSE") + (if (cl-plusp + (length (getenv "EMACS_TEST_VERBOSE"))) (ert-reason-for-test-result result) "")))) (message "%s" "")) @@ -1420,12 +1454,14 @@ Returns the stats object." (message "%9s %S%s" (ert-string-for-test-result result nil) (ert-test-name test) - (if (getenv "EMACS_TEST_VERBOSE") + (if (cl-plusp + (length (getenv "EMACS_TEST_VERBOSE"))) (ert-reason-for-test-result result) "")))) - (message "%s" ""))))) - (test-started - ) + (message "%s" "")) + (when (getenv "EMACS_TEST_JUNIT_REPORT") + (ert-write-junit-test-report stats))))) + (test-started) (test-ended (cl-destructuring-bind (stats test result) event-args (unless (ert-test-result-expected-p test result) @@ -1435,8 +1471,14 @@ Returns the stats object." (ert-test-result-with-condition (message "Test %S backtrace:" (ert-test-name test)) (with-temp-buffer - (insert (backtrace-to-string - (ert-test-result-with-condition-backtrace result))) + (let ((backtrace-line-length + (if (eq ert-batch-backtrace-line-length t) + backtrace-line-length + ert-batch-backtrace-line-length)) + (print-level ert-batch-print-level) + (print-length ert-batch-print-length)) + (insert (backtrace-to-string + (ert-test-result-with-condition-backtrace result)))) (if (not ert-batch-backtrace-right-margin) (message "%s" (buffer-substring-no-properties (point-min) @@ -1455,8 +1497,8 @@ Returns the stats object." (ert--insert-infos result) (insert " ") (let ((print-escape-newlines t) - (print-level 5) - (print-length 10)) + (print-level ert-batch-print-level) + (print-length ert-batch-print-length)) (ert--pp-with-indentation-and-newline (ert-test-result-with-condition-condition result))) (goto-char (1- (point-max))) @@ -1473,14 +1515,17 @@ Returns the stats object." (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) (format-string (concat "%9s %" (prin1-to-string (length max)) - "s/" max " %S (%f sec)"))) + "s/" max " %S (%f sec)%s"))) (message format-string (ert-string-for-test-result result (ert-test-result-expected-p test result)) (1+ (ert--stats-test-pos stats test)) (ert-test-name test) - (ert-test-result-duration result)))))))) + (ert-test-result-duration result) + (if (ert-test-result-expected-p test result) + "" + (concat " " (ert-test-location test)))))))))) nil)) ;;;###autoload @@ -1506,6 +1551,183 @@ the tests)." (backtrace)) (kill-emacs 2)))) +(defvar ert-load-file-name nil + "The name of the loaded ERT test file, a string. +Usually, it is not needed to be defined, but if different ERT +test packages depend on each other, it might be helpful.") + +(defun ert-write-junit-test-report (stats) + "Write a JUnit test report, generated from STATS." + ;; https://www.ibm.com/docs/en/developer-for-zos/14.1.0?topic=formats-junit-xml-format + ;; https://llg.cubic.org/docs/junit/ + (when-let ((symbol (car (apropos-internal "" #'ert-test-boundp))) + (test-file (symbol-file symbol 'ert--test)) + (test-report + (file-name-with-extension + (or ert-load-file-name test-file) "xml"))) + (with-temp-file test-report + (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n") + (insert (format "<testsuites name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\">\n" + (file-name-nondirectory test-report) + (ert-stats-total stats) + (if (ert--stats-aborted-p stats) 1 0) + (ert-stats-completed-unexpected stats) + (ert-stats-skipped stats) + (float-time + (time-subtract + (ert--stats-end-time stats) + (ert--stats-start-time stats))))) + (insert (format " <testsuite id=\"0\" name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\" timestamp=\"%s\">\n" + (file-name-nondirectory test-report) + (ert-stats-total stats) + (if (ert--stats-aborted-p stats) 1 0) + (ert-stats-completed-unexpected stats) + (ert-stats-skipped stats) + (float-time + (time-subtract + (ert--stats-end-time stats) + (ert--stats-start-time stats))) + (ert--format-time-iso8601 (ert--stats-end-time stats)))) + ;; If the test has aborted, `ert--stats-selector' might return + ;; huge junk. Skip this. + (when (< (length (format "%s" (ert--stats-selector stats))) 1024) + (insert " <properties>\n" + (format " <property name=\"selector\" value=\"%s\"/>\n" + (xml-escape-string + (format "%s" (ert--stats-selector stats)) 'noerror)) + " </properties>\n")) + (cl-loop for test across (ert--stats-tests stats) + for result = (ert-test-most-recent-result test) do + (insert (format " <testcase name=\"%s\" status=\"%s\" time=\"%s\"" + (xml-escape-string + (symbol-name (ert-test-name test)) 'noerror) + (ert-string-for-test-result + result + (ert-test-result-expected-p test result)) + (ert-test-result-duration result))) + (if (and (ert-test-result-expected-p test result) + (not (ert-test-aborted-with-non-local-exit-p result)) + (not (ert-test-skipped-p result)) + (zerop (length (ert-test-result-messages result)))) + (insert "/>\n") + (insert ">\n") + (cond + ((ert-test-skipped-p result) + (insert (format " <skipped message=\"%s\" type=\"%s\">\n" + (xml-escape-string + (string-trim + (ert-reason-for-test-result result)) + 'noerror) + (ert-string-for-test-result + result + (ert-test-result-expected-p + test result))) + (xml-escape-string + (string-trim + (ert-reason-for-test-result result)) + 'noerror) + "\n" + " </skipped>\n")) + ((ert-test-aborted-with-non-local-exit-p result) + (insert (format " <error message=\"%s\" type=\"%s\">\n" + (file-name-nondirectory test-report) + (ert-string-for-test-result + result + (ert-test-result-expected-p + test result))) + (format "Test %s aborted with non-local exit\n" + (xml-escape-string + (symbol-name (ert-test-name test)) 'noerror)) + " </error>\n")) + ((not (ert-test-result-type-p + result (ert-test-expected-result-type test))) + (insert (format " <failure message=\"%s\" type=\"%s\">\n" + (xml-escape-string + (string-trim + (ert-reason-for-test-result result)) + 'noerror) + (ert-string-for-test-result + result + (ert-test-result-expected-p + test result))) + (xml-escape-string + (string-trim + (ert-reason-for-test-result result)) + 'noerror) + "\n" + " </failure>\n"))) + (unless (zerop (length (ert-test-result-messages result))) + (insert " <system-out>\n" + (xml-escape-string + (ert-test-result-messages result) 'noerror) + " </system-out>\n")) + (insert " </testcase>\n"))) + (insert " </testsuite>\n") + (insert "</testsuites>\n")))) + +(defun ert-write-junit-test-summary-report (&rest logfiles) + "Write a JUnit summary test report, generated from LOGFILES." + (let ((report (file-name-with-extension + (getenv "EMACS_TEST_JUNIT_REPORT") "xml")) + (tests 0) (errors 0) (failures 0) (skipped 0) (time 0) (id 0)) + (with-temp-file report + (dolist (logfile logfiles) + (let ((test-report (file-name-with-extension logfile "xml"))) + (if (not (file-readable-p test-report)) + (let* ((logfile (file-name-with-extension logfile "log")) + (logfile-contents + (when (file-readable-p logfile) + (with-temp-buffer + (insert-file-contents-literally logfile) + (buffer-string))))) + (unless + ;; No defined tests, perhaps a helper file. + (and logfile-contents + (string-match-p "^Running 0 tests" logfile-contents)) + (insert (format " <testsuite id=\"%s\" name=\"%s\" tests=\"1\" errors=\"1\" failures=\"0\" skipped=\"0\" time=\"0\" timestamp=\"%s\">\n" + id test-report + (ert--format-time-iso8601 (current-time)))) + (insert (format " <testcase name=\"Test report missing %s\" status=\"error\" time=\"0\">\n" + (file-name-nondirectory test-report))) + (insert (format " <error message=\"Test report missing %s\" type=\"error\">\n" + (file-name-nondirectory test-report))) + (when logfile-contents + (insert (xml-escape-string logfile-contents 'noerror))) + (insert " </error>\n" + " </testcase>\n" + " </testsuite>\n") + (cl-incf errors 1) + (cl-incf id 1))) + + (insert-file-contents-literally test-report) + (when (looking-at-p + (regexp-quote "<?xml version=\"1.0\" encoding=\"utf-8\"?>")) + (delete-region (point) (line-beginning-position 2))) + (when (looking-at + "<testsuites name=\".+\" tests=\"\\(.+\\)\" errors=\"\\(.+\\)\" failures=\"\\(.+\\)\" skipped=\"\\(.+\\)\" time=\"\\(.+\\)\">") + (cl-incf tests (string-to-number (match-string 1))) + (cl-incf errors (string-to-number (match-string 2))) + (cl-incf failures (string-to-number (match-string 3))) + (cl-incf skipped (string-to-number (match-string 4))) + (cl-incf time (string-to-number (match-string 5))) + (delete-region (point) (line-beginning-position 2))) + (when (looking-at " <testsuite id=\"\\(0\\)\"") + (replace-match (number-to-string id) nil nil nil 1) + (cl-incf id 1)) + (goto-char (point-max)) + (beginning-of-line 0) + (when (looking-at-p "</testsuites>") + (delete-region (point) (line-beginning-position 2)))) + + (narrow-to-region (point-max) (point-max)))) + + (insert "</testsuites>\n") + (widen) + (goto-char (point-min)) + (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n") + (insert (format "<testsuites name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\">\n" + (file-name-nondirectory report) + tests errors failures skipped time))))) (defun ert-summarize-tests-batch-and-exit (&optional high) "Summarize the results of testing. @@ -1521,6 +1743,8 @@ If HIGH is a natural number, the HIGH long lasting tests are summarized." ;; behavior. (setq attempt-stack-overflow-recovery nil attempt-orderly-shutdown-on-fatal-signal nil) + (when (getenv "EMACS_TEST_JUNIT_REPORT") + (apply #'ert-write-junit-test-summary-report command-line-args-left)) (let ((nlogs (length command-line-args-left)) (ntests 0) (nrun 0) (nexpected 0) (nunexpected 0) (nskipped 0) nnotrun logfile notests badtests unexpected skipped tests) @@ -1836,7 +2060,6 @@ Also sets `ert--results-progress-bar-button-begin'." ;; should test it again.) "\n"))) - (defvar ert-test-run-redisplay-interval-secs .1 "How many seconds ERT should wait between redisplays while running tests. @@ -1984,13 +2207,13 @@ otherwise." (ewoc-refresh ert--results-ewoc) (font-lock-default-function enabledp)) -(defun ert--setup-results-buffer (stats listener buffer-name) +(defvar ert--output-buffer-name "*ert*") + +(defun ert--setup-results-buffer (stats listener) "Set up a test results buffer. -STATS is the stats object; LISTENER is the results listener; -BUFFER-NAME, if non-nil, is the buffer name to use." - (unless buffer-name (setq buffer-name "*ert*")) - (let ((buffer (get-buffer-create buffer-name))) +STATS is the stats object; LISTENER is the results listener." + (let ((buffer (get-buffer-create ert--output-buffer-name))) (with-current-buffer buffer (let ((inhibit-read-only t)) (buffer-disable-undo) @@ -2018,22 +2241,14 @@ BUFFER-NAME, if non-nil, is the buffer name to use." (goto-char (1- (point-max))) buffer))))) - (defvar ert--selector-history nil "List of recent test selectors read from terminal.") -;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here? -;; They are needed only for our automated self-tests at the moment. -;; Or should there be some other mechanism? ;;;###autoload -(defun ert-run-tests-interactively (selector - &optional output-buffer-name message-fn) +(defun ert-run-tests-interactively (selector) "Run the tests specified by SELECTOR and display the results in a buffer. -SELECTOR works as described in `ert-select-tests'. -OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they -are used for automated self-tests and specify which buffer to use -and how to display message." +SELECTOR works as described in `ert-select-tests'." (interactive (list (let ((default (if ert--selector-history ;; Can't use `first' here as this form is @@ -2044,25 +2259,18 @@ and how to display message." (read (completing-read (format-prompt "Run tests" default) obarray #'ert-test-boundp nil nil - 'ert--selector-history default nil))) - nil)) - (unless message-fn (setq message-fn 'message)) - (let ((output-buffer-name output-buffer-name) - buffer - listener - (message-fn message-fn)) + 'ert--selector-history default nil))))) + (let (buffer listener) (setq listener (lambda (event-type &rest event-args) (cl-ecase event-type (run-started (cl-destructuring-bind (stats) event-args - (setq buffer (ert--setup-results-buffer stats - listener - output-buffer-name)) + (setq buffer (ert--setup-results-buffer stats listener)) (pop-to-buffer buffer))) (run-ended (cl-destructuring-bind (stats abortedp) event-args - (funcall message-fn + (message "%sRan %s tests, %s results were as expected%s%s" (if (not abortedp) "" @@ -2416,7 +2624,7 @@ To be used in the ERT results buffer." (interactive nil ert-results-mode) (cl-assert (eql major-mode 'ert-results-mode)) (let ((selector (ert--stats-selector ert--results-stats))) - (ert-run-tests-interactively selector (buffer-name)))) + (ert-run-tests-interactively selector))) (defun ert-results-rerun-test-at-point () "Re-run the test at point. @@ -2665,9 +2873,135 @@ To be used in the ERT results buffer." 'ert--activate-font-lock-keywords) nil) +(defun ert-test-erts-file (file &optional transform) + "Parse FILE as a file containing before/after parts. +TRANSFORM will be called to get from before to after." + (with-temp-buffer + (insert-file-contents file) + (let ((gen-specs (list (cons 'dummy t) + (cons 'code transform)))) + ;; Find the start of a test. + (while (re-search-forward "^=-=\n" nil t) + (setq gen-specs (ert-test--erts-test gen-specs file)) + ;; Search to the end of the test. + (re-search-forward "^=-=-=\n"))))) + +(defun ert-test--erts-test (gen-specs file) + (let* ((file-buffer (current-buffer)) + (specs (ert--erts-specifications (match-beginning 0))) + (name (cdr (assq 'name specs))) + (start-before (point)) + (end-after (if (re-search-forward "^=-=-=\n" nil t) + (match-beginning 0) + (point-max))) + (skip (cdr (assq 'skip specs))) + end-before start-after + after after-point) + (unless name + (error "No name for test case")) + (if (and skip + (eval (car (read-from-string skip)))) + ;; Skipping this test. + () + ;; Do the test. + (goto-char end-after) + ;; We have a separate after section. + (if (re-search-backward "^=-=\n" start-before t) + (setq end-before (match-beginning 0) + start-after (match-end 0)) + (setq end-before end-after + start-after start-before)) + ;; Update persistent specs. + (when-let ((point-char (assq 'point-char specs))) + (setq gen-specs + (map-insert gen-specs 'point-char (cdr point-char)))) + (when-let ((code (cdr (assq 'code specs)))) + (setq gen-specs + (map-insert gen-specs 'code (car (read-from-string code))))) + ;; Get the "after" strings. + (with-temp-buffer + (insert-buffer-substring file-buffer start-after end-after) + (ert--erts-unquote) + ;; Remove the newline at the end of the buffer. + (when-let ((no-newline (cdr (assq 'no-after-newline specs)))) + (goto-char (point-min)) + (when (re-search-forward "\n\\'" nil t) + (delete-region (match-beginning 0) (match-end 0)))) + ;; Get the expected "after" point. + (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (goto-char (point-min)) + (when (search-forward point-char nil t) + (delete-region (match-beginning 0) (match-end 0)) + (setq after-point (point)))) + (setq after (buffer-string))) + ;; Do the test. + (with-temp-buffer + (insert-buffer-substring file-buffer start-before end-before) + (ert--erts-unquote) + ;; Remove the newline at the end of the buffer. + (when-let ((no-newline (cdr (assq 'no-before-newline specs)))) + (goto-char (point-min)) + (when (re-search-forward "\n\\'" nil t) + (delete-region (match-beginning 0) (match-end 0)))) + (goto-char (point-min)) + ;; Place point in the specified place. + (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (when (search-forward point-char nil t) + (delete-region (match-beginning 0) (match-end 0)))) + (let ((code (cdr (assq 'code gen-specs)))) + (unless code + (error "No code to run the transform")) + (funcall code)) + (unless (equal (buffer-string) after) + (ert-fail (list (format "Mismatch in test \"%s\", file %s" + name file) + (buffer-string) + after))) + (when (and after-point + (not (= after-point (point)))) + (ert-fail (list (format "Point wrong in test \"%s\", expected point %d, actual %d, file %s" + name + after-point (point) + file) + (buffer-string))))))) + ;; Return the new value of the general specifications. + gen-specs) + +(defun ert--erts-unquote () + (goto-char (point-min)) + (while (re-search-forward "^\\=-=\\(-=\\)$" nil t) + (delete-region (match-beginning 0) (1+ (match-beginning 0))))) + +(defun ert--erts-specifications (end) + "Find specifications before point (back to the previous test)." + (save-excursion + (goto-char end) + (goto-char + (if (re-search-backward "^=-=-=\n" nil t) + (match-end 0) + (point-min))) + (let ((specs nil)) + (while (< (point) end) + (if (looking-at "\\([^ \n\t:]+\\):\\([ \t]+\\)?\\(.*\\)") + (let ((name (intern (downcase (match-string 1)))) + (value (match-string 3))) + (forward-line 1) + (while (looking-at "[ \t]+\\(.*\\)") + (setq value (concat value (match-string 1))) + (forward-line 1)) + (push (cons name (substring-no-properties value)) specs)) + (forward-line 1))) + (nreverse specs)))) + (defvar ert-unload-hook ()) (add-hook 'ert-unload-hook #'ert--unload-function) +;;; Obsolete + +(define-obsolete-function-alias 'ert-equal-including-properties + #'equal-including-properties "29.1") +(put 'ert-equal-including-properties 'ert-explainer + 'ert--explain-equal-including-properties) (provide 'ert) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index c4f48b8a79e..96eaf1ab642 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -61,6 +61,7 @@ "^\\s-*(\\(def\\(ine-skeleton\\|ine-generic-mode\\|ine-derived-mode\\|\ ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ foo\\|\\(?:[^icfgv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ +cl-\\(?:defun\\|defmethod\\|defgeneric\\)\\|\ menu-bar-make-toggle\\|menu-bar-make-toggle-command\\)" find-function-space-re "\\('\\|(quote \\)?%s\\(\\s-\\|$\\|[()]\\)") @@ -123,6 +124,15 @@ should insert the feature name." :group 'xref :version "25.1") +(defcustom find-ert-deftest-regexp + "(ert-deftest +'%s" + "The regexp used to search for an ert-deftest definition. +Note it must contain a `%s' at the place where `format' +should insert the feature name." + :type 'regexp + :group 'xref + :version "29.1") + (defun find-function--defface (symbol) (catch 'found (while (re-search-forward (format find-face-regexp symbol) nil t) @@ -136,7 +146,8 @@ should insert the feature name." (defvar . find-variable-regexp) (defface . find-function--defface) (feature . find-feature-regexp) - (defalias . find-alias-regexp)) + (defalias . find-alias-regexp) + (ert-deftest . find-ert-deftest-regexp)) "Alist mapping definition types into regexp variables. Each regexp variable's value should actually be a format string to be used to substitute the desired symbol name into the regexp. @@ -173,6 +184,16 @@ See the functions `find-function' and `find-variable'." :group 'find-function :version "20.3") +(defcustom find-library-include-other-files t + "If non-nil, `read-library-name' will also include non-library files. +This affects commands like `read-library'. + +If nil, only library files (i.e., \".el\" files) will be offered +for completion." + :type 'boolean + :version "29.1" + :group 'find-function) + ;;; Functions: (defun find-library-suffixes () @@ -292,7 +313,10 @@ TYPE should be nil to find a function, or `defvar' to find a variable." Interactively, prompt for LIBRARY using the one at or near point. This function searches `find-library-source-path' if non-nil, and -`load-path' otherwise." +`load-path' otherwise. + +See the `find-library-include-other-files' user option for +customizing the candidate completions." (interactive (list (read-library-name))) (prog1 (switch-to-buffer (find-file-noselect (find-library-name library))) @@ -307,8 +331,6 @@ in a directory under `load-path' (or `find-library-source-path', if non-nil)." (let* ((dirs (or find-library-source-path load-path)) (suffixes (find-library-suffixes)) - (table (apply-partially 'locate-file-completion-table - dirs suffixes)) (def (if (eq (function-called-at-point) 'require) ;; `function-called-at-point' may return 'require ;; with `point' anywhere on this line. So wrap the @@ -322,10 +344,28 @@ if non-nil)." (thing-at-point 'symbol)) (error nil)) (thing-at-point 'symbol)))) - (when (and def (not (test-completion def table))) - (setq def nil)) - (completing-read (format-prompt "Library name" def) - table nil nil nil nil def))) + (if find-library-include-other-files + (let ((table (apply-partially #'locate-file-completion-table + dirs suffixes))) + (when (and def (not (test-completion def table))) + (setq def nil)) + (completing-read (format-prompt "Library name" def) + table nil nil nil nil def)) + (let ((files (read-library-name--find-files dirs suffixes))) + (when (and def (not (member def files))) + (setq def nil)) + (completing-read (format-prompt "Library name" def) + files nil t nil nil def))))) + +(defun read-library-name--find-files (dirs suffixes) + "Return a list of all files in DIRS that match SUFFIXES." + (let ((files nil) + (regexp (concat (regexp-opt suffixes) "\\'"))) + (dolist (dir dirs) + (dolist (file (ignore-errors (directory-files dir nil regexp t))) + (and (string-match regexp file) + (push (substring file 0 (match-beginning 0)) files)))) + files)) ;;;###autoload (defun find-library-other-window (library) diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index be48699a278..8fbc3b03648 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -143,8 +143,7 @@ the CPS state machinery." (setf ,static-var ,dynamic-var))))) (defmacro cps--with-dynamic-binding (dynamic-var static-var &rest body) - "Evaluate BODY such that generated atomic evaluations run with -DYNAMIC-VAR bound to STATIC-VAR." + "Run BODY's atomic evaluations run with DYNAMIC-VAR bound to STATIC-VAR." (declare (indent 2)) `(cps--with-value-wrapper (cps--make-dynamic-binding-wrapper ,dynamic-var ,static-var) @@ -291,22 +290,28 @@ DYNAMIC-VAR bound to STATIC-VAR." (cps--transform-1 `(progn ,@rest) next-state))) - ;; Process `let' in a helper function that transforms it into a - ;; let* with temporaries. + (`(,(or 'let 'let*) () . ,body) + (cps--transform-1 `(progn ,@body) next-state)) + + ;; Transform multi-variable `let' into `let*': + ;; (let ((v1 e1) ... (vN eN)) BODY) + ;; -> (let* ((t1 e1) ... (tN-1 eN-1) (vN eN) (v1 t1) (vN-1 tN-1)) BODY) (`(let ,bindings . ,body) (let* ((bindings (cl-loop for binding in bindings collect (if (symbolp binding) (list binding nil) binding))) - (temps (cl-loop for (var _value-form) in bindings + (butlast-bindings (butlast bindings)) + (temps (cl-loop for (var _value-form) in butlast-bindings collect (cps--add-binding var)))) (cps--transform-1 `(let* ,(append - (cl-loop for (_var value-form) in bindings + (cl-loop for (_var value-form) in butlast-bindings for temp in temps collect (list temp value-form)) - (cl-loop for (var _binding) in bindings + (last bindings) + (cl-loop for (var _binding) in butlast-bindings for temp in temps collect (list var temp))) ,@body) @@ -315,9 +320,6 @@ DYNAMIC-VAR bound to STATIC-VAR." ;; Process `let*' binding: process one binding at a time. Flatten ;; lexical bindings. - (`(let* () . ,body) - (cps--transform-1 `(progn ,@body) next-state)) - (`(let* (,binding . ,more-bindings) . ,body) (let* ((var (if (symbolp binding) binding (car binding))) (value-form (car (cdr-safe binding))) @@ -642,12 +644,11 @@ modified copy." (iter-close iterator))))) iterator)))) -(defun iter-yield (value) +(defun iter-yield (_value) "When used inside a generator, yield control to caller. The caller of `iter-next' receives VALUE, and the next call to `iter-next' resumes execution with the form immediately following this `iter-yield' call." - (identity value) (error "`iter-yield' used outside a generator")) (defmacro iter-yield-from (value) @@ -689,8 +690,10 @@ of values. Callers can retrieve each value using `iter-next'." (declare (indent defun) (debug (&define lambda-list lambda-doc &rest sexp))) (cl-assert lexical-binding) - `(lambda ,arglist - ,(cps-generate-evaluator body))) + (pcase-let* ((`(,declarations . ,exps) (macroexp-parse-body body))) + `(lambda ,arglist + ,@declarations + ,(cps-generate-evaluator exps)))) (defmacro iter-make (&rest body) "Return a new iterator." diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 33e85e49c7b..7cfa1f2dadc 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -74,7 +74,7 @@ ;; (defvar gv--macro-environment nil ;; "Macro expanders for generalized variables.") -(define-error 'gv-invalid-place "%S is not a valid place expression") +(define-error 'gv-invalid-place "Invalid place expression") ;;;###autoload (defun gv-get (place do) @@ -594,7 +594,7 @@ binding mode." code (macroexp-warn-and-return "Use of gv-ref probably requires lexical-binding" - code)))) + code nil nil place)))) (defsubst gv-deref (ref) "Dereference REF, returning the referenced value. diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index b871a832466..7c6f89deb11 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -111,8 +111,6 @@ ;;; Code: -(require 'mail-parse) - ;;; Variables: (defgroup lisp-mnt nil @@ -361,6 +359,8 @@ Return argument is of the form (\"HOLDER\" \"YEAR1\" ... \"YEARN\")" (defun lm-crack-address (x) "Split up email address(es) X into full name and real email address. The value is a list of elements of the form (FULLNAME . ADDRESS)." + (require 'mail-parse) + (declare-function mail-header-parse-addresses-lax "mail-parse" (string)) (mapcar (lambda (elem) (cons (cdr elem) (car elem))) (mail-header-parse-addresses-lax x))) @@ -505,7 +505,7 @@ absent, return nil." (if (and page (string-match (rx bol "<" (+ nonl) ">" eol) page)) (substring page 1 -1) page))) -(defalias 'lm-homepage 'lm-website) ; for backwards-compatibility +(defalias 'lm-homepage #'lm-website) ; for backwards-compatibility ;;; Verification and synopses diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index c6fcc06e38d..7df40e36f8f 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -29,6 +29,7 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) (defvar font-lock-comment-face) (defvar font-lock-doc-face) @@ -590,6 +591,8 @@ containing STARTPOS." (defun lisp-string-after-doc-keyword-p (listbeg startpos) "Return non-nil if `:documentation' symbol ends at STARTPOS inside a list. +`:doc' can also be used. + LISTBEG is the position of the start of the innermost list containing STARTPOS." (and listbeg ; We are inside a Lisp form. @@ -597,7 +600,7 @@ containing STARTPOS." (goto-char startpos) (ignore-errors (progn (backward-sexp 1) - (looking-at ":documentation\\_>")))))) + (looking-at ":documentation\\_>\\|:doc\\_>")))))) (defun lisp-font-lock-syntactic-face-function (state) "Return syntactic face function for the position represented by STATE. @@ -1106,6 +1109,53 @@ is the buffer position of the start of the containing expression." (t normal-indent)))))) +(defun lisp--local-defform-body-p (state) + "Return non-nil when at local definition body according to STATE. +STATE is the `parse-partial-sexp' state for current position." + (when-let ((start-of-innermost-containing-list (nth 1 state))) + (let* ((parents (nth 9 state)) + (first-cons-after (cdr parents)) + (second-cons-after (cdr first-cons-after)) + first-order-parent second-order-parent) + (while second-cons-after + (when (= start-of-innermost-containing-list + (car second-cons-after)) + (setq second-order-parent (pop parents) + first-order-parent (pop parents) + ;; Leave the loop. + second-cons-after nil)) + (pop second-cons-after) + (pop parents)) + (when second-order-parent + (let (local-definitions-starting-point) + (and (save-excursion + (goto-char (1+ second-order-parent)) + (when-let ((head (ignore-errors + ;; FIXME: This does not distinguish + ;; between reading nil and a read error. + ;; We don't care but still, better fix this. + (read (current-buffer))))) + (when (memq head '( cl-flet cl-labels cl-macrolet cl-flet* + cl-symbol-macrolet)) + ;; In what follows, we rely on (point) returning non-nil. + (setq local-definitions-starting-point + (progn + (parse-partial-sexp + (point) first-order-parent nil + ;; From docstring of `parse-partial-sexp': + ;; Fourth arg non-nil means stop + ;; when we come to any character + ;; that starts a sexp. + t) + (point)))))) + (save-excursion + (when (ignore-errors + ;; We rely on `backward-up-list' working + ;; even when sexp is incomplete “to the right”. + (backward-up-list 2) + t) + (= local-definitions-starting-point (point)))))))))) + (defun lisp-indent-function (indent-point state) "This function is the normal value of the variable `lisp-indent-function'. The function `calculate-lisp-indent' calls this to determine @@ -1139,16 +1189,19 @@ Lisp function does not specify a special indentation." (if (and (elt state 2) (not (looking-at "\\sw\\|\\s_"))) ;; car of form doesn't seem to be a symbol - (progn + (if (lisp--local-defform-body-p state) + ;; We nevertheless check whether we are in flet-like form + ;; as we presume local function names could be non-symbols. + (lisp-indent-defform state indent-point) (if (not (> (save-excursion (forward-line 1) (point)) calculate-lisp-indent-last-sexp)) - (progn (goto-char calculate-lisp-indent-last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) - calculate-lisp-indent-last-sexp 0 t))) - ;; Indent under the list or under the first sexp on the same - ;; line as calculate-lisp-indent-last-sexp. Note that first - ;; thing on that line has to be complete sexp since we are + (progn (goto-char calculate-lisp-indent-last-sexp) + (beginning-of-line) + (parse-partial-sexp (point) + calculate-lisp-indent-last-sexp 0 t))) + ;; Indent under the list or under the first sexp on the same + ;; line as calculate-lisp-indent-last-sexp. Note that first + ;; thing on that line has to be complete sexp since we are ;; inside the innermost containing sexp. (backward-prefix-chars) (current-column)) @@ -1159,15 +1212,14 @@ Lisp function does not specify a special indentation." 'lisp-indent-function) (get (intern-soft function) 'lisp-indent-hook))) (cond ((or (eq method 'defun) - (and (null method) - (> (length function) 3) - (string-match "\\`def" function))) + ;; Check whether we are in flet-like form. + (lisp--local-defform-body-p state)) (lisp-indent-defform state indent-point)) ((integerp method) (lisp-indent-specform method state indent-point normal-indent)) (method - (funcall method indent-point state))))))) + (funcall method indent-point state))))))) (defcustom lisp-body-indent 2 "Number of columns to indent the second line of a `(def...)' form." @@ -1235,6 +1287,13 @@ Lisp function does not specify a special indentation." (put 'autoload 'lisp-indent-function 'defun) ;Elisp (put 'progn 'lisp-indent-function 0) +(put 'defvar 'lisp-indent-function 'defun) +(put 'defalias 'lisp-indent-function 'defun) +(put 'defvaralias 'lisp-indent-function 'defun) +(put 'defconst 'lisp-indent-function 'defun) +(put 'define-category 'lisp-indent-function 'defun) +(put 'define-charset-internal 'lisp-indent-function 'defun) +(put 'define-fringe-bitmap 'lisp-indent-function 'defun) (put 'prog1 'lisp-indent-function 1) (put 'save-excursion 'lisp-indent-function 0) ;Elisp (put 'save-restriction 'lisp-indent-function 0) ;Elisp @@ -1249,6 +1308,7 @@ Lisp function does not specify a special indentation." (put 'handler-bind 'lisp-indent-function 1) ;CL (put 'unwind-protect 'lisp-indent-function 1) (put 'with-output-to-temp-buffer 'lisp-indent-function 1) +(put 'closure 'lisp-indent-function 2) (defun indent-sexp (&optional endpos) "Indent each line of the list starting just after point. diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index f1bb2c1cf37..e91b302af10 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -28,6 +28,17 @@ ;;; Code: +(defvar byte-compile-form-stack nil + "Dynamic list of successive enclosing forms. +This is used by the warning message routines to determine a +source code position. The most accessible element is the current +most deeply nested form. + +Normally a form is manually pushed onto the list at the beginning +of `byte-compile-form', etc., and manually popped off at its end. +This is to preserve the data in it in the event of a +condition-case handling a signaled error.") + ;; Bound by the top-level `macroexpand-all', and modified to include any ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) @@ -96,10 +107,11 @@ each clause." (defun macroexp--compiler-macro (handler form) (condition-case-unless-debug err - (apply handler form (cdr form)) + (let ((symbols-with-pos-enabled t)) + (apply handler form (cdr form))) (error - (message "Compiler-macro error for %S: %S" (car form) err) - form))) + (message "Compiler-macro error for %S: Handler: %S\n%S" (car form) handler err) + form))) (defun macroexp--funcall-if-compiled (_form) "Pseudo function used internally by macroexp to delay warnings. @@ -135,22 +147,27 @@ Other uses risk returning non-nil value that point to the wrong file." (defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key)) -(defun macroexp--warn-wrap (msg form category) - (let ((when-compiled (lambda () - (when (byte-compile-warning-enabled-p category) - (byte-compile-warn "%s" msg))))) +(defun macroexp--warn-wrap (arg msg form category) + (let ((when-compiled + (lambda () + (when (if (consp category) + (apply #'byte-compile-warning-enabled-p category) + (byte-compile-warning-enabled-p category)) + (byte-compile-warn-x arg "%s" msg))))) `(progn (macroexp--funcall-if-compiled ',when-compiled) ,form))) (define-obsolete-function-alias 'macroexp--warn-and-return #'macroexp-warn-and-return "28.1") -(defun macroexp-warn-and-return (msg form &optional category compile-only) +(defun macroexp-warn-and-return (msg form &optional category compile-only arg) "Return code equivalent to FORM labeled with warning MSG. CATEGORY is the category of the warning, like the categories that can appear in `byte-compile-warnings'. COMPILE-ONLY non-nil means no warning should be emitted if the code -is executed without being compiled first." +is executed without being compiled first. +ARG is a symbol (or a form) giving the source code position for the message. +It should normally be a symbol with position and it defaults to FORM." (cond ((null msg) form) ((macroexp-compiling-p) @@ -160,7 +177,7 @@ is executed without being compiled first." ;; macroexpand-all gets right back to macroexpanding `form'. form (puthash form form macroexp--warned) - (macroexp--warn-wrap msg form category))) + (macroexp--warn-wrap (or arg form) msg form category))) (t (unless compile-only (message "%sWarning: %s" @@ -220,7 +237,7 @@ is executed without being compiled first." fun obsolete (if (symbolp (symbol-function fun)) "alias" "macro")) - new-form 'obsolete)) + new-form (list 'obsolete fun) nil fun)) new-form))) (defun macroexp--unfold-lambda (form &optional name) @@ -275,7 +292,7 @@ is executed without being compiled first." "attempt to open-code `%s' with too few arguments" "attempt to open-code `%s' with too many arguments") name) - form) + form nil nil arglist) ;; The following leads to infinite recursion when loading a ;; file containing `(defsubst f () (f))', and then trying to @@ -286,118 +303,136 @@ is executed without being compiled first." `(let ,(nreverse bindings) . ,body) (macroexp-progn body))))) +(defun macroexp--dynamic-variable-p (var) + "Whether the variable VAR is dynamically scoped. +Only valid during macro-expansion." + (defvar byte-compile-bound-variables) + (or (not lexical-binding) + (special-variable-p var) + (memq var macroexp--dynvars) + (and (boundp 'byte-compile-bound-variables) + (memq var byte-compile-bound-variables)))) + (defun macroexp--expand-all (form) "Expand all macros in FORM. This is an internal version of `macroexpand-all'. Assumes the caller has bound `macroexpand-all-environment'." - (if (eq (car-safe form) 'backquote-list*) - ;; Special-case `backquote-list*', as it is normally a macro that - ;; generates exceedingly deep expansions from relatively shallow input - ;; forms. We just process it `in reverse' -- first we expand all the - ;; arguments, _then_ we expand the top-level definition. - (macroexpand (macroexp--all-forms form 1) - macroexpand-all-environment) - ;; Normal form; get its expansion, and then expand arguments. - (setq form (macroexp-macroexpand form macroexpand-all-environment)) - ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when - ;; I tried it, it broke the bootstrap :-( - (pcase form - (`(cond . ,clauses) - (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) - (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) - (macroexp--cons - 'condition-case - (macroexp--cons err - (macroexp--cons (macroexp--expand-all body) - (macroexp--all-clauses handlers 1) - (cddr form)) - (cdr form)) - form)) - (`(,(or 'defvar 'defconst) . ,_) (macroexp--all-forms form 2)) - (`(function ,(and f `(lambda . ,_))) - (macroexp--cons 'function - (macroexp--cons (macroexp--all-forms f 2) - nil - (cdr form)) - form)) - (`(,(or 'function 'quote) . ,_) form) - (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) - pcase--dontcare)) - (macroexp--cons - fun - (macroexp--cons - (macroexp--all-clauses bindings 1) - (if (null body) - (macroexp-unprogn - (macroexp-warn-and-return - (format "Empty %s body" fun) - nil nil 'compile-only)) - (macroexp--all-forms body)) - (cdr form)) - form)) - (`(,(and fun `(lambda . ,_)) . ,args) - ;; Embedded lambda in function position. - ;; If the byte-optimizer is loaded, try to unfold this, - ;; i.e. rewrite it to (let (<args>) <body>). We'd do it in the optimizer - ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the - ;; creation of a closure, thus resulting in much better code. - (let ((newform (macroexp--unfold-lambda form))) - (if (eq newform form) - ;; Unfolding failed for some reason, avoid infinite recursion. - (macroexp--cons (macroexp--all-forms fun 2) - (macroexp--all-forms args) - form) - (macroexp--expand-all newform)))) - - (`(funcall . ,(or `(,exp . ,args) pcase--dontcare)) - (let ((eexp (macroexp--expand-all exp)) - (eargs (macroexp--all-forms args))) - ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' - ;; has a compiler-macro, or to unfold it. - (pcase eexp - (`#',f (macroexp--expand-all `(,f . ,eargs))) - (_ `(funcall ,eexp . ,eargs))))) - (`(,func . ,_) - (let ((handler (function-get func 'compiler-macro)) - (funargs (function-get func 'funarg-positions))) - ;; Check functions quoted with ' rather than with #' - (dolist (funarg funargs) - (let ((arg (nth funarg form))) - (when (and (eq 'quote (car-safe arg)) - (eq 'lambda (car-safe (cadr arg)))) - (setcar (nthcdr funarg form) - (macroexp-warn-and-return - (format "%S quoted with ' rather than with #'" - (let ((f (cadr arg))) - (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) - arg))))) - ;; Macro expand compiler macros. This cannot be delayed to - ;; byte-optimize-form because the output of the compiler-macro can - ;; use macros. - (if (null handler) - ;; No compiler macro. We just expand each argument (for - ;; setq/setq-default this works alright because the variable names - ;; are symbols). - (macroexp--all-forms form 1) - ;; If the handler is not loaded yet, try (auto)loading the - ;; function itself, which may in turn load the handler. - (unless (functionp handler) - (with-demoted-errors "macroexp--expand-all: %S" - (autoload-do-load (indirect-function func) func))) - (let ((newform (macroexp--compiler-macro handler form))) - (if (eq form newform) - ;; The compiler macro did not find anything to do. - (if (equal form (setq newform (macroexp--all-forms form 1))) - form - ;; Maybe after processing the args, some new opportunities - ;; appeared, so let's try the compiler macro again. - (setq form (macroexp--compiler-macro handler newform)) - (if (eq newform form) - newform - (macroexp--expand-all newform))) - (macroexp--expand-all newform)))))) - - (_ form)))) + (push form byte-compile-form-stack) + (prog1 + (if (eq (car-safe form) 'backquote-list*) + ;; Special-case `backquote-list*', as it is normally a macro that + ;; generates exceedingly deep expansions from relatively shallow input + ;; forms. We just process it `in reverse' -- first we expand all the + ;; arguments, _then_ we expand the top-level definition. + (macroexpand (macroexp--all-forms form 1) + macroexpand-all-environment) + ;; Normal form; get its expansion, and then expand arguments. + (setq form (macroexp-macroexpand form macroexpand-all-environment)) + ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when + ;; I tried it, it broke the bootstrap :-( + (pcase form + (`(cond . ,clauses) + (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) + (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) + (macroexp--cons + 'condition-case + (macroexp--cons err + (macroexp--cons (macroexp--expand-all body) + (macroexp--all-clauses handlers 1) + (cddr form)) + (cdr form)) + form)) + (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) + (push name macroexp--dynvars) + (macroexp--all-forms form 2)) + (`(function ,(and f `(lambda . ,_))) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons 'function + (macroexp--cons (macroexp--all-forms f 2) + nil + (cdr form)) + form))) + (`(,(or 'function 'quote) . ,_) form) + (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) + pcase--dontcare)) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons + fun + (macroexp--cons + (macroexp--all-clauses bindings 1) + (if (null body) + (macroexp-unprogn + (macroexp-warn-and-return + (format "Empty %s body" fun) + nil nil 'compile-only fun)) + (macroexp--all-forms body)) + (cdr form)) + form))) + (`(,(and fun `(lambda . ,_)) . ,args) + ;; Embedded lambda in function position. + ;; If the byte-optimizer is loaded, try to unfold this, + ;; i.e. rewrite it to (let (<args>) <body>). We'd do it in the optimizer + ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the + ;; creation of a closure, thus resulting in much better code. + (let ((newform (macroexp--unfold-lambda form))) + (if (eq newform form) + ;; Unfolding failed for some reason, avoid infinite recursion. + (macroexp--cons (macroexp--all-forms fun 2) + (macroexp--all-forms args) + form) + (macroexp--expand-all newform)))) + (`(funcall ,exp . ,args) + (let ((eexp (macroexp--expand-all exp)) + (eargs (macroexp--all-forms args))) + ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' + ;; has a compiler-macro, or to unfold it. + (pcase eexp + ((and `#',f + (guard (not (or (special-form-p f) (macrop f))))) ;; bug#46636 + (macroexp--expand-all `(,f . ,eargs))) + (_ `(funcall ,eexp . ,eargs))))) + (`(funcall . ,_) form) ;bug#53227 + (`(,func . ,_) + (let ((handler (function-get func 'compiler-macro)) + (funargs (function-get func 'funarg-positions))) + ;; Check functions quoted with ' rather than with #' + (dolist (funarg funargs) + (let ((arg (nth funarg form))) + (when (and (eq 'quote (car-safe arg)) + (eq 'lambda (car-safe (cadr arg)))) + (setcar (nthcdr funarg form) + (macroexp-warn-and-return + (format "%S quoted with ' rather than with #'" + (let ((f (cadr arg))) + (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) + arg nil nil (cadr arg)))))) + ;; Macro expand compiler macros. This cannot be delayed to + ;; byte-optimize-form because the output of the compiler-macro can + ;; use macros. + (if (null handler) + ;; No compiler macro. We just expand each argument (for + ;; setq/setq-default this works alright because the variable names + ;; are symbols). + (macroexp--all-forms form 1) + ;; If the handler is not loaded yet, try (auto)loading the + ;; function itself, which may in turn load the handler. + (unless (functionp handler) + (with-demoted-errors "macroexp--expand-all: %S" + (autoload-do-load (indirect-function func) func))) + (let ((newform (macroexp--compiler-macro handler form))) + (if (eq form newform) + ;; The compiler macro did not find anything to do. + (if (equal form (setq newform (macroexp--all-forms form 1))) + form + ;; Maybe after processing the args, some new opportunities + ;; appeared, so let's try the compiler macro again. + (setq form (macroexp--compiler-macro handler newform)) + (if (eq newform form) + newform + (macroexp--expand-all newform))) + (macroexp--expand-all newform)))))) + (_ form))) + (pop byte-compile-form-stack))) ;; Record which arguments expect functions, so we can warn when those ;; are accidentally quoted with ' rather than with #' @@ -418,6 +453,14 @@ Assumes the caller has bound `macroexpand-all-environment'." If no macros are expanded, FORM is returned unchanged. The second optional arg ENVIRONMENT specifies an environment of macro definitions to shadow the loaded ones for use in file byte-compilation." + (let ((macroexpand-all-environment environment) + (macroexp--dynvars macroexp--dynvars)) + (macroexp--expand-all form))) + +;; This function is like `macroexpand-all' but for use with top-level +;; forms. It does not dynbind `macroexp--dynvars' because we want +;; top-level `defvar' declarations to be recorded in that variable. +(defun macroexpand--all-toplevel (form &optional environment) (let ((macroexpand-all-environment environment)) (macroexp--expand-all form))) @@ -679,38 +722,40 @@ test of free variables in the following ways: (defun internal-macroexpand-for-load (form full-p) ;; Called from the eager-macroexpansion in readevalloop. - (cond - ;; Don't repeat the same warning for every top-level element. - ((eq 'skip (car macroexp--pending-eager-loads)) form) - ;; If we detect a cycle, skip macro-expansion for now, and output a warning - ;; with a trimmed backtrace. - ((and load-file-name (member load-file-name macroexp--pending-eager-loads)) - (let* ((bt (delq nil - (mapcar #'macroexp--trim-backtrace-frame - (macroexp--backtrace)))) - (elem `(load ,(file-name-nondirectory load-file-name))) - (tail (member elem (cdr (member elem bt))))) - (if tail (setcdr tail (list '…))) - (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) - (if macroexp--debug-eager - (debug 'eager-macroexp-cycle) - (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" - (mapconcat #'prin1-to-string (nreverse bt) " => "))) - (push 'skip macroexp--pending-eager-loads) - form)) - (t - (condition-case err - (let ((macroexp--pending-eager-loads - (cons load-file-name macroexp--pending-eager-loads))) - (if full-p - (macroexpand-all form) - (macroexpand form))) - (error - ;; Hopefully this shouldn't happen thanks to the cycle detection, - ;; but in case it does happen, let's catch the error and give the - ;; code a chance to macro-expand later. - (message "Eager macro-expansion failure: %S" err) - form))))) + (let ((symbols-with-pos-enabled t) + (print-symbols-bare t)) + (cond + ;; Don't repeat the same warning for every top-level element. + ((eq 'skip (car macroexp--pending-eager-loads)) form) + ;; If we detect a cycle, skip macro-expansion for now, and output a warning + ;; with a trimmed backtrace. + ((and load-file-name (member load-file-name macroexp--pending-eager-loads)) + (let* ((bt (delq nil + (mapcar #'macroexp--trim-backtrace-frame + (macroexp--backtrace)))) + (elem `(load ,(file-name-nondirectory load-file-name))) + (tail (member elem (cdr (member elem bt))))) + (if tail (setcdr tail (list '…))) + (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) + (if macroexp--debug-eager + (debug 'eager-macroexp-cycle) + (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" + (mapconcat #'prin1-to-string (nreverse bt) " => "))) + (push 'skip macroexp--pending-eager-loads) + form)) + (t + (condition-case err + (let ((macroexp--pending-eager-loads + (cons load-file-name macroexp--pending-eager-loads))) + (if full-p + (macroexpand--all-toplevel form) + (macroexpand form))) + (error + ;; Hopefully this shouldn't happen thanks to the cycle detection, + ;; but in case it does happen, let's catch the error and give the + ;; code a chance to macro-expand later. + (message "Eager macro-expansion failure: %S" err) + form)))))) ;; ¡¡¡ Big Ugly Hack !!! ;; src/bootstrap-emacs is mostly used to compile .el files, so it needs diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index f6848008249..b3e7fca4781 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -215,12 +215,12 @@ The function's value is the number of actions taken." (action (or (nth 2 help) "act on"))) (concat (format-message - "\ -Type SPC or `y' to %s the current %s; -DEL or `n' to skip the current %s; -RET or `q' to skip the current and all remaining %s; -C-g to quit (cancel the whole command); -! to %s all remaining %s;\n" + (substitute-command-keys "\ +Type \\`SPC' or \\`y' to %s the current %s; +\\`DEL' or \\`n' to skip the current %s; +\\`RET' or \\`q' to skip the current and all remaining %s; +\\`C-g' to quit (cancel the whole command); +\\`!' to %s all remaining %s;\n") action object object objects action objects) (mapconcat (lambda (elt) (format "%s to %s;\n" diff --git a/lisp/emacs-lisp/memory-report.el b/lisp/emacs-lisp/memory-report.el index d9c0f02820e..6cb4cb02e0c 100644 --- a/lisp/emacs-lisp/memory-report.el +++ b/lisp/emacs-lisp/memory-report.el @@ -31,7 +31,7 @@ (require 'subr-x) (require 'cl-lib) -(defvar memory-report--type-size (make-hash-table)) +(defvar memory-report--type-size nil) ;;;###autoload (defun memory-report () @@ -75,7 +75,7 @@ by counted more than once." (defun memory-report-object-size (object) "Return the size of OBJECT in bytes." - (when (zerop (hash-table-count memory-report--type-size)) + (unless memory-report--type-size (memory-report--garbage-collect)) (memory-report--object-size (make-hash-table :test #'eq) object)) @@ -84,6 +84,7 @@ by counted more than once." (gethash 'object memory-report--type-size))) (defun memory-report--set-size (elems) + (setq memory-report--type-size (make-hash-table)) (setf (gethash 'string memory-report--type-size) (cadr (assq 'strings elems))) (setf (gethash 'cons memory-report--type-size) @@ -282,7 +283,7 @@ by counted more than once." buffers) do (insert (memory-report--format size) " " - (button-buttonize + (buttonize (buffer-name buffer) #'memory-report--buffer-details buffer) "\n")) diff --git a/lisp/emacs-lisp/multisession.el b/lisp/emacs-lisp/multisession.el new file mode 100644 index 00000000000..d6f1ab98faa --- /dev/null +++ b/lisp/emacs-lisp/multisession.el @@ -0,0 +1,454 @@ +;;; multisession.el --- Multisession storage for variables -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'cl-lib) +(require 'eieio) +(require 'sqlite) +(require 'tabulated-list) + +(defcustom multisession-storage 'files + "Storage method for multisession variables. +Valid methods are `sqlite' and `files'." + :type '(choice (const :tag "SQLite" sqlite) + (const :tag "Files" files)) + :version "29.1" + :group 'files) + +(defcustom multisession-directory (expand-file-name "multisession/" + user-emacs-directory) + "Directory to store multisession variables." + :type 'file + :version "29.1" + :group 'files) + +;;;###autoload +(defmacro define-multisession-variable (name initial-value &optional doc + &rest args) + "Make NAME into a multisession variable initialized from INITIAL-VALUE. +DOC should be a doc string, and ARGS are keywords as applicable to +`make-multisession'." + (declare (indent defun)) + (unless (plist-get args :package) + (setq args (nconc (list :package + (replace-regexp-in-string "-.*" "" + (symbol-name name))) + args))) + `(defvar ,name + (make-multisession :key ,(symbol-name name) + :initial-value ,initial-value + ,@args) + ,@(list doc))) + +(defconst multisession--unbound (make-symbol "unbound")) + +(cl-defstruct (multisession + (:constructor nil) + (:constructor multisession--create) + (:conc-name multisession--)) + "A persistent variable that will live across Emacs invocations." + key + (initial-value nil) + package + (storage multisession-storage) + (synchronized nil) + (cached-value multisession--unbound) + (cached-sequence 0)) + +(cl-defun make-multisession (&key key initial-value package synchronized + storage) + "Create a multisession object." + (unless package + (error "No package for the multisession object")) + (unless key + (error "No key for the multisession object")) + (unless (stringp package) + (error "The package has to be a string")) + (unless (stringp key) + (error "The key has to be a string")) + (multisession--create + :key key + :synchronized synchronized + :initial-value initial-value + :package package + :storage (or storage multisession-storage))) + +(defun multisession-value (object) + "Return the value of the multisession OBJECT." + (if (null user-init-file) + ;; If we don't have storage, then just return the value from the + ;; object. + (if (eq (multisession--cached-value object) multisession--unbound) + (multisession--initial-value object) + (multisession--cached-value object)) + ;; We have storage, so we update from storage. + (multisession-backend-value (multisession--storage object) object))) + +(defun multisession--set-value (object value) + "Set the stored value of OBJECT to VALUE." + (if (null user-init-file) + ;; We have no backend, so just store the value. + (setf (multisession--cached-value object) value) + ;; We have a backend. + (multisession--backend-set-value (multisession--storage object) + object value))) + +(defun multisession-delete (object) + "Delete OBJECT from the backend storage." + (multisession--backend-delete (multisession--storage object) object)) + +(gv-define-simple-setter multisession-value multisession--set-value) + +;; SQLite Backend + +(declare-function sqlite-execute "sqlite.c") +(declare-function sqlite-select "sqlite.c") +(declare-function sqlite-open "sqlite.c") +(declare-function sqlite-pragma "sqlite.c") +(declare-function sqlite-transaction "sqlite.c") +(declare-function sqlite-commit "sqlite.c") + +(defvar multisession--db nil) + +(defun multisession--ensure-db () + (unless multisession--db + (let* ((file (expand-file-name "sqlite/multisession.sqlite" + multisession-directory)) + (dir (file-name-directory file))) + (unless (file-exists-p dir) + (make-directory dir t)) + (setq multisession--db (sqlite-open file))) + (with-sqlite-transaction multisession--db + ;; Use a write-ahead-log (available since 2010), which makes + ;; writes a lot faster. + (sqlite-pragma multisession--db "journal_mode = WAL") + (sqlite-pragma multisession--db "synchronous = NORMAL") + (unless (sqlite-select + multisession--db + "select name from sqlite_master where type = 'table' and name = 'multisession'") + ;; Tidy up the database automatically. + (sqlite-pragma multisession--db "auto_vacuum = FULL") + ;; Create the table. + (sqlite-execute + multisession--db + "create table multisession (package text not null, key text not null, sequence number not null default 1, value text not null)") + (sqlite-execute + multisession--db + "create unique index multisession_idx on multisession (package, key)"))))) + +(cl-defmethod multisession-backend-value ((_type (eql 'sqlite)) object) + (multisession--ensure-db) + (let ((id (list (multisession--package object) + (multisession--key object)))) + (cond + ;; We have no value yet; check the database. + ((eq (multisession--cached-value object) multisession--unbound) + (let ((stored + (car + (sqlite-select + multisession--db + "select value, sequence from multisession where package = ? and key = ?" + id)))) + (if stored + (let ((value (car (read-from-string (car stored))))) + (setf (multisession--cached-value object) value + (multisession--cached-sequence object) (cadr stored)) + value) + ;; Nothing; return the initial value. + (multisession--initial-value object)))) + ;; We have a value, but we want to update in case some other + ;; Emacs instance has updated. + ((multisession--synchronized object) + (let ((stored + (car + (sqlite-select + multisession--db + "select value, sequence from multisession where sequence > ? and package = ? and key = ?" + (cons (multisession--cached-sequence object) id))))) + (if stored + (let ((value (car (read-from-string (car stored))))) + (setf (multisession--cached-value object) value + (multisession--cached-sequence object) (cadr stored)) + value) + ;; Nothing, return the cached value. + (multisession--cached-value object)))) + ;; Just return the cached value. + (t + (multisession--cached-value object))))) + +(cl-defmethod multisession--backend-set-value ((_type (eql 'sqlite)) + object value) + (catch 'done + (let ((i 0)) + (while (< i 10) + (condition-case nil + (throw 'done (multisession--set-value-sqlite object value)) + (sqlite-locked-error + (setq i (1+ i)) + (sleep-for (+ 0.1 (/ (float (random 10)) 10)))))) + (signal 'sqlite-locked-error "Database is locked")))) + +(defun multisession--set-value-sqlite (object value) + (multisession--ensure-db) + (with-sqlite-transaction multisession--db + (let ((id (list (multisession--package object) + (multisession--key object))) + (pvalue + (let ((print-length nil) + (print-circle t) + (print-level nil)) + (readablep value)))) + (when (and value (not pvalue)) + (error "Unable to store unreadable value: %s" value)) + (sqlite-execute + multisession--db + "insert into multisession(package, key, sequence, value) values(?, ?, 1, ?) on conflict(package, key) do update set sequence = sequence + 1, value = ?" + (append id (list pvalue pvalue))) + (setf (multisession--cached-sequence object) + (caar (sqlite-select + multisession--db + "select sequence from multisession where package = ? and key = ?" + id))) + (setf (multisession--cached-value object) value)))) + +(cl-defmethod multisession--backend-values ((_type (eql 'sqlite))) + (multisession--ensure-db) + (sqlite-select + multisession--db + "select package, key, value from multisession order by package, key")) + +(cl-defmethod multisession--backend-delete ((_type (eql 'sqlite)) object) + (sqlite-execute multisession--db + "delete from multisession where package = ? and key = ?" + (list (multisession--package object) + (multisession--key object)))) + +;; Files Backend + +(defun multisession--encode-file-name (name) + (url-hexify-string name)) + +(defun multisession--read-file-value (file object) + (catch 'done + (let ((i 0) + last-error) + (while (< i 10) + (condition-case err + (throw 'done + (with-temp-buffer + (let* ((time (file-attribute-modification-time + (file-attributes file))) + (coding-system-for-read 'utf-8-emacs-unix)) + (insert-file-contents file) + (let ((stored (read (current-buffer)))) + (setf (multisession--cached-value object) stored + (multisession--cached-sequence object) time) + stored)))) + ;; Windows uses OS-level file locking that may preclude + ;; reading the file in some circumstances. In addition, + ;; rename-file is not an atomic operation on MS-Windows, + ;; when the target file already exists, so there could be a + ;; small race window when the file to read doesn't yet + ;; exist. So when these problems happen, wait a bit and retry. + ((permission-denied file-missing) + (setq i (1+ i) + last-error err) + (sleep-for (+ 0.1 (/ (float (random 10)) 10)))))) + (signal (car last-error) (cdr last-error))))) + +(defun multisession--object-file-name (object) + (expand-file-name + (concat "files/" + (multisession--encode-file-name (multisession--package object)) + "/" + (multisession--encode-file-name (multisession--key object)) + ".value") + multisession-directory)) + +(cl-defmethod multisession-backend-value ((_type (eql 'files)) object) + (let ((file (multisession--object-file-name object))) + (cond + ;; We have no value yet; see whether it's stored. + ((eq (multisession--cached-value object) multisession--unbound) + (if (file-exists-p file) + (multisession--read-file-value file object) + ;; Nope; return the initial value. + (multisession--initial-value object))) + ;; We have a value, but we want to update in case some other + ;; Emacs instance has updated. + ((multisession--synchronized object) + (if (and (file-exists-p file) + (time-less-p (multisession--cached-sequence object) + (file-attribute-modification-time + (file-attributes file)))) + (multisession--read-file-value file object) + ;; Nothing, return the cached value. + (multisession--cached-value object))) + ;; Just return the cached value. + (t + (multisession--cached-value object))))) + +(cl-defmethod multisession--backend-set-value ((_type (eql 'files)) + object value) + (let ((file (multisession--object-file-name object)) + (time (current-time))) + ;; Ensure that the directory exists. + (let ((dir (file-name-directory file))) + (unless (file-exists-p dir) + (make-directory dir t))) + (with-temp-buffer + (let ((print-length nil) + (print-circle t) + (print-level nil)) + (prin1 value (current-buffer))) + (goto-char (point-min)) + (condition-case nil + (read (current-buffer)) + (error (error "Unable to store unreadable value: %s" (buffer-string)))) + ;; Write to a temp file in the same directory and rename to the + ;; file for somewhat better atomicity. + (let ((coding-system-for-write 'utf-8-emacs-unix) + (create-lockfiles nil) + (temp (make-temp-name file)) + (write-region-inhibit-fsync nil)) + (write-region (point-min) (point-max) temp nil 'silent) + (set-file-times temp time) + (rename-file temp file t))) + (setf (multisession--cached-sequence object) time + (multisession--cached-value object) value))) + +(cl-defmethod multisession--backend-values ((_type (eql 'files))) + (mapcar (lambda (file) + (let ((bits (file-name-split file))) + (list (url-unhex-string (car (last bits 2))) + (url-unhex-string + (file-name-sans-extension (car (last bits)))) + (with-temp-buffer + (let ((coding-system-for-read 'utf-8-emacs-unix)) + (insert-file-contents file) + (read (current-buffer))))))) + (directory-files-recursively + (expand-file-name "files" multisession-directory) + "\\.value\\'"))) + +(cl-defmethod multisession--backend-delete ((_type (eql 'files)) object) + (let ((file (multisession--object-file-name object))) + (when (file-exists-p file) + (delete-file file)))) + +;; Mode for editing. + +(defvar-keymap multisession-edit-mode-map + :parent tabulated-list-mode-map + "d" #'multisession-delete-value + "e" #'multisession-edit-value) + +(define-derived-mode multisession-edit-mode special-mode "Multisession" + "This mode lists all elements in the \"multisession\" database." + :interactive nil + (buffer-disable-undo) + (setq-local buffer-read-only t + truncate-lines t) + (setq tabulated-list-format + [("Package" 10) + ("Key" 30) + ("Value" 30)]) + (setq-local revert-buffer-function #'multisession-edit-mode--revert)) + +;;;###autoload +(defun list-multisession-values (&optional choose-storage) + "List all values in the \"multisession\" database. +If CHOOSE-STORAGE (interactively, the prefix), query for the +storage method to list." + (interactive "P") + (let ((storage + (if choose-storage + (intern (completing-read "Storage method: " '(sqlite files) nil t)) + multisession-storage))) + (pop-to-buffer (get-buffer-create (format "*Multisession %s*" storage))) + (multisession-edit-mode) + (setq-local multisession-storage storage) + (multisession-edit-mode--revert) + (goto-char (point-min)))) + +(defun multisession-edit-mode--revert (&rest _) + (let ((inhibit-read-only t) + (id (get-text-property (point) 'tabulated-list-id))) + (erase-buffer) + (tabulated-list-init-header) + (setq tabulated-list-entries + (mapcar (lambda (elem) + (list + (cons (car elem) (cadr elem)) + (vector (car elem) (cadr elem) + (string-replace "\n" "\\n" + (format "%s" (caddr elem)))))) + (multisession--backend-values multisession-storage))) + (tabulated-list-print t) + (goto-char (point-min)) + (when id + (when-let ((match + (text-property-search-forward 'tabulated-list-id id t))) + (goto-char (prop-match-beginning match)))))) + +(defun multisession-delete-value (id) + "Delete the value at point." + (interactive (list (get-text-property (point) 'tabulated-list-id)) + multisession-edit-mode) + (unless id + (error "No value on the current line")) + (unless (yes-or-no-p "Really delete this item? ") + (user-error "Not deleting")) + (multisession--backend-delete multisession-storage + (make-multisession :package (car id) + :key (cdr id))) + (let ((inhibit-read-only t)) + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point))))) + +(defun multisession-edit-value (id) + "Edit the value at point." + (interactive (list (get-text-property (point) 'tabulated-list-id)) + multisession-edit-mode) + (unless id + (error "No value on the current line")) + (let* ((object (or + ;; If the multisession variable already exists, use + ;; it (so that we update it). + (and (intern-soft (cdr id)) + (bound-and-true-p (intern (cdr id)))) + ;; Create a new object. + (make-multisession + :package (car id) + :key (cdr id) + :storage multisession-storage))) + (value (multisession-value object))) + (setf (multisession-value object) + (car (read-from-string + (read-string "New value: " (prin1-to-string value)))))) + (multisession-edit-mode--revert)) + +(provide 'multisession) + +;;; multisession.el ends here diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 212499d10b0..77e140dda19 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -480,6 +480,8 @@ is defined as a macro, alias, command, ..." (get symbol 'advice--pending)) (t (symbol-function symbol))) function props) + ;; FIXME: We could use a defmethod on `function-docstring' instead, + ;; except when (or (not nf) (autoloadp nf))! (put symbol 'function-documentation `(advice--make-docstring ',symbol)) (add-function :around (get symbol 'defalias-fset-function) #'advice--defalias-fset)) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 7679ba2fae5..6aa82e576d9 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -720,6 +720,7 @@ REQUIREMENTS is a list of dependencies on other packages. where OTHER-VERSION is a string. EXTRA-PROPERTIES is currently unused." + (declare (indent defun)) ;; FIXME: Placeholder! Should we keep it? (error "Don't call me!")) @@ -763,47 +764,47 @@ PKG-DESC is a `package-desc' object." (format "%s-autoloads" (package-desc-name pkg-desc)) (package-desc-dir pkg-desc))) -(defun package--activate-autoloads-and-load-path (pkg-desc) - "Load the autoloads file and add package dir to `load-path'. -PKG-DESC is a `package-desc' object." - (let* ((old-lp load-path) - (pkg-dir (package-desc-dir pkg-desc)) - (pkg-dir-dir (file-name-as-directory pkg-dir))) - (with-demoted-errors "Error loading autoloads: %s" - (load (package--autoloads-file-name pkg-desc) nil t)) - (when (and (eq old-lp load-path) - (not (or (member pkg-dir load-path) - (member pkg-dir-dir load-path)))) - ;; Old packages don't add themselves to the `load-path', so we have to - ;; do it ourselves. - (push pkg-dir load-path)))) - (defvar Info-directory-list) (declare-function info-initialize "info" ()) (defvar package--quickstart-pkgs t "If set to a list, we're computing the set of pkgs to activate.") -(defun package--load-files-for-activation (pkg-desc reload) - "Load files for activating a package given by PKG-DESC. -Load the autoloads file, and ensure `load-path' is setup. If -RELOAD is non-nil, also load all files in the package that -correspond to previously loaded files." - (let* ((loaded-files-list - (when reload - (package--list-loaded-files (package-desc-dir pkg-desc))))) - ;; Add to load path, add autoloads, and activate the package. - (package--activate-autoloads-and-load-path pkg-desc) - ;; Call `load' on all files in `package-desc-dir' already present in - ;; `load-history'. This is done so that macros in these files are updated - ;; to their new definitions. If another package is being installed which - ;; depends on this new definition, not doing this update would cause - ;; compilation errors and break the installation. - (with-demoted-errors "Error in package--load-files-for-activation: %s" - (mapc (lambda (feature) (load feature nil t)) - ;; Skip autoloads file since we already evaluated it above. - (remove (file-truename (package--autoloads-file-name pkg-desc)) - loaded-files-list))))) +(defsubst package--library-stem (file) + (catch 'done + (let (result) + (dolist (suffix (get-load-suffixes) file) + (setq result (string-trim file nil suffix)) + (unless (equal file result) + (throw 'done result)))))) + +(defun package--reload-previously-loaded (pkg-desc) + "Force reimportation of files in PKG-DESC already present in `load-history'. +New editions of files contain macro definitions and +redefinitions, the overlooking of which would cause +byte-compilation of the new package to fail." + (with-demoted-errors "Error in package--load-files-for-activation: %s" + (let* (result + (dir (package-desc-dir pkg-desc)) + (load-path-sans-dir + (cl-remove-if (apply-partially #'string= dir) + (or (bound-and-true-p find-function-source-path) + load-path))) + (files (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")) + (history (mapcar #'file-truename + (cl-remove-if-not #'stringp + (mapcar #'car load-history))))) + (dolist (file files) + (when-let ((library (package--library-stem + (file-relative-name file dir))) + (canonical (locate-library library nil load-path-sans-dir)) + (found (member (file-truename canonical) history)) + (recent-index (length found))) + (unless (equal (file-name-base library) + (format "%s-autoloads" (package-desc-name pkg-desc))) + (push (cons (expand-file-name library dir) recent-index) result)))) + (mapc (lambda (c) (load (car c) nil t)) + (sort result (lambda (x y) (< (cdr x) (cdr y)))))))) (defun package-activate-1 (pkg-desc &optional reload deps) "Activate package given by PKG-DESC, even if it was already active. @@ -830,7 +831,11 @@ correspond to previously loaded files (those returned by (if (listp package--quickstart-pkgs) ;; We're only collecting the set of packages to activate! (push pkg-desc package--quickstart-pkgs) - (package--load-files-for-activation pkg-desc reload)) + (when reload + (package--reload-previously-loaded pkg-desc)) + (with-demoted-errors "Error loading autoloads: %s" + (load (package--autoloads-file-name pkg-desc) nil t)) + (add-to-list 'load-path (directory-file-name pkg-dir))) ;; Add info node. (when (file-exists-p (expand-file-name "dir" pkg-dir)) ;; FIXME: not the friendliest, but simple. @@ -841,48 +846,6 @@ correspond to previously loaded files (those returned by ;; Don't return nil. t))) -(defun package--files-load-history () - (delq nil - (mapcar (lambda (x) - (let ((f (car x))) - (and (stringp f) - (file-name-sans-extension (file-truename f))))) - load-history))) - -(defun package--list-of-conflicts (dir history) - (require 'find-func) - (declare-function find-library-name "find-func" (library)) - (delq - nil - (mapcar - (lambda (x) (let* ((file (file-relative-name x dir)) - ;; Previously loaded file, if any. - (previous - (ignore-error file-error ;"Can't find library" - (file-name-sans-extension - (file-truename (find-library-name file))))) - (pos (when previous (member previous history)))) - ;; Return (RELATIVE-FILENAME . HISTORY-POSITION) - (when pos - (cons (file-name-sans-extension file) (length pos))))) - (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")))) - -(defun package--list-loaded-files (dir) - "Recursively list all files in DIR which correspond to loaded features. -Returns the `file-name-sans-extension' of each file, relative to -DIR, sorted by most recently loaded last." - (let* ((history (package--files-load-history)) - (dir (file-truename dir)) - ;; List all files that have already been loaded. - (list-of-conflicts (package--list-of-conflicts dir history))) - ;; Turn the list of (FILENAME . POS) back into a list of features. Files in - ;; subdirectories are returned relative to DIR (so not actually features). - (let ((default-directory (file-name-as-directory dir))) - (mapcar (lambda (x) (file-truename (car x))) - (sort list-of-conflicts - ;; Sort the files by ascending HISTORY-POSITION. - (lambda (x y) (< (cdr x) (cdr y)))))))) - ;;;; `package-activate' (defun package--get-activatable-pkg (pkg-name) @@ -1001,7 +964,7 @@ untar into a directory named DIR; otherwise, signal an error." (package--native-compile-async new-desc)) ;; After compilation, load again any files loaded by ;; `activate-1', so that we use the byte-compiled definitions. - (package--load-files-for-activation new-desc :reload))) + (package--reload-previously-loaded new-desc))) pkg-dir)) (defun package-generate-description-file (pkg-desc pkg-file) @@ -1042,7 +1005,8 @@ untar into a directory named DIR; otherwise, signal an error." "Make sure that the autoload file FILE exists and if not create it." (unless (file-exists-p file) (require 'autoload) - (write-region (autoload-rubric file "package" nil) nil file nil 'silent)) + (let ((coding-system-for-write 'utf-8-emacs-unix)) + (write-region (autoload-rubric file "package" nil) nil file nil 'silent))) file) (defvar autoload-timestamps) @@ -1224,13 +1188,17 @@ The return result is a `package-desc'." info) (while files (with-temp-buffer - (insert-file-contents (pop files)) - ;; When we find the file with the data, - (when (setq info (ignore-errors (package-buffer-info))) - ;; stop looping, - (setq files nil) - ;; set the 'dir kind, - (setf (package-desc-kind info) 'dir)))) + (let ((file (pop files))) + ;; The file may be a link to a nonexistent file; e.g., a + ;; lock file. + (when (file-exists-p file) + (insert-file-contents file) + ;; When we find the file with the data, + (when (setq info (ignore-errors (package-buffer-info))) + ;; stop looping, + (setq files nil) + ;; set the 'dir kind, + (setf (package-desc-kind info) 'dir)))))) (unless info (error "No .el files with package headers in `%s'" default-directory)) ;; and return the info. @@ -2072,6 +2040,7 @@ if all the in-between dependencies are also in PACKAGE-LIST." package-alist)))) (setf (package-desc-signed (car pkg-descs)) t)))))))))) +;;;###autoload (defun package-installed-p (package &optional min-version) "Return non-nil if PACKAGE, of MIN-VERSION or newer, is installed. If PACKAGE is a symbol, it is the package name and MIN-VERSION @@ -2494,6 +2463,15 @@ The description is read from the installed package files." (format "%s.el" (package-desc-name desc)) srcdir)) ""))) +(defun package--describe-add-library-links () + "Add links to library names in package description." + (while (re-search-forward "\\<\\([-[:alnum:]]+\\.el\\)\\>" nil t) + (if (locate-library (match-string 1)) + (make-text-button (match-beginning 1) (match-end 1) + 'xref (match-string-no-properties 1) + 'help-echo "Read this file's commentary" + :type 'package--finder-xref)))) + (defun describe-package-1 (pkg) "Insert the package description for PKG. Helper function for `describe-package'." @@ -2720,6 +2698,9 @@ Helper function for `describe-package'." t) (insert (or readme-string "This package does not provide a description."))))) + ;; Make library descriptions into links. + (goto-char start-of-description) + (package--describe-add-library-links) ;; Make URLs in the description into links. (goto-char start-of-description) (browse-url-add-buttons)))) @@ -2765,6 +2746,15 @@ function is a convenience wrapper used by `describe-package-1'." (apply #'insert-text-button button-text 'face button-face 'follow-link t properties))) +(defun package--finder-goto-xref (button) + "Jump to a Lisp file for the BUTTON at point." + (let* ((file (button-get button 'xref)) + (lib (locate-library file))) + (if lib (finder-commentary lib) + (message "Unable to locate `%s'" file)))) + +(define-button-type 'package--finder-xref 'action #'package--finder-goto-xref) + (defun package--print-email-button (recipient) "Insert a button whose action will send an email to RECIPIENT. NAME should have the form (FULLNAME . EMAIL) where FULLNAME is @@ -2786,35 +2776,33 @@ either a full name or nil, and EMAIL is a valid email address." ;;;; Package menu mode. -(defvar package-menu-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map tabulated-list-mode-map) - (define-key map "\C-m" 'package-menu-describe-package) - (define-key map "u" 'package-menu-mark-unmark) - (define-key map "\177" 'package-menu-backup-unmark) - (define-key map "d" 'package-menu-mark-delete) - (define-key map "i" 'package-menu-mark-install) - (define-key map "U" 'package-menu-mark-upgrades) - (define-key map "r" 'revert-buffer) - (define-key map "~" 'package-menu-mark-obsolete-for-deletion) - (define-key map "w" 'package-browse-url) - (define-key map "x" 'package-menu-execute) - (define-key map "h" 'package-menu-quick-help) - (define-key map "H" #'package-menu-hide-package) - (define-key map "?" 'package-menu-describe-package) - (define-key map "(" #'package-menu-toggle-hiding) - (define-key map (kbd "/ /") 'package-menu-clear-filter) - (define-key map (kbd "/ a") 'package-menu-filter-by-archive) - (define-key map (kbd "/ d") 'package-menu-filter-by-description) - (define-key map (kbd "/ k") 'package-menu-filter-by-keyword) - (define-key map (kbd "/ N") 'package-menu-filter-by-name-or-description) - (define-key map (kbd "/ n") 'package-menu-filter-by-name) - (define-key map (kbd "/ s") 'package-menu-filter-by-status) - (define-key map (kbd "/ v") 'package-menu-filter-by-version) - (define-key map (kbd "/ m") 'package-menu-filter-marked) - (define-key map (kbd "/ u") 'package-menu-filter-upgradable) - map) - "Local keymap for `package-menu-mode' buffers.") +(defvar-keymap package-menu-mode-map + :doc "Local keymap for `package-menu-mode' buffers." + :parent tabulated-list-mode-map + "C-m" #'package-menu-describe-package + "u" #'package-menu-mark-unmark + "DEL" #'package-menu-backup-unmark + "d" #'package-menu-mark-delete + "i" #'package-menu-mark-install + "U" #'package-menu-mark-upgrades + "r" #'revert-buffer + "~" #'package-menu-mark-obsolete-for-deletion + "w" #'package-browse-url + "x" #'package-menu-execute + "h" #'package-menu-quick-help + "H" #'package-menu-hide-package + "?" #'package-menu-describe-package + "(" #'package-menu-toggle-hiding + "/ /" #'package-menu-clear-filter + "/ a" #'package-menu-filter-by-archive + "/ d" #'package-menu-filter-by-description + "/ k" #'package-menu-filter-by-keyword + "/ N" #'package-menu-filter-by-name-or-description + "/ n" #'package-menu-filter-by-name + "/ s" #'package-menu-filter-by-status + "/ v" #'package-menu-filter-by-version + "/ m" #'package-menu-filter-marked + "/ u" #'package-menu-filter-upgradable) (easy-menu-define package-menu-mode-menu package-menu-mode-map "Menu for `package-menu-mode'." @@ -4096,7 +4084,9 @@ The list is displayed in a buffer named `*Packages*'." "Return the version number of the package in which this is used. Assumes it is used from an Elisp file placed inside the top-level directory of an installed ELPA package. -The return value is a string (or nil in case we can't find it)." +The return value is a string (or nil in case we can't find it). +It works in more cases if the call is in the file which contains +the `Version:' header." ;; In a sense, this is a lie, but it does just what we want: precompute ;; the version at compile time and hardcodes it into the .elc file! (declare (pure t)) @@ -4115,6 +4105,7 @@ The return value is a string (or nil in case we can't find it)." (let* ((pkgdir (file-name-directory file)) (pkgname (file-name-nondirectory (directory-file-name pkgdir))) (mainfile (expand-file-name (concat pkgname ".el") pkgdir))) + (unless (file-readable-p mainfile) (setq mainfile file)) (when (file-readable-p mainfile) (require 'lisp-mnt) (with-temp-buffer @@ -4201,6 +4192,7 @@ activations need to be changed, such as when `package-load-list' is modified." (replace-match (if (match-end 1) "" pfile) t t))) (unless (bolp) (insert "\n")) (insert ")\n"))) + (pp `(defvar package-activated-list) (current-buffer)) (pp `(setq package-activated-list (append ',(mapcar #'package-desc-name package--quickstart-pkgs) package-activated-list)) @@ -4218,6 +4210,7 @@ activations need to be changed, such as when `package-load-list' is modified." ;; Local\sVariables: ;; version-control: never ;; no-update-autoloads: t +;; byte-compile-warnings: (not make-local) ;; End: ")) ;; FIXME: Do it asynchronously in an Emacs subprocess, and diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 7a82b416e55..0330a2a0aba 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -435,7 +435,7 @@ how many time this CODEGEN is called." (macroexp-warn-and-return (format "pcase pattern %S shadowed by previous pcase pattern" (car case)) - main)))) + main nil nil (car case))))) main))) (defun pcase--expand (exp cases) @@ -941,7 +941,7 @@ Otherwise, it defers to REST which is a list of branches of the form (if (eq upat '_) code (macroexp-warn-and-return "Pattern t is deprecated. Use `_' instead" - code)))) + code nil nil upat)))) ((eq upat 'pcase--dontcare) :pcase--dontcare) ((memq (car-safe upat) '(guard pred)) (if (eq (car upat) 'pred) (pcase--mark-used sym)) diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index 9a48c7f908e..e782cdb1dab 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -24,6 +24,7 @@ ;;; Code: +(require 'cl-lib) (defvar font-lock-verbose) (defgroup pp nil @@ -33,22 +34,43 @@ (defcustom pp-escape-newlines t "Value of `print-escape-newlines' used by pp-* functions." + :type 'boolean) + +(defcustom pp-max-width t + "Max width to use when formatting. +If nil, there's no max width. If t, use the window width. +Otherwise this should be a number." + :type '(choice (const :tag "none" nil) + (const :tag "window width" t) + number) + :version "29.1") + +(defcustom pp-use-max-width nil + "If non-nil, `pp'-related functions will try to fold lines. +The target width is given by the `pp-max-width' variable." :type 'boolean - :group 'pp) + :version "29.1") + +(defvar pp--inhibit-function-formatting nil) ;;;###autoload (defun pp-to-string (object) "Return a string containing the pretty-printed representation of OBJECT. OBJECT can be any Lisp object. Quoting characters are used as needed to make output that `read' can handle, whenever this is possible." - (with-temp-buffer - (lisp-mode-variables nil) - (set-syntax-table emacs-lisp-mode-syntax-table) - (let ((print-escape-newlines pp-escape-newlines) - (print-quoted t)) - (prin1 object (current-buffer))) - (pp-buffer) - (buffer-string))) + (if pp-use-max-width + (let ((pp--inhibit-function-formatting t)) + (with-temp-buffer + (pp-emacs-lisp-code object) + (buffer-string))) + (with-temp-buffer + (lisp-mode-variables nil) + (set-syntax-table emacs-lisp-mode-syntax-table) + (let ((print-escape-newlines pp-escape-newlines) + (print-quoted t)) + (prin1 object (current-buffer))) + (pp-buffer) + (buffer-string)))) ;;;###autoload (defun pp-buffer () @@ -56,7 +78,6 @@ to make output that `read' can handle, whenever this is possible." (interactive) (goto-char (point-min)) (while (not (eobp)) - ;; (message "%06d" (- (point-max) (point))) (cond ((ignore-errors (down-list 1) t) (save-excursion @@ -82,11 +103,21 @@ to make output that `read' can handle, whenever this is possible." "Output the pretty-printed representation of OBJECT, any Lisp object. Quoting characters are printed as needed to make output that `read' can handle, whenever this is possible. + +This function does not apply special formatting rules for Emacs +Lisp code. See `pp-emacs-lisp-code' instead. + +By default, this function won't limit the line length of lists +and vectors. Bind `pp-use-max-width' to a non-nil value to do so. + Output stream is STREAM, or value of `standard-output' (which see)." (princ (pp-to-string object) (or stream standard-output))) -(defun pp-display-expression (expression out-buffer-name) +;;;###autoload +(defun pp-display-expression (expression out-buffer-name &optional lisp) "Prettify and display EXPRESSION in an appropriate way, depending on length. +If LISP, format with `pp-emacs-lisp-code'; use `pp' otherwise. + If a temporary buffer is needed for representation, it will be named after OUT-BUFFER-NAME." (let* ((old-show-function temp-buffer-show-function) @@ -110,11 +141,13 @@ after OUT-BUFFER-NAME." (select-window window) (run-hooks 'temp-buffer-show-hook)) (when (window-live-p old-selected) - (select-window old-selected)) - (message "See buffer %s." out-buffer-name))) + (select-window old-selected)))) (message "%s" (buffer-substring (point-min) (point)))))))) (with-output-to-temp-buffer out-buffer-name - (pp expression) + (if lisp + (with-current-buffer standard-output + (pp-emacs-lisp-code expression)) + (pp expression)) (with-current-buffer standard-output (emacs-lisp-mode) (setq buffer-read-only nil) @@ -179,6 +212,192 @@ Ignores leading comment characters." (insert (pp-to-string (macroexpand-1 (pp-last-sexp)))) (pp-macroexpand-expression (pp-last-sexp)))) +;;;###autoload +(defun pp-emacs-lisp-code (sexp) + "Insert SEXP into the current buffer, formatted as Emacs Lisp code. +Use the `pp-max-width' variable to control the desired line length." + (require 'edebug) + (let ((obuf (current-buffer))) + (with-temp-buffer + (emacs-lisp-mode) + (pp--insert-lisp sexp) + (insert "\n") + (goto-char (point-min)) + (indent-sexp) + (while (re-search-forward " +$" nil t) + (replace-match "")) + (insert-into-buffer obuf)))) + +(defun pp--insert-lisp (sexp) + (cl-case (type-of sexp) + (vector (pp--format-vector sexp)) + (cons (cond + ((consp (cdr sexp)) + (if (and (length= sexp 2) + (memq (car sexp) '(quote function))) + (cond + ((symbolp (cadr sexp)) + (let ((print-quoted t)) + (prin1 sexp (current-buffer)))) + ((consp (cadr sexp)) + (insert (if (eq (car sexp) 'quote) + "'" "#'")) + (pp--format-list (cadr sexp) + (set-marker (make-marker) (1- (point)))))) + (pp--format-list sexp))) + (t + (princ sexp (current-buffer))))) + ;; Print some of the smaller integers as characters, perhaps? + (integer + (if (<= ?0 sexp ?z) + (let ((print-integers-as-characters t)) + (princ sexp (current-buffer))) + (princ sexp (current-buffer)))) + (string + (let ((print-escape-newlines t)) + (prin1 sexp (current-buffer)))) + (otherwise (princ sexp (current-buffer))))) + +(defun pp--format-vector (sexp) + (insert "[") + (cl-loop for i from 0 + for element across sexp + do (pp--insert (and (> i 0) " ") element)) + (insert "]")) + +(defun pp--format-list (sexp &optional start) + (if (and (symbolp (car sexp)) + (not pp--inhibit-function-formatting) + (not (keywordp (car sexp)))) + (pp--format-function sexp) + (insert "(") + (pp--insert start (pop sexp)) + (while sexp + (if (consp sexp) + (pp--insert " " (pop sexp)) + (pp--insert " . " sexp) + (setq sexp nil))) + (insert ")"))) + +(defun pp--format-function (sexp) + (let* ((sym (car sexp)) + (edebug (get sym 'edebug-form-spec)) + (indent (get sym 'lisp-indent-function)) + (doc (get sym 'doc-string-elt))) + (when (eq indent 'defun) + (setq indent 2)) + ;; We probably want to keep all the elements before the doc string + ;; on a single line. + (when doc + (setq indent (1- doc))) + ;; Special-case closures -- these shouldn't really exist in actual + ;; source code, so there's no indentation information. But make + ;; them output slightly better. + (when (and (not indent) + (eq sym 'closure)) + (setq indent 0)) + (pp--insert "(" sym) + (pop sexp) + ;; Get the first entries on the first line. + (if indent + (pp--format-definition sexp indent edebug) + (let ((prev 0)) + (while sexp + (let ((start (point))) + ;; Don't put sexps on the same line as a multi-line sexp + ;; preceding it. + (pp--insert (if (> prev 1) "\n" " ") + (pop sexp)) + (setq prev (count-lines start (point))))))) + (insert ")"))) + +(defun pp--format-definition (sexp indent edebug) + (while (and (cl-plusp indent) + sexp) + (insert " ") + ;; We don't understand all the edebug specs. + (unless (consp edebug) + (setq edebug nil)) + (if (and (consp (car edebug)) + (eq (caar edebug) '&rest)) + (pp--insert-binding (pop sexp)) + (if (null (car sexp)) + (insert "()") + (pp--insert-lisp (car sexp))) + (pop sexp)) + (pop edebug) + (cl-decf indent)) + (when (stringp (car sexp)) + (insert "\n") + (prin1 (pop sexp) (current-buffer))) + ;; Then insert the rest with line breaks before each form. + (while sexp + (insert "\n") + (if (keywordp (car sexp)) + (progn + (pp--insert-lisp (pop sexp)) + (when sexp + (pp--insert " " (pop sexp)))) + (pp--insert-lisp (pop sexp))))) + +(defun pp--insert-binding (sexp) + (insert "(") + (while sexp + (if (consp (car sexp)) + ;; Newlines after each (...) binding. + (progn + (pp--insert-lisp (car sexp)) + (when (cdr sexp) + (insert "\n"))) + ;; Keep plain symbols on the same line. + (pp--insert " " (car sexp))) + (pop sexp)) + (insert ")")) + +(defun pp--insert (delim &rest things) + (let ((start (if (markerp delim) + (prog1 + delim + (setq delim nil)) + (point-marker)))) + (when delim + (insert delim)) + (dolist (thing things) + (pp--insert-lisp thing)) + ;; We need to indent what we have so far to see if we have to fold. + (pp--indent-buffer) + (when (> (current-column) (pp--max-width)) + (save-excursion + (goto-char start) + (unless (looking-at "[ \t]+$") + (insert "\n")) + (pp--indent-buffer) + (goto-char (point-max)) + ;; If we're still too wide, then go up one step and try to + ;; insert a newline there. + (when (> (current-column) (pp--max-width)) + (condition-case () + (backward-up-list 1) + (:success (when (looking-back " " 2) + (insert "\n"))) + (error nil))))))) + +(defun pp--max-width () + (cond ((numberp pp-max-width) + pp-max-width) + ((null pp-max-width) + most-positive-fixnum) + ((eq pp-max-width t) + (window-width)) + (t + (error "Invalid pp-max-width value: %s" pp-max-width)))) + +(defun pp--indent-buffer () + (goto-char (point-min)) + (while (not (eobp)) + (lisp-indent-line) + (forward-line 1))) + (provide 'pp) ; so (require 'pp) works ;;; pp.el ends here diff --git a/lisp/emacs-lisp/range.el b/lisp/emacs-lisp/range.el new file mode 100644 index 00000000000..38c2866cd4c --- /dev/null +++ b/lisp/emacs-lisp/range.el @@ -0,0 +1,467 @@ +;;; ranges.el --- range functions -*- lexical-binding: t; -*- + +;; Copyright (C) 1996-2022 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; A "range" is a list that represents a list of integers. A range is +;; a list containing cons cells of start/end pairs, as well as integers. +;; +;; ((2 . 5) 9 (11 . 13)) +;; +;; represents the list (2 3 4 5 9 11 12 13). + +;;; Code: + +(defun range-normalize (range) + "Normalize RANGE. +If RANGE is a single range, return (RANGE). Otherwise, return RANGE." + (if (listp (cdr-safe range)) + range + (list range))) + +(defun range-denormalize (range) + "If RANGE contains a single range, then return that. +If not, return RANGE as is." + (if (and (consp (car range)) + (length= range 1)) + (car range) + range)) + +(defun range-difference (range1 range2) + "Return the range of elements in RANGE1 that do not appear in RANGE2. +Both ranges must be in ascending order." + (setq range1 (range-normalize range1)) + (setq range2 (range-normalize range2)) + (let* ((new-range (cons nil (copy-sequence range1))) + (r new-range)) + (while (cdr r) + (let* ((r1 (cadr r)) + (r2 (car range2)) + (min1 (if (numberp r1) r1 (car r1))) + (max1 (if (numberp r1) r1 (cdr r1))) + (min2 (if (numberp r2) r2 (car r2))) + (max2 (if (numberp r2) r2 (cdr r2)))) + + (cond ((> min1 max1) + ;; Invalid range: may result from overlap condition (below) + ;; remove Invalid range + (setcdr r (cddr r))) + ((and (= min1 max1) + (listp r1)) + ;; Inefficient representation: may result from overlap + ;; condition (below) + (setcar (cdr r) min1)) + ((not min2) + ;; All done with range2 + (setq r nil)) + ((< max1 min2) + ;; No overlap: range1 precedes range2 + (pop r)) + ((< max2 min1) + ;; No overlap: range2 precedes range1 + (pop range2)) + ((and (<= min2 min1) (<= max1 max2)) + ;; Complete overlap: range1 removed + (setcdr r (cddr r))) + (t + (setcdr r (nconc (list (cons min1 (1- min2)) + (cons (1+ max2) max1)) + (cddr r))))))) + (cdr new-range))) + +(defun range-intersection (range1 range2) + "Return intersection of RANGE1 and RANGE2." + (let* (out + (min1 (car range1)) + (max1 (if (numberp min1) + (if (numberp (cdr range1)) + (prog1 (cdr range1) + (setq range1 nil)) min1) + (prog1 (cdr min1) + (setq min1 (car min1))))) + (min2 (car range2)) + (max2 (if (numberp min2) + (if (numberp (cdr range2)) + (prog1 (cdr range2) + (setq range2 nil)) min2) + (prog1 (cdr min2) + (setq min2 (car min2)))))) + (setq range1 (cdr range1) + range2 (cdr range2)) + (while (and min1 min2) + (cond ((< max1 min2) ; range1 precedes range2 + (setq range1 (cdr range1) + min1 nil)) + ((< max2 min1) ; range2 precedes range1 + (setq range2 (cdr range2) + min2 nil)) + (t ; some sort of overlap is occurring + (let ((min (max min1 min2)) + (max (min max1 max2))) + (setq out (if (= min max) + (cons min out) + (cons (cons min max) out)))) + (if (< max1 max2) ; range1 ends before range2 + (setq min1 nil) ; incr range1 + (setq min2 nil)))) ; incr range2 + (unless min1 + (setq min1 (car range1) + max1 (if (numberp min1) min1 + (prog1 (cdr min1) (setq min1 (car min1)))) + range1 (cdr range1))) + (unless min2 + (setq min2 (car range2) + max2 (if (numberp min2) min2 + (prog1 (cdr min2) (setq min2 (car min2)))) + range2 (cdr range2)))) + (cond ((cdr out) + (nreverse out)) + ((numberp (car out)) + out) + (t + (car out))))) + +(defun range-compress-list (numbers) + "Convert a sorted list of numbers to a range list." + (let ((first (car numbers)) + (last (car numbers)) + result) + (cond + ((null numbers) + nil) + ((not (listp (cdr numbers))) + numbers) + (t + (while numbers + (cond ((= last (car numbers)) nil) ;Omit duplicated number + ((= (1+ last) (car numbers)) ;Still in sequence + (setq last (car numbers))) + (t ;End of one sequence + (setq result + (cons (if (= first last) first + (cons first last)) + result)) + (setq first (car numbers)) + (setq last (car numbers)))) + (setq numbers (cdr numbers))) + (nreverse (cons (if (= first last) first (cons first last)) + result)))))) + +(defun range-uncompress (ranges) + "Expand a list of ranges into a list of numbers. +RANGES is either a single range on the form `(num . num)' or a list of +these ranges." + (let (first last result) + (cond + ((null ranges) + nil) + ((not (listp (cdr ranges))) + (setq first (car ranges)) + (setq last (cdr ranges)) + (while (<= first last) + (setq result (cons first result)) + (setq first (1+ first))) + (nreverse result)) + (t + (while ranges + (if (atom (car ranges)) + (when (numberp (car ranges)) + (setq result (cons (car ranges) result))) + (setq first (caar ranges)) + (setq last (cdar ranges)) + (while (<= first last) + (setq result (cons first result)) + (setq first (1+ first)))) + (setq ranges (cdr ranges))) + (nreverse result))))) + +(defun range-add-list (ranges list) + "Return a list of ranges that has all articles from both RANGES and LIST. +Note: LIST has to be sorted over `<'." + (if (not ranges) + (range-compress-list list) + (setq list (copy-sequence list)) + (unless (listp (cdr ranges)) + (setq ranges (list ranges))) + (let ((out ranges) + ilist lowest highest temp) + (while (and ranges list) + (setq ilist list) + (setq lowest (or (and (atom (car ranges)) (car ranges)) + (caar ranges))) + (while (and list (cdr list) (< (cadr list) lowest)) + (setq list (cdr list))) + (when (< (car ilist) lowest) + (setq temp list) + (setq list (cdr list)) + (setcdr temp nil) + (setq out (nconc (range-compress-list ilist) out))) + (setq highest (or (and (atom (car ranges)) (car ranges)) + (cdar ranges))) + (while (and list (<= (car list) highest)) + (setq list (cdr list))) + (setq ranges (cdr ranges))) + (when list + (setq out (nconc (range-compress-list list) out))) + (setq out (sort out (lambda (r1 r2) + (< (or (and (atom r1) r1) (car r1)) + (or (and (atom r2) r2) (car r2)))))) + (setq ranges out) + (while ranges + (if (atom (car ranges)) + (when (cdr ranges) + (if (atom (cadr ranges)) + (when (= (1+ (car ranges)) (cadr ranges)) + (setcar ranges (cons (car ranges) + (cadr ranges))) + (setcdr ranges (cddr ranges))) + (when (= (1+ (car ranges)) (caadr ranges)) + (setcar (cadr ranges) (car ranges)) + (setcar ranges (cadr ranges)) + (setcdr ranges (cddr ranges))))) + (when (cdr ranges) + (if (atom (cadr ranges)) + (when (= (1+ (cdar ranges)) (cadr ranges)) + (setcdr (car ranges) (cadr ranges)) + (setcdr ranges (cddr ranges))) + (when (= (1+ (cdar ranges)) (caadr ranges)) + (setcdr (car ranges) (cdadr ranges)) + (setcdr ranges (cddr ranges)))))) + (setq ranges (cdr ranges))) + out))) + +(defun range-remove (range1 range2) + "Return a range that has all articles from RANGE2 removed from RANGE1. +The returned range is always a list. RANGE2 can also be a unsorted +list of articles. RANGE1 is modified by side effects, RANGE2 is not +modified." + (if (or (null range1) (null range2)) + range1 + (let (out r1 r2 r1-min r1-max r2-min r2-max + (range2 (copy-tree range2))) + (setq range1 (if (listp (cdr range1)) range1 (list range1)) + range2 (sort (if (listp (cdr range2)) range2 (list range2)) + (lambda (e1 e2) + (< (if (consp e1) (car e1) e1) + (if (consp e2) (car e2) e2)))) + r1 (car range1) + r2 (car range2) + r1-min (if (consp r1) (car r1) r1) + r1-max (if (consp r1) (cdr r1) r1) + r2-min (if (consp r2) (car r2) r2) + r2-max (if (consp r2) (cdr r2) r2)) + (while (and range1 range2) + (cond ((< r2-max r1-min) ; r2 < r1 + (pop range2) + (setq r2 (car range2) + r2-min (if (consp r2) (car r2) r2) + r2-max (if (consp r2) (cdr r2) r2))) + ((and (<= r2-min r1-min) (<= r1-max r2-max)) ; r2 overlap r1 + (pop range1) + (setq r1 (car range1) + r1-min (if (consp r1) (car r1) r1) + r1-max (if (consp r1) (cdr r1) r1))) + ((and (<= r2-min r1-min) (<= r2-max r1-max)) ; r2 overlap min r1 + (pop range2) + (setq r1-min (1+ r2-max) + r2 (car range2) + r2-min (if (consp r2) (car r2) r2) + r2-max (if (consp r2) (cdr r2) r2))) + ((and (<= r1-min r2-min) (<= r2-max r1-max)) ; r2 contained in r1 + (if (eq r1-min (1- r2-min)) + (push r1-min out) + (push (cons r1-min (1- r2-min)) out)) + (pop range2) + (if (< r2-max r1-max) ; finished with r1? + (setq r1-min (1+ r2-max)) + (pop range1) + (setq r1 (car range1) + r1-min (if (consp r1) (car r1) r1) + r1-max (if (consp r1) (cdr r1) r1))) + (setq r2 (car range2) + r2-min (if (consp r2) (car r2) r2) + r2-max (if (consp r2) (cdr r2) r2))) + ((and (<= r2-min r1-max) (<= r1-max r2-max)) ; r2 overlap max r1 + (if (eq r1-min (1- r2-min)) + (push r1-min out) + (push (cons r1-min (1- r2-min)) out)) + (pop range1) + (setq r1 (car range1) + r1-min (if (consp r1) (car r1) r1) + r1-max (if (consp r1) (cdr r1) r1))) + ((< r1-max r2-min) ; r2 > r1 + (pop range1) + (if (eq r1-min r1-max) + (push r1-min out) + (push (cons r1-min r1-max) out)) + (setq r1 (car range1) + r1-min (if (consp r1) (car r1) r1) + r1-max (if (consp r1) (cdr r1) r1))))) + (when r1 + (if (eq r1-min r1-max) + (push r1-min out) + (push (cons r1-min r1-max) out)) + (pop range1)) + (while range1 + (push (pop range1) out)) + (nreverse out)))) + +(defun range-member-p (number ranges) + "Say whether NUMBER is in RANGES." + (if (not (listp (cdr ranges))) + (and (>= number (car ranges)) + (<= number (cdr ranges))) + (let ((not-stop t)) + (while (and ranges + (if (numberp (car ranges)) + (>= number (car ranges)) + (>= number (caar ranges))) + not-stop) + (when (if (numberp (car ranges)) + (= number (car ranges)) + (and (>= number (caar ranges)) + (<= number (cdar ranges)))) + (setq not-stop nil)) + (setq ranges (cdr ranges))) + (not not-stop)))) + +(defun range-list-intersection (list ranges) + "Return a list of numbers in LIST that are members of RANGES. +oLIST is a sorted list." + (setq ranges (range-normalize ranges)) + (let (number result) + (while (setq number (pop list)) + (while (and ranges + (if (numberp (car ranges)) + (< (car ranges) number) + (< (cdar ranges) number))) + (setq ranges (cdr ranges))) + (when (and ranges + (if (numberp (car ranges)) + (= (car ranges) number) + ;; (caar ranges) <= number <= (cdar ranges) + (>= number (caar ranges)))) + (push number result))) + (nreverse result))) + +(defun range-list-difference (list ranges) + "Return a list of numbers in LIST that are not members of RANGES. +LIST is a sorted list." + (setq ranges (range-normalize ranges)) + (let (number result) + (while (setq number (pop list)) + (while (and ranges + (if (numberp (car ranges)) + (< (car ranges) number) + (< (cdar ranges) number))) + (setq ranges (cdr ranges))) + (when (or (not ranges) + (if (numberp (car ranges)) + (not (= (car ranges) number)) + ;; not ((caar ranges) <= number <= (cdar ranges)) + (< number (caar ranges)))) + (push number result))) + (nreverse result))) + +(defun range-length (range) + "Return the length RANGE would have if uncompressed." + (cond + ((null range) + 0) + ((not (listp (cdr range))) + (- (cdr range) (car range) -1)) + (t + (let ((sum 0)) + (dolist (x range sum) + (setq sum + (+ sum (if (consp x) (- (cdr x) (car x) -1) 1)))))))) + +(defun range-concat (range1 range2) + "Add RANGE2 to RANGE1 (nondestructively)." + (unless (listp (cdr range1)) + (setq range1 (list range1))) + (unless (listp (cdr range2)) + (setq range2 (list range2))) + (let ((item1 (pop range1)) + (item2 (pop range2)) + range item selector) + (while (or item1 item2) + (setq selector + (cond + ((null item1) nil) + ((null item2) t) + ((and (numberp item1) (numberp item2)) (< item1 item2)) + ((numberp item1) (< item1 (car item2))) + ((numberp item2) (< (car item1) item2)) + (t (< (car item1) (car item2))))) + (setq item + (or + (let ((tmp1 item) (tmp2 (if selector item1 item2))) + (cond + ((null tmp1) tmp2) + ((null tmp2) tmp1) + ((and (numberp tmp1) (numberp tmp2)) + (cond + ((eq tmp1 tmp2) tmp1) + ((eq (1+ tmp1) tmp2) (cons tmp1 tmp2)) + ((eq (1+ tmp2) tmp1) (cons tmp2 tmp1)) + (t nil))) + ((numberp tmp1) + (cond + ((and (>= tmp1 (car tmp2)) (<= tmp1 (cdr tmp2))) tmp2) + ((eq (1+ tmp1) (car tmp2)) (cons tmp1 (cdr tmp2))) + ((eq (1- tmp1) (cdr tmp2)) (cons (car tmp2) tmp1)) + (t nil))) + ((numberp tmp2) + (cond + ((and (>= tmp2 (car tmp1)) (<= tmp2 (cdr tmp1))) tmp1) + ((eq (1+ tmp2) (car tmp1)) (cons tmp2 (cdr tmp1))) + ((eq (1- tmp2) (cdr tmp1)) (cons (car tmp1) tmp2)) + (t nil))) + ((< (1+ (cdr tmp1)) (car tmp2)) nil) + ((< (1+ (cdr tmp2)) (car tmp1)) nil) + (t (cons (min (car tmp1) (car tmp2)) + (max (cdr tmp1) (cdr tmp2)))))) + (progn + (if item (push item range)) + (if selector item1 item2)))) + (if selector + (setq item1 (pop range1)) + (setq item2 (pop range2)))) + (if item (push item range)) + (reverse range))) + +(defun range-map (func range) + "Apply FUNC to each value contained by RANGE." + (setq range (range-normalize range)) + (while range + (let ((span (pop range))) + (if (numberp span) + (funcall func span) + (let ((first (car span)) + (last (cdr span))) + (while (<= first last) + (funcall func first) + (setq first (1+ first)))))))) + +(provide 'range) + +;;; range.el ends here diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index d460407a803..24770fac67f 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -274,8 +274,8 @@ Except for Lisp syntax this is the same as `reb-regexp'.") emacs-lisp-mode "RE Builder Lisp" "Major mode for interactively building symbolic Regular Expressions." ;; Pull in packages as needed - (cond ((memq reb-re-syntax '(sregex rx)) ; rx-to-string is autoloaded - (require 'rx))) ; require rx anyway + (when (eq reb-re-syntax 'rx) ; rx-to-string is autoloaded + (require 'rx)) ; require rx anyway (reb-mode-common)) (defvar reb-subexp-mode-map @@ -307,8 +307,8 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (eq 'color (frame-parameter nil 'display-type))) (defsubst reb-lisp-syntax-p () - "Return non-nil if RE Builder uses a Lisp syntax." - (memq reb-re-syntax '(sregex rx))) + "Return non-nil if RE Builder uses `rx' syntax." + (eq reb-re-syntax 'rx)) (defmacro reb-target-binding (symbol) "Return binding for SYMBOL in the RE Builder target buffer." @@ -323,7 +323,10 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (reb-lisp-mode)) (t (reb-mode))) (reb-restart-font-lock) - (reb-do-update)) + ;; When using `rx' syntax, the initial syntax () is invalid. But + ;; don't signal an error in that case. + (ignore-errors + (reb-do-update))) (defun reb-mode-buffer-p () "Return non-nil if the current buffer is a RE Builder buffer." @@ -448,7 +451,8 @@ provided in the Commentary section of this library." (setq reb-subexp-mode t) (reb-update-modestring) (use-local-map reb-subexp-mode-map) - (message "`0'-`9' to display subexpressions `q' to quit subexp mode")) + (message (substitute-command-keys + "\\`0'-\\`9' to display subexpressions \\`q' to quit subexp mode"))) (defun reb-show-subexp (subexp &optional pause) "Visually show limit of subexpression SUBEXP of recent search. @@ -482,11 +486,11 @@ Optional argument SYNTAX must be specified if called non-interactively." (list (intern (completing-read (format-prompt "Select syntax" reb-re-syntax) - '(read string sregex rx) + '(read string rx) nil t nil nil (symbol-name reb-re-syntax) 'reb-change-syntax-hist)))) - (if (memq syntax '(read string sregex rx)) + (if (memq syntax '(read string rx)) (let ((buffer (get-buffer reb-buffer))) (setq reb-re-syntax syntax) (when buffer @@ -605,9 +609,9 @@ optional fourth argument FORCE is non-nil." (defun reb-cook-regexp (re) "Return RE after processing it according to `reb-re-syntax'." - (cond ((memq reb-re-syntax '(sregex rx)) - (rx-to-string (eval (car (read-from-string re))))) - (t re))) + (if (eq reb-re-syntax 'rx) + (rx-to-string (eval (car (read-from-string re)))) + re)) (defun reb-update-regexp () "Update the regexp for the target buffer. diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el index df0fc339e6d..195035e6be9 100644 --- a/lisp/emacs-lisp/rmc.el +++ b/lisp/emacs-lisp/rmc.el @@ -25,8 +25,107 @@ (require 'seq) +(defun rmc--add-key-description (elem) + (let* ((char (car elem)) + (name (cadr elem)) + (pos (seq-position name char)) + (desc (key-description (char-to-string char))) + (graphical-terminal + (display-supports-face-attributes-p + '(:underline t) (window-frame))) + (altered-name + (cond + ;; Not in the name string, or a special character. + ((or (not pos) + (member desc '("ESC" "TAB" "RET" "DEL" "SPC"))) + (format "%s %s" + (if graphical-terminal + (propertize desc 'face 'read-multiple-choice-face) + (propertize desc 'face 'help-key-binding)) + name)) + ;; The prompt character is in the name, so highlight + ;; it on graphical terminals. + (graphical-terminal + (setq name (copy-sequence name)) + (put-text-property pos (1+ pos) + 'face 'read-multiple-choice-face + name) + name) + ;; And put it in [bracket] on non-graphical terminals. + (t + (concat + (substring name 0 pos) + "[" + (upcase (substring name pos (1+ pos))) + "]" + (substring name (1+ pos))))))) + (cons char altered-name))) + +(defun rmc--show-help (prompt help-string show-help choices altered-names) + (let* ((buf-name (if (stringp show-help) + show-help + "*Multiple Choice Help*")) + (buf (get-buffer-create buf-name))) + (if (stringp help-string) + (with-help-window buf + (with-current-buffer buf + (insert help-string))) + (with-help-window buf + (with-current-buffer buf + (erase-buffer) + (pop-to-buffer buf) + (insert prompt "\n\n") + (let* ((columns (/ (window-width) 25)) + (fill-column 21) + (times 0) + (start (point))) + (dolist (elem choices) + (goto-char start) + (unless (zerop times) + (if (zerop (mod times columns)) + ;; Go to the next "line". + (goto-char (setq start (point-max))) + ;; Add padding. + (while (not (eobp)) + (end-of-line) + (insert (make-string (max (- (* (mod times columns) + (+ fill-column 4)) + (current-column)) + 0) + ?\s)) + (forward-line 1)))) + (setq times (1+ times)) + (let ((text + (with-temp-buffer + (insert (format + "%c: %s\n" + (car elem) + (cdr (assq (car elem) altered-names)))) + (fill-region (point-min) (point-max)) + (when (nth 2 elem) + (let ((start (point))) + (insert (nth 2 elem)) + (unless (bolp) + (insert "\n")) + (fill-region start (point-max)))) + (buffer-string)))) + (goto-char start) + (dolist (line (split-string text "\n")) + (end-of-line) + (if (not (bolp)) + (insert line) + (insert (make-string + (max (- (* (mod (1- times) columns) + (+ fill-column 4)) + (current-column)) + 0) + ?\s)) + (insert line "\n")) + (forward-line 1)))))))) + buf)) + ;;;###autoload -(defun read-multiple-choice (prompt choices &optional help-string) +(defun read-multiple-choice (prompt choices &optional help-string show-help) "Ask user to select an entry from CHOICES, promting with PROMPT. This function allows to ask the user a multiple-choice question. @@ -42,6 +141,9 @@ the optional argument HELP-STRING. This argument is a string that should contain a more detailed description of all of the possible choices. `read-multiple-choice' will display that description in a help buffer if the user requests that. +If optional argument SHOW-HELP is non-nil, show the help screen +immediately, before any user input. If SHOW-HELP is a string, +use it as the name of the help buffer. This function translates user input into responses by consulting the bindings in `query-replace-map'; see the documentation of @@ -67,45 +169,20 @@ Usage example: \\='((?a \"always\") (?s \"session only\") (?n \"no\")))" - (let* ((altered-names nil) + (let* ((prompt-choices + (if show-help choices (append choices '((?? "?"))))) + (altered-names (mapcar #'rmc--add-key-description prompt-choices)) (full-prompt (format "%s (%s): " prompt - (mapconcat - (lambda (elem) - (let* ((name (cadr elem)) - (pos (seq-position name (car elem))) - (altered-name - (cond - ;; Not in the name string. - ((not pos) - (format "[%c] %s" (car elem) name)) - ;; The prompt character is in the name, so highlight - ;; it on graphical terminals... - ((display-supports-face-attributes-p - '(:underline t) (window-frame)) - (setq name (copy-sequence name)) - (put-text-property pos (1+ pos) - 'face 'read-multiple-choice-face - name) - name) - ;; And put it in [bracket] on non-graphical terminals. - (t - (concat - (substring name 0 pos) - "[" - (upcase (substring name pos (1+ pos))) - "]" - (substring name (1+ pos))))))) - (push (cons (car elem) altered-name) - altered-names) - altered-name)) - (append choices '((?? "?"))) - ", "))) + (mapconcat (lambda (e) (cdr e)) altered-names ", "))) tchar buf wrong-char answer) (save-window-excursion (save-excursion + (if show-help + (setq buf (rmc--show-help prompt help-string show-help + choices altered-names))) (while (not tchar) (message "%s%s" (if wrong-char @@ -124,7 +201,7 @@ Usage example: (lambda (elem) (cons (capitalize (cadr elem)) (car elem))) - choices))) + prompt-choices))) (condition-case nil (let ((cursor-in-echo-area t)) (read-event)) @@ -161,57 +238,8 @@ Usage example: tchar nil) (when wrong-char (ding)) - (setq buf (get-buffer-create "*Multiple Choice Help*")) - (if (stringp help-string) - (with-help-window buf - (with-current-buffer buf - (insert help-string))) - (with-help-window buf - (with-current-buffer buf - (erase-buffer) - (pop-to-buffer buf) - (insert prompt "\n\n") - (let* ((columns (/ (window-width) 25)) - (fill-column 21) - (times 0) - (start (point))) - (dolist (elem choices) - (goto-char start) - (unless (zerop times) - (if (zerop (mod times columns)) - ;; Go to the next "line". - (goto-char (setq start (point-max))) - ;; Add padding. - (while (not (eobp)) - (end-of-line) - (insert (make-string (max (- (* (mod times columns) - (+ fill-column 4)) - (current-column)) - 0) - ?\s)) - (forward-line 1)))) - (setq times (1+ times)) - (let ((text - (with-temp-buffer - (insert (format - "%c: %s\n" - (car elem) - (cdr (assq (car elem) altered-names)))) - (fill-region (point-min) (point-max)) - (when (nth 2 elem) - (let ((start (point))) - (insert (nth 2 elem)) - (unless (bolp) - (insert "\n")) - (fill-region start (point-max)))) - (buffer-string)))) - (goto-char start) - (dolist (line (split-string text "\n")) - (end-of-line) - (if (bolp) - (insert line "\n") - (insert line)) - (forward-line 1)))))))))))) + (setq buf (rmc--show-help prompt help-string show-help + choices altered-names)))))) (when (buffer-live-p buf) (kill-buffer buf)) (assq tchar choices))) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index abfe51d32b5..1bcb844d8e9 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -299,6 +299,7 @@ sorted. FUNCTION must be a function of one argument." TYPE must be one of following symbols: vector, string or list. \n(fn TYPE SEQUENCE...)" + (setq sequences (mapcar #'seq-into-sequence sequences)) (pcase type ('vector (apply #'vconcat sequences)) ('string (apply #'concat sequences)) @@ -417,8 +418,9 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." Equality is defined by TESTFN if non-nil or by `equal' if nil." (catch 'seq--break (seq-doseq (e sequence) - (when (funcall (or testfn #'equal) e elt) - (throw 'seq--break t))) + (let ((r (funcall (or testfn #'equal) e elt))) + (when r + (throw 'seq--break r)))) nil)) (cl-defgeneric seq-set-equal-p (sequence1 sequence2 &optional testfn) diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index 2c83bc7b503..8cd371321ae 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -151,9 +151,6 @@ See the documentation for `list-load-path-shadows' for further information." ;; Return the list of shadowings. shadows)) -(define-obsolete-function-alias 'find-emacs-lisp-shadows - 'load-path-shadows-find "23.3") - ;; Return true if neither file exists, or if both exist and have identical ;; contents. (defun load-path-shadows-same-file-or-nonexistent (f1 f2) diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 99035c9e892..658edd67527 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -71,6 +71,7 @@ string, it'll be inserted as is, then the string will be `read', and then evaluated. There can be any number of :example/:result elements." + (declare (indent defun)) `(progn (setq shortdoc--groups (delq (assq ',group shortdoc--groups) shortdoc--groups)) @@ -195,6 +196,13 @@ There can be any number of :example/:result elements." :eval (substring-no-properties (propertize "foobar" 'face 'bold) 0 3)) (try-completion :eval (try-completion "foo" '("foobar" "foozot" "gazonk"))) + "Unicode Strings" + (string-glyph-split + :eval (string-glyph-split "Hello, 👼🏻🧑🏼🤝🧑🏻")) + (string-glyph-compose + :eval (string-glyph-compose "Å")) + (string-glyph-decompose + :eval (string-glyph-decompose "Å")) "Predicates for Strings" (string-equal :eval (string-equal "foo" "foo")) @@ -241,7 +249,14 @@ There can be any number of :example/:result elements." :eval (number-to-string 42)) "Data About Strings" (length - :eval (length "foo")) + :eval (length "foo") + :eval (length "avocado: 🥑")) + (string-width + :eval (string-width "foo") + :eval (string-width "avocado: 🥑")) + (string-pixel-width + :eval (string-pixel-width "foo") + :eval (string-pixel-width "avocado: 🥑")) (string-search :eval (string-search "bar" "foobarzot")) (assoc-string @@ -271,6 +286,9 @@ There can be any number of :example/:result elements." :eval (file-name-base "/tmp/foo.txt")) (file-relative-name :eval (file-relative-name "/tmp/foo" "/tmp")) + (file-name-split + :eval (file-name-split "/tmp/foo") + :eval (file-name-split "foo/bar")) (make-temp-name :eval (make-temp-name "/tmp/foo-")) (file-name-concat @@ -348,6 +366,9 @@ There can be any number of :example/:result elements." (file-newer-than-file-p :no-eval (file-newer-than-file-p "/tmp/foo" "/tmp/bar") :eg-result nil) + (file-has-changed-p + :no-eval (file-has-changed-p "/tmp/foo") + :eg-result t) (file-equal-p :no-eval (file-equal-p "/tmp/foo" "/tmp/bar") :eg-result nil) @@ -1206,6 +1227,39 @@ There can be any number of :example/:result elements." (text-property-search-backward :no-eval (text-property-search-backward 'face nil t))) +(define-short-documentation-group keymaps + "Defining keymaps" + (define-keymap + :no-eval (define-keymap "C-c C-c" #'quit-buffer)) + (defvar-keymap + :no-eval (defvar-keymap my-keymap "C-c C-c" #'quit-buffer)) + "Setting keys" + (keymap-set + :no-eval (keymap-set map "C-c C-c" #'quit-buffer)) + (keymap-local-set + :no-eval (keymap-local-set "C-c C-c" #'quit-buffer)) + (keymap-global-set + :no-eval (keymap-global-set "C-c C-c" #'quit-buffer)) + (keymap-unset + :no-eval (keymap-unset map "C-c C-c")) + (keymap-local-unset + :no-eval (keymap-local-unset "C-c C-c")) + (keymap-global-unset + :no-eval (keymap-global-unset "C-c C-c")) + (keymap-substitute + :no-eval (keymap-substitute map "C-c C-c" "M-a")) + (keymap-set-after + :no-eval (keymap-set-after map "<separator-2>" menu-bar-separator)) + "Predicates" + (keymapp + :eval (keymapp (define-keymap))) + (key-valid-p + :eval (key-valid-p "C-c C-c") + :eval (key-valid-p "C-cC-c")) + "Lookup" + (keymap-lookup + :eval (keymap-lookup (current-global-map) "C-x x g"))) + ;;;###autoload (defun shortdoc-display-group (group &optional function) "Pop to a buffer with short documentation summary for functions in GROUP. @@ -1245,6 +1299,9 @@ If FUNCTION is non-nil, place point on the entry for FUNCTION (if any)." (text-property-search-forward 'shortdoc-function function t) (beginning-of-line))) +;;;###autoload +(defalias 'shortdoc #'shortdoc-display-group) + (defun shortdoc--display-function (data) (let ((function (pop data)) (start-section (point)) @@ -1369,14 +1426,12 @@ Example: (setq slist (cdr slist))) (setcdr slist (cons elem (cdr slist)))))) -(defvar shortdoc-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "n") 'shortdoc-next) - (define-key map (kbd "p") 'shortdoc-previous) - (define-key map (kbd "C-c C-n") 'shortdoc-next-section) - (define-key map (kbd "C-c C-p") 'shortdoc-previous-section) - map) - "Keymap for `shortdoc-mode'.") +(defvar-keymap shortdoc-mode-map + :doc "Keymap for `shortdoc-mode'." + "n" #'shortdoc-next + "p" #'shortdoc-previous + "C-c C-n" #'shortdoc-next-section + "C-c C-p" #'shortdoc-previous-section) (define-derived-mode shortdoc-mode special-mode "shortdoc" "Mode for shortdoc." diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index b2283e66e4f..2bab1319132 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -1301,9 +1301,9 @@ Only meaningful when called from within `smie-rules-function'." (let ((afterpos (save-excursion (let ((tok (funcall smie-forward-token-function))) (unless tok - (with-demoted-errors - (error "smie-rule-separator: Can't skip token %s" - smie--token)))) + (funcall (if debug-on-error #'error #'message) + "smie-rule-separator: Can't skip token %s" + smie--token))) (skip-chars-forward " ") (unless (eolp) (point))))) (or (and afterpos @@ -1820,7 +1820,7 @@ to which that point should be aligned, if we were to reindent it.") "Indent current line using the SMIE indentation engine." (interactive) (let* ((savep (point)) - (indent (or (with-demoted-errors + (indent (or (with-demoted-errors "SMIE Error: %S" (save-excursion (forward-line 0) (skip-chars-forward " \t") @@ -1846,7 +1846,7 @@ to which that point should be aligned, if we were to reindent it.") (move-to-column fc) (syntax-ppss)))) (while - (and (with-demoted-errors + (and (with-demoted-errors "SMIE Error: %S" (save-excursion (let ((end (point)) (bsf nil) ;Best-so-far. diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 9529d51e40b..7ad4e9ba2ab 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -208,7 +208,9 @@ The variable list SPEC is the same as in `if-let'." (string= string "")) (defsubst string-join (strings &optional separator) - "Join all STRINGS using SEPARATOR." + "Join all STRINGS using SEPARATOR. +Optional argument SEPARATOR must be a string, a vector, or a list of +characters; nil stands for the empty string." (mapconcat #'identity strings separator)) (define-obsolete-function-alias 'string-reverse 'reverse "25.1") @@ -400,6 +402,161 @@ as the new values of the bound variables in the recursive invocation." (cl-labels ((,name ,fargs . ,body)) #',name) . ,aargs))) +(defmacro with-memoization (place &rest code) + "Return the value of CODE and stash it in PLACE. +If PLACE's value is non-nil, then don't bother evaluating CODE +and return the value found in PLACE instead." + (declare (indent 1) (debug (gv-place body))) + (gv-letplace (getter setter) place + `(or ,getter + ,(macroexp-let2 nil val (macroexp-progn code) + `(progn + ,(funcall setter val) + ,val))))) + +;;;###autoload +(defun ensure-empty-lines (&optional lines) + "Ensure that there are LINES number of empty lines before point. +If LINES is nil or omitted, ensure that there is a single empty +line before point. + +If called interactively, LINES is given by the prefix argument. + +If there are more than LINES empty lines before point, the number +of empty lines is reduced to LINES. + +If point is not at the beginning of a line, a newline character +is inserted before adjusting the number of empty lines." + (interactive "p") + (unless (bolp) + (insert "\n")) + (let ((lines (or lines 1)) + (start (save-excursion + (if (re-search-backward "[^\n]" nil t) + (+ (point) 2) + (point-min))))) + (cond + ((> (- (point) start) lines) + (delete-region (point) (- (point) (- (point) start lines)))) + ((< (- (point) start) lines) + (insert (make-string (- lines (- (point) start)) ?\n)))))) + +;;;###autoload +(defun string-pixel-width (string) + "Return the width of STRING in pixels." + (if (zerop (length string)) + 0 + ;; Keeping a work buffer around is more efficient than creating a + ;; new temporary buffer. + (with-current-buffer (get-buffer-create " *string-pixel-width*") + (delete-region (point-min) (point-max)) + (insert string) + (car (buffer-text-pixel-size nil nil t))))) + +;;;###autoload +(defun string-glyph-split (string) + "Split STRING into a list of strings representing separate glyphs. +This takes into account combining characters and grapheme clusters." + (let ((result nil) + (start 0) + comp) + (while (< start (length string)) + (if (setq comp (find-composition-internal + start + ;; Don't search backward in the string for the + ;; start of the composition. + (min (length string) (1+ start)) + string nil)) + (progn + (push (substring string (car comp) (cadr comp)) result) + (setq start (cadr comp))) + (push (substring string start (1+ start)) result) + (setq start (1+ start)))) + (nreverse result))) + +;;;###autoload +(defun add-display-text-property (start end prop value + &optional object) + "Add display property PROP with VALUE to the text from START to END. +If any text in the region has a non-nil `display' property, those +properties are retained. + +If OBJECT is non-nil, it should be a string or a buffer. If nil, +this defaults to the current buffer." + (let ((sub-start start) + (sub-end 0) + disp) + (while (< sub-end end) + (setq sub-end (next-single-property-change sub-start 'display object + (if (stringp object) + (min (length object) end) + (min end (point-max))))) + (if (not (setq disp (get-text-property sub-start 'display object))) + ;; No old properties in this range. + (put-text-property sub-start sub-end 'display (list prop value)) + ;; We have old properties. + (let ((vector nil)) + ;; Make disp into a list. + (setq disp + (cond + ((vectorp disp) + (setq vector t) + (seq-into disp 'list)) + ((not (consp (car disp))) + (list disp)) + (t + disp))) + ;; Remove any old instances. + (when-let ((old (assoc prop disp))) + (setq disp (delete old disp))) + (setq disp (cons (list prop value) disp)) + (when vector + (setq disp (seq-into disp 'vector))) + ;; Finally update the range. + (put-text-property sub-start sub-end 'display disp))) + (setq sub-start sub-end)))) + +;;;###autoload +(defun read-process-name (prompt) + "Query the user for a process and return the process object." + ;; Currently supports only the PROCESS argument. + ;; Must either return a list containing a process, or signal an error. + ;; (Returning `nil' would mean the current buffer's process.) + (unless (fboundp 'process-list) + (error "Asynchronous subprocesses are not supported on this system")) + ;; Local function to return cons of a complete-able name, and the + ;; associated process object, for use with `completing-read'. + (cl-flet ((procitem + (p) (when (process-live-p p) + (let ((pid (process-id p)) + (procname (process-name p)) + (procbuf (process-buffer p))) + (and (eq (process-type p) 'real) + (cons (if procbuf + (format "%s (%s) in buffer %s" + procname pid + (buffer-name procbuf)) + (format "%s (%s)" procname pid)) + p)))))) + ;; Perform `completing-read' for a process. + (let* ((currproc (get-buffer-process (current-buffer))) + (proclist (or (process-list) + (error "No processes found"))) + (collection (delq nil (mapcar #'procitem proclist))) + (selection (completing-read + (format-prompt prompt + (and currproc + (eq (process-type currproc) 'real) + (procitem currproc))) + collection nil :require-match nil nil + (car (seq-find (lambda (proc) + (eq currproc (cdr proc))) + collection)))) + (process (and selection + (cdr (assoc selection collection))))) + (unless process + (error "No process selected")) + process))) (provide 'subr-x) diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 3d944bf5e16..b740a7457af 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -115,16 +115,25 @@ where: This should be either a function, or a list. If a list, each element has the form (ID [DESC1 ... DESCN]), where: + - ID is nil, or a Lisp object uniquely identifying this entry, which is used to keep the cursor on the \"same\" entry when rearranging the list. Comparison is done with `equal'. - Each DESC is a column descriptor, one for each column - specified in `tabulated-list-format'. A descriptor is either - a string, which is printed as-is, or a list (LABEL . PROPS), - which means to use `insert-text-button' to insert a text - button with label LABEL and button properties PROPS. - The string, or button label, must not contain any newline. + specified in `tabulated-list-format'. The descriptor DESC is + one of: + + - A string, which is printed as-is, and must not contain any + newlines. + + - An image descriptor (a list), which is used to insert an + image (see Info node `(elisp) Image Descriptors'). + + - A list (LABEL . PROPS), which means to use + `insert-text-button' to insert a text button with label + LABEL and button properties PROPS. LABEL must not contain + any newlines. If `tabulated-list-entries' is a function, it is called with no arguments and must return a list of the above form.") @@ -547,7 +556,9 @@ Return the column number after insertion." (props (nthcdr 3 format)) (pad-right (or (plist-get props :pad-right) 1)) (right-align (plist-get props :right-align)) - (label (if (stringp col-desc) col-desc (car col-desc))) + (label (cond ((stringp col-desc) col-desc) + ((eq (car col-desc) 'image) " ") + (t (car col-desc)))) (label-width (string-width label)) (help-echo (concat (car format) ": " label)) (opoint (point)) @@ -571,11 +582,15 @@ Return the column number after insertion." 'display `(space :align-to ,(+ x shift)))) (setq width (- width shift)) (setq x (+ x shift)))) - (if (stringp col-desc) - (insert (if (get-text-property 0 'help-echo label) - label - (propertize label 'help-echo help-echo))) - (apply 'insert-text-button label (cdr col-desc))) + (cond ((stringp col-desc) + (insert (if (get-text-property 0 'help-echo label) + label + (propertize label 'help-echo help-echo)))) + ((eq (car col-desc) 'image) + (insert (propertize " " + 'display col-desc + 'help-echo help-echo))) + ((apply 'insert-text-button label (cdr col-desc)))) (let ((next-x (+ x pad-right width))) ;; No need to append any spaces if this is the last column. (when not-last-col @@ -668,6 +683,10 @@ With a numeric prefix argument N, sort the Nth column. If the numeric prefix is -1, restore order the list was originally displayed in." (interactive "P") + (when (and n + (or (>= n (length tabulated-list-format)) + (< n -1))) + (user-error "Invalid column number")) (if (equal n -1) ;; Restore original order. (progn @@ -712,6 +731,7 @@ Interactively, N is the prefix numeric argument, and defaults to 1." (interactive "p") (let ((start (current-column)) + (entry (tabulated-list-get-entry)) (nb-cols (length tabulated-list-format)) (col-nb 0) (total-width 0) @@ -719,14 +739,25 @@ Interactively, N is the prefix numeric argument, and defaults to col-width) (while (and (not found) (< col-nb nb-cols)) - (if (> start - (setq total-width - (+ total-width - (setq col-width - (cadr (aref tabulated-list-format - col-nb)))))) + (if (>= start + (setq total-width + (+ total-width + (max (setq col-width + (cadr (aref tabulated-list-format + col-nb))) + (let ((desc (aref entry col-nb))) + (string-width (if (stringp desc) + desc + (car desc))))) + (or (plist-get (nthcdr 3 (aref tabulated-list-format + col-nb)) + :pad-right) + 1)))) (setq col-nb (1+ col-nb)) (setq found t) + ;; `tabulated-list-format' may be a constant (sharing list + ;; structures), so copy it before mutating. + (setq tabulated-list-format (copy-tree tabulated-list-format t)) (setf (cadr (aref tabulated-list-format col-nb)) (max 1 (+ col-width n))) (tabulated-list-print t) diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 27359dfbfce..fd29abf40a3 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -314,7 +314,7 @@ This function is called, by name, directly by the C code." (not (timer--idle-delay timer))) (setf (timer--time timer) (timer-next-integral-multiple-of-time - (current-time) (timer--repeat-delay timer)))) + nil (timer--repeat-delay timer)))) ;; Place it back on the timer-list before running ;; timer--function, so it can cancel-timer itself. (timer-activate timer t cell) @@ -351,19 +351,27 @@ This function is called, by name, directly by the C code." Repeat the action every REPEAT seconds, if REPEAT is non-nil. REPEAT may be an integer or floating point number. TIME should be one of: + - a string giving today's time like \"11:23pm\" (the acceptable formats are HHMM, H:MM, HH:MM, HHam, HHAM, HHpm, HHPM, HH:MMam, HH:MMAM, HH:MMpm, or HH:MMPM; a period `.' can be used instead of a colon `:' to separate the hour and minute parts); + - a string giving a relative time like \"90\" or \"2 hours 35 minutes\" (the acceptable forms are a number of seconds without units or some combination of values using units in `timer-duration-words'); + - nil, meaning now; + - a number of seconds from now; + - a value from `encode-time'; -- or t (with non-nil REPEAT) meaning the next integral - multiple of REPEAT. + +- or t (with non-nil REPEAT) meaning the next integral multiple + of REPEAT. This is handy when you want the function to run at + a certain \"round\" number. For instance, (run-at-time t 60 ...) + will run at 11:04:00, 11:05:00, etc. The action is to call FUNCTION with arguments ARGS. @@ -383,7 +391,7 @@ This function returns a timer object which you can use in ;; Special case: t means the next integral multiple of REPEAT. (when (and (eq time t) repeat) - (setq time (timer-next-integral-multiple-of-time (current-time) repeat)) + (setq time (timer-next-integral-multiple-of-time nil repeat)) (setf (timer--integral-multiple timer) t)) ;; Handle numbers as relative times in seconds. diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index 71eca5a3230..165f5c7bfe2 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -172,9 +172,10 @@ You can call this function to add internal values in the trace buffer." LEVEL is the trace level, ARGS is the list of arguments passed to FUNCTION, and CONTEXT is a string describing the dynamic context (e.g. values of some global variables)." - (let ((print-circle t)) + (let ((print-circle t) + (print-escape-newlines t)) (format "%s%s%d -> %S%s\n" - (mapconcat 'char-to-string (make-string (max 0 (1- level)) ?|) " ") + (mapconcat #'char-to-string (make-string (max 0 (1- level)) ?|) " ") (if (> level 1) " " "") level ;; FIXME: Make it so we can click the function name to jump to its @@ -187,7 +188,8 @@ some global variables)." LEVEL is the trace level, VALUE value returned by FUNCTION, and CONTEXT is a string describing the dynamic context (e.g. values of some global variables)." - (let ((print-circle t)) + (let ((print-circle t) + (print-escape-newlines t)) (format "%s%s%d <- %s: %S%s\n" (mapconcat 'char-to-string (make-string (1- level) ?|) " ") (if (> level 1) " " "") @@ -278,7 +280,8 @@ If `current-prefix-arg' is non-nil, also read a buffer and a \"context\" nil read-expression-map t 'read-expression-history)))) (lambda () - (let ((print-circle t)) + (let ((print-circle t) + (print-escape-newlines t)) (concat " [" (prin1-to-string (eval exp t)) "]")))))))) ;;;###autoload diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el new file mode 100644 index 00000000000..8d777335315 --- /dev/null +++ b/lisp/emacs-lisp/vtable.el @@ -0,0 +1,762 @@ +;;; vtable.el --- Displaying data in tables -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'cl-lib) +(require 'eieio) +(require 'text-property-search) +(require 'mule-util) + +(cl-defstruct vtable-column + "A vtable column." + name + width + min-width + max-width + primary + align + getter + formatter + displayer + -numerical) + +(defclass vtable () + ((columns :initarg :columns :accessor vtable-columns) + (objects :initarg :objects :accessor vtable-objects) + (objects-function :initarg :objects-function + :accessor vtable-objects-function) + (getter :initarg :getter :accessor vtable-getter) + (formatter :initarg :formatter :accessor vtable-formatter) + (displayer :initarg :displayer :accessor vtable-displayer) + (use-header-line :initarg :use-header-line + :accessor vtable-use-header-line) + (face :initarg :face :accessor vtable-face) + (actions :initarg :actions :accessor vtable-actions) + (keymap :initarg :keymap :accessor vtable-keymap) + (separator-width :initarg :separator-width :accessor vtable-separator-width) + (sort-by :initarg :sort-by :accessor vtable-sort-by) + (ellipsis :initarg :ellipsis :accessor vtable-ellipsis) + (-cache :initform (make-hash-table :test #'equal))) + "A object to hold the data for a table.") + +(defvar-keymap vtable-map + "S" #'vtable-sort-by-current-column + "{" #'vtable-narrow-current-column + "}" #'vtable-widen-current-column + "g" #'vtable-revert-command + "M-<left>" #'vtable-previous-column + "M-<right>" #'vtable-next-column) + +(defvar-keymap vtable-header-line-map + :parent vtable-map + "<follow-link>" 'mouse-face + "<mouse-2>" #'vtable-header-line-sort) + +(cl-defun make-vtable (&key columns objects objects-function + getter + formatter + displayer + (use-header-line t) + (face 'variable-pitch) + actions keymap + (separator-width 1) + sort-by + (ellipsis t) + (insert t)) + "Create and insert a vtable at point. +The vtable object is returned. If INSERT is nil, the table won't +be inserted." + (when objects-function + (setq objects (funcall objects-function))) + ;; Auto-generate the columns. + (unless columns + (unless objects + (error "Can't auto-generate columns; no objects")) + (setf columns (make-list (length (car objects)) ""))) + (setq columns (mapcar (lambda (column) + (cond + ;; We just have the name (as a string). + ((stringp column) + (make-vtable-column :name column)) + ;; A plist of keywords/values. + ((listp column) + (apply #'make-vtable-column column)) + ;; A full `vtable-column' object. + (t + column))) + columns)) + ;; We'll be altering the list, so create a copy. + (setq objects (copy-sequence objects)) + (let ((table + (make-instance 'vtable + :columns columns + :objects objects + :objects-function objects-function + :getter getter + :formatter formatter + :displayer displayer + :use-header-line use-header-line + :face face + :actions actions + :keymap keymap + :separator-width separator-width + :sort-by sort-by + :ellipsis ellipsis))) + ;; Compute missing column data. + (setf (vtable-columns table) (vtable--compute-columns table)) + (unless sort-by + (seq-do-indexed (lambda (column index) + (when (vtable-column-primary column) + (push (cons index (vtable-column-primary column)) + (vtable-sort-by table)))) + (vtable-columns table))) + (when insert + (vtable-insert table)) + table)) + +;;; Interface utility functions. + +(defun vtable-current-table () + "Return the table under point." + (get-text-property (point) 'vtable)) + +(defun vtable-current-object () + "Return the object under point." + (get-text-property (point) 'vtable-object)) + +(defun vtable-current-column () + "Return the index of the column under point." + (get-text-property (point) 'vtable-column)) + +(defun vtable-beginning-of-table () + "Go to the start of the current table." + (if (text-property-search-backward 'vtable (vtable-current-table)) + (point) + (goto-char (point-min)))) + +(defun vtable-end-of-table () + "Go to the end of the current table." + (if (text-property-search-forward 'vtable (vtable-current-table)) + (point) + (goto-char (point-max)))) + +(defun vtable-goto-object (object) + "Go to OBJECT in the current table. +Return the position of the object if found, and nil if not." + (let ((start (point))) + (vtable-beginning-of-table) + (save-restriction + (narrow-to-region (point) (save-excursion (vtable-end-of-table))) + (if (text-property-search-forward 'vtable-object object #'eq) + (progn + (forward-line -1) + (point)) + (goto-char start) + nil)))) + +(defun vtable-goto-table (table) + "Go to TABLE in the current buffer. +If TABLE is found, return the position of the start of the table. +If it can't be found, return nil and don't move point." + (let ((start (point))) + (goto-char (point-min)) + (if-let ((match (text-property-search-forward 'vtable table t))) + (goto-char (prop-match-beginning match)) + (goto-char start) + nil))) + +(defun vtable-goto-column (column) + "Go to COLUMN on the current line." + (beginning-of-line) + (if-let ((match (text-property-search-forward 'vtable-column column t))) + (goto-char (prop-match-beginning match)) + (end-of-line))) + +(defun vtable-update-object (table object old-object) + "Replace OLD-OBJECT in TABLE with OBJECT." + (let* ((objects (vtable-objects table)) + (inhibit-read-only t)) + ;; First replace the object in the object storage. + (if (eq old-object (car objects)) + ;; It's at the head, so replace it there. + (setf (vtable-objects table) + (cons object (cdr objects))) + ;; Otherwise splice into the list. + (while (and (cdr objects) + (not (eq (cadr objects) old-object))) + (setq objects (cdr objects))) + (unless objects + (error "Can't find the old object")) + (setcar (cdr objects) object)) + ;; Then update the cache... + (let ((line (assq old-object (car (vtable--cache table))))) + (unless line + (error "Can't find cached object")) + (setcar line object) + (setcdr line (vtable--compute-cached-line table object)) + ;; ... and redisplay the line in question. + (save-excursion + (vtable-goto-object old-object) + (let ((keymap (get-text-property (point) 'keymap)) + (start (point))) + (delete-line) + (vtable--insert-line table line (nth 1 (vtable--cache table)) + (vtable--spacer table)) + (add-text-properties start (point) (list 'keymap keymap + 'vtable table)))) + ;; We may have inserted a non-numerical value into a previously + ;; all-numerical table, so recompute. + (vtable--recompute-numerical table (cdr line))))) + +(defun vtable-remove-object (table object) + "Remove OBJECT from TABLE. +This will also remove the displayed line." + ;; First remove from the objects. + (setf (vtable-objects table) (delq object (vtable-objects table))) + ;; Then adjust the cache and display. + (let ((cache (vtable--cache table)) + (inhibit-read-only t)) + (setcar cache (delq (assq object (car cache)) (car cache))) + (save-excursion + (vtable-goto-table table) + (when (vtable-goto-object object) + (delete-line))))) + +(defun vtable-insert-object (table object &optional after-object) + "Insert OBJECT into TABLE after AFTER-OBJECT. +If AFTER-OBJECT is nil (or doesn't exist in the table), insert +OBJECT at the end. +This also updates the displayed table." + ;; First insert into the objects. + (let (pos) + (if (and after-object + (setq pos (memq after-object (vtable-objects table)))) + ;; Splice into list. + (setcdr pos (cons object (cdr pos))) + ;; Append. + (nconc (vtable-objects table) (list object)))) + ;; Then adjust the cache and display. + (save-excursion + (vtable-goto-table table) + (let* ((cache (vtable--cache table)) + (inhibit-read-only t) + (keymap (get-text-property (point) 'keymap)) + (elem (and after-object + (assq after-object (car cache)))) + (line (cons object (vtable--compute-cached-line table object)))) + (if (not elem) + ;; Append. + (progn + (setcar cache (nconc (car cache) (list line))) + (vtable-end-of-table)) + ;; Splice into list. + (let ((pos (memq elem (car cache)))) + (setcdr pos (cons line (cdr pos))) + (unless (vtable-goto-object after-object) + (vtable-end-of-table)))) + (let ((start (point))) + (vtable--insert-line table line (nth 1 cache) (vtable--spacer table)) + (add-text-properties start (point) (list 'keymap keymap + 'vtable table))) + ;; We may have inserted a non-numerical value into a previously + ;; all-numerical table, so recompute. + (vtable--recompute-numerical table (cdr line))))) + +(defun vtable-column (table index) + "Return the name of the INDEXth column in TABLE." + (vtable-column-name (elt (vtable-columns table) index))) + +;;; Generating the table. + +(defun vtable--get-value (object index column table) + "Compute a cell value." + (cond + ((vtable-column-getter column) + (funcall (vtable-column-getter column) + object table)) + ((vtable-getter table) + (funcall (vtable-getter table) + object index table)) + ;; No getter functions; standard getters. + ((stringp object) + object) + (t + (elt object index)))) + +(defun vtable--compute-columns (table) + (let ((numerical (make-vector (length (vtable-columns table)) t)) + (columns (vtable-columns table))) + ;; First determine whether there are any all-numerical columns. + (dolist (object (vtable-objects table)) + (seq-do-indexed + (lambda (_elem index) + (unless (numberp (vtable--get-value object index (elt columns index) + table)) + (setf (elt numerical index) nil))) + (vtable-columns table))) + ;; Then fill in defaults. + (seq-map-indexed + (lambda (column index) + ;; This is used when displaying. + (unless (vtable-column-align column) + (setf (vtable-column-align column) + (if (elt numerical index) + 'right + 'left))) + ;; This is used for sorting. + (setf (vtable-column--numerical column) + (elt numerical index)) + column) + (vtable-columns table)))) + +(defun vtable--spacer (table) + (vtable--compute-width table (vtable-separator-width table))) + +(defun vtable-insert (table) + (let* ((spacer (vtable--spacer table)) + (start (point)) + (ellipsis (if (vtable-ellipsis table) + (propertize (truncate-string-ellipsis) + 'face (vtable-face table)) + "")) + (ellipsis-width (string-pixel-width ellipsis)) + data widths) + ;; We maintain a cache per screen/window width, so that we render + ;; correctly if Emacs is open on two different screens (or the + ;; user resizes the frame). + (if-let ((cache (vtable--cache table))) + (setq data (nth 0 cache) + widths (nth 1 cache)) + (setq data (vtable--compute-cache table) + widths (vtable--compute-widths table data)) + (setf (gethash (vtable--cache-key) (slot-value table '-cache)) + (list data widths))) + (if (vtable-use-header-line table) + (vtable--set-header-line table widths spacer) + ;; Insert the header line directly into the buffer, and put a + ;; keymap to be able to sort the columns there (by clicking on + ;; them). + (vtable--insert-header-line table widths spacer) + (add-text-properties start (point) + (list 'keymap vtable-header-line-map + 'rear-nonsticky t + 'vtable table)) + (setq start (point))) + (vtable--sort table) + ;; Insert the data. + (dolist (line (car (vtable--cache table))) + (vtable--insert-line table line widths spacer + ellipsis ellipsis-width)) + (add-text-properties start (point) + (list 'keymap (vtable--make-keymap table) + 'rear-nonsticky t + 'vtable table)) + (goto-char start))) + +(defun vtable--insert-line (table line widths spacer + &optional ellipsis ellipsis-width) + (let ((start (point)) + (columns (vtable-columns table))) + (seq-do-indexed + (lambda (elem index) + (let ((value (nth 0 elem)) + (column (elt columns index)) + (pre-computed (nth 2 elem))) + ;; See if we have any formatters here. + (cond + ((vtable-column-formatter column) + (setq value (funcall (vtable-column-formatter column) value) + pre-computed nil)) + ((vtable-formatter table) + (setq value (funcall (vtable-formatter table) + value index table) + pre-computed nil))) + (let ((displayed + ;; Allow any displayers to have their say. + (cond + ((vtable-column-displayer column) + (funcall (vtable-column-displayer column) + value (elt widths index) table)) + ((vtable-displayer table) + (funcall (vtable-displayer table) + value index (elt widths index) table)) + (pre-computed + ;; If we don't have a displayer, use the pre-made + ;; (cached) string value. + (if (> (nth 1 elem) (elt widths index)) + (concat + (vtable--limit-string + pre-computed (- (elt widths index) ellipsis-width)) + ellipsis) + pre-computed)) + ;; Recompute widths. + (t + (if (> (string-pixel-width value) (elt widths index)) + (concat + (vtable--limit-string + value (- (elt widths index) ellipsis-width)) + ellipsis) + value)))) + (start (point))) + (if (eq (vtable-column-align column) 'left) + (insert displayed + (propertize + " " 'display + (list 'space + :width (list + (+ (- (elt widths index) + (string-pixel-width displayed)) + spacer))))) + ;; Align to the right. + (insert (propertize " " 'display + (list 'space + :width (list (- (elt widths index) + (string-pixel-width + displayed))))) + displayed + (propertize " " 'display + (list 'space + :width (list spacer))))) + (put-text-property start (point) 'vtable-column index)))) + (cdr line)) + (insert "\n") + (put-text-property start (point) 'vtable-object (car line)))) + +(defun vtable--cache-key () + (cons (frame-terminal) (window-width))) + +(defun vtable--cache (table) + (gethash (vtable--cache-key) (slot-value table '-cache))) + +(defun vtable--clear-cache (table) + (setf (gethash (vtable--cache-key) (slot-value table '-cache)) nil)) + +(defun vtable--sort (table) + (pcase-dolist (`(,index . ,direction) (vtable-sort-by table)) + (let ((cache (vtable--cache table)) + (numerical (vtable-column--numerical + (elt (vtable-columns table) index))) + (numcomp (if (eq direction 'descend) + #'> #'<)) + (stringcomp (if (eq direction 'descend) + #'string> #'string<))) + (setcar cache + (sort (car cache) + (lambda (e1 e2) + (let ((c1 (elt e1 (1+ index))) + (c2 (elt e2 (1+ index)))) + (if numerical + (funcall numcomp (car c1) (car c2)) + (funcall + stringcomp + (if (stringp (car c1)) + (car c1) + (format "%s" (car c1))) + (if (stringp (car c2)) + (car c2) + (format "%s" (car c2)))))))))))) + +(defun vtable--indicator (table index) + (let ((order (car (last (vtable-sort-by table))))) + (if (eq index (car order)) + ;; We're sorting by this column last, so return an indicator. + (catch 'found + (dolist (candidate (nth (if (eq (cdr order) 'ascend) + 1 + 0) + '((?▼ ?v) + (?▲ ?^)))) + (when (char-displayable-p candidate) + (throw 'found (string candidate))))) + ""))) + +(defun vtable--insert-header-line (table widths spacer) + ;; Insert the header directly into the buffer. + (let* ((start (point))) + (seq-do-indexed + (lambda (column index) + (let* ((name (propertize + (vtable-column-name column) + 'face (list 'header-line (vtable-face table)))) + (start (point)) + (indicator (vtable--indicator table index)) + (indicator-width (string-pixel-width indicator)) + displayed) + (insert + (setq displayed + (concat + (if (> (string-pixel-width name) + (- (elt widths index) indicator-width)) + (vtable--limit-string + name (- (elt widths index) indicator-width)) + name) + indicator)) + (propertize " " 'display + (list 'space :width + (list (+ (- (elt widths index) + (string-pixel-width displayed)) + spacer))))) + (put-text-property start (point) 'vtable-column index))) + (vtable-columns table)) + (insert "\n") + (add-face-text-property start (point) 'header-line))) + +(defun vtable--recompute-numerical (table line) + "Recompute numericalness of columns if necessary." + (let ((columns (vtable-columns table)) + (recompute nil)) + (seq-do-indexed + (lambda (elem index) + (when (and (vtable-column--numerical (elt columns index)) + (not (numberp elem))) + (setq recompute t))) + line) + (when recompute + (vtable--compute-columns table)))) + +(defun vtable--set-header-line (table widths spacer) + (setq header-line-format + (string-replace + "%" "%%" + (with-temp-buffer + (insert " ") + (vtable--insert-header-line table widths spacer) + ;; Align the header with the (possibly) fringed buffer text. + (put-text-property + (point-min) (1+ (point-min)) + 'display '(space :align-to 0)) + (buffer-substring (point-min) (1- (point-max)))))) + (vtable-header-mode 1)) + +(defun vtable--limit-string (string pixels) + (while (and (length> string 0) + (> (string-pixel-width string) pixels)) + (setq string (substring string 0 (1- (length string))))) + string) + +(defun vtable--char-width (table) + (string-pixel-width (propertize "x" 'face (vtable-face table)))) + +(defun vtable--compute-width (table spec) + (cond + ((numberp spec) + (* spec (vtable--char-width table))) + ((string-match "\\([0-9.]+\\)ex" spec) + (* (string-to-number (match-string 1 spec)) (vtable--char-width table))) + ((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))) + (t + (error "Invalid spec: %s" spec)))) + +(defun vtable--compute-widths (table cache) + "Compute the display widths for TABLE." + (seq-into + (seq-map-indexed + (lambda (column index) + (let ((width + (or + ;; Explicit widths. + (and (vtable-column-width column) + (vtable--compute-width table (vtable-column-width column))) + ;; Compute based on the displayed widths of + ;; the data. + (seq-max (seq-map (lambda (elem) + (nth 1 (elt (cdr elem) index))) + cache))))) + ;; Let min-width/max-width specs have their say. + (when-let ((min-width (and (vtable-column-min-width column) + (vtable--compute-width + table (vtable-column-min-width column))))) + (setq width (max width min-width))) + (when-let ((max-width (and (vtable-column-max-width column) + (vtable--compute-width + table (vtable-column-max-width column))))) + (setq width (min width max-width))) + width)) + (vtable-columns table)) + 'vector)) + +(defun vtable--compute-cache (table) + (seq-map + (lambda (object) + (cons object (vtable--compute-cached-line table object))) + (vtable-objects table))) + +(defun vtable--compute-cached-line (table object) + (seq-map-indexed + (lambda (column index) + (let* ((value (vtable--get-value object index column table)) + (string (if (stringp value) + (copy-sequence value) + (format "%s" value)))) + (add-face-text-property 0 (length string) + (vtable-face table) + t string) + ;; We stash the computed width and string here -- if there are + ;; no formatters/displayers, we'll be using the string, and + ;; then won't have to recreate it. + (list value (string-pixel-width string) string))) + (vtable-columns table))) + +(defun vtable--make-keymap (table) + (let ((map (if (or (vtable-actions table) + (vtable-keymap table)) + (copy-keymap vtable-map) + vtable-map))) + (when-let ((actions (vtable-actions table))) + (while actions + (funcall (lambda (key binding) + (keymap-set map key + (lambda (object) + (interactive (list (vtable-current-object))) + (funcall binding object)))) + (car actions) (cadr actions)) + (setq actions (cddr actions)))) + (if (vtable-keymap table) + (progn + (setf (vtable-keymap table) + (copy-keymap (vtable-keymap table))) + ;; Respect any previously set parent keymaps. + (set-keymap-parent (vtable-keymap table) + (if (keymap-parent (vtable-keymap table)) + (append (ensure-list + (vtable-keymap table)) + (list map)) + map)) + (vtable-keymap table)) + map))) + +(defun vtable-revert () + "Regenerate the table under point." + (let ((table (vtable-current-table)) + (object (vtable-current-object)) + (column (vtable-current-column)) + (inhibit-read-only t)) + (unless table + (user-error "No table under point")) + (delete-region (vtable-beginning-of-table) (vtable-end-of-table)) + (vtable-insert table) + (when object + (vtable-goto-object object)) + (when column + (vtable-goto-column column)))) + +(defun vtable--widths (table) + (nth 1 (vtable--cache table))) + +;;; Commands. + +(defvar-keymap vtable-header-mode-map + "<header-line> <mouse-1>" 'vtable-header-line-sort + "<header-line> <mouse-2>" 'vtable-header-line-sort) + +(define-minor-mode vtable-header-mode + "Minor mode for buffers with vtables with headers." + :keymap vtable-header-mode-map) + +(defun vtable-narrow-current-column () + "Narrow the current column." + (interactive) + (let* ((table (vtable-current-table)) + (column (vtable-current-column)) + (widths (vtable--widths table))) + (setf (aref widths column) + (max (* (vtable--char-width table) 2) + (- (aref widths column) (vtable--char-width table)))) + (vtable-revert))) + +(defun vtable-widen-current-column () + "Widen the current column." + (interactive) + (let* ((table (vtable-current-table)) + (column (vtable-current-column)) + (widths (nth 1 (vtable--cache table)))) + (cl-incf (aref widths column) (vtable--char-width table)) + (vtable-revert))) + +(defun vtable-previous-column () + "Go to the previous column." + (interactive) + (vtable-goto-column + (max 0 (1- (or (vtable-current-column) + (length (vtable--widths (vtable-current-table)))))))) + +(defun vtable-next-column () + "Go to the next column." + (interactive) + (when (vtable-current-column) + (vtable-goto-column + (min (1- (length (vtable--widths (vtable-current-table)))) + (1+ (vtable-current-column)))))) + +(defun vtable-revert-command () + "Re-query data and regenerate the table under point." + (interactive) + (let ((table (vtable-current-table))) + (when (vtable-objects-function table) + (setf (vtable-objects table) (funcall (vtable-objects-function table)))) + (vtable--clear-cache table)) + (vtable-revert)) + +(defun vtable-sort-by-current-column () + "Sort the table under point by the column under point." + (interactive) + (unless (vtable-current-column) + (user-error "No current column")) + (let* ((table (vtable-current-table)) + (last (car (last (vtable-sort-by table)))) + (index (vtable-current-column))) + ;; First prune any previous appearance of this column. + (setf (vtable-sort-by table) + (delq (assq index (vtable-sort-by table)) + (vtable-sort-by table))) + ;; Then insert this as the last sort key. + (setf (vtable-sort-by table) + (append (vtable-sort-by table) + (list (cons index + (if (eq (car last) index) + (if (eq (cdr last) 'ascend) + 'descend + 'ascend) + 'ascend)))))) + (vtable-revert)) + +(defun vtable-header-line-sort (e) + "Sort a vtable from the header line." + (interactive "e") + (let* ((pos (event-start e)) + (obj (posn-object pos))) + (with-current-buffer (window-buffer (posn-window pos)) + (goto-char (point-min)) + (vtable-goto-column + (get-text-property (if obj (cdr obj) (posn-point pos)) + 'vtable-column + (car obj))) + (vtable-sort-by-current-column)))) + +(provide 'vtable) + +;;; vtable.el ends here diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 55adb9c8b91..23e20c3b10c 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -307,7 +307,9 @@ entirely by setting `warning-suppress-types' or 'type 'warning-suppress-log-warning 'warning-type type)) (funcall newline) - (when (and warning-fill-prefix (not (string-search "\n" message))) + (when (and warning-fill-prefix + (not (string-search "\n" message)) + (not noninteractive)) (let ((fill-prefix warning-fill-prefix) (fill-column warning-fill-column)) (fill-region start (point)))) |