* generic/tclPipe.c (TclCleanupChildren):

	* tests/winPipe.c:
	* win/tclWinPipe.c (Tcl_WaitPid):
	* win/tclWinTest.c:  Gave Tcl_WaitPid the ability to return a
	Win32 exception code translated into a posix style SIG*.  This
	allows [close] to report "CHILDKILLED" without the meaning
	getting lost in a truncated exit code.  In TclCleanupChildren(),
	TclpGetPid() had to get moved to before Tcl_WaitPid() as the
	the handle is removed from the list taking away the ability
	to get the process id after the wait is done.  This shouldn't
	effect the unix implimentaion unless waitpid is called with
	a pid of zero, meaning "any".  I don't think it is..

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;
+}