* 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.

5 files changed, 311 insertions, 8 deletions

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));