summaryrefslogtreecommitdiffstats
path: root/win/tclWinTest.c
diff options
context:
space:
mode:
Diffstat (limited to 'win/tclWinTest.c')
-rw-r--r--win/tclWinTest.c115
1 files changed, 113 insertions, 2 deletions
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;
+}