/* 
 * Copyright (c) 1994 Sun Microsystems, Inc. - All Rights Reserved.
 *
 * Permission is hereby granted, without written agreement and without
 * license or royalty fees, to use, copy, modify, and distribute this
 * software and its documentation for any purpose, provided that the
 * above copyright notice and the following two paragraphs appear in
 * all copies of this software.
 * 
 * IN NO EVENT SHALL SUN MICROSYSTEMS INC. BE LIABLE TO ANY PARTY FOR
 * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
 * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF SUN MICROSYSTEMS
 * INC. HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *
 * SUN MICROSYSTEMS INC. SPECIFICALLY DISCLAIMS ANY WARRANTIES,
 * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
 * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
 * ON AN "AS IS" BASIS, AND SUN MICROSYSTEMS INC. HAS NO OBLIGATION TO
 * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
 */

#include <synch.h>
#include <thread.h>
#include <string.h>
#include <stdlib.h>
#include <errno.h>
#include <assert.h>
#include <sys/stat.h>

#include "tcl_thread.h"

typedef struct {
    Tcl_Interp *interp;
    char *script;
    char *thr_name;
    int eval_rc;
    char *status;
    char *result;
    char **messages;
    unsigned int msg_array_max;
    unsigned int msg_array_len;
    unsigned int msg_array_next;
    cond_t msg_cond;
    int msg_notifier_pipe[2];
    long flags;
    thread_t tid;
} Tcl_Thread;

typedef struct {
    char *value;
    unsigned int ref;
    Tcl_HashEntry *entry;
} ShareVar;

/*
 * For each linked variable there is a data structure of the following
 * type, which describes the link and is the clientData for the trace
 * set on the Tcl variable.
 */

typedef struct {
    Tcl_Interp *interp;		/* Interpreter containing Tcl variable. */
    ShareVar *share_var;	/* Location of C variable. */
} ShareLink;

void MTtcl_ShareUnlinkVar( Tcl_Interp *interp, char *varName);
int MTtcl_ShareLinkVar( Tcl_Interp *interp, char *varName, ShareVar *var,
	unsigned int flags);


static Tcl_CmdProc MTtcl_ThreadCmd;
static Tcl_CmdProc MTtcl_ShareCmd;
static Tcl_CmdProc MTtcl_MutexCmd;
static Tcl_CmdProc MTtcl_SemaCmd;
static Tcl_CmdProc MTtcl_RwlockCmd;
static Tcl_CmdProc MTtcl_CondCmd;

static int ThreadCreate( Tcl_Interp *interp, int argc, char **argv);
static int ThreadJoin( Tcl_Interp *interp, int argc, char **argv);
static int ThreadList( Tcl_Interp *interp, int argc, char **argv);

static char * ShareLinkTraceProc (ClientData clientData,
			    Tcl_Interp *interp, char *name1, char *name2,
			    int flags);
static char * StringValue (ShareLink *linkPtr);

static void releaseShareVar( ShareLink *linkPtr, char *name);
static void printShareHash( char *prefix1, char *prefix2);

static int CondTimedWait( Tcl_Interp *interp, cond_t *cond, mutex_t *mutex,
    char *sec, char *nsec, int absolute);

static void * start_tcl_thread( void *arg);
static Tcl_HashTable threads;
static mutex_t threads_mutex;
static thread_key_t tclThreadKey;
static mutex_t threadkey_mutex;

static Tcl_HashTable share_vars;
static mutex_t share_mutex;
static cond_t share_cond;

/* Called just before a thread is started for an interpretter
*/
static int (*ThrInterp_init)( Tcl_Interp *) = NULL;


int
Tcl_thread_Init( Tcl_Interp *interp)
{
    static int once= 0;
    mutex_lock( &threadkey_mutex);
    if ( once == 0)  {
	thread_t init_tid;
	char thread_id[24];
	Tcl_Thread *tcl_thread;
	Tcl_HashEntry *entry;
        int rc, created;

	if ( (rc= thr_keycreate( &tclThreadKey, NULL)) != 0)  {
	    Tcl_AppendResult( interp, "Tcl thread init; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}

	Tcl_InitHashTable( &share_vars, TCL_STRING_KEYS);
	Tcl_InitHashTable( &threads, TCL_STRING_KEYS);
	sprintf( thread_id, "thread%u", thr_self());
	tcl_thread= (Tcl_Thread *) malloc( sizeof ( Tcl_Thread));
	tcl_thread->interp= interp;
        tcl_thread->script= NULL;
	tcl_thread->thr_name= NULL;
	tcl_thread->eval_rc= -1;
	tcl_thread->status= "running";
	tcl_thread->result= NULL;
	tcl_thread->messages= NULL;
	tcl_thread->msg_array_max= 0;
	tcl_thread->msg_array_len= 0;
	tcl_thread->msg_array_next= 0;
	cond_init( &tcl_thread->msg_cond, 0, USYNC_THREAD);
	tcl_thread->msg_notifier_pipe[0]= -1;
	tcl_thread->msg_notifier_pipe[1]= -1;
	tcl_thread->flags= 0;
	tcl_thread->tid= thr_self();
	entry= Tcl_CreateHashEntry( &threads, thread_id, &created);
	if ( ! created)  {
	    tcl_thread->status= "collision";
	    interp->result="Tcl thread-id collision";
	    return TCL_ERROR;
	}
	Tcl_SetHashValue( entry, (ClientData) tcl_thread);
	(void) thr_setspecific( tclThreadKey, tcl_thread);
	once++;
    }
    mutex_unlock( &threadkey_mutex);
    Tcl_CreateCommand( interp, "thread", MTtcl_ThreadCmd, 0, 0);
    Tcl_CreateCommand( interp, "share", MTtcl_ShareCmd, 0, 0);
    Tcl_CreateCommand( interp, "mutex", MTtcl_MutexCmd, 0, 0);
    Tcl_CreateCommand( interp, "sema", MTtcl_SemaCmd, 0, 0);
    Tcl_CreateCommand( interp, "rwlock", MTtcl_RwlockCmd, 0, 0);
    Tcl_CreateCommand( interp, "cond", MTtcl_CondCmd, 0, 0);

    return TCL_OK;
}

static char thread_help[] = {
"thread ?-suspended? ?-detached? ?-bound? ?-daemon? ?-new_lwp? ?-name name? <script> ?arg arg ...?"
"\n" "       name <thread-id> ?new name?"
"\n" "       join ?-result <var>? ?thread-id?"
"\n" "       script <thread-id>"
"\n" "       script <thread-id>"
"\n" "       exit ?result?"
"\n" "       self"
"\n" "       list"
"\n" "       setconcurrency <new level>"
"\n" "       getconcurrency"
"\n" "       setprio <thread-id> <new-priority>"
"\n" "       getprio <thread-id>"
"\n" "       suspend <thread-id>"
"\n" "       continue <thread-id>"
"\n" "       yield"
"\n" "       sleep <seconds> ?nano-seconds?"
"\n" "       status <thread-id>"
"\n" "       result <thread-id>"
"\n" "       errorInfo <thread-id>"
"\n" "       errorCode <thread-id>"
"\n" "       post <thread-id> <message>"
"\n" "       nextmsg"
};


void
MTtcl_SetThreadInitFunc( int (*init_func)( Tcl_Interp *))
{
    ThrInterp_init= init_func;
}

static Tcl_Thread *
GetCurrentThread()
{
    void *thread;
    (void) thr_getspecific( tclThreadKey, &thread);
    return (Tcl_Thread *) thread;
}

/* Return Tcl_Thread structure for a thread-id.  The thread-id is
 * "thread%u" where %u is the thread ID assigned by thr_create().
 * The thread-id may also be "self" to refer to the calling thread.
 * Upon successful completion, a pointer to the matching Tcl_Thread
 * is returned and threads_mutex is locked.  Upon failure, NULL is
 * returned and threads_mutex is not locked.
 */
static Tcl_Thread *
GetThread( Tcl_Interp *interp, char *thread_id)
{
    Tcl_Thread *tcl_thread;
    Tcl_HashEntry *entry;

    mutex_lock( &threads_mutex);
    if ( thread_id[0] == 's' && strcmp( "self", thread_id) == 0)  {
	if ( (tcl_thread= GetCurrentThread()) == NULL)  {
	    interp->result= "operation not available on main thread";
	    mutex_unlock( &threads_mutex);
	    return NULL;
	}
	return tcl_thread;
    }

    entry= Tcl_FindHashEntry( &threads, thread_id);
    if ( entry == NULL)  {
	Tcl_AppendResult( interp, thread_id, " is not a thread", NULL);
	mutex_unlock( &threads_mutex);
	return NULL;
    }
    tcl_thread= Tcl_GetHashValue( entry);
    return tcl_thread;
}


int
MTtcl_ThreadCmd (
    ClientData       clientData,
    Tcl_Interp *interp,
    int         argc,
    char      **argv
)
{
    static char *options= "create, continue, errorCode, errorInfo, exit, getconcurrency, getprio, join, kill, list, result, script, self, setconcurrency, setprio, status, suspend, yield";
    int rc;
    char *cmd= argv[1];
    Tcl_Thread *tcl_thread= NULL;

    if ( argc == 1)  {
	Tcl_AppendResult( interp, argv[0], " options are: ", options, NULL);
	return TCL_ERROR;
    }

    if ( argc == 2 && strcmp( argv[1], "help") == 0)  {
	puts( thread_help);
	return TCL_OK;
    }

    if ( *cmd == 'c' && strcmp( cmd, "create") == 0)  {
	return ThreadCreate( interp, argc, argv);
    }
    else if ( *cmd == 'n' && strcmp( cmd, "nextmsg") == 0)  {
	if ( argc != 2)  {
	    interp->result= "wrong # args: thread nextmsg";
	    return TCL_ERROR;
	}
	return MessageNext( interp);
    }
    else if ( *cmd == 'j' && strcmp( cmd, "join") == 0)  {
	return ThreadJoin( interp, argc, argv);
    }
    else if ( *cmd == 'l' && strcmp( cmd, "list") == 0)  {
	return ThreadList( interp, argc, argv);
    }
    else if ( *cmd == 's' && strcmp( cmd, "sleep") == 0)  {
	cond_t never;
	mutex_t say;
	char *cond_argv[10];
	if ( argc < 3 || argc > 4)  {
	    Tcl_AppendResult( interp, argv[0],
		" wrong # args; thread sleep seconds ?nano-seconds?", NULL);
	    return TCL_ERROR;
	}
	cond_init( &never, USYNC_THREAD, 0);
	mutex_init( &say, USYNC_THREAD, 0);
	rc= CondTimedWait( interp, &never, &say, argv[2],
		( argc == 4) ? argv[3] : "0", 0);
	cond_destroy( &never);
	mutex_destroy( &say);
	if ( rc != ETIME && rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
    }
    else if ( *cmd == 'h' && strcmp( cmd, "hrtime") == 0)  {
	static hrtime_t last= 0;
	hrtime_t now= gethrtime();
	sprintf( interp->result, "%u", (unsigned int) (now-last));
	last= now;
    }
    else if ( *cmd == 'e' && strcmp( cmd, "exit") == 0)  {
	tcl_thread= GetThread( interp, "self");
	if ( tcl_thread == NULL)
	    return TCL_ERROR;
	if ( argc == 2)
	    tcl_thread->result= strdup( "");
	else
	    tcl_thread->result= strdup( argv[2]);  /* ignored for detached threads */
	tcl_thread->status= "exit";
	mutex_unlock( &threads_mutex);
	thr_exit( tcl_thread);
	/* not reached */
    }
    else if ( *cmd == 's' && strcmp( cmd, "self") == 0)  {
	tcl_thread= GetThread(interp, "self");
	if ( tcl_thread == NULL)
	    return TCL_ERROR;
	sprintf( interp->result, "thread%u", tcl_thread->tid);
	mutex_unlock( &threads_mutex);
	tcl_thread= NULL;
    }
    else if ( *cmd == 's' && strcmp( cmd, "setconcurrency") == 0)  {
	int new_level;
	if ( argc != 3)  {
	    Tcl_AppendResult( interp, argv[0],
		" wrong # args: thread setconcurrency <number>", NULL);
	    return TCL_ERROR;
	}
	if ( Tcl_GetInt( interp, argv[2], &new_level) == TCL_ERROR)
	    return TCL_ERROR;
	if ( (rc= thr_setconcurrency( new_level)) != 0)  {
	    Tcl_AppendResult( interp, argv[0], " setconcurrency; ",
		strerror(rc), NULL);
	    return TCL_ERROR;
	}
    }
    else if ( *cmd == 'g' && strcmp( cmd, "getconcurrency") == 0)  {
	if ( argc != 2)  {
	    Tcl_AppendResult( interp, argv[0],
		" wrong # args: thread getconcurrency", NULL);
	    return TCL_ERROR;
	}
	sprintf( interp->result, "%d", thr_getconcurrency());
    }
    else if ( *cmd == 'y' && strcmp( cmd, "yield") == 0)  {
	if ( argc != 2)  {
	    Tcl_AppendResult( interp, argv[0],
		" wrong # args: thread yield", NULL);
	    return TCL_ERROR;
	}
	thr_yield();
    }
    else if ( argc > 2)  {
	tcl_thread= GetThread( interp, argv[2]);
	if ( tcl_thread == NULL)
	    return TCL_ERROR;
    }
    else  {
        Tcl_AppendResult( interp, argv[0], " unknown option; should be ",
		options, NULL);
	return TCL_ERROR;
    }

    /* Options which take a thread-id argument
     */
    if ( tcl_thread == NULL)
	return TCL_OK;

    do  {

    rc= TCL_OK;

    if ( *cmd == 'n' && strcmp( cmd, "name") == 0)  {
	if ( argc < 3 || argc > 4)  {
	    Tcl_AppendResult( interp, argv[0],
		" wrong # args: thread name thread-id ?new-name?", NULL);
	    rc= TCL_ERROR;
	    break;
	}
	if ( argc == 4)  {
	    if ( tcl_thread->thr_name != NULL)	
	        free( tcl_thread->thr_name);
	    tcl_thread->thr_name= strdup( argv[3]);
	}
	else
	    Tcl_SetResult( interp, tcl_thread->thr_name, TCL_VOLATILE);
    }
    else if ( *cmd == 'p' && strcmp( cmd, "post") == 0)  {
	if ( argc != 4)  {
	    interp->result= "wrong # args: thread post thread-id message";
	    rc= TCL_ERROR;
	    break;
	}
	rc= MessagePost( interp, tcl_thread, argv[3]);
    }
    else if ( *cmd == 's' && strcmp( cmd, "status") == 0)  {
	if ( argc != 3)  {
	    interp->result= "wrong # args: thread status <thread-id>";
	    rc= TCL_ERROR;
	    break;
	}
	Tcl_SetResult( interp, tcl_thread->status, TCL_VOLATILE);
    }
    else if ( *cmd == 'r' && strcmp( cmd, "result") == 0)  {
	if ( argc != 3)  {
	    interp->result= "wrong # args: thread result <thread-id>";
	    rc= TCL_ERROR;
	    break;
	}
	if ( tcl_thread->result == NULL)  {
	    interp->result= "thread; result not available until thread exits";
	    rc= TCL_ERROR;
	    break;
	}
	else
	    Tcl_SetResult( interp, tcl_thread->result, TCL_VOLATILE);
    }
    else if ( *cmd == 's' && strcmp( cmd, "script") == 0)  {
	if ( argc != 3)  {
	    interp->result= "wrong # args: thread script <thread-id>";
	    rc= TCL_ERROR;
	    break;
	}
	if ( tcl_thread->script == NULL)
	    interp->result= "";
	else
	    Tcl_SetResult( interp, tcl_thread->script, TCL_VOLATILE);
    }
    else if ( *cmd == 's' && strcmp( cmd, "setprio") == 0)  {
	int priority;
	if ( argc != 4)  {
	    Tcl_AppendResult( interp, argv[0],
		" wrong # args: thread setprio thread-id priority", NULL);
	    rc= TCL_ERROR;
	    break;
	}
	if ( Tcl_GetInt( interp, argv[3], &priority) == TCL_ERROR)  {
	    rc= TCL_ERROR;
	    break;
	}
	if ( (rc= thr_setprio( tcl_thread->tid, priority)) != 0)  {
	    Tcl_AppendResult( interp, argv[0], " setprio; ",
		strerror(rc), NULL);
	    rc= TCL_ERROR;
	    break;
	}
    }
    else if ( *cmd == 'g' && strcmp( cmd, "getprio") == 0)  {
	int priority;
	if ( argc != 3)  {
	    interp->result= "wrong # args: thread getprio thread-id";
	    rc= TCL_ERROR;
	    break;
	}
	if ( (rc= thr_getprio( tcl_thread->tid, &priority)) != 0)  {
	    Tcl_AppendResult( interp, argv[0], " getprio; ",
		strerror(rc), NULL);
	    rc= TCL_ERROR;
	    break;
	}
	sprintf( interp->result, "%d", priority);
    }
    else if ( *cmd == 's' && strcmp( cmd, "suspend") == 0)  {
	if ( argc != 3)  {
	    interp->result= "wrong # args: thread suspend thread-id";
	    rc= TCL_ERROR;
	    break;
	}
	if ( (rc= thr_suspend( tcl_thread->tid)) != 0)  {
	    Tcl_AppendResult( interp, argv[0], " suspend; ",
		strerror(rc), NULL);
	    rc= TCL_ERROR;
	    break;
	}
    }
    else if ( *cmd == 'c' && strcmp( cmd, "continue") == 0)  {
	if ( argc != 3)  {
	    interp->result= " wrong # args: thread continue thread-id";
	    rc= TCL_ERROR;
	    break;
	}
	if ( (rc= thr_continue( tcl_thread->tid)) != 0)  {
	    Tcl_AppendResult( interp, argv[0], " continue; ",
		strerror(rc), NULL);
	    rc= TCL_ERROR;
	    break;
	}
    }
    else if ( *cmd == 'e' && strcmp( cmd, "errorInfo") == 0)  {
	char *result;
	if ( argc != 3)  {
	    interp->result= "wrong # args; thread errorInfo thread-id";
	    rc= TCL_ERROR;
	    break;
	}
	if ( strcmp( tcl_thread->status, "running") == 0)  {
	    interp->result= "value not available until thread exits";
	    rc= TCL_ERROR;
	    break;
	}
	result= Tcl_GetVar( tcl_thread->interp, "errorInfo",
		TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
	if ( result == NULL)  {
	    rc= TCL_ERROR;
	    break;
	}
	Tcl_SetResult( interp, result, TCL_VOLATILE);
    }
    else if ( *cmd == 'e' && strcmp( cmd, "errorCode") == 0)  {
	char *result;
	if ( argc != 3)  {
	    interp->result= "wrong # args; thread errorCode thread-id";
	    rc= TCL_ERROR;
	    break;
	}
	if ( strcmp( tcl_thread->status, "running") == 0)  {
	    interp->result= "value not available until thread exits";
	    rc= TCL_ERROR;
	    break;
	}
	result= Tcl_GetVar( tcl_thread->interp, "errorCode",
		TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
	if ( result == NULL)  {
	    rc= TCL_ERROR;
	    break;
	}
	Tcl_SetResult( interp, result, TCL_VOLATILE);
    }
    else  {
        Tcl_AppendResult( interp, argv[0], " unknown option; should be ",
		options, NULL);
	rc= TCL_ERROR;
    }

    } while (0);

    mutex_unlock( &threads_mutex);
    return rc;
}

int
ThreadCreate(
    Tcl_Interp *interp,
    int         argc,
    char      **argv
)
{
    static char *flags= "-bound -daemon -detached -new_lwp -suspended -name";
    static char *syntax= "thread create ?flags ...? script ?arg arg ...?";
    Tcl_Thread *tcl_thread;
    int rc;
    unsigned int thr_argc, thr_flags, arg;
    Tcl_DString thr_argv;
    char argc_str[16], thread_id[24];
    char *thr_name;
    Tcl_HashEntry *entry;
    int created;

    thr_flags= 0;
    thr_name= NULL;
    for ( arg= 2; arg < argc; arg++)  {
	if ( argv[arg][0] != '-')
	    break;
	if ( strcmp( "-bound", argv[arg]) == 0)
	    thr_flags|= THR_BOUND;
	else if ( strcmp( "-suspended", argv[arg]) == 0)
	    thr_flags|= THR_SUSPENDED;
	else if ( strcmp( "-detached", argv[arg]) == 0)
	    thr_flags|= THR_DETACHED;
	else if ( strcmp( "-daemon", argv[arg]) == 0)
	    thr_flags|= THR_DAEMON;
	else if ( strcmp( "-new_lwp", argv[arg]) == 0)
	    thr_flags|= THR_NEW_LWP;
	else if ( strcmp( "-name", argv[arg]) == 0)  {
	    arg++;
	    if ( arg >= argc)  {
		Tcl_AppendResult( interp, argv[0], " missing arg for -name",
			NULL);
		return TCL_ERROR;
	    }
	    thr_name= argv[arg];
	}
	else  {
	    Tcl_AppendResult( interp, argv[0], " unknown flag ", argv[arg],
		"; flags are ", flags, NULL);
	    return TCL_ERROR;
	}
    }

    if ( arg >= argc)  {
	Tcl_AppendResult( interp, argv[0], " missing args; ", syntax, NULL);
	return TCL_ERROR;
    }

    tcl_thread= (Tcl_Thread *) malloc( sizeof( Tcl_Thread));
    tcl_thread->script= strdup( argv[arg]);
    tcl_thread->thr_name= thr_name;
    tcl_thread->eval_rc= -1;
    tcl_thread->status= "suspended";
    tcl_thread->result= NULL;
    tcl_thread->flags= thr_flags;
    tcl_thread->interp= Tcl_CreateInterp();
    tcl_thread->messages= NULL;
    tcl_thread->msg_array_max= 0;
    tcl_thread->msg_array_len= 0;
    tcl_thread->msg_array_next= 0;
    cond_init( &tcl_thread->msg_cond, 0, USYNC_THREAD);
    tcl_thread->msg_notifier_pipe[0]= -1;
    tcl_thread->msg_notifier_pipe[1]= -1;

    Tcl_CreateCommand( tcl_thread->interp, "thread", MTtcl_ThreadCmd, 0, 0);
    Tcl_CreateCommand( tcl_thread->interp, "share", MTtcl_ShareCmd, 0, 0);
    Tcl_CreateCommand( tcl_thread->interp, "mutex", MTtcl_MutexCmd, 0, 0);
    Tcl_CreateCommand( tcl_thread->interp, "sema", MTtcl_SemaCmd, 0, 0);
    Tcl_CreateCommand( tcl_thread->interp, "rwlock", MTtcl_RwlockCmd, 0, 0);
    Tcl_CreateCommand( tcl_thread->interp, "cond", MTtcl_CondCmd, 0, 0);

    Tcl_DStringInit( &thr_argv);
    for ( thr_argc= 0, arg++; arg < argc; thr_argc++, arg++)
	Tcl_DStringAppendElement( &thr_argv, argv[arg]);
    sprintf( argc_str, "%u", thr_argc);
    Tcl_SetVar( tcl_thread->interp, "argc", argc_str, TCL_GLOBAL_ONLY);
    Tcl_SetVar( tcl_thread->interp, "argv", Tcl_DStringValue(&thr_argv),
	TCL_GLOBAL_ONLY);
    Tcl_DStringFree( &thr_argv);

    if ( ThrInterp_init != NULL)
        ThrInterp_init( tcl_thread->interp);

    rc= thr_create( NULL, 0, start_tcl_thread, tcl_thread,
	tcl_thread->flags|THR_SUSPENDED, &(tcl_thread->tid));
    if ( rc != 0)  {
	Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	return TCL_ERROR;
    }

    sprintf( thread_id, "thread%u", tcl_thread->tid);
    mutex_lock( &threads_mutex);
    entry= Tcl_CreateHashEntry( &threads, thread_id, &created);
    if ( ! created)  {
	tcl_thread->status= "collision";
	mutex_unlock( &threads_mutex);
	Tcl_AppendResult( interp, argv[0], "; thread-id collision", NULL);
	return TCL_ERROR;
    }
    Tcl_SetHashValue( entry, (ClientData) tcl_thread);
    mutex_unlock( &threads_mutex);

    if ( ! (thr_flags & THR_SUSPENDED))
	thr_continue( tcl_thread->tid);

    sprintf( interp->result, "thread%u", tcl_thread->tid);
    return TCL_OK;
}

void *
start_tcl_thread( void *arg)
{
    Tcl_Thread *tcl_thread= (Tcl_Thread *) arg;
 
    if ( tcl_thread->status && strcmp( tcl_thread->status, "collision") == 0)  {
	tcl_thread->result= strdup( "collision");
	return tcl_thread;
    }

    (void) thr_setspecific( tclThreadKey, arg);
    tcl_thread->status= "running";

    tcl_thread->eval_rc= Tcl_Eval( tcl_thread->interp, tcl_thread->script);

    tcl_thread->result= strdup( tcl_thread->interp->result);
    switch ( tcl_thread->eval_rc)  {
	case TCL_OK:		tcl_thread->status= "done"; break;
	case TCL_ERROR:		tcl_thread->status= "error"; break;
	case TCL_RETURN:	tcl_thread->status= "return"; break;
	case TCL_BREAK:		tcl_thread->status= "break"; break;
	case TCL_CONTINUE:	tcl_thread->status= "continue"; break;
	default:		tcl_thread->status= "unknown"; break;
    }

    return tcl_thread;
}

int
MTtcl_MessageNotifierPipe( Tcl_Interp *interp, char *tcl_thread_id, int fd[2])
{
    Tcl_Thread *tcl_thread= GetThread( interp, tcl_thread_id);
    if ( tcl_thread != NULL)  {
	tcl_thread->msg_notifier_pipe[0]= fd[0];
	tcl_thread->msg_notifier_pipe[1]= fd[1];
	mutex_unlock( &threads_mutex);
    }
    return TCL_OK;
}

int
MessagePost(
    Tcl_Interp *interp,
    Tcl_Thread *tcl_thread,
    char *message
)
{
    if ( tcl_thread->messages == NULL)  {
	tcl_thread->messages= ( char **) malloc( sizeof(char*) * 20);
	tcl_thread->msg_array_max= 20;
    }
    else if ( tcl_thread->msg_array_len >= tcl_thread->msg_array_max)  {
	tcl_thread->messages= ( char **) realloc( tcl_thread->messages,
		(tcl_thread->msg_array_max + 20)*sizeof(char*));
	tcl_thread->msg_array_max+= 20;
    }

    tcl_thread->messages[tcl_thread->msg_array_len]= strdup( message);
    tcl_thread->msg_array_len++;

    cond_signal( &tcl_thread->msg_cond);

    if ( tcl_thread->msg_notifier_pipe[1] != -1)  {
	struct stat pipe_info;
	fstat( tcl_thread->msg_notifier_pipe[0], &pipe_info);
	if ( pipe_info.st_size == 0)
	    write( tcl_thread->msg_notifier_pipe[1], "B", 1);
    }
    return TCL_OK;
}

int
MessageNext(
    Tcl_Interp *interp
)
{
    Tcl_Thread *tcl_thread= GetThread( interp, "self");
    if ( tcl_thread == NULL)
	return TCL_ERROR;

    while ( tcl_thread->msg_array_next == tcl_thread->msg_array_len)
	cond_wait( &tcl_thread->msg_cond, &threads_mutex);

    if ( tcl_thread->messages == NULL)  {
	mutex_unlock( &threads_mutex);
	return TCL_OK;
    }
    Tcl_SetResult( interp, tcl_thread->messages[tcl_thread->msg_array_next],
	TCL_DYNAMIC);
    tcl_thread->messages[tcl_thread->msg_array_next]= NULL;
    tcl_thread->msg_array_next++;
    if ( tcl_thread->msg_notifier_pipe[0] != -1)  {
	int foo;
	if ( tcl_thread->msg_array_next == tcl_thread->msg_array_len)
	    read( tcl_thread->msg_notifier_pipe[0], &foo, 1);
    }
    if ( tcl_thread->msg_array_next > 1000)  {
	unsigned int new_size= tcl_thread->msg_array_max -
					tcl_thread->msg_array_next;
	char **new_messages= malloc( sizeof(char*) * (new_size + 40));
	memcpy( new_messages, tcl_thread->messages+tcl_thread->msg_array_next, 
		sizeof( char *) * new_size);
	tcl_thread->messages= new_messages;
	tcl_thread->msg_array_max= new_size+40;
        tcl_thread->msg_array_len= new_size;
	tcl_thread->msg_array_next= 0;
    }
    mutex_unlock( &threads_mutex);
    return TCL_OK;
}

int
ThreadJoin(
    Tcl_Interp *interp,
    int         argc,
    char      **argv
)
{
    char *status_var= NULL, scratch[24];
    void *status;
    Tcl_Thread *join_thr;
    Tcl_Thread *joined_thr;
    thread_t join_tid= 0;
    thread_t joined_tid;
    Tcl_HashEntry *entry;
    int rc;

    if ( argc >= 3 && argc <= 5)  {
	if ( argc > 3)  {
	    if ( strcmp( argv[2], "-result") != 0 )  {
	        Tcl_AppendResult( interp, "unknown flag ", argv[2],
			": should be -result", NULL);
	        return TCL_ERROR;
	    }
	    status_var= argv[3];
	}
	if ((join_thr= GetThread( interp, argv[argc-1])) == NULL)
	    return TCL_ERROR;
	join_tid= join_thr->tid;
	mutex_unlock( &threads_mutex);
    }
    else if ( argc != 2) {
	interp->result="wrong # args: thread join ?-result <var>? ?<thread-id>?";
	return TCL_ERROR;
    }

    rc= thr_join( join_tid, &joined_tid, &status);
    if ( rc != 0)  {
	Tcl_AppendResult( interp, "could not join: ", strerror( errno), NULL);
	return TCL_ERROR;
    }
    joined_thr= (Tcl_Thread *) status;
    if ( status_var != NULL)
	Tcl_SetVar( interp, status_var, joined_thr->result, 0);

    if ( joined_thr->script)     free( joined_thr->script);
    if ( joined_thr->thr_name)   free( joined_thr->thr_name);
    if ( joined_thr->result)     free( joined_thr->result);

    sprintf( interp->result, "thread%u", joined_thr->tid);
    mutex_lock( &threads_mutex);
    entry= Tcl_FindHashEntry( &threads, interp->result);
    if ( entry != NULL)  {
	Tcl_Thread *tcl_thread= Tcl_GetHashValue( entry);
	assert( tcl_thread == joined_thr);
	Tcl_DeleteHashEntry( entry);
    }
    mutex_unlock( &threads_mutex);

    Tcl_DeleteInterp( joined_thr->interp);
    free( joined_thr);

    return TCL_OK;
}

int
ThreadList(
    Tcl_Interp *interp,
    int         argc,
    char      **argv
)
{
    Tcl_HashEntry *entry;
    Tcl_HashSearch search;
    Tcl_DString string;
    char scratch[256];

    if ( argc != 2)  {
	interp->result= "wrong # args: thread list";
	return TCL_ERROR;
    }

/* ** thread list ?<thread-id> ...?
*/
    mutex_lock( &threads_mutex);

    Tcl_DStringInit( &string);
    entry= Tcl_FirstHashEntry( &threads, &search);
    while ( entry != NULL)  {
	Tcl_Thread *tcl_thread= (Tcl_Thread *) Tcl_GetHashValue( entry);

	Tcl_DStringStartSublist( &string);
	sprintf( scratch, "thread%u", tcl_thread->tid);
	Tcl_DStringAppendElement( &string, scratch);
	if ( tcl_thread->thr_name != NULL)
	    Tcl_DStringAppendElement( &string, tcl_thread->thr_name);
	else
	    Tcl_DStringAppendElement( &string, "");
	Tcl_DStringAppendElement( &string, tcl_thread->status);
	if ( tcl_thread->result != NULL)
	    Tcl_DStringAppendElement( &string, tcl_thread->result);
	else
	    Tcl_DStringAppendElement( &string, "");
	Tcl_DStringEndSublist( &string);
	entry= Tcl_NextHashEntry( &search);
    }

    mutex_unlock( &threads_mutex);
    Tcl_DStringResult( interp, &string);
    return TCL_OK;
}

int
MTtcl_ShareCmd (
    ClientData  clientData,
    Tcl_Interp *interp,
    int         argc,
    char      **argv
)
{
    static char *options= "?-global? ?var var ...?";
    Tcl_HashEntry *entry;
    int arg, created, rc, global_rc, global= 0;
    char *var_value;
    ShareVar *share_var;

    arg= 1;
    if ( argv[1][0] == '-')  {
	if ( strcmp( "-global", argv[1])  == 0)
	    global++;
	else  {
	    Tcl_AppendResult( interp, argv[0], " options are: ", options, NULL);
	    return TCL_ERROR;
	}
	arg= 2;
    }

    if ( argc <= arg)  {
	Tcl_AppendResult( interp, argv[0], " options are: ", options, NULL);
	return TCL_ERROR;
    }

    mutex_lock( &share_mutex);
    for ( ; arg < argc; arg++)  {
	share_var= (ShareVar *) Tcl_VarTraceInfo( interp, argv[arg], 0,
		ShareLinkTraceProc, NULL);
	if ( share_var != NULL)
	    continue;
	entry= Tcl_CreateHashEntry( &share_vars, argv[arg], &created);
	if ( created)  {
	    var_value= Tcl_GetVar( interp, argv[arg], 0);
	    share_var= (ShareVar *) malloc( sizeof( ShareVar));
	    if ( var_value == NULL)
		share_var->value= strdup( "");
	    else
		share_var->value= strdup( var_value);
	    share_var->ref= 0;
	    Tcl_SetHashValue( entry, share_var);
	    share_var->entry= entry;
	}
	else
	    share_var= (ShareVar *) Tcl_GetHashValue( entry);

	rc= MTtcl_ShareLinkVar(interp, argv[arg], share_var, 0);
	if ( rc == TCL_OK && global)
	    global_rc= MTtcl_ShareLinkVar(interp, argv[arg], share_var,
				TCL_GLOBAL_ONLY);
	if ( rc == TCL_ERROR || (global && global_rc == TCL_ERROR))  {
	    if ( rc == TCL_OK)
		MTtcl_ShareUnlinkVar( interp, argv[arg]);
	    if ( created)  {
		Tcl_DeleteHashEntry( entry);
		free( share_var->value);
		free( share_var);
	    }
	    mutex_unlock( &share_mutex);
	    Tcl_AppendResult( interp, "failed to share ", argv[arg], NULL);
	    return TCL_ERROR;
	}
	share_var->ref += 1 + global;
/*	printShareHash( "+", argv[arg]); */
    }
    mutex_unlock( &share_mutex);
    return TCL_OK;
}

static void
printShareHash( char *prefix1, char *prefix2)
{
    Tcl_HashEntry *entry;
    Tcl_HashSearch search;
    entry= Tcl_FirstHashEntry( &share_vars, &search);
    while ( entry != NULL)  {
	ShareVar *share_var= (ShareVar *) Tcl_GetHashValue( entry);
	fprintf( stderr, "%s%s %12s %2d %s\n", prefix1, prefix2,
		Tcl_GetHashKey( &share_vars, entry), share_var->ref,
		share_var->value);
	entry= Tcl_NextHashEntry( &search);
    }
}

static void
releaseShareVar( ShareLink *linkPtr, char *name)
{
    linkPtr->share_var->ref--;
    if ( linkPtr->share_var->ref == 0)  {
	Tcl_DeleteHashEntry( linkPtr->share_var->entry);
	free( linkPtr->share_var);
	if ( linkPtr->share_var->value != NULL)
	    free( linkPtr->share_var->value);
    }
/*    printShareHash( "-", name); */
}

/*
 *----------------------------------------------------------------------
 *
 * MTtcl_ShareLinkVar --
 *
 *	Link a C variable to a Tcl variable so that changes to either
 *	one causes the other to change.
 *
 * Results:
 *	The return value is TCL_OK if everything went well or TCL_ERROR
 *	if an error occurred (interp->result is also set after errors).
 *
 * Side effects:
 *	The value at *addr is linked to the Tcl variable "varName",
 *	using "type" to convert between string values for Tcl and
 *	binary values for *addr.
 *
 *----------------------------------------------------------------------
 */

int
MTtcl_ShareLinkVar(
    Tcl_Interp *interp,		/* Interpreter in which varName exists. */
    char *varName,		/* Name of a global variable in interp. */
    ShareVar *share_var,	/* Address of a C variable to be linked
				 * to varName. */
    unsigned int flags		/* TCL_GLOBAL_ONLY or 0 */
)
{
    ShareLink *linkPtr;
    int code;

    linkPtr = (ShareLink *) ckalloc(sizeof(ShareLink));
    linkPtr->interp = interp;
    linkPtr->share_var = share_var;
    if (Tcl_SetVar(interp, varName, StringValue(linkPtr),
	    TCL_LEAVE_ERR_MSG|flags) == NULL) {
	ckfree((char *) linkPtr);
	return TCL_ERROR;
    }
    code = Tcl_TraceVar(interp, varName, TCL_TRACE_READS|
	    TCL_TRACE_WRITES|TCL_TRACE_UNSETS|flags, ShareLinkTraceProc,
	    (ClientData) linkPtr);
    if (code != TCL_OK) {
	ckfree((char *) linkPtr);
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * MTtcl_ShareUnlinkVar --
 *
 *	Destroy the link between a Tcl variable and a C variable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If "varName" was previously linked to a C variable, the link
 *	is broken to make the variable independent.  If there was no
 *	previous link for "varName" then nothing happens.
 *
 *----------------------------------------------------------------------
 */

void
MTtcl_ShareUnlinkVar(
    Tcl_Interp *interp,		/* Interpreter containing variable to unlink. */
    char *varName		/* Global variable in interp to unlink. */
)
{
    ShareLink *linkPtr;

    linkPtr = (ShareLink *) Tcl_VarTraceInfo(interp, varName, 0,
	    ShareLinkTraceProc, (ClientData) NULL);
    if (linkPtr == NULL)
	return;

    Tcl_UntraceVar(interp, varName,
	    TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
	    ShareLinkTraceProc, (ClientData) linkPtr);

    ckfree((char *) linkPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * ShareLinkTraceProc --
 *
 *	This procedure is invoked when a linked Tcl variable is read,
 *	written, or unset from Tcl.  It's responsible for keeping the
 *	C variable in sync with the Tcl variable.
 *
 * Results:
 *	If all goes well, NULL is returned; otherwise an error message
 *	is returned.
 *
 * Side effects:
 *	The C variable may be updated to make it consistent with the
 *	Tcl variable, or the Tcl variable may be overwritten to reject
 *	a modification.
 *
 *----------------------------------------------------------------------
 */

static char *
ShareLinkTraceProc(
    ClientData clientData,	/* Contains information about the link. */
    Tcl_Interp *interp,		/* Interpreter containing Tcl variable. */
    char *name1,		/* First part of variable name. */
    char *name2,		/* Second part of variable name. */
    int flags			/* Miscellaneous additional information. */
)
{
    ShareLink *linkPtr = (ShareLink *) clientData;
    char *new_value;

    /*
     * If the variable is being unset, then unlink it from this interpreter
     * unless the whole interpreter is going away.
     */

    if (flags & TCL_TRACE_UNSETS) {
	if (flags & TCL_INTERP_DESTROYED) {
	    ckfree((char *) linkPtr);
	}
	if (flags & TCL_TRACE_DESTROYED) {
	    mutex_lock( &share_mutex);
	    releaseShareVar( linkPtr, name1);
	    mutex_unlock( &share_mutex);
	}
	return NULL;
    }

    /*
     * For read accesses, update the Tcl variable if the C variable
     * has changed since the last time we updated the Tcl variable.
     */

    if (flags & TCL_TRACE_READS) {
	Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr), 0);
	return NULL;
    }

    /*
     * For writes, first make sure that the variable is writable.  Then
     * convert the Tcl value to C if possible.  If the variable isn't
     * writable or can't be converted, then restore the variable's old
     * value and return an error.  Another tricky thing: we have to save
     * and restore the interpreter's result, since the variable access
     * could occur when the result has been partially set.
     */

    new_value = Tcl_GetVar2(interp, name1, name2, 0);
    if (new_value == NULL) {
	/*
	 * This shouldn't ever happen.
	 */
	return "internal error: linked variable couldn't be read";
    }
    if (linkPtr->share_var->value != NULL) {
	ckfree(linkPtr->share_var->value);
    }
    linkPtr->share_var->value = ckalloc((unsigned) (strlen(new_value) + 1));
    strcpy(linkPtr->share_var->value, new_value);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * StringValue --
 *
 *	Converts the value of a C variable to a string for use in a
 *	Tcl variable to which it is linked.
 *
 * Results:
 *	The return value is a pointer to a string that represents
 *	the value of the C variable given by linkPtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static char *
StringValue(
    ShareLink *linkPtr		/* Structure describing linked variable. */
)
{
    char *p;

    p = linkPtr->share_var->value;
    if (p == NULL) {
	return "NULL";
    }
    return p;
}


static char mutex_help[] = {
     "mutex create"
"\n" "      lock <mutex-id>"
"\n" "      unlock <mutex-id>"
"\n" "      trylock <mutex-id>"
"\n" "      destroy <mutex-id>"
};

int
MTtcl_MutexCmd (
    ClientData  clientData,
    Tcl_Interp *interp,
    int         argc,
    char      **argv
)
{
    static char *options= "create, destroy, lock, trylock, unlock";
    mutex_t *mutex;

    if ( argc == 1)  {
	Tcl_AppendResult( interp, argv[0], " options are: ", options, NULL);
	return TCL_ERROR;
    }
    if ( argc == 2 && strcmp( argv[1], "help") == 0)  {
	puts( mutex_help);
	return TCL_OK;
    }

    if ( argv[1][0] == 'c' && strcmp( argv[1], "create") == 0)  {
	int type= USYNC_THREAD;
	if ( argc == 3 && 0)  {
	    if ( strcmp( argv[2], "-process") == 0)
	        type= USYNC_PROCESS;
	    else if ( strcmp( argv[2], "-thread") == 0)
	        type= USYNC_THREAD;
	    else  {
	        Tcl_AppendResult( interp, "unknown mutex type ", argv[2],
			": should be -process or -thread", NULL);
	        return TCL_ERROR;
	    }
	}
	else if ( argc != 2)  {
	    interp->result="wrong # args: mutex create";
	    return TCL_ERROR;
	}
        mutex= (mutex_t *) malloc( sizeof( mutex_t));
        if ( mutex_init( mutex, type, 0) != 0)  {
            interp->result= "could not create mutex";
            return TCL_ERROR;
        }
	sprintf( interp->result, "mutex%u", (unsigned int) mutex);
	return TCL_OK;
    }

    if ( argc < 3)  {
	interp->result= "missing args: mutex option <mutex-id> ?arg ...?";
	return TCL_ERROR;
    }

    if ( argv[2][0] != 'm' && argv[2][1] != 'u')  {
	interp->result= "argument is not a mutex";
	return TCL_ERROR;
    }
    mutex= (mutex_t *) atoi(argv[2]+5);

    if ( argv[1][0] == 'l' && strcmp( argv[1], "lock") == 0)  {
        int rc= mutex_lock( mutex);
	if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
    }
    else if ( argv[1][0] == 'u' && strcmp( argv[1], "unlock") == 0)  {
        int rc= mutex_unlock( mutex);
	if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
    }
    else if ( argv[1][0] == 't' && strcmp( argv[1], "trylock") == 0)  {
	int rc= mutex_trylock( mutex);
	if ( rc == EBUSY)  {
	    Tcl_AppendResult( interp, argv[0], " lock busy", NULL);
	    return TCL_ERROR;
	}
	else if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
    }
    else if ( argv[1][0] == 'd' && strcmp( argv[1], "destroy") == 0)  {
	int rc= mutex_destroy( mutex);
	if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
	free( mutex);
    }
    else  {
	Tcl_AppendResult( interp, "bad option ", argv[1], ": ",
		argv[0], " options are ", options, NULL);
	return TCL_ERROR;
    }

    return TCL_OK;
}


static char sema_help[] = {
     "sema create <count>"
"\n" "     post <sema-id>"
"\n" "     wait <sema-id>"
"\n" "     trywait <sema-id>"
"\n" "     destroy <sema-id>"
};

int
MTtcl_SemaCmd (
    ClientData  clientData,
    Tcl_Interp *interp,
    int         argc,
    char      **argv
)
{
    static char *options= "create, destroy, post, trywait, wait";
    sema_t *sema;

    if ( argc == 1)  {
	Tcl_AppendResult( interp, argv[0], " options are: ", options, NULL);
	return TCL_ERROR;
    }
    if ( argc == 2 && strcmp( argv[1], "help") == 0)  {
	puts( sema_help);
	return TCL_OK;
    }

    if ( argv[1][0] == 'c' && strcmp( argv[1], "create") == 0)  {
	int type= USYNC_THREAD, count;
	if ( argc == 4 && 0)  {
	    if ( strcmp( argv[2], "-process") == 0)
	        type= USYNC_PROCESS;
	    else if ( strcmp( argv[2], "-thread") == 0)
	        type= USYNC_THREAD;
	    else  {
	        Tcl_AppendResult( interp, "unknown semaphore type ", argv[2],
			": should be -process or -thread", NULL);
	        return TCL_ERROR;
	    }
	}
	else if ( argc != 3)  {
	    interp->result="wrong # args: sema create <count>";
	    return TCL_ERROR;
	}
	if ( Tcl_GetInt( interp, argv[argc-1], &count) != TCL_OK)
	    return TCL_ERROR;

	sema= (sema_t *) malloc( sizeof( sema_t));
        if ( sema_init( sema, count, type, 0) != 0)  {
            interp->result= "could not create semaphore";
            return TCL_ERROR;
        }

	sprintf( interp->result, "sema%u", (unsigned int) sema);
	return TCL_OK;
    }

    if ( argc < 3)  {
	interp->result= "missing args: sema option <sema-id> ?arg ...?";
	return TCL_ERROR;
    }
    if ( argv[2][0] != 's' && argv[2][1] != 'e')  {
	interp->result= "argument is not a semaphore";
	return TCL_ERROR;
    }
    sema= (sema_t *) atoi( argv[2]+4);

    if ( argv[1][0] == 'w' && strcmp( argv[1], "wait") == 0)  {
	int rc= sema_wait( sema);
	if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
    }
    else if ( argv[1][0] == 'p' && strcmp( argv[1], "post") == 0)  {
	int rc= sema_post( sema);
	if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
    }
    else if ( argv[1][0] == 't' && strcmp( argv[1], "trywait") == 0)  {
	int rc= sema_trywait( sema);
	if ( rc == EBUSY)  {
	    Tcl_AppendResult( interp, argv[0], " zero count", NULL);
	    return TCL_ERROR;
	}
	else if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
    }
    else if ( argv[1][0] == 'd' && strcmp( argv[1], "destroy") == 0)  {
	int rc= sema_destroy( sema);
	if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
	free( sema);
    }
    else  {
	Tcl_AppendResult( interp, "bad option ", argv[1], ": ",
		argv[0], " options are ", options, NULL);
	return TCL_ERROR;
    }

    return TCL_OK;
}


static char rwlock_help[] = {
     "rwlock create"
"\n" "       read <rwlock-id>"
"\n" "       write <rwlock-id>"
"\n" "       unlock <rwlock-id>"
"\n" "       tryread <rwlock-id>"
"\n" "       trywrite <rwlock-id>"
"\n" "       destroy <rwlock-id>"
};

int
MTtcl_RwlockCmd (
    ClientData  clientData,
    Tcl_Interp *interp,
    int         argc,
    char      **argv
)
{
    static char *options= "create, destroy, read, write, unlock, tryread, trywrite";
    rwlock_t *rwlock;

    if ( argc == 1)  {
	Tcl_AppendResult( interp, argv[0], " options are: ", options, NULL);
	return TCL_ERROR;
    }
    if ( argc == 2 && strcmp( argv[1], "help") == 0)  {
	puts( rwlock_help);
	return TCL_OK;
    }

    if ( argv[1][0] == 'c' && strcmp( argv[1], "create") == 0)  {
	int type= USYNC_THREAD;
	if ( argc == 3 && 0)  {
	    if ( strcmp( argv[2], "-process") == 0)
	        type= USYNC_PROCESS;
	    else if ( strcmp( argv[2], "-thread") == 0)
	        type= USYNC_THREAD;
	    else  {
	        Tcl_AppendResult( interp, "unknown rwlock type ", argv[2],
			": should be -process or -thread", NULL);
	        return TCL_ERROR;
	    }
	}
	else if ( argc != 2)  {
	    interp->result="wrong # args: rwlock create";
	    return TCL_ERROR;
	}
        rwlock= (rwlock_t *) malloc( sizeof( rwlock_t));
        if ( rwlock_init( rwlock, type, 0) != 0)  {
            interp->result= "could not create rwlock";
            return TCL_ERROR;
        }
	sprintf( interp->result, "rwlock%u", (unsigned int) rwlock);
	return TCL_OK;
    }

    if ( argc < 3)  {
	interp->result= "missing args: rwlock option <rwlock-id> ?arg ...?";
	return TCL_ERROR;
    }

    if ( argv[2][0] != 'r' && argv[2][1] != 'w')  {
	interp->result= "argument is not a rwlock";
	return TCL_ERROR;
    }
    rwlock= (rwlock_t *) atoi(argv[2]+6);

    if ( argv[1][0] == 'r' && strcmp( argv[1], "read") == 0)  {
        int rc= rw_rdlock( rwlock);
	if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
    }
    else if ( argv[1][0] == 'w' && strcmp( argv[1], "write") == 0)  {
        int rc= rw_wrlock( rwlock);
	if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
    }
    else if ( argv[1][0] == 'u' && strcmp( argv[1], "unlock") == 0)  {
        int rc= rw_unlock( rwlock);
	if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
    }
    else if ( argv[1][0] == 'd' && strcmp( argv[1], "destroy") == 0)  {
	int rc= rwlock_destroy( rwlock);
	if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
	free( rwlock);
    }
    else if ( strcmp( argv[1], "tryread") == 0)  {
	int rc= rw_tryrdlock( rwlock);
	if ( rc == EBUSY)  {
	    Tcl_AppendResult( interp, argv[0], " lock busy", NULL);
	    return TCL_ERROR;
	}
	else if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
    }
    else if ( strcmp( argv[1], "trywrite") == 0)  {
	int rc= rw_trywrlock( rwlock);
	if ( rc == EBUSY)  {
	    Tcl_AppendResult( interp, argv[0], " lock busy", NULL);
	    return TCL_ERROR;
	}
	else if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
    }
    else  {
	Tcl_AppendResult( interp, "bad option ", argv[1], ": ",
		argv[0], " options are ", options, NULL);
	return TCL_ERROR;
    }

    return TCL_OK;
}


static char cond_help[] = {
     "cond create"
"\n" "     wait <cond-id> <mutex-id>"
"\n" "     signal <cond-id>"
"\n" "     broadcast <cond-id>"
"\n" "     timedwait ?-absolute? <cond-id> <mutex-id> seconds ?nano-seconds?"
"\n" "     destroy <cond-id>"
};

int
MTtcl_CondCmd (
    ClientData  clientData,
    Tcl_Interp *interp,
    int         argc,
    char      **argv
)
{
    static char *options= "create, destroy, wait, signal, broadcast, timedwait";
    cond_t *cond;
    int rc;

    if ( argc == 1)  {
	Tcl_AppendResult( interp, argv[0], " options are: ", options, NULL);
	return TCL_ERROR;
    }
    if ( argc == 2 && strcmp( argv[1], "help") == 0)  {
	puts( cond_help);
	return TCL_OK;
    }

    if ( argv[1][0] == 'c' && strcmp( argv[1], "create") == 0)  {
	int type= USYNC_THREAD;
	if ( argc == 3 && 0)  {
	    if ( strcmp( argv[2], "-process") == 0)
	        type= USYNC_PROCESS;
	    else if ( strcmp( argv[2], "-thread") == 0)
	        type= USYNC_THREAD;
	    else  {
	        Tcl_AppendResult( interp, "unknown mutex type ", argv[2],
			": should be -process or -thread", NULL);
	        return TCL_ERROR;
	    }
	}
	else if ( argc != 2)  {
	    interp->result="wrong # args: cond create";
	    return TCL_ERROR;
	}
        cond= (cond_t *) malloc( sizeof( cond_t));
        if ( cond_init( cond, type, 0) != 0)  {
            interp->result= "could not create cond";
            return TCL_ERROR;
        }
	sprintf( interp->result, "cond%u", (unsigned int) cond);
	return TCL_OK;
    }

    if ( argc < 3)  {
	interp->result= "missing args: cond option <cond-id> ?arg ...?";
	return TCL_ERROR;
    }


    if ( argv[1][0] == 't' && strcmp( argv[1], "timedwait") == 0)  {
	static char *syntax= "cond timedwait ?-absolute? cond-id mutex-id seconds ?nano-seconds?";
	int absolute= 0, arg;
	mutex_t *mutex;
	timestruc_t abstime;
	if ( argc < 5)  {
	    Tcl_AppendResult( interp, "missing args; ", syntax, NULL);
	    return TCL_ERROR;
	}
	arg= 2;
	if ( argv[arg][0] == '-')  {
	    if ( strcmp( argv[arg], "-absolute") == 0)
		absolute++;
	    else  {
		Tcl_AppendResult( interp, "unknown flag; ", syntax, NULL);
		return TCL_ERROR;
	    }
	    arg++;
	}
	cond= (cond_t *) atoi(argv[arg++]+4);
	mutex= (mutex_t *) atoi(argv[arg++]+5);
	rc= CondTimedWait( interp, cond, mutex, argv[arg++],
		( arg < argc) ? argv[arg++] : "0", absolute);
        if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
        }
    }

    if ( argv[2][0] != 'c' && argv[2][1] != 'o')  {
	interp->result= "argument is not a cond";
	return TCL_ERROR;
    }
    cond= (cond_t *) atoi(argv[2]+4);

    if ( argv[1][0] == 'w' && strcmp( argv[1], "wait") == 0)  {
	mutex_t *mutex;
	if ( argc != 4)  {
	    Tcl_AppendResult( interp,
		"missing args: cond wait cond-id mutex-id", NULL);
	    return TCL_ERROR;
	}
        if ( argv[3][0] != 'm' && argv[3][1] != 'u')  {
	    interp->result= "argument is not a mutex";
	    return TCL_ERROR;
        }
	mutex= (mutex_t *) atoi( argv[3]+5);
        rc= cond_wait( cond, mutex);
	if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
    }
    else if ( argv[1][0] == 's' && strcmp( argv[1], "signal") == 0)  {
        rc= cond_signal( cond);
	if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
    }
    else if ( argv[1][0] == 'b' && strcmp( argv[1], "broadcast") == 0)  {
	rc= cond_broadcast( cond);
	if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
    }
    else if ( argv[1][0] == 'd' && strcmp( argv[1], "destroy") == 0)  {
	rc= cond_destroy( cond);
	if ( rc != 0)  {
	    Tcl_AppendResult( interp, argv[0], "; ", strerror( rc), NULL);
	    return TCL_ERROR;
	}
	free( cond);
    }
    else  {
	Tcl_AppendResult( interp, "bad option ", argv[1], ": ",
		argv[0], " options are ", options, NULL);
	return TCL_ERROR;
    }

    return TCL_OK;
}

static int
CondTimedWait(
    Tcl_Interp *interp,
    cond_t *cond,
    mutex_t *mutex,
    char *sec,
    char *nsec,
    int absolute
)
{
    timestruc_t abstime;
    int rc;

    abstime.tv_nsec= 0;
    if ( Tcl_GetInt( interp, sec, (int *)&abstime.tv_sec) != TCL_OK)
	return TCL_ERROR;
    if ( Tcl_GetInt(interp, nsec, (int *)&abstime.tv_nsec) != TCL_OK)
	return TCL_ERROR;

    if ( ! absolute)  {
	struct timeval curtime;
	gettimeofday( &curtime);
	abstime.tv_sec+= abstime.tv_nsec / 1000000000U;
	abstime.tv_nsec= abstime.tv_nsec % 1000000000U;
	abstime.tv_sec+= curtime.tv_sec;
	abstime.tv_nsec+= curtime.tv_usec * 1000;
	abstime.tv_sec+= abstime.tv_nsec / 1000000000U;
	abstime.tv_nsec= abstime.tv_nsec % 1000000000U;
    }
    return cond_timedwait( cond, mutex, &abstime);

}
