Re: hash-table-{to, from}-alist

[Ted Zlatanov]

The attached patch does print and read of hashtables.  It respects
print-length only, exactly like vector print and consistent with the
rest of GNU Emacs.  Please review and comment.  Some notes:

I ended up with this code to put a list into Fmake_hash_table format
('params' is a Lisp_Object that holds a bunch of conses).

              int param_count = 0;
              Lisp_Object *pa = (Lisp_Object*) 
xmalloc(XFASTINT(Flength(params)) * sizeof(Lisp_Object));

              while (!NILP(params))
                {
                  pa[param_count++] = CAR_SAFE(params);
                  params = CDR_SAFE(params);
                }

              Lisp_Object ht = Fmake_hash_table(param_count, pa);

I would prefer it if I could avoid all that work, but it seems (from
reading lisp.h and hunting for similar code) that it must be done as
above.  I don't see a macro to convert a Lisp_Object that holds a list
into the Lisp_Object* that a lot of functions need.

Also I don't know if what xmalloc() gives needs to be freed eventually.

To generate the Lisp symbol ":size" from the symbol "size" for example,
I used:

Lisp_Object colon = make_string (":", 1);
intern(SDATA(concat2(colon, SYMBOL_NAME(head))))

I don't know if there's a better way, but this works.

Thanks!
Ted

? hashprint.patch
Index: lread.c
===================================================================
RCS file: /sources/emacs/emacs/src/lread.c,v
retrieving revision 1.401
diff -u -r1.401 lread.c
--- lread.c     7 Sep 2008 20:41:10 -0000       1.401
+++ lread.c     2 Dec 2008 20:46:34 -0000
@@ -80,6 +80,13 @@
 extern int errno;
 #endif
 
+/* hash table read constants */
+Lisp_Object Qhash_table_read_marker, Qhash_table_data_marker;
+Lisp_Object Qhash_table_test_marker, Qhash_table_size_marker;
+Lisp_Object Qhash_table_weakness_marker;
+Lisp_Object Qhash_table_rehash_size_marker;
+Lisp_Object Qhash_table_rehash_threshold_marker;
+
 Lisp_Object Qread_char, Qget_file_char, Qstandard_input, Qcurrent_load_list;
 Lisp_Object Qvariable_documentation, Vvalues, Vstandard_input, 
Vafter_load_alist;
 Lisp_Object Qascii_character, Qload, Qload_file_name;
@@ -2341,6 +2348,94 @@
 
     case '#':
       c = READCHAR;
+      if (c == 's')
+       {
+         c = READCHAR;
+         if (c == '(')
+           {
+             /*
+               Accept extended format for hashtables (extensible to
+               other types), e.g.
+               #s(hash-table size 2 test equal data (k1 v1 k2 v2))          
+             */
+             Lisp_Object tmp = read_list (0, readcharfun);
+             Lisp_Object head = CAR_SAFE(tmp);
+             Lisp_Object data = Qnil;
+             Lisp_Object val = Qnil;
+             Lisp_Object params = Qnil;
+             Lisp_Object colon = make_string (":", 1);
+             
+             if (!EQ (head, Qhash_table_read_marker))
+               error ("Invalid extended read marker at head of #s list"
+                      "(only hash-table allowed)");
+
+             while (!NILP(tmp))
+               {
+                 tmp = CDR_SAFE(tmp);
+                 head = CAR_SAFE(tmp);
+                 /* allowed parameters: size test weakness
+                    rehash-size rehash-threshold */
+                 if (EQ(head, Qhash_table_data_marker))
+                   {
+                     tmp = CDR_SAFE(tmp);
+                     data = CAR_SAFE(tmp);
+                   }
+
+                 if (
+                     EQ(head, Qhash_table_size_marker) ||
+                     EQ(head, Qhash_table_test_marker) ||
+                     EQ(head, Qhash_table_weakness_marker) ||
+                     EQ(head, Qhash_table_rehash_size_marker) ||
+                     EQ(head, Qhash_table_rehash_threshold_marker))
+                   {
+                     tmp = CDR_SAFE(tmp);
+                     val = CAR_SAFE(tmp);
+                     params = Fcons(val, params);
+                     params = Fcons(intern(SDATA(concat2(colon,
+                                                         SYMBOL_NAME(head)))),
+                                    params);
+                     debug_print(params);
+                     /*
+                       debug_print(head);
+                       debug_print(val);
+                     */
+                   }
+               }
+
+             if (NILP(data))
+               error ("No data marker was found in the hash table");
+
+             int param_count = 0;
+             Lisp_Object *pa = (Lisp_Object*) 
xmalloc(XFASTINT(Flength(params)) * sizeof(Lisp_Object));
+
+             while (!NILP(params))
+               {
+                 pa[param_count++] = CAR_SAFE(params);
+                 params = CDR_SAFE(params);
+               }
+
+             Lisp_Object ht = Fmake_hash_table(param_count, pa);
+
+             Lisp_Object key = Qnil;
+             
+             while (!NILP(data))
+               {
+                 key = CAR_SAFE(data);
+                 data = CDR_SAFE(data);
+                 val = CAR_SAFE(data);
+                 data = CDR_SAFE(data);
+                 if (NILP(val))
+                   error ("Odd number of elements in hashtable data");
+                 /*
+                   debug_print(key);
+                   debug_print(val);
+                 */
+                 Fputhash(key, val, ht);
+               }
+             
+             return ht;
+           }   
+       }
       if (c == '^')
        {
          c = READCHAR;
@@ -4432,6 +4527,21 @@
 
   Vloads_in_progress = Qnil;
   staticpro (&Vloads_in_progress);
+
+  Qhash_table_read_marker = intern ("hash-table");
+  staticpro (&Qhash_table_read_marker);
+  Qhash_table_data_marker = intern ("data");
+  staticpro (&Qhash_table_data_marker);
+  Qhash_table_test_marker = intern ("test");
+  staticpro (&Qhash_table_size_marker);
+  Qhash_table_test_marker = intern ("size");
+  staticpro (&Qhash_table_size_marker);
+  Qhash_table_weakness_marker = intern ("weakness");
+  staticpro (&Qhash_table_weakness_marker);
+  Qhash_table_rehash_size_marker = intern ("rehash-size");
+  staticpro (&Qhash_table_rehash_size_marker);
+  Qhash_table_rehash_threshold_marker = intern ("rehash-threshold");
+  staticpro (&Qhash_table_rehash_threshold_marker);
 }
 
 /* arch-tag: a0d02733-0f96-4844-a659-9fd53c4f414d
Index: print.c
===================================================================
RCS file: /sources/emacs/emacs/src/print.c,v
retrieving revision 1.253
diff -u -r1.253 print.c
--- print.c     31 Jul 2008 05:33:53 -0000      1.253
+++ print.c     2 Dec 2008 20:46:34 -0000
@@ -1341,6 +1341,7 @@
  loop:
   if (STRINGP (obj) || CONSP (obj) || VECTORP (obj)
       || COMPILEDP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj)
+      || HASH_TABLE_P (obj)
       || (! NILP (Vprint_gensym)
          && SYMBOLP (obj)
          && !SYMBOL_INTERNED_P (obj)))
@@ -1536,6 +1537,7 @@
   /* Detect circularities and truncate them.  */
   if (STRINGP (obj) || CONSP (obj) || VECTORP (obj)
       || COMPILEDP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj)
