/* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
- Copyright (C) 1985,86,88,93,94,95,97,98,99, 2000, 2001, 2002
- 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.
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, Inc., 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
+the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
#include <config.h>
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 Qfloatp;
Lisp_Object Qnumberp, Qnumber_or_marker_p;
-static Lisp_Object Qinteger, Qsymbol, Qstring, Qcons, Qmarker, Qoverlay;
+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;
}
DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
- doc: /* Return t if OBJECT is a list. This includes nil. */)
+ doc: /* Return t if OBJECT is a list, that is, a cons cell or nil.
+Otherwise, return nil. */)
(object)
Lisp_Object object;
{
Lisp_Object object;
{
if (SYMBOLP (object)
- && XSYMBOL (object)->name->data[0] == ':'
+ && SREF (SYMBOL_NAME (object), 0) == ':'
&& SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object))
return Qt;
return Qnil;
}
DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
- doc: /* Return t if OBJECT is a character or a string. */)
+ doc: /* Return t if OBJECT is a character (an integer) or a string. */)
(object)
register Lisp_Object object;
{
DEFUN ("car", Fcar, Scar, 1, 1, 0,
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'. */)
+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;
{
DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
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'. */)
+Error if arg is not nil and not a cons cell. See also `cdr-safe'.
+
+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;
{
}
DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0,
- doc: /* Make SYMBOL's value be void. */)
+ doc: /* Make SYMBOL's value be void.
+Return SYMBOL. */)
(symbol)
register Lisp_Object symbol;
{
}
DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0,
- doc: /* Make SYMBOL's function definition be void. */)
+ doc: /* Make SYMBOL's function definition be void.
+Return SYMBOL. */)
(symbol)
register Lisp_Object symbol;
{
register Lisp_Object name;
CHECK_SYMBOL (symbol);
- XSETSTRING (name, XSYMBOL (symbol)->name);
+ name = SYMBOL_NAME (symbol);
return name;
}
return definition;
}
-DEFUN ("defalias", Fdefalias, Sdefalias, 2, 2, 0,
+extern Lisp_Object Qfunction_documentation;
+
+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. */)
- (symbol, definition)
- register Lisp_Object symbol, 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 (symbol);
+ if (CONSP (XSYMBOL (symbol)->function)
+ && EQ (XCAR (XSYMBOL (symbol)->function), Qautoload))
+ LOADHIST_ATTACH (Fcons (Qt, symbol));
definition = Ffset (symbol, definition);
- LOADHIST_ATTACH (symbol);
+ 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 NEWVAL, and return NEWVAL. */)
+ doc: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
(symbol, newplist)
register Lisp_Object symbol, newplist;
{
return Fcons (make_number (minargs), make_number (maxargs));
}
-DEFUN ("subr-interactive-form", Fsubr_interactive_form, Ssubr_interactive_form, 1, 1, 0,
- doc: /* Return the interactive form of SUBR or nil if none.
-SUBR must be a built-in function. Value, if non-nil, is a list
-\(interactive SPEC). */)
+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;
if (!SUBRP (subr))
wrong_type_argument (Qsubrp, subr);
- if (XSUBR (subr)->prompt)
- return list2 (Qinteractive, build_string (XSUBR (subr)->prompt));
+ 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))
+ {
+ if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE)
+ return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE));
+ }
+ 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;
}
hare = XSYMBOL (hare)->value;
if (!XSYMBOL (hare)->indirect_variable)
break;
-
+
hare = XSYMBOL (hare)->value;
tortoise = XSYMBOL (tortoise)->value;
*XINTFWD (valcontents)->intvar = XINT (newval);
if (*XINTFWD (valcontents)->intvar != XINT (newval))
error ("Value out of range for variable `%s'",
- XSYMBOL (symbol)->name->data);
+ SDATA (SYMBOL_NAME (symbol)));
break;
case Lisp_Misc_Boolfwd:
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:
Lisp_Object type;
type = PER_BUFFER_TYPE (offset);
- if (XINT (type) == -1)
- error ("Variable %s is read-only", XSYMBOL (symbol)->name->data);
-
if (! NILP (type) && ! NILP (newval)
&& XTYPE (newval) != XINT (type))
buffer_slot_type_mismatch (offset);
Lisp_Object symbol;
{
Lisp_Object valcontents, cdr;
-
+
valcontents = SYMBOL_VALUE (symbol);
if (!BUFFER_LOCAL_VALUEP (valcontents)
&& !SOME_BUFFER_LOCAL_VALUEP (valcontents))
/* 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);
Lisp_Object symbol, valcontents;
{
register Lisp_Object tem1;
-
+
tem1 = XBUFFER_LOCAL_VALUE (valcontents)->buffer;
if (NILP (tem1)
{
if (XSYMBOL (symbol)->indirect_variable)
symbol = indirect_variable (symbol);
-
+
/* Unload the previously loaded binding. */
tem1 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
Fsetcdr (tem1,
{
register Lisp_Object valcontents;
register Lisp_Object val;
-
+
CHECK_SYMBOL (symbol);
valcontents = SYMBOL_VALUE (symbol);
let_shadows_buffer_binding_p (symbol)
Lisp_Object symbol;
{
- struct specbinding *p;
+ volatile struct specbinding *p;
for (p = specpdl_ptr - 1; p >= specpdl; p--)
if (p->func == NULL
return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
innercontents = valcontents = SYMBOL_VALUE (symbol);
-
+
if (BUFFER_OBJFWDP (valcontents))
{
int offset = XBUFFER_OBJFWD (valcontents)->offset;
and load that binding. */
else
{
- tem1 = Fcons (symbol, Fcdr (current_alist_element));
+ tem1 = Fcons (symbol, XCDR (current_alist_element));
buf->local_var_alist
= Fcons (tem1, buf->local_var_alist);
}
}
DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
- doc: /* Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.
+ 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)
if (idx > 0)
{
struct buffer *b;
-
+
for (b = all_buffers; b; b = b->next)
if (!PER_BUFFER_VALUE_P (b, idx))
PER_BUFFER_VALUE (b, offset) = value;
return value;
}
-DEFUN ("setq-default", Fsetq_default, Ssetq_default, 2, UNEVALLED, 0,
+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 and it is 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 SYMBOL VALUE SYMBOL VALUE...)
-This sets each SYMBOL's default value to the corresponding VALUE.
-The VALUE for the Nth SYMBOL can refer to the new default values
-of previous SYMs.
-usage: (setq-default SYMBOL VALUE [SYMBOL VALUE...]) */)
+ (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;
{
do
{
val = Feval (Fcar (Fcdr (args_left)));
- symbol = Fcar (args_left);
+ symbol = XCAR (args_left);
Fset_default (symbol, val);
- args_left = Fcdr (Fcdr (args_left));
+ args_left = Fcdr (XCDR (args_left));
}
while (!NILP (args_left));
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.
+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 tem, valcontents, newval;
CHECK_SYMBOL (variable);
+ variable = indirect_variable (variable);
valcontents = SYMBOL_VALUE (variable);
if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents))
- error ("Symbol %s may not be buffer-local", XSYMBOL (variable)->name->data);
+ error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable)));
if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents))
return variable;
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.\)
-See also `make-variable-buffer-local'.
+Return VARIABLE.
If the variable is already arranged to become local when set,
this function causes a local value to exist for this buffer,
(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 tem, valcontents;
CHECK_SYMBOL (variable);
+ variable = indirect_variable (variable);
valcontents = SYMBOL_VALUE (variable);
if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents))
- error ("Symbol %s may not be buffer-local", XSYMBOL (variable)->name->data);
+ error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable)));
if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents))
{
DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable,
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. */)
+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 (variable);
+ variable = indirect_variable (variable);
valcontents = SYMBOL_VALUE (variable);
loaded, recompute its value. We have to do it now, or else
forwarded objects won't work right. */
{
- Lisp_Object *pvalbuf;
+ Lisp_Object *pvalbuf, buf;
valcontents = SYMBOL_VALUE (variable);
pvalbuf = &XBUFFER_LOCAL_VALUE (valcontents)->buffer;
- if (current_buffer == XBUFFER (*pvalbuf))
+ XSETBUFFER (buf, current_buffer);
+ if (EQ (buf, *pvalbuf))
{
*pvalbuf = Qnil;
XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
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.
-When a frame-local binding exists in the current frame,
-it is in effect whenever the current buffer has no buffer-local binding.
-A frame-local binding is actual a frame parameter value;
-thus, any given frame has a local binding for VARIABLE
-if it has a value for the frame parameter named VARIABLE.
-See `modify-frame-parameters'. */)
+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", XSYMBOL (variable)->name->data);
+ error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable)));
if (BUFFER_LOCAL_VALUEP (valcontents)
|| SOME_BUFFER_LOCAL_VALUEP (valcontents))
}
CHECK_SYMBOL (variable);
+ variable = indirect_variable (variable);
valcontents = SYMBOL_VALUE (variable);
if (BUFFER_LOCAL_VALUEP (valcontents)
{
Lisp_Object tail, elt;
- variable = indirect_variable (variable);
for (tail = buf->local_var_alist; CONSP (tail); tail = XCDR (tail))
{
elt = XCAR (tail);
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 if it is set there.
+ 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;
}
CHECK_SYMBOL (variable);
+ variable = indirect_variable (variable);
valcontents = SYMBOL_VALUE (variable);
}
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 (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;
+ }
+
+ return Qnil;
+}
\f
/* Find the function at the end of a chain of symbol function indirections. */
return hare;
}
-DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 1, 0,
+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 a symbol, follow all function indirections and return the final
-function binding.
-If OBJECT is not a symbol, just return it.
-Signal a void-function error if the final symbol is unbound.
+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)
+ (object, noerror)
register Lisp_Object object;
+ Lisp_Object noerror;
{
Lisp_Object result;
result = indirect_function (object);
if (EQ (result, Qunbound))
- return Fsignal (Qvoid_function, Fcons (object, Qnil));
+ return (NILP (noerror)
+ ? Fsignal (Qvoid_function, Fcons (object, Qnil))
+ : Qnil);
return result;
}
\f
{
int c, idxval_byte;
- if (idxval < 0 || idxval >= XSTRING (array)->size)
+ if (idxval < 0 || idxval >= SCHARS (array))
args_out_of_range (array, idx);
if (! STRING_MULTIBYTE (array))
- return make_number ((unsigned char) XSTRING (array)->data[idxval]);
+ return make_number ((unsigned char) SREF (array, idxval));
idxval_byte = string_char_to_byte (array, idxval);
- c = STRING_CHAR (&XSTRING (array)->data[idxval_byte],
- STRING_BYTES (XSTRING (array)) - idxval_byte);
+ c = STRING_CHAR (SDATA (array) + idxval_byte,
+ SBYTES (array) - idxval_byte);
return make_number (c);
}
else if (BOOL_VECTOR_P (array))
if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
args_out_of_range (array, idx);
- val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR];
- return (val & (1 << (idxval % BITS_PER_CHAR)) ? Qt : Qnil);
+ 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))
{
}
}
-/* Don't use alloca for relocating string data larger than this, lest
- we overflow their stack. The value is the same as what used in
- fns.c for base64 handling. */
-#define MAX_ALLOCA 16*1024
-
DEFUN ("aset", Faset, Saset, 3, 3, 0,
doc: /* Store into the element of ARRAY at index IDX the value NEWELT.
-ARRAY may be a vector, a string, a char-table or a bool-vector.
-IDX starts at 0. */)
+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;
if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
args_out_of_range (array, idx);
- val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR];
+ val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR];
if (! NILP (newelt))
- val |= 1 << (idxval % BITS_PER_CHAR);
+ val |= 1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR);
else
- val &= ~(1 << (idxval % BITS_PER_CHAR));
- XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR] = val;
+ 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))
{
}
else if (STRING_MULTIBYTE (array))
{
- int idxval_byte, prev_bytes, new_bytes;
+ int idxval_byte, prev_bytes, new_bytes, nbytes;
unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1;
- if (idxval < 0 || idxval >= XSTRING (array)->size)
+ if (idxval < 0 || idxval >= SCHARS (array))
args_out_of_range (array, idx);
- CHECK_NUMBER (newelt);
+ CHECK_CHARACTER (newelt);
+
+ nbytes = SBYTES (array);
idxval_byte = string_char_to_byte (array, idxval);
- p1 = &XSTRING (array)->data[idxval_byte];
+ 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 = XSTRING (array)->size;
- int nbytes = STRING_BYTES (XSTRING (array));
+ int nchars = SCHARS (array);
unsigned char *str;
+ USE_SAFE_ALLOCA;
- str = (nbytes <= MAX_ALLOCA
- ? (unsigned char *) alloca (nbytes)
- : (unsigned char *) xmalloc (nbytes));
- bcopy (XSTRING (array)->data, str, nbytes);
+ SAFE_ALLOCA (str, unsigned char *, nbytes);
+ bcopy (SDATA (array), str, nbytes);
allocate_string_data (XSTRING (array), nchars,
nbytes + new_bytes - prev_bytes);
- bcopy (str, XSTRING (array)->data, idxval_byte);
- p1 = XSTRING (array)->data + idxval_byte;
+ 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));
- if (nbytes > MAX_ALLOCA)
- xfree (str);
+ SAFE_FREE ();
clear_string_char_byte_cache ();
}
while (new_bytes--)
}
else
{
- if (idxval < 0 || idxval >= XSTRING (array)->size)
+ 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)))
- XSTRING (array)->data[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 = XSTRING (array)->data, *str;
- int nchars, nbytes;
-
- nchars = XSTRING (array)->size;
- nbytes = idxval_byte = count_size_as_multibyte (origstr, idxval);
- nbytes += count_size_as_multibyte (origstr + idxval,
- nchars - idxval);
- str = (nbytes <= MAX_ALLOCA
- ? (unsigned char *) alloca (nbytes)
- : (unsigned char *) xmalloc (nbytes));
- copy_text (XSTRING (array)->data, 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, XSTRING (array)->data, idxval_byte);
- p1 = XSTRING (array)->data + idxval_byte;
- while (new_bytes--)
- *p1++ = *p0++;
- bcopy (str + idxval_byte + prev_bytes, p1,
- nbytes - (idxval_byte + prev_bytes));
- if (nbytes > MAX_ALLOCA)
- xfree (str);
- clear_string_char_byte_cache ();
- }
+ if (XINT (newelt) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt)))
+ args_out_of_range (array, newelt);
+ SSET (array, idxval, XINT (newelt));
}
return newelt;
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);
}
\f
DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0,
- doc: /* Convert NUMBER to a string by printing it in decimal.
+ 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)
return -1;
else
return digit;
-}
+}
DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0,
- doc: /* Convert STRING to a number by parsing it as a decimal number.
+ 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.
/* 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 = XSTRING (string)->data;
+ p = SDATA (string);
while (*p == ' ' || *p == '\t')
p++;
}
else if (*p == '+')
p++;
-
+
if (isfloat_string (p) && b == 10)
val = make_float (sign * atof (p));
else
}
DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
- doc: /* Negate number or subtract numbers or markers.
+ 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) */)
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 ("lsh", Flsh, Slsh, 2, 2, 0,
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. */)
+In this case, zeros are shifted in on the left. */)
(value, count)
register Lisp_Object value, count;
{
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. */)
+ ()
+{
+ unsigned i = 0x04030201;
+ int order = *(char *)&i == 1 ? 108 : 66;
+
+ return make_number (order);
+}
+
+
\f
void
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);
staticpro (&Qhash_table);
defsubr (&Sindirect_variable);
- defsubr (&Ssubr_interactive_form);
+ defsubr (&Sinteractive_form);
defsubr (&Seq);
defsubr (&Snull);
defsubr (&Stype_of);
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);
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);
sigsetmask (SIGEMPTYMASK);
#endif /* not BSD4_1 */
+ SIGNAL_THREAD_CHECK (signo);
Fsignal (Qarith_error, Qnil);
}
signal (SIGEMT, arith_error);
#endif /* uts */
}
+
+/* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
+ (do not change this comment) */