xemacs-beta: src/elhash.c comparison

comparison src/elhash.c @ 223:2c611d1463a6 r20-4b10

Import from CVS: tag r20-4b10

author	cvs
date	Mon, 13 Aug 2007 10:10:54 +0200
parents	78478c60bfcd
children	557eaa0339bf

comparison

equal deleted inserted replaced

-:aae4c8b01452
+:2c611d1463a6
 /* Lisp interface to hash tables.
 Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
 Copyright (C) 1995, 1996 Ben Wing.
+Copyright (C) 1997 Free Software Foundation, Inc.
 This file is part of XEmacs.
 XEmacs is free software; you can redistribute it and/or modify it
 under the terms of the GNU General Public License as published by the
 #include "lisp.h"
 #include "hash.h"
 #include "elhash.h"
 #include "bytecode.h"
-Lisp_Object Qhashtablep;
+Lisp_Object Qhashtablep, Qhashtable;
+Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qnon_weak;
 #define LISP_OBJECTS_PER_HENTRY (sizeof (hentry) / sizeof (Lisp_Object))/* 2 */
 struct hashtable
 {
 return Qnil;
 }
 ((markobj) (table->zero_entry));
 return table->harray;
 }
+/* Printing hashtables.
+This is non-trivial, because we use a readable structure-style
+syntax for hashtables.  This means that a typical hashtable will be
+readably printed in the form of:
+#s(hashtable size 2 data (key1 value1 key2 value2))
+The supported keywords are `type' (non-weak (or nil), weak,
+key-weak and value-weak), `test' (eql (or nil), eq or equal),
+`size' (a natnum or nil) and `data' (a list).
+If `print-readably' is non-nil, then a simpler syntax is used; for
+instance:
+#<hashtable size 2/13 data (key1 value1 key2 value2) 0x874d>
+The data is truncated to four pairs, and the rest is shown with
+`...'.  The actual printer is non-consing.  */
+struct print_mapper_arg {
+EMACS_INT count;		/* Used to implement the truncation
+				   for non-readable printing, as well
+				   as to avoid the unnecessary space
+				   at the beginning.  */
+Lisp_Object printcharfun;
+};
+static void
+print_hashtable_data_mapper (void *key, void *contents, void *arg)
+{
+Lisp_Object keytem, valuetem;
+struct print_mapper_arg *closure = (struct print_mapper_arg *)arg;
+if (closure->count < 4 || print_readably)
+{
+CVOID_TO_LISP (keytem, key);
+CVOID_TO_LISP (valuetem, contents);
+if (closure->count)
+	write_c_string (" ", closure->printcharfun);
+print_internal (keytem, closure->printcharfun, 1);
+write_c_string (" ", closure->printcharfun);
+print_internal (valuetem, closure->printcharfun, 1);
+}
+++closure->count;
+}
+/* Print the data of the hashtable.  This maps through a Lisp
+hashtable and prints key/value pairs using PRINTCHARFUN.  */
+static void
+print_hashtable_data (Lisp_Object hashtable, Lisp_Object printcharfun)
+{
+struct print_mapper_arg closure;
+closure.count = 0;
+closure.printcharfun = printcharfun;
+write_c_string (" data (", printcharfun);
+elisp_maphash (print_hashtable_data_mapper, hashtable, &closure);
+write_c_string ((!print_readably && closure.count > 4) ? " ...)" : ")",
+		  printcharfun);
+}
+/* Needed for tests.  */
+static int lisp_object_eql_equal (CONST void *x1, CONST void *x2);
+static int lisp_object_equal_equal (CONST void *x1, CONST void *x2);
 static void
 print_hashtable (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 {
 struct hashtable *table = XHASHTABLE (obj);
-char buf[200];
+char buf[128];
+write_c_string (print_readably ? "#s(hashtable" : "#<hashtable",
+		  printcharfun);
+if (table->type != HASHTABLE_NONWEAK)
+{
+sprintf (buf, " type %s",
+	       (table->type == HASHTABLE_WEAK ? "weak" :
+		table->type == HASHTABLE_KEY_WEAK ? "key-weak" :
+		table->type == HASHTABLE_VALUE_WEAK ? "value-weak" :
+		"you-d-better-not-see-this"));
+write_c_string (buf, printcharfun);
+}
+/* These checks are way kludgy... */
+if (table->test_function == NULL)
+write_c_string (" test eq", printcharfun);
+else if (table->test_function == lisp_object_equal_equal)
+write_c_string (" test equal", printcharfun);
+else if (table->test_function == lisp_object_eql_equal)
+;
+else
+abort ();
+if (table->fullness || !print_readably)
+{
+if (print_readably)
+	sprintf (buf, " size %d", table->fullness);
+else
+	sprintf (buf, " size %u/%ld", table->fullness,
+		 XVECTOR_LENGTH (table->harray) / LISP_OBJECTS_PER_HENTRY);
+write_c_string (buf, printcharfun);
+}
+if (table->fullness)
+print_hashtable_data (obj, printcharfun);
 if (print_readably)
-error ("printing unreadable object #<hashtable 0x%x>",
+write_c_string (")", printcharfun);
-	   table->header.uid);
+else
-sprintf (buf, GETTEXT ("#<%shashtable %d/%ld 0x%x>"),
+{
-	   (table->type == HASHTABLE_WEAK ? "weak " :
+sprintf (buf, " 0x%x>", table->header.uid);
-	    table->type == HASHTABLE_KEY_WEAK ? "key-weak " :
+write_c_string (buf, printcharfun);
-	    table->type == HASHTABLE_VALUE_WEAK ? "value-weak " :
+}
-	    table->type == HASHTABLE_KEY_CAR_WEAK ? "key-car-weak " :
+}
-	    table->type == HASHTABLE_VALUE_CAR_WEAK ? "value-car-weak " :
-	    ""),
-table->fullness,
+/* Pretty reading of hashtables.
-XVECTOR_LENGTH (table->harray) / LISP_OBJECTS_PER_HENTRY,
-table->header.uid);
+Here we use the existing structures mechanism (which is,
-write_c_string (buf, printcharfun);
+unfortunately, pretty cumbersome) for validating and instantiating
-}
+the hashtables.  The idea is that the side-effect of reading a
+#s(hashtable PLIST) object is creation of a hashtable with desired
+properties, and that the hashtable is returned.  */
+/* Validation functions: each keyword provides its own validation
+function.  The errors should maybe be continuable, but it is
+unclear how this would cope with ERRB.  */
+static int
+hashtable_type_validate (Lisp_Object keyword, Lisp_Object value,
+			 Error_behavior errb)
+{
+if (!(NILP (value)
+	|| EQ (value, Qnon_weak)
+	|| EQ (value, Qweak)
+	|| EQ (value, Qkey_weak)
+	|| EQ (value, Qvalue_weak)))
+{
+maybe_signal_simple_error ("Invalid hashtable type", value,
+				 Qhashtable, errb);
+return 0;
+}
+return 1;
+}
+static int
+hashtable_test_validate (Lisp_Object keyword, Lisp_Object value,
+			 Error_behavior errb)
+{
+if (!(NILP (value)
+	|| EQ (value, Qeq)
+	|| EQ (value, Qeql)
+	|| EQ (value, Qequal)))
+{
+maybe_signal_simple_error ("Invalid hashtable test", value,
+				 Qhashtable, errb);
+return 0;
+}
+return 1;
+}
+static int
+hashtable_size_validate (Lisp_Object keyword, Lisp_Object value,
+			 Error_behavior errb)
+{
+if (!NATNUMP (value))
+{
+maybe_signal_error (Qwrong_type_argument, list2 (Qnatnump, value),
+			  Qhashtable, errb);
+return 0;
+}
+return 1;
+}
+static int
+hashtable_data_validate (Lisp_Object keyword, Lisp_Object value,
+			 Error_behavior errb)
+{
+int num = 0;
+Lisp_Object tail;
+/* #### Doesn't respect ERRB!  */
+EXTERNAL_LIST_LOOP (tail, value)
+{
+++num;
+QUIT;
+}
+if (num & 1)
+{
+maybe_signal_simple_error
+	("Hashtable data must have alternating keyword/value pairs", value,
+	 Qhashtable, errb);
+return 0;
+}
+return 1;
+}
+/* The actual instantiation of hashtable.  This does practically no
+error checking, because it relies on the fact that the paranoid
+functions above have error-checked everything to the last details.
+If this assumption is wrong, we will get a crash immediately (with
+error-checking compiled in), and we'll know if there is a bug in
+the structure mechanism.  So there.  */
+static Lisp_Object
+hashtable_instantiate (Lisp_Object plist)
+{
+/* I'm not sure whether this can GC, but better safe than sorry.  */
+Lisp_Object hashtab = Qnil;
+Lisp_Object type = Qnil, test = Qnil, size = Qnil, data = Qnil;
+Lisp_Object key, value;
+struct gcpro gcpro1;
+GCPRO1 (hashtab);
+while (!NILP (plist))
+{
+key = XCAR (plist);
+plist = XCDR (plist);
+value = XCAR (plist);
+plist = XCDR (plist);
+if (EQ (key, Qtype))
+	type = value;
+else if (EQ (key, Qtest))
+	test = value;
+else if (EQ (key, Qsize))
+	size = value;
+else if (EQ (key, Qdata))
+	data = value;
+else
+	abort ();
+}
+if (NILP (type))
+type = Qnon_weak;
+if (NILP (size))
+{
+/* Divide by two, because data is a plist. */
+XSETINT (size, XINT (Flength (data)) / 2);
+}
+/* Create the hashtable.  */
+if (EQ (type, Qnon_weak))
+hashtab = Fmake_hashtable (size, test);
+else if (EQ (type, Qweak))
+hashtab = Fmake_weak_hashtable (size, test);
+else if (EQ (type, Qkey_weak))
+hashtab = Fmake_key_weak_hashtable (size, test);
+else if (EQ (type, Qvalue_weak))
+hashtab = Fmake_value_weak_hashtable (size, test);
+else
+abort ();
+/* And fill it with data.  */
+while (!NILP (data))
+{
+key = XCAR (data);
+data = XCDR (data);
+value = XCAR (data);
+data = XCDR (data);
+Fputhash (key, value, hashtab);
+}
+UNGCPRO;
+return hashtab;
+}
+/* Initialize the hashtable as a structure type.  This is called from
+emacs.c.  */
+void
+structure_type_create_hashtable (void)
+{
+struct structure_type *st;
+st = define_structure_type (Qhashtable, 0, hashtable_instantiate);
+define_structure_type_keyword (st, Qtype, hashtable_type_validate);
+define_structure_type_keyword (st, Qtest, hashtable_test_validate);
+define_structure_type_keyword (st, Qsize, hashtable_size_validate);
+define_structure_type_keyword (st, Qdata, hashtable_data_validate);
+}
+/* Basic conversion and allocation functions. */
+/* Create a C hashtable from the data in the Lisp hashtable.  The
+actual vector is not copied, nor are the keys or values copied.  */
 static void
 ht_copy_to_c (struct hashtable *ht, c_hashtable c_table)
 {
 int len = XVECTOR_LENGTH (ht->harray);
 static void
 verify_function (Lisp_Object function, CONST char *description)
 {
+/* #### Unused DESCRIPTION?  */
 if (SYMBOLP (function))
 {
 if (NILP (function))
 return;
 else
 }
 if (SUBRP (function) || COMPILED_FUNCTIONP (function))
 return;
 else if (CONSP (function))
 {
-Lisp_Object funcar = Fcar (function);
+Lisp_Object funcar = XCAR (function);
 if ((SYMBOLP (funcar)) && (EQ (funcar, Qlambda) ||
 			       EQ (funcar, Qautoload)))
 return;
 }
 signal_error (Qinvalid_function, list1 (function));
 	   here because we know that everything *in* it is already marked,
 	   we just need to prevent the vector itself from disappearing.)
 	   (The remhash above has taken care of zero_entry.)
 	   */
 	struct Lisp_Vector *ptr = XVECTOR (XHASHTABLE (rest)->harray);
-	int len = vector_length (ptr);
 #ifdef LRECORD_VECTOR
 	if (! MARKED_RECORD_P(XHASHTABLE(rest)->harray))
 	  {
 	    MARK_RECORD_HEADER(&(ptr->header.lheader));
 	    did_mark = 1;
 	  }
 #else
+	int len = vector_length (ptr);
 	if (len >= 0)
 	  {
 	    ptr->size = -1 - len;
 	    did_mark = 1;
 	  }
 DEFSUBR (Fhashtable_fullness);
 DEFSUBR (Fmake_weak_hashtable);
 DEFSUBR (Fmake_key_weak_hashtable);
 DEFSUBR (Fmake_value_weak_hashtable);
 defsymbol (&Qhashtablep, "hashtablep");
+defsymbol (&Qhashtable, "hashtable");
+defsymbol (&Qweak, "weak");
+defsymbol (&Qkey_weak, "key-weak");
+defsymbol (&Qvalue_weak, "value-weak");
+defsymbol (&Qnon_weak, "non-weak");
 }
 void
 vars_of_elhash (void)
 {

Mercurial > hg > xemacs-beta

comparison src/elhash.c @ 223:2c611d1463a6 r20-4b10