diff options
author | Michael R. Mauger <michael@mauger.com> | 2017-07-03 15:32:41 -0400 |
---|---|---|
committer | Michael R. Mauger <michael@mauger.com> | 2017-07-03 15:32:41 -0400 |
commit | 776635c01abd4aa759e7aa9584b513146978568c (patch) | |
tree | 554f444bc96cb6b05435e8bf195de4df1b00df8f /lisp/emacs-lisp | |
parent | 77083e2d34ba5559ae2899d3b03cf08c2e6c5ad4 (diff) | |
parent | 4cd0db3d6e6e4d5bd49283483bdafbbfc0f583f1 (diff) | |
download | emacs-776635c01abd4aa759e7aa9584b513146978568c.tar.gz emacs-776635c01abd4aa759e7aa9584b513146978568c.tar.bz2 emacs-776635c01abd4aa759e7aa9584b513146978568c.zip |
Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs
Diffstat (limited to 'lisp/emacs-lisp')
28 files changed, 1018 insertions, 779 deletions
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index d1f3c359f37..8fe94013700 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -164,7 +164,8 @@ expression, in which case we want to handle forms differently." ((and (memq car '(easy-mmode-define-global-mode define-global-minor-mode define-globalized-minor-mode defun defmacro easy-mmode-define-minor-mode define-minor-mode - define-inline cl-defun cl-defmacro cl-defgeneric)) + define-inline cl-defun cl-defmacro cl-defgeneric + pcase-defmacro)) (macrop car) (setq expand (let ((load-file-name file)) (macroexpand form))) (memq (car expand) '(progn prog1 defalias))) @@ -254,30 +255,22 @@ expression, in which case we want to handle forms differently." ;; Those properties are now set in lisp-mode.el. (defun autoload-find-generated-file () - "Visit the autoload file for the current buffer, and return its buffer. -If a buffer is visiting the desired autoload file, return it." + "Visit the autoload file for the current buffer, and return its buffer." (let ((enable-local-variables :safe) - (enable-local-eval nil)) + (enable-local-eval nil) + (delay-mode-hooks t) + (file (autoload-generated-file))) ;; We used to use `raw-text' to read this file, but this causes ;; problems when the file contains non-ASCII characters. - (let* ((delay-mode-hooks t) - (file (autoload-generated-file)) - (file-missing (not (file-exists-p file)))) - (when file-missing - (autoload-ensure-default-file file)) - (with-current-buffer - (find-file-noselect - (autoload-ensure-file-writeable - file)) - ;; block backups when the file has just been created, since - ;; the backups will just be the auto-generated headers. - ;; bug#23203 - (when file-missing - (setq buffer-backed-up t) - (save-buffer)) - (current-buffer))))) + (with-current-buffer (find-file-noselect + (autoload-ensure-file-writeable file)) + (if (zerop (buffer-size)) (insert (autoload-rubric file nil t))) + (current-buffer)))) (defun autoload-generated-file () + "Return `generated-autoload-file' as an absolute name. +If local to the current buffer, expand using the default directory; +otherwise, using `source-directory'/lisp." (expand-file-name generated-autoload-file ;; File-local settings of generated-autoload-file should ;; be interpreted relative to the file's location, @@ -362,24 +355,28 @@ put the output in." (defun autoload-rubric (file &optional type feature) "Return a string giving the appropriate autoload rubric for FILE. TYPE (default \"autoloads\") is a string stating the type of -information contained in FILE. If FEATURE is non-nil, FILE -will provide a feature. FEATURE may be a string naming the -feature, otherwise it will be based on FILE's name. - -At present, a feature is in fact always provided, but this should -not be relied upon." - (let ((basename (file-name-nondirectory file))) +information contained in FILE. TYPE \"package\" acts like the default, +but adds an extra line to the output to modify `load-path'. + +If FEATURE is non-nil, FILE will provide a feature. FEATURE may +be a string naming the feature, otherwise it will be based on +FILE's name." + (let ((basename (file-name-nondirectory file)) + (lp (if (equal type "package") (setq type "autoloads")))) (concat ";;; " basename " --- automatically extracted " (or type "autoloads") "\n" ";;\n" ";;; Code:\n\n" + (if lp + ;; `load-path' should contain only directory names. + "(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path))))\n\n") "\n" ;; This is used outside of autoload.el, eg cus-dep, finder. - "(provide '" - (if (stringp feature) - feature - (file-name-sans-extension basename)) - ")\n" + (if feature + (format "(provide '%s)\n" + (if (stringp feature) feature + (file-name-sans-extension basename)))) ";; Local Variables:\n" ";; version-control: never\n" ";; no-byte-compile: t\n" @@ -390,7 +387,7 @@ not be relied upon." " ends here\n"))) (defvar autoload-ensure-writable nil - "Non-nil means `autoload-ensure-default-file' makes existing file writable.") + "Non-nil means `autoload-find-generated-file' makes existing file writable.") ;; Just in case someone tries to get you to overwrite a file that you ;; don't want to. ;;;###autoload @@ -400,6 +397,7 @@ not be relied upon." ;; Probably pointless, but replaces the old AUTOGEN_VCS in lisp/Makefile, ;; which was designed to handle CVSREAD=1 and equivalent. (and autoload-ensure-writable + (file-exists-p file) (let ((modes (file-modes file))) (if (zerop (logand modes #o0200)) ;; Ignore any errors here, and let subsequent attempts @@ -407,12 +405,6 @@ not be relied upon." (ignore-errors (set-file-modes file (logior modes #o0200)))))) file) -(defun autoload-ensure-default-file (file) - "Make sure that the autoload file FILE exists, creating it if needed. -If the file already exists and `autoload-ensure-writable' is non-nil, -make it writable." - (write-region (autoload-rubric file) nil file)) - (defun autoload-insert-section-header (outbuf autoloads load-name file time) "Insert the section-header line, which lists the file name and which functions are in it, etc." @@ -546,7 +538,9 @@ Don't try to split prefixes that are already longer than that.") ;; "cc-helper" and "c-mode", you'll get "c" in the root prefixes. (dolist (pair (prog1 prefixes (setq prefixes nil))) (let ((s (car pair))) - (if (or (> (length s) 2) ;Long enough! + (if (or (and (> (length s) 2) ; Long enough! + ;; But don't use "def" from deffoo-pkg-thing. + (not (string= "def" s))) (string-match ".[[:punct:]]\\'" s) ;A real (tho short) prefix? (radix-tree-lookup (cdr pair) "")) ;Nothing to expand! (push pair prefixes) ;Keep it as is. @@ -595,7 +589,8 @@ Don't try to split prefixes that are already longer than that.") (lambda (x) (let ((prefix (car x))) (if (or (> (length prefix) 2) ;Long enough! - (string-match ".[[:punct:]]\\'" prefix)) + (and (eq (length prefix) 2) + (string-match "[[:punct:]]" prefix))) prefix ;; Some packages really don't follow the rules. ;; Drop the most egregious cases such as the @@ -875,11 +870,26 @@ FILE's modification time." (error "%s:0:0: error: %s: %s" file (car err) (cdr err))) )) +;; For parallel builds, to stop another process reading a half-written file. +(defun autoload--save-buffer () + "Save current buffer to its file, atomically." + ;; Copied from byte-compile-file. + (let* ((version-control 'never) + (tempfile (make-temp-name buffer-file-name)) + (kill-emacs-hook + (cons (lambda () (ignore-errors (delete-file tempfile))) + kill-emacs-hook))) + (write-region (point-min) (point-max) tempfile nil 1) + (backup-buffer) + (rename-file tempfile buffer-file-name t) + (set-buffer-modified-p nil) + (set-visited-file-modtime) + (or noninteractive (message "Wrote %s" buffer-file-name)))) + (defun autoload-save-buffers () (while autoload-modified-buffers (with-current-buffer (pop autoload-modified-buffers) - (let ((version-control 'never)) - (save-buffer))))) + (autoload--save-buffer)))) ;; FIXME This command should be deprecated. ;; See http://debbugs.gnu.org/22213#41 @@ -1119,8 +1129,7 @@ write its autoloads into the specified file instead." ;; dependencies don't trigger unnecessarily. (if (not changed) (set-buffer-modified-p nil) - (let ((version-control 'never)) - (save-buffer))) + (autoload--save-buffer)) ;; In case autoload entries were added to other files because of ;; file-local autoload-generated-file settings. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 004f2e28653..962a7ae5cde 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -185,7 +185,7 @@ (require 'bytecomp) (eval-when-compile (require 'cl-lib)) (require 'macroexp) -(require 'subr-x) +(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. @@ -1247,7 +1247,7 @@ hash-table-p identity ignore integerp integer-or-marker-p interactive-p invocation-directory invocation-name - keymapp + keymapp keywordp line-beginning-position line-end-position list listp make-marker mark mark-marker markerp max-char memory-limit minibuffer-window diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 2c2996ebab4..e5b9b47b1d0 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -124,11 +124,13 @@ (require 'backquote) (require 'macroexp) (require 'cconv) +(require 'cl-lib) ;; During bootstrap, cl-loaddefs.el is not created yet, so loading cl-lib ;; doesn't setup autoloads for things like cl-every, which is why we have to -;; require cl-extra instead (bug#18804). -(require 'cl-extra) +;; require cl-extra as well (bug#18804). +(or (fboundp 'cl-every) + (require 'cl-extra)) (or (fboundp 'defsubst) ;; This really ought to be loaded already! @@ -164,24 +166,19 @@ file name, and return the name of the compiled file." (funcall handler 'byte-compiler-base-file-name filename) filename))) -(or (fboundp 'byte-compile-dest-file) - ;; The user may want to redefine this along with emacs-lisp-file-regexp, - ;; so only define it if it is undefined. - ;; Note - redefining this function is obsolete as of 23.2. - ;; Customize byte-compile-dest-file-function instead. - (defun byte-compile-dest-file (filename) - "Convert an Emacs Lisp source file name to a compiled file name. +(defun byte-compile-dest-file (filename) + "Convert an Emacs Lisp source file name to a compiled file name. If `byte-compile-dest-file-function' is non-nil, uses that function to do the work. Otherwise, if FILENAME matches `emacs-lisp-file-regexp' (by default, files with the extension `.el'), adds `c' to it; otherwise adds `.elc'." - (if byte-compile-dest-file-function - (funcall byte-compile-dest-file-function filename) - (setq filename (file-name-sans-versions - (byte-compiler-base-file-name filename))) - (cond ((string-match emacs-lisp-file-regexp filename) - (concat (substring filename 0 (match-beginning 0)) ".elc")) - (t (concat filename ".elc")))))) + (if byte-compile-dest-file-function + (funcall byte-compile-dest-file-function filename) + (setq filename (file-name-sans-versions + (byte-compiler-base-file-name filename))) + (cond ((string-match emacs-lisp-file-regexp filename) + (concat (substring filename 0 (match-beginning 0)) ".elc")) + (t (concat filename ".elc"))))) ;; This can be the 'byte-compile property of any symbol. (autoload 'byte-compile-inline-expand "byte-opt") @@ -1378,10 +1375,15 @@ extra args." (let ((nfields (with-temp-buffer (insert (nth 1 form)) (goto-char (point-min)) - (let ((n 0)) + (let ((i 0) (n 0)) (while (re-search-forward "%." nil t) - (unless (eq ?% (char-after (1+ (match-beginning 0)))) - (setq n (1+ n)))) + (backward-char) + (unless (eq ?% (char-after)) + (setq i (if (looking-at "\\([0-9]+\\)\\$") + (string-to-number (match-string 1) 10) + (1+ i)) + n (max n i))) + (forward-char)) n))) (nargs (- (length form) 2))) (unless (= nargs nfields) @@ -1662,7 +1664,12 @@ that already has a `.elc' file." (if arg (setq arg (prefix-numeric-value arg))) (if noninteractive nil - (save-some-buffers) + (save-some-buffers + nil (lambda () + (let ((file (buffer-file-name))) + (and file + (string-match-p emacs-lisp-file-regexp file) + (file-in-directory-p file directory))))) (force-mode-line-update)) (with-current-buffer (get-buffer-create byte-compile-log-buffer) (setq default-directory (expand-file-name directory)) @@ -2024,13 +2031,20 @@ With argument ARG, insert value in current buffer after the form." (not (eobp))) (setq byte-compile-read-position (point) byte-compile-last-position byte-compile-read-position) - (let* ((old-style-backquotes nil) + (let* ((lread--old-style-backquotes nil) + (lread--unescaped-character-literals nil) (form (read inbuffer))) ;; Warn about the use of old-style backquotes. - (when old-style-backquotes + (when lread--old-style-backquotes (byte-compile-warn "!! The file uses old-style backquotes !! This functionality has been obsolete for more than 10 years already and will be removed soon. See (elisp)Backquote in the manual.")) + (when lread--unescaped-character-literals + (byte-compile-warn + "unescaped character literals %s detected!" + (mapconcat (lambda (char) (format "`?%c'" char)) + (sort lread--unescaped-character-literals #'<) + ", "))) (byte-compile-toplevel-file-form form))) ;; Compile pending forms at end of file. (byte-compile-flush-pending) @@ -3202,47 +3216,53 @@ for symbols generated by the byte compiler itself." (fmax2 (if (numberp fargs) (lsh fargs -7))) ;2*max+rest. ;; (fmin (if (numberp fargs) (logand fargs 127))) (alen (length (cdr form))) - (dynbinds ())) + (dynbinds ()) + lap) (fetch-bytecode fun) - (mapc 'byte-compile-form (cdr form)) - (unless fmax2 - ;; Old-style byte-code. - (cl-assert (listp fargs)) - (while fargs - (pcase (car fargs) - (`&optional (setq fargs (cdr fargs))) - (`&rest (setq fmax2 (+ (* 2 (length dynbinds)) 1)) - (push (cadr fargs) dynbinds) - (setq fargs nil)) - (_ (push (pop fargs) dynbinds)))) - (unless fmax2 (setq fmax2 (* 2 (length dynbinds))))) - (cond - ((<= (+ alen alen) fmax2) - ;; Add missing &optional (or &rest) arguments. - (dotimes (_ (- (/ (1+ fmax2) 2) alen)) - (byte-compile-push-constant nil))) - ((zerop (logand fmax2 1)) - (byte-compile-report-error - (format "Too many arguments for inlined function %S" form)) - (byte-compile-discard (- alen (/ fmax2 2)))) - (t - ;; Turn &rest args into a list. - (let ((n (- alen (/ (1- fmax2) 2)))) - (cl-assert (> n 0) nil "problem: fmax2=%S alen=%S n=%S" fmax2 alen n) - (if (< n 5) - (byte-compile-out - (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- n)) - 0) - (byte-compile-out 'byte-listN n))))) - (mapc #'byte-compile-dynamic-variable-bind dynbinds) - (byte-compile-inline-lapcode - (byte-decompile-bytecode-1 (aref fun 1) (aref fun 2) t) - (1+ start-depth)) - ;; Unbind dynamic variables. - (when dynbinds - (byte-compile-out 'byte-unbind (length dynbinds))) - (cl-assert (eq byte-compile-depth (1+ start-depth)) - nil "Wrong depth start=%s end=%s" start-depth byte-compile-depth))) + (setq lap (byte-decompile-bytecode-1 (aref fun 1) (aref fun 2) t)) + ;; optimized switch bytecode makes it impossible to guess the correct + ;; `byte-compile-depth', which can result in incorrect inlined code. + ;; therefore, we do not inline code that uses the `byte-switch' + ;; instruction. + (if (assq 'byte-switch lap) + (byte-compile-normal-call form) + (mapc 'byte-compile-form (cdr form)) + (unless fmax2 + ;; Old-style byte-code. + (cl-assert (listp fargs)) + (while fargs + (pcase (car fargs) + (`&optional (setq fargs (cdr fargs))) + (`&rest (setq fmax2 (+ (* 2 (length dynbinds)) 1)) + (push (cadr fargs) dynbinds) + (setq fargs nil)) + (_ (push (pop fargs) dynbinds)))) + (unless fmax2 (setq fmax2 (* 2 (length dynbinds))))) + (cond + ((<= (+ alen alen) fmax2) + ;; Add missing &optional (or &rest) arguments. + (dotimes (_ (- (/ (1+ fmax2) 2) alen)) + (byte-compile-push-constant nil))) + ((zerop (logand fmax2 1)) + (byte-compile-report-error + (format "Too many arguments for inlined function %S" form)) + (byte-compile-discard (- alen (/ fmax2 2)))) + (t + ;; Turn &rest args into a list. + (let ((n (- alen (/ (1- fmax2) 2)))) + (cl-assert (> n 0) nil "problem: fmax2=%S alen=%S n=%S" fmax2 alen n) + (if (< n 5) + (byte-compile-out + (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- n)) + 0) + (byte-compile-out 'byte-listN n))))) + (mapc #'byte-compile-dynamic-variable-bind dynbinds) + (byte-compile-inline-lapcode lap (1+ start-depth)) + ;; Unbind dynamic variables. + (when dynbinds + (byte-compile-out 'byte-unbind (length dynbinds))) + (cl-assert (eq byte-compile-depth (1+ start-depth)) + nil "Wrong depth start=%s end=%s" start-depth byte-compile-depth)))) (defun byte-compile-check-variable (var access-type) "Do various error checks before a use of the variable VAR." @@ -4058,8 +4078,8 @@ Return a list of the form ((TEST . VAR) ((VALUE BODY) ...))" ;; discard duplicate clauses (not (assq obj2 cases))) (push (list (if (consp obj2) (eval obj2) obj2) body) cases) - (if (eq condition t) - (progn (push (list 'default body) cases) + (if (and (macroexp-const-p condition) condition) + (progn (push (list 'default (or body `(,condition))) cases) (throw 'break t)) (setq ok nil) (throw 'break nil)))))) @@ -4945,6 +4965,10 @@ already up-to-date." (defvar command-line-args-left) ;Avoid 'free variable' warning (if (not noninteractive) (error "`batch-byte-compile' is to be used only with -batch")) + ;; Better crash loudly than attempting to recover from undefined + ;; behavior. + (setq attempt-stack-overflow-recovery nil + attempt-orderly-shutdown-on-fatal-signal nil) (let ((error nil)) (while command-line-args-left (if (file-directory-p (expand-file-name (car command-line-args-left))) @@ -5037,6 +5061,10 @@ and corresponding effects." (defvar command-line-args-left) ;Avoid 'free variable' warning (if (not noninteractive) (error "batch-byte-recompile-directory is to be used only with -batch")) + ;; Better crash loudly than attempting to recover from undefined + ;; behavior. + (setq attempt-stack-overflow-recovery nil + attempt-orderly-shutdown-on-fatal-signal nil) (or command-line-args-left (setq command-line-args-left '("."))) (while command-line-args-left diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 021ef232749..99df209d1a2 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -437,22 +437,38 @@ as an integer unless JUNK-ALLOWED is non-nil." ;; Random numbers. +(defun cl--random-time () + (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) + (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i)))) + v)) + +;;;###autoload (autoload 'cl-random-state-p "cl-extra") +(cl-defstruct (cl--random-state + (:copier nil) + (:predicate cl-random-state-p) + (:constructor nil) + (:constructor cl--make-random-state (vec))) + (i -1) (j 30) vec) + +(defvar cl--random-state (cl--make-random-state (cl--random-time))) + ;;;###autoload (defun cl-random (lim &optional state) "Return a random nonnegative number less than LIM, an integer or float. Optional second arg STATE is a random-state object." (or state (setq state cl--random-state)) ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method. - (let ((vec (aref state 3))) + (let ((vec (cl--random-state-vec state))) (if (integerp vec) (let ((i 0) (j (- 1357335 (abs (% vec 1357333)))) (k 1)) - (aset state 3 (setq vec (make-vector 55 nil))) + (setf (cl--random-state-vec state) + (setq vec (make-vector 55 nil))) (aset vec 0 j) (while (> (setq i (% (+ i 21) 55)) 0) (aset vec i (setq j (prog1 k (setq k (- j k)))))) (while (< (setq i (1+ i)) 200) (cl-random 2 state)))) - (let* ((i (aset state 1 (% (1+ (aref state 1)) 55))) - (j (aset state 2 (% (1+ (aref state 2)) 55))) + (let* ((i (cl-callf (lambda (x) (% (1+ x) 55)) (cl--random-state-i state))) + (j (cl-callf (lambda (x) (% (1+ x) 55)) (cl--random-state-j state))) (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j)))))) (if (integerp lim) (if (<= lim 512) (% n lim) @@ -466,17 +482,10 @@ Optional second arg STATE is a random-state object." (defun cl-make-random-state (&optional state) "Return a copy of random-state STATE, or of the internal state if omitted. If STATE is t, return a new state object seeded from the time of day." - (cond ((null state) (cl-make-random-state cl--random-state)) - ((vectorp state) (copy-tree state t)) - ((integerp state) (vector 'cl--random-state-tag -1 30 state)) - (t (cl-make-random-state (cl--random-time))))) - -;;;###autoload -(defun cl-random-state-p (object) - "Return t if OBJECT is a random-state object." - (and (vectorp object) (= (length object) 4) - (eq (aref object 0) 'cl--random-state-tag))) - + (unless state (setq state cl--random-state)) + (if (cl-random-state-p state) + (copy-tree state t) + (cl--make-random-state (if (integerp state) state (cl--random-time))))) ;; Implementation limits. @@ -775,8 +784,7 @@ including `cl-block' and `cl-eval-when'." (defun cl--describe-class (type &optional class) (unless class (setq class (cl--find-class type))) (let ((location (find-lisp-object-file-name type 'define-type)) - ;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch. - (metatype (cl--class-name (symbol-value (aref class 0))))) + (metatype (type-of class))) (insert (symbol-name type) (substitute-command-keys " is a type (of kind `")) (help-insert-xref-button (symbol-name metatype) @@ -901,8 +909,7 @@ including `cl-block' and `cl-eval-when'." "Print help description for the slots in CLASS. Outputs to the current buffer." (let* ((slots (cl--class-slots class)) - ;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch. - (metatype (cl--class-name (symbol-value (aref class 0)))) + (metatype (type-of class)) ;; ¡For EIEIO! (cslots (condition-case nil (cl-struct-slot-value metatype 'class-slots class) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 8c6d3d5d51f..c64376b940f 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -413,10 +413,12 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (declare (doc-string 3) (indent 2) (debug (&define ; this means we are defining something - [&or name ("setf" :name setf name)] + [&or name ("setf" name :name setf)] ;; ^^ This is the methods symbol - [ &optional keywordp ] ; this is key :before etc - list ; arguments + [ &rest atom ] ; Multiple qualifiers are allowed. + ; Like in CLOS spec, we support + ; any non-list values. + cl-generic-method-args ; arguments [ &optional stringp ] ; documentation string def-body))) ; part to be debugged (let ((qualifiers nil)) @@ -1082,24 +1084,8 @@ These match if the argument is `eql' to VAL." ;;; Support for cl-defstructs specializers. (defun cl--generic-struct-tag (name &rest _) - ;; It's tempting to use (and (vectorp ,name) (aref ,name 0)) - ;; but that would suffer from some problems: - ;; - the vector may have size 0. - ;; - when called on an actual vector (rather than an object), we'd - ;; end up returning an arbitrary value, possibly colliding with - ;; other tagcode's values. - ;; - it can also result in returning all kinds of irrelevant - ;; values which would end up filling up the method-cache with - ;; lots of irrelevant/redundant entries. - ;; FIXME: We could speed this up by introducing a dedicated - ;; vector type at the C level, so we could do something like - ;; (and (vector-objectp ,name) (aref ,name 0)) - `(and (vectorp ,name) - (> (length ,name) 0) - (let ((tag (aref ,name 0))) - (and (symbolp tag) - (eq (symbol-function tag) :quick-object-witness-check) - tag)))) + ;; Use exactly the same code as for `typeof'. + `(if ,name (type-of ,name) 'null)) (defun cl--generic-class-parents (class) (let ((parents ()) @@ -1113,8 +1099,8 @@ These match if the argument is `eql' to VAL." (nreverse parents))) (defun cl--generic-struct-specializers (tag &rest _) - (and (symbolp tag) (boundp tag) - (let ((class (symbol-value tag))) + (and (symbolp tag) + (let ((class (get tag 'cl--class))) (when (cl-typep class 'cl-structure-class) (cl--generic-class-parents class))))) diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index 33ecf3f4542..df0e0a88583 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -1,4 +1,4 @@ -;;; cl-indent.el --- enhanced lisp-indent mode +;;; cl-indent.el --- Enhanced lisp-indent mode -*- lexical-binding:t -*- ;; Copyright (C) 1987, 2000-2017 Free Software Foundation, Inc. @@ -35,7 +35,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup lisp-indent nil "Indentation in Lisp." @@ -166,7 +166,7 @@ is set to `defun'.") (forward-char 1) (forward-sexp 2) (backward-sexp 1) - (looking-at "\\sw")) + (looking-at "\\(:\\|\\sw\\)")) (error t))) (defun lisp-indent-find-method (symbol &optional no-compat) @@ -187,13 +187,13 @@ the standard lisp indent package." (when (and (eq lisp-indent-backquote-substitution-mode 'corrected)) (save-excursion (goto-char (elt state 1)) - (incf loop-indentation - (cond ((eq (char-before) ?,) -1) - ((and (eq (char-before) ?@) - (progn (backward-char) - (eq (char-before) ?,))) - -2) - (t 0))))) + (cl-incf loop-indentation + (cond ((eq (char-before) ?,) -1) + ((and (eq (char-before) ?@) + (progn (backward-char) + (eq (char-before) ?,))) + -2) + (t 0))))) (goto-char indent-point) (beginning-of-line) @@ -315,7 +315,6 @@ instead." ;; If non-nil, this is an indentation to use ;; if nothing else specifies it more firmly. tentative-calculated - (last-point indent-point) ;; the position of the open-paren of the innermost containing list (containing-form-start (elt state 1)) ;; the column of the above @@ -410,9 +409,9 @@ instead." ;; ",(...)" or ",@(...)" (when (eq lisp-indent-backquote-substitution-mode 'corrected) - (incf sexp-column -1) + (cl-incf sexp-column -1) (when (eq (char-after (1- containing-sexp)) ?\@) - (incf sexp-column -1))) + (cl-incf sexp-column -1))) (cond (lisp-indent-backquote-substitution-mode (setf tentative-calculated normal-indent) (setq depth lisp-indent-maximum-backtracking) @@ -465,7 +464,6 @@ instead." function method path state indent-point sexp-column normal-indent))))) (goto-char containing-sexp) - (setq last-point containing-sexp) (unless calculated (condition-case () (progn (backward-up-list 1) @@ -474,6 +472,9 @@ instead." (or calculated tentative-calculated)))) +;; Dynamically bound in common-lisp-indent-call-method. +(defvar lisp-indent-error-function) + (defun common-lisp-indent-call-method (function method path state indent-point sexp-column normal-indent) (let ((lisp-indent-error-function function)) @@ -484,9 +485,6 @@ instead." (lisp-indent-259 method path state indent-point sexp-column normal-indent)))) -;; Dynamically bound in common-lisp-indent-call-method. -(defvar lisp-indent-error-function) - (defun lisp-indent-report-bad-format (m) (error "%s has a badly-formed %s property: %s" ;; Love those free variable references!! @@ -717,7 +715,7 @@ optional\\|rest\\|key\\|allow-other-keys\\|aux\\|whole\\|body\\|environment\ (forward-sexp 2) (skip-chars-forward " \t\n") (while (looking-at "\\sw\\|\\s_") - (incf nqual) + (cl-incf nqual) (forward-sexp) (skip-chars-forward " \t\n")) (> nqual 0))) @@ -726,7 +724,7 @@ optional\\|rest\\|key\\|allow-other-keys\\|aux\\|whole\\|body\\|environment\ path state indent-point sexp-column normal-indent)) -(defun lisp-indent-function-lambda-hack (path state indent-point +(defun lisp-indent-function-lambda-hack (path _state _indent-point sexp-column normal-indent) ;; indent (function (lambda () <newline> <body-forms>)) kludgily. (if (or (cdr path) ; wtf? diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 8c4455a3dad..936c852526c 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -349,7 +349,6 @@ Call `cl-float-limits' to set this.") (declare-function cl--mapcar-many "cl-extra" (cl-func cl-seqs &optional acc)) -;;;###autoload (defun cl-mapcar (cl-func cl-x &rest cl-rest) "Apply FUNCTION to each element of SEQ, and make a list of the results. If there are several SEQs, FUNCTION is called with that many arguments, @@ -639,6 +638,42 @@ If ALIST is non-nil, the new pairs are prepended to it." (require 'cl-macs) (require 'cl-seq)) +(defun cl--old-struct-type-of (orig-fun object) + (or (and (vectorp object) + (let ((tag (aref object 0))) + (when (and (symbolp tag) + (string-prefix-p "cl-struct-" (symbol-name tag))) + (unless (eq (symbol-function tag) + :quick-object-witness-check) + ;; Old-style old-style struct: + ;; Convert to new-style old-style struct! + (let* ((type (intern (substring (symbol-name tag) + (length "cl-struct-")))) + (class (cl--struct-get-class type))) + ;; If the `cl-defstruct' was recompiled after the code + ;; which constructed `object', `cl--struct-get-class' may + ;; not have called `cl-struct-define' and setup the tag + ;; symbol for us. + (unless (eq (symbol-function tag) + :quick-object-witness-check) + (set tag class) + (fset tag :quick-object-witness-check)))) + (cl--class-name (symbol-value tag))))) + (funcall orig-fun object))) + +;;;###autoload +(define-minor-mode cl-old-struct-compat-mode + "Enable backward compatibility with old-style structs. +This can be needed when using code byte-compiled using the old +macro-expansion of `cl-defstruct' that used vectors objects instead +of record objects." + :global t + (cond + (cl-old-struct-compat-mode + (advice-add 'type-of :around #'cl--old-struct-type-of)) + (t + (advice-remove 'type-of #'cl--old-struct-type-of)))) + ;; Local variables: ;; byte-compile-dynamic: t ;; End: diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 58bcdd52acf..b1ada00f4a4 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2052,15 +2052,17 @@ This is like `cl-flet', but for macros instead of functions. This function replaces `macroexpand' during macro expansion of `cl-symbol-macrolet', and does the same thing as `macroexpand' except that it additionally expands symbol macros." - (let ((macroexpand-all-environment env)) + (let ((macroexpand-all-environment env) + (venv (alist-get :cl-symbol-macros env))) (while (progn (setq exp (funcall cl--old-macroexpand exp env)) (pcase exp ((pred symbolp) ;; Perform symbol-macro expansion. - (when (cdr (assq exp env)) - (setq exp (cadr (assq exp env))))) + (let ((symval (assq exp venv))) + (when symval + (setq exp (cadr symval))))) (`(setq . ,_) ;; Convert setq to setf if required by symbol-macro expansion. (let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f env)) @@ -2078,7 +2080,7 @@ except that it additionally expands symbol macros." (let ((letf nil) (found nil) (nbs ())) (dolist (binding bindings) (let* ((var (if (symbolp binding) binding (car binding))) - (sm (assq var env))) + (sm (assq var venv))) (push (if (not (cdr sm)) binding (let ((nexp (cadr sm))) @@ -2136,29 +2138,28 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). \(fn ((NAME EXPANSION) ...) FORM...)" (declare (indent 1) (debug ((&rest (symbolp sexp)) cl-declarations body))) - (cond - ((cdr bindings) - `(cl-symbol-macrolet (,(car bindings)) - (cl-symbol-macrolet ,(cdr bindings) ,@body))) - ((null bindings) (macroexp-progn body)) - (t - (let ((previous-macroexpand (symbol-function 'macroexpand))) - (unwind-protect - (progn - (fset 'macroexpand #'cl--sm-macroexpand) - (let ((expansion - ;; FIXME: For N bindings, this will traverse `body' N times! - (macroexpand-all (macroexp-progn body) - (cons (list (caar bindings) - (cl-cadar bindings)) - macroexpand-all-environment)))) - (if (or (null (cdar bindings)) (cl-cddar bindings)) - (macroexp--warn-and-return - (format-message "Malformed `cl-symbol-macrolet' binding: %S" - (car bindings)) - expansion) - expansion))) - (fset 'macroexpand previous-macroexpand)))))) + (let ((previous-macroexpand (symbol-function 'macroexpand)) + (malformed-bindings nil)) + (dolist (binding bindings) + (unless (and (consp binding) (symbolp (car binding)) + (consp (cdr binding)) (null (cddr binding))) + (push binding malformed-bindings))) + (unwind-protect + (progn + (fset 'macroexpand #'cl--sm-macroexpand) + (let* ((venv (cdr (assq :cl-symbol-macros macroexpand-all-environment))) + (expansion + (macroexpand-all (macroexp-progn body) + (cons (cons :cl-symbol-macros + (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) + expansion))) + (fset 'macroexpand previous-macroexpand)))) ;;; Multiple values. @@ -2604,11 +2605,24 @@ non-nil value, that slot cannot be set via `setf'. (print-func nil) (print-auto nil) (safety (if (cl--compiling-file) cl--optimize-safety 3)) (include nil) - (tag (intern (format "cl-struct-%s" name))) + ;; There are 4 types of structs: + ;; - `vector' type: means we should use a vector, which can come + ;; with or without a tag `name', which is usually in slot 0 + ;; but obeys :initial-offset. + ;; - `list' type: same as `vector' but using lists. + ;; - `record' type: means we should use a record, which necessarily + ;; comes tagged in slot 0. Currently we'll use the `name' as + ;; the tag, but we may want to change it so that the class object + ;; is used as the tag. + ;; - nil type: this is the "pre-record default", which uses a vector + ;; with a tag in slot 0 which is a symbol of the form + ;; `cl-struct-NAME'. We need to still support this for backward + ;; compatibility with old .elc files. + (tag name) (tag-symbol (intern (format "cl-struct-%s-tags" name))) (include-descs nil) (include-name nil) - (type nil) + (type nil) ;nil here means not specified explicitly. (named nil) (forms nil) (docstring (if (stringp (car descs)) (pop descs))) @@ -2648,7 +2662,9 @@ non-nil value, that slot cannot be set via `setf'. ((eq opt :print-function) (setq print-func (car args))) ((eq opt :type) - (setq type (car args))) + (setq type (car args)) + (unless (memq type '(vector list)) + (error "Invalid :type specifier: %s" type))) ((eq opt :named) (setq named t)) ((eq opt :initial-offset) @@ -2680,13 +2696,11 @@ non-nil value, that slot cannot be set via `setf'. (pop include-descs))) (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs)) type inc-type - named (if type (assq 'cl-tag-slot descs) 'true)) - (if (cl--struct-class-named include) (setq tag name named t))) - (if type - (progn - (or (memq type '(vector list)) - (error "Invalid :type specifier: %s" type)) - (if named (setq tag name))) + named (if (memq type '(vector list)) + (assq 'cl-tag-slot descs) + 'true)) + (if (cl--struct-class-named include) (setq named t))) + (unless type (setq named 'true))) (or named (setq descs (delq (assq 'cl-tag-slot descs) descs))) (when (and (null predicate) named) @@ -2696,7 +2710,9 @@ non-nil value, that slot cannot be set via `setf'. (length (memq (assq 'cl-tag-slot descs) descs))))) (cond - ((memq type '(nil vector)) + ((null type) ;Record type. + `(memq (type-of cl-x) ,tag-symbol)) + ((eq type 'vector) `(and (vectorp cl-x) (>= (length cl-x) ,(length descs)) (memq (aref cl-x ,pos) ,tag-symbol))) @@ -2793,7 +2809,8 @@ non-nil value, that slot cannot be set via `setf'. (setq slots (nreverse slots) defaults (nreverse defaults)) (and copier - (push `(defalias ',copier #'copy-sequence) forms)) + (push `(defalias ',copier #'copy-sequence) + forms)) (if constructor (push (list constructor (cons '&key (delq nil (copy-sequence slots)))) @@ -2808,7 +2825,7 @@ non-nil value, that slot cannot be set via `setf'. (format "Constructor for objects of type `%s'." name)) ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) '((declare (side-effect-free t)))) - (,(or type #'vector) ,@make)) + (,(or type #'record) ,@make)) forms))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) ;; Don't bother adding to cl-custom-print-functions since it's not used @@ -2830,8 +2847,8 @@ non-nil value, that slot cannot be set via `setf'. ;; struct as a parent. (eval-and-compile (cl-struct-define ',name ,docstring ',include-name - ',type ,(eq named t) ',descs ',tag-symbol ',tag - ',print-auto)) + ',(or type 'record) ,(eq named t) ',descs + ',tag-symbol ',tag ',print-auto)) ',name))) ;;; Add cl-struct support to pcase @@ -2866,6 +2883,15 @@ is a shorthand for (NAME NAME)." ,pat))) fields))) +(defun cl--defstruct-predicate (type) + (let ((cons (assq (cl-struct-sequence-type type) + `((list . consp) + (vector . vectorp) + (nil . recordp))))) + (if cons + (cdr cons) + 'recordp))) + (defun cl--pcase-mutually-exclusive-p (orig pred1 pred2) "Extra special cases for `cl-typep' predicates." (let* ((x1 pred1) (x2 pred2) @@ -2888,14 +2914,12 @@ is a shorthand for (NAME NAME)." (memq c2 (cl--struct-all-parents c1))))))) (let ((c1 (and (symbolp t1) (cl--find-class t1)))) (and c1 (cl--struct-class-p c1) - (funcall orig (if (eq 'list (cl-struct-sequence-type t1)) - 'consp 'vectorp) + (funcall orig (cl--defstruct-predicate t1) pred2))) (let ((c2 (and (symbolp t2) (cl--find-class t2)))) (and c2 (cl--struct-class-p c2) (funcall orig pred1 - (if (eq 'list (cl-struct-sequence-type t2)) - 'consp 'vectorp)))) + (cl--defstruct-predicate t2)))) (funcall orig pred1 pred2)))) (advice-add 'pcase--mutually-exclusive-p :around #'cl--pcase-mutually-exclusive-p) @@ -2903,8 +2927,8 @@ is a shorthand for (NAME NAME)." (defun cl-struct-sequence-type (struct-type) "Return the sequence used to build STRUCT-TYPE. -STRUCT-TYPE is a symbol naming a struct type. Return `vector' or -`list', or nil if STRUCT-TYPE is not a struct type. " +STRUCT-TYPE is a symbol naming a struct type. Return `record', +`vector`, or `list' if STRUCT-TYPE is a struct type, nil otherwise." (declare (side-effect-free t) (pure t)) (cl--struct-class-type (cl--struct-get-class struct-type))) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 482b579f11a..ab6354de7cd 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -64,7 +64,7 @@ ;; cl--slot-descriptor. ;; BEWARE: Obviously, it's important to keep the two in sync! (lambda (name &optional initform type props) - (vector 'cl-struct-cl-slot-descriptor + (record 'cl-slot-descriptor name initform type props))) (defun cl--struct-get-class (name) @@ -101,7 +101,7 @@ (defun cl--struct-register-child (parent tag) ;; Can't use (cl-typep parent 'cl-structure-class) at this stage ;; because `cl-structure-class' is defined later. - (while (vectorp parent) + (while (recordp parent) (add-to-list (cl--struct-class-children-sym parent) tag) ;; Only register ourselves as a child of the leftmost parent since structs ;; can only only have one parent. @@ -110,6 +110,12 @@ ;;;###autoload (defun cl-struct-define (name docstring parent type named slots children-sym tag print) + (unless type + ;; Legacy defstruct, using tagged vectors. Enable backward compatibility. + (cl-old-struct-compat-mode 1)) + (if (eq type 'record) + ;; Defstruct using record objects. + (setq type nil)) (cl-assert (or type (not named))) (if (boundp children-sym) (add-to-list children-sym tag) @@ -150,7 +156,7 @@ parent name)))) (add-to-list 'current-load-list `(define-type . ,name)) (cl--struct-register-child parent-class tag) - (unless (eq named t) + (unless (or (eq named t) (eq tag name)) ;; We used to use `defconst' instead of `set' but that ;; has a side-effect of purecopying during the dump, so that the ;; class object stored in the tag ends up being a *copy* of the diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 8a8d4a4c1af..e9ca0412848 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -33,10 +33,13 @@ ;;; Code: +(require 'button) + (defvar cl-print-readably nil "If non-nil, try and make sure the result can be `read'.") (defvar cl-print--number-table nil) +(defvar cl-print--currently-printing nil) ;;;###autoload (cl-defgeneric cl-print-object (object stream) @@ -59,8 +62,9 @@ call other entry points instead, such as `cl-prin1'." (princ "(" stream) (cl-print-object car stream) (while (and (consp object) - (not (and cl-print--number-table - (numberp (gethash object cl-print--number-table))))) + (not (if cl-print--number-table + (numberp (gethash object cl-print--number-table)) + (memq object cl-print--currently-printing)))) (princ " " stream) (cl-print-object (pop object) stream)) (when object @@ -74,23 +78,38 @@ call other entry points instead, such as `cl-prin1'." (cl-print-object (aref object i) stream)) (princ "]" stream)) +(define-button-type 'help-byte-code + 'follow-link t + 'action (lambda (button) + (disassemble (button-get button 'byte-code-function))) + 'help-echo (purecopy "mouse-2, RET: disassemble this function")) + (defvar cl-print-compiled nil "Control how to print byte-compiled functions. Can be: - `static' to print the vector of constants. - `disassemble' to print the disassembly of the code. - nil to skip printing any details about the code.") +(defvar cl-print-compiled-button t + "Control how to print byte-compiled functions into buffers. +When the stream is a buffer, make the bytecode part of the output +into a button whose action shows the function's disassembly.") + +(autoload 'disassemble-1 "disass") + (cl-defmethod cl-print-object ((object compiled-function) stream) + (unless stream (setq stream standard-output)) ;; We use "#f(...)" rather than "#<...>" so that pp.el gives better results. (princ "#f(compiled-function " stream) (let ((args (help-function-arglist object 'preserve-names))) (if args (prin1 args stream) (princ "()" stream))) - (let ((doc (documentation object 'raw))) - (when doc - (princ " " stream) - (prin1 doc stream))) + (pcase (help-split-fundoc (documentation object 'raw) object) + ;; Drop args which `help-function-arglist' already printed. + (`(,_usage . ,(and doc (guard (stringp doc)))) + (princ " " stream) + (prin1 doc stream))) (let ((inter (interactive-form object))) (when inter (princ " " stream) @@ -108,10 +127,19 @@ call other entry points instead, such as `cl-prin1'." (disassemble-1 object 0) (buffer-string)) stream) - (princ " #<bytecode>" stream) - (when (eq cl-print-compiled 'static) - (princ " " stream) - (cl-print-object (aref object 2) stream))) + (princ " " stream) + (let ((button-start (and cl-print-compiled-button + (bufferp stream) + (with-current-buffer stream (point))))) + (princ "#<bytecode>" stream) + (when (eq cl-print-compiled 'static) + (princ " " stream) + (cl-print-object (aref object 2) stream)) + (when button-start + (with-current-buffer stream + (make-text-button button-start (point) + :type 'help-byte-code + 'byte-code-function object))))) (princ ")" stream)) ;; This belongs in nadvice.el, of course, but some load-ordering issues make it @@ -137,7 +165,7 @@ call other entry points instead, such as `cl-prin1'." (cl-defmethod cl-print-object ((object cl-structure-object) stream) (princ "#s(" stream) - (let* ((class (symbol-value (aref object 0))) + (let* ((class (cl-find-class (type-of object))) (slots (cl--struct-class-slots class))) (princ (cl--struct-class-name class) stream) (dotimes (i (length slots)) @@ -156,15 +184,26 @@ call other entry points instead, such as `cl-prin1'." (cl-defmethod cl-print-object :around (object stream) ;; FIXME: Only put such an :around method on types where it's relevant. - (let ((n (if cl-print--number-table (gethash object cl-print--number-table)))) - (if (not (numberp n)) - (cl-call-next-method) - (if (> n 0) - ;; Already printed. Just print a reference. - (progn (princ "#" stream) (princ n stream) (princ "#" stream)) - (puthash object (- n) cl-print--number-table) - (princ "#" stream) (princ (- n) stream) (princ "=" stream) - (cl-call-next-method))))) + (cond + (print-circle + (let ((n (gethash object cl-print--number-table))) + (if (not (numberp n)) + (cl-call-next-method) + (if (> n 0) + ;; Already printed. Just print a reference. + (progn (princ "#" stream) (princ n stream) (princ "#" stream)) + (puthash object (- n) cl-print--number-table) + (princ "#" stream) (princ (- n) stream) (princ "=" stream) + (cl-call-next-method))))) + ((let ((already-printing (memq object cl-print--currently-printing))) + (when already-printing + ;; Currently printing, just print reference to avoid endless + ;; recursion. + (princ "#" stream) + (princ (length (cdr already-printing)) stream)))) + (t (let ((cl-print--currently-printing + (cons object cl-print--currently-printing))) + (cl-call-next-method))))) (defvar cl-print--number-index nil) diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index cb77148c285..2b8782590c4 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -49,6 +49,12 @@ the middle is discarded, and just the beginning and end are displayed." :group 'debugger :version "21.1") +(defcustom debugger-print-function #'cl-prin1 + "Function used to print values in the debugger backtraces." + :type 'function + :options '(cl-prin1 prin1) + :version "26.1") + (defcustom debugger-bury-or-kill 'bury "What to do with the debugger buffer when exiting `debug'. The value affects the behavior of operations on any window @@ -264,6 +270,40 @@ first will be printed into the backtrace buffer." (setq debug-on-next-call debugger-step-after-exit) debugger-value))) + +(defun debugger-insert-backtrace (frames do-xrefs) + "Format and insert the backtrace FRAMES at point. +Make functions into cross-reference buttons if DO-XREFS is non-nil." + (let ((standard-output (current-buffer)) + (eval-buffers eval-buffer-list)) + (require 'help-mode) ; Define `help-function-def' button type. + (pcase-dolist (`(,evald ,fun ,args ,flags) frames) + (insert (if (plist-get flags :debug-on-exit) + "* " " ")) + (let ((fun-file (and do-xrefs (symbol-file fun 'defun))) + (fun-pt (point))) + (cond + ((and evald (not debugger-stack-frame-as-list)) + (funcall debugger-print-function fun) + (if args (funcall debugger-print-function args) (princ "()"))) + (t + (funcall debugger-print-function (cons fun args)) + (cl-incf fun-pt))) + (when fun-file + (make-text-button fun-pt (+ fun-pt (length (symbol-name fun))) + :type 'help-function-def + 'help-args (list fun fun-file)))) + ;; After any frame that uses eval-buffer, insert a line that + ;; states the buffer position it's reading at. + (when (and eval-buffers (memq fun '(eval-buffer eval-region))) + (insert (format " ; Reading at buffer position %d" + ;; This will get the wrong result if there are + ;; two nested eval-region calls for the same + ;; buffer. That's not a very useful case. + (with-current-buffer (pop eval-buffers) + (point))))) + (insert "\n")))) + (defun debugger-setup-buffer (args) "Initialize the `*Backtrace*' buffer for entry to the debugger. That buffer should be current already." @@ -271,27 +311,20 @@ That buffer should be current already." (erase-buffer) (set-buffer-multibyte t) ;Why was it nil ? -stef (setq buffer-undo-list t) - (let ((standard-output (current-buffer)) - (print-escape-newlines t) - (print-level 8) - (print-length 50)) - ;; FIXME the debugger could pass a custom callback to mapbacktrace - ;; instead of manipulating printed results. - (mapbacktrace #'backtrace--print-frame 'debug)) - (goto-char (point-min)) - (delete-region (point) - (progn - (forward-line (if (eq (car args) 'debug) - ;; Remove debug--implement-debug-on-entry - ;; and the advice's `apply' frame. - 3 - 1)) - (point))) (insert "Debugger entered") - ;; lambda is for debug-on-call when a function call is next. - ;; debug is for debug-on-entry function called. - (let ((pos (point))) + (let ((frames (nthcdr + ;; Remove debug--implement-debug-on-entry and the + ;; advice's `apply' frame. + (if (eq (car args) 'debug) 3 1) + (backtrace-frames 'debug))) + (print-escape-newlines t) + (print-escape-control-characters t) + (print-level 8) + (print-length 50) + (pos (point))) (pcase (car args) + ;; lambda is for debug-on-call when a function call is next. + ;; debug is for debug-on-entry function called. ((or `lambda `debug) (insert "--entering a function:\n") (setq pos (1- (point)))) @@ -300,11 +333,9 @@ That buffer should be current already." (insert "--returning value: ") (setq pos (point)) (setq debugger-value (nth 1 args)) - (prin1 debugger-value (current-buffer)) - (insert ?\n) - (delete-char 1) - (insert ? ) - (beginning-of-line)) + (funcall debugger-print-function debugger-value (current-buffer)) + (setf (cl-getf (nth 3 (car frames)) :debug-on-exit) nil) + (insert ?\n)) ;; Watchpoint triggered. ((and `watchpoint (let `(,symbol ,newval . ,details) (cdr args))) (insert @@ -327,7 +358,7 @@ That buffer should be current already." (`error (insert "--Lisp error: ") (setq pos (point)) - (prin1 (nth 1 args) (current-buffer)) + (funcall debugger-print-function (nth 1 args) (current-buffer)) (insert ?\n)) ;; debug-on-call, when the next thing is an eval. (`t @@ -337,98 +368,15 @@ That buffer should be current already." (_ (insert ": ") (setq pos (point)) - (prin1 (if (eq (car args) 'nil) - (cdr args) args) - (current-buffer)) + (funcall debugger-print-function + (if (eq (car args) 'nil) + (cdr args) args) + (current-buffer)) (insert ?\n))) + (debugger-insert-backtrace frames t) ;; Place point on "stack frame 0" (bug#15101). - (goto-char pos)) - ;; After any frame that uses eval-buffer, - ;; insert a line that states the buffer position it's reading at. - (save-excursion - (let ((tem eval-buffer-list)) - (while (and tem - (re-search-forward "^ eval-\\(buffer\\|region\\)(" nil t)) - (end-of-line) - (insert (format " ; Reading at buffer position %d" - ;; This will get the wrong result - ;; if there are two nested eval-region calls - ;; for the same buffer. That's not a very useful case. - (with-current-buffer (car tem) - (point)))) - (pop tem)))) - (debugger-make-xrefs)) - -(defun debugger-make-xrefs (&optional buffer) - "Attach cross-references to function names in the `*Backtrace*' buffer." - (interactive "b") - (with-current-buffer (or buffer (current-buffer)) - (save-excursion - (setq buffer (current-buffer)) - (let ((inhibit-read-only t) - (old-end (point-min)) (new-end (point-min))) - ;; If we saved an old backtrace, find the common part - ;; between the new and the old. - ;; Compare line by line, starting from the end, - ;; because that's the part that is likely to be unchanged. - (if debugger-previous-backtrace - (let (old-start new-start (all-match t)) - (goto-char (point-max)) - (with-temp-buffer - (insert debugger-previous-backtrace) - (while (and all-match (not (bobp))) - (setq old-end (point)) - (forward-line -1) - (setq old-start (point)) - (with-current-buffer buffer - (setq new-end (point)) - (forward-line -1) - (setq new-start (point))) - (if (not (zerop - (let ((case-fold-search nil)) - (compare-buffer-substrings - (current-buffer) old-start old-end - buffer new-start new-end)))) - (setq all-match nil)))) - ;; Now new-end is the position of the start of the - ;; unchanged part in the current buffer, and old-end is - ;; the position of that same text in the saved old - ;; backtrace. But we must subtract (point-min) since strings are - ;; indexed in origin 0. - - ;; Replace the unchanged part of the backtrace - ;; with the text from debugger-previous-backtrace, - ;; since that already has the proper xrefs. - ;; With this optimization, we only need to scan - ;; the changed part of the backtrace. - (delete-region new-end (point-max)) - (goto-char (point-max)) - (insert (substring debugger-previous-backtrace - (- old-end (point-min)))) - ;; Make the unchanged part of the backtrace inaccessible - ;; so it won't be scanned. - (narrow-to-region (point-min) new-end))) - - ;; Scan the new part of the backtrace, inserting xrefs. - (goto-char (point-min)) - (while (progn - (goto-char (+ (point) 2)) - (skip-syntax-forward "^w_") - (not (eobp))) - (let* ((beg (point)) - (end (progn (skip-syntax-forward "w_") (point))) - (sym (intern-soft (buffer-substring-no-properties - beg end))) - (file (and sym (symbol-file sym 'defun)))) - (when file - (goto-char beg) - ;; help-xref-button needs to operate on something matched - ;; by a regexp, so set that up for it. - (re-search-forward "\\(\\sw\\|\\s_\\)+") - (help-xref-button 0 'help-function-def sym file))) - (forward-line 1)) - (widen)) - (setq debugger-previous-backtrace (buffer-string))))) + (goto-char pos))) + (defun debugger-step-through () "Proceed, stepping through subexpressions of this expression. @@ -727,6 +675,9 @@ Complete list of commands: \\{debugger-mode-map}" (setq truncate-lines t) (set-syntax-table emacs-lisp-mode-syntax-table) + (add-hook 'kill-buffer-hook + (lambda () (if (> (recursion-depth) 0) (top-level))) + nil t) (use-local-map debugger-mode-map)) (defcustom debugger-record-buffer "*Debugger-record*" @@ -863,9 +814,13 @@ To specify a nil argument interactively, exit with an empty minibuffer." 'type 'help-function 'help-args (list fun)) (terpri)) - (terpri) - (princ "Note: if you have redefined a function, then it may no longer\n") - (princ "be set to debug on entry, even if it is in the list.")))))) + ;; Now that debug--function-list uses advice-member-p, its + ;; output should be reliable (except for bugs and the exceptional + ;; case where some other advice ends up overriding ours). + ;;(terpri) + ;;(princ "Note: if you have redefined a function, then it may no longer\n") + ;;(princ "be set to debug on entry, even if it is in the list.") + ))))) (defun debug--implement-debug-watch (symbol newval op where) "Conditionally call the debugger. diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 4116e31d0a9..65e30f86778 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1607,6 +1607,7 @@ expressions; a `progn' form will be returned enclosing these forms." ;; Less frequently used: ;; (function . edebug-match-function) (lambda-expr . edebug-match-lambda-expr) + (cl-generic-method-args . edebug-match-cl-generic-method-args) (¬ . edebug-match-¬) (&key . edebug-match-&key) (place . edebug-match-place) @@ -1900,6 +1901,16 @@ expressions; a `progn' form will be returned enclosing these forms." spec)) nil) +(defun edebug-match-cl-generic-method-args (cursor) + (let ((args (edebug-top-element-required cursor "Expected arguments"))) + (if (not (consp args)) + (edebug-no-match cursor "List expected")) + ;; Append the arguments to edebug-def-name. + (setq edebug-def-name + (intern (format "%s %s" edebug-def-name args))) + (edebug-move-cursor cursor) + (list args))) + (defun edebug-match-arg (cursor) ;; set the def-args bound in edebug-defining-form (let ((edebug-arg (edebug-top-element-required cursor "Expected arg"))) @@ -3186,8 +3197,11 @@ go to the end of the last sexp, or if that is the same point, then step." ))))) (defun edebug-instrument-function (func) - ;; Func should be a function symbol. - ;; Return the function symbol, or nil if not instrumented. + "Instrument the function or generic method FUNC. +Return the list of function symbols which were instrumented. +This may be simply (FUNC) for a normal function, or a list of +generated symbols for methods. If a function or method to +instrument cannot be found, signal an error." (let ((func-marker (get func 'edebug))) (cond ((and (markerp func-marker) (marker-buffer func-marker)) @@ -3195,10 +3209,24 @@ go to the end of the last sexp, or if that is the same point, then step." (with-current-buffer (marker-buffer func-marker) (goto-char func-marker) (edebug-eval-top-level-form) - func)) + (list func))) ((consp func-marker) (message "%s is already instrumented." func) - func) + (list func)) + ((get func 'cl--generic) + (let ((method-defs (method-files func)) + symbols) + (unless method-defs + (error "Could not find any method definitions for %s" func)) + (pcase-dolist (`(,file . ,spec) method-defs) + (let* ((loc (find-function-search-for-symbol spec 'cl-defmethod file))) + (unless (cdr loc) + (error "Could not find the definition for %s in its file" spec)) + (with-current-buffer (car loc) + (goto-char (cdr loc)) + (edebug-eval-top-level-form) + (push (edebug-form-data-symbol) symbols)))) + symbols)) (t (let ((loc (find-function-noselect func t))) (unless (cdr loc) @@ -3206,13 +3234,16 @@ go to the end of the last sexp, or if that is the same point, then step." (with-current-buffer (car loc) (goto-char (cdr loc)) (edebug-eval-top-level-form) - func)))))) + (list func))))))) (defun edebug-instrument-callee () "Instrument the definition of the function or macro about to be called. Do this when stopped before the form or it will be too late. One side effect of using this command is that the next time the -function or macro is called, Edebug will be called there as well." +function or macro is called, Edebug will be called there as well. +If the callee is a generic function, Edebug will instrument all +the methods, not just the one which is about to be called. Return +the list of symbols which were instrumented." (interactive) (if (not (looking-at "(")) (error "You must be before a list form") @@ -3227,15 +3258,15 @@ function or macro is called, Edebug will be called there as well." (defun edebug-step-in () - "Step into the definition of the function or macro about to be called. + "Step into the definition of the function, macro or method about to be called. This first does `edebug-instrument-callee' to ensure that it is instrumented. Then it does `edebug-on-entry' and switches to `go' mode." (interactive) - (let ((func (edebug-instrument-callee))) - (if func + (let ((funcs (edebug-instrument-callee))) + (if funcs (progn - (edebug-on-entry func 'temp) - (edebug-go-mode nil))))) + (mapc (lambda (func) (edebug-on-entry func 'temp)) funcs) + (edebug-go-mode nil))))) (defun edebug-on-entry (function &optional flag) "Cause Edebug to stop when FUNCTION is called. diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 986d0285172..33c71ec5807 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -294,8 +294,7 @@ Second, any text properties will be stripped from strings." (cond ((consp proposed-value) ;; Lists with something in them need special treatment. (let* ((slot-idx (- (eieio--slot-name-index class slot) - (eval-when-compile - (length (cl-struct-slot-info 'eieio--object))))) + (eval-when-compile eieio--object-num-slots))) (type (cl--slot-descriptor-type (aref (eieio--class-slots class) slot-idx))) (classtype (eieio-persistent-slot-type-is-class-p type))) diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index 888d85f6038..e6e6d118709 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el @@ -105,10 +105,10 @@ Summary: (declare (doc-string 3) (obsolete cl-defmethod "25.1") (debug (&define ; this means we are defining something - [&or name ("setf" :name setf name)] + [&or name ("setf" name :name setf)] ;; ^^ This is the methods symbol [ &optional symbolp ] ; this is key :before etc - list ; arguments + cl-generic-method-args ; arguments [ &optional stringp ] ; documentation string def-body ; part to be debugged ))) @@ -145,7 +145,7 @@ Summary: ;; interleaved list comes before the class's non-interleaved list. 51 #'cl--generic-struct-tag (lambda (tag &rest _) - (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag)) + (and (symbolp tag) (setq tag (cl--find-class tag)) (eieio--class-p tag) (let ((superclasses (eieio--class-precedence-list tag)) (specializers ())) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 5cc6d020eaf..9d618e1dc81 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -32,8 +32,7 @@ ;;; Code: (require 'cl-lib) -(require 'pcase) -(require 'eieio-loaddefs) +(require 'eieio-loaddefs nil t) ;;; ;; A few functions that are better in the official EIEIO src, but @@ -85,7 +84,7 @@ Currently under control of this var: (progn ;; Arrange for field access not to bother checking if the access is indeed ;; made to an eieio--class object. - (cl-declaim (optimize (safety 0))) + (eval-when-compile (cl-declaim (optimize (safety 0)))) (cl-defstruct (eieio--class (:constructor nil) @@ -104,25 +103,22 @@ Currently under control of this var: options ;; storage location of tagged class option ; Stored outright without modifications or stripping ) - ;; Set it back to the default value. - (cl-declaim (optimize (safety 1)))) + ;; Set it back to the default value. NOTE: Using the default + ;; `safety' value does NOT give the default + ;; `byte-compile-delete-errors' value. Therefore limit this (and + ;; the above `cl-declaim') to compile time so that we don't affect + ;; code which only loads this library. + (eval-when-compile (cl-declaim (optimize (safety 1))))) -(cl-defstruct (eieio--object - (:type vector) ;We manage our own tagging system. - (:constructor nil) - (:copier nil)) - ;; `class-tag' holds a symbol, which is not the class name, but is instead - ;; properly prefixed as an internal EIEIO thingy and which holds the class - ;; object/struct in its `symbol-value' slot. - class-tag) +(eval-and-compile + (defconst eieio--object-num-slots 1)) -(eval-when-compile - (defconst eieio--object-num-slots - (length (cl-struct-slot-info 'eieio--object)))) +(defsubst eieio--object-class-tag (obj) + (aref obj 0)) (defsubst eieio--object-class (obj) - (symbol-value (eieio--object-class-tag obj))) + (eieio--object-class-tag obj)) ;;; Important macros used internally in eieio. @@ -166,13 +162,8 @@ Return nil if that option doesn't exist." (defun eieio-object-p (obj) "Return non-nil if OBJ is an EIEIO object." - (and (vectorp obj) - (> (length obj) 0) - (let ((tag (eieio--object-class-tag obj))) - (and (symbolp tag) - ;; (eq (symbol-function tag) :quick-object-witness-check) - (boundp tag) - (eieio--class-p (symbol-value tag)))))) + (and (recordp obj) + (eieio--class-p (eieio--object-class-tag obj)))) (define-obsolete-function-alias 'object-p 'eieio-object-p "25.1") @@ -496,18 +487,11 @@ See `defclass' for more information." (if clearparent (setf (eieio--class-parents newc) nil)) ;; Create the cached default object. - (let ((cache (make-vector (+ (length (eieio--class-slots newc)) - (eval-when-compile eieio--object-num-slots)) - nil)) - ;; We don't strictly speaking need to use a symbol, but the old - ;; code used the class's name rather than the class's object, so - ;; we follow this preference for using a symbol, which is probably - ;; convenient to keep the printed representation of such Elisp - ;; objects readable. - (tag (intern (format "eieio-class-tag--%s" cname)))) - (set tag newc) - (fset tag :quick-object-witness-check) - (setf (eieio--object-class-tag cache) tag) + (let ((cache (make-record newc + (+ (length (eieio--class-slots newc)) + (eval-when-compile eieio--object-num-slots) + -1) + nil))) (let ((eieio-skip-typecheck t)) ;; All type-checking has been done to our satisfaction ;; before this call. Don't waste our time in this call.. @@ -1060,9 +1044,10 @@ method invocation orders of the involved classes." ;; part of the dispatch code. 50 #'cl--generic-struct-tag (lambda (tag &rest _) - (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag)) - (mapcar #'eieio--class-name - (eieio--class-precedence-list (symbol-value tag)))))) + (let ((class (cl--find-class tag))) + (and (eieio--class-p class) + (mapcar #'eieio--class-name + (eieio--class-precedence-list class)))))) (cl-defmethod cl-generic-generalizers :extra "class" (specializer) "Support for dispatch on types defined by EIEIO's `defclass'." diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 1a6d5e9d7c1..1a7de55fcef 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -235,7 +235,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 @@ -337,14 +337,12 @@ variable name of the same name as the slot." ;; hard-coded in random .elc files. (defun eieio-pcase-slot-index-table (obj) "Return some data structure from which can be extracted the slot offset." - (eieio--class-index-table - (symbol-value (eieio--object-class-tag obj)))) + (eieio--class-index-table (eieio--object-class obj))) (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 - (length (cl-struct-slot-info 'eieio--object))) + (if index (+ (eval-when-compile eieio--object-num-slots) index)))) (pcase-defmacro eieio (&rest fields) diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 6cb8e6ce480..a05bd7cc4d4 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -186,8 +186,9 @@ expression point is on." :group 'eldoc :lighter eldoc-minor-mode-string (setq eldoc-last-message nil) (cond - ((memq eldoc-documentation-function '(nil ignore)) - (message "There is no ElDoc support in this buffer") + ((not (eldoc--supported-p)) + (when (called-interactively-p 'any) + (message "There is no ElDoc support in this buffer")) (setq eldoc-mode nil)) (eldoc-mode (when eldoc-print-after-edit @@ -203,29 +204,20 @@ expression point is on." (setq eldoc-timer nil))))) ;;;###autoload -(define-minor-mode global-eldoc-mode - "Toggle Global Eldoc mode on or off. -With a prefix argument ARG, enable Global Eldoc mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil, and toggle it if ARG is ‘toggle’. - -If Global Eldoc mode is on, `eldoc-mode' will be enabled in all -buffers where it's applicable. These are buffers that have modes -that have enabled eldoc support. See `eldoc-documentation-function'." +(define-globalized-minor-mode global-eldoc-mode eldoc-mode turn-on-eldoc-mode :group 'eldoc - :global t :initialize 'custom-initialize-delay - :init-value t - (setq eldoc-last-message nil) - (if global-eldoc-mode - (progn - (add-hook 'post-command-hook #'eldoc-schedule-timer) - (add-hook 'pre-command-hook #'eldoc-pre-command-refresh-echo-area)) - (remove-hook 'post-command-hook #'eldoc-schedule-timer) - (remove-hook 'pre-command-hook #'eldoc-pre-command-refresh-echo-area))) + :init-value t) ;;;###autoload -(define-obsolete-function-alias 'turn-on-eldoc-mode 'eldoc-mode "24.4") +(defun turn-on-eldoc-mode () + "Turn on `eldoc-mode' if the buffer has eldoc support enabled. +See `eldoc-documentation-function' for more detail." + (when (eldoc--supported-p) + (eldoc-mode 1))) + +(defun eldoc--supported-p () + (not (memq eldoc-documentation-function '(nil ignore)))) (defun eldoc-schedule-timer () @@ -426,7 +418,7 @@ return any documentation.") "down-list" "end-of-" "exchange-point-and-mark" "forward-" "goto-" "handle-select-window" "indent-for-tab-command" "left-" "mark-page" "mark-paragraph" "mouse-set-point" "move-" "move-beginning-of-" - "move-end-of-" "next-" "other-window" "pop-global-mark" "previous-" + "move-end-of-" "newline" "next-" "other-window" "pop-global-mark" "previous-" "recenter" "right-" "scroll-" "self-insert-command" "split-window-" "up-list") diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index e7387e463cb..eb2b2e3e11b 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -276,7 +276,8 @@ DATA is displayed to the user and should state the reason for skipping." (defun ert--expand-should-1 (whole form inner-expander) "Helper function for the `should' macro and its variants." (let ((form - (macroexpand form (append byte-compile-macro-environment + (macroexpand form (append (bound-and-true-p + byte-compile-macro-environment) (cond ((boundp 'macroexpand-all-environment) macroexpand-all-environment) @@ -669,48 +670,12 @@ and is displayed in front of the value of MESSAGE-FORM." (cl-defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) - -(defun ert--record-backtrace () - "Record the current backtrace (as a list) and return it." - ;; Since the backtrace is stored in the result object, result - ;; objects must only be printed with appropriate limits - ;; (`print-level' and `print-length') in place. For interactive - ;; use, the cost of ensuring this possibly outweighs the advantage - ;; of storing the backtrace for - ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we - ;; already have `ert-results-rerun-test-debugging-errors-at-point'. - ;; For batch use, however, printing the backtrace may be useful. - (cl-loop - ;; 6 is the number of frames our own debugger adds (when - ;; compiled; more when interpreted). FIXME: Need to describe a - ;; procedure for determining this constant. - for i from 6 - for frame = (backtrace-frame i) - while frame - collect frame)) - -(defun ert--print-backtrace (backtrace) +(defun ert--print-backtrace (backtrace do-xrefs) "Format the backtrace BACKTRACE to the current buffer." - ;; This is essentially a reimplementation of Fbacktrace - ;; (src/eval.c), but for a saved backtrace, not the current one. (let ((print-escape-newlines t) (print-level 8) (print-length 50)) - (dolist (frame backtrace) - (pcase-exhaustive frame - (`(nil ,special-operator . ,arg-forms) - ;; Special operator. - (insert - (format " %S\n" (cons special-operator arg-forms)))) - (`(t ,fn . ,args) - ;; Function call. - (insert (format " %S(" fn)) - (cl-loop for firstp = t then nil - for arg in args do - (unless firstp - (insert " ")) - (insert (format "%S" arg))) - (insert ")\n")))))) + (debugger-insert-backtrace backtrace do-xrefs))) ;; A container for the state of the execution of a single test and ;; environment data needed during its execution. @@ -749,7 +714,19 @@ run. ARGS are the arguments to `debugger'." ((quit) 'quit) ((ert-test-skipped) 'skipped) (otherwise 'failed))) - (backtrace (ert--record-backtrace)) + ;; We store the backtrace in the result object for + ;; `ert-results-pop-to-backtrace-for-test-at-point'. + ;; This means we have to limit `print-level' and + ;; `print-length' when printing result objects. That + ;; might not be worth while when we can also use + ;; `ert-results-rerun-test-debugging-errors-at-point', + ;; (i.e., when running interactively) but having the + ;; backtrace ready for printing is important for batch + ;; use. + ;; + ;; Grab the frames starting from `signal', frames below + ;; that are all from the debugger. + (backtrace (backtrace-frames 'signal)) (infos (reverse ert--infos))) (setf (ert--test-execution-info-result info) (cl-ecase type @@ -1408,8 +1385,9 @@ Returns the stats object." (ert-test-result-with-condition (message "Test %S backtrace:" (ert-test-name test)) (with-temp-buffer - (ert--print-backtrace (ert-test-result-with-condition-backtrace - result)) + (ert--print-backtrace + (ert-test-result-with-condition-backtrace result) + nil) (goto-char (point-min)) (while (not (eobp)) (let ((start (point)) @@ -1457,6 +1435,12 @@ The exit status will be 0 if all test results were as expected, 1 on unexpected results, or 2 if the tool detected an error outside of the tests (e.g. invalid SELECTOR or bug in the code that runs the tests)." + (or noninteractive + (user-error "This function is only for use in batch mode")) + ;; Better crash loudly than attempting to recover from undefined + ;; behavior. + (setq attempt-stack-overflow-recovery nil + attempt-orderly-shutdown-on-fatal-signal nil) (unwind-protect (let ((stats (ert-run-tests-batch selector))) (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1))) @@ -1474,13 +1458,17 @@ The logfiles should have the `ert-run-tests-batch' format. When finished, this exits Emacs, with status as per `ert-run-tests-batch-and-exit'." (or noninteractive (user-error "This function is only for use in batch mode")) + ;; Better crash loudly than attempting to recover from undefined + ;; behavior. + (setq attempt-stack-overflow-recovery nil + attempt-orderly-shutdown-on-fatal-signal nil) (let ((nlogs (length command-line-args-left)) (ntests 0) (nrun 0) (nexpected 0) (nunexpected 0) (nskipped 0) nnotrun logfile notests badtests unexpected skipped) (with-temp-buffer (while (setq logfile (pop command-line-args-left)) (erase-buffer) - (insert-file-contents logfile) + (when (file-readable-p logfile) (insert-file-contents logfile)) (if (not (re-search-forward "^Running \\([0-9]+\\) tests" nil t)) (push logfile notests) (setq ntests (+ ntests (string-to-number (match-string 1)))) @@ -1602,7 +1590,7 @@ Signals an error if no test name was read." (let ((sym (intern-soft input))) (if (ert-test-boundp sym) sym - (error "Input does not name a test"))))) + (user-error "Input does not name a test"))))) (defun ert-read-test-name-at-point (prompt) "Read the name of a test and return it as a symbol. @@ -1628,7 +1616,7 @@ Nothing more than an interactive interface to `ert-make-test-unbound'." (interactive) (when (called-interactively-p 'any) (unless (y-or-n-p "Delete all tests? ") - (error "Aborted"))) + (user-error "Aborted"))) ;; We can't use `ert-select-tests' here since that gives us only ;; test objects, and going from them back to the test name symbols ;; can fail if the `ert-test' defstruct has been redefined. @@ -1817,12 +1805,23 @@ EWOC and STATS are arguments for `ert--results-update-stats-display'." BEGIN and END specify a region in the current buffer." (save-excursion - (save-restriction - (narrow-to-region begin end) - ;; Inhibit optimization in `debugger-make-xrefs' that would - ;; sometimes insert unrelated backtrace info into our buffer. - (let ((debugger-previous-backtrace nil)) - (debugger-make-xrefs))))) + (goto-char begin) + (while (progn + (goto-char (+ (point) 2)) + (skip-syntax-forward "^w_") + (< (point) end)) + (let* ((beg (point)) + (end (progn (skip-syntax-forward "w_") (point))) + (sym (intern-soft (buffer-substring-no-properties + beg end))) + (file (and sym (symbol-file sym 'defun)))) + (when file + (goto-char beg) + ;; help-xref-button needs to operate on something matched + ;; by a regexp, so set that up for it. + (re-search-forward "\\(\\sw\\|\\s_\\)+") + (help-xref-button 0 'help-function-def sym file))) + (forward-line 1)))) (defun ert--string-first-line (s) "Return the first line of S, or S if it contains no newlines. @@ -2141,7 +2140,7 @@ To be used in the ERT results buffer." To be used in the ERT results buffer." (or (ert--results-test-node-or-null-at-point) - (error "No test at point"))) + (user-error "No test at point"))) (defun ert-results-next-test () "Move point to the next test. @@ -2191,7 +2190,7 @@ To be used in the ERT results buffer." (interactive) (let ((name (ert-test-at-point))) (unless name - (error "No test at point")) + (user-error "No test at point")) (ert-find-test-other-window name))) (defun ert--test-name-button-action (button) @@ -2352,7 +2351,7 @@ To be used in the ERT results buffer." (cl-destructuring-bind (test redefinition-state) (ert--results-test-at-point-allow-redefinition) (when (null test) - (error "No test at point")) + (user-error "No test at point")) (let* ((stats ert--results-stats) (progress-message (format "Running %stest %S" (cl-ecase redefinition-state @@ -2409,8 +2408,7 @@ To be used in the ERT results buffer." ;; Use unibyte because `debugger-setup-buffer' also does so. (set-buffer-multibyte nil) (setq truncate-lines t) - (ert--print-backtrace backtrace) - (debugger-make-xrefs) + (ert--print-backtrace backtrace t) (goto-char (point-min)) (insert (substitute-command-keys "Backtrace for test `")) (ert-insert-test-name-button (ert-test-name test)) @@ -2525,7 +2523,7 @@ To be used in the ERT results buffer." "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)." (interactive (list (ert-read-test-name-at-point "Describe test"))) (when (< emacs-major-version 24) - (error "Requires Emacs 24")) + (user-error "Requires Emacs 24 or later")) (let (test-name test-definition) (cl-etypecase test-or-test-name diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 6699e3fd2b1..9b98f05ae81 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -43,7 +43,7 @@ ;;; Code: -(require 'seq) +(eval-when-compile (require 'cl-lib)) ;;; User variables: @@ -203,43 +203,21 @@ LIBRARY should be a string (the name of the library)." (locate-file rel (or find-function-source-path load-path) load-file-rep-suffixes))))) - (find-library--from-load-path library) + (find-library--from-load-history library) (error "Can't find library %s" library))) -(defun find-library--from-load-path (library) +(defun find-library--from-load-history (library) ;; In `load-history', the file may be ".elc", ".el", ".el.gz", and - ;; LIBRARY may be "foo.el" or "foo", so make sure that we get all - ;; potential matches, and then see whether any of them lead us to an - ;; ".el" or an ".el.gz" file. - (let* ((elc-regexp "\\.el\\(c\\(\\..*\\)?\\)\\'") - (suffix-regexp - (concat "\\(" - (mapconcat 'regexp-quote (find-library-suffixes) "\\'\\|") - "\\|" elc-regexp "\\)\\'")) - (potentials - (mapcar - (lambda (entry) - (if (string-match suffix-regexp (car entry)) - (replace-match "" t t (car entry)) - (car entry))) - (seq-filter - (lambda (entry) - (string-match - (concat "\\`" - (regexp-quote - (replace-regexp-in-string suffix-regexp "" library)) - suffix-regexp) - (file-name-nondirectory (car entry)))) - load-history))) - result) - (dolist (file potentials) - (dolist (suffix (find-library-suffixes)) - (when (not result) - (cond ((file-exists-p file) - (setq result file)) - ((file-exists-p (concat file suffix)) - (setq result (concat file suffix))))))) - result)) + ;; LIBRARY may be "foo.el" or "foo". + (let ((load-re + (concat "\\(" (regexp-quote (file-name-sans-extension library)) "\\)" + (regexp-opt (get-load-suffixes)) "\\'"))) + (cl-loop + for (file . _) in load-history thereis + (and (stringp file) (string-match load-re file) + (let ((dir (substring file 0 (match-beginning 1))) + (basename (match-string 1 file))) + (locate-file basename (list dir) (find-library-suffixes))))))) (defvar find-function-C-source-directory (let ((dir (expand-file-name "src" source-directory))) @@ -293,43 +271,65 @@ TYPE should be nil to find a function, or `defvar' to find a variable." (cons (current-buffer) (match-beginning 0)))) ;;;###autoload -(defun find-library (library &optional other-window) +(defun find-library (library) "Find the Emacs Lisp source of LIBRARY. -LIBRARY should be a string (the name of the library). If the -optional OTHER-WINDOW argument (i.e., the command argument) is -specified, pop to a different window before displaying the -buffer." - (interactive - (let* ((dirs (or find-function-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 - ;; `save-excursion' below in a `condition-case' to - ;; avoid reporting a scan-error here. - (condition-case nil - (save-excursion - (backward-up-list) - (forward-char) - (forward-sexp 2) - (thing-at-point 'symbol)) - (error nil)) - (thing-at-point 'symbol)))) - (when (and def (not (test-completion def table))) - (setq def nil)) - (list - (completing-read (if def - (format "Library name (default %s): " def) - "Library name: ") - table nil nil nil nil def) - current-prefix-arg))) + +Interactively, prompt for LIBRARY using the one at or near point." + (interactive (list (read-library-name))) + (prog1 + (switch-to-buffer (find-file-noselect (find-library-name library))) + (run-hooks 'find-function-after-hook))) + +(defun read-library-name () + "Read and return a library name, defaulting to the one near point. + +A library name is the filename of an Emacs Lisp library located +in a directory under `load-path' (or `find-function-source-path', +if non-nil)." + (let* ((dirs (or find-function-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 + ;; `save-excursion' below in a `condition-case' to + ;; avoid reporting a scan-error here. + (condition-case nil + (save-excursion + (backward-up-list) + (forward-char) + (forward-sexp 2) + (thing-at-point 'symbol)) + (error nil)) + (thing-at-point 'symbol)))) + (when (and def (not (test-completion def table))) + (setq def nil)) + (completing-read (if def + (format "Library name (default %s): " def) + "Library name: ") + table nil nil nil nil def))) + +;;;###autoload +(defun find-library-other-window (library) + "Find the Emacs Lisp source of LIBRARY in another window. + +See `find-library' for more details." + (interactive (list (read-library-name))) + (prog1 + (switch-to-buffer-other-window (find-file-noselect + (find-library-name library))) + (run-hooks 'find-function-after-hook))) + +;;;###autoload +(defun find-library-other-frame (library) + "Find the Emacs Lisp source of LIBRARY in another frame. + +See `find-library' for more details." + (interactive (list (read-library-name))) (prog1 - (funcall (if other-window - 'pop-to-buffer - 'pop-to-buffer-same-window) - (find-file-noselect (find-library-name library))) + (switch-to-buffer-other-frame (find-file-noselect + (find-library-name library))) (run-hooks 'find-function-after-hook))) ;;;###autoload diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index 2ab01404bad..c96b400809b 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -77,7 +77,6 @@ ;;; Code: (require 'cl-lib) -(require 'pcase) (defvar cps--bindings nil) (defvar cps--states nil) diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index fc3caf3359a..a1c5b6977f8 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -326,12 +326,13 @@ Return argument is of the form (\"HOLDER\" \"YEAR1\" ... \"YEARN\")" (start (point)) (end (line-end-position))) ;; Cope with multi-line copyright `lines'. Assume the second - ;; line is indented (with the same commenting style). + ;; line is indented at least as much as the original, with the + ;; same commenting style. (save-excursion (beginning-of-line 2) - (let ((str (concat (match-string-no-properties 1) "[ \t]+"))) + (let ((str (match-string-no-properties 1))) (beginning-of-line) - (while (looking-at str) + (while (and (looking-at str) (not (looking-at lm-copyright-prefix))) (setq end (line-end-position)) (beginning-of-line 2)))) ;; Make a single line and parse that. diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index b7a5eb774da..59db00d5f96 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -164,6 +164,9 @@ (put 'defalias 'doc-string-elt 3) (put 'defvaralias 'doc-string-elt 3) (put 'define-category 'doc-string-elt 2) +;; CL +(put 'defconstant 'doc-string-elt 3) +(put 'defparameter 'doc-string-elt 3) (defvar lisp-doc-string-elt-property 'doc-string-elt "The symbol property that holds the docstring position info.") @@ -573,6 +576,13 @@ Lisp font lock syntactic face function." font-lock-string-face)))) font-lock-comment-face)) +(defun lisp-adaptive-fill () + "Return fill prefix found at point. +Value for `adaptive-fill-function'." + ;; Adaptive fill mode gets the fill wrong for a one-line paragraph made of + ;; a single docstring. Let's fix it here. + (if (looking-at "\\s-+\"[^\n\"]+\"\\s-*$") "")) + (defun lisp-mode-variables (&optional lisp-syntax keywords-case-insensitive elisp) "Common initialization routine for lisp modes. @@ -584,16 +594,14 @@ font-lock keywords will not be case sensitive." (set-syntax-table lisp-mode-syntax-table)) (setq-local paragraph-ignore-fill-prefix t) (setq-local fill-paragraph-function 'lisp-fill-paragraph) - ;; Adaptive fill mode gets the fill wrong for a one-line paragraph made of - ;; a single docstring. Let's fix it here. - (setq-local adaptive-fill-function - (lambda () (if (looking-at "\\s-+\"[^\n\"]+\"\\s-*$") ""))) + (setq-local adaptive-fill-function #'lisp-adaptive-fill) ;; Adaptive fill mode gets in the way of auto-fill, ;; and should make no difference for explicit fill ;; because lisp-fill-paragraph should do the job. ;; I believe that newcomment's auto-fill code properly deals with it -stef ;;(set (make-local-variable 'adaptive-fill-mode) nil) (setq-local indent-line-function 'lisp-indent-line) + (setq-local indent-region-function 'lisp-indent-region) (setq-local outline-regexp ";;;\\(;* [^ \t\n]\\|###autoload\\)\\|(") (setq-local outline-level 'lisp-outline-level) (setq-local add-log-current-defun-function #'lisp-current-defun-name) @@ -725,11 +733,7 @@ or to switch back to an existing one." ;; Used in old LispM code. (defalias 'common-lisp-mode 'lisp-mode) -;; This will do unless inf-lisp.el is loaded. -(defun lisp-eval-defun (&optional _and-go) - "Send the current defun to the Lisp process made by \\[run-lisp]." - (interactive) - (error "Process lisp does not exist")) +(autoload 'lisp-eval-defun "inf-lisp" nil t) ;; May still be used by some external Lisp-mode variant. (define-obsolete-function-alias 'lisp-comment-indent @@ -752,14 +756,109 @@ function is `common-lisp-indent-function'." :type 'function :group 'lisp) -(defun lisp-indent-line (&optional _whole-exp) - "Indent current line as Lisp code. -With argument, indent any additional lines of the same expression -rigidly along with this one." - (interactive "P") - (let ((indent (calculate-lisp-indent)) shift-amt - (pos (- (point-max) (point))) - (beg (progn (beginning-of-line) (point)))) +(defun lisp-ppss (&optional pos) + "Return Parse-Partial-Sexp State at POS, defaulting to point. +Like `syntax-ppss' but includes the character address of the last +complete sexp in the innermost containing list at position +2 (counting from 0). This is important for lisp indentation." + (unless pos (setq pos (point))) + (let ((pss (syntax-ppss pos))) + (if (nth 9 pss) + (let ((sexp-start (car (last (nth 9 pss))))) + (parse-partial-sexp sexp-start pos nil nil (syntax-ppss sexp-start))) + pss))) + +(cl-defstruct (lisp-indent-state + (:constructor nil) + (:constructor lisp-indent-initial-state + (&aux (ppss (lisp-ppss)) + (ppss-point (point)) + (stack (make-list (1+ (car ppss)) nil))))) + stack ;; Cached indentation, per depth. + ppss + ppss-point) + +(defun lisp-indent-calc-next (state) + "Move to next line and return calculated indent for it. +STATE is updated by side effect, the first state should be +created by `lisp-indent-initial-state'. This function may move +by more than one line to cross a string literal." + (pcase-let* (((cl-struct lisp-indent-state + (stack indent-stack) ppss ppss-point) + state) + (indent-depth (car ppss)) ; Corresponding to indent-stack. + (depth indent-depth)) + ;; Parse this line so we can learn the state to indent the + ;; next line. + (while (let ((last-sexp (nth 2 ppss))) + (setq ppss (parse-partial-sexp + ppss-point (progn (end-of-line) (point)) + nil nil ppss)) + ;; Preserve last sexp of state (position 2) for + ;; `calculate-lisp-indent', if we're at the same depth. + (if (and (not (nth 2 ppss)) (= depth (car ppss))) + (setf (nth 2 ppss) last-sexp) + (setq last-sexp (nth 2 ppss))) + (setq depth (car ppss)) + ;; Skip over newlines within strings. + (nth 3 ppss)) + (let ((string-start (nth 8 ppss))) + (setq ppss (parse-partial-sexp (point) (point-max) + nil nil ppss 'syntax-table)) + (setf (nth 2 ppss) string-start) ; Finished a complete string. + (setq depth (car ppss))) + (setq ppss-point (point))) + (setq ppss-point (point)) + (let* ((depth-delta (- depth indent-depth))) + (cond ((< depth-delta 0) + (setq indent-stack (nthcdr (- depth-delta) indent-stack))) + ((> depth-delta 0) + (setq indent-stack (nconc (make-list depth-delta nil) + indent-stack))))) + (prog1 + (let (indent) + (cond ((= (forward-line 1) 1) nil) + ((car indent-stack)) + ((integerp (setq indent (calculate-lisp-indent ppss))) + (setf (car indent-stack) indent)) + ((consp indent) ; (COLUMN CONTAINING-SEXP-START) + (car indent)) + ;; This only happens if we're in a string. + (t (error "This shouldn't happen")))) + (setf (lisp-indent-state-stack state) indent-stack) + (setf (lisp-indent-state-ppss-point state) ppss-point) + (setf (lisp-indent-state-ppss state) ppss)))) + +(defun lisp-indent-region (start end) + "Indent region as Lisp code, efficiently." + (save-excursion + (setq end (copy-marker end)) + (goto-char start) + (beginning-of-line) + ;; The default `indent-region-line-by-line' doesn't hold a running + ;; parse state, which forces each indent call to reparse from the + ;; beginning. That has O(n^2) complexity. + (let* ((parse-state (lisp-indent-initial-state)) + (pr (unless (minibufferp) + (make-progress-reporter "Indenting region..." (point) end)))) + (let ((ppss (lisp-indent-state-ppss parse-state))) + (unless (or (and (bolp) (eolp)) (nth 3 ppss)) + (lisp-indent-line (calculate-lisp-indent ppss)))) + (let ((indent nil)) + (while (progn (setq indent (lisp-indent-calc-next parse-state)) + (< (point) end)) + (unless (or (and (bolp) (eolp)) (not indent)) + (lisp-indent-line indent)) + (and pr (progress-reporter-update pr (point))))) + (and pr (progress-reporter-done pr)) + (move-marker end nil)))) + +(defun lisp-indent-line (&optional indent) + "Indent current line as Lisp code." + (interactive) + (let ((pos (- (point-max) (point))) + (indent (progn (beginning-of-line) + (or indent (calculate-lisp-indent (lisp-ppss)))))) (skip-chars-forward " \t") (if (or (null indent) (looking-at "\\s<\\s<\\s<")) ;; Don't alter indentation of a ;;; comment line @@ -771,11 +870,7 @@ rigidly along with this one." ;; as comment lines, not as code. (progn (indent-for-comment) (forward-char -1)) (if (listp indent) (setq indent (car indent))) - (setq shift-amt (- indent (current-column))) - (if (zerop shift-amt) - nil - (delete-region beg (point)) - (indent-to indent))) + (indent-line-to indent)) ;; If initial point was within line's indentation, ;; position after the indentation. Else stay at same point in text. (if (> (- (point-max) pos) (point)) @@ -789,6 +884,10 @@ In usual case returns an integer: the column to indent to. If the value is nil, that means don't change the indentation because the line starts inside a string. +PARSE-START may be a buffer position to start parsing from, or a +parse state as returned by calling `parse-partial-sexp' up to the +beginning of the current line. + The value can also be a list of the form (COLUMN CONTAINING-SEXP-START). This means that following lines at the same level of indentation should not necessarily be indented the same as this line. @@ -802,12 +901,14 @@ is the buffer position of the start of the containing expression." (desired-indent nil) (retry t) calculate-lisp-indent-last-sexp containing-sexp) - (if parse-start - (goto-char parse-start) - (beginning-of-defun)) - ;; Find outermost containing sexp - (while (< (point) indent-point) - (setq state (parse-partial-sexp (point) indent-point 0))) + (cond ((or (markerp parse-start) (integerp parse-start)) + (goto-char parse-start)) + ((null parse-start) (beginning-of-defun)) + (t (setq state parse-start))) + (unless state + ;; Find outermost containing sexp + (while (< (point) indent-point) + (setq state (parse-partial-sexp (point) indent-point 0)))) ;; Find innermost containing sexp (while (and retry state @@ -1077,86 +1178,34 @@ Lisp function does not specify a special indentation." If optional arg ENDPOS is given, indent each line, stopping when ENDPOS is encountered." (interactive) - (let* ((indent-stack (list nil)) - ;; If ENDPOS is non-nil, use beginning of defun as STARTING-POINT. - ;; If ENDPOS is nil, it is safe not to scan before point - ;; since every line we indent is more deeply nested than point is. - (starting-point (save-excursion (if endpos (beginning-of-defun)) - (point))) - ;; Use `syntax-ppss' to get initial state so we don't get - ;; confused by starting inside a string. We don't use - ;; `syntax-ppss' in the loop, because this is measurably - ;; slower when we're called on a long list. - (state (syntax-ppss)) - (init-depth (car state)) - (next-depth init-depth) - (last-depth init-depth) - (last-syntax-point (point)) - (real-endpos endpos)) - (unless endpos - ;; Get error now if we don't have a complete sexp after point. - (save-excursion (forward-sexp 1) - ;; We need a marker because we modify the buffer - ;; text preceding endpos. - (setq endpos (point-marker)))) + (let* ((parse-state (lisp-indent-initial-state))) + ;; We need a marker because we modify the buffer + ;; text preceding endpos. + (setq endpos (copy-marker + (if endpos endpos + ;; Get error now if we don't have a complete sexp + ;; after point. + (save-excursion (forward-sexp 1) (point))))) (save-excursion - (while (< (point) endpos) - ;; Parse this line so we can learn the state to indent the - ;; next line. - (while (progn - (setq state (parse-partial-sexp - last-syntax-point (progn (end-of-line) (point)) - nil nil state)) - ;; Skip over newlines within strings. - (nth 3 state)) - (setq state (parse-partial-sexp (point) (point-max) - nil nil state 'syntax-table)) - (setq last-syntax-point (point))) - (setq next-depth (car state)) - ;; If the line contains a comment indent it now with - ;; `indent-for-comment'. - (when (nth 4 state) - (indent-for-comment) - (end-of-line)) - (setq last-syntax-point (point)) - (when (< next-depth init-depth) - (setq indent-stack (nconc indent-stack - (make-list (- init-depth next-depth) nil)) - last-depth (- last-depth next-depth) - next-depth init-depth)) - (forward-line 1) - (when (and (not real-endpos) (<= next-depth init-depth)) - (goto-char endpos)) - (when (< (point) endpos) - (let ((depth-delta (- next-depth last-depth))) - (cond ((< depth-delta 0) - (setq indent-stack (nthcdr (- depth-delta) indent-stack))) - ((> depth-delta 0) - (setq indent-stack (nconc (make-list depth-delta nil) - indent-stack)))) - (setq last-depth next-depth)) - ;; Now indent the next line according - ;; to what we learned from parsing the previous one. - (skip-chars-forward " \t") - ;; But not if the line is blank, or just a comment (we - ;; already called `indent-for-comment' above). - (unless (or (eolp) (eq (char-syntax (char-after)) ?<)) - (let ((this-indent (car indent-stack))) - (when (listp this-indent) - (let ((val (calculate-lisp-indent - (or (car this-indent) starting-point)))) - (setq - this-indent - (cond ((integerp val) - (setf (car indent-stack) val)) - ((consp val) ; (COLUMN CONTAINING-SEXP-START) - (setf (car indent-stack) (cdr val)) - (car val)) - ;; `calculate-lisp-indent' only returns nil - ;; when we're in a string, but this won't - ;; happen because we skip strings above. - (t (error "This shouldn't happen!")))))) - (indent-line-to this-indent)))))))) + (while (let ((indent (lisp-indent-calc-next parse-state)) + (ppss (lisp-indent-state-ppss parse-state))) + ;; If the line contains a comment indent it now with + ;; `indent-for-comment'. + (when (and (nth 4 ppss) (<= (nth 8 ppss) endpos)) + (save-excursion + (goto-char (lisp-indent-state-ppss-point parse-state)) + (indent-for-comment) + (setf (lisp-indent-state-ppss-point parse-state) + (line-end-position)))) + (when (< (point) endpos) + ;; Indent the next line, unless it's blank, or just a + ;; comment (we will `indent-for-comment' the latter). + (skip-chars-forward " \t") + (unless (or (eolp) (not indent) + (eq (char-syntax (char-after)) ?<)) + (indent-line-to indent)) + t)))) + (move-marker endpos nil))) (defun indent-pp-sexp (&optional arg) "Indent each line of the list starting just after point, or prettyprint it. diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 0172e3af261..0c1fe42fedb 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -398,6 +398,42 @@ is called as a function to find the defun's beginning." (goto-char (if arg-+ve floor ceiling)) nil)))))))) +(defun beginning-of-defun--in-emptyish-line-p () + "Return non-nil if the point is in an \"emptyish\" line. +This means a line that consists entirely of comments and/or +whitespace." +;; See http://lists.gnu.org/archive/html/help-gnu-emacs/2016-08/msg00141.html + (save-excursion + (forward-line 0) + (< (line-end-position) + (let ((ppss (syntax-ppss))) + (when (nth 4 ppss) + (goto-char (nth 8 ppss))) + (forward-comment (point-max)) + (point))))) + +(defun beginning-of-defun-comments (&optional arg) + "Move to the beginning of ARGth defun, including comments." + (interactive "^p") + (unless arg (setq arg 1)) + (beginning-of-defun arg) + (let (first-line-p) + (while (let ((ppss (progn (setq first-line-p (= (forward-line -1) -1)) + (syntax-ppss (line-end-position))))) + (while (and (nth 4 ppss) ; If eol is in a line-spanning comment, + (< (nth 8 ppss) (line-beginning-position))) + (goto-char (nth 8 ppss)) ; skip to comment start. + (setq ppss (syntax-ppss (line-end-position)))) + (and (not first-line-p) + (progn (skip-syntax-backward + "-" (line-beginning-position)) + (not (bolp))) ; Check for blank line. + (progn (parse-partial-sexp + (line-beginning-position) (line-end-position) + nil t (syntax-ppss (line-beginning-position))) + (eolp))))) ; Check for non-comment text. + (forward-line (if first-line-p 0 1)))) + (defvar end-of-defun-function (lambda () (forward-sexp 1)) "Function for `end-of-defun' to call. @@ -478,48 +514,72 @@ is called as a function to find the defun's end." (funcall end-of-defun-function) (funcall skip))))) -(defun mark-defun (&optional allow-extend) +(defun mark-defun (&optional arg) "Put mark at end of this defun, point at beginning. The defun marked is the one that contains point or follows point. +With positive ARG, mark this and that many next defuns; with negative +ARG, change the direction of marking. -Interactively, if this command is repeated -or (in Transient Mark mode) if the mark is active, -it marks the next defun after the ones already marked." +If the mark is active, it marks the next or previous defun(s) after +the one(s) already marked." (interactive "p") - (cond ((and allow-extend - (or (and (eq last-command this-command) (mark t)) - (and transient-mark-mode mark-active))) - (set-mark - (save-excursion - (goto-char (mark)) - (end-of-defun) - (point)))) - (t - (let ((opoint (point)) - beg end) - (push-mark opoint) - ;; Try first in this order for the sake of languages with nested - ;; functions where several can end at the same place as with - ;; the offside rule, e.g. Python. - (beginning-of-defun) - (setq beg (point)) - (end-of-defun) - (setq end (point)) - (while (looking-at "^\n") - (forward-line 1)) - (if (> (point) opoint) - (progn - ;; We got the right defun. - (push-mark beg nil t) - (goto-char end) - (exchange-point-and-mark)) - ;; beginning-of-defun moved back one defun - ;; so we got the wrong one. - (goto-char opoint) - (end-of-defun) - (push-mark (point) nil t) - (beginning-of-defun)) - (re-search-backward "^\n" (- (point) 1) t))))) + (setq arg (or arg 1)) + ;; There is no `mark-defun-back' function - see + ;; https://lists.gnu.org/archive/html/bug-gnu-emacs/2016-11/msg00079.html + ;; for explanation + (when (eq last-command 'mark-defun-back) + (setq arg (- arg))) + (when (< arg 0) + (setq this-command 'mark-defun-back)) + (cond ((use-region-p) + (if (>= arg 0) + (set-mark + (save-excursion + (goto-char (mark)) + ;; change the dotimes below to (end-of-defun arg) once bug #24427 is fixed + (dotimes (_ignore arg) + (end-of-defun)) + (point))) + (beginning-of-defun-comments (- arg)))) + (t + (let ((opoint (point)) + beg end) + (push-mark opoint) + ;; Try first in this order for the sake of languages with nested + ;; functions where several can end at the same place as with the + ;; offside rule, e.g. Python. + (beginning-of-defun-comments) + (setq beg (point)) + (end-of-defun) + (setq end (point)) + (when (or (and (<= (point) opoint) + (> arg 0)) + (= beg (point-min))) ; we were before the first defun! + ;; beginning-of-defun moved back one defun so we got the wrong + ;; one. If ARG < 0, however, we actually want to go back. + (goto-char opoint) + (end-of-defun) + (setq end (point)) + (beginning-of-defun-comments) + (setq beg (point))) + (goto-char beg) + (cond ((> arg 0) + ;; change the dotimes below to (end-of-defun arg) once bug #24427 is fixed + (dotimes (_ignore arg) + (end-of-defun)) + (setq end (point)) + (push-mark end nil t) + (goto-char beg)) + (t + (goto-char beg) + (unless (= arg -1) ; beginning-of-defun behaves + ; strange with zero arg - see + ; https://lists.gnu.org/archive/html/bug-gnu-emacs/2017-02/msg00196.html + (beginning-of-defun (1- (- arg)))) + (push-mark end nil t)))))) + (skip-chars-backward "[:space:]\n") + (unless (bobp) + (forward-line 1))) (defvar narrow-to-defun-include-comments nil "If non-nil, `narrow-to-defun' will also show comments preceding the defun.") diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 8d5fac96cfb..4245294457f 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -194,14 +194,16 @@ If VERSION is nil, the package is not loaded (it is \"disabled\")." :risky t :version "24.1") -(defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/")) +(defcustom package-archives `(("gnu" . + ,(format "http%s://elpa.gnu.org/packages/" + (if (gnutls-available-p) "s" "")))) "An alist of archives from which to fetch. The default value points to the GNU Emacs package repository. Each element has the form (ID . LOCATION). ID is an archive name, as a string. LOCATION specifies the base location for the archive. - If it starts with \"http:\", it is treated as a HTTP URL; + If it starts with \"http(s):\", it is treated as an HTTP(S) URL; otherwise it should be an absolute directory name. (Other types of URL are currently not supported.) @@ -210,7 +212,7 @@ a package can run arbitrary code." :type '(alist :key-type (string :tag "Archive name") :value-type (string :tag "URL or directory name")) :risky t - :version "24.1") + :version "26.1") ; gnutls test (defcustom package-menu-hide-low-priority 'archive "If non-nil, hide low priority packages from the packages menu. @@ -305,6 +307,23 @@ contrast, `package-user-dir' contains packages for personal use." (declare-function epg-find-configuration "epg-config" (protocol &optional no-cache program-alist)) +(defcustom package-gnupghome-dir (expand-file-name "gnupg" package-user-dir) + "Directory containing GnuPG keyring or nil. +This variable specifies the GnuPG home directory used by package. +That directory is passed via the option \"--homedir\" to GnuPG. +If nil, do not use the option \"--homedir\", but stick with GnuPG's +default directory." + :type `(choice + (const + :tag "Default Emacs package management GnuPG home directory" + ,(expand-file-name "gnupg" package-user-dir)) + (const + :tag "Default GnuPG directory (GnuPG option --homedir not used)" + nil) + (directory :tag "A specific GnuPG --homedir")) + :risky t + :version "26.1") + (defcustom package-check-signature (if (and (require 'epg-config) (epg-find-configuration 'OpenPGP)) @@ -619,7 +638,7 @@ Return the max version (as a string) if the package is held at a lower version." (t (error "Invalid element in `package-load-list'"))))) (defun package-built-in-p (package &optional min-version) - "Return true if PACKAGE is built-in to Emacs. + "Return non-nil if PACKAGE is built-in to Emacs. Optional arg MIN-VERSION, if non-nil, should be a version list specifying the minimum acceptable version." (if (package-desc-p package) ;; was built-in and then was converted @@ -886,25 +905,13 @@ untar into a directory named DIR; otherwise, signal an error." nil pkg-file nil 'silent)))) ;;;; Autoload -;; From Emacs 22, but changed so it adds to load-path. +(declare-function autoload-rubric "autoload" (file &optional type feature)) + (defun package-autoload-ensure-default-file (file) "Make sure that the autoload file FILE exists and if not create it." (unless (file-exists-p file) - (write-region - (concat ";;; " (file-name-nondirectory file) - " --- automatically extracted autoloads\n" - ";;\n" - ";;; Code:\n" - ;; `load-path' should contain only directory names - "(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))\n" - "\n;; Local Variables:\n" - ";; version-control: never\n" - ";; no-byte-compile: t\n" - ";; no-update-autoloads: t\n" - ";; End:\n" - ";;; " (file-name-nondirectory file) - " ends here\n") - nil file nil 'silent)) + (require 'autoload) + (write-region (autoload-rubric file "package" nil) nil file nil 'silent)) file) (defvar generated-autoload-file) @@ -1207,9 +1214,9 @@ errors signaled by ERROR-FORM or by BODY). "Check signature CONTENT against STRING. SIG-FILE is the name of the signature file, used when signaling errors." - (let* ((context (epg-make-context 'OpenPGP)) - (homedir (expand-file-name "gnupg" package-user-dir))) - (setf (epg-context-home-directory context) homedir) + (let ((context (epg-make-context 'OpenPGP))) + (when package-gnupghome-dir + (setf (epg-context-home-directory context) package-gnupghome-dir)) (condition-case error (epg-verify-string context content string) (error (package--display-verify-error context sig-file) @@ -1236,7 +1243,7 @@ errors." "Check signature of the current buffer. Download the signature file from LOCATION by appending \".sig\" to FILE. -GnuPG keyring is located under \"gnupg\" in `package-user-dir'. +GnuPG keyring location depends on `package-gnupghome-dir'. STRING is the string to verify, it defaults to `buffer-string'. If ASYNC is non-nil, the download of the signature file is done asynchronously. @@ -1476,11 +1483,11 @@ taken care of by `package-initialize'." "Import keys from FILE." (interactive "fFile: ") (setq file (expand-file-name file)) - (let ((context (epg-make-context 'OpenPGP)) - (homedir (expand-file-name "gnupg" package-user-dir))) - (with-file-modes 448 - (make-directory homedir t)) - (setf (epg-context-home-directory context) homedir) + (let ((context (epg-make-context 'OpenPGP))) + (when package-gnupghome-dir + (with-file-modes 448 + (make-directory package-gnupghome-dir t)) + (setf (epg-context-home-directory context) package-gnupghome-dir)) (message "Importing %s..." (file-name-nondirectory file)) (epg-import-keys-from-file context file) (message "Importing %s...done" (file-name-nondirectory file)))) @@ -1522,7 +1529,7 @@ similar to an entry in `package-alist'. Save the cached copy to (when (listp (read-from-string content)) (make-directory dir t) (if (or (not package-check-signature) - (member archive package-unsigned-archives)) + (member name package-unsigned-archives)) ;; If we don't care about the signature, save the file and ;; we're done. (progn (write-region content nil local-file nil 'silent) @@ -1769,7 +1776,7 @@ destructively set to nil in ONLY." That is, any element of the returned list is guaranteed to not directly depend on any elements that come before it. -PACKAGE-LIST is a list of package-desc objects. +PACKAGE-LIST is a list of `package-desc' objects. Indirect dependencies are guaranteed to be returned in order only if all the in-between dependencies are also in PACKAGE-LIST." (let ((alist (mapcar (lambda (p) (cons (package-desc-name p) p)) package-list)) @@ -1838,11 +1845,11 @@ if all the in-between dependencies are also in PACKAGE-LIST." (setf (package-desc-signed (car pkg-descs)) t)))))))))) (defun package-installed-p (package &optional min-version) - "Return true if PACKAGE, of MIN-VERSION or newer, is installed. + "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 should be a version list. -If PACKAGE is a package-desc object, MIN-VERSION is ignored." +If PACKAGE is a `package-desc' object, MIN-VERSION is ignored." (unless package--initialized (error "package.el is not yet initialized!")) (if (package-desc-p package) (let ((dir (package-desc-dir package))) @@ -1858,7 +1865,7 @@ If PACKAGE is a package-desc object, MIN-VERSION is ignored." (defun package-download-transaction (packages) "Download and install all the packages in PACKAGES. -PACKAGES should be a list of package-desc. +PACKAGES should be a list of `package-desc'. This function assumes that all package requirements in PACKAGES are satisfied, i.e. that PACKAGES is computed using `package-compute-transaction'." @@ -1925,13 +1932,13 @@ add a call to it along with some explanatory comments." ;;;###autoload (defun package-install (pkg &optional dont-select) "Install the package PKG. -PKG can be a package-desc or a symbol naming one of the available packages +PKG can be a `package-desc' or a symbol naming one of the available packages in an archive in `package-archives'. Interactively, prompt for its name. If called interactively or if DONT-SELECT nil, add PKG to `package-selected-packages'. -If PKG is a package-desc and it is already installed, don't try +If PKG is a `package-desc' and it is already installed, don't try to install it but still mark it as selected." (interactive (progn @@ -2060,7 +2067,7 @@ If some packages are not installed propose to install them." ;;; Package Deletion (defun package--newest-p (pkg) - "Return t if PKG is the newest package with its name." + "Return non-nil if PKG is the newest package with its name." (equal (cadr (assq (package-desc-name pkg) package-alist)) pkg)) @@ -2120,11 +2127,16 @@ If NOSAVE is non-nil, the package is not removed from (package-desc-name pkg-used-elsewhere-by))) (t (add-hook 'post-command-hook #'package-menu--post-refresh) - (delete-directory dir t t) - ;; Remove NAME-VERSION.signed file. - (let ((signed-file (concat dir ".signed"))) - (if (file-exists-p signed-file) - (delete-file signed-file))) + (delete-directory dir t) + ;; Remove NAME-VERSION.signed and NAME-readme.txt files. + (dolist (suffix '(".signed" "readme.txt")) + (let* ((version (package-version-join (package-desc-version pkg-desc))) + (file (concat (if (string= suffix ".signed") + dir + (substring dir 0 (- (length version)))) + suffix))) + (when (file-exists-p file) + (delete-file file)))) ;; Update package-alist. (let ((pkgs (assq name package-alist))) (delete pkg-desc pkgs) @@ -2135,7 +2147,7 @@ If NOSAVE is non-nil, the package is not removed from ;;;###autoload (defun package-reinstall (pkg) "Reinstall package PKG. -PKG should be either a symbol, the package name, or a package-desc +PKG should be either a symbol, the package name, or a `package-desc' object." (interactive (list (intern (completing-read "Reinstall package: " @@ -2352,6 +2364,12 @@ Otherwise no newline is inserted." (package-desc-name pkg)))) (insert "\n"))) (when homepage + ;; Prefer https for the homepage of packages on gnu.org. + (if (string-match-p "^http://\\(elpa\\|www\\)\\.gnu\\.org/" homepage) + (let ((gnu (cdr (assoc "gnu" package-archives)))) + (and gnu (string-match-p "^https" gnu) + (setq homepage + (replace-regexp-in-string "^http" "https" homepage))))) (package--print-help-section "Homepage") (help-insert-xref-button homepage 'help-url homepage) (insert "\n")) @@ -2554,7 +2572,7 @@ package PKG-DESC, add one. The alist is keyed with PKG-DESC." (defun package--incompatible-p (pkg &optional shallow) "Return non-nil if PKG has no chance of being installable. -PKG is a package-desc object. +PKG is a `package-desc' object. If SHALLOW is non-nil, this only checks if PKG depends on a higher `emacs-version' than the one being used. Otherwise, also @@ -2638,7 +2656,7 @@ Installed obsolete packages are always displayed.") (defun package--remove-hidden (pkg-list) "Filter PKG-LIST according to `package-archive-priorities'. -PKG-LIST must be a list of package-desc objects, all with the +PKG-LIST must be a list of `package-desc' objects, all with the same name, sorted by decreasing `package-desc-priority-version'. Return a list of packages tied for the highest priority according to their archives." @@ -2879,7 +2897,7 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." :version "25.1") (defface package-status-incompat - '((t :inherit font-lock-comment-face)) + '((t :inherit error)) "Face used on the status and version of incompat packages." :version "25.1") @@ -2892,7 +2910,7 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." ;;; Package menu printing (defun package-menu--print-info-simple (pkg) "Return a package entry suitable for `tabulated-list-entries'. -PKG is a package-desc object. +PKG is a `package-desc' object. Return (PKG-DESC [NAME VERSION STATUS DOC])." (let* ((status (package-desc-status pkg)) (face (pcase status diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index fc5474ecc43..4a06ab25d3e 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -503,24 +503,30 @@ MATCH is the pattern that needs to be matched, of the form: (symbolp . vectorp) (symbolp . stringp) (symbolp . byte-code-function-p) + (symbolp . recordp) (integerp . consp) (integerp . arrayp) (integerp . vectorp) (integerp . stringp) (integerp . byte-code-function-p) + (integerp . recordp) (numberp . consp) (numberp . arrayp) (numberp . vectorp) (numberp . stringp) (numberp . byte-code-function-p) + (numberp . recordp) (consp . arrayp) (consp . atom) (consp . vectorp) (consp . stringp) (consp . byte-code-function-p) + (consp . recordp) (arrayp . byte-code-function-p) (vectorp . byte-code-function-p) + (vectorp . recordp) (stringp . vectorp) + (stringp . recordp) (stringp . byte-code-function-p))) (defun pcase--mutually-exclusive-p (pred1 pred2) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 10de2484798..23e444fe241 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -4,7 +4,7 @@ ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Keywords: sequences -;; Version: 2.19 +;; Version: 2.20 ;; Package: seq ;; Maintainer: emacs-devel@gnu.org @@ -355,6 +355,12 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." e)) sequence)) +(cl-defgeneric seq-set-equal-p (sequence1 sequence2 &optional testfn) + "Return non-nil if SEQUENCE1 and SEQUENCE2 contain the same elements, regardless of order. +Equality is defined by TESTFN if non-nil or by `equal' if nil." + (and (seq-every-p (lambda (item1) (seq-contains sequence2 item1 testfn)) sequence1) + (seq-every-p (lambda (item2) (seq-contains sequence1 item2 testfn)) sequence2))) + (cl-defgeneric seq-position (sequence elt &optional testfn) "Return the index of the first element in SEQUENCE that is equal to ELT. Equality is defined by TESTFN if non-nil or by `equal' if nil." diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 4d02b751afe..7baccbc7524 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -123,6 +123,8 @@ (eval-when-compile (require 'cl-lib)) +(require 'prog-mode) + (defgroup smie nil "Simple Minded Indentation Engine." :group 'languages) @@ -1455,7 +1457,7 @@ in order to figure out the indentation of some other (further down) point." ;; Start the file at column 0. (save-excursion (forward-comment (- (point))) - (if (bobp) 0))) + (if (bobp) (prog-first-column)))) (defun smie-indent-close () ;; Align close paren with opening paren. diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 1d729f94092..849ac19d6a5 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -30,9 +30,11 @@ ;; Do not document these functions in the lispref. ;; http://lists.gnu.org/archive/html/emacs-devel/2014-01/msg01006.html +;; NB If you want to use this library, it's almost always correct to use: +;; (eval-when-compile (require 'subr-x)) + ;;; Code: -(require 'pcase) (eval-when-compile (require 'cl-lib)) @@ -176,21 +178,27 @@ VARLIST can just be a plain tuple. (define-obsolete-function-alias 'string-reverse 'reverse "25.1") -(defsubst string-trim-left (string) - "Remove leading whitespace from STRING." - (if (string-match "\\`[ \t\n\r]+" string) +(defsubst string-trim-left (string &optional regexp) + "Trim STRING of leading string matching REGEXP. + +REGEXP defaults to \"[ \\t\\n\\r]+\"." + (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+")"\\)") string) (replace-match "" t t string) string)) -(defsubst string-trim-right (string) - "Remove trailing whitespace from STRING." - (if (string-match "[ \t\n\r]+\\'" string) +(defsubst string-trim-right (string &optional regexp) + "Trim STRING of trailing string matching REGEXP. + +REGEXP defaults to \"[ \\t\\n\\r]+\"." + (if (string-match (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'") string) (replace-match "" t t string) string)) -(defsubst string-trim (string) - "Remove leading and trailing whitespace from STRING." - (string-trim-left (string-trim-right string))) +(defsubst string-trim (string &optional trim-left trim-right) + "Trim STRING of leading and trailing strings matching TRIM-LEFT and TRIM-RIGHT. + +TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"." + (string-trim-left (string-trim-right string trim-right) trim-left)) (defsubst string-blank-p (string) "Check whether STRING is either empty or only whitespace." |