'\"
'\" Copyright (c) 2018 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH abstract n 0.3 TclOO "TclOO Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
oo::abstract \- A class that does not allow direct instances of itself
.SH SYNOPSIS
.nf
package require tcl::oo

\fBoo::abstract\fI method \fR?\fIarg ...\fR?
.fi
.SH "CLASS HIERARCHY"

'\"
'\" Copyright (c) 2018 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH callback n 0.3 TclOO "TclOO Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
callback, mymethod \- Generate callbacks to methods
.SH SYNOPSIS
.nf
package require tcl::oo

\fBcallback\fI methodName\fR ?\fIarg ...\fR?
\fBmymethod\fI methodName\fR ?\fIarg ...\fR?
.fi

'\"
'\" Copyright (c) 2007 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH class n 0.1 TclOO "TclOO Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
oo::class \- The class of all classes
.SH SYNOPSIS
.nf
package require tcl::oo

\fBoo::class\fI method \fR?\fIarg ...\fR?
.fi
.SH "CLASS HIERARCHY"

'\"
'\" Copyright (c) 2011-2015 Andreas Kupries
'\" Copyright (c) 2018 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH classvariable n 0.3 TclOO "TclOO Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
classvariable \- Create link from local variable to variable in class
.SH SYNOPSIS
.nf
package require tcl::oo

\fBclassvariable\fI variableName\fR ?\fI...\fR?
.fi
.BE

'\"
'\" Copyright (c) 2019 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH configurable n 0.4 TclOO "TclOO Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
oo::configurable, configure, property \- A class that makes configurable classes and objects, and supports making configurable properties
.SH SYNOPSIS
.nf
package require TclOO

\fBoo::configurable create \fIclass\fR ?\fIdefinitionScript\fR?

