diff options
| -rw-r--r-- | ChangeLog | 24 | ||||
| -rw-r--r-- | generic/tclBasic.c | 6 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 281 | ||||
| -rw-r--r-- | generic/tclCompile.h | 5 | ||||
| -rw-r--r-- | generic/tclExecute.c | 21 | ||||
| -rw-r--r-- | generic/tclInt.h | 6 |
6 files changed, 335 insertions, 8 deletions
@@ -1,3 +1,27 @@ +2000-05-23 Eric Melski <ericm@scriptics.com> + + * generic/tclInt.h: Added function prototypes for + TclCompileStringCmd and TclCompileReturnCmd. + + * generic/tclCompile.h: Added definition of INST_STRLEN opcode and + updated LAST_INST_OPCODE value. + + * generic/tclBasic.c: Added information about TclCompileStringCmd + and TclCompileReturnCmd to BuiltInCmds table. + + * generic/tclExecute.c (TclExecuteByteCode): Added support for the + INST_STRLEN opcode. + + * generic/tclCompCmds.c + (TclCompileStringCmd): Basic implementation of byte-compiled + [string] command. Not all subcommands are implemented; those + that are not an out-line compiled. + + (TclCompileReturnCmd): Byte-compiled implementation of [return] + command. Only "simple" returns are byte-compiled; in particular, + if the -code, -errorinfo or -errorcode flags are used, the command + is not byte-compiled. + 2000-05-22 Jeff Hobbs <hobbs@scriptics.com> * doc/scan.n: diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 9a73e94..e9a52e6 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.27 2000/04/15 17:34:09 hobbs Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.28 2000/05/23 22:10:49 ericm Exp $ */ #include "tclInt.h" @@ -142,7 +142,7 @@ static CmdInfo builtInCmds[] = { {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd, (CompileProc *) NULL, 1}, {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd, - (CompileProc *) NULL, 1}, + TclCompileReturnCmd, 1}, {"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd, (CompileProc *) NULL, 1}, {"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd, @@ -150,7 +150,7 @@ static CmdInfo builtInCmds[] = { {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd, (CompileProc *) NULL, 1}, {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd, - (CompileProc *) NULL, 1}, + TclCompileStringCmd, 1}, {"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd, (CompileProc *) NULL, 1}, {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 75fa02e..5b6c966 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.5 2000/01/21 02:25:26 hobbs Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.6 2000/05/23 22:10:50 ericm Exp $ */ #include "tclInt.h" @@ -1543,6 +1543,111 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) /* *---------------------------------------------------------------------- * + * TclCompileReturnCmd -- + * + * Procedure called to compile the "return" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if the + * compilation was successful. If the particular return command is + * too complex for this function (ie, return with any flags like "-code" + * or "-errorinfo"), TCL_OUT_LINE_COMPILE is returned, indicating that + * the command should be compiled "out of line" (eg, not byte compiled). + * If an error occurs then the interpreter's result contains a standard + * error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "return" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileReturnCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr; + int code; + + /* + * If we're not in a procedure, don't compile. + */ + + if (envPtr->procPtr == NULL) { + return TCL_OUT_LINE_COMPILE; + } + + switch (parsePtr->numWords) { + case 1: { + /* + * Simple case: [return] + * Just push the literal string "". + */ + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, 0), envPtr); + envPtr->maxStackDepth = 1; + break; + } + case 2: { + /* + * More complex cases: + * [return "foo"] + * [return $value] + * [return [otherCmd]] + */ + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* + * [return "foo"] case: the parse token is a simple word, + * so just push it. + */ + TclEmitPush(TclRegisterLiteral(envPtr, varTokenPtr[1].start, + varTokenPtr[1].size, /*onHeap*/ 0), envPtr); + envPtr->maxStackDepth = 1; + } else { + /* + * Parse token is more complex, so compile it; this handles the + * variable reference and nested command cases. If the + * parse token can be byte-compiled, then this instance of + * "return" will be byte-compiled; otherwise it will be + * out line compiled. + */ + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + } + break; + } + default: { + /* + * Most complex return cases: everything else, including + * [return -code error], etc. + */ + return TCL_OUT_LINE_COMPILE; + } + } + + /* + * The INST_DONE opcode actually causes the branching out of the + * subroutine, and takes the top stack item as the return result + * (which is why we pushed the value above). + */ + TclEmitOpcode(INST_DONE, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileSetCmd -- * * Procedure called to compile the "set" command. @@ -1840,6 +1945,180 @@ TclCompileSetCmd(interp, parsePtr, envPtr) /* *---------------------------------------------------------------------- * + * TclCompileStringCmd -- + * + * Procedure called to compile the "string" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if the + * compilation was successful. If the command cannot be byte-compiled, + * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the + * interpreter's result contains an error message, and TCL_ERROR is + * returned. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "string" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileStringCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *opTokenPtr, *varTokenPtr; + Tcl_Obj *opObj; + int index; + int code; + + static char *options[] = { + "bytelength", "compare", "equal", "first", + "index", "is", "last", "length", + "map", "match", "range", "repeat", + "replace", "tolower", "toupper", "totitle", + "trim", "trimleft", "trimright", + "wordend", "wordstart", (char *) NULL + }; + enum options { + STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST, + STR_INDEX, STR_IS, STR_LAST, STR_LENGTH, + STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT, + STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE, + STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, + STR_WORDEND, STR_WORDSTART + }; + + /* + * If we're not in a procedure, don't compile. + */ + if (envPtr->procPtr == NULL) { + return TCL_OUT_LINE_COMPILE; + } + + if (parsePtr->numWords < 2) { + Tcl_SetResult(interp, "wrong # args: should be \"string option " + "arg ?arg?\"", TCL_STATIC); + return TCL_ERROR; + } + opTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + + opObj = Tcl_NewStringObj(opTokenPtr->start, opTokenPtr->size); + + if (Tcl_GetIndexFromObj(interp, opObj, options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + varTokenPtr = opTokenPtr + (opTokenPtr->numComponents + 1); + + switch ((enum options) index) { + case STR_BYTELENGTH: + case STR_COMPARE: + break; + case STR_EQUAL: { + int i; + int depth; + /* + * If there are any flags to the command, we can't byte compile it + * because the INST_STREQ bytecode doesn't support flags. + */ + + if (parsePtr->numWords != 4) { + return TCL_OUT_LINE_COMPILE; + } + + depth = 0; + + /* + * Push the two operands onto the stack. + */ + + for (i = 0; i < 2; i++) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterLiteral(envPtr, + varTokenPtr[1].start, varTokenPtr[1].size, + 0), envPtr); + depth++; + } else { + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + depth += envPtr->maxStackDepth; + } + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + } + + envPtr->maxStackDepth = depth; + TclEmitOpcode(INST_STREQ, envPtr); + return TCL_OK; + break; + } + case STR_FIRST: + case STR_INDEX: + case STR_IS: + case STR_LAST: + break; + case STR_LENGTH: { + if (parsePtr->numWords != 3) { + Tcl_SetResult(interp, "wrong # args: should be " + "\"string length string\"", TCL_STATIC); + return TCL_ERROR; + } + + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterLiteral(envPtr, varTokenPtr[1].start, + varTokenPtr[1].size, 0), envPtr); + envPtr->maxStackDepth = 1; + TclEmitOpcode(INST_STRLEN, envPtr); + return TCL_OK; + } else { + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + TclEmitOpcode(INST_STRLEN, envPtr); + return TCL_OK; + } + break; + } + case STR_MAP: + case STR_MATCH: + case STR_RANGE: + case STR_REPEAT: + case STR_REPLACE: + case STR_TOLOWER: + case STR_TOUPPER: + case STR_TOTITLE: + case STR_TRIM: + case STR_TRIMLEFT: + case STR_TRIMRIGHT: + case STR_WORDEND: + case STR_WORDSTART: + break; + } + + /* + * All other cases: compile out of line. + */ + return TCL_OUT_LINE_COMPILE; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileWhileCmd -- * * Procedure called to compile the "while" command. diff --git a/generic/tclCompile.h b/generic/tclCompile.h index aa72c93..a7efb6b 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -7,7 +7,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.h,v 1.12 2000/05/09 00:00:34 hobbs Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.13 2000/05/23 22:10:51 ericm Exp $ */ #ifndef _TCLCOMPILATION @@ -497,9 +497,10 @@ typedef struct ByteCode { /* Opcodes 73 to 74 */ #define INST_STREQ 73 #define INST_STRNEQ 74 +#define INST_STRLEN 75 /* The last opcode */ -#define LAST_INST_OPCODE 74 +#define LAST_INST_OPCODE 75 /* * Table describing the Tcl bytecode instructions: their name (for diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f19a968..1169689 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.11 2000/05/09 00:00:34 hobbs Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.12 2000/05/23 22:10:51 ericm Exp $ */ #include "tclInt.h" @@ -1806,6 +1806,25 @@ TclExecuteByteCode(interp, codePtr) } ADJUST_PC(1); + case INST_STRLEN: + { + int length1; + valuePtr = POP_OBJECT(); + if (valuePtr->typePtr == &tclByteArrayType) { + (void) Tcl_GetByteArrayFromObj(valuePtr, &length1); + } else { + length1 = Tcl_GetCharLength(valuePtr); + } + if (Tcl_IsShared(valuePtr)) { + PUSH_OBJECT(Tcl_NewIntObj(length1)); + TclDecrRefCount(valuePtr); + } else { + Tcl_SetIntObj(valuePtr, length1); + ++stackTop; + } + } + ADJUST_PC(1); + case INST_EQ: case INST_NEQ: case INST_LT: diff --git a/generic/tclInt.h b/generic/tclInt.h index 818f82a..0c26e19 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.43 2000/05/02 22:02:34 kupries Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.44 2000/05/23 22:10:52 ericm Exp $ */ #ifndef _TCLINT @@ -2035,8 +2035,12 @@ EXTERN int TclCompileIfCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileIncrCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileReturnCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileStringCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); |