refactored varname pushing code and some of the bytecode instructions

updated tests to not break when someone has a C:/test directory
corrected possible ABR problem
2001-05-15 20:07:38 +00:00 · 2001-05-15 20:03:05 +00:00 · 2001-05-15 20:02:28 +00:00 · 2001-05-15 20:01:56 +00:00 · 2001-05-12 00:01:03 +00:00 · 2001-05-11 20:47:44 +00:00
20 changed files with 2513 additions and 718 deletions
@@ -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: tcl.decls,v 1.46 2001/04/24 20:59:17 kennykb Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.46.2.1 2001/05/11 20:47:44 hobbs Exp $

 library tcl

@@ -1515,6 +1515,12 @@ declare 433 generic {
    Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel)
 }

+# introduced in 8.4a3
+declare 434 generic {
+    Tcl_UniChar * Tcl_GetUnicodeFromObj (Tcl_Obj *objPtr, int *lengthPtr)
+}
+
+
 ##############################################################################

 # Define the platform specific public Tcl interface.  These functions are
@@ -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.31 2001/04/25 09:44:49 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.31.2.2 2001/05/15 20:07:38 hobbs Exp $
 */

 #include "tclInt.h"
@@ -65,7 +65,7 @@ static CmdInfo builtInCmds[] = {
     */

    {"append",		(Tcl_CmdProc *) NULL,	Tcl_AppendObjCmd,
-        (CompileProc *) NULL,		1},
+	TclCompileAppendCmd,		1},
    {"array",		(Tcl_CmdProc *) NULL,	Tcl_ArrayObjCmd,
        (CompileProc *) NULL,		1},
    {"binary",		(Tcl_CmdProc *) NULL,	Tcl_BinaryObjCmd,
@@ -113,15 +113,15 @@ static CmdInfo builtInCmds[] = {
    {"join",		(Tcl_CmdProc *) NULL,	Tcl_JoinObjCmd,
        (CompileProc *) NULL,		1},
    {"lappend",		(Tcl_CmdProc *) NULL,	Tcl_LappendObjCmd,
-        (CompileProc *) NULL,		1},
+        TclCompileLappendCmd,		1},
    {"lindex",		(Tcl_CmdProc *) NULL,	Tcl_LindexObjCmd,
-        (CompileProc *) NULL,		1},
+        TclCompileLindexCmd,		1},
    {"linsert",		(Tcl_CmdProc *) NULL,	Tcl_LinsertObjCmd,
        (CompileProc *) NULL,		1},
    {"list",		(Tcl_CmdProc *) NULL,	Tcl_ListObjCmd,
        (CompileProc *) NULL,		1},
    {"llength",		(Tcl_CmdProc *) NULL,	Tcl_LlengthObjCmd,
-        (CompileProc *) NULL,		1},
+        TclCompileLlengthCmd,		1},
    {"load",		(Tcl_CmdProc *) NULL,	Tcl_LoadObjCmd,
        (CompileProc *) NULL,		0},
    {"lrange",		(Tcl_CmdProc *) NULL,	Tcl_LrangeObjCmd,
@@ -13,7 +13,7 @@
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
- * RCS: @(#) $Id: tclCmdMZ.c,v 1.36 2001/04/24 20:59:17 kennykb Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.36.2.1 2001/05/11 20:47:44 hobbs Exp $
 */

 #include "tclInt.h"
@@ -568,10 +568,8 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv)
    }

    objPtr	= objv[1];
-    wstring	= Tcl_GetUnicode(objPtr);
-    wlen	= Tcl_GetCharLength(objPtr);
-    wsubspec	= Tcl_GetUnicode(objv[2]);
-    wsublen	= Tcl_GetCharLength(objv[2]);
+    wstring	= Tcl_GetUnicodeFromObj(objPtr, &wlen);
+    wsubspec	= Tcl_GetUnicodeFromObj(objv[2], &wsublen);
    varPtr	= objv[3];

    result = TCL_OK;
@@ -1123,11 +1121,9 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
 		!(objv[0]->typePtr == NULL && objv[1]->typePtr == NULL)) {
 		Tcl_UniChar *uni1, *uni2;

-		length1 = Tcl_GetCharLength(objv[0]);
-		length2 = Tcl_GetCharLength(objv[1]);
+		uni1 = Tcl_GetUnicodeFromObj(objv[0], &length1);
+		uni2 = Tcl_GetUnicodeFromObj(objv[1], &length2);
 		length = (length1 < length2) ? length1 : length2;
-		uni1 = Tcl_GetUnicode(objv[0]);
-		uni2 = Tcl_GetUnicode(objv[1]);

 		if (reqlength > 0 && reqlength < length) {
 		    length = reqlength;
@@ -1247,10 +1243,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
 	    start = 0;
 	    length2 = -1;

-	    ustring1 = Tcl_GetUnicode(objv[2]);
-	    length1  = Tcl_GetCharLength(objv[2]);
-	    ustring2 = Tcl_GetUnicode(objv[3]);
-	    length2  = Tcl_GetCharLength(objv[3]);
+	    ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
+	    ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);

 	    if (objc == 5) {
 		/*
@@ -1637,10 +1631,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
 	    start = 0;
 	    length2 = -1;

-	    ustring1 = Tcl_GetUnicode(objv[2]);
-	    length1  = Tcl_GetCharLength(objv[2]);
-	    ustring2 = Tcl_GetUnicode(objv[3]);
-	    length2  = Tcl_GetCharLength(objv[3]);
+	    ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
+	    ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);

 	    if (objc == 5) {
 		/*
@@ -1750,8 +1742,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
 	    }
 	    objc--;

-	    ustring1 = Tcl_GetUnicode(objv[objc]);
-	    length1  = Tcl_GetCharLength(objv[objc]);
+	    ustring1 = Tcl_GetUnicodeFromObj(objv[objc], &length1);
 	    if (length1 == 0) {
 		/*
 		 * Empty input string, just stop now
@@ -1774,10 +1765,11 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
 		 * algorithm is otherwise identical to the multi-pair case.
 		 * This will be >30% faster on larger strings.
 		 */
-		Tcl_UniChar *mapString = Tcl_GetUnicode(mapElemv[1]);
-		int mapLen = Tcl_GetCharLength(mapElemv[1]);
-		ustring2 = Tcl_GetUnicode(mapElemv[0]);
-		length2  = Tcl_GetCharLength(mapElemv[0]);
+		int mapLen;
+		Tcl_UniChar *mapString;
+
+		ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
+		mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen);
 		for (p = ustring1; ustring1 < end; ustring1++) {
 		    if ((length2 > 0) &&
 			    (nocase || (*ustring1 == *ustring2)) &&
@@ -1807,8 +1799,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
 		 * significantly speeding up the algorithm.
 		 */
 		for (index = 0; index < mapElemc; index++) {
-		    mapStrings[index] = Tcl_GetUnicode(mapElemv[index]);
-		    mapLens[index]    = Tcl_GetCharLength(mapElemv[index]);
+		    mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
+			    &(mapLens[index]));
 		}
 		for (p = ustring1; ustring1 < end; ustring1++) {
 		    for (index = 0; index < mapElemc; index += 2) {
@@ -1967,8 +1959,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
 		return TCL_ERROR;
 	    }

-	    ustring1 = Tcl_GetUnicode(objv[2]);
-	    length1  = Tcl_GetCharLength(objv[2]) - 1;
+	    ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
+	    length1--;

 	    if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
 		    || (TclGetIntForIndex(interp, objv[4], length1,
@@ -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: tclCompile.c,v 1.21 2000/05/26 08:53:41 hobbs Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.21.4.2 2001/05/15 20:07:38 hobbs Exp $
 */

 #include "tclInt.h"
@@ -222,6 +222,36 @@ InstructionDesc instructionTable[] = {
 	/* Str Index:	push (strindex stknext stktop) */
    {"strmatch",	  1,   0,   {OPERAND_NONE}},
 	/* Str Match:	push (strmatch stkforenext stknext stktop) */
+    {"list",		  1,   0,   {OPERAND_NONE}},
+	/* List:	push (stk1 stk2 ... stktop) */
+    {"listindex",	  1,   0,   {OPERAND_NONE}},
+	/* List Index:	push (listindex stknext stktop) */
+    {"listlength",	  1,   0,   {OPERAND_NONE}},
+	/* List Len:	push (listlength stktop) */
+    {"appendScalar1",	  2,   1,   {OPERAND_UINT1}},
+	/* Append scalar variable at op1<=255 in frame; value is stktop */
+    {"appendScalar4",	  5,   1,   {OPERAND_UINT4}},
+	/* Append scalar variable at op1 > 255 in frame; value is stktop */
+    {"appendArray1",	  2,   1,   {OPERAND_UINT1}},
+	/* Append array element; array at op1<=255, value is top then elem */
+    {"appendArray4",	  5,   1,   {OPERAND_UINT4}},
+	/* Append array element; array at op1>=256, value is top then elem */
+    {"appendArrayStk",	  1,   0,   {OPERAND_NONE}},
+	/* Append array element; value is stktop, then elem, array names */
+    {"appendStk",	  1,   0,   {OPERAND_NONE}},
+	/* Append general variable; value is stktop, then unparsed name */
+    {"lappendScalar1",	  2,   1,   {OPERAND_UINT1}},
+	/* Lappend scalar variable at op1<=255 in frame; value is stktop */
+    {"lappendScalar4",	  5,   1,   {OPERAND_UINT4}},
+	/* Lappend scalar variable at op1 > 255 in frame; value is stktop */
+    {"lappendArray1",	  2,   1,   {OPERAND_UINT1}},
+	/* Lappend array element; array at op1<=255, value is top then elem */
+    {"lappendArray4",	  5,   1,   {OPERAND_UINT4}},
+	/* Lappend array element; array at op1>=256, value is top then elem */
+    {"lappendArrayStk",	  1,   0,   {OPERAND_NONE}},
+	/* Lappend array element; value is stktop, then elem, array names */
+    {"lappendStk",	  1,   0,   {OPERAND_NONE}},
+	/* Lappend general variable; value is stktop, then unparsed name */
    {0}
 };

@@ -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.14 2000/05/26 08:53:42 hobbs Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.14.4.2 2001/05/15 20:07:38 hobbs Exp $
 */

 #ifndef _TCLCOMPILATION
@@ -494,7 +494,7 @@ typedef struct ByteCode {
 #define INST_PUSH_RESULT		71
 #define INST_PUSH_RETURN_CODE		72

-/* Opcodes 73 to 74 */
+/* Opcodes 73 to 78 */
 #define INST_STR_EQ			73
 #define INST_STR_NEQ			74
 #define INST_STR_CMP			75
@@ -502,8 +502,27 @@ typedef struct ByteCode {
 #define INST_STR_INDEX			77
 #define INST_STR_MATCH			78

+/* Opcodes 78 to 81 */
+#define INST_LIST			79
+#define INST_LIST_INDEX			80
+#define INST_LIST_LENGTH		81
+
+#define INST_APPEND_SCALAR1		82
+#define INST_APPEND_SCALAR4		83
+#define INST_APPEND_ARRAY1		84
+#define INST_APPEND_ARRAY4		85
+#define INST_APPEND_ARRAY_STK		86
+#define INST_APPEND_STK			87
+
+#define INST_LAPPEND_SCALAR1		88
+#define INST_LAPPEND_SCALAR4		89
+#define INST_LAPPEND_ARRAY1		90
+#define INST_LAPPEND_ARRAY4		91
+#define INST_LAPPEND_ARRAY_STK		92
+#define INST_LAPPEND_STK		93
+
 /* The last opcode */
-#define LAST_INST_OPCODE        	78
+#define LAST_INST_OPCODE        	93

 /*
 * Table describing the Tcl bytecode instructions: their name (for
@@ -8,7 +8,7 @@
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
- * RCS: @(#) $Id: tclDecls.h,v 1.48 2001/04/24 20:59:18 kennykb Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.48.2.1 2001/05/11 20:47:44 hobbs Exp $
 */

 #ifndef _TCLDECLS
@@ -1363,6 +1363,9 @@ EXTERN int		Tcl_AttemptSetObjLength _ANSI_ARGS_((
 /* 433 */
 EXTERN Tcl_ThreadId	Tcl_GetChannelThread _ANSI_ARGS_((
 				Tcl_Channel channel));
+/* 434 */
+EXTERN Tcl_UniChar *	Tcl_GetUnicodeFromObj _ANSI_ARGS_((Tcl_Obj * objPtr, 
+				int * lengthPtr));

 typedef struct TclStubHooks {
    struct TclPlatStubs *tclPlatStubs;
@@ -1864,6 +1867,7 @@ typedef struct TclStubs {
    char * (*tcl_AttemptDbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, char * file, int line)); /* 431 */
    int (*tcl_AttemptSetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 432 */
    Tcl_ThreadId (*tcl_GetChannelThread) _ANSI_ARGS_((Tcl_Channel channel)); /* 433 */
+    Tcl_UniChar * (*tcl_GetUnicodeFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 434 */
 } TclStubs;

 #ifdef __cplusplus
@@ -3648,6 +3652,10 @@ extern TclStubs *tclStubsPtr;
 #define Tcl_GetChannelThread \
 	(tclStubsPtr->tcl_GetChannelThread) /* 433 */
 #endif
+#ifndef Tcl_GetUnicodeFromObj
+#define Tcl_GetUnicodeFromObj \
+	(tclStubsPtr->tcl_GetUnicodeFromObj) /* 434 */
+#endif

 #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

@@ -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.22 2001/05/07 22:15:29 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.22.2.3 2001/05/15 20:07:38 hobbs Exp $
 */

 #include "tclInt.h"
@@ -102,7 +102,7 @@ static char *operatorStrings[] = {
    "BUILTIN FUNCTION", "FUNCTION",
    "", "", "", "", "", "", "", "", "eq", "ne",
 };
-    
+
 /*
 * Mapping from Tcl result codes to strings; used for error and debugging
 * messages. 
@@ -203,11 +203,11 @@ long		tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
 	       (unsigned int)(pc - codePtr->codeStart), \
 	       GetOpcodeName(pc)); \
 	printf a; \
-        TclPrintObject(stdout, (objPtr), 30); \
+        TclPrintObject(stdout, objPtr, 30); \
        fprintf(stdout, "\n"); \
    }
 #define O2S(objPtr) \
-    Tcl_GetString(objPtr)
+    (objPtr ? Tcl_GetString(objPtr) : "")
 #else
 #define TRACE(a)
 #define TRACE_WITH_OBJ(a, objPtr)
@@ -556,7 +556,7 @@ TclExecuteByteCode(interp, codePtr)
 				 * process break, continue, and errors. */
    int result = TCL_OK;	/* Return code returned after execution. */
    int traceInstructions = (tclTraceExec == 3);
-    Tcl_Obj *valuePtr, *value2Ptr, *objPtr;
+    Tcl_Obj *valuePtr, *value2Ptr, *objPtr, *elemPtr;
    char *bytes;
    int length;
    long i;
@@ -1097,8 +1097,7 @@ TclExecuteByteCode(interp, codePtr)
 #ifdef TCL_COMPILE_DEBUG
 	    opnd = TclGetUInt1AtPtr(pc+1);
 	    DECACHE_STACK_INFO();
-	    valuePtr = TclGetIndexedScalar(interp, opnd,
-		    /*leaveErrorMsg*/ 1);
+	    valuePtr = TclGetIndexedScalar(interp, opnd, TCL_LEAVE_ERR_MSG);
 	    CACHE_STACK_INFO();
 	    if (valuePtr == NULL) {
 		TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
@@ -1111,7 +1110,7 @@ TclExecuteByteCode(interp, codePtr)
 #else /* TCL_COMPILE_DEBUG */
 	    DECACHE_STACK_INFO();
 	    opnd = TclGetUInt1AtPtr(pc+1);
-	    valuePtr = TclGetIndexedScalar(interp, opnd, /*leaveErrorMsg*/ 1);
+	    valuePtr = TclGetIndexedScalar(interp, opnd, TCL_LEAVE_ERR_MSG);
 	    CACHE_STACK_INFO();
 	    if (valuePtr == NULL) {
 		result = TCL_ERROR;
@@ -1124,8 +1123,7 @@ TclExecuteByteCode(interp, codePtr)
 	case INST_LOAD_SCALAR4:
 	    opnd = TclGetUInt4AtPtr(pc+1);
 	    DECACHE_STACK_INFO();
-	    valuePtr = TclGetIndexedScalar(interp, opnd,
-					   /*leaveErrorMsg*/ 1);
+	    valuePtr = TclGetIndexedScalar(interp, opnd, TCL_LEAVE_ERR_MSG);
 	    CACHE_STACK_INFO();
 	    if (valuePtr == NULL) {
 		TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
@@ -1137,8 +1135,9 @@ TclExecuteByteCode(interp, codePtr)
 	    TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
 	    ADJUST_PC(5);

+	case INST_LOAD_STK:
 	case INST_LOAD_SCALAR_STK:
-	    objPtr = POP_OBJECT(); /* scalar name */
+	    objPtr = POP_OBJECT(); /* scalar / variable name */
 	    DECACHE_STACK_INFO();
 	    valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);
 	    CACHE_STACK_INFO();
@@ -1164,70 +1163,48 @@ TclExecuteByteCode(interp, codePtr)
 	    pcAdjustment = 2;
 	    
 	    doLoadArray:
-	    {
-		Tcl_Obj *elemPtr = POP_OBJECT();
-		
-		DECACHE_STACK_INFO();
-		valuePtr = TclGetElementOfIndexedArray(interp, opnd,
-	                elemPtr, /*leaveErrorMsg*/ 1);
-		CACHE_STACK_INFO();
-		if (valuePtr == NULL) {
-		    TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ",
-			    opnd, O2S(elemPtr)), Tcl_GetObjResult(interp));
-		    Tcl_DecrRefCount(elemPtr);
-		    result = TCL_ERROR;
-		    goto checkForCatch;
-		}
-		PUSH_OBJECT(valuePtr);
-		TRACE_WITH_OBJ(("%u \"%.30s\" => ",
-		        opnd, O2S(elemPtr)),valuePtr);
-		TclDecrRefCount(elemPtr);
-	    }
-	    ADJUST_PC(pcAdjustment);
+	    elemPtr = POP_OBJECT();

-	case INST_LOAD_ARRAY_STK:
-	    {
-		Tcl_Obj *elemPtr = POP_OBJECT();
-		
-		objPtr = POP_OBJECT();	/* array name */
-		DECACHE_STACK_INFO();
-		valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr,
-		        TCL_LEAVE_ERR_MSG);
-		CACHE_STACK_INFO();
-		if (valuePtr == NULL) {
-		    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ",
-		            O2S(objPtr), O2S(elemPtr)),
-			    Tcl_GetObjResult(interp));
-		    Tcl_DecrRefCount(objPtr);
-		    Tcl_DecrRefCount(elemPtr);
-		    result = TCL_ERROR;
-		    goto checkForCatch;
-		}
-		PUSH_OBJECT(valuePtr);
-		TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ",
-		        O2S(objPtr), O2S(elemPtr)), valuePtr);
-		TclDecrRefCount(objPtr);
-		TclDecrRefCount(elemPtr);
-	    }
-	    ADJUST_PC(1);
-
-	case INST_LOAD_STK:
-	    objPtr = POP_OBJECT(); /* variable name */
 	    DECACHE_STACK_INFO();
-	    valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);
+	    valuePtr = TclGetElementOfIndexedArray(interp, opnd,
+		    elemPtr, TCL_LEAVE_ERR_MSG);
 	    CACHE_STACK_INFO();
 	    if (valuePtr == NULL) {
-		TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
-		        O2S(objPtr)), Tcl_GetObjResult(interp));
-		Tcl_DecrRefCount(objPtr);
+		TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ",
+			opnd, O2S(elemPtr)), Tcl_GetObjResult(interp));
+		Tcl_DecrRefCount(elemPtr);
 		result = TCL_ERROR;
 		goto checkForCatch;
 	    }
 	    PUSH_OBJECT(valuePtr);
-	    TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
+	    TRACE_WITH_OBJ(("%u \"%.30s\" => ",
+		    opnd, O2S(elemPtr)),valuePtr);
+	    TclDecrRefCount(elemPtr);
+	    ADJUST_PC(pcAdjustment);
+
+	case INST_LOAD_ARRAY_STK:
+	    elemPtr = POP_OBJECT();
+	    objPtr = POP_OBJECT();	/* array name */
+	    DECACHE_STACK_INFO();
+	    valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr,
+		    TCL_LEAVE_ERR_MSG);
+	    CACHE_STACK_INFO();
+	    if (valuePtr == NULL) {
+		TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ",
+			O2S(objPtr), O2S(elemPtr)),
+			Tcl_GetObjResult(interp));
+		Tcl_DecrRefCount(objPtr);
+		Tcl_DecrRefCount(elemPtr);
+		result = TCL_ERROR;
+		goto checkForCatch;
+	    }
+	    PUSH_OBJECT(valuePtr);
+	    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ",
+		    O2S(objPtr), O2S(elemPtr)), valuePtr);
 	    TclDecrRefCount(objPtr);
+	    TclDecrRefCount(elemPtr);
 	    ADJUST_PC(1);
-	    
+
 	case INST_STORE_SCALAR4:
 	    opnd = TclGetUInt4AtPtr(pc+1);
 	    pcAdjustment = 5;
@@ -1236,12 +1213,12 @@ TclExecuteByteCode(interp, codePtr)
 	case INST_STORE_SCALAR1:
 	    opnd = TclGetUInt1AtPtr(pc+1);
 	    pcAdjustment = 2;
-	    
+
 	  doStoreScalar:
 	    valuePtr = POP_OBJECT();
 	    DECACHE_STACK_INFO();
 	    value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr,
-	            /*leaveErrorMsg*/ 1);
+	            TCL_LEAVE_ERR_MSG);
 	    CACHE_STACK_INFO();
 	    if (value2Ptr == NULL) {
 		TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ",
@@ -1256,9 +1233,10 @@ TclExecuteByteCode(interp, codePtr)
 	    TclDecrRefCount(valuePtr);
 	    ADJUST_PC(pcAdjustment);

+	case INST_STORE_STK:
 	case INST_STORE_SCALAR_STK:
 	    valuePtr = POP_OBJECT();
-	    objPtr = POP_OBJECT(); /* scalar name */
+	    objPtr = POP_OBJECT(); /* scalar / variable name */
 	    DECACHE_STACK_INFO();
 	    value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
 		    TCL_LEAVE_ERR_MSG);
@@ -1289,86 +1267,318 @@ TclExecuteByteCode(interp, codePtr)
 	    pcAdjustment = 2;
 	    
 	    doStoreArray:
-	    {
-		Tcl_Obj *elemPtr;
-
-		valuePtr = POP_OBJECT();
-		elemPtr = POP_OBJECT();
-		DECACHE_STACK_INFO();
-		value2Ptr = TclSetElementOfIndexedArray(interp, opnd,
-		        elemPtr, valuePtr, TCL_LEAVE_ERR_MSG);
-		CACHE_STACK_INFO();
-		if (value2Ptr == NULL) {
-		    TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ",
-			    opnd, O2S(elemPtr), O2S(valuePtr)),
-			    Tcl_GetObjResult(interp));
-		    Tcl_DecrRefCount(elemPtr);
-		    Tcl_DecrRefCount(valuePtr);
-		    result = TCL_ERROR;
-		    goto checkForCatch;
-		}
-		PUSH_OBJECT(value2Ptr);
-		TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ",
-		        opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr);
-		TclDecrRefCount(elemPtr);
-		TclDecrRefCount(valuePtr);
+	    valuePtr = POP_OBJECT();
+	    elemPtr = POP_OBJECT();
+	    DECACHE_STACK_INFO();
+	    value2Ptr = TclSetElementOfIndexedArray(interp, opnd,
+		    elemPtr, valuePtr, TCL_LEAVE_ERR_MSG);
+	    CACHE_STACK_INFO();
+	    if (value2Ptr == NULL) {
+		TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ",
+			opnd, O2S(elemPtr), O2S(valuePtr)),
+			Tcl_GetObjResult(interp));
+		Tcl_DecrRefCount(elemPtr);
+		Tcl_DecrRefCount(valuePtr);
+		result = TCL_ERROR;
+		goto checkForCatch;
 	    }
+	    PUSH_OBJECT(value2Ptr);
+	    TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ",
+		    opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr);
+	    TclDecrRefCount(elemPtr);
+	    TclDecrRefCount(valuePtr);
 	    ADJUST_PC(pcAdjustment);

 	case INST_STORE_ARRAY_STK:
-	    {
-		Tcl_Obj *elemPtr;
-
-		valuePtr = POP_OBJECT();
-		elemPtr = POP_OBJECT();
-		objPtr = POP_OBJECT();	/* array name */
-		DECACHE_STACK_INFO();
-		value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr,
-			TCL_LEAVE_ERR_MSG);
-		CACHE_STACK_INFO();
-		if (value2Ptr == NULL) {
-		    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
-		            O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
-			    Tcl_GetObjResult(interp));
-		    Tcl_DecrRefCount(objPtr);
-		    Tcl_DecrRefCount(elemPtr);
-		    Tcl_DecrRefCount(valuePtr);
-		    result = TCL_ERROR;
-		    goto checkForCatch;
-		}
-		PUSH_OBJECT(value2Ptr);
-		TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
-		        O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
-			value2Ptr);
-		TclDecrRefCount(objPtr);
-		TclDecrRefCount(elemPtr);
-		TclDecrRefCount(valuePtr);
-	    }
-	    ADJUST_PC(1);
-
-	case INST_STORE_STK:
 	    valuePtr = POP_OBJECT();
-	    objPtr = POP_OBJECT(); /* variable name */
+	    elemPtr = POP_OBJECT();
+	    objPtr = POP_OBJECT();	/* array name */
 	    DECACHE_STACK_INFO();
-	    value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
+	    value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr,
 		    TCL_LEAVE_ERR_MSG);
 	    CACHE_STACK_INFO();
 	    if (value2Ptr == NULL) {
-		TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ",
-		        O2S(objPtr), O2S(valuePtr)),
+		TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
+			O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
 			Tcl_GetObjResult(interp));
 		Tcl_DecrRefCount(objPtr);
+		Tcl_DecrRefCount(elemPtr);
+		Tcl_DecrRefCount(valuePtr);
+		result = TCL_ERROR;
+		goto checkForCatch;
+	    }
+	    PUSH_OBJECT(value2Ptr);
+	    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
+		    O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
+		    value2Ptr);
+	    TclDecrRefCount(objPtr);
+	    TclDecrRefCount(elemPtr);
+	    TclDecrRefCount(valuePtr);
+	    ADJUST_PC(1);
+
+	    /*
+	     * START (L)APPEND INSTRUCTIONS
+	     */
+
+	case INST_APPEND_SCALAR4:
+	    opnd = TclGetUInt4AtPtr(pc+1);
+	    pcAdjustment = 5;
+	    goto doAppendScalar;
+
+	case INST_APPEND_SCALAR1:
+	    opnd = TclGetUInt1AtPtr(pc+1);
+	    pcAdjustment = 2;
+
+	  doAppendScalar:
+	    valuePtr = POP_OBJECT();
+	    DECACHE_STACK_INFO();
+	    value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr,
+	            TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
+	    CACHE_STACK_INFO();
+	    if (value2Ptr == NULL) {
+		TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ",
+			opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
+		Tcl_DecrRefCount(valuePtr);
+		result = TCL_ERROR;
+		goto checkForCatch;
+	    }
+	    PUSH_OBJECT(value2Ptr);
+	    TRACE_WITH_OBJ(("%u <- \"%.30s\" => ",
+		    opnd, O2S(valuePtr)), value2Ptr);
+	    TclDecrRefCount(valuePtr);
+	    ADJUST_PC(pcAdjustment);
+
+	case INST_APPEND_STK:
+	case INST_APPEND_ARRAY_STK:
+	    valuePtr = POP_OBJECT(); /* value to append */
+	    if (*pc == INST_APPEND_ARRAY_STK) {
+		elemPtr = POP_OBJECT();
+	    } else {
+		elemPtr = NULL;
+	    }
+	    objPtr = POP_OBJECT(); /* scalar name */
+
+	    DECACHE_STACK_INFO();
+	    value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr,
+		    TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
+	    CACHE_STACK_INFO();
+	    if (value2Ptr == NULL) {
+		if (elemPtr) {
+		    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <-+ \"%.30s\" => ERROR: ",
+			    O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
+			    Tcl_GetObjResult(interp));
+		    TclDecrRefCount(elemPtr);
+		} else {
+		    TRACE_WITH_OBJ(("\"%.30s\" <-+ \"%.30s\" => ERROR: ",
+			    O2S(objPtr), O2S(valuePtr)),
+			    Tcl_GetObjResult(interp));
+		}
+		Tcl_DecrRefCount(objPtr);
 		Tcl_DecrRefCount(valuePtr);
 		result = TCL_ERROR;
 		goto checkForCatch;
 	    }
 	    PUSH_OBJECT(value2Ptr);
-	    TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ",
-		    O2S(objPtr), O2S(valuePtr)), value2Ptr);
+	    if (elemPtr) {
+		TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <-+ \"%.30s\" => ",
+			O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
+			value2Ptr);
+		TclDecrRefCount(elemPtr);
+	    } else {
+		TRACE_WITH_OBJ(("\"%.30s\" <-+ \"%.30s\" => ",
+			O2S(objPtr), O2S(valuePtr)), value2Ptr);
+	    }
 	    TclDecrRefCount(objPtr);
 	    TclDecrRefCount(valuePtr);
 	    ADJUST_PC(1);

+	case INST_APPEND_ARRAY4:
+	    opnd = TclGetUInt4AtPtr(pc+1);
+	    pcAdjustment = 5;
+	    goto doAppendArray;
+
+	case INST_APPEND_ARRAY1:
+	    opnd = TclGetUInt1AtPtr(pc+1);
+	    pcAdjustment = 2;
+	    
+	    doAppendArray:
+	    valuePtr = POP_OBJECT();
+	    elemPtr = POP_OBJECT();
+	    DECACHE_STACK_INFO();
+	    value2Ptr = TclSetElementOfIndexedArray(interp, opnd,
+		    elemPtr, valuePtr, TCL_LEAVE_ERR_MSG|TCL_APPEND_VALUE);
+	    CACHE_STACK_INFO();
+	    if (value2Ptr == NULL) {
+		TRACE_WITH_OBJ(("%u \"%.30s\" <-+ \"%.30s\" => ERROR: ",
+			opnd, O2S(elemPtr), O2S(valuePtr)),
+			Tcl_GetObjResult(interp));
+		Tcl_DecrRefCount(elemPtr);
+		Tcl_DecrRefCount(valuePtr);
+		result = TCL_ERROR;
+		goto checkForCatch;
+	    }
+	    PUSH_OBJECT(value2Ptr);
+	    TRACE_WITH_OBJ(("%u \"%.30s\" <-+ \"%.30s\" => ",
+		    opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr);
+	    TclDecrRefCount(elemPtr);
+	    TclDecrRefCount(valuePtr);
+	    ADJUST_PC(pcAdjustment);
+
+	    /*
+	     * END (L)APPEND INSTRUCTIONS
+	     */
+	    /*
+	     * START LAPPEND INSTRUCTIONS
+	     */
+
+	case INST_LAPPEND_SCALAR4:
+	    opnd = TclGetUInt4AtPtr(pc+1);
+	    pcAdjustment = 5;
+	    goto doLappendScalar;
+
+	case INST_LAPPEND_SCALAR1:
+	    opnd = TclGetUInt1AtPtr(pc+1);
+	    pcAdjustment = 2;
+
+	  doLappendScalar:
+	    valuePtr = POP_OBJECT();
+	    DECACHE_STACK_INFO();
+	    value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr,
+	            TCL_LEAVE_ERR_MSG|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
+	    CACHE_STACK_INFO();
+	    if (value2Ptr == NULL) {
+		TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ",
+			opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
+		Tcl_DecrRefCount(valuePtr);
+		result = TCL_ERROR;
+		goto checkForCatch;
+	    }
+	    PUSH_OBJECT(value2Ptr);
+	    TRACE_WITH_OBJ(("%u <- \"%.30s\" => ",
+		    opnd, O2S(valuePtr)), value2Ptr);
+	    TclDecrRefCount(valuePtr);
+	    ADJUST_PC(pcAdjustment);
+
+	case INST_LAPPEND_STK:
+	case INST_LAPPEND_ARRAY_STK:
+	{
+	    Tcl_Obj *newValuePtr;
+	    int createdNewObj = 0;
+
+	    value2Ptr = POP_OBJECT(); /* value to append */
+	    if (*pc == INST_LAPPEND_ARRAY_STK) {
+		elemPtr = POP_OBJECT();
+	    } else {
+		elemPtr = NULL;
+	    }
+	    objPtr = POP_OBJECT(); /* scalar name */
+
+	    DECACHE_STACK_INFO();
+	    /* Currently value of the list */
+	    valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr, 0);
+	    CACHE_STACK_INFO();
+	    if (valuePtr == NULL) {
+		valuePtr = Tcl_NewObj();
+		createdNewObj = 1;
+	    } else if (Tcl_IsShared(valuePtr)) {
+		valuePtr = Tcl_DuplicateObj(valuePtr);
+		createdNewObj = 1;
+	    }
+
+	    DECACHE_STACK_INFO();
+	    result = Tcl_ListObjAppendElement(interp, valuePtr, value2Ptr);
+	    CACHE_STACK_INFO();
+	    if (result != TCL_OK) {
+		if (elemPtr) {
+		    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
+			    O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
+			    Tcl_GetObjResult(interp));
+		    Tcl_DecrRefCount(elemPtr);
+		} else {
+		    TRACE_WITH_OBJ(("\"%.30s\" <-+ \"%.30s\" => ERROR: ",
+			    O2S(objPtr), O2S(value2Ptr)),
+			    Tcl_GetObjResult(interp));
+		}
+		Tcl_DecrRefCount(objPtr);
+		Tcl_DecrRefCount(value2Ptr);
+		if (createdNewObj) Tcl_DecrRefCount(valuePtr);
+		result = TCL_ERROR;
+		goto checkForCatch;
+	    }
+
+	    DECACHE_STACK_INFO();
+	    newValuePtr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr,
+		    TCL_LEAVE_ERR_MSG);
+	    CACHE_STACK_INFO();
+	    if (newValuePtr == NULL) {
+		if (elemPtr) {
+		    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
+			    O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
+			    Tcl_GetObjResult(interp));
+		    Tcl_DecrRefCount(elemPtr);
+		} else {
+		    TRACE_WITH_OBJ(("\"%.30s\" <-+ \"%.30s\" => ERROR: ",
+			    O2S(objPtr), O2S(value2Ptr)),
+			    Tcl_GetObjResult(interp));
+		}
+		Tcl_DecrRefCount(objPtr);
+		Tcl_DecrRefCount(value2Ptr);
+		if (createdNewObj) Tcl_DecrRefCount(valuePtr);
+		result = TCL_ERROR;
+		goto checkForCatch;
+	    }
+	    PUSH_OBJECT(newValuePtr);
+	    if (elemPtr) {
+		TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
+			O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
+			value2Ptr);
+		TclDecrRefCount(elemPtr);
+	    } else {
+		TRACE_WITH_OBJ(("\"%.30s\" <-+ \"%.30s\" => ",
+			O2S(objPtr), O2S(valuePtr)), value2Ptr);
+	    }
+	    TclDecrRefCount(objPtr);
+	    TclDecrRefCount(value2Ptr);
+	    ADJUST_PC(1);
+	}
+
+	case INST_LAPPEND_ARRAY4:
+	    opnd = TclGetUInt4AtPtr(pc+1);
+	    pcAdjustment = 5;
+	    goto doLappendArray;
+
+	case INST_LAPPEND_ARRAY1:
+	    opnd = TclGetUInt1AtPtr(pc+1);
+	    pcAdjustment = 2;
+
+	    doLappendArray:
+	    valuePtr = POP_OBJECT();
+	    elemPtr = POP_OBJECT();
+	    DECACHE_STACK_INFO();
+	    value2Ptr = TclSetElementOfIndexedArray(interp, opnd,
+		    elemPtr, valuePtr,
+		    TCL_LEAVE_ERR_MSG|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
+	    CACHE_STACK_INFO();
+	    if (value2Ptr == NULL) {
+		TRACE_WITH_OBJ(("%u \"%.30s\" <-+ \"%.30s\" => ERROR: ",
+			opnd, O2S(elemPtr), O2S(valuePtr)),
+			Tcl_GetObjResult(interp));
+		Tcl_DecrRefCount(elemPtr);
+		Tcl_DecrRefCount(valuePtr);
+		result = TCL_ERROR;
+		goto checkForCatch;
+	    }
+	    PUSH_OBJECT(value2Ptr);
+	    TRACE_WITH_OBJ(("%u \"%.30s\" <-+ \"%.30s\" => ",
+		    opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr);
+	    TclDecrRefCount(elemPtr);
+	    TclDecrRefCount(valuePtr);
+	    ADJUST_PC(pcAdjustment);
+
+	    /*
+	     * END (L)APPEND INSTRUCTIONS
+	     */
+
 	case INST_INCR_SCALAR1:
 	    opnd = TclGetUInt1AtPtr(pc+1);
 	    valuePtr = POP_OBJECT(); 
@@ -1433,86 +1643,78 @@ TclExecuteByteCode(interp, codePtr)
 	    ADJUST_PC(1);

 	case INST_INCR_ARRAY1:
-	    {
-		Tcl_Obj *elemPtr;
-
-		opnd = TclGetUInt1AtPtr(pc+1);
-		valuePtr = POP_OBJECT();
-		elemPtr = POP_OBJECT();
-		if (valuePtr->typePtr != &tclIntType) {
-		    result = tclIntType.setFromAnyProc(interp, valuePtr);
-		    if (result != TCL_OK) {
-			TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
-		                opnd, O2S(elemPtr), O2S(valuePtr)),
-			        Tcl_GetObjResult(interp));
-			Tcl_DecrRefCount(elemPtr);
-			Tcl_DecrRefCount(valuePtr);
-			goto checkForCatch;
-		    }
-		}
-		i = valuePtr->internalRep.longValue;
-		DECACHE_STACK_INFO();
-		value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
-		        elemPtr, i);
-		CACHE_STACK_INFO();
-		if (value2Ptr == NULL) {
-		    TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
-		            opnd, O2S(elemPtr), i),
+	    opnd = TclGetUInt1AtPtr(pc+1);
+	    valuePtr = POP_OBJECT();
+	    elemPtr = POP_OBJECT();
+	    if (valuePtr->typePtr != &tclIntType) {
+		result = tclIntType.setFromAnyProc(interp, valuePtr);
+		if (result != TCL_OK) {
+		    TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
+			    opnd, O2S(elemPtr), O2S(valuePtr)),
 			    Tcl_GetObjResult(interp));
 		    Tcl_DecrRefCount(elemPtr);
 		    Tcl_DecrRefCount(valuePtr);
-		    result = TCL_ERROR;
 		    goto checkForCatch;
 		}
-		PUSH_OBJECT(value2Ptr);
-		TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
-	                opnd, O2S(elemPtr), i), value2Ptr);
+	    }
+	    i = valuePtr->internalRep.longValue;
+	    DECACHE_STACK_INFO();
+	    value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
+		    elemPtr, i);
+	    CACHE_STACK_INFO();
+	    if (value2Ptr == NULL) {
+		TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
+			opnd, O2S(elemPtr), i),
+			Tcl_GetObjResult(interp));
 		Tcl_DecrRefCount(elemPtr);
 		Tcl_DecrRefCount(valuePtr);
+		result = TCL_ERROR;
+		goto checkForCatch;
 	    }
+	    PUSH_OBJECT(value2Ptr);
+	    TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
+		    opnd, O2S(elemPtr), i), value2Ptr);
+	    Tcl_DecrRefCount(elemPtr);
+	    Tcl_DecrRefCount(valuePtr);
 	    ADJUST_PC(2);
 	    
 	case INST_INCR_ARRAY_STK:
-	    {
-		Tcl_Obj *elemPtr;
-
-		valuePtr = POP_OBJECT();
-		elemPtr = POP_OBJECT();
-		objPtr = POP_OBJECT();	/* array name */
-		if (valuePtr->typePtr != &tclIntType) {
-		    result = tclIntType.setFromAnyProc(interp, valuePtr);
-		    if (result != TCL_OK) {
-		        TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ",
-		                O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
-			        Tcl_GetObjResult(interp));
-			Tcl_DecrRefCount(objPtr);
-			Tcl_DecrRefCount(elemPtr);
-			Tcl_DecrRefCount(valuePtr);
-			goto checkForCatch;
-		    }
-		}
-		i = valuePtr->internalRep.longValue;
-		DECACHE_STACK_INFO();
-		value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
-			TCL_LEAVE_ERR_MSG);
-		CACHE_STACK_INFO();
-		if (value2Ptr == NULL) {
-		    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
-		            O2S(objPtr), O2S(elemPtr), i),
+	    valuePtr = POP_OBJECT();
+	    elemPtr = POP_OBJECT();
+	    objPtr = POP_OBJECT();	/* array name */
+	    if (valuePtr->typePtr != &tclIntType) {
+		result = tclIntType.setFromAnyProc(interp, valuePtr);
+		if (result != TCL_OK) {
+		    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ",
+			    O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
 			    Tcl_GetObjResult(interp));
 		    Tcl_DecrRefCount(objPtr);
 		    Tcl_DecrRefCount(elemPtr);
 		    Tcl_DecrRefCount(valuePtr);
-		    result = TCL_ERROR;
 		    goto checkForCatch;
 		}
-		PUSH_OBJECT(value2Ptr);
-		TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
-	                O2S(objPtr), O2S(elemPtr), i), value2Ptr);
+	    }
+	    i = valuePtr->internalRep.longValue;
+	    DECACHE_STACK_INFO();
+	    value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
+		    TCL_LEAVE_ERR_MSG);
+	    CACHE_STACK_INFO();
+	    if (value2Ptr == NULL) {
+		TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
+			O2S(objPtr), O2S(elemPtr), i),
+			Tcl_GetObjResult(interp));
 		Tcl_DecrRefCount(objPtr);
 		Tcl_DecrRefCount(elemPtr);
 		Tcl_DecrRefCount(valuePtr);
+		result = TCL_ERROR;
+		goto checkForCatch;
 	    }
+	    PUSH_OBJECT(value2Ptr);
+	    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
+		    O2S(objPtr), O2S(elemPtr), i), value2Ptr);
+	    Tcl_DecrRefCount(objPtr);
+	    Tcl_DecrRefCount(elemPtr);
+	    Tcl_DecrRefCount(valuePtr);
 	    ADJUST_PC(1);
 	    
 	case INST_INCR_SCALAR1_IMM:
@@ -1553,57 +1755,49 @@ TclExecuteByteCode(interp, codePtr)
 	    ADJUST_PC(2);

 	case INST_INCR_ARRAY1_IMM:
-	    {
-		Tcl_Obj *elemPtr;
-
-		opnd = TclGetUInt1AtPtr(pc+1);
-		i = TclGetInt1AtPtr(pc+2);
-		elemPtr = POP_OBJECT();
-		DECACHE_STACK_INFO();
-		value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
-		        elemPtr, i);
-		CACHE_STACK_INFO();
-		if (value2Ptr == NULL) {
-		    TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
-		            opnd, O2S(elemPtr), i),
-			    Tcl_GetObjResult(interp));
-		    Tcl_DecrRefCount(elemPtr);
-		    result = TCL_ERROR;
-		    goto checkForCatch;
-		}
-		PUSH_OBJECT(value2Ptr);
-		TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
-	                opnd, O2S(elemPtr), i), value2Ptr);
+	    opnd = TclGetUInt1AtPtr(pc+1);
+	    i = TclGetInt1AtPtr(pc+2);
+	    elemPtr = POP_OBJECT();
+	    DECACHE_STACK_INFO();
+	    value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
+		    elemPtr, i);
+	    CACHE_STACK_INFO();
+	    if (value2Ptr == NULL) {
+		TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
+			opnd, O2S(elemPtr), i),
+			Tcl_GetObjResult(interp));
 		Tcl_DecrRefCount(elemPtr);
+		result = TCL_ERROR;
+		goto checkForCatch;
 	    }
+	    PUSH_OBJECT(value2Ptr);
+	    TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
+		    opnd, O2S(elemPtr), i), value2Ptr);
+	    Tcl_DecrRefCount(elemPtr);
 	    ADJUST_PC(3);
 	    
 	case INST_INCR_ARRAY_STK_IMM:
-	    {
-		Tcl_Obj *elemPtr;
-
-		i = TclGetInt1AtPtr(pc+1);
-		elemPtr = POP_OBJECT();
-		objPtr = POP_OBJECT();	/* array name */
-		DECACHE_STACK_INFO();
-		value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
-			TCL_LEAVE_ERR_MSG);
-		CACHE_STACK_INFO();
-		if (value2Ptr == NULL) {
-		    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
-		            O2S(objPtr), O2S(elemPtr), i),
-			    Tcl_GetObjResult(interp));
-		    Tcl_DecrRefCount(objPtr);
-		    Tcl_DecrRefCount(elemPtr);
-		    result = TCL_ERROR;
-		    goto checkForCatch;
-		}
-		PUSH_OBJECT(value2Ptr);
-		TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
-	                O2S(objPtr), O2S(elemPtr), i), value2Ptr);
+	    i = TclGetInt1AtPtr(pc+1);
+	    elemPtr = POP_OBJECT();
+	    objPtr = POP_OBJECT();	/* array name */
+	    DECACHE_STACK_INFO();
+	    value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
+		    TCL_LEAVE_ERR_MSG);
+	    CACHE_STACK_INFO();
+	    if (value2Ptr == NULL) {
+		TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
+			O2S(objPtr), O2S(elemPtr), i),
+			Tcl_GetObjResult(interp));
 		Tcl_DecrRefCount(objPtr);
 		Tcl_DecrRefCount(elemPtr);
+		result = TCL_ERROR;
+		goto checkForCatch;
 	    }
+	    PUSH_OBJECT(value2Ptr);
+	    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
+		    O2S(objPtr), O2S(elemPtr), i), value2Ptr);
+	    Tcl_DecrRefCount(objPtr);
+	    Tcl_DecrRefCount(elemPtr);
 	    ADJUST_PC(2);

 	case INST_JUMP1:
@@ -1715,12 +1909,12 @@ TclExecuteByteCode(interp, codePtr)
 		int iResult;
 		char *s;
 		Tcl_ObjType *t1Ptr, *t2Ptr;
-		
+
 		value2Ptr = POP_OBJECT();
 		valuePtr  = POP_OBJECT();
 		t1Ptr = valuePtr->typePtr;
 		t2Ptr = value2Ptr->typePtr;
-		
+
 		if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
 		    i1 = (valuePtr->internalRep.longValue != 0);
 		} else if (t1Ptr == &tclDoubleType) {
@@ -1771,7 +1965,7 @@ TclExecuteByteCode(interp, codePtr)
 			goto checkForCatch;
 		    }
 		}
-		
+
 		/*
 		 * Reuse the valuePtr object already on stack if possible.
 		 */
@@ -1796,6 +1990,80 @@ TclExecuteByteCode(interp, codePtr)
 	    }
 	    ADJUST_PC(1);

+	case INST_LIST_LENGTH:
+	    valuePtr = POP_OBJECT();
+
+	    result = Tcl_ListObjLength(interp, valuePtr, &length);
+	    if (result != TCL_OK) {
+		TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
+			Tcl_GetObjResult(interp));
+		TclDecrRefCount(valuePtr);
+		goto checkForCatch;
+	    }
+	    PUSH_OBJECT(Tcl_NewIntObj(length));
+	    TRACE(("%.20s => %d\n", O2S(valuePtr), length));
+	    TclDecrRefCount(valuePtr);
+	    ADJUST_PC(1);
+	    
+	case INST_LIST_INDEX:
+	    {
+		Tcl_Obj **elemPtrs;
+		int index;
+
+		value2Ptr = POP_OBJECT();
+		valuePtr  = POP_OBJECT();
+
+		result = Tcl_ListObjGetElements(interp, valuePtr,
+			&length, &elemPtrs);
+		if (result != TCL_OK) {
+		    TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
+			    Tcl_GetObjResult(interp));
+		    TclDecrRefCount(value2Ptr);
+		    TclDecrRefCount(valuePtr);
+		    goto checkForCatch;
+		}
+
+		result = TclGetIntForIndex(interp, value2Ptr, length - 1,
+			&index);
+		if (result != TCL_OK) {
+		    TRACE_WITH_OBJ(("%.20s => ERROR: ", O2S(value2Ptr)),
+			    Tcl_GetObjResult(interp));
+		    Tcl_DecrRefCount(value2Ptr);
+		    Tcl_DecrRefCount(valuePtr);
+		    goto checkForCatch;
+		}
+
+		if ((index < 0) || (index >= length)) {
+		    objPtr = Tcl_NewObj();
+		} else {
+		    /*
+		     * Make sure listPtr still refers to a list object. It
+		     * might have been converted to an int above if the
+		     * argument objects were shared.
+		     */
+
+		    if (valuePtr->typePtr != &tclListType) {
+			result = Tcl_ListObjGetElements(interp, valuePtr,
+				&length, &elemPtrs);
+			if (result != TCL_OK) {
+			    TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
+				    Tcl_GetObjResult(interp));
+			    TclDecrRefCount(value2Ptr);
+			    TclDecrRefCount(valuePtr);
+			    goto checkForCatch;
+			}
+		    }
+		    objPtr = elemPtrs[index];
+		}
+
+		PUSH_OBJECT(objPtr);
+		TRACE(("%.20s %.20s => %s\n",
+			O2S(valuePtr), O2S(value2Ptr), O2S(objPtr)));
+		TclDecrRefCount(valuePtr);
+		TclDecrRefCount(value2Ptr);
+	    }
+	    ADJUST_PC(1);
+
 	case INST_STR_EQ:
 	case INST_STR_NEQ:
 	    {
@@ -1852,18 +2120,48 @@ TclExecuteByteCode(interp, codePtr)
 		value2Ptr = POP_OBJECT();
 		valuePtr  = POP_OBJECT();

-		s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
-		s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
 		/*
-		 * Compare up to the minimum byte length
+		 * The comparison function should compare up to the
+		 * minimum byte length only.
+		 */
+		if ((valuePtr->typePtr == &tclByteArrayType) &&
+			(value2Ptr->typePtr == &tclByteArrayType)) {
+		    s1 = Tcl_GetByteArrayFromObj(valuePtr, &s1len);
+		    s2 = Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
+		    iResult = memcmp(s1, s2,
+			    (size_t) ((s1len < s2len) ? s1len : s2len));
+		} else {
+#if 0
+		    /*
+		     * This solution is less mem intensive, but it is
+		     * computationally expensive as the string grows.  The
+		     * reason that we can't use a memcmp is that UTF-8 strings
+		     * that contain a \u0000 can't be compared with memcmp.  If
+		     * we knew that the string was ascii-7 or had no null byte,
+		     * we could just do memcmp and save all the hassle.
+		     */
+		    s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
+		    s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
+		    iResult = Tcl_UtfNcmp(s1, s2,
+			    (size_t) ((s1len < s2len) ? s1len : s2len));
+#else
+		    Tcl_UniChar *uni1, *uni2;
+		    uni1 = Tcl_GetUnicodeFromObj(valuePtr, &s1len);
+		    uni2 = Tcl_GetUnicodeFromObj(value2Ptr, &s2len);
+		    iResult = Tcl_UniCharNcmp(uni1, uni2,
+			    (unsigned) ((s1len < s2len) ? s1len : s2len));
+#endif
+		}
+
+		/*
+		 * Make sure only -1,0,1 is returned
 		 */
-		iResult = memcmp(s1, s2,
-			(size_t) ((s1len < s2len) ? s1len : s2len));
 		if (iResult == 0) {
 		    iResult = s1len - s2len;
-		} else if (iResult < 0) {
+		}
+		if (iResult < 0) {
 		    iResult = -1;
-		} else {
+		} else if (iResult > 0) {
 		    iResult = 1;
 		}

@@ -1935,7 +2233,13 @@ TclExecuteByteCode(interp, codePtr)
 			char buf[TCL_UTF_MAX];
 			Tcl_UniChar ch;

-			ch     = Tcl_GetUniChar(valuePtr, index);
+			ch = Tcl_GetUniChar(valuePtr, index);
+			/*
+			 * This could be:
+			 * Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch, 1)
+			 * but creating the object as a string seems to be
+			 * faster in practical use.
+			 */
 			length = Tcl_UniCharToUtf(ch, buf);
 			objPtr = Tcl_NewStringObj(buf, length);
 		    }
@@ -3004,7 +3308,7 @@ TclExecuteByteCode(interp, codePtr)
 			    varIndex = varListPtr->varIndexes[j];
 			    DECACHE_STACK_INFO();
 			    value2Ptr = TclSetIndexedScalar(interp,
-			           varIndex, valuePtr, /*leaveErrorMsg*/ 1);
+			           varIndex, valuePtr, TCL_LEAVE_ERR_MSG);
 			    CACHE_STACK_INFO();
 			    if (value2Ptr == NULL) {
 				TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
@@ -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: tclFileName.c,v 1.13 2000/04/19 23:24:52 hobbs Exp $
+ * RCS: @(#) $Id: tclFileName.c,v 1.13.8.1 2001/05/15 20:02:28 hobbs Exp $
 */

 #include "tclInt.h"
@@ -163,7 +163,6 @@ ExtractWinRoot(path, resultPtr, offset, typePtr)
 {
    FileNameInit();

-
    if (path[0] == '/' || path[0] == '\\') {
 	/* Might be a UNC or Vol-Relative path */
 	char *host, *share, *tail;
@@ -173,10 +172,10 @@ ExtractWinRoot(path, resultPtr, offset, typePtr)
 	    *typePtr = TCL_PATH_VOLUME_RELATIVE;
 	    Tcl_DStringAppend(resultPtr, "/", 1);
 	    return &path[1];
-    }
+	}
 	host = (char *)&path[2];

-	/* Skip seperators */
+	/* Skip separators */
 	while (host[0] == '/' || host[0] == '\\') host++;

 	for (hlen = 0; host[hlen];hlen++) {
@@ -191,7 +190,7 @@ ExtractWinRoot(path, resultPtr, offset, typePtr)
 	Tcl_DStringSetLength(resultPtr, offset);
 	share = &host[hlen];

-	/* Skip seperators */
+	/* Skip separators */
 	while (share[0] == '/' || share[0] == '\\') share++;

 	for (slen = 0; share[slen];slen++) {
@@ -205,12 +204,12 @@ ExtractWinRoot(path, resultPtr, offset, typePtr)

 	tail = &share[slen];

-	/* Skip seperators */
+	/* Skip separators */
 	while (tail[0] == '/' || tail[0] == '\\') tail++;

 	*typePtr = TCL_PATH_ABSOLUTE;
 	return tail;
-    } else if (path[1] == ':') {
+    } else if (*path && path[1] == ':') {
 	/* Might be a drive sep */
 	Tcl_DStringSetLength(resultPtr, offset);

@@ -218,17 +217,17 @@ ExtractWinRoot(path, resultPtr, offset, typePtr)
 	    *typePtr = TCL_PATH_VOLUME_RELATIVE;
 	    Tcl_DStringAppend(resultPtr, path, 2);
 	    return &path[2];
-    } else {
+	} else {
 	    char *tail = (char*)&path[3];

-	    /* Skip seperators */
-	    while (tail[0] == '/' || tail[0] == '\\') tail++;
+	    /* Skip separators */
+	    while (*tail && (tail[0] == '/' || tail[0] == '\\')) tail++;

 	    *typePtr = TCL_PATH_ABSOLUTE;
 	    Tcl_DStringAppend(resultPtr, path, 2);
-	Tcl_DStringAppend(resultPtr, "/", 1);
+	    Tcl_DStringAppend(resultPtr, "/", 1);

-    return tail;
+	    return tail;
 	}
    } else {
 	*typePtr = TCL_PATH_RELATIVE;
@@ -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: tclInt.decls,v 1.25 2001/04/27 22:11:51 kennykb Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.25.2.1 2001/05/15 20:07:38 hobbs Exp $

 library tcl

@@ -128,7 +128,7 @@ declare 28 generic {
 }
 declare 29 generic {
    Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp, \
-	    int localIndex, Tcl_Obj *elemPtr, int leaveErrorMsg)
+	    int localIndex, Tcl_Obj *elemPtr, int flags)
 }
 # Replaced by char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) in 8.1:
 #  declare 30 generic {
@@ -149,7 +149,7 @@ declare 34 generic {
 }
 declare 35 generic {
    Tcl_Obj * TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, \
-	    int leaveErrorMsg)
+	    int flags)
 }
 declare 36 generic {
    int TclGetLong(Tcl_Interp *interp, char *str, long *longPtr)
@@ -374,11 +374,11 @@ declare 98 generic {
 }
 declare 99 generic {
    Tcl_Obj * TclSetElementOfIndexedArray(Tcl_Interp *interp, \
-	    int localIndex, Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int leaveErrorMsg)
+	    int localIndex, Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags)
 }
 declare 100 generic {
    Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, \
-	    Tcl_Obj *objPtr, int leaveErrorMsg)
+	    Tcl_Obj *objPtr, int flags)
 }
 declare 101 {unix win} {
    char * TclSetPreInitScript(char *string)
@@ -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.52 2001/04/27 22:11:51 kennykb Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.52.2.2 2001/05/15 20:07:38 hobbs Exp $
 */

 #ifndef _TCLINT
@@ -1700,7 +1700,7 @@ EXTERN int		TclGetDate _ANSI_ARGS_((char *p,
 			    unsigned long *timePtr));
 EXTERN Tcl_Obj *	TclGetElementOfIndexedArray _ANSI_ARGS_((
 			    Tcl_Interp *interp, int localIndex,
-			    Tcl_Obj *elemPtr, int leaveErrorMsg));
+			    Tcl_Obj *elemPtr, int flags));
 EXTERN char *		TclGetExtension _ANSI_ARGS_((char *name));
 EXTERN int		TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp,
 			    char *string, CallFrame **framePtrPtr));
@@ -1708,7 +1708,7 @@ EXTERN TclCmdProcType	TclGetInterpProc _ANSI_ARGS_((void));
 EXTERN int		TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp *interp,
 			    Tcl_Obj *objPtr, int endValue, int *indexPtr));
 EXTERN Tcl_Obj *	TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp,
-			    int localIndex, int leaveErrorMsg));
+			    int localIndex, int flags));
 EXTERN int		TclGetLong _ANSI_ARGS_((Tcl_Interp *interp,
 			    char *string, long *longPtr));
 EXTERN int		TclGetLoadedPackages _ANSI_ARGS_((
@@ -1876,11 +1876,9 @@ EXTERN void		TclResetShadowedCmdRefs _ANSI_ARGS_((
 EXTERN int		TclServiceIdle _ANSI_ARGS_((void));
 EXTERN Tcl_Obj *	TclSetElementOfIndexedArray _ANSI_ARGS_((
 			    Tcl_Interp *interp, int localIndex,
-			    Tcl_Obj *elemPtr, Tcl_Obj *objPtr,
-			    int leaveErrorMsg));
+			    Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags));
 EXTERN Tcl_Obj *	TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp,
-			    int localIndex, Tcl_Obj *objPtr,
-			    int leaveErrorMsg));
+			    int localIndex, Tcl_Obj *objPtr, int flags));
 EXTERN char *		TclSetPreInitScript _ANSI_ARGS_((char *string));
 EXTERN void		TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp));
 EXTERN VOID             TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id,
