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

/* ----------------------------------------------------------------------------- 
 * wadtcl.c
 *
 *     Dynamically loadable Tcl module for wad.
 * 
 * Author(s) : David Beazley (beazley@cs.uchicago.edu)
 *
 * Copyright (C) 2000.  The University of Chicago. 
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 * 
 * See the file COPYING for a complete copy of the LGPL.
 * ----------------------------------------------------------------------------- */

#include <tcl.h>
#include "wad.h"
#include <signal.h>

static char cvs[] = "$Id: wadtcl.c 10001 2007-10-17 21:33:57Z wsfulton $";

/* Handler function */	
static void handler(int signo, WadFrame *frame, char *ret) {
  static char message[65536];
  static char temp[1024];
  int  len = 0;
  char *name;
  WadFrame *f;
  WadFrame *fline = 0;
  char *srcstr= 0;
  Tcl_Interp *interp;
  int err;
  char  *type;

  if (!ret) {
    wad_default_callback(signo, frame, ret);
    return;
  }

  strcpy(message,"[ C stack trace ]\n\n");
  switch(signo) {
  case SIGSEGV:
    type = (char*)"Segmentation fault.";
    break;
  case SIGBUS:
    type = (char*)"Bus error.";
    break;
  case SIGABRT:
    type = (char*)"Abort.";
    break;
  case SIGFPE:
    type = (char*)"Floating point exception.";
    break;
  default:
    type = (char*)"Unknown.";
    break;
  }

  f = frame;
  /* Find the last exception frame */
  while (!f->last) {
    f= f->next;
  }
  /* Now work backwards */
  f = f->prev;
  while (f) {
    strcat(message, f->debug_str);
    if (f->debug_srcstr) srcstr = f->debug_srcstr;
    f = f->prev;
  }
  if (srcstr) {
    strcat(message,"\n");
    strcat(message, srcstr);
    strcat(message,"\n");
  }

  if (wad_heap_overflow) {
    write(2, "WAD: Heap overflow detected.\n", 30);
    wad_default_callback(signo, frame, ret);
  }

  /* Note: if the heap is blown, there is a very good chance that this
  function will not succeed and we'll dump core.  However, the check
  above should dump a stack trace to stderr just in case we don't make it
  back. */

  /* Try to get the Tcl interpreter through magic */
  if (ret) {
    interp = (Tcl_Interp *) wad_steal_outarg(frame,ret,1,&err);
    if (err == 0) {
      Tcl_SetResult(interp,type,TCL_STATIC);
      Tcl_AddErrorInfo(interp,message);
    }
  }
}

void tclwadinit() {
  printf("WAD Enabled\n");
  wad_init();
  wad_set_callback(handler);
  wad_set_return("TclExecuteByteCode", TCL_ERROR);
  wad_set_return("EvalObjv", TCL_ERROR);
}

int Wad_Init(Tcl_Interp *interp) {
  return TCL_OK;
}

int Wadtcl_Init(Tcl_Interp *interp) {
  return TCL_OK;
}