a different approach

5 files changed, 98 insertions, 72 deletions

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 89c286a..70379c6 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -437,6 +437,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},
@@ -516,7 +517,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/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 345dd9f..1436a20 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -500,7 +500,7 @@ TclCompileStringIsCmd(
      * example of this.
      */
 
-    switch (t) {
+    switch ((enum isClasses) t) {
     case STR_IS_ALNUM:
     case STR_IS_ALPHA:
     case STR_IS_ASCII:
@@ -514,93 +514,103 @@ TclCompileStringIsCmd(
     case STR_IS_UPPER:
     case STR_IS_WORD:
     case STR_IS_XDIGIT:
+	/* Not yet implemented */
 	return TCL_ERROR;
 
     case STR_IS_BOOL:
     case STR_IS_FALSE:
-    case STR_IS_INT:
     case STR_IS_TRUE:
-    case STR_IS_WIDE:
 	/* Not yet implemented */
 	return TCL_ERROR;
-    }
-
-    /*
-     * Push the word to check.
-     */
-
-    CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
 
-    /*
-     * Next, do the type check. First, we push a catch range; most of the
-     * type-check operations throw an exception on failure.
-     */
-
-    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
-    OP4(		BEGIN_CATCH4, range);
-    ExceptionRangeStarts(envPtr, range);
-
-    /*
-     * Issue the type-check itself for the specific type.
-     */
+    case STR_IS_DOUBLE: {
+	int satisfied, isEmpty;
 
-    switch (t) {
-    case STR_IS_DOUBLE:
-	/*
-	 * Careful! Preserve behavior of NaN which is a double (that is, true
-	 * for the purposes of a type check) but most math ops fail on it. The
-	 * key is that it is not == to itself (and is the only value which
-	 * this is true for).
-	 */
+	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;
+    }
 
-	OP(		DUP);
-	OP(		DUP);
-	OP(		NEQ);
-	OP1(		JUMP_TRUE1, 5);
+    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);
+	}
 
-	/*
-	 * Type check for all other double values.
-	 */
+	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;
 
-	OP(		DUP);
-	OP(		UMINUS);
-	OP(		POP);
-	break;
-    case STR_IS_ENTIER:
-	OP(		DUP);
-	OP(		BITNOT);
-	OP(		POP);
-	break;
     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);
-	break;
-    }
-
-    /*
-     * Based on whether the exception was thrown (or conditional branch taken,
-     * in the case of true/false checks), push the correct boolean value. This
-     * is also where we deal with what happens with empty values in non-strict
-     * mode.
-     */
-
-    ExceptionRangeEnds(envPtr, range);
-    OP(			END_CATCH);
-    OP(			POP);
-    PUSH(		"1");
-    JUMP1(		JUMP, end);
-    ExceptionRangeTarget(envPtr, range, catchOffset);
-    OP(			END_CATCH);
-    if (allowEmpty) {
-	PUSH(		"");
-	OP(		STR_EQ);
-    } else {
+	ExceptionRangeEnds(envPtr, range);
+	ExceptionRangeTarget(envPtr, range, catchOffset);
 	OP(		POP);
-	PUSH(		"0");
+	OP(		PUSH_RETURN_CODE);
+	OP(		END_CATCH);
+	OP(		LNOT);
+	return TCL_OK;
     }
-    FIXJUMP1(	end);
-    return TCL_OK;
+    return TCL_ERROR;
 }
 
 int
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index ee67e24..c01571f 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -621,6 +621,10 @@ InstructionDesc const tclInstructionTable[] = {
 	/* Push the identity of the current TclOO object (i.e., the name of
 	 * its current public access command) on the stack. */
 
+    {"numericType",	 1,	0,	  0,	{OPERAND_NONE}},
+	/* Pushes the numeric type code of the word at the top of the stack.
+	 * Stack:  ... value => ... typeCode */
+
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
 
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 6ecadf4..6bf5daf 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -792,8 +792,10 @@ typedef struct ByteCode {
 
 #define INST_TCLOO_NEXT			179
 
+#define INST_NUM_TYPE			180
+
 /* The last opcode */
-#define LAST_INST_OPCODE		179
+#define LAST_INST_OPCODE		180
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 5b42124..2707ec1 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -5776,6 +5776,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: