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.

10 files changed, 201 insertions, 99 deletions

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  <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):
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  <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.
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  <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):
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 <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