diff --git a/admin/ChangeLog b/admin/ChangeLog index 7d77becb522..5da0bf0c67d 100644 --- a/admin/ChangeLog +++ b/admin/ChangeLog @@ -1,3 +1,8 @@ +2013-01-15 Dmitry Antipov + + * coccinelle/xsave.cocci: Semantic patch to adjust users of + XSAVE_POINTER and XSAVE_INTEGER macros. + 2013-01-03 Glenn Morris * check-doc-strings: Update for CVS->bzr, moved lispref/ directory. diff --git a/admin/coccinelle/xsave.cocci b/admin/coccinelle/xsave.cocci new file mode 100644 index 00000000000..5172bb55b33 --- /dev/null +++ b/admin/coccinelle/xsave.cocci @@ -0,0 +1,11 @@ +// Adjust users of XSAVE_POINTER and XSAVE_INTEGER. +@@ +expression E; +@@ +( +- XSAVE_POINTER (E) ++ XSAVE_POINTER (E, 0) +| +- XSAVE_INTEGER (E) ++ XSAVE_INTEGER (E, 1) +) diff --git a/lib-src/ChangeLog b/lib-src/ChangeLog index 92b970eb778..2bdbebeb110 100644 --- a/lib-src/ChangeLog +++ b/lib-src/ChangeLog @@ -1,3 +1,9 @@ +2013-01-15 Paul Eggert + + * make-docfile.c (write_globals): Make it a bit clearer (Bug#13448). + This pacifies GCC 4.7.2 when Emacs is configured with + --enable-link-time-optimization and --enable-gcc-warnings. + 2013-01-01 Juanma Barranquero * makefile.w32-in (lisp1): Add macroexp.elc (bug#13320). diff --git a/lib-src/make-docfile.c b/lib-src/make-docfile.c index 54a53c0d441..68e5279fd15 100644 --- a/lib-src/make-docfile.c +++ b/lib-src/make-docfile.c @@ -624,7 +624,7 @@ write_globals (void) qsort (globals, num_globals, sizeof (struct global), compare_globals); for (i = 0; i < num_globals; ++i) { - char const *type; + char const *type = 0; switch (globals[i].type) { @@ -649,7 +649,7 @@ write_globals (void) fatal ("not a recognized DEFVAR_", 0); } - if (globals[i].type != FUNCTION) + if (type) { fprintf (outfile, " %s f_%s;\n", type, globals[i].name); fprintf (outfile, "#define %s globals.f_%s\n", diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d4a81bffd9c..f324ebbad51 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,29 @@ +2013-01-15 Stefan Monnier + + * emacs-lisp/nadvice.el (advice--tweak): Make it possible for `tweak' + to return an explicit nil. + (advice--remove-function): Change accordingly. + + * emacs-lisp/advice.el (ad-preactivate-advice): Adjust the cleanup to + the use of nadvice.el. + + * progmodes/which-func.el (which-function): Silence imenu errors + (bug#13433). + +2013-01-15 Michael R. Mauger + + * progmodes/sql.el: (sql-imenu-generic-expression): + (sql-mode-font-lock-object-name): Match schema qualified names. + (sql-connect): Use string keys. + (sql-product-interactive): Wait for interpreter prompt. + (sql-comint-oracle): Set process coding based on NLS_LANG. + +2013-01-15 Michael R. Mauger + + * progmodes/sql.el (sql-output-to-send): Remove, unused. + (sql-interactive-remove-continuation-prompt): + (sql-send-magic-terminator, sql-interactive-mode): Remove references. + 2013-01-14 Leo Liu * calendar/calendar.el (calendar-redraw): Sync window-point and point. @@ -10,22 +36,21 @@ 2013-01-13 Fabián Ezequiel Gallina - * progmodes/python.el (python-nav-end-of-statement): Fix - cornercase when handling multiline strings. + * progmodes/python.el (python-nav-end-of-statement): + Fix cornercase when handling multiline strings. 2013-01-13 Richard Stallman * mail/sendmail.el (mail-position-on-field): Add doc string. - * mail/rmailmm.el (rmail-insert-mime-forwarded-message): Get - current message boundaries and pass them to + * mail/rmailmm.el (rmail-insert-mime-forwarded-message): + Get current message boundaries and pass them to message-forward-make-body-mime. Minor style changes. 2013-01-13 Eli Zaretskii * cus-start.el (all): Avoid warnings about - scroll-bar-adjust-thumb-portion on platforms where it is not - defined. + scroll-bar-adjust-thumb-portion on platforms where it is not defined. 2013-01-11 Jan Djärv diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 07340f06a13..3d03e894534 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2866,10 +2866,8 @@ advised definition from scratch." (defun ad-preactivate-advice (function advice class position) "Preactivate FUNCTION and returns the constructed cache." - (let* ((function-defined-p (fboundp function)) - (old-definition - (if function-defined-p - (symbol-function function))) + (let* ((advicefunname (ad-get-advice-info-field function 'advicefunname)) + (old-advice (symbol-function advicefunname)) (old-advice-info (ad-copy-advice-info function)) (ad-advised-functions ad-advised-functions)) (unwind-protect @@ -2883,10 +2881,9 @@ advised definition from scratch." (list (ad-get-cache-definition function) (ad-get-cache-id function)))) (ad-set-advice-info function old-advice-info) - ;; Don't `fset' function to nil if it was previously unbound: - (if function-defined-p - (fset function old-definition) - (fmakunbound function))))) + (advice-remove function advicefunname) + (fset advicefunname old-advice) + (if old-advice (advice-add function :around advicefunname))))) ;; @@ Activation and definition handling: diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 1715763d482..b0711fed26c 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -173,20 +173,21 @@ WHERE is a symbol to select an entry in `advice--where-alist'." (let ((first (advice--car flist)) (rest (advice--cdr flist)) (props (advice--props flist))) - (or (funcall tweaker first rest props) + (let ((val (funcall tweaker first rest props))) + (if val (car val) (let ((nrest (advice--tweak rest tweaker))) (if (eq rest nrest) flist (advice--make-1 (aref flist 1) (aref flist 3) - first nrest props))))))) + first nrest props)))))))) ;;;###autoload (defun advice--remove-function (flist function) (advice--tweak flist (lambda (first rest props) - (if (or (not first) - (equal function first) + (cond ((not first) rest) + ((or (equal function first) (equal function (cdr (assq 'name props)))) - rest)))) + (list rest)))))) (defvar advice--buffer-local-function-sample nil) diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 2b09a1f456c..733f1d26510 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,7 +1,12 @@ +2013-01-15 Stefan Monnier + + * nnimap.el (nnimap-keepalive): Don't throw an error if there's no more + imap process running. + 2013-01-14 Julien Danjou - * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Compare - addresses against addresses, not against the full From field. + * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): + Compare addresses against addresses, not against the full From field. 2013-01-13 Richard Stallman @@ -178,8 +183,8 @@ the `face' property with a list whose car is the face specified in the format string and whose cdr is (nil). * lisp/gnus-util.el - (gnus-put-text-property-excluding-characters-with-faces): Change - accordingly. + (gnus-put-text-property-excluding-characters-with-faces): + Change accordingly. (gnus-get-text-property-excluding-characters-with-faces): New function. * lisp/gnus-sum.el (gnus-summary-highlight-line): * lisp/gnus-salt.el (gnus-tree-highlight-node): @@ -227,8 +232,8 @@ 2012-12-22 Philipp Haselwarter - * gnus-sync.el (gnus-sync-file-encrypt-to, gnus-sync-save): Set - epa-file-encrypt-to from variable to avoid querying. + * gnus-sync.el (gnus-sync-file-encrypt-to, gnus-sync-save): + Set epa-file-encrypt-to from variable to avoid querying. 2012-12-14 Akinori MUSHA (tiny change) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index ea579fa3a2b..9c18bc2cff0 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -339,7 +339,8 @@ textual parts.") (nnimap-last-command-time nnimap-object))) ;; More than five minutes since the last command. (* 5 60))) - (nnimap-send-command "NOOP"))))))) + (ignore-errors ;E.g. "buffer foo has no process". + (nnimap-send-command "NOOP")))))))) (defun nnimap-open-connection (buffer) ;; Be backwards-compatible -- the earlier value of nnimap-stream was @@ -367,7 +368,7 @@ textual parts.") (defun nnimap-open-connection-1 (buffer) (unless nnimap-keepalive-timer (setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15) - 'nnimap-keepalive))) + #'nnimap-keepalive))) (with-current-buffer (nnimap-make-process-buffer buffer) (let* ((coding-system-for-read 'binary) (coding-system-for-write 'binary) diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 453386cdba5..781aa241802 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -723,15 +723,15 @@ this variable is nil, that buffer is shown using (defvar sql-imenu-generic-expression ;; Items are in reverse order because they are rendered in reverse. - '(("Rules/Defaults" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*\\(?:rule\\|default\\)\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\s-+\\(\\w+\\)" 1) - ("Sequences" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*sequence\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) - ("Triggers" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*trigger\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) - ("Functions" "^\\s-*\\(?:create\\s-+\\(?:\\w+\\s-+\\)*\\)?function\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) - ("Procedures" "^\\s-*\\(?:create\\s-+\\(?:\\w+\\s-+\\)*\\)?proc\\(?:edure\\)?\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) - ("Packages" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*package\\s-+\\(?:body\\s-+\\)?\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) - ("Types" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*type\\s-+\\(?:body\\s-+\\)?\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) - ("Indexes" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*index\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) - ("Tables/Views" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*\\(?:table\\|view\\)\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1)) + '(("Rules/Defaults" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*\\(?:rule\\|default\\)\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\s-+\\(\\(?:\\w+\\s-*[.]\\s-*\\)*\\w+\\)" 1) + ("Sequences" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*sequence\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\(?:\\w+\\s-*[.]\\s-*\\)*\\w+\\)" 1) + ("Triggers" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*trigger\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\(?:\\w+\\s-*[.]\\s-*\\)*\\w+\\)" 1) + ("Functions" "^\\s-*\\(?:create\\s-+\\(?:\\w+\\s-+\\)*\\)?function\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\(?:\\w+\\s-*[.]\\s-*\\)*\\w+\\)" 1) + ("Procedures" "^\\s-*\\(?:create\\s-+\\(?:\\w+\\s-+\\)*\\)?proc\\(?:edure\\)?\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\(?:\\w+\\s-*[.]\\s-*\\)*\\w+\\)" 1) + ("Packages" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*package\\s-+\\(?:body\\s-+\\)?\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\(?:\\w+\\s-*[.]\\s-*\\)*\\w+\\)" 1) + ("Types" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*type\\s-+\\(?:body\\s-+\\)?\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\(?:\\w+\\s-*[.]\\s-*\\)*\\w+\\)" 1) + ("Indexes" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*index\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\(?:\\w+\\s-*[.]\\s-*\\)*\\w+\\)" 1) + ("Tables/Views" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*\\(?:table\\|view\\)\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\(?:\\w+\\s-*[.]\\s-*\\)*\\w+\\)" 1)) "Define interesting points in the SQL buffer for `imenu'. This is used to set `imenu-generic-expression' when SQL mode is @@ -1313,7 +1313,7 @@ Based on `comint-mode-map'.") "\\(?:table\\|view\\|\\(?:package\\|type\\)\\(?:\\s-+body\\)?\\|proc\\(?:edure\\)?" "\\|function\\|trigger\\|sequence\\|rule\\|default\\)\\s-+" "\\(?:if\\s-+not\\s-+exists\\s-+\\)?" ;; IF NOT EXISTS - "\\(\\w+\\)") + "\\(\\w+\\(?:\\s-*[.]\\s-*\\w+\\)*\\)") 1 'font-lock-function-name-face)) "Pattern to match the names of top-level objects. @@ -3219,9 +3219,6 @@ Every newline in STRING will be preceded with a space and a backslash." Allows the suppression of continuation prompts.") -(defvar sql-output-by-send nil - "Non-nil if the command in the input was generated by `sql-send-string'.") - (defun sql-input-sender (proc string) "Send STRING to PROC after applying filters." @@ -3288,8 +3285,7 @@ to avoid deleting non-prompt output." (if (= sql-output-newline-count 0) (setq sql-output-newline-count nil - oline (concat "\n" oline) - sql-output-by-send nil) + oline (concat "\n" oline)) (setq sql-preoutput-hold oline oline "")) @@ -3383,8 +3379,7 @@ to avoid deleting non-prompt output." (setq sql-output-newline-count (if sql-output-newline-count (1+ sql-output-newline-count) - 1))) - (setq sql-output-by-send t))) + 1))))) (defun sql-remove-tabs-filter (str) "Replace tab characters with spaces." @@ -3857,7 +3852,6 @@ you entered, right above the output it created. (sql-get-product-feature sql-product :prompt-cont-regexp)) (make-local-variable 'sql-output-newline-count) (make-local-variable 'sql-preoutput-hold) - (make-local-variable 'sql-output-by-send) (add-hook 'comint-preoutput-filter-functions 'sql-interactive-remove-continuation-prompt nil t) (make-local-variable 'sql-input-ring-separator) @@ -3930,7 +3924,7 @@ is specified in the connection settings." ;; Was one selected (when connection ;; Get connection settings - (let ((connect-set (assoc connection sql-connection-alist))) + (let ((connect-set (assoc-string connection sql-connection-alist t))) ;; Settings are defined (if connect-set ;; Set the desired parameters @@ -4134,9 +4128,17 @@ the call to \\[sql-product-interactive] with (setq sql-buffer (buffer-name new-sqli-buffer)) (run-hooks 'sql-set-sqli-hook))) + ;; Make sure the connection is complete + ;; (Sometimes start up can be slow) + ;; and call the login hook + (let ((proc (get-buffer-process new-sqli-buffer))) + (while (and (memq (process-status proc) '(open run)) + (accept-process-output proc 2.5) + (progn (goto-char (point-max)) + (not (looking-back sql-prompt-regexp)))))) + (run-hooks 'sql-login-hook) ;; All done. (message "Login...done") - (run-hooks 'sql-login-hook) (pop-to-buffer new-sqli-buffer))))) (message "No default SQL product defined. Set `sql-product'."))) @@ -4202,7 +4204,7 @@ The default comes from `process-coding-system-alist' and ;; is meaningless; database without user/password is meaningless, ;; because "@param" will ask sqlplus to interpret the script ;; "param". - (let ((parameter nil)) + (let (parameter nlslang coding) (if (not (string= "" sql-user)) (if (not (string= "" sql-password)) (setq parameter (concat sql-user "/" sql-password)) @@ -4212,7 +4214,29 @@ The default comes from `process-coding-system-alist' and (if parameter (setq parameter (nconc (list parameter) options)) (setq parameter options)) - (sql-comint product parameter))) + (sql-comint product parameter) + ;; Set process coding system to agree with the interpreter + (setq nlslang (or (getenv "NLS_LANG") "") + coding (dolist (cs + ;; Are we missing any common NLS character sets + '(("US8PC437" . cp437) + ("EL8PC737" . cp737) + ("WE8PC850" . cp850) + ("EE8PC852" . cp852) + ("TR8PC857" . cp857) + ("WE8PC858" . cp858) + ("IS8PC861" . cp861) + ("IW8PC1507" . cp862) + ("N8PC865" . cp865) + ("RU8PC866" . cp866) + ("US7ASCII" . us-ascii) + ("UTF8" . utf-8) + ("AL32UTF8" . utf-8) + ("AL16UTF16" . utf-16)) + (or coding 'utf-8)) + (when (string-match (format "\\.%s\\'" (car cs)) nlslang) + (setq coding (cdr cs))))) + (set-buffer-process-coding-system coding coding))) (defun sql-oracle-save-settings (sqlbuf) "Save most SQL*Plus settings so they may be reset by \\[sql-redirect]." diff --git a/lisp/progmodes/which-func.el b/lisp/progmodes/which-func.el index adf378f6bc7..edfe368479c 100644 --- a/lisp/progmodes/which-func.el +++ b/lisp/progmodes/which-func.el @@ -290,7 +290,7 @@ If no function name is found, return nil." (when (and (null name) (boundp 'imenu--index-alist) (null imenu--index-alist) (null which-function-imenu-failed)) - (imenu--make-index-alist t) + (ignore-errors (imenu--make-index-alist t)) (unless imenu--index-alist (set (make-local-variable 'which-function-imenu-failed) t))) ;; If we have an index alist, use it. diff --git a/src/ChangeLog b/src/ChangeLog index 80f5875ef16..115b8d42915 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,42 @@ +2013-01-15 Paul Eggert + + * alloc.c (free_save_value): Now static. + +2013-01-15 Dmitry Antipov + + * keymap.c (map_keymap_internal): Use format_save_value. + (map_keymap_char_table_item): Adjust accordingly. + * fileio.c (non_regular_fd, non_regular_inserted) + (non_regular_nbytes): Remove. + (Finsert_file_contents): Convert trytry to ptrdiff_t. Use + format_save_value to pass parameters to read_non_regular. + (read_non_regular): Use XSAVE_ macros to extract parameters. + Adjust comment. + * xmenu.c (xmenu_show) [!USE_X_TOOLKIT && !USE_GTK]: Use + format_save_value. + (pop_down_menu) [!USE_X_TOOLKIT && !USE_GTK]: Adjust user. + +2013-01-15 Dmitry Antipov + + * lisp.h (XSAVE_POINTER, XSAVE_INTEGER): Change to allow + extraction from any Lisp_Save_Value slot. Add type checking. + * alloc.c, dired.c, editfns.c, fileio.c, ftfont.c, gtkutil.c: + * keymap.c, lread.c, nsterm.h, nsmenu.c, xfns.c, xmenu.c: + * xselect.c: All users changed. + +2013-01-15 Dmitry Antipov + + Some convenient bits to deal with Lisp_Save_Values. + * lisp.h (XSAVE_OBJECT): New macro to extract saved objects. + (allocate_misc): Remove prototype. + (format_save_value): New prototype. + * alloc.c (allocate_misc): Revert back to static. + (format_save_value): New function to build Lisp_Save_Value + object with the specified internal structure. + (make_save_value): Reimplement using format_save_value. + * editfns.c (save_excursion_save): Use format_save_value. + (save_excursion_restore): Use XSAVE_OBJECT. + 2013-01-14 Paul Eggert Avoid needless casts with XSAVE_POINTER. diff --git a/src/alloc.c b/src/alloc.c index 3f1ccc82a58..7275a01bb73 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -209,6 +209,7 @@ Lisp_Object Qchar_table_extra_slots; static Lisp_Object Qpost_gc_hook; +static void free_save_value (Lisp_Object); static void mark_terminals (void); static void gc_sweep (void); static Lisp_Object make_pure_vector (ptrdiff_t); @@ -3302,7 +3303,7 @@ static union Lisp_Misc *marker_free_list; /* Return a newly allocated Lisp_Misc object of specified TYPE. */ -Lisp_Object +static Lisp_Object allocate_misc (enum Lisp_Misc_Type type) { Lisp_Object val; @@ -3350,6 +3351,59 @@ free_misc (Lisp_Object misc) total_free_markers++; } +/* Return a Lisp_Save_Value object with the data saved according to + FMT. Format specifiers are `i' for an integer, `p' for a pointer + and `o' for Lisp_Object. Up to 4 objects can be specified. */ + +Lisp_Object +format_save_value (const char *fmt, ...) +{ + va_list ap; + int len = strlen (fmt); + Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); + struct Lisp_Save_Value *p = XSAVE_VALUE (val); + + eassert (0 < len && len < 5); + va_start (ap, fmt); + +#define INITX(index) \ + do { \ + if (len <= index) \ + p->type ## index = SAVE_UNUSED; \ + else \ + { \ + if (fmt[index] == 'i') \ + { \ + p->type ## index = SAVE_INTEGER; \ + p->data[index].integer = va_arg (ap, ptrdiff_t); \ + } \ + else if (fmt[index] == 'p') \ + { \ + p->type ## index = SAVE_POINTER; \ + p->data[index].pointer = va_arg (ap, void *); \ + } \ + else if (fmt[index] == 'o') \ + { \ + p->type ## index = SAVE_OBJECT; \ + p->data[index].object = va_arg (ap, Lisp_Object); \ + } \ + else \ + emacs_abort (); \ + } \ + } while (0) + + INITX (0); + INITX (1); + INITX (2); + INITX (3); + +#undef INITX + + va_end (ap); + p->area = 0; + return val; +} + /* Return a Lisp_Save_Value object containing POINTER and INTEGER. Most code should use this to package C integers and pointers to call record_unwind_protect. The unwind function can get the @@ -3358,27 +3412,16 @@ free_misc (Lisp_Object misc) Lisp_Object make_save_value (void *pointer, ptrdiff_t integer) { - register Lisp_Object val; - register struct Lisp_Save_Value *p; - - val = allocate_misc (Lisp_Misc_Save_Value); - p = XSAVE_VALUE (val); - p->type0 = SAVE_POINTER; - p->data[0].pointer = pointer; - p->type1 = SAVE_INTEGER; - p->data[1].integer = integer; - p->type2 = p->type3 = SAVE_UNUSED; - p->area = 0; - return val; + return format_save_value ("pi", pointer, integer); } /* Free a Lisp_Save_Value object. Do not use this function if SAVE contains pointer other than returned by xmalloc. */ -void +static void free_save_value (Lisp_Object save) { - xfree (XSAVE_POINTER (save)); + xfree (XSAVE_POINTER (save, 0)); free_misc (save); } diff --git a/src/dired.c b/src/dired.c index 8483721401a..3dca9d24f67 100644 --- a/src/dired.c +++ b/src/dired.c @@ -78,7 +78,7 @@ directory_files_internal_w32_unwind (Lisp_Object arg) static Lisp_Object directory_files_internal_unwind (Lisp_Object dh) { - DIR *d = XSAVE_POINTER (dh); + DIR *d = XSAVE_POINTER (dh, 0); block_input (); closedir (d); unblock_input (); diff --git a/src/editfns.c b/src/editfns.c index feac17f64b8..8910b66e4d3 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -833,31 +833,17 @@ This function does not move point. */) Lisp_Object save_excursion_save (void) { - Lisp_Object save = allocate_misc (Lisp_Misc_Save_Value); - register struct Lisp_Save_Value *v = XSAVE_VALUE (save); - - /* Do not allocate extra space and pack everything in SAVE. */ - v->area = 0; - - v->type0 = SAVE_OBJECT; - v->data[0].object = Fpoint_marker (); - - /* Do not copy the mark if it points to nowhere. */ - v->type1 = SAVE_OBJECT; - v->data[1].object = (XMARKER (BVAR (current_buffer, mark))->buffer - ? Fcopy_marker (BVAR (current_buffer, mark), Qnil) - : Qnil); - - /* Selected window if current buffer is shown in it, nil otherwise. */ - v->type2 = SAVE_OBJECT; - v->data[2].object - = ((XBUFFER (XWINDOW (selected_window)->buffer) == current_buffer) - ? selected_window : Qnil); - - v->type3 = SAVE_OBJECT; - v->data[3].object = BVAR (current_buffer, mark_active); - - return save; + return format_save_value + ("oooo", + Fpoint_marker (), + /* Do not copy the mark if it points to nowhere. */ + (XMARKER (BVAR (current_buffer, mark))->buffer + ? Fcopy_marker (BVAR (current_buffer, mark), Qnil) + : Qnil), + /* Selected window if current buffer is shown in it, nil otherwise. */ + ((XBUFFER (XWINDOW (selected_window)->buffer) == current_buffer) + ? selected_window : Qnil), + BVAR (current_buffer, mark_active)); } /* Restore saved buffer before leaving `save-excursion' special form. */ @@ -867,13 +853,8 @@ save_excursion_restore (Lisp_Object info) { Lisp_Object tem, tem1, omark, nmark; struct gcpro gcpro1, gcpro2, gcpro3; - register struct Lisp_Save_Value *v = XSAVE_VALUE (info); - /* Paranoid. */ - eassert (v->type0 == SAVE_OBJECT && v->type1 == SAVE_OBJECT - && v->type2 == SAVE_OBJECT && v->type3 == SAVE_OBJECT); - - tem = Fmarker_buffer (v->data[0].object); + tem = Fmarker_buffer (XSAVE_OBJECT (info, 0)); /* If we're unwinding to top level, saved buffer may be deleted. This means that all of its markers are unchained and so tem is nil. */ if (NILP (tem)) @@ -885,12 +866,12 @@ save_excursion_restore (Lisp_Object info) Fset_buffer (tem); /* Point marker. */ - tem = v->data[0].object; + tem = XSAVE_OBJECT (info, 0); Fgoto_char (tem); unchain_marker (XMARKER (tem)); /* Mark marker. */ - tem = v->data[1].object; + tem = XSAVE_OBJECT (info, 1); omark = Fmarker_position (BVAR (current_buffer, mark)); if (NILP (tem)) unchain_marker (XMARKER (BVAR (current_buffer, mark))); @@ -902,7 +883,7 @@ save_excursion_restore (Lisp_Object info) } /* Mark active. */ - tem = v->data[3].object; + tem = XSAVE_OBJECT (info, 3); tem1 = BVAR (current_buffer, mark_active); bset_mark_active (current_buffer, tem); @@ -926,7 +907,7 @@ save_excursion_restore (Lisp_Object info) /* If buffer was visible in a window, and a different window was selected, and the old selected window is still showing this buffer, restore point in that window. */ - tem = v->data[2].object; + tem = XSAVE_OBJECT (info, 2); if (WINDOWP (tem) && !EQ (tem, selected_window) && (tem1 = XWINDOW (tem)->buffer, @@ -4273,7 +4254,7 @@ usage: (format STRING &rest OBJECTS) */) memcpy (buf, initial_buffer, used); } else - XSAVE_POINTER (buf_save_value) = buf = xrealloc (buf, bufsize); + XSAVE_POINTER (buf_save_value, 0) = buf = xrealloc (buf, bufsize); p = buf + used; } diff --git a/src/fileio.c b/src/fileio.c index d468576d639..87d945c1e5e 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -3408,30 +3408,22 @@ decide_coding_unwind (Lisp_Object unwind_data) return Qnil; } - -/* Used to pass values from insert-file-contents to read_non_regular. */ - -static int non_regular_fd; -static ptrdiff_t non_regular_inserted; -static int non_regular_nbytes; - - -/* Read from a non-regular file. - Read non_regular_nbytes bytes max from non_regular_fd. - Non_regular_inserted specifies where to put the read bytes. - Value is the number of bytes read. */ +/* Read from a non-regular file. STATE is a Lisp_Save_Value + object where slot 0 is the file descriptor, slot 1 specifies + an offset to put the read bytes, and slot 2 is the maximum + amount of bytes to read. Value is the number of bytes read. */ static Lisp_Object -read_non_regular (Lisp_Object ignore) +read_non_regular (Lisp_Object state) { int nbytes; immediate_quit = 1; QUIT; - nbytes = emacs_read (non_regular_fd, + nbytes = emacs_read (XSAVE_INTEGER (state, 0), ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE - + non_regular_inserted), - non_regular_nbytes); + + XSAVE_INTEGER (state, 1)), + XSAVE_INTEGER (state, 2)); immediate_quit = 0; return make_number (nbytes); } @@ -4238,7 +4230,7 @@ by calling `format-decode', which see. */) while (how_much < total) { /* try is reserved in some compilers (Microsoft C) */ - int trytry = min (total - how_much, READ_BUF_SIZE); + ptrdiff_t trytry = min (total - how_much, READ_BUF_SIZE); ptrdiff_t this; if (not_regular) @@ -4255,12 +4247,11 @@ by calling `format-decode', which see. */) /* Read from the file, capturing `quit'. When an error occurs, end the loop, and arrange for a quit to be signaled after decoding the text we read. */ - non_regular_fd = fd; - non_regular_inserted = inserted; - non_regular_nbytes = trytry; - nbytes = internal_condition_case_1 (read_non_regular, - Qnil, Qerror, - read_non_regular_quit); + nbytes = internal_condition_case_1 + (read_non_regular, + format_save_value ("iii", (ptrdiff_t) fd, inserted, trytry), + Qerror, read_non_regular_quit); + if (NILP (nbytes)) { read_quit = 1; @@ -5507,7 +5498,7 @@ static Lisp_Object do_auto_save_unwind (Lisp_Object arg) /* used as unwind-protect function */ { - FILE *stream = XSAVE_POINTER (arg); + FILE *stream = XSAVE_POINTER (arg, 0); auto_saving = 0; if (stream != NULL) { diff --git a/src/font.c b/src/font.c index c4153428147..89931f6ec76 100644 --- a/src/font.c +++ b/src/font.c @@ -1857,7 +1857,7 @@ otf_open (Lisp_Object file) OTF *otf; if (! NILP (val)) - otf = XSAVE_POINTER (XCDR (val)); + otf = XSAVE_POINTER (XCDR (val), 0); else { otf = STRINGP (file) ? OTF_open (SSDATA (file)) : NULL; diff --git a/src/ftfont.c b/src/ftfont.c index 1d7678bfe09..5bf91832c7c 100644 --- a/src/ftfont.c +++ b/src/ftfont.c @@ -400,7 +400,7 @@ ftfont_lookup_cache (Lisp_Object key, enum ftfont_cache_for cache_for) else { val = XCDR (cache); - cache_data = XSAVE_POINTER (val); + cache_data = XSAVE_POINTER (val, 0); } if (cache_for == FTFONT_CACHE_FOR_ENTITY) @@ -466,7 +466,7 @@ ftfont_get_fc_charset (Lisp_Object entity) cache = ftfont_lookup_cache (entity, FTFONT_CACHE_FOR_CHARSET); val = XCDR (cache); - cache_data = XSAVE_POINTER (val); + cache_data = XSAVE_POINTER (val, 0); return cache_data->fc_charset; } @@ -1198,9 +1198,9 @@ ftfont_open (FRAME_PTR f, Lisp_Object entity, int pixel_size) filename = XCAR (val); idx = XCDR (val); val = XCDR (cache); - cache_data = XSAVE_POINTER (XCDR (cache)); + cache_data = XSAVE_POINTER (XCDR (cache), 0); ft_face = cache_data->ft_face; - if (XSAVE_INTEGER (val) > 0) + if (XSAVE_INTEGER (val, 1) > 0) { /* FT_Face in this cache is already used by the different size. */ if (FT_New_Size (ft_face, &ft_size) != 0) @@ -1211,13 +1211,13 @@ ftfont_open (FRAME_PTR f, Lisp_Object entity, int pixel_size) return Qnil; } } - XSAVE_INTEGER (val)++; + XSAVE_INTEGER (val, 1)++; size = XINT (AREF (entity, FONT_SIZE_INDEX)); if (size == 0) size = pixel_size; if (FT_Set_Pixel_Sizes (ft_face, size, size) != 0) { - if (XSAVE_INTEGER (val) == 0) + if (XSAVE_INTEGER (val, 1) == 0) FT_Done_Face (ft_face); return Qnil; } @@ -1326,10 +1326,10 @@ ftfont_close (FRAME_PTR f, struct font *font) cache = ftfont_lookup_cache (val, FTFONT_CACHE_FOR_FACE); eassert (CONSP (cache)); val = XCDR (cache); - (XSAVE_INTEGER (val))--; - if (XSAVE_INTEGER (val) == 0) + XSAVE_INTEGER (val, 1)--; + if (XSAVE_INTEGER (val, 1) == 0) { - struct ftfont_cache_data *cache_data = XSAVE_POINTER (val); + struct ftfont_cache_data *cache_data = XSAVE_POINTER (val, 0); FT_Done_Face (cache_data->ft_face); #ifdef HAVE_LIBOTF diff --git a/src/gtkutil.c b/src/gtkutil.c index 259e0e971fd..f045deacd33 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -1650,7 +1650,7 @@ xg_dialog_response_cb (GtkDialog *w, static Lisp_Object pop_down_dialog (Lisp_Object arg) { - struct xg_dialog_data *dd = XSAVE_POINTER (arg); + struct xg_dialog_data *dd = XSAVE_POINTER (arg, 0); block_input (); if (dd->w) gtk_widget_destroy (dd->w); diff --git a/src/keymap.c b/src/keymap.c index 82c9e980221..a9266120e86 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -565,14 +565,13 @@ map_keymap_char_table_item (Lisp_Object args, Lisp_Object key, Lisp_Object val) { if (!NILP (val)) { - map_keymap_function_t fun = XSAVE_POINTER (XCAR (args)); - args = XCDR (args); + map_keymap_function_t fun = XSAVE_POINTER (args, 0); /* If the key is a range, make a copy since map_char_table modifies it in place. */ if (CONSP (key)) key = Fcons (XCAR (key), XCDR (key)); - map_keymap_item (fun, XCDR (args), key, val, - XSAVE_POINTER (XCAR (args))); + map_keymap_item (fun, XSAVE_OBJECT (args, 2), key, + val, XSAVE_POINTER (args, 1)); } } @@ -610,12 +609,8 @@ map_keymap_internal (Lisp_Object map, } } else if (CHAR_TABLE_P (binding)) - { - map_char_table (map_keymap_char_table_item, Qnil, binding, - Fcons (make_save_value ((void *) fun, 0), - Fcons (make_save_value (data, 0), - args))); - } + map_char_table (map_keymap_char_table_item, Qnil, binding, + format_save_value ("ppo", fun, data, args)); } UNGCPRO; return tail; diff --git a/src/lisp.h b/src/lisp.h index 3ac2bda94c5..31028e14679 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -1418,13 +1418,25 @@ struct Lisp_Save_Value } data[4]; }; -/* Compatibility macro to set and extract saved pointer. */ +/* Macro to set and extract Nth saved pointer. Type + checking is ugly because it's used as an lvalue. */ -#define XSAVE_POINTER(obj) XSAVE_VALUE (obj)->data[0].pointer +#define XSAVE_POINTER(obj, n) \ + XSAVE_VALUE (obj)->data[(eassert (XSAVE_VALUE (obj)->type \ + ## n == SAVE_POINTER), n)].pointer /* Likewise for the saved integer. */ -#define XSAVE_INTEGER(obj) XSAVE_VALUE (obj)->data[1].integer +#define XSAVE_INTEGER(obj, n) \ + XSAVE_VALUE (obj)->data[(eassert (XSAVE_VALUE (obj)->type \ + ## n == SAVE_INTEGER), n)].integer + +/* Macro to extract Nth saved object. This is never used as + an lvalue, so we can do more convenient type checking. */ + +#define XSAVE_OBJECT(obj, n) \ + (eassert (XSAVE_VALUE (obj)->type ## n == SAVE_OBJECT), \ + XSAVE_VALUE (obj)->data[n].object) /* A miscellaneous object, when it's on the free list. */ struct Lisp_Free @@ -2926,7 +2938,6 @@ extern void memory_warnings (void *, void (*warnfun) (const char *)); /* Defined in alloc.c. */ extern void check_pure_size (void); -extern Lisp_Object allocate_misc (enum Lisp_Misc_Type); extern void free_misc (Lisp_Object); extern void allocate_string_data (struct Lisp_String *, EMACS_INT, EMACS_INT); extern void malloc_warning (const char *); @@ -3012,8 +3023,8 @@ extern bool abort_on_gc; extern Lisp_Object make_float (double); extern void display_malloc_warning (void); extern ptrdiff_t inhibit_garbage_collection (void); +extern Lisp_Object format_save_value (const char *, ...); extern Lisp_Object make_save_value (void *, ptrdiff_t); -extern void free_save_value (Lisp_Object); extern Lisp_Object build_overlay (Lisp_Object, Lisp_Object, Lisp_Object); extern void free_marker (Lisp_Object); extern void free_cons (struct Lisp_Cons *); diff --git a/src/lread.c b/src/lread.c index ced690a77b0..a01cf099b49 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1357,7 +1357,7 @@ Return t if the file exists and loads successfully. */) static Lisp_Object load_unwind (Lisp_Object arg) /* Used as unwind-protect function in load. */ { - FILE *stream = XSAVE_POINTER (arg); + FILE *stream = XSAVE_POINTER (arg, 0); if (stream != NULL) { block_input (); diff --git a/src/nsmenu.m b/src/nsmenu.m index 3e6fa54b047..b0369e76a27 100644 --- a/src/nsmenu.m +++ b/src/nsmenu.m @@ -1347,7 +1347,7 @@ struct Popdown_data static Lisp_Object pop_down_menu (Lisp_Object arg) { - struct Popdown_data *unwind_data = XSAVE_POINTER (arg); + struct Popdown_data *unwind_data = XSAVE_POINTER (arg, 0); block_input (); if (popup_activated_flag) diff --git a/src/nsterm.h b/src/nsterm.h index 7732e6d27cc..0cf4aa60d08 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -675,9 +675,9 @@ struct x_output #define FRAME_FONT(f) ((f)->output_data.ns->font) #ifdef __OBJC__ -#define XNS_SCROLL_BAR(vec) ((id) XSAVE_POINTER (vec)) +#define XNS_SCROLL_BAR(vec) ((id) XSAVE_POINTER (vec, 0)) #else -#define XNS_SCROLL_BAR(vec) XSAVE_POINTER (vec) +#define XNS_SCROLL_BAR(vec) XSAVE_POINTER (vec, 0) #endif /* Compute pixel size for vertical scroll bars */ diff --git a/src/xfns.c b/src/xfns.c index fe99d36f9f4..65148d1c9e1 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -5292,7 +5292,7 @@ file_dialog_unmap_cb (Widget widget, XtPointer client_data, XtPointer call_data) static Lisp_Object clean_up_file_dialog (Lisp_Object arg) { - Widget dialog = XSAVE_POINTER (arg); + Widget dialog = XSAVE_POINTER (arg, 0); /* Clean up. */ block_input (); diff --git a/src/xmenu.c b/src/xmenu.c index 6d880993d19..7f6914d26ac 100644 --- a/src/xmenu.c +++ b/src/xmenu.c @@ -1413,7 +1413,7 @@ pop_down_menu (Lisp_Object arg) { popup_activated_flag = 0; block_input (); - gtk_widget_destroy (GTK_WIDGET (XSAVE_POINTER (arg))); + gtk_widget_destroy (GTK_WIDGET (XSAVE_POINTER (arg, 0))); unblock_input (); return Qnil; } @@ -1610,7 +1610,7 @@ create_and_show_popup_menu (FRAME_PTR f, widget_value *first_wv, static Lisp_Object cleanup_widget_value_tree (Lisp_Object arg) { - free_menubar_widget_value_tree (XSAVE_POINTER (arg)); + free_menubar_widget_value_tree (XSAVE_POINTER (arg, 0)); return Qnil; } @@ -2236,8 +2236,8 @@ menu_help_callback (char const *help_string, int pane, int item) static Lisp_Object pop_down_menu (Lisp_Object arg) { - FRAME_PTR f = XSAVE_POINTER (Fcar (arg)); - XMenu *menu = XSAVE_POINTER (Fcdr (arg)); + FRAME_PTR f = XSAVE_POINTER (arg, 0); + XMenu *menu = XSAVE_POINTER (arg, 1); block_input (); #ifndef MSDOS @@ -2479,8 +2479,7 @@ xmenu_show (FRAME_PTR f, int x, int y, bool for_click, bool keymaps, #endif record_unwind_protect (pop_down_menu, - Fcons (make_save_value (f, 0), - make_save_value (menu, 0))); + format_save_value ("pp", f, menu)); /* Help display under X won't work because XMenuActivate contains a loop that doesn't give Emacs a chance to process it. */ diff --git a/src/xselect.c b/src/xselect.c index 9abfb2931f8..b7cdf70ff77 100644 --- a/src/xselect.c +++ b/src/xselect.c @@ -1120,7 +1120,7 @@ unexpect_property_change (struct prop_location *location) static Lisp_Object wait_for_property_change_unwind (Lisp_Object loc) { - struct prop_location *location = XSAVE_POINTER (loc); + struct prop_location *location = XSAVE_POINTER (loc, 0); unexpect_property_change (location); if (location == property_change_reply_object) diff --git a/test/ChangeLog b/test/ChangeLog index 472a6073884..7857000ba2f 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,7 @@ +2013-01-15 Stefan Monnier + + * automated/advice-tests.el: Split up. Add advice-test-preactivate. + 2013-01-14 Glenn Morris * automated/compile-tests.el (compile-tests--test-regexps-data): diff --git a/test/automated/advice-tests.el b/test/automated/advice-tests.el index 238561bef84..8beaea64cd9 100644 --- a/test/automated/advice-tests.el +++ b/test/automated/advice-tests.el @@ -21,99 +21,112 @@ ;;; Code: -(ert-deftest advice-tests () +(ert-deftest advice-tests-nadvice () + "Test nadvice code." + (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 (get 'sm-test1 'defalias-fset-function) nil)) + + (advice-add 'sm-test3 :around + (lambda (f &rest args) `(toto ,(apply f args))) + '((name . wrap-with-toto))) + (defmacro sm-test3 (x) `(call-test3 ,x)) + (should (equal (macroexpand '(sm-test3 56)) '(toto (call-test3 56))))) + +(ert-deftest advice-tests-advice () "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)) + (should (equal (sm-test2 6) 10)) + (defadvice sm-test2 (around sm-test activate) + ad-do-it (setq ad-return-value (* ad-return-value 5))) + (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)) - (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))) - (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)) + (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)) + (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)))) - (advice-add 'sm-test3 :around - (lambda (f &rest args) `(toto ,(apply f args))) - '((name . wrap-with-toto))) - (defmacro sm-test3 (x) `(call-test3 ,x)) - (should (equal (macroexpand '(sm-test3 56)) '(toto (call-test3 56)))) + ;; This used to signal an error (bug#12858). + (autoload 'sm-test6 "foo") + (defadvice sm-test6 (around test activate) + ad-do-it)) - (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)) - (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)))) +(ert-deftest advice-tests-combination () + "Combining old style and new style advices." + (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))) + (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))) - ;; Combining old style and new style advices. - (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))) - (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)) +(ert-deftest advice-test-called-interactively-p () + "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)))) - ;; This used to signal an error (bug#12858). - (autoload 'sm-test6 "foo") - (defadvice sm-test6 (around test activate) - ad-do-it) +(ert-deftest advice-test-interactive () + "Check handling of interactive spec." + (defun sm-test8 (a) (interactive "p") a) + (defadvice sm-test8 (before adv1 activate) nil) + (defadvice sm-test8 (before adv2 activate) (interactive "P") nil) + (should (equal (interactive-form 'sm-test8) '(interactive "P")))) - ;; 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))) - - ;; Check handling of interactive spec. - (defun sm-test8 (a) (interactive "p") a) - (defadvice sm-test8 (before adv1 activate) nil) - (defadvice sm-test8 (before adv2 activate) (interactive "P") nil) - (should (equal (interactive-form 'sm-test8) '(interactive "P"))) - )) +(ert-deftest advice-test-preactivate () + (should (equal (null (get 'sm-test9 'defalias-fset-function)) t)) + (defun sm-test9 (a) (interactive "p") a) + (should (equal (null (get 'sm-test9 'defalias-fset-function)) t)) + (defadvice sm-test9 (before adv1 pre act protect compile) nil) + (should (equal (null (get 'sm-test9 'defalias-fset-function)) nil)) + (defadvice sm-test9 (before adv2 pre act protect compile) + (interactive "P") nil) + (should (equal (interactive-form 'sm-test9) '(interactive "P")))) ;; Local Variables: ;; no-byte-compile: t