diff options
Diffstat (limited to 'lisp/emacs-lisp')
32 files changed, 623 insertions, 415 deletions
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index b45984be1d5..9d1ae705976 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -250,7 +250,10 @@ expression, in which case we want to handle forms differently." (custom-autoload ',varname ,file ,(condition-case nil (null (plist-get props :set)) - (error nil)))))) + (error nil))) + ;; Propagate the :safe property to the loaddefs file. + ,@(when-let ((safe (plist-get props :safe))) + `((put ',varname 'safe-local-variable ,safe)))))) ((eq car 'defgroup) ;; In Emacs this is normally handled separately by cus-dep.el, but for diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index 439d3bd363e..64c628822df 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -37,8 +37,7 @@ "Return the time in seconds elapsed for execution of FORMS." (declare (indent 0) (debug t)) (let ((t1 (make-symbol "t1"))) - `(let (,t1) - (setq ,t1 (current-time)) + `(let ((,t1 (current-time))) ,@forms (float-time (time-since ,t1))))) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 10a50da4628..341643c7d16 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -343,7 +343,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (numberp expr) (stringp expr) (and (consp expr) - (eq (car expr) 'quote) + (memq (car expr) '(quote function)) (symbolp (cadr expr))) (keywordp expr))) @@ -414,7 +414,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") form))) (t form))) (`(quote . ,v) - (if (cdr v) + (if (or (not v) (cdr v)) (byte-compile-warn "malformed quote form: `%s'" (prin1-to-string form))) ;; Map (quote nil) to nil to simplify optimizer logic. @@ -667,8 +667,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (byte-compile-log " %s\t==>\t%s" old new) (setq form new) (not (eq new old)))))))) - ;; Normalise (quote nil) to nil, for a single representation of constant nil. - (and (not (equal form '(quote nil))) form)) + form) (defun byte-optimize-let-form (head form for-effect) ;; Recursively enter the optimizer for the bindings and body @@ -969,6 +968,11 @@ See Info node `(elisp) Integer Basics'." ;; Arity errors reported elsewhere. form))) +(defun byte-optimize-eq (form) + (pcase (cdr form) + ((or `(,x nil) `(nil ,x)) `(not ,x)) + (_ (byte-optimize-binary-predicate form)))) + (defun byte-optimize-member (form) ;; Replace `member' or `memql' with `memq' if the first arg is a symbol, ;; or the second arg is a list of symbols. Same with fixnums. @@ -1056,7 +1060,7 @@ See Info node `(elisp) Integer Basics'." (put 'min 'byte-optimizer #'byte-optimize-min-max) (put '= 'byte-optimizer #'byte-optimize-binary-predicate) -(put 'eq 'byte-optimizer #'byte-optimize-binary-predicate) +(put 'eq 'byte-optimizer #'byte-optimize-eq) (put 'eql 'byte-optimizer #'byte-optimize-equal) (put 'equal 'byte-optimizer #'byte-optimize-equal) (put 'string= 'byte-optimizer #'byte-optimize-binary-predicate) @@ -1072,7 +1076,7 @@ See Info node `(elisp) Integer Basics'." (defun byte-optimize-quote (form) (if (or (consp (nth 1 form)) (and (symbolp (nth 1 form)) - (not (macroexp--const-symbol-p form)))) + (not (macroexp--const-symbol-p (nth 1 form))))) form (nth 1 form))) @@ -1269,6 +1273,14 @@ See Info node `(elisp) Integer Basics'." form) form)) +(put 'cons 'byte-optimizer #'byte-optimize-cons) +(defun byte-optimize-cons (form) + ;; (cons X nil) => (list X) + (if (and (= (safe-length form) 3) + (null (nth 2 form))) + `(list ,(nth 1 form)) + form)) + ;; Fixme: delete-char -> delete-region (byte-coded) ;; optimize string-as-unibyte, string-as-multibyte, string-make-unibyte, ;; string-make-multibyte for constant args. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 96a0da924fc..2968f1af5df 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -603,15 +603,11 @@ Each element is (INDEX . VALUE)") form lexical) (defvar byte-native-compiling nil - "Non nil while native compiling.") + "Non-nil while native compiling.") (defvar byte-native-qualities nil "To spill default qualities from the compiled file.") (defvar byte+native-compile nil - "Non nil while compiling for bootstrap." - ;; During bootstrap we produce both the .eln and the .elc together. - ;; Because the make target is the later this has to be produced as - ;; last to be resilient against build interruptions. -) + "Non-nil while producing at the same time byte and native code.") (defvar byte-to-native-lambdas-h nil "Hash byte-code -> byte-to-native-lambda.") (defvar byte-to-native-top-level-forms nil @@ -1631,7 +1627,7 @@ the `\\\\=[command]' ones that are assumed to be of length `byte-compile--wide-docstring-substitution-len'. Also ignore URLs." (string-match - (format "^.\\{%s,\\}$" (int-to-string (1+ col))) + (format "^.\\{%d,\\}$" (min (1+ col) #xffff)) ; Heed RE_DUP_MAX. (replace-regexp-in-string (rx (or ;; Ignore some URLs. @@ -1639,7 +1635,10 @@ URLs." ;; Ignore these `substitute-command-keys' substitutions. (seq "\\" (or "=" (seq "<" (* (not ">")) ">") - (seq "{" (* (not "}")) "}"))))) + (seq "{" (* (not "}")) "}"))) + ;; Ignore the function signature that's stashed at the end of + ;; the doc string (in some circumstances). + (seq bol "(fn (" (* nonl)))) "" ;; Heuristic: assume these substitutions are of some length N. (replace-regexp-in-string @@ -1858,8 +1857,7 @@ also be compiled." (file-readable-p source) (not (string-match "\\`\\.#" file)) (not (auto-save-file-name-p source)) - (not (string-equal dir-locals-file - (file-name-nondirectory source)))) + (not (member source (dir-locals--all-files directory)))) (progn (cl-incf (pcase (byte-recompile-file source force arg) ('no-byte-compile skip-count) @@ -2067,74 +2065,73 @@ See also `emacs-lisp-byte-compile-and-load'." (message "Compiling %s...done" filename)) (kill-buffer input-buffer) (with-current-buffer output-buffer - (goto-char (point-max)) - (insert "\n") ; aaah, unix. - (cond - ((null target-file) nil) ;We only wanted the warnings! - ((or byte-native-compiling - (and (file-writable-p target-file) - ;; We attempt to create a temporary file in the - ;; target directory, so the target directory must be - ;; writable. - (file-writable-p - (file-name-directory - ;; 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 - (if byte+native-compile - ;; Defer elc final renaming. - (setf byte-to-native-output-file - (cons tempfile target-file)) - (delete-file tempfile)) - (rename-file tempfile target-file t))) - (or noninteractive - byte-native-compiling - (message "Wrote %s" target-file))) - ((file-writable-p target-file) - ;; In case the target directory isn't writable (see e.g. Bug#44631), - ;; try writing to the output file directly. We must disable any - ;; code conversion here. - (let ((coding-system-for-write 'no-conversion)) - (with-file-modes (logand (default-file-modes) #o666) - (write-region (point-min) (point-max) target-file nil 1))) - (or noninteractive (message "Wrote %s" target-file))) - (t - ;; This is just to give a better error message than write-region - (let ((exists (file-exists-p target-file))) - (signal (if exists 'file-error 'file-missing) - (list "Opening output file" - (if exists - "Cannot overwrite file" - "Directory not writable or nonexistent") - target-file))))) + (when (and target-file + (or (not byte-native-compiling) + (and byte-native-compiling byte+native-compile))) + (goto-char (point-max)) + (insert "\n") ; aaah, unix. + (cond + ((and (file-writable-p target-file) + ;; We attempt to create a temporary file in the + ;; target directory, so the target directory must be + ;; writable. + (file-writable-p + (file-name-directory + ;; 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))) + (or noninteractive + byte-native-compiling + (message "Wrote %s" target-file))) + ((file-writable-p target-file) + ;; In case the target directory isn't writable (see e.g. Bug#44631), + ;; try writing to the output file directly. We must disable any + ;; code conversion here. + (let ((coding-system-for-write 'no-conversion)) + (with-file-modes (logand (default-file-modes) #o666) + (write-region (point-min) (point-max) target-file nil 1))) + (or noninteractive (message "Wrote %s" target-file))) + (t + ;; This is just to give a better error message than write-region + (let ((exists (file-exists-p target-file))) + (signal (if exists 'file-error 'file-missing) + (list "Opening output file" + (if exists + "Cannot overwrite file" + "Directory not writable or nonexistent") + target-file)))))) (kill-buffer (current-buffer))) (if (and byte-compile-generate-call-tree (or (eq t byte-compile-generate-call-tree) @@ -4343,6 +4340,16 @@ Return (TAIL VAR TEST CASES), where: (push value keys) (push (cons (list value) (or body '(t))) cases)) t)))) + ;; Treat (not X) as (eq X nil). + (`((,(or 'not 'null) ,(and var (pred symbolp))) . ,body) + (and (or (eq var switch-var) (not switch-var)) + (progn + (setq switch-var var) + (setq switch-test 'eq) + (unless (memq nil keys) + (push nil keys) + (push (cons (list nil) (or body '(t))) cases)) + t))) (`((,(and fn (or 'memq 'memql 'member)) ,var ,expr) . ,body) (and (symbolp var) (or (eq var switch-var) (not switch-var)) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index f6637109028..ea0b09805ea 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -286,7 +286,7 @@ 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)) wrappers)) + (push (lambda (body) (macroexp--warn-wrap msg body 'lexical)) wrappers)) (_ (if (assq arg env) (push `(,arg . nil) env))))) (setq funcbody (mapcar (lambda (form) @@ -407,7 +407,7 @@ places where they originally did not directly appear." `(ignore ,(cconv-convert value env extend))) (msg (cconv--warn-unused-msg var "variable"))) (if (null msg) newval - (macroexp--warn-wrap msg newval)))) + (macroexp--warn-wrap msg newval 'lexical)))) ;; Normal default case. (_ @@ -506,7 +506,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) + (macroexp--warn-wrap msg newprotform 'lexical) newprotform) ,@(mapcar (lambda (handler) @@ -598,14 +598,16 @@ 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. + ;; so as to give better position information and obey + ;; `byte-compile-warnings'. (byte-compile-warn "%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 ,_ ,_)) ;; FIXME: Convert this warning to use `macroexp--warn-wrap' - ;; so as to give better position information. + ;; 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)))) (pcase vardata diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index 5afc6d3bde3..0494497feaf 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -203,7 +203,7 @@ Make sure the width/height is correct." (defclass chart-bar (chart) ((direction :initarg :direction - :initform vertical)) + :initform 'vertical)) "Subclass for bar charts (vertical or horizontal).") (cl-defmethod chart-draw ((c chart) &optional buff) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index eabba27d229..3840d13ecff 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -847,7 +847,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'. "\n"))) "\n")) -(defun cl--print-table (header rows) +(defun cl--print-table (header rows &optional last-slot-on-next-line) ;; FIXME: Isn't this functionality already implemented elsewhere? (let ((cols (apply #'vector (mapcar #'string-width header))) (col-space 2)) @@ -877,7 +877,11 @@ PROPLIST is a list of the sort returned by `symbol-plist'. header)) "\n") (dolist (row rows) - (insert (apply #'format format row) "\n")))))) + (insert (apply #'format format row) "\n") + (when last-slot-on-next-line + (dolist (line (string-lines (car (last row)))) + (insert " " line "\n")) + (insert "\n"))))))) (defun cl--describe-class-slots (class) "Print help description for the slots in CLASS. @@ -897,14 +901,13 @@ Outputs to the current buffer." (list (cl-prin1-to-string (cl--slot-descriptor-name slot)) (cl-prin1-to-string (cl--slot-descriptor-type slot)) (cl-prin1-to-string (cl--slot-descriptor-initform slot)) - (let ((doc (plist-get (cl--slot-descriptor-props slot) - :documentation))) + (let ((doc (alist-get :documentation + (cl--slot-descriptor-props slot)))) (if (not doc) "" (setq has-doc t) (substitute-command-keys doc))))) slots))) - (cl--print-table `("Name" "Type" "Default" . ,(if has-doc '("Doc"))) - slots-strings)) + (cl--print-table `("Name" "Type" "Default") slots-strings has-doc)) (insert "\n") (when (> (length cslots) 0) (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold)) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 31aa0cb4f9c..544704be387 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -568,17 +568,17 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (cons method mt) ;; Keep the ordering; important for methods with :extra qualifiers. (mapcar (lambda (x) (if (eq x (car me)) method x)) mt))) - (let ((sym (cl--generic-name generic))) ; Actual name (for aliases). + (let ((sym (cl--generic-name generic)) ; Actual name (for aliases). + ;; FIXME: Try to avoid re-constructing a new function if the old one + ;; is still valid (e.g. still empty method cache)? + (gfun (cl--generic-make-function generic))) (unless (symbol-function sym) (defalias sym 'dummy)) ;Record definition into load-history. (cl-pushnew `(cl-defmethod . ,(cl--generic-load-hist-format (cl--generic-name generic) qualifiers specializers)) current-load-list :test #'equal) - ;; FIXME: Try to avoid re-constructing a new function if the old one - ;; is still valid (e.g. still empty method cache)? - (let ((gfun (cl--generic-make-function generic)) - ;; Prevent `defalias' from recording this as the definition site of + (let (;; Prevent `defalias' from recording this as the definition site of ;; the generic function. current-load-list ;; BEWARE! Don't purify this function definition, since that leads diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 7f7eb963423..317a4c62309 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -515,111 +515,6 @@ the process stops as soon as KEYS or VALUES run out. If ALIST is non-nil, the new pairs are prepended to it." (nconc (cl-mapcar 'cons keys values) alist)) -;;; Generalized variables. - -;; These used to be in cl-macs.el since all macros that use them (like setf) -;; were autoloaded from cl-macs.el. But now that setf, push, and pop are in -;; core Elisp, they need to either be right here or be autoloaded via -;; cl-loaddefs.el, which is more trouble than it is worth. - -;; Some more Emacs-related place types. -(gv-define-simple-setter buffer-file-name set-visited-file-name t) -(gv-define-setter buffer-modified-p (flag &optional buf) - (macroexp-let2 nil buffer `(or ,buf (current-buffer)) - `(with-current-buffer ,buffer - (set-buffer-modified-p ,flag)))) -(gv-define-simple-setter buffer-name rename-buffer t) -(gv-define-setter buffer-string (store) - `(insert (prog1 ,store (erase-buffer)))) -(gv-define-simple-setter buffer-substring cl--set-buffer-substring) -(gv-define-simple-setter current-buffer set-buffer) -(gv-define-simple-setter current-column move-to-column t) -(gv-define-simple-setter current-global-map use-global-map t) -(gv-define-setter current-input-mode (store) - `(progn (apply #'set-input-mode ,store) ,store)) -(gv-define-simple-setter current-local-map use-local-map t) -(gv-define-simple-setter current-window-configuration - set-window-configuration t) -(gv-define-simple-setter default-file-modes set-default-file-modes t) -(gv-define-simple-setter documentation-property put) -(gv-define-setter face-background (x f &optional s) - `(set-face-background ,f ,x ,s)) -(gv-define-setter face-background-pixmap (x f &optional s) - `(set-face-background-pixmap ,f ,x ,s)) -(gv-define-setter face-font (x f &optional s) `(set-face-font ,f ,x ,s)) -(gv-define-setter face-foreground (x f &optional s) - `(set-face-foreground ,f ,x ,s)) -(gv-define-setter face-underline-p (x f &optional s) - `(set-face-underline ,f ,x ,s)) -(gv-define-simple-setter file-modes set-file-modes t) -(gv-define-setter frame-height (x &optional frame) - `(set-frame-height (or ,frame (selected-frame)) ,x)) -(gv-define-simple-setter frame-parameters modify-frame-parameters t) -(gv-define-simple-setter frame-visible-p cl--set-frame-visible-p) -(gv-define-setter frame-width (x &optional frame) - `(set-frame-width (or ,frame (selected-frame)) ,x)) -(gv-define-simple-setter getenv setenv t) -(gv-define-simple-setter get-register set-register) -(gv-define-simple-setter global-key-binding global-set-key) -(gv-define-simple-setter local-key-binding local-set-key) -(gv-define-simple-setter mark set-mark t) -(gv-define-simple-setter mark-marker set-mark t) -(gv-define-simple-setter marker-position set-marker t) -(gv-define-setter mouse-position (store scr) - `(set-mouse-position ,scr (car ,store) (cadr ,store) - (cddr ,store))) -(gv-define-simple-setter point goto-char) -(gv-define-simple-setter point-marker goto-char t) -(gv-define-setter point-max (store) - `(progn (narrow-to-region (point-min) ,store) ,store)) -(gv-define-setter point-min (store) - `(progn (narrow-to-region ,store (point-max)) ,store)) -(gv-define-setter read-mouse-position (store scr) - `(set-mouse-position ,scr (car ,store) (cdr ,store))) -(gv-define-simple-setter screen-height set-screen-height t) -(gv-define-simple-setter screen-width set-screen-width t) -(gv-define-simple-setter selected-window select-window) -(gv-define-simple-setter selected-screen select-screen) -(gv-define-simple-setter selected-frame select-frame) -(gv-define-simple-setter standard-case-table set-standard-case-table) -(gv-define-simple-setter syntax-table set-syntax-table) -(gv-define-simple-setter visited-file-modtime set-visited-file-modtime t) -(gv-define-setter window-height (store) - `(progn (enlarge-window (- ,store (window-height))) ,store)) -(gv-define-setter window-width (store) - `(progn (enlarge-window (- ,store (window-width)) t) ,store)) -(gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t) - -;; More complex setf-methods. - -;; This is a hack that allows (setf (eq a 7) B) to mean either -;; (setq a 7) or (setq a nil) depending on whether B is nil or not. -;; This is useful when you have control over the PLACE but not over -;; the VALUE, as is the case in define-minor-mode's :variable. -;; It turned out that :variable needed more flexibility anyway, so -;; this doesn't seem too useful now. -(gv-define-expander eq - (lambda (do place val) - (gv-letplace (getter setter) place - (macroexp-let2 nil val val - (funcall do `(eq ,getter ,val) - (lambda (v) - `(cond - (,v ,(funcall setter val)) - ((eq ,getter ,val) ,(funcall setter `(not ,val)))))))))) - -(gv-define-expander substring - (lambda (do place from &optional to) - (gv-letplace (getter setter) place - (macroexp-let2* nil ((start from) (end to)) - (funcall do `(substring ,getter ,start ,end) - (lambda (v) - (macroexp-let2 nil v v - `(progn - ,(funcall setter `(cl--set-substring - ,getter ,start ,end ,v)) - ,v)))))))) - ;;; Miscellaneous. (provide 'cl-lib) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index a59d42e673c..cff43689405 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3276,6 +3276,13 @@ STRUCT-TYPE is a symbol naming a struct type. Return `record', (declare (side-effect-free t) (pure t)) (cl--struct-class-type (cl--struct-get-class struct-type))) +(defun cl--alist-to-plist (alist) + (let ((res '())) + (dolist (x alist) + (push (car x) res) + (push (cdr x) res)) + (nreverse res))) + (defun cl-struct-slot-info (struct-type) "Return a list of slot names of struct STRUCT-TYPE. Each entry is a list (SLOT-NAME . OPTS), where SLOT-NAME is a @@ -3293,7 +3300,7 @@ slots skipped by :initial-offset may appear in the list." ,(cl--slot-descriptor-initform slot) ,@(if (not (eq (cl--slot-descriptor-type slot) t)) `(:type ,(cl--slot-descriptor-type slot))) - ,@(cl--slot-descriptor-props slot)) + ,@(cl--alist-to-plist (cl--slot-descriptor-props slot))) descs))) (nreverse descs))) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 7365e23186a..ef60b266f9e 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -124,12 +124,11 @@ supertypes from the most specific to least specific.") (get name 'cl-struct-print)) (cl--find-class name))))) -(defun cl--plist-remove (plist member) - (cond - ((null plist) nil) - ((null member) plist) - ((eq plist member) (cddr plist)) - (t `(,(car plist) ,(cadr plist) ,@(cl--plist-remove (cddr plist) member))))) +(defun cl--plist-to-alist (plist) + (let ((res '())) + (while plist + (push (cons (pop plist) (pop plist)) res)) + (nreverse res))) (defun cl--struct-register-child (parent tag) ;; Can't use (cl-typep parent 'cl-structure-class) at this stage @@ -164,12 +163,14 @@ supertypes from the most specific to least specific.") (i 0) (offset (if type 0 1))) (dolist (slot slots) - (let* ((props (cddr slot)) - (typep (plist-member props :type)) - (type (if typep (cadr typep) t))) + (let* ((props (cl--plist-to-alist (cddr slot))) + (typep (assq :type props)) + (type (if (null typep) t + (setq props (delq typep props)) + (cdr typep)))) (aset v i (cl--make-slot-desc (car slot) (nth 1 slot) - type (cl--plist-remove props typep)))) + type props))) (puthash (car slot) (+ i offset) index-table) (cl-incf i)) v)) diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index 6ba2e7804bb..d2e4891acee 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -144,11 +144,16 @@ This function sets the match-data that `copyright-update-year' uses." (with-demoted-errors "Can't update copyright: %s" ;; (1) Need the extra \\( \\) around copyright-regexp because we ;; goto (match-end 1) below. See note (2) below. - (copyright-re-search (concat "\\(" copyright-regexp - "\\)\\([ \t]*\n\\)?.*\\(?:" - copyright-names-regexp "\\)") - (copyright-limit) - t))) + (let ((regexp (concat "\\(" copyright-regexp + "\\)\\([ \t]*\n\\)?.*\\(?:" + copyright-names-regexp "\\)"))) + (when (copyright-re-search regexp (copyright-limit) t) + ;; We may accidentally have landed in the middle of a + ;; copyright line, so re-perform the search without the + ;; search. (Otherwise we may be inserting the new year in the + ;; middle of the list of years.) + (goto-char (match-beginning 0)) + (copyright-re-search regexp nil t))))) (defun copyright-find-end () "Possibly adjust the search performed by `copyright-find-copyright'. diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index e106815817e..d24ea355a51 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -183,8 +183,7 @@ Return t if the current element is now a valid match; otherwise return nil." Like `minibuffer-complete-word' but for `completing-read-multiple'." (interactive) (crm--completion-command beg end - (completion-in-region--single-word - beg end minibuffer-completion-table minibuffer-completion-predicate))) + (completion-in-region--single-word beg end))) (defun crm-complete-and-exit () "If all of the minibuffer elements are valid completions then exit. diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 0a6d4ec504e..3a00fdb454d 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -84,18 +84,22 @@ replacing its case-insensitive matches with the literal string in LIGHTER." (defconst easy-mmode--arg-docstring " -If called interactively, toggle `%s'. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +This is a minor mode. If called interactively, toggle the `%s' +mode. If the prefix argument is positive, enable the mode, and +if it is zero or negative, disable the mode. If called from Lisp, toggle the mode if ARG is `toggle'. Enable the mode if ARG is nil, omitted, or is a positive number. Disable the mode if ARG is a negative number. +To check whether the minor mode is enabled in the current buffer, +evaluate `%S'. + The mode's hook is called both when the mode is enabled and when it is disabled.") -(defun easy-mmode--mode-docstring (doc mode-pretty-name keymap-sym) +(defun easy-mmode--mode-docstring (doc mode-pretty-name keymap-sym + getter) (let ((doc (or doc (format "Toggle %s on or off. \\{%s}" mode-pretty-name keymap-sym)))) @@ -104,7 +108,8 @@ it is disabled.") (let* ((fill-prefix nil) (docs-fc (bound-and-true-p emacs-lisp-docstring-fill-column)) (fill-column (if (integerp docs-fc) docs-fc 65)) - (argdoc (format easy-mmode--arg-docstring mode-pretty-name)) + (argdoc (format easy-mmode--arg-docstring mode-pretty-name + getter)) (filled (if (fboundp 'fill-region) (with-temp-buffer (insert argdoc) @@ -308,7 +313,8 @@ or call the function `%s'.")))) ,(funcall warnwrap `(defun ,modefun (&optional arg ,@extra-args) - ,(easy-mmode--mode-docstring doc pretty-name keymap-sym) + ,(easy-mmode--mode-docstring doc pretty-name keymap-sym + getter) ,(when interactive ;; Use `toggle' rather than (if ,mode 0 1) so that using ;; repeat-command still does the toggling correctly. diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 641882c9026..ec7c899bddc 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -156,7 +156,7 @@ only one object ever exists." ;; NOTE TO SELF: In next version, make `slot-boundp' support classes ;; with class allocated slots or default values. (let ((old (oref-default class singleton))) - (if (eq old eieio-unbound) + (if (eq old eieio--unbound) (oset-default class singleton (cl-call-next-method)) old))) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 34b4575182e..b11ed3333f0 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -71,11 +71,10 @@ Currently under control of this var: - Define <class>-child-p and <class>-list-p predicates. - Allow object names in constructors.") -(defconst eieio-unbound - (if (and (boundp 'eieio-unbound) (symbolp eieio-unbound)) - eieio-unbound - (make-symbol "unbound")) +(define-obsolete-variable-alias 'eieio-unbound 'eieio--unbound "28.1") +(defvar eieio--unbound (make-symbol "eieio--unbound") "Uninterned symbol representing an unbound slot in an object.") +(defvar eieio--unbound-form (macroexp-quote eieio--unbound)) ;; This is a bootstrap for eieio-default-superclass so it has a value ;; while it is being built itself. @@ -264,6 +263,7 @@ use \\='%s or turn off `eieio-backward-compatibility' instead" cname) (object-of-class-p obj class)))) (defvar eieio--known-slot-names nil) +(defvar eieio--known-class-slot-names nil) (defun eieio-defclass-internal (cname superclasses slots options) "Define CNAME as a new subclass of SUPERCLASSES. @@ -381,7 +381,7 @@ See `defclass' for more information." (pcase-dolist (`(,name . ,slot) slots) (let* ((init (or (plist-get slot :initform) (if (member :initform slot) nil - eieio-unbound))) + eieio--unbound-form))) (initarg (plist-get slot :initarg)) (docstr (plist-get slot :documentation)) (prot (plist-get slot :protection)) @@ -395,6 +395,14 @@ See `defclass' for more information." (skip-nil (eieio--class-option-assoc options :allow-nil-initform)) ) + (unless (or (macroexp-const-p init) + (eieio--eval-default-p init)) + ;; FIXME: We duplicate this test here and in `defclass' because + ;; if we move this part to `defclass' we may break some existing + ;; code (because the `fboundp' test in `eieio--eval-default-p' + ;; returns a different result at compile time). + (setq init (macroexp-quote init))) + ;; Clean up the meaning of protection. (setq prot (pcase prot @@ -457,8 +465,9 @@ See `defclass' for more information." (n (length slots)) (v (make-vector n nil))) (dotimes (i n) - (setf (aref v i) (eieio-default-eval-maybe - (cl--slot-descriptor-initform (aref slots i))))) + (setf (aref v i) (eval + (cl--slot-descriptor-initform (aref slots i)) + t))) (setf (eieio--class-class-allocation-values newc) v)) ;; Attach slot symbols into a hash table, and store the index of @@ -513,7 +522,7 @@ See `defclass' for more information." cname )) -(defsubst eieio-eval-default-p (val) +(defun eieio--eval-default-p (val) "Whether the default value VAL should be evaluated for use." (and (consp val) (symbolp (car val)) (fboundp (car val)))) @@ -522,10 +531,10 @@ See `defclass' for more information." If SKIPNIL is non-nil, then if default value is nil return t instead." (let ((value (cl--slot-descriptor-initform slot)) (spec (cl--slot-descriptor-type slot))) - (if (not (or (eieio-eval-default-p value) ;FIXME: Why? + (if (not (or (not (macroexp-const-p value)) eieio-skip-typecheck (and skipnil (null value)) - (eieio--perform-slot-validation spec value))) + (eieio--perform-slot-validation spec (eval value t)))) (signal 'invalid-slot-type (list (cl--slot-descriptor-name slot) spec value))))) (defun eieio--slot-override (old new skipnil) @@ -546,7 +555,7 @@ If SKIPNIL is non-nil, then if default value is nil return t instead." type tp a)) (setf (cl--slot-descriptor-type new) tp)) ;; If we have a repeat, only update the initarg... - (unless (eq d eieio-unbound) + (unless (eq d eieio--unbound-form) (eieio--perform-slot-validation-for-default new skipnil) (setf (cl--slot-descriptor-initform old) d)) @@ -604,6 +613,8 @@ if default value is nil." (cold (car (cl-member a (eieio--class-class-slots newc) :key #'cl--slot-descriptor-name)))) (cl-pushnew a eieio--known-slot-names) + (when (eq alloc :class) + (cl-pushnew a eieio--known-class-slot-names)) (condition-case nil (if (sequencep d) (setq d (copy-sequence d))) ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's @@ -679,7 +690,7 @@ the new child class." (defun eieio--perform-slot-validation (spec value) "Return non-nil if SPEC does not match VALUE." (or (eq spec t) ; t always passes - (eq value eieio-unbound) ; unbound always passes + (eq value eieio--unbound) ; unbound always passes (cl-typep value spec))) (defun eieio--validate-slot-value (class slot-idx value slot) @@ -715,7 +726,7 @@ an error." INSTANCE is the object being referenced. SLOTNAME is the offending slot. If the slot is ok, return VALUE. Argument FN is the function calling this verifier." - (if (and (eq value eieio-unbound) (not eieio-skip-typecheck)) + (if (and (eq value eieio--unbound) (not eieio-skip-typecheck)) (slot-unbound instance (eieio--object-class instance) slotname fn) value)) @@ -731,7 +742,8 @@ Argument FN is the function calling this verifier." ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return - (format-message "Unknown slot `%S'" name) exp 'compile-only)) + (format-message "Unknown slot `%S'" name) + exp nil 'compile-only)) (_ exp)))) (gv-setter eieio-oset)) (cl-check-type slot symbol) @@ -755,15 +767,30 @@ Argument FN is the function calling this verifier." (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) -(defun eieio-oref-default (obj slot) +(defun eieio-oref-default (class slot) "Do the work for the macro `oref-default' with similar parameters. -Fills in OBJ's SLOT with its default value." - (declare (gv-setter eieio-oset-default)) - (cl-check-type obj (or eieio-object class)) +Fills in CLASS's SLOT with its default value." + (declare (gv-setter eieio-oset-default) + (compiler-macro + (lambda (exp) + (ignore class) + (pcase slot + ((and (or `',name (and name (pred keywordp))) + (guard (not (memq name eieio--known-slot-names)))) + (macroexp-warn-and-return + (format-message "Unknown slot `%S'" name) + exp nil 'compile-only)) + ((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))))) + (cl-check-type class (or eieio-object class)) (cl-check-type slot symbol) - (let* ((cl (cond ((symbolp obj) (cl--find-class obj)) - ((eieio-object-p obj) (eieio--object-class obj)) - (t obj))) + (let* ((cl (cond ((symbolp class) (cl--find-class class)) + ((eieio-object-p class) (eieio--object-class class)) + (t class))) (c (eieio--slot-name-index cl slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. @@ -773,27 +800,13 @@ Fills in OBJ's SLOT with its default value." ;; Oref that slot. (aref (eieio--class-class-allocation-values cl) c) - (slot-missing obj slot 'oref-default)) + (slot-missing class slot 'oref-default)) (eieio-barf-if-slot-unbound (let ((val (cl--slot-descriptor-initform (aref (eieio--class-slots cl) (- c (eval-when-compile eieio--object-num-slots)))))) - (eieio-default-eval-maybe val)) - obj (eieio--class-name cl) 'oref-default)))) - -(defun eieio-default-eval-maybe (val) - "Check VAL, and return what `oref-default' would provide." - ;; FIXME: What the hell is this supposed to do? Shouldn't it evaluate - ;; variables as well? Why not just always call `eval'? - (cond - ;; Is it a function call? If so, evaluate it. - ((eieio-eval-default-p val) - (eval val t)) - ;;;; check for quoted things, and unquote them - ;;((and (consp val) (eq (car val) 'quote)) - ;; (car (cdr val))) - ;; return it verbatim - (t val))) + (eval val t)) + class (eieio--class-name cl) 'oref-default)))) (defun eieio-oset (obj slot value) "Do the work for the macro `oset'. @@ -820,6 +833,21 @@ Fills in OBJ's SLOT with VALUE." (defun eieio-oset-default (class slot value) "Do the work for the macro `oset-default'. Fills in the default value in CLASS' in SLOT with VALUE." + (declare (compiler-macro + (lambda (exp) + (ignore class value) + (pcase slot + ((and (or `',name (and name (pred keywordp))) + (guard (not (memq name eieio--known-slot-names)))) + (macroexp-warn-and-return + (format-message "Unknown slot `%S'" name) + exp nil 'compile-only)) + ((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))))) (setq class (eieio--class-object class)) (cl-check-type class eieio--class) (cl-check-type slot symbol) @@ -836,22 +864,18 @@ Fills in the default value in CLASS' in SLOT with VALUE." (signal 'invalid-slot-name (list (eieio--class-name class) slot))) ;; `oset-default' on an instance-allocated slot is allowed by EIEIO but ;; not by CLOS and is mildly inconsistent with the :initform thingy, so - ;; it'd be nice to get of it. This said, it is/was used at one place by - ;; gnus/registry.el, so it might be used elsewhere as well, so let's - ;; keep it for now. + ;; it'd be nice to get rid of it. + ;; This said, it is/was used at one place by gnus/registry.el, so it + ;; might be used elsewhere as well, so let's keep it for now. ;; FIXME: Generate a compile-time warning for it! ;; (error "Can't `oset-default' an instance-allocated slot: %S of %S" ;; slot class) (eieio--validate-slot-value class c value slot) ;; Set this into the storage for defaults. - (if (eieio-eval-default-p value) - (error "Can't set default to a sexp that gets evaluated again")) (setf (cl--slot-descriptor-initform - ;; FIXME: Apparently we set it both in `slots' and in - ;; `object-cache', which seems redundant. (aref (eieio--class-slots class) (- c (eval-when-compile eieio--object-num-slots)))) - value) + (macroexp-quote value)) ;; Take the value, and put it into our cache object. (eieio-oset (eieio--class-default-object-cache class) slot value) @@ -1093,8 +1117,20 @@ These match if the argument is the name of a subclass of CLASS." (defmacro eieio-declare-slots (&rest slots) "Declare that SLOTS are known eieio object slot names." - `(eval-when-compile - (setq eieio--known-slot-names (append ',slots eieio--known-slot-names)))) + (let ((slotnames (mapcar (lambda (s) (if (consp s) (car s) s)) slots)) + (classslots (delq nil + (mapcar (lambda (s) + (when (and (consp s) + (eq :class (plist-get (cdr s) + :allocation))) + (car s))) + slots)))) + `(eval-when-compile + ,@(when classslots + (mapcar (lambda (s) `(add-to-list 'eieio--known-class-slot-names ',s)) + classslots)) + ,@(mapcar (lambda (s) `(add-to-list 'eieio--known-slot-names ',s)) + slotnames)))) (provide 'eieio-core) diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index 8257f7a4bae..d7d078b2d94 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -46,7 +46,7 @@ :documentation "A string for testing custom. This is the next line of documentation.") (listostuff :initarg :listostuff - :initform ("1" "2" "3") + :initform '("1" "2" "3") :type list :custom (repeat (string :tag "Stuff")) :label "List of Strings" diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el index c25ea8acee9..3f2a6537ab8 100644 --- a/lisp/emacs-lisp/eieio-speedbar.el +++ b/lisp/emacs-lisp/eieio-speedbar.el @@ -248,7 +248,7 @@ and take the appropriate action." Possible values are those symbols supported by the `exp-button-type' argument to `speedbar-make-tag-line'." :allocation :class) - (buttonface :initform speedbar-tag-face + (buttonface :initform 'speedbar-tag-face :type (or symbol face) :documentation "The face used on the textual part of the button for this class. @@ -265,15 +265,15 @@ Add one of the child classes to this class to the parent list of a class." :abstract t) (defclass eieio-speedbar-directory-button (eieio-speedbar) - ((buttontype :initform angle) - (buttonface :initform speedbar-directory-face)) + ((buttontype :initform 'angle) + (buttonface :initform 'speedbar-directory-face)) "Class providing support for objects which behave like a directory." :method-invocation-order :depth-first :abstract t) (defclass eieio-speedbar-file-button (eieio-speedbar) - ((buttontype :initform bracket) - (buttonface :initform speedbar-file-face)) + ((buttontype :initform 'bracket) + (buttonface :initform 'speedbar-file-face)) "Class providing support for objects which behave like a file." :method-invocation-order :depth-first :abstract t) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 31b6b0945bb..c16d8e110ec 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -53,6 +53,7 @@ (message eieio-version)) (require 'eieio-core) +(eval-when-compile (require 'subr-x)) ;;; Defining a new class @@ -131,6 +132,7 @@ and reference them using the function `class-option'." (let ((testsym1 (intern (concat (symbol-name name) "-p"))) (testsym2 (intern (format "%s--eieio-childp" name))) + (warnings '()) (accessors ())) ;; Collect the accessors we need to define. @@ -145,6 +147,8 @@ and reference them using the function `class-option'." ;; Update eieio--known-slot-names already in case we compile code which ;; uses this before the class is loaded. (cl-pushnew sname eieio--known-slot-names) + (when (eq alloc :class) + (cl-pushnew sname eieio--known-class-slot-names)) (if eieio-error-unsupported-class-tags (let ((tmp soptions)) @@ -176,8 +180,22 @@ and reference them using the function `class-option'." (signal 'invalid-slot-type (list :label label))) ;; Is there an initarg, but allocation of class? - (if (and initarg (eq alloc :class)) - (message "Class allocated slots do not need :initarg")) + (when (and initarg (eq alloc :class)) + (push (format "Meaningless :initarg for class allocated slot '%S'" + sname) + warnings)) + + (let ((init (plist-get soptions :initform))) + (unless (or (macroexp-const-p init) + (eieio--eval-default-p init)) + ;; FIXME: Historically, EIEIO used a heuristic to try and guess + ;; whether the initform is a form to be evaluated or just + ;; a constant. We use `eieio--eval-default-p' to see what the + ;; 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))) ;; Anyone can have an accessor function. This creates a function ;; of the specified name, and also performs a `defsetf' if applicable @@ -223,6 +241,9 @@ This method is obsolete." )) `(progn + ,@(mapcar (lambda (w) + (macroexp-warn-and-return w `(progn ',w) nil 'compile-only)) + warnings) ;; This test must be created right away so we can have self- ;; referencing classes. ei, a class whose slot can contain only ;; pointers to itself. @@ -282,9 +303,7 @@ This method is obsolete." ;;; Get/Set slots in an object. ;; (defmacro oref (obj slot) - "Retrieve the value stored in OBJ in the slot named by SLOT. -Slot is the name of the slot when created by `defclass' or the label -created by the :initarg tag." + "Retrieve the value stored in OBJ in the slot named by SLOT." (declare (debug (form symbolp))) `(eieio-oref ,obj (quote ,slot))) @@ -292,13 +311,11 @@ created by the :initarg tag." (defalias 'set-slot-value #'eieio-oset) (make-obsolete 'set-slot-value "use (setf (slot-value ..) ..) instead" "25.1") -(defmacro oref-default (obj slot) - "Get the default value of OBJ (maybe a class) for SLOT. -The default value is the value installed in a class with the :initform -tag. SLOT can be the slot name, or the tag specified by the :initarg -tag in the `defclass' call." +(defmacro oref-default (class slot) + "Get the value of class allocated slot SLOT. +CLASS can also be an object, in which case we use the object's class." (declare (debug (form symbolp))) - `(eieio-oref-default ,obj (quote ,slot))) + `(eieio-oref-default ,class (quote ,slot))) ;;; Handy CLOS macros ;; @@ -538,11 +555,11 @@ OBJECT can be an instance or a class." ((eieio-object-p object) (eieio-oref object slot)) ((symbolp object) (eieio-oref-default object slot)) (t (signal 'wrong-type-argument (list 'eieio-object-p object)))) - eieio-unbound)))) + eieio--unbound)))) (defun slot-makeunbound (object slot) "In OBJECT, make SLOT unbound." - (eieio-oset object slot eieio-unbound)) + (eieio-oset object slot eieio--unbound)) (defun slot-exists-p (object-or-class slot) "Return non-nil if OBJECT-OR-CLASS has SLOT." @@ -725,35 +742,37 @@ Called from the constructor routine." "Construct the new object THIS based on SLOTS.") (cl-defmethod initialize-instance ((this eieio-default-superclass) - &optional slots) - "Construct the new object THIS based on SLOTS. -SLOTS is a tagged list where odd numbered elements are tags, and + &optional args) + "Construct the new object THIS based on ARGS. +ARGS is a property list where odd numbered elements are tags, and even numbered elements are the values to store in the tagged slot. If you overload the `initialize-instance', there you will need to call `shared-initialize' yourself, or you can call `call-next-method' to have this constructor called automatically. If these steps are not taken, then new objects of your class will not have their values -dynamically set from SLOTS." - ;; First, see if any of our defaults are `lambda', and - ;; re-evaluate them and apply the value to our slots. +dynamically set from ARGS." (let* ((this-class (eieio--object-class this)) + (initargs args) (slots (eieio--class-slots this-class))) (dotimes (i (length slots)) - ;; For each slot, see if we need to evaluate it. - ;; - ;; Paul Landes said in an email: - ;; > CL evaluates it if it can, and otherwise, leaves it as - ;; > the quoted thing as you already have. This is by the - ;; > Sonya E. Keene book and other things I've look at on the - ;; > web. + ;; For each slot, see if we need to evaluate its initform. (let* ((slot (aref slots i)) - (initform (cl--slot-descriptor-initform slot)) - (dflt (eieio-default-eval-maybe initform))) - (when (not (eq dflt initform)) - ;; FIXME: We should be able to just do (aset this (+ i <cst>) dflt)! - (eieio-oset this (cl--slot-descriptor-name slot) dflt))))) - ;; Shared initialize will parse our slots for us. - (shared-initialize this slots)) + (slot-name (eieio-slot-descriptor-name slot)) + (initform (cl--slot-descriptor-initform slot))) + (unless (or (when-let ((initarg + (car (rassq slot-name + (eieio--class-initarg-tuples + this-class))))) + (plist-get initargs initarg)) + ;; Those slots whose initform is constant already have + ;; the right value set in the default-object. + (macroexp-const-p initform)) + ;; FIXME: Use `aset' instead of `eieio-oset', relying on that + ;; vector returned by `eieio--class-slots' + ;; should be congruent with the object itself. + (eieio-oset this slot-name (eval initform t)))))) + ;; Shared initialize will parse our args for us. + (shared-initialize this args)) (cl-defgeneric slot-missing (object slot-name _operation &optional _new-value) "Method invoked when an attempt to access a slot in OBJECT fails. diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index e91ec0af443..92acfe7246f 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -313,12 +313,13 @@ It should only be stopped when ran from inside ert--run-test-internal." (list :form `(,,fn ,@,args)) (unless (eql ,value ',default-value) (list :value ,value)) - (let ((-explainer- - (and (symbolp ',fn-name) - (get ',fn-name 'ert-explainer)))) - (when -explainer- - (list :explanation - (apply -explainer- ,args))))) + (unless (eql ,value ',default-value) + (let ((-explainer- + (and (symbolp ',fn-name) + (get ',fn-name 'ert-explainer)))) + (when -explainer- + (list :explanation + (apply -explainer- ,args)))))) value) ,value)))))))) @@ -1279,11 +1280,28 @@ EXPECTEDP specifies whether the result was expected." (ert-test-quit '("quit" "QUIT"))))) (elt s (if expectedp 0 1)))) +(defun ert-reason-for-test-result (result) + "Return the reason given for RESULT, as a string. + +The reason is the argument given when invoking `ert-fail' or `ert-skip'. +It is output using `prin1' prefixed by two spaces. + +If no reason was given, or for a successful RESULT, return the +empty string." + (let ((reason + (and + (ert-test-result-with-condition-p result) + (cadr (ert-test-result-with-condition-condition result)))) + (print-escape-newlines t) + (print-level 6) + (print-length 10)) + (if reason (format " %S" reason) ""))) + (defun ert--pp-with-indentation-and-newline (object) "Pretty-print OBJECT, indenting it to the current column of point. Ensures a final newline is inserted." (let ((begin (point)) - (pp-escape-newlines nil) + (pp-escape-newlines t) (print-escape-control-characters t)) (pp object (current-buffer)) (unless (bolp) (insert "\n")) @@ -1369,18 +1387,24 @@ Returns the stats object." (cl-loop for test across (ert--stats-tests stats) for result = (ert-test-most-recent-result test) do (when (not (ert-test-result-expected-p test result)) - (message "%9s %S" + (message "%9s %S%s" (ert-string-for-test-result result nil) - (ert-test-name test)))) + (ert-test-name test) + (if (getenv "EMACS_TEST_VERBOSE") + (ert-reason-for-test-result result) + "")))) (message "%s" "")) (unless (zerop skipped) (message "%s skipped results:" skipped) (cl-loop for test across (ert--stats-tests stats) for result = (ert-test-most-recent-result test) do (when (ert-test-result-type-p result :skipped) - (message "%9s %S" + (message "%9s %S%s" (ert-string-for-test-result result nil) - (ert-test-name test)))) + (ert-test-name test) + (if (getenv "EMACS_TEST_VERBOSE") + (ert-reason-for-test-result result) + "")))) (message "%s" ""))))) (test-started ) @@ -1528,7 +1552,7 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ (when badtests (message "%d files did not finish:" (length badtests)) (mapc (lambda (l) (message " %s" l)) badtests) - (if (getenv "EMACS_HYDRA_CI") + (if (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI")) (with-temp-buffer (dolist (f badtests) (erase-buffer) @@ -1544,8 +1568,8 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ (setq tests (sort tests (lambda (x y) (> (car x) (car y))))) (when (< high (length tests)) (setcdr (nthcdr (1- high) tests) nil)) (message "%s" (mapconcat #'cdr tests "\n"))) - ;; More details on hydra, where the logs are harder to get to. - (when (and (getenv "EMACS_HYDRA_CI") + ;; More details on hydra and emba, where the logs are harder to get to. + (when (and (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI")) (not (zerop (+ nunexpected nskipped)))) (message "\nDETAILS") (message "-------") diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 58876a45e19..7bc3e6b25ff 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -123,10 +123,18 @@ should insert the feature name." :group 'xref :version "25.1") +(defun find-function--defface (symbol) + (catch 'found + (while (re-search-forward (format find-face-regexp symbol) nil t) + (unless (ppss-comment-or-string-start + (save-excursion (syntax-ppss (match-beginning 0)))) + ;; We're not in a comment or a string. + (throw 'found t))))) + (defvar find-function-regexp-alist '((nil . find-function-regexp) (defvar . find-variable-regexp) - (defface . find-face-regexp) + (defface . find-function--defface) (feature . find-feature-regexp) (defalias . find-alias-regexp)) "Alist mapping definition types into regexp variables. diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index f08f7ac1153..d6272a52469 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -614,5 +614,105 @@ REF must have been previously obtained with `gv-ref'." ;; (,(nth 1 vars) (v) (funcall ',setter v))) ;; ,@body))) +;;; Generalized variables. + +;; Some Emacs-related place types. +(gv-define-simple-setter buffer-file-name set-visited-file-name t) +(gv-define-setter buffer-modified-p (flag &optional buf) + (macroexp-let2 nil buffer `(or ,buf (current-buffer)) + `(with-current-buffer ,buffer + (set-buffer-modified-p ,flag)))) +(gv-define-simple-setter buffer-name rename-buffer t) +(gv-define-setter buffer-string (store) + `(insert (prog1 ,store (erase-buffer)))) +(gv-define-simple-setter buffer-substring cl--set-buffer-substring) +(gv-define-simple-setter current-buffer set-buffer) +(gv-define-simple-setter current-column move-to-column t) +(gv-define-simple-setter current-global-map use-global-map t) +(gv-define-setter current-input-mode (store) + `(progn (apply #'set-input-mode ,store) ,store)) +(gv-define-simple-setter current-local-map use-local-map t) +(gv-define-simple-setter current-window-configuration + set-window-configuration t) +(gv-define-simple-setter default-file-modes set-default-file-modes t) +(gv-define-simple-setter documentation-property put) +(gv-define-setter face-background (x f &optional s) + `(set-face-background ,f ,x ,s)) +(gv-define-setter face-background-pixmap (x f &optional s) + `(set-face-background-pixmap ,f ,x ,s)) +(gv-define-setter face-font (x f &optional s) `(set-face-font ,f ,x ,s)) +(gv-define-setter face-foreground (x f &optional s) + `(set-face-foreground ,f ,x ,s)) +(gv-define-setter face-underline-p (x f &optional s) + `(set-face-underline ,f ,x ,s)) +(gv-define-simple-setter file-modes set-file-modes t) +(gv-define-setter frame-height (x &optional frame) + `(set-frame-height (or ,frame (selected-frame)) ,x)) +(gv-define-simple-setter frame-parameters modify-frame-parameters t) +(gv-define-simple-setter frame-visible-p cl--set-frame-visible-p) +(gv-define-setter frame-width (x &optional frame) + `(set-frame-width (or ,frame (selected-frame)) ,x)) +(gv-define-simple-setter getenv setenv t) +(gv-define-simple-setter get-register set-register) +(gv-define-simple-setter global-key-binding global-set-key) +(gv-define-simple-setter local-key-binding local-set-key) +(gv-define-simple-setter mark set-mark t) +(gv-define-simple-setter mark-marker set-mark t) +(gv-define-simple-setter marker-position set-marker t) +(gv-define-setter mouse-position (store scr) + `(set-mouse-position ,scr (car ,store) (cadr ,store) + (cddr ,store))) +(gv-define-simple-setter point goto-char) +(gv-define-simple-setter point-marker goto-char t) +(gv-define-setter point-max (store) + `(progn (narrow-to-region (point-min) ,store) ,store)) +(gv-define-setter point-min (store) + `(progn (narrow-to-region ,store (point-max)) ,store)) +(gv-define-setter read-mouse-position (store scr) + `(set-mouse-position ,scr (car ,store) (cdr ,store))) +(gv-define-simple-setter screen-height set-screen-height t) +(gv-define-simple-setter screen-width set-screen-width t) +(gv-define-simple-setter selected-window select-window) +(gv-define-simple-setter selected-screen select-screen) +(gv-define-simple-setter selected-frame select-frame) +(gv-define-simple-setter standard-case-table set-standard-case-table) +(gv-define-simple-setter syntax-table set-syntax-table) +(gv-define-simple-setter visited-file-modtime set-visited-file-modtime t) +(gv-define-setter window-height (store) + `(progn (enlarge-window (- ,store (window-height))) ,store)) +(gv-define-setter window-width (store) + `(progn (enlarge-window (- ,store (window-width)) t) ,store)) +(gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t) + +;; More complex setf-methods. + +;; This is a hack that allows (setf (eq a 7) B) to mean either +;; (setq a 7) or (setq a nil) depending on whether B is nil or not. +;; This is useful when you have control over the PLACE but not over +;; the VALUE, as is the case in define-minor-mode's :variable. +;; It turned out that :variable needed more flexibility anyway, so +;; this doesn't seem too useful now. +(gv-define-expander eq + (lambda (do place val) + (gv-letplace (getter setter) place + (macroexp-let2 nil val val + (funcall do `(eq ,getter ,val) + (lambda (v) + `(cond + (,v ,(funcall setter val)) + ((eq ,getter ,val) ,(funcall setter `(not ,val)))))))))) + +(gv-define-expander substring + (lambda (do place from &optional to) + (gv-letplace (getter setter) place + (macroexp-let2* nil ((start from) (end to)) + (funcall do `(substring ,getter ,start ,end) + (lambda (v) + (macroexp-let2 nil v v + `(progn + ,(funcall setter `(cl--set-substring + ,getter ,start ,end ,v)) + ,v)))))))) + (provide 'gv) ;;; gv.el ends here diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index 73a33a553fb..83da495edf0 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -360,10 +360,10 @@ Return argument is of the form (\"HOLDER\" \"YEAR1\" ... \"YEARN\")" "Split up an email address X into full name and real email address. The value is a cons of the form (FULLNAME . ADDRESS)." (cond ((string-match "\\(.+\\) [(<]\\(\\S-+@\\S-+\\)[>)]" x) - (cons (match-string 1 x) + (cons (string-trim-right (match-string 1 x)) (match-string 2 x))) ((string-match "\\(\\S-+@\\S-+\\) [(<]\\(.*\\)[>)]" x) - (cons (match-string 2 x) + (cons (string-trim-right (match-string 2 x)) (match-string 1 x))) ((string-match "\\S-+@\\S-+" x) (cons nil x)) @@ -378,14 +378,22 @@ the cdr is an email address." (let ((authorlist (lm-header-multiline "author"))) (mapcar #'lm-crack-address authorlist)))) +(defun lm-maintainers (&optional file) + "Return the maintainer list of file FILE, or current buffer if FILE is nil. +If the maintainers are unspecified, then return the authors. +Each element of the list is a cons; the car is the full name, +the cdr is an email address." + (lm-with-file file + (mapcar #'lm-crack-address + (or (lm-header-multiline "maintainer") + (lm-header-multiline "author"))))) + (defun lm-maintainer (&optional file) "Return the maintainer of file FILE, or current buffer if FILE is nil. +If the maintainer is unspecified, then return the author. The return value has the form (NAME . ADDRESS)." - (lm-with-file file - (let ((maint (lm-header "maintainer"))) - (if maint - (lm-crack-address maint) - (car (lm-authors)))))) + (declare (obsolete lm-maintainers "28.1")) + (car (lm-maintainers file))) (defun lm-creation-date (&optional file) "Return the created date given in file FILE, or current buffer if FILE is nil." @@ -545,7 +553,7 @@ copyright notice is allowed." "Can't find package name") ((not (lm-authors)) "`Author:' tag missing") - ((not (lm-maintainer)) + ((not (lm-maintainers)) "`Maintainer:' tag missing") ((not (lm-summary)) "Can't find the one-line summary description") @@ -613,7 +621,7 @@ Prompts for bug subject TOPIC. Leaves you in a mail buffer." (interactive "sBug Subject: ") (require 'emacsbug) (let ((package (lm-get-package-name)) - (addr (lm-maintainer)) + (addr (car (lm-maintainers))) (version (lm-version))) (compose-mail (if addr (concat (car addr) " <" (cdr addr) ">") diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 59325d647d8..51fb88502ab 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -765,7 +765,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.") :help "Run an inferior Lisp process, input and output via buffer `*inferior-lisp*'"])) (define-derived-mode lisp-mode lisp-data-mode "Lisp" - "Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp. + "Major mode for editing programs in Common Lisp and other similar Lisps. Commands: Delete converts tabs to spaces as it moves back. Blank lines separate paragraphs. Semicolons start comments. diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index df864464b77..61c1ea490f0 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -135,15 +135,22 @@ 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) - (let ((when-compiled (lambda () (byte-compile-warn "%s" msg)))) +(defun macroexp--warn-wrap (msg form category) + (let ((when-compiled (lambda () + (when (byte-compile-warning-enabled-p category) + (byte-compile-warn "%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 compile-only) +(defun macroexp-warn-and-return (msg form &optional category compile-only) + "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." (cond ((null msg) form) ((macroexp-compiling-p) @@ -153,7 +160,7 @@ Other uses risk returning non-nil value that point to the wrong file." ;; macroexpand-all gets right back to macroexpanding `form'. form (puthash form form macroexp--warned) - (macroexp--warn-wrap msg form))) + (macroexp--warn-wrap msg form category))) (t (unless compile-only (message "%sWarning: %s" @@ -205,9 +212,7 @@ Other uses risk returning non-nil value that point to the wrong file." (if (and (not (eq form new-form)) ;It was a macro call. (car-safe form) (symbolp (car form)) - (get (car form) 'byte-obsolete-info) - (or (not (fboundp 'byte-compile-warning-enabled-p)) - (byte-compile-warning-enabled-p 'obsolete (car form)))) + (get (car form) 'byte-obsolete-info)) (let* ((fun (car form)) (obsolete (get fun 'byte-obsolete-info))) (macroexp-warn-and-return @@ -215,7 +220,7 @@ Other uses risk returning non-nil value that point to the wrong file." fun obsolete (if (symbolp (symbol-function fun)) "alias" "macro")) - new-form)) + new-form 'obsolete)) new-form))) (defun macroexp--unfold-lambda (form &optional name) @@ -318,16 +323,18 @@ Assumes the caller has bound `macroexpand-all-environment'." (`(,(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 t)) - (macroexp--all-forms body)) - (cdr form)) - form)) + (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, diff --git a/lisp/emacs-lisp/memory-report.el b/lisp/emacs-lisp/memory-report.el index f4f03133b0f..1125dde4055 100644 --- a/lisp/emacs-lisp/memory-report.el +++ b/lisp/emacs-lisp/memory-report.el @@ -44,6 +44,8 @@ by counted more than once." (pop-to-buffer "*Memory Report*") (special-mode) (button-mode 1) + (setq-local revert-buffer-function (lambda (_ignore-auto _noconfirm) + (memory-report))) (setq truncate-lines t) (message "Gathering data...") (let ((reports (append (memory-report--garbage-collect) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 5df9b53657b..f1daa8d124a 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2195,8 +2195,24 @@ Downloads and installs required packages as needed." ((derived-mode-p 'tar-mode) (package-tar-file-info)) (t - (save-excursion - (package-buffer-info))))) + ;; Package headers should be parsed from decoded text + ;; (see Bug#48137) where possible. + (if (and (eq buffer-file-coding-system 'no-conversion) + buffer-file-name) + (let* ((package-buffer (current-buffer)) + (decoding-system + (car (find-operation-coding-system + 'insert-file-contents + (cons buffer-file-name + package-buffer))))) + (with-temp-buffer + (insert-buffer-substring package-buffer) + (decode-coding-region (point-min) (point-max) + decoding-system) + (package-buffer-info))) + + (save-excursion + (package-buffer-info)))))) (name (package-desc-name pkg-desc))) ;; Download and install the dependencies. (let* ((requires (package-desc-reqs pkg-desc)) @@ -2222,6 +2238,7 @@ directory." (setq default-directory file) (dired-mode)) (insert-file-contents-literally file) + (set-visited-file-name file) (when (string-match "\\.tar\\'" file) (tar-mode))) (package-install-from-buffer))) @@ -3374,7 +3391,8 @@ If optional arg BUTTON is non-nil, describe its associated package." (forward-line 1))))) (defvar package--quick-help-keys - '(("install," "delete," "unmark," ("execute" . 1)) + '((("mark for installation," . 9) + ("mark for deletion," . 9) "unmark," ("execute marked actions" . 1)) ("next," "previous") ("Hide-package," "(-toggle-hidden") ("g-refresh-contents," "/-filter," "help"))) @@ -3953,9 +3971,14 @@ packages." (package--ensure-package-menu-mode) (if (or (not status) (string-empty-p status)) (package-menu--generate t t) - (package-menu--filter-by (lambda (pkg-desc) - (string-match-p status (package-desc-status pkg-desc))) - (format "status:%s" status)))) + (let ((status-list + (if (listp status) + status + (split-string status ",")))) + (package-menu--filter-by + (lambda (pkg-desc) + (member (package-desc-status pkg-desc) status-list)) + (format "status:%s" (string-join status-list ",")))))) (defun package-menu-filter-by-version (version predicate) "Filter the \"*Packages*\" buffer by VERSION and PREDICATE. diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index 7d042a9102e..396949d59a2 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -355,11 +355,16 @@ provided in the Commentary section of this library." (reb-delete-overlays)) (setq reb-target-buffer (current-buffer) reb-target-window (selected-window)) - (select-window (or (get-buffer-window reb-buffer) - (progn - (setq reb-window-config (current-window-configuration)) - (split-window (selected-window) (- (window-height) 4))))) - (switch-to-buffer (get-buffer-create reb-buffer)) + (select-window + (or (get-buffer-window reb-buffer) + (let ((dir (if (window-parameter nil 'window-side) + 'bottom 'down))) + (setq reb-window-config (current-window-configuration)) + (display-buffer + (get-buffer-create reb-buffer) + `((display-buffer-in-direction) + (direction . ,dir) + (dedicated . t)))))) (font-lock-mode 1) (reb-initialize-buffer))) diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index c1d05941239..02f2ad3d816 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -115,9 +115,12 @@ See the documentation for `list-load-path-shadows' for further information." ;; FILE now contains the current file name, with no suffix. (unless (or (member file files-seen-this-dir) ;; Ignore these files. - (member file (list "subdirs" "leim-list" - (file-name-sans-extension - dir-locals-file)))) + (member file + (list "subdirs" "leim-list" + (file-name-sans-extension dir-locals-file) + (concat + (file-name-sans-extension dir-locals-file) + "-2")))) ;; File has not been seen yet in this directory. ;; This test prevents us declaring that XXX.el shadows ;; XXX.elc (or vice-versa) when they are in the same directory. diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 16e83074764..22439f4c36c 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -32,14 +32,6 @@ "Short documentation." :group 'lisp) -(defface shortdoc-separator - '((((class color) (background dark)) - :height 0.1 :background "#505050" :extend t) - (((class color) (background light)) - :height 0.1 :background "#a0a0a0" :extend t) - (t :height 0.1 :inverse-video t :extend t)) - "Face used to separate sections.") - (defface shortdoc-heading '((t :inherit variable-pitch :height 1.3 :weight bold)) "Face used for a heading." @@ -162,6 +154,10 @@ There can be any number of :example/:result elements." :eval (split-string "foo bar") :eval (split-string "|foo|bar|" "|") :eval (split-string "|foo|bar|" "|" t)) + (split-string-and-unquote + :eval (split-string-and-unquote "foo \"bar zot\"")) + (split-string-shell-command + :eval (split-string-shell-command "ls /tmp/'foo bar'")) (string-lines :eval (string-lines "foo\n\nbar") :eval (string-lines "foo\n\nbar" t)) @@ -268,6 +264,9 @@ There can be any number of :example/:result elements." :eval (file-name-extension "/tmp/foo.txt")) (file-name-sans-extension :eval (file-name-sans-extension "/tmp/foo.txt")) + (file-name-with-extension + :eval (file-name-with-extension "foo.txt" "bin") + :eval (file-name-with-extension "foo" "bin")) (file-name-base :eval (file-name-base "/tmp/foo.txt")) (file-relative-name @@ -496,9 +495,13 @@ There can be any number of :example/:result elements." (flatten-tree :eval (flatten-tree '(1 (2 3) 4))) (car - :eval (car '(one two three))) + :eval (car '(one two three)) + :eval (car '(one . two)) + :eval (car nil)) (cdr - :eval (cdr '(one two three))) + :eval (cdr '(one two three)) + :eval (cdr '(one . two)) + :eval (cdr nil)) (last :eval (last '(one two three))) (butlast @@ -887,7 +890,7 @@ There can be any number of :example/:result elements." (lock-buffer :no-value (lock-buffer "/tmp/foo")) (unlock-buffer - :no-value (lock-buffer))) + :no-value (unlock-buffer))) (define-short-documentation-group overlay "Predicates" @@ -1134,8 +1137,9 @@ There can be any number of :example/:result elements." :eval (sqrt -1))) ;;;###autoload -(defun shortdoc-display-group (group) - "Pop to a buffer with short documentation summary for functions in GROUP." +(defun shortdoc-display-group (group &optional function) + "Pop to a buffer with short documentation summary for functions in GROUP. +If FUNCTION is non-nil, place point on the entry for FUNCTION (if any)." (interactive (list (completing-read "Show summary for functions in: " (mapcar #'car shortdoc--groups)))) (when (stringp group) @@ -1162,19 +1166,21 @@ There can be any number of :example/:result elements." ;; There may be functions not yet defined in the data. ((fboundp (car data)) (when prev - (insert (propertize "\n" 'face 'shortdoc-separator))) + (insert (make-separator-line))) (setq prev t) (shortdoc--display-function data)))) (cdr (assq group shortdoc--groups)))) - (goto-char (point-min))) + (goto-char (point-min)) + (when function + (text-property-search-forward 'shortdoc-function function t) + (beginning-of-line))) (defun shortdoc--display-function (data) (let ((function (pop data)) (start-section (point)) arglist-start) ;; Function calling convention. - (insert (propertize "(" - 'shortdoc-function t)) + (insert (propertize "(" 'shortdoc-function function)) (if (plist-get data :no-manual) (insert-text-button (symbol-name function) @@ -1283,11 +1289,11 @@ Example: (let ((glist (assq group shortdoc--groups))) (unless glist (setq glist (list group)) - (setq shortdoc--groups (append shortdoc--groups (list glist)))) + (push glist shortdoc--groups)) (let ((slist (member section glist))) (unless slist (setq slist (list section)) - (setq slist (append glist slist))) + (nconc glist slist)) (while (and (cdr slist) (not (stringp (cadr slist)))) (setq slist (cdr slist))) @@ -1305,16 +1311,15 @@ Example: (define-derived-mode shortdoc-mode special-mode "shortdoc" "Mode for shortdoc.") -(defmacro shortdoc--goto-section (arg sym &optional reverse) - `(progn - (unless (natnump ,arg) - (setq ,arg 1)) - (while (< 0 ,arg) - (,(if reverse - 'text-property-search-backward - 'text-property-search-forward) - ,sym t) - (setq ,arg (1- ,arg))))) +(defun shortdoc--goto-section (arg sym &optional reverse) + (unless (natnump arg) + (setq arg 1)) + (while (> arg 0) + (funcall + (if reverse 'text-property-search-backward + 'text-property-search-forward) + sym nil t t) + (setq arg (1- arg)))) (defun shortdoc-next (&optional arg) "Move cursor to the next function. diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 1c13c398dde..468d124c0e2 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -317,6 +317,7 @@ than this function." (end (substring string (- (length string) length))) (t (substring string 0 length))))) +;;;###autoload (defun string-lines (string &optional omit-nulls) "Split STRING into a list of lines. If OMIT-NULLS, empty lines will be removed from the results." diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 0b10dfdc0af..04f3b70aaa8 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -36,6 +36,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defgroup tabulated-list nil "Tabulated-list customization group." :group 'convenience @@ -645,18 +647,41 @@ this is the vector stored within it." (defun tabulated-list-sort (&optional n) "Sort Tabulated List entries by the column at point. -With a numeric prefix argument N, sort the Nth column." +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") - (let ((name (if n - (car (aref tabulated-list-format n)) - (get-text-property (point) - 'tabulated-list-column-name)))) - (if (nth 2 (assoc name (append tabulated-list-format nil))) - (tabulated-list--sort-by-column-name name) - (user-error "Cannot sort by %s" name)))) + (if (equal n -1) + ;; Restore original order. + (progn + (unless tabulated-list--original-order + (error "Order is already in original order")) + (setq tabulated-list-entries + (sort tabulated-list-entries + (lambda (e1 e2) + (< (gethash e1 tabulated-list--original-order) + (gethash e2 tabulated-list--original-order))))) + (setq tabulated-list-sort-key nil) + (tabulated-list-init-header) + (tabulated-list-print t)) + ;; Sort based on a column name. + (let ((name (if n + (car (aref tabulated-list-format n)) + (get-text-property (point) + 'tabulated-list-column-name)))) + (if (nth 2 (assoc name (append tabulated-list-format nil))) + (tabulated-list--sort-by-column-name name) + (user-error "Cannot sort by %s" name))))) (defun tabulated-list--sort-by-column-name (name) (when (and name (derived-mode-p 'tabulated-list-mode)) + (unless tabulated-list--original-order + ;; Store the original order so that we can restore it later. + (setq tabulated-list--original-order (make-hash-table)) + (cl-loop for elem in tabulated-list-entries + for i from 0 + do (setf (gethash elem tabulated-list--original-order) i))) ;; Flip the sort order on a second click. (if (equal name (car tabulated-list-sort-key)) (setcdr tabulated-list-sort-key @@ -717,6 +742,8 @@ Interactively, N is the prefix numeric argument, and defaults to ;;; The mode definition: +(defvar tabulated-list--original-order nil) + (define-derived-mode tabulated-list-mode special-mode "Tabulated" "Generic major mode for browsing a list of items. This mode is usually not used directly; instead, other major @@ -757,6 +784,7 @@ as the ewoc pretty-printer." (setq-local glyphless-char-display (tabulated-list-make-glyphless-char-display-table)) (setq-local text-scale-remap-header-line t) + (setq-local tabulated-list--original-order nil) ;; Avoid messing up the entries' display just because the first ;; column of the first entry happens to begin with a R2L letter. (setq bidi-paragraph-direction 'left-to-right) |