Mercurial > hg > xemacs-beta

changeset 4846:a98ca4640147

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
clean up object print methods casetab.c, console.c, data.c, database.c, device-msw.c, device.c, eval.c, file-coding.c, frame.c, glyphs.c, gui.c, keymap.c, lisp.h, mule-charset.c, objects.c, print.c, process.c, tooltalk.c, ui-gtk.c, window.c: New function printing_unreadable_lcrecord(). Automatically prints the type name and pointer value of the object. Use it instead of printing_unreadable_object(); make that latter function local to print.c. window.c: During creation, window may have Qt as its buffer. Don't crash if trying to print such a window.
author Ben Wing <ben@xemacs.org>
date Wed, 13 Jan 2010 05:49:13 -0600
parents a3c673c0720b
children 05c519de7353
files src/ChangeLog src/casetab.c src/console.c src/data.c src/database.c src/device-msw.c src/device.c src/eval.c src/file-coding.c src/frame.c src/glyphs.c src/gui.c src/keymap.c src/lisp.h src/mule-charset.c src/objects.c src/print.c src/process.c src/tooltalk.c src/ui-gtk.c src/window.c
diffstat 21 files changed, 138 insertions(+), 68 deletions(-) [+]
line wrap: on
line diff
--- a/src/ChangeLog	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/ChangeLog	Wed Jan 13 05:49:13 2010 -0600
@@ -1,3 +1,47 @@
+2010-01-13  Ben Wing  <ben@xemacs.org>
+
+	* casetab.c (print_case_table):
+	* console.c (print_console):
+	* data.c (print_weak_list):
+	* data.c (print_weak_box):
+	* data.c (print_ephemeron):
+	* data.c (ephemeron_equal):
+	* database.c (print_database):
+	* device-msw.c (print_devmode):
+	* device.c (print_device):
+	* eval.c:
+	* file-coding.c (print_coding_system):
+	* frame.c (print_frame):
+	* glyphs.c (print_image_instance):
+	* glyphs.c (print_glyph):
+	* gui.c:
+	* gui.c (print_gui_item):
+	* keymap.c (print_keymap):
+	* lisp.h:
+	* mule-charset.c (print_charset):
+	* objects.c (print_color_instance):
+	* objects.c (print_font_instance):
+	* print.c:
+	* print.c (printing_unreadable_object):
+	* print.c (printing_unreadable_lcrecord):
+	* print.c (default_object_printer):
+	* process.c (print_process):
+	* tooltalk.c:
+	* tooltalk.c (print_tooltalk_message):
+	* tooltalk.c (print_tooltalk_pattern):
+	* ui-gtk.c (ffi_object_printer):
+	* ui-gtk.c (emacs_gtk_object_printer):
+	* ui-gtk.c (emacs_gtk_boxed_printer):
+	* window.c (print_window):
+	New function printing_unreadable_lcrecord().  Automatically
+	prints the type name and pointer value of the object.  Use it
+	instead of printing_unreadable_object(); make that latter
+	function local to print.c.
+
+	* window.c (print_window):
+	During creation, window may have Qt as its buffer. Don't
+	crash if trying to print such a window.
+
 2010-01-13  Ben Wing  <ben@xemacs.org>
 
 	* dynarr.c:
