diff options
Diffstat (limited to 'win')
| -rw-r--r-- | win/tclWinPipe.c | 57 | ||||
| -rw-r--r-- | win/tclWinTest.c | 115 |
2 files changed, 165 insertions, 7 deletions
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 64ecf6d..a8071c0 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinPipe.c,v 1.31 2002/12/05 00:15:01 davygrvy Exp $ + * RCS: @(#) $Id: tclWinPipe.c,v 1.32 2002/12/17 02:47:39 davygrvy Exp $ */ #include "tclWinInt.h" @@ -2452,7 +2452,7 @@ Tcl_WaitPid( ProcInfo *infoPtr, **prevPtrPtr; DWORD flags; Tcl_Pid result; - DWORD ret; + DWORD ret, exitCode; PipeInit(); @@ -2507,9 +2507,56 @@ Tcl_WaitPid( } else { result = 0; } - } else if (ret != WAIT_FAILED) { - GetExitCodeProcess(infoPtr->hProcess, (DWORD*)statPtr); - *statPtr = ((*statPtr << 8) & 0xff00); + } else if (ret == WAIT_OBJECT_0) { + GetExitCodeProcess(infoPtr->hProcess, &exitCode); + if (exitCode & 0xC0000000) { + /* + * A fatal exception occured. + */ + switch (exitCode) { + case EXCEPTION_FLT_DENORMAL_OPERAND: + case EXCEPTION_FLT_DIVIDE_BY_ZERO: + case EXCEPTION_FLT_INEXACT_RESULT: + case EXCEPTION_FLT_INVALID_OPERATION: + case EXCEPTION_FLT_OVERFLOW: + case EXCEPTION_FLT_STACK_CHECK: + case EXCEPTION_FLT_UNDERFLOW: + case EXCEPTION_INT_DIVIDE_BY_ZERO: + case EXCEPTION_INT_OVERFLOW: + *statPtr = SIGFPE; + break; + + case EXCEPTION_PRIV_INSTRUCTION: + case EXCEPTION_ILLEGAL_INSTRUCTION: + *statPtr = SIGILL; + break; + + case EXCEPTION_ACCESS_VIOLATION: + case EXCEPTION_DATATYPE_MISALIGNMENT: + case EXCEPTION_ARRAY_BOUNDS_EXCEEDED: + case EXCEPTION_STACK_OVERFLOW: + case EXCEPTION_NONCONTINUABLE_EXCEPTION: + case EXCEPTION_INVALID_DISPOSITION: + case EXCEPTION_GUARD_PAGE: + case EXCEPTION_INVALID_HANDLE: + *statPtr = SIGSEGV; + break; + + case CONTROL_C_EXIT: + *statPtr = SIGINT; + break; + + default: + *statPtr = SIGABRT; + break; + } + } else { + /* + * Non exception, normal, exit code. Note that the exit code + * is truncated to a byte range. + */ + *statPtr = ((exitCode << 8) & 0xff00); + } result = pid; } else { errno = ECHILD; diff --git a/win/tclWinTest.c b/win/tclWinTest.c index bda1f11..51b72e7 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinTest.c,v 1.7 2002/08/05 03:24:41 dgp Exp $ + * RCS: @(#) $Id: tclWinTest.c,v 1.8 2002/12/17 02:47:39 davygrvy Exp $ */ #define USE_COMPAT_CONST @@ -27,6 +27,8 @@ static int TestwinclockCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp* interp, int objc, Tcl_Obj *CONST objv[] )); +static Tcl_ObjCmdProc TestExceptionCmd; + /* *---------------------------------------------------------------------- @@ -34,7 +36,7 @@ static int TestwinclockCmd _ANSI_ARGS_(( ClientData dummy, * TclplatformtestInit -- * * Defines commands that test platform specific functionality for - * Unix platforms. + * Windows platforms. * * Results: * A standard Tcl result. @@ -59,6 +61,7 @@ TclplatformtestInit(interp) (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testexcept", TestExceptionCmd, NULL, NULL); return TCL_OK; } @@ -266,3 +269,111 @@ TestwinclockCmd( ClientData dummy, return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TestExceptionCmd -- + * + * Causes this process to end with the named exception. Used for + * testing Tcl_WaitPid(). + * + * Usage: + * testexcept <type> + * + * Parameters: + * Type of exception. + * + * Results: + * None, this process closes now and doesn't return. + * + * Side effects: + * This Tcl process closes, hard... Bang! + * + *---------------------------------------------------------------------- + */ + +static int +TestExceptionCmd( + ClientData dummy, /* Unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Argument count */ + Tcl_Obj *CONST objv[]) /* Argument vector */ +{ + static char *cmds[] = { + "access_violation", + "datatype_misalignment", + "array_bounds", + "float_denormal", + "float_divbyzero", + "float_inexact", + "float_invalidop", + "float_overflow", + "float_stack", + "float_underflow", + "int_divbyzero", + "int_overflow", + "private_instruction", + "inpageerror", + "illegal_instruction", + "noncontinue", + "stack_overflow", + "invalid_disp", + "guard_page", + "invalid_handle", + "ctrl+c", + NULL + }; + static DWORD exceptions[] = { + EXCEPTION_ACCESS_VIOLATION, + EXCEPTION_DATATYPE_MISALIGNMENT, + EXCEPTION_ARRAY_BOUNDS_EXCEEDED, + EXCEPTION_FLT_DENORMAL_OPERAND, + EXCEPTION_FLT_DIVIDE_BY_ZERO, + EXCEPTION_FLT_INEXACT_RESULT, + EXCEPTION_FLT_INVALID_OPERATION, + EXCEPTION_FLT_OVERFLOW, + EXCEPTION_FLT_STACK_CHECK, + EXCEPTION_FLT_UNDERFLOW, + EXCEPTION_INT_DIVIDE_BY_ZERO, + EXCEPTION_INT_OVERFLOW, + EXCEPTION_PRIV_INSTRUCTION, + EXCEPTION_IN_PAGE_ERROR, + EXCEPTION_ILLEGAL_INSTRUCTION, + EXCEPTION_NONCONTINUABLE_EXCEPTION, + EXCEPTION_STACK_OVERFLOW, + EXCEPTION_INVALID_DISPOSITION, + EXCEPTION_GUARD_PAGE, + EXCEPTION_INVALID_HANDLE, + CONTROL_C_EXIT + }; + int cmd; + + if ( objc != 2 ) { + Tcl_WrongNumArgs(interp, 0, objv, "<type-of-exception>"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], cmds, "command", 0, + &cmd) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Make sure the GPF dialog doesn't popup. + */ + + SetErrorMode(SEM_FAILCRITICALERRORS | SEM_NOGPFAULTERRORBOX); + + /* + * As Tcl does not handle structured exceptions, this falls all the way + * back up the instruction stack to the C run-time portion that called + * main() where the process will now be terminated with this exception + * code by the default handler the C run-time provides. + */ + + /* SMASH! */ + RaiseException(exceptions[cmd], EXCEPTION_NONCONTINUABLE, 0, NULL); + + /* NOTREACHED */ + return TCL_OK; +} |