display-error takes a frame, shows source if possible

* libguile/backtrace.h:
* libguile/backtrace.c (scm_display_error): Change "stack" arg to
  "frame". Still accept stacks for backward compatibility.
  (display_header, display_error_body): Show the source of the error, if
  possible.

1 files changed, 49 insertions, 9 deletions

diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index aac7e2062..b4bee732d 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -33,6 +33,7 @@
 #include <io.h>
 #endif
 
+#include "libguile/deprecation.h"
 #include "libguile/stacks.h"
 #include "libguile/srcprop.h"
 #include "libguile/struct.h"
@@ -74,7 +75,28 @@
 static void
 display_header (SCM source, SCM port)
 {
-  scm_puts ("ERROR", port);
+  if (scm_is_true (source))
+    {
+      /* source := (addr . (filename . (line . column))) */
+      SCM fname = scm_cadr (source);
+      SCM line = scm_caddr (source);
+      SCM col = scm_cdddr (source);
+
+      if (scm_is_true (fname))
+	scm_prin1 (fname, port, 0);
+      else
+	scm_puts ("<unnamed port>", port);
+
+      if (scm_is_true (line) && scm_is_true (col))
+	{
+	  scm_putc (':', port);
+	  scm_intprint (scm_to_long (line) + 1, 10, port);
+	  scm_putc (':', port);
+	  scm_intprint (scm_to_long (col) + 1, 10, port);
+	}
+    }
+  else
+    scm_puts ("ERROR", port);
   scm_puts (": ", port);
 }
 
@@ -162,7 +184,7 @@ display_expression (SCM frame, SCM pname, SCM source, SCM port)
 }
 
 struct display_error_args {
-  SCM stack;
+  SCM frame;
   SCM port;
   SCM subr;
   SCM message;
@@ -173,14 +195,20 @@ struct display_error_args {
 static SCM
 display_error_body (struct display_error_args *a)
 {
-  SCM current_frame = SCM_BOOL_F;
   SCM source = SCM_BOOL_F;
   SCM pname = a->subr;
 
+ if (SCM_FRAMEP (a->frame))
+    {
+      source = scm_frame_source (a->frame);
+      if (!scm_is_symbol (pname) && !scm_is_string (pname))
+	pname = scm_procedure_name (scm_frame_procedure (a->frame));
+    }
+
   if (scm_is_symbol (pname) || scm_is_string (pname))
     {
       display_header (source, a->port);
-      display_expression (current_frame, pname, source, a->port);
+      display_expression (a->frame, pname, source, a->port);
     }
   display_header (source, a->port);
   scm_display_error_message (a->message, a->args, a->port);
@@ -217,11 +245,23 @@ display_error_handler (struct display_error_handler_data *data,
  * code should rather use the function scm_display_error.
  */
 void
-scm_i_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest)
+scm_i_display_error (SCM frame, SCM port, SCM subr, SCM message, SCM args, SCM rest)
 {
   struct display_error_args a;
   struct display_error_handler_data data;
-  a.stack = stack;
+
+  if (SCM_FRAMEP (frame))
+    a.frame = frame;
+#if SCM_ENABLE_DEPRECATED
+  else if (SCM_STACKP (frame))
+    {
+      scm_c_issue_deprecation_warning
+        ("Passing a stack to display-error is deprecated. Pass a frame instead.");
+      a.frame = scm_stack_ref (frame, SCM_INUM0);
+    }
+#endif
+  else
+    a.frame = SCM_BOOL_F;
   a.port  = port;
   a.subr  = subr;
   a.message = message;
@@ -236,9 +276,9 @@ scm_i_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM r
 
 
 SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0,
-	    (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest),
+	    (SCM frame, SCM port, SCM subr, SCM message, SCM args, SCM rest),
 	    "Display an error message to the output port @var{port}.\n"
-	    "@var{stack} is the saved stack for the error, @var{subr} is\n"
+	    "@var{frame} is the frame in which the error occurred, @var{subr} is\n"
 	    "the name of the procedure in which the error occurred and\n"
 	    "@var{message} is the actual error message, which may contain\n"
 	    "formatting instructions. These will format the arguments in\n"
@@ -248,7 +288,7 @@ SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0,
 {
   SCM_VALIDATE_OUTPUT_PORT (2, port);
 
-  scm_i_display_error (stack, port, subr, message, args, rest);
+  scm_i_display_error (frame, port, subr, message, args, rest);
 
   return SCM_UNSPECIFIED;
 }