--- a/src/casetab.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/casetab.c	Wed Jan 13 05:49:13 2010 -0600
@@ -105,7 +105,7 @@
 {
   Lisp_Case_Table *ct = XCASE_TABLE (obj);
   if (print_readably)
-    printing_unreadable_object ("#<case-table 0x%x>", ct->header.uid);
+    printing_unreadable_lcrecord (obj, 0);
   write_fmt_string_lisp
     (printcharfun, "#<case-table downcase=%s upcase=%s canon=%s eqv=%s ", 4,
      CASE_TABLE_DOWNCASE (ct), CASE_TABLE_UPCASE (ct),
--- a/src/console.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/console.c	Wed Jan 13 05:49:13 2010 -0600
@@ -169,8 +169,7 @@
   struct console *con = XCONSOLE (obj);
 
   if (print_readably)
-    printing_unreadable_object ("#<console %s 0x%x>",
-				XSTRING_DATA (con->name), con->header.uid);
+    printing_unreadable_lcrecord (obj, XSTRING_DATA (con->name));
 
   write_fmt_string (printcharfun, "#<%s-console",
 		    !CONSOLE_LIVE_P (con) ? "dead" : CONSOLE_TYPE_NAME (con));
--- a/src/data.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/data.c	Wed Jan 13 05:49:13 2010 -0600
@@ -2592,7 +2592,7 @@
 		 int UNUSED (escapeflag))
 {
   if (print_readably)
-    printing_unreadable_object ("#<weak-list>");
+    printing_unreadable_lcrecord (obj, 0);
 
   write_fmt_string_lisp (printcharfun, "#<weak-list %s %S>", 2,
 			 encode_weak_list_type (XWEAK_LIST (obj)->type),
@@ -3067,12 +3067,12 @@
 }
 
 static void
-print_weak_box (Lisp_Object UNUSED (obj), Lisp_Object printcharfun,
+print_weak_box (Lisp_Object obj, Lisp_Object printcharfun,
 		int UNUSED (escapeflag))
 {
   if (print_readably)
-    printing_unreadable_object ("#<weak_box>");
-  write_fmt_string (printcharfun, "#<weak_box>");
+    printing_unreadable_lcrecord (obj, 0);
+  write_fmt_string (printcharfun, "#<weak-box>"); /* #### fix */
 }
 
 static int
@@ -3293,12 +3293,12 @@
 }
 
 static void
-print_ephemeron (Lisp_Object UNUSED (obj), Lisp_Object printcharfun,
+print_ephemeron (Lisp_Object obj, Lisp_Object printcharfun,
 		 int UNUSED (escapeflag))
 {
   if (print_readably)
-    printing_unreadable_object ("#<ephemeron>");
-  write_fmt_string (printcharfun, "#<ephemeron>");
+    printing_unreadable_lcrecord (obj, 0);
+  write_fmt_string (printcharfun, "#<ephemeron>"); /* #### fix */
 }
 
 static int
--- a/src/database.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/database.c	Wed Jan 13 05:49:13 2010 -0600
@@ -216,7 +216,7 @@
   Lisp_Database *db = XDATABASE (obj);
 
   if (print_readably)
-    printing_unreadable_object ("#<database 0x%x>", db->header.uid);
+    printing_unreadable_lcrecord (obj, 0);
 
   write_fmt_string_lisp (printcharfun, "#<database \"%s\" (%s/%s/",
 			 3, db->fname, db->funcs->get_type (db),
--- a/src/device-msw.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/device-msw.c	Wed Jan 13 05:49:13 2010 -0600
@@ -1154,8 +1154,7 @@
 {
   Lisp_Devmode *dm = XDEVMODE (obj);
   if (print_readably)
-    printing_unreadable_object ("#<msprinter-settings 0x%x>",
-				dm->header.uid);
+    printing_unreadable_lcrecord (obj, 0);
   write_c_string (printcharfun, "#<msprinter-settings");
   if (!NILP (dm->printer_name))
     write_fmt_string_lisp (printcharfun, " for %S", 1, dm->printer_name);
--- a/src/device.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/device.c	Wed Jan 13 05:49:13 2010 -0600
@@ -160,8 +160,7 @@
   struct device *d = XDEVICE (obj);
 
   if (print_readably)
-    printing_unreadable_object ("#<device %s 0x%x>",
-				XSTRING_DATA (d->name), d->header.uid);
+    printing_unreadable_lcrecord (obj, XSTRING_DATA (d->name));
 
   write_fmt_string (printcharfun, "#<%s-device", !DEVICE_LIVE_P (d) ? "dead" :
 		    DEVICE_TYPE_NAME (d));
--- a/src/eval.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/eval.c	Wed Jan 13 05:49:13 2010 -0600
@@ -3140,20 +3140,6 @@
   signal_error (Qout_of_memory, reason, frob);
 }
 
-DOESNT_RETURN
-printing_unreadable_object (const CIbyte *fmt, ...)
-{
-  Lisp_Object obj;
-  va_list args;
-
-  va_start (args, fmt);
-  obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
-  va_end (args);
-
-  /* Fsignal GC-protects its args */
-  signal_error (Qprinting_unreadable_object, 0, obj);
-}
-
 
 /************************************************************************/
 /*			      User commands				*/
--- a/src/file-coding.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/file-coding.c	Wed Jan 13 05:49:13 2010 -0600
@@ -297,8 +297,7 @@
 {
   Lisp_Coding_System *c = XCODING_SYSTEM (obj);
   if (print_readably)
-    printing_unreadable_object
-      ("printing unreadable object #<coding-system 0x%x>", c->header.uid);
+    printing_unreadable_lcrecord (obj, 0);
 
   write_fmt_string_lisp (printcharfun, "#<coding-system %s ", 1, c->name);
   print_coding_system_properties (obj, printcharfun);
--- a/src/frame.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/frame.c	Wed Jan 13 05:49:13 2010 -0600
@@ -274,8 +274,7 @@
   struct frame *frm = XFRAME (obj);
 
   if (print_readably)
-    printing_unreadable_object ("#<frame %s 0x%x>",
-				XSTRING_DATA (frm->name), frm->header.uid);
+    printing_unreadable_lcrecord (obj, XSTRING_DATA (frm->name));
 
   write_fmt_string (printcharfun, "#<%s-frame ", !FRAME_LIVE_P (frm) ? "dead" :
 		    FRAME_TYPE_NAME (frm));
--- a/src/glyphs.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/glyphs.c	Wed Jan 13 05:49:13 2010 -0600
@@ -992,8 +992,7 @@
   Lisp_Image_Instance *ii = XIMAGE_INSTANCE (obj);
 
   if (print_readably)
-    printing_unreadable_object ("#<image-instance 0x%x>",
-	   ii->header.uid);
+    printing_unreadable_lcrecord (obj, 0);
   write_fmt_string_lisp (printcharfun, "#<image-instance (%s) ", 1,
 			 Fimage_instance_type (obj));
   if (!NILP (ii->name))
@@ -3693,7 +3692,7 @@
   Lisp_Glyph *glyph = XGLYPH (obj);
 
   if (print_readably)
-    printing_unreadable_object ("#<glyph 0x%x>", glyph->header.uid);
+    printing_unreadable_lcrecord (obj, 0);
 
   write_fmt_string_lisp (printcharfun, "#<glyph (%s", 1, Fglyph_type (obj));
   write_fmt_string_lisp (printcharfun, ") %S", 1, glyph->image);
--- a/src/gui.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/gui.c	Wed Jan 13 05:49:13 2010 -0600
@@ -696,7 +696,7 @@
   Lisp_Gui_Item *g = XGUI_ITEM (obj);
 
   if (print_readably)
-    printing_unreadable_object ("#<gui-item 0x%x>", g->header.uid);
+    printing_unreadable_lcrecord (obj, 0);
 
   write_fmt_string (printcharfun, "#<gui-item 0x%x>", g->header.uid);
 }
--- a/src/keymap.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/keymap.c	Wed Jan 13 05:49:13 2010 -0600
@@ -289,7 +289,7 @@
   /* This function can GC */
   Lisp_Keymap *keymap = XKEYMAP (obj);
   if (print_readably)
-    printing_unreadable_object ("#<keymap 0x%x>", keymap->header.uid);
+    printing_unreadable_lcrecord (obj, 0);
   write_c_string (printcharfun, "#<keymap ");
   if (!NILP (keymap->name))
     {
--- a/src/lisp.h	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/lisp.h	Wed Jan 13 05:49:13 2010 -0600
@@ -4716,9 +4716,6 @@
 						 Lisp_Object frob));
 DECLARE_DOESNT_RETURN (stack_overflow (const CIbyte *reason,
 				       Lisp_Object frob));
-MODULE_API DECLARE_DOESNT_RETURN (printing_unreadable_object (const CIbyte *,
-							      ...))
-       PRINTF_ARGS (1, 2);
 
 Lisp_Object signal_void_function_error (Lisp_Object);
 Lisp_Object signal_invalid_function_error (Lisp_Object);
@@ -5326,6 +5323,11 @@
 						 Lisp_Object, Lisp_Object);
 void float_to_string (char *, double);
 void internal_object_printer (Lisp_Object, Lisp_Object, int);
+MODULE_API DECLARE_DOESNT_RETURN (printing_unreadable_object (const CIbyte *,
+							      ...))
+       PRINTF_ARGS (1, 2);
+DECLARE_DOESNT_RETURN (printing_unreadable_lcrecord (Lisp_Object obj,
+						     const Ibyte *name));
 
 /* Defined in rangetab.c */
 EXFUN (Fclear_range_table, 1);
--- a/src/mule-charset.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/mule-charset.c	Wed Jan 13 05:49:13 2010 -0600
@@ -141,10 +141,8 @@
   Lisp_Charset *cs = XCHARSET (obj);
 
   if (print_readably)
-    printing_unreadable_object ("#<charset %s 0x%x>",
-				XSTRING_DATA (XSYMBOL (CHARSET_NAME (cs))->
-					     name),
-				cs->header.uid);
+    printing_unreadable_lcrecord
+      (obj, XSTRING_DATA (XSYMBOL (XCHARSET_NAME (obj))->name));
 
   write_fmt_string_lisp (printcharfun, "#<charset %s %S %S %S", 4,
 			 CHARSET_NAME (cs), CHARSET_SHORT_NAME (cs),
--- a/src/objects.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/objects.c	Wed Jan 13 05:49:13 2010 -0600
@@ -102,8 +102,7 @@
 {
   Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj);
   if (print_readably)
-    printing_unreadable_object ("#<color-instance 0x%x>",
-	   c->header.uid);
+    printing_unreadable_lcrecord (obj, 0);
   write_fmt_string_lisp (printcharfun, "#<color-instance %s", 1, c->name);
   write_fmt_string_lisp (printcharfun, " on %s", 1, c->device);
   if (!NILP (c->device)) /* Vthe_null_color_instance */
@@ -319,7 +318,7 @@
 {
   Lisp_Font_Instance *f = XFONT_INSTANCE (obj);
   if (print_readably)
-    printing_unreadable_object ("#<font-instance 0x%x>", f->header.uid);
+    printing_unreadable_lcrecord (obj, 0);
   write_fmt_string_lisp (printcharfun, "#<font-instance %S", 1, f->name);
   write_fmt_string_lisp (printcharfun, " on %s", 1, f->device);
   if (!NILP (f->device))
--- a/src/print.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/print.c	Wed Jan 13 05:49:13 2010 -0600
@@ -1485,13 +1485,41 @@
   UNGCPRO;
 }
 
-void
-default_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
-			int UNUSED (escapeflag))
+DOESNT_RETURN
+printing_unreadable_object (const CIbyte *fmt, ...)
+{
+  Lisp_Object obj;
+  va_list args;
+
+  va_start (args, fmt);
+  obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
+  va_end (args);
+
+  /* Fsignal GC-protects its args */
+  signal_error (Qprinting_unreadable_object, 0, obj);
+}
+
+DOESNT_RETURN
+printing_unreadable_lcrecord (Lisp_Object obj, const Ibyte *name)
 {
   struct LCRECORD_HEADER *header = (struct LCRECORD_HEADER *) XPNTR (obj);
 
-  if (print_readably)
+#ifndef NEW_GC
+  /* This must be a real lcrecord */
+  assert (!LHEADER_IMPLEMENTATION (&header->lheader)->basic_p);
+#endif
+
+  if (name)
+    printing_unreadable_object
+      ("#<%s %s 0x%x>",
+#ifdef NEW_GC
+       LHEADER_IMPLEMENTATION (header)->name,
+#else /* not NEW_GC */
+       LHEADER_IMPLEMENTATION (&header->lheader)->name,
+#endif /* not NEW_GC */
+       name,
+       header->uid);
+  else
     printing_unreadable_object
       ("#<%s 0x%x>",
 #ifdef NEW_GC
@@ -1500,6 +1528,21 @@
        LHEADER_IMPLEMENTATION (&header->lheader)->name,
 #endif /* not NEW_GC */
        header->uid);
+}
+
+void
+default_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
+			int UNUSED (escapeflag))
+{
+  struct LCRECORD_HEADER *header = (struct LCRECORD_HEADER *) XPNTR (obj);
+
+#ifndef NEW_GC
+  /* This must be a real lcrecord */
+  assert (!LHEADER_IMPLEMENTATION (&header->lheader)->basic_p);
+#endif
+
+  if (print_readably)
+    printing_unreadable_lcrecord (obj, 0);
 
   write_fmt_string (printcharfun, "#<%s 0x%x>",
 #ifdef NEW_GC
--- a/src/process.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/process.c	Wed Jan 13 05:49:13 2010 -0600
@@ -145,12 +145,12 @@
 }
 
 static void
-print_process (Lisp_Object object, Lisp_Object printcharfun, int escapeflag)
+print_process (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 {
-  Lisp_Process *process = XPROCESS (object);
+  Lisp_Process *process = XPROCESS (obj);
 
   if (print_readably)
-    printing_unreadable_object ("#<process %s>", XSTRING_DATA (process->name));
+    printing_unreadable_lcrecord (obj, XSTRING_DATA (process->name));
 
   if (!escapeflag)
     {
@@ -158,7 +158,7 @@
     }
   else
     {
-      int netp = network_connection_p (object);
+      int netp = network_connection_p (obj);
       write_c_string (printcharfun,
 		      netp ? GETTEXT ("#<network connection ") :
 		      GETTEXT ("#<process "));
--- a/src/tooltalk.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/tooltalk.c	Wed Jan 13 05:49:13 2010 -0600
@@ -172,10 +172,9 @@
   Lisp_Tooltalk_Message *p = XTOOLTALK_MESSAGE (obj);
 
   if (print_readably)
-    printing_unreadable_object ("#<tooltalk_message 0x%x>",
-				p->header.uid);
+    printing_unreadable_lcrecord (obj, 0);
 
-  write_fmt_string (printcharfun, "#<tooltalk_message id:0x%lx 0x%x>",
+  write_fmt_string (printcharfun, "#<tooltalk-message id:0x%lx 0x%x>",
 		    (long) (p->m), p->header.uid);
 }
 
@@ -250,10 +249,9 @@
   Lisp_Tooltalk_Pattern *p = XTOOLTALK_PATTERN (obj);
 
   if (print_readably)
-    printing_unreadable_object ("#<tooltalk_pattern 0x%x>",
-				p->header.uid);
+    printing_unreadable_lcrecord (obj, 0);
 
-  write_fmt_string (printcharfun, "#<tooltalk_pattern id:0x%lx 0x%x>",
+  write_fmt_string (printcharfun, "#<tooltalk-pattern id:0x%lx 0x%x>",
 		    (long) (p->p), p->header.uid);
 }
 
--- a/src/ui-gtk.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/ui-gtk.c	Wed Jan 13 05:49:13 2010 -0600
@@ -326,7 +326,7 @@
 		    int UNUSED (escapeflag))
 {
   if (print_readably)
-    printing_unreadable_object ("#<ffi %p>", XFFI (obj)->function_ptr);
+    printing_unreadable_lcrecord (obj, 0);
 
   write_fmt_string_lisp (printcharfun, "#<ffi %S", 1, XFFI (obj)->function_name);
   if (XFFI (obj)->n_args)
@@ -796,7 +796,7 @@
 			  int UNUSED (escapeflag))
 {
   if (print_readably)
-    printing_unreadable_object ("#<GtkObject %p>", XGTK_OBJECT (obj)->object);
+    printing_unreadable_lcrecord (obj, 0);
 
   write_c_string (printcharfun, "#<GtkObject (");
   if (XGTK_OBJECT (obj)->alive_p)
@@ -1115,7 +1115,7 @@
 			 int UNUSED (escapeflag))
 {
   if (print_readably)
-    printing_unreadable_object ("#<GtkBoxed %p>", XGTK_BOXED (obj)->object);
+    printing_unreadable_lcrecord (obj, 0);
 
   write_c_string (printcharfun, "#<GtkBoxed (");
   write_c_string (printcharfun, gtk_type_name (XGTK_BOXED (obj)->object_type));
--- a/src/window.c	Wed Jan 13 04:25:15 2010 -0600
+++ b/src/window.c	Wed Jan 13 05:49:13 2010 -0600
@@ -313,13 +313,19 @@
 print_window (Lisp_Object obj, Lisp_Object printcharfun,
 	      int UNUSED (escapeflag))
 {
+  Lisp_Object buf;
+
   if (print_readably)
-    printing_unreadable_object ("#<window 0x%x>", XWINDOW (obj)->header.uid);
+    printing_unreadable_lcrecord (obj, 0);
 
   write_c_string (printcharfun, "#<window");
-  if (!NILP (XWINDOW (obj)->buffer))
+  buf = XWINDOW_BUFFER (obj);
+  if (EQ (buf, Qt))
+    write_c_string (printcharfun, " during creation");
+  else if (!NILP (buf))
     {
-      Lisp_Object name = XBUFFER (XWINDOW (obj)->buffer)->name;
+      
+      Lisp_Object name = XBUFFER (buf)->name;
       write_fmt_string_lisp (printcharfun, " on %S", 1, name);
     }
   write_fmt_string (printcharfun, " 0x%x>", XWINDOW (obj)->header.uid);