libguile/backtrace.c

   1 /* Printing of backtraces and error messages
   2  * Copyright (C) 1996,1997,1998,1999,2000,2001 Free Software Foundation
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public
   6  * License as published by the Free Software Foundation; either
   7  * version 2.1 of the License, or (at your option) any later version.
   8  *
   9  * This library 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 GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  17  */
  18
  19 #if HAVE_CONFIG_H
  20 #  include <config.h>
  21 #endif
  22
  23 #include <stdio.h>
  24 #include <ctype.h>
  25
  26 #include "libguile/_scm.h"
  27
  28 #ifdef HAVE_UNISTD_H
  29 #include <unistd.h>
  30 #endif
  31 #ifdef HAVE_IO_H
  32 #include <io.h>
  33 #endif
  34
  35 #include "libguile/stacks.h"
  36 #include "libguile/srcprop.h"
  37 #include "libguile/struct.h"
  38 #include "libguile/strports.h"
  39 #include "libguile/throw.h"
  40 #include "libguile/fluids.h"
  41 #include "libguile/ports.h"
  42 #include "libguile/strings.h"
  43
  44 #include "libguile/validate.h"
  45 #include "libguile/lang.h"
  46 #include "libguile/backtrace.h"
  47 #include "libguile/filesys.h"
  48
  49 /* {Error reporting and backtraces}
  50  * (A first approximation.)
  51  *
  52  * Note that these functions shouldn't generate errors themselves.
  53  */
  54
  55 #undef SCM_ASSERT
  56 #define SCM_ASSERT(_cond, _arg, _pos, _subr) \
  57         if (!(_cond)) \
  58           return SCM_BOOL_F;
  59
  60 SCM scm_the_last_stack_fluid_var;
  61
  62 static void
  63 display_header (SCM source, SCM port)
  64 {
  65   if (SCM_MEMOIZEDP (source))
  66     {
  67       SCM fname = scm_source_property (source, scm_sym_filename);
  68       SCM line = scm_source_property (source, scm_sym_line);
  69       SCM col = scm_source_property (source, scm_sym_column);
  70
  71       /* Dirk:FIXME:: Maybe we should store the _port_ rather than the
  72        * filename with the source properties?  Then we could in case of
  73        * non-file ports give at least some more details than just
  74        * "<unnamed port>". */
  75       if (SCM_STRINGP (fname))
  76         scm_prin1 (fname, port, 0);
  77       else
  78         scm_puts ("<unnamed port>", port);
  79
  80       if (!SCM_FALSEP (line) && !SCM_FALSEP (col))
  81         {
  82           scm_putc (':', port);
  83           scm_intprint (SCM_INUM (line) + 1, 10, port);
  84           scm_putc (':', port);
  85           scm_intprint (SCM_INUM (col) + 1, 10, port);
  86         }
  87     }
  88   else
  89     scm_puts ("ERROR", port);
  90   scm_puts (": ", port);
  91 }
  92
  93
  94 void
  95 scm_display_error_message (SCM message, SCM args, SCM port)
  96 {
  97   if (SCM_STRINGP (message) && !SCM_FALSEP (scm_list_p (args)))
  98     {
  99       scm_simple_format (port, message, args);
 100       scm_newline (port);
 101     }
 102   else
 103     {
 104       scm_display (message, port);
 105       scm_newline (port);
 106     }
 107 }
 108
 109 static void
 110 display_expression (SCM frame, SCM pname, SCM source, SCM port)
 111 {
 112   SCM print_state = scm_make_print_state ();
 113   scm_print_state *pstate = SCM_PRINT_STATE (print_state);
 114   pstate->writingp = 0;
 115   pstate->fancyp = 1;
 116   pstate->level = 2;
 117   pstate->length = 3;
 118   if (SCM_SYMBOLP (pname) || SCM_STRINGP (pname))
 119     {
 120       if (SCM_FRAMEP (frame)
 121           && SCM_FRAME_EVAL_ARGS_P (frame))
 122         scm_puts ("While evaluating arguments to ", port);
 123       else
 124         scm_puts ("In procedure ", port);
 125       scm_iprin1 (pname, port, pstate);
 126       if (SCM_MEMOIZEDP (source))
 127         {
 128           scm_puts (" in expression ", port);
 129           pstate->writingp = 1;
 130           scm_iprin1 (scm_unmemoize (source), port, pstate);
 131         }
 132     }
 133   else if (SCM_MEMOIZEDP (source))
 134     {
 135       scm_puts ("In expression ", port);
 136       pstate->writingp = 1;
 137       scm_iprin1 (scm_unmemoize (source), port, pstate);
 138     }
 139   scm_puts (":\n", port);
 140   scm_free_print_state (print_state);
 141 }
 142
 143 struct display_error_args {
 144   SCM stack;
 145   SCM port;
 146   SCM subr;
 147   SCM message;
 148   SCM args;
 149   SCM rest;
 150 };
 151
 152 static SCM
 153 display_error_body (struct display_error_args *a)
 154 {
 155   SCM current_frame = SCM_BOOL_F;
 156   SCM source = SCM_BOOL_F;
 157   SCM prev_frame = SCM_BOOL_F;
 158   SCM pname = a->subr;
 159
 160   if (SCM_DEBUGGINGP
 161       && SCM_STACKP (a->stack)
 162       && SCM_STACK_LENGTH (a->stack) > 0)
 163     {
 164       current_frame = scm_stack_ref (a->stack, SCM_INUM0);
 165       source = SCM_FRAME_SOURCE (current_frame);
 166       prev_frame = SCM_FRAME_PREV (current_frame);
 167       if (!SCM_MEMOIZEDP (source) && !SCM_FALSEP (prev_frame))
 168         source = SCM_FRAME_SOURCE (prev_frame);
 169       if (!SCM_SYMBOLP (pname) && !SCM_STRINGP (pname) && SCM_FRAME_PROC_P (current_frame)
 170           && SCM_EQ_P (scm_procedure_p (SCM_FRAME_PROC (current_frame)), SCM_BOOL_T))
 171         pname = scm_procedure_name (SCM_FRAME_PROC (current_frame));
 172     }
 173   if (SCM_SYMBOLP (pname) || SCM_STRINGP (pname) || SCM_MEMOIZEDP (source))
 174     {
 175       display_header (source, a->port);
 176       display_expression (current_frame, pname, source, a->port);
 177     }
 178   display_header (source, a->port);
 179   scm_display_error_message (a->message, a->args, a->port);
 180   return SCM_UNSPECIFIED;
 181 }
 182
 183 struct display_error_handler_data {
 184   char *mode;
 185   SCM port;
 186 };
 187
 188 /* This is the exception handler for error reporting routines.
 189    Note that it is very important that this handler *doesn't* try to
 190    print more than the error tag, since the error very probably is
 191    caused by an erroneous print call-back routine.  If we would
 192    try to print all objects, we would enter an infinite loop. */
 193 static SCM
 194 display_error_handler (struct display_error_handler_data *data,
 195                        SCM tag, SCM args SCM_UNUSED)
 196 {
 197   SCM print_state = scm_make_print_state ();
 198   scm_puts ("\nException during displaying of ", data->port);
 199   scm_puts (data->mode, data->port);
 200   scm_puts (": ", data->port);
 201   scm_iprin1 (tag, data->port, SCM_PRINT_STATE (print_state));
 202   scm_putc ('\n', data->port);
 203   return SCM_UNSPECIFIED;
 204 }
 205
 206
 207 /* The function scm_i_display_error prints out a detailed error message.  This
 208  * function will be called directly within libguile to signal error messages.
 209  * No parameter checks will be performed by scm_i_display_error.  Thus, User
 210  * code should rather use the function scm_display_error.
 211  */
 212 void
 213 scm_i_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest)
 214 {
 215   struct display_error_args a;
 216   struct display_error_handler_data data;
 217   a.stack = stack;
 218   a.port  = port;
 219   a.subr  = subr;
 220   a.message = message;
 221   a.args  = args;
 222   a.rest  = rest;
 223   data.mode = "error";
 224   data.port = port;
 225   scm_internal_catch (SCM_BOOL_T,
 226                       (scm_t_catch_body) display_error_body, &a,
 227                       (scm_t_catch_handler) display_error_handler, &data);
 228 }
 229
 230
 231 SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0,
 232             (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest),
 233             "Display an error message to the output port @var{port}.\n"
 234             "@var{stack} is the saved stack for the error, @var{subr} is\n"
 235             "the name of the procedure in which the error occurred and\n"
 236             "@var{message} is the actual error message, which may contain\n"
 237             "formatting instructions. These will format the arguments in\n"
 238             "the list @var{args} accordingly.  @var{rest} is currently\n"
 239             "ignored.")
 240 #define FUNC_NAME s_scm_display_error
 241 {
 242   SCM_VALIDATE_OUTPUT_PORT (2, port);
 243
 244   scm_i_display_error (stack, port, subr, message, args, rest);
 245
 246   return SCM_UNSPECIFIED;
 247 }
 248 #undef FUNC_NAME
 249
 250
 251 typedef struct {
 252   int level;
 253   int length;
 254 } print_params_t;
 255
 256 static int n_print_params = 9;
 257 static print_params_t default_print_params[] = {
 258   { 4, 9 }, { 4, 3 },
 259   { 3, 4 }, { 3, 3 },
 260   { 2, 4 }, { 2, 3 },
 261   { 1, 4 }, { 1, 3 }, { 1, 2 }
 262 };
 263 static print_params_t *print_params = default_print_params;
 264
 265 #ifdef GUILE_DEBUG
 266 SCM_DEFINE (scm_set_print_params_x, "set-print-params!", 1, 0, 0,
 267            (SCM params),
 268             "Set the print parameters to the values from @var{params}.\n"
 269             "@var{params} must be a list of two-element lists which must\n"
 270             "hold two integer values.")
 271 #define FUNC_NAME s_scm_set_print_params_x
 272 {
 273   int i;
 274   int n;
 275   SCM ls;
 276   print_params_t *new_params;
 277
 278   SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, params, n);
 279   for (ls = params; !SCM_NULL_OR_NIL_P (ls); ls = SCM_CDR (ls))
 280     SCM_ASSERT (scm_ilength (SCM_CAR (params)) == 2
 281                 && SCM_INUMP (SCM_CAAR (ls))
 282                 && SCM_INUM (SCM_CAAR (ls)) >= 0
 283                 && SCM_INUMP (SCM_CADAR (ls))
 284                 && SCM_INUM (SCM_CADAR (ls)) >= 0,
 285                 params,
 286                 SCM_ARG2,
 287                 s_scm_set_print_params_x);
 288   new_params = scm_malloc (n * sizeof (print_params_t));
 289   if (print_params != default_print_params)
 290     free (print_params);
 291   print_params = new_params;
 292   for (i = 0; i < n; ++i)
 293     {
 294       print_params[i].level = SCM_INUM (SCM_CAAR (params));
 295       print_params[i].length = SCM_INUM (SCM_CADAR (params));
 296       params = SCM_CDR (params);
 297     }
 298   n_print_params = n;
 299   return SCM_UNSPECIFIED;
 300 }
 301 #undef FUNC_NAME
 302 #endif
 303
 304 static void
 305 indent (int n, SCM port)
 306 {
 307   int i;
 308   for (i = 0; i < n; ++i)
 309     scm_putc (' ', port);
 310 }
 311
 312 static void
 313 display_frame_expr (char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate)
 314 {
 315   SCM string;
 316   int i = 0, n;
 317   scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (sport);
 318   do
 319     {
 320       pstate->length = print_params[i].length;
 321       ptob->seek (sport, 0, SEEK_SET);
 322       if (SCM_CONSP (exp))
 323         {
 324           pstate->level = print_params[i].level - 1;
 325           scm_iprlist (hdr, exp, tlr[0], sport, pstate);
 326           scm_puts (&tlr[1], sport);
 327         }
 328       else
 329         {
 330           pstate->level = print_params[i].level;
 331           scm_iprin1 (exp, sport, pstate);
 332         }
 333       ptob->flush (sport);
 334       n = ptob->seek (sport, 0, SEEK_CUR);
 335       ++i;
 336     }
 337   while (indentation + n > SCM_BACKTRACE_WIDTH && i < n_print_params);
 338   ptob->truncate (sport, n);
 339   string = scm_strport_to_string (sport);
 340   /* Remove control characters */
 341   for (i = 0; i < n; ++i)
 342     if (iscntrl (SCM_STRING_CHARS (string)[i]))
 343       SCM_STRING_CHARS (string)[i] = ' ';
 344   /* Truncate */
 345   if (indentation + n > SCM_BACKTRACE_WIDTH)
 346     {
 347       n = SCM_BACKTRACE_WIDTH - indentation;
 348       SCM_STRING_CHARS (string)[n - 1] = '$';
 349     }
 350
 351   scm_lfwrite (SCM_STRING_CHARS (string), n, port);
 352 }
 353
 354 static void
 355 display_application (SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate)
 356 {
 357   SCM proc = SCM_FRAME_PROC (frame);
 358   SCM name = (!SCM_FALSEP (scm_procedure_p (proc))
 359               ? scm_procedure_name (proc)
 360               : SCM_BOOL_F);
 361   display_frame_expr ("[",
 362                       scm_cons (!SCM_FALSEP (name) ? name : proc,
 363                                 SCM_FRAME_ARGS (frame)),
 364                       SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]",
 365                       indentation,
 366                       sport,
 367                       port,
 368                       pstate);
 369 }
 370
 371 SCM_DEFINE (scm_display_application, "display-application", 1, 2, 0,
 372            (SCM frame, SCM port, SCM indent),
 373             "Display a procedure application @var{frame} to the output port\n"
 374             "@var{port}. @var{indent} specifies the indentation of the\n"
 375             "output.")
 376 #define FUNC_NAME s_scm_display_application
 377 {
 378   SCM_VALIDATE_FRAME (1, frame);
 379   if (SCM_UNBNDP (port))
 380     port = scm_cur_outp;
 381   else
 382     SCM_VALIDATE_OPOUTPORT (2, port);
 383   if (SCM_UNBNDP (indent))
 384     indent = SCM_INUM0;
 385   else
 386     SCM_VALIDATE_INUM (3, indent);
 387
 388   if (SCM_FRAME_PROC_P (frame))
 389     /* Display an application. */
 390     {
 391       SCM sport, print_state;
 392       scm_print_state *pstate;
 393
 394       /* Create a string port used for adaptation of printing parameters. */
 395       sport = scm_mkstrport (SCM_INUM0,
 396                              scm_make_string (SCM_MAKINUM (240),
 397                                               SCM_UNDEFINED),
 398                              SCM_OPN | SCM_WRTNG,
 399                              FUNC_NAME);
 400
 401       /* Create a print state for printing of frames. */
 402       print_state = scm_make_print_state ();
 403       pstate = SCM_PRINT_STATE (print_state);
 404       pstate->writingp = 1;
 405       pstate->fancyp = 1;
 406
 407       display_application (frame, SCM_INUM (indent), sport, port, pstate);
 408       return SCM_BOOL_T;
 409     }
 410   else
 411     return SCM_BOOL_F;
 412 }
 413 #undef FUNC_NAME
 414
 415 SCM_SYMBOL (sym_base, "base");
 416
 417 static void
 418 display_backtrace_get_file_line (SCM frame, SCM *file, SCM *line)
 419 {
 420   SCM source = SCM_FRAME_SOURCE (frame);
 421   *file = SCM_MEMOIZEDP (source) ? scm_source_property (source, scm_sym_filename) : SCM_BOOL_F;
 422   *line = (SCM_MEMOIZEDP (source)) ? scm_source_property (source, scm_sym_line) : SCM_BOOL_F;
 423 }
 424
 425 static void
 426 display_backtrace_file (frame, last_file, port, pstate)
 427      SCM frame;
 428      SCM *last_file;
 429      SCM port;
 430      scm_print_state *pstate;
 431 {
 432   SCM file, line;
 433
 434   display_backtrace_get_file_line (frame, &file, &line);
 435
 436   if (SCM_EQ_P (file, *last_file))
 437     return;
 438
 439   *last_file = file;
 440
 441   scm_puts ("In ", port);
 442   if (SCM_FALSEP (file))
 443     if (SCM_FALSEP (line))
 444       scm_puts ("unknown file", port);
 445     else
 446       scm_puts ("current input", port);
 447   else
 448     {
 449       pstate->writingp = 0;
 450       scm_iprin1 (file, port, pstate);
 451       pstate->writingp = 1;
 452     }
 453   scm_puts (":\n", port);
 454 }
 455
 456 static void
 457 display_backtrace_file_and_line (SCM frame, SCM port, scm_print_state *pstate)
 458 {
 459   SCM file, line;
 460
 461   display_backtrace_get_file_line (frame, &file, &line);
 462
 463   if (SCM_EQ_P (SCM_SHOW_FILE_NAME, sym_base))
 464     {
 465       if (SCM_FALSEP (file))
 466         {
 467           if (SCM_FALSEP (line))
 468             scm_putc ('?', port);
 469           else
 470             scm_puts ("<stdin>", port);
 471         }
 472       else
 473         {
 474           pstate -> writingp = 0;
 475 #ifdef HAVE_POSIX
 476           scm_iprin1 (SCM_STRINGP (file) ? scm_basename (file, SCM_UNDEFINED) : file,
 477                       port, pstate);
 478 #else
 479           scm_iprin1 (file, port, pstate);
 480 #endif
 481           pstate -> writingp = 1;
 482         }
 483
 484       scm_putc (':', port);
 485     }
 486   else if (!SCM_FALSEP (line))
 487     {
 488       int i, j=0;
 489       for (i = SCM_INUM (line)+1; i > 0; i = i/10, j++)
 490         ;
 491       indent (4-j, port);
 492     }
 493
 494   if (SCM_FALSEP (line))
 495     scm_puts ("   ?", port);
 496   else
 497     scm_intprint (SCM_INUM (line) + 1, 10, port);
 498   scm_puts (": ", port);
 499 }
 500
 501 static void
 502 display_frame (SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate)
 503 {
 504   int n, i, j;
 505
 506   /* Announce missing frames? */
 507   if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
 508     {
 509       indent (nfield + 1 + indentation, port);
 510       scm_puts ("...\n", port);
 511     }
 512
 513   /* display file name and line number */
 514   if (!SCM_FALSEP (SCM_SHOW_FILE_NAME))
 515     display_backtrace_file_and_line (frame, port, pstate);
 516
 517   /* Check size of frame number. */
 518   n = SCM_FRAME_NUMBER (frame);
 519   for (i = 0, j = n; j > 0; ++i) j /= 10;
 520
 521   /* Number indentation. */
 522   indent (nfield - (i ? i : 1), port);
 523
 524   /* Frame number. */
 525   scm_iprin1 (SCM_MAKINUM (n), port, pstate);
 526
 527   /* Real frame marker */
 528   scm_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port);
 529
 530   /* Indentation. */
 531   indent (indentation, port);
 532
 533   if (SCM_FRAME_PROC_P (frame))
 534     /* Display an application. */
 535     display_application (frame, nfield + 1 + indentation, sport, port, pstate);
 536   else
 537     /* Display a special form. */
 538     {
 539       SCM source = SCM_FRAME_SOURCE (frame);
 540       SCM copy = (SCM_CONSP (source)
 541                   ? scm_source_property (source, scm_sym_copy)
 542                   : SCM_BOOL_F);
 543       SCM umcopy = (SCM_MEMOIZEDP (source)
 544                     ? scm_unmemoize (source)
 545                     : SCM_BOOL_F);
 546       display_frame_expr ("(",
 547                           SCM_CONSP (copy) ? copy : umcopy,
 548                           ")",
 549                           nfield + 1 + indentation,
 550                           sport,
 551                           port,
 552                           pstate);
 553     }
 554   scm_putc ('\n', port);
 555
 556   /* Announce missing frames? */
 557   if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
 558     {
 559       indent (nfield + 1 + indentation, port);
 560       scm_puts ("...\n", port);
 561     }
 562 }
 563
 564 struct display_backtrace_args {
 565   SCM stack;
 566   SCM port;
 567   SCM first;
 568   SCM depth;
 569 };
 570
 571 static SCM
 572 display_backtrace_body (struct display_backtrace_args *a)
 573 #define FUNC_NAME "display_backtrace_body"
 574 {
 575   int n_frames, beg, end, n, i, j;
 576   int nfield, indent_p, indentation;
 577   SCM frame, sport, print_state;
 578   SCM last_file;
 579   scm_print_state *pstate;
 580
 581   a->port = SCM_COERCE_OUTPORT (a->port);
 582
 583   /* Argument checking and extraction. */
 584   SCM_VALIDATE_STACK (1, a->stack);
 585   SCM_VALIDATE_OPOUTPORT (2, a->port);
 586   n_frames = SCM_INUM (scm_stack_length (a->stack));
 587   n = SCM_INUMP (a->depth) ? SCM_INUM (a->depth) : SCM_BACKTRACE_DEPTH;
 588   if (SCM_BACKWARDS_P)
 589     {
 590       beg = SCM_INUMP (a->first) ? SCM_INUM (a->first) : 0;
 591       end = beg + n - 1;
 592       if (end >= n_frames)
 593         end = n_frames - 1;
 594       n = end - beg + 1;
 595     }
 596   else
 597     {
 598       if (SCM_INUMP (a->first))
 599         {
 600           beg = SCM_INUM (a->first);
 601           end = beg - n + 1;
 602           if (end < 0)
 603             end = 0;
 604         }
 605       else
 606         {
 607           beg = n - 1;
 608           end = 0;
 609           if (beg >= n_frames)
 610             beg = n_frames - 1;
 611         }
 612       n = beg - end + 1;
 613     }
 614   SCM_ASSERT (beg >= 0 && beg < n_frames, a->first, SCM_ARG3, s_display_backtrace);
 615   SCM_ASSERT (n > 0, a->depth, SCM_ARG4, s_display_backtrace);
 616
 617   /* Create a string port used for adaptation of printing parameters. */
 618   sport = scm_mkstrport (SCM_INUM0,
 619                          scm_make_string (SCM_MAKINUM (240), SCM_UNDEFINED),
 620                          SCM_OPN | SCM_WRTNG,
 621                          FUNC_NAME);
 622
 623   /* Create a print state for printing of frames. */
 624   print_state = scm_make_print_state ();
 625   pstate = SCM_PRINT_STATE (print_state);
 626   pstate->writingp = 1;
 627   pstate->fancyp = 1;
 628
 629   /* First find out if it's reasonable to do indentation. */
 630   if (SCM_BACKWARDS_P)
 631     indent_p = 0;
 632   else
 633     {
 634       unsigned int j;
 635
 636       indent_p = 1;
 637       frame = scm_stack_ref (a->stack, SCM_MAKINUM (beg));
 638       for (i = 0, j = 0; i < n; ++i)
 639         {
 640           if (SCM_FRAME_REAL_P (frame))
 641             ++j;
 642           if (j > SCM_BACKTRACE_INDENT)
 643             {
 644               indent_p = 0;
 645               break;
 646             }
 647           frame = (SCM_BACKWARDS_P
 648                    ? SCM_FRAME_PREV (frame)
 649                    : SCM_FRAME_NEXT (frame));
 650         }
 651     }
 652
 653   /* Determine size of frame number field. */
 654   j = SCM_FRAME_NUMBER (scm_stack_ref (a->stack, SCM_MAKINUM (end)));
 655   for (i = 0; j > 0; ++i) j /= 10;
 656   nfield = i ? i : 1;
 657
 658   /* Print frames. */
 659   frame = scm_stack_ref (a->stack, SCM_MAKINUM (beg));
 660   indentation = 1;
 661   last_file = SCM_UNDEFINED;
 662   for (i = 0; i < n; ++i)
 663     {
 664       if (!SCM_EQ_P (SCM_SHOW_FILE_NAME, sym_base))
 665         display_backtrace_file (frame, &last_file, a->port, pstate);
 666
 667       display_frame (frame, nfield, indentation, sport, a->port, pstate);
 668       if (indent_p && SCM_FRAME_EVAL_ARGS_P (frame))
 669         ++indentation;
 670       frame = (SCM_BACKWARDS_P ?
 671                SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame));
 672     }
 673
 674   scm_remember_upto_here_1 (print_state);
 675
 676   return SCM_UNSPECIFIED;
 677 }
 678 #undef FUNC_NAME
 679
 680 SCM_DEFINE (scm_display_backtrace, "display-backtrace", 2, 2, 0,
 681             (SCM stack, SCM port, SCM first, SCM depth),
 682             "Display a backtrace to the output port @var{port}. @var{stack}\n"
 683             "is the stack to take the backtrace from, @var{first} specifies\n"
 684             "where in the stack to start and @var{depth} how much frames\n"
 685             "to display. Both @var{first} and @var{depth} can be @code{#f},\n"
 686             "which means that default values will be used.")
 687 #define FUNC_NAME s_scm_display_backtrace
 688 {
 689   struct display_backtrace_args a;
 690   struct display_error_handler_data data;
 691   a.stack = stack;
 692   a.port  = port;
 693   a.first = first;
 694   a.depth = depth;
 695   data.mode = "backtrace";
 696   data.port = port;
 697   scm_internal_catch (SCM_BOOL_T,
 698                       (scm_t_catch_body) display_backtrace_body, &a,
 699                       (scm_t_catch_handler) display_error_handler, &data);
 700   return SCM_UNSPECIFIED;
 701 }
 702 #undef FUNC_NAME
 703
 704 SCM_VARIABLE (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?");
 705
 706 SCM_DEFINE (scm_backtrace, "backtrace", 0, 0, 0,
 707             (),
 708             "Display a backtrace of the stack saved by the last error\n"
 709             "to the current output port.")
 710 #define FUNC_NAME s_scm_backtrace
 711 {
 712   SCM the_last_stack =
 713     scm_fluid_ref (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var));
 714   if (!SCM_FALSEP (the_last_stack))
 715     {
 716       scm_newline (scm_cur_outp);
 717       scm_puts ("Backtrace:\n", scm_cur_outp);
 718       scm_display_backtrace (the_last_stack,
 719                              scm_cur_outp,
 720                              SCM_UNDEFINED,
 721                              SCM_UNDEFINED);
 722       scm_newline (scm_cur_outp);
 723       if (SCM_FALSEP (SCM_VARIABLE_REF (scm_has_shown_backtrace_hint_p_var))
 724           && !SCM_BACKTRACE_P)
 725         {
 726           scm_puts ("Type \"(debug-enable 'backtrace)\" if you would like "
 727                     "a backtrace\n"
 728                     "automatically if an error occurs in the future.\n",
 729                     scm_cur_outp);
 730           SCM_VARIABLE_SET (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T);
 731         }
 732     }
 733   else
 734     {
 735       scm_puts ("No backtrace available.\n", scm_cur_outp);
 736     }
 737   return SCM_UNSPECIFIED;
 738 }
 739 #undef FUNC_NAME
 740
 741 \f
 742
 743 void
 744 scm_init_backtrace ()
 745 {
 746   SCM f = scm_make_fluid ();
 747   scm_the_last_stack_fluid_var = scm_c_define ("the-last-stack", f);
 748
 749 #include "libguile/backtrace.x"
 750 }
 751
 752 /*
 753   Local Variables:
 754   c-file-style: "gnu"
 755   End:
 756 */