From a104f656c8217b027866d32e8d7bf024a671e3cc Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 2 Aug 2013 17:16:33 -0400 Subject: [PATCH] Make defvar affect the default binding outside of any let. * src/eval.c (default_toplevel_binding): New function. (Fdefvar): Use it. (unbind_to, backtrace_eval_unrewind): Do a bit of CSE simplification. (Fdefault_toplevel_value, Fset_default_toplevel_value): New subrs. (syms_of_eval): Export them. * src/data.c (Fdefault_value): Micro cleanup. * src/term.c (init_tty): Use "false". * lisp/custom.el (custom-initialize-default, custom-initialize-set) (custom-initialize-reset, custom-initialize-changed): Affect the toplevel-default-value (bug#6275, bug#14586). * lisp/emacs-lisp/advice.el (ad-compile-function): Undo previous workaround for bug#6275. * test/automated/core-elisp-tests.el: New file. --- etc/NEWS | 2 + lisp/ChangeLog | 8 ++ lisp/custom.el | 85 ++++++++++---------- lisp/emacs-lisp/advice.el | 1 - src/ChangeLog | 10 +++ src/data.c | 4 +- src/eval.c | 124 +++++++++++++++++++---------- src/term.c | 24 +++--- test/ChangeLog | 4 + test/automated/core-elisp-tests.el | 38 +++++++++ 10 files changed, 201 insertions(+), 99 deletions(-) create mode 100644 test/automated/core-elisp-tests.el diff --git a/etc/NEWS b/etc/NEWS index 170f369d104..299c247c344 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -524,6 +524,8 @@ low-level libraries gfilenotify.c, inotify.c or w32notify.c. * Incompatible Lisp Changes in Emacs 24.4 +** `defvar' and `defcustom' in a let-binding affect the "external" default. + ** The syntax of ?» and ?« is now punctuation instead of matched parens. Some languages match those as »...« and others as «...» so better stay neutral. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 5a37f858104..900c9625fce 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,11 @@ +2013-08-02 Stefan Monnier + + * custom.el (custom-initialize-default, custom-initialize-set) + (custom-initialize-reset, custom-initialize-changed): Affect the + toplevel-default-value (bug#6275, bug#14586). + * emacs-lisp/advice.el (ad-compile-function): Undo previous workaround + for bug#6275. + 2013-08-02 Juanma Barranquero * emacs-lisp/lisp-mode.el (lisp-imenu-generic-expression): diff --git a/lisp/custom.el b/lisp/custom.el index f2d58084e9e..3db34e4d1fb 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -49,63 +49,66 @@ Users should not set it.") ;;; The `defcustom' Macro. -(defun custom-initialize-default (symbol value) - "Initialize SYMBOL with VALUE. +(defun custom-initialize-default (symbol exp) + "Initialize SYMBOL with EXP. This will do nothing if symbol already has a default binding. Otherwise, if symbol has a `saved-value' property, it will evaluate the car of that and use it as the default binding for symbol. -Otherwise, VALUE will be evaluated and used as the default binding for +Otherwise, EXP will be evaluated and used as the default binding for symbol." - (eval `(defvar ,symbol ,(if (get symbol 'saved-value) - (car (get symbol 'saved-value)) - value)))) + (eval `(defvar ,symbol ,(let ((sv (get symbol 'saved-value))) + (if sv (car sv) exp))))) -(defun custom-initialize-set (symbol value) - "Initialize SYMBOL based on VALUE. +(defun custom-initialize-set (symbol exp) + "Initialize SYMBOL based on EXP. If the symbol doesn't have a default binding already, then set it using its `:set' function (or `set-default' if it has none). The value is either the value in the symbol's `saved-value' property, -if any, or VALUE." - (unless (default-boundp symbol) - (funcall (or (get symbol 'custom-set) 'set-default) - symbol - (eval (if (get symbol 'saved-value) - (car (get symbol 'saved-value)) - value))))) - -(defun custom-initialize-reset (symbol value) - "Initialize SYMBOL based on VALUE. +if any, or the value of EXP." + (condition-case nil + (default-toplevel-value symbol) + (error + (funcall (or (get symbol 'custom-set) #'set-default-toplevel-value) + symbol + (eval (let ((sv (get symbol 'saved-value))) + (if sv (car sv) exp))))))) + +(defun custom-initialize-reset (symbol exp) + "Initialize SYMBOL based on EXP. Set the symbol, using its `:set' function (or `set-default' if it has none). The value is either the symbol's current value (as obtained using the `:get' function), if any, or the value in the symbol's `saved-value' property if any, -or (last of all) VALUE." - (funcall (or (get symbol 'custom-set) 'set-default) +or (last of all) the value of EXP." + (funcall (or (get symbol 'custom-set) #'set-default-toplevel-value) symbol - (cond ((default-boundp symbol) - (funcall (or (get symbol 'custom-get) 'default-value) - symbol)) - ((get symbol 'saved-value) - (eval (car (get symbol 'saved-value)))) - (t - (eval value))))) - -(defun custom-initialize-changed (symbol value) - "Initialize SYMBOL with VALUE. + (condition-case nil + (let ((def (default-toplevel-value symbol)) + (getter (get symbol 'custom-get))) + (if getter (funcall getter symbol) def)) + (error + (eval (let ((sv (get symbol 'saved-value))) + (if sv (car sv) exp))))))) + +(defun custom-initialize-changed (symbol exp) + "Initialize SYMBOL with EXP. Like `custom-initialize-reset', but only use the `:set' function if not using the standard setting. For the standard setting, use `set-default'." - (cond ((default-boundp symbol) - (funcall (or (get symbol 'custom-set) 'set-default) - symbol - (funcall (or (get symbol 'custom-get) 'default-value) - symbol))) - ((get symbol 'saved-value) - (funcall (or (get symbol 'custom-set) 'set-default) - symbol - (eval (car (get symbol 'saved-value))))) - (t - (set-default symbol (eval value))))) + (condition-case nil + (let ((def (default-toplevel-value symbol))) + (funcall (or (get symbol 'custom-set) #'set-default-toplevel-value) + symbol + (let ((getter (get symbol 'custom-get))) + (if getter (funcall getter symbol) def)))) + (error + (cond + ((get symbol 'saved-value) + (funcall (or (get symbol 'custom-set) #'set-default-toplevel-value) + symbol + (eval (car (get symbol 'saved-value))))) + (t + (set-default symbol (eval exp))))))) (defvar custom-delayed-init-variables nil "List of variables whose initialization is pending.") diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 3d03e894534..eb1d63e788b 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2280,7 +2280,6 @@ For that it has to be fbound with a non-autoload definition." (defun ad-compile-function (function) "Byte-compile the assembled advice function." (require 'bytecomp) - (require 'warnings) ;To define warning-suppress-types before we let-bind it. (let ((byte-compile-warnings byte-compile-warnings) ;; Don't pop up windows showing byte-compiler warnings. (warning-suppress-types '((bytecomp)))) diff --git a/src/ChangeLog b/src/ChangeLog index 2a511d2fc8a..c6e349010a7 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,13 @@ +2013-08-02 Stefan Monnier + + * eval.c (default_toplevel_binding): New function. + (Fdefvar): Use it. + (unbind_to, backtrace_eval_unrewind): Do a bit of CSE simplification. + (Fdefault_toplevel_value, Fset_default_toplevel_value): New subrs. + (syms_of_eval): Export them. + * data.c (Fdefault_value): Micro cleanup. + * term.c (init_tty): Use "false". + 2013-08-02 Dmitry Antipov Fix X GC leak in GTK and raw (no toolkit) X ports. diff --git a/src/data.c b/src/data.c index f04d6da618f..d1e43ac1b5f 100644 --- a/src/data.c +++ b/src/data.c @@ -1384,9 +1384,7 @@ for this variable. The default value is meaningful for variables with local bindings in certain buffers. */) (Lisp_Object symbol) { - register Lisp_Object value; - - value = default_value (symbol); + Lisp_Object value = default_value (symbol); if (!EQ (value, Qunbound)) return value; diff --git a/src/eval.c b/src/eval.c index cb716690e3c..8ee259110f4 100644 --- a/src/eval.c +++ b/src/eval.c @@ -658,6 +658,51 @@ The return value is BASE-VARIABLE. */) return base_variable; } +static union specbinding * +default_toplevel_binding (Lisp_Object symbol) +{ + union specbinding *binding = NULL; + union specbinding *pdl = specpdl_ptr; + while (pdl > specpdl) + { + switch ((--pdl)->kind) + { + case SPECPDL_LET_DEFAULT: + case SPECPDL_LET: + if (EQ (specpdl_symbol (pdl), symbol)) + binding = pdl; + break; + } + } + return binding; +} + +DEFUN ("default-toplevel-value", Fdefault_toplevel_value, Sdefault_toplevel_value, 1, 1, 0, + doc: /* Return SYMBOL's toplevel default value. +"Toplevel" means outside of any let binding. */) + (Lisp_Object symbol) +{ + union specbinding *binding = default_toplevel_binding (symbol); + Lisp_Object value + = binding ? specpdl_old_value (binding) : Fdefault_value (symbol); + if (!EQ (value, Qunbound)) + return value; + xsignal1 (Qvoid_variable, symbol); +} + +DEFUN ("set-default-toplevel-value", Fset_default_toplevel_value, + Sset_default_toplevel_value, 2, 2, 0, + doc: /* Set SYMBOL's toplevel default value to VALUE. +"Toplevel" means outside of any let binding. */) + (Lisp_Object symbol, Lisp_Object value) +{ + union specbinding *binding = default_toplevel_binding (symbol); + if (binding) + set_specpdl_old_value (binding, value); + else + Fset_default (symbol, value); + return Qnil; +} DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0, doc: /* Define SYMBOL as a variable, and return SYMBOL. @@ -706,18 +751,10 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) else { /* Check if there is really a global binding rather than just a let binding that shadows the global unboundness of the var. */ - union specbinding *pdl = specpdl_ptr; - while (pdl > specpdl) + union specbinding *binding = default_toplevel_binding (sym); + if (binding && EQ (specpdl_old_value (binding), Qunbound)) { - if ((--pdl)->kind >= SPECPDL_LET - && EQ (specpdl_symbol (pdl), sym) - && EQ (specpdl_old_value (pdl), Qunbound)) - { - message_with_string - ("Warning: defvar ignored because %s is let-bound", - SYMBOL_NAME (sym), 1); - break; - } + set_specpdl_old_value (binding, eval_sub (XCAR (tail))); } } tail = XCDR (tail); @@ -3311,19 +3348,21 @@ unbind_to (ptrdiff_t count, Lisp_Object value) case SPECPDL_BACKTRACE: break; case SPECPDL_LET: - /* If variable has a trivial value (no forwarding), we can - just set it. No need to check for constant symbols here, - since that was already done by specbind. */ - if (XSYMBOL (specpdl_symbol (specpdl_ptr))->redirect - == SYMBOL_PLAINVAL) - SET_SYMBOL_VAL (XSYMBOL (specpdl_symbol (specpdl_ptr)), - specpdl_old_value (specpdl_ptr)); - else - /* NOTE: we only ever come here if make_local_foo was used for - the first time on this var within this let. */ - Fset_default (specpdl_symbol (specpdl_ptr), - specpdl_old_value (specpdl_ptr)); - break; + { /* If variable has a trivial value (no forwarding), we can + just set it. No need to check for constant symbols here, + since that was already done by specbind. */ + struct Lisp_Symbol *sym = XSYMBOL (specpdl_symbol (specpdl_ptr)); + if (sym->redirect == SYMBOL_PLAINVAL) + { + SET_SYMBOL_VAL (sym, specpdl_old_value (specpdl_ptr)); + break; + } + else + { /* FALLTHROUGH!! + NOTE: we only ever come here if make_local_foo was used for + the first time on this var within this let. */ + } + } case SPECPDL_LET_DEFAULT: Fset_default (specpdl_symbol (specpdl_ptr), specpdl_old_value (specpdl_ptr)); @@ -3511,24 +3550,23 @@ backtrace_eval_unrewind (int distance) case SPECPDL_BACKTRACE: break; case SPECPDL_LET: - /* If variable has a trivial value (no forwarding), we can - just set it. No need to check for constant symbols here, - since that was already done by specbind. */ - if (XSYMBOL (specpdl_symbol (tmp))->redirect - == SYMBOL_PLAINVAL) - { - struct Lisp_Symbol *sym = XSYMBOL (specpdl_symbol (tmp)); - Lisp_Object old_value = specpdl_old_value (tmp); - set_specpdl_old_value (tmp, SYMBOL_VAL (sym)); - SET_SYMBOL_VAL (sym, old_value); - break; - } - else - { - /* FALLTHROUGH! - NOTE: we only ever come here if make_local_foo was used for - the first time on this var within this let. */ - } + { /* If variable has a trivial value (no forwarding), we can + just set it. No need to check for constant symbols here, + since that was already done by specbind. */ + struct Lisp_Symbol *sym = XSYMBOL (specpdl_symbol (tmp)); + if (sym->redirect == SYMBOL_PLAINVAL) + { + Lisp_Object old_value = specpdl_old_value (tmp); + set_specpdl_old_value (tmp, SYMBOL_VAL (sym)); + SET_SYMBOL_VAL (sym, old_value); + break; + } + else + { /* FALLTHROUGH!! + NOTE: we only ever come here if make_local_foo was used for + the first time on this var within this let. */ + } + } case SPECPDL_LET_DEFAULT: { Lisp_Object sym = specpdl_symbol (tmp); @@ -3796,6 +3834,8 @@ alist of active lexical bindings. */); defsubr (&Ssetq); defsubr (&Squote); defsubr (&Sfunction); + defsubr (&Sdefault_toplevel_value); + defsubr (&Sset_default_toplevel_value); defsubr (&Sdefvar); defsubr (&Sdefvaralias); defsubr (&Sdefconst); diff --git a/src/term.c b/src/term.c index 376d6e7831a..f5f4882161e 100644 --- a/src/term.c +++ b/src/term.c @@ -2933,7 +2933,7 @@ dissociate_if_controlling_tty (int fd) TERMINAL_TYPE is the termcap type of the device, e.g. "vt100". - If MUST_SUCCEED is true, then all errors are fatal. */ + If MUST_SUCCEED is true, then all errors are fatal. */ struct terminal * init_tty (const char *name, const char *terminal_type, bool must_succeed) @@ -2944,7 +2944,7 @@ init_tty (const char *name, const char *terminal_type, bool must_succeed) int status; struct tty_display_info *tty = NULL; struct terminal *terminal = NULL; - bool ctty = 0; /* True if asked to open controlling tty. */ + bool ctty = false; /* True if asked to open controlling tty. */ if (!terminal_type) maybe_fatal (must_succeed, 0, @@ -3031,7 +3031,7 @@ init_tty (const char *name, const char *terminal_type, bool must_succeed) tty->termcap_term_buffer = xmalloc (buffer_size); /* On some systems, tgetent tries to access the controlling - terminal. */ + terminal. */ block_tty_out_signal (); status = tgetent (tty->termcap_term_buffer, terminal_type); unblock_tty_out_signal (); @@ -3101,13 +3101,13 @@ use the Bourne shell command `TERM=... export TERM' (C-shell:\n\ Right (tty) = tgetstr ("nd", address); Down (tty) = tgetstr ("do", address); if (!Down (tty)) - Down (tty) = tgetstr ("nl", address); /* Obsolete name for "do" */ + Down (tty) = tgetstr ("nl", address); /* Obsolete name for "do". */ if (tgetflag ("bs")) - Left (tty) = "\b"; /* can't possibly be longer! */ - else /* (Actually, "bs" is obsolete...) */ + Left (tty) = "\b"; /* Can't possibly be longer! */ + else /* (Actually, "bs" is obsolete...) */ Left (tty) = tgetstr ("le", address); if (!Left (tty)) - Left (tty) = tgetstr ("bc", address); /* Obsolete name for "le" */ + Left (tty) = tgetstr ("bc", address); /* Obsolete name for "le". */ tty->TS_pad_char = tgetstr ("pc", address); tty->TS_repeat = tgetstr ("rp", address); tty->TS_end_standout_mode = tgetstr ("se", address); @@ -3229,7 +3229,7 @@ use the Bourne shell command `TERM=... export TERM' (C-shell:\n\ don't think we're losing anything by turning it off. */ terminal->line_ins_del_ok = 0; - tty->TN_max_colors = 16; /* Required to be non-zero for tty-display-color-p */ + tty->TN_max_colors = 16; /* Must be non-zero for tty-display-color-p. */ #endif /* DOS_NT */ #ifdef HAVE_GPM @@ -3325,16 +3325,16 @@ use the Bourne shell command `TERM=... export TERM' (C-shell:\n\ tty->Wcm->cm_tab = 0; /* We can't support standout mode, because it uses magic cookies. */ tty->TS_standout_mode = 0; - /* But that means we cannot rely on ^M to go to column zero! */ + /* But that means we cannot rely on ^M to go to column zero! */ CR (tty) = 0; - /* LF can't be trusted either -- can alter hpos */ - /* if move at column 0 thru a line with TS_standout_mode */ + /* LF can't be trusted either -- can alter hpos. */ + /* If move at column 0 thru a line with TS_standout_mode. */ Down (tty) = 0; } tty->specified_window = FrameRows (tty); - if (Wcm_init (tty) == -1) /* can't do cursor motion */ + if (Wcm_init (tty) == -1) /* Can't do cursor motion. */ { maybe_fatal (must_succeed, terminal, "Terminal type \"%s\" is not powerful enough to run Emacs", diff --git a/test/ChangeLog b/test/ChangeLog index 1efd86545aa..554db3649d9 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,7 @@ +2013-08-02 Stefan Monnier + + * automated/core-elisp-tests.el: New file. + 2013-08-01 Glenn Morris * automated/file-notify-tests.el (file-notify--test-remote-enabled): diff --git a/test/automated/core-elisp-tests.el b/test/automated/core-elisp-tests.el new file mode 100644 index 00000000000..809be10bc02 --- /dev/null +++ b/test/automated/core-elisp-tests.el @@ -0,0 +1,38 @@ +;;; core-elisp-tests.el --- Testing some core Elisp rules + +;; Copyright (C) 2013 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(ert-deftest core-elisp-tests () + "Test some core Elisp rules." + (with-temp-buffer + ;; Check that when defvar is run within a let-binding, the toplevel default + ;; is properly initialized. + (should (equal (list (let ((c-e-x 1)) (defvar c-e-x 2) c-e-x) c-e-x) + '(1 2))) + (should (equal (list (let ((c-e-x 1)) (defcustom c-e-x 2) c-e-x) c-e-x) + '(1 2))))) + +(provide 'core-elisp-tests) +;;; core-elisp-tests.el ends here -- 2.39.2