/* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
- 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+ 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
This file is part of GNU Emacs.
#include <stdio.h>
#include "lisp.h"
#include "puresize.h"
-#include "charset.h"
+#include "character.h"
#include "buffer.h"
#include "keyboard.h"
#include "frame.h"
tem = call1 (predicate, value);
}
while (NILP (tem));
+ /* This function is marked as NO_RETURN, gcc would warn if it has a
+ return statement or if falls off the function. Other compilers
+ warn if no return statement is present. */
+#ifndef __GNUC__
return value;
+#else
+ abort ();
+#endif
}
void
}
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;
{
(object)
register Lisp_Object object;
{
- if (INTEGERP (object) || STRINGP (object))
+ if (CHARACTERP (object) || STRINGP (object))
return Qt;
return Qnil;
}
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 basic Lisp
-concepts such as car, cdr, cons cell and list. */)
+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;
{
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'.
-See Info node `(elisp)Cons Cells' for a discussion of basic Lisp
-concepts such as cdr, car, cons cell and 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;
{
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
}
else if (CHAR_TABLE_P (array))
{
- Lisp_Object 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;
- }
+ CHECK_CHARACTER (idx);
+ return CHAR_TABLE_REF (array, idxval);
}
else
{
}
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;
- }
+ CHECK_CHARACTER (idx);
+ CHAR_TABLE_SET (array, idxval, newelt);
}
else if (STRING_MULTIBYTE (array))
{
if (idxval < 0 || idxval >= SCHARS (array))
args_out_of_range (array, idx);
- CHECK_NUMBER (newelt);
+ CHECK_CHARACTER (newelt);
nbytes = SBYTES (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 ();
- }
+ if (XINT (newelt) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt)))
+ args_out_of_range (array, newelt);
+ SSET (array, idxval, XINT (newelt));
}
return newelt;