diff src/print.c @ 5133:444a448b2f53

Merge branch ben-lisp-object into default branch
author Ben Wing <ben@xemacs.org>
date Sun, 07 Mar 2010 06:47:37 -0600
parents a9c41067dd88
children f965e31a35f0
line wrap: on
line diff
--- a/src/print.c	Sun Mar 07 06:43:19 2010 -0600
+++ b/src/print.c	Sun Mar 07 06:47:37 2010 -0600
@@ -1539,61 +1539,50 @@
 DOESNT_RETURN
 printing_unreadable_lcrecord (Lisp_Object obj, const Ibyte *name)
 {
-  struct LCRECORD_HEADER *header = (struct LCRECORD_HEADER *) XPNTR (obj);
+  NORMAL_LISP_OBJECT_HEADER *header = (NORMAL_LISP_OBJECT_HEADER *) XPNTR (obj);
+  const struct lrecord_implementation *imp =
+    XRECORD_LHEADER_IMPLEMENTATION (obj);
 
 #ifndef NEW_GC
   /* This must be a real lcrecord */
-  assert (!LHEADER_IMPLEMENTATION (&header->lheader)->basic_p);
+  assert (!imp->frob_block_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);
+    printing_unreadable_object ("#<%s %s 0x%x>", imp->name, name, header->uid);
   else
-    printing_unreadable_object
-      ("#<%s 0x%x>",
-#ifdef NEW_GC
-       LHEADER_IMPLEMENTATION (header)->name,
-#else /* not NEW_GC */
-       LHEADER_IMPLEMENTATION (&header->lheader)->name,
-#endif /* not NEW_GC */
-       header->uid);
+    printing_unreadable_object ("#<%s 0x%x>", imp->name, header->uid);
 }
 
 void
-default_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
-			int UNUSED (escapeflag))
+external_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
+			 int UNUSED (escapeflag))
 {
-  struct LCRECORD_HEADER *header = (struct LCRECORD_HEADER *) XPNTR (obj);
+  NORMAL_LISP_OBJECT_HEADER *header = (NORMAL_LISP_OBJECT_HEADER *) XPNTR (obj);
+  const struct lrecord_implementation *imp =
+    XRECORD_LHEADER_IMPLEMENTATION (obj);
 
 #ifndef NEW_GC
   /* This must be a real lcrecord */
-  assert (!LHEADER_IMPLEMENTATION (&header->lheader)->basic_p);
+  assert (!imp->frob_block_p);
 #endif
 
   if (print_readably)
     printing_unreadable_lcrecord (obj, 0);
 
-  write_fmt_string (printcharfun, "#<%s 0x%x>",
-#ifdef NEW_GC
-		    LHEADER_IMPLEMENTATION (header)->name,
-#else /* not NEW_GC */
-		    LHEADER_IMPLEMENTATION (&header->lheader)->name,
-#endif /* not NEW_GC */
-		    header->uid);
+  write_fmt_string (printcharfun, "#<%s 0x%x>", imp->name, header->uid);
 }
 
 void
 internal_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
 			 int UNUSED (escapeflag))
 {
+  if (print_readably)
+    printing_unreadable_object
+      ("#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>",
+       XRECORD_LHEADER_IMPLEMENTATION (obj)->name,
+       (unsigned long) XPNTR (obj));
+
   /* Internal objects shouldn't normally escape to the Lisp level;
      that's why we say "XEmacs bug?".  This can happen, however, when
      printing backtraces. */
@@ -1935,11 +1924,13 @@
 	      }
 	  }
 
-	if (LHEADER_IMPLEMENTATION (lheader)->printer)
-	  ((LHEADER_IMPLEMENTATION (lheader)->printer)
-	   (obj, printcharfun, escapeflag));
-	else
-	  internal_object_printer (obj, printcharfun, escapeflag);
+	/* Either use a custom-written printer, or use
+	   internal_object_printer or external_object_printer, depending on
+	   whether the object is internal (not visible at Lisp level) or
+	   external. */
+	assert (LHEADER_IMPLEMENTATION (lheader)->printer);
+	((LHEADER_IMPLEMENTATION (lheader)->printer)
+	 (obj, printcharfun, escapeflag));
 	break;
       }
 
@@ -2446,7 +2437,7 @@
 	debug_out ("#<%s addr=0x%lx uid=0x%lx>",
 		   LHEADER_IMPLEMENTATION (header)->name,
 		   (EMACS_INT) header,
-		   (EMACS_INT) (LHEADER_IMPLEMENTATION (header)->basic_p ?
+		   (EMACS_INT) (LHEADER_IMPLEMENTATION (header)->frob_block_p ?
 				((struct lrecord_header *) header)->uid :
 				((struct old_lcrecord_header *) header)->uid));
 #endif /* not NEW_GC */