Tcl Source Code

	codePtr->localCachePtr->refCount++;
    }

    /*
     * Report on what the assembler did.
     */

#ifdef TCL_COMPILE_DEBUG
    if (tclTraceCompile >= 2) {
	TclPrintByteCodeObj(interp, objPtr);
	fflush(stdout);
    }
#endif /* TCL_COMPILE_DEBUG */

    return codePtr;
}

/*
 *-----------------------------------------------------------------------------
 *

	/* Make array element cease to exist; element is stktop, array name is
	 * stknext; op1 is 1 for errors on problems, 0 otherwise */
    {"unsetStk",	 2,    -1,        1,	{OPERAND_UINT1}},
	/* Make general variable cease to exist; unparsed variable name is
	 * stktop; op1 is 1 for errors on problems, 0 otherwise */

    {"dictExpand",       1,    -1,        0,    {OPERAND_NONE}},
        /* Probe into a dict and extract it (or a subdict of it) into
         * variables with matched names. Produces list of keys bound as
         * result. Part of [dict with].
	 * Stack:  ... dict path => ... keyList */
    {"dictRecombineStk", 1,    -3,        0,    {OPERAND_NONE}},
        /* Map variable contents back into a dictionary in a variable. Part of
         * [dict with].
	 * Stack:  ... dictVarName path keyList => ... */
    {"dictRecombineImm", 5,    -2,        1,    {OPERAND_LVT4}},
        /* Map variable contents back into a dictionary in the local variable
         * indicated by the LVT index. Part of [dict with].
	 * Stack:  ... path keyList => ... */
    {"dictExists",	 5,	INT_MIN,  1,	{OPERAND_UINT4}},
	/* The top op4 words (min 1) are a key path into the dictionary just
	 * below the keys on the stack, and all those values are replaced by a
	 * boolean indicating whether it is possible to read out a value from
	 * that key-path (like [dict exists]).
	 * Stack:  ... dict key1 ... keyN => ... boolean */

	/* Lappend list to array element.
	 * Stack:  ... arrayName elem list => ... listVarContents */
    {"lappendListStk",	 1,	-1,	0,	{OPERAND_NONE}},
	/* Lappend list to general variable.
	 * Stack:  ... varName list => ... listVarContents */

    {"clockRead",	 2,	+1,	1,	{OPERAND_UINT1}},
        /* Read clock out to the stack. Operand is which clock to read
	 * 0=clicks, 1=microseconds, 2=milliseconds, 3=seconds.
	 * Stack: ... => ... time */

    {"dictGetDef",	  5,	INT_MIN,   1,	{OPERAND_UINT4}},
	/* The top word is the default, the next op4 words (min 1) are a key
	 * path into the dictionary just below the keys on the stack, and all
	 * those values are replaced by the value read out of that key-path

#ifdef TCL_COMPILE_DEBUG
    TclVerifyLocalLiteralTable(&compEnv);
#endif /*TCL_COMPILE_DEBUG*/

    if (result == TCL_OK) {
	(void) TclInitByteCodeObj(objPtr, &tclByteCodeType, &compEnv);
#ifdef TCL_COMPILE_DEBUG
	if (tclTraceCompile >= 2) {
	    TclPrintByteCodeObj(interp, objPtr);
	    fflush(stdout);
	}
#endif /* TCL_COMPILE_DEBUG */
    }

    TclFreeCompileEnv(&compEnv);
    return result;
}

/*

	TclFreeCompileEnv(&compEnv);

	SubstFlags(objPtr) = INT2PTR(flags);
	if (iPtr->varFramePtr->localCachePtr) {
	    codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
	    codePtr->localCachePtr->refCount++;
	}
#ifdef TCL_COMPILE_DEBUG
	if (tclTraceCompile >= 2) {
	    TclPrintByteCodeObj(interp, objPtr);
	    fflush(stdout);
	}
#endif /* TCL_COMPILE_DEBUG */
    }
    return codePtr;
}

/*
 *----------------------------------------------------------------------
 *

		(tokenPtr->start[1] == '\n')) {
		if (isLiteral) {
		    int clPos = Tcl_DStringLength(&textBuffer);

		    if (numCL >= maxNumCL) {
			maxNumCL *= 2;
			clPosition = (int *)ckrealloc(clPosition,
                                maxNumCL * sizeof(int));
		    }
		    clPosition[numCL] = clPos;
		    numCL ++;
		}
		adjust++;
	    }
	    break;

	     * Prevent circular reference where the bytecode internalrep of
	     * a value contains a literal which is that same value.
	     * If this is allowed to happen, refcount decrements may not
	     * reach zero, and memory may leak.  Bugs 467523, 3357771
	     *
	     * NOTE:  [Bugs 3392070, 3389764] We make a copy based completely
	     * on the string value, and do not call Tcl_DuplicateObj() so we
             * can be sure we do not have any lingering cycles hiding in
	     * the internalrep.
	     */
	    int numBytes;
	    const char *bytes = TclGetStringFromObj(objPtr, &numBytes);
	    Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes);

	    Tcl_IncrRefCount(copyPtr);

