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
  54 #include "backtrace.h"
  55
  56 /* {Error reporting and backtraces}
  57  * (A first approximation.)
  58  *
  59  * Note that these functions shouldn't generate errors themselves.
  60  */
  61
  62 #ifndef SCM_RECKLESS
  63 #undef SCM_ASSERT
  64 #define SCM_ASSERT(_cond, _arg, _pos, _subr) \
  65         if (!(_cond)) \
  66           return SCM_BOOL_F;
  67 #endif
  68
  69 static void display_header SCM_P ((SCM source, SCM port));
  70 static void
  71 display_header (source, port)
  72      SCM source;
  73      SCM port;
  74 {
  75   SCM fname = (SCM_NIMP (source) && SCM_MEMOIZEDP (source)
  76                ? scm_source_property (source, scm_i_filename)
  77                : SCM_BOOL_F);
  78   if (SCM_NIMP (fname) && SCM_STRINGP (fname))
  79     {
  80       scm_prin1 (fname, port, 0);
  81       scm_gen_putc (':', port);
  82       scm_prin1 (scm_source_property (source, scm_i_line), port, 0);
  83       scm_gen_putc (':', port);
  84       scm_prin1 (scm_source_property (source, scm_i_column), port, 0);
  85     }
  86   else
  87     scm_gen_puts (scm_regular_string, "ERROR", port);
  88   scm_gen_puts (scm_regular_string, ": ", port);
  89 }
  90
  91
  92 void
  93 scm_display_error_message (message, args, port)
  94      SCM message;
  95      SCM args;
  96      SCM port;
  97 {
  98   int writingp;
  99   char *start;
 100   char *p;
 101
 102   if (SCM_IMP (message) || !SCM_ROSTRINGP (message) || SCM_IMP (args)
 103       || !scm_list_p (args))
 104     {
 105       scm_prin1 (message, port, 0);
 106       scm_gen_putc ('\n', port);
 107       return;
 108     }
 109
 110   SCM_COERCE_SUBSTR (message);
 111   start = SCM_ROCHARS (message);
 112   for (p = start; *p != '\0'; ++p)
 113     if (*p == '%')
 114       {
 115         if (SCM_IMP (args) || SCM_NCONSP (args))
 116           continue;
 117
 118         ++p;
 119         if (*p == 's')
 120           writingp = 0;
 121         else if (*p == 'S')
 122           writingp = 1;
 123         else
 124           continue;
 125
 126         scm_gen_write (scm_regular_string, start, p - start - 1, port);
 127         scm_prin1 (SCM_CAR (args), port, writingp);
 128         args = SCM_CDR (args);
 129         start = p + 1;
 130       }
 131   scm_gen_write (scm_regular_string, start, p - start, port);
 132   scm_gen_putc ('\n', port);
 133 }
 134
 135 static void display_expression SCM_P ((SCM frame, SCM pname, SCM source, SCM port));
 136 static void
 137 display_expression (frame, pname, source, port)
 138      SCM frame;
 139      SCM pname;
 140      SCM source;
 141      SCM port;
 142 {
 143   SCM print_state = scm_make_print_state ();
 144   scm_print_state *pstate = SCM_PRINT_STATE (print_state);
 145   pstate->writingp = 0;
 146   pstate->fancyp = 1;
 147   pstate->level = 2;
 148   pstate->length = 3;
 149   if (SCM_NIMP (pname) && SCM_ROSTRINGP (pname))
 150     {
 151       if (SCM_NIMP (frame)
 152           && SCM_FRAMEP (frame)
 153           && SCM_FRAME_EVAL_ARGS_P (frame))
 154         scm_gen_puts (scm_regular_string, "While evaluating arguments to ", port);
 155       else
 156         scm_gen_puts (scm_regular_string, "In procedure ", port);
 157       scm_iprin1 (pname, port, pstate);
 158       if (SCM_NIMP (source) && SCM_MEMOIZEDP (source))
 159         {
 160           scm_gen_puts (scm_regular_string, " in expression ", port);
 161           pstate->writingp = 1;
 162           scm_iprin1 (scm_unmemoize (source), port, pstate);
 163         }
 164     }
 165   else if (SCM_NIMP (source))
 166     {
 167       scm_gen_puts (scm_regular_string, "In expression ", port);
 168       pstate->writingp = 1;
 169       scm_iprin1 (scm_unmemoize (source), port, pstate);
 170     }
 171   scm_gen_puts (scm_regular_string, ":\n", port);
 172   scm_free_print_state (print_state);
 173 }
 174
 175 SCM_PROC(s_display_error, "display-error", 6, 0, 0, scm_display_error);
 176 SCM
 177 scm_display_error (stack, port, subr, message, args, rest)
 178      SCM stack;
 179      SCM port;
 180      SCM subr;
 181      SCM message;
 182      SCM args;
 183      SCM rest;
 184 {
 185   SCM current_frame = SCM_BOOL_F;
 186   SCM source = SCM_BOOL_F;
 187   SCM pname = SCM_BOOL_F;
 188   if (SCM_DEBUGGINGP
 189       && SCM_NIMP (stack)
 190       && SCM_STACKP (stack)
 191       && SCM_STACK_LENGTH (stack) > 0)
 192     {
 193       current_frame = scm_stack_ref (stack, SCM_INUM0);
 194       source = SCM_FRAME_SOURCE (current_frame);
 195       if (!(SCM_NIMP (source) && SCM_MEMOIZEDP (source)))
 196         source = SCM_FRAME_SOURCE (SCM_FRAME_PREV (current_frame));
 197       if (SCM_FRAME_PROC_P (current_frame)
 198           && scm_procedure_p (SCM_FRAME_PROC (current_frame)) == SCM_BOOL_T)
 199         pname = scm_procedure_name (SCM_FRAME_PROC (current_frame));
 200     }
 201   if (!(SCM_NIMP (pname) && SCM_ROSTRINGP (pname)))
 202     pname = subr;
 203   if ((SCM_NIMP (source) && SCM_MEMOIZEDP (source))
 204       || (SCM_NIMP (pname) && SCM_ROSTRINGP (pname)))
 205     {
 206       display_header (source, port);
 207       display_expression (current_frame, pname, source, port);
 208     }
 209   display_header (source, port);
 210   scm_display_error_message (message, args, port);
 211   return SCM_UNSPECIFIED;
 212 }
 213
 214 static void indent SCM_P ((int n, SCM port));
 215 static void
 216 indent (n, port)
 217      int n;
 218      SCM port;
 219 {
 220   int i;
 221   for (i = 0; i < n; ++i)
 222     scm_gen_putc (' ', port);
 223 }
 224
 225 static void display_frame_expr SCM_P ((char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate));
 226 static void
 227 display_frame_expr (hdr, exp, tlr, indentation, sport, port, pstate)
 228      char *hdr;
 229      SCM exp;
 230      char *tlr;
 231      int indentation;
 232      SCM sport;
 233      SCM port;
 234      scm_print_state *pstate;
 235 {
 236   if (SCM_NIMP (exp) && SCM_CONSP (exp))
 237     {
 238       scm_iprlist (hdr, exp, tlr[0], port, pstate);
 239       scm_gen_puts (scm_regular_string, &tlr[1], port);
 240     }
 241   else
 242     scm_iprin1 (exp, port, pstate);
 243   scm_gen_putc ('\n', port);
 244 }
 245
 246 static void display_application SCM_P ((SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate));
 247 static void
 248 display_application (frame, indentation, sport, port, pstate)
 249      SCM frame;
 250      int indentation;
 251      SCM sport;
 252      SCM port;
 253      scm_print_state *pstate;
 254 {
 255   SCM proc = SCM_FRAME_PROC (frame);
 256   SCM name = (SCM_NFALSEP (scm_procedure_p (proc))
 257               ? scm_procedure_name (proc)
 258               : SCM_BOOL_F);
 259   display_frame_expr ("[",
 260                       scm_cons (SCM_NFALSEP (name) ? name : proc,
 261                                 SCM_FRAME_ARGS (frame)),
 262                       SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]",
 263                       indentation,
 264                       sport,
 265                       port,
 266                       pstate);
 267 }
 268
 269 SCM_PROC(s_display_application, "display-application", 1, 1, 0, scm_display_application);
 270
 271 SCM
 272 scm_display_application (SCM frame, SCM port)
 273 {
 274   if (SCM_UNBNDP (port))
 275     port = scm_cur_outp;
 276   if (SCM_FRAME_PROC_P (frame))
 277     /* Display an application. */
 278     {
 279       SCM print_state;
 280       scm_print_state *pstate;
 281
 282       /* Create a print state for printing of frames. */
 283       print_state = scm_make_print_state ();
 284       pstate = SCM_PRINT_STATE (print_state);
 285       pstate->writingp = 1;
 286       pstate->fancyp = 1;
 287       pstate->level = 2;
 288       pstate->length = 9;
 289
 290       display_application (frame, 0, SCM_BOOL_F, port, pstate); /*fixme*/
 291       return SCM_BOOL_T;
 292     }
 293   else
 294     return SCM_BOOL_F;
 295 }
 296
 297 static void display_frame SCM_P ((SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate));
 298 static void
 299 display_frame (frame, nfield, indentation, sport, port, pstate)
 300      SCM frame;
 301      int nfield;
 302      int indentation;
 303      SCM sport;
 304      SCM port;
 305      scm_print_state *pstate;
 306 {
 307   int n, i, j;
 308
 309   /* Announce missing frames? */
 310   if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
 311     {
 312       indent (nfield + 1 + indentation, port);
 313       scm_gen_puts (scm_regular_string, "...\n", port);
 314     }
 315
 316   /* Check size of frame number. */
 317   n = SCM_FRAME_NUMBER (frame);
 318   for (i = 0, j = n; j > 0; ++i) j /= 10;
 319
 320   /* Number indentation. */
 321   indent (nfield - (i ? i : 1), port);
 322
 323   /* Frame number. */
 324   scm_iprin1 (SCM_MAKINUM (n), port, pstate);
 325
 326   /* Real frame marker */
 327   scm_gen_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port);
 328
 329   /* Indentation. */
 330   indent (indentation, port);
 331
 332   if (SCM_FRAME_PROC_P (frame))
 333     /* Display an application. */
 334     display_application (frame, nfield + 1 + indentation, sport, port, pstate);
 335   else
 336     /* Display a special form. */
 337     {
 338       SCM source = SCM_FRAME_SOURCE (frame);
 339       SCM copy = scm_source_property (source, scm_i_copy);
 340       display_frame_expr ("(",
 341                           SCM_NIMP (copy) && SCM_CONSP (copy)
 342                           ? copy
 343                           : scm_unmemoize (source),
 344                           ")",
 345                           nfield + 1 + indentation,
 346                           sport,
 347                           port,
 348                           pstate);
 349     }
 350
 351   /* Announce missing frames? */
 352   if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
 353     {
 354       indent (nfield + 1 + indentation, port);
 355       scm_gen_puts (scm_regular_string, "...\n", port);
 356     }
 357 }
 358
 359 SCM_PROC(s_display_backtrace, "display-backtrace", 2, 2, 0, scm_display_backtrace);
 360 SCM
 361 scm_display_backtrace (stack, port, first, depth)
 362      SCM stack;
 363      SCM port;
 364      SCM first;
 365      SCM depth;
 366 {
 367   int n_frames, beg, end, n, i, j;
 368   int nfield, indent_p, indentation;
 369   SCM frame, sport, print_state;
 370   scm_print_state *pstate;
 371
 372   /* Argument checking and extraction. */
 373   SCM_ASSERT (SCM_NIMP (stack) && SCM_STACKP (stack),
 374               stack,
 375               SCM_ARG1,
 376               s_display_backtrace);
 377   SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port),
 378               port,
 379               SCM_ARG2,
 380               s_display_backtrace);
 381   n_frames = SCM_INUM (scm_stack_length (stack));
 382   n = SCM_INUMP (depth) ? SCM_INUM (depth) : SCM_BACKTRACE_DEPTH;
 383   if (SCM_BACKWARDS_P)
 384     {
 385       beg = SCM_INUMP (first) ? SCM_INUM (first) : 0;
 386       end = beg + n - 1;
 387       if (end >= n_frames)
 388         end = n_frames - 1;
 389       n = end - beg + 1;
 390     }
 391   else
 392     {
 393       if (SCM_INUMP (first))
 394         {
 395           beg = SCM_INUM (first);
 396           end = beg - n + 1;
 397           if (end < 0)
 398             end = 0;
 399         }
 400       else
 401         {
 402           beg = n - 1;
 403           end = 0;
 404           if (beg >= n_frames)
 405             beg = n_frames - 1;
 406         }
 407       n = beg - end + 1;
 408     }
 409   SCM_ASSERT (beg >= 0 && beg < n_frames, first, SCM_ARG3, s_display_backtrace);
 410   SCM_ASSERT (n > 0, depth, SCM_ARG4, s_display_backtrace);
 411
 412   /* Create a string port used for adaptation of printing parameters. */
 413   sport = scm_mkstrport (SCM_INUM0,
 414                          scm_make_string (SCM_MAKINUM (240), SCM_UNDEFINED),
 415                          SCM_OPN | SCM_WRTNG,
 416                          s_display_backtrace);
 417
 418   /* Create a print state for printing of frames. */
 419   print_state = scm_make_print_state ();
 420   pstate = SCM_PRINT_STATE (print_state);
 421   pstate->writingp = 1;
 422   pstate->fancyp = 1;
 423   pstate->level = 2;
 424   pstate->length = 3;
 425
 426   /* First find out if it's reasonable to do indentation. */
 427   if (SCM_BACKWARDS_P)
 428     indent_p = 0;
 429   else
 430     {
 431       indent_p = 1;
 432       frame = scm_stack_ref (stack, SCM_MAKINUM (beg));
 433       for (i = 0, j = 0; i < n; ++i)
 434         {
 435           if (SCM_FRAME_REAL_P (frame))
 436             ++j;
 437           if (j > SCM_BACKTRACE_INDENT)
 438             {
 439               indent_p = 0;
 440               break;
 441             }
 442           frame = (SCM_BACKWARDS_P
 443                    ? SCM_FRAME_PREV (frame)
 444                    : SCM_FRAME_NEXT (frame));
 445         }
 446     }
 447
 448   /* Determine size of frame number field. */
 449   j = SCM_FRAME_NUMBER (scm_stack_ref (stack, SCM_MAKINUM (end)));
 450   for (i = 0; j > 0; ++i) j /= 10;
 451   nfield = i ? i : 1;
 452
 453   scm_gen_puts (scm_regular_string, "Backtrace:\n", port);
 454
 455   /* Print frames. */
 456   frame = scm_stack_ref (stack, SCM_MAKINUM (beg));
 457   indentation = 1;
 458   display_frame (frame, nfield, indentation, sport, port, pstate);
 459   for (i = 1; i < n; ++i)
 460     {
 461       if (indent_p && SCM_FRAME_EVAL_ARGS_P (frame))
 462         ++indentation;
 463       frame = SCM_BACKWARDS_P ? SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame);
 464       display_frame (frame, nfield, indentation, sport, port, pstate);
 465     }
 466
 467   return SCM_UNSPECIFIED;
 468 }
 469
 470 SCM_VCELL (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?");
 471
 472 SCM_PROC(s_backtrace, "backtrace", 0, 0, 0, scm_backtrace);
 473 SCM
 474 scm_backtrace ()
 475 {
 476   if (SCM_NFALSEP (SCM_CDR (scm_the_last_stack_var)))
 477     {
 478       scm_newline (scm_cur_outp);
 479       scm_display_backtrace (SCM_CDR (scm_the_last_stack_var),
 480                              scm_cur_outp,
 481                              SCM_UNDEFINED,
 482                              SCM_UNDEFINED);
 483       scm_newline (scm_cur_outp);
 484       if (SCM_FALSEP (SCM_CDR (scm_has_shown_backtrace_hint_p_var))
 485           && !SCM_BACKTRACE_P)
 486         {
 487           scm_gen_puts (scm_regular_string,
 488                         "Type \"(debug-enable 'backtrace)\" if you would like "
 489                         "a backtrace\n"
 490                         "automatically if an error occurs in the future.\n",
 491                         scm_cur_outp);
 492           SCM_SETCDR (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T);
 493         }
 494     }
 495   else
 496     {
 497       scm_gen_puts (scm_regular_string,
 498                     "No backtrace available.\n",
 499                     scm_cur_outp);
 500     }
 501   return SCM_UNSPECIFIED;
 502 }
 503
 504 \f
 505
 506 void
 507 scm_init_backtrace ()
 508 {
 509   scm_the_last_stack_var = scm_sysintern ("the-last-stack", SCM_BOOL_F);
 510
 511 #include "backtrace.x"
 512 }