From 72901fb88ca266a88a78b0a34c4db3b3c386e367 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 2 Nov 2012 16:50:06 +0000 Subject: Work on compilation of [string is]. Hit some problem edge cases with differences in strictness of edge cases that will force a rethink ([string is boolean] is significantly more strict than Tcl_GetBooleanFromObj). --- generic/tclCmdMZ.c | 2 +- generic/tclCompCmdsSZ.c | 190 ++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 3 + 3 files changed, 194 insertions(+), 1 deletion(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index de32fce..0526325 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3306,7 +3306,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, NULL, 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 57cb992..b9309ec 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -451,6 +451,196 @@ TclCompileStringIndexCmd( /* *---------------------------------------------------------------------- * + * TclCompileStringIsCmd -- + * + * Procedure called to compile the simplest and most common form of the + * "string is" 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 "string is" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +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); + int numWords = parsePtr->numWords; + enum IsType { + TypeBool, TypeBoolFalse, TypeBoolTrue, + TypeFloat, + TypeInteger, TypeNarrowInt, TypeWideInt, + TypeList /*, TypeDict */ + }; + enum IsType t; + JumpFixup jumpFixup; + int start, range; + int allowEmpty = 0; + + if (numWords < 2 || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } +#define GotLiteral(tokenPtr,word) \ + ((tokenPtr)[1].size > 1 && (tokenPtr)[1].start[0] == word[0] && \ + strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0) + + if (GotLiteral(tokenPtr, "boolean")) { + t = TypeBool; + } else if (GotLiteral(tokenPtr, "double")) { + t = TypeFloat; + } else if (GotLiteral(tokenPtr, "entier")) { + t = TypeInteger; + } else if (GotLiteral(tokenPtr, "false")) { + t = TypeBoolFalse; + } else if (GotLiteral(tokenPtr, "integer")) { + t = TypeNarrowInt; + return TCL_ERROR; // Not yet implemented + } else if (GotLiteral(tokenPtr, "list")) { + t = TypeList; + } else if (GotLiteral(tokenPtr, "true")) { + t = TypeBoolTrue; + } else if (GotLiteral(tokenPtr, "wideinteger")) { + t = TypeWideInt; + return TCL_ERROR; // Not yet implemented + } else { + /* + * We don't handle character class checks in bytecode currently. + */ + + return TCL_ERROR; + } + if (numWords != 3 && numWords != 4) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + if (numWords == 3) { + allowEmpty = (t != TypeList); + } else { + if (!GotLiteral(tokenPtr, "-strict")) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + } +#undef GotLiteral + + /* + * Push the word to check. + */ + + CompileWord(envPtr, tokenPtr, interp, 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 = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + start = 0; + TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); + ExceptionRangeStarts(envPtr, range); + + /* + * Issue the type-check itself for the specific type. + */ + + switch (t) { + case TypeBool: + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LNOT, envPtr); + TclEmitOpcode( INST_POP, envPtr); + break; + case TypeBoolFalse: + TclEmitOpcode( INST_DUP, envPtr); + start = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + break; + case TypeBoolTrue: + TclEmitOpcode( INST_DUP, envPtr); + start = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); + break; + case TypeFloat: + /* + * 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). + */ + + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_NEQ, envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 5, envPtr); + + /* + * Type check for all other double values. + */ + + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_UMINUS, envPtr); + TclEmitOpcode( INST_POP, envPtr); + break; + case TypeInteger: + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_BITNOT, envPtr); + TclEmitOpcode( INST_POP, envPtr); + break; + case TypeNarrowInt: + Tcl_Panic("not yet implemented"); + case TypeWideInt: + Tcl_Panic("not yet implemented"); + case TypeList: + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + 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); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + PushLiteral(envPtr, "1", 1); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + ExceptionRangeTarget(envPtr, range, catchOffset); + if (start != 0) { + TclStoreInt1AtPtr(CurrentOffset(envPtr) - start, + envPtr->codeStart + start + 1); + } + TclEmitOpcode( INST_END_CATCH, envPtr); + if (allowEmpty) { + PushLiteral(envPtr, "", 0); + TclEmitOpcode( INST_STR_EQ, envPtr); + } else { + TclEmitOpcode( INST_POP, envPtr); + PushLiteral(envPtr, "0", 1); + } + TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileStringMatchCmd -- * * Procedure called to compile the simplest and most common form of the diff --git a/generic/tclInt.h b/generic/tclInt.h index 1fffa1f..e513a6e 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3647,6 +3647,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 TclCompileStringLenCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12