#endif
MODULE_SCOPE Tcl_Size TclLocalScalar(const char *bytes, TCL_HASH_TYPE numBytes,
			    CompileEnv *envPtr);
MODULE_SCOPE Tcl_Size TclLocalScalarFromToken(Tcl_Token *tokenPtr,
			    CompileEnv *envPtr);
MODULE_SCOPE void	TclOptimizeBytecode(void *envPtr);
#ifdef TCL_COMPILE_DEBUG
MODULE_SCOPE void	TclPrintByteCodeObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);

#endif
MODULE_SCOPE int	TclPrintInstruction(ByteCode *codePtr,
			    const unsigned char *pc);
MODULE_SCOPE void	TclPrintObject(FILE *outFile,
			    Tcl_Obj *objPtr, Tcl_Size maxChars);
MODULE_SCOPE void	TclPrintSource(FILE *outFile,
			    const char *string, Tcl_Size maxChars);

    }
}

#ifdef TCL_COMPILE_DEBUG
/*
 *----------------------------------------------------------------------
 *
 * TclPrintByteCodeObj --
 *
 *	This procedure prints ("disassembles") the instructions of a bytecode
 *	object to stdout.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclPrintByteCodeObj(
    TCL_UNUSED(Tcl_Interp *),	/* Stuck with this in internal stubs */
    Tcl_Obj *objPtr)		/* The bytecode object to disassemble. */
{

    Tcl_Obj *bufPtr = DisassembleByteCodeObj(objPtr);

    fprintf(stdout, "\n%s", TclGetString(bufPtr));
    Tcl_DecrRefCount(bufPtr);


}

/*
 *----------------------------------------------------------------------
 *
 * TclPrintInstruction --
 *

    case INST_LNOT:
    case INST_BITNOT:
    case INST_UMINUS:
    case INST_UPLUS:
    case INST_TRY_CVT_TO_NUMERIC:
    case INST_EXPAND_STKTOP:
    case INST_EXPR_STK:
        objc = 1;
        break;

    case INST_LIST_IN:
    case INST_LIST_NOT_IN:	/* Basic list containment operators. */
    case INST_STR_EQ:
    case INST_STR_NEQ:		/* String (in)equality check */
    case INST_STR_CMP:		/* String compare. */
    case INST_STR_INDEX:

    case INST_BITXOR:
    case INST_BITAND:
    case INST_EXPON:
    case INST_ADD:
    case INST_SUB:
    case INST_DIV:
    case INST_MULT:
        objc = 2;
        break;

    case INST_RETURN_STK:
        /* early pop. TODO: dig out opt dict too :/ */
        objc = 1;
        break;

    case INST_SYNTAX:
    case INST_RETURN_IMM:
        objc = 2;
        break;

    case INST_INVOKE_STK4:
	objc = TclGetUInt4AtPtr(pc+1);
        break;

    case INST_INVOKE_STK1:
	objc = TclGetUInt1AtPtr(pc+1);
	break;
    }

    result = iPtr->innerContext;
    if (Tcl_IsShared(result)) {
        Tcl_DecrRefCount(result);
        iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL);
        Tcl_IncrRefCount(result);
    } else {
        Tcl_Size len;

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

	TclListObjLength(interp, result, &len);
        Tcl_ListObjReplace(interp, result, 0, len, 0, NULL);
    }
    Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc));

    for (; objc>0 ; objc--) {
        Tcl_Obj *objPtr;

        objPtr = tosPtr[1 - objc];
        if (!objPtr) {
            Tcl_Panic("InnerContext: bad tos -- appending null object");
        }
        if ((objPtr->refCount<=0)
#ifdef TCL_MEM_DEBUG
                || (objPtr->refCount==0x61616161)
#endif
        ) {
            Tcl_Panic("InnerContext: bad tos -- appending freed object %p",
                    objPtr);
        }
        Tcl_ListObjAppendElement(NULL, result, objPtr);
    }

    return result;
}

/*
 *----------------------------------------------------------------------

    char *dst;

    InstNameGetInternalRep(objPtr, inst);

    if (inst > LAST_INST_OPCODE) {
	dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5);
	TclOOM(dst, TCL_INTEGER_SPACE + 5);
        snprintf(dst, TCL_INTEGER_SPACE + 5, "inst_%" TCL_Z_MODIFIER "u", inst);
	(void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
    } else {
	const char *s = tclInstructionTable[inst].name;
	size_t len = strlen(s);
	dst = Tcl_InitStringRep(objPtr, s, len);
	TclOOM(dst, len);
    }

    TclDictPut(NULL, description, "variables", variables);
    TclDictPut(NULL, description, "exception", exn);
    TclDictPut(NULL, description, "instructions", instructions);
    TclDictPut(NULL, description, "auxiliary", aux);
    TclDictPut(NULL, description, "commands", commands);
    TclDictPut(NULL, description, "script",
	    Tcl_NewStringObj(codePtr->source, codePtr->numSrcBytes));
    TclDictPut(NULL, description, "namespace", 
	    Tcl_NewStringObj(codePtr->nsPtr->fullName, -1));
    TclDictPut(NULL, description, "stackdepth",
	    Tcl_NewWideIntObj(codePtr->maxStackDepth));
    TclDictPut(NULL, description, "exceptdepth",
	    Tcl_NewWideIntObj(codePtr->maxExceptDepth));
    if (line >= 0) {
	TclDictPut(NULL, description, "initiallinenumber",

	TclEmitOpcode(INST_DONE, &compEnv);
	codePtr = TclInitByteCodeObj(objPtr, &exprCodeType, &compEnv);
	TclFreeCompileEnv(&compEnv);
	if (iPtr->varFramePtr->localCachePtr) {
	    codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
	    codePtr->localCachePtr->refCount++;
	}
#ifdef TCL_COMPILE_DEBUG
	if (tclTraceCompile == 2) {
	    TclPrintByteCodeObj(interp, objPtr);
	    fflush(stdout);
	}
#endif /* TCL_COMPILE_DEBUG */
    }
    return codePtr;
}

/*
 *----------------------------------------------------------------------
 *

    /*
     * Globals: variables that store state, must remain valid at all times.
     */

    Tcl_Obj **tosPtr;		/* Cached pointer to top of evaluation
				 * stack. */
    const unsigned char *pc = (const unsigned char *)data[1];
                                /* The current program counter. */
    unsigned char inst;         /* The currently running instruction */

    /*
     * Transfer variables - needed only between opcodes, but not while
     * executing an instruction.
     */

    int cleanup = PTR2INT(data[2]);
    Tcl_Obj *objResultPtr;
    int checkInterp = 0;        /* Indicates when a check of interp readyness
				 * is necessary. Set by CACHE_STACK_INFO() */

    /*
     * Locals - variables that are used within opcodes or bounded sections of
     * the file (jumps between opcodes within a family).
     * NOTE: These are now mostly defined locally where needed.
     */

	    TclNewObj(objPtr);
	    Tcl_IncrRefCount(objPtr);
	    iPtr->objResultPtr = objPtr;
	}

	goto cleanup0;
    } else {
        /* resume from invocation */
	CACHE_STACK_INFO();

	NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
	if (bcFramePtr->cmdObj) {
	    Tcl_DecrRefCount(bcFramePtr->cmdObj);
	    bcFramePtr->cmdObj = NULL;
	    bcFramePtr->cmd = NULL;

#ifdef TCL_COMPILE_DEBUG
	if (tclTraceExec >= 2) {
	    if (traceInstructions) {
		TRACE_APPEND(("YIELD...\n"));
	    } else {
		fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) yielding value \"%.30s\"\n",
			iPtr->numLevels, (pc - codePtr->codeStart),
			Tcl_GetString(OBJ_AT_TOS));
	    }
	    fflush(stdout);
	}
#endif
	yieldParameter = NULL;	/*==CORO_ACTIVATE_YIELD*/
	Tcl_SetObjResult(interp, OBJ_AT_TOS);
	goto doYield;

	if (continueLoop) {
	    listTmpIndex = infoPtr->firstValueTemp;
	    for (i = 0;  i < numLists;  i++) {
		varListPtr = infoPtr->varLists[i];
		numVars = varListPtr->numVars;

		listVarPtr = LOCAL(listTmpIndex);
                /* Do not use TclListObjCopy here - shimmers arithseries to list */
		listPtr = Tcl_DuplicateObj(listVarPtr->value.objPtr);
		TclListObjGetElements(interp, listPtr, &listLen, &elements);

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

Tcl_Obj *
TclGetSourceFromFrame(
    CmdFrame *cfPtr,
    Tcl_Size objc,
    Tcl_Obj *const objv[])
{
    if (cfPtr == NULL) {
        return Tcl_NewListObj(objc, objv);
    }
    if (cfPtr->cmdObj == NULL) {
        if (cfPtr->cmd == NULL) {
	    ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;

            cfPtr->cmd = GetSrcInfoForPc((unsigned char *)
		    cfPtr->data.tebc.pc, codePtr, &cfPtr->len, NULL, NULL);
        }
	if (cfPtr->cmd) {
	    cfPtr->cmdObj = Tcl_NewStringObj(cfPtr->cmd, cfPtr->len);
	} else {
	    cfPtr->cmdObj = Tcl_NewListObj(objc, objv);
	}
        Tcl_IncrRefCount(cfPtr->cmdObj);
    }
    return cfPtr->cmdObj;
}

void
TclGetSrcInfoForPc(
    CmdFrame *cfPtr)