\fBoo::define \fIclass\fB {\fR

'\"
'\" Copyright (c) 2023 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH const n 9.0 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
const \- Create and initialize a constant
.SH SYNOPSIS
\fBconst \fIvarName value\fR
.BE
.SH DESCRIPTION
.PP
This command is normally used within a procedure body (or method body,
or lambda term) to create a constant within that procedure, or within a

'\"
'\" Copyright (c) 2007 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH copy n 0.1 TclOO "TclOO Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
oo::copy \- Create copies of objects and classes
.SH SYNOPSIS
.nf
package require tcl::oo

\fBoo::copy\fI sourceObject \fR?\fItargetObject\fR? ?\fItargetNamespace\fR?
.fi
.BE

'\"
'\" Copyright (c) 2007-2018 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH define n 0.3 TclOO "TclOO Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
oo::define, oo::objdefine, oo::Slot \- Define and configure classes and objects
.SH SYNOPSIS
.nf
package require tcl::oo

\fBoo::define\fI class defScript\fR
\fBoo::define\fI class subcommand arg\fR ?\fIarg ...\fR?
\fBoo::objdefine\fI object defScript\fR

'\"
'\" Copyright (c) 1991-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH library n "8.0" Tcl "Tcl Built-In Commands"
.so man.macros
.BS
.SH NAME
auto_execok, auto_import, auto_load, auto_mkindex, auto_qualify, auto_reset, foreachLine, parray, readFile, tcl_findLibrary, tcl_endOfWord, tcl_nonwordchars, tcl_startOfNextWord, tcl_startOfPreviousWord, tcl_wordBreakAfter, tcl_wordBreakBefore, tcl_wordchars, writeFile \- Standard library of Tcl procedures
.SH SYNOPSIS
.nf
\fBauto_execok \fIcmd\fR
\fBauto_import \fIpattern\fR
\fBauto_load \fIcmd\fR
\fBauto_mkindex \fIdir pattern pattern ...\fR
\fBauto_qualify \fIcommand namespace\fR

'\"
'\" Copyright (c) 2011-2015 Andreas Kupries
'\" Copyright (c) 2018 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH link n 0.3 TclOO "TclOO Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
link \- Create link from command to method of object
.SH SYNOPSIS
.nf
package require tcl::oo

\fBlink\fI methodName\fR ?\fI...\fR?
\fBlink\fR \fB{\fIcommandName methodName\fB}\fR ?\fI...\fR?
.fi

'\"
'\" Copyright (c) 2007 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH my n 0.1 TclOO "TclOO Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
my, myclass \- Invoke any method of current object or its class
.SH SYNOPSIS
.nf
package require tcl::oo

\fBmy\fI methodName\fR ?\fIarg ...\fR?
\fBmyclass\fI methodName\fR ?\fIarg ...\fR?
.fi

'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH namespace n 8.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
namespace \- Create and manipulate contexts for commands and variables
.SH SYNOPSIS
\fBnamespace \fR\fIsubcommand\fR ?\fIarg ...\fR?
.BE
.SH DESCRIPTION
.PP
The \fBnamespace\fR command lets you create, access, and destroy
separate contexts for commands and variables.

'\"
'\" Copyright (c) 2007 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH next n 0.1 TclOO "TclOO Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
next, nextto \- Invoke superclass method implementations
.SH SYNOPSIS
.nf
package require tcl::oo

\fBnext\fR ?\fIarg ...\fR?
\fBnextto\fI class\fR ?\fIarg ...\fR?
.fi

'\"
'\" Copyright (c) 2007-2008 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH object n 0.1 TclOO "TclOO Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
oo::object \- The root class of the class hierarchy
.SH SYNOPSIS
.nf
package require tcl::oo

\fBoo::object\fI method \fR?\fIarg ...\fR?
.fi
.SH "CLASS HIERARCHY"

'\"
'\" Copyright (c) 2008 Peter Spjuth <pspjuth@users.sourceforge.net>
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH prefix n 8.6 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
tcl::prefix \- Facilities for prefix matching
.SH SYNOPSIS
.nf
\fB::tcl::prefix all\fI table string\fR
\fB::tcl::prefix longest\fI table string\fR
\fB::tcl::prefix match\fR ?\fIoption ...\fR? \fItable string\fR
.fi
.BE

'\"
'\" Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH refchan n 8.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
.\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
refchan \- Command handler API for channels implemented in Tcl code
.SH SYNOPSIS
.nf
\fBchan create \fImode cmdPrefix\fR

\fIcmdPrefix \fBblocking\fI channel mode\fR
\fIcmdPrefix \fBcget\fI channel option\fR
\fIcmdPrefix \fBcgetall\fI channel\fR

'\"
'\" Copyright (c) 2007 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH self n 0.1 TclOO "TclOO Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
self \- Current method call introspection
.SH SYNOPSIS
.nf
package require tcl::oo

\fBself\fR ?\fIsubcommand\fR?
.fi
.BE

'\"
'\" Copyright (c) 2018 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH singleton n 0.3 TclOO "TclOO Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
oo::singleton \- A class that does only allows one instance of itself
.SH SYNOPSIS
.nf
package require tcl::oo

\fBoo::singleton\fI method \fR?\fIarg ...\fR?
.fi
.SH "CLASS HIERARCHY"

'\"
'\" Copyright (c) 2008 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH transchan n 8.6 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
transchan \- Command handler API for channel transforms implemented in Tcl code
.SH SYNOPSIS
.nf
\fBchan push \fIchannel cmdPrefix\fR

\fIcmdPrefix \fBclear \fIhandle\fR
\fIcmdPrefix \fBdrain \fIhandle\fR
\fIcmdPrefix \fBfinalize \fIhandle\fR

'\"
'\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH variable n 8.0 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
variable \- Create and initialize a namespace variable
.SH SYNOPSIS
\fBvariable \fR\fIname\fR
.sp
\fBvariable \fR?\fIname value...\fR?
.BE
.SH DESCRIPTION
.PP

'\"
'\" Copyright (c) 2008-2012 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH zlib n 8.6 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
zlib \- Compression and decompression operations
.SH SYNOPSIS
.nf
\fBzlib \fIsubcommand arg ...\fR
.fi
.BE
.SH DESCRIPTION
.PP

 * library:
 *
 *----------------------------------------------------------------------
 */

MODULE_SCOPE Tcl_LibraryInitProc TclplatformtestInit;
MODULE_SCOPE Tcl_LibraryInitProc TclObjTest_Init;
MODULE_SCOPE Tcl_LibraryInitProc TclMutex_Init;
MODULE_SCOPE Tcl_LibraryInitProc TclThread_Init;
MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_Init;
MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit;
MODULE_SCOPE Tcl_LibraryInitProc Tcl_ABSListTest_Init;

/*
 *----------------------------------------------------------------

/*
 * tclMutexTest.c --
 *
 *	This file implements the testmutex command.
 *
 * Copyright (c) 2025 Ashok P. Nadkarni.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#undef BUILD_tcl
#undef STATIC_BUILD
#ifndef USE_TCL_STUBS
#   define USE_TCL_STUBS
#endif
#include "tclInt.h"

#ifdef HAVE_UNISTD_H
#   include <unistd.h>
#   ifdef _POSIX_PRIORITY_SCHEDULING
#       include <sched.h>
#   endif
#endif

#if TCL_THREADS
/*
 * Types related to Tcl_Mutex tests.
 */
TCL_DECLARE_MUTEX(testContextMutex)
static inline void LockTestContext(int numRecursions) {
    for (int j = 0; j < numRecursions; ++j) {
	Tcl_MutexLock(&testContextMutex);
    }
}
static inline void UnlockTestContext(int numRecursions) {
    for (int j = 0; j < numRecursions; ++j) {
	Tcl_MutexUnlock(&testContextMutex);
    }
}

/*
 * ProducerConsumerContext is used in producer consumer tests to
 * simulate a resource queue.
 */
typedef struct {
    Tcl_Condition canEnqueue;	/* Signal producer if queue not full */
    Tcl_Condition canDequeue;	/* Signal consumer if queue not empty */
    Tcl_WideUInt totalEnqueued;	/* Total enqueued so far */
    Tcl_WideUInt totalDequeued;	/* Total dequeued so far */
    int available;              /* Number of "resources" available */
    int capacity;		/* Max number allowed in queue */
} ProducerConsumerQueue;
#define CONDITION_TIMEOUT_SECS 5

/*
 * MutexSharedContext holds context shared amongst all threads in a test.
 * Should only be modified under testContextMutex lock unless only single
 * thread has access.
 */
typedef struct {
    int numThreads;	/* Number of threads in test run */
    int numRecursions;	/* Number of mutex lock recursions */
    int numIterations;	/* Number of times each thread should loop */
    int yield;		/* Whether threads should yield when looping */
    union {
	Tcl_WideUInt counter;		/* Used in lock tests */
	ProducerConsumerQueue queue;	/* Used in condition variable tests */
    } u;
} MutexSharedContext;

/*
 * MutexThreadContext holds context specific to each test thread. This
 * is passed as the clientData argument to each test thread.
 */
typedef struct {
    MutexSharedContext *sharedContextPtr; /* Pointer to shared context */
    Tcl_ThreadId threadId;		  /* Only access in creator */
    Tcl_WideUInt numOperations;		  /* Use is dependent on the test */
    Tcl_WideUInt timeouts;	/* Timeouts on condition variables */
} MutexThreadContext;

/* Used to track how many test threads running. Also used as trigger */
static volatile int mutexThreadCount;

static Tcl_ThreadCreateType	CounterThreadProc(void *clientData);
static int			TestMutexLock(Tcl_Interp *interp,
				    MutexSharedContext *contextPtr);
static int			TestConditionVariable(Tcl_Interp *interp,
				    MutexSharedContext *contextPtr);
static Tcl_ThreadCreateType	ConsumerThreadProc(void *clientData);
static Tcl_ThreadCreateType	ProducerThreadProc(void *clientData);


#if defined(_WIN32)
static inline void YieldToOtherThreads() {
    Sleep(0);
}
#elif defined(_POSIX_PRIORITY_SCHEDULING)
static inline void YieldToOtherThreads() {
    (void)sched_yield();
}
#else
static inline void YieldToOtherThreads() {
    volatile int i;
    for (i = 0; i < 1000; ++i) {
	/* Just some random delay */
    }
}
#endif


#ifdef __cplusplus
extern "C" {
#endif
extern int		Tcltest_Init(Tcl_Interp *interp);
#ifdef __cplusplus
}
#endif


/*
 *----------------------------------------------------------------------
 *
 * TestMutexCmd --
 *
 *	This procedure is invoked to process the "testmutex" Tcl command.
 *
 *	testmutex counter ?numthreads? ?numrecursions? ?numiterations?
 *	testmutex conditionvariable ?numthreads? ?numrecursions? ?numiterations?
 *
 * Results:
 *	A standard Tcl result.
 *
 *----------------------------------------------------------------------
 */

static int
TestMutexObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    static const char *const mutexOptions[] = {
	"lock", "condition", NULL
    };
    enum options {
	LOCK, CONDITION
    } option;
    MutexSharedContext context = {
	2,		/* numThreads */
	1,		/* numRecursions */
	1000000,	/* numIterations */
	1,		/* yield */
	{0},		/* u.counter */
    };

    if (objc < 2 || objc > 6) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"option ?numthreads? ?numrecursions? ?numiterations? ?yield?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], mutexOptions, "option", 0,
	    &option) != TCL_OK) {
	return TCL_ERROR;
    }
    if (objc > 2) {
	if (Tcl_GetIntFromObj(interp, objv[2],
		&context.numThreads) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (objc > 3) {
	    if (Tcl_GetIntFromObj(interp, objv[3],
		    &context.numRecursions) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (objc > 4) {
		if (Tcl_GetIntFromObj(interp, objv[4],
			&context.numIterations) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (objc > 5) {
		    if (Tcl_GetIntFromObj(
			    interp, objv[5], &context.yield) != TCL_OK) {
			return TCL_ERROR;
		    }
		}
	    }
	}
    }

    if (context.numIterations <= 0 || context.numRecursions <= 0 ||
	    context.numThreads <= 0) {
	Tcl_SetResult(interp,
	    "Thread, recursion and iteration counts must not be 0.",
	    TCL_STATIC);
    }

    int result = TCL_OK;
    switch (option) {
    case LOCK:
	result = TestMutexLock(interp, &context);
	break;
    case CONDITION:
	result = TestConditionVariable(interp, &context);
	break;
    }
    return result;
}

/*
 *------------------------------------------------------------------------
 *
 * TestMutexLock --
 *
 *	Implements the "testmutex lock" command to test Tcl_MutexLock.
 *
 * Results:
 *	A Tcl result code.
 *
 * Side effects:
 *	Stores a result in the interpreter.
 *
 *------------------------------------------------------------------------
 */
static int
TestMutexLock(
    Tcl_Interp *interp,
    MutexSharedContext *contextPtr)
{
    MutexThreadContext *threadContextsPtr =
	(MutexThreadContext *)Tcl_Alloc(
		sizeof(*threadContextsPtr) * contextPtr->numThreads);

    contextPtr->u.counter = 0;
    mutexThreadCount = 0;
    for (int i = 0; i < contextPtr->numThreads; i++) {
	threadContextsPtr[i].sharedContextPtr = contextPtr;
	threadContextsPtr[i].numOperations = 0; /* Init though not used */

	if (Tcl_CreateThread(&threadContextsPtr[i].threadId,
			     CounterThreadProc,
			     &threadContextsPtr[i],
			     TCL_THREAD_STACK_DEFAULT,
			     TCL_THREAD_JOINABLE) != TCL_OK) {
	    Tcl_Panic("Failed to create %d'th thread\n", i);
	}
    }
    mutexThreadCount = contextPtr->numThreads; /* Will fire off all test threads */

    /* Wait for all threads */
    for (int i = 0; i < contextPtr->numThreads; i++) {
	int threadResult;
	Tcl_JoinThread(threadContextsPtr[i].threadId, &threadResult);
    }
    Tcl_Free(threadContextsPtr);

    Tcl_SetObjResult(interp, Tcl_NewWideUIntObj(contextPtr->u.counter));
    return TCL_OK;
}

/*
 *------------------------------------------------------------------------
 *
 * CounterThreadProc --
 *
 *	Increments a shared counter a specified number of times and exits
 *	the thread.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *------------------------------------------------------------------------
 */
 static Tcl_ThreadCreateType
 CounterThreadProc(void *clientData)
{
    MutexThreadContext *threadContextPtr = (MutexThreadContext *)clientData;
    MutexSharedContext *contextPtr = threadContextPtr->sharedContextPtr;

    /* Spin wait until given the run signal */
    while (mutexThreadCount < contextPtr->numThreads) {
	YieldToOtherThreads();
    }

    for (int i = 0; i < contextPtr->numIterations; i++) {
	LockTestContext(contextPtr->numRecursions);
	Tcl_WideUInt temp = contextPtr->u.counter;
	if (contextPtr->yield) {
	    /* Some delay. No one else is supposed to modify the counter */
	    YieldToOtherThreads();
	}
	contextPtr->u.counter = temp + 1; /* Increment original value read */
	UnlockTestContext(contextPtr->numRecursions);
    }

    Tcl_ExitThread(0);
    TCL_THREAD_CREATE_RETURN;
}

/*
 *------------------------------------------------------------------------
 *
 * TestConditionVariable --
 *
 *	Implements the "testmutex condition" command to test Tcl_Condition*.
 *	The test emulates a producer-consumer scenario.
 *
 * Results:
 *	A Tcl result code.
 *
 * Side effects:
 *	Stores a result in the interpreter.
 *
 *------------------------------------------------------------------------
 */
static int
TestConditionVariable(
    Tcl_Interp *interp,
    MutexSharedContext *contextPtr)
{
    Tcl_SetResult(interp, "Not implemented", TCL_STATIC);
    if (contextPtr->numThreads < 2) {
	Tcl_SetResult(interp, "Need at least 2 threads.", TCL_STATIC);
	return TCL_ERROR;
    }
    int numProducers = contextPtr->numThreads / 2;
    int numConsumers = contextPtr->numThreads - numProducers;

    contextPtr->u.queue.canDequeue = NULL;
    contextPtr->u.queue.canEnqueue = NULL;

    /*
     * available tracks how many elements in the virtual queue
     * capacity is max length of virtual queue.
     */
    contextPtr->u.queue.totalEnqueued = 0;
    contextPtr->u.queue.totalDequeued = 0;
    contextPtr->u.queue.available = 0;
    contextPtr->u.queue.capacity = 3; /* Arbitrary for now */

    MutexThreadContext *consumerContextsPtr = (MutexThreadContext *)Tcl_Alloc(
	sizeof(*consumerContextsPtr) * numConsumers);
    MutexThreadContext *producerContextsPtr = (MutexThreadContext *)Tcl_Alloc(
	sizeof(*producerContextsPtr) * numProducers);

    mutexThreadCount = 0;

    for (int i = 0; i < numConsumers; i++) {
	consumerContextsPtr[i].sharedContextPtr = contextPtr;
	consumerContextsPtr[i].numOperations = 0;
	consumerContextsPtr[i].timeouts = 0;

	if (Tcl_CreateThread(&consumerContextsPtr[i].threadId,
		ConsumerThreadProc, &consumerContextsPtr[i],
		TCL_THREAD_STACK_DEFAULT, TCL_THREAD_JOINABLE) != TCL_OK) {
	    Tcl_Panic("Failed to create %d'th thread\n", (int) i);
	}
    }

    for (int i = 0; i < numProducers; i++) {
	producerContextsPtr[i].sharedContextPtr = contextPtr;
	producerContextsPtr[i].numOperations = 0;
	producerContextsPtr[i].timeouts = 0;

	if (Tcl_CreateThread(&producerContextsPtr[i].threadId,
		ProducerThreadProc, &producerContextsPtr[i],
		TCL_THREAD_STACK_DEFAULT, TCL_THREAD_JOINABLE) != TCL_OK) {
	    Tcl_Panic("Failed to create %d'th thread\n", (int) i);
	}
    }

    mutexThreadCount = contextPtr->numThreads; /* Will trigger all threads */

    /* Producer total, thread, timeouts, Consumer total, thread, timeouts */
    Tcl_Obj *results[6];
    results[1] = Tcl_NewListObj(numProducers, NULL);
    results[4] = Tcl_NewListObj(numConsumers, NULL);

    Tcl_WideUInt producerTimeouts = 0;
    Tcl_WideUInt producerOperations = 0;
    Tcl_WideUInt consumerTimeouts = 0;
    Tcl_WideUInt consumerOperations = 0;
    for (int i = 0; i < numProducers; i++) {
	int threadResult;
	Tcl_JoinThread(producerContextsPtr[i].threadId, &threadResult);
	producerOperations += producerContextsPtr[i].numOperations;
	Tcl_ListObjAppendElement(NULL, results[1],
	    Tcl_NewWideUIntObj(producerContextsPtr[i].numOperations));
	producerTimeouts += producerContextsPtr[i].timeouts;
    }
    for (int i = 0; i < numConsumers; i++) {
	int threadResult;
	Tcl_JoinThread(consumerContextsPtr[i].threadId, &threadResult);
	consumerOperations += consumerContextsPtr[i].numOperations;
	Tcl_ListObjAppendElement(NULL, results[4],
	    Tcl_NewWideUIntObj(consumerContextsPtr[i].numOperations));
	consumerTimeouts += consumerContextsPtr[i].timeouts;
    }

    results[0] = Tcl_NewWideUIntObj(producerOperations);
    results[2] = Tcl_NewWideUIntObj(producerTimeouts);
    results[3] = Tcl_NewWideUIntObj(consumerOperations);
    results[5] = Tcl_NewWideUIntObj(consumerTimeouts);
    Tcl_SetObjResult(interp, Tcl_NewListObj(6, results));

    Tcl_Free(producerContextsPtr);
    Tcl_Free(consumerContextsPtr);

    Tcl_ConditionFinalize(&contextPtr->u.queue.canDequeue);
    Tcl_ConditionFinalize(&contextPtr->u.queue.canEnqueue);

    return TCL_OK;
}

/*
 *------------------------------------------------------------------------
 *
 * ProducerThreadProc --
 *
 *	Acts as a "producer" that enqueues to the virtual resource queue.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *------------------------------------------------------------------------
 */
static Tcl_ThreadCreateType
ProducerThreadProc(void *clientData)
{
    MutexThreadContext *threadContextPtr = (MutexThreadContext *)clientData;
    MutexSharedContext *contextPtr = threadContextPtr->sharedContextPtr;

    /* Limit on total number of operations across all threads */
    Tcl_WideUInt limit;
    limit = contextPtr->numThreads * (Tcl_WideUInt) contextPtr->numIterations;

    /* Spin wait until given the run signal */
    while (mutexThreadCount < contextPtr->numThreads) {
	YieldToOtherThreads();
    }

    LockTestContext(contextPtr->numRecursions);
    while (contextPtr->u.queue.totalEnqueued < limit) {
	if (contextPtr->u.queue.available == contextPtr->u.queue.capacity) {
	    Tcl_Time before, after;
	    Tcl_Time timeout = {CONDITION_TIMEOUT_SECS, 0};
	    Tcl_GetTime(&before);
	    Tcl_ConditionWait(
		&contextPtr->u.queue.canEnqueue, &testContextMutex, &timeout);
	    Tcl_GetTime(&after);
	    if ((1000000 * (after.sec - before.sec) +
		 (after.usec - before.usec)) >=
		1000000 * CONDITION_TIMEOUT_SECS) {
		threadContextPtr->timeouts += 1;
	    }
	} else {
	    contextPtr->u.queue.available += 1; /* Enqueue operation */
	    contextPtr->u.queue.totalEnqueued += 1;
	    threadContextPtr->numOperations += 1;
	    Tcl_ConditionNotify(&contextPtr->u.queue.canDequeue);
	    if (contextPtr->yield) {
		/* Simulate real work by unlocking before yielding */
		UnlockTestContext(contextPtr->numRecursions);
		YieldToOtherThreads();
		LockTestContext(contextPtr->numRecursions);
	    }
	}
    }
    UnlockTestContext(contextPtr->numRecursions);

    Tcl_ExitThread(0);
    TCL_THREAD_CREATE_RETURN;
}

/*
 *------------------------------------------------------------------------
 *
 * ConsumerThreadProc --
 *
 *	Acts as a "consumer" that dequeues from the virtual resource queue.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *------------------------------------------------------------------------
 */
static Tcl_ThreadCreateType
ConsumerThreadProc(void *clientData)
{
    MutexThreadContext *threadContextPtr = (MutexThreadContext *)clientData;
    MutexSharedContext *contextPtr = threadContextPtr->sharedContextPtr;

    /* Limit on total number of operations across all threads */
    Tcl_WideUInt limit;
    limit = contextPtr->numThreads * (Tcl_WideUInt) contextPtr->numIterations;

    /* Spin wait until given the run signal */
    while (mutexThreadCount < contextPtr->numThreads) {
	YieldToOtherThreads();
    }

    LockTestContext(contextPtr->numRecursions);
    while (contextPtr->u.queue.totalDequeued < limit) {
	if (contextPtr->u.queue.available == 0) {
	    Tcl_Time before, after;
	    Tcl_Time timeout = {CONDITION_TIMEOUT_SECS, 0};
	    Tcl_GetTime(&before);
	    Tcl_ConditionWait(
		&contextPtr->u.queue.canDequeue, &testContextMutex, &timeout);
	    Tcl_GetTime(&after);
	    if ((1000000 * (after.sec - before.sec) +
		 (after.usec - before.usec)) >=
		1000000 * CONDITION_TIMEOUT_SECS) {
		threadContextPtr->timeouts += 1;
	    }
	} else {
	    contextPtr->u.queue.totalDequeued += 1;
	    threadContextPtr->numOperations += 1;
	    contextPtr->u.queue.available -= 1;
	    Tcl_ConditionNotify(&contextPtr->u.queue.canEnqueue);
	    if (contextPtr->yield) {
		/* Simulate real work by unlocking before yielding */
		UnlockTestContext(contextPtr->numRecursions);
		YieldToOtherThreads();
		LockTestContext(contextPtr->numRecursions);
	    }
	}
    }
    UnlockTestContext(contextPtr->numRecursions);

    Tcl_ExitThread(0);
    TCL_THREAD_CREATE_RETURN;
}

/*
 *----------------------------------------------------------------------
 *
 * TclMutex_Init --
 *
 *	Initialize the testmutex command.
 *
 * Results:
 *	TCL_OK if the package was properly initialized.
 *
 * Side effects:
 *	Add the "testmutex" command to the interp.
 *
 *----------------------------------------------------------------------
 */

int
TclMutex_Init(
    Tcl_Interp *interp)		/* The current Tcl interpreter */
{
    Tcl_CreateObjCommand(interp, "testmutex", TestMutexObjCmd, NULL, NULL);
    return TCL_OK;
}
#endif /* TCL_THREADS */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

    }
    if (Procbodytest_Init(interp) != TCL_OK) {
	return TCL_ERROR;
    }
#if TCL_THREADS
    if (TclThread_Init(interp) != TCL_OK) {
	return TCL_ERROR;
    }
    if (TclMutex_Init(interp) != TCL_OK) {
	return TCL_ERROR;
    }
#endif

    if (Tcl_ABSListTest_Init(interp) != TCL_OK) {
	return TCL_ERROR;
    }

# Commands covered:  (test)mutex
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2025 Ashok P. Nadkarni
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {"::tcltest" ni [namespace children]} {
    package require tcltest 2.5
    namespace import -force ::tcltest::*
}

source [file join [file dirname [info script]] tcltests.tcl]

::tcltest::loadTestedCommands
package require -exact tcl::test [info patchlevel]

testConstraint testmutex [expr {[info commands testmutex] ne {}}]

namespace eval testmutex {
    namespace import ::tcltest::test

    proc testlock {id nthreads recursion iters yield} {
        test $id "mutex lock $nthreads/$recursion/$iters/$yield" \
            -constraints testmutex \
            -body "testmutex lock $nthreads $recursion $iters $yield" \
            -result [expr {$nthreads*$iters}]
    }
    #                   threads recursions iterations yield
    testlock mutex-lock-1   2     1          1000000    0
    testlock mutex-lock-2   2     1          1000000    1
    testlock mutex-lock-3  10     1           200000    0
    testlock mutex-lock-4  10     1           200000    1
    testlock mutex-lock-5   4     5           400000    0
    testlock mutex-lock-6   4     5           400000    1

    proc fairness {totalOps perThreadOps} {
        set errors {}
        set threadTotal [tcl::mathop::+ {*}$perThreadOps]
        if {$threadTotal ne $totalOps} {
            append errors "Thread total $threadTotal != expected $totalOps\n"
        }
        # Each thread should get at least half of fair share
        set fairShare [expr {$totalOps / [llength $perThreadOps]}]
        foreach share $perThreadOps {
            if {$fairShare > 2*$share} {
                append errors "Thread share $share < 0.5 fair share $fairShare"
            }
        }
        return $errors
    }
    proc testcondition {id nthreads recursion iters yield} {
        set totalOps [expr {$nthreads*$iters}]
        test $id "mutex condition $nthreads/$recursion/$iters/$yield" \
            -constraints testmutex \
            -body {
                lassign \
                    [testmutex condition $nthreads $recursion $iters $yield] \
                    enqTotal enqPerThread enqTimeouts \
                    deqTotal deqPerThread deqTimeouts
                list \
                    $enqTotal [fairness $totalOps $enqPerThread] $enqTimeouts \
                    $deqTotal [fairness $totalOps $deqPerThread] $deqTimeouts
            } -result [list $totalOps {} 0 $totalOps {} 0]
    }
    testcondition mutex-condition-1   2     1          100000    0
    testcondition mutex-condition-2   2     1          100000    1
    testcondition mutex-condition-3  10     1           20000    0
    testcondition mutex-condition-4  10     1           20000    1
    testcondition mutex-condition-5   4     5           40000    0
    testcondition mutex-condition-6   4     5           40000    1

}

# cleanup
::tcltest::cleanupTests
return

DEPEND_SWITCHES	= ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \
	${AC_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@

TCLSH_OBJS = tclAppInit.o

TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
	tclMutexTest.o tclThreadTest.o tclUnixTest.o tclTestABSList.o

XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
	tclMutexTest.o tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o \
	tclTestABSList.o

GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
	tclArithSeries.o tclAssembly.o tclAsync.o tclBasic.o tclBinary.o \
	tclCkalloc.o tclClock.o tclClockFmt.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \
	tclCompCmds.o tclCompCmdsGR.o tclCompCmdsSZ.o tclCompExpr.o \
	tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclDisassemble.o \

tclThreadJoin.o: $(GENERIC_DIR)/tclThreadJoin.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadJoin.c

tclThreadStorage.o: $(GENERIC_DIR)/tclThreadStorage.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadStorage.c

tclMutexTest.o: $(GENERIC_DIR)/tclMutexTest.c
	$(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclMutexTest.c

tclThreadTest.o: $(GENERIC_DIR)/tclThreadTest.c
	$(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclThreadTest.c

tclTomMathInterface.o: $(GENERIC_DIR)/tclTomMathInterface.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTomMathInterface.c

bn_s_mp_reverse.o: $(TOMMATH_DIR)/bn_s_mp_reverse.c $(MATHHDRS)

${AC_FLAGS} ${COMPILE_DEBUG_FLAGS}

TCLTEST_OBJS = \
	tclTest.$(OBJEXT) \
	tclTestABSList.$(OBJEXT) \
	tclTestObj.$(OBJEXT) \
	tclTestProcBodyObj.$(OBJEXT) \
	tclMutexTest.$(OBJEXT) \
	tclThreadTest.$(OBJEXT) \
	tclWinTest.$(OBJEXT)

GENERIC_OBJS = \
	regcomp.$(OBJEXT) \
	regexec.$(OBJEXT) \
	regfree.$(OBJEXT) \

	$(TMP_DIR)\tclAppInit.obj \
	$(TMP_DIR)\tclsh.res

TCLTESTOBJS = \
	$(TMP_DIR)\tclTest.obj \
	$(TMP_DIR)\tclTestObj.obj \
	$(TMP_DIR)\tclTestProcBodyObj.obj \
	$(TMP_DIR)\tclMutexTest.obj \
	$(TMP_DIR)\tclThreadTest.obj \
	$(TMP_DIR)\tclWinTest.obj \
	$(TMP_DIR)\tclTestABSList.obj \
!if !$(STATIC_BUILD)
	$(OUT_DIR)\tommath.lib \
!endif
	$(TMP_DIR)\testMain.obj \