libguile/backtrace.c

   1 /* Printing of backtraces and error messages
   2  * Copyright (C) 1996 Mikael Djurfeldt
   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, 675 Mass Ave, Cambridge, MA 02139, USA.
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.
  41  *
  42  * The author can be reached at djurfeldt@nada.kth.se
  43  * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
  44  */
  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_STRINGP (message) || SCM_IMP (args) || !scm_list_p (args))
 103     {
 104       scm_prin1 (message, port, 0);
 105       scm_gen_putc ('\n', port);
 106       return;
 107     }
 108
 109   start = SCM_CHARS (message);
 110   for (p = start; *p != '\0'; ++p)
 111     if (*p == '%')
 112       {
 113         if (SCM_IMP (args) || SCM_NCONSP (args))
 114           continue;
 115
 116         ++p;
 117         if (*p == 's')
 118           writingp = 0;
 119         else if (*p == 'S')
 120           writingp = 1;
 121         else
 122           continue;
 123
 124         scm_gen_write (scm_regular_string, start, p - start - 1, port);
 125         scm_prin1 (SCM_CAR (args), port, writingp);
 126         args = SCM_CDR (args);
 127         start = p + 1;
 128       }
 129   scm_gen_write (scm_regular_string, start, p - start, port);
 130   scm_gen_putc ('\n', port);
 131 }
 132
 133 static void display_expression SCM_P ((SCM frame, SCM pname, SCM source, SCM port));
 134 static void
 135 display_expression (frame, pname, source, port)
 136      SCM frame;
 137      SCM pname;
 138      SCM source;
 139      SCM port;
 140 {
 141   SCM print_state = scm_make_print_state ();
 142   scm_print_state *pstate = SCM_PRINT_STATE (print_state);
 143   pstate->writingp = 0;
 144   pstate->fancyp = 1;
 145   pstate->level = 2;
 146   pstate->length = 3;
 147   if (SCM_NIMP (pname) && SCM_ROSTRINGP (pname))
 148     {
 149       if (SCM_NIMP (frame)
 150           && SCM_FRAMEP (frame)
 151           && SCM_FRAME_EVAL_ARGS_P (frame))
 152         scm_gen_puts (scm_regular_string, "While evaluating arguments to ", port);
 153       else
 154         scm_gen_puts (scm_regular_string, "In procedure ", port);
 155       scm_iprin1 (pname, port, pstate);
 156       if (SCM_NIMP (source) && SCM_MEMOIZEDP (source))
 157         {
 158           scm_gen_puts (scm_regular_string, " in expression ", port);
 159           pstate->writingp = 1;
 160           scm_iprin1 (scm_unmemoize (source), port, pstate);
 161         }
 162     }
 163   else if (SCM_NIMP (source))
 164     {
 165       scm_gen_puts (scm_regular_string, "In expression ", port);
 166       pstate->writingp = 1;
 167       scm_iprin1 (scm_unmemoize (source), port, pstate);
 168     }
 169   scm_gen_puts (scm_regular_string, ":\n", port);
 170   scm_free_print_state (print_state);
 171 }
 172
 173 SCM_PROC(s_display_error, "display-error", 6, 0, 0, scm_display_error);
 174 SCM
 175 scm_display_error (stack, port, subr, message, args, rest)
 176      SCM stack;
 177      SCM port;
 178      SCM subr;
 179      SCM message;
 180      SCM args;
 181      SCM rest;
 182 {
 183   SCM current_frame = SCM_BOOL_F;
 184   SCM source = SCM_BOOL_F;
 185   SCM pname = SCM_BOOL_F;
 186   if (SCM_DEBUGGINGP
 187       && SCM_NIMP (stack)
 188       && SCM_STACKP (stack)
 189       && SCM_STACK_LENGTH (stack) > 0)
 190     {
 191       current_frame = scm_stack_ref (stack, SCM_INUM0);
 192       source = SCM_FRAME_SOURCE (current_frame);
 193       if (!(SCM_NIMP (source) && SCM_MEMOIZEDP (source)))
 194         source = SCM_FRAME_SOURCE (SCM_FRAME_PREV (current_frame));
 195       if (SCM_FRAME_PROC_P (current_frame)
 196           && scm_procedure_p (SCM_FRAME_PROC (current_frame)) == SCM_BOOL_T)
 197         pname = scm_procedure_name (SCM_FRAME_PROC (current_frame));
 198     }
 199   if (!(SCM_NIMP (pname) && SCM_ROSTRINGP (pname)))
 200     pname = subr;
 201   if ((SCM_NIMP (source) && SCM_MEMOIZEDP (source))
 202       || (SCM_NIMP (pname) && SCM_ROSTRINGP (pname)))
 203     {
 204       display_header (source, port);
 205       display_expression (current_frame, pname, source, port);
 206     }
 207   display_header (source, port);
 208   scm_display_error_message (message, args, port);
 209   return SCM_UNSPECIFIED;
 210 }
 211
 212 static void indent SCM_P ((int n, SCM port));
 213 static void
 214 indent (n, port)
 215      int n;
 216      SCM port;
 217 {
 218   int i;
 219   for (i = 0; i < n; ++i)
 220     scm_gen_putc (' ', port);
 221 }
 222
 223 static void display_frame_expr SCM_P ((char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate));
 224 static void
 225 display_frame_expr (hdr, exp, tlr, indentation, sport, port, pstate)
 226      char *hdr;
 227      SCM exp;
 228      char *tlr;
 229      int indentation;
 230      SCM sport;
 231      SCM port;
 232      scm_print_state *pstate;
 233 {
 234   pstate->level = 2;
 235   pstate->length = 3;
 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_frame SCM_P ((SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate));
 247 static void
 248 display_frame (frame, nfield, indentation, sport, port, pstate)
 249      SCM frame;
 250      int nfield;
 251      int indentation;
 252      SCM sport;
 253      SCM port;
 254      scm_print_state *pstate;
 255 {
 256   int n, i, j;
 257
 258   /* Announce missing frames? */
 259   if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
 260     {
 261       indent (nfield + 1 + indentation, port);
 262       scm_gen_puts (scm_regular_string, "...\n", port);
 263     }
 264
 265   /* Check size of frame number. */
 266   n = SCM_FRAME_NUMBER (frame);
 267   for (i = 0, j = n; j > 0; ++i) j /= 10;
 268
 269   /* Number indentation. */
 270   indent (nfield - (i ? i : 1), port);
 271
 272   /* Frame number. */
 273   scm_iprin1 (SCM_MAKINUM (n), port, pstate);
 274
 275   /* Real frame marker */
 276   scm_gen_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port);
 277
 278   /* Indentation. */
 279   indent (indentation, port);
 280
 281   if (SCM_FRAME_PROC_P (frame))
 282     /* Display an application. */
 283     {
 284       SCM proc = SCM_FRAME_PROC (frame);
 285       SCM name = (SCM_NFALSEP (scm_procedure_p (proc))
 286                   ? scm_procedure_name (proc)
 287                   : SCM_BOOL_F);
 288       display_frame_expr ("[",
 289                           scm_cons (SCM_NFALSEP (name) ? name : proc,
 290                                     SCM_FRAME_ARGS (frame)),
 291                           SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]",
 292                           nfield + 1 + indentation,
 293                           sport,
 294                           port,
 295                           pstate);
 296     }
 297   else
 298     /* Display a special form. */
 299     {
 300       SCM source = SCM_FRAME_SOURCE (frame);
 301       SCM copy = scm_source_property (source, scm_i_copy);
 302       display_frame_expr ("(",
 303                           SCM_NIMP (copy) && SCM_CONSP (copy)
 304                           ? copy
 305                           : scm_unmemoize (source),
 306                           ")",
 307                           nfield + 1 + indentation,
 308                           sport,
 309                           port,
 310                           pstate);
 311     }
 312
 313   /* Announce missing frames? */
 314   if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
 315     {
 316       indent (nfield + 1 + indentation, port);
 317       scm_gen_puts (scm_regular_string, "...\n", port);
 318     }
 319 }
 320
 321 SCM_PROC(s_display_backtrace, "display-backtrace", 2, 2, 0, scm_display_backtrace);
 322 SCM
 323 scm_display_backtrace (stack, port, first, depth)
 324      SCM stack;
 325      SCM port;
 326      SCM first;
 327      SCM depth;
 328 {
 329   int n_frames, beg, end, n, i, j;
 330   int nfield, indent_p, indentation;
 331   SCM frame, sport, print_state;
 332   scm_print_state *pstate;
 333
 334   /* Argument checking and extraction. */
 335   SCM_ASSERT (SCM_NIMP (stack) && SCM_STACKP (stack),
 336               stack,
 337               SCM_ARG1,
 338               s_display_backtrace);
 339   SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port),
 340               port,
 341               SCM_ARG2,
 342               s_display_backtrace);
 343   n_frames = SCM_INUM (scm_stack_length (stack));
 344   n = SCM_INUMP (depth) ? SCM_INUM (depth) : SCM_BACKTRACE_DEPTH;
 345   if (SCM_BACKWARDS_P)
 346     {
 347       beg = SCM_INUMP (first) ? SCM_INUM (first) : 0;
 348       end = beg + n - 1;
 349       if (end >= n_frames)
 350         end = n_frames - 1;
 351       n = end - beg + 1;
 352     }
 353   else
 354     {
 355       if (SCM_INUMP (first))
 356         {
 357           beg = SCM_INUM (first);
 358           end = beg - n + 1;
 359           if (end < 0)
 360             end = 0;
 361         }
 362       else
 363         {
 364           beg = n - 1;
 365           end = 0;
 366           if (beg >= n_frames)
 367             beg = n_frames - 1;
 368         }
 369       n = beg - end + 1;
 370     }
 371   SCM_ASSERT (beg >= 0 && beg < n_frames, first, SCM_ARG3, s_display_backtrace);
 372   SCM_ASSERT (n > 0, depth, SCM_ARG4, s_display_backtrace);
 373
 374   /* Create a string port used for adaptation of printing parameters. */
 375   sport = scm_mkstrport (SCM_INUM0,
 376                          scm_make_string (SCM_MAKINUM (240), SCM_UNDEFINED),
 377                          SCM_OPN | SCM_WRTNG,
 378                          s_display_backtrace);
 379
 380   /* Create a print state for printing of frames. */
 381   print_state = scm_make_print_state ();
 382   pstate = SCM_PRINT_STATE (print_state);
 383   pstate->writingp = 1;
 384   pstate->fancyp = 1;
 385
 386   /* First find out if it's reasonable to do indentation. */
 387   if (SCM_BACKWARDS_P)
 388     indent_p = 0;
 389   else
 390     {
 391       indent_p = 1;
 392       frame = scm_stack_ref (stack, SCM_MAKINUM (beg));
 393       for (i = 0, j = 0; i < n; ++i)
 394         {
 395           if (SCM_FRAME_REAL_P (frame))
 396             ++j;
 397           if (j > SCM_BACKTRACE_INDENT)
 398             {
 399               indent_p = 0;
 400               break;
 401             }
 402           frame = (SCM_BACKWARDS_P
 403                    ? SCM_FRAME_PREV (frame)
 404                    : SCM_FRAME_NEXT (frame));
 405         }
 406     }
 407
 408   /* Determine size of frame number field. */
 409   j = SCM_FRAME_NUMBER (scm_stack_ref (stack, SCM_MAKINUM (end)));
 410   for (i = 0; j > 0; ++i) j /= 10;
 411   nfield = i ? i : 1;
 412
 413   scm_gen_puts (scm_regular_string, "Backtrace:\n", port);
 414
 415   /* Print frames. */
 416   frame = scm_stack_ref (stack, SCM_MAKINUM (beg));
 417   indentation = 1;
 418   display_frame (frame, nfield, indentation, sport, port, pstate);
 419   for (i = 1; i < n; ++i)
 420     {
 421       if (indent_p && SCM_FRAME_EVAL_ARGS_P (frame))
 422         ++indentation;
 423       frame = SCM_BACKWARDS_P ? SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame);
 424       display_frame (frame, nfield, indentation, sport, port, pstate);
 425     }
 426
 427   return SCM_UNSPECIFIED;
 428 }
 429
 430 SCM_GLOBAL (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?");
 431
 432 SCM_PROC(s_backtrace, "backtrace", 0, 0, 0, scm_backtrace);
 433 SCM
 434 scm_backtrace ()
 435 {
 436   if (SCM_NFALSEP (SCM_CDR (scm_the_last_stack_var)))
 437     {
 438       scm_newline (scm_cur_outp);
 439       scm_display_backtrace (SCM_CDR (scm_the_last_stack_var),
 440                              scm_cur_outp,
 441                              SCM_UNDEFINED,
 442                              SCM_UNDEFINED);
 443       scm_newline (scm_cur_outp);
 444       if (SCM_FALSEP (SCM_CDR (scm_has_shown_backtrace_hint_p_var))
 445           && !SCM_BACKTRACE_P)
 446         {
 447           scm_gen_puts (scm_regular_string,
 448                         "Type \"(debug-enable 'backtrace)\" if you would like a backtrace
 449 automatically if an error occurs in the future.\n",
 450                         scm_cur_outp);
 451           SCM_SETCDR (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T);
 452         }
 453     }
 454   else
 455     {
 456       scm_gen_puts (scm_regular_string,
 457                     "No backtrace available.\n",
 458                     scm_cur_outp);
 459     }
 460   return SCM_UNSPECIFIED;
 461 }
 462
 463 \f
 464
 465 void
 466 scm_init_backtrace ()
 467 {
 468   scm_the_last_stack_var = scm_sysintern ("the-last-stack", SCM_BOOL_F);
 469
 470 #include "backtrace.x"
 471 }