From e03f79336240cf8f1a4f59aeb4347ef54e419c28 Mon Sep 17 00:00:00 2001 From: "Richard M. Stallman" Date: Sat, 7 Oct 1995 21:52:15 +0000 Subject: [PATCH] (Fset_char_table_range): New function. (make_char_table, Fmap_char_table): New function. (Fchar_table_extra_slot, Fset_char_table_extra_slot): New functions. (Fcopy_sequence, Felt, internal_equal, Ffillarray): Handle chartables and boolvectors. (Flength, concat): Handle boolvectors as args. (Flength): Handle chartables as args. --- src/fns.c | 252 ++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 246 insertions(+), 6 deletions(-) diff --git a/src/fns.c b/src/fns.c index 287187d5a85..efa8e23f453 100644 --- a/src/fns.c +++ b/src/fns.c @@ -106,6 +106,10 @@ A byte-code function object is also allowed.") XSETFASTINT (val, XSTRING (obj)->size); else if (VECTORP (obj)) XSETFASTINT (val, XVECTOR (obj)->size); + else if (CHAR_TABLE_P (obj)) + XSETFASTINT (val, CHAR_TABLE_ORDINARY_SLOTS); + else if (BOOL_VECTOR_P (obj)) + XSETFASTINT (val, XBOOL_VECTOR (obj)->size); else if (COMPILEDP (obj)) XSETFASTINT (val, XVECTOR (obj)->size & PSEUDOVECTOR_SIZE_MASK); else if (CONSP (obj)) @@ -289,6 +293,41 @@ with the original.") Lisp_Object arg; { if (NILP (arg)) return arg; + + if (CHAR_TABLE_P (arg)) + { + int i, size; + Lisp_Object copy; + + /* Calculate the number of extra slots. */ + size = CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (arg)); + copy = Fmake_char_table (make_number (size), Qnil); + /* Copy all the slots, including the extra ones. */ + bcopy (XCHAR_TABLE (arg)->contents, XCHAR_TABLE (copy)->contents, + (XCHAR_TABLE (arg)->size & PSEUDOVECTOR_SIZE_MASK) * sizeof (Lisp_Object)); + + /* Recursively copy any char-tables in the ordinary slots. */ + for (i = 0; i < CHAR_TABLE_ORDINARY_SLOTS; i++) + if (CHAR_TABLE_P (XCHAR_TABLE (arg)->contents[i])) + XCHAR_TABLE (copy)->contents[i] + = Fcopy_sequence (XCHAR_TABLE (copy)->contents[i]); + + return copy; + } + + if (BOOL_VECTOR_P (arg)) + { + Lisp_Object val; + int bits_per_char = INTBITS / sizeof (int); + int size_in_chars + = (XBOOL_VECTOR (arg)->size + bits_per_char) / bits_per_char; + + val = Fmake_bool_vector (Flength (arg), Qnil); + bcopy (XBOOL_VECTOR (arg)->data, XBOOL_VECTOR (val)->data, + size_in_chars); + return val; + } + if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg)) arg = wrong_type_argument (Qsequencep, arg); return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0); @@ -324,7 +363,7 @@ concat (nargs, args, target_type, last_special) { this = args[argnum]; if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this) - || COMPILEDP (this))) + || COMPILEDP (this) || BOOL_VECTOR_P (this))) { if (INTEGERP (this)) args[argnum] = Fnumber_to_string (this); @@ -391,6 +430,19 @@ concat (nargs, args, target_type, last_special) if (thisindex >= thisleni) break; if (STRINGP (this)) XSETFASTINT (elt, XSTRING (this)->data[thisindex++]); + else if (BOOL_VECTOR_P (this)) + { + int bits_per_char = INTBITS / sizeof (int); + int size_in_chars + = ((XBOOL_VECTOR (this)->size + bits_per_char) + / bits_per_char); + int byte; + byte = XBOOL_VECTOR (val)->data[thisindex / bits_per_char]; + if (byte & (1 << thisindex)) + elt = Qt; + else + elt = Qnil; + } else elt = XVECTOR (this)->contents[thisindex++]; } @@ -521,7 +573,8 @@ DEFUN ("elt", Felt, Selt, 2, 2, 0, { if (CONSP (seq) || NILP (seq)) return Fcar (Fnthcdr (n, seq)); - else if (STRINGP (seq) || VECTORP (seq)) + else if (STRINGP (seq) || VECTORP (seq) || BOOL_VECTOR_P (seq) + || CHAR_TABLE_P (seq)) return Faref (seq, n); else seq = wrong_type_argument (Qsequencep, seq); @@ -1019,11 +1072,26 @@ internal_equal (o1, o2, depth) same size. */ if (XVECTOR (o2)->size != size) return 0; - /* But only true vectors and compiled functions are actually sensible - to compare, so eliminate the others now. */ + /* Boolvectors are compared much like strings. */ + if (BOOL_VECTOR_P (o1)) + { + int bits_per_char = INTBITS / sizeof (int); + int size_in_chars + = (XBOOL_VECTOR (o1)->size + bits_per_char) / bits_per_char; + + if (XBOOL_VECTOR (o1)->size != XBOOL_VECTOR (o2)->size) + return 0; + if (bcmp (XBOOL_VECTOR (o1)->data, XBOOL_VECTOR (o2)->data, + size_in_chars)) + return 0; + return 1; + } + + /* Aside from them, only true vectors, char-tables, and compiled + functions are sensible to compare, so eliminate the others now. */ if (size & PSEUDOVECTOR_FLAG) { - if (!(size & PVEC_COMPILED)) + if (!(size & (PVEC_COMPILED | PVEC_CHAR_TABLE))) return 0; size &= PSEUDOVECTOR_SIZE_MASK; } @@ -1058,7 +1126,8 @@ internal_equal (o1, o2, depth) } DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0, - "Store each element of ARRAY with ITEM. ARRAY is a vector or string.") + "Store each element of ARRAY with ITEM.\n\ +ARRAY is a vector, string, char-table, or bool-vector.") (array, item) Lisp_Object array, item; { @@ -1071,6 +1140,14 @@ DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0, for (index = 0; index < size; index++) p[index] = item; } + else if (CHAR_TABLE_P (array)) + { + register Lisp_Object *p = XCHAR_TABLE (array)->contents; + size = CHAR_TABLE_ORDINARY_SLOTS; + for (index = 0; index < size; index++) + p[index] = item; + XCHAR_TABLE (array)->defalt = Qnil; + } else if (STRINGP (array)) { register unsigned char *p = XSTRING (array)->data; @@ -1080,6 +1157,17 @@ DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0, for (index = 0; index < size; index++) p[index] = charval; } + else if (BOOL_VECTOR_P (array)) + { + register unsigned char *p = XBOOL_VECTOR (array)->data; + int bits_per_char = INTBITS / sizeof (int); + int size_in_chars + = (XBOOL_VECTOR (array)->size + bits_per_char) / bits_per_char; + + charval = (! NILP (item) ? -1 : 0); + for (index = 0; index < size_in_chars; index++) + p[index] = charval; + } else { array = wrong_type_argument (Qarrayp, array); @@ -1088,6 +1176,152 @@ DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0, return array; } +DEFUN ("char-table-parent", Fchar_table_parent, Schar_table_parent, + 1, 1, 0, + "Return the parent char-table of CHAR-TABLE.\n\ +The value is either nil or another char-table.\n\ +If CHAR-TABLE holds nil for a given character,\n\ +then the actual applicable value is inherited from the parent char-table\n\ +\(or from its parents, if necessary).") + (chartable) + Lisp_Object chartable; +{ + CHECK_CHAR_TABLE (chartable, 0); + + return XCHAR_TABLE (chartable)->parent; +} + +DEFUN ("set-char-table-parent", Fset_char_table_parent, Sset_char_table_parent, + 2, 2, 0, + "Set the parent char-table of CHAR-TABLE to PARENT.\n\ +PARENT must be either nil or another char-table.") + (chartable, parent) + Lisp_Object chartable, parent; +{ + Lisp_Object temp; + + CHECK_CHAR_TABLE (chartable, 0); + CHECK_CHAR_TABLE (parent, 0); + + for (temp = parent; !NILP (temp); temp = XCHAR_TABLE (temp)->parent) + if (EQ (temp, chartable)) + error ("Attempt to make a chartable be its own parent"); + + XCHAR_TABLE (chartable)->parent = parent; + + return parent; +} + +DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot, + 2, 2, 0, + "Return the value in extra-slot number N of char-table CHAR-TABLE.") + (chartable, n) + Lisp_Object chartable, n; +{ + CHECK_CHAR_TABLE (chartable, 1); + CHECK_NUMBER (n, 2); + if (XINT (n) < 0 + || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (chartable))) + args_out_of_range (chartable, n); + + return XCHAR_TABLE (chartable)->extras[XINT (n)]; +} + +DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot, + Sset_char_table_extra_slot, + 3, 3, 0, + "Set extra-slot number N of CHAR-TABLE to VALUE.") + (chartable, n, value) + Lisp_Object chartable, n, value; +{ + CHECK_CHAR_TABLE (chartable, 1); + CHECK_NUMBER (n, 2); + if (XINT (n) < 0 + || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (chartable))) + args_out_of_range (chartable, n); + + return XCHAR_TABLE (chartable)->extras[XINT (n)] = value; +} + +DEFUN ("set-char-table-range", Fset_char_table_range, Sset_char_table_range, + 3, 3, 0, + "Set the value in CHARTABLE for a range of characters RANGE to VALUE.\n\ +RANGE should be t (for all characters), nil (for the default value)\n\ +a vector which identifies a character set or a row of a character set,\n\ +or a character code.") + (chartable, range, value) + Lisp_Object chartable, range, value; +{ + int i; + + CHECK_CHAR_TABLE (chartable, 0); + + if (EQ (range, Qt)) + for (i = 0; i < CHAR_TABLE_ORDINARY_SLOTS; i++) + XCHAR_TABLE (chartable)->contents[i] = value; + else if (EQ (range, Qnil)) + XCHAR_TABLE (chartable)->defalt = value; + else if (INTEGERP (range)) + Faset (chartable, range, value); + else if (VECTORP (range)) + { + for (i = 0; i < XVECTOR (range)->size - 1; i++) + chartable = Faref (chartable, XVECTOR (range)->contents[i]); + + if (EQ (XVECTOR (range)->contents[i], Qnil)) + XCHAR_TABLE (chartable)->defalt = value; + else + Faset (chartable, XVECTOR (range)->contents[i], value); + } + else + error ("Invalid RANGE argument to `set-char-table-range'"); + + return value; +} + +static void +map_char_table (function, chartable, depth, indices) + Lisp_Object function, chartable, depth, *indices; +{ + int i; + int size = XCHAR_TABLE (chartable)->size; + + /* Make INDICES longer if we are about to fill it up. */ + if ((depth % 10) == 9) + { + Lisp_Object *new_indices + = (Lisp_Object *) alloca ((depth += 10) * sizeof (Lisp_Object)); + bcopy (indices, new_indices, depth * sizeof (Lisp_Object)); + indices = new_indices; + } + + for (i = 0; i < size; i++) + { + Lisp_Object elt; + indices[depth] = i; + elt = XCHAR_TABLE (chartable)->contents[i]; + if (!CHAR_TABLE_P (elt)) + call2 (function, Fvector (depth + 1, indices), elt); + else + map_char_table (chartable, function, depth + 1, indices); + } +} + +DEFUN ("map-char-table", Fmap_char_table, Smap_char_table, + 2, 2, 0, + "Call FUNCTION for each range of like characters in CHARTABLE.\n\ +FUNCTION is called with two arguments--a key and a value.\n\ +The key is always a possible RANGE argument to `set-char-table-range'.") + (function, chartable) + Lisp_Object function, chartable; +{ + Lisp_Object keyvec; + Lisp_Object *indices = (Lisp_Object *) alloca (10 * sizeof (Lisp_Object)); + + map_char_table (function, chartable, 0, indices); + return Qnil; +} + /* ARGSUSED */ Lisp_Object nconc2 (s1, s2) @@ -1570,6 +1804,12 @@ Used by `featurep' and `require', and altered by `provide'."); defsubr (&Sput); defsubr (&Sequal); defsubr (&Sfillarray); + defsubr (&Schar_table_parent); + defsubr (&Sset_char_table_parent); + defsubr (&Schar_table_extra_slot); + defsubr (&Sset_char_table_extra_slot); + defsubr (&Sset_char_table_range); + defsubr (&Smap_char_table); defsubr (&Snconc); defsubr (&Smapcar); defsubr (&Smapconcat); -- 2.39.2