Tcl Source Code

typedef struct Tcl_Namespace {
    char *name;			/* The namespace's name within its parent
				 * namespace. This contains no ::'s. The name
				 * of the global namespace is "" although "::"
				 * is an synonym. */
    char *fullName;		/* The namespace's fully qualified name. This
				 * starts with ::. */
    void *clientData;	/* Arbitrary value associated with this
				 * namespace. */
    Tcl_NamespaceDeleteProc *deleteProc;
				/* Function invoked when deleting the
				 * namespace to, e.g., free clientData. */
    struct Tcl_Namespace *parentPtr;
				/* Points to the namespace that contains this
				 * one. NULL if this is the global

    int isNativeObjectProc;	/* 1 if objProc was registered by a call to
				 * Tcl_CreateObjCommand; 2 if objProc was registered by
				 * a call to Tcl_CreateObjCommand2; 0 otherwise.
				 * Tcl_SetCmdInfo does not modify this field. */
    Tcl_ObjCmdProc *objProc;	/* Command's object-based function. */
    void *objClientData;	/* ClientData for object proc. */
    Tcl_CmdProc *proc;		/* Command's string-based function. */
    void *clientData;	/* ClientData for string proc. */
    Tcl_CmdDeleteProc *deleteProc;
				/* Function to call when command is
				 * deleted. */
    void *deleteData;	/* Value to pass to deleteProc (usually the
				 * same as clientData). */
    Tcl_Namespace *namespacePtr;/* Points to the namespace that contains this
				 * command. Note that Tcl_SetCmdInfo will not
				 * change a command's namespace; use
				 * TclRenameCommand or Tcl_Eval (of 'rename')
				 * to do that. */
    Tcl_ObjCmdProc2 *objProc2;	/* Command's object2-based function. */

 *				o Run in iPtr->lookupNsPtr or global namespace
 *				o Cut out of error traces
 *				o Don't reset the flags controlling ensemble
 *				  error message rewriting.
 *	TCL_CANCEL_UNWIND:	Magical Tcl_CancelEval mode that causes the
 *				stack for the script in progress to be
 *				completely unwound.
 *	TCL_EVAL_NOERR:	Do no exception reporting at all, just return
 *				as the caller will report.
 */

#define TCL_NO_EVAL		0x010000
#define TCL_EVAL_GLOBAL		0x020000
#define TCL_EVAL_DIRECT		0x040000
#define TCL_EVAL_INVOKE		0x080000

 */

struct Tcl_HashEntry {
    Tcl_HashEntry *nextPtr;	/* Pointer to next entry in this hash bucket,
				 * or NULL for end of chain. */
    Tcl_HashTable *tablePtr;	/* Pointer to table containing entry. */
    size_t hash;		/* Hash value. */
    void *clientData;	/* Application stores something here with
				 * Tcl_SetHashValue. */
    union {			/* Key has one of these forms: */
	char *oneWordValue;	/* One-word value for key. */
	Tcl_Obj *objPtr;	/* Tcl_Obj * key value. */
	int words[1];		/* Multiple integer words for key. The actual
				 * size will be as large as necessary for this
				 * table's keys. */

struct Tcl_HashTable {
    Tcl_HashEntry **buckets;	/* Pointer to bucket array. Each element
				 * points to first entry in bucket's hash
				 * chain, or NULL. */
    Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
				/* Bucket array used for small tables (to
				 * avoid mallocs and frees). */
    Tcl_Size numBuckets;		/* Total number of buckets allocated at
				 * **bucketPtr. */
    Tcl_Size numEntries;		/* Total number of entries present in
				 * table. */
    Tcl_Size rebuildSize;		/* Enlarge table when numEntries gets to be
				 * this large. */
#if TCL_MAJOR_VERSION > 8
    size_t mask;		/* Mask value used in hashing function. */
#endif
    int downShift;		/* Shift count used in hashing function.
				 * Designed to use high-order bits of
				 * randomized keys. */
#if TCL_MAJOR_VERSION < 9
    int mask;		/* Mask value used in hashing function. */
#endif
    int keyType;		/* Type of keys used in this table. It's
				 * either TCL_CUSTOM_KEYS, TCL_STRING_KEYS,
				 * TCL_ONE_WORD_KEYS, or an integer giving the
				 * number of ints that is the size of the
				 * key. */
    Tcl_HashEntry *(*findProc) (Tcl_HashTable *tablePtr, const char *key);

 * token.
 */

typedef struct Tcl_Token {
    int type;			/* Type of token, such as TCL_TOKEN_WORD; see
				 * below for valid types. */
    const char *start;		/* First character in token. */
    Tcl_Size size;			/* Number of bytes in token. */
    Tcl_Size numComponents;		/* If this token is composed of other tokens,
				 * this field tells how many of them there are
				 * (including components of components, etc.).
				 * The component tokens immediately follow
				 * this one. */
} Tcl_Token;

/*

 */

#define NUM_STATIC_TOKENS 20

typedef struct Tcl_Parse {
    const char *commentStart;	/* Pointer to # that begins the first of one
				 * or more comments preceding the command. */
    Tcl_Size commentSize;		/* Number of bytes in comments (up through
				 * newline character that terminates the last
				 * comment). If there were no comments, this
				 * field is 0. */
    const char *commandStart;	/* First character in first word of
				 * command. */
    Tcl_Size commandSize;		/* Number of bytes in command, including first
				 * character of first word, up through the
				 * terminating newline, close bracket, or
				 * semicolon. */
    Tcl_Size numWords;		/* Total number of words in command. May be
				 * 0. */
    Tcl_Token *tokenPtr;	/* Pointer to first token representing the
				 * words of the command. Initially points to

				 * into UTF-8. */
    Tcl_EncodingConvertProc *fromUtfProc;
				/* Function to convert from UTF-8 into
				 * external encoding. */
    Tcl_FreeProc *freeProc;
				/* If non-NULL, function to call when this
				 * encoding is deleted. */
    void *clientData;	/* Arbitrary value associated with encoding
				 * type. Passed to conversion functions. */
    Tcl_Size nullSize;		/* Number of zero bytes that signify
				 * end-of-string in this encoding. This number
				 * is used to determine the source string
				 * length when the srcLen argument is
				 * negative. Must be 1, 2, or 4. */
} Tcl_EncodingType;

				 * argv array. */
    void *srcPtr;		/* Value to be used in setting dst; usage
				 * depends on type.*/
    void *dstPtr;		/* Address of value to be modified; usage
				 * depends on type.*/
    const char *helpStr;	/* Documentation message describing this
				 * option. */
    void *clientData;	/* Word to pass to function callbacks. */
} Tcl_ArgvInfo;

/*
 * Legal values for the type field of a Tcl_ArgInfo: see the user
 * documentation for details.
 */

 *   Tcl_DecrRefCount(objPtr);
 *
 * This will free the obj if there are no references to the obj.
 */
#   define Tcl_BounceRefCount(objPtr) \
    TclBounceRefCount(objPtr, __FILE__, __LINE__)

static inline void TclBounceRefCount(Tcl_Obj* objPtr, const char* fn, int line)




{
    if (objPtr) {
        if ((objPtr)->refCount == 0) {
            Tcl_DbDecrRefCount(objPtr, fn, line);
	}
    }
}
#else
#   undef Tcl_IncrRefCount
#   define Tcl_IncrRefCount(objPtr) \
	((void)++(objPtr)->refCount)
    /*
     * Use do/while0 idiom for optimum correctness without compiler warnings.
     * https://wiki.c2.com/?TrivialDoWhileLoop
     */
#   undef Tcl_DecrRefCount
#   define Tcl_DecrRefCount(objPtr) \
	do { \
	    Tcl_Obj *_objPtr = (objPtr); \
	    if (_objPtr->refCount-- <= 1) { \
		TclFreeObj(_objPtr); \
	    } \
	} while(0)
#   undef Tcl_IsShared
#   define Tcl_IsShared(objPtr) \
	((objPtr)->refCount > 1)

/*
 * Declare that obj will no longer be used or referenced.
 * This will release the obj if there is no referece count,
 * otherwise let it be.
 */
#   define Tcl_BounceRefCount(objPtr)     \
    TclBounceRefCount(objPtr);

static inline void TclBounceRefCount(Tcl_Obj* objPtr)


{
    if (objPtr) {
        if ((objPtr)->refCount == 0) {
            Tcl_DecrRefCount(objPtr);
	}
    }
}

    } ovu;
#define overMagic0	ovu.magic0
#define overMagic1	ovu.magic1
#define bucketIndex	ovu.index
#define rangeCheckMagic	ovu.rmagic
#define realBlockSize	ovu.size
};


#define MAGIC		0xEF	/* magic # on accounting info */
#define RMAGIC		0x5555	/* magic # on range info */

#ifndef NDEBUG
#define	RSLOP		sizeof(unsigned short)
#else

typedef struct AssemblyEnv {
    CompileEnv* envPtr;		/* Compilation environment being used for code
				 * generation */
    Tcl_Parse* parsePtr;	/* Parse of the current line of source */
    Tcl_HashTable labelHash;	/* Hash table whose keys are labels and whose
				 * values are 'label' objects storing the code
				 * offsets of the labels. */
    Tcl_Size cmdLine;	/* Current line number within the assembly
				 * code */
    Tcl_Size* clNext;	/* Invisible continuation line for
				 * [info frame] */
    BasicBlock* head_bb;	/* First basic block in the code */
    BasicBlock* curr_bb;	/* Current basic block */
    int maxDepth;		/* Maximum stack depth encountered */
    int curCatchDepth;		/* Current depth of catches */
    int maxCatchDepth;		/* Maximum depth of catches encountered */
    int flags;			/* Compilation flags (TCL_EVAL_DIRECT) */

static void		CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*,
			    const TalInstDesc*);
static int		DefineLabel(AssemblyEnv* envPtr, const char* label);
static void		DeleteMirrorJumpTable(JumptableInfo* jtPtr);
static void		FillInJumpOffsets(AssemblyEnv*);
static int		CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr,
			    Tcl_Obj* jumpTable);
static size_t	FindLocalVar(AssemblyEnv* envPtr,
			    Tcl_Token** tokenPtrPtr);
static int		FinishAssembly(AssemblyEnv*);
static void		FreeAssemblyEnv(AssemblyEnv*);
static int		GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*);
static int		GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*);
static int		GetIntegerOperand(AssemblyEnv*, Tcl_Token**, int*);
static int		GetNextOperand(AssemblyEnv*, Tcl_Token**, Tcl_Obj**);

    TalInstType instType;	/* Type of the instruction */
    Tcl_Obj* operand1Obj = NULL;
				/* First operand to the instruction */
    const char* operand1;	/* String rep of the operand */
    Tcl_Size operand1Len;	/* String length of the operand */
    int opnd;			/* Integer representation of an operand */
    int litIndex;		/* Literal pool index of a constant */
    Tcl_Size localVar;	/* LVT index of a local variable */
    int flags;			/* Flags for a basic block */
    JumptableInfo* jtPtr;	/* Pointer to a jumptable */
    int infoIndex;		/* Index of the jumptable in auxdata */
    int status = TCL_ERROR;	/* Return value from this function */

    /*
     * Make sure that the instruction name is known at compile time.

 */

static int
CreateMirrorJumpTable(
    AssemblyEnv* assemEnvPtr,	/* Assembly environment */
    Tcl_Obj* jumps)		/* List of alternating keywords and labels */
{
    Tcl_Size objc;			/* Number of elements in the 'jumps' list */
    Tcl_Obj** objv;		/* Pointers to the elements in the list */
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    BasicBlock* bbPtr = assemEnvPtr->curr_bb;
				/* Current basic block */

/*
 * TCL_FPCLASSIFY_MODE:
 *	0  - fpclassify
 *	1  - _fpclass
 *	2  - simulate
 *	3  - __builtin_fpclassify


 */







#ifndef TCL_FPCLASSIFY_MODE
#if defined(__MINGW32__) && defined(_X86_) /* mingw 32-bit */
/*
 * MINGW x86 (tested up to gcc 8.1) seems to have a bug in fpclassify,
 * [fpclassify 1e-314], x86 => normal, x64 => subnormal, so switch to using a
 * version using a compiler built-in.

 * assumes that we're on x86 (or at least a system with classic little-endian
 * double layout and a 32-bit 'int' type).
 */
#define TCL_FPCLASSIFY_MODE 2
#endif /* !fpclassify */
/* actually there is no fallback to builtin fpclassify */
#endif /* !TCL_FPCLASSIFY_MODE */


/*
 * Bug 7371b6270b: to check C call stack depth, prefer an approach which is
 * compatible with AddressSanitizer (ASan) use-after-return detection.
 */

#if defined(_MSC_VER) && defined(HAVE_INTRIN_H)

    /* Export unsupported commands */
    nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
    if (nsPtr) {
	Tcl_Export(interp, nsPtr, "*", 1);
    }


#ifdef USE_DTRACE
    /*
     * Register the tcl::dtrace command.
     */

    Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL);
#endif /* USE_DTRACE */

	for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	    Tcl_DeleteCommandFromToken(interp, (Tcl_Command)Tcl_GetHashValue(hPtr));
	}
	Tcl_DeleteHashTable(hTablePtr);
	Tcl_Free(hTablePtr);
    }


    if (iPtr->assocData != NULL) {
	AssocData *dPtr;

	hTablePtr = iPtr->assocData;
	/*
	 * Invoke deletion callbacks; note that a callback can create new
	 * callbacks, so we iterate.

typedef struct {
    Tcl_ObjCmdProc2 *proc;
    void *clientData; /* Arbitrary value to pass to proc function. */
    Tcl_CmdDeleteProc *deleteProc;
    void *deleteData; /* Arbitrary value to pass to deleteProc function. */
    Tcl_ObjCmdProc2 *nreProc;
} CmdWrapperInfo;


static int
cmdWrapperProc(
    void *clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj * const *objv)

			runPtr->data[1] = NULL;
			corPtr->yieldPtr = NULL;
			break;
		    }
		}
	    }
	    iPtr->execEnvPtr = corPtr->eePtr;


            Tcl_SetObjResult(interp, Tcl_NewStringObj(
                    "cannot yield: C stack busy", -1));
            Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD",
                    (char *)NULL);
            return TCL_ERROR;
        }

#define BINARY_ALL -1		/* Use all elements in the argument. */
#define BINARY_NOCOUNT -2	/* No count was specified in format. */

/*
 * The following flags may be OR'ed together and returned by GetFormatSpec
 */

#define BINARY_SIGNED 0		/* Field to be read as signed data */
#define BINARY_UNSIGNED 1	/* Field to be read as unsigned data */


/*
 * The following defines the maximum number of different (integer) numbers
 * placed in the object cache by 'binary scan' before it bails out and
 * switches back to Plan A (creating a new object for each value.)
 * Theoretically, it would be possible to keep the cache about for the values
 * that are already in it, but that makes the code slower in practice when

    Tcl_Interp *interp)		/* Interpreter in which commands should be
				 * added */
{
    TclInitDbCkalloc();
    Tcl_CreateObjCommand(interp, "memory", MemoryCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "checkmem", CheckmemCmd, NULL, NULL);
}


#else	/* TCL_MEM_DEBUG */

/* This is the !TCL_MEM_DEBUG case */

#undef Tcl_InitMemory
#undef Tcl_DumpActiveMemory

 * Structure containing description of "native" clock commands to create.
 */

struct ClockCommand {
    const char *name;		/* The tail of the command name. The full name
				 * is "::tcl::clock::<name>". When NULL marks
				 * the end of the table. */
    Tcl_ObjCmdProc *objCmdProc; /* Function that implements the command. This
				 * will always have the ClockClientData sent
				 * to it, but may well ignore this data. */
    CompileProc *compileProc;	/* The compiler for the command. */
    void *clientData;		/* Any clientData to give the command (if NULL
    				 * a reference to ClockClientData will be sent) */
};

    data->defFlags = 0;

    /*
     * Install the commands.
     */

#define TCL_CLOCK_PREFIX_LEN 14 /* == strlen("::tcl::clock::") */
    memcpy(cmdName, "::tcl::clock::", TCL_CLOCK_PREFIX_LEN);
    for (clockCmdPtr=clockCommands ; clockCmdPtr->name!=NULL ; clockCmdPtr++) {
    	void *clientData;

	strcpy(cmdName + TCL_CLOCK_PREFIX_LEN, clockCmdPtr->name);
	if (!(clientData = clockCmdPtr->clientData)) {
	    clientData = data;

	    || (localeObj->length == dataPtr->prevUsedLocale->length
	    && strcasecmp(loc, TclGetString(dataPtr->prevUsedLocale)) == 0))) {
	*mcDictObj = dataPtr->prevUsedLocaleDict;
	TclSetObjRef(dataPtr->prevUsedLocaleUnnorm, localeObj);
	return dataPtr->prevUsedLocale;
    }

    if ((localeObj->length == 1 /* C */
	    && strcasecmp(loc, Literals[LIT_C]) == 0)
	    || (dataPtr->defaultLocale && (loc2 = TclGetString(dataPtr->defaultLocale))
      	    && localeObj->length == dataPtr->defaultLocale->length
	    && strcasecmp(loc, loc2) == 0)) {
	*mcDictObj = dataPtr->defaultLocaleDict;
	return dataPtr->defaultLocale ?
		dataPtr->defaultLocale : dataPtr->literals[LIT_C];
    }

    if (localeObj->length == 7 /* current */
	    && strcasecmp(loc, Literals[LIT_CURRENT]) == 0) {
	if (dataPtr->currentLocale == NULL) {
	    ClockGetCurrentLocale(dataPtr, interp);
	}
	*mcDictObj = dataPtr->currentLocaleDict;
	return dataPtr->currentLocale;
    }

    if ((localeObj->length == 6 /* system */
	    && strcasecmp(loc, Literals[LIT_SYSTEM]) == 0)) {
	SavePrevLocaleObj(dataPtr);
	TclSetObjRef(dataPtr->lastUsedLocaleUnnorm, localeObj);
	localeObj = ClockGetSystemLocale(dataPtr, interp);
	TclSetObjRef(dataPtr->lastUsedLocale, localeObj);
	*mcDictObj = NULL;
	return localeObj;

		if (Tcl_EvalObjv(opts->interp, 2, callargs, 0) != TCL_OK) {
		    return NULL;
		}

		opts->mcDictObj = Tcl_GetObjResult(opts->interp);
		Tcl_ResetResult(opts->interp);
		ref = 0; /* new object is not yet referenced */
	    }


	    /* be sure that object reference doesn't increase (dict changeable) */

	    if (opts->mcDictObj->refCount > ref) {
		/* smart reference (shared dict as object with no ref-counter) */
		opts->mcDictObj = TclDictObjSmartRef(opts->interp,
			opts->mcDictObj);
	    }


	    /* create exactly one reference to catalog / make it searchable for future */

	    Tcl_DictObjPut(NULL, dataPtr->mcDicts, opts->localeObj,
		    opts->mcDictObj);

	    if (opts->localeObj == dataPtr->literals[LIT_C]
		    || opts->localeObj == dataPtr->defaultLocale) {
		dataPtr->defaultLocaleDict = opts->mcDictObj;
	    }

	if (opts->mcDictObj == NULL) {
	    return NULL;
	}
    }

    Tcl_DictObjGet(opts->interp, opts->mcDictObj,
	    opts->dataPtr->mcLiterals[mcKey], &valObj);
    return valObj; /* or NULL in obscure case if Tcl_DictObjGet failed */
}

/*
 *----------------------------------------------------------------------
 *
 * ClockMCGetIdx --
 *

		rangesVal) != TCL_OK) {
	    return TCL_ERROR;
	}

	seconds = fields->seconds;

	/* Cache the last conversion */
	if (ltzoc != NULL) { /* slot was found above */
	    /* timezoneObj and changeover are the same */
	    TclSetObjRef(ltzoc->tzName, fields->tzName); /* may be NULL */
	} else {
	    /* no TZ in cache - just move second slot down and use the first one */
	    ltzoc = &dataPtr->lastTZOffsCache[0];
	    TclUnsetObjRef(dataPtr->lastTZOffsCache[1].timezoneObj);
	    TclUnsetObjRef(dataPtr->lastTZOffsCache[1].tzName);
	    memcpy(&dataPtr->lastTZOffsCache[1], ltzoc, sizeof(*ltzoc));
	    TclInitObjRef(ltzoc->timezoneObj, timezoneObj);
	    ltzoc->changeover = changeover;
	    TclInitObjRef(ltzoc->tzName, fields->tzName); /* may be NULL */
	}
	ltzoc->localSeconds = fields->localSeconds;
	ltzoc->rangesVal[0] = rangesVal[0];
	ltzoc->rangesVal[1] = rangesVal[1];
	ltzoc->tzOffset = fields->tzOffset;
    }


    /* check DST-hole: if retrieved seconds is out of range */
    if (ltzoc->rangesVal[0] > seconds || seconds >= ltzoc->rangesVal[1]) {
    dstHole:
#if 0
	printf("given local-time is outside the time-zone (in DST-hole): "
		"%d - offs %d => %d <= %d < %d\n",
		(int)fields->localSeconds, fields->tzOffset,
		(int)ltzoc->rangesVal[0], (int)seconds, (int)ltzoc->rangesVal[1]);
#endif
	/* because we don't know real TZ (we're outsize), just invalidate local
	 * time (which could be verified in ClockValidDate later) */
	fields->localSeconds = TCL_INV_SECONDS; /* not valid seconds */
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *

	    return TCL_ERROR;
	}

	/* converted using table (TZ isn't :localtime) */
	fields->flags &= ~CLF_CTZ;

	/* Cache the last conversion */
	if (ltzoc != NULL) { /* slot was found above */
	    /* timezoneObj and changeover are the same */
	    TclSetObjRef(ltzoc->tzName, fields->tzName);
	} else {

	    /* no TZ in cache - just move second slot down and use the first one */



	    ltzoc = &dataPtr->lastTZOffsCache[0];
	    TclUnsetObjRef(dataPtr->lastTZOffsCache[1].timezoneObj);
	    TclUnsetObjRef(dataPtr->lastTZOffsCache[1].tzName);
	    memcpy(&dataPtr->lastTZOffsCache[1], ltzoc, sizeof(*ltzoc));
	    TclInitObjRef(ltzoc->timezoneObj, timezoneObj);
	    ltzoc->changeover = changeover;
	    TclInitObjRef(ltzoc->tzName, fields->tzName);

    int month;
    const int *dipm = daysInPriorMonths[IsGregorianLeapYear(fields)];

    /*
     * Estimate month by calculating `dayOfYear / (365/12)`
     */
    month = (day*12) / dipm[12];


    /* then do forwards backwards correction */

    while (1) {
	if (day > dipm[month]) {
	    if (month >= 11 || day <= dipm[month + 1]) {
		break;
	    }
	    month++;
	} else {

	fields->year = year;
    }

    /*
     * Try an initial conversion in the Gregorian calendar.
     */

#if 0 /* BUG https://core.tcl-lang.org/tcl/tktview?name=da340d4f32 */
    ym1o4 = ym1 / 4;
#else
    /*
     * Have to make sure quotient is truncated towards 0 when negative.
     * See above bug for details. The casts are necessary.
     */
    if (ym1 >= 0) {

 *
 * Side effects:
 *	Stores day number in 'julianDay'
 *
 *----------------------------------------------------------------------
 */


void
GetJulianDayFromEraYearDay(
    TclDateFields *fields,	/* Date to convert */
    int changeover)		/* Gregorian transition date as a Julian Day */
{
    Tcl_WideInt year, ym1;

} ClockOperation;

static int
ClockParseFmtScnArgs(
    ClockFmtScnCmdArgs *opts,	/* Result vector: format, locale, timezone... */
    TclDateFields *date,	/* Extracted date-time corresponding base
				 * (by scan or add) resp. clockval (by format) */
    Tcl_Size objc,			/* Parameter count */
    Tcl_Obj *const objv[],	/* Parameter vector */
    ClockOperation operation,	/* What operation are we doing: format, scan, add */
    const char *syntax)		/* Syntax of the current command */
{
    Tcl_Interp *interp = opts->interp;
    ClockClientData *dataPtr = opts->dataPtr;
    int gmtFlag = 0;

    Tcl_WideInt baseVal;	/* Base time, expressed in seconds from the Epoch */

    if (operation == CLC_OP_SCN) {
    	/* default flags (from configure) */
    	opts->flags |= dataPtr->defFlags & CLF_VALIDATE;
    } else {
    	/* clock value (as current base) */

	opts->baseObj = objv[(baseIdx = 1)];
	saw |= 1 << CLC_ARGS_BASE;
    }

    /*
     * Extract values for the keywords.
     */

	case CLC_ARGS_LOCALE:
	    opts->localeObj = objv[i + 1];
	    break;
	case CLC_ARGS_TIMEZONE:
	    opts->timezoneObj = objv[i + 1];
	    break;
	case CLC_ARGS_BASE:

	    opts->baseObj = objv[(baseIdx = i + 1)];
	    break;
	case CLC_ARGS_VALIDATE:
	    if (operation != CLC_OP_SCN) {
		goto badOptionMsg;
	    } else {
		int val;

    DateInfo *info,		/* Clock scan info structure */
    ClockFmtScnCmdArgs *opts)	/* Format, locale, timezone and base */
{
    /* If needed assemble julianDay using year, month, etc. */
    if (info->flags & CLF_ASSEMBLE_JULIANDAY) {
	if (info->flags & CLF_ISO8601WEEK) {
	    GetJulianDayFromEraYearWeekDay(&yydate, GREGORIAN_CHANGE_DATE);
	} else if (!(info->flags & CLF_DAYOFYEAR) /* no day of year */
		|| (info->flags & (CLF_DAYOFMONTH|CLF_MONTH)) /* yymmdd over yyddd */
		== (CLF_DAYOFMONTH|CLF_MONTH)) {
	    GetJulianDayFromEraYearMonthDay(&yydate, GREGORIAN_CHANGE_DATE);
	} else {
	    GetJulianDayFromEraYearDay(&yydate, GREGORIAN_CHANGE_DATE);
	}
	info->flags |= CLF_ASSEMBLE_SECONDS;
	info->flags &= ~CLF_ASSEMBLE_JULIANDAY;

	    yySecondOfDay, (int)yydate.localSeconds, (int)(yydate.localSeconds % SECONDS_PER_DAY),
	    yydate.tzOffset);
#endif

    if (!(stage & CLF_VALIDATE_S1) || !(opts->flags & CLF_VALIDATE_S1)) {
	goto stage_2;
    }
    opts->flags &= ~CLF_VALIDATE_S1; /* stage 1 is done */

    /* first year (used later in hath / daysInPriorMonths) */
    if ((info->flags & (CLF_YEAR | CLF_ISO8601YEAR))) {
	if ((info->flags & CLF_ISO8601YEAR)) {
	    if (yydate.iso8601Year < dataPtr->validMinYear
		    || yydate.iso8601Year > dataPtr->validMaxYear) {
		errMsg = "invalid iso year";
		errCode = "iso year";
		goto error;
	    }
	}
	if (info->flags & CLF_YEAR) {
	    if (yyYear < dataPtr->validMinYear
		    || yyYear > dataPtr->validMaxYear) {
		errMsg = "invalid year";
		errCode = "year";
		goto error;
	    }
	} else if ((info->flags & CLF_ISO8601YEAR)) {
	    yyYear = yydate.iso8601Year; /* used to recognize leap */
	}
	if ((info->flags & (CLF_ISO8601YEAR | CLF_YEAR))
		== (CLF_ISO8601YEAR | CLF_YEAR)) {
	    if (yyYear != yydate.iso8601Year) {
		errMsg = "ambiguous year";
		errCode = "year";
		goto error;

	    goto error;
	}
    }

    if (!(stage & CLF_VALIDATE_S2) || !(opts->flags & CLF_VALIDATE_S2)) {
	return TCL_OK;
    }
    opts->flags &= ~CLF_VALIDATE_S2; /* stage 2 is done */

    /*
     * Further tests expected ready calculated julianDay (inclusive relative),
     * and time-zone conversion (local to UTC time).
     */
  stage_2:

    /* adjust if we end up on a weekend */
    if (resDayOfWeek > 5) {
	offs += 2;
    }

    return offs;
}



/*----------------------------------------------------------------------
 *
 * ClockAddObjCmd -- , clock add --
 *
 *	Adds an offset to a given time.
 *

    } else {
	/* legacy (alnum) timezone like CEST, etc. */
	if (maxLen > 4) {
	    maxLen = 4;
	}
	while (len < maxLen) {
	    if ((*p & 0x80)
		    || (!isalpha(UCHAR(*p)) && !isdigit(UCHAR(*p)))) {	/* INTL: ISO only. */
		break;
	    }
	    p++;
	    len++;
	}

	if (len < minLen) {

				 * changed from TCL_OK to TCL_ERROR. */
} SortInfo;

/*
 * The "sortMode" field of the SortInfo structure can take on any of the
 * following values.
 */

#define SORTMODE_ASCII		0
#define SORTMODE_INTEGER	1
#define SORTMODE_REAL		2
#define SORTMODE_COMMAND	3
#define SORTMODE_DICTIONARY	4
#define SORTMODE_ASCII_NC	8


/*
 * Definitions for [lseq] command
 */
static const char *const seq_operations[] = {
    "..", "to", "count", "by", NULL
};

	    /*
	     * Once an error has occurred, skip any future comparisons so as
	     * to preserve the error message in sortInterp->result.
	     */

	    return 0;
	}


	objPtr1 = elemPtr1->collationKey.objValuePtr;
	objPtr2 = elemPtr2->collationKey.objValuePtr;

	paramObjv[0] = objPtr1;
	paramObjv[1] = objPtr2;

	/* drop the script */
	dropScript = 1;
	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
	TclEmitOpcode(		INST_POP,			envPtr);
    }
    ExceptionRangeEnds(envPtr, range);


    /*
     * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result,
     * and jump around the "error case" code.
     */

    TclCheckStackDepth(depth+1, envPtr);
    PushStringLiteral(envPtr, "0");
    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);

    /*
     * Emit the "error case" epilogue. Push the interpreter result and the
     * return code.
     */

    ExceptionRangeTarget(envPtr, range, catchOffset);
    TclSetStackDepth(depth + dropScript, envPtr);

    if (dropScript) {
	TclEmitOpcode(		INST_POP,			envPtr);
    }


    /* Stack at this point is empty */
    TclEmitOpcode(		INST_PUSH_RESULT,		envPtr);
    TclEmitOpcode(		INST_PUSH_RETURN_CODE,		envPtr);

    /* Stack at this point on both branches: result returnCode */

	infoPtr->numLists++;

	for (j = 0;  j < numVars;  j++) {
	    Tcl_Obj *varNameObj;
	    const char *bytes;
	    int varIndex;
	    Tcl_Size length;


	    Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj);
	    bytes = TclGetStringFromObj(varNameObj, &length);
	    varIndex = LocalScalar(bytes, length, envPtr);
	    if (varIndex < 0) {
		code = TCL_ERROR;
		goto done;

	Tcl_Parse *parsePtr = (Tcl_Parse *)Tcl_Alloc(sizeof(Tcl_Parse));

	do {
	    const char *next;

	    if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, parsePtr)) {
		/*
		* Compile bytecodes to report the parsePtr error at runtime.
		*/

		Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
			parsePtr->term + 1 - parsePtr->commandStart);
		TclCompileSyntaxError(interp, envPtr);
		Tcl_Free(parsePtr);
		return;
	    }

 * The structure defining the bytecode instructions resulting from compiling a
 * Tcl script. Note that this structure is variable length: a single heap
 * object is allocated to hold the ByteCode structure immediately followed by
 * the code bytes, the literal object array, the ExceptionRange array, the
 * CmdLocation map, and the compilation AuxData array.
 */


/*
 * A PRECOMPILED bytecode struct is one that was generated from a compiled
 * image rather than implicitly compiled from source
 */

#define TCL_BYTECODE_PRECOMPILED		0x0001

/*
 * When a bytecode is compiled, interp or namespace resolvers have not been
 * applied yet: this is indicated by the TCL_BYTECODE_RESOLVE_VARS flag.
 */

#define TCL_BYTECODE_RESOLVE_VARS		0x0002

#define TCL_BYTECODE_RECOMPILE			0x0004


typedef struct ByteCode {
    TclHandle interpHandle;	/* Handle for interpreter containing the
				 * compiled code. Commands and their compile
				 * procs are specific to an interpreter so the
				 * code emitted will depend on the
				 * interpreter. */
    Tcl_Size compileEpoch;		/* Value of iPtr->compileEpoch when this
				 * ByteCode was compiled. Used to invalidate
				 * code when, e.g., commands with compile
				 * procs are redefined. */
    Namespace *nsPtr;		/* Namespace context in which this code was
				 * compiled. If the code is executed if a
				 * different namespace, it must be
				 * recompiled. */

				 * Proc structure; otherwise NULL. This
				 * pointer is also not owned by the ByteCode
				 * and must not be freed by it. */
    size_t structureSize;	/* Number of bytes in the ByteCode structure
				 * itself. Does not include heap space for
				 * literal Tcl objects or storage referenced
				 * by AuxData entries. */
    Tcl_Size numCommands;		/* Number of commands compiled. */
    Tcl_Size numSrcBytes;		/* Number of source bytes compiled. */
    Tcl_Size numCodeBytes;		/* Number of code bytes. */
    Tcl_Size numLitObjects;		/* Number of objects in literal array. */
    Tcl_Size numExceptRanges;	/* Number of ExceptionRange array elems. */
    Tcl_Size numAuxDataItems;	/* Number of AuxData items. */
    Tcl_Size numCmdLocBytes;		/* Number of bytes needed for encoded command
				 * location information. */
    Tcl_Size maxExceptDepth;		/* Maximum nesting level of ExceptionRanges;
				 * TCL_INDEX_NONE if no ranges were compiled. */
    Tcl_Size maxStackDepth;		/* Maximum number of stack elements needed to
				 * execute the code. */
    unsigned char *codeStart;	/* Points to the first byte of the code. This
				 * is just after the final ByteCode member
				 * cmdMapPtr. */
    Tcl_Obj **objArrayPtr;	/* Points to the start of the literal object
				 * array. This is just after the last code
				 * byte. */

				 * variables. */
#ifdef TCL_COMPILE_STATS
    Tcl_Time createTime;	/* Absolute time when the ByteCode was
				 * created. */
#endif /* TCL_COMPILE_STATS */
} ByteCode;

#define ByteCodeSetInternalRep(objPtr, typePtr, codePtr)			\
    do {								\
	Tcl_ObjInternalRep ir;						\
	ir.twoPtrValue.ptr1 = (codePtr);				\
	ir.twoPtrValue.ptr2 = NULL;					\
	Tcl_StoreInternalRep((objPtr), (typePtr), &ir);			\
    } while (0)



#define ByteCodeGetInternalRep(objPtr, typePtr, codePtr)			\
    do {								\
	const Tcl_ObjInternalRep *irPtr;					\
	irPtr = TclFetchInternalRep((objPtr), (typePtr));			\
	(codePtr) = irPtr ? (ByteCode*)irPtr->twoPtrValue.ptr1 : NULL;		\
    } while (0)

/*
 * Opcodes for the Tcl bytecode instructions. These must correspond to the
 * entries in the table of instruction descriptions, tclInstructionTable, in
 * tclCompile.c. Also, the order and number of the expression opcodes (e.g.,
 * INST_BITOR) must match the entries in the array operatorStrings in

 *
 * void *TclFetchAuxData(CompileEng *envPtr, int index);
 */

#define TclFetchAuxData(envPtr, index) \
    (envPtr)->auxDataArrayPtr[(index)].clientData


#define LITERAL_ON_HEAP		0x01
#define LITERAL_CMD_NAME	0x02
#define LITERAL_UNSHARED	0x04


/*
 * Macro used to manually adjust the stack requirements; used in cases where
 * the stack effect cannot be computed from the opcode and its operands, but
 * is still known at compile time.
 *
 * void TclAdjustStackDepth(int delta, CompileEnv *envPtr);

#define TclUpdateStackReqs(op, i, envPtr) \
    do {							\
	int _delta = tclInstructionTable[(op)].stackEffect;	\
	if (_delta) {						\
	    if (_delta == INT_MIN) {				\
		_delta = 1 - (i);				\
	    }							\
	    TclAdjustStackDepth(_delta, envPtr);			\
	}							\
    } while (0)

/*
 * Macros used to update the flag that indicates if we are at the start of a
 * command, based on whether the opcode is INST_START_COMMAND.
 *

				 * EscapeSubTables. */
} EscapeEncodingData;

/*
 * Constants used when loading an encoding file to identify the type of the
 * file.
 */

#define ENCODING_SINGLEBYTE	0
#define ENCODING_DOUBLEBYTE	1
#define ENCODING_MULTIBYTE	2
#define ENCODING_ESCAPE		3


/*
 * A list of directories in which Tcl should look for *.enc files. This list
 * is shared by all threads. Access is governed by a mutex lock.
 */

static TclInitProcessGlobalValueProc InitializeEncodingSearchPath;

static Tcl_EncodingConvertProc	UtfToUtf32Proc;
static Tcl_EncodingConvertProc	Utf16ToUtfProc;
static Tcl_EncodingConvertProc	UtfToUtf16Proc;
static Tcl_EncodingConvertProc	UtfToUcs2Proc;
static Tcl_EncodingConvertProc	UtfToUtfProc;
static Tcl_EncodingConvertProc	Iso88591FromUtfProc;
static Tcl_EncodingConvertProc	Iso88591ToUtfProc;


/*
 * A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field
 * of the internalrep. This should help the lifetime of encodings be more useful.
 * See concerns raised in [Bug 1077262].
 */

/*
 * NOTE: THESE BIT DEFINITIONS SHOULD NOT OVERLAP WITH INTERNAL USE BITS
 * DEFINED IN tcl.h (TCL_ENCODING_* et al). Be cognizant of this
 * when adding bits. TODO - should really be defined in a single file.
 *
 * To prevent conflicting bits, only define bits within 0xff00 mask here.
 */

#define TCL_ENCODING_LE	0x100   /* Used to distinguish LE/BE variants */
#define ENCODING_UTF	0x200	/* For UTF-8 encoding, allow 4-byte output sequences */
#define ENCODING_INPUT	0x400   /* For UTF-8/CESU-8 encoding, means external -> internal */


void
TclInitEncodingSubsystem(void)
{
    Tcl_EncodingType type;
    TableEncodingData *dataPtr;
    unsigned size;

#  define tenviron environ
#  define tenviron2utfdstr(str, dsPtr) \
		Tcl_ExternalToUtfDString(NULL, str, -1, dsPtr)
#  define utf2tenvirondstr(str, dsPtr) \
		Tcl_UtfToExternalDString(NULL, str, -1, dsPtr)
#  define techar char
#endif


/* MODULE_SCOPE */
size_t TclEnvEpoch = 0;	/* Epoch of the tcl environment
				 * (if changed with tcl-env). */

static struct {
    Tcl_Size cacheSize;		/* Number of env strings in cache. */

     */

    if (move) {
	moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1;
    }
    needed = growth + moveWords + WALLOCALIGN;


    /*
     * Check if there is enough room in the next stack (if there is one, it
     * should be both empty and the last one!)
     */

    if (esPtr->nextPtr) {
	oldPtr = esPtr;

    case INST_GE: {
	int iResult = 0, compare = 0;

	value2Ptr = OBJ_AT_TOS;
	valuePtr = OBJ_UNDER_TOS;

	/*
	    Try to determine, without triggering generation of a string
	    representation, whether one value is not a number.
	*/
	if (TclCheckEmptyString(valuePtr) > 0 || TclCheckEmptyString(value2Ptr) > 0) {
	    goto stringCompare;
	}

	if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK
		|| GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) {
	    /*

			interp, listPtr, &listLen, &elements);
		}
		if (status != TCL_OK) {
		    CACHE_STACK_INFO();
		    goto gotError;
		}
		CACHE_STACK_INFO();


		valIndex = (iterNum * numVars);
		for (j = 0;  j < numVars;  j++) {
		    if (valIndex >= listLen) {
			TclNewObj(valuePtr);
		    } else {
			DECACHE_STACK_INFO();

			    const char *separators, Tcl_Obj *pathPtr, int flags,
			    char *pattern, Tcl_GlobTypeData *types);
static int		TclGlob(Tcl_Interp *interp, char *pattern,
			    Tcl_Obj *pathPrefix, int globFlags,
			    Tcl_GlobTypeData *types);

/* Flag values used by TclGlob() */

#define TCL_GLOBMODE_DIR	4
#define TCL_GLOBMODE_TAILS	8


/*
 * When there is no support for getting the block size of a file in a stat()
 * call, use this as a guess. Allow it to be overridden in the platform-
 * specific files.
 */

    }

    /*
     * Cancel any outstanding timer.
     */
    DeleteTimerHandler(statePtr);


    /*
     * Mark the channel as deleted by clearing the type structure.
     */

    if (chanPtr->downChanPtr != NULL) {
	Channel *downChanPtr = chanPtr->downChanPtr;

    /* This must comes after UpdateInterest(), which may set errno */
    if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
	    && (!copied || !GotFlag(statePtr, CHANNEL_NONBLOCKING))) {
	/* Channel either is blocking or is nonblocking with no data
	 * succesfully red before the error.  Return an error so that callers
	 * like [read] can also return an error.
	*/
	ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR);
	Tcl_SetErrno(EILSEQ);
	copied = -1;
    }
    TclChannelRelease((Tcl_Channel)chanPtr);
    return copied;
}

 * Buffers data being sent to or from a channel.
 */

typedef struct ChannelBuffer {
    Tcl_Size refCount;		/* Current uses count */
    Tcl_Size nextAdded;		/* The next position into which a character
				 * will be put in the buffer. */
    Tcl_Size nextRemoved;		/* Position of next byte to be removed from
				 * the buffer. */
    Tcl_Size bufLength;		/* How big is the buffer? */
    struct ChannelBuffer *nextPtr;
    				/* Next buffer in chain. */
    char buf[TCLFLEXARRAY];		/* Placeholder for real buffer. The real
				 * buffer occupies this space + bufSize-1
				 * bytes. This must be the last field in the
				 * structure. */
} ChannelBuffer;

#define CHANNELBUFFER_HEADER_SIZE	offsetof(ChannelBuffer, buf)

 * data specific to the channel but which belongs to the generic part of the
 * Tcl channel mechanism, and it points at an instance specific (and type
 * specific) instance data, and at a channel type structure.
 */

typedef struct Channel {
    struct ChannelState *state; /* Split out state information */
    void *instanceData;	/* Instance-specific data provided by creator
				 * of channel. */
    const Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */
    struct Channel *downChanPtr;/* Refers to channel this one was stacked
				 * upon. This reference is NULL for normal
				 * channels. See Tcl_StackChannel. */
    struct Channel *upChanPtr;	/* Refers to the channel above stacked this
				 * one. NULL for the top most channel. */

    TclEolTranslation outputTranslation;
				/* What translation to use for generating end
				 * of line sequences in output? */
    int inEofChar;		/* If nonzero, use this as a signal of EOF on
				 * input. */
#if TCL_MAJOR_VERSION < 9
    int outEofChar;		/* If nonzero, append this to the channel when
				 * it is closed if it is open for writing. For Tcl 8.x only */

#endif
    int unreportedError;	/* Non-zero if an error report was deferred
				 * because it happened in the background. The
				 * value is the POSIX error code. */
    Tcl_Size refCount;		/* How many interpreters hold references to
				 * this IO channel? */
    struct CloseCallback *closeCbPtr;

				 * handlers for. */
    EventScriptRecord *scriptRecordPtr;
				/* Chain of all scripts registered for event
				 * handlers ("fileevent") on this channel. */
    Tcl_Size bufSize;		/* What size buffers to allocate? */
    Tcl_TimerToken timer;	/* Handle to wakeup timer for this channel. */
    Channel *timerChanPtr;	/* Needed in order to decrement the refCount of
				   the right channel when the timer is
				   deleted. */
    struct CopyState *csPtrR;	/* State of background copy for which channel
				 * is input, or NULL. */
    struct CopyState *csPtrW;	/* State of background copy for which channel
				 * is output, or NULL. */
    Channel *topChanPtr;	/* Refers to topmost channel in a stack. Never
				 * NULL. */
    Channel *bottomChanPtr;	/* Refers to bottommost channel in a stack.

/*
 * Values for the flags field in Channel. Any OR'ed combination of the
 * following flags can be stored in the field. These flags record various
 * options and state bits about the channel. In addition to the flags below,
 * the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set.
 */


#define CHANNEL_NONBLOCKING	(1<<6)	/* Channel is currently in nonblocking
					 * mode. */
#define BG_FLUSH_SCHEDULED	(1<<7)	/* A background flush of the queued
					 * output buffers has been
					 * scheduled. */
#define CHANNEL_CLOSED		(1<<8)	/* Channel has been closed. No further
					 * Tcl-level IO on the channel is
					 * allowed. */
#define CHANNEL_EOF		(1<<9)	/* EOF occurred on this channel. This
					 * bit is cleared before every input
					 * operation. */
#define CHANNEL_STICKY_EOF	(1<<10)	/* EOF occurred on this channel
					 * because we saw the input
					 * eofChar. This bit prevents clearing
					 * of the EOF bit before every input
					 * operation. */
#define CHANNEL_BLOCKED		(1<<11)	/* EWOULDBLOCK or EAGAIN occurred on
					 * this channel. This bit is cleared
					 * before every input or output
					 * operation. */
#define INPUT_SAW_CR		(1<<12)	/* Channel is in CRLF eol input
					 * translation mode and the last byte
					 * seen was a "\r". */
#define CHANNEL_DEAD		(1<<13)	/* The channel has been closed by the
					 * exit handler (on exit) but not
					 * deallocated. When any IO operation
					 * sees this flag on a channel, it
					 * does not call driver level
					 * functions to avoid referring to
					 * deallocated data. */

#define CHANNEL_NEED_MORE_DATA	(1<<14)	/* The last input operation failed
					 * because there was not enough data
					 * to complete the operation. This
					 * flag is set when gets fails to get
					 * a complete line or when read fails
					 * to get a complete character. When
					 * set, file events will not be
					 * delivered for buffered data until
					 * the state of the channel
					 * changes. */
#define CHANNEL_ENCODING_ERROR	(1<<15)	/* set if channel
					 * encountered an encoding error */

#define CHANNEL_RAW_MODE	(1<<16)	/* When set, notes that the Raw API is
					 * being used. */

#define CHANNEL_LINEBUFFERED	(1<<17)	/* Output to the channel must be
					 * flushed after every newline. */
#define CHANNEL_UNBUFFERED	(1<<18)	/* Output to the channel must always
					 * be flushed immediately. */
#define CHANNEL_INCLOSE		(1<<19)	/* Channel is currently being closed.
					 * Its structures are still live and
					 * usable, but it may not be closed
					 * again from within the close
					 * handler. */
#define CHANNEL_CLOSEDWRITE	(1<<21)	/* Channel write side has been closed.
					 * No further Tcl-level write IO on
					 * the channel is allowed. */


/*
 * The length of time to wait between synthetic timer events. Must be zero or
 * bad things tend to happen.
 */

#define SYNTHETIC_EVENT_TIME	0

    newLoc = Tcl_Tell(chan);

    /*
     * TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result.
     */


    code  = TclChanCaughtErrorBypass(interp, chan);
    TclChannelRelease(chan);
    if (code) {
	return TCL_ERROR;
    }

			    unsigned char *buf, int bufLen, int transmit,
			    int preserve);

/*
 * Action codes to give to 'ExecuteCallback' (argument 'transmit'), telling
 * the procedure what to do with the result of the script it calls.
 */

#define TRANSMIT_DONT	0	/* No transfer to do. */
#define TRANSMIT_DOWN	1	/* Transfer to the underlying channel. */
#define TRANSMIT_SELF	2	/* Transfer into our channel. */
#define TRANSMIT_IBUF	3	/* Transfer to internal input buffer. */
#define TRANSMIT_NUM	4	/* Transfer number to 'maxRead'. */


/*
 * Codes for 'preserve' of 'ExecuteCallback'.
 */

#define P_PRESERVE	1
#define P_NO_PRESERVE	0


/*
 * Strings for the action codes delivered to the script implementing a
 * transformation. Argument 'op' of 'ExecuteCallback'.
 */

#define A_CREATE_WRITE	(UCHARP("create/write"))

    int mode;			/* Mask of R/W mode */
    int interest;		/* Mask of events the channel is interested
				 * in. */

    int dead;			/* Boolean signal that some operations
				 * should no longer be attempted. */

    Tcl_TimerToken readTimer;   /*
				   A token for the timer that is scheduled in
				   order to call Tcl_NotifyChannel when the
				   channel is readable
			        */
    Tcl_TimerToken writeTimer;  /*
				   A token for the timer that is scheduled in
				   order to call Tcl_NotifyChannel when the
				   channel is writable
			        */

    /*
     * Note regarding the usage of timers.
     *
     * Most channel implementations need a timer in the C level to ensure that
     * data in buffers is flushed out through the generation of fake file
     * events.

static int		TransformLimit(ReflectedTransform *rtPtr,
			    int *errorCodePtr, int *maxPtr);

/*
 * Operation codes for TransformFlush().
 */


#define FLUSH_WRITE	1
#define FLUSH_DISCARD	0


/*
 * Main methods to plug into the 'chan' ensemble'. ==================
 */

/*
 *----------------------------------------------------------------------

	    goto stop;
	}

	if (rtPtr->eofPending) {
	    goto stop;
	}


	/*
	 * The buffer is exhausted, but the caller wants even more. We now
	 * have to go to the underlying channel, get more bytes and then
	 * transform them for delivery. We may not get what we want (full EOF
	 * or temporarily out of data).
	 *
	 * Length (rtPtr->result) == 0, toRead > 0 here. Use 'buf'! as target

		}
	    } /* else: 'maxRead < 0' == Accept the current value of toRead */
	}

	if (toRead <= 0) {
	    goto stop;
	}


	readBytes = Tcl_ReadRaw(rtPtr->parent,
		(char *) Tcl_SetByteArrayLength(bufObj, toRead), toRead);
	if (readBytes < 0) {
	    if (Tcl_InputBlocked(rtPtr->parent) && (gotBytes > 0)) {

		/*

 * are the same for win/unix, and not in tclInt.h because they are and should
 * be used only here.
 */

MODULE_SCOPE const char *const		tclpFileAttrStrings[];
MODULE_SCOPE const TclFileAttrProcs	tclpFileAttrProcs[];


/*
 * These these functions are not static either because routines in the native
 * (win/unix) directories call them or they are actually implemented in those
 * directories. They should be called from outside Tcl's native filesystem
 * routines. If we ever built the native filesystem support into a separate
 * code library, this could actually be enforced.
 */

    }
    return ret;
}

/* Obsolete */
int
Tcl_Access(
    const char *path,		/* Pathname of file to access (in current CP).
				*/
    int mode)			/* Permission setting. */
{
    int ret;
    Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);

    Tcl_IncrRefCount(pathPtr);
    ret = Tcl_FSAccess(pathPtr,mode);

		    /*
		     * Deal with the root of the volume.
		     */

		    len--;
		}
		len++;		/* account for '/' in the mElt [Bug 1602539] */


		mElt = TclNewFSPathObj(pathPtr, mount + len, mlen - len);
		Tcl_ListObjAppendElement(NULL, resultPtr, mElt);
	    }
	    /*
	     * Not comparing mounts to mounts, so no need to increment gLength
	     */

				 * as "rw". */
    int permissions)		/* What modes to use if opening the file
				   involves creating it. */
{
    const Tcl_Filesystem *fsPtr;
    Tcl_Channel retVal = NULL;


    if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
	/*
	 * Return the correct error message.
	 */
	return NULL;
    }

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

int
Tcl_FSLoadFile(
    Tcl_Interp *interp,		/* Used for error reporting. */
    Tcl_Obj *pathPtr,		/* Pathname of the file containing the dynamic shared object.
				 */
    const char *sym1, const char *sym2,
				/* Names of two functions to find in the
				 * dynamic shared object. */
    Tcl_LibraryInitProc **proc1Ptr, Tcl_LibraryInitProc **proc2Ptr,
				/* Places to store pointers to the functions
				 * named by sym1 and sym2. */
    Tcl_LoadHandle *handlePtr,	/* A place to store the token for the loaded

     *
     * 2.   If the environment variable TCL_TEMPLOAD_NO_UNLINK is present and
     * set to true (an integer > 0)
     *
     * 3. TCL_TEMPLOAD_NO_UNLINK is not true (an integer > 0) and AUFS filesystem can be detected (using statfs, if available).
     *
     */


#ifdef hpux
    (void)shlibFile;
    return 1;
#else
    WCHAR *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK");

    if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) {
	/* not a valid pathname */
	Disclaim();
	return NULL;
    } else if (retVal != NULL) {
	/*
	 * Found the filesystem in the internal representation of pathPtr.
	*/
	Disclaim();
	return retVal;
    }

    /*
     * Call each of the "pathInFilesystem" functions in succession until the
     * corresponding filesystem is found.

 *		code unit that refers to the namespace has been freed (i.e.,
 *		when the namespace's refCount is 0), the namespace's storage
 *		will be freed.
 * NS_SUPPRESS_COMPILATION -
 *		Marks the commands in this namespace for not being compiled,
 *		forcing them to be looked up every time.
 */

#define NS_DYING	0x01
#define NS_DEAD		0x02
#define NS_TEARDOWN	0x04
#define NS_KILLED	0x04 /* Same as NS_TEARDOWN (Deprecated) */
#define NS_SUPPRESS_COMPILATION	0x08


/*
 * Flags passed to TclGetNamespaceForQualName:
 *
 * TCL_GLOBAL_ONLY		- (see tcl.h) Look only in the global ns.
 * TCL_NAMESPACE_ONLY		- (see tcl.h) Look only in the context ns.
 * TCL_CREATE_NS_IF_UNKNOWN	- Create unknown namespaces.
 * TCL_FIND_ONLY_NS		- The name sought is a namespace name.
 * TCL_FIND_IF_NOT_SIMPLE       - Retrieve last namespace even if the rest of
 *                                name is not simple name (contains ::).
 */

#define TCL_CREATE_NS_IF_UNKNOWN	0x800
#define TCL_FIND_ONLY_NS		0x1000
#define TCL_FIND_IF_NOT_SIMPLE		0x2000


/*
 * The client data for an ensemble command. This consists of the table of
 * commands that are actually exported by the namespace, and an epoch counter
 * that, combined with the exportLookupEpoch field of the namespace structure,
 * defines whether the table contains valid data or will need to be recomputed
 * next time the ensemble command is called.
 */

typedef struct EnsembleConfig {
    Namespace *nsPtr;		/* The namespace backing this ensemble up. */
    Tcl_Command token;		/* The token for the command that provides
				 * ensemble support for the namespace, or NULL
				 * if the command has been deleted (or never
				 * existed; the global namespace never has an
				 * ensemble command.) */
    Tcl_Size epoch;			/* The epoch at which this ensemble's table of
				 * exported commands is valid. */
    char **subcommandArrayPtr;	/* Array of ensemble subcommand names. At all
				 * consistent points, this will have the same
				 * number of entries as there are entries in
				 * the subcommandTable hash. */
    Tcl_HashTable subcommandTable;
				/* Hash table of ensemble subcommand names,

				 * results passed directly back to the caller
				 * (including the error code) unless the code
				 * is TCL_CONTINUE in which case the
				 * subcommand will be re-parsed by the ensemble
				 * core, presumably because the ensemble
				 * itself has been updated. */
    Tcl_Obj *parameterList;	/* List of ensemble parameter names. */
    Tcl_Size numParameters;		/* Cached number of parameters. This is either
				 * 0 (if the parameterList field is NULL) or
				 * the length of the list in the parameterList
				 * field. */
} EnsembleConfig;

/*
 * Various bits for the EnsembleConfig.flags field.
 */

#define ENSEMBLE_DEAD	0x1	/* Flag value to say that the ensemble is dead
				 * and on its way out. */
#define ENSEMBLE_COMPILE 0x4	/* Flag to enable bytecode compilation of an
				 * ensemble. */


/*
 *----------------------------------------------------------------
 * Data structures related to variables. These are used primarily in tclVar.c
 *----------------------------------------------------------------
 */

/*
 * The following structure defines a variable trace, which is used to invoke a
 * specific C procedure whenever certain operations are performed on a
 * variable.
 */

typedef struct VarTrace {
    Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given by
				 * flags are performed on variable. */
    void *clientData;	/* Argument to pass to proc. */
    int flags;			/* What events the trace procedure is
				 * interested in: OR-ed combination of
				 * TCL_TRACE_READS, TCL_TRACE_WRITES,
				 * TCL_TRACE_UNSETS and TCL_TRACE_ARRAY. */
    struct VarTrace *nextPtr;	/* Next in list of traces associated with a
				 * particular variable. */
} VarTrace;

/*
 * The following structure defines a command trace, which is used to invoke a
 * specific C procedure whenever certain operations are performed on a
 * command.
 */

typedef struct CommandTrace {
    Tcl_CommandTraceProc *traceProc;
				/* Procedure to call when operations given by
				 * flags are performed on command. */
    void *clientData;	/* Argument to pass to proc. */
    int flags;			/* What events the trace procedure is
				 * interested in: OR-ed combination of
				 * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
    struct CommandTrace *nextPtr;
				/* Next in list of traces associated with a
				 * particular command. */
    Tcl_Size refCount;		/* Used to ensure this structure is not

 *
 * IMPORTANT: skip the values 0x10, 0x20, 0x40, 0x800 corresponding to
 * TCL_TRACE_(READS/WRITES/UNSETS/ARRAY): makes code simpler in tclTrace.c
 *
 * Keep the flag values for VAR_ARGUMENT and VAR_TEMPORARY so that old values
 * in precompiled scripts keep working.
 */

/* Type of value (0 is scalar) */
#define VAR_ARRAY		0x1
#define VAR_LINK		0x2
#define VAR_CONSTANT		0x10000

/* Type of storage (0 is compiled local) */
#define VAR_IN_HASHTABLE	0x4
#define VAR_DEAD_HASH		0x8
#define VAR_ARRAY_ELEMENT	0x1000
#define VAR_NAMESPACE_VAR	0x80	/* KEEP OLD VALUE for Itcl */

#define VAR_ALL_HASH \
	(VAR_IN_HASHTABLE|VAR_DEAD_HASH|VAR_NAMESPACE_VAR|VAR_ARRAY_ELEMENT)

/* Trace and search state. */

#define VAR_TRACED_READ		0x10	/* TCL_TRACE_READS */
#define VAR_TRACED_WRITE	0x20	/* TCL_TRACE_WRITES */
#define VAR_TRACED_UNSET	0x40	/* TCL_TRACE_UNSETS */
#define VAR_TRACED_ARRAY	0x800	/* TCL_TRACE_ARRAY */
#define VAR_TRACE_ACTIVE	0x2000
#define VAR_SEARCH_ACTIVE	0x4000
#define VAR_ALL_TRACES \
	(VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_ARRAY|VAR_TRACED_UNSET)

/* Special handling on initialisation (only CompiledLocal). */
#define VAR_ARGUMENT		0x100	/* KEEP OLD VALUE! See tclProc.c */
#define VAR_TEMPORARY		0x200	/* KEEP OLD VALUE! See tclProc.c */
#define VAR_IS_ARGS		0x400
#define VAR_RESOLVED		0x8000


/*
 * Macros to ensure that various flag bits are set properly for variables.
 * The ANSI C "prototypes" for these macros are:
 *
 * MODULE_SCOPE void	TclSetVarScalar(Var *varPtr);
 * MODULE_SCOPE void	TclSetVarArray(Var *varPtr);

	(varPtr)->flags |= VAR_NAMESPACE_VAR;\
	if (TclIsVarInHash(varPtr)) {\
	    ((VarInHash *)(varPtr))->refCount++;\
	}\
    }

#define TclClearVarNamespaceVar(varPtr) \
    if (TclIsVarNamespaceVar(varPtr)) {\
	(varPtr)->flags &= ~VAR_NAMESPACE_VAR;\
	if (TclIsVarInHash(varPtr)) {\
	    ((VarInHash *)(varPtr))->refCount--;\
	}\
    }

/*
 * Macros to read various flag bits of variables.
 * The ANSI C "prototypes" for these macros are:
 *
 * MODULE_SCOPE int	TclIsVarScalar(Var *varPtr);

 */

typedef struct CompiledLocal {
    struct CompiledLocal *nextPtr;
				/* Next compiler-recognized local variable for
				 * this procedure, or NULL if this is the last
				 * local. */
    Tcl_Size nameLength;		/* The number of bytes in local variable's name.
				 * Among others used to speed up var lookups. */
    Tcl_Size frameIndex;		/* Index in the array of compiler-assigned
				 * variables in the procedure call frame. */
#if TCL_MAJOR_VERSION < 9
    int flags;
#endif
    Tcl_Obj *defValuePtr;	/* Pointer to the default value of an
				 * argument, if any. NULL if not an argument
				 * or, if an argument, no default value. */
    Tcl_ResolvedVarInfo *resolveInfo;
				/* Customized variable resolution info
				 * supplied by the Tcl_ResolveCompiledVarProc
				 * associated with a namespace. Each variable
				 * is marked by a unique tag during
				 * compilation, and that same tag is used to
				 * find the variable at runtime. */
#if TCL_MAJOR_VERSION > 8
    int flags;			/* Flag bits for the local variable. Same as
				 * the flags for the Var structure above,
				 * although only VAR_ARGUMENT, VAR_TEMPORARY,
				 * and VAR_RESOLVED make sense. */
#endif
    char name[TCLFLEXARRAY];		/* Name of the local variable starts here. If
				 * the name is NULL, this will just be '\0'.
				 * The actual size of this field will be large
				 * enough to hold the name. MUST BE THE LAST
				 * FIELD IN THE STRUCTURE! */
} CompiledLocal;

/*

 * TCL_TRACE_ENTER_EXEC		- triggers enter/enterstep traces.
 * 				- passed to Tcl_CreateObjTrace to set up
 *				  "enterstep" traces.
 * TCL_TRACE_LEAVE_EXEC		- triggers leave/leavestep traces.
 * 				- passed to Tcl_CreateObjTrace to set up
 *				  "leavestep" traces.
 */

#define TCL_TRACE_ENTER_EXEC	1
#define TCL_TRACE_LEAVE_EXEC	2


#if TCL_MAJOR_VERSION > 8
#define TclObjTypeHasProc(objPtr, proc) (((objPtr)->typePtr \
	&& ((offsetof(Tcl_ObjType, proc) < offsetof(Tcl_ObjType, version)) \
	|| (offsetof(Tcl_ObjType, proc) < (objPtr)->typePtr->version))) ? \
	((objPtr)->typePtr)->proc : NULL)

MODULE_SCOPE Tcl_Size TclLengthOne(Tcl_Obj *);


/*
 * Abstract List
 *
 *  This structure provides the functions used in List operations to emulate a
 *  List for AbstractList types.
 */


static inline Tcl_Size
TclObjTypeLength(Tcl_Obj *objPtr)

{
    Tcl_ObjTypeLengthProc *proc = TclObjTypeHasProc(objPtr, lengthProc);
    return proc(objPtr);
}

static inline int
TclObjTypeIndex(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    Tcl_Size index,
    Tcl_Obj **elemObjPtr)
{
    Tcl_ObjTypeIndexProc *proc = TclObjTypeHasProc(objPtr, indexProc);
    return proc(interp, objPtr, index, elemObjPtr);
}

static inline int
TclObjTypeSlice(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    Tcl_Size fromIdx,
    Tcl_Size toIdx,
    Tcl_Obj **newObjPtr)
{
    Tcl_ObjTypeSliceProc *proc = TclObjTypeHasProc(objPtr, sliceProc);
    return proc(interp, objPtr, fromIdx, toIdx, newObjPtr);
}

static inline int
TclObjTypeReverse(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    Tcl_Obj **newObjPtr)
{
    Tcl_ObjTypeReverseProc *proc = TclObjTypeHasProc(objPtr, reverseProc);
    return proc(interp, objPtr, newObjPtr);
}

static inline int
TclObjTypeGetElements(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    Tcl_Size *objCPtr,
    Tcl_Obj ***objVPtr)
{
    Tcl_ObjTypeGetElements *proc = TclObjTypeHasProc(objPtr, getElementsProc);
    return proc(interp, objPtr, objCPtr, objVPtr);
}

static inline Tcl_Obj*
TclObjTypeSetElement(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    Tcl_Size indexCount,
    Tcl_Obj *const indexArray[],
    Tcl_Obj *valueObj)
{
    Tcl_ObjTypeSetElement *proc = TclObjTypeHasProc(objPtr, setElementProc);
    return proc(interp, objPtr, indexCount, indexArray, valueObj);
}

static inline int
TclObjTypeReplace(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    Tcl_Size first,
    Tcl_Size numToDelete,
    Tcl_Size numToInsert,
    Tcl_Obj *const insertObjs[])
{
    Tcl_ObjTypeReplaceProc *proc = TclObjTypeHasProc(objPtr, replaceProc);
    return proc(interp, objPtr, first, numToDelete, numToInsert, insertObjs);
}

static inline int
TclObjTypeInOperator(Tcl_Interp *interp, struct Tcl_Obj *valueObj,


		     struct Tcl_Obj *listObj, int *boolResult)

{
    Tcl_ObjTypeInOperatorProc *proc = TclObjTypeHasProc(listObj, inOperProc);
    return proc(interp, valueObj, listObj, boolResult);
}
#endif /* TCL_MAJOR_VERSION > 8 */


/*
 * The structure below defines an entry in the assocData hash table which is
 * associated with an interpreter. The entry contains a pointer to a function
 * to call when the interpreter is deleted, and a pointer to a user-defined
 * piece of data.
 */

typedef struct AssocData {
    Tcl_InterpDeleteProc *proc;	/* Proc to call when deleting. */
    void *clientData;	/* Value to pass to proc. */
} AssocData;

/*
 * The structure below defines a call frame. A call frame defines a naming
 * context for a procedure call: its local naming scope (for local variables)
 * and its global naming scope (a namespace, perhaps the global :: namespace).
 * A call frame can also define the naming context for a namespace eval or

    int isProcCallFrame;	/* If 0, the frame was pushed to execute a
				 * namespace command and var references are
				 * treated as references to namespace vars;
				 * varTablePtr and compiledLocals are ignored.
				 * If FRAME_IS_PROC is set, the frame was
				 * pushed to execute a Tcl procedure and may
				 * have local vars. */
    Tcl_Size objc;			/* This and objv below describe the arguments
				 * for this procedure call. */
    Tcl_Obj *const *objv;	/* Array of argument objects. */
    struct CallFrame *callerPtr;
				/* Value of interp->framePtr when this
				 * procedure was invoked (i.e. next higher in
				 * stack of all active procedures). */
    struct CallFrame *callerVarPtr;
				/* Value of interp->varFramePtr when this
				 * procedure was invoked (i.e. determines
				 * variable scoping within caller). Same as
				 * callerPtr unless an "uplevel" command or
				 * something equivalent was active in the
				 * caller). */
    Tcl_Size level;			/* Level of this procedure, for "uplevel"
				 * purposes (i.e. corresponds to nesting of
				 * callerVarPtr's, not callerPtr's). 1 for
				 * outermost procedure, 0 for top-level. */
    Proc *procPtr;		/* Points to the structure defining the called
				 * procedure. Used to get information such as
				 * the number of compiled local variables
				 * (local variables assigned entries ["slots"]

				 * sets it, and it should only ever be set by
				 * the code that is pushing the frame. In that
				 * case, the code that sets it should also
				 * have some means of discovering what the
				 * meaning of the value is, which we do not
				 * specify. */
    LocalCache *localCachePtr;
    Tcl_Obj    *tailcallPtr;
				/* NULL if no tailcall is scheduled */
} CallFrame;


#define FRAME_IS_PROC	0x1
#define FRAME_IS_LAMBDA 0x2
#define FRAME_IS_METHOD	0x4	/* The frame is a method body, and the frame's
				 * clientData field contains a CallContext
				 * reference. Part of TIP#257. */
#define FRAME_IS_OO_DEFINE 0x8	/* The frame is part of the inside workings of
				 * the [oo::define] command; the clientData
				 * field contains an Object reference that has
				 * been confirmed to refer to a class. Part of
				 * TIP#257. */
#define FRAME_IS_PRIVATE_DEFINE 0x10
				/* Marks this frame as being used for private
				 * declarations with [oo::define]. Usually
				 * OR'd with FRAME_IS_OO_DEFINE. TIP#500. */


/*
 * TIP #280
 * The structure below defines a command frame. A command frame provides
 * location information for all commands executing a tcl script (source, eval,
 * uplevel, procedure bodies, ...). The runtime structure essentially contains
 * the stack trace as it would be if the currently executing command were to

	struct {
	    const void *codePtr;/* Byte code currently executed... */
	    const char *pc;	/* ... and instruction pointer. */
	} tebc;
    } data;
    Tcl_Obj *cmdObj;
    const char *cmd;		/* The executed command, if possible... */
    Tcl_Size len;			/* ... and its length. */
    const struct CFWordBC *litarg;
				/* Link to set of literal arguments which have
				 * ben pushed on the lineLABCPtr stack by
				 * TclArgumentBCEnter(). These will be removed
				 * by TclArgumentBCRelease. */
} CmdFrame;

typedef struct CFWord {
    CmdFrame *framePtr;		/* CmdFrame to access. */
    Tcl_Size word;			/* Index of the word in the command. */
    Tcl_Size refCount;		/* Number of times the word is on the
				 * stack. */
} CFWord;

typedef struct CFWordBC {
    CmdFrame *framePtr;		/* CmdFrame to access. */
    Tcl_Size pc;			/* Instruction pointer of a command in
				 * ExtCmdLoc.loc[.] */
    Tcl_Size word;			/* Index of word in
				 * ExtCmdLoc.loc[cmd]->line[.] */
    struct CFWordBC *prevPtr;	/* Previous entry in stack for same Tcl_Obj. */
    struct CFWordBC *nextPtr;	/* Next entry for same command call. See
				 * CmdFrame litarg field for the list start. */
    Tcl_Obj *obj;		/* Back reference to hash table key */
} CFWordBC;

 * released by the function TclFreeObj(), in the file "tclObj.c", and also by
 * the function TclThreadFinalizeObjects(), in the same file.
 */

#define CLL_END		(-1)

typedef struct ContLineLoc {
    Tcl_Size num;			/* Number of entries in loc, not counting the
				 * final -1 marker entry. */
    Tcl_Size loc[TCLFLEXARRAY];/* Table of locations, as character offsets.
				 * The table is allocated as part of the
				 * structure, extending behind the nominal end
				 * of the structure. An entry containing the
				 * value -1 is put after the last location, as
				 * end-marker/sentinel. */

 *			    sourced file.
 * TCL_LOCATION_PROC	  : Frame is for bytecode of a procedure.
 *
 * A TCL_LOCATION_BC type in a frame can be overridden by _SOURCE and _PROC
 * types, per the context of the byte code in execution.
 */


#define TCL_LOCATION_EVAL	(0) /* Location in a dynamic eval script. */
#define TCL_LOCATION_BC		(2) /* Location in byte code. */
#define TCL_LOCATION_PREBC	(3) /* Location in precompiled byte code, no
				     * location. */
#define TCL_LOCATION_SOURCE	(4) /* Location in a file. */
#define TCL_LOCATION_PROC	(5) /* Location in a dynamic proc. */
#define TCL_LOCATION_LAST	(6) /* Number of values in the enum. */


/*
 * Structure passed to describe procedure-like "procedures" that are not
 * procedures (e.g. a lambda) so that their details can be reported correctly
 * by [info frame]. Contains a sub-structure for each extra field.
 */

typedef Tcl_Obj * (GetFrameInfoValueProc)(void *clientData);

typedef struct {
    const char *name;		/* Name of this field. */
    GetFrameInfoValueProc *proc;	/* Function to generate a Tcl_Obj* from the
				 * clientData, or just use the clientData
				 * directly (after casting) if NULL. */
    void *clientData;	/* Context for above function, or Tcl_Obj* if
				 * proc field is NULL. */
} ExtraFrameInfoField;

typedef struct {
    Tcl_Size length;			/* Length of array. */
    ExtraFrameInfoField fields[2];
				/* Really as long as necessary, but this is
				 * long enough for nearly anything. */
} ExtraFrameInfo;

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

 * There is one ExecEnv structure per Tcl interpreter. It holds the evaluation
 * stack that holds command operands and results. The stack grows towards
 * increasing addresses. The member stackPtr points to the stackItems of the
 * currently active execution stack.
 */

typedef struct CorContext {
    struct CallFrame *framePtr;
    struct CallFrame *varFramePtr;
    struct CmdFrame *cmdFramePtr;  /* See Interp.cmdFramePtr */
    Tcl_HashTable *lineLABCPtr;    /* See Interp.lineLABCPtr */
} CorContext;

typedef struct CoroutineData {
    struct Command *cmdPtr;	/* The command handle for the coroutine. */
    struct ExecEnv *eePtr;	/* The special execution environment (stacks,
				 * etc.) for the coroutine. */
    struct ExecEnv *callerEEPtr;/* The execution environment for the caller of
				 * the coroutine, which might be the
				 * interpreter global environment or another
				 * coroutine. */
    CorContext caller;
    CorContext running;
    Tcl_HashTable *lineLABCPtr;    /* See Interp.lineLABCPtr */
    void *stackLevel;
    Tcl_Size auxNumLevels;		/* While the coroutine is running the
				 * numLevels of the create/resume command is
				 * stored here; for suspended coroutines it
				 * holds the nesting numLevels at yield. */
    Tcl_Size nargs;                  /* Number of args required for resuming this
				 * coroutine; COROUTINE_ARGUMENTS_SINGLE_OPTIONAL means "0 or 1"
				 * (default), COROUTINE_ARGUMENTS_ARBITRARY means "any" */
    Tcl_Obj *yieldPtr;		/* The command to yield to.  Stored here in
				 * order to reset splice point in
				 * TclNRCoroutineActivateCallback if the
				 * coroutine is busy.
				*/
} CoroutineData;

typedef struct ExecEnv {
    ExecStack *execStackPtr;	/* Points to the first item in the evaluation
				 * stack on the heap. */
    Tcl_Obj *constants[2];	/* Pointers to constant "0" and "1" objs. */
    struct Tcl_Interp *interp;
    struct NRE_callback *callbackPtr;
				/* Top callback in NRE's stack. */
    struct CoroutineData *corPtr;
    int rewind;
} ExecEnv;

#define COR_IS_SUSPENDED(corPtr) \
    ((corPtr)->stackLevel == NULL)

/*

typedef struct LiteralTable {
    LiteralEntry **buckets;	/* Pointer to bucket array. Each element
				 * points to first entry in bucket's hash
				 * chain, or NULL. */
    LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
				/* Bucket array used for small tables to avoid
				 * mallocs and frees. */
    TCL_HASH_TYPE numBuckets; /* Total number of buckets allocated at
				 * **buckets. */
    TCL_HASH_TYPE numEntries; /* Total number of entries present in
				 * table. */
    TCL_HASH_TYPE rebuildSize; /* Enlarge table when numEntries gets to be
				 * this large. */
    TCL_HASH_TYPE mask;		/* Mask value used in hashing function. */
} LiteralTable;

/*
 * The following structure defines for each Tcl interpreter various
 * statistics-related information about the bytecode compiler and

 */

typedef struct {
    const char *name;		/* The name of the subcommand. */
    Tcl_ObjCmdProc *proc;	/* The implementation of the subcommand. */
    CompileProc *compileProc;	/* The compiler for the subcommand. */
    Tcl_ObjCmdProc *nreProc;	/* NRE implementation of this command. */
    void *clientData;	/* Any clientData to give the command. */
    int unsafe;			/* Whether this command is to be hidden by
				 * default in a safe interpreter. */
} EnsembleImplMap;

/*
 *----------------------------------------------------------------
 * Data structures related to commands.

				 * that point to this command when it is
				 * renamed, deleted, hidden, or exposed. */
    CompileProc *compileProc;	/* Procedure called to compile command. NULL
				 * if no compile proc exists for command. */
    Tcl_ObjCmdProc *objProc;	/* Object-based command procedure. */
    void *objClientData;	/* Arbitrary value passed to object proc. */
    Tcl_CmdProc *proc;		/* String-based command procedure. */
    void *clientData;	/* Arbitrary value passed to string proc. */
    Tcl_CmdDeleteProc *deleteProc;
				/* Procedure invoked when deleting command to,
				 * e.g., free all client data. */
    void *deleteData;	/* Arbitrary value passed to deleteProc. */
    int flags;			/* Miscellaneous bits of information about
				 * command. See below for definitions. */
    ImportRef *importRefPtr;	/* List of each imported Command created in
				 * another namespace when this command is
				 * imported. These imported commands redirect
				 * invocations back to this command. The list
				 * is used to remove all those imported
				 * commands when deleting this "real"
				 * command. */
    CommandTrace *tracePtr;	/* First in list of all traces set for this
				 * command. */
    Tcl_ObjCmdProc *nreProc;	/* NRE implementation of this command. */
} Command;

/*
 * Flag bits for commands.
 *

 * CMD_DYING -			If 1 the command is in the process of
 *				being deleted (its deleteProc is currently
 *				executing). Other attempts to delete the
 *				command should be ignored.
 * CMD_TRACE_ACTIVE -		If 1 the trace processing is currently
 *				underway for a rename/delete change. See the

 *				two flags below for which is currently being
 *				processed.
 * CMD_HAS_EXEC_TRACES -	If 1 means that this command has at least one
 *				execution trace (as opposed to simple
 *				delete/rename traces) in its tracePtr list.

 * CMD_COMPILES_EXPANDED -	If 1 this command has a compiler that
 *				can handle expansion (provided it is not the
 *				first word).
 * TCL_TRACE_RENAME -		A rename trace is in progress. Further
 *				recursive renames will not be traced.
 * TCL_TRACE_DELETE -		A delete trace is in progress. Further
 *				recursive deletes will not be traced.
 * (these last two flags are defined in tcl.h)
 */

#define CMD_DYING		    0x01
#define CMD_TRACE_ACTIVE	    0x02
#define CMD_HAS_EXEC_TRACES	    0x04
#define CMD_COMPILES_EXPANDED	    0x08
#define CMD_REDEF_IN_PROGRESS	    0x10
#define CMD_VIA_RESOLVER	    0x20
#define CMD_DEAD                    0x40


/*
 *----------------------------------------------------------------
 * Data structures related to name resolution procedures.
 *----------------------------------------------------------------
 */

				 * interp is deleted. */

    Namespace *globalNsPtr;	/* The interpreter's global namespace. */
    Tcl_HashTable *hiddenCmdTablePtr;
				/* Hash table used by tclBasic.c to keep track
				 * of hidden commands on a per-interp
				 * basis. */
    void *interpInfo;	/* Information used by tclInterp.c to keep
				 * track of parent/child interps on a
				 * per-interp basis. */
#if TCL_MAJOR_VERSION > 8
    void (*optimizer)(void *envPtr);
#else
    union {
	void (*optimizer)(void *envPtr);

    int unused1;		/* No longer used (was termOffset) */
#endif
    LiteralTable literalTable;	/* Contains LiteralEntry's describing all Tcl
				 * objects holding literals of scripts
				 * compiled by the interpreter. Indexed by the
				 * string representations of literals. Used to
				 * avoid creating duplicate objects. */
    Tcl_Size compileEpoch;		/* Holds the current "compilation epoch" for
				 * this interpreter. This is incremented to
				 * invalidate existing ByteCodes when, e.g., a
				 * command with a compile procedure is
				 * redefined. */
    Proc *compiledProcPtr;	/* If a procedure is being compiled, a pointer
				 * to its Proc structure; otherwise, this is
				 * NULL. Set by ObjInterpProc in tclProc.c and

    ActiveCommandTrace *activeCmdTracePtr;
				/* First in list of active command traces for
				 * interp, or NULL if no active traces. */
    ActiveInterpTrace *activeInterpTracePtr;
				/* First in list of active traces for interp,
				 * or NULL if no active traces. */

    Tcl_Size tracesForbiddingInline;	/* Count of traces (in the list headed by

				 * tracePtr) that forbid inline bytecode
				 * compilation. */

    /*
     * Fields used to manage extensible return options (TIP 90).
     */

	int active;		/* Flag values defining which limits have been
				 * set. */
	int granularityTicker;	/* Counter used to determine how often to
				 * check the limits. */
	int exceeded;		/* Which limits have been exceeded, described
				 * as flag values the same as the 'active'
				 * field. */

	Tcl_Size cmdCount;		/* Limit for how many commands to execute in
				 * the interpreter. */
	LimitHandler *cmdHandlers;
				/* Handlers to execute when the limit is
				 * reached. */
	int cmdGranularity;	/* Mod factor used to determine how often to
				 * evaluate the limit check. */

	Tcl_Time time;		/* Time limit for execution within the
				 * interpreter. */
	LimitHandler *timeHandlers;
				/* Handlers to execute when the limit is
				 * reached. */
	int timeGranularity;	/* Mod factor used to determine how often to
				 * evaluate the limit check. */

    struct {
	Tcl_Obj *const *sourceObjs;
				/* What arguments were actually input into the
				 * *root* ensemble command? (Nested ensembles
				 * don't rewrite this.) NULL if we're not
				 * processing an ensemble. */
	Tcl_Size numRemovedObjs;	/* How many arguments have been stripped off
				 * because of ensemble processing. */
	Tcl_Size numInsertedObjs;	/* How many of the current arguments were

				 * inserted by an ensemble. */
    } ensembleRewrite;

    /*
     * TIP #219: Global info for the I/O system.
     */

    ContLineLoc *scriptCLLocPtr;/* This table points to the location data for
				 * invisible continuation lines in the script,
				 * if any. This pointer is set by the function
				 * TclEvalObjEx() in file "tclBasic.c", and
				 * used by function ...() in the same file.
				 * It does for the eval/direct path of script
				 * execution what CompileEnv.clLoc does for
				 * the bytecode compiler.
				 */
    /*
     * TIP #268. The currently active selection mode, i.e. the package require
     * preferences.
     */

    int packagePrefer;		/* Current package selection mode. */

    Tcl_Obj *asyncCancelMsg;	/* Error message set by async cancel handler
				 * for the propagation of arbitrary Tcl
				 * errors. This information, if present
				 * (asyncCancelMsg not NULL), takes precedence
				 * over the default error messages returned by
				 * a script cancellation operation. */

	/*
	 * TIP #348 IMPLEMENTATION  -  Substituted error stack
	 */

    Tcl_Obj *errorStack;	/* [info errorstack] value (as a Tcl_Obj). */
    Tcl_Obj *upLiteral;		/* "UP" literal for [info errorstack] */
    Tcl_Obj *callLiteral;	/* "CALL" literal for [info errorstack] */
    Tcl_Obj *innerLiteral;	/* "INNER" literal for [info errorstack] */
    Tcl_Obj *innerContext;	/* cached list for fast reallocation */
    int resetErrorStack;        /* controls cleaning up of ::errorStack */

    }						\
    if ((a)->nextPtr != NULL) {			\
	(a)->nextPtr->prevPtr = (a)->prevPtr;	\
    }

/*
 * EvalFlag bits for Interp structures:
 *


 * TCL_ALLOW_EXCEPTIONS	1 means it's OK for the script to terminate with a
 *			code other than TCL_OK or TCL_ERROR; 0 means codes

 *			other than these should be turned into errors.
 */

#define TCL_ALLOW_EXCEPTIONS		0x04
#define TCL_EVAL_FILE			0x02
#define TCL_EVAL_SOURCE_IN_FRAME	0x10
#define TCL_EVAL_NORESOLVE		0x20
#define TCL_EVAL_DISCARD_RESULT		0x40


/*
 * Flag bits for Interp structures:
 *
 * DELETED:		Non-zero means the interpreter has been deleted:
 *			don't process any more commands for it, and destroy
 *			the structure as soon as all nested invocations of

 *			the evaluation stack for the interp to be fully
 *			unwound.
 *
 * WARNING: For the sake of some extensions that have made use of former
 * internal values, do not re-use the flag values 2 (formerly ERR_IN_PROGRESS)
 * or 8 (formerly ERROR_CODE_SET).
 */

#define DELETED				     1
#define ERR_ALREADY_LOGGED		     4
#define INTERP_DEBUG_FRAME		  0x10
#define DONT_COMPILE_CMDS_INLINE	  0x20
#define RAND_SEED_INITIALIZED		  0x40
#define SAFE_INTERP			  0x80
#define INTERP_TRACE_IN_PROGRESS	 0x200
#define INTERP_ALTERNATE_WRONG_ARGS	 0x400
#define ERR_LEGACY_COPY			 0x800
#define CANCELED			0x1000


/*
 * Maximum number of levels of nesting permitted in Tcl commands (used to
 * catch infinite recursion).
 */

#define MAX_NESTING_DEPTH	1000

 *				an effect if invoking an exposed command,
 *				i.e. if TCL_INVOKE_HIDDEN is not also set.
 * TCL_INVOKE_NO_TRACEBACK	Does not record traceback information if the
 *				invoked command returns an error. Used if the
 *				caller plans on recording its own traceback
 *				information.
 */

#define	TCL_INVOKE_HIDDEN	(1<<0)
#define TCL_INVOKE_NO_UNKNOWN	(1<<1)
#define TCL_INVOKE_NO_TRACEBACK	(1<<2)


/*
 * ListStore --
 *
 * A Tcl list's internal representation is defined through three structures.
 *
 * A ListStore struct is a structure that includes a variable size array that

 * define the content of the list. The ListSpan specifies the range of slots
 * within the ListStore that hold elements for this list. The ListSpan is
 * optional in which case the list includes all the "in-use" slots of the
 * ListStore.
 *
 */
typedef struct ListStore {
    Tcl_Size firstUsed;    /* Index of first slot in use within slots[] */
    Tcl_Size numUsed;      /* Number of slots in use (starting firstUsed) */
    Tcl_Size numAllocated; /* Total number of slots[] array slots. */
    size_t refCount;           /* Number of references to this instance */
    int flags;              /* LISTSTORE_* flags */
    Tcl_Obj *slots[TCLFLEXARRAY];      /* Variable size array. Grown as needed */
} ListStore;


#define LISTSTORE_CANONICAL 0x1 /* All Tcl_Obj's referencing this
                                   store have their string representation
                                   derived from the list representation */


/* Max number of elements that can be contained in a list */
#define LIST_MAX                                               \
    ((Tcl_Size)(((size_t)TCL_SIZE_MAX - offsetof(ListStore, slots)) \
		   / sizeof(Tcl_Obj *)))

/* Memory size needed for a ListStore to hold numSlots_ elements */
#define LIST_SIZE(numSlots_) \
	((Tcl_Size)(offsetof(ListStore, slots) + ((numSlots_) * sizeof(Tcl_Obj *))))

/*
 * ListSpan --
 * See comments above for ListStore
 */
typedef struct ListSpan {
    Tcl_Size spanStart;    /* Starting index of the span */
    Tcl_Size spanLength;   /* Number of elements in the span */
    size_t refCount;     /* Count of references to this span record */
} ListSpan;

#ifndef LIST_SPAN_THRESHOLD /* May be set on build line */
#define LIST_SPAN_THRESHOLD 101
#endif

/*
 * ListRep --
 * See comments above for ListStore
 */
typedef struct ListRep {
    ListStore *storePtr;/* element array shared amongst different lists */

    ListSpan *spanPtr;  /* If not NULL, the span holds the range of slots
                           within *storePtr that contain this list elements. */

} ListRep;

/*
 * Macros used to get access list internal representations.
 *
 * Naming conventions:
 * ListRep* - expect a pointer to a valid ListRep
 * ListObj* - expect a pointer to a Tcl_Obj whose internal type is known to
 *            be a list (tclListType). Will crash otherwise.
 * TclListObj* - expect a pointer to a Tcl_Obj whose internal type may or may not
 *            be tclListType. These will convert as needed and return error if
 *            conversion not possible.
 */

/* Returns the starting slot for this listRep in the contained ListStore */
#define ListRepStart(listRepPtr_)                               \
    ((listRepPtr_)->spanPtr ? (listRepPtr_)->spanPtr->spanStart \
			    : (listRepPtr_)->storePtr->firstUsed)

/* Returns the number of elements in this listRep */
#define ListRepLength(listRepPtr_)                               \
    ((listRepPtr_)->spanPtr ? (listRepPtr_)->spanPtr->spanLength \
			    : (listRepPtr_)->storePtr->numUsed)

/* Returns a pointer to the first slot containing this ListRep elements */
#define ListRepElementsBase(listRepPtr_) \
    (&(listRepPtr_)->storePtr->slots[ListRepStart(listRepPtr_)])

    ((ListStore *)((listObj_)->internalRep.twoPtrValue.ptr1))

/* Returns a pointer to the ListSpan component */
#define ListObjSpanPtr(listObj_) \
    ((ListSpan *)((listObj_)->internalRep.twoPtrValue.ptr2))

/* Returns the ListRep internal representaton in a Tcl_Obj */
#define ListObjGetRep(listObj_, listRepPtr_)                 \
    do {                                                     \
	(listRepPtr_)->storePtr = ListObjStorePtr(listObj_); \
	(listRepPtr_)->spanPtr = ListObjSpanPtr(listObj_);   \
    } while (0)

/* Returns the length of the list */
#define ListObjLength(listObj_, len_)                                         \
    ((len_) = ListObjSpanPtr(listObj_) ? ListObjSpanPtr(listObj_)->spanLength \
				       : ListObjStorePtr(listObj_)->numUsed)

/* Returns the starting slot index of this list's elements in the ListStore */
#define ListObjStart(listObj_)                                      \
    (ListObjSpanPtr(listObj_) ? ListObjSpanPtr(listObj_)->spanStart \
			      : ListObjStorePtr(listObj_)->firstUsed)

/* Stores the element count and base address of this list's elements */
#define ListObjGetElements(listObj_, objc_, objv_) \
    (((objv_) = &ListObjStorePtr(listObj_)->slots[ListObjStart(listObj_)]), \
     (ListObjLength(listObj_, (objc_))))


/*
 * Returns 1/0 whether the internal representation (not the Tcl_Obj itself)
 * is shared.  Note by intent this only checks for sharing of ListStore,
 * not spans.
 */
#define ListObjRepIsShared(listObj_) (ListObjStorePtr(listObj_)->refCount > 1)


/*
 * Certain commands like concat are optimized if an existing string
 * representation of a list object is known to be in canonical format (i.e.
 * generated from the list representation). There are three conditions when
 * this will be the case:
 * (1) No string representation exists which means it will obviously have
 * to be generated from the list representation when needed
 * (2) The ListStore flags is marked canonical. This is done at the time
 * the string representation is generated from the list under certain
 * conditions (see comments in UpdateStringOfList).
 * (3) The list representation does not have a span component. This is
 * because list Tcl_Obj's with spans are always created from existing lists
 * and never from strings (see SetListFromAny) and thus their string
 * representation will always be canonical.
 */
#define ListObjIsCanonical(listObj_)                             \
    (((listObj_)->bytes == NULL)                                 \
     || (ListObjStorePtr(listObj_)->flags & LISTSTORE_CANONICAL) \
     || ListObjSpanPtr(listObj_) != NULL)

/*
 * Converts the Tcl_Obj to a list if it isn't one and stores the element
 * count and base address of this list's elements in objcPtr_ and objvPtr_.
 * Return TCL_OK on success or TCL_ERROR if the Tcl_Obj cannot be
 * converted to a list.
 */
#define TclListObjGetElements(interp_, listObj_, objcPtr_, objvPtr_)    \
    ((TclHasInternalRep((listObj_), &tclListType))                              \
	 ? ((ListObjGetElements((listObj_), *(objcPtr_), *(objvPtr_))), \
	    TCL_OK)                                                     \
	 : Tcl_ListObjGetElements(                                      \
	     (interp_), (listObj_), (objcPtr_), (objvPtr_)))

/*
 * Converts the Tcl_Obj to a list if it isn't one and stores the element
 * count in lenPtr_.  Returns TCL_OK on success or TCL_ERROR if the
 * Tcl_Obj cannot be converted to a list.
 */
#define TclListObjLength(interp_, listObj_, lenPtr_)         \
    ((TclHasInternalRep((listObj_), &tclListType))                   \
	 ? ((ListObjLength((listObj_), *(lenPtr_))), TCL_OK) \
	 : Tcl_ListObjLength((interp_), (listObj_), (lenPtr_)))

#define TclListObjIsCanonical(listObj_) \
    ((TclHasInternalRep((listObj_), &tclListType)) ? ListObjIsCanonical((listObj_)) : 0)

/*
 * Modes for collecting (or not) in the implementations of TclNRForeachCmd,
 * TclNRLmapCmd and their compilations.
 */

#define TCL_EACH_KEEP_NONE  0	/* Discard iteration result like [foreach] */
#define TCL_EACH_COLLECT    1	/* Collect iteration result like [lmap] */


/*
 * Macros providing a faster path to booleans and integers:
 * Tcl_GetBooleanFromObj, Tcl_GetLongFromObj, Tcl_GetIntFromObj
 * and Tcl_GetIntForIndex.
 *
 * WARNING: these macros eval their args more than once.
 */

#if TCL_MAJOR_VERSION > 8
#define TclGetBooleanFromObj(interp, objPtr, intPtr) \
    ((TclHasInternalRep((objPtr), &tclIntType) \
	    || TclHasInternalRep((objPtr), &tclBooleanType)) \
	? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK)	\
	: Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr)))
#else
#define TclGetBooleanFromObj(interp, objPtr, intPtr) \
    ((TclHasInternalRep((objPtr), &tclIntType))			\
	? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK)	\
	: (TclHasInternalRep((objPtr), &tclBooleanType))			\
	? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK)	\
	: Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr)))
#endif

#ifdef TCL_WIDE_INT_IS_LONG
#define TclGetLongFromObj(interp, objPtr, longPtr) \
    ((TclHasInternalRep((objPtr), &tclIntType))	\
	    ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
	    : Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
#else
#define TclGetLongFromObj(interp, objPtr, longPtr) \
    ((TclHasInternalRep((objPtr), &tclIntType) \
	    && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(LONG_MIN) \
	    && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(LONG_MAX)) \
	    ? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \
	    : Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
#endif

#define TclGetIntFromObj(interp, objPtr, intPtr) \
    ((TclHasInternalRep((objPtr), &tclIntType) \
	    && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \
	    && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \
	    ? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
	    : Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
    (((TclHasInternalRep((objPtr), &tclIntType)) && ((objPtr)->internalRep.wideValue >= 0) \
	    && ((objPtr)->internalRep.wideValue <= endValue)) \
	    ? ((*(idxPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
	    : Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))

/*
 * Macro used to save a function call for common uses of
 * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is:
 *
 * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
 *			Tcl_WideInt *wideIntPtr);
 */

#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
    ((TclHasInternalRep((objPtr), &tclIntType))					\
	? (*(wideIntPtr) =						\
		((objPtr)->internalRep.wideValue), TCL_OK) :		\
	Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))

/*
 * Flag values for TclTraceDictPath().
 *

 * lookup failure should therefore not be an error. If (and only if) this flag
 * is set, TclTraceDictPath() will return the special value
 * DICT_PATH_NON_EXISTENT if the path is not traceable.
 *
 * DICT_PATH_CREATE (which also requires the DICT_PATH_UPDATE bit to be set)
 * indicates that we are to create non-existent dictionaries on the path.
 */

#define DICT_PATH_READ		0
#define DICT_PATH_UPDATE	1
#define DICT_PATH_EXISTS	2
#define DICT_PATH_CREATE	5


#define DICT_PATH_NON_EXISTENT	((Tcl_Obj *) (void *) 1)

/*
 *----------------------------------------------------------------
 * Data structures related to the filesystem internals
 *----------------------------------------------------------------

 * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of
 * the value, and the gobal value is kept as a counted string, with epoch and
 * mutex control. Each ProcessGlobalValue struct should be a static variable in
 * some file.
 */

typedef struct ProcessGlobalValue {
    Tcl_Size epoch;			/* Epoch counter to detect changes in the
				 * global value. */
    TCL_HASH_TYPE numBytes;	/* Length of the global string. */
    char *value;		/* The global string value. */
    Tcl_Encoding encoding;	/* system encoding when global string was
				 * initialized. */
    TclInitProcessGlobalValueProc *proc;
    				/* A procedure to initialize the global string
				 * copy when a "get" request comes in before
				 * any "set" request has been received. */
    Tcl_Mutex mutex;		/* Enforce orderly access from multiple
				 * threads. */
    Tcl_ThreadDataKey key;	/* Key for per-thread data holding the
				 * (Tcl_Obj) copy for each thread. */
} ProcessGlobalValue;

/*
 *----------------------------------------------------------------------
 * Flags for TclParseNumber
 *----------------------------------------------------------------------
 */

#define TCL_PARSE_DECIMAL_ONLY		1
				/* Leading zero doesn't denote octal or
				 * hex. */
#define TCL_PARSE_OCTAL_ONLY		2
				/* Parse octal even without prefix. */
#define TCL_PARSE_HEXADECIMAL_ONLY	4
				/* Parse hexadecimal even without prefix. */
#define TCL_PARSE_INTEGER_ONLY		8
				/* Disable floating point parsing. */
#define TCL_PARSE_SCAN_PREFIXES		16
				/* Use [scan] rules dealing with 0?
				 * prefixes. */
#define TCL_PARSE_NO_WHITESPACE		32
				/* Reject leading/trailing whitespace. */
#define TCL_PARSE_BINARY_ONLY	64
				/* Parse binary even without prefix. */
#define TCL_PARSE_NO_UNDERSCORE	128
				/* Reject underscore digit separator */


/*
 *----------------------------------------------------------------------
 * Internal convenience macros for manipulating encoding flags. See
 * TCL_ENCODING_PROFILE_* in tcl.h
 *----------------------------------------------------------------------
 */

#define ENCODING_PROFILE_MASK     0xFF000000

#define ENCODING_PROFILE_GET(flags_)  ((flags_) & ENCODING_PROFILE_MASK)


#define ENCODING_PROFILE_SET(flags_, profile_)       \
    do {                                             \
	(flags_) &= ~ENCODING_PROFILE_MASK;              \
	(flags_) |= ((profile_) & ENCODING_PROFILE_MASK);\
    } while (0)

/*
 *----------------------------------------------------------------------
 * Common functions for calculating overallocation. Trivial but allows for
 * experimenting with growth factors without having to change code in
 * multiple places. See TclAttemptAllocElemsEx and similar for usage
 * examples. Best to use those functions. Direct use of TclUpsizeAlloc /
 * TclResizeAlloc is needed in special cases such as when total size of
 * memory block is limited to less than TCL_SIZE_MAX.
 *
 *----------------------------------------------------------------------
 */

static inline Tcl_Size

TclUpsizeAlloc(TCL_UNUSED(Tcl_Size) /* oldSize. For future experiments with
				     * some growth algorithms that use this
				     * information. */,
	       Tcl_Size needed,
	       Tcl_Size limit)
{
    /* assert (oldCapacity < needed <= limit) */
    if (needed < (limit - needed/2)) {
	return needed + needed / 2;
    }
    else {
	return limit;
    }
}

static inline Tcl_Size TclUpsizeRetry(Tcl_Size needed, Tcl_Size lastAttempt) {




	/* assert (needed < lastAttempt) */
    if (needed < lastAttempt - 1) {
	/* (needed+lastAttempt)/2 but that formula may overflow Tcl_Size */
	return needed + (lastAttempt - needed) / 2;
    } else {
	return needed;
    }
}

MODULE_SCOPE void *TclAllocElemsEx(Tcl_Size elemCount, Tcl_Size elemSize,
			Tcl_Size leadSize, Tcl_Size *capacityPtr);
MODULE_SCOPE void *TclReallocElemsEx(void *oldPtr, Tcl_Size elemCount,
			Tcl_Size elemSize, Tcl_Size leadSize,
			Tcl_Size *capacityPtr);
MODULE_SCOPE void *TclAttemptReallocElemsEx(void *oldPtr,
			Tcl_Size elemCount, Tcl_Size elemSize,
			Tcl_Size leadSize, Tcl_Size *capacityPtr);

/* Alloc elemCount elements of size elemSize with leadSize header
 * returning actual capacity (in elements) in *capacityPtr. */
static inline void *TclAttemptAllocElemsEx(Tcl_Size elemCount, Tcl_Size elemSize,



			Tcl_Size leadSize, Tcl_Size *capacityPtr) {


    return TclAttemptReallocElemsEx(
	NULL, elemCount, elemSize, leadSize, capacityPtr);
}

/* Alloc numByte bytes, returning actual capacity in *capacityPtr. */
static inline void *TclAllocEx(Tcl_Size numBytes, Tcl_Size *capacityPtr) {




    return TclAllocElemsEx(numBytes, 1, 0, capacityPtr);
}

/* Alloc numByte bytes, returning actual capacity in *capacityPtr. */
static inline void *
TclAttemptAllocEx(Tcl_Size numBytes, Tcl_Size *capacityPtr)


{
    return TclAttemptAllocElemsEx(numBytes, 1, 0, capacityPtr);
}

/* Realloc numByte bytes, returning actual capacity in *capacityPtr. */
static inline void *TclReallocEx(void *oldPtr, Tcl_Size numBytes, Tcl_Size *capacityPtr) {





    return TclReallocElemsEx(oldPtr, numBytes, 1, 0, capacityPtr);
}

/* Realloc numByte bytes, returning actual capacity in *capacityPtr. */
static inline void *TclAttemptReallocEx(void *oldPtr, Tcl_Size numBytes, Tcl_Size *capacityPtr) {





    return TclAttemptReallocElemsEx(oldPtr, numBytes, 1, 0, capacityPtr);
}

/*
 *----------------------------------------------------------------
 * Variables shared among Tcl modules but not used by the outside world.
 *----------------------------------------------------------------
 */

MODULE_SCOPE char *tclNativeExecutableName;
MODULE_SCOPE int tclFindExecutableSearchDone;
MODULE_SCOPE char *tclMemDumpFileName;
MODULE_SCOPE TclPlatformType tclPlatform;

/*
 * Declarations related to internal encoding functions.
 */

MODULE_SCOPE Tcl_Encoding tclIdentityEncoding;
MODULE_SCOPE Tcl_Encoding tclUtf8Encoding;
MODULE_SCOPE int
TclEncodingProfileNameToId(Tcl_Interp *interp,
			   const char *profileName,
			   int *profilePtr);
MODULE_SCOPE const char *TclEncodingProfileIdToName(Tcl_Interp *interp,
						    int profileId);
MODULE_SCOPE void TclGetEncodingProfiles(Tcl_Interp *interp);

/*
 * TIP #233 (Virtualized Time)
 * Data for the time hooks, if any.
 */

MODULE_SCOPE Tcl_GetTimeProc *tclGetTimeProcPtr;

MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke;
MODULE_SCOPE Tcl_NRPostProc TclNRReleaseValues;

MODULE_SCOPE void  TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr);
MODULE_SCOPE void  TclPushTailcallPoint(Tcl_Interp *interp);

/* These two can be considered for the public api */
MODULE_SCOPE void  TclMarkTailcall(Tcl_Interp *interp);
MODULE_SCOPE void  TclSkipTailcall(Tcl_Interp *interp);

/*
 * This structure holds the data for the various iteration callbacks used to
 * NRE the 'for' and 'while' commands. We need a separate structure because we
 * have more than the 4 client data entries we can provide directly thorugh
 * the callback API. It is the 'word' information which puts us over the
 * limit. It is needed because the loop body is argument 4 of 'for' and
 * argument 2 of 'while'. Not providing the correct index confuses the #280
 * code. We TclSmallAlloc/Free this.
 */

typedef struct ForIterData {
    Tcl_Obj *cond;		/* Loop condition expression. */
    Tcl_Obj *body;		/* Loop body. */
    Tcl_Obj *next;		/* Loop step script, NULL for 'while'. */
    const char *msg;		/* Error message part. */
    Tcl_Size word;			/* Index of the body script in the command */
} ForIterData;

/* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile
 *            and Tcl_FindSymbol. This structure corresponds to an opaque
 *            typedef in tcl.h */

typedef void* TclFindSymbolProc(Tcl_Interp* interp, Tcl_LoadHandle loadHandle,
				const char* symbol);
struct Tcl_LoadHandle_ {
    void *clientData;	/* Client data is the load handle in the
				 * native filesystem if a module was loaded
				 * there, or an opaque pointer to a structure
				 * for further bookkeeping on load-from-VFS
				 * and load-from-memory */
    TclFindSymbolProc* findSymbolProcPtr;
				/* Procedure that resolves symbols in a
				 * loaded module */
    Tcl_FSUnloadFileProc* unloadFileProcPtr;
				/* Procedure that unloads a loaded module */
};

/* Flags for conversion of doubles to digit strings */

#define TCL_DD_E_FORMAT 		0x2
				/* Use a fixed-length string of digits,
				 * suitable for E format*/
#define TCL_DD_F_FORMAT 		0x3
				/* Use a fixed number of digits after the
				 * decimal point, suitable for F format */
#define TCL_DD_SHORTEST 		0x4
				/* Use the shortest possible string */
#define TCL_DD_NO_QUICK 		0x8
				/* Debug flag: forbid quick FP conversion */

#define TCL_DD_CONVERSION_TYPE_MASK	0x3
				/* Mask to isolate the conversion type */


/*
 *----------------------------------------------------------------
 * Procedures shared among Tcl modules but not used by the outside world:
 *----------------------------------------------------------------
 */

MODULE_SCOPE int TclUniCharNcmp(const Tcl_UniChar *ucs,
				const Tcl_UniChar *uct, size_t numChars);
MODULE_SCOPE int TclUniCharNcasecmp(const Tcl_UniChar *ucs,
				const Tcl_UniChar *uct, size_t numChars);
MODULE_SCOPE int TclUniCharCaseMatch(const Tcl_UniChar *uniStr,
				const Tcl_UniChar *uniPattern, int nocase);


/*
 * Just for the purposes of command-type registration.
 */

MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclLocalAliasObjCmd;

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

#define TclInitEmptyStringRep(objPtr) \
	((objPtr)->length = (((objPtr)->bytes = &tclEmptyString), 0))


#define TclInitStringRep(objPtr, bytePtr, len) \
    if ((len) == 0) { \
	TclInitEmptyStringRep(objPtr); \
    } else { \
	(objPtr)->bytes = (char *)Tcl_Alloc((len) + 1U); \
	memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)); \
	(objPtr)->bytes[len] = '\0'; \

#define TclIsPureDict(objPtr) \
	(((objPtr)->bytes==NULL) && TclHasInternalRep((objPtr), &tclDictType))
#define TclHasInternalRep(objPtr, type) \
	((objPtr)->typePtr == (type))
#define TclFetchInternalRep(objPtr, type) \
	(TclHasInternalRep((objPtr), (type)) ? &((objPtr)->internalRep) : NULL)


/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to increment a namespace's export epoch
 * counter. The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE void	TclInvalidateNsCmdLookup(Namespace *nsPtr);
 *----------------------------------------------------------------

MODULE_SCOPE Tcl_LibraryInitProc TclplatformtestInit;
MODULE_SCOPE Tcl_LibraryInitProc TclObjTest_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;


/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to check whether a pattern has any characters
 * special to [string match]. The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE int	TclMatchIsTrivial(const char *pattern);

#define TclCleanupCommandMacro(cmdPtr)		\
    do {					\
	if ((cmdPtr)->refCount-- <= 1) {	\
	    Tcl_Free(cmdPtr);			\
	}					\
    } while (0)


/*
 * inside this routine crement refCount first incase cmdPtr is replacing itself
 */
#define TclRoutineAssign(location, cmdPtr)	    \
    do {					    \
	(cmdPtr)->refCount++;			    \
	if ((location) != NULL			    \
	    && (location--) <= 1) {		    \
	    Tcl_Free(((location)));		    \
	}					    \
	(location) = (cmdPtr);			    \
    } while (0)


#define TclRoutineHasName(cmdPtr) \
    ((cmdPtr)->hPtr != NULL)

/*
 *----------------------------------------------------------------
 * Inline versions of Tcl_LimitReady() and Tcl_LimitExceeded to limit number

    LimitHandler *prevPtr;	/* Previous item in linked list of
				 * handlers. */
    LimitHandler *nextPtr;	/* Next item in linked list of handlers. */
};

/*
 * Values for the LimitHandler flags field.


 *      LIMIT_HANDLER_ACTIVE - Whether the handler is currently being
 *              processed; handlers are never to be reentered.

 *      LIMIT_HANDLER_DELETED - Whether the handler has been deleted. This
 *              should not normally be observed because when a handler is

 *              deleted it is also spliced out of the list of handlers, but
 *              even so we will be careful.
 */

#define LIMIT_HANDLER_ACTIVE    0x01
#define LIMIT_HANDLER_DELETED   0x02



/*
 * Prototypes for local static functions:
 */

static int		AliasCreate(Tcl_Interp *interp,
			    Tcl_Interp *childInterp, Tcl_Interp *parentInterp,

				 * avoid string conversions. */
    int flags;			/* Miscellaneous one-bit values; see below for
				 * definitions. */
} Link;

/*
 * Definitions for flag bits:


 * LINK_READ_ONLY -		1 means errors should be generated if Tcl
 *				script attempts to write variable.
 * LINK_BEING_UPDATED -		1 means that a call to Tcl_UpdateLinkedVar is
 *				in progress for this variable, so trace
 *				callbacks on the variable should be ignored.

 * LINK_ALLOC_ADDR -		1 means linkPtr->addr was allocated on the
 *				heap.
 * LINK_ALLOC_LAST -		1 means linkPtr->valueLast.p was allocated on
 *				the heap.
 */

#define LINK_READ_ONLY		1
#define LINK_BEING_UPDATED	2
#define LINK_ALLOC_ADDR		4
#define LINK_ALLOC_LAST		8

/*
 * Forward references to functions defined later in this file:
 */

static char *		LinkTraceProc(void *clientData,Tcl_Interp *interp,
			    const char *name1, const char *name2, int flags);

 * - Conversely, if only LISTREP_FAVOR_BACK is present extra space is allocated
 *   with more to the back.
 * - If both flags are present (LISTREP_SPACE_FAVOR_NONE), the extra space
 *   is equally apportioned.
 * - Finally if LISTREP_SPACE_ONLY_BACK is present, ALL extra space is at
 *   the back.
 */

#define LISTREP_PANIC_ON_FAIL         0x00000001
#define LISTREP_SPACE_FAVOR_FRONT     0x00000002
#define LISTREP_SPACE_FAVOR_BACK      0x00000004
#define LISTREP_SPACE_ONLY_BACK       0x00000008
#define LISTREP_SPACE_FAVOR_NONE \
    (LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK)
#define LISTREP_SPACE_FLAGS                               \
    (LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK \
     | LISTREP_SPACE_ONLY_BACK)


/*
 * Prototypes for non-inline static functions defined later in this file:
 */
static int	MemoryAllocationError(Tcl_Interp *, size_t size);
static int	ListLimitExceededError(Tcl_Interp *);
static ListStore *ListStoreNew(Tcl_Size objc, Tcl_Obj *const objv[], int flags);

static int	ListRepInit(Tcl_Size objc, Tcl_Obj *const objv[], int flags, ListRep *);

static int	ListRepInitAttempt(Tcl_Interp *,
		    Tcl_Size objc,
		    Tcl_Obj *const objv[],
		    ListRep *);
static void	ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags);

static void	ListRepUnsharedFreeUnreferenced(const ListRep *repPtr);
static int	TclListObjGetRep(Tcl_Interp *, Tcl_Obj *listPtr, ListRep *repPtr);

static void	ListRepRange(ListRep *srcRepPtr,
		    Tcl_Size rangeStart,
		    Tcl_Size rangeEnd,
		    int preserveSrcRep,
		    ListRep *rangeRepPtr);
static ListStore *ListStoreReallocate(ListStore *storePtr, Tcl_Size numSlots);
static void	ListRepValidate(const ListRep *repPtr, const char *file,
		    int lineNum);
static void	DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void	FreeListInternalRep(Tcl_Obj *listPtr);
static int	SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void	UpdateStringOfList(Tcl_Obj *listPtr);
static Tcl_Size ListLength(Tcl_Obj *listPtr);

/*
 * The structure below defines the list Tcl object type by means of functions
 * that can be invoked by generic object code.
 *
 * The internal representation of a list object is ListRep defined in tcl.h.
 */

 * Side effects:
 *    The function will panic on memory allocation failure.
 *
 *------------------------------------------------------------------------
 */
static inline ListSpan *
ListSpanNew(
    Tcl_Size firstSlot, /* Starting slot index of the span */
    Tcl_Size numSlots)  /* Number of slots covered by the span */
{
    ListSpan *spanPtr = (ListSpan *) Tcl_Alloc(sizeof(*spanPtr));
    spanPtr->refCount = 0;
    spanPtr->spanStart = firstSlot;
    spanPtr->spanLength = numSlots;
    return spanPtr;
}

 *
 * Side effects:
 *   The memory may be freed.
 *
 *------------------------------------------------------------------------
 */
static inline void
ListSpanDecrRefs(ListSpan *spanPtr)

{
    if (spanPtr->refCount <= 1) {
	Tcl_Free(spanPtr);
    } else {
	spanPtr->refCount -= 1;
    }
}

 *
 * Side effects:
 *    See comments for ListRepUnsharedFreeUnreferenced.
 *
 *------------------------------------------------------------------------
 */
static inline void
ListRepFreeUnreferenced(const ListRep *repPtr)

{
    if (! ListRepIsShared(repPtr) && repPtr->spanPtr) {
	/* T:listrep-1.5.1 */
	ListRepUnsharedFreeUnreferenced(repPtr);
    }
}


 * Side effects:
 *    As above.
 *
 *------------------------------------------------------------------------
 */
static inline void
ObjArrayIncrRefs(
    Tcl_Obj * const *objv,  /* Pointer to the array */
    Tcl_Size startIdx,     /* Starting index of subarray within objv */
    Tcl_Size count)        /* Number of elements in the subarray */
{
    Tcl_Obj *const *end;
    LIST_INDEX_ASSERT(startIdx);
    LIST_COUNT_ASSERT(count);
    objv += startIdx;
    end = objv + count;
    while (objv < end) {

 * Side effects:
 *    As above.
 *
 *------------------------------------------------------------------------
 */
static inline void
ObjArrayDecrRefs(
    Tcl_Obj * const *objv, /* Pointer to the array */
    Tcl_Size startIdx,    /* Starting index of subarray within objv */
    Tcl_Size count)       /* Number of elements in the subarray */
{
    Tcl_Obj * const *end;
    LIST_INDEX_ASSERT(startIdx);
    LIST_COUNT_ASSERT(count);
    objv += startIdx;
    end = objv + count;
    while (objv < end) {

	return TCL_OK;
    }

    if (TclObjTypeHasProc(listObj, lengthProc)) {
	*lenPtr = TclObjTypeLength(listObj);
	return TCL_OK;
    }


    if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
	return TCL_ERROR;
    }
    *lenPtr = ListRepLength(&listRep);
    return TCL_OK;
}

 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"


/*
 * The following structure describes a library that has been loaded either
 * dynamically (with the "load" command) or statically (as indicated by a call
 * to Tcl_StaticLibrary). All such libraries are linked together into a
 * single list for the process.
 */

		code = TCL_ERROR;
		goto done;
	    }
	}
	unloadProc = libraryPtr->unloadProc;
    }



    /*
     * We are ready to unload the library. First, evaluate the unload
     * function. If this fails, we cannot proceed with unload. Also, we must
     * specify the proper flag to pass to the unload callback.
     * TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback should
     * only remove itself from the interpreter; the library will be unloaded
     * in a future call of unload. In case the library will be unloaded just

	    if (safeRefCount <= 0 && trustedRefCount <= 0) {
		code = TCL_UNLOAD_DETACH_FROM_PROCESS;
	    }
	}
	code = unloadProc(target, code);
    }


    if (code != TCL_OK) {
	Tcl_TransferResult(target, code, interp);
	goto done;
    }


    /*
     * Remove this library from the interpreter's library cache.
     */

    ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL);
    ipPtr = ipFirstPtr;

		ipPrevPtr->nextPtr = ipPtr->nextPtr;
		break;
	    }
	}
    }
    Tcl_Free(ipPtr);
    Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr);


    if (IsStatic(libraryPtr)) {
	goto done;
    }

    /*
     * The unload function was called succesfully.

 */

static int
InitFoundation(
    Tcl_Interp *interp)
{
    static Tcl_ThreadDataKey tsdKey;
    ThreadLocalData *tsdPtr =
	    (ThreadLocalData *)Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
    Foundation *fPtr = (Foundation *)Tcl_Alloc(sizeof(Foundation));
    Tcl_Obj *namePtr;
    Tcl_DString buffer;
    Command *cmdPtr;
    size_t i;

    /*

    /*
     * Create the subcommands in the oo::define and oo::objdefine spaces.
     */

    Tcl_DStringInit(&buffer);
    for (i = 0 ; defineCmds[i].name ; i++) {
	TclDStringAppendLiteral(&buffer, "::oo::define::");
	Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
		defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
	Tcl_DStringFree(&buffer);
    }
    for (i = 0 ; objdefCmds[i].name ; i++) {
	TclDStringAppendLiteral(&buffer, "::oo::objdefine::");
	Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1);
	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
		objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL);
	Tcl_DStringFree(&buffer);
    }

    Tcl_CallWhenDeleted(interp, KillFoundation, NULL);

    /*
     * Evaluate the remaining definitions, which are a compiled-in Tcl script.
     */

    return Tcl_EvalEx(interp, tclOOSetupScript, TCL_INDEX_NONE, 0);
}

/*
 * ----------------------------------------------------------------------
 *
 * InitClassSystemRoots --
 *
 *	Creates the objects at the core of the object system. These need to be
 *	spliced manually.

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

static void
KillFoundation(
    TCL_UNUSED(void *),
    Tcl_Interp *interp)	/* The interpreter containing the OO system
			 * foundation. */
{
    Foundation *fPtr = GetFoundation(interp);

    TclDecrRefCount(fPtr->unknownMethodNameObj);
    TclDecrRefCount(fPtr->constructorName);
    TclDecrRefCount(fPtr->destructorName);
    TclDecrRefCount(fPtr->clonedName);

	}
	Tcl_ResetResult(interp);
    }

    while (1) {
	char objName[10 + TCL_INTEGER_SPACE];

	snprintf(objName, sizeof(objName), "::oo::Obj%" TCL_Z_MODIFIER "u", ++fPtr->tsdPtr->nsCount);

	oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL);
	if (oPtr->namespacePtr != NULL) {
	    creationEpoch = fPtr->tsdPtr->nsCount;
	    break;
	}

	/*

 *	of those commands when the object itself is deleted.
 *
 * ----------------------------------------------------------------------
 */

static void
MyDeleted(
    void *clientData)	/* Reference to the object whose [my] has been
				 * squelched. */
{
    Object *oPtr = (Object *)clientData;

    oPtr->myCommand = NULL;
}

static void
MyClassDeleted(
    void *clientData)
{

 *	object data structures.
 *
 * ----------------------------------------------------------------------
 */

static void
ObjectRenamedTrace(
    void *clientData,	/* The object being deleted. */
    TCL_UNUSED(Tcl_Interp *),
    TCL_UNUSED(const char *) /*oldName*/,
    TCL_UNUSED(const char *) /*newName*/,
    int flags)			/* Why was the object deleted? */
{
    Object *oPtr = (Object *)clientData;

 *	(interpreter teardown is complex!)
 *
 * ----------------------------------------------------------------------
 */

static void
ObjectNamespaceDeleted(
    void *clientData)	/* Pointer to the class whose namespace is
				 * being deleted. */
{
    Object *oPtr = (Object *)clientData;
    Foundation *fPtr = oPtr->fPtr;
    FOREACH_HASH_DECLS;
    Class *mixinPtr;
    Method *mPtr;

 */

int
TclOODecrRefCount(
    Object *oPtr)
{
    if (oPtr->refCount-- <= 1) {

	if (oPtr->classPtr != NULL) {
	    Tcl_Free(oPtr->classPtr);
	}
	Tcl_Free(oPtr);
	return 1;
    }
    return 0;

    Tcl_Interp *interp,		/* Interpreter context. */
    Tcl_Class cls,		/* Class to create an instance of. */
    const char *nameStr,	/* Name of object to create, or NULL to ask
				 * the code to pick its own unique name. */
    const char *nsNameStr,	/* Name of namespace to create inside object,
				 * or NULL to ask the code to pick its own
				 * unique name. */
    Tcl_Size objc,			/* Number of arguments. Negative value means
				 * do not call constructor. */
    Tcl_Obj *const *objv,	/* Argument list. */
    Tcl_Size skip)			/* Number of arguments to _not_ pass to the
				 * constructor. */
{
    Class *classPtr = (Class *) cls;
    Object *oPtr;
    void *clientData[4];

    oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);

    Tcl_Interp *interp,		/* Interpreter context. */
    Tcl_Class cls,		/* Class to create an instance of. */
    const char *nameStr,	/* Name of object to create, or NULL to ask
				 * the code to pick its own unique name. */
    const char *nsNameStr,	/* Name of namespace to create inside object,
				 * or NULL to ask the code to pick its own
				 * unique name. */
    Tcl_Size objc,			/* Number of arguments. Negative value means
				 * do not call constructor. */
    Tcl_Obj *const *objv,	/* Argument list. */
    Tcl_Size skip,			/* Number of arguments to _not_ pass to the
				 * constructor. */
    Tcl_Object *objectPtr)	/* Place to write the object reference upon
				 * successful allocation. */
{
    Class *classPtr = (Class *) cls;
    CallContext *contextPtr;
    Tcl_InterpState state;

    /*
     * Ensure an error if the object was deleted in the constructor. Don't
     * want to lose errors by accident. [Bug 2903011]
     */

    if (result != TCL_ERROR && Destructing(oPtr)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"object deleted in constructor", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", (char *)NULL);
	result = TCL_ERROR;
    }
    if (result != TCL_OK) {
	Tcl_DiscardInterpState(state);

	/*

    /*
     * Sanity check.
     */

    if (IsRootClass(oPtr)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not clone the class of classes", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", (char *)NULL);
	return NULL;
    }

    /*
     * Build the instance. Note that this does not run any constructors.
     */

				 * invoke from, or NULL to traverse the whole
				 * chain including filters. */
    int publicPrivate,		/* Whether this is an invoke from a public
				 * context (PUBLIC_METHOD), a private context
				 * (PRIVATE_METHOD), or a *really* private
				 * context (any other value; conventionally
				 * 0). */
    Tcl_Size objc,			/* Number of arguments. */
    Tcl_Obj *const *objv)	/* Array of argument objects. It is assumed
				 * that the name of the method to invoke will
				 * be at index 1. */
{
    switch (publicPrivate) {
    case PUBLIC_METHOD:
	return TclOOObjectCmdCore((Object *) object, interp, objc, objv,

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

int
TclOOObjectCmdCore(
    Object *oPtr,		/* The object being invoked. */
    Tcl_Interp *interp,		/* The interpreter containing the object. */
    Tcl_Size objc,			/* How many arguments are being passed in. */
    Tcl_Obj *const *objv,	/* The array of arguments. */
    int flags,			/* Whether this is an invocation through the
				 * public or the private command interface. */
    Class *startCls)		/* Where to start in the call chain, or NULL
				 * if we are to start at the front with
				 * filters and the object's methods (which is
				 * the normal case). */

	    }
	    if (miPtr->mPtr->declaringClassPtr == startCls) {
		break;
	    }
	}
	if (contextPtr->index >= contextPtr->callPtr->numChain) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "no valid method implementation", -1));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		    TclGetString(methodNamePtr), (char *)NULL);
	    TclOODeleteContext(contextPtr);
	    return TCL_ERROR;
	}
    }

    }

    /*
     * Make the class definition delegate. This is special; it doesn't reenter
     * here (and the class definition delegate doesn't run any constructors).
     */

    nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1);
    Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1);
    Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
	    TclGetString(nameObj), NULL, -1, NULL, -1);
    Tcl_DecrRefCount(nameObj);

    /*
     * Delegate to [oo::define] to do the work.
     */

    invoke = (Tcl_Obj **)Tcl_Alloc(3 * sizeof(Tcl_Obj *));
    invoke[0] = oPtr->fPtr->defineName;
    invoke[1] = TclOOObjectName(interp, oPtr);
    invoke[2] = objv[objc-1];

    /*
     * Must add references or errors in configuration script will cause
     * trouble.
     */

    Tcl_IncrRefCount(invoke[0]);

    Object *oPtr = (Object *)data[1];
    Tcl_InterpState saved;
    int code;

    TclDecrRefCount(invoke[0]);
    TclDecrRefCount(invoke[1]);
    TclDecrRefCount(invoke[2]);
    invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1);
    invoke[1] = TclOOObjectName(interp, oPtr);
    Tcl_IncrRefCount(invoke[0]);
    Tcl_IncrRefCount(invoke[1]);
    saved = Tcl_SaveInterpState(interp, result);
    code = Tcl_EvalObjv(interp, 2, invoke, 0);
    TclDecrRefCount(invoke[0]);
    TclDecrRefCount(invoke[1]);

		"objectName ?arg ...?");
	return TCL_ERROR;
    }
    objName = Tcl_GetStringFromObj(
	    objv[Tcl_ObjectContextSkippedArgs(context)], &len);
    if (len == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"object name must not be empty", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (char *)NULL);
	return TCL_ERROR;
    }

    /*
     * Make the object and return its name.
     */

		"objectName namespaceName ?arg ...?");
	return TCL_ERROR;
    }
    objName = Tcl_GetStringFromObj(
	    objv[Tcl_ObjectContextSkippedArgs(context)], &len);
    if (len == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"object name must not be empty", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (char *)NULL);
	return TCL_ERROR;
    }
    nsName = Tcl_GetStringFromObj(
	    objv[Tcl_ObjectContextSkippedArgs(context)+1], &len);
    if (len == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"namespace name must not be empty", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (char *)NULL);
	return TCL_ERROR;
    }

    /*
     * Make the object and return its name.
     */

	return TCL_ERROR;
    }

    errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ",
	    TclGetString(objv[skip]));
    for (i=0 ; i<numMethodNames-1 ; i++) {
	if (i) {
	    Tcl_AppendToObj(errorMsg, ", ", -1);
	}
	Tcl_AppendToObj(errorMsg, methodNames[i], -1);
    }
    if (i) {
	Tcl_AppendToObj(errorMsg, " or ", -1);
    }
    Tcl_AppendToObj(errorMsg, methodNames[i], -1);
    Tcl_Free((void *)methodNames);
    Tcl_SetObjResult(interp, errorMsg);
    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
	    TclGetString(objv[skip]), (char *)NULL);
    return TCL_ERROR;
}


	 * This is copied out of Tcl_VariableObjCmd...
	 */

	if (!TclIsVarNamespaceVar(varPtr)) {
	    TclSetVarNamespaceVar(varPtr);
	}

	if (TclPtrMakeUpvar(interp, varPtr, varName, 0, -1) != TCL_OK) {
	    return TCL_ERROR;
	}
    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Object_VarName --
 *
 *	Implementation of the oo::object->varname method.
 *
 * ----------------------------------------------------------------------
 */

























































int
TclOO_Object_VarName(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Interpreter in which to create the object;
				 * also used for error reporting. */
    Tcl_ObjectContext context,	/* The object/call context. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const *objv)	/* The actual arguments. */
{
    Var *varPtr, *aryVar;
    Tcl_Obj *varNamePtr, *argPtr;
    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
    const char *arg;

    if ((int)Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"varName");
	return TCL_ERROR;
    }
    argPtr = objv[objc-1];
    arg = TclGetString(argPtr);

    /*
     * Convert the variable name to fully-qualified form if it wasn't already.
     * This has to be done prior to lookup because we can run into problems
     * with resolvers otherwise. [Bug 3603695]
     *
     * We still need to do the lookup; the variable could be linked to another
     * variable and we want the target's name.
     */

    if (arg[0] == ':' && arg[1] == ':') {
	varNamePtr = argPtr;
    } else {
	Tcl_Namespace *namespacePtr =
		Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));

	/*
	 * Private method handling. [TIP 500]
	 *
	 * If we're in a context that can see some private methods of an
	 * object, we may need to precede a variable name with its prefix.
	 * This is a little tricky as we need to check through the inheritance
	 * hierarchy when the method was declared by a class to see if the
	 * current object is an instance of that class.
	 */

	if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
	    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
	    CallContext *callerContext = (CallContext *)framePtr->clientData;
	    Method *mPtr = callerContext->callPtr->chain[
		    callerContext->index].mPtr;
	    PrivateVariableMapping *pvPtr;
	    Tcl_Size i;

	    if (mPtr->declaringObjectPtr == oPtr) {
		FOREACH_STRUCT(pvPtr, oPtr->privateVariables) {
		    if (!strcmp(TclGetString(pvPtr->variableObj),
			    TclGetString(argPtr))) {
			argPtr = pvPtr->fullNameObj;
			break;
		    }
		}
	    } else if (mPtr->declaringClassPtr &&
		    mPtr->declaringClassPtr->privateVariables.num) {
		Class *clsPtr = mPtr->declaringClassPtr;
		int isInstance = TclOOIsReachable(clsPtr, oPtr->selfCls);
		Class *mixinCls;

		if (!isInstance) {
		    FOREACH(mixinCls, oPtr->mixins) {
			if (TclOOIsReachable(clsPtr, mixinCls)) {
			    isInstance = 1;
			    break;
			}
		    }
		}
		if (isInstance) {
		    FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) {
			if (!strcmp(TclGetString(pvPtr->variableObj),
				TclGetString(argPtr))) {
			    argPtr = pvPtr->fullNameObj;
			    break;
			}
		    }
		}
	    }
	}

	varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
	Tcl_AppendToObj(varNamePtr, "::", 2);
	Tcl_AppendObjToObj(varNamePtr, argPtr);
    }
    Tcl_IncrRefCount(varNamePtr);
    varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
	    TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar);
    Tcl_DecrRefCount(varNamePtr);

    if (aryVar != NULL) {
	Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);

	/*
	 * WARNING! This code pokes inside the implementation of hash tables!
	 */

	Tcl_AppendToObj(varNamePtr, "(", -1);
	Tcl_AppendObjToObj(varNamePtr, ((VarInHash *)
		varPtr)->entry.key.objPtr);
	Tcl_AppendToObj(varNamePtr, ")", -1);
    } else {
	Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
    }
    Tcl_SetObjResult(interp, varNamePtr);
    return TCL_OK;
}


	    /*
	     * Invoke the (advanced) method call context in the caller
	     * context. Note that this is like [uplevel 1] and not [eval].
	     */

	    TclNRAddCallback(interp, NextRestoreFrame, framePtr,
		    contextPtr, INT2PTR(contextPtr->index), NULL);
	    contextPtr->index = i-1;
	    iPtr->varFramePtr = framePtr->callerVarPtr;
	    return TclNRObjectContextInvokeNext(interp,
		    (Tcl_ObjectContext) contextPtr, objc, objv, 2);
	}
    }

    /*

    iPtr->varFramePtr = (CallFrame *)data[0];
    if (contextPtr != NULL) {
	contextPtr->index = PTR2UINT(data[2]);
    }
    return result;
}









































/*
 * ----------------------------------------------------------------------
 *
 * TclOOSelfObjCmd --
 *
 *	Implementation of the [self] command, which provides introspection of

    switch (index) {
    case SELF_OBJECT:
	Tcl_SetObjResult(interp, TclOOObjectName(interp, contextPtr->oPtr));
	return TCL_OK;
    case SELF_NS:
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		contextPtr->oPtr->namespacePtr->fullName, -1));
	return TCL_OK;
    case SELF_CLASS: {
	Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;

	if (clsPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "method not defined by a class", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (char *)NULL);
	    return TCL_ERROR;
	}

	Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
	return TCL_OK;
    }
    case SELF_METHOD:
	if (contextPtr->callPtr->flags & CONSTRUCTOR) {
	    Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->constructorName);
	} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
	    Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->destructorName);
	} else {
	    Tcl_SetObjResult(interp,
		    CurrentlyInvoked(contextPtr).mPtr->namePtr);
	}
	return TCL_OK;
    case SELF_FILTER:
	if (!CurrentlyInvoked(contextPtr).isFilter) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "not inside a filtering context", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (char *)NULL);
	    return TCL_ERROR;
	} else {
	    struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
	    Object *oPtr;
	    const char *type;

	    if (miPtr->filterDeclarer != NULL) {
		oPtr = miPtr->filterDeclarer->thisPtr;
		type = "class";
	    } else {
		oPtr = contextPtr->oPtr;
		type = "object";
	    }

	    result[0] = TclOOObjectName(interp, oPtr);
	    result[1] = Tcl_NewStringObj(type, -1);
	    result[2] = miPtr->mPtr->namePtr;
	    Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
	    return TCL_OK;
	}
    case SELF_CALLER:
	if ((framePtr->callerVarPtr == NULL) ||
		!(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "caller is not an object", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL);
	    return TCL_ERROR;
	} else {
	    CallContext *callerPtr = (CallContext *)framePtr->callerVarPtr->clientData;
	    Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
	    Object *declarerPtr;

	    if (mPtr->declaringClassPtr != NULL) {
		declarerPtr = mPtr->declaringClassPtr->thisPtr;
	    } else if (mPtr->declaringObjectPtr != NULL) {
		declarerPtr = mPtr->declaringObjectPtr;
	    } else {
		/*
		 * This should be unreachable code.
		 */

		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"method without declarer!", -1));
		return TCL_ERROR;
	    }

	    result[0] = TclOOObjectName(interp, declarerPtr);
	    result[1] = TclOOObjectName(interp, callerPtr->oPtr);
	    if (callerPtr->callPtr->flags & CONSTRUCTOR) {
		result[2] = declarerPtr->fPtr->constructorName;
	    } else if (callerPtr->callPtr->flags & DESTRUCTOR) {
		result[2] = declarerPtr->fPtr->destructorName;
	    } else {
		result[2] = mPtr->namePtr;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
	    return TCL_OK;
	}
    case SELF_NEXT:
	if (contextPtr->index < contextPtr->callPtr->numChain-1) {
	    Method *mPtr =
		    contextPtr->callPtr->chain[contextPtr->index+1].mPtr;
	    Object *declarerPtr;

	    if (mPtr->declaringClassPtr != NULL) {
		declarerPtr = mPtr->declaringClassPtr->thisPtr;
	    } else if (mPtr->declaringObjectPtr != NULL) {
		declarerPtr = mPtr->declaringObjectPtr;
	    } else {
		/*
		 * This should be unreachable code.
		 */

		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"method without declarer!", -1));
		return TCL_ERROR;
	    }

	    result[0] = TclOOObjectName(interp, declarerPtr);
	    if (contextPtr->callPtr->flags & CONSTRUCTOR) {
		result[1] = declarerPtr->fPtr->constructorName;
	    } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
		result[1] = declarerPtr->fPtr->destructorName;
	    } else {
		result[1] = mPtr->namePtr;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
	}
	return TCL_OK;
    case SELF_TARGET:
	if (!CurrentlyInvoked(contextPtr).isFilter) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "not inside a filtering context", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (char *)NULL);
	    return TCL_ERROR;
	} else {
	    Method *mPtr;
	    Object *declarerPtr;
	    Tcl_Size i;

	    for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){
		if (!contextPtr->callPtr->chain[i].isFilter) {
		    break;
		}
	    }
	    if (i == contextPtr->callPtr->numChain) {
		Tcl_Panic("filtering call chain without terminal non-filter");
	    }
	    mPtr = contextPtr->callPtr->chain[i].mPtr;
	    if (mPtr->declaringClassPtr != NULL) {
		declarerPtr = mPtr->declaringClassPtr->thisPtr;
	    } else if (mPtr->declaringObjectPtr != NULL) {
		declarerPtr = mPtr->declaringObjectPtr;
	    } else {
		/*
		 * This should be unreachable code.
		 */

		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"method without declarer!", -1));
		return TCL_ERROR;
	    }
	    result[0] = TclOOObjectName(interp, declarerPtr);
	    result[1] = mPtr->namePtr;
	    Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
	    return TCL_OK;
	}
    case SELF_CALL:
	result[0] = TclOORenderCallChain(interp, contextPtr->callPtr);
	TclNewIndexObj(result[1], contextPtr->index);
	Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));

    int size;
} DefineChain;

/*
 * Extra flags used for call chain management.
 */


#define DEFINITE_PROTECTED 0x100000
#define DEFINITE_PUBLIC    0x200000

#define KNOWN_STATE	   (DEFINITE_PROTECTED | DEFINITE_PUBLIC)
#define SPECIAL		   (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN)
#define BUILDING_MIXINS	   0x400000
#define TRAVERSED_MIXIN	   0x800000
#define OBJECT_MIXIN	   0x1000000
#define DEFINE_FOR_CLASS   0x2000000

#define MIXIN_CONSISTENT(flags) \
    (((flags) & OBJECT_MIXIN) ||					\
	!((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN))

/*
 * Note that the flag bit PRIVATE_METHOD has a confusing name; it's just for
 * Itcl's special type of private.
 */

#define IS_PUBLIC(mPtr)				\
    (((mPtr)->flags & PUBLIC_METHOD) != 0)
#define IS_UNEXPORTED(mPtr)			\
    (((mPtr)->flags & SCOPE_FLAGS) == 0)
#define IS_ITCLPRIVATE(mPtr)				\
    (((mPtr)->flags & PRIVATE_METHOD) != 0)
#define IS_PRIVATE(mPtr)			\
    (((mPtr)->flags & TRUE_PRIVATE_METHOD) != 0)
#define WANT_PUBLIC(flags)			\
    (((flags) & PUBLIC_METHOD) != 0)
#define WANT_UNEXPORTED(flags)			\
    (((flags) & (PRIVATE_METHOD | TRUE_PRIVATE_METHOD)) == 0)
#define WANT_ITCLPRIVATE(flags)			\
    (((flags) & PRIVATE_METHOD) != 0)
#define WANT_PRIVATE(flags)			\
    (((flags) & TRUE_PRIVATE_METHOD) != 0)

/*
 * Function declarations for things defined in this file.

    "TclOO method name",
    FreeMethodNameRep,
    DupMethodNameRep,
    NULL,
    NULL,
    TCL_OBJTYPE_V0
};










/*
 * ----------------------------------------------------------------------
 *
 * TclOODeleteContext --
 *

 *	in stack usage as possible.
 *
 * ----------------------------------------------------------------------
 */

int
TclOOInvokeContext(
    void *clientData,	/* The method call context. */
    Tcl_Interp *interp,		/* Interpreter for error reporting, and many
				 * other sorts of context handling (e.g.,
				 * commands, variables) depending on method
				 * implementation. */
    int objc,			/* The number of arguments. */
    Tcl_Obj *const objv[])	/* The arguments as actually seen. */
{

    /*
     * Run the method implementation.
     */

    if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) {
	return (mPtr->typePtr->callProc)(mPtr->clientData, interp,
		(Tcl_ObjectContext) contextPtr, objc, objv);
    }

    return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp,

	    (Tcl_ObjectContext) contextPtr, objc, objv);

}

static int
SetFilterFlags(
    void *data[],
    TCL_UNUSED(Tcl_Interp *),
    int result)

    Class *mixinPtr;
    Tcl_Obj *namePtr;
    Method *mPtr;

    Tcl_InitObjHashTable(&names);
    Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);

    /*
     * Name the bits used in the names table values.
     */
#define IN_LIST 1
#define NO_IMPLEMENTATION 2

    /*
     * Process method names due to the object.
     */

    if (oPtr->methodsPtr) {
	FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
	    if (IS_PRIVATE(mPtr)) {

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

static void
AddClassMethodNames(
    Class *clsPtr,		/* Class to get method names from. */
    int flags,		/* Whether we are interested in just the
				 * public method names. */
    Tcl_HashTable *const namesPtr,
				/* Reference to the hash table to put the
				 * information in. The hash table maps the
				 * Tcl_Obj * method name to an integral value
				 * describing whether the method is wanted.
				 * This ensures that public/private override

	    int isWanted = PTR2INT(Tcl_GetHashValue(hPtr));

	    isWanted &= ~NO_IMPLEMENTATION;
	    Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
	}
    }
}

#undef IN_LIST
#undef NO_IMPLEMENTATION

/*
 * ----------------------------------------------------------------------
 *
 * AddInstancePrivateToCallContext --
 *
 *	Add private methods from the instance. Called when the calling Tcl

    /*
     * Need to really add the method. This is made a bit more complex by the
     * fact that we are using some "static" space initially, and only start
     * realloc-ing if the chain gets long.
     */

    if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) {
	callPtr->chain =
		(struct MInvoke *)Tcl_Alloc(sizeof(struct MInvoke) * (callPtr->numChain + 1));
	memcpy(callPtr->chain, callPtr->staticChain,
		sizeof(struct MInvoke) * callPtr->numChain);
    } else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) {
	callPtr->chain = (struct MInvoke *)Tcl_Realloc(callPtr->chain,
		sizeof(struct MInvoke) * (callPtr->numChain + 1));
    }
    callPtr->chain[i].mPtr = mPtr;

	    return NULL;
	}
    } else if (doFilters && !donePrivate) {
	if (hPtr == NULL) {
	    int isNew;
	    if (oPtr->flags & USE_CLASS_CACHE) {
		if (oPtr->selfCls->classChainCache == NULL) {
		    oPtr->selfCls->classChainCache =
			    (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));

		    Tcl_InitObjHashTable(oPtr->selfCls->classChainCache);
		}
		hPtr = Tcl_CreateHashEntry(oPtr->selfCls->classChainCache,
			methodNameObj, &isNew);
	    } else {
		if (oPtr->chainCache == NULL) {
		    oPtr->chainCache = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));


		    Tcl_InitObjHashTable(oPtr->chainCache);
		}
		hPtr = Tcl_CreateHashEntry(oPtr->chainCache,
			methodNameObj, &isNew);
	    }
	}

	    TclOODeleteChain(oPtr->selfCls->destructorChainPtr);
	}
	oPtr->selfCls->destructorChainPtr = callPtr;
	callPtr->refCount++;
    }

  returnContext:

    contextPtr = (CallContext *)TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext));
    contextPtr->oPtr = oPtr;

    /*
     * Corresponding TclOODecrRefCount() in TclOODeleteContext
     */

    AddRef(oPtr);

	}
	if (toPtr) {
	    newHPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, toPtr,
		    &isNew);
	    if (hPtr == newHPtr) {
	    renameToSelf:
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"cannot rename method to itself", -1));
		Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", (char *)NULL);
		return TCL_ERROR;
	    } else if (!isNew) {
	    renameToExisting:
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"method called %s already exists",
			TclGetString(toPtr)));

    Tcl_HashSearch search;
    Tcl_HashEntry *hPtr;
    Tcl_Size soughtLen;
    const char *soughtStr, *matchedStr = NULL;

    if (objc < 2) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"bad call of unknown handler", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", (char *)NULL);
	return TCL_ERROR;
    }
    if (TclOOGetDefineCmdContext(interp) == NULL) {
	return TCL_ERROR;
    }

	 * Got one match, and only one match!
	 */

	Tcl_Obj **newObjv = (Tcl_Obj **)
		TclStackAlloc(interp, sizeof(Tcl_Obj*) * (objc - 1));
	int result;

	newObjv[0] = Tcl_NewStringObj(matchedStr, -1);
	Tcl_IncrRefCount(newObjv[0]);
	if (objc > 2) {
	    memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2));
	}
	result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0);
	Tcl_DecrRefCount(newObjv[0]);
	TclStackFree(interp, newObjv);

    int objc,
    Tcl_Obj *const objv[])
{
    CallFrame *framePtr, **framePtrPtr = &framePtr;

    if (namespacePtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"no definition namespace available", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    /*
     * framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules.
     */

    Tcl_Object object;

    if ((iPtr->varFramePtr == NULL)
	    || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE
	    && iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"this command may only be called from within the context of"
		" an ::oo::define or ::oo::objdefine command", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return NULL;
    }
    object = (Tcl_Object)iPtr->varFramePtr->clientData;
    if (Tcl_ObjectDeleted(object)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"this command cannot be called when the object has been"
		" deleted", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return NULL;
    }
    return object;
}


























/*
 * ----------------------------------------------------------------------
 *
 * GetClassInOuterContext, GetNamespaceInOuterContext --
 *
 *	Wrappers round Tcl_GetObjectFromObj and TclGetNamespaceFromObj to

    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, className);
    iPtr->varFramePtr = savedFramePtr;
    if (oPtr == NULL) {
	return NULL;
    }
    if (oPtr->classPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
		TclGetString(className), (char *)NULL);
	return NULL;
    }
    return oPtr->classPtr;
}

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (oPtr->flags & ROOT_OBJECT) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not modify the class of the root object class", -1));

	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }
    if (oPtr->flags & ROOT_CLASS) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not modify the class of the class of classes", -1));

	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    /*
     * Parse the argument to get the class to set the object's class to.
     */

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className");
	return TCL_ERROR;
    }
    clsPtr = GetClassInOuterContext(interp, objv[1],
	    "the class of an object must be a class");
    if (clsPtr == NULL) {
	return TCL_ERROR;
    }
    if (oPtr == clsPtr->thisPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not change classes into an instance of themselves", -1));

	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    /*
     * Set the object's class.
     */

{
    static const char *kindList[] = {
	"-class",
	"-instance",
	NULL
    };
    int kind = 0;
    Object *oPtr;
    Tcl_Namespace *nsPtr;
    Tcl_Obj *nsNamePtr, **storagePtr;

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }
    if (oPtr->flags & (ROOT_OBJECT | ROOT_CLASS)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not modify the definition namespace of the root classes",
		-1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    /*
     * Parse the arguments and work out what the user wants to do.
     */

    if (!TclGetString(objv[objc - 1])[0]) {
	nsNamePtr = NULL;
    } else {
	nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]);
	if (nsPtr == NULL) {
	    return TCL_ERROR;
	}
	nsNamePtr = Tcl_NewStringObj(nsPtr->fullName, -1);
	Tcl_IncrRefCount(nsNamePtr);
    }

    /*
     * Update the correct field of the class definition.
     */

    if (kind) {
	storagePtr = &oPtr->classPtr->objDefinitionNs;
    } else {
	storagePtr = &oPtr->classPtr->clsDefinitionNs;
    }
    if (*storagePtr != NULL) {
	Tcl_DecrRefCount(*storagePtr);
    }
    *storagePtr = nsNamePtr;
    return TCL_OK;
}

    }

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (!isInstanceDeleteMethod && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {
	/*
	 * Delete the method structure from the appropriate hash table.
	 */

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    clsPtr = oPtr->classPtr;
    if (!isInstanceExport && !clsPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {
	/*
	 * Exporting is done by adding the PUBLIC_METHOD flag to the method
	 * record. If there is no such method in this object or class (i.e.

    }

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (!isInstanceForward && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }
    isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
	    ? PUBLIC_METHOD : 0;
    if (IsPrivateDefine(interp)) {
	isPublic = TRUE_PRIVATE_METHOD;
    }

    }

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (!isInstanceMethod && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }
    if (objc == 5) {
	if (Tcl_GetIndexFromObj(interp, objv[2], exportModes, "export flag",
		0, &exportMode) != TCL_OK) {
	    return TCL_ERROR;
	}

    }

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (!isInstanceRenameMethod && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    /*
     * Delete the method entry from the appropriate hash table, and transfer
     * the thing it points to to its new entry. To do this, we first need to
     * get the entries from the appropriate hash tables (this can generate a

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    clsPtr = oPtr->classPtr;
    if (!isInstanceUnexport && !clsPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {
	/*
	 * Unexporting is done by removing the PUBLIC_METHOD flag from the
	 * method record. If there is no such method in this object or class

 */

int
TclOODefineSlots(
    Foundation *fPtr)
{
    const struct DeclaredSlot *slotInfoPtr;
    Tcl_Obj *getName = Tcl_NewStringObj("Get", -1);
    Tcl_Obj *setName = Tcl_NewStringObj("Set", -1);
    Tcl_Obj *resolveName = Tcl_NewStringObj("Resolve", -1);
    Class *slotCls;

    slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class)
	    fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0))->classPtr;
    if (slotCls == NULL) {
	return TCL_ERROR;
    }

ClassFilterGet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *filterObj;
    Tcl_Size i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    FOREACH(filterObj, oPtr->classPtr->filters) {
	Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ClassFilterSet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Size filterc;
    Tcl_Obj **filterv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    } else if (TclListObjGetElements(interp, objv[0], &filterc,
	    &filterv) != TCL_OK) {
	return TCL_ERROR;
    }

    TclOOClassSetFilters(interp, oPtr->classPtr, filterc, filterv);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * ClassMixinGet, ClassMixinSet --

ClassMixinGet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    Class *mixinPtr;
    Tcl_Size i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    FOREACH(mixinPtr, oPtr->classPtr->mixins) {
	Tcl_ListObjAppendElement(NULL, resultObj,
		TclOOObjectName(interp, mixinPtr->thisPtr));
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;

}

static int
ClassMixinSet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Size mixinc, i;
    Tcl_Obj **mixinv;
    Class **mixins;		/* The references to the classes to actually
				 * install. */
    Tcl_HashTable uniqueCheck;	/* Note that this hash table is just used as a
				 * set of class references; it has no payload
				 * values and keys are always pointers. */
    int isNew;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"mixinList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    } else if (TclListObjGetElements(interp, objv[0], &mixinc,
	    &mixinv) != TCL_OK) {
	return TCL_ERROR;
    }

    mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);
    Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS);

    for (i = 0; i < mixinc; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (mixins[i] == NULL) {
	    i--;
	    goto freeAndError;
	}
	(void) Tcl_CreateHashEntry(&uniqueCheck, (void *) mixins[i], &isNew);
	if (!isNew) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "class should only be a direct mixin once", -1));

	    Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", (char *)NULL);
	    goto freeAndError;
	}
	if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "may not mix a class into itself", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", (char *)NULL);
	    goto freeAndError;
	}
    }

    TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
    Tcl_DeleteHashTable(&uniqueCheck);
    TclStackFree(interp, mixins);
    return TCL_OK;

  freeAndError:
    Tcl_DeleteHashTable(&uniqueCheck);
    TclStackFree(interp, mixins);

ClassSuperGet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    Class *superPtr;
    Tcl_Size i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    FOREACH(superPtr, oPtr->classPtr->superclasses) {
	Tcl_ListObjAppendElement(NULL, resultObj,
		TclOOObjectName(interp, superPtr->thisPtr));
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ClassSuperSet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Size superc, j;
    Tcl_Size i;
    Tcl_Obj **superv;
    Class **superclasses, *superPtr;


    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"superclassList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    } else if (oPtr == oPtr->fPtr->objectCls->thisPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not modify the superclass of the root object", -1));

	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    } else if (TclListObjGetElements(interp, objv[0], &superc,
	    &superv) != TCL_OK) {
	return TCL_ERROR;
    }

     *
     * Note that zero classes is special, as it is equivalent to just the
     * class of objects. [Bug 9d61624b3d]
     */

    if (superc == 0) {
	superclasses = (Class **)Tcl_Realloc(superclasses, sizeof(Class *));
	if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) {
	    superclasses[0] = oPtr->fPtr->classCls;
	} else {
	    superclasses[0] = oPtr->fPtr->objectCls;
	}
	superc = 1;
	AddRef(superclasses[0]->thisPtr);
    } else {
	for (i = 0; i < superc; i++) {
	    superclasses[i] = GetClassInOuterContext(interp, superv[i],
		    "only a class can be a superclass");
	    if (superclasses[i] == NULL) {
		goto failedAfterAlloc;
	    }
	    for (j = 0; j < i; j++) {
		if (superclasses[j] == superclasses[i]) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "class should only be a direct superclass once",
			    -1));
		    Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",(char *)NULL);
		    goto failedAfterAlloc;
		}
	    }
	    if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"attempt to form circular dependency graph", -1));

		Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", (char *)NULL);
	    failedAfterAlloc:
		for (; i-- > 0 ;) {
		    TclOODecrRefCount(superclasses[i]->thisPtr);
		}
		Tcl_Free(superclasses);
		return TCL_ERROR;

    /*
     * Install the list of superclasses into the class. Note that this also
     * involves splicing the class out of the superclasses' subclass list that
     * it used to be a member of and splicing it into the new superclasses'
     * subclass list.
     */

    if (oPtr->classPtr->superclasses.num != 0) {
	FOREACH(superPtr, oPtr->classPtr->superclasses) {
	    TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
	    TclOODecrRefCount(superPtr->thisPtr);
	}
	Tcl_Free(oPtr->classPtr->superclasses.list);
    }
    oPtr->classPtr->superclasses.list = superclasses;
    oPtr->classPtr->superclasses.num = superc;
    FOREACH(superPtr, oPtr->classPtr->superclasses) {
	TclOOAddToSubclasses(oPtr->classPtr, superPtr);
    }
    BumpGlobalEpoch(interp, oPtr->classPtr);

    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *

ClassVarsGet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    Tcl_Size i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    if (IsPrivateDefine(interp)) {
	PrivateVariableMapping *privatePtr;

	FOREACH_STRUCT(privatePtr, oPtr->classPtr->privateVariables) {
	    Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
	}
    } else {
	Tcl_Obj *variableObj;

	FOREACH(variableObj, oPtr->classPtr->variables) {
	    Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
	}
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ClassVarsSet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Size i;
    Tcl_Size varc;
    Tcl_Obj **varv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    } else if (TclListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    for (i = 0; i < varc; i++) {

		    varName, "refer to an array element"));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", (char *)NULL);
	    return TCL_ERROR;
	}
    }

    if (IsPrivateDefine(interp)) {
	InstallPrivateVariableMapping(&oPtr->classPtr->privateVariables,
		varc, varv, oPtr->classPtr->thisPtr->creationEpoch);
    } else {
	InstallStandardVariableMapping(&oPtr->classPtr->variables, varc, varv);
    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *

		"may only mix in classes");
	if (mixins[i] == NULL) {
	    goto freeAndError;
	}
	(void) Tcl_CreateHashEntry(&uniqueCheck, (void *) mixins[i], &isNew);
	if (!isNew) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "class should only be a direct mixin once", -1));

	    Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", (char *)NULL);
	    goto freeAndError;
	}
    }

    TclOOObjectSetMixins(oPtr, mixinc, mixins);
    TclStackFree(interp, mixins);

ClassRPropsGet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *propNameObj;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    FOREACH(propNameObj, oPtr->classPtr->properties.readable) {
	Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ClassRPropsSet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Size varc;
    Tcl_Obj **varv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    InstallReadableProps(&oPtr->classPtr->properties, varc, varv);
    BumpGlobalEpoch(interp, oPtr->classPtr);
    return TCL_OK;
}

static int
ObjRPropsGet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,

ClassWPropsGet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *propNameObj;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    FOREACH(propNameObj, oPtr->classPtr->properties.writable) {
	Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ClassWPropsSet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Size varc;
    Tcl_Obj **varv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"propertyList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    InstallWritableProps(&oPtr->classPtr->properties, varc, varv);
    BumpGlobalEpoch(interp, oPtr->classPtr);
    return TCL_OK;
}

static int
ObjWPropsGet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,

    /*
     * Install into the [info] ensemble.
     */

    infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
    if (infoCmd) {
	Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict);
	Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1),

		Tcl_NewStringObj("::oo::InfoObject", -1));
	Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("class", -1),

		Tcl_NewStringObj("::oo::InfoClass", -1));
	Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict);
    }
}

/*
 * ----------------------------------------------------------------------
 *

	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[2]), (char *)NULL);
	return TCL_ERROR;
    }
    procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
    if (procPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"definition not available for this kind of method", -1));

	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[2]), (char *)NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObjs[0]);
    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
	    localPtr=localPtr->nextPtr) {
	if (TclIsVarArgument(localPtr)) {
	    Tcl_Obj *argObj;

	    TclNewObj(argObj);
	    Tcl_ListObjAppendElement(NULL, argObj,
		    Tcl_NewStringObj(localPtr->name, -1));
	    if (localPtr->defValuePtr != NULL) {
		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
	    }
	    Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
	}
    }
    resultObjs[1] = TclOOGetMethodBody((Method *)Tcl_GetHashValue(hPtr));

		TclGetString(objv[2]), (char *)NULL);
	return TCL_ERROR;
    }
    prefixObj = TclOOGetFwdFromMethod((Method *)Tcl_GetHashValue(hPtr));
    if (prefixObj == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"prefix argument list not available for this kind of method",
		-1));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[2]), (char *)NULL);
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, prefixObj);
    return TCL_OK;

    if (recurse) {
	const char **names;
	int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag,
		&names);

	for (i=0 ; i<numNames ; i++) {
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(names[i], -1));
	}
	if (numNames > 0) {
	    Tcl_Free((void *)names);
	}
    } else if (oPtr->methodsPtr) {
	FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
	    if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {

	 * Special entry for visibility control: pretend the method doesnt
	 * exist.
	 */

	goto unknownMethod;
    }

    Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, -1));

    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * InfoObjectMixinsCmd --

	return TCL_ERROR;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp,
	    Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1));
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * InfoObjectVariablesCmd --

    }
    if (clsPtr->constructorPtr == NULL) {
	return TCL_OK;
    }
    procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr);
    if (procPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"definition not available for this kind of method", -1));

	Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", (char *)NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObjs[0]);
    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
	    localPtr=localPtr->nextPtr) {
	if (TclIsVarArgument(localPtr)) {
	    Tcl_Obj *argObj;

	    TclNewObj(argObj);
	    Tcl_ListObjAppendElement(NULL, argObj,
		    Tcl_NewStringObj(localPtr->name, -1));
	    if (localPtr->defValuePtr != NULL) {
		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
	    }
	    Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
	}
    }
    resultObjs[1] = TclOOGetMethodBody(clsPtr->constructorPtr);

	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[2]), (char *)NULL);
	return TCL_ERROR;
    }
    procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
    if (procPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"definition not available for this kind of method", -1));

	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[2]), (char *)NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObjs[0]);
    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
	    localPtr=localPtr->nextPtr) {
	if (TclIsVarArgument(localPtr)) {
	    Tcl_Obj *argObj;

	    TclNewObj(argObj);
	    Tcl_ListObjAppendElement(NULL, argObj,
		    Tcl_NewStringObj(localPtr->name, -1));
	    if (localPtr->defValuePtr != NULL) {
		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
	    }
	    Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
	}
    }
    resultObjs[1] = TclOOGetMethodBody((Method *)Tcl_GetHashValue(hPtr));

    if (clsPtr->destructorPtr == NULL) {
	return TCL_OK;
    }
    procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr);
    if (procPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"definition not available for this kind of method", -1));

	Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", (char *)NULL);
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, TclOOGetMethodBody(clsPtr->destructorPtr));
    return TCL_OK;
}

		TclGetString(objv[2]), (char *)NULL);
	return TCL_ERROR;
    }
    prefixObj = TclOOGetFwdFromMethod((Method *)Tcl_GetHashValue(hPtr));
    if (prefixObj == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"prefix argument list not available for this kind of method",
		-1));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[2]), (char *)NULL);
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, prefixObj);
    return TCL_OK;

    TclNewObj(resultObj);
    if (recurse) {
	const char **names;
	Tcl_Size i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names);

	for (i=0 ; i<numNames ; i++) {
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(names[i], -1));
	}
	if (numNames > 0) {
	    Tcl_Free((void *)names);
	}
    } else {
	FOREACH_HASH_DECLS;

	/*
	 * Special entry for visibility control: pretend the method doesnt
	 * exist.
	 */

	goto unknownMethod;
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, -1));

    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * InfoClassMixinsCmd --

     * Get the call context and render its call chain.
     */

    contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL,
	    NULL);
    if (contextPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"cannot construct any call chain", -1));
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp,
	    TclOORenderCallChain(interp, contextPtr->callPtr));
    TclOODeleteContext(contextPtr);
    return TCL_OK;
}

    /*
     * Get an render the stereotypical call chain.
     */

    callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD);
    if (callPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"cannot construct any call chain", -1));
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr));
    TclOODeleteChain(callPtr);
    return TCL_OK;
}


}

/*
 * ----------------------------------------------------------------------
 *
 * SortPropList --
 *	Sort a list of names of properties. Simple support function. Assumes
 *	that the list Tcl_Obj is unshared and doesn't have a string
 *	representation.
 *
 * ----------------------------------------------------------------------
 */

static int
PropNameCompare(
    const void *a,

static void
SortPropList(
    Tcl_Obj *list)
{
    Tcl_Size ec;
    Tcl_Obj **ev;

    Tcl_ListObjGetElements(NULL, list, &ec, &ev);
    qsort(ev, ec, sizeof(Tcl_Obj *), PropNameCompare);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

				/* Callback to allow for additional cleanup
				 * after the method executes. */
    GetFrameInfoValueProc *gfivProc;
				/* Callback to allow for fine tuning of how
				 * the method reports itself. */
} ProcedureMethod;


#define TCLOO_PROCEDURE_METHOD_VERSION 0


/*
 * Flags for use in a ProcedureMethod.
 *
 * When the USE_DECLARER_NS flag is set, the method will use the namespace of
 * the object or class that declared it (or the clone of it, if it was from
 * such that the implementation of the method came to the particular use)
 * instead of the namespace of the object on which the method was invoked.
 * This flag must be distinct from all others that are associated with
 * methods.
 */

#define USE_DECLARER_NS		0x80


/*
 * Forwarded methods have the following extra information.
 */

typedef struct ForwardMethod {
    Tcl_Obj *prefixObj;		/* The list of values to use to replace the

				 * for everything else. It points to the class
				 * structure. */
    Tcl_Size refCount;		/* Number of strong references to this object.
				 * Note that there may be many more weak
				 * references; this mechanism exists to
				 * avoid Tcl_Preserve. */
    int flags;
    Tcl_Size creationEpoch;		/* Unique value to make comparisons of objects
				 * easier. */
    Tcl_Size epoch;			/* Per-object epoch, incremented when the way
				 * an object should resolve call chains is
				 * changed. */
    Tcl_HashTable *metadataPtr;	/* Mapping from pointers to metadata type to
				 * the void *values that are the values
				 * of each piece of attached metadata. This
				 * field starts out as NULL and is only
				 * allocated if metadata is attached. */

    Tcl_Command myclassCommand;	/* Reference to this object's class dispatcher
				 * command. */
    PropertyStorage properties;	/* Information relating to the lists of
				 * properties that this object *claims* to
				 * support. */
} Object;


#define OBJECT_DESTRUCTING 1	/* Indicates that an object is being or has
				 *  been destroyed  */
#define DESTRUCTOR_CALLED 2	/* Indicates that evaluation of destructor
				 * script for the object has began */
#define OO_UNUSED_4	4	/* No longer used.  */
#define ROOT_OBJECT 0x1000	/* Flag to say that this object is the root of
				 * the class hierarchy and should be treated
				 * specially during teardown. */
#define FILTER_HANDLING 0x2000	/* Flag set when the object is processing a
				 * filter; when set, filters are *not*
				 * processed on the object, preventing nasty
				 * recursive filtering problems. */
#define USE_CLASS_CACHE 0x4000	/* Flag set to say that the object is a pure
				 * instance of the class, and has had nothing
				 * added that changes the dispatch chain (i.e.
				 * no methods, mixins, or filters. */
#define ROOT_CLASS 0x8000	/* Flag to say that this object is the root
				 * class of classes, and should be treated
				 * specially during teardown (and in a few
				 * other spots). */
#define FORCE_UNKNOWN 0x10000	/* States that we are *really* looking up the
				 * unknown method handler at that point. */
#define DONT_DELETE 0x20000	/* Inhibit deletion of this object. Used
				 * during fundamental object type mutation to
				 * make sure that the object actually survives
				 * to the end of the operation. */
#define HAS_PRIVATE_METHODS 0x40000
				/* Object/class has (or had) private methods,
				 * and so shouldn't be cached so
				 * aggressively. */


/*
 * And the definition of a class. Note that every class also has an associated
 * object, through which it is manipulated.
 */

typedef struct Class {