/tags/rel-1.3.35/Tools/WAD/Tcl/wadtcl.c

  1/* ----------------------------------------------------------------------------- 
  2 * wadtcl.c
  3 *
  4 *     Dynamically loadable Tcl module for wad.
  5 * 
  6 * Author(s) : David Beazley (beazley@cs.uchicago.edu)
  7 *
  8 * Copyright (C) 2000.  The University of Chicago. 
  9 *
 10 * This library is free software; you can redistribute it and/or
 11 * modify it under the terms of the GNU Lesser General Public
 12 * License as published by the Free Software Foundation; either
 13 * version 2.1 of the License, or (at your option) any later version.
 14 *
 15 * This library is distributed in the hope that it will be useful,
 16 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 17 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 18 * Lesser General Public License for more details.
 19 *
 20 * You should have received a copy of the GNU Lesser General Public
 21 * License along with this library; if not, write to the Free Software
 22 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 23 * 
 24 * See the file COPYING for a complete copy of the LGPL.
 25 * ----------------------------------------------------------------------------- */
 26
 27#include <tcl.h>
 28#include "wad.h"
 29#include <signal.h>
 30
 31static char cvs[] = "$Id: wadtcl.c 10001 2007-10-17 21:33:57Z wsfulton $";
 32
 33/* Handler function */	
 34static void handler(int signo, WadFrame *frame, char *ret) {
 35  static char message[65536];
 36  static char temp[1024];
 37  int  len = 0;
 38  char *name;
 39  WadFrame *f;
 40  WadFrame *fline = 0;
 41  char *srcstr= 0;
 42  Tcl_Interp *interp;
 43  int err;
 44  char  *type;
 45
 46  if (!ret) {
 47    wad_default_callback(signo, frame, ret);
 48    return;
 49  }
 50
 51  strcpy(message,"[ C stack trace ]\n\n");
 52  switch(signo) {
 53  case SIGSEGV:
 54    type = (char*)"Segmentation fault.";
 55    break;
 56  case SIGBUS:
 57    type = (char*)"Bus error.";
 58    break;
 59  case SIGABRT:
 60    type = (char*)"Abort.";
 61    break;
 62  case SIGFPE:
 63    type = (char*)"Floating point exception.";
 64    break;
 65  default:
 66    type = (char*)"Unknown.";
 67    break;
 68  }
 69
 70  f = frame;
 71  /* Find the last exception frame */
 72  while (!f->last) {
 73    f= f->next;
 74  }
 75  /* Now work backwards */
 76  f = f->prev;
 77  while (f) {
 78    strcat(message, f->debug_str);
 79    if (f->debug_srcstr) srcstr = f->debug_srcstr;
 80    f = f->prev;
 81  }
 82  if (srcstr) {
 83    strcat(message,"\n");
 84    strcat(message, srcstr);
 85    strcat(message,"\n");
 86  }
 87
 88  if (wad_heap_overflow) {
 89    write(2, "WAD: Heap overflow detected.\n", 30);
 90    wad_default_callback(signo, frame, ret);
 91  }
 92
 93  /* Note: if the heap is blown, there is a very good chance that this
 94  function will not succeed and we'll dump core.  However, the check
 95  above should dump a stack trace to stderr just in case we don't make it
 96  back. */
 97
 98  /* Try to get the Tcl interpreter through magic */
 99  if (ret) {
100    interp = (Tcl_Interp *) wad_steal_outarg(frame,ret,1,&err);
101    if (err == 0) {
102      Tcl_SetResult(interp,type,TCL_STATIC);
103      Tcl_AddErrorInfo(interp,message);
104    }
105  }
106}
107
108void tclwadinit() {
109  printf("WAD Enabled\n");
110  wad_init();
111  wad_set_callback(handler);
112  wad_set_return("TclExecuteByteCode", TCL_ERROR);
113  wad_set_return("EvalObjv", TCL_ERROR);
114}
115
116int Wad_Init(Tcl_Interp *interp) {
117  return TCL_OK;
118}
119
120int Wadtcl_Init(Tcl_Interp *interp) {
121  return TCL_OK;
122}