mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-01-07 20:30:32 -08:00
Code Issues Projects Releases Wiki Activity

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

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>
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. */)
(Lisp_Object symbol)
{
register Lisp_Object value;
value = default_value (symbol);
Lisp_Object value = default_value (symbol);
if (!EQ (value, Qunbound))
return value;

124
src/eval.c
View file

@ -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);

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".
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",