Now on revision 110956. ------------------------------------------------------------ revno: 110956 committer: Dmitry Antipov branch nick: trunk timestamp: Tue 2012-11-20 11:53:04 +0400 message: * xdisp.c (buffer_shared): Adjust comment. (buffer_shared_and_changed): New function. (prepare_menu_bars, redisplay_internal): Use it to decide whether all windows or frames should be updated. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2012-11-20 04:24:09 +0000 +++ src/ChangeLog 2012-11-20 07:53:04 +0000 @@ -1,3 +1,10 @@ +2012-11-20 Dmitry Antipov + + * xdisp.c (buffer_shared): Adjust comment. + (buffer_shared_and_changed): New function. + (prepare_menu_bars, redisplay_internal): Use it to + decide whether all windows or frames should be updated. + 2012-11-20 Stefan Monnier * eval.c (Finteractive_p, Fcalled_interactively_p, interactive_p): Remove. === modified file 'src/xdisp.c' --- src/xdisp.c 2012-11-14 11:13:33 +0000 +++ src/xdisp.c 2012-11-20 07:53:04 +0000 @@ -515,9 +515,8 @@ static int overlay_arrow_seen; -/* Number of windows showing the buffer of the selected window (or - another buffer with the same base buffer). keyboard.c refers to - this. */ +/* Number of windows showing the buffer of the selected + window (or another buffer with the same base buffer). */ int buffer_shared; @@ -10889,8 +10888,15 @@ return window_height_changed_p; } - - +/* True if the current buffer is shown in more than + one window and was modified since last display. */ + +static int +buffer_shared_and_changed (void) +{ + return (buffer_shared > 1 && UNCHANGED_MODIFIED < MODIFF); +} + /*********************************************************************** Mode Lines and Frame Titles ***********************************************************************/ @@ -11196,7 +11202,7 @@ /* Update the menu bar item lists, if appropriate. This has to be done before any actual redisplay or generation of display lines. */ all_windows = (update_mode_lines - || buffer_shared > 1 + || buffer_shared_and_changed () || windows_or_buffers_changed); if (all_windows) { @@ -13116,7 +13122,7 @@ if ((SAVE_MODIFF < MODIFF) != w->last_had_star) { w->update_mode_line = 1; - if (buffer_shared > 1) + if (buffer_shared_and_changed ()) update_mode_lines++; } @@ -13141,7 +13147,8 @@ /* The variable buffer_shared is set in redisplay_window and indicates that we redisplay a buffer in different windows. See there. */ - consider_all_windows_p = (update_mode_lines || buffer_shared > 1 + consider_all_windows_p = (update_mode_lines + || buffer_shared_and_changed () || cursor_type_changed); /* If specs for an arrow have changed, do thorough redisplay @@ -13433,7 +13440,7 @@ } CHARPOS (this_line_start_pos) = 0; - consider_all_windows_p |= buffer_shared > 1; + consider_all_windows_p |= buffer_shared_and_changed (); ++clear_face_cache_count; #ifdef HAVE_WINDOW_SYSTEM ++clear_image_cache_count; ------------------------------------------------------------ revno: 110955 committer: Stefan Monnier branch nick: trunk timestamp: Mon 2012-11-19 23:24:09 -0500 message: Make called-interactively-p work for edebug or advised code. * lisp/subr.el (called-interactively-p-functions): New var. (internal--called-interactively-p--get-frame): New macro. (called-interactively-p, interactive-p): Rewrite in Lisp. * lisp/emacs-lisp/nadvice.el (advice--called-interactively-skip): New fun. (called-interactively-p-functions): Use it. * lisp/emacs-lisp/edebug.el (edebug--called-interactively-skip): New fun. (called-interactively-p-functions): Use it. * lisp/allout.el (allout-called-interactively-p): Don't assume called-interactively-p is a subr. * src/eval.c (Finteractive_p, Fcalled_interactively_p, interactive_p): Remove. (syms_of_eval): Remove corresponding defsubr. * src/bytecode.c (exec_byte_code): `interactive-p' is now a Lisp function. * test/automated/advice-tests.el (advice-tests--data): Remove. (advice-tests): Move the tests directly here instead. Add called-interactively-p tests. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-11-20 00:57:23 +0000 +++ lisp/ChangeLog 2012-11-20 04:24:09 +0000 @@ -1,3 +1,15 @@ +2012-11-20 Stefan Monnier + + * 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 * profiler.el (profiler-report-mode-map): Add a menu. === modified file 'lisp/allout.el' --- lisp/allout.el 2012-09-25 04:13:02 +0000 +++ lisp/allout.el 2012-11-20 04:24:09 +0000 @@ -1657,10 +1657,9 @@ (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 === modified file 'lisp/emacs-lisp/edebug.el' --- lisp/emacs-lisp/edebug.el 2012-10-08 06:42:29 +0000 +++ lisp/emacs-lisp/edebug.el 2012-11-20 04:24:09 +0000 @@ -4268,6 +4268,21 @@ ;;; 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. === modified file 'lisp/emacs-lisp/nadvice.el' --- lisp/emacs-lisp/nadvice.el 2012-11-15 03:30:25 +0000 +++ lisp/emacs-lisp/nadvice.el 2012-11-20 04:24:09 +0000 @@ -402,6 +402,56 @@ (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 === modified file 'lisp/subr.el' --- lisp/subr.el 2012-11-18 01:52:36 +0000 +++ lisp/subr.el 2012-11-20 04:24:09 +0000 @@ -1191,8 +1191,6 @@ (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 @@ (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 === modified file 'src/ChangeLog' --- src/ChangeLog 2012-11-19 01:39:37 +0000 +++ src/ChangeLog 2012-11-20 04:24:09 +0000 @@ -1,3 +1,9 @@ +2012-11-20 Stefan Monnier + + * eval.c (Finteractive_p, Fcalled_interactively_p, interactive_p): Remove. + (syms_of_eval): Remove corresponding defsubr. + * bytecode.c (exec_byte_code): `interactive-p' is now a Lisp function. + 2012-11-19 Daniel Colascione * w32fns.c (Fx_file_dialog): @@ -17,10 +23,10 @@ windows.h gets included before w32term.h uses some of its features, see below. - * w32term.h (LOCALE_ENUMPROCA, LOCALE_ENUMPROCW) [_MSC_VER]: New - typedefs. - (EnumSystemLocalesA, EnumSystemLocalesW) [_MSC_VER]: New - prototypes. + * w32term.h (LOCALE_ENUMPROCA, LOCALE_ENUMPROCW) [_MSC_VER]: + New typedefs. + (EnumSystemLocalesA, EnumSystemLocalesW) [_MSC_VER]: + New prototypes. (EnumSystemLocales) [_MSC_VER]: Define if undefined. (Bug#12878) 2012-11-18 Jan Djärv @@ -312,8 +318,8 @@ * xdisp.c (try_scrolling): Fix correction of aggressive-scroll amount when the scroll margins are too large. When scrolling backwards in the buffer, give up if cannot reach point or the - scroll margin within a reasonable number of screen lines. Fixes - point position in window under scroll-up/down-aggressively when + scroll margin within a reasonable number of screen lines. + Fixes point position in window under scroll-up/down-aggressively when point is positioned many lines beyond the window top/bottom. (Bug#12811) === modified file 'src/bytecode.c' --- src/bytecode.c 2012-09-24 22:47:51 +0000 +++ src/bytecode.c 2012-11-20 04:24:09 +0000 @@ -1579,7 +1579,9 @@ NEXT; CASE (Binteractive_p): /* Obsolete since 24.1. */ - PUSH (Finteractive_p ()); + BEFORE_POTENTIAL_GC (); + PUSH (call0 (intern ("interactive-p"))); + AFTER_POTENTIAL_GC (); NEXT; CASE (Bforward_char): === modified file 'src/eval.c' --- src/eval.c 2012-11-16 17:20:23 +0000 +++ src/eval.c 2012-11-20 04:24:09 +0000 @@ -489,102 +489,6 @@ } -DEFUN ("interactive-p", Finteractive_p, Sinteractive_p, 0, 0, 0, - doc: /* 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? - -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'. */) - (void) -{ - return (INTERACTIVE && interactive_p ()) ? Qt : Qnil; -} - - -DEFUN ("called-interactively-p", Fcalled_interactively_p, Scalled_interactively_p, 0, 1, 0, - doc: /* 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, or in `noninteractive' mode. - -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? - -Instead of using this function, it is sometimes cleaner 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)). */) - (Lisp_Object kind) -{ - return (((INTERACTIVE || !EQ (kind, intern ("interactive"))) - && interactive_p ()) - ? Qt : Qnil); -} - - -/* Return true if function in which this appears was called using - call-interactively and is not a built-in. */ - -static bool -interactive_p (void) -{ - struct backtrace *btp; - Lisp_Object fun; - - btp = backtrace_list; - - /* If this isn't a byte-compiled function, there may be a frame at - the top for Finteractive_p. If so, skip it. */ - fun = Findirect_function (btp->function, Qnil); - if (SUBRP (fun) && (XSUBR (fun) == &Sinteractive_p - || XSUBR (fun) == &Scalled_interactively_p)) - btp = btp->next; - - /* If we're running an Emacs 18-style byte-compiled function, there - may be a frame for Fbytecode at the top level. In any version of - Emacs there can be Fbytecode frames for subexpressions evaluated - inside catch and condition-case. Skip past them. - - If this isn't a byte-compiled function, then we may now be - looking at several frames for special forms. Skip past them. */ - while (btp - && (EQ (btp->function, Qbytecode) - || btp->nargs == UNEVALLED)) - btp = btp->next; - - /* `btp' now points at the frame of the innermost function that isn't - a special form, ignoring frames for Finteractive_p and/or - Fbytecode at the top. If this frame is for a built-in function - (such as load or eval-region) return false. */ - fun = Findirect_function (btp->function, Qnil); - if (SUBRP (fun)) - return 0; - - /* `btp' points to the frame of a Lisp function that called interactive-p. - Return t if that function was called interactively. */ - if (btp && btp->next && EQ (btp->next->function, Qcall_interactively)) - return 1; - return 0; -} - - DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 3, 0, doc: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE. Aliased variables always have the same value; setting one sets the other. @@ -696,8 +600,9 @@ if (EQ ((--pdl)->symbol, sym) && !pdl->func && EQ (pdl->old_value, Qunbound)) { - message_with_string ("Warning: defvar ignored because %s is let-bound", - SYMBOL_NAME (sym), 1); + message_with_string + ("Warning: defvar ignored because %s is let-bound", + SYMBOL_NAME (sym), 1); break; } } @@ -717,8 +622,8 @@ /* A simple (defvar foo) with lexical scoping does "nothing" except declare that var to be dynamically scoped *locally* (i.e. within the current file or let-block). */ - Vinternal_interpreter_environment = - Fcons (sym, Vinternal_interpreter_environment); + Vinternal_interpreter_environment + = Fcons (sym, Vinternal_interpreter_environment); else { /* Simple (defvar ) should not count as a definition at all. @@ -3551,8 +3456,6 @@ defsubr (&Sunwind_protect); defsubr (&Scondition_case); defsubr (&Ssignal); - defsubr (&Sinteractive_p); - defsubr (&Scalled_interactively_p); defsubr (&Scommandp); defsubr (&Sautoload); defsubr (&Sautoload_do_load); === modified file 'test/ChangeLog' --- test/ChangeLog 2012-11-19 17:24:12 +0000 +++ test/ChangeLog 2012-11-20 04:24:09 +0000 @@ -1,3 +1,9 @@ +2012-11-20 Stefan Monnier + + * automated/advice-tests.el (advice-tests--data): Remove. + (advice-tests): Move the tests directly here instead. + Add called-interactively-p tests. + 2012-11-19 Stefan Monnier * automated/ert-x-tests.el: Use cl-lib. === modified file 'test/automated/advice-tests.el' --- test/automated/advice-tests.el 2012-11-16 18:02:39 +0000 +++ test/automated/advice-tests.el 2012-11-20 04:24:09 +0000 @@ -21,81 +21,94 @@ ;;; Code: -(defvar advice-tests--data - '(((defun sm-test1 (x) (+ x 4)) - (sm-test1 6) 10) - ((advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5))) - (sm-test1 6) 50) - ((defun sm-test1 (x) (+ x 14)) - (sm-test1 6) 100) - ((null (get 'sm-test1 'defalias-fset-function)) nil) - ((advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5))) - (sm-test1 6) 20) - ((null (get 'sm-test1 'defalias-fset-function)) t) +(ert-deftest advice-tests () + "Test advice code." + (with-temp-buffer + (defun sm-test1 (x) (+ x 4)) + (should (equal (sm-test1 6) 10)) + (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test1 6) 50)) + (defun sm-test1 (x) (+ x 14)) + (should (equal (sm-test1 6) 100)) + (should (equal (null (get 'sm-test1 'defalias-fset-function)) nil)) + (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test1 6) 20)) + (should (equal (null (get 'sm-test1 'defalias-fset-function)) t)) - ((defun sm-test2 (x) (+ x 4)) - (sm-test2 6) 10) - ((defadvice sm-test2 (around sm-test activate) + (defun sm-test2 (x) (+ x 4)) + (should (equal (sm-test2 6) 10)) + (defadvice sm-test2 (around sm-test activate) ad-do-it (setq ad-return-value (* ad-return-value 5))) - (sm-test2 6) 50) - ((ad-deactivate 'sm-test2) - (sm-test2 6) 10) - ((ad-activate 'sm-test2) - (sm-test2 6) 50) - ((defun sm-test2 (x) (+ x 14)) - (sm-test2 6) 100) - ((null (get 'sm-test2 'defalias-fset-function)) nil) - ((ad-remove-advice 'sm-test2 'around 'sm-test) - (sm-test2 6) 100) - ((ad-activate 'sm-test2) - (sm-test2 6) 20) - ((null (get 'sm-test2 'defalias-fset-function)) t) + (should (equal (sm-test2 6) 50)) + (ad-deactivate 'sm-test2) + (should (equal (sm-test2 6) 10)) + (ad-activate 'sm-test2) + (should (equal (sm-test2 6) 50)) + (defun sm-test2 (x) (+ x 14)) + (should (equal (sm-test2 6) 100)) + (should (equal (null (get 'sm-test2 'defalias-fset-function)) nil)) + (ad-remove-advice 'sm-test2 'around 'sm-test) + (should (equal (sm-test2 6) 100)) + (ad-activate 'sm-test2) + (should (equal (sm-test2 6) 20)) + (should (equal (null (get 'sm-test2 'defalias-fset-function)) t)) - ((advice-add 'sm-test3 :around + (advice-add 'sm-test3 :around (lambda (f &rest args) `(toto ,(apply f args))) '((name . wrap-with-toto))) (defmacro sm-test3 (x) `(call-test3 ,x)) - (macroexpand '(sm-test3 56)) (toto (call-test3 56))) + (should (equal (macroexpand '(sm-test3 56)) '(toto (call-test3 56)))) - ((defadvice sm-test4 (around wrap-with-toto activate) + (defadvice sm-test4 (around wrap-with-toto activate) ad-do-it (setq ad-return-value `(toto ,ad-return-value))) (defmacro sm-test4 (x) `(call-test4 ,x)) - (macroexpand '(sm-test4 56)) (toto (call-test4 56))) - ((defmacro sm-test4 (x) `(call-testq ,x)) - (macroexpand '(sm-test4 56)) (toto (call-testq 56))) + (should (equal (macroexpand '(sm-test4 56)) '(toto (call-test4 56)))) + (defmacro sm-test4 (x) `(call-testq ,x)) + (should (equal (macroexpand '(sm-test4 56)) '(toto (call-testq 56)))) ;; Combining old style and new style advices. - ((defun sm-test5 (x) (+ x 4)) - (sm-test5 6) 10) - ((advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5))) - (sm-test5 6) 50) - ((defadvice sm-test5 (around test activate) + (defun sm-test5 (x) (+ x 4)) + (should (equal (sm-test5 6) 10)) + (advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test5 6) 50)) + (defadvice sm-test5 (around test activate) ad-do-it (setq ad-return-value (+ ad-return-value 0.1))) - (sm-test5 5) 45.1) - ((ad-deactivate 'sm-test5) - (sm-test5 6) 50) - ((ad-activate 'sm-test5) - (sm-test5 6) 50.1) - ((defun sm-test5 (x) (+ x 14)) - (sm-test5 6) 100.1) - ((advice-remove 'sm-test5 (lambda (f y) (* (funcall f y) 5))) - (sm-test5 6) 20.1) + (should (equal (sm-test5 5) 45.1)) + (ad-deactivate 'sm-test5) + (should (equal (sm-test5 6) 50)) + (ad-activate 'sm-test5) + (should (equal (sm-test5 6) 50.1)) + (defun sm-test5 (x) (+ x 14)) + (should (equal (sm-test5 6) 100.1)) + (advice-remove 'sm-test5 (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test5 6) 20.1)) ;; This used to signal an error (bug#12858). - ((autoload 'sm-test6 "foo") + (autoload 'sm-test6 "foo") (defadvice sm-test6 (around test activate) ad-do-it) - t t) + ;; Check interaction between advice and called-interactively-p. + (defun sm-test7 (&optional x) (interactive) (+ (or x 7) 4)) + (advice-add 'sm-test7 :around + (lambda (f &rest args) + (list (cons 1 (called-interactively-p)) (apply f args)))) + (should (equal (sm-test7) '((1 . nil) 11))) + (should (equal (call-interactively 'sm-test7) '((1 . t) 11))) + (let ((smi 7)) + (advice-add 'sm-test7 :before + (lambda (&rest args) + (setq smi (called-interactively-p)))) + (should (equal (list (sm-test7) smi) + '(((1 . nil) 11) nil))) + (should (equal (list (call-interactively 'sm-test7) smi) + '(((1 . t) 11) t)))) + (advice-add 'sm-test7 :around + (lambda (f &rest args) + (cons (cons 2 (called-interactively-p)) (apply f args)))) + (should (equal (call-interactively 'sm-test7) '((2 . t) (1 . t) 11))) )) -(ert-deftest advice-tests () - "Test advice code." - (with-temp-buffer - (dolist (test advice-tests--data) - (let ((res (eval `(progn ,@(butlast test))))) - (should (equal (car (last test)) res)))))) - ;; Local Variables: ;; no-byte-compile: t ;; End: ------------------------------------------------------------ revno: 110954 committer: Glenn Morris branch nick: trunk timestamp: Mon 2012-11-19 19:57:23 -0500 message: Add a menu for profiler report mode * lisp/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. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-11-19 21:30:55 +0000 +++ lisp/ChangeLog 2012-11-20 00:57:23 +0000 @@ -1,3 +1,9 @@ +2012-11-20 Glenn Morris + + * 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 * emacs-lisp/byte-run.el (defun-declarations-alist): === modified file 'lisp/profiler.el' --- lisp/profiler.el 2012-10-27 09:54:04 +0000 +++ lisp/profiler.el 2012-11-20 00:57:23 +0000 @@ -404,7 +404,6 @@ (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 @@ (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 @@ (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." ------------------------------------------------------------ revno: 110953 committer: Paul Eggert branch nick: trunk timestamp: Mon 2012-11-19 15:39:28 -0800 message: Improve static checking of integer overflow and stack smashing. * configure.ac (WARN_CFLAGS): Add -Wstack-protector and -Wstrict-overflow if using GCC 4.7.2 or later on a platform with at least 64-bit long int. This improves static checking on these platforms, when configured with --enable-gcc-warnings. diff: === modified file 'ChangeLog' --- ChangeLog 2012-11-17 22:12:47 +0000 +++ ChangeLog 2012-11-19 23:39:28 +0000 @@ -1,3 +1,11 @@ +2012-11-19 Paul Eggert + + Improve static checking of integer overflow and stack smashing. + * configure.ac (WARN_CFLAGS): Add -Wstack-protector and + -Wstrict-overflow if using GCC 4.7.2 or later on a platform with + at least 64-bit long int. This improves static checking on these + platforms, when configured with --enable-gcc-warnings. + 2012-11-17 Paul Eggert Assume POSIX 1003.1-1988 or later for fcntl.h (Bug#12881). === modified file 'configure.ac' --- configure.ac 2012-11-17 22:12:47 +0000 +++ configure.ac 2012-11-19 23:39:28 +0000 @@ -717,11 +717,24 @@ # . nw="$nw -Wshadow" - # The following lines should be removable at some point. - nw="$nw -Wstack-protector" - nw="$nw -Wstrict-overflow" + # The following line should be removable at some point. nw="$nw -Wsuggest-attribute=pure" + AC_MSG_CHECKING([whether to use -Wstack-protector -Wstrict-overflow]) + AC_PREPROC_IFELSE( + [AC_LANG_PROGRAM( + [[#if (1 <= __LONG_MAX__ >> 31 >> 31 \ + && 4 < __GNUC__ + (7 < __GNUC_MINOR__ + (2 <= __GNUC_PATCHLEVEL__))) + /* OK */ + #else + #error "Not GCC, or GCC before 4.7.2, or 'long int' has < 64 bits." + #endif + ]])], + [AC_MSG_RESULT(yes)], + [AC_MSG_RESULT(no) + nw="$nw -Wstack-protector" + nw="$nw -Wstrict-overflow"]) + gl_MANYWARN_ALL_GCC([ws]) gl_MANYWARN_COMPLEMENT([ws], [$ws], [$nw]) for w in $ws; do ------------------------------------------------------------ revno: 110952 committer: Stefan Monnier branch nick: trunk timestamp: Mon 2012-11-19 16:30:55 -0500 message: * lisp/emacs-lisp/byte-run.el (defun-declarations-alist): Allow compiler-macros to be lambda expressions. * lisp/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. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-11-19 18:40:18 +0000 +++ lisp/ChangeLog 2012-11-19 21:30:55 +0000 @@ -1,5 +1,13 @@ 2012-11-19 Stefan Monnier + * 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 === modified file 'lisp/emacs-lisp/byte-run.el' --- lisp/emacs-lisp/byte-run.el 2012-10-15 04:03:04 +0000 +++ lisp/emacs-lisp/byte-run.el 2012-11-19 21:30:55 +0000 @@ -81,8 +81,14 @@ #'(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)))) === modified file 'lisp/progmodes/python.el' --- lisp/progmodes/python.el 2012-11-12 13:26:50 +0000 +++ lisp/progmodes/python.el 2012-11-19 21:30:55 +0000 @@ -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 @@ "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 @@ (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 @@ (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 @@ (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 @@ ;; 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 @@ (+ (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 @@ '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 @@ ;; 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 @@ (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 ------------------------------------------------------------ revno: 110951 committer: Stefan Monnier branch nick: trunk timestamp: Mon 2012-11-19 13:40:18 -0500 message: * lisp/vc/diff-mode.el (diff-hunk): Don't make useless timers. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-11-19 18:27:25 +0000 +++ lisp/ChangeLog 2012-11-19 18:40:18 +0000 @@ -1,5 +1,7 @@ 2012-11-19 Stefan Monnier + * 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). === modified file 'lisp/vc/diff-mode.el' --- lisp/vc/diff-mode.el 2012-11-08 17:31:53 +0000 +++ lisp/vc/diff-mode.el 2012-11-19 18:40:18 +0000 @@ -575,19 +575,21 @@ (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) ------------------------------------------------------------ revno: 110950 fixes bug: http://debbugs.gnu.org/cgi/bugreport.cgi?bug=12935 committer: Stefan Monnier branch nick: trunk timestamp: Mon 2012-11-19 13:27:25 -0500 message: * lisp/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. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-11-19 17:24:12 +0000 +++ lisp/ChangeLog 2012-11-19 18:27:25 +0000 @@ -1,5 +1,9 @@ 2012-11-19 Stefan Monnier + * 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'. === modified file 'lisp/files.el' --- lisp/files.el 2012-11-08 19:50:08 +0000 +++ lisp/files.el 2012-11-19 18:27:25 +0000 @@ -730,7 +730,7 @@ ;; 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) ------------------------------------------------------------ revno: 110949 committer: Stefan Monnier branch nick: trunk timestamp: Mon 2012-11-19 12:24:12 -0500 message: Use cl-lib instead of cl, and interactive-p => called-interactively-p. * lisp/erc/erc-track.el, lisp/erc/erc-networks.el, lisp/erc/erc-netsplit.el: * lisp/erc/erc-dcc.el, lisp/erc/erc-backend.el: Use cl-lib, nth, pcase, and called-interactively-p instead of cl. * lisp/erc/erc-speedbar.el, lisp/erc/erc-services.el: * lisp/erc/erc-pcomplete.el, lisp/erc/erc-notify.el, lisp/erc/erc-match.el: * lisp/erc/erc-log.el, lisp/erc/erc-join.el, lisp/erc/erc-ezbounce.el: * lisp/erc/erc-capab.el: Don't require cl since we don't use it. * lisp/erc/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. * lisp/json.el: Don't require cl since we don't use it. * lisp/color.el: Don't require cl. (color-complement): `caddr' -> `nth 2'. * test/automated/ert-x-tests.el: Use cl-lib. * test/automated/ert-tests.el: Use lexical-binding and cl-lib. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-11-19 16:17:49 +0000 +++ lisp/ChangeLog 2012-11-19 17:24:12 +0000 @@ -1,5 +1,9 @@ 2012-11-19 Stefan Monnier + * 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 === modified file 'lisp/color.el' --- lisp/color.el 2012-10-06 02:20:36 +0000 +++ lisp/color.el 2012-11-19 17:24:12 +0000 @@ -33,9 +33,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - ;; Emacs < 23.3 (eval-and-compile (unless (boundp 'float-pi) @@ -69,9 +66,9 @@ 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. === modified file 'lisp/erc/ChangeLog' --- lisp/erc/ChangeLog 2012-11-16 17:20:23 +0000 +++ lisp/erc/ChangeLog 2012-11-19 17:24:12 +0000 @@ -1,3 +1,16 @@ +2012-11-19 Stefan Monnier + + 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 * erc.el (erc-modules): Add "notifications". Tweak "hecomplete" doc. === modified file 'lisp/erc/erc-backend.el' --- lisp/erc/erc-backend.el 2012-10-28 15:32:15 +0000 +++ lisp/erc/erc-backend.el 2012-11-19 17:24:12 +0000 @@ -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 @@ (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 @@ (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 @@ "") 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 @@ (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 @@ (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 @@ 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 @@ (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 @@ (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 @@ "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 @@ (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 @@ (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 @@ (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 @@ "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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ "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 @@ (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 @@ (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 @@ (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 @@ "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 @@ ;; 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 @@ (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 @@ (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 @@ (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 @@ (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 @@ ;; 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 @@ (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 === modified file 'lisp/erc/erc-capab.el' --- lisp/erc/erc-capab.el 2012-10-06 01:04:53 +0000 +++ lisp/erc/erc-capab.el 2012-11-19 17:24:12 +0000 @@ -68,7 +68,6 @@ ;;; Code: (require 'erc) -(eval-when-compile (require 'cl)) ;;; Customization: === modified file 'lisp/erc/erc-dcc.el' --- lisp/erc/erc-dcc.el 2012-10-06 01:04:53 +0000 +++ lisp/erc/erc-dcc.el 2012-11-19 17:24:12 +0000 @@ -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 @@ (* (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 @@ (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 @@ (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)) - (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) 'GET)) - erc-dcc-list))) - (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 + (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) - (intern (upcase (pcomplete-arg 1))))) + (eq (plist-get elt :type) 'CHAT)) erc-dcc-list))) - (send (pcomplete-entries))))) + (`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)))) + (pcomplete-here + (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 @@ (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))) === modified file 'lisp/erc/erc-ezbounce.el' --- lisp/erc/erc-ezbounce.el 2012-10-06 01:04:53 +0000 +++ lisp/erc/erc-ezbounce.el 2012-11-19 17:24:12 +0000 @@ -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)" === modified file 'lisp/erc/erc-join.el' --- lisp/erc/erc-join.el 2012-10-06 01:04:53 +0000 +++ lisp/erc/erc-join.el 2012-11-19 17:24:12 +0000 @@ -34,7 +34,6 @@ (require 'erc) (require 'auth-source) -(eval-when-compile (require 'cl)) (defgroup erc-autojoin nil "Enable autojoining." === modified file 'lisp/erc/erc-log.el' --- lisp/erc/erc-log.el 2012-10-07 07:54:41 +0000 +++ lisp/erc/erc-log.el 2012-11-19 17:24:12 +0000 @@ -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 @@ 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)) === modified file 'lisp/erc/erc-match.el' --- lisp/erc/erc-match.el 2012-10-06 01:04:53 +0000 +++ lisp/erc/erc-match.el 2012-11-19 17:24:12 +0000 @@ -35,7 +35,6 @@ ;;; Code: (require 'erc) -(eval-when-compile (require 'cl)) ;; Customization: === modified file 'lisp/erc/erc-netsplit.el' --- lisp/erc/erc-netsplit.el 2012-10-06 01:04:53 +0000 +++ lisp/erc/erc-netsplit.el 2012-11-19 17:24:12 +0000 @@ -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 @@ (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 @@ ;; 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 @@ 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) === modified file 'lisp/erc/erc-networks.el' --- lisp/erc/erc-networks.el 2012-10-06 01:04:53 +0000 +++ lisp/erc/erc-networks.el 2012-11-19 17:24:12 +0000 @@ -40,7 +40,7 @@ ;;; Code: (require 'erc) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; Variables @@ -729,10 +729,10 @@ (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 @@ (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))) === modified file 'lisp/erc/erc-notify.el' --- lisp/erc/erc-notify.el 2012-10-06 01:04:53 +0000 +++ lisp/erc/erc-notify.el 2012-11-19 17:24:12 +0000 @@ -30,9 +30,7 @@ (require 'erc) (require 'erc-networks) -(eval-when-compile - (require 'cl) - (require 'pcomplete)) +(eval-when-compile (require 'pcomplete)) ;;;; Customizable variables === modified file 'lisp/erc/erc-pcomplete.el' --- lisp/erc/erc-pcomplete.el 2012-10-06 01:04:53 +0000 +++ lisp/erc/erc-pcomplete.el 2012-11-19 17:24:12 +0000 @@ -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" === modified file 'lisp/erc/erc-services.el' --- lisp/erc/erc-services.el 2012-10-06 01:04:53 +0000 +++ lisp/erc/erc-services.el 2012-11-19 17:24:12 +0000 @@ -62,7 +62,7 @@ (require 'erc) (require 'erc-networks) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; Customization: === modified file 'lisp/erc/erc-speedbar.el' --- lisp/erc/erc-speedbar.el 2012-10-06 01:04:53 +0000 +++ lisp/erc/erc-speedbar.el 2012-11-19 17:24:12 +0000 @@ -38,7 +38,6 @@ (require 'erc) (require 'speedbar) (condition-case nil (require 'dframe) (error nil)) -(eval-when-compile (require 'cl)) ;;; Customization: === modified file 'lisp/erc/erc-track.el' --- lisp/erc/erc-track.el 2012-10-06 01:04:53 +0000 +++ lisp/erc/erc-track.el 2012-11-19 17:24:12 +0000 @@ -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 @@ ;;; Test: -(assert +(cl-assert (and ;; verify examples from the doc strings (equal (let ((erc-track-shorten-aggressively nil)) @@ -869,7 +869,7 @@ (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 @@ (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 @@ (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)))) === modified file 'lisp/erc/erc.el' --- lisp/erc/erc.el 2012-11-13 03:40:44 +0000 +++ lisp/erc/erc.el 2012-11-19 17:24:12 +0000 @@ -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 @@ (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 @@ (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 @@ 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 @@ (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 @@ (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 @@ :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 @@ "" 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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ :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 @@ (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 here (insert string) - (if (interactive-p) + (if (called-interactively-p 'interactive) (message "%s" string) string)))) === modified file 'lisp/json.el' --- lisp/json.el 2012-09-27 22:55:03 +0000 +++ lisp/json.el 2012-11-19 17:24:12 +0000 @@ -51,7 +51,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) ;; Compatibility code === modified file 'test/ChangeLog' --- test/ChangeLog 2012-11-14 12:17:21 +0000 +++ test/ChangeLog 2012-11-19 17:24:12 +0000 @@ -1,3 +1,8 @@ +2012-11-19 Stefan Monnier + + * automated/ert-x-tests.el: Use cl-lib. + * automated/ert-tests.el: Use lexical-binding and cl-lib. + 2012-11-14 Dmitry Gutov * automated/ruby-mode-tests.el (ruby-indent-singleton-class): Pass. @@ -5,8 +10,8 @@ (ruby-indent-inside-heredoc-after-space): New tests. Change direct font-lock face references to var references. (ruby-interpolation-suppresses-syntax-inside): New test. - (ruby-interpolation-inside-percent-literal-with-paren): New - failing test. + (ruby-interpolation-inside-percent-literal-with-paren): + New failing test. 2012-11-13 Dmitry Gutov === modified file 'test/automated/ert-tests.el' --- test/automated/ert-tests.el 2012-01-05 09:46:05 +0000 +++ test/automated/ert-tests.el 2012-11-19 17:24:12 +0000 @@ -1,4 +1,4 @@ -;;; ert-tests.el --- ERT's self-tests +;;; ert-tests.el --- ERT's self-tests -*- lexical-binding: t -*- ;; Copyright (C) 2007-2008, 2010-2012 Free Software Foundation, Inc. @@ -27,7 +27,7 @@ ;;; Code: (eval-when-compile - (require 'cl)) + (require 'cl-lib)) (require 'ert) @@ -45,7 +45,7 @@ ;; The buffer name chosen here should not compete with the default ;; results buffer name for completion in `switch-to-buffer'. (let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*"))) - (assert ert--test-body-was-run) + (cl-assert ert--test-body-was-run) (if (zerop (ert-stats-completed-unexpected stats)) ;; Hide results window only when everything went well. (set-window-configuration window-configuration) @@ -71,26 +71,26 @@ (ert-deftest ert-test-nested-test-body-runs () "Test that nested test bodies run." - (lexical-let ((was-run nil)) + (let ((was-run nil)) (let ((test (make-ert-test :body (lambda () (setq was-run t))))) - (assert (not was-run)) + (cl-assert (not was-run)) (ert-run-test test) - (assert was-run)))) + (cl-assert was-run)))) ;;; Test that pass/fail works. (ert-deftest ert-test-pass () (let ((test (make-ert-test :body (lambda ())))) (let ((result (ert-run-test test))) - (assert (ert-test-passed-p result))))) + (cl-assert (ert-test-passed-p result))))) (ert-deftest ert-test-fail () (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) (let ((result (let ((ert-debug-on-error nil)) (ert-run-test test)))) - (assert (ert-test-failed-p result) t) - (assert (equal (ert-test-result-with-condition-condition result) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) '(ert-test-failed "failure message")) t)))) @@ -100,50 +100,50 @@ (progn (let ((ert-debug-on-error t)) (ert-run-test test)) - (assert nil)) + (cl-assert nil)) ((error) - (assert (equal condition '(ert-test-failed "failure message")) t))))) + (cl-assert (equal condition '(ert-test-failed "failure message")) t))))) (ert-deftest ert-test-fail-debug-with-debugger-1 () (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) - (let ((debugger (lambda (&rest debugger-args) - (assert nil)))) + (let ((debugger (lambda (&rest _args) + (cl-assert nil)))) (let ((ert-debug-on-error nil)) (ert-run-test test))))) (ert-deftest ert-test-fail-debug-with-debugger-2 () (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) - (block nil - (let ((debugger (lambda (&rest debugger-args) - (return-from nil nil)))) + (cl-block nil + (let ((debugger (lambda (&rest _args) + (cl-return-from nil nil)))) (let ((ert-debug-on-error t)) (ert-run-test test)) - (assert nil))))) + (cl-assert nil))))) (ert-deftest ert-test-fail-debug-nested-with-debugger () (let ((test (make-ert-test :body (lambda () (let ((ert-debug-on-error t)) (ert-fail "failure message")))))) - (let ((debugger (lambda (&rest debugger-args) - (assert nil nil "Assertion a")))) + (let ((debugger (lambda (&rest _args) + (cl-assert nil nil "Assertion a")))) (let ((ert-debug-on-error nil)) (ert-run-test test)))) (let ((test (make-ert-test :body (lambda () (let ((ert-debug-on-error nil)) (ert-fail "failure message")))))) - (block nil - (let ((debugger (lambda (&rest debugger-args) - (return-from nil nil)))) + (cl-block nil + (let ((debugger (lambda (&rest _args) + (cl-return-from nil nil)))) (let ((ert-debug-on-error t)) (ert-run-test test)) - (assert nil nil "Assertion b"))))) + (cl-assert nil nil "Assertion b"))))) (ert-deftest ert-test-error () (let ((test (make-ert-test :body (lambda () (error "Error message"))))) (let ((result (let ((ert-debug-on-error nil)) (ert-run-test test)))) - (assert (ert-test-failed-p result) t) - (assert (equal (ert-test-result-with-condition-condition result) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) '(error "Error message")) t)))) @@ -153,9 +153,9 @@ (progn (let ((ert-debug-on-error t)) (ert-run-test test)) - (assert nil)) + (cl-assert nil)) ((error) - (assert (equal condition '(error "Error message")) t))))) + (cl-assert (equal condition '(error "Error message")) t))))) ;;; Test that `should' works. @@ -163,13 +163,13 @@ (let ((test (make-ert-test :body (lambda () (should nil))))) (let ((result (let ((ert-debug-on-error nil)) (ert-run-test test)))) - (assert (ert-test-failed-p result) t) - (assert (equal (ert-test-result-with-condition-condition result) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) '(ert-test-failed ((should nil) :form nil :value nil))) t))) (let ((test (make-ert-test :body (lambda () (should t))))) (let ((result (ert-run-test test))) - (assert (ert-test-passed-p result) t)))) + (cl-assert (ert-test-passed-p result) t)))) (ert-deftest ert-test-should-value () (should (eql (should 'foo) 'foo)) @@ -179,17 +179,18 @@ (let ((test (make-ert-test :body (lambda () (should-not t))))) (let ((result (let ((ert-debug-on-error nil)) (ert-run-test test)))) - (assert (ert-test-failed-p result) t) - (assert (equal (ert-test-result-with-condition-condition result) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) '(ert-test-failed ((should-not t) :form t :value t))) t))) (let ((test (make-ert-test :body (lambda () (should-not nil))))) (let ((result (ert-run-test test))) - (assert (ert-test-passed-p result))))) + (cl-assert (ert-test-passed-p result))))) + (ert-deftest ert-test-should-with-macrolet () (let ((test (make-ert-test :body (lambda () - (macrolet ((foo () `(progn t nil))) + (cl-macrolet ((foo () `(progn t nil))) (should (foo))))))) (let ((result (let ((ert-debug-on-error nil)) (ert-run-test test)))) @@ -303,32 +304,33 @@ (ert-deftest ert-test-should-failure-debugging () "Test that `should' errors contain the information we expect them to." - (loop for (body expected-condition) in - `((,(lambda () (let ((x nil)) (should x))) - (ert-test-failed ((should x) :form x :value nil))) - (,(lambda () (let ((x t)) (should-not x))) - (ert-test-failed ((should-not x) :form x :value t))) - (,(lambda () (let ((x t)) (should (not x)))) - (ert-test-failed ((should (not x)) :form (not t) :value nil))) - (,(lambda () (let ((x nil)) (should-not (not x)))) - (ert-test-failed ((should-not (not x)) :form (not nil) :value t))) - (,(lambda () (let ((x t) (y nil)) (should-not - (ert--test-my-list x y)))) - (ert-test-failed - ((should-not (ert--test-my-list x y)) - :form (list t nil) - :value (t nil)))) - (,(lambda () (let ((x t)) (should (error "Foo")))) - (error "Foo"))) - do - (let ((test (make-ert-test :body body))) - (condition-case actual-condition - (progn - (let ((ert-debug-on-error t)) - (ert-run-test test)) - (assert nil)) - ((error) - (should (equal actual-condition expected-condition))))))) + (cl-loop + for (body expected-condition) in + `((,(lambda () (let ((x nil)) (should x))) + (ert-test-failed ((should x) :form x :value nil))) + (,(lambda () (let ((x t)) (should-not x))) + (ert-test-failed ((should-not x) :form x :value t))) + (,(lambda () (let ((x t)) (should (not x)))) + (ert-test-failed ((should (not x)) :form (not t) :value nil))) + (,(lambda () (let ((x nil)) (should-not (not x)))) + (ert-test-failed ((should-not (not x)) :form (not nil) :value t))) + (,(lambda () (let ((x t) (y nil)) (should-not + (ert--test-my-list x y)))) + (ert-test-failed + ((should-not (ert--test-my-list x y)) + :form (list t nil) + :value (t nil)))) + (,(lambda () (let ((_x t)) (should (error "Foo")))) + (error "Foo"))) + do + (let ((test (make-ert-test :body body))) + (condition-case actual-condition + (progn + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (cl-assert nil)) + ((error) + (should (equal actual-condition expected-condition))))))) (ert-deftest ert-test-deftest () (should (equal (macroexpand '(ert-deftest abc () "foo" :tags '(bar))) @@ -520,7 +522,7 @@ (setf (cdr (last a)) (cddr a)) (should (not (ert--proper-list-p a)))) (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) (cdddr a)) + (setf (cdr (last a)) (cl-cdddr a)) (should (not (ert--proper-list-p a))))) (ert-deftest ert-test-parse-keys-and-body () @@ -657,14 +659,14 @@ (i 0)) (let ((result (ert--remove-if-not (lambda (x) (should (eql x (nth i list))) - (incf i) + (cl-incf i) (member i '(2 3))) list))) (should (equal i 4)) (should (equal result '(b c))) (should (equal list '(a b c d))))) (should (equal '() - (ert--remove-if-not (lambda (x) (should nil)) '())))) + (ert--remove-if-not (lambda (_x) (should nil)) '())))) (ert-deftest ert-test-remove* () (let ((list (list 'a 'b 'c 'd)) @@ -676,13 +678,13 @@ (should (eql x (nth key-index list))) (prog1 (list key-index x) - (incf key-index))) + (cl-incf key-index))) :test (lambda (a b) (should (eql a 'foo)) (should (equal b (list test-index (nth test-index list)))) - (incf test-index) + (cl-incf test-index) (member test-index '(2 3)))))) (should (equal key-index 4)) (should (equal test-index 4)) === modified file 'test/automated/ert-x-tests.el' --- test/automated/ert-x-tests.el 2012-06-27 15:11:28 +0000 +++ test/automated/ert-x-tests.el 2012-11-19 17:24:12 +0000 @@ -28,7 +28,7 @@ ;;; Code: (eval-when-compile - (require 'cl)) + (require 'cl-lib)) (require 'ert) (require 'ert-x) @@ -233,8 +233,8 @@ (should (equal (buffer-string) "")) (let ((message-log-max 2)) (let ((message-log-max t)) - (loop for i below 4 do - (message "%s" i)) + (cl-loop for i below 4 do + (message "%s" i)) (should (equal (buffer-string) "0\n1\n2\n3\n"))) (should (equal (buffer-string) "0\n1\n2\n3\n")) (message "") @@ -244,28 +244,28 @@ (ert-deftest ert-test-force-message-log-buffer-truncation () :tags '(:causes-redisplay) - (labels ((body () - (loop for i below 3 do - (message "%s" i))) - ;; Uses the implicit messages buffer truncation implemented - ;; in Emacs' C core. - (c (x) - (ert-with-buffer-renamed ("*Messages*") - (let ((message-log-max x)) - (body)) - (with-current-buffer "*Messages*" - (buffer-string)))) - ;; Uses our lisp reimplementation. - (lisp (x) - (ert-with-buffer-renamed ("*Messages*") - (let ((message-log-max t)) - (body)) - (let ((message-log-max x)) - (ert--force-message-log-buffer-truncation)) - (with-current-buffer "*Messages*" - (buffer-string))))) - (loop for x in '(0 1 2 3 4 t) do - (should (equal (c x) (lisp x)))))) + (cl-labels ((body () + (cl-loop for i below 3 do + (message "%s" i))) + ;; Uses the implicit messages buffer truncation implemented + ;; in Emacs' C core. + (c (x) + (ert-with-buffer-renamed ("*Messages*") + (let ((message-log-max x)) + (body)) + (with-current-buffer "*Messages*" + (buffer-string)))) + ;; Uses our lisp reimplementation. + (lisp (x) + (ert-with-buffer-renamed ("*Messages*") + (let ((message-log-max t)) + (body)) + (let ((message-log-max x)) + (ert--force-message-log-buffer-truncation)) + (with-current-buffer "*Messages*" + (buffer-string))))) + (cl-loop for x in '(0 1 2 3 4 t) do + (should (equal (c x) (lisp x)))))) (provide 'ert-x-tests) ------------------------------------------------------------ revno: 110948 committer: Stefan Monnier branch nick: trunk timestamp: Mon 2012-11-19 11:17:49 -0500 message: * lisp/calendar/time-date.el (time-to-seconds): De-obsolete. diff: === modified file 'etc/NEWS' --- etc/NEWS 2012-11-19 01:39:37 +0000 +++ etc/NEWS 2012-11-19 16:17:49 +0000 @@ -52,6 +52,7 @@ * Lisp changes in Emacs 24.4 +** time-to-seconds is not obsolete any more. ** New function special-form-p. ** Docstrings can be made dynamic by adding a `dynamic-docstring-function' text-property on the first char. === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-11-19 05:03:08 +0000 +++ lisp/ChangeLog 2012-11-19 16:17:49 +0000 @@ -1,3 +1,7 @@ +2012-11-19 Stefan Monnier + + * calendar/time-date.el (time-to-seconds): De-obsolete. + 2012-11-19 Jay Belanger * calc/calc-forms.el (math-leap-year-p): Fix formula for negative @@ -7,8 +11,8 @@ 2012-11-19 Daniel Colascione - * term/w32-win.el (cygwin-convert-path-from-windows): Accomodate - rename of cygwin_convert_path* to cygwin_convert_file_name*. + * 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 === modified file 'lisp/calendar/time-date.el' --- lisp/calendar/time-date.el 2012-06-22 21:17:42 +0000 +++ lisp/calendar/time-date.el 2012-11-19 16:17:49 +0000 @@ -134,9 +134,7 @@ ;;;###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 ------------------------------------------------------------ revno: 110947 committer: Stefan Monnier branch nick: trunk timestamp: Mon 2012-11-19 11:16:07 -0500 message: * lisp/cedet/semantic/fw.el (semantic-make-local-hook) (semantic-mode-line-update): Simplify via CSE. diff: === modified file 'lisp/cedet/ChangeLog' --- lisp/cedet/ChangeLog 2012-11-16 17:20:23 +0000 +++ lisp/cedet/ChangeLog 2012-11-19 16:16:07 +0000 @@ -1,12 +1,17 @@ +2012-11-19 Stefan Monnier + + * semantic/fw.el (semantic-make-local-hook, semantic-mode-line-update): + Simplify via CSE. + 2012-11-16 David Engster - * 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. === modified file 'lisp/cedet/semantic/fw.el' --- lisp/cedet/semantic/fw.el 2012-11-14 20:20:20 +0000 +++ lisp/cedet/semantic/fw.el 2012-11-19 16:16:07 +0000 @@ -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. ------------------------------------------------------------ revno: 110946 committer: Katsumi Yamaoka branch nick: trunk timestamp: Mon 2012-11-19 11:36:02 +0000 message: message.el (message-get-reply-headers): Fix typo in comment diff: === modified file 'lisp/gnus/message.el' --- lisp/gnus/message.el 2012-11-19 06:24:14 +0000 +++ lisp/gnus/message.el 2012-11-19 11:36:02 +0000 @@ -6734,7 +6734,7 @@ mft (and message-use-mail-followup-to (message-fetch-field "mail-followup-to"))) ;; Make sure this message goes to the author if this is a wide - ;; reply, sine Reply-To address may be a list address a mailing + ;; reply, since Reply-To address may be a list address a mailing ;; list server added. (when (and wide author) (setq cc (concat author ", " cc))) ------------------------------------------------------------ revno: 110945 committer: Katsumi Yamaoka branch nick: trunk timestamp: Mon 2012-11-19 06:24:14 +0000 message: message.el (message-get-reply-headers): Make sure the reply goes to the author if it is a wide reply diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2012-11-16 17:20:23 +0000 +++ lisp/gnus/ChangeLog 2012-11-19 06:24:14 +0000 @@ -1,3 +1,8 @@ +2012-11-19 Katsumi Yamaoka + + * 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 * gnus-score.el (gnus-score-body): === modified file 'lisp/gnus/message.el' --- lisp/gnus/message.el 2012-11-02 23:37:02 +0000 +++ lisp/gnus/message.el 2012-11-19 06:24:14 +0000 @@ -6730,11 +6730,16 @@ ", ")) 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, sine 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