Tcl Source Code

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)

    TclBounceRefCount(objPtr);

static inline void
TclBounceRefCount(
    Tcl_Obj* objPtr)
{
    if (objPtr) {
        if ((objPtr)->refCount == 0) {
            Tcl_DecrRefCount(objPtr);
	}
    }
}

#endif

/*

				 * name. */
    void *clientData,		/* Arbitrary value to pass to object
				 * function. */
    Tcl_CmdDeleteProc *deleteProc)
				/* If not NULL, gives a function to call when
				 * this command is deleted. */
{
    Interp *iPtr = (Interp *) interp;
    Namespace *nsPtr;
    const char *tail;

    if (iPtr->flags & DELETED) {
	/*
	 * The interpreter is being deleted. Don't create any new commands;
	 * it's not safe to muck with the interpreter anymore.
	 */
	return (Tcl_Command) NULL;
    }

    /*
     * Determine where the command should reside. If its name contains
     * namespace qualifiers, we put it in the specified namespace;
     * otherwise, we always put it in the global namespace.
     */

    unsigned char bytes[TCLFLEXARRAY];	/* The array of bytes. The actual size of this
				 * field depends on the 'allocated' field
				 * above. */
} ByteArray;

#define BYTEARRAY_MAX_LEN (TCL_SIZE_MAX - (Tcl_Size)offsetof(ByteArray, bytes))
#define BYTEARRAY_SIZE(len) \
        ( (len < 0 || BYTEARRAY_MAX_LEN < (len)) \
	? (Tcl_Panic("negative length specified or max size of a Tcl value exceeded"), 0) \
	: (offsetof(ByteArray, bytes) + (len)) )
#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1)
#define SET_BYTEARRAY(irPtr, baPtr) \
		(irPtr)->twoPtrValue.ptr1 = (baPtr)

int

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

unsigned char *
Tcl_SetByteArrayLength(
    Tcl_Obj *objPtr,		/* The ByteArray object. */
    Tcl_Size numBytes)		/* Number of bytes in resized array
                                 * Must be >= 0 */
{
    ByteArray *byteArrayPtr;
    Tcl_ObjInternalRep *irPtr;

    assert(numBytes >= 0);
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength");

TclDumpMemoryInfo(
    void *clientData,
    int flags)
{
    char buf[1024];

    if (clientData == NULL) {
        return 0;
    }
    snprintf(buf, sizeof(buf),
	    "total mallocs             %10" TCL_Z_MODIFIER "u\n"
	    "total frees               %10" TCL_Z_MODIFIER "u\n"
	    "current packets allocated %10" TCL_Z_MODIFIER "u\n"
	    "current bytes allocated   %10" TCL_Z_MODIFIER "u\n"
	    "maximum packets allocated %10" TCL_Z_MODIFIER "u\n"

	if (fileName == NULL) {
	    return TCL_ERROR;
	}
	result = Tcl_DumpActiveMemory(fileName);
	Tcl_DStringFree(&buffer);
	if (result != TCL_OK) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s",
                    TclGetString(objv[2]), Tcl_PosixError(interp)));
	    return TCL_ERROR;
	}
	return TCL_OK;
    }
    if (strcmp(TclGetString(objv[1]),"break_on_malloc") == 0) {
	Tcl_WideInt value;
	if (objc != 3) {

	fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer);
	if (fileName == NULL) {
	    return TCL_ERROR;
	}
	fileP = fopen(fileName, "w");
	if (fileP == NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "cannot open output file: %s",
                    Tcl_PosixError(interp)));
	    return TCL_ERROR;
	}
	TclDbDumpActiveObjects(fileP);
	fclose(fileP);
	Tcl_DStringFree(&buffer);
	return TCL_OK;
    }

	    goto bad_suboption;
	}
	validate_memory = (strcmp(TclGetString(objv[2]),"on") == 0);
	return TCL_OK;
    }

    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
            "bad option \"%s\": should be active, break_on_malloc, info, "
            "init, objs, onexit, tag, trace, trace_on_at_malloc, or validate",
            TclGetString(objv[1])));
    return TCL_ERROR;

  argError:
    Tcl_WrongNumArgs(interp, 2, objv, "count");
    return TCL_ERROR;

  bad_suboption:

    Tcl_Obj *field, *value, *result;
    unsigned short mode;

    if (varName == NULL) {
	TclNewObj(result);
	Tcl_IncrRefCount(result);
#define DOBJPUT(key, objValue)                  \
        Tcl_DictObjPut(NULL, result,            \
            Tcl_NewStringObj((key), -1),        \
            (objValue));
	DOBJPUT("dev",	Tcl_NewWideIntObj((long)statPtr->st_dev));
	DOBJPUT("ino",	Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
	DOBJPUT("nlink",	Tcl_NewWideIntObj((long)statPtr->st_nlink));
	DOBJPUT("uid",	Tcl_NewWideIntObj((long)statPtr->st_uid));
	DOBJPUT("gid",	Tcl_NewWideIntObj((long)statPtr->st_gid));
	DOBJPUT("size",	Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS

	    &localIndex, &isScalar, 1);

    /*
     * If the user specified an array element, we don't bother handling
     * that.
     */
    if (!isScalar) {
        return TCL_ERROR;
    }

    /*
     * We are doing an assignment to set the value of the constant. This will
     * need to be extended to push a value for each argument.
     */

TclLocalScalar(
    const char *bytes,
    size_t numBytes,
    CompileEnv *envPtr)
{
    Tcl_Token token[2] = {
	{TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1},
        {TCL_TOKEN_TEXT, NULL, 0, 0}
    };

    token[1].start = bytes;
    token[1].size = numBytes;
    return TclLocalScalarFromToken(token, envPtr);
}


    UpdateStringOfDict,		/* updateStringProc */
    SetDictFromAny,		/* setFromAnyProc */
    TCL_OBJTYPE_V0
};

#define DictSetInternalRep(objPtr, dictRepPtr)				\
    do {                                                                \
        Tcl_ObjInternalRep ir;						\
        ir.twoPtrValue.ptr1 = (dictRepPtr);                             \
        ir.twoPtrValue.ptr2 = NULL;                                     \
        Tcl_StoreInternalRep((objPtr), &tclDictType, &ir);		\
    } while (0)

#define DictGetInternalRep(objPtr, dictRepPtr)				\
    do {                                                                \
        const Tcl_ObjInternalRep *irPtr;				\
        irPtr = TclFetchInternalRep((objPtr), &tclDictType);		\
        (dictRepPtr) = irPtr ? (Dict *)irPtr->twoPtrValue.ptr1 : NULL;	\
    } while (0)

/*
 * The type of the specially adapted version of the Tcl_Obj*-containing hash
 * table defined in the tclObj.c code. This version differs in that it
 * allocates a bit more space in each hash entry in order to hold the pointers
 * used to keep the hash entries in a linked list.

    Tcl_Obj *splitPtr;
    Tcl_Obj *resultPtr = NULL;

    splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
    Tcl_IncrRefCount(splitPtr);

    if (objc != 0) {
        /*
         * Return the last component, unless it is the only component, and it
	 * is the root of an absolute path.
	 */

	if (objc > 0) {
	    Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr);
	    if ((objc == 1) &&
		    (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) {

    Tcl_Obj **driveNameRef)
{
    Tcl_PathType type = TCL_PATH_ABSOLUTE;
    const char *path = TclGetString(pathPtr);

    switch (tclPlatform) {
    case TCL_PLATFORM_UNIX: {
        const char *origPath = path;

        /*
         * Paths that begin with / are absolute.
         */

        if (path[0] == '/') {
            ++path;
            /*
             * Check for "//" network path prefix
             */
            if ((*path == '/') && path[1] && (path[1] != '/')) {
                path += 2;
                while (*path && *path != '/') {
                    ++path;
                }
            }
            if (driveNameLengthPtr != NULL) {
                /*
                 * We need this addition in case the "//" code was used.
                 */

                *driveNameLengthPtr = (path - origPath);
            }
        } else {
            type = TCL_PATH_RELATIVE;
        }
        break;
    }
    case TCL_PLATFORM_WINDOWS: {
        Tcl_DString ds;
        const char *rootEnd;

        Tcl_DStringInit(&ds);
        rootEnd = ExtractWinRoot(path, &ds, 0, &type);
        if ((rootEnd != path) && (driveNameLengthPtr != NULL)) {
            *driveNameLengthPtr = rootEnd - path;
            if (driveNameRef != NULL) {
                *driveNameRef = Tcl_DStringToObj(&ds);
                Tcl_IncrRefCount(*driveNameRef);
            }
        }
        Tcl_DStringFree(&ds);
        break;
    }
    }
    return type;
}

/*
 *---------------------------------------------------------------------------

	elementStart = path;
	while ((*path != '\0') && (*path != '/')) {
	    path++;
	}
	length = path - elementStart;
	if (length > 0) {
	    Tcl_Obj *nextElt;
            nextElt = Tcl_NewStringObj(elementStart, length);
            Tcl_ListObjAppendElement(NULL, result, nextElt);
	}
	if (*path++ == '\0') {
	    break;
	}
    }
    return result;
}

    /*
     * Verify the result.
     * - List, of method names. Convert to mask. Check for non-optionals
     *   through the mask. Compare open mode against optional r/w.
     */

    if (TclListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "chan handler \"%s initialize\" returned non-list: %s",
                TclGetString(cmdObj), TclGetString(resObj)));
	Tcl_DecrRefCount(resObj);
	goto error;
    }

    methods = 0;
    while (listc > 0) {
	if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames,

	methods |= FLAG(methIndex);
	listc--;
    }
    Tcl_DecrRefCount(resObj);

    if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "chan handler \"%s\" does not support all required methods",
                TclGetString(cmdObj)));
	goto error;
    }

    /*
     * Mode tell us what the parent channel supports. The methods tell us what
     * the handler supports. We remove the non-supported bits from the mode
     * and check that the channel is not completely inaccessible. Afterward the
     * mode tells us which methods are still required, and these methods will
     * also be supported by the handler, by design of the check.
     */

    if (!HAS(methods, METH_READ)) {
	mode &= ~TCL_READABLE;
    }
    if (!HAS(methods, METH_WRITE)) {
	mode &= ~TCL_WRITABLE;
    }

    if (!mode) {
        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "chan handler \"%s\" makes the channel inaccessible",
                TclGetString(cmdObj)));
	goto error;
    }

    /*
     * The mode and support for it is ok, now check the internal constraints.
     */

    if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) {
        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "chan handler \"%s\" supports \"drain\" but not \"read\"",
                TclGetString(cmdObj)));
	goto error;
    }

    if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) {
        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "chan handler \"%s\" supports \"flush\" but not \"write\"",
                TclGetString(cmdObj)));
	goto error;
    }

    Tcl_ResetResult(interp);

    /*
     * Everything is fine now.

    if (result != 0) {
	*errorMsgPtr =
#ifdef EAI_SYSTEM	/* Doesn't exist on Windows */
		(result == EAI_SYSTEM) ? Tcl_PosixError(interp) :
#endif /* EAI_SYSTEM */
		gai_strerror(result);
        return 0;
    }

    /*
     * Put IPv4 addresses before IPv6 addresses to maximize backwards
     * compatibility of [fconfigure -sockname] output.
     *
     * There might be more elegant/efficient ways to do this.

#define uenum_count      icu_fns._uenum_count


TCL_DECLARE_MUTEX(icu_mutex);

static int FunctionNotAvailableError(Tcl_Interp *interp) {
    if (interp) {

	Tcl_SetResult(interp, "ICU function not available", TCL_STATIC);
    }
    return TCL_ERROR;
}

static int IcuError(Tcl_Interp *interp, const char *message, UErrorCodex code)
{
    if (interp) {

	} else {
	    int i;
	    Tcl_Obj *resultObj = Tcl_NewListObj(0, NULL);
	    for (i = 0; i < count; ++i) {
		const char *name;
		int32_t len;
		name = uenum_next(enumerator, &len, &status);
                if (name == NULL || U_FAILURE(status)) {
		    name = "unknown";
		    len = 7;
		    status = U_ZERO_ERRORZ; /* Reset on error */
		}
		Tcl_ListObjAppendElement(
		    interp, resultObj, Tcl_NewStringObj(name, len));
	    }

    if (objc == 1) {
	return DetectableEncodings(interp);
    }

    int all = 0;
    if (objc == 3) {
        if (strcmp("-all", Tcl_GetString(objv[2]))) {
	    Tcl_SetObjResult(
		interp,
		Tcl_ObjPrintf("Invalid option %s, must be \"-all\"",
			      Tcl_GetString(objv[2])));
	    return TCL_ERROR;
	}
	all = 1;

    if (count <= 0) {
	return TCL_OK;
    }
    Tcl_Obj *resultObj = Tcl_NewListObj(count, NULL);
    int32_t i;
    for (i = 0; i < count; ++i) {
	const char *name = ucnv_getAvailableName(i);
        if (name) {
	    Tcl_ListObjAppendElement(
		NULL, resultObj, Tcl_NewStringObj(name, -1));
	}
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

    }
    if (count <= 0) {
	return TCL_OK;
    }
    Tcl_Obj *resultObj = Tcl_NewListObj(count, NULL);
    uint16_t i;
    for (i = 0; i < count; ++i) {
        status = U_ZERO_ERRORZ; /* Reset in case U_AMBIGUOUS_ALIAS_WARNING */
	const char *aliasName = ucnv_getAlias(name, i, &status);
        if (status != U_AMBIGUOUS_ALIAS_WARNING && U_FAILURE(status)) {
	    status = U_ZERO_ERRORZ; /* Reset error for next iteration */
	    continue;
	}
	if (aliasName) {
	    Tcl_ListObjAppendElement(
		NULL, resultObj, Tcl_NewStringObj(aliasName, -1));
	}
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static void
TclIcuCleanup(
    TCL_UNUSED(void *))
{
    Tcl_MutexLock(&icu_mutex);
    if (icu_fns.nopen-- <= 1) {
        int i;
        if (u_cleanup != NULL) {
	    u_cleanup();
	}
	for (i = 0; i < (int)(sizeof(icu_fns.libs) / sizeof(icu_fns.libs[0]));
	     ++i) {
	    if (icu_fns.libs[i] != NULL) {
                Tcl_FSUnloadFile(NULL, icu_fns.libs[i]);
            }
	}
	memset(&icu_fns, 0, sizeof(icu_fns));
    }
    Tcl_MutexUnlock(&icu_mutex);
}

static void

		    break;
		}
		Tcl_DecrRefCount(nameobj);
		++i;
	    }
	}
	if (icu_fns.libs[0] != NULL) {
            /* Loaded icuuc, load others with the same version */
            nameobj = Tcl_ObjPrintf(DLLNAME, "i18n", icuversion+1);
            Tcl_IncrRefCount(nameobj);
            /* Ignore errors. Calls to contained functions will fail. */
            (void) Tcl_LoadFile(interp, nameobj, NULL, 0, NULL, &icu_fns.libs[1]);
            Tcl_DecrRefCount(nameobj);
        }
#if defined(_WIN32)
        /*
         * On Windows, if no ICU install found, look for the system's
         * (Win10 1703 or later). There are two cases. Newer systems
         * have icu.dll containing all functions. Older systems have
         * icucc.dll and icuin.dll
         */
	if (icu_fns.libs[0] == NULL) {
	    Tcl_ResetResult(interp);
		nameobj = Tcl_NewStringObj("icu.dll", TCL_INDEX_NONE);
		Tcl_IncrRefCount(nameobj);
		if (Tcl_LoadFile(interp, nameobj, NULL, 0, NULL, &icu_fns.libs[0])
			== TCL_OK) {
                    /* Reload same for second set of functions. */
                    (void) Tcl_LoadFile(interp, nameobj, NULL, 0, NULL, &icu_fns.libs[1]);
                    /* Functions do NOT have version suffixes */
		    icuversion[0] = '\0';
		}
		Tcl_DecrRefCount(nameobj);
	}
	if (icu_fns.libs[0] == NULL) {
            /* No icu.dll. Try last fallback */
            Tcl_ResetResult(interp);
            nameobj = Tcl_NewStringObj("icuuc.dll", TCL_INDEX_NONE);
            Tcl_IncrRefCount(nameobj);
            if (Tcl_LoadFile(interp, nameobj, NULL, 0, NULL, &icu_fns.libs[0])
                == TCL_OK) {
                Tcl_DecrRefCount(nameobj);
                nameobj = Tcl_NewStringObj("icuin.dll", TCL_INDEX_NONE);
                Tcl_IncrRefCount(nameobj);
                (void) Tcl_LoadFile(interp, nameobj, NULL, 0, NULL, &icu_fns.libs[1]);
                /* Functions do NOT have version suffixes */
                icuversion[0] = '\0';
            }
            Tcl_DecrRefCount(nameobj);
	}
#endif

#define ICUUC_SYM(name)                                         \
        strcpy(symbol, #name );                                 \
        strcat(symbol, icuversion);                             \
        icu_fns._##name = (fn_ ## name)                         \
            Tcl_FindSymbol(NULL, icu_fns.libs[0], symbol)
        if (icu_fns.libs[0] != NULL) {
	    ICUUC_SYM(u_cleanup);
	    ICUUC_SYM(u_errorName);

	    ICUUC_SYM(ucnv_countAliases);
	    ICUUC_SYM(ucnv_countAvailable);
	    ICUUC_SYM(ucnv_getAlias);
	    ICUUC_SYM(ucnv_getAvailableName);
 
	    ICUUC_SYM(ubrk_open);
	    ICUUC_SYM(ubrk_close);
	    ICUUC_SYM(ubrk_preceding);
	    ICUUC_SYM(ubrk_following);
	    ICUUC_SYM(ubrk_previous);
	    ICUUC_SYM(ubrk_next);
	    ICUUC_SYM(ubrk_setText);

	    ICUUC_SYM(uenum_close);
	    ICUUC_SYM(uenum_count);
	    ICUUC_SYM(uenum_next);

#undef ICUUC_SYM
	}

#define ICUIN_SYM(name)                                         \
        strcpy(symbol, #name );                                 \
        strcat(symbol, icuversion);                             \
        icu_fns._##name = (fn_ ## name)                         \
            Tcl_FindSymbol(NULL, icu_fns.libs[1], symbol)
        if (icu_fns.libs[1] != NULL) {
            ICUIN_SYM(ucsdet_close);
            ICUIN_SYM(ucsdet_detect);
            ICUIN_SYM(ucsdet_detectAll);
            ICUIN_SYM(ucsdet_getName);
            ICUIN_SYM(ucsdet_getAllDetectableCharsets);
            ICUIN_SYM(ucsdet_open);
            ICUIN_SYM(ucsdet_setText);
#undef ICUIN_SYM
        }

    }
#undef ICU_SYM

    Tcl_MutexUnlock(&icu_mutex);

    if (icu_fns.libs[0] != NULL) {
        /*
         * Note refcounts updated BEFORE command definition to protect
         * against self redefinition.
         */
	if (icu_fns.libs[1] != NULL) {
            /* Commands needing both libraries */

	    /* Ref count number of commands */
	    icu_fns.nopen += 1;
	    Tcl_CreateObjCommand(interp,
				 "::tcl::unsupported::icu::detect",
				 IcuDetectObjCmd,
				 0,

	    /* ...the index we're trying to use isn't an index at all. */
	    result = TCL_ERROR;
	    indexArray++; /* Why bother with this increment? TBD */
	    break;
	}
	indexArray++;

        /*
         * Special case 0-length lists. The Tcl indexing function treat
         * will return any value beyond length as TCL_SIZE_MAX for this
         * case.
         */
	if ((index == TCL_SIZE_MAX) && (elemCount == 0)) {
	    index = 0;
	}
	if (index < 0 || index > elemCount
		|| (valueObj == NULL && index >= elemCount)) {
	    /* ...the index points outside the sublist. */
	    if (interp != NULL) {

    tracePtr->nextPtr = NULL;
    tracePtr->refCount = 1;

    oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr,
	    TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
    oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass",
	    oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr,
            MyClassDeleted);
    return oPtr;
}

/*
 * ----------------------------------------------------------------------
 *
 * SquelchCachedName --

MODULE_SCOPE void	TclOOAddToInstances(Object *oPtr, Class *clsPtr);
MODULE_SCOPE void	TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);
MODULE_SCOPE void	TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
MODULE_SCOPE Class *	TclOOAllocClass(Tcl_Interp *interp,
			    Object *useThisObj);
MODULE_SCOPE int    TclMethodIsType(Tcl_Method method,
                        const Tcl_MethodType *typePtr,
                        void **clientDataPtr);
MODULE_SCOPE Tcl_Method TclNewInstanceMethod(Tcl_Interp *interp,
                        Tcl_Object object, Tcl_Obj *nameObj,
                        int flags, const Tcl_MethodType *typePtr,
                        void *clientData);
MODULE_SCOPE Tcl_Method TclNewMethod(Tcl_Interp *interp, Tcl_Class cls,
                        Tcl_Obj *nameObj, int flags,
                        const Tcl_MethodType *typePtr,
                        void *clientData);
MODULE_SCOPE int	TclNRNewObjectInstance(Tcl_Interp *interp,
			    Tcl_Class cls, const char *nameStr,
			    const char *nsNameStr, Tcl_Size objc,
			    Tcl_Obj *const *objv, Tcl_Size skip,
			    Tcl_Object *objectPtr);
MODULE_SCOPE Object *	TclNewObjectInstanceCommon(Tcl_Interp *interp,
			    Class *classPtr,

void
TclContinuationsCopy(
    Tcl_Obj *objPtr,
    Tcl_Obj *originObjPtr)
{
    ThreadSpecificData *tsdPtr = TclGetContLineTable();
    Tcl_HashEntry *hPtr =
            Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr);

    if (hPtr) {
	ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_GetHashValue(hPtr);

	TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc);
    }
}

ContLineLoc *
TclContinuationsGet(
    Tcl_Obj *objPtr)
{
    ThreadSpecificData *tsdPtr = TclGetContLineTable();
    Tcl_HashEntry *hPtr =
            Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);

    if (!hPtr) {
        return NULL;
    }
    return (ContLineLoc *)Tcl_GetHashValue(hPtr);
}

/*
 *----------------------------------------------------------------------
 *

     * already killed the thread-global data structures. Performing
     * TCL_TSD_INIT will leave us with an uninitialized memory block upon
     * which we crash (if we where to access the uninitialized hashtable).
     */

    {
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
        Tcl_HashEntry *hPtr;

	if (tsdPtr->lineCLPtr) {
            hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
	    if (hPtr) {
		Tcl_Free(Tcl_GetHashValue(hPtr));
		Tcl_DeleteHashEntry(hPtr);
	    }
	}
    }
}

     * already killed the thread-global data structures. Performing
     * TCL_TSD_INIT will leave us with an uninitialized memory block upon
     * which we crash (if we where to access the uninitialized hashtable).
     */

    {
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
        Tcl_HashEntry *hPtr;

	if (tsdPtr->lineCLPtr) {
            hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
	    if (hPtr) {
		Tcl_Free(Tcl_GetHashValue(hPtr));
		Tcl_DeleteHashEntry(hPtr);
	    }
	}
    }
}

{
    do {
	if (TclHasInternalRep(objPtr, &tclDoubleType)) {
	    if (isnan(objPtr->internalRep.doubleValue)) {
		if (interp != NULL) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "floating point value is Not a Number", -1));
                    Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN",
                            (char *)NULL);
		}
		return TCL_ERROR;
	    }
	    *dblPtr = (double) objPtr->internalRep.doubleValue;
	    return TCL_OK;
	}
	if (TclHasInternalRep(objPtr, &tclIntType)) {

		return TCL_OK;
	    }
	    goto tooLarge;
	}
#endif
	if (TclHasInternalRep(objPtr, &tclDoubleType)) {
	    if (interp != NULL) {
                Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                        "expected integer but got \"%s\"",
                        TclGetString(objPtr)));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL);
	    }
	    return TCL_ERROR;
	}
	if (TclHasInternalRep(objPtr, &tclBignumType)) {
	    /*
	     * Must check for those bignum values that can fit in a long, even

    do {
	if (TclHasInternalRep(objPtr, &tclIntType)) {
	    *wideIntPtr = objPtr->internalRep.wideValue;
	    return TCL_OK;
	}
	if (TclHasInternalRep(objPtr, &tclDoubleType)) {
	    if (interp != NULL) {
                Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                        "expected integer but got \"%s\"",
                        TclGetString(objPtr)));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL);
	    }
	    return TCL_ERROR;
	}
	if (TclHasInternalRep(objPtr, &tclBignumType)) {
	    /*
	     * Must check for those bignum values that can fit in a

    do {
	if (TclHasInternalRep(objPtr, &tclIntType)) {
	    *wideIntPtr = objPtr->internalRep.wideValue;
	    return TCL_OK;
	}
	if (TclHasInternalRep(objPtr, &tclDoubleType)) {
	    if (interp != NULL) {
                Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                        "expected integer but got \"%s\"",
                        TclGetString(objPtr)));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL);
	    }
	    return TCL_ERROR;
	}
	if (TclHasInternalRep(objPtr, &tclBignumType)) {
	    mp_int big;
	    mp_err err;

		    objPtr->internalRep.wideValue) != MP_OKAY) {
		return TCL_ERROR;
	    }
	    return TCL_OK;
	}
	if (TclHasInternalRep(objPtr, &tclDoubleType)) {
	    if (interp != NULL) {
                Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                        "expected integer but got \"%s\"",
                        TclGetString(objPtr)));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL);
	    }
	    return TCL_ERROR;
	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
	    TCL_PARSE_INTEGER_ONLY)==TCL_OK);
    return TCL_ERROR;

	if (!tablePtr) {
	    Tcl_Panic("object table not initialized");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
	if (!hPtr) {
	    Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
                    "incr ref count");
	}
    }
# endif /* TCL_THREADS */
    ++(objPtr)->refCount;
}
#else /* !TCL_MEM_DEBUG */
void

	if (!tablePtr) {
	    Tcl_Panic("object table not initialized");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
	if (!hPtr) {
	    Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
                    "decr ref count");
	}
    }
# endif /* TCL_THREADS */

    if (objPtr->refCount-- <= 1) {
	TclFreeObj(objPtr);
    }

	if (!tablePtr) {
	    Tcl_Panic("object table not initialized");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
	if (!hPtr) {
	    Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
                    "check shared status");
	}
    }
# endif /* TCL_THREADS */
#endif /* TCL_MEM_DEBUG */

#ifdef TCL_COMPILE_STATS
    Tcl_MutexLock(&tclObjMutex);

    size_t l1, l2;

    /*
     * If the object pointers are the same then they match.
     * OPT: this comparison was moved to the caller

       if (objPtr1 == objPtr2) {
           return 1;
       }
    */

    /*
     * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being
     * in a register.
     */

     *
     * If any check fails, then force another conversion to the command type,
     * to discard the old rep and create a new one.
     */

    resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
    if (TclHasInternalRep(objPtr, &tclCmdNameType)) {
        Command *cmdPtr = resPtr->cmdPtr;

        if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch)
                && (interp == cmdPtr->nsPtr->interp)
                && !(cmdPtr->nsPtr->flags & NS_DYING)) {
            Namespace *refNsPtr = (Namespace *)
                    TclGetCurrentNamespace(interp);

            if ((resPtr->refNsPtr == NULL)
		    || ((refNsPtr == resPtr->refNsPtr)
                    && (resPtr->refNsId == refNsPtr->nsId)
                    && (resPtr->refNsCmdEpoch == refNsPtr->cmdRefEpoch))) {
                return (Tcl_Command) cmdPtr;
            }
        }
    }

    /*
     * OK, must create a new internal representation (or fail) as any cache we
     * had is invalid one way or another.
     */

    /* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */
    if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) {
        return NULL;
    }
    resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
    return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL);
}

/*
 *----------------------------------------------------------------------

	    Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p",
		    (void *) objv[1]->internalRep.twoPtrValue.ptr1,
		    (void *) objv[1]->internalRep.twoPtrValue.ptr2);
	}
    }

    if (objv[1]->bytes) {
        Tcl_AppendToObj(descObj, ", string representation \"", -1);
	Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length,
                16, "...");
	Tcl_AppendToObj(descObj, "\"", -1);
    } else {
	Tcl_AppendToObj(descObj, ", no string representation", -1);
    }

    Tcl_SetObjResult(interp, descObj);
    return TCL_OK;

    if (code == TCL_ERROR) {
	if (iPtr->errorInfo) {
	    Tcl_DecrRefCount(iPtr->errorInfo);
	    iPtr->errorInfo = NULL;
	}
	Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO],
                &valuePtr);
	if (valuePtr != NULL) {
	    Tcl_Size length;

	    (void)TclGetStringFromObj(valuePtr, &length);
	    if (length) {
		iPtr->errorInfo = valuePtr;
		Tcl_IncrRefCount(iPtr->errorInfo);
		iPtr->flags |= ERR_ALREADY_LOGGED;
	    }
	}
	Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK],
                &valuePtr);
	if (valuePtr != NULL) {
            Tcl_Size len, valueObjc;
            Tcl_Obj **valueObjv;

            if (Tcl_IsShared(iPtr->errorStack)) {
                Tcl_Obj *newObj;

                newObj = Tcl_DuplicateObj(iPtr->errorStack);
                Tcl_DecrRefCount(iPtr->errorStack);
                Tcl_IncrRefCount(newObj);
                iPtr->errorStack = newObj;
            }

            /*
             * List extraction done after duplication to avoid moving the rug
             * if someone does [return -errorstack [info errorstack]]
             */

            if (TclListObjGetElements(interp, valuePtr, &valueObjc,
                    &valueObjv) == TCL_ERROR) {
                return TCL_ERROR;
            }
            iPtr->resetErrorStack = 0;
            TclListObjLength(interp, iPtr->errorStack, &len);

            /*
             * Reset while keeping the list internalrep as much as possible.
             */

            Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc,
                    valueObjv);
	}
	Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE],
                &valuePtr);
	if (valuePtr != NULL) {
	    Tcl_SetObjErrorCode(interp, valuePtr);
	} else {
	    Tcl_SetErrorCode(interp, "NONE", (void *)NULL);
	}

	Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE],
                &valuePtr);
	if (valuePtr != NULL) {
	    TclGetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
	}
    }
    if (level != 0) {
	iPtr->returnLevel = level;
	iPtr->returnCode = code;

	    if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict, &search,
		    &keyPtr, &valuePtr, &done)) {
		/*
		 * Value is not a legal dictionary.
		 */

		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                        "bad %s value: expected dictionary but got \"%s\"",
                        compare, TclGetString(objv[1])));
		Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS",
			(void *)NULL);
		goto error;
	    }

	    while (!done) {
		Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr);

    /*
     * Check for bogus -code value.
     */

    Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
    if (valuePtr != NULL) {
	if (TclGetCompletionCodeFromObj(interp, valuePtr,
                &code) == TCL_ERROR) {
	    goto error;
	}
	Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]);
    }

    /*
     * Check for bogus -level value.
     */

    Tcl_DictObjGet(NULL, returnOpts, keys[KEY_LEVEL], &valuePtr);
    if (valuePtr != NULL) {
	if ((TCL_ERROR == TclGetIntFromObj(NULL, valuePtr, &level))
		|| (level < 0)) {
	    /*
	     * Value is not a legal level.
	     */

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "bad -level value: expected non-negative integer but got"
                    " \"%s\"", TclGetString(valuePtr)));
	    Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", (void *)NULL);
	    goto error;
	}
	Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]);
    }

    /*
     * Check for bogus -errorcode value.
     */

    Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORCODE], &valuePtr);
    if (valuePtr != NULL) {
	Tcl_Size length;

	if (TCL_ERROR == TclListObjLength(NULL, valuePtr, &length )) {
	    /*
	     * Value is not a list, which is illegal for -errorcode.
	     */

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "bad -errorcode value: expected a list but got \"%s\"",
                    TclGetString(valuePtr)));
	    Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_ERRORCODE",
		    (void *)NULL);
	    goto error;
	}
    }

    /*
     * Check for bogus -errorstack value.
     */

    Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORSTACK], &valuePtr);
    if (valuePtr != NULL) {
	Tcl_Size length;

	if (TCL_ERROR == TclListObjLength(NULL, valuePtr, &length)) {
	    /*
	     * Value is not a list, which is illegal for -errorstack.
	     */

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "bad -errorstack value: expected a list but got \"%s\"",
                    TclGetString(valuePtr)));
	    Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK",
                    (void *)NULL);
	    goto error;
	}
        if (length % 2) {
            /*
             * Errorstack must always be an even-sized list
             */

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "forbidden odd-sized list for -errorstack: \"%s\"",
		    TclGetString(valuePtr)));
	    Tcl_SetErrorCode(interp, "TCL", "RESULT",
                    "ODDSIZEDLIST_ERRORSTACK", (void *)NULL);
	    goto error;
        }
    }

    /*
     * Convert [return -code return -level X] to [return -code ok -level X+1]
     */

    if (code == TCL_RETURN) {

		Tcl_NewWideIntObj(result));
	Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL],
		Tcl_NewWideIntObj(0));
    }

    if (result == TCL_ERROR) {
	Tcl_AddErrorInfo(interp, "");
        Tcl_DictObjPut(NULL, options, keys[KEY_ERRORSTACK], iPtr->errorStack);
    }
    if (iPtr->errorCode) {
	Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode);
    }
    if (iPtr->errorInfo) {
	Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo);
	Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE],

    int level, code;
    Tcl_Obj **objv, *mergedOpts;

    Tcl_IncrRefCount(options);
    if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv)
	    || (objc % 2)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "expected dict but got \"%s\"", TclGetString(options)));
	Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", (void *)NULL);
	code = TCL_ERROR;
    } else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv,
	    &mergedOpts, &code, &level)) {
	code = TCL_ERROR;
    } else {
	code = TclProcessReturn(interp, code, level, mergedOpts);

	    my_LStringObjLength,   /* Length */
	    my_LStringObjIndex,    /* Index */
	    my_LStringObjRange,    /* Slice */
	    my_LStringObjReverse,  /* Reverse */
	    my_LStringGetElements, /* GetElements */
	    my_LStringObjSetElem,  /* SetElement */
	    my_LStringReplace,     /* Replace */
            NULL)                  /* "in" operator */
        },
    {/*1*/
	"lstring",
	freeRep,
	DupLStringRep,
	UpdateStringOfLString,
	NULL,
	TCL_OBJTYPE_V2(
	    NULL,   /* Length */
	    my_LStringObjIndex,    /* Index */
	    my_LStringObjRange,    /* Slice */
	    my_LStringObjReverse,  /* Reverse */
	    my_LStringGetElements, /* GetElements */
	    my_LStringObjSetElem,  /* SetElement */
	    my_LStringReplace,     /* Replace */
            NULL)                  /* "in" operator */
    },
    {/*2*/
	"lstring",
	freeRep,
	DupLStringRep,
	UpdateStringOfLString,
	NULL,
	TCL_OBJTYPE_V2(
	    my_LStringObjLength,   /* Length */
	    NULL,                  /* Index */
	    my_LStringObjRange,    /* Slice */
	    my_LStringObjReverse,  /* Reverse */
	    my_LStringGetElements, /* GetElements */
	    my_LStringObjSetElem,  /* SetElement */
	    my_LStringReplace,     /* Replace */
            NULL)                  /* "in" operator */
    },
    {/*3*/
	"lstring",
	freeRep,
	DupLStringRep,
	UpdateStringOfLString,
	NULL,
	TCL_OBJTYPE_V2(
	    my_LStringObjLength,   /* Length */
	    my_LStringObjIndex,    /* Index */
	    NULL,                  /* Slice */
	    my_LStringObjReverse,  /* Reverse */
	    my_LStringGetElements, /* GetElements */
	    my_LStringObjSetElem,  /* SetElement */
	    my_LStringReplace,     /* Replace */
            NULL)                  /* "in" operator */
    },
    {/*4*/
	"lstring",
	freeRep,
	DupLStringRep,
	UpdateStringOfLString,
	NULL,
	TCL_OBJTYPE_V2(
	    my_LStringObjLength,   /* Length */
	    my_LStringObjIndex,    /* Index */
	    my_LStringObjRange,    /* Slice */
	    NULL,                  /* Reverse */
	    my_LStringGetElements, /* GetElements */
	    my_LStringObjSetElem,  /* SetElement */
	    my_LStringReplace,     /* Replace */
            NULL)                  /* "in" operator */
    },
    {/*5*/
	"lstring",
	freeRep,
	DupLStringRep,
	UpdateStringOfLString,
	NULL,
	TCL_OBJTYPE_V2(
	    my_LStringObjLength,   /* Length */
	    my_LStringObjIndex,    /* Index */
	    my_LStringObjRange,    /* Slice */
	    my_LStringObjReverse,  /* Reverse */
	    NULL,                  /* GetElements */
	    my_LStringObjSetElem,  /* SetElement */
	    my_LStringReplace,     /* Replace */
            NULL)                  /* "in" operator */
    },
    {/*6*/
	"lstring",
	freeRep,
	DupLStringRep,
	UpdateStringOfLString,
	NULL,
	TCL_OBJTYPE_V2(
	    my_LStringObjLength,   /* Length */
	    my_LStringObjIndex,    /* Index */
	    my_LStringObjRange,    /* Slice */
	    my_LStringObjReverse,  /* Reverse */
	    my_LStringGetElements, /* GetElements */
	    NULL,                  /* SetElement */
	    my_LStringReplace,     /* Replace */
            NULL)                  /* "in" operator */
    },
    {/*7*/
	"lstring",
	freeRep,
	DupLStringRep,
	UpdateStringOfLString,
	NULL,
	TCL_OBJTYPE_V2(
	    my_LStringObjLength,   /* Length */
	    my_LStringObjIndex,    /* Index */
	    my_LStringObjRange,    /* Slice */
	    my_LStringObjReverse,  /* Reverse */
	    my_LStringGetElements, /* GetElements */
	    my_LStringObjSetElem,  /* SetElement */
	    NULL,                  /* Replace */
            NULL)                  /* "in" operator */
    },
    {/*8*/
	"lstring",
	freeRep,
	DupLStringRep,
	UpdateStringOfLString,
	NULL,
	TCL_OBJTYPE_V2(
	    my_LStringObjLength,   /* Length */
	    my_LStringObjIndex,    /* Index */
	    my_LStringObjRange,    /* Slice */
	    my_LStringObjReverse,  /* Reverse */
	    my_LStringGetElements, /* GetElements */
	    my_LStringObjSetElem,  /* SetElement */
	    my_LStringReplace,     /* Replace */
            NULL)                  /* "in" operator */
    },
    {/*9*/
	"lstring",
	freeRep,
	DupLStringRep,
	UpdateStringOfLString,
	NULL,
	TCL_OBJTYPE_V2(
	    my_LStringObjLength,   /* Length */
	    my_LStringObjIndex,    /* Index */
	    my_LStringObjRange,    /* Slice */
	    my_LStringObjReverse,  /* Reverse */
	    my_LStringGetElements, /* GetElements */
	    my_LStringObjSetElem,  /* SetElement */
	    my_LStringReplace,     /* Replace */
            NULL)                  /* "in" operator */
    },
    {/*10*/
	"lstring",
	freeRep,
	DupLStringRep,
	UpdateStringOfLString,
	NULL,
	TCL_OBJTYPE_V2(
	    my_LStringObjLength,   /* Length */
	    my_LStringObjIndex,    /* Index */
	    my_LStringObjRange,    /* Slice */
	    my_LStringObjReverse,  /* Reverse */
	    my_LStringGetElements, /* GetElements */
	    my_LStringObjSetElem,  /* SetElement */
	    my_LStringReplace,     /* Replace */
            NULL)                  /* "in" operator */
    }
};

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

    if (llen <= LOCAL_SIZE) {
	flagPtr = localFlags;
    } else {
	/* We know numElems <= LIST_MAX, so this is safe. */
	flagPtr = (int *) Tcl_Alloc(llen*sizeof(int));
    }
    for (bytesNeeded = 0, i = 0; i < llen; i++) {
        Tcl_Obj *elemObj;
        const char *elemStr;
        Tcl_Size elemLen;
	flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
	typePtr->indexProc(NULL, objPtr, i, &elemObj);
	Tcl_IncrRefCount(elemObj);
        elemStr = Tcl_GetStringFromObj(elemObj, &elemLen);
        /* Note TclScanElement updates flagPtr[i] */
	bytesNeeded += Tcl_ScanCountedElement(elemStr, elemLen, &flagPtr[i]);
	if (bytesNeeded < 0) {
	    Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
	}
	Tcl_DecrRefCount(elemObj);
    }
    if (bytesNeeded > INT_MAX - llen + 1) {
	Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
    }
    bytesNeeded += llen; /* Separating spaces and terminating nul */

    /*
     * Pass 2: generate the string repr.
     */
    objPtr->bytes = (char *) Tcl_Alloc(bytesNeeded);
    p = objPtr->bytes;
    for (i = 0; i < llen; i++) {
        Tcl_Obj *elemObj;
        const char *elemStr;
        Tcl_Size elemLen;
	flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
	typePtr->indexProc(NULL, objPtr, i, &elemObj);
	Tcl_IncrRefCount(elemObj);
	elemStr = Tcl_GetStringFromObj(elemObj, &elemLen);
	p += Tcl_ConvertCountedElement(elemStr, elemLen, p, flagPtr[i]);
	*p++ = ' ';
	Tcl_DecrRefCount(elemObj);

	// EVAL DIRECT to avoid interfering with bytecode compile which may be
	// active on the stack
	int flags = TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT;
	int status = Tcl_EvalObjEx(intrp, genCmd, flags);
	elemObj = Tcl_GetObjResult(intrp);
	if (status != TCL_OK) {
	    Tcl_SetObjResult(intrp, Tcl_ObjPrintf(
	        "Error: %s\nwhile executing %s\n",
		elemObj ? Tcl_GetString(elemObj) : "NULL", Tcl_GetString(genCmd)));
	    return NULL;
	}
    }
    return elemObj;
}

    NULL, /* SetFromAnyProc */
    TCL_OBJTYPE_V2(
	lgenSeriesObjLength,
	lgenSeriesObjIndex,
	NULL, /* slice */
	NULL, /* reverse */
	NULL, /* get elements */
        NULL, /* set element */
        NULL, /* replace */
        NULL) /* "in" operator */
};

/*
 *  ObjType Duplicate Internal Rep Function
 */
static void
DupLgenSeriesRep(

    cachePtr = (Cache*)TclpGetAllocCache();
    if (cachePtr == NULL) {
	cachePtr = (Cache*)TclpSysAlloc(sizeof(Cache));
	if (cachePtr == NULL) {
	    Tcl_Panic("alloc: could not allocate new cache");
	}
        memset(cachePtr, 0, sizeof(Cache));
	Tcl_MutexLock(listLockPtr);
	cachePtr->nextPtr = firstCachePtr;
	firstCachePtr = cachePtr;
	Tcl_MutexUnlock(listLockPtr);
	cachePtr->owner = Tcl_GetCurrentThread();
	TclpSetAllocCache(cachePtr);
    }

    if (TclGetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
	if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index)
		!= TCL_OK) {
	    const char *arg = TclGetString(objv[1]);

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "bad argument \"%s\": must be"
                    " cancel, idle, info, or an integer", arg));
            Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
                    arg, (void *)NULL);
	    return TCL_ERROR;
	}
    }

    /*
     * At this point, either index = -1 and ms contains the number of ms
     * to wait, or else index is the index of a subcommand.

	    for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
		    afterPtr = afterPtr->nextPtr) {
		if (assocPtr->interp == interp) {
		    Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf(
			    "after#%d", afterPtr->id));
		}
	    }
            Tcl_SetObjResult(interp, resultObj);
	    return TCL_OK;
	}
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "?id?");
	    return TCL_ERROR;
	}
	afterPtr = GetAfterEvent(assocPtr, objv[2]);
	if (afterPtr == NULL) {
            const char *eventStr = TclGetString(objv[2]);

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "event \"%s\" doesn't exist", eventStr));
            Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, (void *)NULL);
	    return TCL_ERROR;
	} else {
	    Tcl_Obj *resultListPtr;

	    TclNewObj(resultListPtr);
	    Tcl_ListObjAppendElement(interp, resultListPtr,
		    afterPtr->commandPtr);
	    Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
		    (afterPtr->token == NULL) ? "idle" : "timer", -1));
            Tcl_SetObjResult(interp, resultListPtr);
	}
	break;
    default:
	Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
    }
    return TCL_OK;
}

	}
	if (iPtr->limit.timeEvent == NULL
		|| TCL_TIME_BEFORE(endTime, iPtr->limit.time)) {
	    diff = TCL_TIME_DIFF_MS_CEILING(endTime, now);
	    if (diff > TCL_TIME_MAXIMUM_SLICE) {
		diff = TCL_TIME_MAXIMUM_SLICE;
	    }
            if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
                diff = 1;
            }
	    if (diff > 0) {
		Tcl_Sleep((int) diff);
                if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
                    break;
                }
	    } else {
                break;
            }
	} else {
	    diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now);
	    if (diff > TCL_TIME_MAXIMUM_SLICE) {
		diff = TCL_TIME_MAXIMUM_SLICE;
	    }
	    if (diff > 0) {
		Tcl_Sleep((int) diff);

	/*
	 * None of the remaining traces on this command are execution traces.
	 * We therefore remove this flag:
	 */

	cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES;

        /*
	 * Bug 3484621: up the interp's epoch if this is a BC'ed command
	 */

	if (cmdPtr->compileProc != NULL) {
	    iPtr->compileEpoch++;
	}
    }

	    }
	}
    }

    /* Keep the original pointer for possible use in an error message */
    element = part2;
    if (part2 == NULL) {
        if (TclIsVarArrayElement(varPtr)) {
            Tcl_Obj *keyObj = VarHashGetKey(varPtr);
            part2 = Tcl_GetString(keyObj);
        }
    } else if ((flags & VAR_TRACED_UNSET) && !(flags & VAR_ARRAY_ELEMENT)) {
        /* On unset traces, part2 has already been set by the caller, and
         * the VAR_ARRAY_ELEMENT flag indicates whether the accessed
         * variable actually has a second part, or is a scalar */
        element = NULL;
    }

    /*
     * Invoke traces on the array containing the variable, if relevant.
     */

    result = NULL;

     *	Reconsider this if we ever start treating non-ASCII Unicode
     *	characters as meaningful list syntax, expanded Unicode spaces as
     *	element separators, for example.)
     *

    end = Tcl_UtfPrev(end, start);
    while (*end == '{') {
        if (end == start) {
            return 0;
        }
        end = Tcl_UtfPrev(end, start);
    }

     *
     */

    while ((--end >= start) && (*end == '{')) {
    }
    if (end < start) {
        return 0;
    }

    /*
     * (c) the trailing character of the string is already a list-element
     *	   separator, Use the same testing routine as TclFindElement to
     *	   enforce consistency.
     */

GetWideForIndex(
    Tcl_Interp *interp,         /* Interpreter to use for error reporting. If
				 * NULL, then no error message is left after
				 * errors. */
    Tcl_Obj *objPtr,            /* Points to the value to be parsed */
    Tcl_WideInt endValue,       /* The value to be stored at *widePtr if
				 * objPtr holds "end".
                                 * NOTE: this value may be TCL_INDEX_NONE. */
    Tcl_WideInt *widePtr)       /* Location filled in with a wide integer
                                 * representing an index. */
{
    int numType;
    void *cd;
    int code = Tcl_GetNumberFromObj(NULL, objPtr, &cd, &numType);

    if (code == TCL_OK) {
	if (numType == TCL_NUMBER_INT) {
	    /* objPtr holds an integer in the signed wide range */
	    *widePtr = *(Tcl_WideInt *)cd;
            if ((*widePtr < 0)) {
		*widePtr = (endValue == -1) ? WIDE_MIN : -1;
	    }
	    return TCL_OK;
	}
	if (numType == TCL_NUMBER_BIG) {
	    /* objPtr holds an integer outside the signed wide range */
	    /* Truncate to the signed wide range. */

    if (indexPtr != NULL) {
	/* Note: check against TCL_SIZE_MAX needed for 32-bit builds */
	if (wide >= 0 && wide <= TCL_SIZE_MAX) {
	    *indexPtr = (Tcl_Size)wide; /* A valid index */
	} else if (wide > TCL_SIZE_MAX) {
	    *indexPtr = TCL_SIZE_MAX;   /* Beyond max possible index */
	} else if (wide < -1-TCL_SIZE_MAX) {
            *indexPtr = -1-TCL_SIZE_MAX; /* Below most negative index */
        } else if ((wide < 0) && (endValue >= 0)) {
            *indexPtr = TCL_INDEX_NONE; /* No clue why this special case */
        } else {
	    *indexPtr = (Tcl_Size) wide;
	}
    }
    return TCL_OK;
}

/*

 */

static int
GetEndOffsetFromObj(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,            /* Pointer to the object to parse */
    Tcl_WideInt endValue,       /* The value to be stored at "widePtr" if
                                 * "objPtr" holds "end". */
    Tcl_WideInt *widePtr)       /* Location filled in with an integer
                                 * representing an index. */
{
    Tcl_ObjInternalRep *irPtr;
    Tcl_WideInt offset = -1;	/* Offset in the "end-offset" expression - 1 */
    void *cd;

    while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType)) == NULL) {
	Tcl_ObjInternalRep ir;

	    /*
	     * Quick scan to see if multi-value list is even possible.
	     * This relies on TclGetString() returning a NUL-terminated string.
	     */
	    if ((TclMaxListLength(bytes, TCL_INDEX_NONE, NULL) > 1)
		    /* If it's possible, do the full list parse. */
	            && (TCL_OK == TclListObjLength(NULL, objPtr, &length))
	            && (length > 1)) {
	        goto parseError;
	    }

	    /* Passed the list screen, so parse for index arithmetic expression */
	    if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, TCL_INDEX_NONE, &opPtr,
	            TCL_PARSE_INTEGER_ONLY)) {
		Tcl_WideInt w1=0, w2=0;

		/* value starts with valid integer... */

		if ((*opPtr == '-') || (*opPtr == '+')) {
		    /* ... value continues with [-+] ... */

    }

    offset = irPtr->wideValue;

    if (offset == WIDE_MAX) {
	/*
	 * Encodes end+1. This is distinguished from end+n as noted
         * in function header.
	 * NOTE: this may wrap around if the caller passes (as lset does)
	 * listLen-1 as endValue and and listLen is 0. The -1 will be
	 * interpreted as FF...FF and adding 1 will result in 0 which
	 * is what we want. Callers like lset which pass in listLen-1 == -1
         * as endValue will have to adjust accordingly.
	 */
	*widePtr = (endValue == -1) ? WIDE_MAX : endValue + 1;
    } else if (offset == WIDE_MIN) {
	*widePtr = (endValue == -1) ? WIDE_MIN : -1;
    } else if (offset < 0) {
	/* end-(n-1) - Different signs, sum cannot overflow */
	*widePtr = endValue + offset + 1;
    } else {
	/* 0:WIDE_MAX - plain old index. */
	*widePtr = offset;
    }
    return TCL_OK;

    /* Report a parse error. */
  parseError:
    if (interp != NULL) {
        char * bytes = TclGetString(objPtr);
        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "bad index \"%s\": must be integer?[+-]integer? or"
                " end?[+-]integer?", bytes));
        if (!strncmp(bytes, "end-", 4)) {
            bytes += 4;
        }
        Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", (char *)NULL);
    }

    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------

    /*
     * It's an error to unset an undefined variable.
     */

    if (result != TCL_OK) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset",
              ((initialArrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index);
	    Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", (char *)NULL);
	}
    }

    /*
     * Finally, if the variable is truly not in use then free up its Var
     * structure and remove it from its hash table, if any. The ref count of

		Tcl_SetHashValue(tPtr, tracePtr);
	    }
	}

	if ((dummyVar.flags & VAR_TRACED_UNSET)
		|| (arrayPtr && (arrayPtr->flags & VAR_TRACED_UNSET))) {

            /*
             * Pass the array element name to TclObjCallVarTraces(), because
             * it cannot be determined from dummyVar. Alternatively, indicate
             * via flags whether the variable involved in the code that caused
             * the trace to be triggered was an array element, for the correct
             * formatting of error messages.
             */
            if (part2Ptr) {
                flags |= VAR_ARRAY_ELEMENT;
            } else if (TclIsVarArrayElement(varPtr)) {
                part2Ptr = VarHashGetKey(varPtr);
            }

	    dummyVar.flags &= ~VAR_TRACE_ACTIVE;
	    TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr,
              (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|VAR_ARRAY_ELEMENT))
			    | TCL_TRACE_UNSETS,
		    /* leaveErrMsg */ 0, index);

	    /*
	     * The traces that we just called may have triggered a change in
	     * the set of traces. If so, reload the traces to manipulate.
	     */

     *
     *      array default set v 1
     *      lappend v(a) 2; # returns a new object {1 2}
     *      set v(b); # returns the original default object "1"
     */

    if (tablePtr->defaultObj) {
        Tcl_DecrRefCount(tablePtr->defaultObj);
        Tcl_DecrRefCount(tablePtr->defaultObj);
    }
    tablePtr->defaultObj = defaultObj;
    if (tablePtr->defaultObj) {
        Tcl_IncrRefCount(tablePtr->defaultObj);
        Tcl_IncrRefCount(tablePtr->defaultObj);
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

	 */

	zf->length = Tcl_Seek(zf->chan, 0, SEEK_END);
	if (zf->length == (size_t) TCL_INDEX_NONE) {
	    ZIPFS_POSIX_ERROR(interp, "seek error");
	    goto error;
	}
        /* What's the magic about 64 * 1024 * 1024 ? */
	if ((zf->length <= ZIP_CENTRAL_END_LEN) ||
		(zf->length - ZIP_CENTRAL_END_LEN) >
			(64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) {
	    ZIPFS_ERROR(interp, "illegal file size");
	    ZIPFS_ERROR_CODE(interp, "FILE_SIZE");
	    goto error;
	}

namespace eval ::tcl::unsupported::icu {
    # Map Tcl encoding names to ICU and back. Note ICU has multiple aliases
    # for the same encoding.
    variable tclToIcu
    variable icuToTcl

    proc LogError {message} {
        puts stderr $message
    }

    proc Init {} {
        variable tclToIcu
        variable icuToTcl
        # There are some special cases where names do not line up
        # at all. Map Tcl -> ICU
        array set specialCases {
            ebcdic ebcdic-cp-us
            macCentEuro maccentraleurope
            utf16 UTF16_PlatformEndian
            utf-16be UnicodeBig
            utf-16le UnicodeLittle
            utf32 UTF32_PlatformEndian
        }
        # Ignore all errors. Do not want to hold up Tcl
        # if ICU not available
        if {[catch {
            foreach tclName [encoding names] {
                if {[catch {
                    set icuNames [aliases $tclName]
                } erMsg]} {
                    LogError "Could not get aliases for $tclName: $erMsg"
                    continue
                }
                if {[llength $icuNames] == 0} {
                    # E.g. macGreek -> x-MacGreek
                    set icuNames [aliases x-$tclName]
                    if {[llength $icuNames] == 0} {
                        # Still no joy, check for special cases
                        if {[info exists specialCases($tclName)]} {
                            set icuNames [aliases $specialCases($tclName)]
                        }
                    }
                }
                # If the Tcl name is also an ICU name use it else use
                # the first name which is the canonical ICU name
                set pos [lsearch -exact -nocase $icuNames $tclName]
                if {$pos >= 0} {
                    lappend tclToIcu($tclName) [lindex $icuNames $pos] {*}[lreplace $icuNames $pos $pos]
                } else {
                    set tclToIcu($tclName) $icuNames
                }
                foreach icuName $icuNames {
                    lappend icuToTcl($icuName) $tclName
                }
            }
        } errMsg]} {
            LogError $errMsg
        }
        array default set tclToIcu ""
        array default set icuToTcl ""

        # Redefine ourselves to no-op.
        proc Init {} {}
    }
    # Primarily used during development
    proc MappedIcuNames {{pat *}} {
        Init
        variable icuToTcl
        return [array names icuToTcl $pat]
    }
    # Primarily used during development
    proc UnmappedIcuNames {{pat *}} {
        Init
        variable icuToTcl
        set unmappedNames {}
        foreach icuName [converters] {
            if {[llength [icuToTcl $icuName]] == 0} {
                lappend unmappedNames $icuName
            }
            foreach alias [aliases $icuName] {
                if {[llength [icuToTcl $alias]] == 0} {
                    lappend unmappedNames $alias
                }
            }
        }
        # Aliases can be duplicates. Remove
        return [lsort -unique [lsearch -inline -all $unmappedNames $pat]]
    }
    # Primarily used during development
    proc UnmappedTclNames {{pat *}} {
        Init
        variable tclToIcu
        set unmappedNames {}
        foreach tclName [encoding names] {
            # Note entry will always exist. Check if empty
            if {[llength [tclToIcu $tclName]] == 0} {
                lappend unmappedNames $tclName
            }
        }
        return [lsearch -inline -all $unmappedNames $pat]
    }

    # Returns the Tcl equivalent of an ICU encoding name or
    # the empty string in case not found.
    proc icuToTcl {icuName} {
        Init
        proc icuToTcl {icuName} {
            variable icuToTcl
            return [lindex $icuToTcl($icuName) 0]
        }
        icuToTcl $icuName
    }

    # Returns the ICU equivalent of an Tcl encoding name or
    # the empty string in case not found.
    proc tclToIcu {tclName} {
        Init
        proc tclToIcu {tclName} {
            variable tclToIcu
            return [lindex $tclToIcu($tclName) 0]
        }
        tclToIcu $tclName
    }


    namespace export {[a-z]*}
    namespace ensemble create
}

#
# (Ticket 41c9857bdd) In a safe interpreter, this file does not set
# ::auto_path (other than to {} if it is undefined). The caller, typically
# a Safe Base command, is responsible for setting ::auto_path.

if {![info exists auto_path]} {
    if {[info exists env(TCLLIBPATH)] && (![interp issafe])} {
        set auto_path [apply {{} {
            lmap path $::env(TCLLIBPATH) {
                # Paths relative to unresolvable home dirs are ignored
                if {[catch {file tildeexpand $path} expanded_path]} {
                    continue
                }
                set expanded_path
            }
        }}]
    } else {
	set auto_path ""
    }
}

namespace eval tcl {
    if {![interp issafe]} {

# Tests for tcl::unsupported::icu

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

# Force late loading of ICU if present
catch {::tcl::unsupported::icu}
testConstraint icu [expr {[info commands ::tcl::unsupported::icu::detect] ne ""}]

namespace eval icu {
    test icu-detect-0 {Return list of ICU encodings} -constraints icu -body {
        set encoders [::tcl::unsupported::icu detect]
        list [::tcl::mathop::in UTF-8 $encoders] [::tcl::mathop::in ISO-8859-1 $encoders]
    } -result {1 1}

    test icu-detect-1 {Guess encoding} -constraints icu -body {
        ::tcl::unsupported::icu detect [readFile [info script]]
    } -result ISO-8859-1

    test icu-detect-2 {Get all possible encodings} -constraints icu -body {
        set encodings [::tcl::unsupported::icu detect [readFile [info script]] -all]
        list [::tcl::mathop::in UTF-8 $encodings] [::tcl::mathop::in ISO-8859-1 $encodings]
    } -result {1 1}

    test icu-tclToIcu-0 {Map Tcl encoding} -constraints icu -body {
        # tis-620 because it is ambiguous in ICU on some platforms
        # but should return the preferred encoding
        list [::tcl::unsupported::icu tclToIcu utf-8] [::tcl::unsupported::icu tclToIcu tis-620] [::tcl::unsupported::icu tclToIcu shiftjis]
    } -result {UTF-8 TIS-620 ibm-943_P15A-2003}

    test icu-tclToIcu-1 {Map Tcl encoding - no map} -constraints icu -body {
        # Should not raise an error
        ::tcl::unsupported::icu tclToIcu dummy
    } -result {}

    test icu-icuToTcl-0 {Map ICU encoding} -constraints icu -body {
       list [::tcl::unsupported::icu icuToTcl UTF-8] [::tcl::unsupported::icu icuToTcl TIS-620] [::tcl::unsupported::icu icuToTcl ibm-943_P15A-2003]
    } -result {utf-8 tis-620 cp932}

    test icu-icuToTcl-1 {Map ICU encoding - no map} -constraints icu -body {
        # Should not raise an error
        ::tcl::unsupported::icu icuToTcl dummy
    } -result {}

}


namespace delete icu
::tcltest::cleanupTests

    variable outputChan
    variable errorChan stderr
    variable verbose 0

    # Map Tcl encoding name to ICU UCM file name
    variable encNameMap
    array set encNameMap {
        cp1250    glibc-CP1250-2.1.2
        cp1251    glibc-CP1251-2.1.2
        cp1252    glibc-CP1252-2.1.2
        cp1253    glibc-CP1253-2.1.2
        cp1254    glibc-CP1254-2.1.2
        cp1255    glibc-CP1255-2.1.2
        cp1256    glibc-CP1256-2.1.2
        cp1257    glibc-CP1257-2.1.2
        cp1258    glibc-CP1258-2.1.2
        gb1988    glibc-GB_1988_80-2.3.3
        iso8859-1 glibc-ISO_8859_1-2.1.2
        iso8859-2 glibc-ISO_8859_2-2.1.2
        iso8859-3 glibc-ISO_8859_3-2.1.2
        iso8859-4 glibc-ISO_8859_4-2.1.2
        iso8859-5 glibc-ISO_8859_5-2.1.2
        iso8859-6 glibc-ISO_8859_6-2.1.2
        iso8859-7 glibc-ISO_8859_7-2.3.3
        iso8859-8 glibc-ISO_8859_8-2.3.3
        iso8859-9 glibc-ISO_8859_9-2.1.2
        iso8859-10 glibc-ISO_8859_10-2.1.2
        iso8859-11 glibc-ISO_8859_11-2.1.2
        iso8859-13 glibc-ISO_8859_13-2.3.3
        iso8859-14 glibc-ISO_8859_14-2.1.2
        iso8859-15 glibc-ISO_8859_15-2.1.2
        iso8859-16 glibc-ISO_8859_16-2.3.3
    }

    # Array keyed by Tcl encoding name. Each element contains mapping of
    # Unicode code point -> byte sequence for that encoding as a flat list
    # (or dictionary). Both are stored as hex strings
    variable charMap

proc ucm::warn {msg} {
    variable errorChan
    puts $errorChan $msg
}
proc ucm::log {msg} {
    variable verbose
    if {$verbose} {
        variable errorChan
        puts $errorChan $msg
    }
}
proc ucm::print {s} {
    variable outputChan
    puts $outputChan $s
}

proc ucm::parse_SBCS {encName fd} {
    variable charMap
    variable invalidCodeSequences
    variable unmappedCodePoints

    set result {}
    while {[gets $fd line] >= 0} {
        if {[string match #* $line]} {
            continue
        }
        if {[string equal "END CHARMAP" [string trim $line]]} {
            break
        }
        if {![regexp {^\s*<U([[:xdigit:]]{4})>\s*((\\x[[:xdigit:]]{2})+)\s*(\|(0|1|2|3|4))} $line -> unichar bytes - - precision]} {
            error "Unexpected line parsing SBCS: $line"
        }
        set bytes [string map {\\x {}} $bytes]; # \xNN -> NN
        if {$precision eq "" || $precision eq "0"} {
            lappend result $unichar $bytes
        } else {
            # It is a fallback mapping - ignore
        }
    }
    set charMap($encName) $result

    # Find out invalid code sequences and unicode code points that are not mapped
    set valid {}
    set mapped {}
    foreach {unich bytes} $result {
        lappend mapped $unich
        lappend valid $bytes
    }
    set invalidCodeSequences($encName) {}
    for {set i 0} {$i <= 255} {incr i} {
        set hex [format %.2X $i]
        if {[lsearch -exact $valid $hex] < 0} {
            lappend invalidCodeSequences($encName) $hex
        }
    }

    set unmappedCodePoints($encName) {}
    for {set i 0} {$i <= 65535} {incr i} {
        set hex [format %.4X $i]
        if {[lsearch -exact $mapped $hex] < 0} {
            lappend unmappedCodePoints($encName) $hex
            # Only look for (at most) one below 256 and one above 1024
            if {$i < 255} {
                # Found one so jump past 8 bits
                set i 255
            } else {
                break
            }
        }
        if {$i == 255} {
            set i 1023
        }
    }
    lappend unmappedCodePoints($encName) D800 DC00 10000 10FFFF
}

proc ucm::generate_boilerplate {} {
    # Common procedures
    print {
# This file is automatically generated by ucm2tests.tcl.
# Edits will be overwritten on next generation.
#
# Generates tests comparing Tcl encodings to ICU.
# The generated file is NOT standalone. It should be sourced into a test script.

proc ucmConvertfromMismatches {enc map} {
    set mismatches {}
    foreach {unihex hex} $map {
        set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits
        set unich [subst "\\U$unihex"]
        if {[encoding convertfrom -profile strict $enc [binary decode hex $hex]] ne $unich} {
            lappend mismatches "<[printable $unich],$hex>"
        }
    }
    return $mismatches
}
proc ucmConverttoMismatches {enc map} {
    set mismatches {}
    foreach {unihex hex} $map {
        set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits
        set unich [subst "\\U$unihex"]
        if {[encoding convertto -profile strict $enc $unich] ne [binary decode hex $hex]} {
            lappend mismatches "<[printable $unich],$hex>"
        }
    }
    return $mismatches
}
if {[info commands printable] eq ""} {
    proc printable {s} {
        set print ""
        foreach c [split $s ""] {
            set i [scan $c %c]
            if {[string is print $c] && ($i <= 127)} {
                append print $c
            } elseif {$i <= 0xff} {
                append print \\x[format %02X $i]
            } elseif {$i <= 0xffff} {
                append print \\u[format %04X $i]
            } else {
                append print \\U[format %08X $i]
            }
        }
        return $print
    }
}
    }
} ; # generate_boilerplate

proc ucm::generate_tests {} {
    variable encNameMap
    variable charMap
    variable invalidCodeSequences
    variable unmappedCodePoints
    variable outputPath
    variable outputChan
    variable encSubchar

    if {[info exists outputPath]} {
        set outputChan [open $outputPath w]
        fconfigure $outputChan -translation lf
    } else {
        set outputChan stdout
    }

    array set tclNames {}
    foreach encName [encoding names] {
        set tclNames($encName) ""
    }

    generate_boilerplate
    foreach encName [lsort -dictionary [array names encNameMap]] {
        if {![info exists charMap($encName)]} {
            warn "No character map read for $encName"
            continue
        }
        unset tclNames($encName)

        # Print the valid tests
        print "\n#\n# $encName (generated from $encNameMap($encName))"
        print "\ntest encoding-convertfrom-ucmCompare-$encName {Compare against ICU UCM} -body \{"
        print "    ucmConvertfromMismatches $encName {$charMap($encName)}"
        print "\} -result {}"
        print "\ntest encoding-convertto-ucmCompare-$encName {Compare against ICU UCM} -body \{"
        print "    ucmConverttoMismatches $encName {$charMap($encName)}"
        print "\} -result {}"
        if {0} {
            # This will generate individual tests for every char
            # and test in lead, tail, middle, solo configurations
            # but takes considerable time
            print "lappend encValidStrings \{*\}\{"
            foreach {unich hex} $charMap($encName) {
                print "    $encName \\u$unich $hex {} {}"
            }
            print "\}; # $encName"
        }

        # Generate the invalidity checks
        print "\n# $encName - invalid byte sequences"
        print "lappend encInvalidBytes \{*\}\{"
        foreach hex $invalidCodeSequences($encName) {
            # Map XXXX... to \xXX\xXX...
            set uhex [regsub -all .. $hex {\\x\0}]
            set uhex \\U[string range 00000000$hex end-7 end]
            print "    $encName $hex tcl8    $uhex -1 {} {}"
            print "    $encName $hex replace \\uFFFD -1 {} {}"
            print "    $encName $hex strict  {}       0 {} {}"
        }
        print "\}; # $encName"

        print "\n# $encName - invalid byte sequences"
        print "lappend encUnencodableStrings \{*\}\{"
        if {[info exists encSubchar($encName)]} {
            set subchar $encSubchar($encName)
        } else {
            set subchar "3F"; # Tcl uses ? by default
        }
        foreach hex $unmappedCodePoints($encName) {
            set uhex \\U[string range 00000000$hex end-7 end]
            print "    $encName $uhex tcl8    $subchar -1 {} {}"
            print "    $encName $uhex replace $subchar -1 {} {}"
            print "    $encName $uhex strict  {}                      0 {} {}"
        }
        print "\}; # $encName"
    }

    if {[array size tclNames]} {
        warn "Missing encoding: [lsort [array names tclNames]]"
    }
    if {[info exists outputPath]} {
        close $outputChan
        unset outputChan
    }
}

proc ucm::parse_file {encName ucmPath} {
    variable charMap
    variable encSubchar

    set fd [open $ucmPath]
    try {
        # Parse the metadata
        unset -nocomplain state
        while {[gets $fd line] >= 0} {
            if {[regexp {<(code_set_name|mb_cur_max|mb_cur_min|uconv_class|subchar)>\s+(\S+)} $line -> key val]} {
                set state($key) $val
            } elseif {[regexp {^\s*CHARMAP\s*$} $line]} {
                set state(charmap) ""
                break
            } else {
                # Skip all else
            }
        }
        if {![info exists state(charmap)]} {
            abort "Error: $ucmPath has No CHARMAP line."
        }
        foreach key {code_set_name uconv_class} {
            if {[info exists state($key)]} {
                set state($key) [string trim $state($key) {"}]
            }
        }
        if {[info exists charMap($encName)]} {
            abort "Duplicate file for $encName ($path)"
        }
        if {![info exists state(uconv_class)]} {
            abort "Error: $ucmPath has no uconv_class definition."
        }
        if {[info exists state(subchar)]} {
            # \xNN\xNN.. -> NNNN..
            set encSubchar($encName) [string map {\\x {}} $state(subchar)]
        }
        switch -exact -- $state(uconv_class) {
            SBCS {
                if {[catch {
                    parse_SBCS $encName $fd
                } result]} {
                    abort "Could not process $ucmPath. $result"
                }
            }
            default {
                log "Skipping $ucmPath -- not SBCS encoding."
                return
            }
        }
    } finally {
        close $fd
    }
}

proc ucm::run {} {
    variable encNameMap
    variable outputPath
    switch [llength $::argv] {
        2 {set outputPath [lindex $::argv 1]}
        1 {}
        default {
            abort "Usage: [info nameofexecutable] $::argv0 path/to/icu/ucm/data ?outputfile?"
        }
    }
    foreach {encName fname} [array get encNameMap] {
        ucm::parse_file $encName [file join [lindex $::argv 0] ${fname}.ucm]
    }
    generate_tests
}

ucm::run