/* 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.
&& 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;
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;
}
register Lisp_Object valcontents, newval;
struct buffer *buf;
{
- int offset;
-
switch (SWITCH_ENUM_CAST (XTYPE (valcontents)))
{
case Lisp_Misc:
- (char *) &buffer_defaults);
int idx = PER_BUFFER_IDX (offset);
- Lisp_Object tail, buf;
+ Lisp_Object tail;
if (idx <= 0)
break;
}
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)
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: it is evaluated and its value returned.
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;
{
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))
{
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. */
{
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;
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;
+ {
+ sub_table = val;
+ if (! NILP (XCHAR_TABLE (sub_table)->defalt))
+ current_default = XCHAR_TABLE (sub_table)->defalt;
+ }
else
{
if (NILP (val))
- val = XCHAR_TABLE (sub_table)->defalt;
+ val = current_default;
if (NILP (val))
{
array = XCHAR_TABLE (array)->parent;
return val;
}
}
- /* Here, VAL is a sub char table. We try the default value
- and parent. */
- val = XCHAR_TABLE (val)->defalt;
+ /* 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;
}
}
-/* 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))
{
if (idxval < 0)
args_out_of_range (array, idx);
if (idxval < CHAR_TABLE_ORDINARY_SLOTS)
- XCHAR_TABLE (array)->contents[idxval] = newelt;
+ {
+ 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 temp;
/* VAL is a leaf. Create a sub char table with the
- default value VAL or XCHAR_TABLE (array)->defalt
- and look into it. */
+ initial value VAL and look into it. */
- temp = make_sub_char_table (NILP (val)
- ? XCHAR_TABLE (array)->defalt
- : val);
+ temp = make_sub_char_table (val);
XCHAR_TABLE (array)->contents[code[i]] = temp;
array = temp;
}
/* 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);
}
()
{
unsigned i = 0x04030201;
- int order = *(char *)&i == 4 ? 66 : 108;
+ int order = *(char *)&i == 1 ? 108 : 66;
- return XFASTINT (order);
+ return make_number (order);
}
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 (&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);
}
HCoop / bpt / emacs.git / blobdiff