Commit a104f656 authored by Stefan Monnier's avatar Stefan Monnier

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.
parent 185e3b5a
......@@ -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.
......
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>
* emacs-lisp/lisp-mode.el (lisp-imenu-generic-expression):
......
......@@ -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.")
......
......@@ -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))))
......
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.
......
......@@ -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;
......
......@@ -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);
......
......@@ -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",
......
2013-08-02 Stefan Monnier <monnier@iro.umontreal.ca>
* automated/core-elisp-tests.el: New file.
2013-08-01 Glenn Morris <rgm@gnu.org>
* automated/file-notify-tests.el (file-notify--test-remote-enabled):
......
;;; 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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment