Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcl/tcl/ChangeLog,v
retrieving revision 1.1762
diff -u -r1.1762 ChangeLog
--- ChangeLog	15 Nov 2003 23:42:42 -0000	1.1762
+++ ChangeLog	16 Nov 2003 00:46:01 -0000
@@ -1,3 +1,13 @@
+2003-11-16  Donal K. Fellows  <donal.k.fellows@man.ac.uk>
+
+	* generic/tclExecute.c (TclExecuteByteCode): Make sure that
+	Tcl_AsyncInvoke is called regularly when processing bytecodes.
+	* generic/tclTest.c (AsyncThreadProc, TestasyncCmd): Extended
+	testing harness to send an asynchronous marking without relying on
+	UNIX signals.
+	* tests/async.test (async-4.*): Tests to check that async events
+	are handled by the bytecode core. [Bug 746722]
+
 2003-11-15  Donal K. Fellows  <donal.k.fellows@man.ac.uk>
 
 	* generic/tclTest.c (TestHashSystemHashCmd): Removed 'const'
Index: generic/tclExecute.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclExecute.c,v
retrieving revision 1.114
diff -u -r1.114 tclExecute.c
--- generic/tclExecute.c	14 Nov 2003 20:44:44 -0000	1.114
+++ generic/tclExecute.c	16 Nov 2003 00:46:02 -0000
@@ -62,6 +62,16 @@
 #endif /* !DBL_MAX */
 
 /*
+ * A mask (should be 2**n-1) that is used to work out when the
+ * bytecode engine should call Tcl_AsyncReady() to see whether there
+ * is a signal that needs handling.
+ */
+
+#ifndef ASYNC_CHECK_COUNT_MASK
+#   define ASYNC_CHECK_COUNT_MASK	15
+#endif /* !ASYNC_CHECK_COUNT_MASK */
+
+/*
  * Boolean flag indicating whether the Tcl bytecode interpreter has been
  * initialized.
  */
@@ -1088,6 +1098,7 @@
     int traceInstructions = (tclTraceExec == 3);
     char cmdNameBuf[21];
 #endif
+    int instructionCount = 0;
 
     /*
      * The execution uses a unified stack: first the catch stack, immediately
@@ -1202,6 +1213,21 @@
 #ifdef TCL_COMPILE_STATS    
     iPtr->stats.instructionCount[*pc]++;
 #endif
+
+    /*
+     * Check for asynchronous handlers [Bug 746722]; we
+     * do the check every 16th instruction.
+     */
+
+    if (!(instructionCount++ & ASYNC_CHECK_COUNT_MASK) && Tcl_AsyncReady()) {
+	DECACHE_STACK_INFO();
+	result = Tcl_AsyncInvoke(interp, result);
+	CACHE_STACK_INFO();
+	if (result == TCL_ERROR) {
+	    goto checkForCatch;
+	}
+    }
+
     switch (*pc) {
     case INST_RETURN:
 	if (iPtr->returnOpts != iPtr->defaultReturnOpts) {
@@ -1210,6 +1236,7 @@
 	    Tcl_IncrRefCount(iPtr->returnOpts);
 	}
 	result = TCL_RETURN;
+
     case INST_DONE:
 	if (tosPtr <= eePtr->stackPtr + initStackTop) {
 	    tosPtr--;
@@ -1491,6 +1518,14 @@
 
 	    preservedStackRefCountPtr = (char **) (eePtr->stackPtr-1);
 	    ++*preservedStackRefCountPtr;
+
+	    /*
+	     * Reset the instructionCount variable, since we're about
+	     * to check for async stuff anyway while processing
+	     * TclEvalObjvInternal.
+	     */
+
+	    instructionCount = 1;
 
 	    /*
 	     * Finally, let TclEvalObjvInternal handle the command. 
Index: generic/tclTest.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclTest.c,v
retrieving revision 1.72
diff -u -r1.72 tclTest.c
--- generic/tclTest.c	15 Nov 2003 23:42:42 -0000	1.72
+++ generic/tclTest.c	16 Nov 2003 00:46:03 -0000
@@ -129,6 +129,9 @@
 int			Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));
 static int		AsyncHandlerProc _ANSI_ARGS_((ClientData clientData,
 			    Tcl_Interp *interp, int code));
+#ifdef TCL_THREADS
+static Tcl_ThreadCreateType AsyncThreadProc _ANSI_ARGS_((ClientData));
+#endif
 static void		CleanupTestSetassocdataTests _ANSI_ARGS_((
 			    ClientData clientData, Tcl_Interp *interp));
 static void		CmdDelProc1 _ANSI_ARGS_((ClientData clientData));
@@ -840,11 +843,39 @@
 	}
 	Tcl_SetResult(interp, (char *)argv[3], TCL_VOLATILE);
 	return code;
+#ifdef TCL_THREADS
+    } else if (strcmp(argv[1], "marklater") == 0) {
+	if (argc != 3) {
+	    goto wrongNumArgs;
+	}
+	if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	for (asyncPtr = firstHandler; asyncPtr != NULL;
+		asyncPtr = asyncPtr->nextPtr) {
+	    if (asyncPtr->id == id) {
+		Tcl_ThreadId threadID;
+		if (Tcl_CreateThread(&threadID, AsyncThreadProc,
+			(ClientData) asyncPtr, TCL_THREAD_STACK_DEFAULT,
+			TCL_THREAD_NOFLAGS) != TCL_OK) {
+		    Tcl_SetResult(interp, "can't create thread", TCL_STATIC);
+		    return TCL_ERROR;
+		}
+		break;
+	    }
+	}
+    } else {
+	Tcl_AppendResult(interp, "bad option \"", argv[1],
+		"\": must be create, delete, int, mark, or marklater",
+		(char *) NULL);
+	return TCL_ERROR;
+#else /* !TCL_THREADS */
     } else {
 	Tcl_AppendResult(interp, "bad option \"", argv[1],
 		"\": must be create, delete, int, or mark",
 		(char *) NULL);
 	return TCL_ERROR;
+#endif
     }
     return TCL_OK;
 }
@@ -878,6 +909,36 @@
     ckfree((char *)cmd);
     return code;
 }
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AsyncThreadProc --
+ *
+ *	Delivers an asynchronous event to a handler in another thread.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Invokes Tcl_AsyncMark on the handler
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef TCL_THREADS
+static Tcl_ThreadCreateType
+AsyncThreadProc(clientData)
+    ClientData clientData;	/* Parameter is a pointer to a
+				 * TestAsyncHandler, defined above. */
+{
+    TestAsyncHandler* asyncPtr = clientData;
+    Tcl_Sleep(1);
+    Tcl_AsyncMark(asyncPtr->handler);
+    Tcl_ExitThread(TCL_OK);
+    TCL_THREAD_CREATE_RETURN;
+}
+#endif
 
 /*
  *----------------------------------------------------------------------
Index: tests/async.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/async.test,v
retrieving revision 1.6
diff -u -r1.6 async.test
--- tests/async.test	24 Jul 2003 16:05:24 -0000	1.6
+++ tests/async.test	16 Nov 2003 00:46:03 -0000
@@ -25,6 +25,10 @@
     return
 }
 
+tcltest::testConstraint threaded [expr {
+    [info exists ::tcl_platform(threaded)] && $::tcl_platform(threaded)
+}]
+
 proc async1 {result code} {
     global aresult acode
     set aresult $result
@@ -146,19 +150,71 @@
     list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
 } {3 del2 {0 0 0 del1 del2}}
 
+proc nothing {} {
+    # empty proc
+}
+proc hang1 {handle} {
+    global aresult
+    set aresult {Async event not delivered}
+    testasync marklater $handle
+    for {set i 0} {
+	$i < 2500000  &&  $aresult eq "Async event not delivered"
+    } {incr i} {
+	nothing
+    }
+    return $aresult
+}
+proc hang2 {handle} {
+    global aresult
+    set aresult {Async event not delivered}
+    testasync marklater $handle
+    for {set i 0} {
+	$i < 2500000  &&  $aresult eq "Async event not delivered"
+    } {incr i} {}
+    return $aresult
+}
+proc hang3 {handle} [concat {
+    global aresult
+    set aresult {Async event not delivered}
+    testasync marklater $handle
+    set i 0
+} [string repeat {;incr i;} 1500000] {
+    return $aresult
+}]
+
+test async-4.1 {async interrupting bytecode sequence} -constraints {
+    threaded
+} -setup {
+    set hm [testasync create async3]
+} -body {
+    hang1 $hm
+} -result {test pattern} -cleanup {
+    testasync delete $hm
+}
+test async-4.2 {async interrupting straight bytecode sequence} -constraints {
+    threaded
+} -setup {
+    set hm [testasync create async3]
+} -body {
+    hang2 $hm
+} -result {test pattern} -cleanup {
+    testasync delete $hm
+}
+test async-4.3 {async interrupting loop-less bytecode sequence} -constraints {
+    threaded
+} -setup {
+    set hm [testasync create async3]
+} -body {
+    hang3 $hm
+} -result {test pattern} -cleanup {
+    testasync delete $hm
+}
+
 # cleanup
 testasync delete
 ::tcltest::cleanupTests
 return
 
-
-
-
-
-
-
-
-
-
-
-
+# Local Variables:
+# mode: tcl
+# End:
