From a14ef5dc21d5fb63776b7d6be34b84ecfd368aad Mon Sep 17 00:00:00 2001 From: hobbs Date: Fri, 26 May 2000 08:53:40 +0000 Subject: * generic/tclCompExpr.c: changed INST_STREQ -> INST_STR_EQ, INST_STRNEQ -> INST_STR_NEQ * generic/tclCompile.c: added streq, strneq, strcmp, strlen & strmatch to the compiled stats instructionTable * generic/tclCompile.h: added instructions INST_STR_CMP, INST_STR_INDEX, INST_STR_MATCH * generic/tclCompCmds.c: added byte compiler support for [string compare|match|index]. * generic/tclExecute.c: Changed INST_STR_(N)EQ to return an Int object and not bother trying to reuse the top stack object. Added INST_STR_CMP, INST_STR_INDEX, INST_STR_MATCH bytecode ops. Extended evalstats output info with Tcl_IsShared stat info. --- generic/tclCompCmds.c | 157 +++++++++++++++++++------- generic/tclCompExpr.c | 6 +- generic/tclCompile.c | 302 ++++++++++++++++++++++++++------------------------ generic/tclCompile.h | 13 ++- generic/tclExecute.c | 208 +++++++++++++++++++++++++++------- 5 files changed, 456 insertions(+), 230 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 5b6c966..6d9b273 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.6 2000/05/23 22:10:50 ericm Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.7 2000/05/26 08:53:40 hobbs Exp $ */ #include "tclInt.h" @@ -2021,14 +2021,32 @@ TclCompileStringCmd(interp, parsePtr, envPtr) switch ((enum options) index) { case STR_BYTELENGTH: + case STR_FIRST: + case STR_IS: + case STR_LAST: + case STR_MAP: + case STR_RANGE: + case STR_REPEAT: + case STR_REPLACE: + case STR_TOLOWER: + case STR_TOUPPER: + case STR_TOTITLE: + case STR_TRIM: + case STR_TRIMLEFT: + case STR_TRIMRIGHT: + case STR_WORDEND: + case STR_WORDSTART: + /* + * All other cases: compile out of line. + */ + return TCL_OUT_LINE_COMPILE; + case STR_COMPARE: - break; case STR_EQUAL: { - int i; - int depth; + int i, depth; /* * If there are any flags to the command, we can't byte compile it - * because the INST_STREQ bytecode doesn't support flags. + * because the INST_STR_EQ bytecode doesn't support flags. */ if (parsePtr->numWords != 4) { @@ -2059,59 +2077,124 @@ TclCompileStringCmd(interp, parsePtr, envPtr) } envPtr->maxStackDepth = depth; - TclEmitOpcode(INST_STREQ, envPtr); + TclEmitOpcode(((((enum options) index) == STR_COMPARE) ? + INST_STR_CMP : INST_STR_EQ), envPtr); + return TCL_OK; + } + case STR_INDEX: { + int i, depth; + + if (parsePtr->numWords != 4) { + Tcl_SetResult(interp, "wrong # args: should be " + "\"string index string charIndex\"", TCL_STATIC); + return TCL_ERROR; + } + + depth = 0; + + /* + * Push the two operands onto the stack. + */ + + for (i = 0; i < 2; i++) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterLiteral(envPtr, + varTokenPtr[1].start, varTokenPtr[1].size, + 0), envPtr); + depth++; + } else { + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + depth += envPtr->maxStackDepth; + } + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + } + + envPtr->maxStackDepth = depth; + TclEmitOpcode(INST_STR_INDEX, envPtr); return TCL_OK; - break; } - case STR_FIRST: - case STR_INDEX: - case STR_IS: - case STR_LAST: - break; case STR_LENGTH: { if (parsePtr->numWords != 3) { Tcl_SetResult(interp, "wrong # args: should be " "\"string length string\"", TCL_STATIC); return TCL_ERROR; } - + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { TclEmitPush(TclRegisterLiteral(envPtr, varTokenPtr[1].start, varTokenPtr[1].size, 0), envPtr); envPtr->maxStackDepth = 1; - TclEmitOpcode(INST_STRLEN, envPtr); - return TCL_OK; } else { code = TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); if (code != TCL_OK) { return code; } - TclEmitOpcode(INST_STRLEN, envPtr); - return TCL_OK; } - break; + TclEmitOpcode(INST_STR_LEN, envPtr); + return TCL_OK; + } + case STR_MATCH: { + int i, length, nocase = 0, depth = 0; + char *str; + + if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { + Tcl_SetResult(interp, "wrong # args: should be " + "\"string match ?-nocase? pattern string\"", + TCL_STATIC); + return TCL_ERROR; + } + + if (parsePtr->numWords == 5) { + if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_OUT_LINE_COMPILE; + } + str = varTokenPtr[1].start; + length = varTokenPtr[1].size; + if ((length > 1) && + strncmp(str, "-nocase", (size_t) length) == 0) { + nocase = 1; + } else { + char c = str[length]; + str[length] = '\0'; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option \"", str, "\": must be -nocase", + (char *) NULL); + str[length] = c; + return TCL_ERROR; + } + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + } + TclEmitPush(TclRegisterLiteral(envPtr, (nocase ? "1" : "0"), + 1, 0), envPtr); + depth++; + + for (i = 0; i < 2; i++) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterLiteral(envPtr, + varTokenPtr[1].start, varTokenPtr[1].size, + 0), envPtr); + depth++; + } else { + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + depth += envPtr->maxStackDepth; + } + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + } + + envPtr->maxStackDepth = depth; + TclEmitOpcode(INST_STR_MATCH, envPtr); + return TCL_OK; } - case STR_MAP: - case STR_MATCH: - case STR_RANGE: - case STR_REPEAT: - case STR_REPLACE: - case STR_TOLOWER: - case STR_TOUPPER: - case STR_TOTITLE: - case STR_TRIM: - case STR_TRIMLEFT: - case STR_TRIMRIGHT: - case STR_WORDEND: - case STR_WORDSTART: - break; } - - /* - * All other cases: compile out of line. - */ - return TCL_OUT_LINE_COMPILE; return TCL_OK; } diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 8a781b9..b619e2c 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompExpr.c,v 1.5 2000/05/09 00:00:34 hobbs Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.6 2000/05/26 08:53:40 hobbs Exp $ */ #include "tclInt.h" @@ -144,8 +144,8 @@ OperatorDesc operatorTable[] = { {"?", 0}, {"!", 1, INST_LNOT}, {"~", 1, INST_BITNOT}, - {"eq", 2, INST_STREQ}, - {"ne", 2, INST_STRNEQ}, + {"eq", 2, INST_STR_EQ}, + {"ne", 2, INST_STR_NEQ}, {NULL} }; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 7a9f64d..6a108ab 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.20 2000/03/30 04:36:11 hobbs Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.21 2000/05/26 08:53:41 hobbs Exp $ */ #include "tclInt.h" @@ -50,166 +50,178 @@ static int traceInitialized = 0; */ InstructionDesc instructionTable[] = { - /* Name Bytes #Opnds Operand types Stack top, next */ - {"done", 1, 0, {OPERAND_NONE}}, - /* Finish ByteCode execution and return stktop (top stack item) */ - {"push1", 2, 1, {OPERAND_UINT1}}, - /* Push object at ByteCode objArray[op1] */ - {"push4", 5, 1, {OPERAND_UINT4}}, - /* Push object at ByteCode objArray[op4] */ - {"pop", 1, 0, {OPERAND_NONE}}, - /* Pop the topmost stack object */ - {"dup", 1, 0, {OPERAND_NONE}}, - /* Duplicate the topmost stack object and push the result */ - {"concat1", 2, 1, {OPERAND_UINT1}}, - /* Concatenate the top op1 items and push result */ - {"invokeStk1", 2, 1, {OPERAND_UINT1}}, - /* Invoke command named objv[0]; = */ - {"invokeStk4", 5, 1, {OPERAND_UINT4}}, - /* Invoke command named objv[0]; = */ - {"evalStk", 1, 0, {OPERAND_NONE}}, - /* Evaluate command in stktop using Tcl_EvalObj. */ - {"exprStk", 1, 0, {OPERAND_NONE}}, - /* Execute expression in stktop using Tcl_ExprStringObj. */ + /* Name Bytes #Opnds Operand types Stack top, next */ + {"done", 1, 0, {OPERAND_NONE}}, + /* Finish ByteCode execution and return stktop (top stack item) */ + {"push1", 2, 1, {OPERAND_UINT1}}, + /* Push object at ByteCode objArray[op1] */ + {"push4", 5, 1, {OPERAND_UINT4}}, + /* Push object at ByteCode objArray[op4] */ + {"pop", 1, 0, {OPERAND_NONE}}, + /* Pop the topmost stack object */ + {"dup", 1, 0, {OPERAND_NONE}}, + /* Duplicate the topmost stack object and push the result */ + {"concat1", 2, 1, {OPERAND_UINT1}}, + /* Concatenate the top op1 items and push result */ + {"invokeStk1", 2, 1, {OPERAND_UINT1}}, + /* Invoke command named objv[0]; = */ + {"invokeStk4", 5, 1, {OPERAND_UINT4}}, + /* Invoke command named objv[0]; = */ + {"evalStk", 1, 0, {OPERAND_NONE}}, + /* Evaluate command in stktop using Tcl_EvalObj. */ + {"exprStk", 1, 0, {OPERAND_NONE}}, + /* Execute expression in stktop using Tcl_ExprStringObj. */ - {"loadScalar1", 2, 1, {OPERAND_UINT1}}, - /* Load scalar variable at index op1 <= 255 in call frame */ - {"loadScalar4", 5, 1, {OPERAND_UINT4}}, - /* Load scalar variable at index op1 >= 256 in call frame */ - {"loadScalarStk", 1, 0, {OPERAND_NONE}}, - /* Load scalar variable; scalar's name is stktop */ - {"loadArray1", 2, 1, {OPERAND_UINT1}}, - /* Load array element; array at slot op1<=255, element is stktop */ - {"loadArray4", 5, 1, {OPERAND_UINT4}}, - /* Load array element; array at slot op1 > 255, element is stktop */ - {"loadArrayStk", 1, 0, {OPERAND_NONE}}, - /* Load array element; element is stktop, array name is stknext */ - {"loadStk", 1, 0, {OPERAND_NONE}}, - /* Load general variable; unparsed variable name is stktop */ - {"storeScalar1", 2, 1, {OPERAND_UINT1}}, - /* Store scalar variable at op1<=255 in frame; value is stktop */ - {"storeScalar4", 5, 1, {OPERAND_UINT4}}, - /* Store scalar variable at op1 > 255 in frame; value is stktop */ - {"storeScalarStk", 1, 0, {OPERAND_NONE}}, - /* Store scalar; value is stktop, scalar name is stknext */ - {"storeArray1", 2, 1, {OPERAND_UINT1}}, - /* Store array element; array at op1<=255, value is top then elem */ - {"storeArray4", 5, 1, {OPERAND_UINT4}}, - /* Store array element; array at op1>=256, value is top then elem */ - {"storeArrayStk", 1, 0, {OPERAND_NONE}}, - /* Store array element; value is stktop, then elem, array names */ - {"storeStk", 1, 0, {OPERAND_NONE}}, - /* Store general variable; value is stktop, then unparsed name */ + {"loadScalar1", 2, 1, {OPERAND_UINT1}}, + /* Load scalar variable at index op1 <= 255 in call frame */ + {"loadScalar4", 5, 1, {OPERAND_UINT4}}, + /* Load scalar variable at index op1 >= 256 in call frame */ + {"loadScalarStk", 1, 0, {OPERAND_NONE}}, + /* Load scalar variable; scalar's name is stktop */ + {"loadArray1", 2, 1, {OPERAND_UINT1}}, + /* Load array element; array at slot op1<=255, element is stktop */ + {"loadArray4", 5, 1, {OPERAND_UINT4}}, + /* Load array element; array at slot op1 > 255, element is stktop */ + {"loadArrayStk", 1, 0, {OPERAND_NONE}}, + /* Load array element; element is stktop, array name is stknext */ + {"loadStk", 1, 0, {OPERAND_NONE}}, + /* Load general variable; unparsed variable name is stktop */ + {"storeScalar1", 2, 1, {OPERAND_UINT1}}, + /* Store scalar variable at op1<=255 in frame; value is stktop */ + {"storeScalar4", 5, 1, {OPERAND_UINT4}}, + /* Store scalar variable at op1 > 255 in frame; value is stktop */ + {"storeScalarStk", 1, 0, {OPERAND_NONE}}, + /* Store scalar; value is stktop, scalar name is stknext */ + {"storeArray1", 2, 1, {OPERAND_UINT1}}, + /* Store array element; array at op1<=255, value is top then elem */ + {"storeArray4", 5, 1, {OPERAND_UINT4}}, + /* Store array element; array at op1>=256, value is top then elem */ + {"storeArrayStk", 1, 0, {OPERAND_NONE}}, + /* Store array element; value is stktop, then elem, array names */ + {"storeStk", 1, 0, {OPERAND_NONE}}, + /* Store general variable; value is stktop, then unparsed name */ - {"incrScalar1", 2, 1, {OPERAND_UINT1}}, - /* Incr scalar at index op1<=255 in frame; incr amount is stktop */ - {"incrScalarStk", 1, 0, {OPERAND_NONE}}, - /* Incr scalar; incr amount is stktop, scalar's name is stknext */ - {"incrArray1", 2, 1, {OPERAND_UINT1}}, - /* Incr array elem; arr at slot op1<=255, amount is top then elem */ - {"incrArrayStk", 1, 0, {OPERAND_NONE}}, - /* Incr array element; amount is top then elem then array names */ - {"incrStk", 1, 0, {OPERAND_NONE}}, - /* Incr general variable; amount is stktop then unparsed var name */ - {"incrScalar1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}}, - /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */ + {"incrScalar1", 2, 1, {OPERAND_UINT1}}, + /* Incr scalar at index op1<=255 in frame; incr amount is stktop */ + {"incrScalarStk", 1, 0, {OPERAND_NONE}}, + /* Incr scalar; incr amount is stktop, scalar's name is stknext */ + {"incrArray1", 2, 1, {OPERAND_UINT1}}, + /* Incr array elem; arr at slot op1<=255, amount is top then elem */ + {"incrArrayStk", 1, 0, {OPERAND_NONE}}, + /* Incr array element; amount is top then elem then array names */ + {"incrStk", 1, 0, {OPERAND_NONE}}, + /* Incr general variable; amount is stktop then unparsed var name */ + {"incrScalar1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}}, + /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */ {"incrScalarStkImm", 2, 1, {OPERAND_INT1}}, - /* Incr scalar; scalar name is stktop; incr amount is op1 */ - {"incrArray1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}}, - /* Incr array elem; array at slot op1 <= 255, elem is stktop, + /* Incr scalar; scalar name is stktop; incr amount is op1 */ + {"incrArray1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}}, + /* Incr array elem; array at slot op1 <= 255, elem is stktop, * amount is 2nd operand byte */ - {"incrArrayStkImm", 2, 1, {OPERAND_INT1}}, - /* Incr array element; elem is top then array name, amount is op1 */ - {"incrStkImm", 2, 1, {OPERAND_INT1}}, - /* Incr general variable; unparsed name is top, amount is op1 */ + {"incrArrayStkImm", 2, 1, {OPERAND_INT1}}, + /* Incr array element; elem is top then array name, amount is op1 */ + {"incrStkImm", 2, 1, {OPERAND_INT1}}, + /* Incr general variable; unparsed name is top, amount is op1 */ - {"jump1", 2, 1, {OPERAND_INT1}}, - /* Jump relative to (pc + op1) */ - {"jump4", 5, 1, {OPERAND_INT4}}, - /* Jump relative to (pc + op4) */ - {"jumpTrue1", 2, 1, {OPERAND_INT1}}, - /* Jump relative to (pc + op1) if stktop expr object is true */ - {"jumpTrue4", 5, 1, {OPERAND_INT4}}, - /* Jump relative to (pc + op4) if stktop expr object is true */ - {"jumpFalse1", 2, 1, {OPERAND_INT1}}, - /* Jump relative to (pc + op1) if stktop expr object is false */ - {"jumpFalse4", 5, 1, {OPERAND_INT4}}, - /* Jump relative to (pc + op4) if stktop expr object is false */ - - {"lor", 1, 0, {OPERAND_NONE}}, - /* Logical or: push (stknext || stktop) */ - {"land", 1, 0, {OPERAND_NONE}}, - /* Logical and: push (stknext && stktop) */ - {"bitor", 1, 0, {OPERAND_NONE}}, - /* Bitwise or: push (stknext | stktop) */ - {"bitxor", 1, 0, {OPERAND_NONE}}, - /* Bitwise xor push (stknext ^ stktop) */ - {"bitand", 1, 0, {OPERAND_NONE}}, - /* Bitwise and: push (stknext & stktop) */ - {"eq", 1, 0, {OPERAND_NONE}}, - /* Equal: push (stknext == stktop) */ - {"neq", 1, 0, {OPERAND_NONE}}, - /* Not equal: push (stknext != stktop) */ - {"lt", 1, 0, {OPERAND_NONE}}, - /* Less: push (stknext < stktop) */ - {"gt", 1, 0, {OPERAND_NONE}}, - /* Greater: push (stknext || stktop) */ - {"le", 1, 0, {OPERAND_NONE}}, - /* Logical or: push (stknext || stktop) */ - {"ge", 1, 0, {OPERAND_NONE}}, - /* Logical or: push (stknext || stktop) */ - {"lshift", 1, 0, {OPERAND_NONE}}, - /* Left shift: push (stknext << stktop) */ - {"rshift", 1, 0, {OPERAND_NONE}}, - /* Right shift: push (stknext >> stktop) */ - {"add", 1, 0, {OPERAND_NONE}}, - /* Add: push (stknext + stktop) */ - {"sub", 1, 0, {OPERAND_NONE}}, - /* Sub: push (stkext - stktop) */ - {"mult", 1, 0, {OPERAND_NONE}}, - /* Multiply: push (stknext * stktop) */ - {"div", 1, 0, {OPERAND_NONE}}, - /* Divide: push (stknext / stktop) */ - {"mod", 1, 0, {OPERAND_NONE}}, - /* Mod: push (stknext % stktop) */ - {"uplus", 1, 0, {OPERAND_NONE}}, - /* Unary plus: push +stktop */ - {"uminus", 1, 0, {OPERAND_NONE}}, - /* Unary minus: push -stktop */ - {"bitnot", 1, 0, {OPERAND_NONE}}, - /* Bitwise not: push ~stktop */ - {"not", 1, 0, {OPERAND_NONE}}, - /* Logical not: push !stktop */ + {"jump1", 2, 1, {OPERAND_INT1}}, + /* Jump relative to (pc + op1) */ + {"jump4", 5, 1, {OPERAND_INT4}}, + /* Jump relative to (pc + op4) */ + {"jumpTrue1", 2, 1, {OPERAND_INT1}}, + /* Jump relative to (pc + op1) if stktop expr object is true */ + {"jumpTrue4", 5, 1, {OPERAND_INT4}}, + /* Jump relative to (pc + op4) if stktop expr object is true */ + {"jumpFalse1", 2, 1, {OPERAND_INT1}}, + /* Jump relative to (pc + op1) if stktop expr object is false */ + {"jumpFalse4", 5, 1, {OPERAND_INT4}}, + /* Jump relative to (pc + op4) if stktop expr object is false */ + + {"lor", 1, 0, {OPERAND_NONE}}, + /* Logical or: push (stknext || stktop) */ + {"land", 1, 0, {OPERAND_NONE}}, + /* Logical and: push (stknext && stktop) */ + {"bitor", 1, 0, {OPERAND_NONE}}, + /* Bitwise or: push (stknext | stktop) */ + {"bitxor", 1, 0, {OPERAND_NONE}}, + /* Bitwise xor push (stknext ^ stktop) */ + {"bitand", 1, 0, {OPERAND_NONE}}, + /* Bitwise and: push (stknext & stktop) */ + {"eq", 1, 0, {OPERAND_NONE}}, + /* Equal: push (stknext == stktop) */ + {"neq", 1, 0, {OPERAND_NONE}}, + /* Not equal: push (stknext != stktop) */ + {"lt", 1, 0, {OPERAND_NONE}}, + /* Less: push (stknext < stktop) */ + {"gt", 1, 0, {OPERAND_NONE}}, + /* Greater: push (stknext || stktop) */ + {"le", 1, 0, {OPERAND_NONE}}, + /* Logical or: push (stknext || stktop) */ + {"ge", 1, 0, {OPERAND_NONE}}, + /* Logical or: push (stknext || stktop) */ + {"lshift", 1, 0, {OPERAND_NONE}}, + /* Left shift: push (stknext << stktop) */ + {"rshift", 1, 0, {OPERAND_NONE}}, + /* Right shift: push (stknext >> stktop) */ + {"add", 1, 0, {OPERAND_NONE}}, + /* Add: push (stknext + stktop) */ + {"sub", 1, 0, {OPERAND_NONE}}, + /* Sub: push (stkext - stktop) */ + {"mult", 1, 0, {OPERAND_NONE}}, + /* Multiply: push (stknext * stktop) */ + {"div", 1, 0, {OPERAND_NONE}}, + /* Divide: push (stknext / stktop) */ + {"mod", 1, 0, {OPERAND_NONE}}, + /* Mod: push (stknext % stktop) */ + {"uplus", 1, 0, {OPERAND_NONE}}, + /* Unary plus: push +stktop */ + {"uminus", 1, 0, {OPERAND_NONE}}, + /* Unary minus: push -stktop */ + {"bitnot", 1, 0, {OPERAND_NONE}}, + /* Bitwise not: push ~stktop */ + {"not", 1, 0, {OPERAND_NONE}}, + /* Logical not: push !stktop */ {"callBuiltinFunc1", 2, 1, {OPERAND_UINT1}}, - /* Call builtin math function with index op1; any args are on stk */ - {"callFunc1", 2, 1, {OPERAND_UINT1}}, - /* Call non-builtin func objv[0]; = */ - {"tryCvtToNumeric", 1, 0, {OPERAND_NONE}}, - /* Try converting stktop to first int then double if possible. */ - - {"break", 1, 0, {OPERAND_NONE}}, - /* Abort closest enclosing loop; if none, return TCL_BREAK code. */ - {"continue", 1, 0, {OPERAND_NONE}}, - /* Skip to next iteration of closest enclosing loop; if none, + /* Call builtin math function with index op1; any args are on stk */ + {"callFunc1", 2, 1, {OPERAND_UINT1}}, + /* Call non-builtin func objv[0]; = */ + {"tryCvtToNumeric", 1, 0, {OPERAND_NONE}}, + /* Try converting stktop to first int then double if possible. */ + + {"break", 1, 0, {OPERAND_NONE}}, + /* Abort closest enclosing loop; if none, return TCL_BREAK code. */ + {"continue", 1, 0, {OPERAND_NONE}}, + /* Skip to next iteration of closest enclosing loop; if none, * return TCL_CONTINUE code. */ - {"foreach_start4", 5, 1, {OPERAND_UINT4}}, - /* Initialize execution of a foreach loop. Operand is aux data index + {"foreach_start4", 5, 1, {OPERAND_UINT4}}, + /* Initialize execution of a foreach loop. Operand is aux data index * of the ForeachInfo structure for the foreach command. */ - {"foreach_step4", 5, 1, {OPERAND_UINT4}}, - /* "Step" or begin next iteration of foreach loop. Push 0 if to + {"foreach_step4", 5, 1, {OPERAND_UINT4}}, + /* "Step" or begin next iteration of foreach loop. Push 0 if to * terminate loop, else push 1. */ {"beginCatch4", 5, 1, {OPERAND_UINT4}}, - /* Record start of catch with the operand's exception index. + /* Record start of catch with the operand's exception index. * Push the current stack depth onto a special catch stack. */ {"endCatch", 1, 0, {OPERAND_NONE}}, - /* End of last catch. Pop the bytecode interpreter's catch stack. */ + /* End of last catch. Pop the bytecode interpreter's catch stack. */ {"pushResult", 1, 0, {OPERAND_NONE}}, - /* Push the interpreter's object result onto the stack. */ + /* Push the interpreter's object result onto the stack. */ {"pushReturnCode", 1, 0, {OPERAND_NONE}}, - /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as + /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as * a new object onto the stack. */ + {"streq", 1, 0, {OPERAND_NONE}}, + /* Str Equal: push (stknext eq stktop) */ + {"strneq", 1, 0, {OPERAND_NONE}}, + /* Str !Equal: push (stknext neq stktop) */ + {"strcmp", 1, 0, {OPERAND_NONE}}, + /* Str Compare: push (stknext cmp stktop) */ + {"strlen", 1, 0, {OPERAND_NONE}}, + /* Str Length: push (strlen stktop) */ + {"strindex", 1, 0, {OPERAND_NONE}}, + /* Str Index: push (strindex stknext stktop) */ + {"strmatch", 1, 0, {OPERAND_NONE}}, + /* Str Match: push (strmatch stkforenext stknext stktop) */ {0} }; @@ -3383,7 +3395,7 @@ RecordByteCodeStats(codePtr) statsPtr->currentByteCodeBytes += (double) codePtr->structureSize; statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++; - statsPtr->byteCodeCount[TclLog2(codePtr->structureSize)]++; + statsPtr->byteCodeCount[TclLog2((int)(codePtr->structureSize))]++; statsPtr->currentInstBytes += (double) codePtr->numCodeBytes; statsPtr->currentLitBytes += diff --git a/generic/tclCompile.h b/generic/tclCompile.h index a7efb6b..935f5a7 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -7,7 +7,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.h,v 1.13 2000/05/23 22:10:51 ericm Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.14 2000/05/26 08:53:42 hobbs Exp $ */ #ifndef _TCLCOMPILATION @@ -495,12 +495,15 @@ typedef struct ByteCode { #define INST_PUSH_RETURN_CODE 72 /* Opcodes 73 to 74 */ -#define INST_STREQ 73 -#define INST_STRNEQ 74 -#define INST_STRLEN 75 +#define INST_STR_EQ 73 +#define INST_STR_NEQ 74 +#define INST_STR_CMP 75 +#define INST_STR_LEN 76 +#define INST_STR_INDEX 77 +#define INST_STR_MATCH 78 /* The last opcode */ -#define LAST_INST_OPCODE 75 +#define LAST_INST_OPCODE 78 /* * Table describing the Tcl bytecode instructions: their name (for diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 1169689..88b5299 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.12 2000/05/23 22:10:51 ericm Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.13 2000/05/26 08:53:42 hobbs Exp $ */ #include "tclInt.h" @@ -1757,15 +1757,14 @@ TclExecuteByteCode(interp, codePtr) } ADJUST_PC(1); - case INST_STREQ: - case INST_STRNEQ: + case INST_STR_EQ: + case INST_STR_NEQ: { /* * String (in)equality check */ char *s1, *s2; - int s1len, s2len; - long iResult; + int s1len, s2len, iResult; value2Ptr = POP_OBJECT(); valuePtr = POP_OBJECT(); @@ -1777,54 +1776,160 @@ TclExecuteByteCode(interp, codePtr) * We only need to check (in)equality when we have equal * length strings. */ - if (*pc == INST_STRNEQ) { + if (*pc == INST_STR_NEQ) { iResult = (strcmp(s1, s2) != 0); } else { - /* INST_STREQ */ + /* INST_STR_EQ */ iResult = (strcmp(s1, s2) == 0); } } else { - iResult = (*pc == INST_STRNEQ); + iResult = (*pc == INST_STR_NEQ); } + PUSH_OBJECT(Tcl_NewIntObj(iResult)); + TRACE(("%.20s %.20s => %d\n", + O2S(valuePtr), O2S(value2Ptr), iResult)); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); + } + ADJUST_PC(1); + + case INST_STR_CMP: + { /* - * Reuse the valuePtr object already on stack if possible. + * String compare */ - - if (Tcl_IsShared(valuePtr)) { - PUSH_OBJECT(Tcl_NewLongObj(iResult)); - TRACE(("%.20s %.20s => %ld\n", - O2S(valuePtr), O2S(value2Ptr), iResult)); - TclDecrRefCount(valuePtr); + char *s1, *s2; + int s1len, s2len, iResult; + + value2Ptr = POP_OBJECT(); + valuePtr = POP_OBJECT(); + + s1 = Tcl_GetStringFromObj(valuePtr, &s1len); + s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); + /* + * Compare up to the minimum byte length + */ + iResult = memcmp(s1, s2, + (size_t) ((s1len < s2len) ? s1len : s2len)); + if (iResult == 0) { + iResult = s1len - s2len; + } + + PUSH_OBJECT(Tcl_NewIntObj(iResult)); + TRACE(("%.20s %.20s => %d\n", + O2S(valuePtr), O2S(value2Ptr), iResult)); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); + } + ADJUST_PC(1); + + case INST_STR_LEN: + { + int length1; + + valuePtr = POP_OBJECT(); + + if (valuePtr->typePtr == &tclByteArrayType) { + (void) Tcl_GetByteArrayFromObj(valuePtr, &length1); + } else { + length1 = Tcl_GetCharLength(valuePtr); + } + PUSH_OBJECT(Tcl_NewIntObj(length1)); + TRACE(("%.20s => %d\n", O2S(valuePtr), length1)); + TclDecrRefCount(valuePtr); + } + ADJUST_PC(1); + + case INST_STR_INDEX: + { + /* + * String compare + */ + int index; + bytes = NULL; /* lint */ + + value2Ptr = POP_OBJECT(); + valuePtr = POP_OBJECT(); + + /* + * If we have a ByteArray object, avoid indexing in the + * Utf string since the byte array contains one byte per + * character. Otherwise, use the Unicode string rep to + * get the index'th char. + */ + + if (valuePtr->typePtr == &tclByteArrayType) { + bytes = Tcl_GetByteArrayFromObj(valuePtr, &length); + } else { + /* + * Get Unicode char length to calulate what 'end' means. + */ + length = Tcl_GetCharLength(valuePtr); + } + + result = TclGetIntForIndex(interp, value2Ptr, length - 1, + &index); + if (result != TCL_OK) { + Tcl_DecrRefCount(value2Ptr); + Tcl_DecrRefCount(valuePtr); + goto checkForCatch; + } + + if ((index >= 0) && (index < length)) { + if (valuePtr->typePtr == &tclByteArrayType) { + objPtr = Tcl_NewByteArrayObj((unsigned char *) + (&bytes[index]), 1); + } else { + char buf[TCL_UTF_MAX]; + Tcl_UniChar ch; + + ch = Tcl_GetUniChar(valuePtr, index); + length = Tcl_UniCharToUtf(ch, buf); + objPtr = Tcl_NewStringObj(buf, length); + } + } else { + objPtr = Tcl_NewObj(); + } + + PUSH_OBJECT(objPtr); + TRACE(("%.20s %.20s => %s\n", + O2S(valuePtr), O2S(value2Ptr), O2S(objPtr))); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); + } + ADJUST_PC(1); + + case INST_STR_MATCH: + { + int nocase, match; + + valuePtr = POP_OBJECT(); /* String */ + value2Ptr = POP_OBJECT(); /* Pattern */ + objPtr = POP_OBJECT(); /* Case Sensitivity */ + + Tcl_GetBooleanFromObj(interp, objPtr, &nocase); + match = Tcl_UniCharCaseMatch(Tcl_GetUnicode(valuePtr), + Tcl_GetUnicode(value2Ptr), nocase); + + /* + * Reuse the casePtr object already on stack if possible. + */ + + TRACE(("%.20s %.20s => %d\n", + O2S(valuePtr), O2S(value2Ptr), match)); + if (Tcl_IsShared(objPtr)) { + PUSH_OBJECT(Tcl_NewIntObj(match)); + TclDecrRefCount(objPtr); } else { /* reuse the valuePtr object */ - TRACE(("%.20s %.20s => %ld\n", - O2S(valuePtr), O2S(value2Ptr), iResult)); - Tcl_SetLongObj(valuePtr, iResult); + Tcl_SetIntObj(objPtr, match); ++stackTop; /* valuePtr now on stk top has right r.c. */ } + TclDecrRefCount(valuePtr); TclDecrRefCount(value2Ptr); } ADJUST_PC(1); - case INST_STRLEN: - { - int length1; - valuePtr = POP_OBJECT(); - if (valuePtr->typePtr == &tclByteArrayType) { - (void) Tcl_GetByteArrayFromObj(valuePtr, &length1); - } else { - length1 = Tcl_GetCharLength(valuePtr); - } - if (Tcl_IsShared(valuePtr)) { - PUSH_OBJECT(Tcl_NewIntObj(length1)); - TclDecrRefCount(valuePtr); - } else { - Tcl_SetIntObj(valuePtr, length1); - ++stackTop; - } - } - ADJUST_PC(1); - case INST_EQ: case INST_NEQ: case INST_LT: @@ -4519,7 +4624,7 @@ EvalStatsCmd(unused, interp, argc, argv) fprintf(stdout, " Mean code/source %.1f\n", totalCodeBytes / statsPtr->totalSrcBytes); - fprintf(stdout, "\nCurrent ByteCodes %ld\n", + fprintf(stdout, "\nCurrent (active) ByteCodes %ld\n", numCurrentByteCodes); fprintf(stdout, " Source bytes %.6g\n", statsPtr->currentSrcBytes); @@ -4542,6 +4647,29 @@ EvalStatsCmd(unused, interp, argc, argv) (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) %ld\n", + tclObjsShared[1]); + for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) { + fprintf(stdout, " refcount ==%d %ld\n", + i, tclObjsShared[i]); + numSharedMultX += tclObjsShared[i]; + } + fprintf(stdout, " refcount >=%d %ld\n", + i, tclObjsShared[0]); + numSharedMultX += tclObjsShared[0]; + fprintf(stdout, " Total shared objects %d\n", + numSharedMultX); + + /* * Literal table statistics. */ @@ -4581,7 +4709,7 @@ EvalStatsCmd(unused, interp, argc, argv) (tclObjsAlloced - tclObjsFreed)); fprintf(stdout, "Total literal objects %ld\n", statsPtr->numLiteralsCreated); - + fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n", globalTablePtr->numEntries, (globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed)); @@ -4732,7 +4860,7 @@ EvalStatsCmd(unused, interp, argc, argv) decadeHigh, (sum * 100.0) / statsPtr->numCompilations); } - fprintf(stdout, "\nByteCode longevity (excludes current ByteCodes):\n"); + fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n"); fprintf(stdout, " Up to ms Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { -- cgit v0.12