procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Make defvar affect the default binding outside of any let.

Browse source 
* 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.
This commit is contained in:
Stefan Monnier 2013-08-02 17:16:33 -04:00
parent 185e3b5a2f
commit a104f656c8
10 changed files with 199 additions and 97 deletions
Download patch file Download diff file Expand all files Collapse all files

2
etc/NEWS
View file

@ -524,6 +524,8 @@ low-level libraries gfilenotify.c, inotify.c or w32notify.c.
* Incompatible Lisp Changes in Emacs 24.4 * 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. ** The syntax of ?» and ?« is now punctuation instead of matched parens.
Some languages match those as »...« and others as «...» so better stay neutral. Some languages match those as »...« and others as «...» so better stay neutral.

8
lisp/ChangeLog
View file

@ -1,3 +1,11 @@
2013-08-02 Stefan Monnier <monnier@iro.umontreal.ca>
* 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 <lekktu@gmail.com> 2013-08-02 Juanma Barranquero <lekktu@gmail.com>
* emacs-lisp/lisp-mode.el (lisp-imenu-generic-expression): * emacs-lisp/lisp-mode.el (lisp-imenu-generic-expression):

81
lisp/custom.el
View file

@ -49,63 +49,66 @@ Users should not set it.")
;;; The `defcustom' Macro. ;;; The `defcustom' Macro.
(defun custom-initialize-default (symbol value) (defun custom-initialize-default (symbol exp)
"Initialize SYMBOL with VALUE. "Initialize SYMBOL with EXP.
This will do nothing if symbol already has a default binding. This will do nothing if symbol already has a default binding.
Otherwise, if symbol has a `saved-value' property, it will evaluate Otherwise, if symbol has a `saved-value' property, it will evaluate
the car of that and use it as the default binding for symbol. 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." symbol."
(eval `(defvar ,symbol ,(if (get symbol 'saved-value) (eval `(defvar ,symbol ,(let ((sv (get symbol 'saved-value)))
(car (get symbol 'saved-value)) (if sv (car sv) exp)))))
value))))
(defun custom-initialize-set (symbol value) (defun custom-initialize-set (symbol exp)
"Initialize SYMBOL based on VALUE. "Initialize SYMBOL based on EXP.
If the symbol doesn't have a default binding already, If the symbol doesn't have a default binding already,
then set it using its `:set' function (or `set-default' if it has none). 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, The value is either the value in the symbol's `saved-value' property,
if any, or VALUE." if any, or the value of EXP."
(unless (default-boundp symbol) (condition-case nil
(funcall (or (get symbol 'custom-set) 'set-default) (default-toplevel-value symbol)
symbol (error
(eval (if (get symbol 'saved-value) (funcall (or (get symbol 'custom-set) #'set-default-toplevel-value)
(car (get symbol 'saved-value)) symbol
value))))) (eval (let ((sv (get symbol 'saved-value)))
(if sv (car sv) exp)))))))
(defun custom-initialize-reset (symbol value) (defun custom-initialize-reset (symbol exp)
"Initialize SYMBOL based on VALUE. "Initialize SYMBOL based on EXP.
Set the symbol, using its `:set' function (or `set-default' if it has none). Set the symbol, using its `:set' function (or `set-default' if it has none).
The value is either the symbol's current value The value is either the symbol's current value
(as obtained using the `:get' function), if any, (as obtained using the `:get' function), if any,
or the value in the symbol's `saved-value' property if any, or the value in the symbol's `saved-value' property if any,
or (last of all) VALUE." or (last of all) the value of EXP."
(funcall (or (get symbol 'custom-set) 'set-default) (funcall (or (get symbol 'custom-set) #'set-default-toplevel-value)
symbol symbol
(cond ((default-boundp symbol) (condition-case nil
(funcall (or (get symbol 'custom-get) 'default-value) (let ((def (default-toplevel-value symbol))
symbol)) (getter (get symbol 'custom-get)))
((get symbol 'saved-value) (if getter (funcall getter symbol) def))
(eval (car (get symbol 'saved-value)))) (error
(t (eval (let ((sv (get symbol 'saved-value)))
(eval value))))) (if sv (car sv) exp)))))))
(defun custom-initialize-changed (symbol value) (defun custom-initialize-changed (symbol exp)
"Initialize SYMBOL with VALUE. "Initialize SYMBOL with EXP.
Like `custom-initialize-reset', but only use the `:set' function if Like `custom-initialize-reset', but only use the `:set' function if
not using the standard setting. not using the standard setting.
For the standard setting, use `set-default'." For the standard setting, use `set-default'."
(cond ((default-boundp symbol) (condition-case nil
(funcall (or (get symbol 'custom-set) 'set-default) (let ((def (default-toplevel-value symbol)))
symbol (funcall (or (get symbol 'custom-set) #'set-default-toplevel-value)
(funcall (or (get symbol 'custom-get) 'default-value) symbol
symbol))) (let ((getter (get symbol 'custom-get)))
((get symbol 'saved-value) (if getter (funcall getter symbol) def))))
(funcall (or (get symbol 'custom-set) 'set-default) (error
symbol (cond
(eval (car (get symbol 'saved-value))))) ((get symbol 'saved-value)
(t (funcall (or (get symbol 'custom-set) #'set-default-toplevel-value)
(set-default symbol (eval value))))) symbol
(eval (car (get symbol 'saved-value)))))
(t
(set-default symbol (eval exp)))))))
(defvar custom-delayed-init-variables nil (defvar custom-delayed-init-variables nil
"List of variables whose initialization is pending.") "List of variables whose initialization is pending.")

1
lisp/emacs-lisp/advice.el
View file

@ -2280,7 +2280,6 @@ For that it has to be fbound with a non-autoload definition."
(defun ad-compile-function (function) (defun ad-compile-function (function)
"Byte-compile the assembled advice function." "Byte-compile the assembled advice function."
(require 'bytecomp) (require 'bytecomp)
(require 'warnings) ;To define warning-suppress-types before we let-bind it.
(let ((byte-compile-warnings byte-compile-warnings) (let ((byte-compile-warnings byte-compile-warnings)
;; Don't pop up windows showing byte-compiler warnings. ;; Don't pop up windows showing byte-compiler warnings.
(warning-suppress-types '((bytecomp)))) (warning-suppress-types '((bytecomp))))

10
src/ChangeLog
View file

@ -1,3 +1,13 @@
2013-08-02 Stefan Monnier <monnier@iro.umontreal.ca>
* 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 <dmantipov@yandex.ru> 2013-08-02 Dmitry Antipov <dmantipov@yandex.ru>
Fix X GC leak in GTK and raw (no toolkit) X ports. Fix X GC leak in GTK and raw (no toolkit) X ports.

4
src/data.c
View file

@ -1384,9 +1384,7 @@ for this variable. The default value is meaningful for variables with
local bindings in certain buffers. */) local bindings in certain buffers. */)
(Lisp_Object symbol) (Lisp_Object symbol)
{ {
register Lisp_Object value; Lisp_Object value = default_value (symbol);
value = default_value (symbol);
if (!EQ (value, Qunbound)) if (!EQ (value, Qunbound))
return value; return value;

124
src/eval.c
View file

@ -658,6 +658,51 @@ The return value is BASE-VARIABLE. */)
return 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, DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0,
doc: /* Define SYMBOL as a variable, and return SYMBOL. doc: /* Define SYMBOL as a variable, and return SYMBOL.
@ -706,18 +751,10 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
else else
{ /* Check if there is really a global binding rather than just a let { /* Check if there is really a global binding rather than just a let
binding that shadows the global unboundness of the var. */ binding that shadows the global unboundness of the var. */
union specbinding *pdl = specpdl_ptr; union specbinding *binding = default_toplevel_binding (sym);
while (pdl > specpdl) if (binding && EQ (specpdl_old_value (binding), Qunbound))
{ {
if ((--pdl)->kind >= SPECPDL_LET set_specpdl_old_value (binding, eval_sub (XCAR (tail)));
&& 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;
}
} }
} }
tail = XCDR (tail); tail = XCDR (tail);
@ -3311,19 +3348,21 @@ unbind_to (ptrdiff_t count, Lisp_Object value)
case SPECPDL_BACKTRACE: case SPECPDL_BACKTRACE:
break; break;
case SPECPDL_LET: case SPECPDL_LET:
/* If variable has a trivial value (no forwarding), we can { /* If variable has a trivial value (no forwarding), we can
just set it. No need to check for constant symbols here, just set it. No need to check for constant symbols here,
since that was already done by specbind. */ since that was already done by specbind. */
if (XSYMBOL (specpdl_symbol (specpdl_ptr))->redirect struct Lisp_Symbol *sym = XSYMBOL (specpdl_symbol (specpdl_ptr));
== SYMBOL_PLAINVAL) if (sym->redirect == SYMBOL_PLAINVAL)
SET_SYMBOL_VAL (XSYMBOL (specpdl_symbol (specpdl_ptr)), {
specpdl_old_value (specpdl_ptr)); SET_SYMBOL_VAL (sym, specpdl_old_value (specpdl_ptr));
else break;
/* NOTE: we only ever come here if make_local_foo was used for }
the first time on this var within this let. */ else
Fset_default (specpdl_symbol (specpdl_ptr), { /* FALLTHROUGH!!
specpdl_old_value (specpdl_ptr)); NOTE: we only ever come here if make_local_foo was used for
break; the first time on this var within this let. */
}
}
case SPECPDL_LET_DEFAULT: case SPECPDL_LET_DEFAULT:
Fset_default (specpdl_symbol (specpdl_ptr), Fset_default (specpdl_symbol (specpdl_ptr),
specpdl_old_value (specpdl_ptr)); specpdl_old_value (specpdl_ptr));
@ -3511,24 +3550,23 @@ backtrace_eval_unrewind (int distance)
case SPECPDL_BACKTRACE: case SPECPDL_BACKTRACE:
break; break;
case SPECPDL_LET: case SPECPDL_LET:
/* If variable has a trivial value (no forwarding), we can { /* If variable has a trivial value (no forwarding), we can
just set it. No need to check for constant symbols here, just set it. No need to check for constant symbols here,
since that was already done by specbind. */ since that was already done by specbind. */
if (XSYMBOL (specpdl_symbol (tmp))->redirect struct Lisp_Symbol *sym = XSYMBOL (specpdl_symbol (tmp));
== SYMBOL_PLAINVAL) if (sym->redirect == SYMBOL_PLAINVAL)
{ {
struct Lisp_Symbol *sym = XSYMBOL (specpdl_symbol (tmp)); Lisp_Object old_value = specpdl_old_value (tmp);
Lisp_Object old_value = specpdl_old_value (tmp); set_specpdl_old_value (tmp, SYMBOL_VAL (sym));
set_specpdl_old_value (tmp, SYMBOL_VAL (sym)); SET_SYMBOL_VAL (sym, old_value);
SET_SYMBOL_VAL (sym, old_value); break;
break; }
} else
else { /* FALLTHROUGH!!
{ NOTE: we only ever come here if make_local_foo was used for
/* FALLTHROUGH! the first time on this var within this let. */
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: case SPECPDL_LET_DEFAULT:
{ {
Lisp_Object sym = specpdl_symbol (tmp); Lisp_Object sym = specpdl_symbol (tmp);
@ -3796,6 +3834,8 @@ alist of active lexical bindings. */);
defsubr (&Ssetq); defsubr (&Ssetq);
defsubr (&Squote); defsubr (&Squote);
defsubr (&Sfunction); defsubr (&Sfunction);
defsubr (&Sdefault_toplevel_value);
defsubr (&Sset_default_toplevel_value);
defsubr (&Sdefvar); defsubr (&Sdefvar);
defsubr (&Sdefvaralias); defsubr (&Sdefvaralias);
defsubr (&Sdefconst); defsubr (&Sdefconst);

24
src/term.c
View file

@ -2933,7 +2933,7 @@ dissociate_if_controlling_tty (int fd)
TERMINAL_TYPE is the termcap type of the device, e.g. "vt100". 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 * struct terminal *
init_tty (const char *name, const char *terminal_type, bool must_succeed) 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; int status;
struct tty_display_info *tty = NULL; struct tty_display_info *tty = NULL;
struct terminal *terminal = 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) if (!terminal_type)
maybe_fatal (must_succeed, 0, 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); tty->termcap_term_buffer = xmalloc (buffer_size);
/* On some systems, tgetent tries to access the controlling /* On some systems, tgetent tries to access the controlling
terminal. */ terminal. */
block_tty_out_signal (); block_tty_out_signal ();
status = tgetent (tty->termcap_term_buffer, terminal_type); status = tgetent (tty->termcap_term_buffer, terminal_type);
unblock_tty_out_signal (); unblock_tty_out_signal ();
@ -3101,13 +3101,13 @@ use the Bourne shell command `TERM=... export TERM' (C-shell:\n\
Right (tty) = tgetstr ("nd", address); Right (tty) = tgetstr ("nd", address);
Down (tty) = tgetstr ("do", address); Down (tty) = tgetstr ("do", address);
if (!Down (tty)) if (!Down (tty))
Down (tty) = tgetstr ("nl", address); /* Obsolete name for "do" */ Down (tty) = tgetstr ("nl", address); /* Obsolete name for "do". */
if (tgetflag ("bs")) if (tgetflag ("bs"))
Left (tty) = "\b"; /* can't possibly be longer! */ Left (tty) = "\b"; /* Can't possibly be longer! */
else /* (Actually, "bs" is obsolete...) */ else /* (Actually, "bs" is obsolete...) */
Left (tty) = tgetstr ("le", address); Left (tty) = tgetstr ("le", address);
if (!Left (tty)) 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_pad_char = tgetstr ("pc", address);
tty->TS_repeat = tgetstr ("rp", address); tty->TS_repeat = tgetstr ("rp", address);
tty->TS_end_standout_mode = tgetstr ("se", 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. */ don't think we're losing anything by turning it off. */
terminal->line_ins_del_ok = 0; 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 */ #endif /* DOS_NT */
#ifdef HAVE_GPM #ifdef HAVE_GPM
@ -3325,16 +3325,16 @@ use the Bourne shell command `TERM=... export TERM' (C-shell:\n\
tty->Wcm->cm_tab = 0; tty->Wcm->cm_tab = 0;
/* We can't support standout mode, because it uses magic cookies. */ /* We can't support standout mode, because it uses magic cookies. */
tty->TS_standout_mode = 0; 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; CR (tty) = 0;
/* LF can't be trusted either -- can alter hpos */ /* LF can't be trusted either -- can alter hpos. */
/* if move at column 0 thru a line with TS_standout_mode */ /* If move at column 0 thru a line with TS_standout_mode. */
Down (tty) = 0; Down (tty) = 0;
} }
tty->specified_window = FrameRows (tty); 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, maybe_fatal (must_succeed, terminal,
"Terminal type \"%s\" is not powerful enough to run Emacs", "Terminal type \"%s\" is not powerful enough to run Emacs",

4
test/ChangeLog
View file

@ -1,3 +1,7 @@
2013-08-02 Stefan Monnier <monnier@iro.umontreal.ca>
* automated/core-elisp-tests.el: New file.
2013-08-01 Glenn Morris <rgm@gnu.org> 2013-08-01 Glenn Morris <rgm@gnu.org>
* automated/file-notify-tests.el (file-notify--test-remote-enabled): * automated/file-notify-tests.el (file-notify--test-remote-enabled):

38
test/automated/core-elisp-tests.el Normal file
View file

@ -0,0 +1,38 @@
;;; core-elisp-tests.el --- Testing some core Elisp rules
;; Copyright (C) 2013 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; 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 <http://www.gnu.org/licenses/>.
;;; 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