summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2014-01-10 15:58:41 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2014-01-10 15:58:41 (GMT)
commitc3c6e803684022dcc788ddbfc4a59a6d0dfde102 (patch)
treee059ae617b58faac8fe25b5c8b71697b13b788df /generic
parentacf1cebeab93607fc83206e77534b5fada8726ef (diff)
downloadtcl-c3c6e803684022dcc788ddbfc4a59a6d0dfde102.zip
tcl-c3c6e803684022dcc788ddbfc4a59a6d0dfde102.tar.gz
tcl-c3c6e803684022dcc788ddbfc4a59a6d0dfde102.tar.bz2
a different approach
Diffstat (limited to 'generic')
-rw-r--r--generic/tclAssembly.c4
-rw-r--r--generic/tclCompCmdsSZ.c150
-rw-r--r--generic/tclCompile.c4
-rw-r--r--generic/tclCompile.h4
-rw-r--r--generic/tclExecute.c8
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: