summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog24
-rw-r--r--generic/tclBasic.c6
-rw-r--r--generic/tclCompCmds.c281
-rw-r--r--generic/tclCompile.h5
-rw-r--r--generic/tclExecute.c21
-rw-r--r--generic/tclInt.h6
6 files changed, 335 insertions, 8 deletions
diff --git a/ChangeLog b/ChangeLog
index 62e7f92..a641d2c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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));