X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/9701c742ad8556cf02e37d879926b77627187e0f..7ffefb0856637762050ca248013d2b2f1cf7554e:/src/data.c diff --git a/src/data.c b/src/data.c index dade1a0b1b..ec9a176f07 100644 --- a/src/data.c +++ b/src/data.c @@ -1,6 +1,6 @@ /* 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. @@ -25,7 +25,7 @@ Boston, MA 02110-1301, USA. */ #include #include "lisp.h" #include "puresize.h" -#include "charset.h" +#include "character.h" #include "buffer.h" #include "keyboard.h" #include "frame.h" @@ -125,7 +125,14 @@ wrong_type_argument (predicate, value) 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 @@ -274,7 +281,8 @@ DEFUN ("atom", Fatom, Satom, 1, 1, 0, } 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; { @@ -449,7 +457,7 @@ DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0, (object) register Lisp_Object object; { - if (INTEGERP (object) || STRINGP (object)) + if (CHARACTERP (object) || STRINGP (object)) return Qt; return Qnil; } @@ -523,8 +531,8 @@ 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'. -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; { @@ -554,8 +562,8 @@ 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'. -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; { @@ -1926,23 +1934,26 @@ indirect_function (object) 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; } @@ -1986,96 +1997,8 @@ or a byte-code object. IDX starts at 0. */) } 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 { @@ -2133,45 +2056,8 @@ bool-vector. IDX starts at 0. */) } 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)) { @@ -2180,7 +2066,7 @@ bool-vector. IDX starts at 0. */) if (idxval < 0 || idxval >= SCHARS (array)) args_out_of_range (array, idx); - CHECK_NUMBER (newelt); + CHECK_CHARACTER (newelt); nbytes = SBYTES (array); @@ -2215,38 +2101,9 @@ bool-vector. IDX starts at 0. */) 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;