/tags/wad-0-2-1/SWIG/Tools/WAD/Tcl/wadtcl.c
C | 118 lines | 74 code | 11 blank | 33 comment | 9 complexity | 108e5ab8b29effb0c1e8fe080daf48a7 MD5 | raw file
Possible License(s): LGPL-2.1, Cube, GPL-3.0, 0BSD, GPL-2.0
- /* -----------------------------------------------------------------------------
- * 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[] = "$Header$";
- /* 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;
- }