emacs: src/data.c comparison

comparison src/data.c @ 13148:18b1b690defe

(Fchartablep, Fboolvectorp): New functions. (syms_of_data): defsubr them. (Faref, Faset, Fsequencep): Handle chartables and boolvectors.

author	Richard M. Stallman <rms@gnu.org>
date	Sat, 07 Oct 1995 22:04:15 +0000
parents	ed5b91dd829a
children	5fd4e8e4185a

comparison

equal deleted inserted replaced

-:bd9ff4ee6cd4
+:18b1b690defe
 Lisp_Object Qintegerp, Qnatnump, Qwholenump, Qsymbolp, Qlistp, Qconsp;
 Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
 Lisp_Object Qbuffer_or_string_p;
 Lisp_Object Qboundp, Qfboundp;
+Lisp_Object Qchar_table_p;
 Lisp_Object Qcdr;
 Lisp_Object Qad_advice_info, Qad_activate;
 Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error;
 if (STRINGP (object))
 return Qt;
 return Qnil;
 }
+DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0, "T if OBJECT is a char-table.")
+(object)
+Lisp_Object object;
+{
+if (CHAR_TABLE_P (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0, "T if OBJECT is a bool-vector.")
+(object)
+Lisp_Object object;
+{
+if (BOOL_VECTOR_P (object))
+return Qt;
+return Qnil;
+}
 DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "T if OBJECT is an array (string or vector).")
 (object)
 Lisp_Object object;
 {
 if (VECTORP (object) || STRINGP (object))
 DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
 "T if OBJECT is a sequence (list or array).")
 (object)
 register Lisp_Object object;
 {
-if (CONSP (object) || NILP (object) || VECTORP (object) || STRINGP (object))
+if (CONSP (object) || NILP (object) || VECTORP (object) || STRINGP (object)
+|| CHAR_TABLE_P (object) || BOOL_VECTOR_P (object))
 return Qt;
 return Qnil;
 }
 DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, "T if OBJECT is an editor buffer.")
 /* Extract and set vector and string elements */
 DEFUN ("aref", Faref, Saref, 2, 2, 0,
 "Return the element of ARRAY at index INDEX.\n\
-ARRAY may be a vector or a string, or a byte-code object.  INDEX starts at 0.")
+ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
+or a byte-code object.  INDEX starts at 0.")
 (array, idx)
 register Lisp_Object array;
 Lisp_Object idx;
 {
 register int idxval;
 Lisp_Object val;
 if (idxval < 0 || idxval >= XSTRING (array)->size)
 	args_out_of_range (array, idx);
 XSETFASTINT (val, (unsigned char) XSTRING (array)->data[idxval]);
 return val;
+}
+else if (BOOL_VECTOR_P (array))
+{
+int val;
+int bits_per_char = INTBITS / sizeof (int);
+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);
+}
+else if (CHAR_TABLE_P (array))
+{
+Lisp_Object val;
+if (idxval < 0)
+	args_out_of_range (array, idx);
+#if 1
+if ((unsigned) idxval >= CHAR_TABLE_ORDINARY_SLOTS)
+	args_out_of_range (array, idx);
+return val = XCHAR_TABLE (array)->contents[idxval];
+#else /* 0 */
+if ((unsigned) idxval < CHAR_TABLE_ORDINARY_SLOTS)
+	val = XCHAR_TABLE (array)->data[idxval];
+else
+	{
+	  int charset;
+	  unsigned char c1, c2;
+	  Lisp_Object val, temp;
+	  BREAKUP_NON_ASCII_CHAR (idxval, charset, c1, c2);
+	try_parent_char_table:
+	  val = XCHAR_TABLE (array)->contents[charset];
+	  if (c1 == 0 || !CHAR_TABLE_P (val))
+	    return val;
+	  temp = XCHAR_TABLE (val)->contents[c1];
+	  if (NILP (temp))
+	    val = XCHAR_TABLE (val)->defalt;
+	  else
+	    val = temp;
+	  if (NILP (val) && !NILP (XCHAR_TABLE (array)->parent))
+	    {
+	      array = XCHAR_TABLE (array)->parent;
+	      goto try_parent_char_table;
+	    }
+	  if (c2 == 0 || !CHAR_TABLE_P (val))
+	    return val;
+	  temp = XCHAR_TABLE (val)->contents[c2];
+	  if (NILP (temp))
+	    val = XCHAR_TABLE (val)->defalt;
+	  else
+	    val = temp;
+	  if (NILP (val) && !NILP (XCHAR_TABLE (array)->parent))
+	    {
+	      array = XCHAR_TABLE (array)->parent;
+	      goto try_parent_char_table;
+	    }
+	  return val;
+	}
+#endif /* 0 */
 }
 else
 {
 int size;
 if (VECTORP (array))
 {
 register int idxval;
 CHECK_NUMBER (idx, 1);
 idxval = XINT (idx);
-if (!VECTORP (array) && !STRINGP (array))
+if (!VECTORP (array) && !STRINGP (array) && !BOOL_VECTOR_P (array)
+&& ! CHAR_TABLE_P (array))
 array = wrong_type_argument (Qarrayp, array);
 CHECK_IMPURE (array);
 if (VECTORP (array))
 {
 if (idxval < 0 || idxval >= XVECTOR (array)->size)
 	args_out_of_range (array, idx);
 XVECTOR (array)->contents[idxval] = newelt;
+}
+else if (BOOL_VECTOR_P (array))
+{
+int val;
+int bits_per_char = INTBITS / sizeof (int);
+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];
+if (! NILP (newelt))
+	val |= 1 << (idxval % bits_per_char);
+else
+	val &= ~(1 << (idxval % bits_per_char));
+XBOOL_VECTOR (array)->data[idxval / bits_per_char] = val;
+}
+else if (CHAR_TABLE_P (array))
+{
+Lisp_Object val;
+if (idxval < 0)
+	args_out_of_range (array, idx);
+#if 1
+if (idxval >= CHAR_TABLE_ORDINARY_SLOTS)
+	args_out_of_range (array, idx);
+XCHAR_TABLE (array)->contents[idxval] = newelt;
+return newelt;
+#else /* 0 */
+if (idxval < CHAR_TABLE_ORDINARY_SLOTS)
+	val = XCHAR_TABLE (array)->contents[idxval];
+else
+	{
+	  int charset;
+	  unsigned char c1, c2;
+	  Lisp_Object val, val2;
+	  BREAKUP_NON_ASCII_CHAR (idxval, charset, c1, c2);
+	  if (c1 == 0)
+	    return XCHAR_TABLE (array)->contents[charset] = newelt;
+	  val = XCHAR_TABLE (array)->contents[charset];
+	  if (!CHAR_TABLE_P (val))
+	    XCHAR_TABLE (array)->contents[charset]
+	      = val = Fmake_char_table (Qnil);
+	  if (c2 == 0)
+	    return XCHAR_TABLE (val)->contents[c1] = newelt;
+	  val2 = XCHAR_TABLE (val)->contents[c2];
+	  if (!CHAR_TABLE_P (val2))
+	    XCHAR_TABLE (val)->contents[charset]
+	      = val2 = Fmake_char_table (Qnil);
+	  return XCHAR_TABLE (val2)->contents[c2] = newelt;
+	}
+#endif /* 0 */
 }
 else
 {
 if (idxval < 0 || idxval >= XSTRING (array)->size)
 	args_out_of_range (array, idx);
 Qfloatp = intern ("floatp");
 Qnumberp = intern ("numberp");
 Qnumber_or_marker_p = intern ("number-or-marker-p");
 #endif /* LISP_FLOAT_TYPE */
+Qchar_table_p = intern ("char-table-p");
 Qcdr = intern ("cdr");
 /* Handle automatic advice activation */
 Qad_advice_info = intern ("ad-advice-info");
 Qad_activate = intern ("ad-activate");
 #ifdef LISP_FLOAT_TYPE
 staticpro (&Qfloatp);
 staticpro (&Qnumberp);
 staticpro (&Qnumber_or_marker_p);
 #endif /* LISP_FLOAT_TYPE */
+staticpro (&Qchar_table_p);
 staticpro (&Qboundp);
 staticpro (&Qfboundp);
 staticpro (&Qcdr);
 staticpro (&Qad_advice_info);
 #endif /* LISP_FLOAT_TYPE */
 defsubr (&Snatnump);
 defsubr (&Ssymbolp);
 defsubr (&Sstringp);
 defsubr (&Svectorp);
+defsubr (&Schar_table_p);
+defsubr (&Sbool_vector_p);
 defsubr (&Sarrayp);
 defsubr (&Ssequencep);
 defsubr (&Sbufferp);
 defsubr (&Smarkerp);
 defsubr (&Ssubrp);

Mercurial > emacs

comparison src/data.c @ 13148:18b1b690defe