From xemacs-m  Mon Jun 23 01:47:27 1997
Received: from jagor.srce.hr (hniksic@jagor.srce.hr [161.53.2.130])
	by xemacs.org (8.8.5/8.8.5) with ESMTP id BAA26338
	for <xemacs-beta@xemacs.org>; Mon, 23 Jun 1997 01:47:26 -0500 (CDT)
Received: (from hniksic@localhost)
          by jagor.srce.hr (8.8.5/8.8.4)
	  id IAA05947; Mon, 23 Jun 1997 08:47:25 +0200 (MET DST)
To: XEmacs Developers <xemacs-beta@xemacs.org>
Subject: Ferror_message_string properly implemented
X-Attribution: Hrv
X-Face: Mie8:rOV<\c/~z{s.X4A{!?vY7{drJ([U]0O=W/<W*SMo/Mv:58:*_y~ki>xDi&N7XG
        KV^$k0m3Oe/)'e%3=$PCR&3ITUXH,cK>]bci&<qQ>Ff%x_>1`T(+M2Gg/fgndU%k*ft
        [(7._6e0n-V%|%'[c|q:;}td$#INd+;?!-V=c8Pqf}3J
From: Hrvoje Niksic <hniksic@srce.hr>
Date: 23 Jun 1997 08:47:24 +0200
Message-ID: <kigafkholxf.fsf@jagor.srce.hr>
Lines: 220
X-Mailer: Gnus v5.4.59/XEmacs 20.3(beta8) - "Copenhagen"

Here is a treat for all the XEmacs lovers.  I have looked at
Ferror_message_string, and something stroke me as quite unusual --
primarily the face that this function is never called by anything, and 
neither is print_error_message.  So how /does/ XEmacs print its
messages?

A little bit of investigation (which included `grep -i peculiar *')
showed that XEmacs has a Lisp equivalent of print_error_message called
`display-message' in cmdloop.el -- but much much more flexible, of
course.  Since that function should be callable from
Ferror_message_string, I have ported it to C (to print_error_message)
and made Fdisplay_string a trivial wrapper around print_error_message.

A patch for print.c follows.  Note that all of this probably has
nothing to do with debug-ignored-errors crashes.  I have tested this
rather well, but the function was tricky (for me), so I would like you 
to bang on it.

--- src/print.c.orig	Mon Jun 23 01:35:36 1997
+++ src/print.c	Mon Jun 23 08:35:14 1997
@@ -84,6 +84,9 @@
 Lisp_Object Qprint_escape_newlines;
 Lisp_Object Qprint_readably;
 
+Lisp_Object Qdisplay_error;
+Lisp_Object Qprint_message_label;
+
 /* Force immediate output of all printed data.  Used for debugging. */
 int print_unbuffered;
 
@@ -591,16 +594,19 @@
   UNGCPRO;
   return obj;
 }
+
 
 #include "emacsfns.h"
-/* Synched with Emacs 19.34 */
+
+/* Synched with Emacs 19.34 -- underlying implementation (incarnated
+   in print_error_message) is completely divergent, though.  */
 DEFUN ("error-message-string", Ferror_message_string, 1, 1, 0, /*
 Convert an error value (ERROR-SYMBOL . DATA) to an error message.
 */
   (obj))
 {
   struct buffer *old = XBUFFER(Fcurrent_buffer());
-  Lisp_Object original, printcharfun, value;
+  Lisp_Object printcharfun, value;
   struct gcpro gcpro1;
 
   print_error_message (obj, Vprin1_to_string_buffer);
@@ -618,56 +624,108 @@
   return value;
 }
 
-/* Print an error message for the error DATA
-   onto Lisp output stream STREAM (suitable for the print functions).  */
+/* Print an error message for the error DATA onto Lisp output stream
+   STREAM (suitable for the print functions).
 
-static void print_error_message (Lisp_Object data, Lisp_Object stream)
+   This is a complete implementation of `display-error', which used to
+   be in Lisp (see prim/cmdloop.el).  It was ported to C so we can use
+   it in Ferror_message_string.  Fdisplay_error and
+   Ferror_message_string are trivial wrappers to this function.  */
+static void
+print_error_message (Lisp_Object error_object, Lisp_Object stream)
 {
-  Lisp_Object errname, errmsg, file_error, tail;
+  Lisp_Object type;
+  Lisp_Object method = Qnil;
+  Lisp_Object tail = Qnil;
   struct gcpro gcpro1;
-  int i;
 
-  errname = Fcar (data);
+  GCPRO1 (tail);
+
+  type = Fcar_safe (error_object);
+
+  if (! (CONSP (error_object) && SYMBOLP (type)
+	 && CONSP (Fget (type, Qerror_conditions, Qnil))))
+    goto error_throw;
 
-  if (EQ (errname, Qerror))
+  tail = XCDR (error_object);
+  while (!NILP (tail))
     {
-      data = Fcdr (data);
-      if (!CONSP (data)) data = Qnil;
-      errmsg = Fcar (data);
-      file_error = Qnil;
+      if (CONSP (tail))
+	tail = XCDR (tail);
+      else
+	goto error_throw;
     }
-  else
+  tail = Fget (type, Qerror_conditions, Qnil);
+  while (!NILP (tail))
     {
-      errmsg = Fget (errname, Qerror_message, Qnil);
-      file_error = Fmemq (Qfile_error,
-			  Fget (errname, Qerror_conditions, Qnil));
+      if (!(CONSP (tail) && SYMBOLP (XCAR (tail))))
+	goto error_throw;
+      else if (!NILP (Fget (XCAR (tail), Qdisplay_error, Qnil)))
+	{
+	  method = Fget (XCAR (tail), Qdisplay_error, Qnil);
+	  goto error_throw;
+	}
+      else
+	tail = XCDR (tail);
     }
+  /* Default method */
+  {
+    int first = 1;
+    Lisp_Object printcharfun = canonicalize_printcharfun (stream);
+    int speccount = specpdl_depth ();
+
+    specbind (Qprint_message_label, Qerror);
+    tail = Fcdr (error_object);
+    if (EQ (type, Qerror))
+      {
+	Fprinc (Fcar (tail), stream);
+	tail = Fcdr (tail);
+      }
+    else
+      {
+	Lisp_Object errmsg = Fget (type, Qerror_message, Qnil);
+	if (NILP (errmsg))
+	  Fprinc (type, stream);
+	else
+	  Fprinc (errmsg, stream);
+      }
+    while (!NILP (tail))
+      {
+	write_c_string (first ? ": " : ", ", printcharfun);
+	Fprin1 (Fcar (tail), stream);
+	tail = Fcdr (tail);
+	first = 0;
+      }
+    unbind_to (speccount, Qnil);
+    UNGCPRO;
+    return;
+    /* Unreached */
+  }
 
-  /* Print an error message including the data items.  */
-
-  tail = Fcdr_safe (data);
-  GCPRO1 (tail);
-
-  /* For file-error, make error message by concatenating
-     all the data items.  They are all strings.  */
-  if (!NILP (file_error) && !NILP (tail))
-    errmsg = XCONS (tail)->car, tail = XCONS (tail)->cdr;
-
-  if (STRINGP (errmsg))
-    Fprinc (errmsg, stream);
+ error_throw:
+  UNGCPRO;
+  if (NILP (method))
+    {
+      write_c_string ("Peculiar error ",
+		      canonicalize_printcharfun (stream));
+      Fprin1 (error_object, stream);
+      return;
+    }
   else
-    write_string_1 ((CONST Bufbyte *)"Peculiar error", 14, stream);
-
-  for (i = 0; CONSP (tail); tail = Fcdr (tail), i++)
     {
-      write_string_1 ((CONST Bufbyte *)(i ? ", " : ": "), 2, stream);
-      if (!NILP (file_error))
-	Fprinc (Fcar (tail), stream);
-      else
-	Fprin1 (Fcar (tail), stream);
+      call2 (method, error_object, stream);
     }
-  UNGCPRO;
 }
+
+DEFUN ("display-error", Fdisplay_error, 2, 2, 0, /*
+Display an error message for ERROR-OBJECT to STREAM.
+*/
+       (error_object, stream))
+{
+  print_error_message (error_object, stream);
+  return Qnil;
+}
+
 
 #ifdef LISP_FLOAT_TYPE
 
@@ -1511,11 +1569,16 @@
   defsymbol (&Qprint_length, "print-length");
 
   defsymbol (&Qprint_string_length, "print-string-length");
+
+  defsymbol (&Qdisplay_error, "display-error");
+  defsymbol (&Qprint_message_label, "print-message-label");
+
   DEFSUBR (Fprin1);
   DEFSUBR (Fprin1_to_string);
   DEFSUBR (Fprinc);
   DEFSUBR (Fprint);
   DEFSUBR (Ferror_message_string);
+  DEFSUBR (Fdisplay_error);
   DEFSUBR (Fterpri);
   DEFSUBR (Fwrite_char);
   DEFSUBR (Falternate_debugging_output);


-- 
Hrvoje Niksic <hniksic@srce.hr> | Student at FER Zagreb, Croatia
--------------------------------+--------------------------------
I'm sure they'll listen to reason! -- Neal Stevenson, _Snow Crash_

