libguile/backtrace.c

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