From xemacs-m  Mon Jul  7 19:21:49 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 TAA09570
	for <xemacs-beta@xemacs.org>; Mon, 7 Jul 1997 19:21:48 -0500 (CDT)
Received: (from hniksic@localhost)
          by jagor.srce.hr (8.8.5/8.8.4)
	  id CAA07061; Tue, 8 Jul 1997 02:21:46 +0200 (MET DST)
To: XEmacs Developers <xemacs-beta@xemacs.org>
Subject: [PATCH] Ferror_message_string
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: 08 Jul 1997 02:21:46 +0200
Message-ID: <kigiuymtmud.fsf@jagor.srce.hr>
Lines: 310
X-Mailer: Gnus v5.4.59/XEmacs 20.3(beta11) - "Stockholm"

The old patch to implement Ferror_message_string correctly will no
longer apply.  Here is the updated version.  Apply the patch,
byte-recompile lisp/prim/cmdloop.el and build XEmacs.

--- src/print.c.orig	Mon Jun 30 01:14:18 1997
+++ src/print.c	Tue Jul  8 02:15:21 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;
 
@@ -593,14 +596,17 @@
 }
 
 #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.
 */
   (data))
 {
+  /* This function can GC */
   struct buffer *pbuf;
-  Lisp_Object original, printcharfun, value;
+  Lisp_Object value;
   struct gcpro gcpro1;
 
   print_error_message (data, Vprin1_to_string_buffer);
@@ -616,56 +622,110 @@
   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;
+  /* This function can GC */
+  Lisp_Object type;
+  Lisp_Object method = Qnil;
+  Lisp_Object tail = Qnil;
   struct gcpro gcpro1;
-  int i;
 
-  errname = Fcar (data);
+  GCPRO1 (tail);
 
-  if (EQ (errname, Qerror))
+  type = Fcar_safe (error_object);
+
+  if (! (CONSP (error_object) && SYMBOLP (type)
+	 && CONSP (Fget (type, Qerror_conditions, Qnil))))
+    goto error_throw;
+
+  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))
+{
+  /* This function can GC */
+  print_error_message (error_object, stream);
+  return Qnil;
+}
+
 
 #ifdef LISP_FLOAT_TYPE
 
@@ -1509,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);
--- lisp/prim/cmdloop.el.orig	Tue Jul  8 02:20:22 1997
+++ lisp/prim/cmdloop.el	Tue Jul  8 02:20:26 1997
@@ -164,53 +164,54 @@
 
 ;;;; Object-oriented programming at its finest
 
-(defun display-error (error-object stream) ;(defgeneric report-condition ...)
-  "Display `error-object' on `stream' in a user-friendly way."
-  (funcall (or (let ((type (car-safe error-object)))
-                 (catch 'error
-                   (and (consp error-object)
-                        (symbolp type)
-                        ;;(stringp (get type 'error-message))
-			(consp (get type 'error-conditions))
-                        (let ((tail (cdr error-object)))
-                          (while (not (null tail))
-                            (if (consp tail)
-                                (setq tail (cdr tail))
-                                (throw 'error nil)))
-                          t)
-                        ;; (check-type condition condition)
-                        (get type 'error-conditions)
-                        ;; Search class hierarchy
-                        (let ((tail (get type 'error-conditions)))
-                          (while (not (null tail))
-                            (cond ((not (and (consp tail)
-                                             (symbolp (car tail))))
-                                   (throw 'error nil))
-                                  ((get (car tail) 'display-error)
-                                   (throw 'error (get (car tail)
-                                                      'display-error)))
-                                  (t
-                                   (setq tail (cdr tail)))))
-                          ;; Default method
-                          #'(lambda (error-object stream)
-                              (let ((type (car error-object))
-                                    (tail (cdr error-object))
-                                    (first t)
-				    (print-message-label 'error))
-                                (if (eq type 'error)
-                                    (progn (princ (car tail) stream)
-                                           (setq tail (cdr tail)))
-				  (princ (or (gettext (get type 'error-message)) type)
-					 stream))
-                                (while tail
-                                  (princ (if first ": " ", ") stream)
-                                  (prin1 (car tail) stream)
-                                  (setq tail (cdr tail)
-                                        first nil))))))))
-	       #'(lambda (error-object stream)
-                   (princ (gettext "Peculiar error ") stream)
-                   (prin1 error-object stream)))
-           error-object stream))
+;; Now in src/print.c; used by Ferror_message_string and others
+;(defun display-error (error-object stream) ;(defgeneric report-condition ...)
+;  "Display `error-object' on `stream' in a user-friendly way."
+;  (funcall (or (let ((type (car-safe error-object)))
+;                 (catch 'error
+;                   (and (consp error-object)
+;                        (symbolp type)
+;                        ;;(stringp (get type 'error-message))
+;			(consp (get type 'error-conditions))
+;                        (let ((tail (cdr error-object)))
+;                          (while (not (null tail))
+;                            (if (consp tail)
+;                                (setq tail (cdr tail))
+;                                (throw 'error nil)))
+;                          t)
+;                        ;; (check-type condition condition)
+;                        (get type 'error-conditions)
+;                        ;; Search class hierarchy
+;                        (let ((tail (get type 'error-conditions)))
+;                          (while (not (null tail))
+;                            (cond ((not (and (consp tail)
+;                                             (symbolp (car tail))))
+;                                   (throw 'error nil))
+;                                  ((get (car tail) 'display-error)
+;                                   (throw 'error (get (car tail)
+;                                                      'display-error)))
+;                                  (t
+;                                   (setq tail (cdr tail)))))
+;                          ;; Default method
+;                          #'(lambda (error-object stream)
+;                              (let ((type (car error-object))
+;                                    (tail (cdr error-object))
+;                                    (first t)
+;				    (print-message-label 'error))
+;                                (if (eq type 'error)
+;                                    (progn (princ (car tail) stream)
+;                                           (setq tail (cdr tail)))
+;				  (princ (or (gettext (get type 'error-message)) type)
+;					 stream))
+;                                (while tail
+;                                  (princ (if first ": " ", ") stream)
+;                                  (prin1 (car tail) stream)
+;                                  (setq tail (cdr tail)
+;                                        first nil))))))))
+;	       #'(lambda (error-object stream)
+;                   (princ (gettext "Peculiar error ") stream)
+;                   (prin1 error-object stream)))
+;           error-object stream))
 
 (put 'file-error 'display-error
      #'(lambda (error-object stream)


-- 
Hrvoje Niksic <hniksic@srce.hr> | Student at FER Zagreb, Croatia
--------------------------------+--------------------------------
Oh lord won't you buy me a color TV...

