summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclAssembly.c5
-rw-r--r--generic/tclCmdMZ.c2
-rw-r--r--generic/tclCompCmdsSZ.c232
-rw-r--r--generic/tclCompile.c7
-rw-r--r--generic/tclCompile.h5
-rw-r--r--generic/tclExecute.c19
-rw-r--r--generic/tclInt.h3
7 files changed, 270 insertions, 3 deletions
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 7b775a9..d5dbb9a 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -438,6 +438,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"nop", ASSEM_1BYTE, INST_NOP, 0, 0},
{"not", ASSEM_1BYTE, INST_LNOT, 1, 1},
{"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1},
+ {"numericType", ASSEM_1BYTE, INST_NUM_TYPE, 1, 1},
{"originCmd", ASSEM_1BYTE, INST_ORIGIN_COMMAND, 1, 1},
{"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1},
{"pop", ASSEM_1BYTE, INST_POP, 1, 0},
@@ -478,6 +479,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1},
{"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1},
{"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1},
+ {"tryCvtToBoolean", ASSEM_1BYTE, INST_TRY_CVT_TO_BOOLEAN,1, 2},
{"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1},
{"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1},
{"unset", ASSEM_BOOL_LVT4,INST_UNSET_SCALAR, 0, 0},
@@ -517,7 +519,8 @@ static const unsigned char NonThrowingByteCodes[] = {
INST_RESOLVE_COMMAND, /* 154 */
INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 166-168 */
INST_CONCAT_STK, /* 169 */
- INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE /* 170-172 */
+ INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE, /* 170-172 */
+ INST_NUM_TYPE /* 180 */
};
/*
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index d477216..e4020dd 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -3299,7 +3299,7 @@ TclInitStringCmd(
{"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0},
{"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0},
{"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0},
- {"is", StringIsCmd, NULL, NULL, NULL, 0},
+ {"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0},
{"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0},
{"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0},
{"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0},
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 5c132b4..1a69a89 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -425,6 +425,238 @@ 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;
+ 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 = (t != STR_IS_LIST);
+ } else {
+ if (!GotLiteral(tokenPtr, "-strict")) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+#undef GotLiteral
+
+ /*
+ * Some types are not currently handled. Character classes are a prime
+ * example of this.
+ */
+
+ switch ((enum isClasses) t) {
+ case STR_IS_ALNUM:
+ case STR_IS_ALPHA:
+ case STR_IS_ASCII:
+ case STR_IS_CONTROL:
+ case STR_IS_DIGIT:
+ case STR_IS_GRAPH:
+ case STR_IS_LOWER:
+ case STR_IS_PRINT:
+ case STR_IS_PUNCT:
+ case STR_IS_SPACE:
+ case STR_IS_UPPER:
+ case STR_IS_WORD:
+ case STR_IS_XDIGIT:
+ return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+
+ case STR_IS_BOOL:
+ case STR_IS_FALSE:
+ case STR_IS_TRUE:
+ CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
+ 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;
+
+ CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
+ 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:
+ CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
+ 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:
+ CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
+ 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 TCL_ERROR;
+}
+
+int
TclCompileStringMatchCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index f75ac83..fdc3e26 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -638,6 +638,13 @@ InstructionDesc const tclInstructionTable[] = {
* that are the response back on top of the stack when it resumes.
* Stack: ... [list ns cmd arg1 ... argN] => ... resumeList */
+ {"numericType", 1, 0, 0, {OPERAND_NONE}},
+ /* Pushes the numeric type code of the word at the top of the stack.
+ * Stack: ... value => ... typeCode */
+ {"tryCvtToBoolean", 1, +1, 0, {OPERAND_NONE}},
+ /* Try converting stktop to boolean if possible. No errors.
+ * Stack: ... value => ... value isStrictBool */
+
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 7994e2c..d6d515d 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -795,8 +795,11 @@ typedef struct ByteCode {
#define INST_YIELD_TO_INVOKE 181
+#define INST_NUM_TYPE 182
+#define INST_TRY_CVT_TO_BOOLEAN 183
+
/* The last opcode */
-#define LAST_INST_OPCODE 181
+#define LAST_INST_OPCODE 183
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 6749120..916de17 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -5944,6 +5944,14 @@ TEBCresume(
int type1, type2;
long l1, l2, lResult;
+ case INST_NUM_TYPE:
+ if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
+ type1 = 0;
+ }
+ TclNewIntObj(objResultPtr, type1);
+ TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
+ NEXT_INST_F(1, 1, 1);
+
case INST_EQ:
case INST_NEQ:
case INST_LT:
@@ -6621,6 +6629,17 @@ TEBCresume(
* -----------------------------------------------------------------
*/
+ case INST_TRY_CVT_TO_BOOLEAN:
+ valuePtr = OBJ_AT_TOS;
+ if (valuePtr->typePtr == &tclBooleanType) {
+ objResultPtr = TCONST(1);
+ } else {
+ int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK);
+ objResultPtr = TCONST(result);
+ }
+ TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr);
+ NEXT_INST_F(1, 0, 1);
+
case INST_BREAK:
/*
DECACHE_STACK_INFO();
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 6ddb015..a9f4c16 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3622,6 +3622,9 @@ MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileStringLastCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
generated by cgit v0.12 at 2024-07-07 14:48:12 (GMT)