diff options
| author | Kenichi Handa <handa@gnu.org> | 2012-11-23 23:36:24 +0900 |
|---|---|---|
| committer | Kenichi Handa <handa@gnu.org> | 2012-11-23 23:36:24 +0900 |
| commit | 2aaec2d9be5cec44ea3b59cba476fd3e091f2fc9 (patch) | |
| tree | 3711b97807201b7eeaa066003b1c3a4ce929e5bb /lisp | |
| parent | e1d276cbf9e18f13101328f56bed1a1c0a66e63a (diff) | |
| parent | e7d0e5ee247a155a268ffbf80bedbe25e15b5032 (diff) | |
| download | emacs-2aaec2d9be5cec44ea3b59cba476fd3e091f2fc9.tar.gz | |
Diffstat (limited to 'lisp')
54 files changed, 1441 insertions, 940 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ca65e431964..09f42233f96 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,166 @@ +2012-11-23 Chong Yidong <cyd@gnu.org> + + * find-cmd.el (find-constituents): Add executable, ipath, + readable, samefile, writable, daystart, regextype (Bug#12856). + +2012-11-23 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/ert.el, emacs-lisp/ert-x.el: Use cl-lib and lexical-binding. + +2012-11-22 Paul Eggert <eggert@cs.ucla.edu> + + * calc/calc.el (calc-gregorian-switch): Move to after calc-refresh + definition. This fixes a bootstrap failure. + (calc-gregorian-switch): In menu, put dates before regions. + This is easier to follow, lines up better in the menu, and lets us + coalesce regions that switch at the same time. Give country + names, not "Vatican", as that's better for non-expert users. + Use names that are stable between the date of switch and now, e.g., + Bohemia and Moravia (which existed then and now) and not + Czechoslovakia (which didn't exist then and doesn't exist now). + What is now the U.S. mostly did not switch at the same time as + Britain, so omit the U.S. Correct spelling of "Britain". + Catholic Switzerland was too much of a mess, so omit it. + +2012-11-22 Jay Belanger <jay.p.belanger@gmail.com> + + * calc/calc.el (calc-gregorian-switch): Refresh the Calc buffer + after the variable is changed. + +2012-11-21 Daniel Colascione <dancol@dancol.org> + + * progmodes/sql.el (sql-mode-font-lock-object-name): Support IF NOT EXISTS + in SQL declarations for font-lock. + (sql-imenu-generic-expression): Teach imenu about IF NOT EXISTS. + +2012-11-21 Glenn Morris <rgm@gnu.org> + + * faces.el (face-underline-p, face-inverse-video-p, face-bold-p) + (face-italic-p): Add optional argument "inherit". + + * faces.el (set-face-inverse-video, set-face-bold, set-face-italic): + Remove -p suffix from names, for consistency with other set-face-*. + (set-face-inverse-video): Fix interactive spec. + * play/gamegrid.el (gamegrid-make-mono-tty-face): + * textmodes/table.el (table--update-cell-face): + Use set-face-inverse-video rather than now obsolete alias. + +2012-11-21 Eli Zaretskii <eliz@gnu.org> + + * simple.el (line-move): Don't call line-move-partial if + scroll-conservatively is in effect. (Bug#12927) + +2012-11-21 Stefan Monnier <monnier@iro.umontreal.ca> + + * eshell/em-cmpl.el (eshell-pcomplete): Refine fix for bug#12838: + Fallback on completion-at-point rather than + pcomplete-expand-and-complete, and only if pcomplete actually failed. + (eshell-cmpl-initialize): Setup completion-at-point. + + * pcomplete.el (pcomplete--entries): Obey pcomplete-ignore-case. + + * emacs-lisp/ert.el (ert--expand-should-1): Adapt to cl-lib. + +2012-11-21 Michael Albinus <michael.albinus@gmx.de> + + * net/tramp-sh.el (tramp-do-copy-or-rename-file): If both files + are remote, check out-of-band property for both. + +2012-11-21 Stefan Monnier <monnier@iro.umontreal.ca> + + * window.el (switch-to-buffer): Re-add the warning that was lost in the + code rewrite. + +2012-11-21 Paul Eggert <eggert@cs.ucla.edu> + + More minor time fixes. + * calendar/time-date.el: Commentary fix. + * net/tramp-sh.el (tramp-do-file-attributes-with-ls): Undo last change; + too much other code depends on (0 0) time stamps. + * net/tramp.el (tramp-time-less-p, tramp-time-subtract): + Add a couple of FIXME comments. + + Minor cleanup for times as lists of four integers. + * files.el (dir-locals-directory-cache): + * ps-bdf.el (bdf-file-mod-time, bdf-read-font-info): + Doc fixes. + * net/tramp-sh.el (tramp-do-file-attributes-with-ls): + * ps-bdf.el (bdf-file-newer-than-time): + Process four-integers time stamps, not two. Doc fixes. + +2012-11-20 Stefan Monnier <monnier@iro.umontreal.ca> + + * uniquify.el (uniquify-managed): Use defvar-local. + (rename-buffer, create-file-buffer): Advise with advice-add. + (uniquify-unload-function): Unadvise accordingly. + + * emacs-lisp/trace.el: Rewrite, use nadvice and lexical-binding. + (trace-buffer): Don't purecopy. + (trace-entry-message, trace-exit-message): Add `context' arg. + (trace--timer): New var. + (trace-make-advice): Adjust for use in nadvice. + Add `context' argument. Delay `display-buffer' via a timer. + (trace-function-internal): Use advice-add. + (trace--read-args): New function. + (trace-function-foreground, trace-function-background): Use it. + (trace-function): Rename to trace-function-foreground and redefine as + an alias to that new name. + (untrace-function, untrace-all): Adjust to the use of nadvice. + + * emacs-lisp/bytecomp.el (byte-compile): Fix handling of closures. + + * emacs-lisp/byte-run.el (defun-declarations-alist): Fix last change. + + * subr.el (called-interactively-p-functions): New var. + (internal--called-interactively-p--get-frame): New macro. + (called-interactively-p, interactive-p): Rewrite in Lisp. + * emacs-lisp/nadvice.el (advice--called-interactively-skip): New fun. + (called-interactively-p-functions): Use it. + * emacs-lisp/edebug.el (edebug--called-interactively-skip): New fun. + (called-interactively-p-functions): Use it. + * allout.el (allout-called-interactively-p): Don't assume + called-interactively-p is a subr. + +2012-11-20 Glenn Morris <rgm@gnu.org> + + * profiler.el (profiler-report-mode-map): Add a menu. + No need to bind `q' because we derive from special-mode. + (profiler-report-find-entry): Handle calls from the menu-bar. + +2012-11-19 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/byte-run.el (defun-declarations-alist): + Allow a compiler-macro to be a lambda expression. + + * progmodes/python.el: Use cl-lib. Move var declarations outside of + eval-when-compile. + (python-syntax-context): Add compiler-macro. + (python-font-lock-keywords): Simplify with De Morgan. + + * vc/diff-mode.el (diff-hunk): Don't make useless timers. + + * files.el (load-file): Require match in minibuffer selection, as was + the case in Emacs-20 before we changed the spec to allow .elc files + (bug#12935). + + * json.el: Don't require cl since we don't use it. + * color.el: Don't require cl. + (color-complement): `caddr' -> `nth 2'. + + * calendar/time-date.el (time-to-seconds): De-obsolete. + +2012-11-19 Jay Belanger <jay.p.belanger@gmail.com> + + * calc/calc-forms.el (math-leap-year-p): Fix formula for negative + year numbers. + (math-date-to-julian-dt): Adjust the initial approximation for the + year to deal with the new definition of the DATE. + +2012-11-19 Daniel Colascione <dancol@dancol.org> + + * term/w32-win.el (cygwin-convert-path-from-windows): + Accomodate rename of cygwin_convert_path* to cygwin_convert_file_name*. + 2012-11-18 Chong Yidong <cyd@gnu.org> * filecache.el (file-cache--read-list): New function. @@ -47,8 +210,10 @@ 2012-11-17 Paul Eggert <eggert@cs.ucla.edu> + Calc by default uses the Gregorian calendar for all dates (Bug#12633). + It also uses January 1, 1 AD as its day number 1. * calc/calc-forms.el (math-julian-date-beginning) - (math-julian-date-beginning-int): Implement [new date numbering]. + (math-julian-date-beginning-int): Implement this. 2012-11-17 Juanma Barranquero <lekktu@gmail.com> diff --git a/lisp/allout.el b/lisp/allout.el index 04de853ebe0..e93aefd12cc 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -1657,10 +1657,9 @@ and the place for the cursor after the decryption is done." (defmacro allout-called-interactively-p () "A version of `called-interactively-p' independent of Emacs version." ;; ... to ease maintenance of allout without betraying deprecation. - (if (equal (subr-arity (symbol-function 'called-interactively-p)) - '(0 . 0)) - '(called-interactively-p) - '(called-interactively-p 'interactive))) + (if (ignore-errors (called-interactively-p 'interactive) t) + '(called-interactively-p 'interactive) + '(called-interactively-p))) ;;;_ = allout-inhibit-aberrance-doublecheck nil ;; In some exceptional moments, disparate topic depths need to be allowed ;; momentarily, eg when one topic is being yanked into another and they're diff --git a/lisp/calc/README b/lisp/calc/README index 25d1a5e9b58..638b482a60a 100644 --- a/lisp/calc/README +++ b/lisp/calc/README @@ -70,11 +70,18 @@ opinions. Summary of changes to "Calc" ------- -- ------- -- ---- +Emacs 24.4 + +* The date forms use the Gregorian calendar for all dates. + (Previously they were a combination of Julian and Gregorian + dates.) This can be configured with the customizable variable + `calc-gregorian-switch'. + Emacs 24.3 -Algebraic simplification mode is now the default. -To restrict to the limited simplifications given by the former -default simplification mode, use `m I'. +* Algebraic simplification mode is now the default. + To restrict to the limited simplifications given by the former + default simplification mode, use `m I'. Emacs 24.1 diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el index 709250f9ba9..98b22550f75 100644 --- a/lisp/calc/calc-forms.el +++ b/lisp/calc/calc-forms.el @@ -371,9 +371,10 @@ ;;; These versions are rewritten to use arbitrary-size integers. ;;; A numerical date is the number of days since midnight on -;;; the morning of December 31, 1 B.C. Emacs's calendar refers to such -;;; a date as an absolute date, some function names also use that -;;; terminology. If the date is a non-integer, it represents a specific date and time. +;;; the morning of December 31, 1 B.C. (Gregorian) or January 2, 1 A.D. (Julian). +;;; Emacs's calendar refers to such a date as an absolute date, some Calc function +;;; names also use that terminology. If the date is a non-integer, it represents +;;; a specific date and time. ;;; A "dt" is a list of the form, (year month day), corresponding to ;;; an integer code, or (year month day hour minute second), corresponding ;;; to a non-integer code. @@ -408,8 +409,8 @@ DATE is the number of days since December 31, -1 in the Gregorian calendar." (let* ((month 1) day (year (math-quotient (math-add date (if (Math-lessp date 711859) - 365 ; for speed, we take - -108)) ; >1950 as a special case + 367 ; for speed, we take + -106)) ; >1950 as a special case (if (math-negp date) 366 365))) ; this result may be an overestimate temp) @@ -494,6 +495,8 @@ Gregorian calendar." (if (math-negp year) (= (math-imod (math-neg year) 4) 1) (= (math-imod year 4) 0)) + (if (math-negp year) + (setq year (math-sub -1 year))) (setq year (math-imod year 400)) (or (and (= (% year 4) 0) (/= (% year 100) 0)) (= year 0)))) diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index aeca45ebf26..58eabf9bcec 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -466,50 +466,6 @@ to be identified as that note." (defvar math-format-date-cache) ; calc-forms.el -;; Dates that are built-in options for `calc-gregorian-switch' should be -;; (YEAR MONTH DAY math-date-from-gregorian-dt(YEAR MONTH DAY)) for speed. -(defcustom calc-gregorian-switch nil - "The first day the Gregorian calendar is used by Calc's date forms. -This is `nil' (the default) if the Gregorian calendar is the only one used. -Otherwise, it should be a list `(YEAR MONTH DAY)' when Calc begins to use -the Gregorian calendar; Calc will use the Julian calendar for earlier dates. -The dates in which different regions of the world began to use the -Gregorian calendar vary quite a bit, even within a single country. -If you want Calc's date forms to switch between the Julian and -Gregorian calendar, you can specify the date or choose from several -common choices. Some of these choices should be taken with a grain -of salt; for example different parts of France changed calendars at -different times, and Sweden's change to the Gregorian calendar was -complicated. Also, the boundaries of the countries were different at -the times of the calendar changes than they are now. -The Vatican decided that the Gregorian calendar should take effect -on 15 October 1582 (Gregorian), and many Catholic countries made -the change then. Great Britian and its colonies had the Gregorian -calendar take effect on 14 September 1752 (Gregorian); this includes -the United States." - :group 'calc - :version "24.4" - :type '(choice (const :tag "Always use the Gregorian calendar" nil) - (const :tag "Great Britian and the US (1752 9 14)" (1752 9 14 639797)) - (const :tag "Vatican (1582 10 15)" (1582 10 15 577736)) - (const :tag "Czechoslovakia (1584 1 17)" (1584 1 17 578195)) - (const :tag "Denmark (1700 3 1)" (1700 3 1 620607)) - (const :tag "France (1582 12 20)" (1582 12 20 577802)) - (const :tag "Hungary (1587 11 1)" (1587 11 1 579579)) - (const :tag "Luxemburg (1582 12 25)" (1582 12 25 577807)) - (const :tag "Romania (1919 4 14)" (1919 4 14 700638)) - (const :tag "Russia (1918 2 14)" (1918 2 14 700214)) - (const :tag "Sweden (1753 3 1)" (1753 3 1 639965)) - (const :tag "Switzerland (Catholic) (1584 1 22)" (1584 1 22 578200)) - (const :tag "Switzerland (Protestant) (1701 1 12)" (1701 1 12 620924)) - (list :tag "(YEAR MONTH DAY)" - (integer :tag "Year") - (integer :tag "Month (integer)") - (integer :tag "Day"))) - :set (lambda (symbol value) - (set-default symbol value) - (setq math-format-date-cache nil))) - (defface calc-nonselected-face '((t :inherit shadow :slant italic)) @@ -2066,6 +2022,50 @@ See calc-keypad for details." (calc-refresh align))) (setq calc-refresh-count (1+ calc-refresh-count))) +;; Dates that are built-in options for `calc-gregorian-switch' should be +;; (YEAR MONTH DAY math-date-from-gregorian-dt(YEAR MONTH DAY)) for speed. +(defcustom calc-gregorian-switch nil + "The first day the Gregorian calendar is used by Calc's date forms. +This is `nil' (the default) if the Gregorian calendar is the only one used. +Otherwise, it should be a list `(YEAR MONTH DAY)' when Calc begins to use +the Gregorian calendar; Calc will use the Julian calendar for earlier dates. +The dates in which different regions of the world began to use the +Gregorian calendar vary quite a bit, even within a single country. +If you want Calc's date forms to switch between the Julian and +Gregorian calendar, you can specify the date or choose from several +common choices. Some of these choices should be taken with a grain +of salt; for example different parts of France changed calendars at +different times, and Sweden's change to the Gregorian calendar was +complicated. Also, the boundaries of the countries were different at +the times of the calendar changes than they are now. +The Vatican decided that the Gregorian calendar should take effect +on 15 October 1582 (Gregorian), and many Catholic countries made +the change then. Great Britain and its colonies had the Gregorian +calendar take effect on 14 September 1752 (Gregorian); this includes +the United States." + :group 'calc + :version "24.4" + :type '(choice (const :tag "Always use the Gregorian calendar" nil) + (const :tag "1582-10-15 - Italy, Poland, Portugal, Spain" (1582 10 15 577736)) + (const :tag "1582-12-20 - France" (1582 12 20 577802)) + (const :tag "1582-12-25 - Luxemburg" (1582 12 25 577807)) + (const :tag "1584-01-17 - Bohemia and Moravia" (1584 1 17 578195)) + (const :tag "1587-11-01 - Hungary" (1587 11 1 579579)) + (const :tag "1700-03-01 - Denmark" (1700 3 1 620607)) + (const :tag "1701-01-12 - Protestant Switzerland" (1701 1 12 620924)) + (const :tag "1752-09-14 - Great Britain and dominions" (1752 9 14 639797)) + (const :tag "1753-03-01 - Sweden" (1753 3 1 639965)) + (const :tag "1918-02-14 - Russia" (1918 2 14 700214)) + (const :tag "1919-04-14 - Romania" (1919 4 14 700638)) + (list :tag "(YEAR MONTH DAY)" + (integer :tag "Year") + (integer :tag "Month (integer)") + (integer :tag "Day"))) + :set (lambda (symbol value) + (set-default symbol value) + (setq math-format-date-cache nil) + (calc-refresh))) + ;;;; The Calc Trail buffer. (defun calc-check-trail-aligned () diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index 38b766084c9..9cac659d848 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -30,11 +30,10 @@ ;; value equal to HIGH * 2^16 + LOW + USEC * 10^-6 + PSEC * 10^-12 ;; seconds, where missing components are treated as zero. HIGH can be ;; negative, either because the value is a time difference, or because -;; the machine supports negative time stamps that fall before the -;; epoch. The macro `with-decoded-time-value' and the -;; function `encode-time-value' make it easier to deal with these -;; three formats. See `time-subtract' for an example of how to use -;; them. +;; the machine supports negative time stamps that fall before the epoch. +;; The macro `with-decoded-time-value' and the function +;; `encode-time-value' make it easier to deal with these formats. +;; See `time-subtract' for an example of how to use them. ;;; Code: @@ -134,9 +133,7 @@ If DATE lacks timezone information, GMT is assumed." ;;;###autoload(if (or (featurep 'emacs) ;;;###autoload (and (fboundp 'float-time) ;;;###autoload (subrp (symbol-function 'float-time)))) -;;;###autoload (progn -;;;###autoload (defalias 'time-to-seconds 'float-time) -;;;###autoload (make-obsolete 'time-to-seconds 'float-time "21.1")) +;;;###autoload (defalias 'time-to-seconds 'float-time) ;;;###autoload (autoload 'time-to-seconds "time-date")) (eval-when-compile diff --git a/lisp/cedet/ChangeLog b/lisp/cedet/ChangeLog index a01ce4c30a3..cdfb357b646 100644 --- a/lisp/cedet/ChangeLog +++ b/lisp/cedet/ChangeLog @@ -1,12 +1,17 @@ +2012-11-19 Stefan Monnier <monnier@iro.umontreal.ca> + + * semantic/fw.el (semantic-make-local-hook, semantic-mode-line-update): + Simplify via CSE. + 2012-11-16 David Engster <deng@randomsample.de> - * semantic/symref/list.el (semantic-symref-symbol): Use - `semantic-complete-read-tag-project' instead of + * semantic/symref/list.el (semantic-symref-symbol): + Use `semantic-complete-read-tag-project' instead of `semantic-complete-read-tag-buffer-deep', since the latter is not working correctly. - * semantic/symref.el (semantic-symref-result-get-tags): Use - `find-buffer-visiting' to follow symbolic links. + * semantic/symref.el (semantic-symref-result-get-tags): + Use `find-buffer-visiting' to follow symbolic links. * semantic/fw.el (semantic-find-file-noselect): Always set `enable-local-variables' to `:safe' when loading files. diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el index 14ffc808c44..6dd85309967 100644 --- a/lisp/cedet/semantic/fw.el +++ b/lisp/cedet/semantic/fw.el @@ -122,15 +122,13 @@ ) - (if (and (not (featurep 'xemacs)) - (>= emacs-major-version 21)) - (defalias 'semantic-make-local-hook 'identity) - (defalias 'semantic-make-local-hook 'make-local-hook) - ) + (defalias 'semantic-make-local-hook + (if (and (not (featurep 'xemacs)) + (>= emacs-major-version 21)) + #'identity #'make-local-hook)) - (if (featurep 'xemacs) - (defalias 'semantic-mode-line-update 'redraw-modeline) - (defalias 'semantic-mode-line-update 'force-mode-line-update)) + (defalias 'semantic-mode-line-update + (if (featurep 'xemacs) #'redraw-modeline #'force-mode-line-update)) ;; Since Emacs 22 major mode functions should use `run-mode-hooks' to ;; run major mode hooks. diff --git a/lisp/color.el b/lisp/color.el index b915beacb0a..e1563ea474c 100644 --- a/lisp/color.el +++ b/lisp/color.el @@ -33,9 +33,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - ;; Emacs < 23.3 (eval-and-compile (unless (boundp 'float-pi) @@ -69,9 +66,9 @@ RED, GREEN, and BLUE should be numbers between 0.0 and 1.0, inclusive." COLOR-NAME should be a string naming a color (e.g. \"white\"), or a string specifying a color's RGB components (e.g. \"#ff12ec\")." (let ((color (color-name-to-rgb color-name))) - (list (- 1.0 (car color)) - (- 1.0 (cadr color)) - (- 1.0 (caddr color))))) + (list (- 1.0 (nth 0 color)) + (- 1.0 (nth 1 color)) + (- 1.0 (nth 2 color))))) (defun color-gradient (start stop step-number) "Return a list with STEP-NUMBER colors from START to STOP. diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 462b4a25154..b4582a41d6c 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -81,8 +81,14 @@ The return value of this function is not used." #'(lambda (f _args new-name when) `(make-obsolete ',f ',new-name ,when))) (list 'compiler-macro - #'(lambda (f _args compiler-function) - `(put ',f 'compiler-macro #',compiler-function))) + #'(lambda (f args compiler-function) + ;; FIXME: Make it possible to just reuse `args'. + `(eval-and-compile + (put ',f 'compiler-macro + ,(if (eq (car-safe compiler-function) 'lambda) + `(lambda ,(append (cadr compiler-function) args) + ,@(cddr compiler-function)) + `#',compiler-function))))) (list 'doc-string #'(lambda (f _args pos) (list 'put (list 'quote f) ''doc-string-elt (list 'quote pos)))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index a325e0f3e44..60036c86dc0 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2509,8 +2509,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (when (symbolp form) (unless (memq (car-safe fun) '(closure lambda)) (error "Don't know how to compile %S" fun)) - (setq fun (byte-compile--reify-function fun)) - (setq lexical-binding (eq (car fun) 'closure))) + (setq lexical-binding (eq (car fun) 'closure)) + (setq fun (byte-compile--reify-function fun))) (unless (eq (car-safe fun) 'lambda) (error "Don't know how to compile %S" fun)) ;; Expand macros. diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 483ed64de20..12311711fe0 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -4268,6 +4268,21 @@ With prefix argument, make it a temporary breakpoint." ;;; Finalize Loading +;; When edebugging a function, some of the sub-expressions are +;; wrapped in (edebug-enter (lambda () ..)), so we need to teach +;; called-interactively-p that calls within the inner lambda should refer to +;; the outside function. +(add-hook 'called-interactively-p-functions + #'edebug--called-interactively-skip) +(defun edebug--called-interactively-skip (i frame1 frame2) + (when (and (eq (car-safe (nth 1 frame1)) 'lambda) + (eq (nth 1 (nth 1 frame1)) '()) + (eq (nth 1 frame2) 'edebug-enter)) + ;; `edebug-enter' calls itself on its first invocation. + (if (eq (nth 1 (internal--called-interactively-p--get-frame i)) + 'edebug-enter) + 2 1))) + ;; Finally, hook edebug into the rest of Emacs. ;; There are probably some other things that could go here. diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index c3b8e5e10d4..60d74774e87 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -1,4 +1,4 @@ -;;; ert-x.el --- Staging area for experimental extensions to ERT +;;; ert-x.el --- Staging area for experimental extensions to ERT -*- lexical-binding: t -*- ;; Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc. @@ -28,8 +28,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'ert) @@ -90,8 +89,8 @@ ERT--THUNK with that buffer as current." (kill-buffer ert--buffer) (remhash ert--buffer ert--test-buffers)))) -(defmacro* ert-with-test-buffer ((&key ((:name name-form))) - &body body) +(cl-defmacro ert-with-test-buffer ((&key ((:name name-form))) + &body body) "Create a test buffer and run BODY in that buffer. To be used in ERT tests. If BODY finishes successfully, the test @@ -116,10 +115,10 @@ the name of the test and the result of NAME-FORM." "Kill all test buffers that are still live." (interactive) (let ((count 0)) - (maphash (lambda (buffer dummy) + (maphash (lambda (buffer _dummy) (when (or (not (buffer-live-p buffer)) (kill-buffer buffer)) - (incf count))) + (cl-incf count))) ert--test-buffers) (message "%s out of %s test buffers killed" count (hash-table-count ert--test-buffers))) @@ -149,9 +148,9 @@ the rest are arguments to the command. NOTE: Since the command is not called by `call-interactively' test for `called-interactively' in the command will fail." - (assert (listp command) t) - (assert (commandp (car command)) t) - (assert (not unread-command-events) t) + (cl-assert (listp command) t) + (cl-assert (commandp (car command)) t) + (cl-assert (not unread-command-events) t) (let (return-value) ;; For the order of things here see command_loop_1 in keyboard.c. ;; @@ -175,7 +174,7 @@ test for `called-interactively' in the command will fail." (when (boundp 'last-repeatable-command) (setq last-repeatable-command real-last-command)) (when (and deactivate-mark transient-mark-mode) (deactivate-mark)) - (assert (not unread-command-events) t) + (cl-assert (not unread-command-events) t) return-value)) (defun ert-run-idle-timers () @@ -198,7 +197,7 @@ rather than the entire match." (with-temp-buffer (insert s) (dolist (x regexps) - (destructuring-bind (regexp subexp) (if (listp x) x `(,x nil)) + (cl-destructuring-bind (regexp subexp) (if (listp x) x `(,x nil)) (goto-char (point-min)) (while (re-search-forward regexp nil t) (replace-match "" t t nil subexp)))) @@ -224,15 +223,15 @@ would return the string \"foo bar baz quux\" where the substring None of the ARGS are modified, but the return value may share structure with the plists in ARGS." (with-temp-buffer - (loop with current-plist = nil - for x in args do - (etypecase x - (string (let ((begin (point))) - (insert x) - (set-text-properties begin (point) current-plist))) - (list (unless (zerop (mod (length x) 2)) - (error "Odd number of args in plist: %S" x)) - (setq current-plist x)))) + (cl-loop with current-plist = nil + for x in args do + (cl-etypecase x + (string (let ((begin (point))) + (insert x) + (set-text-properties begin (point) current-plist))) + (list (unless (zerop (mod (length x) 2)) + (error "Odd number of args in plist: %S" x)) + (setq current-plist x)))) (buffer-string))) @@ -245,8 +244,8 @@ buffer, and renames the original buffer back to BUFFER-NAME. This is useful if THUNK has undesirable side-effects on an Emacs buffer with a fixed name such as *Messages*." - (lexical-let ((new-buffer-name (generate-new-buffer-name - (format "%s orig buffer" buffer-name)))) + (let ((new-buffer-name (generate-new-buffer-name + (format "%s orig buffer" buffer-name)))) (with-current-buffer (get-buffer-create buffer-name) (rename-buffer new-buffer-name)) (unwind-protect @@ -258,7 +257,7 @@ buffer with a fixed name such as *Messages*." (with-current-buffer new-buffer-name (rename-buffer buffer-name))))) -(defmacro* ert-with-buffer-renamed ((buffer-name-form) &body body) +(cl-defmacro ert-with-buffer-renamed ((buffer-name-form) &body body) "Protect the buffer named BUFFER-NAME from side-effects and run BODY. See `ert-call-with-buffer-renamed' for details." diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index ff00be7a237..ab6dcb58143 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1,4 +1,4 @@ -;;; ert.el --- Emacs Lisp Regression Testing +;;; ert.el --- Emacs Lisp Regression Testing -*- lexical-binding: t -*- ;; Copyright (C) 2007-2008, 2010-2012 Free Software Foundation, Inc. @@ -54,8 +54,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'button) (require 'debug) (require 'easymenu) @@ -105,33 +104,33 @@ "A reimplementation of `remove-if-not'. ERT-PRED is a predicate, ERT-LIST is the input list." - (loop for ert-x in ert-list - if (funcall ert-pred ert-x) - collect ert-x)) + (cl-loop for ert-x in ert-list + if (funcall ert-pred ert-x) + collect ert-x)) (defun ert--intersection (a b) "A reimplementation of `intersection'. Intersect the sets A and B. Elements are compared using `eql'." - (loop for x in a - if (memql x b) - collect x)) + (cl-loop for x in a + if (memql x b) + collect x)) (defun ert--set-difference (a b) "A reimplementation of `set-difference'. Subtract the set B from the set A. Elements are compared using `eql'." - (loop for x in a - unless (memql x b) - collect x)) + (cl-loop for x in a + unless (memql x b) + collect x)) (defun ert--set-difference-eq (a b) "A reimplementation of `set-difference'. Subtract the set B from the set A. Elements are compared using `eq'." - (loop for x in a - unless (memq x b) - collect x)) + (cl-loop for x in a + unless (memq x b) + collect x)) (defun ert--union (a b) "A reimplementation of `union'. Compute the union of the sets A and B. @@ -149,7 +148,7 @@ Elements are compared using `eql'." (make-symbol (format "%s%s" prefix (prog1 ert--gensym-counter - (incf ert--gensym-counter)))))) + (cl-incf ert--gensym-counter)))))) (defun ert--coerce-to-vector (x) "Coerce X to a vector." @@ -158,19 +157,19 @@ Elements are compared using `eql'." x (vconcat x))) -(defun* ert--remove* (x list &key key test) +(cl-defun ert--remove* (x list &key key test) "Does not support all the keywords of remove*." (unless key (setq key #'identity)) (unless test (setq test #'eql)) - (loop for y in list - unless (funcall test x (funcall key y)) - collect y)) + (cl-loop for y in list + unless (funcall test x (funcall key y)) + collect y)) (defun ert--string-position (c s) "Return the position of the first occurrence of C in S, or nil if none." - (loop for i from 0 - for x across s - when (eql x c) return i)) + (cl-loop for i from 0 + for x across s + when (eql x c) return i)) (defun ert--mismatch (a b) "Return index of first element that differs between A and B. @@ -184,29 +183,30 @@ Like `mismatch'. Uses `equal' for comparison." (t (let ((la (length a)) (lb (length b))) - (assert (arrayp a) t) - (assert (arrayp b) t) - (assert (<= la lb) t) - (loop for i below la - when (not (equal (aref a i) (aref b i))) return i - finally (return (if (/= la lb) - la - (assert (equal a b) t) - nil))))))) + (cl-assert (arrayp a) t) + (cl-assert (arrayp b) t) + (cl-assert (<= la lb) t) + (cl-loop for i below la + when (not (equal (aref a i) (aref b i))) return i + finally (cl-return (if (/= la lb) + la + (cl-assert (equal a b) t) + nil))))))) (defun ert--subseq (seq start &optional end) "Return a subsequence of SEQ from START to END." (when (char-table-p seq) (error "Not supported")) (let ((vector (substring (ert--coerce-to-vector seq) start end))) - (etypecase seq + (cl-etypecase seq (vector vector) (string (concat vector)) (list (append vector nil)) - (bool-vector (loop with result = (make-bool-vector (length vector) nil) - for i below (length vector) do - (setf (aref result i) (aref vector i)) - finally (return result))) - (char-table (assert nil))))) + (bool-vector (cl-loop with result + = (make-bool-vector (length vector) nil) + for i below (length vector) do + (setf (aref result i) (aref vector i)) + finally (cl-return result))) + (char-table (cl-assert nil))))) (defun ert-equal-including-properties (a b) "Return t if A and B have similar structure and contents. @@ -225,10 +225,10 @@ Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." ;;; Defining and locating tests. ;; The data structure that represents a test case. -(defstruct ert-test +(cl-defstruct ert-test (name nil) (documentation nil) - (body (assert nil)) + (body (cl-assert nil)) (most-recent-result nil) (expected-result-type ':passed) (tags '())) @@ -273,7 +273,7 @@ Returns a two-element list containing the keys-and-values plist and the body." (let ((extracted-key-accu '()) (remaining keys-and-body)) - (while (and (consp remaining) (keywordp (first remaining))) + (while (keywordp (car-safe remaining)) (let ((keyword (pop remaining))) (unless (consp remaining) (error "Value expected after keyword %S in %S" @@ -283,13 +283,13 @@ and the body." keys-and-body)) (push (cons keyword (pop remaining)) extracted-key-accu))) (setq extracted-key-accu (nreverse extracted-key-accu)) - (list (loop for (key . value) in extracted-key-accu - collect key - collect value) + (list (cl-loop for (key . value) in extracted-key-accu + collect key + collect value) remaining))) ;;;###autoload -(defmacro* ert-deftest (name () &body docstring-keys-and-body) +(cl-defmacro ert-deftest (name () &body docstring-keys-and-body) "Define NAME (a symbol) as a test. BODY is evaluated as a `progn' when the test is run. It should @@ -313,12 +313,13 @@ description of valid values for RESULT-TYPE. (indent 2)) (let ((documentation nil) (documentation-supplied-p nil)) - (when (stringp (first docstring-keys-and-body)) + (when (stringp (car docstring-keys-and-body)) (setq documentation (pop docstring-keys-and-body) documentation-supplied-p t)) - (destructuring-bind ((&key (expected-result nil expected-result-supplied-p) - (tags nil tags-supplied-p)) - body) + (cl-destructuring-bind + ((&key (expected-result nil expected-result-supplied-p) + (tags nil tags-supplied-p)) + body) (ert--parse-keys-and-body docstring-keys-and-body) `(progn (ert-set-test ',name @@ -388,16 +389,11 @@ DATA is displayed to the user and should state the reason of the failure." (defun ert--expand-should-1 (whole form inner-expander) "Helper function for the `should' macro and its variants." (let ((form - ;; If `cl-macroexpand' isn't bound, the code that we're - ;; compiling doesn't depend on cl and thus doesn't need an - ;; environment arg for `macroexpand'. - (if (fboundp 'cl-macroexpand) - ;; Suppress warning about run-time call to cl function: we - ;; only call it if it's fboundp. - (with-no-warnings - (cl-macroexpand form (and (boundp 'cl-macro-environment) - cl-macro-environment))) - (macroexpand form)))) + (macroexpand form (cond + ((boundp 'macroexpand-all-environment) + macroexpand-all-environment) + ((boundp 'cl-macro-environment) + cl-macro-environment))))) (cond ((or (atom form) (ert--special-operator-p (car form))) (let ((value (ert--gensym "value-"))) @@ -410,10 +406,10 @@ DATA is displayed to the user and should state the reason of the failure." (t (let ((fn-name (car form)) (arg-forms (cdr form))) - (assert (or (symbolp fn-name) - (and (consp fn-name) - (eql (car fn-name) 'lambda) - (listp (cdr fn-name))))) + (cl-assert (or (symbolp fn-name) + (and (consp fn-name) + (eql (car fn-name) 'lambda) + (listp (cdr fn-name))))) (let ((fn (ert--gensym "fn-")) (args (ert--gensym "args-")) (value (ert--gensym "value-")) @@ -451,35 +447,34 @@ should return code that calls INNER-FORM and performs the checks and error signaling specific to the particular variant of `should'. The code that INNER-EXPANDER returns must not call FORM-DESCRIPTION-FORM before it has called INNER-FORM." - (lexical-let ((inner-expander inner-expander)) - (ert--expand-should-1 - whole form - (lambda (inner-form form-description-form value-var) - (let ((form-description (ert--gensym "form-description-"))) - `(let (,form-description) - ,(funcall inner-expander - `(unwind-protect - ,inner-form - (setq ,form-description ,form-description-form) - (ert--signal-should-execution ,form-description)) - `,form-description - value-var))))))) - -(defmacro* should (form) + (ert--expand-should-1 + whole form + (lambda (inner-form form-description-form value-var) + (let ((form-description (ert--gensym "form-description-"))) + `(let (,form-description) + ,(funcall inner-expander + `(unwind-protect + ,inner-form + (setq ,form-description ,form-description-form) + (ert--signal-should-execution ,form-description)) + `,form-description + value-var)))))) + +(cl-defmacro should (form) "Evaluate FORM. If it returns nil, abort the current test as failed. Returns the value of FORM." (ert--expand-should `(should ,form) form - (lambda (inner-form form-description-form value-var) + (lambda (inner-form form-description-form _value-var) `(unless ,inner-form (ert-fail ,form-description-form))))) -(defmacro* should-not (form) +(cl-defmacro should-not (form) "Evaluate FORM. If it returns non-nil, abort the current test as failed. Returns nil." (ert--expand-should `(should-not ,form) form - (lambda (inner-form form-description-form value-var) + (lambda (inner-form form-description-form _value-var) `(unless (not ,inner-form) (ert-fail ,form-description-form))))) @@ -490,10 +485,10 @@ Returns nil." Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, and aborts the current test as failed if it doesn't." (let ((signaled-conditions (get (car condition) 'error-conditions)) - (handled-conditions (etypecase type + (handled-conditions (cl-etypecase type (list type) (symbol (list type))))) - (assert signaled-conditions) + (cl-assert signaled-conditions) (unless (ert--intersection signaled-conditions handled-conditions) (ert-fail (append (funcall form-description-fn) @@ -512,7 +507,7 @@ and aborts the current test as failed if it doesn't." ;; FIXME: The expansion will evaluate the keyword args (if any) in ;; nonstandard order. -(defmacro* should-error (form &rest keys &key type exclude-subtypes) +(cl-defmacro should-error (form &rest keys &key type exclude-subtypes) "Evaluate FORM and check that it signals an error. The error signaled needs to match TYPE. TYPE should be a list @@ -560,19 +555,19 @@ failed." (defun ert--proper-list-p (x) "Return non-nil if X is a proper list, nil otherwise." - (loop + (cl-loop for firstp = t then nil for fast = x then (cddr fast) for slow = x then (cdr slow) do - (when (null fast) (return t)) - (when (not (consp fast)) (return nil)) - (when (null (cdr fast)) (return t)) - (when (not (consp (cdr fast))) (return nil)) - (when (and (not firstp) (eq fast slow)) (return nil)))) + (when (null fast) (cl-return t)) + (when (not (consp fast)) (cl-return nil)) + (when (null (cdr fast)) (cl-return t)) + (when (not (consp (cdr fast))) (cl-return nil)) + (when (and (not firstp) (eq fast slow)) (cl-return nil)))) (defun ert--explain-format-atom (x) "Format the atom X for `ert--explain-equal'." - (typecase x + (cl-typecase x (fixnum (list x (format "#x%x" x) (format "?%c" x))) (t x))) @@ -581,7 +576,7 @@ failed." Returns nil if they are." (if (not (equal (type-of a) (type-of b))) `(different-types ,a ,b) - (etypecase a + (cl-etypecase a (cons (let ((a-proper-p (ert--proper-list-p a)) (b-proper-p (ert--proper-list-p b))) @@ -593,19 +588,19 @@ Returns nil if they are." ,a ,b first-mismatch-at ,(ert--mismatch a b)) - (loop for i from 0 - for ai in a - for bi in b - for xi = (ert--explain-equal-rec ai bi) - do (when xi (return `(list-elt ,i ,xi))) - finally (assert (equal a b) t))) + (cl-loop for i from 0 + for ai in a + for bi in b + for xi = (ert--explain-equal-rec ai bi) + do (when xi (cl-return `(list-elt ,i ,xi))) + finally (cl-assert (equal a b) t))) (let ((car-x (ert--explain-equal-rec (car a) (car b)))) (if car-x `(car ,car-x) (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b)))) (if cdr-x `(cdr ,cdr-x) - (assert (equal a b) t) + (cl-assert (equal a b) t) nil)))))))) (array (if (not (equal (length a) (length b))) `(arrays-of-different-length ,(length a) ,(length b) @@ -613,12 +608,12 @@ Returns nil if they are." ,@(unless (char-table-p a) `(first-mismatch-at ,(ert--mismatch a b)))) - (loop for i from 0 - for ai across a - for bi across b - for xi = (ert--explain-equal-rec ai bi) - do (when xi (return `(array-elt ,i ,xi))) - finally (assert (equal a b) t)))) + (cl-loop for i from 0 + for ai across a + for bi across b + for xi = (ert--explain-equal-rec ai bi) + do (when xi (cl-return `(array-elt ,i ,xi))) + finally (cl-assert (equal a b) t)))) (atom (if (not (equal a b)) (if (and (symbolp a) (symbolp b) (string= a b)) `(different-symbols-with-the-same-name ,a ,b) @@ -637,10 +632,10 @@ Returns nil if they are." (defun ert--significant-plist-keys (plist) "Return the keys of PLIST that have non-null values, in order." - (assert (zerop (mod (length plist) 2)) t) - (loop for (key value . rest) on plist by #'cddr - unless (or (null value) (memq key accu)) collect key into accu - finally (return accu))) + (cl-assert (zerop (mod (length plist) 2)) t) + (cl-loop for (key value . rest) on plist by #'cddr + unless (or (null value) (memq key accu)) collect key into accu + finally (cl-return accu))) (defun ert--plist-difference-explanation (a b) "Return a programmer-readable explanation of why A and B are different plists. @@ -648,8 +643,8 @@ Returns nil if they are." Returns nil if they are equivalent, i.e., have the same value for each key, where absent values are treated as nil. The order of key/value pairs in each list does not matter." - (assert (zerop (mod (length a) 2)) t) - (assert (zerop (mod (length b) 2)) t) + (cl-assert (zerop (mod (length a) 2)) t) + (cl-assert (zerop (mod (length b) 2)) t) ;; Normalizing the plists would be another way to do this but it ;; requires a total ordering on all lisp objects (since any object ;; is valid as a text property key). Perhaps defining such an @@ -659,21 +654,21 @@ key/value pairs in each list does not matter." (keys-b (ert--significant-plist-keys b)) (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b)) (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a))) - (flet ((explain-with-key (key) - (let ((value-a (plist-get a key)) - (value-b (plist-get b key))) - (assert (not (equal value-a value-b)) t) - `(different-properties-for-key - ,key ,(ert--explain-equal-including-properties value-a - value-b))))) + (cl-flet ((explain-with-key (key) + (let ((value-a (plist-get a key)) + (value-b (plist-get b key))) + (cl-assert (not (equal value-a value-b)) t) + `(different-properties-for-key + ,key ,(ert--explain-equal-including-properties value-a + value-b))))) (cond (keys-in-a-not-in-b - (explain-with-key (first keys-in-a-not-in-b))) + (explain-with-key (car keys-in-a-not-in-b))) (keys-in-b-not-in-a - (explain-with-key (first keys-in-b-not-in-a))) + (explain-with-key (car keys-in-b-not-in-a))) (t - (loop for key in keys-a - when (not (equal (plist-get a key) (plist-get b key))) - return (explain-with-key key))))))) + (cl-loop for key in keys-a + when (not (equal (plist-get a key) (plist-get b key))) + return (explain-with-key key))))))) (defun ert--abbreviate-string (s len suffixp) "Shorten string S to at most LEN chars. @@ -697,29 +692,30 @@ Returns a programmer-readable explanation of why A and B are not `ert-equal-including-properties', or nil if they are." (if (not (equal a b)) (ert--explain-equal a b) - (assert (stringp a) t) - (assert (stringp b) t) - (assert (eql (length a) (length b)) t) - (loop for i from 0 to (length a) - for props-a = (text-properties-at i a) - for props-b = (text-properties-at i b) - for difference = (ert--plist-difference-explanation props-a props-b) - do (when difference - (return `(char ,i ,(substring-no-properties a i (1+ i)) - ,difference - context-before - ,(ert--abbreviate-string - (substring-no-properties a 0 i) - 10 t) - context-after - ,(ert--abbreviate-string - (substring-no-properties a (1+ i)) - 10 nil)))) - ;; TODO(ohler): Get `equal-including-properties' fixed in - ;; Emacs, delete `ert-equal-including-properties', and - ;; re-enable this assertion. - ;;finally (assert (equal-including-properties a b) t) - ))) + (cl-assert (stringp a) t) + (cl-assert (stringp b) t) + (cl-assert (eql (length a) (length b)) t) + (cl-loop for i from 0 to (length a) + for props-a = (text-properties-at i a) + for props-b = (text-properties-at i b) + for difference = (ert--plist-difference-explanation + props-a props-b) + do (when difference + (cl-return `(char ,i ,(substring-no-properties a i (1+ i)) + ,difference + context-before + ,(ert--abbreviate-string + (substring-no-properties a 0 i) + 10 t) + context-after + ,(ert--abbreviate-string + (substring-no-properties a (1+ i)) + 10 nil)))) + ;; TODO(ohler): Get `equal-including-properties' fixed in + ;; Emacs, delete `ert-equal-including-properties', and + ;; re-enable this assertion. + ;;finally (cl-assert (equal-including-properties a b) t) + ))) (put 'ert-equal-including-properties 'ert-explainer 'ert--explain-equal-including-properties) @@ -734,8 +730,8 @@ Returns a programmer-readable explanation of why A and B are not Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") -(defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) - &body body) +(cl-defmacro ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) + &body body) "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. To be used within ERT tests. MESSAGE-FORM should evaluate to a @@ -755,18 +751,19 @@ and is displayed in front of the value of MESSAGE-FORM." "Non-nil means enter debugger when a test fails or terminates with an error.") ;; The data structures that represent the result of running a test. -(defstruct ert-test-result +(cl-defstruct ert-test-result (messages nil) (should-forms nil) ) -(defstruct (ert-test-passed (:include ert-test-result))) -(defstruct (ert-test-result-with-condition (:include ert-test-result)) - (condition (assert nil)) - (backtrace (assert nil)) - (infos (assert nil))) -(defstruct (ert-test-quit (:include ert-test-result-with-condition))) -(defstruct (ert-test-failed (:include ert-test-result-with-condition))) -(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) +(cl-defstruct (ert-test-passed (:include ert-test-result))) +(cl-defstruct (ert-test-result-with-condition (:include ert-test-result)) + (condition (cl-assert nil)) + (backtrace (cl-assert nil)) + (infos (cl-assert nil))) +(cl-defstruct (ert-test-quit (:include ert-test-result-with-condition))) +(cl-defstruct (ert-test-failed (:include ert-test-result-with-condition))) +(cl-defstruct (ert-test-aborted-with-non-local-exit + (:include ert-test-result))) (defun ert--record-backtrace () @@ -779,7 +776,7 @@ and is displayed in front of the value of MESSAGE-FORM." ;; `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. - (loop + (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. @@ -796,33 +793,33 @@ and is displayed in front of the value of MESSAGE-FORM." (print-level 8) (print-length 50)) (dolist (frame backtrace) - (ecase (first frame) + (cl-ecase (car frame) ((nil) ;; Special operator. - (destructuring-bind (special-operator &rest arg-forms) + (cl-destructuring-bind (special-operator &rest arg-forms) (cdr frame) (insert - (format " %S\n" (list* special-operator arg-forms))))) + (format " %S\n" (cons special-operator arg-forms))))) ((t) ;; Function call. - (destructuring-bind (fn &rest args) (cdr frame) + (cl-destructuring-bind (fn &rest args) (cdr frame) (insert (format " %S(" fn)) - (loop for firstp = t then nil - for arg in args do - (unless firstp - (insert " ")) - (insert (format "%S" arg))) + (cl-loop for firstp = t then nil + for arg in args do + (unless firstp + (insert " ")) + (insert (format "%S" arg))) (insert ")\n"))))))) ;; A container for the state of the execution of a single test and ;; environment data needed during its execution. -(defstruct ert--test-execution-info - (test (assert nil)) - (result (assert nil)) +(cl-defstruct ert--test-execution-info + (test (cl-assert nil)) + (result (cl-assert nil)) ;; A thunk that may be called when RESULT has been set to its final ;; value and test execution should be terminated. Should not ;; return. - (exit-continuation (assert nil)) + (exit-continuation (cl-assert nil)) ;; The binding of `debugger' outside of the execution of the test. next-debugger ;; The binding of `ert-debug-on-error' that is in effect for the @@ -831,7 +828,7 @@ and is displayed in front of the value of MESSAGE-FORM." ;; don't remember whether this feature is important.) ert-debug-on-error) -(defun ert--run-test-debugger (info debugger-args) +(defun ert--run-test-debugger (info args) "During a test run, `debugger' is bound to a closure that calls this function. This function records failures and errors and either terminates @@ -839,21 +836,21 @@ the test silently or calls the interactive debugger, as appropriate. INFO is the ert--test-execution-info corresponding to this test -run. DEBUGGER-ARGS are the arguments to `debugger'." - (destructuring-bind (first-debugger-arg &rest more-debugger-args) - debugger-args - (ecase first-debugger-arg +run. ARGS are the arguments to `debugger'." + (cl-destructuring-bind (first-debugger-arg &rest more-debugger-args) + args + (cl-ecase first-debugger-arg ((lambda debug t exit nil) - (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (apply (ert--test-execution-info-next-debugger info) args)) (error - (let* ((condition (first more-debugger-args)) - (type (case (car condition) + (let* ((condition (car more-debugger-args)) + (type (cl-case (car condition) ((quit) 'quit) (otherwise 'failed))) (backtrace (ert--record-backtrace)) (infos (reverse ert--infos))) (setf (ert--test-execution-info-result info) - (ecase type + (cl-ecase type (quit (make-ert-test-quit :condition condition :backtrace backtrace @@ -864,39 +861,42 @@ run. DEBUGGER-ARGS are the arguments to `debugger'." :infos infos)))) ;; Work around Emacs's heuristic (in eval.c) for detecting ;; errors in the debugger. - (incf num-nonmacro-input-events) + (cl-incf num-nonmacro-input-events) ;; FIXME: We should probably implement more fine-grained ;; control a la non-t `debug-on-error' here. (cond ((ert--test-execution-info-ert-debug-on-error info) - (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (apply (ert--test-execution-info-next-debugger info) args)) (t)) (funcall (ert--test-execution-info-exit-continuation info))))))) -(defun ert--run-test-internal (ert-test-execution-info) - "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO. +(defun ert--run-test-internal (test-execution-info) + "Low-level function to run a test according to TEST-EXECUTION-INFO. This mainly sets up debugger-related bindings." - (lexical-let ((info ert-test-execution-info)) - (setf (ert--test-execution-info-next-debugger info) debugger - (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error) - (catch 'ert--pass - ;; For now, each test gets its own temp buffer and its own - ;; window excursion, just to be safe. If this turns out to be - ;; too expensive, we can remove it. - (with-temp-buffer - (save-window-excursion - (let ((debugger (lambda (&rest debugger-args) - (ert--run-test-debugger info debugger-args))) - (debug-on-error t) - (debug-on-quit t) - ;; FIXME: Do we need to store the old binding of this - ;; and consider it in `ert--run-test-debugger'? - (debug-ignored-errors nil) - (ert--infos '())) - (funcall (ert-test-body (ert--test-execution-info-test info)))))) - (ert-pass)) - (setf (ert--test-execution-info-result info) (make-ert-test-passed))) + (setf (ert--test-execution-info-next-debugger test-execution-info) debugger + (ert--test-execution-info-ert-debug-on-error test-execution-info) + ert-debug-on-error) + (catch 'ert--pass + ;; For now, each test gets its own temp buffer and its own + ;; window excursion, just to be safe. If this turns out to be + ;; too expensive, we can remove it. + (with-temp-buffer + (save-window-excursion + (let ((debugger (lambda (&rest args) + (ert--run-test-debugger test-execution-info + args))) + (debug-on-error t) + (debug-on-quit t) + ;; FIXME: Do we need to store the old binding of this + ;; and consider it in `ert--run-test-debugger'? + (debug-ignored-errors nil) + (ert--infos '())) + (funcall (ert-test-body (ert--test-execution-info-test + test-execution-info)))))) + (ert-pass)) + (setf (ert--test-execution-info-result test-execution-info) + (make-ert-test-passed)) nil) (defun ert--force-message-log-buffer-truncation () @@ -934,18 +934,18 @@ The elements are of type `ert-test'.") Returns the result and stores it in ERT-TEST's `most-recent-result' slot." (setf (ert-test-most-recent-result ert-test) nil) - (block error - (lexical-let ((begin-marker - (with-current-buffer (get-buffer-create "*Messages*") - (set-marker (make-marker) (point-max))))) + (cl-block error + (let ((begin-marker + (with-current-buffer (get-buffer-create "*Messages*") + (set-marker (make-marker) (point-max))))) (unwind-protect - (lexical-let ((info (make-ert--test-execution-info - :test ert-test - :result - (make-ert-test-aborted-with-non-local-exit) - :exit-continuation (lambda () - (return-from error nil)))) - (should-form-accu (list))) + (let ((info (make-ert--test-execution-info + :test ert-test + :result + (make-ert-test-aborted-with-non-local-exit) + :exit-continuation (lambda () + (cl-return-from error nil)))) + (should-form-accu (list))) (unwind-protect (let ((ert--should-execution-observer (lambda (form-description) @@ -987,32 +987,32 @@ t -- Always matches. RESULT." ;; It would be easy to add `member' and `eql' types etc., but I ;; haven't bothered yet. - (etypecase result-type + (cl-etypecase result-type ((member nil) nil) ((member t) t) ((member :failed) (ert-test-failed-p result)) ((member :passed) (ert-test-passed-p result)) (cons - (destructuring-bind (operator &rest operands) result-type - (ecase operator + (cl-destructuring-bind (operator &rest operands) result-type + (cl-ecase operator (and - (case (length operands) + (cl-case (length operands) (0 t) (t - (and (ert-test-result-type-p result (first operands)) - (ert-test-result-type-p result `(and ,@(rest operands))))))) + (and (ert-test-result-type-p result (car operands)) + (ert-test-result-type-p result `(and ,@(cdr operands))))))) (or - (case (length operands) + (cl-case (length operands) (0 nil) (t - (or (ert-test-result-type-p result (first operands)) - (ert-test-result-type-p result `(or ,@(rest operands))))))) + (or (ert-test-result-type-p result (car operands)) + (ert-test-result-type-p result `(or ,@(cdr operands))))))) (not - (assert (eql (length operands) 1)) - (not (ert-test-result-type-p result (first operands)))) + (cl-assert (eql (length operands) 1)) + (not (ert-test-result-type-p result (car operands)))) (satisfies - (assert (eql (length operands) 1)) - (funcall (first operands) result))))))) + (cl-assert (eql (length operands) 1)) + (funcall (car operands) result))))))) (defun ert-test-result-expected-p (test result) "Return non-nil if TEST's expected result type matches RESULT." @@ -1053,9 +1053,9 @@ set implied by them without checking whether it is really contained in UNIVERSE." ;; This code needs to match the etypecase in ;; `ert-insert-human-readable-selector'. - (etypecase selector + (cl-etypecase selector ((member nil) nil) - ((member t) (etypecase universe + ((member t) (cl-etypecase universe (list universe) ((member t) (ert-select-tests "" universe)))) ((member :new) (ert-select-tests @@ -1083,7 +1083,7 @@ contained in UNIVERSE." universe)) ((member :unexpected) (ert-select-tests `(not :expected) universe)) (string - (etypecase universe + (cl-etypecase universe ((member t) (mapcar #'ert-get-test (apropos-internal selector #'ert-test-boundp))) (list (ert--remove-if-not (lambda (test) @@ -1093,51 +1093,51 @@ contained in UNIVERSE." universe)))) (ert-test (list selector)) (symbol - (assert (ert-test-boundp selector)) + (cl-assert (ert-test-boundp selector)) (list (ert-get-test selector))) (cons - (destructuring-bind (operator &rest operands) selector - (ecase operator + (cl-destructuring-bind (operator &rest operands) selector + (cl-ecase operator (member (mapcar (lambda (purported-test) - (etypecase purported-test - (symbol (assert (ert-test-boundp purported-test)) + (cl-etypecase purported-test + (symbol (cl-assert (ert-test-boundp purported-test)) (ert-get-test purported-test)) (ert-test purported-test))) operands)) (eql - (assert (eql (length operands) 1)) + (cl-assert (eql (length operands) 1)) (ert-select-tests `(member ,@operands) universe)) (and ;; Do these definitions of AND, NOT and OR satisfy de ;; Morgan's laws? Should they? - (case (length operands) + (cl-case (length operands) (0 (ert-select-tests 't universe)) - (t (ert-select-tests `(and ,@(rest operands)) - (ert-select-tests (first operands) + (t (ert-select-tests `(and ,@(cdr operands)) + (ert-select-tests (car operands) universe))))) (not - (assert (eql (length operands) 1)) + (cl-assert (eql (length operands) 1)) (let ((all-tests (ert-select-tests 't universe))) (ert--set-difference all-tests - (ert-select-tests (first operands) + (ert-select-tests (car operands) all-tests)))) (or - (case (length operands) + (cl-case (length operands) (0 (ert-select-tests 'nil universe)) - (t (ert--union (ert-select-tests (first operands) universe) - (ert-select-tests `(or ,@(rest operands)) + (t (ert--union (ert-select-tests (car operands) universe) + (ert-select-tests `(or ,@(cdr operands)) universe))))) (tag - (assert (eql (length operands) 1)) - (let ((tag (first operands))) + (cl-assert (eql (length operands) 1)) + (let ((tag (car operands))) (ert-select-tests `(satisfies ,(lambda (test) (member tag (ert-test-tags test)))) universe))) (satisfies - (assert (eql (length operands) 1)) - (ert--remove-if-not (first operands) + (cl-assert (eql (length operands) 1)) + (ert--remove-if-not (car operands) (ert-select-tests 't universe)))))))) (defun ert--insert-human-readable-selector (selector) @@ -1146,26 +1146,27 @@ contained in UNIVERSE." ;; `backtrace' slot of the result objects in the ;; `most-recent-result' slots of test case objects in (eql ...) or ;; (member ...) selectors. - (labels ((rec (selector) - ;; This code needs to match the etypecase in `ert-select-tests'. - (etypecase selector - ((or (member nil t - :new :failed :passed - :expected :unexpected) - string - symbol) - selector) - (ert-test - (if (ert-test-name selector) - (make-symbol (format "<%S>" (ert-test-name selector))) - (make-symbol "<unnamed test>"))) - (cons - (destructuring-bind (operator &rest operands) selector - (ecase operator - ((member eql and not or) - `(,operator ,@(mapcar #'rec operands))) - ((member tag satisfies) - selector))))))) + (cl-labels ((rec (selector) + ;; This code needs to match the etypecase in + ;; `ert-select-tests'. + (cl-etypecase selector + ((or (member nil t + :new :failed :passed + :expected :unexpected) + string + symbol) + selector) + (ert-test + (if (ert-test-name selector) + (make-symbol (format "<%S>" (ert-test-name selector))) + (make-symbol "<unnamed test>"))) + (cons + (cl-destructuring-bind (operator &rest operands) selector + (cl-ecase operator + ((member eql and not or) + `(,operator ,@(mapcar #'rec operands))) + ((member tag satisfies) + selector))))))) (insert (format "%S" (rec selector))))) @@ -1182,21 +1183,21 @@ contained in UNIVERSE." ;; that corresponds to this run in order to be able to update the ;; statistics correctly when a test is re-run interactively and has a ;; different result than before. -(defstruct ert--stats - (selector (assert nil)) +(cl-defstruct ert--stats + (selector (cl-assert nil)) ;; The tests, in order. - (tests (assert nil) :type vector) + (tests (cl-assert nil) :type vector) ;; A map of test names (or the test objects themselves for unnamed ;; tests) to indices into the `tests' vector. - (test-map (assert nil) :type hash-table) + (test-map (cl-assert nil) :type hash-table) ;; The results of the tests during this run, in order. - (test-results (assert nil) :type vector) + (test-results (cl-assert nil) :type vector) ;; The start times of the tests, in order, as reported by ;; `current-time'. - (test-start-times (assert nil) :type vector) + (test-start-times (cl-assert nil) :type vector) ;; The end times of the tests, in order, as reported by ;; `current-time'. - (test-end-times (assert nil) :type vector) + (test-end-times (cl-assert nil) :type vector) (passed-expected 0) (passed-unexpected 0) (failed-expected 0) @@ -1246,21 +1247,25 @@ Also changes the counters in STATS to match." (results (ert--stats-test-results stats)) (old-test (aref tests pos)) (map (ert--stats-test-map stats))) - (flet ((update (d) - (if (ert-test-result-expected-p (aref tests pos) - (aref results pos)) - (etypecase (aref results pos) - (ert-test-passed (incf (ert--stats-passed-expected stats) d)) - (ert-test-failed (incf (ert--stats-failed-expected stats) d)) - (null) - (ert-test-aborted-with-non-local-exit) - (ert-test-quit)) - (etypecase (aref results pos) - (ert-test-passed (incf (ert--stats-passed-unexpected stats) d)) - (ert-test-failed (incf (ert--stats-failed-unexpected stats) d)) - (null) - (ert-test-aborted-with-non-local-exit) - (ert-test-quit))))) + (cl-flet ((update (d) + (if (ert-test-result-expected-p (aref tests pos) + (aref results pos)) + (cl-etypecase (aref results pos) + (ert-test-passed + (cl-incf (ert--stats-passed-expected stats) d)) + (ert-test-failed + (cl-incf (ert--stats-failed-expected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit) + (ert-test-quit)) + (cl-etypecase (aref results pos) + (ert-test-passed + (cl-incf (ert--stats-passed-unexpected stats) d)) + (ert-test-failed + (cl-incf (ert--stats-failed-unexpected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit) + (ert-test-quit))))) ;; Adjust counters to remove the result that is currently in stats. (update -1) ;; Put new test and result into stats. @@ -1278,11 +1283,11 @@ Also changes the counters in STATS to match." SELECTOR is the selector that was used to select TESTS." (setq tests (ert--coerce-to-vector tests)) (let ((map (make-hash-table :size (length tests)))) - (loop for i from 0 - for test across tests - for key = (ert--stats-test-key test) do - (assert (not (gethash key map))) - (setf (gethash key map) i)) + (cl-loop for i from 0 + for test across tests + for key = (ert--stats-test-key test) do + (cl-assert (not (gethash key map))) + (setf (gethash key map) i)) (make-ert--stats :selector selector :tests tests :test-map map @@ -1324,8 +1329,8 @@ SELECTOR is the selector that was used to select TESTS." (force-mode-line-update) (unwind-protect (progn - (loop for test in tests do - (ert-run-or-rerun-test stats test listener)) + (cl-loop for test in tests do + (ert-run-or-rerun-test stats test listener)) (setq abortedp nil)) (setf (ert--stats-aborted-p stats) abortedp) (setf (ert--stats-end-time stats) (current-time)) @@ -1349,7 +1354,7 @@ SELECTOR is the selector that was used to select TESTS." "Return a character that represents the test result RESULT. EXPECTEDP specifies whether the result was expected." - (let ((s (etypecase result + (let ((s (cl-etypecase result (ert-test-passed ".P") (ert-test-failed "fF") (null "--") @@ -1361,7 +1366,7 @@ EXPECTEDP specifies whether the result was expected." "Return a string that represents the test result RESULT. EXPECTEDP specifies whether the result was expected." - (let ((s (etypecase result + (let ((s (cl-etypecase result (ert-test-passed '("passed" "PASSED")) (ert-test-failed '("failed" "FAILED")) (null '("unknown" "UNKNOWN")) @@ -1383,9 +1388,9 @@ Ensures a final newline is inserted." "Insert `ert-info' infos from RESULT into current buffer. RESULT must be an `ert-test-result-with-condition'." - (check-type result ert-test-result-with-condition) + (cl-check-type result ert-test-result-with-condition) (dolist (info (ert-test-result-with-condition-infos result)) - (destructuring-bind (prefix . message) info + (cl-destructuring-bind (prefix . message) info (let ((begin (point)) (indentation (make-string (+ (length prefix) 4) ?\s)) (end nil)) @@ -1421,14 +1426,14 @@ Returns the stats object." (ert-run-tests selector (lambda (event-type &rest event-args) - (ecase event-type + (cl-ecase event-type (run-started - (destructuring-bind (stats) event-args + (cl-destructuring-bind (stats) event-args (message "Running %s tests (%s)" (length (ert--stats-tests stats)) (ert--format-time-iso8601 (ert--stats-start-time stats))))) (run-ended - (destructuring-bind (stats abortedp) event-args + (cl-destructuring-bind (stats abortedp) event-args (let ((unexpected (ert-stats-completed-unexpected stats)) (expected-failures (ert--stats-failed-expected stats))) (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" @@ -1446,19 +1451,19 @@ Returns the stats object." (format "\n%s expected failures" expected-failures))) (unless (zerop unexpected) (message "%s unexpected results:" unexpected) - (loop for test across (ert--stats-tests stats) - for result = (ert-test-most-recent-result test) do - (when (not (ert-test-result-expected-p test result)) - (message "%9s %S" - (ert-string-for-test-result result nil) - (ert-test-name test)))) + (cl-loop for test across (ert--stats-tests stats) + for result = (ert-test-most-recent-result test) do + (when (not (ert-test-result-expected-p test result)) + (message "%9s %S" + (ert-string-for-test-result result nil) + (ert-test-name test)))) (message "%s" ""))))) (test-started ) (test-ended - (destructuring-bind (stats test result) event-args + (cl-destructuring-bind (stats test result) event-args (unless (ert-test-result-expected-p test result) - (etypecase result + (cl-etypecase result (ert-test-passed (message "Test %S passed unexpectedly" (ert-test-name test))) (ert-test-result-with-condition @@ -1484,7 +1489,7 @@ Returns the stats object." (ert--pp-with-indentation-and-newline (ert-test-result-with-condition-condition result))) (goto-char (1- (point-max))) - (assert (looking-at "\n")) + (cl-assert (looking-at "\n")) (delete-char 1) (message "Test %S condition:" (ert-test-name test)) (message "%s" (buffer-string)))) @@ -1532,7 +1537,7 @@ the tests)." (1 font-lock-keyword-face nil t) (2 font-lock-function-name-face nil t))))) -(defun* ert--remove-from-list (list-var element &key key test) +(cl-defun ert--remove-from-list (list-var element &key key test) "Remove ELEMENT from the value of LIST-VAR if present. This can be used as an inverse of `add-to-list'." @@ -1557,7 +1562,7 @@ If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to include the default, if any. Signals an error if no test name was read." - (etypecase default + (cl-etypecase default (string (let ((symbol (intern-soft default))) (unless (and symbol (ert-test-boundp symbol)) (setq default nil)))) @@ -1614,11 +1619,11 @@ Nothing more than an interactive interface to `ert-make-test-unbound'." ;;; Display of test progress and results. ;; An entry in the results buffer ewoc. There is one entry per test. -(defstruct ert--ewoc-entry - (test (assert nil)) +(cl-defstruct ert--ewoc-entry + (test (cl-assert nil)) ;; If the result of this test was expected, its ewoc entry is hidden ;; initially. - (hidden-p (assert nil)) + (hidden-p (cl-assert nil)) ;; An ewoc entry may be collapsed to hide details such as the error ;; condition. ;; @@ -1694,7 +1699,7 @@ Also sets `ert--results-progress-bar-button-begin'." ((ert--stats-current-test stats) 'running) ((ert--stats-end-time stats) 'finished) (t 'preparing)))) - (ecase state + (cl-ecase state (preparing (insert "")) (aborted @@ -1705,12 +1710,12 @@ Also sets `ert--results-progress-bar-button-begin'." (t (insert "Aborted.")))) (running - (assert (ert--stats-current-test stats)) + (cl-assert (ert--stats-current-test stats)) (insert "Running test: ") (ert-insert-test-name-button (ert-test-name (ert--stats-current-test stats)))) (finished - (assert (not (ert--stats-current-test stats))) + (cl-assert (not (ert--stats-current-test stats))) (insert "Finished."))) (insert "\n") (if (ert--stats-end-time stats) @@ -1813,7 +1818,7 @@ non-nil, returns the face for expected results.." (defun ert-face-for-stats (stats) "Return a face that represents STATS." (cond ((ert--stats-aborted-p stats) 'nil) - ((plusp (ert-stats-completed-unexpected stats)) + ((cl-plusp (ert-stats-completed-unexpected stats)) (ert-face-for-test-result nil)) ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) (ert-face-for-test-result t)) @@ -1824,7 +1829,7 @@ non-nil, returns the face for expected results.." (let* ((test (ert--ewoc-entry-test entry)) (stats ert--results-stats) (result (let ((pos (ert--stats-test-pos stats test))) - (assert pos) + (cl-assert pos) (aref (ert--stats-test-results stats) pos))) (hiddenp (ert--ewoc-entry-hidden-p entry)) (expandedp (ert--ewoc-entry-expanded-p entry)) @@ -1850,7 +1855,7 @@ non-nil, returns the face for expected results.." (ert--string-first-line (ert-test-documentation test)) 'font-lock-face 'font-lock-doc-face) "\n")) - (etypecase result + (cl-etypecase result (ert-test-passed (if (ert-test-result-expected-p test result) (insert " passed\n") @@ -1908,9 +1913,10 @@ BUFFER-NAME, if non-nil, is the buffer name to use." (make-string (ert-stats-total stats) (ert-char-for-test-result nil t))) (set (make-local-variable 'ert--results-listener) listener) - (loop for test across (ert--stats-tests stats) do - (ewoc-enter-last ewoc - (make-ert--ewoc-entry :test test :hidden-p t))) + (cl-loop for test across (ert--stats-tests stats) do + (ewoc-enter-last ewoc + (make-ert--ewoc-entry :test test + :hidden-p t))) (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) (goto-char (1- (point-max))) buffer))))) @@ -1945,21 +1951,21 @@ and how to display message." default nil)) nil)) (unless message-fn (setq message-fn 'message)) - (lexical-let ((output-buffer-name output-buffer-name) - buffer - listener - (message-fn message-fn)) + (let ((output-buffer-name output-buffer-name) + buffer + listener + (message-fn message-fn)) (setq listener (lambda (event-type &rest event-args) - (ecase event-type + (cl-ecase event-type (run-started - (destructuring-bind (stats) event-args + (cl-destructuring-bind (stats) event-args (setq buffer (ert--setup-results-buffer stats listener output-buffer-name)) (pop-to-buffer buffer))) (run-ended - (destructuring-bind (stats abortedp) event-args + (cl-destructuring-bind (stats abortedp) event-args (funcall message-fn "%sRan %s tests, %s results were as expected%s" (if (not abortedp) @@ -1976,19 +1982,19 @@ and how to display message." ert--results-ewoc) stats))) (test-started - (destructuring-bind (stats test) event-args + (cl-destructuring-bind (stats test) event-args (with-current-buffer buffer (let* ((ewoc ert--results-ewoc) (pos (ert--stats-test-pos stats test)) (node (ewoc-nth ewoc pos))) - (assert node) + (cl-assert node) (setf (ert--ewoc-entry-test (ewoc-data node)) test) (aset ert--results-progress-bar-string pos (ert-char-for-test-result nil t)) (ert--results-update-stats-display-maybe ewoc stats) (ewoc-invalidate ewoc node))))) (test-ended - (destructuring-bind (stats test result) event-args + (cl-destructuring-bind (stats test result) event-args (with-current-buffer buffer (let* ((ewoc ert--results-ewoc) (pos (ert--stats-test-pos stats test)) @@ -2020,28 +2026,28 @@ and how to display message." (define-derived-mode ert-results-mode special-mode "ERT-Results" "Major mode for viewing results of ERT test runs.") -(loop for (key binding) in - '(;; Stuff that's not in the menu. - ("\t" forward-button) - ([backtab] backward-button) - ("j" ert-results-jump-between-summary-and-result) - ("L" ert-results-toggle-printer-limits-for-test-at-point) - ("n" ert-results-next-test) - ("p" ert-results-previous-test) - ;; Stuff that is in the menu. - ("R" ert-results-rerun-all-tests) - ("r" ert-results-rerun-test-at-point) - ("d" ert-results-rerun-test-at-point-debugging-errors) - ("." ert-results-find-test-at-point-other-window) - ("b" ert-results-pop-to-backtrace-for-test-at-point) - ("m" ert-results-pop-to-messages-for-test-at-point) - ("l" ert-results-pop-to-should-forms-for-test-at-point) - ("h" ert-results-describe-test-at-point) - ("D" ert-delete-test) - ("T" ert-results-pop-to-timings) - ) - do - (define-key ert-results-mode-map key binding)) +(cl-loop for (key binding) in + '( ;; Stuff that's not in the menu. + ("\t" forward-button) + ([backtab] backward-button) + ("j" ert-results-jump-between-summary-and-result) + ("L" ert-results-toggle-printer-limits-for-test-at-point) + ("n" ert-results-next-test) + ("p" ert-results-previous-test) + ;; Stuff that is in the menu. + ("R" ert-results-rerun-all-tests) + ("r" ert-results-rerun-test-at-point) + ("d" ert-results-rerun-test-at-point-debugging-errors) + ("." ert-results-find-test-at-point-other-window) + ("b" ert-results-pop-to-backtrace-for-test-at-point) + ("m" ert-results-pop-to-messages-for-test-at-point) + ("l" ert-results-pop-to-should-forms-for-test-at-point) + ("h" ert-results-describe-test-at-point) + ("D" ert-delete-test) + ("T" ert-results-pop-to-timings) + ) + do + (define-key ert-results-mode-map key binding)) (easy-menu-define ert-results-mode-menu ert-results-mode-map "Menu for `ert-results-mode'." @@ -2121,15 +2127,15 @@ To be used in the ERT results buffer." EWOC-FN specifies the direction and should be either `ewoc-prev' or `ewoc-next'. If there are no more nodes in that direction, an error is signaled with the message ERROR-MESSAGE." - (loop + (cl-loop (setq node (funcall ewoc-fn ert--results-ewoc node)) (when (null node) (error "%s" error-message)) (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) (goto-char (ewoc-location node)) - (return)))) + (cl-return)))) -(defun ert--results-expand-collapse-button-action (button) +(defun ert--results-expand-collapse-button-action (_button) "Expand or collapse the test node BUTTON belongs to." (let* ((ewoc ert--results-ewoc) (node (save-excursion @@ -2158,11 +2164,11 @@ To be used in the ERT results buffer." (defun ert--ewoc-position (ewoc node) ;; checkdoc-order: nil "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." - (loop for i from 0 - for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) - do (when (eql node node-here) - (return i)) - finally (return nil))) + (cl-loop for i from 0 + for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) + do (when (eql node node-here) + (cl-return i)) + finally (cl-return nil))) (defun ert-results-jump-between-summary-and-result () "Jump back and forth between the test run summary and individual test results. @@ -2210,7 +2216,7 @@ To be used in the ERT results buffer." "Return the test at point, or nil. To be used in the ERT results buffer." - (assert (eql major-mode 'ert-results-mode)) + (cl-assert (eql major-mode 'ert-results-mode)) (if (ert--results-test-node-or-null-at-point) (let* ((node (ert--results-test-node-at-point)) (test (ert--ewoc-entry-test (ewoc-data node)))) @@ -2282,9 +2288,9 @@ definition." (point)) ((eventp last-command-event) (posn-point (event-start last-command-event))) - (t (assert nil)))) + (t (cl-assert nil)))) -(defun ert--results-progress-bar-button-action (button) +(defun ert--results-progress-bar-button-action (_button) "Jump to details for the test represented by the character clicked in BUTTON." (goto-char (ert--button-action-position)) (ert-results-jump-between-summary-and-result)) @@ -2294,7 +2300,7 @@ definition." To be used in the ERT results buffer." (interactive) - (assert (eql major-mode 'ert-results-mode)) + (cl-assert (eql major-mode 'ert-results-mode)) (let ((selector (ert--stats-selector ert--results-stats))) (ert-run-tests-interactively selector (buffer-name)))) @@ -2303,13 +2309,13 @@ To be used in the ERT results buffer." To be used in the ERT results buffer." (interactive) - (destructuring-bind (test redefinition-state) + (cl-destructuring-bind (test redefinition-state) (ert--results-test-at-point-allow-redefinition) (when (null test) (error "No test at point")) (let* ((stats ert--results-stats) (progress-message (format "Running %stest %S" - (ecase redefinition-state + (cl-ecase redefinition-state ((nil) "") (redefined "new definition of ") (deleted "deleted ")) @@ -2350,7 +2356,7 @@ To be used in the ERT results buffer." (stats ert--results-stats) (pos (ert--stats-test-pos stats test)) (result (aref (ert--stats-test-results stats) pos))) - (etypecase result + (cl-etypecase result (ert-test-passed (error "Test passed, no backtrace available")) (ert-test-result-with-condition (let ((backtrace (ert-test-result-with-condition-backtrace result)) @@ -2408,13 +2414,14 @@ To be used in the ERT results buffer." (ert-simple-view-mode) (if (null (ert-test-result-should-forms result)) (insert "\n(No should forms during this test.)\n") - (loop for form-description in (ert-test-result-should-forms result) - for i from 1 do - (insert "\n") - (insert (format "%s: " i)) - (let ((begin (point))) - (ert--pp-with-indentation-and-newline form-description) - (ert--make-xrefs-region begin (point))))) + (cl-loop for form-description + in (ert-test-result-should-forms result) + for i from 1 do + (insert "\n") + (insert (format "%s: " i)) + (let ((begin (point))) + (ert--pp-with-indentation-and-newline form-description) + (ert--make-xrefs-region begin (point))))) (goto-char (point-min)) (insert "`should' forms executed during test `") (ert-insert-test-name-button (ert-test-name test)) @@ -2443,17 +2450,16 @@ To be used in the ERT results buffer." To be used in the ERT results buffer." (interactive) (let* ((stats ert--results-stats) - (start-times (ert--stats-test-start-times stats)) - (end-times (ert--stats-test-end-times stats)) (buffer (get-buffer-create "*ERT timings*")) - (data (loop for test across (ert--stats-tests stats) - for start-time across (ert--stats-test-start-times stats) - for end-time across (ert--stats-test-end-times stats) - collect (list test - (float-time (subtract-time end-time - start-time)))))) + (data (cl-loop for test across (ert--stats-tests stats) + for start-time across (ert--stats-test-start-times + stats) + for end-time across (ert--stats-test-end-times stats) + collect (list test + (float-time (subtract-time + end-time start-time)))))) (setq data (sort data (lambda (a b) - (> (second a) (second b))))) + (> (cl-second a) (cl-second b))))) (pop-to-buffer buffer) (let ((inhibit-read-only t)) (buffer-disable-undo) @@ -2462,13 +2468,13 @@ To be used in the ERT results buffer." (if (null data) (insert "(No data)\n") (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) - (loop for (test time) in data - for cumul-time = time then (+ cumul-time time) - for i from 1 do - (let ((begin (point))) - (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) - (ert-insert-test-name-button (ert-test-name test)) - (insert "\n")))) + (cl-loop for (test time) in data + for cumul-time = time then (+ cumul-time time) + for i from 1 do + (progn + (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n")))) (goto-char (point-min)) (insert "Tests by run time (seconds):\n\n") (forward-line 1)))) @@ -2481,7 +2487,7 @@ To be used in the ERT results buffer." (error "Requires Emacs 24")) (let (test-name test-definition) - (etypecase test-or-test-name + (cl-etypecase test-or-test-name (symbol (setq test-name test-or-test-name test-definition (ert-get-test test-or-test-name))) (ert-test (setq test-name (ert-test-name test-or-test-name) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 540e0166ec2..d9c5316b1b8 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -402,6 +402,56 @@ of the piece of advice." (if (fboundp function-name) (symbol-function function-name)))))) +;; When code is advised, called-interactively-p needs to be taught to skip +;; the advising frames. +;; FIXME: This Major Ugly Hack won't handle calls to called-interactively-p +;; done from the advised function if the deepest advice is an around advice! +;; In other cases (calls from an advice or calls from the advised function when +;; the deepest advice is not an around advice), it should hopefully get +;; it right. +(add-hook 'called-interactively-p-functions + #'advice--called-interactively-skip) +(defun advice--called-interactively-skip (origi frame1 frame2) + (let* ((i origi) + (get-next-frame + (lambda () + (setq frame1 frame2) + (setq frame2 (internal--called-interactively-p--get-frame i)) + ;; (message "Advice Frame %d = %S" i frame2) + (setq i (1+ i))))) + (when (and (eq (nth 1 frame2) 'apply) + (progn + (funcall get-next-frame) + (advice--p (indirect-function (nth 1 frame2))))) + (funcall get-next-frame) + ;; If we now have the symbol, this was the head advice and + ;; we're done. + (while (advice--p (nth 1 frame1)) + ;; This was an inner advice called from some earlier advice. + ;; The stack frames look different depending on the particular + ;; kind of the earlier advice. + (let ((inneradvice (nth 1 frame1))) + (if (and (eq (nth 1 frame2) 'apply) + (progn + (funcall get-next-frame) + (advice--p (indirect-function + (nth 1 frame2))))) + ;; The earlier advice was something like a before/after + ;; advice where the "next" code is called directly by the + ;; advice--p object. + (funcall get-next-frame) + ;; It's apparently an around advice, where the "next" is + ;; called by the body of the advice in any way it sees fit, + ;; so we need to skip the frames of that body. + (while + (progn + (funcall get-next-frame) + (not (and (eq (nth 1 frame2) 'apply) + (eq (nth 3 frame2) inneradvice))))) + (funcall get-next-frame) + (funcall get-next-frame)))) + (- i origi 1)))) + (provide 'nadvice) ;;; nadvice.el ends here diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index c6fff7aa443..722e6270e95 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -1,4 +1,4 @@ -;;; trace.el --- tracing facility for Emacs Lisp functions +;;; trace.el --- tracing facility for Emacs Lisp functions -*- lexical-binding: t -*- ;; Copyright (C) 1993, 1998, 2000-2012 Free Software Foundation, Inc. @@ -151,18 +151,15 @@ ;;; Code: -(require 'advice) - (defgroup trace nil "Tracing facility for Emacs Lisp functions." :prefix "trace-" :group 'lisp) ;;;###autoload -(defcustom trace-buffer (purecopy "*trace-output*") +(defcustom trace-buffer "*trace-output*" "Trace output will by default go to that buffer." - :type 'string - :group 'trace) + :type 'string) ;; Current level of traced function invocation: (defvar trace-level 0) @@ -176,78 +173,109 @@ (defvar inhibit-trace nil "If non-nil, all tracing is temporarily inhibited.") -(defun trace-entry-message (function level argument-bindings) - ;; Generates a string that describes that FUNCTION has been entered at - ;; trace LEVEL with ARGUMENT-BINDINGS. - (format "%s%s%d -> %s: %s\n" - (mapconcat 'char-to-string (make-string (1- level) ?|) " ") - (if (> level 1) " " "") - level - function - (let ((print-circle t)) - (mapconcat (lambda (binding) - (concat - (symbol-name (ad-arg-binding-field binding 'name)) - "=" - ;; do this so we'll see strings: - (prin1-to-string - (ad-arg-binding-field binding 'value)))) - argument-bindings - " ")))) - -(defun trace-exit-message (function level value) - ;; Generates a string that describes that FUNCTION has been exited at - ;; trace LEVEL and that it returned VALUE. - (format "%s%s%d <- %s: %s\n" - (mapconcat 'char-to-string (make-string (1- level) ?|) " ") - (if (> level 1) " " "") - level - function - ;; do this so we'll see strings: - (let ((print-circle t)) (prin1-to-string value)))) - -(defun trace-make-advice (function buffer background) - ;; Builds the piece of advice to be added to FUNCTION's advice info - ;; so that it will generate the proper trace output in BUFFER - ;; (quietly if BACKGROUND is t). - (ad-make-advice - trace-advice-name nil t - `(advice - lambda () - (let ((trace-level (1+ trace-level)) - (trace-buffer (get-buffer-create ,buffer))) - (unless inhibit-trace - (with-current-buffer trace-buffer - (set (make-local-variable 'window-point-insertion-type) t) - ,(unless background '(display-buffer trace-buffer)) - (goto-char (point-max)) - ;; Insert a separator from previous trace output: - (if (= trace-level 1) (insert trace-separator)) - (insert - (trace-entry-message - ',function trace-level ad-arg-bindings)))) - ad-do-it - (unless inhibit-trace - (with-current-buffer trace-buffer - ,(unless background '(display-buffer trace-buffer)) - (goto-char (point-max)) - (insert - (trace-exit-message - ',function trace-level ad-return-value)))))))) - -(defun trace-function-internal (function buffer background) - ;; Adds trace advice for FUNCTION and activates it. - (ad-add-advice - function - (trace-make-advice function (or buffer trace-buffer) background) - 'around 'last) - (ad-activate function nil)) +(defun trace-entry-message (function level args context) + "Generate a string that describes that FUNCTION has been entered. +LEVEL is the trace level, ARGS is the list of arguments passed to FUNCTION, +and CONTEXT is a string describing the dynamic context (e.g. values of +some global variables)." + (let ((print-circle t)) + (format "%s%s%d -> %S%s\n" + (mapconcat 'char-to-string (make-string (1- level) ?|) " ") + (if (> level 1) " " "") + level + (cons function args) + context))) + +(defun trace-exit-message (function level value context) + "Generate a string that describes that FUNCTION has exited. +LEVEL is the trace level, VALUE value returned by FUNCTION, +and CONTEXT is a string describing the dynamic context (e.g. values of +some global variables)." + (let ((print-circle t)) + (format "%s%s%d <- %s: %S%s\n" + (mapconcat 'char-to-string (make-string (1- level) ?|) " ") + (if (> level 1) " " "") + level + function + ;; Do this so we'll see strings: + value + context))) + +(defvar trace--timer nil) + +(defun trace-make-advice (function buffer background context) + "Build the piece of advice to be added to trace FUNCTION. +FUNCTION is the name of the traced function. +BUFFER is the buffer where the trace should be printed. +BACKGROUND if nil means to display BUFFER. +CONTEXT if non-nil should be a function that returns extra info that should +be printed along with the arguments in the trace." + (lambda (body &rest args) + (let ((trace-level (1+ trace-level)) + (trace-buffer (get-buffer-create buffer)) + (ctx (funcall context))) + (unless inhibit-trace + (with-current-buffer trace-buffer + (set (make-local-variable 'window-point-insertion-type) t) + (unless (or background trace--timer + (get-buffer-window trace-buffer 'visible)) + (setq trace--timer + ;; Postpone the display to some later time, in case we + ;; can't actually do it now. + (run-with-timer 0 nil + (lambda () + (setq trace--timer nil) + (display-buffer trace-buffer))))) + (goto-char (point-max)) + ;; Insert a separator from previous trace output: + (if (= trace-level 1) (insert trace-separator)) + (insert + (trace-entry-message + function trace-level args ctx)))) + (let ((result)) + (unwind-protect + (setq result (list (apply body args))) + (unless inhibit-trace + (let ((ctx (funcall context))) + (with-current-buffer trace-buffer + (unless background (display-buffer trace-buffer)) + (goto-char (point-max)) + (insert + (trace-exit-message + function + trace-level + (if result (car result) '\!non-local\ exit\!) + ctx)))))) + (car result))))) + +(defun trace-function-internal (function buffer background context) + "Add trace advice for FUNCTION." + (advice-add + function :around + (trace-make-advice function (or buffer trace-buffer) background + (or context (lambda () ""))) + `((name . ,trace-advice-name)))) (defun trace-is-traced (function) - (ad-find-advice function 'around trace-advice-name)) + (advice-member-p trace-advice-name function)) + +(defun trace--read-args (prompt) + (cons + (intern (completing-read prompt obarray 'fboundp t)) + (when current-prefix-arg + (list + (read-buffer "Output to buffer: " trace-buffer) + (let ((exp + (let ((minibuffer-completing-symbol t)) + (read-from-minibuffer "Context expression: " + nil read-expression-map t + 'read-expression-history)))) + `(lambda () + (let ((print-circle t)) + (concat " [" (prin1-to-string ,exp) "]")))))))) ;;;###autoload -(defun trace-function (function &optional buffer) +(defun trace-function-foreground (function &optional buffer context) "Traces FUNCTION with trace output going to BUFFER. For every call of FUNCTION Lisp-style trace messages that display argument and return values will be inserted into BUFFER. This function generates the @@ -255,14 +283,11 @@ trace advice for FUNCTION and activates it together with any other advice there might be!! The trace BUFFER will popup whenever FUNCTION is called. Do not use this to trace functions that switch buffers or do any other display oriented stuff, use `trace-function-background' instead." - (interactive - (list - (intern (completing-read "Trace function: " obarray 'fboundp t)) - (read-buffer "Output to buffer: " trace-buffer))) - (trace-function-internal function buffer nil)) + (interactive (trace--read-args "Trace function: ")) + (trace-function-internal function buffer nil context)) ;;;###autoload -(defun trace-function-background (function &optional buffer) +(defun trace-function-background (function &optional buffer context) "Traces FUNCTION with trace output going quietly to BUFFER. When this tracing is enabled, every call to FUNCTION writes a Lisp-style trace message (showing the arguments and return value) @@ -272,12 +297,11 @@ The trace output goes to BUFFER quietly, without changing the window or buffer configuration. BUFFER defaults to `trace-buffer'." - (interactive - (list - (intern - (completing-read "Trace function in background: " obarray 'fboundp t)) - (read-buffer "Output to buffer: " trace-buffer))) - (trace-function-internal function buffer t)) + (interactive (trace--read-args "Trace function in background: ")) + (trace-function-internal function buffer t context)) + +;;;###autoload +(defalias 'trace-function 'trace-function-foreground) (defun untrace-function (function) "Untraces FUNCTION and possibly activates all remaining advice. @@ -285,16 +309,14 @@ Activation is performed with `ad-update', hence remaining advice will get activated only if the advice of FUNCTION is currently active. If FUNCTION was not traced this is a noop." (interactive - (list (ad-read-advised-function "Untrace function" 'trace-is-traced))) - (when (trace-is-traced function) - (ad-remove-advice function 'around trace-advice-name) - (ad-update function))) + (list (intern (completing-read "Untrace function: " + obarray #'trace-is-traced t)))) + (advice-remove function trace-advice-name)) (defun untrace-all () "Untraces all currently traced functions." (interactive) - (ad-do-advised-functions (function) - (untrace-function function))) + (mapatoms #'untrace-function)) (provide 'trace) diff --git a/lisp/erc/ChangeLog b/lisp/erc/ChangeLog index e0a88461dc9..ca7edd1aa88 100644 --- a/lisp/erc/ChangeLog +++ b/lisp/erc/ChangeLog @@ -1,3 +1,16 @@ +2012-11-19 Stefan Monnier <monnier@iro.umontreal.ca> + + Use cl-lib instead of cl, and interactive-p => called-interactively-p. + * erc-track.el, erc-networks.el, erc-netsplit.el, erc-dcc.el: + * erc-backend.el: Use cl-lib, nth, pcase, and called-interactively-p + instead of cl. + * erc-speedbar.el, erc-services.el, erc-pcomplete.el, erc-notify.el: + * erc-match.el, erc-log.el, erc-join.el, erc-ezbounce.el: + * erc-capab.el: Don't require cl since we don't use it. + * erc.el: Use cl-lib, nth, pcase, and called-interactively-p i.s.o cl. + (erc-lurker-ignore-chars, erc-common-server-suffixes): + Move before first use. + 2012-11-16 Glenn Morris <rgm@gnu.org> * erc.el (erc-modules): Add "notifications". Tweak "hecomplete" doc. diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 90b96d7c763..a3d0ebe121f 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -98,7 +98,7 @@ ;;; Code: (require 'erc-compat) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; There's a fairly strong mutual dependency between erc.el and erc-backend.el. ;; Luckily, erc.el does not need erc-backend.el for macroexpansion whereas the ;; reverse is true: @@ -109,7 +109,7 @@ (defvar erc-server-responses (make-hash-table :test #'equal) "Hashtable mapping server responses to their handler hooks.") -(defstruct (erc-response (:conc-name erc-response.)) +(cl-defstruct (erc-response (:conc-name erc-response.)) (unparsed "" :type string) (sender "" :type string) (command "" :type string) @@ -950,7 +950,7 @@ PROCs `process-buffer' is `current-buffer' when this function is called." (push str (erc-response.command-args msg)))) (setf (erc-response.contents msg) - (first (erc-response.command-args msg))) + (car (erc-response.command-args msg))) (setf (erc-response.command-args msg) (nreverse (erc-response.command-args msg))) @@ -1045,7 +1045,7 @@ Finds hooks by looking in the `erc-server-responses' hashtable." (name &rest name) &optional sexp sexp def-body)) -(defmacro* define-erc-response-handler ((name &rest aliases) +(cl-defmacro define-erc-response-handler ((name &rest aliases) &optional extra-fn-doc extra-var-doc &rest fn-body) "Define an ERC handler hook/function pair. @@ -1154,11 +1154,11 @@ add things to `%s' instead." "") name hook-name)) (fn-alternates - (loop for alias in aliases - collect (intern (format "erc-server-%s" alias)))) + (cl-loop for alias in aliases + collect (intern (format "erc-server-%s" alias)))) (var-alternates - (loop for alias in aliases - collect (intern (format "erc-server-%s-functions" alias))))) + (cl-loop for alias in aliases + collect (intern (format "erc-server-%s-functions" alias))))) `(prog2 ;; Normal hook variable. (defvar ,hook-name ',fn-name ,(format hook-doc name)) @@ -1172,19 +1172,19 @@ add things to `%s' instead." (put ',hook-name 'definition-name ',name) ;; Hashtable map of responses to hook variables - ,@(loop for response in (cons name aliases) - for var in (cons hook-name var-alternates) - collect `(puthash ,(format "%s" response) ',var - erc-server-responses)) + ,@(cl-loop for response in (cons name aliases) + for var in (cons hook-name var-alternates) + collect `(puthash ,(format "%s" response) ',var + erc-server-responses)) ;; Alternates. ;; Functions are defaliased, hook variables are defvared so we ;; can add hooks to one alias, but not another. - ,@(loop for fn in fn-alternates - for var in var-alternates - for a in aliases - nconc (list `(defalias ',fn ',fn-name) - `(defvar ,var ',fn-name ,(format hook-doc a)) - `(put ',var 'definition-name ',hook-name)))))) + ,@(cl-loop for fn in fn-alternates + for var in var-alternates + for a in aliases + nconc (list `(defalias ',fn ',fn-name) + `(defvar ,var ',fn-name ,(format hook-doc a)) + `(put ',var 'definition-name ',hook-name)))))) (define-erc-response-handler (ERROR) "Handle an ERROR command from the server." nil @@ -1196,10 +1196,10 @@ add things to `%s' instead." (define-erc-response-handler (INVITE) "Handle invitation messages." nil - (let ((target (first (erc-response.command-args parsed))) + (let ((target (car (erc-response.command-args parsed))) (chnl (erc-response.contents parsed))) - (multiple-value-bind (nick login host) - (values-list (erc-parse-user (erc-response.sender parsed))) + (pcase-let ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) (setq erc-invitation chnl) (when (string= target (erc-current-nick)) (erc-display-message @@ -1212,8 +1212,8 @@ add things to `%s' instead." nil (let ((chnl (erc-response.contents parsed)) (buffer nil)) - (multiple-value-bind (nick login host) - (values-list (erc-parse-user (erc-response.sender parsed))) + (pcase-let ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) ;; strip the stupid combined JOIN facility (IRC 2.9) (if (string-match "^\\(.*\\)?\^g.*$" chnl) (setq chnl (match-string 1 chnl))) @@ -1249,12 +1249,12 @@ add things to `%s' instead." (define-erc-response-handler (KICK) "Handle kick messages received from the server." nil - (let* ((ch (first (erc-response.command-args parsed))) - (tgt (second (erc-response.command-args parsed))) + (let* ((ch (nth 0 (erc-response.command-args parsed))) + (tgt (nth 1 (erc-response.command-args parsed))) (reason (erc-trim-string (erc-response.contents parsed))) (buffer (erc-get-buffer ch proc))) - (multiple-value-bind (nick login host) - (values-list (erc-parse-user (erc-response.sender parsed))) + (pcase-let ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) (erc-remove-channel-member buffer tgt) (cond ((string= tgt (erc-current-nick)) @@ -1277,11 +1277,11 @@ add things to `%s' instead." (define-erc-response-handler (MODE) "Handle server mode changes." nil - (let ((tgt (first (erc-response.command-args parsed))) + (let ((tgt (car (erc-response.command-args parsed))) (mode (mapconcat 'identity (cdr (erc-response.command-args parsed)) " "))) - (multiple-value-bind (nick login host) - (values-list (erc-parse-user (erc-response.sender parsed))) + (pcase-let ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) (erc-log (format "MODE: %s -> %s: %s" nick tgt mode)) ;; dirty hack (let ((buf (cond ((erc-channel-p tgt) @@ -1305,8 +1305,8 @@ add things to `%s' instead." "Handle nick change messages." nil (let ((nn (erc-response.contents parsed)) bufs) - (multiple-value-bind (nick login host) - (values-list (erc-parse-user (erc-response.sender parsed))) + (pcase-let ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) (setq bufs (erc-buffer-list-with-nick nick proc)) (erc-log (format "NICK: %s -> %s" nick nn)) ;; if we had a query with this user, make sure future messages will be @@ -1340,11 +1340,11 @@ add things to `%s' instead." (define-erc-response-handler (PART) "Handle part messages." nil - (let* ((chnl (first (erc-response.command-args parsed))) + (let* ((chnl (car (erc-response.command-args parsed))) (reason (erc-trim-string (erc-response.contents parsed))) (buffer (erc-get-buffer chnl proc))) - (multiple-value-bind (nick login host) - (values-list (erc-parse-user (erc-response.sender parsed))) + (pcase-let ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) (erc-remove-channel-member buffer nick) (erc-display-message parsed 'notice buffer 'PART ?n nick ?u login @@ -1361,7 +1361,7 @@ add things to `%s' instead." (define-erc-response-handler (PING) "Handle ping messages." nil - (let ((pinger (first (erc-response.command-args parsed)))) + (let ((pinger (car (erc-response.command-args parsed)))) (erc-log (format "PING: %s" pinger)) ;; ping response to the server MUST be forced, or you can lose big (erc-server-send (format "PONG :%s" pinger) t) @@ -1379,7 +1379,7 @@ add things to `%s' instead." (when erc-verbose-server-ping (erc-display-message parsed 'notice proc 'PONG - ?h (first (erc-response.command-args parsed)) ?i erc-server-lag + ?h (car (erc-response.command-args parsed)) ?i erc-server-lag ?s (if (/= erc-server-lag 1) "s" ""))) (erc-update-mode-line)))) @@ -1451,8 +1451,8 @@ add things to `%s' instead." "Another user has quit IRC." nil (let ((reason (erc-response.contents parsed)) bufs) - (multiple-value-bind (nick login host) - (values-list (erc-parse-user (erc-response.sender parsed))) + (pcase-let ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) (setq bufs (erc-buffer-list-with-nick nick proc)) (erc-remove-user nick) (setq reason (erc-wash-quit-reason reason nick login host)) @@ -1462,12 +1462,12 @@ add things to `%s' instead." (define-erc-response-handler (TOPIC) "The channel topic has changed." nil - (let* ((ch (first (erc-response.command-args parsed))) + (let* ((ch (car (erc-response.command-args parsed))) (topic (erc-trim-string (erc-response.contents parsed))) (time (format-time-string erc-server-timestamp-format (current-time)))) - (multiple-value-bind (nick login host) - (values-list (erc-parse-user (erc-response.sender parsed))) + (pcase-let ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) (erc-update-channel-member ch nick nick nil nil nil host login) (erc-update-channel-topic ch (format "%s\C-o (%s, %s)" topic nick time)) (erc-display-message parsed 'notice (erc-get-buffer ch proc) @@ -1477,8 +1477,8 @@ add things to `%s' instead." (define-erc-response-handler (WALLOPS) "Display a WALLOPS message." nil (let ((message (erc-response.contents parsed))) - (multiple-value-bind (nick login host) - (values-list (erc-parse-user (erc-response.sender parsed))) + (pcase-let ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) (erc-display-message parsed 'notice nil 'WALLOPS ?n nick ?m message)))) @@ -1486,7 +1486,7 @@ add things to `%s' instead." (define-erc-response-handler (001) "Set `erc-server-current-nick' to reflect server settings and display the welcome message." nil - (erc-set-current-nick (first (erc-response.command-args parsed))) + (erc-set-current-nick (car (erc-response.command-args parsed))) (erc-update-mode-line) ; needed here? (setq erc-nick-change-attempt-count 0) (setq erc-default-nicks (if (consp erc-nick) erc-nick (list erc-nick))) @@ -1507,16 +1507,16 @@ add things to `%s' instead." (define-erc-response-handler (004) "Display the server's identification." nil - (multiple-value-bind (server-name server-version) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,server-name ,server-version) + (cdr (erc-response.command-args parsed)))) (setq erc-server-version server-version) (setq erc-server-announced-name server-name) (erc-update-mode-line-buffer (process-buffer proc)) (erc-display-message parsed 'notice proc 's004 ?s server-name ?v server-version - ?U (fourth (erc-response.command-args parsed)) - ?C (fifth (erc-response.command-args parsed))))) + ?U (nth 3 (erc-response.command-args parsed)) + ?C (nth 4 (erc-response.command-args parsed))))) (define-erc-response-handler (005) "Set the variable `erc-server-parameters' and display the received message. @@ -1547,7 +1547,7 @@ A server may send more than one 005 message." (define-erc-response-handler (221) "Display the current user modes." nil - (let* ((nick (first (erc-response.command-args parsed))) + (let* ((nick (car (erc-response.command-args parsed))) (modes (mapconcat 'identity (cdr (erc-response.command-args parsed)) " "))) (erc-set-modes nick modes) @@ -1576,8 +1576,8 @@ See `erc-display-server-message'." nil (define-erc-response-handler (275) "Display secure connection message." nil - (multiple-value-bind (nick user message) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,nick ,user ,message) + (cdr (erc-response.command-args parsed)))) (erc-display-message parsed 'notice 'active 's275 ?n nick @@ -1612,8 +1612,8 @@ See `erc-display-server-message'." nil (define-erc-response-handler (307) "Display nick-identified message." nil - (multiple-value-bind (nick user message) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,nick ,user ,message) + (cdr (erc-response.command-args parsed)))) (erc-display-message parsed 'notice 'active 's307 ?n nick @@ -1624,8 +1624,8 @@ See `erc-display-server-message'." nil "WHOIS/WHOWAS notices." nil (let ((fname (erc-response.contents parsed)) (catalog-entry (intern (format "s%s" (erc-response.command parsed))))) - (multiple-value-bind (nick user host) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,nick ,user ,host) + (cdr (erc-response.command-args parsed)))) (erc-update-user-nick nick nick host nil fname user) (erc-display-message parsed 'notice 'active catalog-entry @@ -1633,8 +1633,8 @@ See `erc-display-server-message'." nil (define-erc-response-handler (312) "Server name response in WHOIS." nil - (multiple-value-bind (nick server-host) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,nick ,server-host)) + (cdr (erc-response.command-args parsed))) (erc-display-message parsed 'notice 'active 's312 ?n nick ?s server-host ?c (erc-response.contents parsed)))) @@ -1655,8 +1655,8 @@ See `erc-display-server-message'." nil (define-erc-response-handler (317) "IDLE notice." nil - (multiple-value-bind (nick seconds-idle on-since time) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,nick ,seconds-idle ,on-since ,time) + (cdr (erc-response.command-args parsed)))) (setq time (when on-since (format-time-string erc-server-timestamp-format (erc-string-to-emacs-time on-since)))) @@ -1696,16 +1696,16 @@ See `erc-display-server-message'." nil (define-erc-response-handler (322) "LIST notice." nil (let ((topic (erc-response.contents parsed))) - (multiple-value-bind (channel num-users) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,channel ,num-users) + (cdr (erc-response.command-args parsed)))) (add-to-list 'erc-channel-list (list channel)) (erc-update-channel-topic channel topic)))) (defun erc-server-322-message (proc parsed) "Display a message for the 322 event." (let ((topic (erc-response.contents parsed))) - (multiple-value-bind (channel num-users) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,channel ,num-users) + (cdr (erc-response.command-args parsed)))) (erc-display-message parsed 'notice proc 's322 ?c channel ?u num-users ?t (or topic ""))))) @@ -1732,7 +1732,7 @@ See `erc-display-server-message'." nil "Channel creation date." nil (let ((channel (second (erc-response.command-args parsed))) (time (erc-string-to-emacs-time - (third (erc-response.command-args parsed))))) + (nth 2 (erc-response.command-args parsed))))) (erc-display-message parsed 'notice (erc-get-buffer channel proc) 's329 ?c channel ?t (format-time-string erc-server-timestamp-format @@ -1749,7 +1749,7 @@ See `erc-display-server-message'." nil ;; authmsg == (aref parsed 5) ;; The guesses below are, well, just that. -- Lawrence 2004/05/10 (let ((nick (second (erc-response.command-args parsed))) - (authaccount (third (erc-response.command-args parsed))) + (authaccount (nth 2 (erc-response.command-args parsed))) (authmsg (erc-response.contents parsed))) (erc-display-message parsed 'notice 'active 's330 ?n nick ?a authmsg ?i authaccount))) @@ -1771,8 +1771,8 @@ See `erc-display-server-message'." nil (define-erc-response-handler (333) "Who set the topic, and when." nil - (multiple-value-bind (channel nick time) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,channel ,nick ,time) + (cdr (erc-response.command-args parsed)))) (setq time (format-time-string erc-server-timestamp-format (erc-string-to-emacs-time time))) (erc-update-channel-topic channel @@ -1784,15 +1784,15 @@ See `erc-display-server-message'." nil (define-erc-response-handler (341) "Let user know when an INVITE attempt has been sent successfully." nil - (multiple-value-bind (nick channel) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,nick ,channel) + (cdr (erc-response.command-args parsed)))) (erc-display-message parsed 'notice (erc-get-buffer channel proc) 's341 ?n nick ?c channel))) (define-erc-response-handler (352) "WHO notice." nil - (multiple-value-bind (channel user host server nick away-flag) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,channel ,user ,host ,server ,nick ,away-flag) + (cdr (erc-response.command-args parsed)))) (let ((full-name (erc-response.contents parsed)) hopcount) (when (string-match "\\(^[0-9]+ \\)\\(.*\\)$" full-name) @@ -1806,7 +1806,7 @@ See `erc-display-server-message'." nil (define-erc-response-handler (353) "NAMES notice." nil - (let ((channel (third (erc-response.command-args parsed))) + (let ((channel (nth 2 (erc-response.command-args parsed))) (users (erc-response.contents parsed))) (erc-display-message parsed 'notice (or (erc-get-buffer channel proc) 'active) @@ -1821,8 +1821,8 @@ See `erc-display-server-message'." nil (define-erc-response-handler (367) "Channel ban list entries." nil - (multiple-value-bind (channel banmask setter time) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,channel ,banmask ,setter ,time) + (cdr (erc-response.command-args parsed)))) ;; setter and time are not standard (if setter (erc-display-message parsed 'notice 'active 's367-set-by @@ -1845,8 +1845,8 @@ See `erc-display-server-message'." nil ;; FIXME: Yet more magic numbers in original code, I'm guessing this ;; command takes two arguments, and doesn't have any "contents". -- ;; Lawrence 2004/05/10 - (multiple-value-bind (from to) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,from ,to) + (cdr (erc-response.command-args parsed)))) (erc-display-message parsed 'notice 'active 's379 ?c from ?f to))) @@ -1855,7 +1855,7 @@ See `erc-display-server-message'." nil (erc-display-message parsed 'notice 'active 's391 ?s (second (erc-response.command-args parsed)) - ?t (third (erc-response.command-args parsed)))) + ?t (nth 2 (erc-response.command-args parsed)))) (define-erc-response-handler (401) "No such nick/channel." nil diff --git a/lisp/erc/erc-capab.el b/lisp/erc/erc-capab.el index 08b9c67f6c0..e8201f2ea43 100644 --- a/lisp/erc/erc-capab.el +++ b/lisp/erc/erc-capab.el @@ -68,7 +68,6 @@ ;;; Code: (require 'erc) -(eval-when-compile (require 'cl)) ;;; Customization: diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index ed8440315eb..e31416f0e1a 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -54,9 +54,7 @@ ;;; Code: (require 'erc) -(eval-when-compile - (require 'cl) - (require 'pcomplete)) +(eval-when-compile (require 'pcomplete)) ;;;###autoload (autoload 'erc-dcc-mode "erc-dcc") (define-erc-module dcc nil @@ -277,7 +275,7 @@ Argument IP is the address as a string. The result is also a string." (* (nth 1 ips) 65536.0) (* (nth 2 ips) 256.0) (nth 3 ips)))) - (if (interactive-p) + (if (called-interactively-p 'interactive) (message "%s is %.0f" ip res) (format "%.0f" res))))) @@ -380,8 +378,8 @@ created subprocess, or nil." (with-no-warnings ; obsolete since 23.1 (set-process-filter-multibyte process nil))))) (file-error - (unless (and (string= "Cannot bind server socket" (cadr err)) - (string= "address already in use" (caddr err))) + (unless (and (string= "Cannot bind server socket" (nth 1 err)) + (string= "address already in use" (nth 2 err))) (signal (car err) (cdr err))) (setq port (1+ port)) (unless (< port upper) @@ -434,38 +432,38 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc." (pcomplete-here (append '("chat" "close" "get" "list") (when (fboundp 'make-network-process) '("send")))) (pcomplete-here - (case (intern (downcase (pcomplete-arg 1))) - (chat (mapcar (lambda (elt) (plist-get elt :nick)) + (pcase (intern (downcase (pcomplete-arg 1))) + (`chat (mapcar (lambda (elt) (plist-get elt :nick)) + (erc-remove-if-not + #'(lambda (elt) + (eq (plist-get elt :type) 'CHAT)) + erc-dcc-list))) + (`close (erc-delete-dups + (mapcar (lambda (elt) (symbol-name (plist-get elt :type))) + erc-dcc-list))) + (`get (mapcar #'erc-dcc-nick (erc-remove-if-not #'(lambda (elt) - (eq (plist-get elt :type) 'CHAT)) + (eq (plist-get elt :type) 'GET)) erc-dcc-list))) - (close (erc-delete-dups - (mapcar (lambda (elt) (symbol-name (plist-get elt :type))) - erc-dcc-list))) - (get (mapcar #'erc-dcc-nick - (erc-remove-if-not - #'(lambda (elt) - (eq (plist-get elt :type) 'GET)) - erc-dcc-list))) - (send (pcomplete-erc-all-nicks)))) + (`send (pcomplete-erc-all-nicks)))) (pcomplete-here - (case (intern (downcase (pcomplete-arg 2))) - (get (mapcar (lambda (elt) (plist-get elt :file)) - (erc-remove-if-not - #'(lambda (elt) - (and (eq (plist-get elt :type) 'GET) - (erc-nick-equal-p (erc-extract-nick - (plist-get elt :nick)) - (pcomplete-arg 1)))) - erc-dcc-list))) - (close (mapcar #'erc-dcc-nick - (erc-remove-if-not - #'(lambda (elt) - (eq (plist-get elt :type) - (intern (upcase (pcomplete-arg 1))))) - erc-dcc-list))) - (send (pcomplete-entries))))) + (pcase (intern (downcase (pcomplete-arg 2))) + (`get (mapcar (lambda (elt) (plist-get elt :file)) + (erc-remove-if-not + #'(lambda (elt) + (and (eq (plist-get elt :type) 'GET) + (erc-nick-equal-p (erc-extract-nick + (plist-get elt :nick)) + (pcomplete-arg 1)))) + erc-dcc-list))) + (`close (mapcar #'erc-dcc-nick + (erc-remove-if-not + #'(lambda (elt) + (eq (plist-get elt :type) + (intern (upcase (pcomplete-arg 1))))) + erc-dcc-list))) + (`send (pcomplete-entries))))) (defun erc-dcc-do-CHAT-command (proc &optional nick) (when nick @@ -1248,7 +1246,7 @@ other client." (defun erc-dcc-no-such-nick (proc parsed) "Detect and handle no-such-nick replies from the IRC server." - (let* ((elt (erc-dcc-member :nick (second (erc-response.command-args parsed)) + (let* ((elt (erc-dcc-member :nick (nth 1 (erc-response.command-args parsed)) :parent proc)) (peer (plist-get elt :peer))) (when (or (and (processp peer) (not (eq (process-status peer) 'open))) diff --git a/lisp/erc/erc-ezbounce.el b/lisp/erc/erc-ezbounce.el index 5e5d6c2c188..6bcc17e4bc0 100644 --- a/lisp/erc/erc-ezbounce.el +++ b/lisp/erc/erc-ezbounce.el @@ -26,7 +26,6 @@ ;;; Code: (require 'erc) -(eval-when-compile (require 'cl)) (defgroup erc-ezbounce nil "Interface to the EZBounce IRC bouncer (a virtual IRC server)" diff --git a/lisp/erc/erc-join.el b/lisp/erc/erc-join.el index ac6b311a0c4..e285cfb4ec5 100644 --- a/lisp/erc/erc-join.el +++ b/lisp/erc/erc-join.el @@ -34,7 +34,6 @@ (require 'erc) (require 'auth-source) -(eval-when-compile (require 'cl)) (defgroup erc-autojoin nil "Enable autojoining." diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el index b3f3f5865a1..1ff2951e09e 100644 --- a/lisp/erc/erc-log.el +++ b/lisp/erc/erc-log.el @@ -93,9 +93,7 @@ ;;; Code: (require 'erc) -(eval-when-compile - (require 'erc-networks) - (require 'cl)) +(eval-when-compile (require 'erc-networks)) (defgroup erc-log nil "Logging facilities for ERC." @@ -429,7 +427,8 @@ You can save every individual message by putting this function on file t 'nomessage)))) (let ((coding-system-for-write coding-system)) (write-region start end file t 'nomessage)))) - (if (and erc-truncate-buffer-on-save (interactive-p)) + (if (and erc-truncate-buffer-on-save + (called-interactively-p 'interactive)) (progn (let ((inhibit-read-only t)) (erase-buffer)) (move-marker erc-last-saved-position (point-max)) diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index 8dcdcb9e2e6..f1219427360 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -35,7 +35,6 @@ ;;; Code: (require 'erc) -(eval-when-compile (require 'cl)) ;; Customization: diff --git a/lisp/erc/erc-netsplit.el b/lisp/erc/erc-netsplit.el index fc4aeb10c84..cbaf62b1a61 100644 --- a/lisp/erc/erc-netsplit.el +++ b/lisp/erc/erc-netsplit.el @@ -31,7 +31,6 @@ ;;; Code: (require 'erc) -(eval-when-compile (require 'cl)) (defgroup erc-netsplit nil "Netsplit detection tries to automatically figure when a @@ -107,7 +106,7 @@ join from that split has been detected or not.") (dolist (elt erc-netsplit-list) (if (member nick (nthcdr 3 elt)) (progn - (if (not (caddr elt)) + (if (not (nth 2 elt)) (progn (erc-display-message parsed 'notice (process-buffer proc) @@ -149,7 +148,7 @@ join from that split has been detected or not.") ;; element for this netsplit exists already (progn (setcdr (nthcdr 2 ass) (cons nick (nthcdr 3 ass))) - (when (caddr ass) + (when (nth 2 ass) ;; There was already a netjoin for this netsplit, it ;; seems like the old one didn't get finished... (erc-display-message @@ -194,7 +193,7 @@ join from that split has been detected or not.") nil 'notice 'active 'netsplit-wholeft ?s (car elt) ?n (mapconcat 'erc-extract-nick (nthcdr 3 elt) " ") - ?t (if (caddr elt) + ?t (if (nth 2 elt) "(joining)" ""))))) t) diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index 89372555ccc..5089ff6b4ba 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -40,7 +40,7 @@ ;;; Code: (require 'erc) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; Variables @@ -729,10 +729,10 @@ search for a match in `erc-networks-alist'." (or ;; Loop through `erc-networks-alist' looking for a match. (let ((server (or erc-server-announced-name erc-session-server))) - (loop for (name matcher) in erc-networks-alist - when (and matcher - (string-match (concat matcher "\\'") server)) - do (return name))) + (cl-loop for (name matcher) in erc-networks-alist + when (and matcher + (string-match (concat matcher "\\'") server)) + do (cl-return name))) 'Unknown))) (defun erc-network () @@ -789,8 +789,8 @@ As an example: (cond ((numberp p) (push p result)) ((listp p) - (setq result (nconc (loop for i from (cadr p) downto (car p) - collect i) + (setq result (nconc (cl-loop for i from (cadr p) downto (car p) + collect i) result))))) (nreverse result))) diff --git a/lisp/erc/erc-notify.el b/lisp/erc/erc-notify.el index 0b5e99180d6..b9d7ff78cd8 100644 --- a/lisp/erc/erc-notify.el +++ b/lisp/erc/erc-notify.el @@ -30,9 +30,7 @@ (require 'erc) (require 'erc-networks) -(eval-when-compile - (require 'cl) - (require 'pcomplete)) +(eval-when-compile (require 'pcomplete)) ;;;; Customizable variables diff --git a/lisp/erc/erc-pcomplete.el b/lisp/erc/erc-pcomplete.el index bb30fd90066..d6bb8019b15 100644 --- a/lisp/erc/erc-pcomplete.el +++ b/lisp/erc/erc-pcomplete.el @@ -43,7 +43,6 @@ (require 'erc) (require 'erc-compat) (require 'time-date) -(eval-when-compile (require 'cl)) (defgroup erc-pcomplete nil "Programmable completion for ERC" diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el index b3b80a5f851..b75ad8e9517 100644 --- a/lisp/erc/erc-services.el +++ b/lisp/erc/erc-services.el @@ -62,7 +62,7 @@ (require 'erc) (require 'erc-networks) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; Customization: diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index 4b98cf173be..22053945159 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el @@ -38,7 +38,6 @@ (require 'erc) (require 'speedbar) (condition-case nil (require 'dframe) (error nil)) -(eval-when-compile (require 'cl)) ;;; Customization: diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index a204584b400..976d2a21030 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -34,7 +34,7 @@ ;; * Add extensibility so that custom functions can track ;; custom modification types. -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'erc) (require 'erc-compat) (require 'erc-match) @@ -484,7 +484,7 @@ START is the minimum length of the name used." ;;; Test: -(assert +(cl-assert (and ;; verify examples from the doc strings (equal (let ((erc-track-shorten-aggressively nil)) @@ -869,7 +869,7 @@ Use `erc-make-mode-line-buffer-name' to create buttons." (setq erc-modified-channels-alist (delete (assq buffer erc-modified-channels-alist) erc-modified-channels-alist)) - (when (interactive-p) + (when (called-interactively-p 'interactive) (erc-modified-channels-display))) (defun erc-track-find-face (faces) @@ -980,7 +980,7 @@ is in `erc-mode'." (add-to-list 'faces cur))) faces)) -(assert +(cl-assert (let ((str "is bold")) (put-text-property 3 (length str) 'face '(bold erc-current-nick-face) @@ -1030,17 +1030,17 @@ relative to `erc-track-switch-direction'" (let ((dir erc-track-switch-direction) offset) (when (< arg 0) - (setq dir (case dir - (oldest 'newest) - (newest 'oldest) - (mostactive 'leastactive) - (leastactive 'mostactive) - (importance 'oldest))) + (setq dir (pcase dir + (`oldest 'newest) + (`newest 'oldest) + (`mostactive 'leastactive) + (`leastactive 'mostactive) + (`importance 'oldest))) (setq arg (- arg))) - (setq offset (case dir - ((oldest leastactive) + (setq offset (pcase dir + ((or `oldest `leastactive) (- (length erc-modified-channels-alist) arg)) - (t (1- arg)))) + (_ (1- arg)))) ;; normalize out of range user input (cond ((>= offset (length erc-modified-channels-alist)) (setq offset (1- (length erc-modified-channels-alist)))) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 7cb6fbb595b..cec9718e751 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -67,7 +67,7 @@ (defconst erc-version-string "Version 5.3" "ERC version. This is used by function `erc-version'.") -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'font-lock) (require 'pp) (require 'thingatpt) @@ -369,7 +369,7 @@ If no server buffer exists, return nil." (with-current-buffer ,buffer ,@body))))) -(defstruct (erc-server-user (:type vector) :named) +(cl-defstruct (erc-server-user (:type vector) :named) ;; User data nickname host login full-name info ;; Buffers @@ -379,7 +379,7 @@ If no server buffer exists, return nil." (buffers nil) ) -(defstruct (erc-channel-user (:type vector) :named) +(cl-defstruct (erc-channel-user (:type vector) :named) op voice ;; Last message time (in the form of the return value of ;; (current-time) @@ -1386,7 +1386,7 @@ If BUFFER is nil, the current buffer is used." t)) (erc-server-send (format "ISON %s" nick)) (while (eq erc-online-p 'unknown) (accept-process-output)) - (if (interactive-p) + (if (called-interactively-p 'interactive) (message "%s is %sonline" (or erc-online-p nick) (if erc-online-p "" "not ")) @@ -2157,11 +2157,11 @@ functions in here get called with the parameters SERVER and NICK." (list :server server :port port :nick nick :password passwd))) ;;;###autoload -(defun* erc (&key (server (erc-compute-server)) - (port (erc-compute-port)) - (nick (erc-compute-nick)) - password - (full-name (erc-compute-full-name))) +(cl-defun erc (&key (server (erc-compute-server)) + (port (erc-compute-port)) + (nick (erc-compute-nick)) + password + (full-name (erc-compute-full-name))) "ERC is a powerful, modular, and extensible IRC client. This function is the main entry point for ERC. @@ -2383,24 +2383,24 @@ If STRING is nil, the function does nothing." (while list (setq elt (car list)) (cond ((integerp elt) ; POSITION - (incf (car list) shift)) + (cl-incf (car list) shift)) ((or (atom elt) ; nil, EXTENT ;; (eq t (car elt)) ; (t . TIME) (markerp (car elt))) ; (MARKER . DISTANCE) nil) ((integerp (car elt)) ; (BEGIN . END) - (incf (car elt) shift) - (incf (cdr elt) shift)) + (cl-incf (car elt) shift) + (cl-incf (cdr elt) shift)) ((stringp (car elt)) ; (TEXT . POSITION) - (incf (cdr elt) (* (if (natnump (cdr elt)) 1 -1) shift))) + (cl-incf (cdr elt) (* (if (natnump (cdr elt)) 1 -1) shift))) ((null (car elt)) ; (nil PROPERTY VALUE BEG . END) (let ((cons (nthcdr 3 elt))) - (incf (car cons) shift) - (incf (cdr cons) shift))) + (cl-incf (car cons) shift) + (cl-incf (cdr cons) shift))) ((and (featurep 'xemacs) (extentp (car elt))) ; (EXTENT START END) - (incf (nth 1 elt) shift) - (incf (nth 2 elt) shift))) + (cl-incf (nth 1 elt) shift) + (cl-incf (nth 2 elt) shift))) (setq list (cdr list)))))) (defvar erc-valid-nick-regexp "[]a-zA-Z^[;\\`_{}|][]^[;\\`_{}|a-zA-Z0-9-]*" @@ -2477,6 +2477,13 @@ purposes." :group 'erc-lurker :type 'boolean) +(defcustom erc-lurker-ignore-chars "`_" + "Characters at the end of a nick to strip for activity tracking purposes. + +See also `erc-lurker-trim-nicks'." + :group 'erc-lurker + :type 'string) + (defun erc-lurker-maybe-trim (nick) "Maybe trim trailing `erc-lurker-ignore-chars' from NICK. @@ -2491,13 +2498,6 @@ non-nil." "" nick) nick)) -(defcustom erc-lurker-ignore-chars "`_" - "Characters at the end of a nick to strip for activity tracking purposes. - -See also `erc-lurker-trim-nicks'." - :group 'erc-lurker - :type 'string) - (defcustom erc-lurker-hide-list nil "List of IRC type messages to hide when sent by lurkers. @@ -2580,7 +2580,8 @@ updates of `erc-lurker-state'." (server (erc-canonicalize-server-name erc-server-announced-name))) (when (equal command "PRIVMSG") - (when (>= (incf erc-lurker-cleanup-count) erc-lurker-cleanup-interval) + (when (>= (cl-incf erc-lurker-cleanup-count) + erc-lurker-cleanup-interval) (setq erc-lurker-cleanup-count 0) (erc-lurker-cleanup)) (unless (gethash server erc-lurker-state) @@ -2605,6 +2606,17 @@ server within `erc-lurker-threshold-time'. See also (time-subtract (current-time) last-PRIVMSG-time)) erc-lurker-threshold-time)))) +(defcustom erc-common-server-suffixes + '(("openprojects.net$" . "OPN") + ("freenode.net$" . "freenode") + ("oftc.net$" . "OFTC")) + "Alist of common server name suffixes. +This variable is used in mode-line display to save screen +real estate. Set it to nil if you want to avoid changing +displayed hostnames." + :group 'erc-mode-line-and-header + :type 'alist) + (defun erc-canonicalize-server-name (server) "Returns the canonical network name for SERVER if any, otherwise `erc-server-announced-name'. SERVER is matched against @@ -3115,37 +3127,37 @@ If SERVER is non-nil, use that, rather than the current server." (add-to-list 'symlist (cons (erc-once-with-server-event 311 `(string= ,nick - (second + (nth 1 (erc-response.command-args parsed)))) 'erc-server-311-functions)) (add-to-list 'symlist (cons (erc-once-with-server-event 312 `(string= ,nick - (second + (nth 1 (erc-response.command-args parsed)))) 'erc-server-312-functions)) (add-to-list 'symlist (cons (erc-once-with-server-event 318 `(string= ,nick - (second + (nth 1 (erc-response.command-args parsed)))) 'erc-server-318-functions)) (add-to-list 'symlist (cons (erc-once-with-server-event 319 `(string= ,nick - (second + (nth 1 (erc-response.command-args parsed)))) 'erc-server-319-functions)) (add-to-list 'symlist (cons (erc-once-with-server-event 320 `(string= ,nick - (second + (nth 1 (erc-response.command-args parsed)))) 'erc-server-320-functions)) (add-to-list 'symlist (cons (erc-once-with-server-event 330 `(string= ,nick - (second + (nth 1 (erc-response.command-args parsed)))) 'erc-server-330-functions)) (add-to-list 'symlist @@ -4328,8 +4340,8 @@ See also: `erc-echo-notice-in-user-buffers', (defun erc-banlist-store (proc parsed) "Record ban entries for a channel." - (multiple-value-bind (channel mask whoset) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,channel ,mask ,whoset) + (cdr (erc-response.command-args parsed)))) ;; Determine to which buffer the message corresponds (let ((buffer (erc-get-buffer channel proc))) (with-current-buffer buffer @@ -4340,7 +4352,7 @@ See also: `erc-echo-notice-in-user-buffers', (defun erc-banlist-finished (proc parsed) "Record that we have received the banlist." - (let* ((channel (second (erc-response.command-args parsed))) + (let* ((channel (nth 1 (erc-response.command-args parsed))) (buffer (erc-get-buffer channel proc))) (with-current-buffer buffer (put 'erc-channel-banlist 'received-from-server t))) @@ -4349,7 +4361,7 @@ See also: `erc-echo-notice-in-user-buffers', (defun erc-banlist-update (proc parsed) "Check MODE commands for bans and update the banlist appropriately." ;; FIXME: Possibly incorrect. -- Lawrence 2004-05-11 - (let* ((tgt (first (erc-response.command-args parsed))) + (let* ((tgt (car (erc-response.command-args parsed))) (mode (erc-response.contents parsed)) (whoset (erc-response.sender parsed)) (buffer (erc-get-buffer tgt proc))) @@ -6000,7 +6012,7 @@ entry of `channel-members'." (if cuser (setq op (erc-channel-user-op cuser) voice (erc-channel-user-voice cuser))) - (if (interactive-p) + (if (called-interactively-p 'interactive) (message "%s is %s@%s%s%s" nick login host (if full-name (format " (%s)" full-name) "") @@ -6088,17 +6100,6 @@ Otherwise, use the `erc-header-line' face." :group 'erc-paranoia :type 'boolean) -(defcustom erc-common-server-suffixes - '(("openprojects.net$" . "OPN") - ("freenode.net$" . "freenode") - ("oftc.net$" . "OFTC")) - "Alist of common server name suffixes. -This variable is used in mode-line display to save screen -real estate. Set it to nil if you want to avoid changing -displayed hostnames." - :group 'erc-mode-line-and-header - :type 'alist) - (defcustom erc-mode-line-away-status-format "(AWAY since %a %b %d %H:%M) " "When you're away on a server, this is shown in the mode line. @@ -6302,7 +6303,7 @@ If optional argument HERE is non-nil, insert version number at point." (format "ERC %s (GNU Emacs %s)" erc-version-string emacs-version))) (if here (insert version-string) - (if (interactive-p) + (if (called-interactively-p 'interactive) (message "%s" version-string) version-string)))) @@ -6322,7 +6323,7 @@ If optional argument HERE is non-nil, insert version number at point." ", "))) (if here (insert string) - (if (interactive-p) + (if (called-interactively-p 'interactive) (message "%s" string) string)))) diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index aa8aae2d245..b4c86e39e86 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el @@ -297,6 +297,8 @@ to writing a completion function." (define-key eshell-command-map [? ] 'pcomplete-expand) (define-key eshell-mode-map [tab] 'eshell-pcomplete) (define-key eshell-mode-map [(control ?i)] 'eshell-pcomplete) + (add-hook 'completion-at-point-functions + #'pcomplete-completions-at-point nil t) ;; jww (1999-10-19): Will this work on anything but X? (if (featurep 'xemacs) (define-key eshell-mode-map [iso-left-tab] 'pcomplete-reverse) @@ -452,9 +454,9 @@ to writing a completion function." (defun eshell-pcomplete () "Eshell wrapper for `pcomplete'." (interactive) - (if eshell-cmpl-ignore-case - (pcomplete-expand-and-complete) ; hack workaround for bug#12838 - (pcomplete))) + (condition-case nil + (pcomplete) + (text-read-only (completion-at-point)))) ; Workaround for bug#12838. (provide 'em-cmpl) diff --git a/lisp/faces.el b/lisp/faces.el index 9e0ca962499..f8dc4783cbb 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -487,44 +487,44 @@ with the `default' face (which is always completely specified)." (defalias 'face-background-pixmap 'face-stipple) -;; FIXME all of these -p functions ignore inheritance (cf face-stipple). -;; Ie, a face that inherits from an underlined face but does not -;; specify :underline will return nil. -;; So these functions don't actually tell you anything about how the -;; face will _appear_. So not very useful IMO. -(defun face-underline-p (face &optional frame) +(defun face-underline-p (face &optional frame inherit) "Return non-nil if FACE specifies a non-nil underlining. If the optional argument FRAME is given, report on face FACE in that frame. If FRAME is t, report on the defaults for face FACE (for new frames). -If FRAME is omitted or nil, use the selected frame." - (face-attribute-specified-or (face-attribute face :underline frame) nil)) +If FRAME is omitted or nil, use the selected frame. +Optional argument INHERIT is passed to `face-attribute'." + (face-attribute-specified-or + (face-attribute face :underline frame inherit) nil)) -(defun face-inverse-video-p (face &optional frame) +(defun face-inverse-video-p (face &optional frame inherit) "Return non-nil if FACE specifies a non-nil inverse-video. If the optional argument FRAME is given, report on face FACE in that frame. If FRAME is t, report on the defaults for face FACE (for new frames). -If FRAME is omitted or nil, use the selected frame." - (eq (face-attribute face :inverse-video frame) t)) +If FRAME is omitted or nil, use the selected frame. +Optional argument INHERIT is passed to `face-attribute'." + (eq (face-attribute face :inverse-video frame inherit) t)) -(defun face-bold-p (face &optional frame) +(defun face-bold-p (face &optional frame inherit) "Return non-nil if the font of FACE is bold on FRAME. If the optional argument FRAME is given, report on face FACE in that frame. If FRAME is t, report on the defaults for face FACE (for new frames). If FRAME is omitted or nil, use the selected frame. +Optional argument INHERIT is passed to `face-attribute'. Use `face-attribute' for finer control." - (let ((bold (face-attribute face :weight frame))) + (let ((bold (face-attribute face :weight frame inherit))) (memq bold '(semi-bold bold extra-bold ultra-bold)))) -(defun face-italic-p (face &optional frame) +(defun face-italic-p (face &optional frame inherit) "Return non-nil if the font of FACE is italic on FRAME. If the optional argument FRAME is given, report on face FACE in that frame. If FRAME is t, report on the defaults for face FACE (for new frames). If FRAME is omitted or nil, use the selected frame. +Optional argument INHERIT is passed to `face-attribute'. Use `face-attribute' for finer control." - (let ((italic (face-attribute face :slant frame))) + (let ((italic (face-attribute face :slant frame inherit))) (memq italic '(italic oblique)))) @@ -862,7 +862,7 @@ Use `set-face-attribute' to ``unspecify'' underlining." 'set-face-underline "24.3") -(defun set-face-inverse-video-p (face inverse-video-p &optional frame) +(defun set-face-inverse-video (face inverse-video-p &optional frame) "Specify whether face FACE is in inverse video. INVERSE-VIDEO-P non-nil means FACE displays explicitly in inverse video. INVERSE-VIDEO-P nil means FACE explicitly is not in inverse video. @@ -870,14 +870,13 @@ FRAME nil or not specified means change face on all frames. Use `set-face-attribute' to ``unspecify'' the inverse video attribute." (interactive (let ((list (read-face-and-attribute :inverse-video))) - (list (car list) (eq (car (cdr list)) t)))) + (list (car list) (if (cadr list) t)))) (set-face-attribute face frame :inverse-video inverse-video-p)) +(define-obsolete-function-alias 'set-face-inverse-video-p + 'set-face-inverse-video "24.4") -;; The -p suffix is a hostage to fortune. What if we want to extend -;; this to allow more than boolean options? Exactly this happened -;; to set-face-underline-p. -(defun set-face-bold-p (face bold-p &optional frame) +(defun set-face-bold (face bold-p &optional frame) "Specify whether face FACE is bold. BOLD-P non-nil means FACE should explicitly display bold. BOLD-P nil means FACE should explicitly display non-bold. @@ -887,8 +886,10 @@ Use `set-face-attribute' or `modify-face' for finer control." (make-face-unbold face frame) (make-face-bold face frame))) +(define-obsolete-function-alias 'set-face-bold-p 'set-face-bold "24.4") + -(defun set-face-italic-p (face italic-p &optional frame) +(defun set-face-italic (face italic-p &optional frame) "Specify whether face FACE is italic. ITALIC-P non-nil means FACE should explicitly display italic. ITALIC-P nil means FACE should explicitly display non-italic. @@ -898,6 +899,8 @@ Use `set-face-attribute' or `modify-face' for finer control." (make-face-unitalic face frame) (make-face-italic face frame))) +(define-obsolete-function-alias 'set-face-italic-p 'set-face-italic "24.4") + (defalias 'set-face-background-pixmap 'set-face-stipple) diff --git a/lisp/files.el b/lisp/files.el index 8e8a178caab..496f9bf8fa4 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -730,7 +730,7 @@ The path separator is colon in GNU and GNU-like systems." ;; This is a case where .elc makes a lot of sense. (interactive (list (let ((completion-ignored-extensions (remove ".elc" completion-ignored-extensions))) - (read-file-name "Load file: ")))) + (read-file-name "Load file: " nil nil 'lambda)))) (load (expand-file-name file) nil nil t)) (defun locate-file (filename path &optional suffixes predicate) @@ -3433,7 +3433,7 @@ DIR is the name of the directory. CLASS is the name of a variable class (a symbol). MTIME is the recorded modification time of the directory-local variables file associated with this entry. This time is a list -of two integers (the same format as `file-attributes'), and is +of integers (the same format as `file-attributes'), and is used to test whether the cache entry is still valid. Alternatively, MTIME can be nil, which means the entry is always considered valid.") diff --git a/lisp/find-cmd.el b/lisp/find-cmd.el index 6589bac0c6a..4cf5b85c81a 100644 --- a/lisp/find-cmd.el +++ b/lisp/find-cmd.el @@ -63,6 +63,7 @@ (cnewer . (1)) (ctime . (1)) (empty . (0)) + (executable . (0)) (false . (0)) (fstype . (1)) (gid . (1)) @@ -70,37 +71,43 @@ (ilname . (1)) (iname . (1)) (inum . (1)) - (iwholename . (1)) + (ipath . (1)) (iregex . (1)) + (iwholename . (1)) (links . (1)) (lname . (1)) (mmin . (1)) (mtime . (1)) (name . (1)) (newer . (1)) - (nouser . (0)) (nogroup . (0)) + (nouser . (0)) (path . (1)) (perm . (0)) + (readable . (0)) (regex . (1)) - (wholename . (1)) + (samefile . (1)) (size . (1)) (true . (0)) (type . (1)) (uid . (1)) (used . (1)) (user . (1)) + (wholename . (1)) + (writable . (0)) (xtype . (nil)) ;; normal options (always true) + (daystart . (0)) (depth . (0)) (maxdepth . (1)) (mindepth . (1)) (mount . (0)) (noleaf . (0)) - (xdev . (0)) (ignore_readdir_race . (0)) (noignore_readdir_race . (0)) + (regextype . (1)) + (xdev . (0)) ;; actions (delete . (0)) diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index dd493d383a3..d0dfd100f44 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,8 @@ +2012-11-19 Katsumi Yamaoka <yamaoka@jpl.org> + + * message.el (message-get-reply-headers): + Make sure the reply goes to the author if it is a wide reply. + 2012-11-16 Jan Tatarik <jan.tatarik@gmail.com> * gnus-score.el (gnus-score-body): diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 8905acb9d1f..5a2b4334582 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -6730,11 +6730,16 @@ The function is called with one parameter, a cons cell ..." ", ")) mct (message-fetch-field "mail-copies-to") author (or (message-fetch-field "mail-reply-to") - (message-fetch-field "reply-to") - (message-fetch-field "from") - "") + (message-fetch-field "reply-to")) mft (and message-use-mail-followup-to - (message-fetch-field "mail-followup-to")))) + (message-fetch-field "mail-followup-to"))) + ;; Make sure this message goes to the author if this is a wide + ;; reply, since Reply-To address may be a list address a mailing + ;; list server added. + (when (and wide author) + (setq cc (concat author ", " cc))) + (when (or wide (not author)) + (setq author (or (message-fetch-field "from") "")))) ;; Handle special values of Mail-Copies-To. (when mct diff --git a/lisp/json.el b/lisp/json.el index 8167bfe93f2..b1ea03120dc 100644 --- a/lisp/json.el +++ b/lisp/json.el @@ -51,7 +51,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) ;; Compatibility code diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index ec321d00506..07da0b3dc16 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1270,9 +1270,10 @@ target of the symlink differ." res-uid ;; 3. File gid. res-gid - ;; 4. Last access time, as a list of two integers. First - ;; integer has high-order 16 bits of time, second has low 16 - ;; bits. + ;; 4. Last access time, as a list of integers. Normally this + ;; would be in the same format as `current-time', but the + ;; subseconds part is not currently implemented, and (0 0) + ;; denotes an unknown time. ;; 5. Last modification time, likewise. ;; 6. Last status change time, likewise. '(0 0) '(0 0) '(0 0) ;CCC how to find out? @@ -1980,6 +1981,7 @@ file names." (error "Unknown operation `%s', must be `copy' or `rename'" op)) (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname)) + (length (nth 7 (file-attributes (file-truename filename)))) (context (and preserve-selinux-context (apply 'file-selinux-context (list filename)))) pr tm) @@ -2009,8 +2011,9 @@ file names." ok-if-already-exists keep-date preserve-uid-gid)) ;; Try out-of-band operation. - ((tramp-method-out-of-band-p - v1 (nth 7 (file-attributes (file-truename filename)))) + ((and + (tramp-method-out-of-band-p v1 length) + (tramp-method-out-of-band-p v2 length)) (tramp-do-copy-or-rename-file-out-of-band op filename newname keep-date)) @@ -2038,8 +2041,7 @@ file names." ;; If the Tramp file has an out-of-band method, the ;; corresponding copy-program can be invoked. - ((tramp-method-out-of-band-p - v (nth 7 (file-attributes (file-truename filename)))) + ((tramp-method-out-of-band-p v length) (tramp-do-copy-or-rename-file-out-of-band op filename newname keep-date)) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index caaae5d553e..d6f2177b03b 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3767,6 +3767,7 @@ Invokes `password-read' if available, `read-passwd' else." ("oct" . 10) ("nov" . 11) ("dec" . 12)) "Alist mapping month names to integers.") +;; FIXME: Shouldn't this also look at any subseconds parts of T1 and T2? ;;;###tramp-autoload (defun tramp-time-less-p (t1 t2) "Say whether time value T1 is less than time value T2." @@ -3776,6 +3777,7 @@ Invokes `password-read' if available, `read-passwd' else." (and (= (car t1) (car t2)) (< (nth 1 t1) (nth 1 t2))))) +;; FIXME: Shouldn't this also look at any subseconds parts of T1 and T2? (defun tramp-time-subtract (t1 t2) "Subtract two time values. Return the difference in the format of a time value." diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el index 9e55976a8bd..13cf7356e7f 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el @@ -833,7 +833,8 @@ this is `comint-dynamic-complete-functions'." . ,(lambda (comps) (sort comps pcomplete-compare-entry-function))) ,@(cdr (completion-file-name-table s p a))) - (let ((completion-ignored-extensions nil)) + (let ((completion-ignored-extensions nil) + (completion-ignore-case pcomplete-ignore-case)) (completion-table-with-predicate #'comint-completion-file-name-table pred 'strict s p a)))))) diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el index a3ea4af4651..8af877c7843 100644 --- a/lisp/play/gamegrid.el +++ b/lisp/play/gamegrid.el @@ -175,7 +175,7 @@ static unsigned char gamegrid_bits[] = { (defun gamegrid-make-mono-tty-face () (let ((face (make-face 'gamegrid-mono-tty-face))) - (set-face-inverse-video-p face t) + (set-face-inverse-video face t) face)) (defun gamegrid-make-color-tty-face (color) diff --git a/lisp/profiler.el b/lisp/profiler.el index 38c0c0b83a7..00b51ffe099 100644 --- a/lisp/profiler.el +++ b/lisp/profiler.el @@ -404,7 +404,6 @@ RET: expand or collapse")) (defvar profiler-report-mode-map (let ((map (make-sparse-keymap))) - ;; FIXME: Add menu. (define-key map "n" 'profiler-report-next-entry) (define-key map "p" 'profiler-report-previous-entry) ;; I find it annoying more than helpful to not be able to navigate @@ -424,8 +423,43 @@ RET: expand or collapse")) (define-key map "D" 'profiler-report-descending-sort) (define-key map "=" 'profiler-report-compare-profile) (define-key map (kbd "C-x C-w") 'profiler-report-write-profile) - (define-key map "q" 'quit-window) - map)) + (easy-menu-define profiler-report-menu map "Menu for Profiler Report mode." + '("Profiler" + ["Next Entry" profiler-report-next-entry :active t + :help "Move to next entry"] + ["Previous Entry" profiler-report-previous-entry :active t + :help "Move to previous entry"] + "--" + ["Toggle Entry" profiler-report-toggle-entry + :active (profiler-report-calltree-at-point) + :help "Expand or collapse the current entry"] + ["Find Entry" profiler-report-find-entry + ;; FIXME should deactivate if not on a known function. + :active (profiler-report-calltree-at-point) + :help "Find the definition of the current entry"] + ["Describe Entry" profiler-report-describe-entry + :active (profiler-report-calltree-at-point) + :help "Show the documentation of the current entry"] + "--" + ["Show Calltree" profiler-report-render-calltree + :active profiler-report-reversed + :help "Show calltree view"] + ["Show Reversed Calltree" profiler-report-render-reversed-calltree + :active (not profiler-report-reversed) + :help "Show reversed calltree view"] + ["Sort Ascending" profiler-report-ascending-sort + :active (not (eq profiler-report-order 'ascending)) + :help "Sort calltree view in ascending order"] + ["Sort Descending" profiler-report-descending-sort + :active (not (eq profiler-report-order 'descending)) + :help "Sort calltree view in descending order"] + "--" + ["Compare Profile..." profiler-report-compare-profile :active t + :help "Compare current profile with another"] + ["Write Profile..." profiler-report-write-profile :active t + :help "Write current profile to a file"])) + map) + "Keymap for `profiler-report-mode'.") (defun profiler-report-make-buffer-name (profile) (format "*%s-Profiler-Report %s*" @@ -529,11 +563,15 @@ otherwise collapse." (defun profiler-report-find-entry (&optional event) "Find entry at point." (interactive (list last-nonmenu-event)) - (if event (posn-set-point (event-end event))) - (let ((tree (profiler-report-calltree-at-point))) - (when tree - (let ((entry (profiler-calltree-entry tree))) - (find-function entry))))) + (with-current-buffer + (if event (window-buffer (posn-window (event-start event))) + (current-buffer)) + (and event (setq event (event-end event)) + (posn-set-point event)) + (let ((tree (profiler-report-calltree-at-point))) + (when tree + (let ((entry (profiler-calltree-entry tree))) + (find-function entry)))))) (defun profiler-report-describe-entry () "Describe entry at point." diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 949b0252bf1..550c5f5a129 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -202,13 +202,12 @@ (require 'ansi-color) (require 'comint) +(eval-when-compile (require 'cl-lib)) -(eval-when-compile - (require 'cl) - ;; Avoid compiler warnings - (defvar view-return-to-alist) - (defvar compilation-error-regexp-alist) - (defvar outline-heading-end-regexp)) +;; Avoid compiler warnings +(defvar view-return-to-alist) +(defvar compilation-error-regexp-alist) +(defvar outline-heading-end-regexp) (autoload 'comint-mode "comint") @@ -364,12 +363,24 @@ This variant of `rx' supports common python named REGEXPS." "Return non-nil if point is on TYPE using SYNTAX-PPSS. TYPE can be `comment', `string' or `paren'. It returns the start character address of the specified TYPE." + (declare (compiler-macro + (lambda (form) + (pcase type + (`'comment + `(let ((ppss (or ,syntax-ppss (syntax-ppss)))) + (and (nth 4 ppss) (nth 8 ppss)))) + (`'string + `(let ((ppss (or ,syntax-ppss (syntax-ppss)))) + (and (nth 3 ppss) (nth 8 ppss)))) + (`'paren + `(nth 1 (or ,syntax-ppss (syntax-ppss)))) + (_ form))))) (let ((ppss (or syntax-ppss (syntax-ppss)))) - (case type - (comment (and (nth 4 ppss) (nth 8 ppss))) - (string (and (not (nth 4 ppss)) (nth 8 ppss))) - (paren (nth 1 ppss)) - (t nil)))) + (pcase type + (`comment (and (nth 4 ppss) (nth 8 ppss))) + (`string (and (nth 3 ppss) (nth 8 ppss))) + (`paren (nth 1 ppss)) + (_ nil)))) (defun python-syntax-context-type (&optional syntax-ppss) "Return the context type using SYNTAX-PPSS. @@ -481,8 +492,8 @@ The type returned can be `comment', `string' or `paren'." (when (re-search-forward re limit t) (while (and (python-syntax-context 'paren) (re-search-forward re limit t))) - (if (and (not (python-syntax-context 'paren)) - (not (equal (char-after (point-marker)) ?=))) + (if (not (or (python-syntax-context 'paren) + (equal (char-after (point-marker)) ?=))) t (set-match-data nil))))) (1 font-lock-variable-name-face nil nil)) @@ -516,7 +527,7 @@ is used to limit the scan." (while (and (< i 3) (or (not limit) (< (+ point i) limit)) (eq (char-after (+ point i)) quote-char)) - (incf i)) + (cl-incf i)) i)) (defun python-syntax-stringify () @@ -723,17 +734,17 @@ START is the buffer position where the sexp starts." (save-restriction (widen) (save-excursion - (case context-status - ('no-indent 0) + (pcase context-status + (`no-indent 0) ;; When point is after beginning of block just add one level ;; of indentation relative to the context-start - ('after-beginning-of-block + (`after-beginning-of-block (goto-char context-start) (+ (current-indentation) python-indent-offset)) ;; When after a simple line just use previous line ;; indentation, in the case current line starts with a ;; `python-indent-dedenters' de-indent one level. - ('after-line + (`after-line (- (save-excursion (goto-char context-start) @@ -746,11 +757,11 @@ START is the buffer position where the sexp starts." ;; When inside of a string, do nothing. just use the current ;; indentation. XXX: perhaps it would be a good idea to ;; invoke standard text indentation here - ('inside-string + (`inside-string (goto-char context-start) (current-indentation)) ;; After backslash we have several possibilities. - ('after-backslash + (`after-backslash (cond ;; Check if current line is a dot continuation. For this ;; the current line must start with a dot and previous @@ -816,7 +827,7 @@ START is the buffer position where the sexp starts." (+ (current-indentation) python-indent-offset))))) ;; When inside a paren there's a need to handle nesting ;; correctly - ('inside-paren + (`inside-paren (cond ;; If current line closes the outermost open paren use the ;; current indentation of the context-start line. @@ -2164,11 +2175,11 @@ INPUT." 'default) (t nil))) (completion-code - (case completion-context - (pdb python-shell-completion-pdb-string-code) - (import python-shell-completion-module-string-code) - (default python-shell-completion-string-code) - (t nil))) + (pcase completion-context + (`pdb python-shell-completion-pdb-string-code) + (`import python-shell-completion-module-string-code) + (`default python-shell-completion-string-code) + (_ nil))) (input (if (eq completion-context 'import) (replace-regexp-in-string "^[ \t]+" "" line) @@ -2492,17 +2503,17 @@ JUSTIFY should be used (if applicable) as in `fill-paragraph'." ;; Docstring styles may vary for oneliners and multi-liners. (> (count-matches "\n" str-start-pos str-end-pos) 0)) (delimiters-style - (case python-fill-docstring-style + (pcase python-fill-docstring-style ;; delimiters-style is a cons cell with the form ;; (START-NEWLINES . END-NEWLINES). When any of the sexps ;; is NIL means to not add any newlines for start or end ;; of docstring. See `python-fill-docstring-style' for a ;; graphic idea of each style. - (django (cons 1 1)) - (onetwo (and multi-line-p (cons 1 2))) - (pep-257 (and multi-line-p (cons nil 2))) - (pep-257-nn (and multi-line-p (cons nil 1))) - (symmetric (and multi-line-p (cons 1 1))))) + (`django (cons 1 1)) + (`onetwo (and multi-line-p (cons 1 2))) + (`pep-257 (and multi-line-p (cons nil 2))) + (`pep-257-nn (and multi-line-p (cons nil 1))) + (`symmetric (and multi-line-p (cons 1 1))))) (docstring-p (save-excursion ;; Consider docstrings those strings which ;; start on a line by themselves. @@ -2703,7 +2714,7 @@ The skeleton will be bound to python-skeleton-NAME." (easy-menu-add-item nil '("Python" "Skeletons") `[,(format - "Insert %s" (caddr (split-string (symbol-name skeleton) "-"))) + "Insert %s" (nth 2 (split-string (symbol-name skeleton) "-"))) ,skeleton t])))) ;;; FFAP diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 64b87d9e436..d84d57cad22 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -736,15 +736,15 @@ this variable is nil, that buffer is shown using (defvar sql-imenu-generic-expression ;; Items are in reverse order because they are rendered in reverse. - '(("Rules/Defaults" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*\\(rule\\|default\\)\\s-+\\(\\w+\\)" 3) - ("Sequences" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*sequence\\s-+\\(\\w+\\)" 2) - ("Triggers" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*trigger\\s-+\\(\\w+\\)" 2) - ("Functions" "^\\s-*\\(create\\s-+\\(\\w+\\s-+\\)*\\)?function\\s-+\\(\\w+\\)" 3) - ("Procedures" "^\\s-*\\(create\\s-+\\(\\w+\\s-+\\)*\\)?proc\\(edure\\)?\\s-+\\(\\w+\\)" 4) - ("Packages" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*package\\s-+\\(body\\s-+\\)?\\(\\w+\\)" 3) - ("Types" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*type\\s-+\\(body\\s-+\\)?\\(\\w+\\)" 3) - ("Indexes" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*index\\s-+\\(\\w+\\)" 2) - ("Tables/Views" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*\\(table\\|view\\)\\s-+\\(\\w+\\)" 3)) + '(("Rules/Defaults" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*\\(?:rule\\|default\\)\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\s-+\\(\\w+\\)" 1) + ("Sequences" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*sequence\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) + ("Triggers" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*trigger\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) + ("Functions" "^\\s-*\\(?:create\\s-+\\(?:\\w+\\s-+\\)*\\)?function\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) + ("Procedures" "^\\s-*\\(?:create\\s-+\\(?:\\w+\\s-+\\)*\\)?proc\\(?:edure\\)?\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) + ("Packages" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*package\\s-+\\(?:body\\s-+\\)?\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) + ("Types" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*type\\s-+\\(?:body\\s-+\\)?\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) + ("Indexes" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*index\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) + ("Tables/Views" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*\\(?:table\\|view\\)\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1)) "Define interesting points in the SQL buffer for `imenu'. This is used to set `imenu-generic-expression' when SQL mode is @@ -1339,6 +1339,7 @@ Based on `comint-mode-map'.") "\\(?:\\w+\\s-+\\)*" ;; optional intervening keywords "\\(?:table\\|view\\|\\(?:package\\|type\\)\\(?:\\s-+body\\)?\\|proc\\(?:edure\\)?" "\\|function\\|trigger\\|sequence\\|rule\\|default\\)\\s-+" + "\\(?:if\\s-+not\\s-+exists\\s-+\\)?" ;; IF NOT EXISTS "\\(\\w+\\)") 1 'font-lock-function-name-face)) diff --git a/lisp/ps-bdf.el b/lisp/ps-bdf.el index a82e03ceda7..477aee1b2da 100644 --- a/lisp/ps-bdf.el +++ b/lisp/ps-bdf.el @@ -70,20 +70,15 @@ for BDFNAME." (defsubst bdf-file-mod-time (filename) "Return modification time of FILENAME. -The value is a list of two integers, the first integer has high-order -16 bits, the second has low 16 bits." +The value is a list of integers in the same format as `current-time'." (nth 5 (file-attributes filename))) (defun bdf-file-newer-than-time (filename mod-time) "Return non-nil if and only if FILENAME is newer than MOD-TIME. -MOD-TIME is a modification time as a list of two integers, the first -integer has high-order 16 bits, the second has low 16 bits." - (let* ((new-mod-time (bdf-file-mod-time filename)) - (new-time (car new-mod-time)) - (time (car mod-time))) - (or (> new-time time) - (and (= new-time time) - (> (nth 1 new-mod-time) (nth 1 mod-time)))))) +MOD-TIME is a modification time as a list of integers in the same +format as `current-time'." + (let ((new-mod-time (bdf-file-mod-time filename))) + (time-less-p mod-time new-mod-time))) (defun bdf-find-file (bdfname) "Return a buffer visiting a bdf file BDFNAME. @@ -178,8 +173,8 @@ FONT-INFO is a list of the following format: (BDFFILE MOD-TIME FONT-BOUNDING-BOX RELATIVE-COMPOSE BASELINE-OFFSET CODE-RANGE MAXLEN OFFSET-VECTOR) -MOD-TIME is last modification time as a list of two integers, the -first integer has high-order 16 bits, the second has low 16 bits. +MOD-TIME is last modification time as a list of integers in the +same format as `current-time'. SIZE is a size of the font on 72 dpi device. This value is got from SIZE record of the font. diff --git a/lisp/simple.el b/lisp/simple.el index aed945d6e13..5867561da26 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -4583,6 +4583,9 @@ lines." (unless (and auto-window-vscroll try-vscroll ;; Only vscroll for single line moves (= (abs arg) 1) + ;; Under scroll-conservatively, the display engine + ;; does this better. + (zerop scroll-conservatively) ;; But don't vscroll in a keyboard macro. (not defining-kbd-macro) (not executing-kbd-macro) diff --git a/lisp/subr.el b/lisp/subr.el index 8410897fd6f..c0479d35987 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -1191,8 +1191,6 @@ is converted into a string by expressing it in decimal." (make-obsolete 'unfocus-frame "it does nothing." "22.1") (make-obsolete 'make-variable-frame-local "explicitly check for a frame-parameter instead." "22.2") -(make-obsolete 'interactive-p 'called-interactively-p "23.2") -(set-advertised-calling-convention 'called-interactively-p '(kind) "23.1") (set-advertised-calling-convention 'all-completions '(string collection &optional predicate) "23.1") (set-advertised-calling-convention 'unintern '(name obarray) "23.3") @@ -3963,6 +3961,152 @@ The properties used on SYMBOL are `composefunc', `sendfunc', (put symbol 'abortfunc (or abortfunc 'kill-buffer)) (put symbol 'hookvar (or hookvar 'mail-send-hook))) +(defvar called-interactively-p-functions nil + "Special hook called to skip special frames in `called-interactively-p'. +The functions are called with 3 arguments: (I FRAME1 FRAME2), +where FRAME1 is a \"current frame\", FRAME2 is the next frame, +I is the index of the frame after FRAME2. It should return nil +if those frames don't seem special and otherwise, it should return +the number of frames to skip (minus 1).") + +(defmacro internal--called-interactively-p--get-frame (n) + ;; `sym' will hold a global variable, which will be used kind of like C's + ;; "static" variables. + (let ((sym (make-symbol "base-index"))) + `(progn + (defvar ,sym + (let ((i 1)) + (while (not (eq (nth 1 (backtrace-frame i)) + 'called-interactively-p)) + (setq i (1+ i))) + i)) + ;; (unless (eq (nth 1 (backtrace-frame ,sym)) 'called-interactively-p) + ;; (error "called-interactively-p: %s is out-of-sync!" ,sym)) + (backtrace-frame (+ ,sym ,n))))) + +(defun called-interactively-p (&optional kind) + "Return t if the containing function was called by `call-interactively'. +If KIND is `interactive', then only return t if the call was made +interactively by the user, i.e. not in `noninteractive' mode nor +when `executing-kbd-macro'. +If KIND is `any', on the other hand, it will return t for any kind of +interactive call, including being called as the binding of a key or +from a keyboard macro, even in `noninteractive' mode. + +This function is very brittle, it may fail to return the intended result when +the code is debugged, advised, or instrumented in some form. Some macros and +special forms (such as `condition-case') may also sometimes wrap their bodies +in a `lambda', so any call to `called-interactively-p' from those bodies will +indicate whether that lambda (rather than the surrounding function) was called +interactively. + +Instead of using this function, it is cleaner and more reliable to give your +function an extra optional argument whose `interactive' spec specifies +non-nil unconditionally (\"p\" is a good way to do this), or via +\(not (or executing-kbd-macro noninteractive)). + +The only known proper use of `interactive' for KIND is in deciding +whether to display a helpful message, or how to display it. If you're +thinking of using it for any other purpose, it is quite likely that +you're making a mistake. Think: what do you want to do when the +command is called from a keyboard macro?" + (declare (advertised-calling-convention (kind) "23.1")) + (when (not (and (eq kind 'interactive) + (or executing-kbd-macro noninteractive))) + (let* ((i 1) ;; 0 is the called-interactively-p frame. + frame nextframe + (get-next-frame + (lambda () + (setq frame nextframe) + (setq nextframe (internal--called-interactively-p--get-frame i)) + ;; (message "Frame %d = %S" i nextframe) + (setq i (1+ i))))) + (funcall get-next-frame) ;; Get the first frame. + (while + ;; FIXME: The edebug and advice handling should be made modular and + ;; provided directly by edebug.el and nadvice.el. + (progn + ;; frame =(backtrace-frame i-2) + ;; nextframe=(backtrace-frame i-1) + (funcall get-next-frame) + ;; `pcase' would be a fairly good fit here, but it sometimes moves + ;; branches within local functions, which then messes up the + ;; `backtrace-frame' data we get, + (or + ;; Skip special forms (from non-compiled code). + (and frame (null (car frame))) + ;; Skip also `interactive-p' (because we don't want to know if + ;; interactive-p was called interactively but if it's caller was) + ;; and `byte-code' (idem; this appears in subexpressions of things + ;; like condition-case, which are wrapped in a separate bytecode + ;; chunk). + ;; FIXME: For lexical-binding code, this is much worse, + ;; because the frames look like "byte-code -> funcall -> #[...]", + ;; which is not a reliable signature. + (memq (nth 1 frame) '(interactive-p 'byte-code)) + ;; Skip package-specific stack-frames. + (let ((skip (run-hook-with-args-until-success + 'called-interactively-p-functions + i frame nextframe))) + (pcase skip + (`nil nil) + (`0 t) + (_ (setq i (+ i skip -1)) (funcall get-next-frame))))))) + ;; Now `frame' should be "the function from which we were called". + (pcase (cons frame nextframe) + ;; No subr calls `interactive-p', so we can rule that out. + (`((,_ ,(pred (lambda (f) (subrp (indirect-function f)))) . ,_) . ,_) nil) + ;; Somehow, I sometimes got `command-execute' rather than + ;; `call-interactively' on my stacktrace !? + ;;(`(,_ . (t command-execute . ,_)) t) + (`(,_ . (t call-interactively . ,_)) t))))) + +(defun interactive-p () + "Return t if the containing function was run directly by user input. +This means that the function was called with `call-interactively' +\(which includes being called as the binding of a key) +and input is currently coming from the keyboard (not a keyboard macro), +and Emacs is not running in batch mode (`noninteractive' is nil). + +The only known proper use of `interactive-p' is in deciding whether to +display a helpful message, or how to display it. If you're thinking +of using it for any other purpose, it is quite likely that you're +making a mistake. Think: what do you want to do when the command is +called from a keyboard macro or in batch mode? + +To test whether your function was called with `call-interactively', +either (i) add an extra optional argument and give it an `interactive' +spec that specifies non-nil unconditionally (such as \"p\"); or (ii) +use `called-interactively-p'." + (declare (obsolete called-interactively-p "23.2")) + (called-interactively-p 'interactive)) + +(defun function-arity (f &optional num) + "Return the (MIN . MAX) arity of F. +If the maximum arity is infinite, MAX is `many'. +F can be a function or a macro. +If NUM is non-nil, return non-nil iff F can be called with NUM args." + (if (symbolp f) (setq f (indirect-function f))) + (if (eq (car-safe f) 'macro) (setq f (cdr f))) + (let ((res + (if (subrp f) + (let ((x (subr-arity f))) + (if (eq (cdr x) 'unevalled) (cons (car x) 'many))) + (let* ((args (if (consp f) (cadr f) (aref f 0))) + (max (length args)) + (opt (memq '&optional args)) + (rest (memq '&rest args)) + (min (- max (length opt)))) + (if opt + (cons min (if rest 'many (1- max))) + (if rest + (cons (- max (length rest)) 'many) + (cons min max))))))) + (if (not num) + res + (and (>= num (car res)) + (or (eq 'many (cdr res)) (<= num (cdr res))))))) + (defun set-temporary-overlay-map (map &optional keep-pred) "Set MAP as a temporary keymap taking precedence over most other keymaps. Note that this does NOT take precedence over the \"overriding\" maps diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 42e09b65750..95dab10101b 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -91,7 +91,7 @@ (declare-function w32-send-sys-command "w32fns.c") (declare-function set-message-beep "w32fns.c") -(declare-function cygwin-convert-path-from-windows "cygw32.c" +(declare-function cygwin-convert-file-name-from-windows "cygw32.c" (path &optional absolute_p)) ;; Conditional on new-fontset so bootstrapping works on non-GUI compiles @@ -108,7 +108,7 @@ (defun w32-handle-dropped-file (window file-name) (let ((f (if (eq system-type 'cygwin) - (cygwin-convert-path-from-windows file-name t) + (cygwin-convert-file-name-from-windows file-name t) (subst-char-in-string ?\\ ?/ file-name))) (coding (or file-name-coding-system default-file-name-coding-system))) diff --git a/lisp/textmodes/table.el b/lisp/textmodes/table.el index 3d9f88a43c9..6db15b7ec2a 100644 --- a/lisp/textmodes/table.el +++ b/lisp/textmodes/table.el @@ -5210,7 +5210,7 @@ instead of the current buffer and returns the OBJECT." "Update cell face according to the current mode." (if (featurep 'xemacs) (set-face-property 'table-cell 'underline table-fixed-width-mode) - (set-face-inverse-video-p 'table-cell table-fixed-width-mode))) + (set-face-inverse-video 'table-cell table-fixed-width-mode))) (table--update-cell-face) diff --git a/lisp/uniquify.el b/lisp/uniquify.el index 3619d499419..2b4794c9cc2 100644 --- a/lisp/uniquify.el +++ b/lisp/uniquify.el @@ -183,10 +183,9 @@ contains the name of the directory which the buffer is visiting.") ;; Internal variables used free (defvar uniquify-possibly-resolvable nil) -(defvar uniquify-managed nil +(defvar-local uniquify-managed nil "Non-nil if the name of this buffer is managed by uniquify. It actually holds the list of `uniquify-item's corresponding to the conflict.") -(make-variable-buffer-local 'uniquify-managed) (put 'uniquify-managed 'permanent-local t) ;; Used in desktop.el to save the non-uniquified buffer name @@ -464,27 +463,34 @@ For use on `kill-buffer-hook'." ;; rename-buffer and create-file-buffer. (Setting find-file-hook isn't ;; sufficient.) -(defadvice rename-buffer (after rename-buffer-uniquify activate) +(advice-add 'rename-buffer :around #'uniquify--rename-buffer-advice) +(defun uniquify--rename-buffer-advice (rb-fun newname &optional unique &rest args) "Uniquify buffer names with parts of directory name." + (let ((retval (apply rb-fun newname unique args))) (uniquify-maybe-rerationalize-w/o-cb) - (if (null (ad-get-arg 1)) ; no UNIQUE argument. + (if (null unique) ;; Mark this buffer so it won't be renamed by uniquify. (setq uniquify-managed nil) (when uniquify-buffer-name-style ;; Rerationalize w.r.t the new name. (uniquify-rationalize-file-buffer-names - (ad-get-arg 0) + newname (uniquify-buffer-file-name (current-buffer)) (current-buffer)) - (setq ad-return-value (buffer-name (current-buffer)))))) + (setq retval (buffer-name (current-buffer))))) + retval)) -(defadvice create-file-buffer (after create-file-buffer-uniquify activate) + +(advice-add 'create-file-buffer :around #'uniquify--create-file-buffer-advice) +(defun uniquify--create-file-buffer-advice (cfb-fun filename &rest args) "Uniquify buffer names with parts of directory name." + (let ((retval (apply cfb-fun filename args))) (if uniquify-buffer-name-style - (let ((filename (expand-file-name (directory-file-name (ad-get-arg 0))))) + (let ((filename (expand-file-name (directory-file-name filename)))) (uniquify-rationalize-file-buffer-names (file-name-nondirectory filename) - (file-name-directory filename) ad-return-value)))) + (file-name-directory filename) retval))) + retval)) ;;; The End @@ -496,9 +502,8 @@ For use on `kill-buffer-hook'." (set-buffer buf) (when uniquify-managed (push (cons buf (uniquify-item-base (car uniquify-managed))) buffers))) - (dolist (fun '(rename-buffer create-file-buffer)) - (ad-remove-advice fun 'after (intern (concat (symbol-name fun) "-uniquify"))) - (ad-update fun)) + (advice-remove 'rename-buffer #'uniquify--rename-buffer-advice) + (advice-remove 'create-file-buffer #'uniquify--create-file-buffer-advice) (dolist (buf buffers) (set-buffer (car buf)) (rename-buffer (cdr buf) t)))) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 26c64ce2ad3..0c023b0f7f4 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -575,19 +575,21 @@ next hunk if TRY-HARDER is non-nil; otherwise signal an error." (easy-mmode-define-navigation diff-hunk diff-hunk-header-re "hunk" diff-end-of-hunk diff-restrict-view (when diff-auto-refine-mode - (setq diff--auto-refine-data (cons (current-buffer) (point-marker))) - (run-at-time 0.0 nil - (lambda () - (when diff--auto-refine-data - (let ((buffer (car diff--auto-refine-data)) - (point (cdr diff--auto-refine-data))) - (setq diff--auto-refine-data nil) - (with-local-quit - (when (buffer-live-p buffer) - (with-current-buffer buffer - (save-excursion - (goto-char point) - (diff-refine-hunk))))))))))) + (unless (prog1 diff--auto-refine-data + (setq diff--auto-refine-data + (cons (current-buffer) (point-marker)))) + (run-at-time 0.0 nil + (lambda () + (when diff--auto-refine-data + (let ((buffer (car diff--auto-refine-data)) + (point (cdr diff--auto-refine-data))) + (setq diff--auto-refine-data nil) + (with-local-quit + (when (buffer-live-p buffer) + (with-current-buffer buffer + (save-excursion + (goto-char point) + (diff-refine-hunk)))))))))))) (easy-mmode-define-navigation diff-file diff-file-header-re "file" diff-end-of-file) diff --git a/lisp/window.el b/lisp/window.el index d378ea5ff14..52909fa9e5f 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -5870,7 +5870,12 @@ the selected window or never appeared in it before, or if :version "24.3") (defun switch-to-buffer (buffer-or-name &optional norecord force-same-window) - "Switch to buffer BUFFER-OR-NAME in the selected window. + "Display buffer BUFFER-OR-NAME in the selected window. + +WARNING: This is NOT the way to work on another buffer temporarily +within a Lisp program! Use `set-buffer' instead. That avoids +messing with the window-buffer correspondences. + If the selected window cannot display the specified buffer (e.g. if it is a minibuffer window or strongly dedicated to another buffer), call `pop-to-buffer' to select the buffer in |