* 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..

5 files changed, 219 insertions, 10 deletions

diff --git a/ChangeLog b/ChangeLog
index c784011..dff32d3 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,18 @@
+2002-12-16  David Gravereaux  <davygrvy@pobox.com>
+
+	* 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..
+
 2002-12-13  Don Porter  <dgp@users.sourceforge.net>
 
 	* unix/configure.in:	Updated configure of CVS snapshots to reflect
diff --git a/generic/tclPipe.c b/generic/tclPipe.c
index 5365047..7d1334d 100644
--- a/generic/tclPipe.c
+++ b/generic/tclPipe.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclPipe.c,v 1.6 2002/02/15 14:28:49 dkf Exp $
+ * RCS: @(#) $Id: tclPipe.c,v 1.7 2002/12/17 02:47:39 davygrvy Exp $
  */
 
 #include "tclInt.h"
@@ -280,9 +280,17 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan)
     Tcl_Pid pid;
     WAIT_STATUS_TYPE waitStatus;
     CONST char *msg;
+    unsigned long resolvedPid;
 
     abnormalExit = 0;
     for (i = 0; i < numPids; i++) {
+	/*
+	 * We need to get the resolved pid before we wait on it as
+	 * the windows implimentation of Tcl_WaitPid deletes the
+	 * information such that any following calls to TclpGetPid
+	 * fail.
+	 */
+	resolvedPid = TclpGetPid(pidPtr[i]);
         pid = Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0);
 	if (pid == (Tcl_Pid) -1) {
 	    result = TCL_ERROR;
@@ -315,7 +323,7 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan)
 	    char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE];
 
 	    result = TCL_ERROR;
-	    TclFormatInt(msg1, (long) TclpGetPid(pid));
+	    TclFormatInt(msg1, (long) resolvedPid);
 	    if (WIFEXITED(waitStatus)) {
                 if (interp != (Tcl_Interp *) NULL) {
 		    TclFormatInt(msg2, WEXITSTATUS(waitStatus));
diff --git a/tests/winPipe.test b/tests/winPipe.test
index 28b2708..26a7e33 100644
--- a/tests/winPipe.test
+++ b/tests/winPipe.test
@@ -12,7 +12,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: winPipe.test,v 1.21 2002/07/18 16:39:50 vincentdarley Exp $
+# RCS: @(#) $Id: winPipe.test,v 1.22 2002/12/17 02:47:39 davygrvy Exp $
 
 package require tcltest
 namespace import -force ::tcltest::*
@@ -198,6 +198,34 @@ test winpipe-4.1 {Tcl_WaitPid} {pcOnly nt exec cat32} {
     vwait x
     list $result $x [contents $path(stderr)]
 } "{$big} 1 stderr32"
+test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {pcOnly exec} {
+    set f [open "|[tcltest::interpreter]" w+]
+    set pid [pid $f]
+    puts $f "testexcept float_underflow"
+    set status [catch {close $f}]
+    list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
+} {1 1 SIGFPE}
+test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {pcOnly exec} {
+    set f [open "|[tcltest::interpreter]" w+]
+    set pid [pid $f]
+    puts $f "testexcept access_violation"
+    set status [catch {close $f}]
+    list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
+} {1 1 SIGSEGV}
+test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {pcOnly exec} {
+    set f [open "|[tcltest::interpreter]" w+]
+    set pid [pid $f]
+    puts $f "testexcept illegal_instruction"
+    set status [catch {close $f}]
+    list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
+} {1 1 SIGILL}
+test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {pcOnly exec} {
+    set f [open "|[tcltest::interpreter]" w+]
+    set pid [pid $f]
+    puts $f "testexcept ctrl+c"
+    set status [catch {close $f}]
+    list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
+} {1 1 SIGINT}
 
 set path(nothing) [makeFile {} nothing]
 close [open $path(nothing) w]
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;
+}