X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/c80bd143cf695be5272821ef623527abcd88ea5d..ee6bb6939fe507dc98986bfc23794da6110f61ef:/src/data.c diff --git a/src/data.c b/src/data.c index 0350ecc315..f362b0253d 100644 --- a/src/data.c +++ b/src/data.c @@ -1,11 +1,12 @@ /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter. - Copyright (C) 1985, 1986, 1988, 1993, 1994 Free Software Foundation, Inc. + Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000, + 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. This file is part of GNU Emacs. GNU Emacs 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 1, or (at your option) +the Free Software Foundation; either version 2, or (at your option) any later version. GNU Emacs is distributed in the hope that it will be useful, @@ -15,32 +16,33 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs; see the file COPYING. If not, write to -the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ +the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ -#include - #include +#include +#include #include "lisp.h" #include "puresize.h" - -#ifndef standalone +#include "charset.h" #include "buffer.h" -#endif - +#include "keyboard.h" +#include "frame.h" #include "syssignal.h" -#ifdef MSDOS -/* These are redefined (correctly, but differently) in values.h. */ -#undef INTBITS -#undef LONGBITS -#undef SHORTBITS +#ifdef STDC_HEADERS +#include #endif -#ifdef LISP_FLOAT_TYPE - -#ifdef STDC_HEADERS -#include +/* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */ +#ifndef IEEE_FLOATING_POINT +#if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \ + && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128) +#define IEEE_FLOATING_POINT 1 +#else +#define IEEE_FLOATING_POINT 0 +#endif #endif /* Work around a problem that happens because math.h on hpux 7 @@ -54,7 +56,6 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #endif #include -#endif /* LISP_FLOAT_TYPE */ #if !defined (atof) extern double atof (); @@ -64,50 +65,63 @@ Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound; Lisp_Object Qerror_conditions, Qerror_message, Qtop_level; Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range; Lisp_Object Qvoid_variable, Qvoid_function, Qcyclic_function_indirection; +Lisp_Object Qcyclic_variable_indirection, Qcircular_list; Lisp_Object Qsetting_constant, Qinvalid_read_syntax; Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch; Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive; Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only; +Lisp_Object Qtext_read_only; + Lisp_Object Qintegerp, Qnatnump, Qwholenump, Qsymbolp, Qlistp, Qconsp; Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp; Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp; -Lisp_Object Qbuffer_or_string_p; +Lisp_Object Qbuffer_or_string_p, Qkeywordp; Lisp_Object Qboundp, Qfboundp; +Lisp_Object Qchar_table_p, Qvector_or_char_table_p; + Lisp_Object Qcdr; -Lisp_Object Qad_advice_info, Qad_activate; +Lisp_Object Qad_advice_info, Qad_activate_internal; Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error; Lisp_Object Qoverflow_error, Qunderflow_error; -#ifdef LISP_FLOAT_TYPE Lisp_Object Qfloatp; Lisp_Object Qnumberp, Qnumber_or_marker_p; -#endif -static Lisp_Object swap_in_symval_forwarding (); +Lisp_Object Qinteger; +static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay; +static Lisp_Object Qfloat, Qwindow_configuration, Qwindow; +Lisp_Object Qprocess; +static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector; +static Lisp_Object Qchar_table, Qbool_vector, Qhash_table; +static Lisp_Object Qsubrp, Qmany, Qunevalled; + +static Lisp_Object swap_in_symval_forwarding P_ ((Lisp_Object, Lisp_Object)); + +Lisp_Object Vmost_positive_fixnum, Vmost_negative_fixnum; + + +void +circular_list_error (list) + Lisp_Object list; +{ + xsignal (Qcircular_list, list); +} + Lisp_Object wrong_type_argument (predicate, value) register Lisp_Object predicate, value; { - register Lisp_Object tem; - do - { - if (!EQ (Vmocklisp_arguments, Qt)) - { - if (STRINGP (value) && - (EQ (predicate, Qintegerp) || EQ (predicate, Qinteger_or_marker_p))) - return Fstring_to_number (value); - if (INTEGERP (value) && EQ (predicate, Qstringp)) - return Fnumber_to_string (value); - } - value = Fsignal (Qwrong_type_argument, Fcons (predicate, Fcons (value, Qnil))); - tem = call1 (predicate, value); - } - while (NILP (tem)); - return value; + /* If VALUE is not even a valid Lisp object, abort here + where we can get a backtrace showing where it came from. */ + if ((unsigned int) XGCTYPE (value) >= Lisp_Type_Limit) + abort (); + + xsignal2 (Qwrong_type_argument, predicate, value); } +void pure_write_error () { error ("Attempt to modify read-only object"); @@ -117,25 +131,14 @@ void args_out_of_range (a1, a2) Lisp_Object a1, a2; { - while (1) - Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Qnil))); + xsignal2 (Qargs_out_of_range, a1, a2); } void args_out_of_range_3 (a1, a2, a3) Lisp_Object a1, a2, a3; { - while (1) - Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Fcons (a3, Qnil)))); -} - -Lisp_Object -make_number (num) - int num; -{ - register Lisp_Object val; - XSETINT (val, num); - return val; + xsignal3 (Qargs_out_of_range, a1, a2, a3); } /* On some machines, XINT needs a temporary location. @@ -158,8 +161,8 @@ sign_extend_lisp_int (num) /* Data type predicates */ DEFUN ("eq", Feq, Seq, 2, 2, 0, - "T if the two args are the same Lisp object.") - (obj1, obj2) + doc: /* Return t if the two args are the same Lisp object. */) + (obj1, obj2) Lisp_Object obj1, obj2; { if (EQ (obj1, obj2)) @@ -167,179 +170,316 @@ DEFUN ("eq", Feq, Seq, 2, 2, 0, return Qnil; } -DEFUN ("null", Fnull, Snull, 1, 1, 0, "T if OBJECT is nil.") - (obj) - Lisp_Object obj; +DEFUN ("null", Fnull, Snull, 1, 1, 0, + doc: /* Return t if OBJECT is nil. */) + (object) + Lisp_Object object; { - if (NILP (obj)) + if (NILP (object)) return Qt; return Qnil; } -DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, "T if OBJECT is a cons cell.") - (obj) - Lisp_Object obj; +DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0, + doc: /* Return a symbol representing the type of OBJECT. +The symbol returned names the object's basic type; +for example, (type-of 1) returns `integer'. */) + (object) + Lisp_Object object; { - if (CONSP (obj)) + switch (XGCTYPE (object)) + { + case Lisp_Int: + return Qinteger; + + case Lisp_Symbol: + return Qsymbol; + + case Lisp_String: + return Qstring; + + case Lisp_Cons: + return Qcons; + + case Lisp_Misc: + switch (XMISCTYPE (object)) + { + case Lisp_Misc_Marker: + return Qmarker; + case Lisp_Misc_Overlay: + return Qoverlay; + case Lisp_Misc_Float: + return Qfloat; + } + abort (); + + case Lisp_Vectorlike: + if (GC_WINDOW_CONFIGURATIONP (object)) + return Qwindow_configuration; + if (GC_PROCESSP (object)) + return Qprocess; + if (GC_WINDOWP (object)) + return Qwindow; + if (GC_SUBRP (object)) + return Qsubr; + if (GC_COMPILEDP (object)) + return Qcompiled_function; + if (GC_BUFFERP (object)) + return Qbuffer; + if (GC_CHAR_TABLE_P (object)) + return Qchar_table; + if (GC_BOOL_VECTOR_P (object)) + return Qbool_vector; + if (GC_FRAMEP (object)) + return Qframe; + if (GC_HASH_TABLE_P (object)) + return Qhash_table; + return Qvector; + + case Lisp_Float: + return Qfloat; + + default: + abort (); + } +} + +DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, + doc: /* Return t if OBJECT is a cons cell. */) + (object) + Lisp_Object object; +{ + if (CONSP (object)) return Qt; return Qnil; } -DEFUN ("atom", Fatom, Satom, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.") - (obj) - Lisp_Object obj; +DEFUN ("atom", Fatom, Satom, 1, 1, 0, + doc: /* Return t if OBJECT is not a cons cell. This includes nil. */) + (object) + Lisp_Object object; { - if (CONSP (obj)) + if (CONSP (object)) return Qnil; return Qt; } -DEFUN ("listp", Flistp, Slistp, 1, 1, 0, "T if OBJECT is a list. This includes nil.") - (obj) - Lisp_Object obj; +DEFUN ("listp", Flistp, Slistp, 1, 1, 0, + doc: /* Return t if OBJECT is a list, that is, a cons cell or nil. +Otherwise, return nil. */) + (object) + Lisp_Object object; { - if (CONSP (obj) || NILP (obj)) + if (CONSP (object) || NILP (object)) return Qt; return Qnil; } -DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.") - (obj) - Lisp_Object obj; +DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, + doc: /* Return t if OBJECT is not a list. Lists include nil. */) + (object) + Lisp_Object object; { - if (CONSP (obj) || NILP (obj)) + if (CONSP (object) || NILP (object)) return Qnil; return Qt; } -DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, "T if OBJECT is a symbol.") - (obj) - Lisp_Object obj; +DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, + doc: /* Return t if OBJECT is a symbol. */) + (object) + Lisp_Object object; +{ + if (SYMBOLP (object)) + return Qt; + return Qnil; +} + +/* Define this in C to avoid unnecessarily consing up the symbol + name. */ +DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0, + doc: /* Return t if OBJECT is a keyword. +This means that it is a symbol with a print name beginning with `:' +interned in the initial obarray. */) + (object) + Lisp_Object object; { - if (SYMBOLP (obj)) + if (SYMBOLP (object) + && SREF (SYMBOL_NAME (object), 0) == ':' + && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object)) return Qt; return Qnil; } -DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0, "T if OBJECT is a vector.") - (obj) - Lisp_Object obj; +DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0, + doc: /* Return t if OBJECT is a vector. */) + (object) + Lisp_Object object; { - if (VECTORP (obj)) + if (VECTORP (object)) return Qt; return Qnil; } -DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, "T if OBJECT is a string.") - (obj) - Lisp_Object obj; +DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, + doc: /* Return t if OBJECT is a string. */) + (object) + Lisp_Object object; { - if (STRINGP (obj)) + if (STRINGP (object)) return Qt; return Qnil; } -DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "T if OBJECT is an array (string or vector).") - (obj) - Lisp_Object obj; +DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p, + 1, 1, 0, + doc: /* Return t if OBJECT is a multibyte string. */) + (object) + Lisp_Object object; +{ + if (STRINGP (object) && STRING_MULTIBYTE (object)) + return Qt; + return Qnil; +} + +DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0, + doc: /* Return t if OBJECT is a char-table. */) + (object) + Lisp_Object object; +{ + if (CHAR_TABLE_P (object)) + return Qt; + return Qnil; +} + +DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p, + Svector_or_char_table_p, 1, 1, 0, + doc: /* Return t if OBJECT is a char-table or vector. */) + (object) + Lisp_Object object; { - if (VECTORP (obj) || STRINGP (obj)) + if (VECTORP (object) || CHAR_TABLE_P (object)) + return Qt; + return Qnil; +} + +DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0, + doc: /* Return t if OBJECT is a bool-vector. */) + (object) + Lisp_Object object; +{ + if (BOOL_VECTOR_P (object)) + return Qt; + return Qnil; +} + +DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, + doc: /* Return t if OBJECT is an array (string or vector). */) + (object) + Lisp_Object object; +{ + if (ARRAYP (object)) return Qt; return Qnil; } DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0, - "T if OBJECT is a sequence (list or array).") - (obj) - register Lisp_Object obj; + doc: /* Return t if OBJECT is a sequence (list or array). */) + (object) + register Lisp_Object object; { - if (CONSP (obj) || NILP (obj) || VECTORP (obj) || STRINGP (obj)) + if (CONSP (object) || NILP (object) || ARRAYP (object)) return Qt; return Qnil; } -DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, "T if OBJECT is an editor buffer.") - (obj) - Lisp_Object obj; +DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, + doc: /* Return t if OBJECT is an editor buffer. */) + (object) + Lisp_Object object; { - if (BUFFERP (obj)) + if (BUFFERP (object)) return Qt; return Qnil; } -DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, "T if OBJECT is a marker (editor pointer).") - (obj) - Lisp_Object obj; +DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, + doc: /* Return t if OBJECT is a marker (editor pointer). */) + (object) + Lisp_Object object; { - if (MARKERP (obj)) + if (MARKERP (object)) return Qt; return Qnil; } -DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "T if OBJECT is a built-in function.") - (obj) - Lisp_Object obj; +DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, + doc: /* Return t if OBJECT is a built-in function. */) + (object) + Lisp_Object object; { - if (SUBRP (obj)) + if (SUBRP (object)) return Qt; return Qnil; } DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p, - 1, 1, 0, "T if OBJECT is a byte-compiled function object.") - (obj) - Lisp_Object obj; + 1, 1, 0, + doc: /* Return t if OBJECT is a byte-compiled function object. */) + (object) + Lisp_Object object; { - if (COMPILEDP (obj)) + if (COMPILEDP (object)) return Qt; return Qnil; } DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0, - "T if OBJECT is a character (an integer) or a string.") - (obj) - register Lisp_Object obj; + doc: /* Return t if OBJECT is a character (an integer) or a string. */) + (object) + register Lisp_Object object; { - if (INTEGERP (obj) || STRINGP (obj)) + if (INTEGERP (object) || STRINGP (object)) return Qt; return Qnil; } -DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, "T if OBJECT is an integer.") - (obj) - Lisp_Object obj; +DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, + doc: /* Return t if OBJECT is an integer. */) + (object) + Lisp_Object object; { - if (INTEGERP (obj)) + if (INTEGERP (object)) return Qt; return Qnil; } DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0, - "T if OBJECT is an integer or a marker (editor pointer).") - (obj) - register Lisp_Object obj; + doc: /* Return t if OBJECT is an integer or a marker (editor pointer). */) + (object) + register Lisp_Object object; { - if (MARKERP (obj) || INTEGERP (obj)) + if (MARKERP (object) || INTEGERP (object)) return Qt; return Qnil; } DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0, - "T if OBJECT is a nonnegative integer.") - (obj) - Lisp_Object obj; + doc: /* Return t if OBJECT is a nonnegative integer. */) + (object) + Lisp_Object object; { - if (NATNUMP (obj)) + if (NATNUMP (object)) return Qt; return Qnil; } DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0, - "T if OBJECT is a number (floating point or integer).") - (obj) - Lisp_Object obj; + doc: /* Return t if OBJECT is a number (floating point or integer). */) + (object) + Lisp_Object object; { - if (NUMBERP (obj)) + if (NUMBERP (object)) return Qt; else return Qnil; @@ -347,267 +487,346 @@ DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0, DEFUN ("number-or-marker-p", Fnumber_or_marker_p, Snumber_or_marker_p, 1, 1, 0, - "T if OBJECT is a number or a marker.") - (obj) - Lisp_Object obj; + doc: /* Return t if OBJECT is a number or a marker. */) + (object) + Lisp_Object object; { - if (NUMBERP (obj) || MARKERP (obj)) + if (NUMBERP (object) || MARKERP (object)) return Qt; return Qnil; } -#ifdef LISP_FLOAT_TYPE DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0, - "T if OBJECT is a floating point number.") - (obj) - Lisp_Object obj; + doc: /* Return t if OBJECT is a floating point number. */) + (object) + Lisp_Object object; { - if (FLOATP (obj)) + if (FLOATP (object)) return Qt; return Qnil; } -#endif /* LISP_FLOAT_TYPE */ + /* Extract and set components of lists */ DEFUN ("car", Fcar, Scar, 1, 1, 0, - "Return the car of CONSCELL. If arg is nil, return nil.\n\ -Error if arg is not nil and not a cons cell. See also `car-safe'.") - (list) + doc: /* Return the car of LIST. If arg is nil, return nil. +Error if arg is not nil and not a cons cell. See also `car-safe'. + +See Info node `(elisp)Cons Cells' for a discussion of related basic +Lisp concepts such as car, cdr, cons cell and list. */) + (list) register Lisp_Object list; { - while (1) - { - if (CONSP (list)) - return XCONS (list)->car; - else if (EQ (list, Qnil)) - return Qnil; - else - list = wrong_type_argument (Qlistp, list); - } + return CAR (list); } DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0, - "Return the car of OBJECT if it is a cons cell, or else nil.") - (object) + doc: /* Return the car of OBJECT if it is a cons cell, or else nil. */) + (object) Lisp_Object object; { - if (CONSP (object)) - return XCONS (object)->car; - else - return Qnil; + return CAR_SAFE (object); } DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0, - "Return the cdr of CONSCELL. If arg is nil, return nil.\n\ -Error if arg is not nil and not a cons cell. See also `cdr-safe'.") + doc: /* Return the cdr of LIST. If arg is nil, return nil. +Error if arg is not nil and not a cons cell. See also `cdr-safe'. - (list) +See Info node `(elisp)Cons Cells' for a discussion of related basic +Lisp concepts such as cdr, car, cons cell and list. */) + (list) register Lisp_Object list; { - while (1) - { - if (CONSP (list)) - return XCONS (list)->cdr; - else if (EQ (list, Qnil)) - return Qnil; - else - list = wrong_type_argument (Qlistp, list); - } + return CDR (list); } DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0, - "Return the cdr of OBJECT if it is a cons cell, or else nil.") - (object) + doc: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */) + (object) Lisp_Object object; { - if (CONSP (object)) - return XCONS (object)->cdr; - else - return Qnil; + return CDR_SAFE (object); } DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0, - "Set the car of CONSCELL to be NEWCAR. Returns NEWCAR.") - (cell, newcar) + doc: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */) + (cell, newcar) register Lisp_Object cell, newcar; { - if (!CONSP (cell)) - cell = wrong_type_argument (Qconsp, cell); - + CHECK_CONS (cell); CHECK_IMPURE (cell); - XCONS (cell)->car = newcar; + XSETCAR (cell, newcar); return newcar; } DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0, - "Set the cdr of CONSCELL to be NEWCDR. Returns NEWCDR.") - (cell, newcdr) + doc: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */) + (cell, newcdr) register Lisp_Object cell, newcdr; { - if (!CONSP (cell)) - cell = wrong_type_argument (Qconsp, cell); - + CHECK_CONS (cell); CHECK_IMPURE (cell); - XCONS (cell)->cdr = newcdr; + XSETCDR (cell, newcdr); return newcdr; } /* Extract and set components of symbols */ -DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, "T if SYMBOL's value is not void.") - (sym) - register Lisp_Object sym; +DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, + doc: /* Return t if SYMBOL's value is not void. */) + (symbol) + register Lisp_Object symbol; { Lisp_Object valcontents; - CHECK_SYMBOL (sym, 0); + CHECK_SYMBOL (symbol); - valcontents = XSYMBOL (sym)->value; + valcontents = SYMBOL_VALUE (symbol); if (BUFFER_LOCAL_VALUEP (valcontents) || SOME_BUFFER_LOCAL_VALUEP (valcontents)) - valcontents = swap_in_symval_forwarding (sym, valcontents); + valcontents = swap_in_symval_forwarding (symbol, valcontents); return (EQ (valcontents, Qunbound) ? Qnil : Qt); } -DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, "T if SYMBOL's function definition is not void.") - (sym) - register Lisp_Object sym; +DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, + doc: /* Return t if SYMBOL's function definition is not void. */) + (symbol) + register Lisp_Object symbol; { - CHECK_SYMBOL (sym, 0); - return (EQ (XSYMBOL (sym)->function, Qunbound) ? Qnil : Qt); + CHECK_SYMBOL (symbol); + return (EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt); } -DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, "Make SYMBOL's value be void.") - (sym) - register Lisp_Object sym; +DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, + doc: /* Make SYMBOL's value be void. +Return SYMBOL. */) + (symbol) + register Lisp_Object symbol; { - CHECK_SYMBOL (sym, 0); - if (NILP (sym) || EQ (sym, Qt)) - return Fsignal (Qsetting_constant, Fcons (sym, Qnil)); - Fset (sym, Qunbound); - return sym; + CHECK_SYMBOL (symbol); + if (SYMBOL_CONSTANT_P (symbol)) + xsignal1 (Qsetting_constant, symbol); + Fset (symbol, Qunbound); + return symbol; } -DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, "Make SYMBOL's function definition be void.") - (sym) - register Lisp_Object sym; +DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, + doc: /* Make SYMBOL's function definition be void. +Return SYMBOL. */) + (symbol) + register Lisp_Object symbol; { - CHECK_SYMBOL (sym, 0); - if (NILP (sym) || EQ (sym, Qt)) - return Fsignal (Qsetting_constant, Fcons (sym, Qnil)); - XSYMBOL (sym)->function = Qunbound; - return sym; + CHECK_SYMBOL (symbol); + if (NILP (symbol) || EQ (symbol, Qt)) + xsignal1 (Qsetting_constant, symbol); + XSYMBOL (symbol)->function = Qunbound; + return symbol; } DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0, - "Return SYMBOL's function definition. Error if that is void.") - (symbol) + doc: /* Return SYMBOL's function definition. Error if that is void. */) + (symbol) register Lisp_Object symbol; { - CHECK_SYMBOL (symbol, 0); - if (EQ (XSYMBOL (symbol)->function, Qunbound)) - return Fsignal (Qvoid_function, Fcons (symbol, Qnil)); - return XSYMBOL (symbol)->function; + CHECK_SYMBOL (symbol); + if (!EQ (XSYMBOL (symbol)->function, Qunbound)) + return XSYMBOL (symbol)->function; + xsignal1 (Qvoid_function, symbol); } -DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, "Return SYMBOL's property list.") - (sym) - register Lisp_Object sym; +DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, + doc: /* Return SYMBOL's property list. */) + (symbol) + register Lisp_Object symbol; { - CHECK_SYMBOL (sym, 0); - return XSYMBOL (sym)->plist; + CHECK_SYMBOL (symbol); + return XSYMBOL (symbol)->plist; } -DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, "Return SYMBOL's name, a string.") - (sym) - register Lisp_Object sym; +DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, + doc: /* Return SYMBOL's name, a string. */) + (symbol) + register Lisp_Object symbol; { register Lisp_Object name; - CHECK_SYMBOL (sym, 0); - XSETSTRING (name, XSYMBOL (sym)->name); + CHECK_SYMBOL (symbol); + name = SYMBOL_NAME (symbol); return name; } DEFUN ("fset", Ffset, Sfset, 2, 2, 0, - "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.") - (sym, newdef) - register Lisp_Object sym, newdef; -{ - CHECK_SYMBOL (sym, 0); - if (NILP (sym) || EQ (sym, Qt)) - return Fsignal (Qsetting_constant, Fcons (sym, Qnil)); - if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (sym)->function, Qunbound)) - Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function), + doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */) + (symbol, definition) + register Lisp_Object symbol, definition; +{ + CHECK_SYMBOL (symbol); + if (NILP (symbol) || EQ (symbol, Qt)) + xsignal1 (Qsetting_constant, symbol); + if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (symbol)->function, Qunbound)) + Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function), Vautoload_queue); - XSYMBOL (sym)->function = newdef; + XSYMBOL (symbol)->function = definition; /* Handle automatic advice activation */ - if (CONSP (XSYMBOL (sym)->plist) && !NILP (Fget (sym, Qad_advice_info))) + if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info))) { - call2 (Qad_activate, sym, Qnil); - newdef = XSYMBOL (sym)->function; + call2 (Qad_activate_internal, symbol, Qnil); + definition = XSYMBOL (symbol)->function; } - return newdef; + return definition; } -/* This name should be removed once it is eliminated from elsewhere. */ +extern Lisp_Object Qfunction_documentation; -DEFUN ("defalias", Fdefalias, Sdefalias, 2, 2, 0, - "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\ -Associates the function with the current load file, if any.") - (sym, newdef) - register Lisp_Object sym, newdef; +DEFUN ("defalias", Fdefalias, Sdefalias, 2, 3, 0, + doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. +Associates the function with the current load file, if any. +The optional third argument DOCSTRING specifies the documentation string +for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string +determined by DEFINITION. */) + (symbol, definition, docstring) + register Lisp_Object symbol, definition, docstring; { - CHECK_SYMBOL (sym, 0); - if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (sym)->function, Qunbound)) - Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function), - Vautoload_queue); - XSYMBOL (sym)->function = newdef; - /* Handle automatic advice activation */ - if (CONSP (XSYMBOL (sym)->plist) && !NILP (Fget (sym, Qad_advice_info))) + CHECK_SYMBOL (symbol); + if (CONSP (XSYMBOL (symbol)->function) + && EQ (XCAR (XSYMBOL (symbol)->function), Qautoload)) + LOADHIST_ATTACH (Fcons (Qt, symbol)); + definition = Ffset (symbol, definition); + LOADHIST_ATTACH (Fcons (Qdefun, symbol)); + if (!NILP (docstring)) + Fput (symbol, Qfunction_documentation, docstring); + return definition; +} + +DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0, + doc: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */) + (symbol, newplist) + register Lisp_Object symbol, newplist; +{ + CHECK_SYMBOL (symbol); + XSYMBOL (symbol)->plist = newplist; + return newplist; +} + +DEFUN ("subr-arity", Fsubr_arity, Ssubr_arity, 1, 1, 0, + doc: /* Return minimum and maximum number of args allowed for SUBR. +SUBR must be a built-in function. +The returned value is a pair (MIN . MAX). MIN is the minimum number +of args. MAX is the maximum number or the symbol `many', for a +function with `&rest' args, or `unevalled' for a special form. */) + (subr) + Lisp_Object subr; +{ + short minargs, maxargs; + CHECK_SUBR (subr); + minargs = XSUBR (subr)->min_args; + maxargs = XSUBR (subr)->max_args; + if (maxargs == MANY) + return Fcons (make_number (minargs), Qmany); + else if (maxargs == UNEVALLED) + return Fcons (make_number (minargs), Qunevalled); + else + return Fcons (make_number (minargs), make_number (maxargs)); +} + +DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0, + doc: /* Return name of subroutine SUBR. +SUBR must be a built-in function. */) + (subr) + Lisp_Object subr; +{ + const char *name; + CHECK_SUBR (subr); + name = XSUBR (subr)->symbol_name; + return make_string (name, strlen (name)); +} + +DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0, + doc: /* Return the interactive form of CMD or nil if none. +If CMD is not a command, the return value is nil. +Value, if non-nil, is a list \(interactive SPEC). */) + (cmd) + Lisp_Object cmd; +{ + Lisp_Object fun = indirect_function (cmd); + + if (SUBRP (fun)) + { + if (XSUBR (fun)->prompt) + return list2 (Qinteractive, build_string (XSUBR (fun)->prompt)); + } + else if (COMPILEDP (fun)) { - call2 (Qad_activate, sym, Qnil); - newdef = XSYMBOL (sym)->function; + if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE) + return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE)); } - LOADHIST_ATTACH (sym); - return newdef; + else if (CONSP (fun)) + { + Lisp_Object funcar = XCAR (fun); + if (EQ (funcar, Qlambda)) + return Fassq (Qinteractive, Fcdr (XCDR (fun))); + else if (EQ (funcar, Qautoload)) + { + struct gcpro gcpro1; + GCPRO1 (cmd); + do_autoload (fun, cmd); + UNGCPRO; + return Finteractive_form (cmd); + } + } + return Qnil; } -DEFUN ("define-function", Fdefine_function, Sdefine_function, 2, 2, 0, - "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\ -Associates the function with the current load file, if any.") - (sym, newdef) - register Lisp_Object sym, newdef; + +/*********************************************************************** + Getting and Setting Values of Symbols + ***********************************************************************/ + +/* Return the symbol holding SYMBOL's value. Signal + `cyclic-variable-indirection' if SYMBOL's chain of variable + indirections contains a loop. */ + +Lisp_Object +indirect_variable (symbol) + Lisp_Object symbol; { - CHECK_SYMBOL (sym, 0); - if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (sym)->function, Qunbound)) - Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function), - Vautoload_queue); - XSYMBOL (sym)->function = newdef; - /* Handle automatic advice activation */ - if (CONSP (XSYMBOL (sym)->plist) && !NILP (Fget (sym, Qad_advice_info))) + Lisp_Object tortoise, hare; + + hare = tortoise = symbol; + + while (XSYMBOL (hare)->indirect_variable) { - call2 (Qad_activate, sym, Qnil); - newdef = XSYMBOL (sym)->function; + hare = XSYMBOL (hare)->value; + if (!XSYMBOL (hare)->indirect_variable) + break; + + hare = XSYMBOL (hare)->value; + tortoise = XSYMBOL (tortoise)->value; + + if (EQ (hare, tortoise)) + xsignal1 (Qcyclic_variable_indirection, symbol); } - LOADHIST_ATTACH (sym); - return newdef; + + return hare; } -DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0, - "Set SYMBOL's property list to NEWVAL, and return NEWVAL.") - (sym, newplist) - register Lisp_Object sym, newplist; + +DEFUN ("indirect-variable", Findirect_variable, Sindirect_variable, 1, 1, 0, + doc: /* Return the variable at the end of OBJECT's variable chain. +If OBJECT is a symbol, follow all variable indirections and return the final +variable. If OBJECT is not a symbol, just return it. +Signal a cyclic-variable-indirection error if there is a loop in the +variable chain of symbols. */) + (object) + Lisp_Object object; { - CHECK_SYMBOL (sym, 0); - XSYMBOL (sym)->plist = newplist; - return newplist; + if (SYMBOLP (object)) + object = indirect_variable (object); + return object; } - -/* Getting and setting values of symbols */ /* Given the raw contents of a symbol value cell, return the Lisp value of the symbol. @@ -621,7 +840,7 @@ do_symval_forwarding (valcontents) register Lisp_Object val; int offset; if (MISCP (valcontents)) - switch (XMISC (valcontents)->type) + switch (XMISCTYPE (valcontents)) { case Lisp_Misc_Intfwd: XSETINT (val, *XINTFWD (valcontents)->intvar); @@ -635,33 +854,40 @@ do_symval_forwarding (valcontents) case Lisp_Misc_Buffer_Objfwd: offset = XBUFFER_OBJFWD (valcontents)->offset; - return *(Lisp_Object *)(offset + (char *)current_buffer); + return PER_BUFFER_VALUE (current_buffer, offset); + + case Lisp_Misc_Kboard_Objfwd: + offset = XKBOARD_OBJFWD (valcontents)->offset; + return *(Lisp_Object *)(offset + (char *)current_kboard); } return valcontents; } -/* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell - of SYM. If SYM is buffer-local, VALCONTENTS should be the +/* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell + of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the buffer-independent contents of the value cell: forwarded just one - step past the buffer-localness. */ + step past the buffer-localness. + + BUF non-zero means set the value in buffer BUF instead of the + current buffer. This only plays a role for per-buffer variables. */ void -store_symval_forwarding (sym, valcontents, newval) - Lisp_Object sym; +store_symval_forwarding (symbol, valcontents, newval, buf) + Lisp_Object symbol; register Lisp_Object valcontents, newval; + struct buffer *buf; { -#ifdef SWITCH_ENUM_BUG - switch ((int) XTYPE (valcontents)) -#else - switch (XTYPE (valcontents)) -#endif + switch (SWITCH_ENUM_CAST (XTYPE (valcontents))) { case Lisp_Misc: - switch (XMISC (valcontents)->type) + switch (XMISCTYPE (valcontents)) { case Lisp_Misc_Intfwd: - CHECK_NUMBER (newval, 1); + CHECK_NUMBER (newval); *XINTFWD (valcontents)->intvar = XINT (newval); + if (*XINTFWD (valcontents)->intvar != XINT (newval)) + error ("Value out of range for variable `%s'", + SDATA (SYMBOL_NAME (symbol))); break; case Lisp_Misc_Boolfwd: @@ -670,6 +896,36 @@ store_symval_forwarding (sym, valcontents, newval) case Lisp_Misc_Objfwd: *XOBJFWD (valcontents)->objvar = newval; + + /* If this variable is a default for something stored + in the buffer itself, such as default-fill-column, + find the buffers that don't have local values for it + and update them. */ + if (XOBJFWD (valcontents)->objvar > (Lisp_Object *) &buffer_defaults + && XOBJFWD (valcontents)->objvar < (Lisp_Object *) (&buffer_defaults + 1)) + { + int offset = ((char *) XOBJFWD (valcontents)->objvar + - (char *) &buffer_defaults); + int idx = PER_BUFFER_IDX (offset); + + Lisp_Object tail; + + if (idx <= 0) + break; + + for (tail = Vbuffer_alist; CONSP (tail); tail = XCDR (tail)) + { + Lisp_Object buf; + struct buffer *b; + + buf = Fcdr (XCAR (tail)); + if (!BUFFERP (buf)) continue; + b = XBUFFER (buf); + + if (! PER_BUFFER_VALUE_P (b, idx)) + PER_BUFFER_VALUE (b, offset) = newval; + } + } break; case Lisp_Misc_Buffer_Objfwd: @@ -677,14 +933,25 @@ store_symval_forwarding (sym, valcontents, newval) int offset = XBUFFER_OBJFWD (valcontents)->offset; Lisp_Object type; - type = *(Lisp_Object *)(offset + (char *)&buffer_local_types); + type = PER_BUFFER_TYPE (offset); if (! NILP (type) && ! NILP (newval) && XTYPE (newval) != XINT (type)) buffer_slot_type_mismatch (offset); - *(Lisp_Object *)(offset + (char *)current_buffer) = newval; - break; + if (buf == NULL) + buf = current_buffer; + PER_BUFFER_VALUE (buf, offset) = newval; + } + break; + + case Lisp_Misc_Kboard_Objfwd: + { + char *base = (char *) current_kboard; + char *p = base + XKBOARD_OBJFWD (valcontents)->offset; + *(Lisp_Object *) p = newval; } + break; + default: goto def; } @@ -692,82 +959,122 @@ store_symval_forwarding (sym, valcontents, newval) default: def: - valcontents = XSYMBOL (sym)->value; + valcontents = SYMBOL_VALUE (symbol); if (BUFFER_LOCAL_VALUEP (valcontents) || SOME_BUFFER_LOCAL_VALUEP (valcontents)) - XBUFFER_LOCAL_VALUE (valcontents)->car = newval; + XBUFFER_LOCAL_VALUE (valcontents)->realvalue = newval; else - XSYMBOL (sym)->value = newval; + SET_SYMBOL_VALUE (symbol, newval); } } -/* Set up the buffer-local symbol SYM for validity in the current - buffer. VALCONTENTS is the contents of its value cell. - Return the value forwarded one step past the buffer-local indicator. */ +/* Set up SYMBOL to refer to its global binding. + This makes it safe to alter the status of other bindings. */ -static Lisp_Object -swap_in_symval_forwarding (sym, valcontents) - Lisp_Object sym, valcontents; -{ - /* valcontents is a list - (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)). - - CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's - local_var_alist, that being the element whose car is this - variable. Or it can be a pointer to the - (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have - an element in its alist for this variable. - - If the current buffer is not BUFFER, we store the current - REALVALUE value into CURRENT-ALIST-ELEMENT, then find the - appropriate alist element for the buffer now current and set up - CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that - element, and store into BUFFER. - - Note that REALVALUE can be a forwarding pointer. */ +void +swap_in_global_binding (symbol) + Lisp_Object symbol; +{ + Lisp_Object valcontents, cdr; + + valcontents = SYMBOL_VALUE (symbol); + if (!BUFFER_LOCAL_VALUEP (valcontents) + && !SOME_BUFFER_LOCAL_VALUEP (valcontents)) + abort (); + cdr = XBUFFER_LOCAL_VALUE (valcontents)->cdr; + + /* Unload the previously loaded binding. */ + Fsetcdr (XCAR (cdr), + do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue)); + /* Select the global binding in the symbol. */ + XSETCAR (cdr, cdr); + store_symval_forwarding (symbol, valcontents, XCDR (cdr), NULL); + + /* Indicate that the global binding is set up now. */ + XBUFFER_LOCAL_VALUE (valcontents)->frame = Qnil; + XBUFFER_LOCAL_VALUE (valcontents)->buffer = Qnil; + XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0; + XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0; +} + +/* Set up the buffer-local symbol SYMBOL for validity in the current buffer. + VALCONTENTS is the contents of its value cell, + which points to a struct Lisp_Buffer_Local_Value. + + Return the value forwarded one step past the buffer-local stage. + This could be another forwarding pointer. */ + +static Lisp_Object +swap_in_symval_forwarding (symbol, valcontents) + Lisp_Object symbol, valcontents; +{ register Lisp_Object tem1; - tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car; - if (NILP (tem1) || current_buffer != XBUFFER (tem1)) + tem1 = XBUFFER_LOCAL_VALUE (valcontents)->buffer; + + if (NILP (tem1) + || current_buffer != XBUFFER (tem1) + || (XBUFFER_LOCAL_VALUE (valcontents)->check_frame + && ! EQ (selected_frame, XBUFFER_LOCAL_VALUE (valcontents)->frame))) { - tem1 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car; + if (XSYMBOL (symbol)->indirect_variable) + symbol = indirect_variable (symbol); + + /* Unload the previously loaded binding. */ + tem1 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr); Fsetcdr (tem1, - do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car)); - tem1 = assq_no_quit (sym, current_buffer->local_var_alist); + do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue)); + /* Choose the new binding. */ + tem1 = assq_no_quit (symbol, current_buffer->local_var_alist); + XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0; + XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0; if (NILP (tem1)) - tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr; - XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car = tem1; - XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car, - current_buffer); - store_symval_forwarding (sym, XBUFFER_LOCAL_VALUE (valcontents)->car, - Fcdr (tem1)); + { + if (XBUFFER_LOCAL_VALUE (valcontents)->check_frame) + tem1 = assq_no_quit (symbol, XFRAME (selected_frame)->param_alist); + if (! NILP (tem1)) + XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 1; + else + tem1 = XBUFFER_LOCAL_VALUE (valcontents)->cdr; + } + else + XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 1; + + /* Load the new binding. */ + XSETCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr, tem1); + XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, current_buffer); + XBUFFER_LOCAL_VALUE (valcontents)->frame = selected_frame; + store_symval_forwarding (symbol, + XBUFFER_LOCAL_VALUE (valcontents)->realvalue, + Fcdr (tem1), NULL); } - return XBUFFER_LOCAL_VALUE (valcontents)->car; + return XBUFFER_LOCAL_VALUE (valcontents)->realvalue; } /* Find the value of a symbol, returning Qunbound if it's not bound. This is helpful for code which just wants to get a variable's value - if it has one, without signalling an error. + if it has one, without signaling an error. Note that it must not be possible to quit within this function. Great care is required for this. */ Lisp_Object -find_symbol_value (sym) - Lisp_Object sym; +find_symbol_value (symbol) + Lisp_Object symbol; { - register Lisp_Object valcontents, tem1; + register Lisp_Object valcontents; register Lisp_Object val; - CHECK_SYMBOL (sym, 0); - valcontents = XSYMBOL (sym)->value; + + CHECK_SYMBOL (symbol); + valcontents = SYMBOL_VALUE (symbol); if (BUFFER_LOCAL_VALUEP (valcontents) || SOME_BUFFER_LOCAL_VALUEP (valcontents)) - valcontents = swap_in_symval_forwarding (sym, valcontents); + valcontents = swap_in_symval_forwarding (symbol, valcontents); if (MISCP (valcontents)) { - switch (XMISC (valcontents)->type) + switch (XMISCTYPE (valcontents)) { case Lisp_Misc_Intfwd: XSETINT (val, *XINTFWD (valcontents)->intvar); @@ -780,8 +1087,12 @@ find_symbol_value (sym) return *XOBJFWD (valcontents)->objvar; case Lisp_Misc_Buffer_Objfwd: - return *(Lisp_Object *)(XBUFFER_OBJFWD (valcontents)->offset - + (char *)current_buffer); + return PER_BUFFER_VALUE (current_buffer, + XBUFFER_OBJFWD (valcontents)->offset); + + case Lisp_Misc_Kboard_Objfwd: + return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset + + (char *)current_kboard); } } @@ -789,158 +1100,227 @@ find_symbol_value (sym) } DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0, - "Return SYMBOL's value. Error if that is void.") - (sym) - Lisp_Object sym; + doc: /* Return SYMBOL's value. Error if that is void. */) + (symbol) + Lisp_Object symbol; { Lisp_Object val; - val = find_symbol_value (sym); - if (EQ (val, Qunbound)) - return Fsignal (Qvoid_variable, Fcons (sym, Qnil)); - else + val = find_symbol_value (symbol); + if (!EQ (val, Qunbound)) return val; + + xsignal1 (Qvoid_variable, symbol); } DEFUN ("set", Fset, Sset, 2, 2, 0, - "Set SYMBOL's value to NEWVAL, and return NEWVAL.") - (sym, newval) - register Lisp_Object sym, newval; + doc: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */) + (symbol, newval) + register Lisp_Object symbol, newval; +{ + return set_internal (symbol, newval, current_buffer, 0); +} + +/* Return 1 if SYMBOL currently has a let-binding + which was made in the buffer that is now current. */ + +static int +let_shadows_buffer_binding_p (symbol) + Lisp_Object symbol; +{ + volatile struct specbinding *p; + + for (p = specpdl_ptr - 1; p >= specpdl; p--) + if (p->func == NULL + && CONSP (p->symbol)) + { + Lisp_Object let_bound_symbol = XCAR (p->symbol); + if ((EQ (symbol, let_bound_symbol) + || (XSYMBOL (let_bound_symbol)->indirect_variable + && EQ (symbol, indirect_variable (let_bound_symbol)))) + && XBUFFER (XCDR (XCDR (p->symbol))) == current_buffer) + break; + } + + return p >= specpdl; +} + +/* Store the value NEWVAL into SYMBOL. + If buffer-locality is an issue, BUF specifies which buffer to use. + (0 stands for the current buffer.) + + If BINDFLAG is zero, then if this symbol is supposed to become + local in every buffer where it is set, then we make it local. + If BINDFLAG is nonzero, we don't do that. */ + +Lisp_Object +set_internal (symbol, newval, buf, bindflag) + register Lisp_Object symbol, newval; + struct buffer *buf; + int bindflag; { int voide = EQ (newval, Qunbound); - register Lisp_Object valcontents, tem1, current_alist_element; + register Lisp_Object valcontents, innercontents, tem1, current_alist_element; + + if (buf == 0) + buf = current_buffer; + + /* If restoring in a dead buffer, do nothing. */ + if (NILP (buf->name)) + return newval; - CHECK_SYMBOL (sym, 0); - if (NILP (sym) || EQ (sym, Qt)) - return Fsignal (Qsetting_constant, Fcons (sym, Qnil)); - valcontents = XSYMBOL (sym)->value; + CHECK_SYMBOL (symbol); + if (SYMBOL_CONSTANT_P (symbol) + && (NILP (Fkeywordp (symbol)) + || !EQ (newval, SYMBOL_VALUE (symbol)))) + xsignal1 (Qsetting_constant, symbol); + + innercontents = valcontents = SYMBOL_VALUE (symbol); if (BUFFER_OBJFWDP (valcontents)) { - register int idx = XBUFFER_OBJFWD (valcontents)->offset; - register int mask = XINT (*((Lisp_Object *) - (idx + (char *)&buffer_local_flags))); - if (mask > 0) - current_buffer->local_var_flags |= mask; + int offset = XBUFFER_OBJFWD (valcontents)->offset; + int idx = PER_BUFFER_IDX (offset); + if (idx > 0 + && !bindflag + && !let_shadows_buffer_binding_p (symbol)) + SET_PER_BUFFER_VALUE_P (buf, idx, 1); } - else if (BUFFER_LOCAL_VALUEP (valcontents) || SOME_BUFFER_LOCAL_VALUEP (valcontents)) { - /* valcontents is actually a pointer to a struct resembling a cons, - with contents something like: - (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE). - - BUFFER is the last buffer for which this symbol's value was - made up to date. - - CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's - local_var_alist, that being the element whose car is this - variable. Or it can be a pointer to the - (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not - have an element in its alist for this variable (that is, if - BUFFER sees the default value of this variable). - - If we want to examine or set the value and BUFFER is current, - we just examine or set REALVALUE. If BUFFER is not current, we - store the current REALVALUE value into CURRENT-ALIST-ELEMENT, - then find the appropriate alist element for the buffer now - current and set up CURRENT-ALIST-ELEMENT. Then we set - REALVALUE out of that element, and store into BUFFER. - - If we are setting the variable and the current buffer does - not have an alist entry for this variable, an alist entry is - created. - - Note that REALVALUE can be a forwarding pointer. Each time - it is examined or set, forwarding must be done. */ - - /* What value are we caching right now? */ - current_alist_element = - XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car; + /* valcontents is a struct Lisp_Buffer_Local_Value. */ + if (XSYMBOL (symbol)->indirect_variable) + symbol = indirect_variable (symbol); + + /* What binding is loaded right now? */ + current_alist_element + = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr); /* If the current buffer is not the buffer whose binding is - currently cached, or if it's a Lisp_Buffer_Local_Value and - we're looking at the default value, the cache is invalid; we - need to write it out, and find the new CURRENT-ALIST-ELEMENT. */ - if ((current_buffer - != XBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car)) + loaded, or if there may be frame-local bindings and the frame + isn't the right one, or if it's a Lisp_Buffer_Local_Value and + the default binding is loaded, the loaded binding may be the + wrong one. */ + if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents)->buffer) + || buf != XBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer) + || (XBUFFER_LOCAL_VALUE (valcontents)->check_frame + && !EQ (selected_frame, XBUFFER_LOCAL_VALUE (valcontents)->frame)) || (BUFFER_LOCAL_VALUEP (valcontents) - && EQ (XCONS (current_alist_element)->car, + && EQ (XCAR (current_alist_element), current_alist_element))) { - /* Write out the cached value for the old buffer; copy it - back to its alist element. This works if the current - buffer only sees the default value, too. */ + /* The currently loaded binding is not necessarily valid. + We need to unload it, and choose a new binding. */ + + /* Write out `realvalue' to the old loaded binding. */ Fsetcdr (current_alist_element, - do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car)); + do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue)); + + /* Find the new binding. */ + tem1 = Fassq (symbol, buf->local_var_alist); + XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 1; + XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0; - /* Find the new value for CURRENT-ALIST-ELEMENT. */ - tem1 = Fassq (sym, current_buffer->local_var_alist); if (NILP (tem1)) { /* This buffer still sees the default value. */ /* If the variable is a Lisp_Some_Buffer_Local_Value, + or if this is `let' rather than `set', make CURRENT-ALIST-ELEMENT point to itself, - indicating that we're seeing the default value. */ - if (SOME_BUFFER_LOCAL_VALUEP (valcontents)) - tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr; + indicating that we're seeing the default value. + Likewise if the variable has been let-bound + in the current buffer. */ + if (bindflag || SOME_BUFFER_LOCAL_VALUEP (valcontents) + || let_shadows_buffer_binding_p (symbol)) + { + XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0; + + if (XBUFFER_LOCAL_VALUE (valcontents)->check_frame) + tem1 = Fassq (symbol, + XFRAME (selected_frame)->param_alist); - /* If it's a Lisp_Buffer_Local_Value, give this buffer a - new assoc for a local value and set - CURRENT-ALIST-ELEMENT to point to that. */ + if (! NILP (tem1)) + XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 1; + else + tem1 = XBUFFER_LOCAL_VALUE (valcontents)->cdr; + } + /* If it's a Lisp_Buffer_Local_Value, being set not bound, + and we're not within a let that was made for this buffer, + create a new buffer-local binding for the variable. + That means, give this buffer a new assoc for a local value + and load that binding. */ else { - tem1 = Fcons (sym, Fcdr (current_alist_element)); - current_buffer->local_var_alist = - Fcons (tem1, current_buffer->local_var_alist); + tem1 = Fcons (symbol, XCDR (current_alist_element)); + buf->local_var_alist + = Fcons (tem1, buf->local_var_alist); } } - /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */ - XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car - = tem1; - /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */ - XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car, - current_buffer); + /* Record which binding is now loaded. */ + XSETCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr, + tem1); + + /* Set `buffer' and `frame' slots for thebinding now loaded. */ + XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, buf); + XBUFFER_LOCAL_VALUE (valcontents)->frame = selected_frame; } - valcontents = XBUFFER_LOCAL_VALUE (valcontents)->car; + innercontents = XBUFFER_LOCAL_VALUE (valcontents)->realvalue; } /* If storing void (making the symbol void), forward only through buffer-local indicator, not through Lisp_Objfwd, etc. */ if (voide) - store_symval_forwarding (sym, Qnil, newval); + store_symval_forwarding (symbol, Qnil, newval, buf); else - store_symval_forwarding (sym, valcontents, newval); + store_symval_forwarding (symbol, innercontents, newval, buf); + + /* If we just set a variable whose current binding is frame-local, + store the new value in the frame parameter too. */ + + if (BUFFER_LOCAL_VALUEP (valcontents) + || SOME_BUFFER_LOCAL_VALUEP (valcontents)) + { + /* What binding is loaded right now? */ + current_alist_element + = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr); + + /* If the current buffer is not the buffer whose binding is + loaded, or if there may be frame-local bindings and the frame + isn't the right one, or if it's a Lisp_Buffer_Local_Value and + the default binding is loaded, the loaded binding may be the + wrong one. */ + if (XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame) + XSETCDR (current_alist_element, newval); + } return newval; } /* Access or set a buffer-local symbol's default value. */ -/* Return the default value of SYM, but don't check for voidness. +/* Return the default value of SYMBOL, but don't check for voidness. Return Qunbound if it is void. */ Lisp_Object -default_value (sym) - Lisp_Object sym; +default_value (symbol) + Lisp_Object symbol; { register Lisp_Object valcontents; - CHECK_SYMBOL (sym, 0); - valcontents = XSYMBOL (sym)->value; + CHECK_SYMBOL (symbol); + valcontents = SYMBOL_VALUE (symbol); /* For a built-in buffer-local variable, get the default value rather than letting do_symval_forwarding get the current value. */ if (BUFFER_OBJFWDP (valcontents)) { - register int idx = XBUFFER_OBJFWD (valcontents)->offset; - - if (XINT (*(Lisp_Object *) (idx + (char *) &buffer_local_flags)) != 0) - return *(Lisp_Object *)(idx + (char *) &buffer_defaults); + int offset = XBUFFER_OBJFWD (valcontents)->offset; + if (PER_BUFFER_IDX (offset) != 0) + return PER_BUFFER_DEFAULT (offset); } /* Handle user-created local variables. */ @@ -949,117 +1329,123 @@ default_value (sym) { /* If var is set up for a buffer that lacks a local value for it, the current value is nominally the default value. - But the current value slot may be more up to date, since + But the `realvalue' slot may be more up to date, since ordinary setq stores just that slot. So use that. */ Lisp_Object current_alist_element, alist_element_car; current_alist_element - = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car; - alist_element_car = XCONS (current_alist_element)->car; + = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr); + alist_element_car = XCAR (current_alist_element); if (EQ (alist_element_car, current_alist_element)) - return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car); + return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue); else - return XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->cdr; + return XCDR (XBUFFER_LOCAL_VALUE (valcontents)->cdr); } /* For other variables, get the current value. */ return do_symval_forwarding (valcontents); } DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0, - "Return T if SYMBOL has a non-void default value.\n\ -This is the value that is seen in buffers that do not have their own values\n\ -for this variable.") - (sym) - Lisp_Object sym; + doc: /* Return t if SYMBOL has a non-void default value. +This is the value that is seen in buffers that do not have their own values +for this variable. */) + (symbol) + Lisp_Object symbol; { register Lisp_Object value; - value = default_value (sym); + value = default_value (symbol); return (EQ (value, Qunbound) ? Qnil : Qt); } DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0, - "Return SYMBOL's default value.\n\ -This is the value that is seen in buffers that do not have their own values\n\ -for this variable. The default value is meaningful for variables with\n\ -local bindings in certain buffers.") - (sym) - Lisp_Object sym; + doc: /* Return SYMBOL's default value. +This is the value that is seen in buffers that do not have their own values +for this variable. The default value is meaningful for variables with +local bindings in certain buffers. */) + (symbol) + Lisp_Object symbol; { register Lisp_Object value; - value = default_value (sym); - if (EQ (value, Qunbound)) - return Fsignal (Qvoid_variable, Fcons (sym, Qnil)); - return value; + value = default_value (symbol); + if (!EQ (value, Qunbound)) + return value; + + xsignal1 (Qvoid_variable, symbol); } DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0, - "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\ -The default value is seen in buffers that do not have their own values\n\ -for this variable.") - (sym, value) - Lisp_Object sym, value; + doc: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated. +The default value is seen in buffers that do not have their own values +for this variable. */) + (symbol, value) + Lisp_Object symbol, value; { register Lisp_Object valcontents, current_alist_element, alist_element_buffer; - CHECK_SYMBOL (sym, 0); - valcontents = XSYMBOL (sym)->value; + CHECK_SYMBOL (symbol); + valcontents = SYMBOL_VALUE (symbol); /* Handle variables like case-fold-search that have special slots in the buffer. Make them work apparently like Lisp_Buffer_Local_Value variables. */ if (BUFFER_OBJFWDP (valcontents)) { - register int idx = XBUFFER_OBJFWD (valcontents)->offset; - register struct buffer *b; - register int mask = XINT (*((Lisp_Object *) - (idx + (char *)&buffer_local_flags))); + int offset = XBUFFER_OBJFWD (valcontents)->offset; + int idx = PER_BUFFER_IDX (offset); - if (mask > 0) + PER_BUFFER_DEFAULT (offset) = value; + + /* If this variable is not always local in all buffers, + set it in the buffers that don't nominally have a local value. */ + if (idx > 0) { - *(Lisp_Object *)(idx + (char *) &buffer_defaults) = value; + struct buffer *b; + for (b = all_buffers; b; b = b->next) - if (!(b->local_var_flags & mask)) - *(Lisp_Object *)(idx + (char *) b) = value; + if (!PER_BUFFER_VALUE_P (b, idx)) + PER_BUFFER_VALUE (b, offset) = value; } return value; } if (!BUFFER_LOCAL_VALUEP (valcontents) && !SOME_BUFFER_LOCAL_VALUEP (valcontents)) - return Fset (sym, value); + return Fset (symbol, value); - /* Store new value into the DEFAULT-VALUE slot */ - XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->cdr = value; + /* Store new value into the DEFAULT-VALUE slot. */ + XSETCDR (XBUFFER_LOCAL_VALUE (valcontents)->cdr, value); - /* If that slot is current, we must set the REALVALUE slot too */ + /* If the default binding is now loaded, set the REALVALUE slot too. */ current_alist_element - = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car; + = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr); alist_element_buffer = Fcar (current_alist_element); if (EQ (alist_element_buffer, current_alist_element)) - store_symval_forwarding (sym, XBUFFER_LOCAL_VALUE (valcontents)->car, - value); + store_symval_forwarding (symbol, + XBUFFER_LOCAL_VALUE (valcontents)->realvalue, + value, NULL); return value; } -DEFUN ("setq-default", Fsetq_default, Ssetq_default, 2, UNEVALLED, 0, - "Set the default value of variable VAR to VALUE.\n\ -VAR, the variable name, is literal (not evaluated);\n\ -VALUE is an expression and it is evaluated.\n\ -The default value of a variable is seen in buffers\n\ -that do not have their own values for the variable.\n\ -\n\ -More generally, you can use multiple variables and values, as in\n\ - (setq-default SYM VALUE SYM VALUE...)\n\ -This sets each SYM's default value to the corresponding VALUE.\n\ -The VALUE for the Nth SYM can refer to the new default values\n\ -of previous SYMs.") - (args) +DEFUN ("setq-default", Fsetq_default, Ssetq_default, 0, UNEVALLED, 0, + doc: /* Set the default value of variable VAR to VALUE. +VAR, the variable name, is literal (not evaluated); +VALUE is an expression: it is evaluated and its value returned. +The default value of a variable is seen in buffers +that do not have their own values for the variable. + +More generally, you can use multiple variables and values, as in + (setq-default VAR VALUE VAR VALUE...) +This sets each VAR's default value to the corresponding VALUE. +The VALUE for the Nth VAR can refer to the new default values +of previous VARs. +usage: (setq-default [VAR VALUE...]) */) + (args) Lisp_Object args; { register Lisp_Object args_left; - register Lisp_Object val, sym; + register Lisp_Object val, symbol; struct gcpro gcpro1; if (NILP (args)) @@ -1071,9 +1457,9 @@ of previous SYMs.") do { val = Feval (Fcar (Fcdr (args_left))); - sym = Fcar (args_left); - Fset_default (sym, val); - args_left = Fcdr (Fcdr (args_left)); + symbol = XCAR (args_left); + Fset_default (symbol, val); + args_left = Fcdr (XCDR (args_left)); } while (!NILP (args_left)); @@ -1084,186 +1470,388 @@ of previous SYMs.") /* Lisp functions for creating and removing buffer-local variables. */ DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local, - 1, 1, "vMake Variable Buffer Local: ", - "Make VARIABLE have a separate value for each buffer.\n\ -At any time, the value for the current buffer is in effect.\n\ -There is also a default value which is seen in any buffer which has not yet\n\ -set its own value.\n\ -Using `set' or `setq' to set the variable causes it to have a separate value\n\ -for the current buffer if it was previously using the default value.\n\ -The function `default-value' gets the default value and `set-default' sets it.") - (sym) - register Lisp_Object sym; + 1, 1, "vMake Variable Buffer Local: ", + doc: /* Make VARIABLE become buffer-local whenever it is set. +At any time, the value for the current buffer is in effect, +unless the variable has never been set in this buffer, +in which case the default value is in effect. +Note that binding the variable with `let', or setting it while +a `let'-style binding made in this buffer is in effect, +does not make the variable buffer-local. Return VARIABLE. + +In most cases it is better to use `make-local-variable', +which makes a variable local in just one buffer. + +The function `default-value' gets the default value and `set-default' sets it. */) + (variable) + register Lisp_Object variable; { register Lisp_Object tem, valcontents, newval; - CHECK_SYMBOL (sym, 0); + CHECK_SYMBOL (variable); + variable = indirect_variable (variable); - if (EQ (sym, Qnil) || EQ (sym, Qt)) - error ("Symbol %s may not be buffer-local", XSYMBOL (sym)->name->data); + valcontents = SYMBOL_VALUE (variable); + if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents)) + error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable))); - valcontents = XSYMBOL (sym)->value; if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents)) - return sym; + return variable; if (SOME_BUFFER_LOCAL_VALUEP (valcontents)) { - XMISC (XSYMBOL (sym)->value)->type = Lisp_Misc_Buffer_Local_Value; - return sym; + XMISCTYPE (SYMBOL_VALUE (variable)) = Lisp_Misc_Buffer_Local_Value; + return variable; } if (EQ (valcontents, Qunbound)) - XSYMBOL (sym)->value = Qnil; - tem = Fcons (Qnil, Fsymbol_value (sym)); - XCONS (tem)->car = tem; + SET_SYMBOL_VALUE (variable, Qnil); + tem = Fcons (Qnil, Fsymbol_value (variable)); + XSETCAR (tem, tem); newval = allocate_misc (); - XMISC (newval)->type = Lisp_Misc_Buffer_Local_Value; - XBUFFER_LOCAL_VALUE (newval)->car = XSYMBOL (sym)->value; - XBUFFER_LOCAL_VALUE (newval)->cdr = Fcons (Fcurrent_buffer (), tem); - XSYMBOL (sym)->value = newval; - return sym; + XMISCTYPE (newval) = Lisp_Misc_Buffer_Local_Value; + XBUFFER_LOCAL_VALUE (newval)->realvalue = SYMBOL_VALUE (variable); + XBUFFER_LOCAL_VALUE (newval)->buffer = Fcurrent_buffer (); + XBUFFER_LOCAL_VALUE (newval)->frame = Qnil; + XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0; + XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0; + XBUFFER_LOCAL_VALUE (newval)->check_frame = 0; + XBUFFER_LOCAL_VALUE (newval)->cdr = tem; + SET_SYMBOL_VALUE (variable, newval); + return variable; } DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable, - 1, 1, "vMake Local Variable: ", - "Make VARIABLE have a separate value in the current buffer.\n\ -Other buffers will continue to share a common default value.\n\ -\(The buffer-local value of VARIABLE starts out as the same value\n\ -VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\ -See also `make-variable-buffer-local'.\n\n\ -If the variable is already arranged to become local when set,\n\ -this function causes a local value to exist for this buffer,\n\ -just as setting the variable would do.\n\ -\n\ -Do not use `make-local-variable' to make a hook variable buffer-local.\n\ -Use `make-local-hook' instead.") - (sym) - register Lisp_Object sym; + 1, 1, "vMake Local Variable: ", + doc: /* Make VARIABLE have a separate value in the current buffer. +Other buffers will continue to share a common default value. +\(The buffer-local value of VARIABLE starts out as the same value +VARIABLE previously had. If VARIABLE was void, it remains void.\) +Return VARIABLE. + +If the variable is already arranged to become local when set, +this function causes a local value to exist for this buffer, +just as setting the variable would do. + +This function returns VARIABLE, and therefore + (set (make-local-variable 'VARIABLE) VALUE-EXP) +works. + +See also `make-variable-buffer-local'. + +Do not use `make-local-variable' to make a hook variable buffer-local. +Instead, use `add-hook' and specify t for the LOCAL argument. */) + (variable) + register Lisp_Object variable; { register Lisp_Object tem, valcontents; - CHECK_SYMBOL (sym, 0); + CHECK_SYMBOL (variable); + variable = indirect_variable (variable); - if (EQ (sym, Qnil) || EQ (sym, Qt)) - error ("Symbol %s may not be buffer-local", XSYMBOL (sym)->name->data); + valcontents = SYMBOL_VALUE (variable); + if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents)) + error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable))); - valcontents = XSYMBOL (sym)->value; if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents)) { - tem = Fboundp (sym); - + tem = Fboundp (variable); + /* Make sure the symbol has a local value in this particular buffer, by setting it to the same value it already has. */ - Fset (sym, (EQ (tem, Qt) ? Fsymbol_value (sym) : Qunbound)); - return sym; + Fset (variable, (EQ (tem, Qt) ? Fsymbol_value (variable) : Qunbound)); + return variable; } - /* Make sure sym is set up to hold per-buffer values */ + /* Make sure symbol is set up to hold per-buffer values. */ if (!SOME_BUFFER_LOCAL_VALUEP (valcontents)) { Lisp_Object newval; tem = Fcons (Qnil, do_symval_forwarding (valcontents)); - XCONS (tem)->car = tem; + XSETCAR (tem, tem); newval = allocate_misc (); - XMISC (newval)->type = Lisp_Misc_Some_Buffer_Local_Value; - XBUFFER_LOCAL_VALUE (newval)->car = XSYMBOL (sym)->value; - XBUFFER_LOCAL_VALUE (newval)->cdr = Fcons (Qnil, tem); - XSYMBOL (sym)->value = newval; + XMISCTYPE (newval) = Lisp_Misc_Some_Buffer_Local_Value; + XBUFFER_LOCAL_VALUE (newval)->realvalue = SYMBOL_VALUE (variable); + XBUFFER_LOCAL_VALUE (newval)->buffer = Qnil; + XBUFFER_LOCAL_VALUE (newval)->frame = Qnil; + XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0; + XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0; + XBUFFER_LOCAL_VALUE (newval)->check_frame = 0; + XBUFFER_LOCAL_VALUE (newval)->cdr = tem; + SET_SYMBOL_VALUE (variable, newval);; } - /* Make sure this buffer has its own value of sym */ - tem = Fassq (sym, current_buffer->local_var_alist); + /* Make sure this buffer has its own value of symbol. */ + tem = Fassq (variable, current_buffer->local_var_alist); if (NILP (tem)) { + /* Swap out any local binding for some other buffer, and make + sure the current value is permanently recorded, if it's the + default value. */ + find_symbol_value (variable); + current_buffer->local_var_alist - = Fcons (Fcons (sym, XCONS (XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (sym)->value)->cdr)->cdr)->cdr), + = Fcons (Fcons (variable, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable))->cdr)), current_buffer->local_var_alist); /* Make sure symbol does not think it is set up for this buffer; - force it to look once again for this buffer's value */ + force it to look once again for this buffer's value. */ { Lisp_Object *pvalbuf; - valcontents = XSYMBOL (sym)->value; - pvalbuf = &XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car; + + valcontents = SYMBOL_VALUE (variable); + + pvalbuf = &XBUFFER_LOCAL_VALUE (valcontents)->buffer; if (current_buffer == XBUFFER (*pvalbuf)) *pvalbuf = Qnil; + XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0; } } - /* If the symbol forwards into a C variable, then swap in the - variable for this buffer immediately. If C code modifies the - variable before we swap in, then that new value will clobber the - default value the next time we swap. */ - valcontents = XBUFFER_LOCAL_VALUE (XSYMBOL (sym)->value)->car; + /* If the symbol forwards into a C variable, then load the binding + for this buffer now. If C code modifies the variable before we + load the binding in, then that new value will clobber the default + binding the next time we unload it. */ + valcontents = XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable))->realvalue; if (INTFWDP (valcontents) || BOOLFWDP (valcontents) || OBJFWDP (valcontents)) - swap_in_symval_forwarding (sym, XSYMBOL (sym)->value); + swap_in_symval_forwarding (variable, SYMBOL_VALUE (variable)); - return sym; + return variable; } DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable, - 1, 1, "vKill Local Variable: ", - "Make VARIABLE no longer have a separate value in the current buffer.\n\ -From now on the default value will apply in this buffer.") - (sym) - register Lisp_Object sym; + 1, 1, "vKill Local Variable: ", + doc: /* Make VARIABLE no longer have a separate value in the current buffer. +From now on the default value will apply in this buffer. Return VARIABLE. */) + (variable) + register Lisp_Object variable; { register Lisp_Object tem, valcontents; - CHECK_SYMBOL (sym, 0); + CHECK_SYMBOL (variable); + variable = indirect_variable (variable); - valcontents = XSYMBOL (sym)->value; + valcontents = SYMBOL_VALUE (variable); if (BUFFER_OBJFWDP (valcontents)) { - register int idx = XBUFFER_OBJFWD (valcontents)->offset; - register int mask = XINT (*((Lisp_Object*) - (idx + (char *)&buffer_local_flags))); + int offset = XBUFFER_OBJFWD (valcontents)->offset; + int idx = PER_BUFFER_IDX (offset); - if (mask > 0) + if (idx > 0) { - *(Lisp_Object *)(idx + (char *) current_buffer) - = *(Lisp_Object *)(idx + (char *) &buffer_defaults); - current_buffer->local_var_flags &= ~mask; + SET_PER_BUFFER_VALUE_P (current_buffer, idx, 0); + PER_BUFFER_VALUE (current_buffer, offset) + = PER_BUFFER_DEFAULT (offset); } - return sym; + return variable; } if (!BUFFER_LOCAL_VALUEP (valcontents) && !SOME_BUFFER_LOCAL_VALUEP (valcontents)) - return sym; + return variable; - /* Get rid of this buffer's alist element, if any */ + /* Get rid of this buffer's alist element, if any. */ - tem = Fassq (sym, current_buffer->local_var_alist); + tem = Fassq (variable, current_buffer->local_var_alist); if (!NILP (tem)) current_buffer->local_var_alist = Fdelq (tem, current_buffer->local_var_alist); - /* Make sure symbol does not think it is set up for this buffer; - force it to look once again for this buffer's value */ + /* If the symbol is set up with the current buffer's binding + loaded, recompute its value. We have to do it now, or else + forwarded objects won't work right. */ { - Lisp_Object *pvalbuf; - valcontents = XSYMBOL (sym)->value; - pvalbuf = &XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car; - if (current_buffer == XBUFFER (*pvalbuf)) - *pvalbuf = Qnil; + Lisp_Object *pvalbuf, buf; + valcontents = SYMBOL_VALUE (variable); + pvalbuf = &XBUFFER_LOCAL_VALUE (valcontents)->buffer; + XSETBUFFER (buf, current_buffer); + if (EQ (buf, *pvalbuf)) + { + *pvalbuf = Qnil; + XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0; + find_symbol_value (variable); + } } - return sym; + return variable; +} + +/* Lisp functions for creating and removing buffer-local variables. */ + +DEFUN ("make-variable-frame-local", Fmake_variable_frame_local, Smake_variable_frame_local, + 1, 1, "vMake Variable Frame Local: ", + doc: /* Enable VARIABLE to have frame-local bindings. +This does not create any frame-local bindings for VARIABLE, +it just makes them possible. + +A frame-local binding is actually a frame parameter value. +If a frame F has a value for the frame parameter named VARIABLE, +that also acts as a frame-local binding for VARIABLE in F-- +provided this function has been called to enable VARIABLE +to have frame-local bindings at all. + +The only way to create a frame-local binding for VARIABLE in a frame +is to set the VARIABLE frame parameter of that frame. See +`modify-frame-parameters' for how to set frame parameters. + +Buffer-local bindings take precedence over frame-local bindings. */) + (variable) + register Lisp_Object variable; +{ + register Lisp_Object tem, valcontents, newval; + + CHECK_SYMBOL (variable); + variable = indirect_variable (variable); + + valcontents = SYMBOL_VALUE (variable); + if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents) + || BUFFER_OBJFWDP (valcontents)) + error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable))); + + if (BUFFER_LOCAL_VALUEP (valcontents) + || SOME_BUFFER_LOCAL_VALUEP (valcontents)) + { + XBUFFER_LOCAL_VALUE (valcontents)->check_frame = 1; + return variable; + } + + if (EQ (valcontents, Qunbound)) + SET_SYMBOL_VALUE (variable, Qnil); + tem = Fcons (Qnil, Fsymbol_value (variable)); + XSETCAR (tem, tem); + newval = allocate_misc (); + XMISCTYPE (newval) = Lisp_Misc_Some_Buffer_Local_Value; + XBUFFER_LOCAL_VALUE (newval)->realvalue = SYMBOL_VALUE (variable); + XBUFFER_LOCAL_VALUE (newval)->buffer = Qnil; + XBUFFER_LOCAL_VALUE (newval)->frame = Qnil; + XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0; + XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0; + XBUFFER_LOCAL_VALUE (newval)->check_frame = 1; + XBUFFER_LOCAL_VALUE (newval)->cdr = tem; + SET_SYMBOL_VALUE (variable, newval); + return variable; } DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p, - 1, 1, 0, - "Non-nil if VARIABLE has a local binding in the current buffer.") - (sym) - register Lisp_Object sym; + 1, 2, 0, + doc: /* Non-nil if VARIABLE has a local binding in buffer BUFFER. +BUFFER defaults to the current buffer. */) + (variable, buffer) + register Lisp_Object variable, buffer; +{ + Lisp_Object valcontents; + register struct buffer *buf; + + if (NILP (buffer)) + buf = current_buffer; + else + { + CHECK_BUFFER (buffer); + buf = XBUFFER (buffer); + } + + CHECK_SYMBOL (variable); + variable = indirect_variable (variable); + + valcontents = SYMBOL_VALUE (variable); + if (BUFFER_LOCAL_VALUEP (valcontents) + || SOME_BUFFER_LOCAL_VALUEP (valcontents)) + { + Lisp_Object tail, elt; + + for (tail = buf->local_var_alist; CONSP (tail); tail = XCDR (tail)) + { + elt = XCAR (tail); + if (EQ (variable, XCAR (elt))) + return Qt; + } + } + if (BUFFER_OBJFWDP (valcontents)) + { + int offset = XBUFFER_OBJFWD (valcontents)->offset; + int idx = PER_BUFFER_IDX (offset); + if (idx == -1 || PER_BUFFER_VALUE_P (buf, idx)) + return Qt; + } + return Qnil; +} + +DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p, Slocal_variable_if_set_p, + 1, 2, 0, + doc: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there. +More precisely, this means that setting the variable \(with `set' or`setq'), +while it does not have a `let'-style binding that was made in BUFFER, +will produce a buffer local binding. See Info node +`(elisp)Creating Buffer-Local'. +BUFFER defaults to the current buffer. */) + (variable, buffer) + register Lisp_Object variable, buffer; +{ + Lisp_Object valcontents; + register struct buffer *buf; + + if (NILP (buffer)) + buf = current_buffer; + else + { + CHECK_BUFFER (buffer); + buf = XBUFFER (buffer); + } + + CHECK_SYMBOL (variable); + variable = indirect_variable (variable); + + valcontents = SYMBOL_VALUE (variable); + + /* This means that make-variable-buffer-local was done. */ + if (BUFFER_LOCAL_VALUEP (valcontents)) + return Qt; + /* All these slots become local if they are set. */ + if (BUFFER_OBJFWDP (valcontents)) + return Qt; + if (SOME_BUFFER_LOCAL_VALUEP (valcontents)) + { + Lisp_Object tail, elt; + for (tail = buf->local_var_alist; CONSP (tail); tail = XCDR (tail)) + { + elt = XCAR (tail); + if (EQ (variable, XCAR (elt))) + return Qt; + } + } + return Qnil; +} + +DEFUN ("variable-binding-locus", Fvariable_binding_locus, Svariable_binding_locus, + 1, 1, 0, + doc: /* Return a value indicating where VARIABLE's current binding comes from. +If the current binding is buffer-local, the value is the current buffer. +If the current binding is frame-local, the value is the selected frame. +If the current binding is global (the default), the value is nil. */) + (variable) + register Lisp_Object variable; { Lisp_Object valcontents; - CHECK_SYMBOL (sym, 0); + CHECK_SYMBOL (variable); + variable = indirect_variable (variable); + + /* Make sure the current binding is actually swapped in. */ + find_symbol_value (variable); + + valcontents = XSYMBOL (variable)->value; + + if (BUFFER_LOCAL_VALUEP (valcontents) + || SOME_BUFFER_LOCAL_VALUEP (valcontents) + || BUFFER_OBJFWDP (valcontents)) + { + /* For a local variable, record both the symbol and which + buffer's or frame's value we are saving. */ + if (!NILP (Flocal_variable_p (variable, Qnil))) + return Fcurrent_buffer (); + else if (!BUFFER_OBJFWDP (valcontents) + && XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame) + return XBUFFER_LOCAL_VALUE (valcontents)->frame; + } - valcontents = XSYMBOL (sym)->value; - return ((BUFFER_LOCAL_VALUEP (valcontents) - || SOME_BUFFER_LOCAL_VALUEP (valcontents) - || BUFFER_OBJFWDP (valcontents)) - ? Qt : Qnil); + return Qnil; } /* Find the function at the end of a chain of symbol function indirections. */ @@ -1295,97 +1883,343 @@ indirect_function (object) tortoise = XSYMBOL (tortoise)->function; if (EQ (hare, tortoise)) - Fsignal (Qcyclic_function_indirection, Fcons (object, Qnil)); + xsignal1 (Qcyclic_function_indirection, object); } return hare; } -DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 1, 0, - "Return the function at the end of OBJECT's function chain.\n\ -If OBJECT is a symbol, follow all function indirections and return the final\n\ -function binding.\n\ -If OBJECT is not a symbol, just return it.\n\ -Signal a void-function error if the final symbol is unbound.\n\ -Signal a cyclic-function-indirection error if there is a loop in the\n\ -function chain of symbols.") - (object) - register Lisp_Object object; +DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 2, 0, + doc: /* Return the function at the end of OBJECT's function chain. +If OBJECT is not a symbol, just return it. Otherwise, follow all +function indirections to find the final function binding and return it. +If the final symbol in the chain is unbound, signal a void-function error. +Optional arg NOERROR non-nil means to return nil instead of signalling. +Signal a cyclic-function-indirection error if there is a loop in the +function chain of symbols. */) + (object, noerror) + register Lisp_Object object; + Lisp_Object noerror; { Lisp_Object result; - result = indirect_function (object); + /* Optimize for no indirection. */ + result = object; + if (SYMBOLP (result) && !EQ (result, Qunbound) + && (result = XSYMBOL (result)->function, SYMBOLP (result))) + result = indirect_function (result); + if (!EQ (result, Qunbound)) + return result; + + if (NILP (noerror)) + xsignal1 (Qvoid_function, object); - if (EQ (result, Qunbound)) - return Fsignal (Qvoid_function, Fcons (object, Qnil)); - return result; + return Qnil; } /* Extract and set vector and string elements */ DEFUN ("aref", Faref, Saref, 2, 2, 0, - "Return the element of ARRAY at index INDEX.\n\ -ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.") - (array, idx) + doc: /* Return the element of ARRAY at index IDX. +ARRAY may be a vector, a string, a char-table, a bool-vector, +or a byte-code object. IDX starts at 0. */) + (array, idx) register Lisp_Object array; Lisp_Object idx; { register int idxval; - CHECK_NUMBER (idx, 1); + CHECK_NUMBER (idx); idxval = XINT (idx); - if (!VECTORP (array) && !STRINGP (array) && !COMPILEDP (array)) - array = wrong_type_argument (Qarrayp, array); - if (idxval < 0 || idxval >= XVECTOR (array)->size) - args_out_of_range (array, idx); if (STRINGP (array)) + { + int c, idxval_byte; + + if (idxval < 0 || idxval >= SCHARS (array)) + args_out_of_range (array, idx); + if (! STRING_MULTIBYTE (array)) + return make_number ((unsigned char) SREF (array, idxval)); + idxval_byte = string_char_to_byte (array, idxval); + + c = STRING_CHAR (SDATA (array) + idxval_byte, + SBYTES (array) - idxval_byte); + return make_number (c); + } + else if (BOOL_VECTOR_P (array)) + { + int val; + + if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size) + args_out_of_range (array, idx); + + val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR]; + return (val & (1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR)) ? Qt : Qnil); + } + else if (CHAR_TABLE_P (array)) { Lisp_Object val; - XSETFASTINT (val, (unsigned char) XSTRING (array)->data[idxval]); - return val; + + val = Qnil; + + if (idxval < 0) + args_out_of_range (array, idx); + if (idxval < CHAR_TABLE_ORDINARY_SLOTS) + { + if (! SINGLE_BYTE_CHAR_P (idxval)) + args_out_of_range (array, idx); + /* For ASCII and 8-bit European characters, the element is + stored in the top table. */ + val = XCHAR_TABLE (array)->contents[idxval]; + if (NILP (val)) + { + int default_slot + = (idxval < 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII + : idxval < 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL + : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC); + val = XCHAR_TABLE (array)->contents[default_slot]; + } + if (NILP (val)) + val = XCHAR_TABLE (array)->defalt; + while (NILP (val)) /* Follow parents until we find some value. */ + { + array = XCHAR_TABLE (array)->parent; + if (NILP (array)) + return Qnil; + val = XCHAR_TABLE (array)->contents[idxval]; + if (NILP (val)) + val = XCHAR_TABLE (array)->defalt; + } + return val; + } + else + { + int code[4], i; + Lisp_Object sub_table; + Lisp_Object current_default; + + SPLIT_CHAR (idxval, code[0], code[1], code[2]); + if (code[1] < 32) code[1] = -1; + else if (code[2] < 32) code[2] = -1; + + /* Here, the possible range of CODE[0] (== charset ID) is + 128..MAX_CHARSET. Since the top level char table contains + data for multibyte characters after 256th element, we must + increment CODE[0] by 128 to get a correct index. */ + code[0] += 128; + code[3] = -1; /* anchor */ + + try_parent_char_table: + current_default = XCHAR_TABLE (array)->defalt; + sub_table = array; + for (i = 0; code[i] >= 0; i++) + { + val = XCHAR_TABLE (sub_table)->contents[code[i]]; + if (SUB_CHAR_TABLE_P (val)) + { + sub_table = val; + if (! NILP (XCHAR_TABLE (sub_table)->defalt)) + current_default = XCHAR_TABLE (sub_table)->defalt; + } + else + { + if (NILP (val)) + val = current_default; + if (NILP (val)) + { + array = XCHAR_TABLE (array)->parent; + if (!NILP (array)) + goto try_parent_char_table; + } + return val; + } + } + /* Reaching here means IDXVAL is a generic character in + which each character or a group has independent value. + Essentially it's nonsense to get a value for such a + generic character, but for backward compatibility, we try + the default value and parent. */ + val = current_default; + if (NILP (val)) + { + array = XCHAR_TABLE (array)->parent; + if (!NILP (array)) + goto try_parent_char_table; + } + return val; + } } else - return XVECTOR (array)->contents[idxval]; + { + int size = 0; + if (VECTORP (array)) + size = XVECTOR (array)->size; + else if (COMPILEDP (array)) + size = XVECTOR (array)->size & PSEUDOVECTOR_SIZE_MASK; + else + wrong_type_argument (Qarrayp, array); + + if (idxval < 0 || idxval >= size) + args_out_of_range (array, idx); + return XVECTOR (array)->contents[idxval]; + } } DEFUN ("aset", Faset, Saset, 3, 3, 0, - "Store into the element of ARRAY at index IDX the value NEWELT.\n\ -ARRAY may be a vector or a string. IDX starts at 0.") - (array, idx, newelt) + doc: /* Store into the element of ARRAY at index IDX the value NEWELT. +Return NEWELT. ARRAY may be a vector, a string, a char-table or a +bool-vector. IDX starts at 0. */) + (array, idx, newelt) register Lisp_Object array; Lisp_Object idx, newelt; { register int idxval; - CHECK_NUMBER (idx, 1); + CHECK_NUMBER (idx); idxval = XINT (idx); - if (!VECTORP (array) && !STRINGP (array)) - array = wrong_type_argument (Qarrayp, array); - if (idxval < 0 || idxval >= XVECTOR (array)->size) - args_out_of_range (array, idx); + CHECK_ARRAY (array, Qarrayp); CHECK_IMPURE (array); if (VECTORP (array)) - XVECTOR (array)->contents[idxval] = newelt; + { + if (idxval < 0 || idxval >= XVECTOR (array)->size) + args_out_of_range (array, idx); + XVECTOR (array)->contents[idxval] = newelt; + } + else if (BOOL_VECTOR_P (array)) + { + int val; + + if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size) + args_out_of_range (array, idx); + + val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR]; + + if (! NILP (newelt)) + val |= 1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR); + else + val &= ~(1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR)); + XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR] = val; + } + else if (CHAR_TABLE_P (array)) + { + if (idxval < 0) + args_out_of_range (array, idx); + if (idxval < CHAR_TABLE_ORDINARY_SLOTS) + { + if (! SINGLE_BYTE_CHAR_P (idxval)) + args_out_of_range (array, idx); + XCHAR_TABLE (array)->contents[idxval] = newelt; + } + else + { + int code[4], i; + Lisp_Object val; + + SPLIT_CHAR (idxval, code[0], code[1], code[2]); + if (code[1] < 32) code[1] = -1; + else if (code[2] < 32) code[2] = -1; + + /* See the comment of the corresponding part in Faref. */ + code[0] += 128; + code[3] = -1; /* anchor */ + for (i = 0; code[i + 1] >= 0; i++) + { + val = XCHAR_TABLE (array)->contents[code[i]]; + if (SUB_CHAR_TABLE_P (val)) + array = val; + else + { + Lisp_Object temp; + + /* VAL is a leaf. Create a sub char table with the + initial value VAL and look into it. */ + + temp = make_sub_char_table (val); + XCHAR_TABLE (array)->contents[code[i]] = temp; + array = temp; + } + } + XCHAR_TABLE (array)->contents[code[i]] = newelt; + } + } + else if (STRING_MULTIBYTE (array)) + { + int idxval_byte, prev_bytes, new_bytes, nbytes; + unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1; + + if (idxval < 0 || idxval >= SCHARS (array)) + args_out_of_range (array, idx); + CHECK_NUMBER (newelt); + + nbytes = SBYTES (array); + + idxval_byte = string_char_to_byte (array, idxval); + p1 = SDATA (array) + idxval_byte; + PARSE_MULTIBYTE_SEQ (p1, nbytes - idxval_byte, prev_bytes); + new_bytes = CHAR_STRING (XINT (newelt), p0); + if (prev_bytes != new_bytes) + { + /* We must relocate the string data. */ + int nchars = SCHARS (array); + unsigned char *str; + USE_SAFE_ALLOCA; + + SAFE_ALLOCA (str, unsigned char *, nbytes); + bcopy (SDATA (array), str, nbytes); + allocate_string_data (XSTRING (array), nchars, + nbytes + new_bytes - prev_bytes); + bcopy (str, SDATA (array), idxval_byte); + p1 = SDATA (array) + idxval_byte; + bcopy (str + idxval_byte + prev_bytes, p1 + new_bytes, + nbytes - (idxval_byte + prev_bytes)); + SAFE_FREE (); + clear_string_char_byte_cache (); + } + while (new_bytes--) + *p1++ = *p0++; + } else { - CHECK_NUMBER (newelt, 2); - XSTRING (array)->data[idxval] = XINT (newelt); + if (idxval < 0 || idxval >= SCHARS (array)) + args_out_of_range (array, idx); + CHECK_NUMBER (newelt); + + if (XINT (newelt) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt))) + SSET (array, idxval, XINT (newelt)); + else + { + /* We must relocate the string data while converting it to + multibyte. */ + int idxval_byte, prev_bytes, new_bytes; + unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1; + unsigned char *origstr = SDATA (array), *str; + int nchars, nbytes; + USE_SAFE_ALLOCA; + + nchars = SCHARS (array); + nbytes = idxval_byte = count_size_as_multibyte (origstr, idxval); + nbytes += count_size_as_multibyte (origstr + idxval, + nchars - idxval); + SAFE_ALLOCA (str, unsigned char *, nbytes); + copy_text (SDATA (array), str, nchars, 0, 1); + PARSE_MULTIBYTE_SEQ (str + idxval_byte, nbytes - idxval_byte, + prev_bytes); + new_bytes = CHAR_STRING (XINT (newelt), p0); + allocate_string_data (XSTRING (array), nchars, + nbytes + new_bytes - prev_bytes); + bcopy (str, SDATA (array), idxval_byte); + p1 = SDATA (array) + idxval_byte; + while (new_bytes--) + *p1++ = *p0++; + bcopy (str + idxval_byte + prev_bytes, p1, + nbytes - (idxval_byte + prev_bytes)); + SAFE_FREE (); + clear_string_char_byte_cache (); + } } return newelt; } - -Lisp_Object -Farray_length (array) - register Lisp_Object array; -{ - register Lisp_Object size; - if (!VECTORP (array) && !STRINGP (array) && !COMPILEDP (array)) - array = wrong_type_argument (Qarrayp, array); - XSETFASTINT (size, XVECTOR (array)->size); - return size; -} /* Arithmetic functions */ @@ -1396,23 +2230,18 @@ arithcompare (num1, num2, comparison) Lisp_Object num1, num2; enum comparison comparison; { - double f1, f2; + double f1 = 0, f2 = 0; int floatp = 0; -#ifdef LISP_FLOAT_TYPE - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1, 0); - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2, 0); + CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1); + CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2); if (FLOATP (num1) || FLOATP (num2)) { floatp = 1; - f1 = (FLOATP (num1)) ? XFLOAT (num1)->data : XINT (num1); - f2 = (FLOATP (num2)) ? XFLOAT (num2)->data : XINT (num2); + f1 = (FLOATP (num1)) ? XFLOAT_DATA (num1) : XINT (num1); + f2 = (FLOATP (num2)) ? XFLOAT_DATA (num2) : XINT (num2); } -#else - CHECK_NUMBER_COERCE_MARKER (num1, 0); - CHECK_NUMBER_COERCE_MARKER (num2, 0); -#endif /* LISP_FLOAT_TYPE */ switch (comparison) { @@ -1452,88 +2281,85 @@ arithcompare (num1, num2, comparison) } DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0, - "T if two args, both numbers or markers, are equal.") - (num1, num2) + doc: /* Return t if two args, both numbers or markers, are equal. */) + (num1, num2) register Lisp_Object num1, num2; { return arithcompare (num1, num2, equal); } DEFUN ("<", Flss, Slss, 2, 2, 0, - "T if first arg is less than second arg. Both must be numbers or markers.") - (num1, num2) + doc: /* Return t if first arg is less than second arg. Both must be numbers or markers. */) + (num1, num2) register Lisp_Object num1, num2; { return arithcompare (num1, num2, less); } DEFUN (">", Fgtr, Sgtr, 2, 2, 0, - "T if first arg is greater than second arg. Both must be numbers or markers.") - (num1, num2) + doc: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */) + (num1, num2) register Lisp_Object num1, num2; { return arithcompare (num1, num2, grtr); } DEFUN ("<=", Fleq, Sleq, 2, 2, 0, - "T if first arg is less than or equal to second arg.\n\ -Both must be numbers or markers.") - (num1, num2) + doc: /* Return t if first arg is less than or equal to second arg. +Both must be numbers or markers. */) + (num1, num2) register Lisp_Object num1, num2; { return arithcompare (num1, num2, less_or_equal); } DEFUN (">=", Fgeq, Sgeq, 2, 2, 0, - "T if first arg is greater than or equal to second arg.\n\ -Both must be numbers or markers.") - (num1, num2) + doc: /* Return t if first arg is greater than or equal to second arg. +Both must be numbers or markers. */) + (num1, num2) register Lisp_Object num1, num2; { return arithcompare (num1, num2, grtr_or_equal); } DEFUN ("/=", Fneq, Sneq, 2, 2, 0, - "T if first arg is not equal to second arg. Both must be numbers or markers.") - (num1, num2) + doc: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */) + (num1, num2) register Lisp_Object num1, num2; { return arithcompare (num1, num2, notequal); } -DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, "T if NUMBER is zero.") - (num) - register Lisp_Object num; +DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, + doc: /* Return t if NUMBER is zero. */) + (number) + register Lisp_Object number; { -#ifdef LISP_FLOAT_TYPE - CHECK_NUMBER_OR_FLOAT (num, 0); + CHECK_NUMBER_OR_FLOAT (number); - if (FLOATP (num)) + if (FLOATP (number)) { - if (XFLOAT(num)->data == 0.0) + if (XFLOAT_DATA (number) == 0.0) return Qt; return Qnil; } -#else - CHECK_NUMBER (num, 0); -#endif /* LISP_FLOAT_TYPE */ - if (!XINT (num)) + if (!XINT (number)) return Qt; return Qnil; } -/* Convert between 32-bit values and pairs of lispy 24-bit values. */ +/* Convert between long values and pairs of Lisp integers. */ Lisp_Object long_to_cons (i) unsigned long i; { - unsigned int top = i >> 16; + unsigned long top = i >> 16; unsigned int bot = i & 0xFFFF; if (top == 0) return make_number (bot); - if (top == 0xFFFF) + if (top == (unsigned long)-1 >> 16) return Fcons (make_number (-1), make_number (bot)); return Fcons (make_number (top), make_number (bot)); } @@ -1545,70 +2371,141 @@ cons_to_long (c) Lisp_Object top, bot; if (INTEGERP (c)) return XINT (c); - top = XCONS (c)->car; - bot = XCONS (c)->cdr; + top = XCAR (c); + bot = XCDR (c); if (CONSP (bot)) - bot = XCONS (bot)->car; + bot = XCAR (bot); return ((XINT (top) << 16) | XINT (bot)); } DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0, - "Convert NUM to a string by printing it in decimal.\n\ -Uses a minus sign if negative.\n\ -NUM may be an integer or a floating point number.") - (num) - Lisp_Object num; + doc: /* Return the decimal representation of NUMBER as a string. +Uses a minus sign if negative. +NUMBER may be an integer or a floating point number. */) + (number) + Lisp_Object number; { - char buffer[20]; + char buffer[VALBITS]; -#ifndef LISP_FLOAT_TYPE - CHECK_NUMBER (num, 0); -#else - CHECK_NUMBER_OR_FLOAT (num, 0); + CHECK_NUMBER_OR_FLOAT (number); - if (FLOATP (num)) + if (FLOATP (number)) { char pigbuf[350]; /* see comments in float_to_string */ - float_to_string (pigbuf, XFLOAT(num)->data); - return build_string (pigbuf); + float_to_string (pigbuf, XFLOAT_DATA (number)); + return build_string (pigbuf); } -#endif /* LISP_FLOAT_TYPE */ - sprintf (buffer, "%d", XINT (num)); + if (sizeof (int) == sizeof (EMACS_INT)) + sprintf (buffer, "%d", XINT (number)); + else if (sizeof (long) == sizeof (EMACS_INT)) + sprintf (buffer, "%ld", (long) XINT (number)); + else + abort (); return build_string (buffer); } -DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 1, 0, - "Convert STRING to a number by parsing it as a decimal number.\n\ -This parses both integers and floating point numbers.\n\ -It ignores leading spaces and tabs.") - (str) - register Lisp_Object str; +INLINE static int +digit_to_number (character, base) + int character, base; +{ + int digit; + + if (character >= '0' && character <= '9') + digit = character - '0'; + else if (character >= 'a' && character <= 'z') + digit = character - 'a' + 10; + else if (character >= 'A' && character <= 'Z') + digit = character - 'A' + 10; + else + return -1; + + if (digit >= base) + return -1; + else + return digit; +} + +DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0, + doc: /* Parse STRING as a decimal number and return the number. +This parses both integers and floating point numbers. +It ignores leading spaces and tabs. + +If BASE, interpret STRING as a number in that base. If BASE isn't +present, base 10 is used. BASE must be between 2 and 16 (inclusive). +If the base used is not 10, floating point is not recognized. */) + (string, base) + register Lisp_Object string, base; { - unsigned char *p; + register unsigned char *p; + register int b; + int sign = 1; + Lisp_Object val; - CHECK_STRING (str, 0); + CHECK_STRING (string); - p = XSTRING (str)->data; + if (NILP (base)) + b = 10; + else + { + CHECK_NUMBER (base); + b = XINT (base); + if (b < 2 || b > 16) + xsignal1 (Qargs_out_of_range, base); + } /* Skip any whitespace at the front of the number. Some versions of atoi do this anyway, so we might as well make Emacs lisp consistent. */ + p = SDATA (string); while (*p == ' ' || *p == '\t') p++; -#ifdef LISP_FLOAT_TYPE - if (isfloat_string (p)) - return make_float (atof (p)); -#endif /* LISP_FLOAT_TYPE */ + if (*p == '-') + { + sign = -1; + p++; + } + else if (*p == '+') + p++; + + if (isfloat_string (p) && b == 10) + val = make_float (sign * atof (p)); + else + { + double v = 0; + + while (1) + { + int digit = digit_to_number (*p++, b); + if (digit < 0) + break; + v = v * b + digit; + } + + val = make_fixnum_or_float (sign * v); + } - return make_number (atoi (p)); + return val; } - -enum arithop - { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin }; -extern Lisp_Object float_arith_driver (); + +enum arithop + { + Aadd, + Asub, + Amult, + Adiv, + Alogand, + Alogior, + Alogxor, + Amax, + Amin + }; + +static Lisp_Object float_arith_driver P_ ((double, int, enum arithop, + int, Lisp_Object *)); +extern Lisp_Object fmod_float (); Lisp_Object arith_driver (code, nargs, args) @@ -1618,67 +2515,76 @@ arith_driver (code, nargs, args) { register Lisp_Object val; register int argnum; - register int accum; - register int next; + register EMACS_INT accum = 0; + register EMACS_INT next; -#ifdef SWITCH_ENUM_BUG - switch ((int) code) -#else - switch (code) -#endif + switch (SWITCH_ENUM_CAST (code)) { case Alogior: case Alogxor: case Aadd: case Asub: - accum = 0; break; + accum = 0; + break; case Amult: - accum = 1; break; + accum = 1; + break; case Alogand: - accum = -1; break; + accum = -1; + break; + default: + break; } for (argnum = 0; argnum < nargs; argnum++) { - val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */ -#ifdef LISP_FLOAT_TYPE - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum); + /* Using args[argnum] as argument to CHECK_NUMBER_... */ + val = args[argnum]; + CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val); - if (FLOATP (val)) /* time to do serious math */ - return (float_arith_driver ((double) accum, argnum, code, - nargs, args)); -#else - CHECK_NUMBER_COERCE_MARKER (val, argnum); -#endif /* LISP_FLOAT_TYPE */ - args[argnum] = val; /* runs into a compiler bug. */ + if (FLOATP (val)) + return float_arith_driver ((double) accum, argnum, code, + nargs, args); + args[argnum] = val; next = XINT (args[argnum]); -#ifdef SWITCH_ENUM_BUG - switch ((int) code) -#else - switch (code) -#endif + switch (SWITCH_ENUM_CAST (code)) { - case Aadd: accum += next; break; + case Aadd: + accum += next; + break; case Asub: - if (!argnum && nargs != 1) - next = - next; - accum -= next; + accum = argnum ? accum - next : nargs == 1 ? - next : next; + break; + case Amult: + accum *= next; break; - case Amult: accum *= next; break; case Adiv: - if (!argnum) accum = next; + if (!argnum) + accum = next; else { if (next == 0) - Fsignal (Qarith_error, Qnil); + xsignal0 (Qarith_error); accum /= next; } break; - case Alogand: accum &= next; break; - case Alogior: accum |= next; break; - case Alogxor: accum ^= next; break; - case Amax: if (!argnum || next > accum) accum = next; break; - case Amin: if (!argnum || next < accum) accum = next; break; + case Alogand: + accum &= next; + break; + case Alogior: + accum |= next; + break; + case Alogxor: + accum ^= next; + break; + case Amax: + if (!argnum || next > accum) + accum = next; + break; + case Amin: + if (!argnum || next < accum) + accum = next; + break; } } @@ -1686,12 +2592,10 @@ arith_driver (code, nargs, args) return val; } -#ifdef LISP_FLOAT_TYPE - #undef isnan #define isnan(x) ((x) != (x)) -Lisp_Object +static Lisp_Object float_arith_driver (accum, argnum, code, nargs, args) double accum; register int argnum; @@ -1701,34 +2605,28 @@ float_arith_driver (accum, argnum, code, nargs, args) { register Lisp_Object val; double next; - + for (; argnum < nargs; argnum++) { val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */ - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum); + CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val); if (FLOATP (val)) { - next = XFLOAT (val)->data; + next = XFLOAT_DATA (val); } else { args[argnum] = val; /* runs into a compiler bug. */ next = XINT (args[argnum]); } -#ifdef SWITCH_ENUM_BUG - switch ((int) code) -#else - switch (code) -#endif + switch (SWITCH_ENUM_CAST (code)) { case Aadd: accum += next; break; case Asub: - if (!argnum && nargs != 1) - next = - next; - accum -= next; + accum = argnum ? accum - next : nargs == 1 ? - next : next; break; case Amult: accum *= next; @@ -1738,8 +2636,8 @@ float_arith_driver (accum, argnum, code, nargs, args) accum = next; else { - if (next == 0) - Fsignal (Qarith_error, Qnil); + if (! IEEE_FLOATING_POINT && next == 0) + xsignal0 (Qarith_error); accum /= next; } break; @@ -1760,11 +2658,12 @@ float_arith_driver (accum, argnum, code, nargs, args) return make_float (accum); } -#endif /* LISP_FLOAT_TYPE */ + DEFUN ("+", Fplus, Splus, 0, MANY, 0, - "Return sum of any number of arguments, which are numbers or markers.") - (nargs, args) + doc: /* Return sum of any number of arguments, which are numbers or markers. +usage: (+ &rest NUMBERS-OR-MARKERS) */) + (nargs, args) int nargs; Lisp_Object *args; { @@ -1772,10 +2671,11 @@ DEFUN ("+", Fplus, Splus, 0, MANY, 0, } DEFUN ("-", Fminus, Sminus, 0, MANY, 0, - "Negate number or subtract numbers or markers.\n\ -With one arg, negates it. With more than one arg,\n\ -subtracts all but the first from the first.") - (nargs, args) + doc: /* Negate number or subtract numbers or markers and return the result. +With one arg, negates it. With more than one arg, +subtracts all but the first from the first. +usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */) + (nargs, args) int nargs; Lisp_Object *args; { @@ -1783,8 +2683,9 @@ subtracts all but the first from the first.") } DEFUN ("*", Ftimes, Stimes, 0, MANY, 0, - "Returns product of any number of arguments, which are numbers or markers.") - (nargs, args) + doc: /* Return product of any number of arguments, which are numbers or markers. +usage: (* &rest NUMBERS-OR-MARKERS) */) + (nargs, args) int nargs; Lisp_Object *args; { @@ -1792,30 +2693,35 @@ DEFUN ("*", Ftimes, Stimes, 0, MANY, 0, } DEFUN ("/", Fquo, Squo, 2, MANY, 0, - "Returns first argument divided by all the remaining arguments.\n\ -The arguments must be numbers or markers.") - (nargs, args) + doc: /* Return first argument divided by all the remaining arguments. +The arguments must be numbers or markers. +usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */) + (nargs, args) int nargs; Lisp_Object *args; { + int argnum; + for (argnum = 2; argnum < nargs; argnum++) + if (FLOATP (args[argnum])) + return float_arith_driver (0, 0, Adiv, nargs, args); return arith_driver (Adiv, nargs, args); } DEFUN ("%", Frem, Srem, 2, 2, 0, - "Returns remainder of first arg divided by second.\n\ -Both must be integers or markers.") - (num1, num2) - register Lisp_Object num1, num2; + doc: /* Return remainder of X divided by Y. +Both must be integers or markers. */) + (x, y) + register Lisp_Object x, y; { Lisp_Object val; - CHECK_NUMBER_COERCE_MARKER (num1, 0); - CHECK_NUMBER_COERCE_MARKER (num2, 1); + CHECK_NUMBER_COERCE_MARKER (x); + CHECK_NUMBER_COERCE_MARKER (y); - if (XFASTINT (num2) == 0) - Fsignal (Qarith_error, Qnil); + if (XFASTINT (y) == 0) + xsignal0 (Qarith_error); - XSETINT (val, XINT (num1) % XINT (num2)); + XSETINT (val, XINT (x) % XINT (y)); return val; } @@ -1824,58 +2730,50 @@ double fmod (f1, f2) double f1, f2; { -#ifdef HAVE_DREM /* Some systems use this non-standard name. */ - return (drem (f1, f2)); -#else /* Other systems don't seem to have it at all. */ - return (f1 - f2 * floor (f1/f2)); -#endif + double r = f1; + + if (f2 < 0.0) + f2 = -f2; + + /* If the magnitude of the result exceeds that of the divisor, or + the sign of the result does not agree with that of the dividend, + iterate with the reduced value. This does not yield a + particularly accurate result, but at least it will be in the + range promised by fmod. */ + do + r -= f2 * floor (r / f2); + while (f2 <= (r < 0 ? -r : r) || ((r < 0) != (f1 < 0) && ! isnan (r))); + + return r; } #endif /* ! HAVE_FMOD */ DEFUN ("mod", Fmod, Smod, 2, 2, 0, - "Returns X modulo Y.\n\ -The result falls between zero (inclusive) and Y (exclusive).\n\ -Both X and Y must be numbers or markers.") - (num1, num2) - register Lisp_Object num1, num2; + doc: /* Return X modulo Y. +The result falls between zero (inclusive) and Y (exclusive). +Both X and Y must be numbers or markers. */) + (x, y) + register Lisp_Object x, y; { Lisp_Object val; - int i1, i2; + EMACS_INT i1, i2; -#ifdef LISP_FLOAT_TYPE - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1, 0); - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2, 1); + CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x); + CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y); - if (FLOATP (num1) || FLOATP (num2)) - { - double f1, f2; - - f1 = FLOATP (num1) ? XFLOAT (num1)->data : XINT (num1); - f2 = FLOATP (num2) ? XFLOAT (num2)->data : XINT (num2); - if (f2 == 0) - Fsignal (Qarith_error, Qnil); - - f1 = fmod (f1, f2); - /* If the "remainder" comes out with the wrong sign, fix it. */ - if ((f1 < 0) != (f2 < 0)) - f1 += f2; - return (make_float (f1)); - } -#else /* not LISP_FLOAT_TYPE */ - CHECK_NUMBER_COERCE_MARKER (num1, 0); - CHECK_NUMBER_COERCE_MARKER (num2, 1); -#endif /* not LISP_FLOAT_TYPE */ + if (FLOATP (x) || FLOATP (y)) + return fmod_float (x, y); - i1 = XINT (num1); - i2 = XINT (num2); + i1 = XINT (x); + i2 = XINT (y); if (i2 == 0) - Fsignal (Qarith_error, Qnil); - + xsignal0 (Qarith_error); + i1 %= i2; /* If the "remainder" comes out with the wrong sign, fix it. */ - if ((i1 < 0) != (i2 < 0)) + if (i2 < 0 ? i1 > 0 : i1 < 0) i1 += i2; XSETINT (val, i1); @@ -1883,9 +2781,10 @@ Both X and Y must be numbers or markers.") } DEFUN ("max", Fmax, Smax, 1, MANY, 0, - "Return largest of all the arguments (which must be numbers or markers).\n\ -The value is always a number; markers are converted to numbers.") - (nargs, args) + doc: /* Return largest of all the arguments (which must be numbers or markers). +The value is always a number; markers are converted to numbers. +usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) + (nargs, args) int nargs; Lisp_Object *args; { @@ -1893,9 +2792,10 @@ The value is always a number; markers are converted to numbers.") } DEFUN ("min", Fmin, Smin, 1, MANY, 0, - "Return smallest of all the arguments (which must be numbers or markers).\n\ -The value is always a number; markers are converted to numbers.") - (nargs, args) + doc: /* Return smallest of all the arguments (which must be numbers or markers). +The value is always a number; markers are converted to numbers. +usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) + (nargs, args) int nargs; Lisp_Object *args; { @@ -1903,9 +2803,10 @@ The value is always a number; markers are converted to numbers.") } DEFUN ("logand", Flogand, Slogand, 0, MANY, 0, - "Return bitwise-and of all the arguments.\n\ -Arguments may be integers, or markers converted to integers.") - (nargs, args) + doc: /* Return bitwise-and of all the arguments. +Arguments may be integers, or markers converted to integers. +usage: (logand &rest INTS-OR-MARKERS) */) + (nargs, args) int nargs; Lisp_Object *args; { @@ -1913,9 +2814,10 @@ Arguments may be integers, or markers converted to integers.") } DEFUN ("logior", Flogior, Slogior, 0, MANY, 0, - "Return bitwise-or of all the arguments.\n\ -Arguments may be integers, or markers converted to integers.") - (nargs, args) + doc: /* Return bitwise-or of all the arguments. +Arguments may be integers, or markers converted to integers. +usage: (logior &rest INTS-OR-MARKERS) */) + (nargs, args) int nargs; Lisp_Object *args; { @@ -1923,9 +2825,10 @@ Arguments may be integers, or markers converted to integers.") } DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0, - "Return bitwise-exclusive-or of all the arguments.\n\ -Arguments may be integers, or markers converted to integers.") - (nargs, args) + doc: /* Return bitwise-exclusive-or of all the arguments. +Arguments may be integers, or markers converted to integers. +usage: (logxor &rest INTS-OR-MARKERS) */) + (nargs, args) int nargs; Lisp_Object *args; { @@ -1933,90 +2836,104 @@ Arguments may be integers, or markers converted to integers.") } DEFUN ("ash", Fash, Sash, 2, 2, 0, - "Return VALUE with its bits shifted left by COUNT.\n\ -If COUNT is negative, shifting is actually to the right.\n\ -In this case, the sign bit is duplicated.") - (num1, num2) - register Lisp_Object num1, num2; + doc: /* Return VALUE with its bits shifted left by COUNT. +If COUNT is negative, shifting is actually to the right. +In this case, the sign bit is duplicated. */) + (value, count) + register Lisp_Object value, count; { register Lisp_Object val; - CHECK_NUMBER (num1, 0); - CHECK_NUMBER (num2, 1); + CHECK_NUMBER (value); + CHECK_NUMBER (count); - if (XINT (num2) > 0) - XSETINT (val, XINT (num1) << XFASTINT (num2)); + if (XINT (count) >= BITS_PER_EMACS_INT) + XSETINT (val, 0); + else if (XINT (count) > 0) + XSETINT (val, XINT (value) << XFASTINT (count)); + else if (XINT (count) <= -BITS_PER_EMACS_INT) + XSETINT (val, XINT (value) < 0 ? -1 : 0); else - XSETINT (val, XINT (num1) >> -XINT (num2)); + XSETINT (val, XINT (value) >> -XINT (count)); return val; } DEFUN ("lsh", Flsh, Slsh, 2, 2, 0, - "Return VALUE with its bits shifted left by COUNT.\n\ -If COUNT is negative, shifting is actually to the right.\n\ -In this case, zeros are shifted in on the left.") - (num1, num2) - register Lisp_Object num1, num2; + doc: /* Return VALUE with its bits shifted left by COUNT. +If COUNT is negative, shifting is actually to the right. +In this case, zeros are shifted in on the left. */) + (value, count) + register Lisp_Object value, count; { register Lisp_Object val; - CHECK_NUMBER (num1, 0); - CHECK_NUMBER (num2, 1); + CHECK_NUMBER (value); + CHECK_NUMBER (count); - if (XINT (num2) > 0) - XSETINT (val, (EMACS_UINT) XUINT (num1) << XFASTINT (num2)); + if (XINT (count) >= BITS_PER_EMACS_INT) + XSETINT (val, 0); + else if (XINT (count) > 0) + XSETINT (val, (EMACS_UINT) XUINT (value) << XFASTINT (count)); + else if (XINT (count) <= -BITS_PER_EMACS_INT) + XSETINT (val, 0); else - XSETINT (val, (EMACS_UINT) XUINT (num1) >> -XINT (num2)); + XSETINT (val, (EMACS_UINT) XUINT (value) >> -XINT (count)); return val; } DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0, - "Return NUMBER plus one. NUMBER may be a number or a marker.\n\ -Markers are converted to integers.") - (num) - register Lisp_Object num; + doc: /* Return NUMBER plus one. NUMBER may be a number or a marker. +Markers are converted to integers. */) + (number) + register Lisp_Object number; { -#ifdef LISP_FLOAT_TYPE - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num, 0); + CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number); - if (FLOATP (num)) - return (make_float (1.0 + XFLOAT (num)->data)); -#else - CHECK_NUMBER_COERCE_MARKER (num, 0); -#endif /* LISP_FLOAT_TYPE */ + if (FLOATP (number)) + return (make_float (1.0 + XFLOAT_DATA (number))); - XSETINT (num, XINT (num) + 1); - return num; + XSETINT (number, XINT (number) + 1); + return number; } DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0, - "Return NUMBER minus one. NUMBER may be a number or a marker.\n\ -Markers are converted to integers.") - (num) - register Lisp_Object num; + doc: /* Return NUMBER minus one. NUMBER may be a number or a marker. +Markers are converted to integers. */) + (number) + register Lisp_Object number; { -#ifdef LISP_FLOAT_TYPE - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num, 0); + CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number); - if (FLOATP (num)) - return (make_float (-1.0 + XFLOAT (num)->data)); -#else - CHECK_NUMBER_COERCE_MARKER (num, 0); -#endif /* LISP_FLOAT_TYPE */ + if (FLOATP (number)) + return (make_float (-1.0 + XFLOAT_DATA (number))); - XSETINT (num, XINT (num) - 1); - return num; + XSETINT (number, XINT (number) - 1); + return number; } DEFUN ("lognot", Flognot, Slognot, 1, 1, 0, - "Return the bitwise complement of ARG. ARG must be an integer.") - (num) - register Lisp_Object num; + doc: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */) + (number) + register Lisp_Object number; +{ + CHECK_NUMBER (number); + XSETINT (number, ~XINT (number)); + return number; +} + +DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0, + doc: /* Return the byteorder for the machine. +Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII +lowercase l) for small endian machines. */) + () { - CHECK_NUMBER (num, 0); - XSETINT (num, ~XINT (num)); - return num; + unsigned i = 0x04030201; + int order = *(char *)&i == 1 ? 108 : 66; + + return make_number (order); } + + void syms_of_data () @@ -2036,6 +2953,7 @@ syms_of_data () Qargs_out_of_range = intern ("args-out-of-range"); Qvoid_function = intern ("void-function"); Qcyclic_function_indirection = intern ("cyclic-function-indirection"); + Qcyclic_variable_indirection = intern ("cyclic-variable-indirection"); Qvoid_variable = intern ("void-variable"); Qsetting_constant = intern ("setting-constant"); Qinvalid_read_syntax = intern ("invalid-read-syntax"); @@ -2048,11 +2966,13 @@ syms_of_data () Qbeginning_of_buffer = intern ("beginning-of-buffer"); Qend_of_buffer = intern ("end-of-buffer"); Qbuffer_read_only = intern ("buffer-read-only"); + Qtext_read_only = intern ("text-read-only"); Qmark_inactive = intern ("mark-inactive"); Qlistp = intern ("listp"); Qconsp = intern ("consp"); Qsymbolp = intern ("symbolp"); + Qkeywordp = intern ("keywordp"); Qintegerp = intern ("integerp"); Qnatnump = intern ("natnump"); Qwholenump = intern ("wholenump"); @@ -2068,17 +2988,22 @@ syms_of_data () Qboundp = intern ("boundp"); Qfboundp = intern ("fboundp"); -#ifdef LISP_FLOAT_TYPE Qfloatp = intern ("floatp"); Qnumberp = intern ("numberp"); Qnumber_or_marker_p = intern ("number-or-marker-p"); -#endif /* LISP_FLOAT_TYPE */ + + Qchar_table_p = intern ("char-table-p"); + Qvector_or_char_table_p = intern ("vector-or-char-table-p"); + + Qsubrp = intern ("subrp"); + Qunevalled = intern ("unevalled"); + Qmany = intern ("many"); Qcdr = intern ("cdr"); /* Handle automatic advice activation */ Qad_advice_info = intern ("ad-advice-info"); - Qad_activate = intern ("ad-activate"); + Qad_activate_internal = intern ("ad-activate-internal"); error_tail = Fcons (Qerror, Qnil); @@ -2114,6 +3039,18 @@ syms_of_data () Fput (Qcyclic_function_indirection, Qerror_message, build_string ("Symbol's chain of function indirections contains a loop")); + Fput (Qcyclic_variable_indirection, Qerror_conditions, + Fcons (Qcyclic_variable_indirection, error_tail)); + Fput (Qcyclic_variable_indirection, Qerror_message, + build_string ("Symbol's chain of variable indirections contains a loop")); + + Qcircular_list = intern ("circular-list"); + staticpro (&Qcircular_list); + Fput (Qcircular_list, Qerror_conditions, + Fcons (Qcircular_list, error_tail)); + Fput (Qcircular_list, Qerror_message, + build_string ("List contains a loop")); + Fput (Qvoid_variable, Qerror_conditions, Fcons (Qvoid_variable, error_tail)); Fput (Qvoid_variable, Qerror_message, @@ -2170,7 +3107,11 @@ syms_of_data () Fput (Qbuffer_read_only, Qerror_message, build_string ("Buffer is read-only")); -#ifdef LISP_FLOAT_TYPE + Fput (Qtext_read_only, Qerror_conditions, + Fcons (Qtext_read_only, error_tail)); + Fput (Qtext_read_only, Qerror_message, + build_string ("Text is read-only")); + Qrange_error = intern ("range-error"); Qdomain_error = intern ("domain-error"); Qsingularity_error = intern ("singularity-error"); @@ -2207,7 +3148,6 @@ syms_of_data () staticpro (&Qsingularity_error); staticpro (&Qoverflow_error); staticpro (&Qunderflow_error); -#endif /* LISP_FLOAT_TYPE */ staticpro (&Qnil); staticpro (&Qt); @@ -2225,6 +3165,7 @@ syms_of_data () staticpro (&Qargs_out_of_range); staticpro (&Qvoid_function); staticpro (&Qcyclic_function_indirection); + staticpro (&Qcyclic_variable_indirection); staticpro (&Qvoid_variable); staticpro (&Qsetting_constant); staticpro (&Qinvalid_read_syntax); @@ -2236,11 +3177,13 @@ syms_of_data () staticpro (&Qbeginning_of_buffer); staticpro (&Qend_of_buffer); staticpro (&Qbuffer_read_only); + staticpro (&Qtext_read_only); staticpro (&Qmark_inactive); staticpro (&Qlistp); staticpro (&Qconsp); staticpro (&Qsymbolp); + staticpro (&Qkeywordp); staticpro (&Qintegerp); staticpro (&Qnatnump); staticpro (&Qwholenump); @@ -2253,20 +3196,65 @@ syms_of_data () staticpro (&Qmarkerp); staticpro (&Qbuffer_or_string_p); staticpro (&Qinteger_or_marker_p); -#ifdef LISP_FLOAT_TYPE staticpro (&Qfloatp); staticpro (&Qnumberp); staticpro (&Qnumber_or_marker_p); -#endif /* LISP_FLOAT_TYPE */ + staticpro (&Qchar_table_p); + staticpro (&Qvector_or_char_table_p); + staticpro (&Qsubrp); + staticpro (&Qmany); + staticpro (&Qunevalled); staticpro (&Qboundp); staticpro (&Qfboundp); staticpro (&Qcdr); staticpro (&Qad_advice_info); - staticpro (&Qad_activate); - + staticpro (&Qad_activate_internal); + + /* Types that type-of returns. */ + Qinteger = intern ("integer"); + Qsymbol = intern ("symbol"); + Qstring = intern ("string"); + Qcons = intern ("cons"); + Qmarker = intern ("marker"); + Qoverlay = intern ("overlay"); + Qfloat = intern ("float"); + Qwindow_configuration = intern ("window-configuration"); + Qprocess = intern ("process"); + Qwindow = intern ("window"); + /* Qsubr = intern ("subr"); */ + Qcompiled_function = intern ("compiled-function"); + Qbuffer = intern ("buffer"); + Qframe = intern ("frame"); + Qvector = intern ("vector"); + Qchar_table = intern ("char-table"); + Qbool_vector = intern ("bool-vector"); + Qhash_table = intern ("hash-table"); + + staticpro (&Qinteger); + staticpro (&Qsymbol); + staticpro (&Qstring); + staticpro (&Qcons); + staticpro (&Qmarker); + staticpro (&Qoverlay); + staticpro (&Qfloat); + staticpro (&Qwindow_configuration); + staticpro (&Qprocess); + staticpro (&Qwindow); + /* staticpro (&Qsubr); */ + staticpro (&Qcompiled_function); + staticpro (&Qbuffer); + staticpro (&Qframe); + staticpro (&Qvector); + staticpro (&Qchar_table); + staticpro (&Qbool_vector); + staticpro (&Qhash_table); + + defsubr (&Sindirect_variable); + defsubr (&Sinteractive_form); defsubr (&Seq); defsubr (&Snull); + defsubr (&Stype_of); defsubr (&Slistp); defsubr (&Snlistp); defsubr (&Sconsp); @@ -2275,13 +3263,16 @@ syms_of_data () defsubr (&Sinteger_or_marker_p); defsubr (&Snumberp); defsubr (&Snumber_or_marker_p); -#ifdef LISP_FLOAT_TYPE defsubr (&Sfloatp); -#endif /* LISP_FLOAT_TYPE */ defsubr (&Snatnump); defsubr (&Ssymbolp); + defsubr (&Skeywordp); defsubr (&Sstringp); + defsubr (&Smultibyte_string_p); defsubr (&Svectorp); + defsubr (&Schar_table_p); + defsubr (&Svector_or_char_table_p); + defsubr (&Sbool_vector_p); defsubr (&Sarrayp); defsubr (&Ssequencep); defsubr (&Sbufferp); @@ -2305,7 +3296,6 @@ syms_of_data () defsubr (&Sfboundp); defsubr (&Sfset); defsubr (&Sdefalias); - defsubr (&Sdefine_function); defsubr (&Ssetplist); defsubr (&Ssymbol_value); defsubr (&Sset); @@ -2316,7 +3306,10 @@ syms_of_data () defsubr (&Smake_variable_buffer_local); defsubr (&Smake_local_variable); defsubr (&Skill_local_variable); + defsubr (&Smake_variable_frame_local); defsubr (&Slocal_variable_p); + defsubr (&Slocal_variable_if_set_p); + defsubr (&Svariable_binding_locus); defsubr (&Saref); defsubr (&Saset); defsubr (&Snumber_to_string); @@ -2344,15 +3337,26 @@ syms_of_data () defsubr (&Sadd1); defsubr (&Ssub1); defsubr (&Slognot); + defsubr (&Sbyteorder); + defsubr (&Ssubr_arity); + defsubr (&Ssubr_name); XSYMBOL (Qwholenump)->function = XSYMBOL (Qnatnump)->function; + + DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum, + doc: /* The largest value that is representable in a Lisp integer. */); + Vmost_positive_fixnum = make_number (MOST_POSITIVE_FIXNUM); + + DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum, + doc: /* The smallest value that is representable in a Lisp integer. */); + Vmost_negative_fixnum = make_number (MOST_NEGATIVE_FIXNUM); } SIGTYPE arith_error (signo) int signo; { -#ifdef USG +#if defined(USG) && !defined(POSIX_SIGNALS) /* USG systems forget handlers when they are used; must reestablish each time */ signal (signo, arith_error); @@ -2367,9 +3371,11 @@ arith_error (signo) sigsetmask (SIGEMPTYMASK); #endif /* not BSD4_1 */ - Fsignal (Qarith_error, Qnil); + SIGNAL_THREAD_CHECK (signo); + xsignal0 (Qarith_error); } +void init_data () { /* Don't do this if just dumping out. @@ -2381,8 +3387,11 @@ init_data () return; #endif /* CANNOT_DUMP */ signal (SIGFPE, arith_error); - + #ifdef uts signal (SIGEMT, arith_error); #endif /* uts */ } + +/* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7 + (do not change this comment) */