@@ -2082,6 +2080,8 @@ EXTERN int	Tcl_ResourceObjCmd _ANSI_ARGS_((ClientData clientData,
 *----------------------------------------------------------------
 */

+EXTERN int	TclCompileAppendCmd _ANSI_ARGS_((Tcl_Interp *interp,
+		    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
 EXTERN int	TclCompileBreakCmd _ANSI_ARGS_((Tcl_Interp *interp,
 		    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
 EXTERN int	TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp,
@@ -2098,6 +2098,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	TclCompileLappendCmd _ANSI_ARGS_((Tcl_Interp *interp,
+		    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+EXTERN int	TclCompileLindexCmd _ANSI_ARGS_((Tcl_Interp *interp,
+		    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+EXTERN int	TclCompileLlengthCmd _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,
@@ -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: tclIntDecls.h,v 1.23 2001/04/27 22:11:51 kennykb Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.23.2.1 2001/05/15 20:07:38 hobbs Exp $
 */

 #ifndef _TCLINTDECLS
@@ -133,7 +133,7 @@ EXTERN Tcl_Channel	TclpGetDefaultStdChannel _ANSI_ARGS_((int type));
 /* 29 */
 EXTERN Tcl_Obj *	TclGetElementOfIndexedArray _ANSI_ARGS_((
 				Tcl_Interp * interp, int localIndex, 
-				Tcl_Obj * elemPtr, int leaveErrorMsg));
+				Tcl_Obj * elemPtr, int flags));
 /* Slot 30 is reserved */
 /* 31 */
 EXTERN char *		TclGetExtension _ANSI_ARGS_((char * name));
@@ -148,7 +148,7 @@ EXTERN int		TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp * interp,
 				int * indexPtr));
 /* 35 */
 EXTERN Tcl_Obj *	TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp, 
-				int localIndex, int leaveErrorMsg));
+				int localIndex, int flags));
 /* 36 */
 EXTERN int		TclGetLong _ANSI_ARGS_((Tcl_Interp * interp, 
 				char * str, long * longPtr));
@@ -327,11 +327,10 @@ EXTERN int		TclServiceIdle _ANSI_ARGS_((void));
 EXTERN Tcl_Obj *	TclSetElementOfIndexedArray _ANSI_ARGS_((
 				Tcl_Interp * interp, int localIndex, 
 				Tcl_Obj * elemPtr, Tcl_Obj * objPtr, 
-				int leaveErrorMsg));
+				int flags));
 /* 100 */
 EXTERN Tcl_Obj *	TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp, 
-				int localIndex, Tcl_Obj * objPtr, 
-				int leaveErrorMsg));
+				int localIndex, Tcl_Obj * objPtr, int flags));
 #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
 /* 101 */
 EXTERN char *		TclSetPreInitScript _ANSI_ARGS_((char * string));
@@ -580,13 +579,13 @@ typedef struct TclIntStubs {
    void *reserved26;
    int (*tclGetDate) _ANSI_ARGS_((char * p, unsigned long now, long zone, unsigned long * timePtr)); /* 27 */
    Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */
-    Tcl_Obj * (*tclGetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, int leaveErrorMsg)); /* 29 */
+    Tcl_Obj * (*tclGetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, int flags)); /* 29 */
    void *reserved30;
    char * (*tclGetExtension) _ANSI_ARGS_((char * name)); /* 31 */
    int (*tclGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, char * str, CallFrame ** framePtrPtr)); /* 32 */
    TclCmdProcType (*tclGetInterpProc) _ANSI_ARGS_((void)); /* 33 */
    int (*tclGetIntForIndex) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int endValue, int * indexPtr)); /* 34 */
-    Tcl_Obj * (*tclGetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, int leaveErrorMsg)); /* 35 */
+    Tcl_Obj * (*tclGetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, int flags)); /* 35 */
    int (*tclGetLong) _ANSI_ARGS_((Tcl_Interp * interp, char * str, long * longPtr)); /* 36 */
    int (*tclGetLoadedPackages) _ANSI_ARGS_((Tcl_Interp * interp, char * targetName)); /* 37 */
    int (*tclGetNamespaceForQualName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * qualName, Namespace * cxtNsPtr, int flags, Namespace ** nsPtrPtr, Namespace ** altNsPtrPtr, Namespace ** actualCxtPtrPtr, CONST char ** simpleNamePtr)); /* 38 */
@@ -650,8 +649,8 @@ typedef struct TclIntStubs {
    int (*tclRenameCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * oldName, char * newName)); /* 96 */
    void (*tclResetShadowedCmdRefs) _ANSI_ARGS_((Tcl_Interp * interp, Command * newCmdPtr)); /* 97 */
    int (*tclServiceIdle) _ANSI_ARGS_((void)); /* 98 */
-    Tcl_Obj * (*tclSetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, Tcl_Obj * objPtr, int leaveErrorMsg)); /* 99 */
-    Tcl_Obj * (*tclSetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * objPtr, int leaveErrorMsg)); /* 100 */
+    Tcl_Obj * (*tclSetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, Tcl_Obj * objPtr, int flags)); /* 99 */
+    Tcl_Obj * (*tclSetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * objPtr, int flags)); /* 100 */
 #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */
 #endif /* UNIX */
@@ -6,11 +6,12 @@
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.
+ * Copyright (c) 2001 by ActiveState Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
- * RCS: @(#) $Id: tclObj.c,v 1.20 2001/04/04 16:07:21 kennykb Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.20.4.2 2001/05/15 20:07:38 hobbs Exp $
 */

 #include "tclInt.h"
@@ -201,6 +202,8 @@ TclInitObjSubsystem()
 void
 TclFinalizeCompExecEnv()
 {
+    Tcl_Obj *objPtr;
+
    Tcl_MutexLock(&tableMutex);
    if (typeTableInitialized) {
        Tcl_DeleteHashTable(&typeTable);
@@ -208,6 +211,15 @@ TclFinalizeCompExecEnv()
    }
    Tcl_MutexUnlock(&tableMutex);
    Tcl_MutexLock(&tclObjMutex);
+    /*
+     * Ensure that at least the last set of objects created with
+     * TclAllocateFreeObjects is freed.
+     */
+    objPtr = tclFreeObjList;
+    while (objPtr) {
+	objPtr = (Tcl_Obj *) objPtr->internalRep.otherValuePtr;
+    }
+    ckfree((char *) objPtr);
    tclFreeObjList = NULL;
    Tcl_MutexUnlock(&tclObjMutex);

@@ -556,10 +568,7 @@ Tcl_DbNewObj(file, line)
 void
 TclAllocateFreeObjects()
 {
-    Tcl_Obj tmp[2];
-    size_t objSizePlusPadding =	/* NB: this assumes byte addressing. */
-	((int)(&(tmp[1])) - (int)(&(tmp[0])));
-    size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding);
+    size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj));
    char *basePtr;
    register Tcl_Obj *prevPtr, *objPtr;
    register int i;
@@ -569,10 +578,10 @@ TclAllocateFreeObjects()

    prevPtr = NULL;
    objPtr = (Tcl_Obj *) basePtr;
-    for (i = 0;  i < OBJS_TO_ALLOC_EACH_TIME;  i++) {
+    for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
 	objPtr->internalRep.otherValuePtr = (VOID *) prevPtr;
 	prevPtr = objPtr;
-	objPtr = (Tcl_Obj *) (((char *)objPtr) + objSizePlusPadding);
+	objPtr++;
    }
    tclFreeObjList = prevPtr;
 }
