* 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.
\f
* 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):
;;; 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.")
(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.
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;
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.
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);
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));
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);
defsubr (&Ssetq);
defsubr (&Squote);
defsubr (&Sfunction);
+ defsubr (&Sdefault_toplevel_value);
+ defsubr (&Sset_default_toplevel_value);
defsubr (&Sdefvar);
defsubr (&Sdefvaralias);
defsubr (&Sdefconst);
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)
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,
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 ();
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);
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
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):
--- /dev/null
+;;; 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
projects / emacs.git / commitdiff