changeset 13140:99c5d39b9531

(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.

--- a/src/fns.c	Sat Oct 07 16:07:24 1995 +0000
+++ b/src/fns.c	Sat Oct 07 21:52:15 1995 +0000
@@ -106,6 +106,10 @@
     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 @@
      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 @@
     {
       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 @@
 	      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 @@
     {
       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 @@
 	   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 @@
 }
 
 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 @@
       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 @@
       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 @@
   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 @@
   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);