通讯编程

开发平台：

Visual C++

tclExecute.c：源码内容

/*
* Shifts are never usefully 64-bits wide!
*/
FORCE_LONG(value2Ptr, i2, w2);
if (valuePtr->typePtr == &tclWideIntType) {
#ifdef TCL_COMPILE_DEBUG
w2 = Tcl_LongAsWide(i2);
#endif /* TCL_COMPILE_DEBUG */
if (w < 0) {
wResult = ~w;
} else {
wResult = w;
}
/*
* Shift in steps when the shift gets large to prevent
* annoying compiler/processor bugs. [Bug 868467]
*/
if (i2 >= 64) {
wResult = Tcl_LongAsWide(0);
} else if (i2 > 60) {
wResult >>= 30;
wResult >>= 30;
wResult >>= i2-60;
} else if (i2 > 30) {
wResult >>= 30;
wResult >>= i2-30;
} else {
wResult >>= i2;
}
if (w < 0) {
wResult = ~wResult;
}
doWide = 1;
break;
}
if (i < 0) {
iResult = ~i;
} else {
iResult = i;
}
/*
* Shift in steps when the shift gets large to prevent
* annoying compiler/processor bugs. [Bug 868467]
*/
if (i2 >= 64) {
iResult = 0;
} else if (i2 > 60) {
iResult >>= 30;
iResult >>= 30;
iResult >>= i2-60;
} else if (i2 > 30) {
iResult >>= 30;
iResult >>= i2-30;
} else {
iResult >>= i2;
}
if (i < 0) {
iResult = ~iResult;
}
break;
case INST_BITOR:
if (valuePtr->typePtr == &tclWideIntType
|| value2Ptr->typePtr == &tclWideIntType) {
/*
* Promote to wide
*/
if (valuePtr->typePtr == &tclIntType) {
w = Tcl_LongAsWide(i);
} else if (value2Ptr->typePtr == &tclIntType) {
w2 = Tcl_LongAsWide(i2);
}
wResult = w | w2;
doWide = 1;
break;
}
iResult = i | i2;
break;
case INST_BITXOR:
if (valuePtr->typePtr == &tclWideIntType
|| value2Ptr->typePtr == &tclWideIntType) {
/*
* Promote to wide
*/
if (valuePtr->typePtr == &tclIntType) {
w = Tcl_LongAsWide(i);
} else if (value2Ptr->typePtr == &tclIntType) {
w2 = Tcl_LongAsWide(i2);
}
wResult = w ^ w2;
doWide = 1;
break;
}
iResult = i ^ i2;
break;
case INST_BITAND:
if (valuePtr->typePtr == &tclWideIntType
|| value2Ptr->typePtr == &tclWideIntType) {
/*
* Promote to wide
*/
if (valuePtr->typePtr == &tclIntType) {
w = Tcl_LongAsWide(i);
} else if (value2Ptr->typePtr == &tclIntType) {
w2 = Tcl_LongAsWide(i2);
}
wResult = w & w2;
doWide = 1;
break;
}
iResult = i & i2;
break;
}
/*
* Reuse the valuePtr object already on stack if possible.
*/
if (Tcl_IsShared(valuePtr)) {
if (doWide) {
objResultPtr = Tcl_NewWideIntObj(wResult);
TRACE((LLD" "LLD" => "LLD"n", w, w2, wResult));
} else {
objResultPtr = Tcl_NewLongObj(iResult);
TRACE(("%ld %ld => %ldn", i, i2, iResult));
}
NEXT_INST_F(1, 2, 1);
} else { /* reuse the valuePtr object */
if (doWide) {
TRACE((LLD" "LLD" => "LLD"n", w, w2, wResult));
Tcl_SetWideIntObj(valuePtr, wResult);
} else {
TRACE(("%ld %ld => %ldn", i, i2, iResult));
Tcl_SetLongObj(valuePtr, iResult);
}
NEXT_INST_F(1, 1, 0);
}
}
case INST_ADD:
case INST_SUB:
case INST_MULT:
case INST_DIV:
{
/*
* Operands must be numeric and ints get converted to floats
* if necessary. We compute value op value2.
*/
Tcl_ObjType *t1Ptr, *t2Ptr;
long i2 = 0, quot, rem; /* Init. avoids compiler warning. */
double d1, d2;
long iResult = 0; /* Init. avoids compiler warning. */
double dResult = 0.0; /* Init. avoids compiler warning. */
int doDouble = 0; /* 1 if doing floating arithmetic */
Tcl_WideInt w2, wquot, wrem;
Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */
int doWide = 0; /* 1 if doing wide arithmetic. */
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
t1Ptr = valuePtr->typePtr;
t2Ptr = value2Ptr->typePtr;
if (t1Ptr == &tclIntType) {
i = valuePtr->internalRep.longValue;
} else if (t1Ptr == &tclWideIntType) {
TclGetWide(w,valuePtr);
} else if ((t1Ptr == &tclDoubleType)
&& (valuePtr->bytes == NULL)) {
/*
* We can only use the internal rep directly if there is
* no string rep. Otherwise the string rep might actually
* look like an integer, which is preferred.
*/
d1 = valuePtr->internalRep.doubleValue;
} else {
char *s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, valuePtr, i, w);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d1);
}
if (result != TCL_OK) {
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %sn",
s, O2S(valuePtr),
(valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto checkForCatch;
}
t1Ptr = valuePtr->typePtr;
}
if (t2Ptr == &tclIntType) {
i2 = value2Ptr->internalRep.longValue;
} else if (t2Ptr == &tclWideIntType) {
TclGetWide(w2,value2Ptr);
} else if ((t2Ptr == &tclDoubleType)
&& (value2Ptr->bytes == NULL)) {
/*
* We can only use the internal rep directly if there is
* no string rep. Otherwise the string rep might actually
* look like an integer, which is preferred.
*/
d2 = value2Ptr->internalRep.doubleValue;
} else {
char *s = Tcl_GetStringFromObj(value2Ptr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, value2Ptr, i2, w2);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
value2Ptr, &d2);
}
if (result != TCL_OK) {
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %sn",
O2S(value2Ptr), s,
(value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, value2Ptr);
CACHE_STACK_INFO();
goto checkForCatch;
}
t2Ptr = value2Ptr->typePtr;
}
if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
/*
* Do double arithmetic.
*/
doDouble = 1;
if (t1Ptr == &tclIntType) {
d1 = i; /* promote value 1 to double */
} else if (t2Ptr == &tclIntType) {
d2 = i2; /* promote value 2 to double */
} else if (t1Ptr == &tclWideIntType) {
d1 = Tcl_WideAsDouble(w);
} else if (t2Ptr == &tclWideIntType) {
d2 = Tcl_WideAsDouble(w2);
}
switch (*pc) {
case INST_ADD:
dResult = d1 + d2;
break;
case INST_SUB:
dResult = d1 - d2;
break;
case INST_MULT:
dResult = d1 * d2;
break;
case INST_DIV:
if (d2 == 0.0) {
TRACE(("%.6g %.6g => DIVIDE BY ZEROn", d1, d2));
goto divideByZero;
}
dResult = d1 / d2;
break;
}
/*
* Check now for IEEE floating-point error.
*/
if (IS_NAN(dResult) || IS_INF(dResult)) {
TRACE(("%.20s %.20s => IEEE FLOATING PT ERRORn",
O2S(valuePtr), O2S(value2Ptr)));
DECACHE_STACK_INFO();
TclExprFloatError(interp, dResult);
CACHE_STACK_INFO();
result = TCL_ERROR;
goto checkForCatch;
}
} else if ((t1Ptr == &tclWideIntType)
|| (t2Ptr == &tclWideIntType)) {
/*
* Do wide integer arithmetic.
*/
doWide = 1;
if (t1Ptr == &tclIntType) {
w = Tcl_LongAsWide(i);
} else if (t2Ptr == &tclIntType) {
w2 = Tcl_LongAsWide(i2);
}
switch (*pc) {
case INST_ADD:
wResult = w + w2;
break;
case INST_SUB:
wResult = w - w2;
break;
case INST_MULT:
wResult = w * w2;
break;
case INST_DIV:
/*
* This code is tricky: C doesn't guarantee much
* about the quotient or remainder, but Tcl does.
* The remainder always has the same sign as the
* divisor and a smaller absolute value.
*/
if (w2 == W0) {
TRACE((LLD" "LLD" => DIVIDE BY ZEROn", w, w2));
goto divideByZero;
}
if (w2 < 0) {
w2 = -w2;
w = -w;
}
wquot = w / w2;
wrem = w % w2;
if (wrem < W0) {
wquot -= 1;
}
wResult = wquot;
break;
}
} else {
/*
* Do integer arithmetic.
*/
switch (*pc) {
case INST_ADD:
iResult = i + i2;
break;
case INST_SUB:
iResult = i - i2;
break;
case INST_MULT:
iResult = i * i2;
break;
case INST_DIV:
/*
* This code is tricky: C doesn't guarantee much
* about the quotient or remainder, but Tcl does.
* The remainder always has the same sign as the
* divisor and a smaller absolute value.
*/
if (i2 == 0) {
TRACE(("%ld %ld => DIVIDE BY ZEROn", i, i2));
goto divideByZero;
}
if (i2 < 0) {
i2 = -i2;
i = -i;
}
quot = i / i2;
rem = i % i2;
if (rem < 0) {
quot -= 1;
}
iResult = quot;
break;
}
}
/*
* Reuse the valuePtr object already on stack if possible.
*/
if (Tcl_IsShared(valuePtr)) {
if (doDouble) {
objResultPtr = Tcl_NewDoubleObj(dResult);
TRACE(("%.6g %.6g => %.6gn", d1, d2, dResult));
} else if (doWide) {
objResultPtr = Tcl_NewWideIntObj(wResult);
TRACE((LLD" "LLD" => "LLD"n", w, w2, wResult));
} else {
objResultPtr = Tcl_NewLongObj(iResult);
TRACE(("%ld %ld => %ldn", i, i2, iResult));
}
NEXT_INST_F(1, 2, 1);
} else { /* reuse the valuePtr object */
if (doDouble) { /* NB: stack top is off by 1 */
TRACE(("%.6g %.6g => %.6gn", d1, d2, dResult));
Tcl_SetDoubleObj(valuePtr, dResult);
} else if (doWide) {
TRACE((LLD" "LLD" => "LLD"n", w, w2, wResult));
Tcl_SetWideIntObj(valuePtr, wResult);
} else {
TRACE(("%ld %ld => %ldn", i, i2, iResult));
Tcl_SetLongObj(valuePtr, iResult);
}
NEXT_INST_F(1, 1, 0);
}
}
case INST_UPLUS:
{
/*
* Operand must be numeric.
*/
double d;
Tcl_ObjType *tPtr;
valuePtr = stackPtr[stackTop];
tPtr = valuePtr->typePtr;
if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
|| (valuePtr->bytes != NULL))) {
char *s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, valuePtr, i, w);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
}
if (result != TCL_OK) {
TRACE((""%.20s" => ILLEGAL TYPE %s n",
s, (tPtr? tPtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto checkForCatch;
}
tPtr = valuePtr->typePtr;
}
/*
* Ensure that the operand's string rep is the same as the
* formatted version of its internal rep. This makes sure
* that "expr +000123" yields "83", not "000123". We
* implement this by _discarding_ the string rep since we
* know it will be regenerated, if needed later, by
* formatting the internal rep's value.
*/
if (Tcl_IsShared(valuePtr)) {
if (tPtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
objResultPtr = Tcl_NewLongObj(i);
} else if (tPtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
objResultPtr = Tcl_NewWideIntObj(w);
} else {
d = valuePtr->internalRep.doubleValue;
objResultPtr = Tcl_NewDoubleObj(d);
}
TRACE_WITH_OBJ(("%s => ", O2S(objResultPtr)), objResultPtr);
NEXT_INST_F(1, 1, 1);
} else {
Tcl_InvalidateStringRep(valuePtr);
TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);
NEXT_INST_F(1, 0, 0);
}
}
case INST_UMINUS:
case INST_LNOT:
{
/*
* The operand must be numeric or a boolean string as
* accepted by Tcl_GetBooleanFromObj(). If the operand
* object is unshared modify it directly, otherwise
* create a copy to modify: this is "copy on write".
* Free any old string representation since it is now
* invalid.
*/
double d;
int boolvar;
Tcl_ObjType *tPtr;
valuePtr = stackPtr[stackTop];
tPtr = valuePtr->typePtr;
if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
|| (valuePtr->bytes != NULL))) {
if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) {
valuePtr->typePtr = &tclIntType;
} else {
char *s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, valuePtr, i, w);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d);
}
if (result == TCL_ERROR && *pc == INST_LNOT) {
result = Tcl_GetBooleanFromObj((Tcl_Interp *)NULL,
valuePtr, &boolvar);
i = (long)boolvar; /* i is long, not int! */
}
if (result != TCL_OK) {
TRACE((""%.20s" => ILLEGAL TYPE %sn",
s, (tPtr? tPtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto checkForCatch;
}
}
tPtr = valuePtr->typePtr;
}
if (Tcl_IsShared(valuePtr)) {
/*
* Create a new object.
*/
if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
i = valuePtr->internalRep.longValue;
objResultPtr = Tcl_NewLongObj(
(*pc == INST_UMINUS)? -i : !i);
TRACE_WITH_OBJ(("%ld => ", i), objResultPtr);
} else if (tPtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
if (*pc == INST_UMINUS) {
objResultPtr = Tcl_NewWideIntObj(-w);
} else {
objResultPtr = Tcl_NewLongObj(w == W0);
}
TRACE_WITH_OBJ((LLD" => ", w), objResultPtr);
} else {
d = valuePtr->internalRep.doubleValue;
if (*pc == INST_UMINUS) {
objResultPtr = Tcl_NewDoubleObj(-d);
} else {
/*
* Should be able to use "!d", but apparently
* some compilers can't handle it.
*/
objResultPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
}
TRACE_WITH_OBJ(("%.6g => ", d), objResultPtr);
}
NEXT_INST_F(1, 1, 1);
} else {
/*
* valuePtr is unshared. Modify it directly.
*/
if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
i = valuePtr->internalRep.longValue;
Tcl_SetLongObj(valuePtr,
(*pc == INST_UMINUS)? -i : !i);
TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
} else if (tPtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
if (*pc == INST_UMINUS) {
Tcl_SetWideIntObj(valuePtr, -w);
} else {
Tcl_SetLongObj(valuePtr, w == W0);
}
TRACE_WITH_OBJ((LLD" => ", w), valuePtr);
} else {
d = valuePtr->internalRep.doubleValue;
if (*pc == INST_UMINUS) {
Tcl_SetDoubleObj(valuePtr, -d);
} else {
/*
* Should be able to use "!d", but apparently
* some compilers can't handle it.
*/
Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
}
TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
}
NEXT_INST_F(1, 0, 0);
}
}
case INST_BITNOT:
{
/*
* The operand must be an integer. If the operand object is
* unshared modify it directly, otherwise modify a copy.
* Free any old string representation since it is now
* invalid.
*/
Tcl_ObjType *tPtr;
valuePtr = stackPtr[stackTop];
tPtr = valuePtr->typePtr;
if (!IS_INTEGER_TYPE(tPtr)) {
REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
if (result != TCL_OK) { /* try to convert to double */
TRACE((""%.20s" => ILLEGAL TYPE %sn",
O2S(valuePtr), (tPtr? tPtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto checkForCatch;
}
}
if (valuePtr->typePtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
if (Tcl_IsShared(valuePtr)) {
objResultPtr = Tcl_NewWideIntObj(~w);
TRACE(("0x%llx => (%llu)n", w, ~w));
NEXT_INST_F(1, 1, 1);
} else {
/*
* valuePtr is unshared. Modify it directly.
*/
Tcl_SetWideIntObj(valuePtr, ~w);
TRACE(("0x%llx => (%llu)n", w, ~w));
NEXT_INST_F(1, 0, 0);
}
} else {
i = valuePtr->internalRep.longValue;
if (Tcl_IsShared(valuePtr)) {
objResultPtr = Tcl_NewLongObj(~i);
TRACE(("0x%lx => (%lu)n", i, ~i));
NEXT_INST_F(1, 1, 1);
} else {
/*
* valuePtr is unshared. Modify it directly.
*/
Tcl_SetLongObj(valuePtr, ~i);
TRACE(("0x%lx => (%lu)n", i, ~i));
NEXT_INST_F(1, 0, 0);
}
}
}
case INST_CALL_BUILTIN_FUNC1:
opnd = TclGetUInt1AtPtr(pc+1);
{
/*
* Call one of the built-in Tcl math functions.
*/
BuiltinFunc *mathFuncPtr;
if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %dn", opnd));
panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
}
mathFuncPtr = &(tclBuiltinFuncTable[opnd]);
DECACHE_STACK_INFO();
result = (*mathFuncPtr->proc)(interp, eePtr,
mathFuncPtr->clientData);
CACHE_STACK_INFO();
if (result != TCL_OK) {
goto checkForCatch;
}
TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]);
}
NEXT_INST_F(2, 0, 0);
case INST_CALL_FUNC1:
opnd = TclGetUInt1AtPtr(pc+1);
{
/*
* Call a non-builtin Tcl math function previously
* registered by a call to Tcl_CreateMathFunc.
*/
int objc = opnd; /* Number of arguments. The function name
* is the 0-th argument. */
Tcl_Obj **objv; /* The array of arguments. The function
* name is objv[0]. */
objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */
DECACHE_STACK_INFO();
result = ExprCallMathFunc(interp, eePtr, objc, objv);
CACHE_STACK_INFO();
if (result != TCL_OK) {
goto checkForCatch;
}
TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]);
}
NEXT_INST_F(2, 0, 0);
case INST_TRY_CVT_TO_NUMERIC:
{
/*
* Try to convert the topmost stack object to an int or
* double object. This is done in order to support Tcl's
* policy of interpreting operands if at all possible as
* first integers, else floating-point numbers.
*/
double d;
char *s;
Tcl_ObjType *tPtr;
int converted, needNew;
valuePtr = stackPtr[stackTop];
tPtr = valuePtr->typePtr;
converted = 0;
if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
|| (valuePtr->bytes != NULL))) {
if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) {
valuePtr->typePtr = &tclIntType;
converted = 1;
} else {
s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, valuePtr, i, w);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d);
}
if (result == TCL_OK) {
converted = 1;
}
result = TCL_OK; /* reset the result variable */
}
tPtr = valuePtr->typePtr;
}
/*
* Ensure that the topmost stack object, if numeric, has a
* string rep the same as the formatted version of its
* internal rep. This is used, e.g., to make sure that "expr
* {0001}" yields "1", not "0001". We implement this by
* _discarding_ the string rep since we know it will be
* regenerated, if needed later, by formatting the internal
* rep's value. Also check if there has been an IEEE
* floating point error.
*/
objResultPtr = valuePtr;
needNew = 0;
if (IS_NUMERIC_TYPE(tPtr)) {
if (Tcl_IsShared(valuePtr)) {
if (valuePtr->bytes != NULL) {
/*
* We only need to make a copy of the object
* when it already had a string rep
*/
needNew = 1;
if (tPtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
objResultPtr = Tcl_NewLongObj(i);
} else if (tPtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
objResultPtr = Tcl_NewWideIntObj(w);
} else {
d = valuePtr->internalRep.doubleValue;
objResultPtr = Tcl_NewDoubleObj(d);
}
tPtr = objResultPtr->typePtr;
}
} else {
Tcl_InvalidateStringRep(valuePtr);
}
if (tPtr == &tclDoubleType) {
d = objResultPtr->internalRep.doubleValue;
if (IS_NAN(d) || IS_INF(d)) {
TRACE((""%.20s" => IEEE FLOATING PT ERRORn",
O2S(objResultPtr)));
DECACHE_STACK_INFO();
TclExprFloatError(interp, d);
CACHE_STACK_INFO();
result = TCL_ERROR;
goto checkForCatch;
}
}
converted = converted; /* lint, converted not used. */
TRACE((""%.20s" => numeric, %s, %sn", O2S(valuePtr),
(converted? "converted" : "not converted"),
(needNew? "new Tcl_Obj" : "same Tcl_Obj")));
} else {
TRACE((""%.20s" => not numericn", O2S(valuePtr)));
}
if (needNew) {
NEXT_INST_F(1, 1, 1);
} else {
NEXT_INST_F(1, 0, 0);
}
}
case INST_BREAK:
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
CACHE_STACK_INFO();
result = TCL_BREAK;
cleanup = 0;
goto processExceptionReturn;
case INST_CONTINUE:
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
CACHE_STACK_INFO();
result = TCL_CONTINUE;
cleanup = 0;
goto processExceptionReturn;
case INST_FOREACH_START4:
opnd = TclGetUInt4AtPtr(pc+1);
{
/*
* Initialize the temporary local var that holds the count
* of the number of iterations of the loop body to -1.
*/
ForeachInfo *infoPtr = (ForeachInfo *)
codePtr->auxDataArrayPtr[opnd].clientData;
int iterTmpIndex = infoPtr->loopCtTemp;
Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
Var *iterVarPtr = &(compiledLocals[iterTmpIndex]);
Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr;
if (oldValuePtr == NULL) {
iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
Tcl_IncrRefCount(iterVarPtr->value.objPtr);
} else {
Tcl_SetLongObj(oldValuePtr, -1);
}
TclSetVarScalar(iterVarPtr);
TclClearVarUndefined(iterVarPtr);
TRACE(("%u => loop iter count temp %dn",
opnd, iterTmpIndex));
}
#ifndef TCL_COMPILE_DEBUG
/*
* Remark that the compiler ALWAYS sets INST_FOREACH_STEP4
* immediately after INST_FOREACH_START4 - let us just fall
* through instead of jumping back to the top.
*/
pc += 5;
TCL_DTRACE_INST_NEXT();
#else
NEXT_INST_F(5, 0, 0);
#endif
case INST_FOREACH_STEP4:
opnd = TclGetUInt4AtPtr(pc+1);
{
/*
* "Step" a foreach loop (i.e., begin its next iteration) by
* assigning the next value list element to each loop var.
*/
ForeachInfo *infoPtr = (ForeachInfo *)
codePtr->auxDataArrayPtr[opnd].clientData;
ForeachVarList *varListPtr;
int numLists = infoPtr->numLists;
Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
Tcl_Obj *listPtr;
Var *iterVarPtr, *listVarPtr;
int iterNum, listTmpIndex, listLen, numVars;
int varIndex, valIndex, continueLoop, j;
/*
* Increment the temp holding the loop iteration number.
*/
iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
valuePtr = iterVarPtr->value.objPtr;
iterNum = (valuePtr->internalRep.longValue + 1);
Tcl_SetLongObj(valuePtr, iterNum);
/*
* Check whether all value lists are exhausted and we should
* stop the loop.
*/
continueLoop = 0;
listTmpIndex = infoPtr->firstValueTemp;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
result = Tcl_ListObjLength(interp, listPtr, &listLen);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%u => ERROR converting list %ld, "%s": ",
opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));
goto checkForCatch;
}
if (listLen > (iterNum * numVars)) {
continueLoop = 1;
}
listTmpIndex++;
}
/*
* If some var in some var list still has a remaining list
* element iterate one more time. Assign to var the next
* element from its value list. We already checked above
* that each list temp holds a valid list object.
*/
if (continueLoop) {
listTmpIndex = infoPtr->firstValueTemp;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
Tcl_Obj **elements;
/*
* The call to TclPtrSetVar might shimmer listPtr,
* so re-fetch pointers every iteration for safety.
* See test foreach-10.1.
*/
Tcl_ListObjGetElements(NULL, listPtr,
&listLen, &elements);
if (valIndex >= listLen) {
TclNewObj(valuePtr);
} else {
valuePtr = elements[valIndex];
}
varIndex = varListPtr->varIndexes[j];
varPtr = &(varFramePtr->compiledLocals[varIndex]);
part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
if (!((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL))
&& (varPtr->tracePtr == NULL)
&& (TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr))) {
value2Ptr = varPtr->value.objPtr;
if (valuePtr != value2Ptr) {
if (value2Ptr != NULL) {
TclDecrRefCount(value2Ptr);
} else {
TclSetVarScalar(varPtr);
TclClearVarUndefined(varPtr);
}
varPtr->value.objPtr = valuePtr;
Tcl_IncrRefCount(valuePtr);
}
} else {
DECACHE_STACK_INFO();
Tcl_IncrRefCount(valuePtr);
value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1,
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
TclDecrRefCount(valuePtr);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
opnd, varIndex),
Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
}
valIndex++;
}
listTmpIndex++;
}
}
TRACE(("%u => %d lists, iter %d, %s loopn", opnd, numLists,
iterNum, (continueLoop? "continue" : "exit")));
/*
* Run-time peep-hole optimisation: the compiler ALWAYS follows
* INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that
* instruction and jump direct from here.
*/
pc += 5;
if (*pc == INST_JUMP_FALSE1) {
NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0);
} else {
NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
}
}
case INST_BEGIN_CATCH4:
/*
* Record start of the catch command with exception range index
* equal to the operand. Push the current stack depth onto the
* special catch stack.
*/
catchStackPtr[++catchTop] = stackTop;
TRACE(("%u => catchTop=%d, stackTop=%dn",
TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
NEXT_INST_F(5, 0, 0);
case INST_END_CATCH:
catchTop--;
result = TCL_OK;
TRACE(("=> catchTop=%dn", catchTop));
NEXT_INST_F(1, 0, 0);
case INST_PUSH_RESULT:
objResultPtr = Tcl_GetObjResult(interp);
TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
/*
* See the comments at INST_INVOKE_STK
*/
{
Tcl_Obj *newObjResultPtr;
TclNewObj(newObjResultPtr);
Tcl_IncrRefCount(newObjResultPtr);
iPtr->objResultPtr = newObjResultPtr;
}
NEXT_INST_F(1, 0, -1);
case INST_PUSH_RETURN_CODE:
objResultPtr = Tcl_NewLongObj(result);
TRACE(("=> %un", result));
NEXT_INST_F(1, 0, 1);
default:
panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
} /* end of switch on opCode */
/*
* Division by zero in an expression. Control only reaches this
* point by "goto divideByZero".
*/
divideByZero:
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
(char *) NULL);
CACHE_STACK_INFO();
result = TCL_ERROR;
goto checkForCatch;
/*
* An external evaluation (INST_INVOKE or INST_EVAL) returned
* something different from TCL_OK, or else INST_BREAK or
* INST_CONTINUE were called.
*/
processExceptionReturn:
#if TCL_COMPILE_DEBUG
switch (*pc) {
case INST_INVOKE_STK1:
case INST_INVOKE_STK4:
TRACE(("%u => ... after "%.20s": ", opnd, cmdNameBuf));
break;
case INST_EVAL_STK:
/*
* Note that the object at stacktop has to be used
* before doing the cleanup.
*/
TRACE((""%.30s" => ", O2S(stackPtr[stackTop])));
break;
default:
TRACE(("=> "));
}
#endif
if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) {
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
if (rangePtr == NULL) {
TRACE_APPEND(("no encl. loop or catch, returning %sn",
StringForResultCode(result)));
goto abnormalReturn;
}
if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
TRACE_APPEND(("%s ...n", StringForResultCode(result)));
goto processCatch;
}
while (cleanup--) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
if (result == TCL_BREAK) {
result = TCL_OK;
pc = (codePtr->codeStart + rangePtr->breakOffset);
TRACE_APPEND(("%s, range at %d, new pc %dn",
StringForResultCode(result),
rangePtr->codeOffset, rangePtr->breakOffset));
NEXT_INST_F(0, 0, 0);
} else {
if (rangePtr->continueOffset == -1) {
TRACE_APPEND(("%s, loop w/o continue, checking for catchn",
StringForResultCode(result)));
goto checkForCatch;
}
result = TCL_OK;
pc = (codePtr->codeStart + rangePtr->continueOffset);
TRACE_APPEND(("%s, range at %d, new pc %dn",
StringForResultCode(result),
rangePtr->codeOffset, rangePtr->continueOffset));
NEXT_INST_F(0, 0, 0);
}
#if TCL_COMPILE_DEBUG
} else if (traceInstructions) {
if ((result != TCL_ERROR) && (result != TCL_RETURN)) {
objPtr = Tcl_GetObjResult(interp);
TRACE_APPEND(("OTHER RETURN CODE %d, result= "%s"n ",
result, O2S(objPtr)));
} else {
objPtr = Tcl_GetObjResult(interp);
TRACE_APPEND(("%s, result= "%s"n",
StringForResultCode(result), O2S(objPtr)));
}
#endif
}
/*
* Execution has generated an "exception" such as TCL_ERROR. If the
* exception is an error, record information about what was being
* executed when the error occurred. Find the closest enclosing
* catch range, if any. If no enclosing catch range is found, stop
* execution and return the "exception" code.
*/
checkForCatch:
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
bytes = GetSrcInfoForPc(pc, codePtr, &length);
if (bytes != NULL) {
DECACHE_STACK_INFO();
Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
CACHE_STACK_INFO();
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
if (catchTop == -1) {
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " ... no enclosing catch, returning %sn",
StringForResultCode(result));
}
#endif
goto abnormalReturn;
}
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
if (rangePtr == NULL) {
/*
* This is only possible when compiling a [catch] that sends its
* script to INST_EVAL. Cannot correct the compiler without
* breakingcompat with previous .tbc compiled scripts.
*/
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " ... no enclosing catch, returning %sn",
StringForResultCode(result));
}
#endif
goto abnormalReturn;
}
/*
* A catch exception range (rangePtr) was found to handle an
* "exception". It was found either by checkForCatch just above or
* by an instruction during break, continue, or error processing.
* Jump to its catchOffset after unwinding the operand stack to
* the depth it had when starting to execute the range's catch
* command.
*/
processCatch:
while (stackTop > catchStackPtr[catchTop]) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %un",
rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],
(unsigned int)(rangePtr->catchOffset));
}
#endif
pc = (codePtr->codeStart + rangePtr->catchOffset);
NEXT_INST_F(0, 0, 0); /* restart the execution loop at pc */
/*
* end of infinite loop dispatching on instructions.
*/
/*
* Abnormal return code. Restore the stack to state it had when starting
* to execute the ByteCode. Panic if the stack is below the initial level.
*/
abnormalReturn:
TCL_DTRACE_INST_LAST();
while (stackTop > initStackTop) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
if (stackTop < initStackTop) {
fprintf(stderr, "nTclExecuteByteCode: abnormal return at pc %u: stack top %d < entry stack top %dn",
(unsigned int)(pc - codePtr->codeStart),
(unsigned int) stackTop,
(unsigned int) initStackTop);
panic("TclExecuteByteCode execution failure: end stack top < start stack top");
}
/*
* Free the catch stack array if malloc'ed storage was used.
*/
if (catchStackPtr != catchStackStorage) {
ckfree((char *) catchStackPtr);
}
eePtr->stackTop = initStackTop;
return result;
#undef STATIC_CATCH_STACK_SIZE
}
#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
*
* PrintByteCodeInfo --
*
* This procedure prints a summary about a bytecode object to stdout.
* It is called by TclExecuteByteCode when starting to execute the
* bytecode object if tclTraceExec has the value 2 or more.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
PrintByteCodeInfo(codePtr)
register ByteCode *codePtr; /* The bytecode whose summary is printed
* to stdout. */
{
Proc *procPtr = codePtr->procPtr;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
fprintf(stdout, "nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)n",
(unsigned int) codePtr, codePtr->refCount,
codePtr->compileEpoch, (unsigned int) iPtr,
iPtr->compileEpoch);
fprintf(stdout, " Source: ");
TclPrintSource(stdout, codePtr->source, 60);
fprintf(stdout, "n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2fn",
codePtr->numCommands, codePtr->numSrcBytes,
codePtr->numCodeBytes, codePtr->numLitObjects,
codePtr->numAuxDataItems, codePtr->maxStackDepth,
#ifdef TCL_COMPILE_STATS
(codePtr->numSrcBytes?
((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
#else
0.0);
#endif
#ifdef TCL_COMPILE_STATS
fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %dn",
codePtr->structureSize,
(sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
codePtr->numCodeBytes,
(codePtr->numLitObjects * sizeof(Tcl_Obj *)),
(codePtr->numExceptRanges * sizeof(ExceptionRange)),
(codePtr->numAuxDataItems * sizeof(AuxData)),
codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */
if (procPtr != NULL) {
fprintf(stdout,
" Proc 0x%x, refCt %d, args %d, compiled locals %dn",
(unsigned int) procPtr, procPtr->refCount,
procPtr->numArgs, procPtr->numCompiledLocals);
}
}
#endif /* TCL_COMPILE_DEBUG */
/*
*----------------------------------------------------------------------
*
* ValidatePcAndStackTop --
*
* This procedure is called by TclExecuteByteCode when debugging to
* verify that the program counter and stack top are valid during
* execution.
*
* Results:
* None.
*
* Side effects:
* Prints a message to stderr and panics if either the pc or stack
* top are invalid.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_COMPILE_DEBUG
static void
ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound)
register ByteCode *codePtr; /* The bytecode whose summary is printed
* to stdout. */
unsigned char *pc; /* Points to first byte of a bytecode
* instruction. The program counter. */
int stackTop; /* Current stack top. Must be between
* stackLowerBound and stackUpperBound
* (inclusive). */
int stackLowerBound; /* Smallest legal value for stackTop. */
{
int stackUpperBound = stackLowerBound + codePtr->maxStackDepth;
/* Greatest legal value for stackTop. */
unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart);
unsigned int codeStart = (unsigned int) codePtr->codeStart;
unsigned int codeEnd = (unsigned int)
(codePtr->codeStart + codePtr->numCodeBytes);
unsigned char opCode = *pc;
if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) {
fprintf(stderr, "nBad instruction pc 0x%x in TclExecuteByteCoden",
(unsigned int) pc);
panic("TclExecuteByteCode execution failure: bad pc");
}
if ((unsigned int) opCode > LAST_INST_OPCODE) {
fprintf(stderr, "nBad opcode %d at pc %u in TclExecuteByteCoden",
(unsigned int) opCode, relativePc);
panic("TclExecuteByteCode execution failure: bad opcode");
}
if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) {
int numChars;
char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
char *ellipsis = "";
fprintf(stderr, "nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)",
stackTop, relativePc, stackLowerBound, stackUpperBound);
if (cmd != NULL) {
if (numChars > 100) {
numChars = 100;
ellipsis = "...";
}
fprintf(stderr, "n executing %.*s%sn", numChars, cmd,
ellipsis);
} else {
fprintf(stderr, "n");
}
panic("TclExecuteByteCode execution failure: bad stack top");
}
}
#endif /* TCL_COMPILE_DEBUG */
/*
*----------------------------------------------------------------------
*
* IllegalExprOperandType --
*
* Used by TclExecuteByteCode to add an error message to errorInfo
* when an illegal operand type is detected by an expression
* instruction. The argument opndPtr holds the operand object in error.
*
* Results:
* None.
*
* Side effects:
* An error message is appended to errorInfo.
*
*----------------------------------------------------------------------
*/
static void
IllegalExprOperandType(interp, pc, opndPtr)
Tcl_Interp *interp; /* Interpreter to which error information
* pertains. */
unsigned char *pc; /* Points to the instruction being executed
* when the illegal type was found. */
Tcl_Obj *opndPtr; /* Points to the operand holding the value
* with the illegal type. */
{
unsigned char opCode = *pc;
Tcl_ResetResult(interp);
if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't use empty string as operand of "",
operatorStrings[opCode - INST_LOR], """, (char *) NULL);
} else {
char *msg = "non-numeric string";
char *s, *p;
int length;
int looksLikeInt = 0;
s = Tcl_GetStringFromObj(opndPtr, &length);
p = s;
/*
* strtod() isn't at all consistent about detecting Inf and
* NaN between platforms.
*/
if (length == 3) {
if ((s[0]=='n' || s[0]=='N') && (s[1]=='a' || s[1]=='A') &&
(s[2]=='n' || s[2]=='N')) {
msg = "non-numeric floating-point value";
goto makeErrorMessage;
}
if ((s[0]=='i' || s[0]=='I') && (s[1]=='n' || s[1]=='N') &&
(s[2]=='f' || s[2]=='F')) {
msg = "infinite floating-point value";
goto makeErrorMessage;
}
}
/*
* We cannot use TclLooksLikeInt here because it passes strings
* like "10;" [Bug 587140]. We'll accept as "looking like ints"
* for the present purposes any string that looks formally like
* a (decimal|octal|hex) integer.
*/
while (length && isspace(UCHAR(*p))) {
length--;
p++;
}
if (length && ((*p == '+') || (*p == '-'))) {
length--;
p++;
}
if (length) {
if ((*p == '0') && ((*(p+1) == 'x') || (*(p+1) == 'X'))) {
p += 2;
length -= 2;
looksLikeInt = ((length > 0) && isxdigit(UCHAR(*p)));
if (looksLikeInt) {
length--;
p++;
while (length && isxdigit(UCHAR(*p))) {
length--;
p++;
}
}
} else {
looksLikeInt = (length && isdigit(UCHAR(*p)));
if (looksLikeInt) {
length--;
p++;
while (length && isdigit(UCHAR(*p))) {
length--;
p++;
}
}
}
while (length && isspace(UCHAR(*p))) {
length--;
p++;
}
looksLikeInt = !length;
}
if (looksLikeInt) {
/*
* If something that looks like an integer could not be
* converted, then it *must* be a bad octal or too large
* to represent [Bug 542588].
*/
if (TclCheckBadOctal(NULL, s)) {
msg = "invalid octal number";
} else {
msg = "integer value too large to represent";
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent", (char *) NULL);
}
} else {
/*
* See if the operand can be interpreted as a double in
* order to improve the error message.
*/
double d;
if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) {
msg = "floating-point value";
}
}
makeErrorMessage:
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
msg, " as operand of "", operatorStrings[opCode - INST_LOR],
""", (char *) NULL);
}
}
/*
*----------------------------------------------------------------------
*
* TclGetSrcInfoForPc, GetSrcInfoForPc --
*
* Given a program counter value, finds the closest command in the
* bytecode code unit's CmdLocation array and returns information about
* that command's source: a pointer to its first byte and the number of
* characters.
*
* Results:
* If a command is found that encloses the program counter value, a
* pointer to the command's source is returned and the length of the
* source is stored at *lengthPtr. If multiple commands resulted in
* code at pc, information about the closest enclosing command is
* returned. If no matching command is found, NULL is returned and
* *lengthPtr is unchanged.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_TIP280
void
TclGetSrcInfoForPc (cfPtr)
CmdFrame* cfPtr;
{
ByteCode* codePtr = (ByteCode*) cfPtr->data.tebc.codePtr;
if (cfPtr->cmd.str.cmd == NULL) {
cfPtr->cmd.str.cmd = GetSrcInfoForPc((char*) cfPtr->data.tebc.pc,
codePtr,
&cfPtr->cmd.str.len);
}
if (cfPtr->cmd.str.cmd != NULL) {
/* We now have the command. We can get the srcOffset back and
* from there find the list of word locations for this command
*/
ExtCmdLoc* eclPtr;
ECL* locPtr = NULL;
int srcOffset;
Interp* iPtr = (Interp*) *codePtr->interpHandle;
Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);
if (!hePtr) return;
srcOffset = cfPtr->cmd.str.cmd - codePtr->source;
eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
{
int i;
for (i=0; i < eclPtr->nuloc; i++) {
if (eclPtr->loc [i].srcOffset == srcOffset) {
locPtr = &(eclPtr->loc [i]);
break;
}
}
}
if (locPtr == NULL) {Tcl_Panic ("LocSearch failure");}
cfPtr->line = locPtr->line;
cfPtr->nline = locPtr->nline;
cfPtr->type = eclPtr->type;
if (eclPtr->type == TCL_LOCATION_SOURCE) {
cfPtr->data.eval.path = eclPtr->path;
Tcl_IncrRefCount (cfPtr->data.eval.path);
}
/* Do not set cfPtr->data.eval.path NULL for non-SOURCE
* Needed for cfPtr->data.tebc.codePtr.
*/
}
}
#endif
static char *
GetSrcInfoForPc(pc, codePtr, lengthPtr)
unsigned char *pc; /* The program counter value for which to
* return the closest command's source info.
* This points to a bytecode instruction
* in codePtr's code. */
ByteCode *codePtr; /* The bytecode sequence in which to look
* up the command source for the pc. */
int *lengthPtr; /* If non-NULL, the location where the
* length of the command's source should be
* stored. If NULL, no length is stored. */
{
register int pcOffset = (pc - codePtr->codeStart);
int numCmds = codePtr->numCommands;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) {
return NULL;
}
/*
* Decode the code and source offset and length for each command. The
* closest enclosing command is the last one whose code started before
* pcOffset.
*/
codeDeltaNext = codePtr->codeDeltaStart;
codeLengthNext = codePtr->codeLengthStart;
srcDeltaNext = codePtr->srcDeltaStart;
srcLengthNext = codePtr->srcLengthStart;
codeOffset = srcOffset = 0;
for (i = 0; i < numCmds; i++) {
if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
codeDeltaNext++;
delta = TclGetInt4AtPtr(codeDeltaNext);
codeDeltaNext += 4;
} else {
delta = TclGetInt1AtPtr(codeDeltaNext);
codeDeltaNext++;
}
codeOffset += delta;
if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
codeLengthNext++;
codeLen = TclGetInt4AtPtr(codeLengthNext);
codeLengthNext += 4;
} else {
codeLen = TclGetInt1AtPtr(codeLengthNext);
codeLengthNext++;
}
codeEnd = (codeOffset + codeLen - 1);
if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
srcDeltaNext++;
delta = TclGetInt4AtPtr(srcDeltaNext);
srcDeltaNext += 4;
} else {
delta = TclGetInt1AtPtr(srcDeltaNext);
srcDeltaNext++;
}
srcOffset += delta;
if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
srcLengthNext++;
srcLen = TclGetInt4AtPtr(srcLengthNext);
srcLengthNext += 4;
} else {
srcLen = TclGetInt1AtPtr(srcLengthNext);
srcLengthNext++;
}
if (codeOffset > pcOffset) { /* best cmd already found */
break;
} else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */
int dist = (pcOffset - codeOffset);
if (dist <= bestDist) {
bestDist = dist;
bestSrcOffset = srcOffset;
bestSrcLength = srcLen;
}
}
}
if (bestDist == INT_MAX) {
return NULL;
}
if (lengthPtr != NULL) {
*lengthPtr = bestSrcLength;
}
return (codePtr->source + bestSrcOffset);
}
/*
*----------------------------------------------------------------------
*
* GetExceptRangeForPc --
*
* Given a program counter value, return the closest enclosing
* ExceptionRange.
*
* Results:
* In the normal case, catchOnly is 0 (false) and this procedure
* returns a pointer to the most closely enclosing ExceptionRange
* structure regardless of whether it is a loop or catch exception
* range. This is appropriate when processing a TCL_BREAK or
* TCL_CONTINUE, which will be "handled" either by a loop exception
* range or a closer catch range. If catchOnly is nonzero, this
* procedure ignores loop exception ranges and returns a pointer to the
* closest catch range. If no matching ExceptionRange is found that
* encloses pc, a NULL is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static ExceptionRange *
GetExceptRangeForPc(pc, catchOnly, codePtr)
unsigned char *pc; /* The program counter value for which to
* search for a closest enclosing exception
* range. This points to a bytecode
* instruction in codePtr's code. */
int catchOnly; /* If 0, consider either loop or catch
* ExceptionRanges in search. If nonzero
* consider only catch ranges (and ignore
* any closer loop ranges). */
ByteCode* codePtr; /* Points to the ByteCode in which to search
* for the enclosing ExceptionRange. */
{
ExceptionRange *rangeArrayPtr;
int numRanges = codePtr->numExceptRanges;
register ExceptionRange *rangePtr;
int pcOffset = (pc - codePtr->codeStart);
register int start;
if (numRanges == 0) {
return NULL;
}
/*
* This exploits peculiarities of our compiler: nested ranges
* are always *after* their containing ranges, so that by scanning
* backwards we are sure that the first matching range is indeed
* the deepest.
*/
rangeArrayPtr = codePtr->exceptArrayPtr;
rangePtr = rangeArrayPtr + numRanges;
while (--rangePtr >= rangeArrayPtr) {
start = rangePtr->codeOffset;
if ((start <= pcOffset) &&
(pcOffset < (start + rangePtr->numCodeBytes))) {
if ((!catchOnly)
|| (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
return rangePtr;
}
}
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* GetOpcodeName --
*
* This procedure is called by the TRACE and TRACE_WITH_OBJ macros
* used in TclExecuteByteCode when debugging. It returns the name of
* the bytecode instruction at a specified instruction pc.
*
* Results:
* A character string for the instruction.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_COMPILE_DEBUG
static char *
GetOpcodeName(pc)
unsigned char *pc; /* Points to the instruction whose name
* should be returned. */
{
unsigned char opCode = *pc;
return tclInstructionTable[opCode].name;
}
#endif /* TCL_COMPILE_DEBUG */
/*
*----------------------------------------------------------------------
*
* VerifyExprObjType --
*
* This procedure is called by the math functions to verify that
* the object is either an int or double, coercing it if necessary.
* If an error occurs during conversion, an error message is left
* in the interpreter's result unless "interp" is NULL.
*
* Results:
* TCL_OK if it was int or double, TCL_ERROR otherwise
*
* Side effects:
* objPtr is ensured to be of tclIntType, tclWideIntType or
* tclDoubleType.
*
*----------------------------------------------------------------------
*/
static int
VerifyExprObjType(interp, objPtr)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
Tcl_Obj *objPtr; /* Points to the object to type check. */
{
if (IS_NUMERIC_TYPE(objPtr->typePtr)) {
return TCL_OK;
} else {
int length, result = TCL_OK;
char *s = Tcl_GetStringFromObj(objPtr, &length);
if (TclLooksLikeInt(s, length)) {
long i;
Tcl_WideInt w;
GET_WIDE_OR_INT(result, objPtr, i, w);
} else {
double d;
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d);
}
if ((result != TCL_OK) && (interp != NULL)) {
Tcl_ResetResult(interp);
if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"argument to math function was an invalid octal number",
-1);
} else {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"argument to math function didn't have numeric value",
-1);
}
}
return result;
}
}
/*
*----------------------------------------------------------------------
*
* Math Functions --
*
* This page contains the procedures that implement all of the
* built-in math functions for expressions.
*
* Results:
* Each procedure returns TCL_OK if it succeeds and pushes an
* Tcl object holding the result. If it fails it returns TCL_ERROR
* and leaves an error message in the interpreter's result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ExprUnaryFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Contains the address of a procedure that
* takes one double argument and returns a
* double result. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
double d, dResult;
int result;
double (*func) _ANSI_ARGS_((double)) =
(double (*)_ANSI_ARGS_((double))) clientData;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the function's argument from the evaluation stack. Convert it
* to a double if necessary.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
GET_DOUBLE_VALUE(d, valuePtr, valuePtr->typePtr);
errno = 0;
dResult = (*func)(d);
if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
TclExprFloatError(interp, dResult);
result = TCL_ERROR;
goto done;
}
/*
* Push a Tcl object holding the result.
*/
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprBinaryFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Contains the address of a procedure that
* takes two double arguments and
* returns a double result. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr, *value2Ptr;
double d1, d2, dResult;
int result;
double (*func) _ANSI_ARGS_((double, double))
= (double (*)_ANSI_ARGS_((double, double))) clientData;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the function's two arguments from the evaluation stack. Convert
* them to doubles if necessary.
*/
value2Ptr = POP_OBJECT();
valuePtr = POP_OBJECT();
if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) ||
(VerifyExprObjType(interp, value2Ptr) != TCL_OK)) {
result = TCL_ERROR;
goto done;
}
GET_DOUBLE_VALUE(d1, valuePtr, valuePtr->typePtr);
GET_DOUBLE_VALUE(d2, value2Ptr, value2Ptr->typePtr);
errno = 0;
dResult = (*func)(d1, d2);
if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
TclExprFloatError(interp, dResult);
result = TCL_ERROR;
goto done;
}
/*
* Push a Tcl object holding the result.
*/
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
TclDecrRefCount(valuePtr);
TclDecrRefCount(value2Ptr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprAbsFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
long i, iResult;
double d, dResult;
int result;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the argument from the evaluation stack.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
/*
* Push a Tcl object with the result.
*/
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
if (i < 0) {
if (i == LONG_MIN) {
#ifdef TCL_WIDE_INT_IS_LONG
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"integer value too large to represent", -1));
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent", (char *) NULL);
result = TCL_ERROR;
goto done;
#else
/*
* Special case: abs(MIN_INT) must promote to wide.
*/
PUSH_OBJECT( Tcl_NewWideIntObj(-(Tcl_WideInt) i) );
result = TCL_OK;
goto done;
#endif
}
iResult = -i;
} else {
iResult = i;
}
PUSH_OBJECT(Tcl_NewLongObj(iResult));
} else if (valuePtr->typePtr == &tclWideIntType) {
Tcl_WideInt wResult, w;
TclGetWide(w,valuePtr);
if (w < W0) {
wResult = -w;
if (wResult < 0) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"integer value too large to represent", -1);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent", (char *) NULL);
result = TCL_ERROR;
goto done;
}
} else {
wResult = w;
}
PUSH_OBJECT(Tcl_NewWideIntObj(wResult));
} else {
d = valuePtr->internalRep.doubleValue;
if (d < 0.0) {
dResult = -d;
} else {
dResult = d;
}
if (IS_NAN(dResult) || IS_INF(dResult)) {
TclExprFloatError(interp, dResult);
result = TCL_ERROR;
goto done;
}
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
}
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprDoubleFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
double dResult;
int result;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the argument from the evaluation stack.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
GET_DOUBLE_VALUE(dResult, valuePtr, valuePtr->typePtr);
/*
* Push a Tcl object with the result.
*/
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprIntFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
long iResult;
double d;
int result;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the argument from the evaluation stack.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (valuePtr->typePtr == &tclIntType) {
iResult = valuePtr->internalRep.longValue;
} else if (valuePtr->typePtr == &tclWideIntType) {
TclGetLongFromWide(iResult,valuePtr);
} else {
d = valuePtr->internalRep.doubleValue;
if (d < 0.0) {
if (d < (double) (long) LONG_MIN) {
tooLarge:
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"integer value too large to represent", -1);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent", (char *) NULL);
result = TCL_ERROR;
goto done;
}
} else {
if (d > (double) LONG_MAX) {
goto tooLarge;
}
}
if (IS_NAN(d) || IS_INF(d)) {
TclExprFloatError(interp, d);
result = TCL_ERROR;
goto done;
}
iResult = (long) d;
}
/*
* Push a Tcl object with the result.
*/
PUSH_OBJECT(Tcl_NewLongObj(iResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprWideFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
Tcl_WideInt wResult;
double d;
int result;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the argument from the evaluation stack.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (valuePtr->typePtr == &tclWideIntType) {
TclGetWide(wResult,valuePtr);
} else if (valuePtr->typePtr == &tclIntType) {
wResult = Tcl_LongAsWide(valuePtr->internalRep.longValue);
} else {
d = valuePtr->internalRep.doubleValue;
if (d < 0.0) {
if (d < Tcl_WideAsDouble(LLONG_MIN)) {
tooLarge:
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"integer value too large to represent", -1);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent", (char *) NULL);
result = TCL_ERROR;
goto done;
}
} else {
if (d > Tcl_WideAsDouble(LLONG_MAX)) {
goto tooLarge;
}
}
if (IS_NAN(d) || IS_INF(d)) {
TclExprFloatError(interp, d);
result = TCL_ERROR;
goto done;
}
wResult = Tcl_DoubleAsWide(d);
}
/*
* Push a Tcl object with the result.
*/
PUSH_OBJECT(Tcl_NewWideIntObj(wResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprRandFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
Interp *iPtr = (Interp *) interp;
double dResult;
long tmp; /* Algorithm assumes at least 32 bits.
* Only long guarantees that. See below. */
if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
iPtr->flags |= RAND_SEED_INITIALIZED;
/*
* Take into consideration the thread this interp is running in order
* to insure different seeds in different threads (bug #416643)
*/
iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12);
/*
* Make sure 1 <= randSeed <= (2^31) - 2. See below.
*/
iPtr->randSeed &= (unsigned long) 0x7fffffff;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
iPtr->randSeed ^= 123459876;
}
}
/*
* Set stackPtr and stackTop from eePtr.
*/
CACHE_STACK_INFO();
/*
* Generate the random number using the linear congruential
* generator defined by the following recurrence:
* seed = ( IA * seed ) mod IM
* where IA is 16807 and IM is (2^31) - 1. The recurrence maps
* a seed in the range [1, IM - 1] to a new seed in that same range.
* The recurrence maps IM to 0, and maps 0 back to 0, so those two
* values must not be allowed as initial values of seed.
*
* In order to avoid potential problems with integer overflow, the
* recurrence is implemented in terms of additional constants
* IQ and IR such that
* IM = IA*IQ + IR
* None of the operations in the implementation overflows a 32-bit
* signed integer, and the C type long is guaranteed to be at least
* 32 bits wide.
*
* For more details on how this algorithm works, refer to the following
* papers:
*
* S.K. Park & K.W. Miller, "Random number generators: good ones
* are hard to find," Comm ACM 31(10):1192-1201, Oct 1988
*
* W.H. Press & S.A. Teukolsky, "Portable random number
* generators," Computers in Physics 6(5):522-524, Sep/Oct 1992.
*/
#define RAND_IA 16807
#define RAND_IM 2147483647
#define RAND_IQ 127773
#define RAND_IR 2836
#define RAND_MASK 123459876
tmp = iPtr->randSeed/RAND_IQ;
iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp;
if (iPtr->randSeed < 0) {
iPtr->randSeed += RAND_IM;
}
/*
* Since the recurrence keeps seed values in the range [1, RAND_IM - 1],
* dividing by RAND_IM yields a double in the range (0, 1).
*/
dResult = iPtr->randSeed * (1.0/RAND_IM);
/*
* Push a Tcl object with the result.
*/
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
DECACHE_STACK_INFO();
return TCL_OK;
}
static int
ExprRoundFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
Tcl_Obj *valuePtr, *resPtr;
double d, f, i;
int result;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the argument from the evaluation stack.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if ((valuePtr->typePtr == &tclIntType) ||
(valuePtr->typePtr == &tclWideIntType)) {
result = TCL_OK;
resPtr = valuePtr;
} else {
/*
* Round the number to the nearest integer. I'd like to use round(),
* but it's C99 (or BSD), and not yet universal.
*/
d = valuePtr->internalRep.doubleValue;
f = modf(d, &i);
if (d < 0.0) {
if (f <= -0.5) {
i += -1.0;
}
if (i <= Tcl_WideAsDouble(LLONG_MIN)) {
goto tooLarge;
} else if (i <= (double) LONG_MIN) {
resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i));
} else {
resPtr = Tcl_NewLongObj((long) i);
}
} else {
if (f >= 0.5) {
i += 1.0;
}
if (i >= Tcl_WideAsDouble(LLONG_MAX)) {
goto tooLarge;
} else if (i >= (double) LONG_MAX) {
resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i));
} else {
resPtr = Tcl_NewLongObj((long) i);
}
}
}
/*
* Push the result object and free the argument Tcl_Obj.
*/
PUSH_OBJECT(resPtr);
done:
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
/*
* Error return: result cannot be represented as an integer.
*/
tooLarge:
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"integer value too large to represent", -1);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent",
(char *) NULL);
result = TCL_ERROR;
goto done;
}
static int
ExprSrandFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
Interp *iPtr = (Interp *) interp;
Tcl_Obj *valuePtr;
long i = 0; /* Initialized to avoid compiler warning. */
/*
* Set stackPtr and stackTop from eePtr.
*/
CACHE_STACK_INFO();
/*
* Pop the argument from the evaluation stack. Use the value
* to reset the random number seed.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
goto badValue;
}
if (Tcl_GetLongFromObj(NULL, valuePtr, &i) != TCL_OK) {
Tcl_WideInt w;
if (Tcl_GetWideIntFromObj(interp, valuePtr, &w) != TCL_OK) {
badValue:
Tcl_AddErrorInfo(interp, "n (argument to "srand()")");
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return TCL_ERROR;
}
i = Tcl_WideAsLong(w);
}
/*
* Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2.
* See comments in ExprRandFunc() for more details.
*/
iPtr->flags |= RAND_SEED_INITIALIZED;
iPtr->randSeed = i;
iPtr->randSeed &= (unsigned long) 0x7fffffff;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
iPtr->randSeed ^= 123459876;
}
/*
* To avoid duplicating the random number generation code we simply
* clean up our state and call the real random number function. That
* function will always succeed.
*/
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
ExprRandFunc(interp, eePtr, clientData);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ExprCallMathFunc --
*
* This procedure is invoked to call a non-builtin math function
* during the execution of an expression.
*
* Results:
* TCL_OK is returned if all went well and the function's value
* was computed successfully. If an error occurred, TCL_ERROR
* is returned and an error message is left in the interpreter's
* result. After a successful return this procedure pushes a Tcl object
* holding the result.
*
* Side effects:
* None, unless the called math function has side effects.
*
*----------------------------------------------------------------------
*/
static int
ExprCallMathFunc(interp, eePtr, objc, objv)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
int objc; /* Number of arguments. The function name is
* the 0-th argument. */
Tcl_Obj **objv; /* The array of arguments. The function name
* is objv[0]. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
char *funcName;
Tcl_HashEntry *hPtr;
MathFunc *mathFuncPtr; /* Information about math function. */
Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */
Tcl_Value funcResult; /* Result of function call as Tcl_Value. */
register Tcl_Obj *valuePtr;
long i;
double d;
int j, k, result;
Tcl_ResetResult(interp);
/*
* Set stackPtr and stackTop from eePtr.
*/
CACHE_STACK_INFO();
/*
* Look up the MathFunc record for the function.
*/
funcName = TclGetString(objv[0]);
hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
if (hPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown math function "", funcName, """, (char *) NULL);
result = TCL_ERROR;
goto done;
}
mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
if (mathFuncPtr->numArgs != (objc-1)) {
panic("ExprCallMathFunc: expected number of args %d != actual number %d",
mathFuncPtr->numArgs, objc);
result = TCL_ERROR;
goto done;
}
/*
* Collect the arguments for the function, if there are any, into the
* array "args". Note that args[0] will have the Tcl_Value that
* corresponds to objv[1].
*/
for (j = 1, k = 0; j < objc; j++, k++) {
valuePtr = objv[j];
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
/*
* Copy the object's numeric value to the argument record,
* converting it if necessary.
*/
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
args[k].type = TCL_DOUBLE;
args[k].doubleValue = i;
} else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
args[k].type = TCL_WIDE_INT;
args[k].wideValue = Tcl_LongAsWide(i);
} else {
args[k].type = TCL_INT;
args[k].intValue = i;
}
} else if (valuePtr->typePtr == &tclWideIntType) {
Tcl_WideInt w;
TclGetWide(w,valuePtr);
if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
args[k].type = TCL_DOUBLE;
args[k].doubleValue = Tcl_WideAsDouble(w);
} else if (mathFuncPtr->argTypes[k] == TCL_INT) {
args[k].type = TCL_INT;
args[k].intValue = Tcl_WideAsLong(w);
} else {
args[k].type = TCL_WIDE_INT;
args[k].wideValue = w;
}
} else {
d = valuePtr->internalRep.doubleValue;
if (mathFuncPtr->argTypes[k] == TCL_INT) {
args[k].type = TCL_INT;
args[k].intValue = (long) d;
} else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
args[k].type = TCL_WIDE_INT;
args[k].wideValue = Tcl_DoubleAsWide(d);
} else {
args[k].type = TCL_DOUBLE;
args[k].doubleValue = d;
}
}
}
/*
* Invoke the function and copy its result back into valuePtr.
*/
result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
&funcResult);
if (result != TCL_OK) {
goto done;
}
/*
* Pop the objc top stack elements and decrement their ref counts.
*/
k = (stackTop - (objc-1));
while (stackTop >= k) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
/*
* Push the call's object result.
*/
if (funcResult.type == TCL_INT) {
PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue));
} else if (funcResult.type == TCL_WIDE_INT) {
PUSH_OBJECT(Tcl_NewWideIntObj(funcResult.wideValue));
} else {
d = funcResult.doubleValue;
if (IS_NAN(d) || IS_INF(d)) {
TclExprFloatError(interp, d);
result = TCL_ERROR;
goto done;
}
PUSH_OBJECT(Tcl_NewDoubleObj(d));
}
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
DECACHE_STACK_INFO();
return result;
}
/*
*----------------------------------------------------------------------
*
* TclExprFloatError --
*
* This procedure is called when an error occurs during a
* floating-point operation. It reads errno and sets
* interp->objResultPtr accordingly.
*
* Results:
* interp->objResultPtr is set to hold an error message.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclExprFloatError(interp, value)
Tcl_Interp *interp; /* Where to store error message. */
double value; /* Value returned after error; used to
* distinguish underflows from overflows. */
{
char *s;
Tcl_ResetResult(interp);
if ((errno == EDOM) || IS_NAN(value)) {
s = "domain error: argument not in valid range";
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL);
} else if ((errno == ERANGE) || IS_INF(value)) {
if (value == 0.0) {
s = "floating-point value too small to represent";
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL);
} else {
s = "floating-point value too large to represent";
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL);
}
} else {
char msg[64 + TCL_INTEGER_SPACE];
sprintf(msg, "unknown floating-point error, errno = %d", errno);
Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1);
Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL);
}
}
#ifdef TCL_COMPILE_STATS
/*
*----------------------------------------------------------------------
*
* TclLog2 --
*
* Procedure used while collecting compilation statistics to determine
* the log base 2 of an integer.
*
* Results:
* Returns the log base 2 of the operand. If the argument is less
* than or equal to zero, a zero is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclLog2(value)
register int value; /* The integer for which to compute the
* log base 2. */
{
register int n = value;
register int result = 0;
while (n > 1) {
n = n >> 1;
result++;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* EvalStatsCmd --
*
* Implements the "evalstats" command that prints instruction execution
* counts to stdout.
*
* Results:
* Standard Tcl results.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
EvalStatsCmd(unused, interp, objc, objv)
ClientData unused; /* Unused. */
Tcl_Interp *interp; /* The current interpreter. */
int objc; /* The number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument strings. */
{
Interp *iPtr = (Interp *) interp;
LiteralTable *globalTablePtr = &(iPtr->literalTable);
ByteCodeStats *statsPtr = &(iPtr->stats);
double totalCodeBytes, currentCodeBytes;
double totalLiteralBytes, currentLiteralBytes;
double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
double strBytesSharedMultX, strBytesSharedOnce;
double numInstructions, currentHeaderBytes;
long numCurrentByteCodes, numByteCodeLits;
long refCountSum, literalMgmtBytes, sum;
int numSharedMultX, numSharedOnce;
int decadeHigh, minSizeDecade, maxSizeDecade, length, i;
char *litTableStats;
LiteralEntry *entryPtr;
numInstructions = 0.0;
for (i = 0; i < 256; i++) {
if (statsPtr->instructionCount[i] != 0) {
numInstructions += statsPtr->instructionCount[i];
}
}
totalLiteralBytes = sizeof(LiteralTable)
+ iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)
+ (statsPtr->numLiteralsCreated * sizeof(LiteralEntry))
+ (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj))
+ statsPtr->totalLitStringBytes;
totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes;
numCurrentByteCodes =
statsPtr->numCompilations - statsPtr->numByteCodesFreed;
currentHeaderBytes = numCurrentByteCodes
* (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time)));
literalMgmtBytes = sizeof(LiteralTable)
+ (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *))
+ (iPtr->literalTable.numEntries * sizeof(LiteralEntry));
currentLiteralBytes = literalMgmtBytes
+ iPtr->literalTable.numEntries * sizeof(Tcl_Obj)
+ statsPtr->currentLitStringBytes;
currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes;
/*
* Summary statistics, total and current source and ByteCode sizes.
*/
fprintf(stdout, "n----------------------------------------------------------------n");
fprintf(stdout,
"Compilation and execution statistics for interpreter 0x%xn",
(unsigned int) iPtr);
fprintf(stdout, "nNumber ByteCodes executed %ldn",
statsPtr->numExecutions);
fprintf(stdout, "Number ByteCodes compiled %ldn",
statsPtr->numCompilations);
fprintf(stdout, " Mean executions/compile %.1fn",
((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations));
fprintf(stdout, "nInstructions executed %.0fn",
numInstructions);
fprintf(stdout, " Mean inst/compile %.0fn",
numInstructions / statsPtr->numCompilations);
fprintf(stdout, " Mean inst/execution %.0fn",
numInstructions / statsPtr->numExecutions);
fprintf(stdout, "nTotal ByteCodes %ldn",
statsPtr->numCompilations);
fprintf(stdout, " Source bytes %.6gn",
statsPtr->totalSrcBytes);
fprintf(stdout, " Code bytes %.6gn",
totalCodeBytes);
fprintf(stdout, " ByteCode bytes %.6gn",
statsPtr->totalByteCodeBytes);
fprintf(stdout, " Literal bytes %.6gn",
totalLiteralBytes);
fprintf(stdout, " table %d + bkts %d + entries %ld + objects %ld + strings %.6gn",
sizeof(LiteralTable),
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
statsPtr->numLiteralsCreated * sizeof(LiteralEntry),
statsPtr->numLiteralsCreated * sizeof(Tcl_Obj),
statsPtr->totalLitStringBytes);
fprintf(stdout, " Mean code/compile %.1fn",
totalCodeBytes / statsPtr->numCompilations);
fprintf(stdout, " Mean code/source %.1fn",
totalCodeBytes / statsPtr->totalSrcBytes);
fprintf(stdout, "nCurrent (active) ByteCodes %ldn",
numCurrentByteCodes);
fprintf(stdout, " Source bytes %.6gn",
statsPtr->currentSrcBytes);
fprintf(stdout, " Code bytes %.6gn",
currentCodeBytes);
fprintf(stdout, " ByteCode bytes %.6gn",
statsPtr->currentByteCodeBytes);
fprintf(stdout, " Literal bytes %.6gn",
currentLiteralBytes);
fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6gn",
sizeof(LiteralTable),
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
iPtr->literalTable.numEntries * sizeof(LiteralEntry),
iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
statsPtr->currentLitStringBytes);
fprintf(stdout, " Mean code/source %.1fn",
currentCodeBytes / statsPtr->currentSrcBytes);
fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)n",
(currentCodeBytes + statsPtr->currentSrcBytes),
(currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
/*
* Tcl_IsShared statistics check
*
* This gives the refcount of each obj as Tcl_IsShared was called
* for it. Shared objects must be duplicated before they can be
* modified.
*/
numSharedMultX = 0;
fprintf(stdout, "nTcl_IsShared object check (all objects):n");
fprintf(stdout, " Object had refcount <=1 (not shared) %ldn",
tclObjsShared[1]);
for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) {
fprintf(stdout, " refcount ==%d %ldn",
i, tclObjsShared[i]);
numSharedMultX += tclObjsShared[i];
}
fprintf(stdout, " refcount >=%d %ldn",
i, tclObjsShared[0]);
numSharedMultX += tclObjsShared[0];
fprintf(stdout, " Total shared objects %dn",
numSharedMultX);
/*
* Literal table statistics.
*/
numByteCodeLits = 0;
refCountSum = 0;
numSharedMultX = 0;
numSharedOnce = 0;
objBytesIfUnshared = 0.0;
strBytesIfUnshared = 0.0;
strBytesSharedMultX = 0.0;
strBytesSharedOnce = 0.0;
for (i = 0; i < globalTablePtr->numBuckets; i++) {
for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
entryPtr = entryPtr->nextPtr) {
if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
numByteCodeLits++;
}
(void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
refCountSum += entryPtr->refCount;
objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
strBytesIfUnshared += (entryPtr->refCount * (length+1));
if (entryPtr->refCount > 1) {
numSharedMultX++;
strBytesSharedMultX += (length+1);
} else {
numSharedOnce++;
strBytesSharedOnce += (length+1);
}
}
}
sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
- currentLiteralBytes;
fprintf(stdout, "nTotal objects (all interps) %ldn",
tclObjsAlloced);
fprintf(stdout, "Current objects %ldn",
(tclObjsAlloced - tclObjsFreed));
fprintf(stdout, "Total literal objects %ldn",
statsPtr->numLiteralsCreated);
fprintf(stdout, "nCurrent literal objects %d (%0.1f%% of current objects)n",
globalTablePtr->numEntries,
(globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed));
fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)n",
numByteCodeLits,
(numByteCodeLits * 100.0) / globalTablePtr->numEntries);
fprintf(stdout, " Literals reused > 1x %dn",
numSharedMultX);
fprintf(stdout, " Mean reference count %.2fn",
((double) refCountSum) / globalTablePtr->numEntries);
fprintf(stdout, " Mean len, str reused >1x %.2fn",
(numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0));
fprintf(stdout, " Mean len, str used 1x %.2fn",
(numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0));
fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)n",
sharingBytesSaved,
(sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared));
fprintf(stdout, " Bytes with sharing %.6gn",
currentLiteralBytes);
fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6gn",
sizeof(LiteralTable),
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
iPtr->literalTable.numEntries * sizeof(LiteralEntry),
iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
statsPtr->currentLitStringBytes);
fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6gn",
(objBytesIfUnshared + strBytesIfUnshared),
objBytesIfUnshared, strBytesIfUnshared);
fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6gn",
(strBytesIfUnshared - statsPtr->currentLitStringBytes),
strBytesIfUnshared, statsPtr->currentLitStringBytes);
fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)n",
literalMgmtBytes,
(literalMgmtBytes * 100.0) / currentLiteralBytes);
fprintf(stdout, " table %d + buckets %d + entries %dn",
sizeof(LiteralTable),
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
iPtr->literalTable.numEntries * sizeof(LiteralEntry));
/*
* Breakdown of current ByteCode space requirements.
*/
fprintf(stdout, "nBreakdown of current ByteCode requirements:n");
fprintf(stdout, " Bytes Pct of Avg pern");
fprintf(stdout, " total ByteCoden");
fprintf(stdout, "Total %12.6g 100.00%% %8.1fn",
statsPtr->currentByteCodeBytes,
statsPtr->currentByteCodeBytes / numCurrentByteCodes);
fprintf(stdout, "Header %12.6g %8.1f%% %8.1fn",
currentHeaderBytes,
((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes),
currentHeaderBytes / numCurrentByteCodes);
fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1fn",
statsPtr->currentInstBytes,
((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes),
statsPtr->currentInstBytes / numCurrentByteCodes);
fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1fn",
statsPtr->currentLitBytes,
((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes),
statsPtr->currentLitBytes / numCurrentByteCodes);
fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1fn",
statsPtr->currentExceptBytes,
((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes),
statsPtr->currentExceptBytes / numCurrentByteCodes);
fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1fn",
statsPtr->currentAuxBytes,
((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes),
statsPtr->currentAuxBytes / numCurrentByteCodes);
fprintf(stdout, "Command map %12.6g %8.1f%% %8.1fn",
statsPtr->currentCmdMapBytes,
((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes),
statsPtr->currentCmdMapBytes / numCurrentByteCodes);
/*
* Detailed literal statistics.
*/
fprintf(stdout, "nLiteral string sizes:n");
fprintf(stdout, " Up to length Percentagen");
maxSizeDecade = 0;
for (i = 31; i >= 0; i--) {
if (statsPtr->literalCount[i] > 0) {
maxSizeDecade = i;
break;
}
}
sum = 0;
for (i = 0; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->literalCount[i];
fprintf(stdout, " %10d %8.0f%%n",
decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated);
}
litTableStats = TclLiteralStats(globalTablePtr);
fprintf(stdout, "nCurrent literal table statistics:n%sn",
litTableStats);
ckfree((char *) litTableStats);
/*
* Source and ByteCode size distributions.
*/
fprintf(stdout, "nSource sizes:n");
fprintf(stdout, " Up to size Percentagen");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->srcCount[i] > 0) {
minSizeDecade = i;
break;
}
}
for (i = 31; i >= 0; i--) {
if (statsPtr->srcCount[i] > 0) {
maxSizeDecade = i;
break;
}
}
sum = 0;
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->srcCount[i];
fprintf(stdout, " %10d %8.0f%%n",
decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
}
fprintf(stdout, "nByteCode sizes:n");
fprintf(stdout, " Up to size Percentagen");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->byteCodeCount[i] > 0) {
minSizeDecade = i;
break;
}
}
for (i = 31; i >= 0; i--) {
if (statsPtr->byteCodeCount[i] > 0) {
maxSizeDecade = i;
break;
}
}
sum = 0;
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->byteCodeCount[i];
fprintf(stdout, " %10d %8.0f%%n",
decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
}
fprintf(stdout, "nByteCode longevity (excludes Current ByteCodes):n");
fprintf(stdout, " Up to ms Percentagen");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->lifetimeCount[i] > 0) {
minSizeDecade = i;
break;
}
}
for (i = 31; i >= 0; i--) {
if (statsPtr->lifetimeCount[i] > 0) {
maxSizeDecade = i;
break;
}
}
sum = 0;
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->lifetimeCount[i];
fprintf(stdout, " %12.3f %8.0f%%n",
decadeHigh / 1000.0,
(sum * 100.0) / statsPtr->numByteCodesFreed);
}
/*
* Instruction counts.
*/
fprintf(stdout, "nInstruction counts:n");
for (i = 0; i <= LAST_INST_OPCODE; i++) {
if (statsPtr->instructionCount[i]) {
fprintf(stdout, "%20s %8ld %6.1f%%n",
tclInstructionTable[i].name,
statsPtr->instructionCount[i],
(statsPtr->instructionCount[i]*100.0) / numInstructions);
}
}
fprintf(stdout, "nInstructions NEVER executed:n");
for (i = 0; i <= LAST_INST_OPCODE; i++) {
if (statsPtr->instructionCount[i] == 0) {
fprintf(stdout, "%20sn", tclInstructionTable[i].name);
}
}
#ifdef TCL_MEM_DEBUG
fprintf(stdout, "nHeap Statistics:n");
TclDumpMemoryInfo(stdout);
#endif
fprintf(stdout, "n----------------------------------------------------------------n");
return TCL_OK;
}
#endif /* TCL_COMPILE_STATS */
#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
*
* StringForResultCode --
*
* Procedure that returns a human-readable string representing a
* Tcl result code such as TCL_ERROR.
*
* Results:
* If the result code is one of the standard Tcl return codes, the
* result is a string representing that code such as "TCL_ERROR".
* Otherwise, the result string is that code formatted as a
* sequence of decimal digit characters. Note that the resulting
* string must not be modified by the caller.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static char *
StringForResultCode(result)
int result; /* The Tcl result code for which to
* generate a string. */
{
static char buf[TCL_INTEGER_SPACE];
if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
return resultStrings[result];
}
TclFormatInt(buf, result);
return buf;
}
#endif /* TCL_COMPILE_DEBUG */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/