X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/3c4ca7155293ffc2d04708007131bcbc882d8913..18da0d8ad4e5036185acbad3238cbfe2aaf3ca66:/src/data.c diff --git a/src/data.c b/src/data.c index 09899400b6..51b0266eca 100644 --- a/src/data.c +++ b/src/data.c @@ -1,6 +1,6 @@ /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter. - Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2012 - Free Software Foundation, Inc. + Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 Free Software + Foundation, Inc. This file is part of GNU Emacs. @@ -76,7 +76,8 @@ static Lisp_Object Qprocess, Qmarker; static Lisp_Object Qcompiled_function, Qframe; Lisp_Object Qbuffer; static Lisp_Object Qchar_table, Qbool_vector, Qhash_table; -static Lisp_Object Qsubrp, Qmany, Qunevalled; +static Lisp_Object Qsubrp; +static Lisp_Object Qmany, Qunevalled; Lisp_Object Qfont_spec, Qfont_entity, Qfont_object; static Lisp_Object Qdefun; @@ -85,6 +86,94 @@ static Lisp_Object Qdefalias_fset_function; static void swap_in_symval_forwarding (struct Lisp_Symbol *, struct Lisp_Buffer_Local_Value *); +static bool +BOOLFWDP (union Lisp_Fwd *a) +{ + return XFWDTYPE (a) == Lisp_Fwd_Bool; +} +static bool +INTFWDP (union Lisp_Fwd *a) +{ + return XFWDTYPE (a) == Lisp_Fwd_Int; +} +static bool +KBOARD_OBJFWDP (union Lisp_Fwd *a) +{ + return XFWDTYPE (a) == Lisp_Fwd_Kboard_Obj; +} +static bool +OBJFWDP (union Lisp_Fwd *a) +{ + return XFWDTYPE (a) == Lisp_Fwd_Obj; +} + +static struct Lisp_Boolfwd * +XBOOLFWD (union Lisp_Fwd *a) +{ + eassert (BOOLFWDP (a)); + return &a->u_boolfwd; +} +static struct Lisp_Kboard_Objfwd * +XKBOARD_OBJFWD (union Lisp_Fwd *a) +{ + eassert (KBOARD_OBJFWDP (a)); + return &a->u_kboard_objfwd; +} +static struct Lisp_Intfwd * +XINTFWD (union Lisp_Fwd *a) +{ + eassert (INTFWDP (a)); + return &a->u_intfwd; +} +static struct Lisp_Objfwd * +XOBJFWD (union Lisp_Fwd *a) +{ + eassert (OBJFWDP (a)); + return &a->u_objfwd; +} + +static void +CHECK_SUBR (Lisp_Object x) +{ + CHECK_TYPE (SUBRP (x), Qsubrp, x); +} + +static void +set_blv_found (struct Lisp_Buffer_Local_Value *blv, int found) +{ + eassert (found == !EQ (blv->defcell, blv->valcell)); + blv->found = found; +} + +static Lisp_Object +blv_value (struct Lisp_Buffer_Local_Value *blv) +{ + return XCDR (blv->valcell); +} + +static void +set_blv_value (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val) +{ + XSETCDR (blv->valcell, val); +} + +static void +set_blv_where (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val) +{ + blv->where = val; +} + +static void +set_blv_defcell (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val) +{ + blv->defcell = val; +} + +static void +set_blv_valcell (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val) +{ + blv->valcell = val; +} Lisp_Object wrong_type_argument (register Lisp_Object predicate, register Lisp_Object value) @@ -100,9 +189,9 @@ wrong_type_argument (register Lisp_Object predicate, register Lisp_Object value) } void -pure_write_error (void) +pure_write_error (Lisp_Object obj) { - error ("Attempt to modify read-only object"); + xsignal2 (Qerror, build_string ("Attempt to modify read-only object"), obj); } void @@ -288,7 +377,8 @@ DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p, 1, 1, 0, - doc: /* Return t if OBJECT is a multibyte string. */) + doc: /* Return t if OBJECT is a multibyte string. +Return nil if OBJECT is either a unibyte string, or not a string. */) (Lisp_Object object) { if (STRINGP (object) && STRING_MULTIBYTE (object)) @@ -506,7 +596,9 @@ DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0, /* Extract and set components of symbols. */ DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, - doc: /* Return t if SYMBOL's value is not void. */) + doc: /* Return t if SYMBOL's value is not void. +Note that if `lexical-binding' is in effect, this refers to the +global value outside of any lexical scope. */) (register Lisp_Object symbol) { Lisp_Object valcontents; @@ -543,12 +635,13 @@ DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, return (EQ (valcontents, Qunbound) ? Qnil : Qt); } +/* FIXME: Make it an alias for function-symbol! */ DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, doc: /* Return t if SYMBOL's function definition is not void. */) (register Lisp_Object symbol) { CHECK_SYMBOL (symbol); - return EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt; + return NILP (XSYMBOL (symbol)->function) ? Qnil : Qt; } DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, @@ -564,14 +657,14 @@ Return SYMBOL. */) } DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, - doc: /* Make SYMBOL's function definition be void. + doc: /* Make SYMBOL's function definition be nil. Return SYMBOL. */) (register Lisp_Object symbol) { CHECK_SYMBOL (symbol); if (NILP (symbol) || EQ (symbol, Qt)) xsignal1 (Qsetting_constant, symbol); - set_symbol_function (symbol, Qunbound); + set_symbol_function (symbol, Qnil); return symbol; } @@ -580,9 +673,7 @@ DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0, (register Lisp_Object symbol) { CHECK_SYMBOL (symbol); - if (!EQ (XSYMBOL (symbol)->function, Qunbound)) - return XSYMBOL (symbol)->function; - xsignal1 (Qvoid_function, symbol); + return XSYMBOL (symbol)->function; } DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, @@ -613,7 +704,7 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0, function = XSYMBOL (symbol)->function; - if (!NILP (Vautoload_queue) && !EQ (function, Qunbound)) + if (!NILP (Vautoload_queue) && !NILP (function)) Vautoload_queue = Fcons (Fcons (symbol, function), Vautoload_queue); if (AUTOLOADP (function)) @@ -714,7 +805,7 @@ Value, if non-nil, is a list \(interactive SPEC). */) { Lisp_Object fun = indirect_function (cmd); /* Check cycles. */ - if (NILP (fun) || EQ (fun, Qunbound)) + if (NILP (fun)) return Qnil; /* Use an `interactive-form' property if present, analogous to the @@ -890,19 +981,14 @@ store_symval_forwarding (union Lisp_Fwd *valcontents, register Lisp_Object newva - (char *) &buffer_defaults); int idx = PER_BUFFER_IDX (offset); - Lisp_Object tail; + Lisp_Object tail, buf; if (idx <= 0) break; - for (tail = Vbuffer_alist; CONSP (tail); tail = XCDR (tail)) + FOR_EACH_LIVE_BUFFER (tail, buf) { - Lisp_Object lbuf; - struct buffer *b; - - lbuf = Fcdr (XCAR (tail)); - if (!BUFFERP (lbuf)) continue; - b = XBUFFER (lbuf); + struct buffer *b = XBUFFER (buf); if (! PER_BUFFER_VALUE_P (b, idx)) set_per_buffer_value (b, offset, newval); @@ -913,13 +999,11 @@ store_symval_forwarding (union Lisp_Fwd *valcontents, register Lisp_Object newva case Lisp_Fwd_Buffer_Obj: { int offset = XBUFFER_OBJFWD (valcontents)->offset; - Lisp_Object type = XBUFFER_OBJFWD (valcontents)->slottype; + Lisp_Object predicate = XBUFFER_OBJFWD (valcontents)->predicate; - if (!(NILP (type) || NILP (newval) - || (XINT (type) == Lisp_Int0 - ? INTEGERP (newval) - : XTYPE (newval) == XINT (type)))) - buffer_slot_type_mismatch (newval, XINT (type)); + if (!NILP (predicate) && !NILP (newval) + && NILP (call1 (predicate, newval))) + wrong_type_argument (predicate, newval); if (buf == NULL) buf = current_buffer; @@ -1048,7 +1132,9 @@ find_symbol_value (Lisp_Object symbol) } DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0, - doc: /* Return SYMBOL's value. Error if that is void. */) + doc: /* Return SYMBOL's value. Error if that is void. +Note that if `lexical-binding' is in effect, this returns the +global value outside of any lexical scope. */) (Lisp_Object symbol) { Lisp_Object val; @@ -1068,40 +1154,6 @@ DEFUN ("set", Fset, Sset, 2, 2, 0, return newval; } -/* Return true if SYMBOL currently has a let-binding - which was made in the buffer that is now current. */ - -static bool -let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol) -{ - struct specbinding *p; - - for (p = specpdl_ptr; p > specpdl; ) - if ((--p)->func == NULL - && CONSP (p->symbol)) - { - struct Lisp_Symbol *let_bound_symbol = XSYMBOL (XCAR (p->symbol)); - eassert (let_bound_symbol->redirect != SYMBOL_VARALIAS); - if (symbol == let_bound_symbol - && XBUFFER (XCDR (XCDR (p->symbol))) == current_buffer) - return 1; - } - - return 0; -} - -static bool -let_shadows_global_binding_p (Lisp_Object symbol) -{ - struct specbinding *p; - - for (p = specpdl_ptr; p > specpdl; ) - if ((--p)->func == NULL && EQ (p->symbol, symbol)) - return 1; - - return 0; -} - /* Store the value NEWVAL into SYMBOL. If buffer/frame-locality is an issue, WHERE specifies which context to use. (nil stands for the current buffer/frame). @@ -1327,9 +1379,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; @@ -1421,24 +1471,19 @@ of previous VARs. usage: (setq-default [VAR VALUE]...) */) (Lisp_Object args) { - register Lisp_Object args_left; - register Lisp_Object val, symbol; + Lisp_Object args_left, symbol, val; struct gcpro gcpro1; - if (NILP (args)) - return Qnil; - - args_left = args; + args_left = val = args; GCPRO1 (args); - do + while (CONSP (args_left)) { - val = eval_sub (Fcar (Fcdr (args_left))); + val = eval_sub (Fcar (XCDR (args_left))); symbol = XCAR (args_left); Fset_default (symbol, val); args_left = Fcdr (XCDR (args_left)); } - while (!NILP (args_left)); UNGCPRO; return val; @@ -1840,17 +1885,18 @@ BUFFER defaults to the current buffer. */) XSETBUFFER (tmp, buf); XSETSYMBOL (variable, sym); /* Update in case of aliasing. */ - for (tail = BVAR (buf, local_var_alist); CONSP (tail); tail = XCDR (tail)) - { - elt = XCAR (tail); - if (EQ (variable, XCAR (elt))) - { - eassert (!blv->frame_local); - eassert (blv_found (blv) || !EQ (blv->where, tmp)); - return Qt; - } - } - eassert (!blv_found (blv) || !EQ (blv->where, tmp)); + if (EQ (blv->where, tmp)) /* The binding is already loaded. */ + return blv_found (blv) ? Qt : Qnil; + else + for (tail = BVAR (buf, local_var_alist); CONSP (tail); tail = XCDR (tail)) + { + elt = XCAR (tail); + if (EQ (variable, XCAR (elt))) + { + eassert (!blv->frame_local); + return Qt; + } + } return Qnil; } case SYMBOL_FORWARDED: @@ -1929,7 +1975,7 @@ If the current binding is global (the default), the value is nil. */) { union Lisp_Fwd *valcontents = SYMBOL_FWD (sym); if (KBOARD_OBJFWDP (valcontents)) - return Fframe_terminal (Fselected_frame ()); + return Fframe_terminal (selected_frame); else if (!BUFFER_OBJFWDP (valcontents)) return Qnil; } @@ -2008,10 +2054,10 @@ indirect_function (register Lisp_Object object) for (;;) { - if (!SYMBOLP (hare) || EQ (hare, Qunbound)) + if (!SYMBOLP (hare) || NILP (hare)) break; hare = XSYMBOL (hare)->function; - if (!SYMBOLP (hare) || EQ (hare, Qunbound)) + if (!SYMBOLP (hare) || NILP (hare)) break; hare = XSYMBOL (hare)->function; @@ -2038,10 +2084,10 @@ function chain of symbols. */) /* Optimize for no indirection. */ result = object; - if (SYMBOLP (result) && !EQ (result, Qunbound) + if (SYMBOLP (result) && !NILP (result) && (result = XSYMBOL (result)->function, SYMBOLP (result))) result = indirect_function (result); - if (!EQ (result, Qunbound)) + if (!NILP (result)) return result; if (NILP (noerror)) @@ -2209,10 +2255,8 @@ bool-vector. IDX starts at 0. */) /* Arithmetic functions */ -enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal }; - -static Lisp_Object -arithcompare (Lisp_Object num1, Lisp_Object num2, enum comparison comparison) +Lisp_Object +arithcompare (Lisp_Object num1, Lisp_Object num2, enum Arith_Comparison comparison) { double f1 = 0, f2 = 0; bool floatp = 0; @@ -2229,32 +2273,32 @@ arithcompare (Lisp_Object num1, Lisp_Object num2, enum comparison comparison) switch (comparison) { - case equal: + case ARITH_EQUAL: if (floatp ? f1 == f2 : XINT (num1) == XINT (num2)) return Qt; return Qnil; - case notequal: + case ARITH_NOTEQUAL: if (floatp ? f1 != f2 : XINT (num1) != XINT (num2)) return Qt; return Qnil; - case less: + case ARITH_LESS: if (floatp ? f1 < f2 : XINT (num1) < XINT (num2)) return Qt; return Qnil; - case less_or_equal: + case ARITH_LESS_OR_EQUAL: if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2)) return Qt; return Qnil; - case grtr: + case ARITH_GRTR: if (floatp ? f1 > f2 : XINT (num1) > XINT (num2)) return Qt; return Qnil; - case grtr_or_equal: + case ARITH_GRTR_OR_EQUAL: if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2)) return Qt; return Qnil; @@ -2264,48 +2308,65 @@ arithcompare (Lisp_Object num1, Lisp_Object num2, enum comparison comparison) } } -DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0, - doc: /* Return t if two args, both numbers or markers, are equal. */) - (register Lisp_Object num1, Lisp_Object num2) +static Lisp_Object +arithcompare_driver (ptrdiff_t nargs, Lisp_Object *args, + enum Arith_Comparison comparison) +{ + for (ptrdiff_t argnum = 1; argnum < nargs; ++argnum) + { + if (EQ (Qnil, arithcompare (args[argnum-1], args[argnum], comparison))) + return Qnil; + } + return Qt; +} + +DEFUN ("=", Feqlsign, Seqlsign, 1, MANY, 0, + doc: /* Return t if args, all numbers or markers, are equal. +usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) + (ptrdiff_t nargs, Lisp_Object *args) { - return arithcompare (num1, num2, equal); + return arithcompare_driver (nargs, args, ARITH_EQUAL); } -DEFUN ("<", Flss, Slss, 2, 2, 0, - doc: /* Return t if first arg is less than second arg. Both must be numbers or markers. */) - (register Lisp_Object num1, Lisp_Object num2) +DEFUN ("<", Flss, Slss, 1, MANY, 0, + doc: /* Return t if each arg is less than the next arg. All must be numbers or markers. +usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) + (ptrdiff_t nargs, Lisp_Object *args) { - return arithcompare (num1, num2, less); + return arithcompare_driver (nargs, args, ARITH_LESS); } -DEFUN (">", Fgtr, Sgtr, 2, 2, 0, - doc: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */) - (register Lisp_Object num1, Lisp_Object num2) +DEFUN (">", Fgtr, Sgtr, 1, MANY, 0, + doc: /* Return t if each arg is greater than the next arg. All must be numbers or markers. +usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) + (ptrdiff_t nargs, Lisp_Object *args) { - return arithcompare (num1, num2, grtr); + return arithcompare_driver (nargs, args, ARITH_GRTR); } -DEFUN ("<=", Fleq, Sleq, 2, 2, 0, - doc: /* Return t if first arg is less than or equal to second arg. -Both must be numbers or markers. */) - (register Lisp_Object num1, Lisp_Object num2) +DEFUN ("<=", Fleq, Sleq, 1, MANY, 0, + doc: /* Return t if each arg is less than or equal to the next arg. +All must be numbers or markers. +usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) + (ptrdiff_t nargs, Lisp_Object *args) { - return arithcompare (num1, num2, less_or_equal); + return arithcompare_driver (nargs, args, ARITH_LESS_OR_EQUAL); } -DEFUN (">=", Fgeq, Sgeq, 2, 2, 0, - doc: /* Return t if first arg is greater than or equal to second arg. -Both must be numbers or markers. */) - (register Lisp_Object num1, Lisp_Object num2) +DEFUN (">=", Fgeq, Sgeq, 1, MANY, 0, + doc: /* Return t if each arg is greater than or equal to the next arg. +All must be numbers or markers. +usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) + (ptrdiff_t nargs, Lisp_Object *args) { - return arithcompare (num1, num2, grtr_or_equal); + return arithcompare_driver (nargs, args, ARITH_GRTR_OR_EQUAL); } DEFUN ("/=", Fneq, Sneq, 2, 2, 0, doc: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */) (register Lisp_Object num1, Lisp_Object num2) { - return arithcompare (num1, num2, notequal); + return arithcompare (num1, num2, ARITH_NOTEQUAL); } DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0,