libguile/backtrace.c

   1 /* Printing of backtraces and error messages
   2  * Copyright (C) 1996,1997 Free Software Foundation
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation; either version 2, or (at your option)
   7  * any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this software; see the file COPYING.  If not, write to
  16  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  17  * Boston, MA 02111-1307 USA
  18  *
  19  * As a special exception, the Free Software Foundation gives permission
  20  * for additional uses of the text contained in its release of GUILE.
  21  *
  22  * The exception is that, if you link the GUILE library with other files
  23  * to produce an executable, this does not by itself cause the
  24  * resulting executable to be covered by the GNU General Public License.
  25  * Your use of that executable is in no way restricted on account of
  26  * linking the GUILE library code into it.
  27  *
  28  * This exception does not however invalidate any other reasons why
  29  * the executable file might be covered by the GNU General Public License.
  30  *
  31  * This exception applies only to the code released by the
  32  * Free Software Foundation under the name GUILE.  If you copy
  33  * code from other Free Software Foundation releases into a copy of
  34  * GUILE, as the General Public License permits, the exception does
  35  * not apply to the code that you add in this way.  To avoid misleading
  36  * anyone as to the status of such modified files, you must delete
  37  * this exception notice from them.
  38  *
  39  * If you write modifications of your own for GUILE, it is your choice
  40  * whether to permit this exception to apply to your modifications.
  41  * If you do not wish that, delete this exception notice.
  42  *
  43  * The author can be reached at djurfeldt@nada.kth.se
  44  * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
  45
  46 #include <stdio.h>
  47 #include "_scm.h"
  48 #include "stacks.h"
  49 #include "srcprop.h"
  50 #include "genio.h"
  51 #include "struct.h"
  52 #include "strports.h"
  53 #include "throw.h"
  54 #include "fluids.h"
  55
  56 #include "backtrace.h"
  57
  58 /* {Error reporting and backtraces}
  59  * (A first approximation.)
  60  *
  61  * Note that these functions shouldn't generate errors themselves.
  62  */
  63
  64 #ifndef SCM_RECKLESS
  65 #undef SCM_ASSERT
  66 #define SCM_ASSERT(_cond, _arg, _pos, _subr) \
  67         if (!(_cond)) \
  68           return SCM_BOOL_F;
  69 #endif
  70
  71 SCM scm_the_last_stack_fluid;
  72
  73 static void display_header SCM_P ((SCM source, SCM port));
  74 static void
  75 display_header (source, port)
  76      SCM source;
  77      SCM port;
  78 {
  79   SCM fname = (SCM_NIMP (source) && SCM_MEMOIZEDP (source)
  80                ? scm_source_property (source, scm_i_filename)
  81                : SCM_BOOL_F);
  82   if (SCM_NIMP (fname) && SCM_STRINGP (fname))
  83     {
  84       scm_prin1 (fname, port, 0);
  85       scm_putc (':', port);
  86       scm_prin1 (scm_source_property (source, scm_i_line), port, 0);
  87       scm_putc (':', port);
  88       scm_prin1 (scm_source_property (source, scm_i_column), port, 0);
  89     }
  90   else
  91     scm_puts ("ERROR", port);
  92   scm_puts (": ", port);
  93 }
  94
  95
  96 void
  97 scm_display_error_message (message, args, port)
  98      SCM message;
  99      SCM args;
 100      SCM port;
 101 {
 102   int writingp;
 103   char *start;
 104   char *p;
 105
 106   if (SCM_IMP (message) || !SCM_ROSTRINGP (message) || SCM_IMP (args)
 107       || !scm_list_p (args))
 108     {
 109       scm_prin1 (message, port, 0);
 110       scm_putc ('\n', port);
 111       return;
 112     }
 113
 114   SCM_COERCE_SUBSTR (message);
 115   start = SCM_ROCHARS (message);
 116   for (p = start; *p != '\0'; ++p)
 117     if (*p == '%')
 118       {
 119         if (SCM_IMP (args) || SCM_NCONSP (args))
 120           continue;
 121
 122         ++p;
 123         if (*p == 's')
 124           writingp = 0;
 125         else if (*p == 'S')
 126           writingp = 1;
 127         else
 128           continue;
 129
 130         scm_lfwrite (start, p - start - 1, port);
 131         scm_prin1 (SCM_CAR (args), port, writingp);
 132         args = SCM_CDR (args);
 133         start = p + 1;
 134       }
 135   scm_lfwrite (start, p - start, port);
 136   scm_putc ('\n', port);
 137 }
 138
 139 static void display_expression SCM_P ((SCM frame, SCM pname, SCM source, SCM port));
 140 static void
 141 display_expression (frame, pname, source, port)
 142      SCM frame;
 143      SCM pname;
 144      SCM source;
 145      SCM port;
 146 {
 147   SCM print_state = scm_make_print_state ();
 148   scm_print_state *pstate = SCM_PRINT_STATE (print_state);
 149   pstate->writingp = 0;
 150   pstate->fancyp = 1;
 151   pstate->level = 2;
 152   pstate->length = 3;
 153   if (SCM_NIMP (pname) && SCM_ROSTRINGP (pname))
 154     {
 155       if (SCM_NIMP (frame)
 156           && SCM_FRAMEP (frame)
 157           && SCM_FRAME_EVAL_ARGS_P (frame))
 158         scm_puts ("While evaluating arguments to ", port);
 159       else
 160         scm_puts ("In procedure ", port);
 161       scm_iprin1 (pname, port, pstate);
 162       if (SCM_NIMP (source) && SCM_MEMOIZEDP (source))
 163         {
 164           scm_puts (" in expression ", port);
 165           pstate->writingp = 1;
 166           scm_iprin1 (scm_unmemoize (source), port, pstate);
 167         }
 168     }
 169   else if (SCM_NIMP (source))
 170     {
 171       scm_puts ("In expression ", port);
 172       pstate->writingp = 1;
 173       scm_iprin1 (scm_unmemoize (source), port, pstate);
 174     }
 175   scm_puts (":\n", port);
 176   scm_free_print_state (print_state);
 177 }
 178
 179 struct display_error_args {
 180   SCM stack;
 181   SCM port;
 182   SCM subr;
 183   SCM message;
 184   SCM args;
 185   SCM rest;
 186 };
 187
 188 static SCM
 189 display_error_body (struct display_error_args *a)
 190 {
 191   SCM current_frame = SCM_BOOL_F;
 192   SCM source = SCM_BOOL_F;
 193   SCM pname = SCM_BOOL_F;
 194   if (SCM_DEBUGGINGP
 195       && SCM_NIMP (a->stack)
 196       && SCM_STACKP (a->stack)
 197       && SCM_STACK_LENGTH (a->stack) > 0)
 198     {
 199       current_frame = scm_stack_ref (a->stack, SCM_INUM0);
 200       source = SCM_FRAME_SOURCE (current_frame);
 201       if (!(SCM_NIMP (source) && SCM_MEMOIZEDP (source)))
 202         source = SCM_FRAME_SOURCE (SCM_FRAME_PREV (current_frame));
 203       if (SCM_FRAME_PROC_P (current_frame)
 204           && scm_procedure_p (SCM_FRAME_PROC (current_frame)) == SCM_BOOL_T)
 205         pname = scm_procedure_name (SCM_FRAME_PROC (current_frame));
 206     }
 207   if (!(SCM_NIMP (pname) && SCM_ROSTRINGP (pname)))
 208     pname = a->subr;
 209   if ((SCM_NIMP (source) && SCM_MEMOIZEDP (source))
 210       || (SCM_NIMP (pname) && SCM_ROSTRINGP (pname)))
 211     {
 212       display_header (source, a->port);
 213       display_expression (current_frame, pname, source, a->port);
 214     }
 215   display_header (source, a->port);
 216   scm_display_error_message (a->message, a->args, a->port);
 217   return SCM_UNSPECIFIED;
 218 }
 219
 220 struct display_error_handler_data {
 221   char *mode;
 222   SCM port;
 223 };
 224
 225 /* This is the exception handler for error reporting routines.
 226    Note that it is very important that this handler *doesn't* try to
 227    print more than the error tag, since the error very probably is
 228    caused by an erroneous print call-back routine.  If we would
 229    tru to print all objects, we would enter an infinite loop. */
 230 static SCM
 231 display_error_handler (struct display_error_handler_data *data,
 232                        SCM tag, SCM args)
 233 {
 234   SCM print_state = scm_make_print_state ();
 235   scm_puts ("\nException during displaying of ", data->port);
 236   scm_puts (data->mode, data->port);
 237   scm_puts (": ", data->port);
 238   scm_iprin1 (tag, data->port, SCM_PRINT_STATE (print_state));
 239   scm_putc ('\n', data->port);
 240   return SCM_UNSPECIFIED;
 241 }
 242
 243 SCM_PROC(s_display_error, "display-error", 6, 0, 0, scm_display_error);
 244 SCM
 245 scm_display_error (stack, port, subr, message, args, rest)
 246      SCM stack;
 247      SCM port;
 248      SCM subr;
 249      SCM message;
 250      SCM args;
 251      SCM rest;
 252 {
 253   struct display_error_args a = { stack, port, subr, message, args, rest };
 254   struct display_error_handler_data data = { "error", port };
 255   scm_internal_catch (SCM_BOOL_T,
 256                       (scm_catch_body_t) display_error_body, &a,
 257                       (scm_catch_handler_t) display_error_handler, &data);
 258   return SCM_UNSPECIFIED;
 259 }
 260
 261 static void indent SCM_P ((int n, SCM port));
 262 static void
 263 indent (n, port)
 264      int n;
 265      SCM port;
 266 {
 267   int i;
 268   for (i = 0; i < n; ++i)
 269     scm_putc (' ', port);
 270 }
 271
 272 static void display_frame_expr SCM_P ((char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate));
 273 static void
 274 display_frame_expr (hdr, exp, tlr, indentation, sport, port, pstate)
 275      char *hdr;
 276      SCM exp;
 277      char *tlr;
 278      int indentation;
 279      SCM sport;
 280      SCM port;
 281      scm_print_state *pstate;
 282 {
 283   if (SCM_NIMP (exp) && SCM_CONSP (exp))
 284     {
 285       scm_iprlist (hdr, exp, tlr[0], port, pstate);
 286       scm_puts (&tlr[1], port);
 287     }
 288   else
 289     scm_iprin1 (exp, port, pstate);
 290   scm_putc ('\n', port);
 291 }
 292
 293 static void display_application SCM_P ((SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate));
 294 static void
 295 display_application (frame, indentation, sport, port, pstate)
 296      SCM frame;
 297      int indentation;
 298      SCM sport;
 299      SCM port;
 300      scm_print_state *pstate;
 301 {
 302   SCM proc = SCM_FRAME_PROC (frame);
 303   SCM name = (SCM_NFALSEP (scm_procedure_p (proc))
 304               ? scm_procedure_name (proc)
 305               : SCM_BOOL_F);
 306   display_frame_expr ("[",
 307                       scm_cons (SCM_NFALSEP (name) ? name : proc,
 308                                 SCM_FRAME_ARGS (frame)),
 309                       SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]",
 310                       indentation,
 311                       sport,
 312                       port,
 313                       pstate);
 314 }
 315
 316 SCM_PROC(s_display_application, "display-application", 1, 1, 0, scm_display_application);
 317
 318 SCM
 319 scm_display_application (SCM frame, SCM port)
 320 {
 321   if (SCM_UNBNDP (port))
 322     port = scm_cur_outp;
 323   if (SCM_FRAME_PROC_P (frame))
 324     /* Display an application. */
 325     {
 326       SCM print_state;
 327       scm_print_state *pstate;
 328
 329       /* Create a print state for printing of frames. */
 330       print_state = scm_make_print_state ();
 331       pstate = SCM_PRINT_STATE (print_state);
 332       pstate->writingp = 1;
 333       pstate->fancyp = 1;
 334       pstate->level = 2;
 335       pstate->length = 9;
 336
 337       display_application (frame, 0, SCM_BOOL_F, port, pstate); /*fixme*/
 338       return SCM_BOOL_T;
 339     }
 340   else
 341     return SCM_BOOL_F;
 342 }
 343
 344 static void display_frame SCM_P ((SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate));
 345 static void
 346 display_frame (frame, nfield, indentation, sport, port, pstate)
 347      SCM frame;
 348      int nfield;
 349      int indentation;
 350      SCM sport;
 351      SCM port;
 352      scm_print_state *pstate;
 353 {
 354   int n, i, j;
 355
 356   /* Announce missing frames? */
 357   if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
 358     {
 359       indent (nfield + 1 + indentation, port);
 360       scm_puts ("...\n", port);
 361     }
 362
 363   /* Check size of frame number. */
 364   n = SCM_FRAME_NUMBER (frame);
 365   for (i = 0, j = n; j > 0; ++i) j /= 10;
 366
 367   /* Number indentation. */
 368   indent (nfield - (i ? i : 1), port);
 369
 370   /* Frame number. */
 371   scm_iprin1 (SCM_MAKINUM (n), port, pstate);
 372
 373   /* Real frame marker */
 374   scm_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port);
 375
 376   /* Indentation. */
 377   indent (indentation, port);
 378
 379   if (SCM_FRAME_PROC_P (frame))
 380     /* Display an application. */
 381     display_application (frame, nfield + 1 + indentation, sport, port, pstate);
 382   else
 383     /* Display a special form. */
 384     {
 385       SCM source = SCM_FRAME_SOURCE (frame);
 386       SCM copy = scm_source_property (source, scm_i_copy);
 387       display_frame_expr ("(",
 388                           SCM_NIMP (copy) && SCM_CONSP (copy)
 389                           ? copy
 390                           : scm_unmemoize (source),
 391                           ")",
 392                           nfield + 1 + indentation,
 393                           sport,
 394                           port,
 395                           pstate);
 396     }
 397
 398   /* Announce missing frames? */
 399   if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
 400     {
 401       indent (nfield + 1 + indentation, port);
 402       scm_puts ("...\n", port);
 403     }
 404 }
 405
 406 struct display_backtrace_args {
 407   SCM stack;
 408   SCM port;
 409   SCM first;
 410   SCM depth;
 411 };
 412
 413 SCM_PROC(s_display_backtrace, "display-backtrace", 2, 2, 0, scm_display_backtrace);
 414
 415 static SCM
 416 display_backtrace_body (struct display_backtrace_args *a)
 417 {
 418   int n_frames, beg, end, n, i, j;
 419   int nfield, indent_p, indentation;
 420   SCM frame, sport, print_state;
 421   scm_print_state *pstate;
 422
 423   a->port = SCM_COERCE_OUTPORT (a->port);
 424
 425   /* Argument checking and extraction. */
 426   SCM_ASSERT (SCM_NIMP (a->stack) && SCM_STACKP (a->stack),
 427               a->stack,
 428               SCM_ARG1,
 429               s_display_backtrace);
 430   SCM_ASSERT (SCM_NIMP (a->port) && SCM_OPOUTPORTP (a->port),
 431               a->port,
 432               SCM_ARG2,
 433               s_display_backtrace);
 434   n_frames = SCM_INUM (scm_stack_length (a->stack));
 435   n = SCM_INUMP (a->depth) ? SCM_INUM (a->depth) : SCM_BACKTRACE_DEPTH;
 436   if (SCM_BACKWARDS_P)
 437     {
 438       beg = SCM_INUMP (a->first) ? SCM_INUM (a->first) : 0;
 439       end = beg + n - 1;
 440       if (end >= n_frames)
 441         end = n_frames - 1;
 442       n = end - beg + 1;
 443     }
 444   else
 445     {
 446       if (SCM_INUMP (a->first))
 447         {
 448           beg = SCM_INUM (a->first);
 449           end = beg - n + 1;
 450           if (end < 0)
 451             end = 0;
 452         }
 453       else
 454         {
 455           beg = n - 1;
 456           end = 0;
 457           if (beg >= n_frames)
 458             beg = n_frames - 1;
 459         }
 460       n = beg - end + 1;
 461     }
 462   SCM_ASSERT (beg >= 0 && beg < n_frames, a->first, SCM_ARG3, s_display_backtrace);
 463   SCM_ASSERT (n > 0, a->depth, SCM_ARG4, s_display_backtrace);
 464
 465   /* Create a string port used for adaptation of printing parameters. */
 466   sport = scm_mkstrport (SCM_INUM0,
 467                          scm_make_string (SCM_MAKINUM (240), SCM_UNDEFINED),
 468                          SCM_OPN | SCM_WRTNG,
 469                          s_display_backtrace);
 470
 471   /* Create a print state for printing of frames. */
 472   print_state = scm_make_print_state ();
 473   pstate = SCM_PRINT_STATE (print_state);
 474   pstate->writingp = 1;
 475   pstate->fancyp = 1;
 476   pstate->level = 2;
 477   pstate->length = 3;
 478
 479   /* First find out if it's reasonable to do indentation. */
 480   if (SCM_BACKWARDS_P)
 481     indent_p = 0;
 482   else
 483     {
 484       indent_p = 1;
 485       frame = scm_stack_ref (a->stack, SCM_MAKINUM (beg));
 486       for (i = 0, j = 0; i < n; ++i)
 487         {
 488           if (SCM_FRAME_REAL_P (frame))
 489             ++j;
 490           if (j > SCM_BACKTRACE_INDENT)
 491             {
 492               indent_p = 0;
 493               break;
 494             }
 495           frame = (SCM_BACKWARDS_P
 496                    ? SCM_FRAME_PREV (frame)
 497                    : SCM_FRAME_NEXT (frame));
 498         }
 499     }
 500
 501   /* Determine size of frame number field. */
 502   j = SCM_FRAME_NUMBER (scm_stack_ref (a->stack, SCM_MAKINUM (end)));
 503   for (i = 0; j > 0; ++i) j /= 10;
 504   nfield = i ? i : 1;
 505
 506   scm_puts ("Backtrace:\n", a->port);
 507
 508   /* Print frames. */
 509   frame = scm_stack_ref (a->stack, SCM_MAKINUM (beg));
 510   indentation = 1;
 511   display_frame (frame, nfield, indentation, sport, a->port, pstate);
 512   for (i = 1; i < n; ++i)
 513     {
 514       if (indent_p && SCM_FRAME_EVAL_ARGS_P (frame))
 515         ++indentation;
 516       frame = SCM_BACKWARDS_P ? SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame);
 517       display_frame (frame, nfield, indentation, sport, a->port, pstate);
 518     }
 519
 520   return SCM_UNSPECIFIED;
 521 }
 522
 523 SCM
 524 scm_display_backtrace (stack, port, first, depth)
 525      SCM stack;
 526      SCM port;
 527      SCM first;
 528      SCM depth;
 529 {
 530   struct display_backtrace_args a = { stack, port, first, depth };
 531   struct display_error_handler_data data = { "backtrace", port };
 532   scm_internal_catch (SCM_BOOL_T,
 533                       (scm_catch_body_t) display_backtrace_body, &a,
 534                       (scm_catch_handler_t) display_error_handler, &data);
 535   return SCM_UNSPECIFIED;
 536 }
 537
 538 SCM_VCELL (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?");
 539
 540 SCM_PROC(s_backtrace, "backtrace", 0, 0, 0, scm_backtrace);
 541 SCM
 542 scm_backtrace ()
 543 {
 544   SCM the_last_stack = scm_fluid_ref (SCM_CDR (scm_the_last_stack_fluid));
 545   if (SCM_NFALSEP (the_last_stack))
 546     {
 547       scm_newline (scm_cur_outp);
 548       scm_display_backtrace (the_last_stack,
 549                              scm_cur_outp,
 550                              SCM_UNDEFINED,
 551                              SCM_UNDEFINED);
 552       scm_newline (scm_cur_outp);
 553       if (SCM_FALSEP (SCM_CDR (scm_has_shown_backtrace_hint_p_var))
 554           && !SCM_BACKTRACE_P)
 555         {
 556           scm_puts ("Type \"(debug-enable 'backtrace)\" if you would like "
 557                     "a backtrace\n"
 558                     "automatically if an error occurs in the future.\n",
 559                     scm_cur_outp);
 560           SCM_SETCDR (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T);
 561         }
 562     }
 563   else
 564     {
 565       scm_puts ("No backtrace available.\n", scm_cur_outp);
 566     }
 567   return SCM_UNSPECIFIED;
 568 }
 569
 570 \f
 571
 572 void
 573 scm_init_backtrace ()
 574 {
 575   SCM f = scm_make_fluid ();
 576   scm_the_last_stack_fluid = scm_sysintern ("the-last-stack", f);
 577
 578 #include "backtrace.x"
 579 }