@@ -764,18 +773,14 @@ Tcl_GetStringFromObj(objPtr, lengthPtr)
 				 * string rep's byte array length should be
 				 * stored. If NULL, no length is stored. */
 {
-    if (objPtr->bytes != NULL) {
-	if (lengthPtr != NULL) {
-	    *lengthPtr = objPtr->length;
+    if (objPtr->bytes == NULL) {
+	if (objPtr->typePtr->updateStringProc == NULL) {
+	    panic("UpdateStringProc should not be invoked for type %s",
+		    objPtr->typePtr->name);
 	}
-	return objPtr->bytes;
+	(*objPtr->typePtr->updateStringProc)(objPtr);
    }

-    if (objPtr->typePtr->updateStringProc == NULL) {
-	panic("UpdateStringProc should not be invoked for type %s",
-		objPtr->typePtr->name);
-    }
-    (*objPtr->typePtr->updateStringProc)(objPtr);
    if (lengthPtr != NULL) {
 	*lengthPtr = objPtr->length;
    }
@@ -33,7 +33,7 @@
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
- * RCS: @(#) $Id: tclStringObj.c,v 1.20 2001/04/04 16:07:21 kennykb Exp $ */
+ * RCS: @(#) $Id: tclStringObj.c,v 1.20.4.1 2001/05/11 20:47:44 hobbs Exp $ */

 #include "tclInt.h"

@@ -517,6 +517,63 @@ Tcl_GetUnicode(objPtr)
    return stringPtr->unicode;
 }

+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetUnicodeFromObj --
+ *
+ *	Get the Unicode form of the String object with length.  If
+ *	the object is not already a String object, it will be converted
+ *	to one.  If the String object does not have a Unicode rep, then
+ *	one is create from the UTF string format.
+ *
+ * Results:
+ *	Returns a pointer to the object's internal Unicode string.
+ *
+ * Side effects:
+ *	Converts the object to have the String internal rep.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_UniChar *
+Tcl_GetUnicodeFromObj(objPtr, lengthPtr)
+    Tcl_Obj *objPtr;	/* The object to find the unicode string for. */
+    int *lengthPtr;	/* If non-NULL, the location where the
+			 * string rep's unichar length should be
+			 * stored. If NULL, no length is stored. */
+{
+    String *stringPtr;
+    
+    SetStringFromAny(NULL, objPtr);
+    stringPtr = GET_STRING(objPtr);
+    
+    if ((stringPtr->numChars == -1) || (stringPtr->uallocated == 0)) {
+
+	/*
+	 * We haven't yet calculated the length, or all of the characters
+	 * in the Utf string are 1 byte chars (so we didn't store the
+	 * unicode str).  Since this function must return a unicode string,
+	 * and one has not yet been stored, force the Unicode to be
+	 * calculated and stored now.
+	 */
+
+	FillUnicodeRep(objPtr);
+
+	/*
+	 * We need to fetch the pointer again because we have just
+	 * reallocated the structure to make room for the Unicode data.
+	 */
+	
+	stringPtr = GET_STRING(objPtr);
+    }
+
+    if (lengthPtr != NULL) {
+	*lengthPtr = stringPtr->numChars;
+    }
+    return stringPtr->unicode;
+}
+
 /*
 *----------------------------------------------------------------------
 *
@@ -8,7 +8,7 @@
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
- * RCS: @(#) $Id: tclStubInit.c,v 1.48 2001/03/30 23:06:40 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.48.4.1 2001/05/11 20:47:44 hobbs Exp $
 */

 #include "tclInt.h"
@@ -837,6 +837,7 @@ TclStubs tclStubs = {
    Tcl_AttemptDbCkrealloc, /* 431 */
    Tcl_AttemptSetObjLength, /* 432 */
    Tcl_GetChannelThread, /* 433 */
+    Tcl_GetUnicodeFromObj, /* 434 */
 };

 /* !END!: Do not edit above this line. */
@@ -14,7 +14,7 @@
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
- * RCS: @(#) $Id: tclVar.c,v 1.31 2001/04/27 22:11:51 kennykb Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.31.2.3 2001/05/15 20:07:38 hobbs Exp $
 */

 #include "tclInt.h"
@@ -665,7 +665,7 @@ Tcl_GetVar2Ex(interp, part1, part2, flags)
 *	given by localIndex. If the specified variable doesn't exist, or
 *	there is a clash in array usage, or an error occurs while executing
 *	variable traces, then NULL is returned and a message will be left in
- *	the interpreter's result if leaveErrorMsg is 1.
+ *	the interpreter's result if TCL_LEAVE_ERR_MSG is set in flags.
 *
 * Side effects:
 *	The ref count for the returned object is _not_ incremented to
@@ -676,13 +676,13 @@ Tcl_GetVar2Ex(interp, part1, part2, flags)
 */

 Tcl_Obj *
-TclGetIndexedScalar(interp, localIndex, leaveErrorMsg)
+TclGetIndexedScalar(interp, localIndex, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
 				 * to be looked up. */
    register int localIndex;	/* Index of variable in procedure's array
 				 * of local variables. */
-    int leaveErrorMsg;		/* 1 if to leave an error message in
-				 * interpreter's result on an error.
+    int flags;			/* TCL_LEAVE_ERR_MSG if to leave an error
+				 * message in interpreter's result on an error.
 				 * Otherwise no error message is left. */
 {
    Interp *iPtr = (Interp *) interp;
@@ -736,7 +736,7 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg)
 	msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL,
 		TCL_TRACE_READS);
 	if (msg != NULL) {
-	    if (leaveErrorMsg) {
+	    if (flags & TCL_LEAVE_ERR_MSG) {
 		VarErrMsg(interp, varName, NULL, "read", msg);
 	    }
 	    return NULL;
@@ -749,7 +749,7 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg)
     */

    if (!TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr)) {
-	if (leaveErrorMsg) {
+	if (flags & TCL_LEAVE_ERR_MSG) {
 	    if (TclIsVarArray(varPtr)) {
 		msg = isArray;
 	    } else {
@@ -778,7 +778,7 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg)
 *	element. If the specified array or element doesn't exist, or there
 *	is a clash in array usage, or an error occurs while executing
 *	variable traces, then NULL is returned and a message will be left in
- *	the interpreter's result if leaveErrorMsg is 1.
+ *	the interpreter's result if TCL_LEAVE_ERR_MSG is set in flags.
 *
 * Side effects:
 *	The ref count for the returned object is _not_ incremented to
@@ -789,15 +789,15 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg)
 */

 Tcl_Obj *
-TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg)
+TclGetElementOfIndexedArray(interp, localIndex, elemPtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
 				 * to be looked up. */
    int localIndex;		/* Index of array variable in procedure's
 				 * array of local variables. */
    Tcl_Obj *elemPtr;		/* Points to an object holding the name of
 				 * an element to get in the array. */
-    int leaveErrorMsg;		/* 1 if to leave an error message in
-				 * the interpreter's result on an error.
+    int flags;			/* TCL_LEAVE_ERR_MSG if to leave an error
+				 * message in interpreter's result on an error.
 				 * Otherwise no error message is left. */
 {
    Interp *iPtr = (Interp *) interp;
@@ -856,7 +856,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg)
     */

    if (!TclIsVarArray(arrayPtr) || TclIsVarUndefined(arrayPtr)) {
-	if (leaveErrorMsg) {
+	if (flags & TCL_LEAVE_ERR_MSG) {
 	    VarErrMsg(interp, arrayName, elem, "read", noSuchVar);
 	}
 	goto errorReturn;
@@ -894,7 +894,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg)
 	msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem,
 	        TCL_TRACE_READS);
 	if (msg != NULL) {
-	    if (leaveErrorMsg) {
+	    if (flags & TCL_LEAVE_ERR_MSG) {
 		VarErrMsg(interp, arrayName, elem, "read", msg);
 	    }
 	    goto errorReturn;
@@ -909,7 +909,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg)
 	return varPtr->value.objPtr;
    }
    
-    if (leaveErrorMsg) {
+    if (flags & TCL_LEAVE_ERR_MSG) {
 	if (TclIsVarArray(varPtr)) {
 	    msg = isArray;
 	} else {
@@ -1190,8 +1190,7 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
    Var *arrayPtr;
    Tcl_Obj *oldValuePtr;
    Tcl_Obj *resultPtr = NULL;
-    char *bytes;
-    int length, result;
+    int result;

    varPtr = TclLookupVar(interp, part1, part2, flags, "set",
 	    /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
@@ -1272,10 +1271,9 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
 	     * We append newValuePtr's bytes but don't change its ref count.
 	     */

-	    bytes = Tcl_GetStringFromObj(newValuePtr, &length);
 	    if (oldValuePtr == NULL) {
-		varPtr->value.objPtr = Tcl_NewStringObj(bytes, length);
-		Tcl_IncrRefCount(varPtr->value.objPtr);
+		varPtr->value.objPtr = newValuePtr;
+		Tcl_IncrRefCount(newValuePtr);
 	    } else {
 		if (Tcl_IsShared(oldValuePtr)) {   /* append to copy */
 		    varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
@@ -1286,34 +1284,16 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
 		Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
 	    }
 	}
-    } else {
-	if (flags & TCL_LIST_ELEMENT) {	       /* set var to list element */
-	    int neededBytes, listFlags;
+    } else if (newValuePtr != oldValuePtr) {
+	/*
+	 * In this case we are replacing the value, so we don't need to
+	 * do more than swap the objects.
+	 */

-	    /*
-	     * We set the variable to the result of converting newValuePtr's
-	     * string rep to a list element. We do not change newValuePtr's
-	     * ref count.
-	     */
-
-	    if (oldValuePtr != NULL) {
-		Tcl_DecrRefCount(oldValuePtr); /* discard old value */
-	    }
-	    bytes = Tcl_GetStringFromObj(newValuePtr, &length);
-	    neededBytes = Tcl_ScanElement(bytes, &listFlags);
-	    oldValuePtr = Tcl_NewObj();
-	    oldValuePtr->bytes = (char *)
-		ckalloc((unsigned) (neededBytes + 1));
-	    oldValuePtr->length = Tcl_ConvertElement(bytes,
-		    oldValuePtr->bytes, listFlags);
-	    varPtr->value.objPtr = oldValuePtr;
-	    Tcl_IncrRefCount(varPtr->value.objPtr);
-	} else if (newValuePtr != oldValuePtr) {
-	    varPtr->value.objPtr = newValuePtr;
-	    Tcl_IncrRefCount(newValuePtr);      /* var is another ref */
-	    if (oldValuePtr != NULL) {
-		TclDecrRefCount(oldValuePtr);   /* discard old value */
-	    }
+	varPtr->value.objPtr = newValuePtr;
+	Tcl_IncrRefCount(newValuePtr);      /* var is another ref */
+	if (oldValuePtr != NULL) {
+	    TclDecrRefCount(oldValuePtr);   /* discard old value */
 	}
    }
    TclSetVarScalar(varPtr);
@@ -1381,8 +1361,8 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
 *	variable given by localIndex. If the specified variable doesn't
 *	exist, or there is a clash in array usage, or an error occurs while
 *	executing variable traces, then NULL is returned and a message will
- *	be left in the interpreter's result if leaveErrorMsg is 1. Note
- *	that the returned object may not be the same one referenced by
+ *	be left in the interpreter's result if flags has TCL_LEAVE_ERR_MSG.
+ *	Note that the returned object may not be the same one referenced by
 *	newValuePtr; this is because variable traces may modify the
 *	variable's value.
 *
@@ -1401,15 +1381,15 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
 */

 Tcl_Obj *
-TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg)
+TclSetIndexedScalar(interp, localIndex, newValuePtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
 				 * to be found. */
    int localIndex;		/* Index of variable in procedure's array
 				 * of local variables. */
    Tcl_Obj *newValuePtr;	/* New value for variable. */
-    int leaveErrorMsg;		/* 1 if to leave an error message in
-				 * the interpreter's result on an error.
-				 * Otherwise no error message is left. */
+    int flags;			/* Various flags that tell how to set value:
+				 * any of TCL_APPEND_VALUE,
+				 * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
 {
    Interp *iPtr = (Interp *) interp;
    CallFrame *varFramePtr = iPtr->varFramePtr;
@@ -1465,7 +1445,7 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg)
     */

    if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) {
-	if (leaveErrorMsg) {
+	if (flags & TCL_LEAVE_ERR_MSG) {
 	    if (TclIsVarArrayElement(varPtr)) {
 		VarErrMsg(interp, varName, NULL, "set", danglingElement);
 	    } else {
@@ -1480,19 +1460,62 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg)
     */

    if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
-	if (leaveErrorMsg) {
+	if (flags & TCL_LEAVE_ERR_MSG) {
 	    VarErrMsg(interp, varName, NULL, "set", isArray);
 	}
 	return NULL;
    }

    /*
-     * Set the variable's new value and discard its old value. We don't
-     * append with this "set" procedure so the old value isn't needed.
+     * Set the variable's new value and discard its old value.
     */

    oldValuePtr = varPtr->value.objPtr;
-    if (newValuePtr != oldValuePtr) {        /* set new value */
+    if (flags & TCL_APPEND_VALUE) {
+	if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) {
+	    Tcl_DecrRefCount(oldValuePtr);     /* discard old value */
+	    varPtr->value.objPtr = NULL;
+	    oldValuePtr = NULL;
+	}
+	if (flags & TCL_LIST_ELEMENT) {	/* append list element */
+	    if (oldValuePtr == NULL) {
+		TclNewObj(oldValuePtr);
+		varPtr->value.objPtr = oldValuePtr;
+		Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
+	    } else if (Tcl_IsShared(oldValuePtr)) {
+		varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
+		Tcl_DecrRefCount(oldValuePtr);
+		oldValuePtr = varPtr->value.objPtr;
+		Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
+	    }
+	    if (Tcl_ListObjAppendElement(interp, oldValuePtr,
+		    newValuePtr) != TCL_OK) {
+		return NULL;
+	    }
+	} else {				/* append string */
+	    /*
+	     * We append newValuePtr's bytes but don't change its ref count.
+	     */
+
+	    if (oldValuePtr == NULL) {
+		varPtr->value.objPtr = newValuePtr;
+		Tcl_IncrRefCount(newValuePtr);
+	    } else {
+		if (Tcl_IsShared(oldValuePtr)) {	/* append to copy */
+		    varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
+		    TclDecrRefCount(oldValuePtr);
+		    oldValuePtr = varPtr->value.objPtr;
+		    Tcl_IncrRefCount(oldValuePtr);	/* since var is ref */
+		}
+		Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
+	    }
+	}
+    } else if (newValuePtr != oldValuePtr) {        /* set new value */
+	/*
+	 * In this case we are replacing the value, so we don't need to
+	 * do more than swap the objects.
+	 */
+
 	varPtr->value.objPtr = newValuePtr;
 	Tcl_IncrRefCount(newValuePtr);       /* var is another ref to obj */
 	if (oldValuePtr != NULL) {
@@ -1510,7 +1533,7 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg)
 	char *msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr,
 	        varName, (char *) NULL, TCL_TRACE_WRITES);
 	if (msg != NULL) {
-	    if (leaveErrorMsg) {
+	    if (flags & TCL_LEAVE_ERR_MSG) {
 		VarErrMsg(interp, varName, NULL, "set", msg);
 	    }
 	    goto cleanup;
@@ -1557,7 +1580,7 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg)
 *	element. If the specified array or element doesn't exist, or there
 *	is a clash in array usage, or an error occurs while executing
 *	variable traces, then NULL is returned and a message will be left in
- *	the interpreter's result if leaveErrorMsg is 1. Note that the
+ *	the interpreter's result if flags has TCL_LEAVE_ERR_MSG. Note that the
 *	returned object may not be the same one referenced by newValuePtr;
 *	this is because variable traces may modify the variable's value.
 *
@@ -1578,8 +1601,7 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg)
 */

 Tcl_Obj *
-TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
-        leaveErrorMsg)
+TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which the array is
 				 * to be found. */
    int localIndex;		/* Index of array variable in procedure's
@@ -1587,9 +1609,9 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
    Tcl_Obj *elemPtr;		/* Points to an object holding the name of
 				 * an element to set in the array. */
    Tcl_Obj *newValuePtr;	/* New value for variable. */
-    int leaveErrorMsg;		/* 1 if to leave an error message in
-				 * the interpreter's result on an error.
-				 * Otherwise no error message is left. */
+    int flags;			/* Various flags that tell how to set value:
+				 * any of TCL_APPEND_VALUE,
+				 * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
 {
    Interp *iPtr = (Interp *) interp;
    CallFrame *varFramePtr = iPtr->varFramePtr;
@@ -1620,7 +1642,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
 		(unsigned int) varFramePtr);
    }
    if ((localIndex < 0) || (localIndex >= localCt)) {
-	fprintf(stderr, "\nTclSetIndexedScalar: can't set elememt of local %i in frame 0x%x with %i locals\n",
+	fprintf(stderr, "\nTclSetIndexedScalar: can't set element of local %i in frame 0x%x with %i locals\n",
 		localIndex, (unsigned int) varFramePtr, localCt);
 	panic("TclSetElementOfIndexedArray: bad local index %i in frame 0x%x",
 		localIndex, (unsigned int) varFramePtr);
@@ -1637,7 +1659,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
     * reference to a variable in an enclosing namespace. Traverse through
     * any links until we find the referenced variable.
     */
-	
+
    while (TclIsVarLink(arrayPtr)) {
 	arrayPtr = arrayPtr->value.linkPtr;
    }
@@ -1651,7 +1673,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
     */

    if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) {
-	if (leaveErrorMsg) {
+	if (flags & TCL_LEAVE_ERR_MSG) {
 	    if (TclIsVarArrayElement(arrayPtr)) {
 		VarErrMsg(interp, arrayName, elem, "set", danglingElement);
 	    } else {
@@ -1672,11 +1694,11 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
 	Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS);
 	TclClearVarUndefined(arrayPtr);
    } else if (!TclIsVarArray(arrayPtr)) {
-	if (leaveErrorMsg) {
+	if (flags & TCL_LEAVE_ERR_MSG) {
 	    VarErrMsg(interp, arrayName, elem, "set", needArray);
 	}
 	goto errorReturn;
-    } 
+    }

    /*
     * Look up the element.
@@ -1700,23 +1722,66 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
     */

    if (TclIsVarArray(varPtr)) {
-	if (leaveErrorMsg) {
+	if (flags & TCL_LEAVE_ERR_MSG) {
 	    VarErrMsg(interp, arrayName, elem, "set", isArray);
 	}
 	goto errorReturn;
    }

    /*
-     * Set the variable's new value and discard the old one. We don't
-     * append with this "set" procedure so the old value isn't needed.
+     * Set the variable's new value and discard the old one.
     */

    oldValuePtr = varPtr->value.objPtr;
-    if (newValuePtr != oldValuePtr) {	     /* set new value */
+    if (flags & TCL_APPEND_VALUE) {
+	if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) {
+	    Tcl_DecrRefCount(oldValuePtr);     /* discard old value */
+	    varPtr->value.objPtr = NULL;
+	    oldValuePtr = NULL;
+	}
+	if (flags & TCL_LIST_ELEMENT) {	/* append list element */
+	    if (oldValuePtr == NULL) {
+		TclNewObj(oldValuePtr);
+		varPtr->value.objPtr = oldValuePtr;
+		Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
+	    } else if (Tcl_IsShared(oldValuePtr)) {
+		varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
+		Tcl_DecrRefCount(oldValuePtr);
+		oldValuePtr = varPtr->value.objPtr;
+		Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
+	    }
+	    if (Tcl_ListObjAppendElement(interp, oldValuePtr,
+		    newValuePtr) != TCL_OK) {
+		return NULL;
+	    }
+	} else {				/* append string */
+	    /*
+	     * We append newValuePtr's bytes but don't change its ref count.
+	     */
+
+	    if (oldValuePtr == NULL) {
+		varPtr->value.objPtr = newValuePtr;
+		Tcl_IncrRefCount(newValuePtr);
+	    } else {
+		if (Tcl_IsShared(oldValuePtr)) {	/* append to copy */
+		    varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
+		    TclDecrRefCount(oldValuePtr);
+		    oldValuePtr = varPtr->value.objPtr;
+		    Tcl_IncrRefCount(oldValuePtr);	/* since var is ref */
+		}
+		Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
+	    }
+	}
+    } else if (newValuePtr != oldValuePtr) {	/* set new value */
+	/*
+	 * In this case we are replacing the value, so we don't need to
+	 * do more than swap the objects.
+	 */
+
 	varPtr->value.objPtr = newValuePtr;
-	Tcl_IncrRefCount(newValuePtr);       /* var is another ref to obj */
+	Tcl_IncrRefCount(newValuePtr);		/* var is another ref to obj */
 	if (oldValuePtr != NULL) {
-	    TclDecrRefCount(oldValuePtr);    /* discard old value */
+	    TclDecrRefCount(oldValuePtr);	/* discard old value */
 	}
    }
    TclSetVarScalar(varPtr);
@@ -1731,7 +1796,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
 	char *msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem,
 		TCL_TRACE_WRITES);
 	if (msg != NULL) {
-	    if (leaveErrorMsg) {
+	    if (flags & TCL_LEAVE_ERR_MSG) {
 		VarErrMsg(interp, arrayName, elem, "set", msg);
 	    }
 	    goto errorReturn;
@@ -1894,8 +1959,7 @@ TclIncrIndexedScalar(interp, localIndex, incrAmount)
    long i;
    int result;

-    varValuePtr = TclGetIndexedScalar(interp, localIndex,
-	    /*leaveErrorMsg*/ 1);
+    varValuePtr = TclGetIndexedScalar(interp, localIndex, TCL_LEAVE_ERR_MSG);
    if (varValuePtr == NULL) {
 	Tcl_AddObjErrorInfo(interp,
 		"\n    (reading value of variable to increment)", -1);
@@ -1929,7 +1993,7 @@ TclIncrIndexedScalar(interp, localIndex, incrAmount)
     */
    
    resultPtr = TclSetIndexedScalar(interp, localIndex, varValuePtr,
-	    /*leaveErrorMsg*/ 1);
+	    TCL_LEAVE_ERR_MSG);
    if (resultPtr == NULL) {
 	return NULL;
    }
@@ -1982,7 +2046,7 @@ TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount)
    int result;

    varValuePtr = TclGetElementOfIndexedArray(interp, localIndex, elemPtr,
-	    /*leaveErrorMsg*/ 1);
+	    TCL_LEAVE_ERR_MSG);
    if (varValuePtr == NULL) {
 	Tcl_AddObjErrorInfo(interp,
 		"\n    (reading value of variable to increment)", -1);
@@ -2016,8 +2080,7 @@ TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount)
     */
    
    resultPtr = TclSetElementOfIndexedArray(interp, localIndex, elemPtr,
-	    varValuePtr,
-	    /*leaveErrorMsg*/ 1);
+	    varValuePtr, TCL_LEAVE_ERR_MSG);
    if (resultPtr == NULL) {
 	return NULL;
    }
@@ -0,0 +1,270 @@
+# Commands covered:  append lappend
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands.  Sourcing this file into Tcl runs the tests and
+# generates output for errors.  No output means no errors were found.
+#
+# Copyright (c) 1991-1993 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: appendComp.test,v 1.1.2.2 2001/05/12 00:01:03 hobbs Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+    package require tcltest
+    namespace import -force ::tcltest::*
+}
+catch {unset x}
+
+test append-1.1 {append command} {
+    catch {unset x}
+    proc foo {} {append ::x 1 2 abc "long string"}
+    list [foo] $x
+} {{12abclong string} {12abclong string}}
+test append-1.2 {append command} {
+    proc foo {} {
+	set x ""
+	list [append x first] [append x second] [append x third] $x
+    }
+    foo
+} {first firstsecond firstsecondthird firstsecondthird}
+test append-1.3 {append command} {
+    proc foo {} {
+	set x "abcd"
+	append x
+    }
+    foo
+} abcd
+
+test append-2.1 {long appends} {
+    proc foo {} {
+	set x ""
+	for {set i 0} {$i < 1000} {set i [expr $i+1]} {
+	    append x "foobar "
+	}
+	set y "foobar"
+	set y "$y $y $y $y $y $y $y $y $y $y"
+	set y "$y $y $y $y $y $y $y $y $y $y"
+	set y "$y $y $y $y $y $y $y $y $y $y "
+	expr {$x == $y}
+    }
+    foo
+} 1
+
+test append-3.1 {append errors} {
+    proc foo {} {append}
+    list [catch {foo} msg] $msg
+} {1 {wrong # args: should be "append varName ?value value ...?"}}
+test append-3.2 {append errors} {
+    proc foo {} {
+	set x ""
+	append x(0) 44
+    }
+    list [catch {foo} msg] $msg
+} {1 {can't set "x(0)": variable isn't array}}
+test append-3.3 {append errors} {
+    proc foo {} {
+	catch {unset x}
+	append x
+    }
+    list [catch {foo} msg] $msg
+} {1 {can't read "x": no such variable}}
+
+test append-4.1 {lappend command} {
+    proc foo {} {
+	global x
+	catch {unset x}
+	lappend x 1 2 abc "long string"
+    }
+    list [foo] $x
+} {{1 2 abc {long string}} {1 2 abc {long string}}}
+test append-4.2 {lappend command} {
+    proc foo {} {
+	set x ""
+	list [lappend x first] [lappend x second] [lappend x third] $x
+    }
+    foo
+} {first {first second} {first second third} {first second third}}
+test append-4.3 {lappend command} {
+    proc foo {} {
+	global x
+	set x old
+	unset x
+	lappend x new
+    }
+    set result [foo]
+    rename foo {}
+    set result
+} {new}
+test append-4.4 {lappend command} {
+    proc foo {} {
+	set x {}
+	lappend x \{\  abc
+    }
+    foo
+} {\{\  abc}
+test append-4.5 {lappend command} {
+    proc foo {} {
+	set x {}
+	lappend x \{ abc
+    }
+    foo
+} {\{ abc}
+test append-4.6 {lappend command} {
+    proc foo {} {
+	set x {1 2 3}
+	lappend x
+    }
+    foo
+} {1 2 3}
+test append-4.7 {lappend command} {
+    proc foo {} {
+	set x "a\{"
+	lappend x abc
+    }
+    foo
+} "a\\\{ abc"
+test append-4.8 {lappend command} {
+    proc foo {} {
+	set x "\\\{"
+	lappend x abc
+    }
+    foo
+} "\\{ abc"
+test append-4.9 {lappend command} {
+    proc foo {} {
+	set x " \{"
+	list [catch {lappend x abc} msg] $msg
+    }
+    foo
+} {1 {unmatched open brace in list}}
+test append-4.10 {lappend command} {
+    proc foo {} {
+	set x "	\{"
+	list [catch {lappend x abc} msg] $msg
+    }
+    foo
+} {1 {unmatched open brace in list}}
+test append-4.11 {lappend command} {
+    proc foo {} {
+	set x "\{\{\{"
+	list [catch {lappend x abc} msg] $msg
+    }
+    foo
+} {1 {unmatched open brace in list}}
+test append-4.12 {lappend command} {
+    proc foo {} {
+	set x "x \{\{\{"
+	list [catch {lappend x abc} msg] $msg
+    }
+    foo
+} {1 {unmatched open brace in list}}
+test append-4.13 {lappend command} {
+    proc foo {} {
+	set x "x\{\{\{"
+	lappend x abc
+    }
+    foo
+} "x\\\{\\\{\\\{ abc"
+test append-4.14 {lappend command} {
+    proc foo {} {
+	set x " "
+	lappend x abc
+    }
+    foo
+} "abc"
+test append-4.15 {lappend command} {
+    proc foo {} {
+	set x "\\ "
+	lappend x abc
+    }
+    foo
+} "{ } abc"
+test append-4.16 {lappend command} {
+    proc foo {} {
+	set x "x "
+	lappend x abc
+    }
+    foo
+} "x abc"
+test append-4.17 {lappend command} {
+    proc foo {} { lappend x }
+    foo
+} {}
+test append-4.18 {lappend command} {
+    proc foo {} { lappend x {} }
+    foo
+} {{}}
+
+proc check {var size} {
+    set l [llength $var]
+    if {$l != $size} {
+	return "length mismatch: should have been $size, was $l"
+    }
+    for {set i 0} {$i < $size} {set i [expr $i+1]} {
+	set j [lindex $var $i]
+	if {$j != "item $i"} {
+	    return "element $i should have been \"item $i\", was \"$j\""
+	}
+    }
+    return ok
+}
+test append-5.1 {long lappends} {
+    set x ""
+    for {set i 0} {$i < 300} {set i [expr $i+1]} {
+	lappend x "item $i"
+    }
+    check $x 300
+} ok
+
+test append-6.1 {lappend errors} {
+    proc foo {} {lappend}
+    list [catch {foo} msg] $msg
+} {1 {wrong # args: should be "lappend varName ?value value ...?"}}
+test append-6.2 {lappend errors} {
+    proc foo {} {
+	set x ""
+	lappend x(0) 44
+    }
+    list [catch {foo} msg] $msg
+} {1 {can't set "x(0)": variable isn't array}}
+
+test append-7.1 {lappend-created var and error in trace on that var} {
+    proc bar {} {
+	global x
+	catch {rename foo ""}
+	catch {unset x}
+	trace variable x w foo
+	proc foo {} {global x; unset x}
+	catch {lappend x 1}
+	proc foo {args} {global x; unset x}
+	info exists x
+	set x
+	lappend x 1
+	list [info exists x] [catch {set x} msg] $msg
+    }
+    bar
+} {0 1 {can't read "x": no such variable}}
+
+catch {unset i x result y}
+catch {rename foo ""}
+catch {rename check ""}
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
@@ -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: fileName.test,v 1.9 2000/09/29 01:12:15 hobbs Exp $
+# RCS: @(#) $Id: fileName.test,v 1.9.4.1 2001/05/15 20:03:05 hobbs Exp $

 if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
@@ -1475,13 +1475,13 @@ test filename-16.4 {windows specific globbing} {pcOnly} {
    glob c:/
 } c:/
 test filename-16.5 {windows specific globbing} {pcOnly} {
-    glob c:*Test
+    glob c:*bTest
 } c:globTest
 test filename-16.6 {windows specific globbing} {pcOnly} {
-    glob c:\\\\*Test
+    glob c:\\\\*bTest
 } c:/globTest
 test filename-16.7 {windows specific globbing} {pcOnly} {
-    glob c:/*Test
+    glob c:/*bTest
 } c:/globTest
 test filename-16.8 {windows specific globbing} {pcOnly} {
    lsort [glob c:globTest/*.bat]
@@ -0,0 +1,647 @@
+# Commands covered:  string
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands.  Sourcing this file into Tcl runs the tests and
+# generates output for errors.  No output means no errors were found.
+#
+# This differs from the original string tests in that the tests call
+# things in procs, which uses the compiled string code instead of
+# the runtime parse string code.  The tests of import should match
+# their equivalent number in string.test.
+#
+# Copyright (c) 2001 by ActiveState Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: stringComp.test,v 1.1.2.1 2001/05/11 20:47:44 hobbs Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+    package require tcltest
+    namespace import -force ::tcltest::*
+}
+
+# Some tests require the testobj command
+
+set ::tcltest::testConstraints(testobj) \
+	[expr {[info commands testobj] != {}}]
+
+test string-1.1 {error conditions} {
+    proc foo {} {string gorp a b}
+    list [catch {foo} msg] $msg
+} {1 {bad option "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}}
+test string-1.2 {error conditions} {
+    proc foo {} {string}
+    list [catch {foo} msg] $msg
+} {1 {wrong # args: should be "string option arg ?arg ...?"}}
+
+test string-2.1 {string compare, too few args} {
+    proc foo {} {string compare a}
+    list [catch {foo} msg] $msg
+} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
+test string-2.2 {string compare, bad args} {
+    proc foo {} {string compare a b c}
+    list [catch {foo} msg] $msg
+} {1 {bad option "a": must be -nocase or -length}}
+test string-2.3 {string compare, bad args} {
+    list [catch {string compare -length -nocase str1 str2} msg] $msg
+} {1 {expected integer but got "-nocase"}}
+test string-2.4 {string compare, too many args} {
+    list [catch {string compare -length 10 -nocase str1 str2 str3} msg] $msg
+} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
+test string-2.5 {string compare with length unspecified} {
+    list [catch {string compare -length 10 10} msg] $msg
+} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
+test string-2.6 {string compare} {
+    proc foo {} {string compare abcde abdef}
+    foo
+} -1
+test string-2.7 {string compare, shortest method name} {
+    proc foo {} {string c abcde ABCDE}
+    foo
+} 1
+test string-2.8 {string compare} {
+    proc foo {} {string compare abcde abcde}
+    foo
+} 0
+test string-2.9 {string compare with length} {
+    proc foo {} {string compare -length 2 abcde abxyz}
+    foo
+} 0
+test string-2.10 {string compare with special index} {
+    proc foo {} {string compare -length end-3 abcde abxyz}
+    list [catch {foo} msg] $msg
+} {1 {expected integer but got "end-3"}}
+test string-2.11 {string compare, unicode} {
+    proc foo {} {string compare ab\u7266 ab\u7267}
+    foo
+} -1
+test string-2.12 {string compare, high bit} {
+    # This test will fail if the underlying comparaison
+    # is using signed chars instead of unsigned chars.
+    # (like SunOS's default memcmp thus the compat/memcmp.c)
+    proc foo {} {string compare "\x80" "@"}
+    foo
+    # Nb this tests works also in utf8 space because \x80 is
+    # translated into a 2 or more bytelength but whose first byte has
+    # the high bit set.
+} 1
+test string-2.13 {string compare -nocase} {
+    proc foo {} {string compare -nocase abcde abdef}
+    foo
+} -1
+test string-2.14 {string compare -nocase} {
+    proc foo {} {string c -nocase abcde ABCDE}
+    foo
+} 0
+test string-2.15 {string compare -nocase} {
+    proc foo {} {string compare -nocase abcde abcde}
+    foo
+} 0
+test string-2.16 {string compare -nocase with length} {
+    proc foo {} {string compare -length 2 -nocase abcde Abxyz}
+    foo
+} 0
+test string-2.17 {string compare -nocase with length} {
+    proc foo {} {string compare -nocase -length 3 abcde Abxyz}
+    foo
+} -1
+test string-2.18 {string compare -nocase with length <= 0} {
+    proc foo {} {string compare -nocase -length -1 abcde AbCdEf}
+    foo
+} -1
+test string-2.19 {string compare -nocase with excessive length} {
+    proc foo {} {string compare -nocase -length 50 AbCdEf abcde}
+    foo
+} 1
+test string-2.20 {string compare -len unicode} {
+    # These are strings that are 6 BYTELENGTH long, but the length
+    # shouldn't make a different because there are actually 3 CHARS long
+    proc foo {} {string compare -len 5 \334\334\334 \334\334\374}
+    foo
+} -1
+test string-2.21 {string compare -nocase with special index} {
+    proc foo {} {string compare -nocase -length end-3 Abcde abxyz}
+    list [catch {foo} msg] $msg
+} {1 {expected integer but got "end-3"}}
+test string-2.22 {string compare, null strings} {
+    proc foo {} {string compare "" ""}
+    foo
+} 0
+test string-2.23 {string compare, null strings} {
+    proc foo {} {string compare "" foo}
+    foo
+} -1
+test string-2.24 {string compare, null strings} {
+    proc foo {} {string compare foo ""}
+    foo
+} 1
+test string-2.25 {string compare -nocase, null strings} {
+    proc foo {} {string compare -nocase "" ""}
+    foo
+} 0
+test string-2.26 {string compare -nocase, null strings} {
+    proc foo {} {string compare -nocase "" foo}
+    foo
+} -1
+test string-2.27 {string compare -nocase, null strings} {
+    proc foo {} {string compare -nocase foo ""}
+    foo
+} 1
+test string-2.28 {string compare with length, unequal strings} {
+    proc foo {} {string compare -length 2 abc abde}
+    foo
+} 0
+test string-2.29 {string compare with length, unequal strings} {
+    proc foo {} {string compare -length 2 ab abde}
+    foo
+} 0
+test string-2.30 {string compare with NUL character vs. other ASCII} {
+    # Be careful here, since UTF-8 rep comparison with memcmp() of
+    # these puts chars in the wrong order
+    proc foo {} {string compare \x00 \x01}
+    foo
+} -1
+
+# only need a few tests on equal, since it uses the same code as
+# string compare, but just modifies the return output
+test string-3.1 {string equal} {
+    proc foo {} {string equal abcde abdef}
+    foo
+} 0
+test string-3.2 {string equal} {
+    proc foo {} {string eq abcde ABCDE}
+    foo
+} 0
+test string-3.3 {string equal} {
+    proc foo {} {string equal abcde abcde}
+    foo
+} 1
+test string-3.4 {string equal -nocase} {
+    proc foo {} {string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334}
+    foo
+} 1
+test string-3.5 {string equal -nocase} {
+    proc foo {} {string equal -nocase abcde abdef}
+    foo
+} 0
+test string-3.6 {string equal -nocase} {
+    proc foo {} {string eq -nocase abcde ABCDE}
+    foo
+} 1
+test string-3.7 {string equal -nocase} {
+    proc foo {} {string equal -nocase abcde abcde}
+    foo
+} 1
+test string-3.8 {string equal with length, unequal strings} {
+    proc foo {} {string equal -length 2 abc abde}
+    foo
+} 1
+
+test string-4.1 {string first, too few args} {
+    proc foo {} {string first a}
+    list [catch {foo} msg] $msg
+} {1 {wrong # args: should be "string first subString string ?startIndex?"}}
+test string-4.2 {string first, bad args} {
+    proc foo {} {string first a b c}
+    list [catch {foo} msg] $msg
+} {1 {bad index "c": must be integer or end?-integer?}}
+test string-4.3 {string first, too many args} {
+    proc foo {} {string first a b 5 d}
+    list [catch {foo} msg] $msg
+} {1 {wrong # args: should be "string first subString string ?startIndex?"}}
+test string-4.4 {string first} {
+    proc foo {} {string first bq abcdefgbcefgbqrs}
+    foo
+} 12
+test string-4.5 {string first} {
+    proc foo {} {string fir bcd abcdefgbcefgbqrs}
+    foo
+} 1
+test string-4.6 {string first} {
+    proc foo {} {string f b abcdefgbcefgbqrs}
+    foo
+} 1
+test string-4.7 {string first} {
+    proc foo {} {string first xxx x123xx345xxx789xxx012}
+    foo
+} 9
+test string-4.8 {string first} {
+    proc foo {} {string first "" x123xx345xxx789xxx012}
+    foo
+} -1
+test string-4.9 {string first, unicode} {
+    proc foo {} {string first x abc\u7266x}
+    foo
+} 4
+test string-4.10 {string first, unicode} {
+    proc foo {} {string first \u7266 abc\u7266x}
+    foo
+} 3
+test string-4.11 {string first, start index} {
+    proc foo {} {string first \u7266 abc\u7266x 3}
+    foo
+} 3
+test string-4.12 {string first, start index} {
+    proc foo {} {string first \u7266 abc\u7266x 4}
+    foo
+} -1
+test string-4.13 {string first, start index} {
+    proc foo {} {string first \u7266 abc\u7266x end-2}
+    foo
+} 3
+
+test string-5.1 {string index} {
+    proc foo {} {string index}
+    list [catch {foo} msg] $msg
+} {1 {wrong # args: should be "string index string charIndex"}}
+test string-5.2 {string index} {
+    proc foo {} {string index a b c}
+    list [catch {foo} msg] $msg
+} {1 {wrong # args: should be "string index string charIndex"}}
+test string-5.3 {string index} {
+    proc foo {} {string index abcde 0}
+    foo
+} a
+test string-5.4 {string index} {
+    proc foo {} {string in abcde 4}
+    foo
+} e
+test string-5.5 {string index} {
+    proc foo {} {string index abcde 5}
+    foo
+} {}
+test string-5.6 {string index} {
+    proc foo {} {string index abcde -10}
+    list [catch {foo} msg] $msg
+} {0 {}}
+test string-5.7 {string index} {
+    proc foo {} {string index a xyz}
+    list [catch {foo} msg] $msg
+} {1 {bad index "xyz": must be integer or end?-integer?}}
+test string-5.8 {string index} {
+    proc foo {} {string index abc end}
+    foo
+} c
+test string-5.9 {string index} {
+    proc foo {} {string index abc end-1}
+    foo
+} b
+test string-5.10 {string index, unicode} {
+    proc foo {} {string index abc\u7266d 4}
+    foo
+} d
+test string-5.11 {string index, unicode} {
+    proc foo {} {string index abc\u7266d 3}
+    foo
+} \u7266
+test string-5.12 {string index, unicode over char length, under byte length} {
+    proc foo {} {string index \334\374\334\374 6}
+    foo
+} {}
+test string-5.13 {string index, bytearray object} {
+    proc foo {} {string index [binary format a5 fuz] 0}
+    foo
+} f
+test string-5.14 {string index, bytearray object} {
+    proc foo {} {string index [binary format I* {0x50515253 0x52}] 3}
+    foo
+} S
+test string-5.15 {string index, bytearray object} {
+    proc foo {} {
+	set b [binary format I* {0x50515253 0x52}]
+	set i1 [string index $b end-6]
+	set i2 [string index $b 1]
+	string compare $i1 $i2
+    }
+    foo
+} 0
+test string-5.16 {string index, bytearray object with string obj shimmering} {
+    proc foo {} {
+	set str "0123456789\x00 abcdedfghi"
+	binary scan $str H* dump
+	string compare [string index $str 10] \x00
+    }
+    foo
+} 0
+test string-5.17 {string index, bad integer} {
+    proc foo {} {string index "abc" 08}
+    list [catch {foo} msg] $msg
+} {1 {bad index "08": must be integer or end?-integer? (looks like invalid octal number)}}
+test string-5.18 {string index, bad integer} {
+    proc foo {} {string index "abc" end-00289}
+    list [catch {foo} msg] $msg
+} {1 {expected integer but got "-00289" (looks like invalid octal number)}}
+test string-5.19 {string index, bytearray object out of bounds} {
+    proc foo {} {string index [binary format I* {0x50515253 0x52}] -1}
+    foo
+} {}
+test string-5.20 {string index, bytearray object out of bounds} {
+    proc foo {} {string index [binary format I* {0x50515253 0x52}] 20}
+    foo
+} {}
+
+
+proc largest_int {} {
+    # This will give us what the largest valid int on this machine is,
+    # so we can test for overflow properly below on >32 bit systems
+    set int 1
+    set exp 7; # assume we get at least 8 bits
+    while {$int > 0} { set int [expr {1 << [incr exp]}] }
+    return [expr {$int-1}]
+}
+
+## string is
+## not yet bc
+
+catch {rename largest_int {}}
+
+## string last
+## not yet bc
+
+## string length
+## not yet bc
+test string-8.1 {string bytelength} {
+    proc foo {} {string bytelength}
+    list [catch {foo} msg] $msg
+} {1 {wrong # args: should be "string bytelength string"}}
+test string-8.2 {string bytelength} {
+    proc foo {} {string bytelength a b}
+    list [catch {foo} msg] $msg
+} {1 {wrong # args: should be "string bytelength string"}}
+test string-8.3 {string bytelength} {
+    proc foo {} {string bytelength "\u00c7"}
+    foo
+} 2
+test string-8.4 {string bytelength} {
+    proc foo {} {string b ""}
+    foo
+} 0
+
+## string length
+##
+test string-9.1 {string length} {
+    proc foo {} {string length}
+    list [catch {foo} msg] $msg
+} {1 {wrong # args: should be "string length string"}}
+test string-9.2 {string length} {
+    proc foo {} {string length a b}
+    list [catch {foo} msg] $msg
+} {1 {wrong # args: should be "string length string"}}
+test string-9.3 {string length} {
+    proc foo {} {string length "a little string"}
+    foo
+} 15
+test string-9.4 {string length} {
+    proc foo {} {string le ""}
+    foo
+} 0
+test string-9.5 {string length, unicode} {
+    proc foo {} {string le "abcd\u7266"}
+    foo
+} 5
+test string-9.6 {string length, bytearray object} {
+    proc foo {} {string length [binary format a5 foo]}
+    foo
+} 5
+test string-9.7 {string length, bytearray object} {
+    proc foo {} {string length [binary format I* {0x50515253 0x52}]}
+    foo
+} 8
+
+## string map
+## not yet bc
+
+## string match
+##
+test string-11.1 {string match, too few args} {
+    proc foo {} {string match a}
+    list [catch {foo} msg] $msg
+} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
+test string-11.2 {string match, too many args} {
+    proc foo {} {string match a b c d}
+    list [catch {foo} msg] $msg
+} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
+test string-11.3 {string match} {
+    proc foo {} {string match abc abc}
+    foo
+} 1
+test string-11.4 {string match} {
+    proc foo {} {string mat abc abd}
+    foo
+} 0
+test string-11.5 {string match} {
+    proc foo {} {string match ab*c abc}
+    foo
+} 1
+test string-11.6 {string match} {
+    proc foo {} {string match ab**c abc}
+    foo
+} 1
+test string-11.7 {string match} {
+    proc foo {} {string match ab* abcdef}
+    foo
+} 1
+test string-11.8 {string match} {
+    proc foo {} {string match *c abc}
+    foo
+} 1
+test string-11.9 {string match} {
+    proc foo {} {string match *3*6*9 0123456789}
+    foo
+} 1
+test string-11.10 {string match} {
+    proc foo {} {string match *3*6*9 01234567890}
+    foo
+} 0
+test string-11.11 {string match} {
+    proc foo {} {string match a?c abc}
+    foo
+} 1
+test string-11.12 {string match} {
+    proc foo {} {string match a??c abc}
+    foo
+} 0
+test string-11.13 {string match} {
+    proc foo {} {string match ?1??4???8? 0123456789}
+    foo
+} 1
+test string-11.14 {string match} {
+    proc foo {} {string match {[abc]bc} abc}
+    foo
+} 1
+test string-11.15 {string match} {
+    proc foo {} {string match {a[abc]c} abc}
+    foo
+} 1
+test string-11.16 {string match} {
+    proc foo {} {string match {a[xyz]c} abc}
+    foo
+} 0
+test string-11.17 {string match} {
+    proc foo {} {string match {12[2-7]45} 12345}
+    foo
+} 1
+test string-11.18 {string match} {
+    proc foo {} {string match {12[ab2-4cd]45} 12345}
+    foo
+} 1
+test string-11.19 {string match} {
+    proc foo {} {string match {12[ab2-4cd]45} 12b45}
+    foo
+} 1
+test string-11.20 {string match} {
+    proc foo {} {string match {12[ab2-4cd]45} 12d45}
+    foo
+} 1
+test string-11.21 {string match} {
+    proc foo {} {string match {12[ab2-4cd]45} 12145}
+    foo
+} 0
+test string-11.22 {string match} {
+    proc foo {} {string match {12[ab2-4cd]45} 12545}
+    foo
+} 0
+test string-11.23 {string match} {
+    proc foo {} {string match {a\*b} a*b}
+    foo
+} 1
+test string-11.24 {string match} {
+    proc foo {} {string match {a\*b} ab}
+    foo
+} 0
+test string-11.25 {string match} {
+    proc foo {} {string match {a\*\?\[\]\\\x} "a*?\[\]\\x"}
+    foo
+} 1
+test string-11.26 {string match} {
+    proc foo {} {string match ** ""}
+    foo
+} 1
+test string-11.27 {string match} {
+    proc foo {} {string match *. ""}
+    foo
+} 0
+test string-11.28 {string match} {
+    proc foo {} {string match "" ""}
+    foo
+} 1
+test string-11.29 {string match} {
+    proc foo {} {string match \[a a}
+    foo
+} 1
+test string-11.30 {string match, bad args} {
+    proc foo {} {string match - b c}
+    list [catch {foo} msg] $msg
+} {1 {bad option "-": must be -nocase}}
+test string-11.31 {string match case} {
+    proc foo {} {string match a A}
+    foo
+} 0
+test string-11.32 {string match nocase} {
+    proc foo {} {string match -n a A}
+    foo
+} 1
+test string-11.33 {string match nocase} {
+    proc foo {} {string match -nocase a\334 A\374}
+    foo
+} 1
+test string-11.34 {string match nocase} {
+    proc foo {} {string match -nocase a*f ABCDEf}
+    foo
+} 1
+test string-11.35 {string match case, false hope} {
+    # This is true because '_' lies between the A-Z and a-z ranges
+    proc foo {} {string match {[A-z]} _}
+    foo
+} 1
+test string-11.36 {string match nocase range} {
+    # This is false because although '_' lies between the A-Z and a-z ranges,
+    # we lower case the end points before checking the ranges.
+    proc foo {} {string match -nocase {[A-z]} _}
+    foo
+} 0
+test string-11.37 {string match nocase} {
+    proc foo {} {string match -nocase {[A-fh-Z]} g}
+    foo
+} 0
+test string-11.38 {string match case, reverse range} {
+    proc foo {} {string match {[A-fh-Z]} g}
+    foo
+} 1
+test string-11.39 {string match, *\ case} {
+    proc foo {} {string match {*\abc} abc}
+    foo
+} 1
+test string-11.40 {string match, *special case} {
+    proc foo {} {string match {*[ab]} abc}
+    foo
+} 0
+test string-11.41 {string match, *special case} {
+    proc foo {} {string match {*[ab]*} abc}
+    foo
+} 1
+test string-11.42 {string match, *special case} {
+    proc foo {} {string match "*\\" "\\"}
+    foo
+} 0
+test string-11.43 {string match, *special case} {
+    proc foo {} {string match "*\\\\" "\\"}
+    foo
+} 1
+test string-11.44 {string match, *special case} {
+    proc foo {} {string match "*???" "12345"}
+    foo
+} 1
+test string-11.45 {string match, *special case} {
+    proc foo {} {string match "*???" "12"}
+    foo
+} 0
+test string-11.46 {string match, *special case} {
+    proc foo {} {string match "*\\*" "abc*"}
+    foo
+} 1
+test string-11.47 {string match, *special case} {
+    proc foo {} {string match "*\\*" "*"}
+    foo
+} 1
+test string-11.48 {string match, *special case} {
+    proc foo {} {string match "*\\*" "*abc"}
+    foo
+} 0
+test string-11.49 {string match, *special case} {
+    proc foo {} {string match "?\\*" "a*"}
+    foo
+} 1
+test string-11.50 {string match, *special case} {
+    proc foo {} {string match "\\" "\\"}
+    foo
+} 0
+
+## string range
+## not yet bc
+
+## string repeat
+## not yet bc
+
+## string replace
+## not yet bc
+
+## string tolower
+## not yet bc
+
+## string toupper
+## not yet bc
+
+## string totitle
+## not yet bc
+
+## string trim*
+## not yet bc
+
+## string word*
+## not yet bc
+
+# cleanup
+::tcltest::cleanupTests
+return
@@ -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: tclUnixPipe.c,v 1.11 2001/03/29 19:45:20 hobbs Exp $
+ * RCS: @(#) $Id: tclUnixPipe.c,v 1.11.4.1 2001/05/15 20:01:56 hobbs Exp $
 */

 #include "tclInt.h"
@@ -67,16 +67,20 @@ static int	SetupStdFile _ANSI_ARGS_((TclFile file, int type));
 */

 static Tcl_ChannelType pipeChannelType = {
-    "pipe",				/* Type name. */
-    PipeBlockModeProc,			/* Set blocking/nonblocking mode.*/
-    PipeCloseProc,			/* Close proc. */
-    PipeInputProc,			/* Input proc. */
-    PipeOutputProc,			/* Output proc. */
-    NULL,				/* Seek proc. */
-    NULL,				/* Set option proc. */
-    NULL,				/* Get option proc. */
-    PipeWatchProc,			/* Initialize notifier. */
-    PipeGetHandleProc,			/* Get OS handles out of channel. */
+    "pipe",			/* Type name. */
+    TCL_CHANNEL_VERSION_2,	/* v2 channel */
+    PipeCloseProc,		/* Close proc. */
+    PipeInputProc,		/* Input proc. */
+    PipeOutputProc,		/* Output proc. */
+    NULL,			/* Seek proc. */
+    NULL,			/* Set option proc. */
+    NULL,			/* Get option proc. */
+    PipeWatchProc,		/* Initialize notifier. */
+    PipeGetHandleProc,		/* Get OS handles out of channel. */
+    NULL,			/* close2proc. */
+    PipeBlockModeProc,		/* Set blocking or non-blocking mode.*/
+    NULL,			/* flush proc. */
+    NULL,			/* handler proc. */
 };

 /*
Author	SHA1	Message	Date
hobbs	693ece84c3	refactored varname pushing code and some of the bytecode instructions	2001-05-15 20:07:38 +00:00
hobbs	951c1014fc	updated tests to not break when someone has a C:/test directory	2001-05-15 20:03:05 +00:00
hobbs	9490b9722c	corrected possible ABR problem	2001-05-15 20:02:28 +00:00
hobbs	0df7bf3a15	updated to TCL_CHANNEL_VERSION_2 spec	2001-05-15 20:01:56 +00:00
hobbs	375dd5eba3	corrected lappend case for non-existent var and list-sensitive data value	2001-05-12 00:01:03 +00:00
hobbs	78c7b79f6e	new byte-compiled commands, Tcl_GetUnicodeFromObj and string comparison changes	2001-05-11 20:47:44 +00:00