summaryrefslogtreecommitdiffstats
path: root/generic/tclCompCmdsSZ.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCompCmdsSZ.c')
-rw-r--r--generic/tclCompCmdsSZ.c868
1 files changed, 812 insertions, 56 deletions
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 754238f..5d3ffd3 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -17,6 +17,7 @@
#include "tclInt.h"
#include "tclCompile.h"
+#include "tclStringTrim.h"
/*
* Prototypes for procedures defined later in this file:
@@ -27,6 +28,9 @@ static void FreeJumptableInfo(ClientData clientData);
static void PrintJumptableInfo(ClientData clientData,
Tcl_Obj *appendObj, ByteCode *codePtr,
unsigned int pcOffset);
+static void DisassembleJumptableInfo(ClientData clientData,
+ Tcl_Obj *dictObj, ByteCode *codePtr,
+ unsigned int pcOffset);
static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, const char *identity,
int instruction, CompileEnv *envPtr);
@@ -71,7 +75,8 @@ const AuxDataType tclJumptableInfoType = {
"JumptableInfo", /* name */
DupJumptableInfo, /* dupProc */
FreeJumptableInfo, /* freeProc */
- PrintJumptableInfo /* printProc */
+ PrintJumptableInfo, /* printProc */
+ DisassembleJumptableInfo /* disassembleProc */
};
/*
@@ -101,6 +106,59 @@ const AuxDataType tclJumptableInfoType = {
if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));}
#define INVOKE(name) \
TclEmitInvoke(envPtr,INST_##name)
+
+#define INDEX_END (-2)
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetIndexFromToken --
+ *
+ * Parse a token and get the encoded version of the index (as understood
+ * by TEBC), assuming it is at all knowable at compile time. Only handles
+ * indices that are integers or 'end' or 'end-integer'.
+ *
+ * Returns:
+ * TCL_OK if parsing succeeded, and TCL_ERROR if it failed.
+ *
+ * Side effects:
+ * Sets *index to the index value if successful.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline int
+GetIndexFromToken(
+ Tcl_Token *tokenPtr,
+ int *index)
+{
+ Tcl_Obj *tmpObj = Tcl_NewObj();
+ int result, idx;
+
+ if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
+ Tcl_DecrRefCount(tmpObj);
+ return TCL_ERROR;
+ }
+
+ result = TclGetIntFromObj(NULL, tmpObj, &idx);
+ if (result == TCL_OK) {
+ if (idx < 0) {
+ result = TCL_ERROR;
+ }
+ } else {
+ result = TclGetIntForIndexM(NULL, tmpObj, INDEX_END, &idx);
+ if (result == TCL_OK && idx > INDEX_END) {
+ result = TCL_ERROR;
+ }
+ }
+ Tcl_DecrRefCount(tmpObj);
+
+ if (result == TCL_OK) {
+ *index = idx;
+ }
+
+ return result;
+}
/*
*----------------------------------------------------------------------
@@ -215,6 +273,78 @@ TclCompileSetCmd(
*/
int
+TclCompileStringCatCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ int i, numWords = parsePtr->numWords, numArgs;
+ Tcl_Token *wordTokenPtr;
+ Tcl_Obj *obj, *folded;
+ DefineLineInformation; /* TIP #280 */
+
+ /* Trivial case, no arg */
+
+ if (numWords<2) {
+ PushStringLiteral(envPtr, "");
+ return TCL_OK;
+ }
+
+ /* General case: issue CONCAT1's (by chunks of 254 if needed), folding
+ contiguous constants along the way */
+
+ numArgs = 0;
+ folded = NULL;
+ wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ for (i = 1; i < numWords; i++) {
+ obj = Tcl_NewObj();
+ if (TclWordKnownAtCompileTime(wordTokenPtr, obj)) {
+ if (folded) {
+ Tcl_AppendObjToObj(folded, obj);
+ Tcl_DecrRefCount(obj);
+ } else {
+ folded = obj;
+ }
+ } else {
+ Tcl_DecrRefCount(obj);
+ if (folded) {
+ int len;
+ const char *bytes = Tcl_GetStringFromObj(folded, &len);
+
+ PushLiteral(envPtr, bytes, len);
+ Tcl_DecrRefCount(folded);
+ folded = NULL;
+ numArgs ++;
+ }
+ CompileWord(envPtr, wordTokenPtr, interp, i);
+ numArgs ++;
+ if (numArgs >= 254) { /* 254 to take care of the possible +1 of "folded" above */
+ TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr);
+ numArgs = 1; /* concat pushes 1 obj, the result */
+ }
+ }
+ wordTokenPtr = TokenAfter(wordTokenPtr);
+ }
+ if (folded) {
+ int len;
+ const char *bytes = Tcl_GetStringFromObj(folded, &len);
+
+ PushLiteral(envPtr, bytes, len);
+ Tcl_DecrRefCount(folded);
+ folded = NULL;
+ numArgs ++;
+ }
+ if (numArgs > 1) {
+ TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr);
+ }
+
+ return TCL_OK;
+}
+
+int
TclCompileStringCmpCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
@@ -371,6 +501,284 @@ TclCompileStringIndexCmd(
}
int
+TclCompileStringIsCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ static const char *const isClasses[] = {
+ "alnum", "alpha", "ascii", "control",
+ "boolean", "digit", "double", "entier",
+ "false", "graph", "integer", "list",
+ "lower", "print", "punct", "space",
+ "true", "upper", "wideinteger", "wordchar",
+ "xdigit", NULL
+ };
+ enum isClasses {
+ STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
+ STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER,
+ STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST,
+ STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE,
+ STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD,
+ STR_IS_XDIGIT
+ };
+ int t, range, allowEmpty = 0, end;
+ InstStringClassType strClassType;
+ Tcl_Obj *isClass;
+
+ if (parsePtr->numWords < 3 || parsePtr->numWords > 6) {
+ return TCL_ERROR;
+ }
+ isClass = Tcl_NewObj();
+ if (!TclWordKnownAtCompileTime(tokenPtr, isClass)) {
+ Tcl_DecrRefCount(isClass);
+ return TCL_ERROR;
+ } else if (Tcl_GetIndexFromObj(interp, isClass, isClasses, "class", 0,
+ &t) != TCL_OK) {
+ Tcl_DecrRefCount(isClass);
+ TclCompileSyntaxError(interp, envPtr);
+ return TCL_OK;
+ }
+ Tcl_DecrRefCount(isClass);
+
+#define GotLiteral(tokenPtr, word) \
+ ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD && \
+ (tokenPtr)[1].size > 1 && \
+ (tokenPtr)[1].start[0] == word[0] && \
+ strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0)
+
+ /*
+ * Cannot handle the -failindex option at all, and that's the only legal
+ * way to have more than 4 arguments.
+ */
+
+ if (parsePtr->numWords != 3 && parsePtr->numWords != 4) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(tokenPtr);
+ if (parsePtr->numWords == 3) {
+ allowEmpty = 1;
+ } else {
+ if (!GotLiteral(tokenPtr, "-strict")) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+#undef GotLiteral
+
+ /*
+ * Compile the code. There are several main classes of check here.
+ * 1. Character classes
+ * 2. Booleans
+ * 3. Integers
+ * 4. Floats
+ * 5. Lists
+ */
+
+ CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
+
+ switch ((enum isClasses) t) {
+ case STR_IS_ALNUM:
+ strClassType = STR_CLASS_ALNUM;
+ goto compileStrClass;
+ case STR_IS_ALPHA:
+ strClassType = STR_CLASS_ALPHA;
+ goto compileStrClass;
+ case STR_IS_ASCII:
+ strClassType = STR_CLASS_ASCII;
+ goto compileStrClass;
+ case STR_IS_CONTROL:
+ strClassType = STR_CLASS_CONTROL;
+ goto compileStrClass;
+ case STR_IS_DIGIT:
+ strClassType = STR_CLASS_DIGIT;
+ goto compileStrClass;
+ case STR_IS_GRAPH:
+ strClassType = STR_CLASS_GRAPH;
+ goto compileStrClass;
+ case STR_IS_LOWER:
+ strClassType = STR_CLASS_LOWER;
+ goto compileStrClass;
+ case STR_IS_PRINT:
+ strClassType = STR_CLASS_PRINT;
+ goto compileStrClass;
+ case STR_IS_PUNCT:
+ strClassType = STR_CLASS_PUNCT;
+ goto compileStrClass;
+ case STR_IS_SPACE:
+ strClassType = STR_CLASS_SPACE;
+ goto compileStrClass;
+ case STR_IS_UPPER:
+ strClassType = STR_CLASS_UPPER;
+ goto compileStrClass;
+ case STR_IS_WORD:
+ strClassType = STR_CLASS_WORD;
+ goto compileStrClass;
+ case STR_IS_XDIGIT:
+ strClassType = STR_CLASS_XDIGIT;
+ compileStrClass:
+ if (allowEmpty) {
+ OP1( STR_CLASS, strClassType);
+ } else {
+ int over, over2;
+
+ OP( DUP);
+ OP1( STR_CLASS, strClassType);
+ JUMP1( JUMP_TRUE, over);
+ OP( POP);
+ PUSH( "0");
+ JUMP1( JUMP, over2);
+ FIXJUMP1(over);
+ PUSH( "");
+ OP( STR_NEQ);
+ FIXJUMP1(over2);
+ }
+ return TCL_OK;
+
+ case STR_IS_BOOL:
+ case STR_IS_FALSE:
+ case STR_IS_TRUE:
+ OP( TRY_CVT_TO_BOOLEAN);
+ switch (t) {
+ int over, over2;
+
+ case STR_IS_BOOL:
+ if (allowEmpty) {
+ JUMP1( JUMP_TRUE, over);
+ PUSH( "");
+ OP( STR_EQ);
+ JUMP1( JUMP, over2);
+ FIXJUMP1(over);
+ OP( POP);
+ PUSH( "1");
+ FIXJUMP1(over2);
+ } else {
+ OP4( REVERSE, 2);
+ OP( POP);
+ }
+ return TCL_OK;
+ case STR_IS_TRUE:
+ JUMP1( JUMP_TRUE, over);
+ if (allowEmpty) {
+ PUSH( "");
+ OP( STR_EQ);
+ } else {
+ OP( POP);
+ PUSH( "0");
+ }
+ FIXJUMP1( over);
+ OP( LNOT);
+ OP( LNOT);
+ return TCL_OK;
+ case STR_IS_FALSE:
+ JUMP1( JUMP_TRUE, over);
+ if (allowEmpty) {
+ PUSH( "");
+ OP( STR_NEQ);
+ } else {
+ OP( POP);
+ PUSH( "1");
+ }
+ FIXJUMP1( over);
+ OP( LNOT);
+ return TCL_OK;
+ }
+
+ case STR_IS_DOUBLE: {
+ int satisfied, isEmpty;
+
+ if (allowEmpty) {
+ OP( DUP);
+ PUSH( "");
+ OP( STR_EQ);
+ JUMP1( JUMP_TRUE, isEmpty);
+ OP( NUM_TYPE);
+ JUMP1( JUMP_TRUE, satisfied);
+ PUSH( "0");
+ JUMP1( JUMP, end);
+ FIXJUMP1( isEmpty);
+ OP( POP);
+ FIXJUMP1( satisfied);
+ } else {
+ OP( NUM_TYPE);
+ JUMP1( JUMP_TRUE, satisfied);
+ PUSH( "0");
+ JUMP1( JUMP, end);
+ TclAdjustStackDepth(-1, envPtr);
+ FIXJUMP1( satisfied);
+ }
+ PUSH( "1");
+ FIXJUMP1( end);
+ return TCL_OK;
+ }
+
+ case STR_IS_INT:
+ case STR_IS_WIDE:
+ case STR_IS_ENTIER:
+ if (allowEmpty) {
+ int testNumType;
+
+ OP( DUP);
+ OP( NUM_TYPE);
+ OP( DUP);
+ JUMP1( JUMP_TRUE, testNumType);
+ OP( POP);
+ PUSH( "");
+ OP( STR_EQ);
+ JUMP1( JUMP, end);
+ TclAdjustStackDepth(1, envPtr);
+ FIXJUMP1( testNumType);
+ OP4( REVERSE, 2);
+ OP( POP);
+ } else {
+ OP( NUM_TYPE);
+ OP( DUP);
+ JUMP1( JUMP_FALSE, end);
+ }
+
+ switch (t) {
+ case STR_IS_INT:
+ PUSH( "1");
+ OP( EQ);
+ break;
+ case STR_IS_WIDE:
+ PUSH( "2");
+ OP( LE);
+ break;
+ case STR_IS_ENTIER:
+ PUSH( "3");
+ OP( LE);
+ break;
+ }
+ FIXJUMP1( end);
+ return TCL_OK;
+
+ case STR_IS_LIST:
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ OP4( BEGIN_CATCH4, range);
+ ExceptionRangeStarts(envPtr, range);
+ OP( DUP);
+ OP( LIST_LENGTH);
+ OP( POP);
+ ExceptionRangeEnds(envPtr, range);
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ OP( POP);
+ OP( PUSH_RETURN_CODE);
+ OP( END_CATCH);
+ OP( LNOT);
+ return TCL_OK;
+ }
+
+ return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
TclCompileStringMatchCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
@@ -565,8 +973,7 @@ TclCompileStringRangeCmd(
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *stringTokenPtr, *fromTokenPtr, *toTokenPtr;
- Tcl_Obj *tmpObj;
- int idx1, idx2, result;
+ int idx1, idx2;
if (parsePtr->numWords != 4) {
return TCL_ERROR;
@@ -576,50 +983,13 @@ TclCompileStringRangeCmd(
toTokenPtr = TokenAfter(fromTokenPtr);
/*
- * Parse the first index. Will only compile if it is constant and not an
- * _integer_ less than zero (since we reserve negative indices here for
- * end-relative indexing).
+ * Parse the two indices.
*/
- tmpObj = Tcl_NewObj();
- result = TCL_ERROR;
- if (TclWordKnownAtCompileTime(fromTokenPtr, tmpObj)) {
- if (TclGetIntFromObj(NULL, tmpObj, &idx1) == TCL_OK) {
- if (idx1 >= 0) {
- result = TCL_OK;
- }
- } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx1) == TCL_OK) {
- if (idx1 <= -2) {
- result = TCL_OK;
- }
- }
- }
- TclDecrRefCount(tmpObj);
- if (result != TCL_OK) {
+ if (GetIndexFromToken(fromTokenPtr, &idx1) != TCL_OK) {
goto nonConstantIndices;
}
-
- /*
- * Parse the second index. Will only compile if it is constant and not an
- * _integer_ less than zero (since we reserve negative indices here for
- * end-relative indexing).
- */
-
- tmpObj = Tcl_NewObj();
- result = TCL_ERROR;
- if (TclWordKnownAtCompileTime(toTokenPtr, tmpObj)) {
- if (TclGetIntFromObj(NULL, tmpObj, &idx2) == TCL_OK) {
- if (idx2 >= 0) {
- result = TCL_OK;
- }
- } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx2) == TCL_OK) {
- if (idx2 <= -2) {
- result = TCL_OK;
- }
- }
- }
- TclDecrRefCount(tmpObj);
- if (result != TCL_OK) {
+ if (GetIndexFromToken(toTokenPtr, &idx2) != TCL_OK) {
goto nonConstantIndices;
}
@@ -642,6 +1012,320 @@ TclCompileStringRangeCmd(
OP( STR_RANGE);
return TCL_OK;
}
+
+int
+TclCompileStringReplaceCmd(
+ Tcl_Interp *interp, /* Tcl interpreter for context. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the
+ * command. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds the resulting instructions. */
+{
+ Tcl_Token *tokenPtr, *valueTokenPtr, *replacementTokenPtr = NULL;
+ DefineLineInformation; /* TIP #280 */
+ int idx1, idx2;
+
+ if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
+ return TCL_ERROR;
+ }
+ valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (parsePtr->numWords == 5) {
+ tokenPtr = TokenAfter(valueTokenPtr);
+ tokenPtr = TokenAfter(tokenPtr);
+ replacementTokenPtr = TokenAfter(tokenPtr);
+ }
+
+ /*
+ * Parse the indices. Will only compile special cases if both are
+ * constants and not an _integer_ less than zero (since we reserve
+ * negative indices here for end-relative indexing) or an end-based index
+ * greater than 'end' itself.
+ */
+
+ tokenPtr = TokenAfter(valueTokenPtr);
+ if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) {
+ goto genericReplace;
+ }
+
+ tokenPtr = TokenAfter(tokenPtr);
+ if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) {
+ goto genericReplace;
+ }
+
+ /*
+ * We handle these replacements specially: first character (where
+ * idx1=idx2=0) and last character (where idx1=idx2=INDEX_END). Anything
+ * else and the semantics get rather screwy.
+ */
+
+ if (idx1 == 0 && idx2 == 0) {
+ int notEq, end;
+
+ /*
+ * Just working with the first character.
+ */
+
+ CompileWord(envPtr, valueTokenPtr, interp, 1);
+ if (replacementTokenPtr == NULL) {
+ /* Drop first */
+ OP44( STR_RANGE_IMM, 1, INDEX_END);
+ return TCL_OK;
+ }
+ /* Replace first */
+ CompileWord(envPtr, replacementTokenPtr, interp, 4);
+ OP4( OVER, 1);
+ PUSH( "");
+ OP( STR_EQ);
+ JUMP1( JUMP_FALSE, notEq);
+ OP( POP);
+ JUMP1( JUMP, end);
+ FIXJUMP1(notEq);
+ TclAdjustStackDepth(1, envPtr);
+ OP4( REVERSE, 2);
+ OP44( STR_RANGE_IMM, 1, INDEX_END);
+ OP1( STR_CONCAT1, 2);
+ FIXJUMP1(end);
+ return TCL_OK;
+
+ } else if (idx1 == INDEX_END && idx2 == INDEX_END) {
+ int notEq, end;
+
+ /*
+ * Just working with the last character.
+ */
+
+ CompileWord(envPtr, valueTokenPtr, interp, 1);
+ if (replacementTokenPtr == NULL) {
+ /* Drop last */
+ OP44( STR_RANGE_IMM, 0, INDEX_END-1);
+ return TCL_OK;
+ }
+ /* Replace last */
+ CompileWord(envPtr, replacementTokenPtr, interp, 4);
+ OP4( OVER, 1);
+ PUSH( "");
+ OP( STR_EQ);
+ JUMP1( JUMP_FALSE, notEq);
+ OP( POP);
+ JUMP1( JUMP, end);
+ FIXJUMP1(notEq);
+ TclAdjustStackDepth(1, envPtr);
+ OP4( REVERSE, 2);
+ OP44( STR_RANGE_IMM, 0, INDEX_END-1);
+ OP4( REVERSE, 2);
+ OP1( STR_CONCAT1, 2);
+ FIXJUMP1(end);
+ return TCL_OK;
+
+ } else {
+ /*
+ * Need to process indices at runtime. This could be because the
+ * indices are not constants, or because we need to resolve them to
+ * absolute indices to work out if a replacement is going to happen.
+ * In any case, to runtime it is.
+ */
+
+ genericReplace:
+ CompileWord(envPtr, valueTokenPtr, interp, 1);
+ tokenPtr = TokenAfter(valueTokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 3);
+ if (replacementTokenPtr != NULL) {
+ CompileWord(envPtr, replacementTokenPtr, interp, 4);
+ } else {
+ PUSH( "");
+ }
+ OP( STR_REPLACE);
+ return TCL_OK;
+ }
+}
+
+int
+TclCompileStringTrimLCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+
+ if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ if (parsePtr->numWords == 3) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ } else {
+ PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet));
+ }
+ OP( STR_TRIM_LEFT);
+ return TCL_OK;
+}
+
+int
+TclCompileStringTrimRCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+
+ if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ if (parsePtr->numWords == 3) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ } else {
+ PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet));
+ }
+ OP( STR_TRIM_RIGHT);
+ return TCL_OK;
+}
+
+int
+TclCompileStringTrimCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+
+ if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ if (parsePtr->numWords == 3) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ } else {
+ PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet));
+ }
+ OP( STR_TRIM);
+ return TCL_OK;
+}
+
+int
+TclCompileStringToUpperCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+
+ if (parsePtr->numWords != 2) {
+ return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ OP( STR_UPPER);
+ return TCL_OK;
+}
+
+int
+TclCompileStringToLowerCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+
+ if (parsePtr->numWords != 2) {
+ return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ OP( STR_LOWER);
+ return TCL_OK;
+}
+
+int
+TclCompileStringToTitleCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+
+ if (parsePtr->numWords != 2) {
+ return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ OP( STR_TITLE);
+ return TCL_OK;
+}
+
+/*
+ * Support definitions for the [string is] compilation.
+ */
+
+static int
+UniCharIsAscii(
+ int character)
+{
+ return (character >= 0) && (character < 0x80);
+}
+
+static int
+UniCharIsHexDigit(
+ int character)
+{
+ return (character >= 0) && (character < 0x80) && isxdigit(character);
+}
+
+StringClassDesc const tclStringClassTable[] = {
+ {"alnum", Tcl_UniCharIsAlnum},
+ {"alpha", Tcl_UniCharIsAlpha},
+ {"ascii", UniCharIsAscii},
+ {"control", Tcl_UniCharIsControl},
+ {"digit", Tcl_UniCharIsDigit},
+ {"graph", Tcl_UniCharIsGraph},
+ {"lower", Tcl_UniCharIsLower},
+ {"print", Tcl_UniCharIsPrint},
+ {"punct", Tcl_UniCharIsPunct},
+ {"space", Tcl_UniCharIsSpace},
+ {"upper", Tcl_UniCharIsUpper},
+ {"word", Tcl_UniCharIsWordChar},
+ {"xdigit", UniCharIsHexDigit},
+ {NULL, NULL}
+};
/*
*----------------------------------------------------------------------
@@ -752,7 +1436,7 @@ TclSubstCompile(
/*
* Tricky point! If the first token does not result in a *guaranteed* push
* of a Tcl_Obj on the stack, we must push an empty object. Otherwise it
- * is possible to get to an INST_CONCAT1 or INST_DONE without enough
+ * is possible to get to an INST_STR_CONCAT1 or INST_DONE without enough
* values on the stack, resulting in a crash. Thanks to Joe Mistachkin for
* identifying a script that could trigger this case.
*/
@@ -817,11 +1501,11 @@ TclSubstCompile(
}
while (count > 255) {
- OP1( CONCAT1, 255);
+ OP1( STR_CONCAT1, 255);
count -= 254;
}
if (count > 1) {
- OP1( CONCAT1, count);
+ OP1( STR_CONCAT1, count);
count = 1;
}
@@ -941,7 +1625,7 @@ TclSubstCompile(
(int) (CurrentOffset(envPtr) - okFixup.codeOffset));
}
if (count > 1) {
- OP1(CONCAT1, count);
+ OP1(STR_CONCAT1, count);
count = 1;
}
@@ -954,11 +1638,11 @@ TclSubstCompile(
}
while (count > 255) {
- OP1( CONCAT1, 255);
+ OP1( STR_CONCAT1, 255);
count -= 254;
}
if (count > 1) {
- OP1( CONCAT1, count);
+ OP1( STR_CONCAT1, count);
}
Tcl_FreeParse(&parse);
@@ -1411,7 +2095,7 @@ IssueSwitchChainedTests(
*/
if (TclReToGlob(NULL, bodyToken[i]->start,
- bodyToken[i]->size, &ds, &exact) == TCL_OK) {
+ bodyToken[i]->size, &ds, &exact, NULL) == TCL_OK){
simple = 1;
PushLiteral(envPtr, Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds));
@@ -1761,11 +2445,13 @@ IssueSwitchJumpTable(
* DupJumptableInfo: a copy of the jump-table
* FreeJumptableInfo: none
* PrintJumptableInfo: none
+ * DisassembleJumptableInfo: none
*
* Side effects:
* DupJumptableInfo: allocates memory
* FreeJumptableInfo: releases memory
* PrintJumptableInfo: none
+ * DisassembleJumptableInfo: none
*
*----------------------------------------------------------------------
*/
@@ -1828,6 +2514,30 @@ PrintJumptableInfo(
keyPtr, pcOffset + offset);
}
}
+
+static void
+DisassembleJumptableInfo(
+ ClientData clientData,
+ Tcl_Obj *dictObj,
+ ByteCode *codePtr,
+ unsigned int pcOffset)
+{
+ register JumptableInfo *jtPtr = clientData;
+ Tcl_Obj *mapping = Tcl_NewObj();
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ const char *keyPtr;
+ int offset;
+
+ hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
+ for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
+ keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
+ offset = PTR2INT(Tcl_GetHashValue(hPtr));
+ Tcl_DictObjPut(NULL, mapping, Tcl_NewStringObj(keyPtr, -1),
+ Tcl_NewIntObj(offset));
+ }
+ Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", -1), mapping);
+}
/*
*----------------------------------------------------------------------
@@ -2358,6 +3068,7 @@ IssueTryClausesInstructions(
if (!handlerTokens[i]) {
forwardsNeedFixing = 1;
JUMP4( JUMP, forwardsToFix[i]);
+ TclAdjustStackDepth(1, envPtr);
} else {
int dontChangeOptions;
@@ -2864,16 +3575,16 @@ TclCompileUnsetCmd(
}
return TCL_ERROR;
}
- if (i == 1) {
+ if (varCount == 0) {
const char *bytes;
int len;
bytes = Tcl_GetStringFromObj(leadingWord, &len);
- if (len == 11 && !strncmp("-nocomplain", bytes, 11)) {
+ if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) {
flags = 0;
- haveFlags = 1;
- } else if (len == 2 && !strncmp("--", bytes, 2)) {
- haveFlags = 1;
+ haveFlags++;
+ } else if (i == (2 - flags) && len == 2 && !strncmp("--", bytes, 2)) {
+ haveFlags++;
} else {
varCount++;
}
@@ -2888,7 +3599,7 @@ TclCompileUnsetCmd(
*/
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (haveFlags) {
+ for (i=0; i<haveFlags;i++) {
varTokenPtr = TokenAfter(varTokenPtr);
}
for (i=1+haveFlags ; i<parsePtr->numWords ; i++) {
@@ -3151,6 +3862,51 @@ TclCompileYieldCmd(
/*
*----------------------------------------------------------------------
*
+ * TclCompileYieldToCmd --
+ *
+ * Procedure called to compile the "yieldto" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "yieldto" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileYieldToCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ int i;
+
+ if (parsePtr->numWords < 2) {
+ return TCL_ERROR;
+ }
+
+ OP( NS_CURRENT);
+ for (i = 1 ; i < parsePtr->numWords ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ OP4( LIST, i);
+ OP( YIELD_TO_INVOKE);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* CompileUnaryOpCmd --
*
* Utility routine to compile the unary operator commands.
generated by cgit v0.12 at 2024-11-24 05:15:14 (GMT)