summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorhobbs <hobbs>2000-05-26 08:53:40 (GMT)
committerhobbs <hobbs>2000-05-26 08:53:40 (GMT)
commita14ef5dc21d5fb63776b7d6be34b84ecfd368aad (patch)
treea406c998489681d6068a7a69a1a2fdcc49338dc2 /generic
parent28c1d61f70d965d141ddad0aa91da2a34886601d (diff)
downloadtcl-a14ef5dc21d5fb63776b7d6be34b84ecfd368aad.zip
tcl-a14ef5dc21d5fb63776b7d6be34b84ecfd368aad.tar.gz
tcl-a14ef5dc21d5fb63776b7d6be34b84ecfd368aad.tar.bz2
* 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.
Diffstat (limited to 'generic')
-rw-r--r--generic/tclCompCmds.c157
-rw-r--r--generic/tclCompExpr.c6
-rw-r--r--generic/tclCompile.c302
-rw-r--r--generic/tclCompile.h13
-rw-r--r--generic/tclExecute.c208
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]; <objc,objv> = <op1,top op1> */
- {"invokeStk4", 5, 1, {OPERAND_UINT4}},
- /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
- {"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]; <objc,objv> = <op1,top op1> */
+ {"invokeStk4", 5, 1, {OPERAND_UINT4}},
+ /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
+ {"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]; <objc,objv>=<op1,top op1> */
- {"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]; <objc,objv>=<op1,top op1> */
+ {"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++) {