/* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
- Copyright (C) 1985,86,88,93,94,95,97,98,99, 2000, 2001, 2003
+ Copyright (C) 1985,86,88,93,94,95,97,98,99, 2000, 2001, 03, 2004
Free Software Foundation, Inc.
This file is part of GNU Emacs.
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 ("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;
}
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:
}
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)
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 [VAR VALUE...]) */)
(args)
Lisp_Object args;
{
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;
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.
+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)
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;
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.
Return NEWELT. ARRAY may be a vector, a string, a char-table or a
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))
{
/* We must relocate the string data. */
int nchars = SCHARS (array);
unsigned char *str;
+ USE_SAFE_ALLOCA;
- str = (nbytes <= MAX_ALLOCA
- ? (unsigned char *) alloca (nbytes)
- : (unsigned char *) xmalloc (nbytes));
+ SAFE_ALLOCA (str, unsigned char *, nbytes);
bcopy (SDATA (array), str, nbytes);
allocate_string_data (XSTRING (array), nchars,
nbytes + new_bytes - prev_bytes);
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--)
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);
- str = (nbytes <= MAX_ALLOCA
- ? (unsigned char *) alloca (nbytes)
- : (unsigned char *) xmalloc (nbytes));
+ 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);
*p1++ = *p0++;
bcopy (str + idxval_byte + prev_bytes, p1,
nbytes - (idxval_byte + prev_bytes));
- if (nbytes > MAX_ALLOCA)
- xfree (str);
+ SAFE_FREE ();
clear_string_char_byte_cache ();
}
}
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);
}
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 (&Qhash_table);
defsubr (&Sindirect_variable);
- defsubr (&Ssubr_interactive_form);
+ defsubr (&Sinteractive_form);
defsubr (&Seq);
defsubr (&Snull);
defsubr (&Stype_of);
defsubr (&Sadd1);
defsubr (&Ssub1);
defsubr (&Slognot);
+ defsubr (&Sbyteorder);
defsubr (&Ssubr_arity);
+ defsubr (&Ssubr_name);
XSYMBOL (Qwholenump)->function = XSYMBOL (Qnatnump)->function;
sigsetmask (SIGEMPTYMASK);
#endif /* not BSD4_1 */
+ SIGNAL_THREAD_CHECK (signo);
Fsignal (Qarith_error, Qnil);
}