From xemacs-m  Mon Jun 23 03:09:23 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 DAA27042
	for <xemacs-beta@xemacs.org>; Mon, 23 Jun 1997 03:09:22 -0500 (CDT)
Received: (from hniksic@localhost)
          by jagor.srce.hr (8.8.5/8.8.4)
	  id KAA17329; Mon, 23 Jun 1997 10:09:07 +0200 (MET DST)
To: wing@666.com
Cc: XEmacs Developers <xemacs-beta@xemacs.org>
Subject: `display-error-message'
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 10:09:07 +0200
Message-ID: <kig4tapoi58.fsf@jagor.srce.hr>
Lines: 111
X-Mailer: Gnus v5.4.59/XEmacs 20.3(beta8) - "Copenhagen"

Various code needs the ability to get the error message string for a
particular error (for example, porting `debug-ignored-errors' from
FSF).  Steve ported Ferror_message_string from FSF to 19.15, but it
calls print_error_message -- another function from FSF.  Now,
print_error_message is a poor-man's version of our `display-message'.
To be usable by Ferror_message_string, I ported display-message to C.

Is there a particular reason why it should remain in Lisp?  For
reference, here is my implementation of Fdisplay_message (which should 
be pretty much equivalent to the original):


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;
}

static void
print_error_message (Lisp_Object error_object, Lisp_Object stream)
{
  Lisp_Object type;
  Lisp_Object method = Qnil;
  Lisp_Object tail = Qnil;
  struct gcpro gcpro1;

  GCPRO1 (tail);

  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))
    {
      if (CONSP (tail))
	tail = XCDR (tail);
      else
	goto error_throw;
    }
  tail = Fget (type, Qerror_conditions, Qnil);
  while (!NILP (tail))
    {
      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 */
  }

 error_throw:
  UNGCPRO;
  if (NILP (method))
    {
      write_c_string ("Peculiar error ",
		      canonicalize_printcharfun (stream));
      Fprin1 (error_object, stream);
      return;
    }
  else
    {
      call2 (method, error_object, stream);
    }
}

-- 
Hrvoje Niksic <hniksic@srce.hr> | Student at FER Zagreb, Croatia
--------------------------------+--------------------------------
Ask not for whom the <CONTROL-G> tolls.