+      || HASH_TABLE_P (obj)
       || (! NILP (Vprint_gensym)
          && SYMBOLP (obj)
          && !SYMBOL_INTERNED_P (obj)))
@@ -2036,6 +2038,7 @@
       else if (HASH_TABLE_P (obj))
        {
          struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
+#if 0
          strout ("#<hash-table", -1, -1, printcharfun, 0);
          if (SYMBOLP (h->test))
            {
@@ -2052,6 +2055,68 @@
          sprintf (buf, " 0x%lx", (unsigned long) h);
          strout (buf, -1, -1, printcharfun, 0);
          PRINTCHAR ('>');
+#endif
+         /*
+           implement a readable output, e.g.:
+           #s(hash-table size 2 test equal data (k1 v1 k2 v2))
+         */
+         /* always print the size */
+         sprintf (buf, "#s(hash-table size %ld", (long) XVECTOR 
(h->next)->size);
+         strout (buf, -1, -1, printcharfun, 0);
+
+         if (!NILP(h->test))
+           {
+             strout (" test ", -1, -1, printcharfun, 0);
+             print_object (h->test, printcharfun, 0);
+           }
+
+         if (!NILP(h->weak))
+           {
+             strout (" weakness ", -1, -1, printcharfun, 0);
+             print_object (h->weak, printcharfun, 0);
+           }
+
+         if (!NILP(h->rehash_size))
+           {
+             strout (" rehash-size ", -1, -1, printcharfun, 0);
+             print_object (h->rehash_size, printcharfun, 0);
+           }
+
+         if (!NILP(h->rehash_threshold))
+           {
+             strout (" rehash-threshold ", -1, -1, printcharfun, 0);
+             print_object (h->rehash_threshold, printcharfun, 0);
+           }
+
+         strout (" data ", -1, -1, printcharfun, 0);
+
+         /* print the data here as a plist */
+         int i;
+
+         int real_size = HASH_TABLE_SIZE (h);
+         int size = real_size;
+
+         /* Don't print more elements than the specified maximum.  */
+         if (NATNUMP (Vprint_length)
+             && XFASTINT (Vprint_length) < size)
+           size = XFASTINT (Vprint_length);
+         
+         PRINTCHAR ('(');
+         for (i = 0; i < size; i++)
+           if (!NILP (HASH_HASH (h, i)))
+             {
+               if (i) PRINTCHAR (' ');
+               print_object (HASH_KEY (h, i), printcharfun, 0);
+               PRINTCHAR (' ');
+               print_object (HASH_VALUE (h, i), printcharfun, 0);
+             }
+
+         if (size < real_size)
+           strout (" ...", 4, 4, printcharfun, 0);
+
+         PRINTCHAR (')');
+         PRINTCHAR (')');
+
        }
       else if (BUFFERP (obj))
        {