From 03bf512eba9ec5dde914e6b2cb171b35cf297b08 Mon Sep 17 00:00:00 2001
From: hobbs <hobbs>
Date: Wed, 14 Nov 2001 23:17:02 +0000
Subject: 	Reference implementation of TIP's #22, #33 and #45.  Adds the 
 ability of the [lindex] command to have multiple index arguments, 	and
 adds the [lset] command.  Both commands are byte-code compiled. 	[Patch
 #471874] (work by Kenny, commited by Hobbs)

---
 ChangeLog             |  40 +++-
 generic/tclBasic.c    |   7 +-
 generic/tclCmdIL.c    | 414 ++++++++++++++++++++++++++++++---
 generic/tclCompCmds.c | 308 ++++++++++++++++++++++--
 generic/tclCompile.c  |  17 +-
 generic/tclCompile.h  |  18 +-
 generic/tclExecute.c  | 235 +++++++++++++++----
 generic/tclInt.decls  |  12 +-
 generic/tclInt.h      |  28 ++-
 generic/tclIntDecls.h |  11 +-
 generic/tclListObj.c  | 630 ++++++++++++++++++++++++++++++++++++++++++++++++--
 generic/tclObj.c      |   3 +-
 generic/tclStubInit.c |   3 +-
 generic/tclTestObj.c  |  15 +-
 generic/tclUtil.c     | 197 ++++++++++++++--
 generic/tclVar.c      |   5 +-
 16 files changed, 1809 insertions(+), 134 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index f5abe98..22dd456 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,41 @@
+2001-10-17  Kevin B. Kenny  <kennykb@users.sourceforge.net>
+
+	* doc/lappend.n:
+	* doc/lindex.n:
+	* doc/linsert.n:
+	* doc/list.n:
+	* doc/llength.n:
+	* doc/lrange.n:
+	* doc/lsearch.n:
+	* doc/lset.n (new-file):
+	* doc/lsort.n:
+	* generic/tclBasic.c (builtInCmds, Tcl_EvalObjEx):
+	* generic/tclCmdIL.c (Tcl_LindexObjCmd, Tcl_LindexList):
+	(Tcl_LindexFlat, Tcl_LsetObjCmd):
+	* generic/tclCompCmds.c (Tcl_CompileLindexCmd, Tcl_CompileLsetCmd):
+	* generic/tclCompile.c:
+	* generic/tclCompile.h:
+	* generic/tclExecute.c (TclExecuteByteCode):
+	* generic/tclInt.decls:
+	* generic/tclInt.h:
+	* generic/tclIntDecls.h:
+	* generic/tclListObj.c (TclLsetList, TclLsetFlat, TclSetListElement):
+	* generic/tclObj.c (TclInitObjSubsystem):
+	* generic/tclStubInit.c:
+	* generic/tclTestObj.c (TestobjCmd):
+	* generic/tclUtil.c (TclGetIntForIndex, SetEndOffsetFromAny):
+	* generic/tclVar.c (Tcl_LappendObjCmd):
+	* tests/lindex.test:
+	* tests/lset.test (new-file):
+	* tests/lsetComp.test (new-file):
+	* tests/obj.test:
+	* tests/string.test:
+	* tests/stringComp.test:
+	Reference implementation of TIP's #22, #33 and #45.  Adds the
+	ability of the [lindex] command to have multiple index arguments,
+	and adds the [lset] command.  Both commands are byte-code compiled.
+	[Patch #471874] (commited by Jeff)
+
 2001-11-12  David Gravereaux <davygrvy@pobox.com>
 
 	* win/buildall.vc.bat(new):
@@ -239,7 +277,7 @@
 
 	* generic/tclIOUtil.c: fix to bug in Tcl_FSChdir shown up
 	by recent tclkit builds.
-	
+
 2001-10-17  Jeff Hobbs  <jeffh@ActiveState.com>
 
 	* unix/tclUnixPipe.c (PipeInputProc, PipeOutputProc): do immediate
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 403d1a1..ce1381e 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -8,11 +8,12 @@
  * Copyright (c) 1987-1994 The Regents of the University of California.
  * Copyright (c) 1994-1997 Sun Microsystems, Inc.
  * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
  *
  * 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.35 2001/09/01 00:51:31 hobbs Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.36 2001/11/14 23:17:03 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -130,6 +131,8 @@ static CmdInfo builtInCmds[] = {
         (CompileProc *) NULL,		1},
     {"lsearch",		(Tcl_CmdProc *) NULL,	Tcl_LsearchObjCmd,
         (CompileProc *) NULL,		1},
+    {"lset",            (Tcl_CmdProc *) NULL,   Tcl_LsetObjCmd,
+        TclCompileLsetCmd,           	1},
     {"lsort",		(Tcl_CmdProc *) NULL,	Tcl_LsortObjCmd,
         (CompileProc *) NULL,		1},
     {"namespace",	(Tcl_CmdProc *) NULL,	Tcl_NamespaceObjCmd,
@@ -2789,7 +2792,7 @@ Tcl_EvalObjEx(interp, objPtr, flags)
 		(objPtr->typePtr == &tclListType) && /* is a list... */
 		(objPtr->bytes == NULL) /* ...without a string rep */) {
 	    register List *listRepPtr =
-		(List *) objPtr->internalRep.otherValuePtr;
+		(List *) objPtr->internalRep.twoPtrValue.ptr1;
 	    result = Tcl_EvalObjv(interp, listRepPtr->elemCount,
 		    listRepPtr->elements, flags);
 	} else {
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index b3461f9..cf8681d 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -10,11 +10,12 @@
  * Copyright (c) 1993-1997 Lucent Technologies.
  * Copyright (c) 1994-1997 Sun Microsystems, Inc.
  * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
  *
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCmdIL.c,v 1.35 2001/10/01 15:31:51 msofer Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.36 2001/11/14 23:17:03 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -2003,61 +2004,334 @@ Tcl_LindexObjCmd(dummy, interp, objc, objv)
     int objc;			/* Number of arguments. */
     Tcl_Obj *CONST objv[];	/* Argument objects. */
 {
-    Tcl_Obj *listPtr;
-    Tcl_Obj **elemPtrs;
-    int listLen, index, result;
 
-    if (objc != 3) {
-	Tcl_WrongNumArgs(interp, 1, objv, "list index");
+    Tcl_Obj *elemPtr;		/* Pointer to the element being extracted */
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?");
 	return TCL_ERROR;
     }
 
     /*
-     * Convert the first argument to a list if necessary.
+     * If objc == 3, then objv[ 2 ] may be either a single index or
+     * a list of indices: go to TclLindexList to determine which.
+     * If objc >= 4, or objc == 2, then objv[ 2 .. objc-2 ] are all
+     * single indices and processed as such in TclLindexFlat.
      */
 
-    listPtr = objv[1];
-    result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
-    if (result != TCL_OK) {
-	return result;
-    }
+    if ( objc == 3 ) {
+
+	elemPtr = TclLindexList( interp, objv[ 1 ], objv[ 2 ] );
+
+    } else {
 
+	elemPtr = TclLindexFlat( interp, objv[ 1 ], objc-2, objv+2 );
+
+    }
+	
     /*
-     * Get the index from objv[2].
+     * Set the interpreter's object result to the last element extracted
      */
 
-    result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
-	    &index);
-    if (result != TCL_OK) {
-	return result;
+    if ( elemPtr == NULL ) {
+	return TCL_ERROR;
+    } else {
+	Tcl_SetObjResult(interp, elemPtr);
+	Tcl_DecrRefCount( elemPtr );
+	return TCL_OK;
     }
-    if ((index < 0) || (index >= listLen)) {
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclLindexList --
+ *
+ *	This procedure handles the 'lindex' command when objc==3.
+ *
+ * Results:
+ *	Returns a pointer to the object extracted, or NULL if an
+ *	error occurred.
+ *
+ * Side effects:
+ *	None.
+ *
+ * If objv[1] can be parsed as a list, TclLindexList handles extraction
+ * of the desired element locally.  Otherwise, it invokes
+ * TclLindexFlat to treat objv[1] as a scalar.
+ *
+ * The reference count of the returned object includes one reference
+ * corresponding to the pointer returned.  Thus, the calling code will
+ * usually do something like:
+ *	Tcl_SetObjResult( interp, result );
+ *	Tcl_DecrRefCount( result );
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclLindexList( interp, listPtr, argPtr )
+    Tcl_Interp* interp;		/* Tcl interpreter */
+    Tcl_Obj* listPtr;		/* List being unpacked */
+    Tcl_Obj* argPtr;		/* Index or index list */
+{
+
+    Tcl_Obj **elemPtrs;		/* Elements of the list being manipulated. */
+    int listLen;		/* Length of the list being manipulated. */
+    int index;			/* Index into the list */
+    int result;			/* Result returned from a Tcl library call */
+    int i;			/* Current index number */
+    Tcl_Obj** indices;		/* Array of list indices */
+    int indexCount;		/* Size of the array of list indices */
+    Tcl_Obj* oldListPtr;	/* Temp location to preserve the list
+				 * pointer when replacing it with a sublist */
+
+    /*
+     * Determine whether argPtr designates a list or a single index.
+     * We have to be careful about the order of the checks to avoid
+     * repeated shimmering; see TIP#22 and TIP#33 for the details.
+     */
+
+    if ( argPtr->typePtr != &tclListType 
+	 && TclGetIntForIndex( NULL , argPtr, 0, &index ) == TCL_OK ) {
+
 	/*
-	 * The index is out of range: the result is an empty string object.
+	 * argPtr designates a single index.
+	 */
+
+	return TclLindexFlat( interp, listPtr, 1, &argPtr );
+
+    } else if ( Tcl_ListObjGetElements( NULL, argPtr, &indexCount, &indices )
+		!= TCL_OK ) {
+
+	/*
+	 * argPtr designates something that is neither an index nor a
+	 * well-formed list.  Report the error via TclLindexFlat.
 	 */
 	
-	return TCL_OK;
+	return TclLindexFlat( interp, listPtr, 1, &argPtr );
     }
 
     /*
-     * Make sure listPtr still refers to a list object. It might have been
-     * converted to an int above if the argument objects were shared.
+     * Record the reference to the list that we are maintaining in
+     * the activation record.
      */
 
-    if (listPtr->typePtr != &tclListType) {
-	result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
-	        &elemPtrs);
+    Tcl_IncrRefCount( listPtr );
+
+    /*
+     * argPtr designates a list, and the 'else if' above has parsed it
+     * into indexCount and indices.
+     */
+
+    for ( i = 0; i < indexCount; ++i ) {
+
+	/*
+	 * Convert the current listPtr to a list if necessary.
+	 */
+	    
+	result = Tcl_ListObjGetElements( interp, listPtr,
+					 &listLen, &elemPtrs);
 	if (result != TCL_OK) {
-	    return result;
+	    Tcl_DecrRefCount( listPtr );
+	    return NULL;
 	}
-    }
+	    
+	/*
+	 * Get the index from indices[ i ]
+	 */
+	
+	result = TclGetIntForIndex( interp, indices[ i ],
+				    /*endValue*/ (listLen - 1),
+				    &index );
+	if ( result != TCL_OK ) {
+	    /*
+	     * Index could not be parsed
+	     */
+
+	    Tcl_DecrRefCount( listPtr );
+	    return NULL;
+
+	} else if ( index < 0
+		    || index >= listLen ) {
+	    /*
+	     * Index is out of range
+	     */
+	    Tcl_DecrRefCount( listPtr );
+	    listPtr = Tcl_NewObj();
+	    Tcl_IncrRefCount( listPtr );
+	    return listPtr;
+	}
+	
+	/*
+	 * Make sure listPtr still refers to a list object.
+	 * If it shared a Tcl_Obj structure with the arguments, then
+	 * it might have just been converted to something else.
+	 */
+	
+	if (listPtr->typePtr != &tclListType) {
+	    result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
+					    &elemPtrs);
+	    if (result != TCL_OK) {
+		Tcl_DecrRefCount( listPtr );
+		return NULL;
+	    }
+	}
+	
+	/*
+	 * Extract the pointer to the appropriate element
+	 */
+	
+	oldListPtr = listPtr;
+	listPtr = elemPtrs[ index ];
+	Tcl_IncrRefCount( listPtr );
+	Tcl_DecrRefCount( oldListPtr );
+	
+	/*
+	 * The work we did above may have caused the internal rep
+	 * of *argPtr to change to something else.  Get it back.
+	 */
+	
+	result = Tcl_ListObjGetElements( interp, argPtr,
+					 &indexCount, &indices );
+	if ( result != TCL_OK ) {
+	    /* 
+	     * This can't happen unless some extension corrupted a Tcl_Obj.
+	     */
+	    Tcl_DecrRefCount( listPtr );
+	    return NULL;
+	}
+	
+    } /* end for */
 
     /*
-     * Set the interpreter's object result to the index-th list element.
+     * Return the last object extracted.  Its reference count will include
+     * the reference being returned.
      */
 
-    Tcl_SetObjResult(interp, elemPtrs[index]);
-    return TCL_OK;
+    return listPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclLindexFlat --
+ *
+ *	This procedure handles the 'lindex' command, given that the
+ *	arguments to the command are known to be a flat list.
+ *
+ * Results:
+ *	Returns a standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ * This procedure is called from either tclExecute.c or
+ * Tcl_LindexObjCmd whenever either is presented with
+ * objc == 2 or objc >= 4.  It is also called from TclLindexList
+ * for the objc==3 case once it is determined that objv[2] cannot
+ * be parsed as a list.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclLindexFlat( interp, listPtr, indexCount, indexArray )
+    Tcl_Interp* interp;		/* Tcl interpreter */
+    Tcl_Obj* listPtr;		/* Tcl object representing the list */
+    int indexCount;		/* Count of indices */
+    Tcl_Obj* CONST indexArray[];
+				/* Array of pointers to Tcl objects
+				 * representing the indices in the
+				 * list */
+{
+
+    int i;			/* Current list index */
+    int result;			/* Result of Tcl library calls */
+    int listLen;		/* Length of the current list being 
+				 * processed */
+    Tcl_Obj** elemPtrs;		/* Array of pointers to the elements
+				 * of the current list */
+    int index;			/* Parsed version of the current element
+				 * of indexArray  */
+    Tcl_Obj* oldListPtr;	/* Temporary to hold listPtr so that
+				 * its ref count can be decremented. */
+
+    /*
+     * Record the reference to the 'listPtr' object that we are
+     * maintaining in the C activation record.
+     */
+
+    Tcl_IncrRefCount( listPtr );
+
+    for ( i = 0; i < indexCount; ++i ) {
+
+	/*
+	 * Convert the current listPtr to a list if necessary.
+	 */
+	
+	result = Tcl_ListObjGetElements(interp, listPtr,
+					&listLen, &elemPtrs);
+	if (result != TCL_OK) {
+	    Tcl_DecrRefCount( listPtr );
+	    return NULL;
+	}
+	
+	/*
+	 * Get the index from objv[i]
+	 */
+	
+	result = TclGetIntForIndex( interp, indexArray[ i ],
+				    /*endValue*/ (listLen - 1),
+				    &index );
+	if ( result != TCL_OK ) {
+
+	    /* Index could not be parsed */
+
+	    Tcl_DecrRefCount( listPtr );
+	    return NULL;
+
+	} else if ( index < 0
+		    || index >= listLen ) {
+	    
+	    /*
+	     * Index is out of range
+	     */
+		
+	    Tcl_DecrRefCount( listPtr );
+	    listPtr = Tcl_NewObj();
+	    Tcl_IncrRefCount( listPtr );
+	    return listPtr;
+	}
+	    
+	/*
+	 * Make sure listPtr still refers to a list object.
+	 * It might have been converted to something else above
+	 * if objv[1] overlaps with one of the other parameters.
+	 */
+	
+	if (listPtr->typePtr != &tclListType) {
+	    result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
+					    &elemPtrs);
+	    if (result != TCL_OK) {
+		Tcl_DecrRefCount( listPtr );
+		return NULL;
+	    }
+	}
+	
+	/*
+	 * Extract the pointer to the appropriate element
+	 */
+	
+	oldListPtr = listPtr;
+	listPtr = elemPtrs[ index ];
+	Tcl_IncrRefCount( listPtr );
+	Tcl_DecrRefCount( oldListPtr );
+	
+    }
+
+    return listPtr;
+
 }
 
 /*
@@ -2721,6 +2995,86 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv)
 /*
  *----------------------------------------------------------------------
  *
+ * Tcl_LsetObjCmd --
+ *
+ *	This procedure is invoked to process the "lset" Tcl command.
+ *	See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_LsetObjCmd( clientData, interp, objc, objv )
+    ClientData clientData;	/* Not used. */
+    Tcl_Interp *interp;		/* Current interpreter. */
+    int objc;			/* Number of arguments. */
+    Tcl_Obj *CONST objv[];	/* Argument values. */
+{
+
+    Tcl_Obj* listPtr;		/* Pointer to the list being altered. */
+    Tcl_Obj* finalValuePtr;	/* Value finally assigned to the variable */
+
+    /* Check parameter count */
+
+    if ( objc < 3 ) {
+	Tcl_WrongNumArgs( interp, 1, objv, "listVar index ?index...? value" );
+	return TCL_ERROR;
+    }
+
+    /* Look up the list variable's value */
+
+    listPtr = Tcl_ObjGetVar2( interp, objv[ 1 ], (Tcl_Obj*) NULL,
+			      TCL_LEAVE_ERR_MSG );
+    if ( listPtr == NULL ) {
+	return TCL_ERROR;
+    }
+
+    /* 
+     * Substitute the value in the value.  Return either the value or
+     * else an unshared copy of it.
+     */
+
+    if ( objc == 4 ) {
+	finalValuePtr = TclLsetList( interp, listPtr,
+				     objv[ 2 ], objv[ 3 ] );
+    } else {
+	finalValuePtr = TclLsetFlat( interp, listPtr,
+				     objc-3, objv+2, objv[ objc-1 ] );
+    }
+
+    /*
+     * If substitution has failed, bail out.
+     */
+
+    if ( finalValuePtr == NULL ) {
+	return TCL_ERROR;
+    }
+
+    /* Finally, update the variable so that traces fire. */
+
+    listPtr = Tcl_ObjSetVar2( interp, objv[1], NULL, finalValuePtr,
+			      TCL_LEAVE_ERR_MSG );
+    Tcl_DecrRefCount( finalValuePtr );
+    if ( listPtr == NULL ) {
+	return TCL_ERROR;
+    }
+
+    /* Return the new value of the variable as the interpreter result. */
+
+    Tcl_SetObjResult( interp, listPtr );
+    return TCL_OK;
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_LsortObjCmd --
  *
  *	This procedure is invoked to process the "lsort" Tcl command.
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 5e24b97..9ea0064 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -5,11 +5,12 @@
  *	Tcl commands into a sequence of instructions ("bytecodes"). 
  *
  * Copyright (c) 1997-1998 Sun Microsystems, Inc.
+ * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
  *
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCompCmds.c,v 1.14 2001/09/19 18:17:54 hobbs Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.15 2001/11/14 23:17:03 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -1822,40 +1823,60 @@ TclCompileLindexCmd(interp, parsePtr, envPtr)
     Tcl_Token *varTokenPtr;
     int code, depth, i;
 
-    if (parsePtr->numWords != 3) {
-	Tcl_SetResult(interp, "wrong # args: should be \"lindex list index\"",
-		TCL_STATIC);
-	return TCL_ERROR;
+    int numWords;
+    numWords = parsePtr->numWords;
+
+    /*
+     * Quit if too few args
+     */
+
+    if ( numWords <= 1 ) {
+	return TCL_OUT_LINE_COMPILE;
     }
+
     varTokenPtr = parsePtr->tokenPtr
 	+ (parsePtr->tokenPtr->numComponents + 1);
-
+    
     depth = 0;
-
+    
     /*
-     * Push the two operands onto the stack.
+     * Push the operands onto the stack.
      */
-
-    for (i = 0; i < 2; i++) {
+	
+    for ( i = 1 ; i < numWords ; i++ ) {
 	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
-	    TclEmitPush(TclRegisterLiteral(envPtr,
-		    varTokenPtr[1].start, varTokenPtr[1].size,
-		    0), envPtr);
+	    TclEmitPush( TclRegisterLiteral( envPtr,
+					     varTokenPtr[1].start,
+					     varTokenPtr[1].size,
+					     0),
+			 envPtr);
 	    depth++;
 	} else {
 	    code = TclCompileTokens(interp, varTokenPtr+1,
-		    varTokenPtr->numComponents, envPtr);
+				    varTokenPtr->numComponents, envPtr);
 	    if (code != TCL_OK) {
+		envPtr->maxStackDepth = depth;
 		return code;
 	    }
 	    depth += envPtr->maxStackDepth;
 	}
 	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
     }
+	
+    /*
+     * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI
+     * if there are multiple index args.
+     */
 
     envPtr->maxStackDepth = depth;
-    TclEmitOpcode(INST_LIST_INDEX, envPtr);
+    if ( numWords == 3 ) {
+	TclEmitOpcode( INST_LIST_INDEX, envPtr );
+    } else {
+	TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-2, envPtr );
+    }
+
     return TCL_OK;
+
 }
 
 /*
@@ -2004,6 +2025,263 @@ TclCompileLlengthCmd(interp, parsePtr, envPtr)
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileLsetCmd --
+ *
+ *	Procedure called to compile the "lset" command.
+ *
+ * Results:
+ *	The return value is a standard Tcl result, which is TCL_OK if
+ *	the compilation was successful.  If the "lset" command is too
+ *	complex for this function, then TCL_OUT_LINE_COMPILE is returned,
+ *	indicating that the command should be compiled "out of line"
+ *	(that is, not byte-compiled).  If an error occurs, TCL_ERROR is
+ *	returned, and the interpreter result contains an error message.
+ *
+ *	envPtr->maxStackDepth is updated with a conservative estimate
+ *	of the number of stack elements needed to execute the command.
+ *
+ * Side effects:
+ *	Instructions are added to envPtr to execute the "lset" command
+ *	at runtime.
+ *
+ * The general template for execution of the "lset" command is:
+ *	(1) Instructions to push the variable name, unless the
+ *	    variable is local to the stack frame.
+ *	(2) If the variable is an array element, instructions
+ *	    to push the array element name.
+ *	(3) Instructions to push each of zero or more "index" arguments
+ *	    to the stack, followed with the "newValue" element.
+ *	(4) Instructions to duplicate the variable name and/or array
+ *	    element name onto the top of the stack, if either was
+ *	    pushed at steps (1) and (2).
+ *	(5) The appropriate INST_LOAD_* instruction to place the
+ *	    original value of the list variable at top of stack.
+ *	(6) At this point, the stack contains:
+ *	     varName? arrayElementName? index1 index2 ... newValue oldList
+ *	    The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
+ *	    according as whether there is exactly one index element (LIST)
+ *	    or either zero or else two or more (FLAT).  This instruction
+ *	    removes everything from the stack except for the two names
+ *	    and pushes the new value of the variable.
+ *	(7) Finally, INST_STORE_* stores the new value in the variable
+ *	    and cleans up the stack.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLsetCmd( interp, parsePtr, envPtr )
+    Tcl_Interp* interp;		/* Tcl interpreter for error reporting */
+    Tcl_Parse* parsePtr;	/* Points to a parse structure for
+				 * the command */
+    CompileEnv* envPtr;		/* Holds the resulting instructions */
+{
+
+    int depth = 0;		/* Current depth of stack */
+    int tempDepth;		/* Depth used for emitting one part
+				 * of the code burst. */
+    int maxDepth = 0;		/* Max depth used anywhere in the
+				 * code burst */
+
+    Tcl_Token* varTokenPtr;	/* Pointer to the Tcl_Token representing
+				 * the parse of the variable name */
+
+    int result;			/* Status return from library calls */
+
+    int localIndex;		/* Index of var in local var table */
+    int simpleVarName;		/* Flag == 1 if var name is simple */
+    int isScalar;		/* Flag == 1 if scalar, 0 if array */
+
+    int i;
+
+    /* Check argument count */
+
+    if ( parsePtr->numWords < 3 ) {
+	/* Fail at run time, not in compilation */
+	return TCL_OUT_LINE_COMPILE;
+    }
+
+    /*
+     * Decide if we can use a frame slot for the var/array name or if we
+     * need to emit code to compute and push the name at runtime. We use a
+     * frame slot (entry in the array of local vars) if we are compiling a
+     * procedure body and if the name is simple text that does not include
+     * namespace qualifiers. 
+     */
+
+    varTokenPtr = parsePtr->tokenPtr
+	    + (parsePtr->tokenPtr->numComponents + 1);
+    tempDepth = 0;
+    result = TclPushVarName( interp, varTokenPtr, envPtr, 0,
+			     &localIndex, &tempDepth,
+			     &simpleVarName, &isScalar );
+    if ( tempDepth > maxDepth ) {
+	maxDepth = tempDepth;
+    }
+    if (result != TCL_OK) {
+	envPtr->maxStackDepth = maxDepth;
+	return result;
+    }
+
+    /* Figure out how much is now on stack. */
+
+    depth = 0;
+    if ( simpleVarName ) {
+	if ( localIndex < 0 ) {
+	    ++depth;		/* We have pushed a variable name. */
+	}
+	if ( !isScalar ) {
+	    ++depth;		/* We have pushed an array element */
+	}
+    } else {
+	++depth;		/* Variable is complex; it's pushed to stack */
+    }
+
+    /* Push the "index" args and the new element value. */
+
+    for ( i = 2; i < parsePtr->numWords; ++i ) {
+
+	/* Advance to next arg */
+
+	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+
+	/* Push an arg */
+
+	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+	    TclEmitPush( TclRegisterLiteral( envPtr,
+					     varTokenPtr[1].start,
+					     varTokenPtr[1].size,
+					     0),
+			 envPtr);
+	    ++depth;
+	    if ( depth > maxDepth ) {
+		maxDepth = depth;
+	    }
+	} else {
+	    envPtr->maxStackDepth = depth;
+	    result = TclCompileTokens(interp, varTokenPtr+1,
+				      varTokenPtr->numComponents, envPtr);
+	    ++depth;
+	    if ( envPtr->maxStackDepth > maxDepth ) {
+		maxDepth = envPtr->maxStackDepth;
+	    }
+	    if ( result != TCL_OK ) {
+		envPtr->maxStackDepth = maxDepth;
+		return result;
+	    }
+	}
+    }
+
+    /*
+     * Duplicate the variable name if it's been pushed.  
+     */
+
+    if ( !simpleVarName || localIndex < 0 ) {
+	if ( !simpleVarName || isScalar ) {
+	    tempDepth = parsePtr->numWords - 2;
+	} else {
+	    tempDepth = parsePtr->numWords - 1;
+	}
+	TclEmitInstInt4( INST_OVER, tempDepth, envPtr );
+	++depth;
+	if ( depth > maxDepth ) {
+	    maxDepth = depth;
+	}
+    }
+
+    /*
+     * Duplicate an array index if one's been pushed
+     */
+
+    if ( simpleVarName && !isScalar ) {
+	if ( localIndex < 0 ) {
+	    tempDepth = parsePtr->numWords - 1;
+	} else {
+	    tempDepth = parsePtr->numWords - 2;
+	}
+	TclEmitInstInt4( INST_OVER, tempDepth, envPtr );
+	++depth;
+	if ( depth > maxDepth ) {
+	    maxDepth = depth;
+	}
+    }
+
+    /*
+     * Emit code to load the variable's value.
+     */
+
+    if ( !simpleVarName ) {
+	TclEmitOpcode( INST_LOAD_STK, envPtr );
+    } else if ( isScalar ) {
+	if ( localIndex < 0 ) {
+	    TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr );
+	} else if ( localIndex < 0x100 ) {
+	    TclEmitInstInt1( INST_LOAD_SCALAR1, localIndex, envPtr );
+	} else {
+	    TclEmitInstInt4( INST_LOAD_SCALAR4, localIndex, envPtr );
+	}
+    } else {
+	if ( localIndex < 0 ) {
+	    TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr );
+	} else if ( localIndex < 0x100 ) {
+	    TclEmitInstInt1( INST_LOAD_ARRAY1, localIndex, envPtr );
+	} else {
+	    TclEmitInstInt4( INST_LOAD_ARRAY4, localIndex, envPtr );
+	}
+    }
+
+    /*
+     * Stack has now reached the maximum depth it will attain
+     * during this code burst.
+     */
+
+    ++depth;
+    if ( depth > maxDepth ) {
+	maxDepth = depth;
+    }
+    envPtr->maxStackDepth = maxDepth;
+
+    /*
+     * Emit the correct variety of 'lset' instruction
+     */
+
+    if ( parsePtr->numWords == 4 ) {
+	TclEmitOpcode( INST_LSET_LIST, envPtr );
+    } else {
+	TclEmitInstInt4( INST_LSET_FLAT, (parsePtr->numWords - 3), envPtr );
+    }
+
+    /*
+     * Emit code to put the value back in the variable
+     */
+
+    if ( !simpleVarName ) {
+	TclEmitOpcode( INST_STORE_STK, envPtr );
+    } else if ( isScalar ) {
+	if ( localIndex < 0 ) {
+	    TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr );
+	} else if ( localIndex < 0x100 ) {
+	    TclEmitInstInt1( INST_STORE_SCALAR1, localIndex, envPtr );
+	} else {
+	    TclEmitInstInt4( INST_STORE_SCALAR4, localIndex, envPtr );
+	}
+    } else {
+	if ( localIndex < 0 ) {
+	    TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr );
+	} else if ( localIndex < 0x100 ) {
+	    TclEmitInstInt1( INST_STORE_ARRAY1, localIndex, envPtr );
+	} else {
+	    TclEmitInstInt4( INST_STORE_ARRAY4, localIndex, envPtr );
+	}
+    }
+    
+    return TCL_OK;
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileReturnCmd --
  *
  *	Procedure called to compile the "return" command.
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 539cb9b..3e71ee7 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -6,11 +6,12 @@
  *	sequence of instructions ("bytecodes"). 
  *
  * Copyright (c) 1996-1998 Sun Microsystems, Inc.
+ * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
  *
  * 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.26 2001/10/15 20:26:57 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.27 2001/11/14 23:17:03 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -254,6 +255,20 @@ InstructionDesc instructionTable[] = {
 	/* Lappend array element; value is stktop, then elem, array names */
     {"lappendStk",	  1,   0,   {OPERAND_NONE}},
 	/* Lappend general variable; value is stktop, then unparsed name */
+    {"lindexMulti",	  5,   1,   {OPERAND_UINT4}},
+        /* Lindex with generalized args, operand is number of indices.
+         * (operand) entries from stktop are the indices; then list to
+         * process. */
+    {"over",		  5,   1,   {OPERAND_UINT4}},
+        /* Duplicate the arg-th element from top of stack (TOS=0) */
+    {"lsetList",          1,   0,   {OPERAND_NONE}},
+        /* Four-arg version of 'lset'. stktop is old value; next is
+         * new element value, next is the index list; pushes new value */
+    {"lsetFlat",          5,   1,   {OPERAND_UINT4}},
+        /* Three- or >=5-arg version of 'lset'. stktop is old value,
+         * next is new element value; next come objc-2 indices; pushes
+	 * the new value.
+	 */
     {0}
 };
 
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index fb922bc..23aa9a6 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -3,11 +3,12 @@
  *
  * Copyright (c) 1996-1998 Sun Microsystems, Inc.
  * Copyright (c) 1998-2000 by Scriptics Corporation.
+ * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
  *
  * 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.17 2001/10/15 20:26:57 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.18 2001/11/14 23:17:03 hobbs Exp $
  */
 
 #ifndef _TCLCOMPILATION
@@ -525,8 +526,21 @@ typedef struct ByteCode {
 #define INST_LAPPEND_ARRAY_STK		92
 #define INST_LAPPEND_STK		93
 
+/* TIP #22 - LINDEX operator with flat arg list */
+
+#define INST_LIST_INDEX_MULTI		94
+
+/*
+ * TIP #33 - 'lset' command.  Code gen also required a Forth-like
+ *           OVER operation.
+ */
+
+#define INST_OVER                       95
+#define INST_LSET_LIST			96
+#define INST_LSET_FLAT                  97
+
 /* The last opcode */
-#define LAST_INST_OPCODE        	93
+#define LAST_INST_OPCODE        	97
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 97a1da2..5eec236 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -6,11 +6,12 @@
  *
  * Copyright (c) 1996-1997 Sun Microsystems, Inc.
  * Copyright (c) 1998-2000 by Scriptics Corporation.
+ * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
  *
  * 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.34 2001/09/21 19:09:03 hobbs Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.35 2001/11/14 23:17:03 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -678,6 +679,13 @@ TclExecuteByteCode(interp, codePtr)
 	    TRACE_WITH_OBJ(("=> "), valuePtr);
 	    ADJUST_PC(1);
 
+	case INST_OVER:
+	    opnd = TclGetUInt4AtPtr( pc+1 );
+	    valuePtr = stackPtr[ stackTop - opnd ];
+	    PUSH_OBJECT( valuePtr );
+	    TRACE_WITH_OBJ(("=> "), valuePtr);
+	    ADJUST_PC( 5 );
+
 	case INST_CONCAT1:
 	    opnd = TclGetUInt1AtPtr(pc+1);
 	    {
@@ -2013,62 +2021,201 @@ TclExecuteByteCode(interp, codePtr)
 	    
 	case INST_LIST_INDEX:
 	    {
-		Tcl_Obj **elemPtrs;
-		int index;
+
+		/*** lindex with objc == 3 ***/
+		
+		/* Pop the two operands */
 
 		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);
+		/* Extract the desired list element */
+
+		objPtr = TclLindexList( interp, valuePtr, value2Ptr );
+		if ( objPtr == NULL ) {
+		    TRACE_WITH_OBJ( ( "%.30s %.30s => ERROR: ",
+				      O2S( valuePtr ),
+				      O2S( value2Ptr ) ),
+				    Tcl_GetObjResult( interp ) );
+		    TclDecrRefCount( value2Ptr );
+		    TclDecrRefCount( valuePtr );
+		    result = TCL_ERROR;
 		    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);
+		/* Stash the list element on the stack */
+
+		PUSH_OBJECT( objPtr );
+		TRACE(( "%.20s %.20s => %s\n",
+			O2S( valuePtr ),
+			O2S( value2Ptr ),
+			O2S( objPtr ) ) );
+		TclDecrRefCount( valuePtr );
+		TclDecrRefCount( value2Ptr );
+		TclDecrRefCount( objPtr );
+	    }
+
+	    ADJUST_PC( 1 );
+
+	case INST_LIST_INDEX_MULTI:
+	    {
+
+		/*
+		 * 'lindex' with multiple index args:
+		 *
+		 * Determine the count of index args.
+		 */
+
+		opnd = TclGetUInt4AtPtr(pc+1);
+		
+		/*
+		 * Do the 'lindex' operation.
+		 */
+
+		objPtr = TclLindexFlat( interp,
+					stackPtr[ stackTop - opnd ],
+					opnd,
+					stackPtr + stackTop - opnd + 1 );
+		/* 
+		 * Clean up ref counts
+		 */
+		
+		for ( i = 0 ; i <= opnd ; i++ ) {
+		    Tcl_DecrRefCount( stackPtr[ stackTop -- ] );
+		}
+
+		/*
+		 * Check for errors
+		 */
+
+		if ( objPtr == NULL ) {
+		    TRACE_WITH_OBJ( ( "%d => ERROR: ", opnd ),
+				    Tcl_GetObjResult( interp ) );
+		    result = TCL_ERROR;
 		    goto checkForCatch;
 		}
+		
+		/*
+		 * Set result
+		 */
 
-		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.
-		     */
+		PUSH_OBJECT( objPtr );
+		TRACE(( "%d => %s\n", opnd, O2S( objPtr ) ));
+		Tcl_DecrRefCount( objPtr );
+	    
+	    }
+	    ADJUST_PC( 5 );
 
-		    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];
+	case INST_LSET_FLAT:
+	    {
+		/*
+		 * Lset with 3, 5, or more args.  Get the number of index args.
+		 */
+
+		opnd = TclGetUInt4AtPtr( pc + 1 );
+
+		/*
+		 * Get the old value of variable, and remove the stack ref.
+		 * This is safe because the variable still references the
+		 * object; the ref count will never go zero here.
+		 */
+
+		value2Ptr = POP_OBJECT();
+		Tcl_DecrRefCount( value2Ptr );
+
+		/*
+		 * Get the new element value.
+		 */
+
+		valuePtr = POP_OBJECT();
+
+		/*
+		 * Compute the new variable value
+		 */
+
+		objPtr = TclLsetFlat( interp, value2Ptr, opnd,
+				      stackPtr + stackTop - opnd + 1,
+				      valuePtr );
+		Tcl_DecrRefCount( valuePtr );
+
+		/* 
+		 * Clean up ref counts
+		 */
+		
+		for ( i = 0 ; i < opnd ; i++ ) {
+		    Tcl_DecrRefCount( stackPtr[ stackTop -- ] );
 		}
 
-		PUSH_OBJECT(objPtr);
-		TRACE(("%.20s %.20s => %s\n",
-			O2S(valuePtr), O2S(value2Ptr), O2S(objPtr)));
-		TclDecrRefCount(valuePtr);
-		TclDecrRefCount(value2Ptr);
+		/*
+		 * Check for errors
+		 */
+
+		if ( objPtr == NULL ) {
+		    TRACE_WITH_OBJ( ( "%d => ERROR: ", opnd ),
+				    Tcl_GetObjResult( interp ) );
+		    result = TCL_ERROR;
+		    goto checkForCatch;
+		}
+		
+		/*
+		 * Set result
+		 */
+
+		PUSH_OBJECT( objPtr );
+		TRACE(( "%d => %s\n", opnd, O2S( objPtr ) ));
+		Tcl_DecrRefCount( objPtr );
+	    
 	    }
-	    ADJUST_PC(1);
+	    ADJUST_PC( 5 );
+
+	case INST_LSET_LIST:
+	    {
+		/*
+		 * 'lset' with 4 args.
+		 *
+		 * Get the old value of variable, and remove the stack ref.
+		 * This is safe because the variable still references the
+		 * object; the ref count will never go zero here.
+		 */
+
+		objPtr = POP_OBJECT();
+		Tcl_DecrRefCount( objPtr );
+
+		/*
+		 * Get the new element value, and the index list
+		 */
+
+		valuePtr = POP_OBJECT();
+		value2Ptr = POP_OBJECT();
+
+		/*
+		 * Compute the new variable value
+		 */
+
+		objPtr = TclLsetList( interp, objPtr, value2Ptr, valuePtr );
+		Tcl_DecrRefCount( valuePtr );
+		Tcl_DecrRefCount( value2Ptr );
+
+		/*
+		 * Check for errors
+		 */
+
+		if ( objPtr == NULL ) {
+		    TRACE_WITH_OBJ( ( "%d => ERROR: ", opnd ),
+				    Tcl_GetObjResult( interp ) );
+		    result = TCL_ERROR;
+		    goto checkForCatch;
+		}
+		
+		/*
+		 * Set result
+		 */
+
+		PUSH_OBJECT( objPtr );
+		TRACE(( "%d => %s\n", opnd, O2S( objPtr ) ));
+		Tcl_DecrRefCount( objPtr );
+	    }
+	    ADJUST_PC( 1 );
 
 	case INST_STR_EQ:
 	case INST_STR_NEQ:
@@ -3321,7 +3468,7 @@ TclExecuteByteCode(interp, codePtr)
 
 			listVarPtr = &(compiledLocals[listTmpIndex]);
 			listPtr = listVarPtr->value.objPtr;
-			listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
+			listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
 			listLen = listRepPtr->elemCount;
 			
 			valIndex = (iterNum * numVars);
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index c7aaa0a..815b88c 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -7,10 +7,12 @@
 #	files
 #
 # Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
+#
 # 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.35 2001/10/15 20:26:57 andreas_kupries Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.36 2001/11/14 23:17:03 hobbs Exp $
 
 library tcl
 
@@ -647,6 +649,14 @@ declare 165 generic {
     void TclpSetInitialEncodings(void)
 }
 
+# New function due to TIP #33
+declare 166 generic {
+    int TclListObjSetElement( Tcl_Interp* interp,
+                               Tcl_Obj* listPtr, 
+                               int index,
+                               Tcl_Obj* valuePtr   )
+}
+
 ##############################################################################
 
 # Define the platform specific internal Tcl interface. These functions are
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 8e60370..ba3fa91 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -7,11 +7,12 @@
  * Copyright (c) 1993-1997 Lucent Technologies.
  * Copyright (c) 1994-1998 Sun Microsystems, Inc.
  * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
  *
  * 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.68 2001/09/28 01:21:53 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.69 2001/11/14 23:17:03 hobbs Exp $
  */
 
 #ifndef _TCLINT
@@ -1565,6 +1566,7 @@ extern Tcl_ObjType	tclBooleanType;
 extern Tcl_ObjType	tclByteArrayType;
 extern Tcl_ObjType	tclByteCodeType;
 extern Tcl_ObjType	tclDoubleType;
+extern Tcl_ObjType	tclEndOffsetType;
 extern Tcl_ObjType	tclIntType;
 extern Tcl_ObjType	tclListType;
 extern Tcl_ObjType	tclProcBodyType;
@@ -1742,6 +1744,25 @@ EXTERN int		TclIsLocalScalar _ANSI_ARGS_((CONST char *src,
 EXTERN Proc *		TclIsProc _ANSI_ARGS_((Command *cmdPtr));
 EXTERN int              TclJoinThread _ANSI_ARGS_((Tcl_ThreadId id,
 			    int* result));
+EXTERN Tcl_Obj *	TclLindexList _ANSI_ARGS_((Tcl_Interp* interp,
+						   Tcl_Obj* listPtr,
+						   Tcl_Obj* argPtr ));
+EXTERN Tcl_Obj *	TclLindexFlat _ANSI_ARGS_((Tcl_Interp* interp,
+						   Tcl_Obj* listPtr,
+						   int indexCount,
+						   Tcl_Obj *CONST indexArray[]
+						   ));
+EXTERN Tcl_Obj *	TclLsetList _ANSI_ARGS_((Tcl_Interp* interp,
+						 Tcl_Obj* listPtr,
+						 Tcl_Obj* indexPtr,
+						 Tcl_Obj* valuePtr  
+						 ));
+EXTERN Tcl_Obj *	TclLsetFlat _ANSI_ARGS_((Tcl_Interp* interp,
+						 Tcl_Obj* listPtr,
+						 int indexCount,
+						 Tcl_Obj *CONST indexArray[],
+						 Tcl_Obj* valuePtr
+						 ));
 EXTERN int		TclMathInProgress _ANSI_ARGS_((void));
 EXTERN Tcl_Obj *	TclNewProcBodyObj _ANSI_ARGS_((Proc *procPtr));
 EXTERN int		TclObjCommandComplete _ANSI_ARGS_((Tcl_Obj *cmdPtr));
@@ -1989,6 +2010,8 @@ EXTERN int	Tcl_LreplaceObjCmd _ANSI_ARGS_((ClientData clientData,
 		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
 EXTERN int	Tcl_LsearchObjCmd _ANSI_ARGS_((ClientData clientData,
 		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int	Tcl_LsetObjCmd _ANSI_ARGS_((ClientData clientData,
+                    Tcl_Interp* interp, int objc, Tcl_Obj *CONST objv[]));
 EXTERN int	Tcl_LsortObjCmd _ANSI_ARGS_((ClientData clientData,
 		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
 EXTERN int	Tcl_NamespaceObjCmd _ANSI_ARGS_((ClientData clientData,
@@ -2103,6 +2126,9 @@ EXTERN int	TclCompileListCmd _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	TclCompileLsetCmd _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,
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 99b8909..5e36ba9 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclIntDecls.h,v 1.30 2001/10/15 20:26:57 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.31 2001/11/14 23:17:03 hobbs Exp $
  */
 
 #ifndef _TCLINTDECLS
@@ -493,6 +493,10 @@ EXTERN void *		TclGetInstructionTable _ANSI_ARGS_((void));
 EXTERN void		TclExpandCodeArray _ANSI_ARGS_((void * envPtr));
 /* 165 */
 EXTERN void		TclpSetInitialEncodings _ANSI_ARGS_((void));
+/* 166 */
+EXTERN int		TclListObjSetElement _ANSI_ARGS_((Tcl_Interp* interp, 
+				Tcl_Obj* listPtr, int index, 
+				Tcl_Obj* valuePtr));
 
 typedef struct TclIntStubs {
     int magic;
@@ -696,6 +700,7 @@ typedef struct TclIntStubs {
     void * (*tclGetInstructionTable) _ANSI_ARGS_((void)); /* 163 */
     void (*tclExpandCodeArray) _ANSI_ARGS_((void * envPtr)); /* 164 */
     void (*tclpSetInitialEncodings) _ANSI_ARGS_((void)); /* 165 */
+    int (*tclListObjSetElement) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* listPtr, int index, Tcl_Obj* valuePtr)); /* 166 */
 } TclIntStubs;
 
 #ifdef __cplusplus
@@ -1300,6 +1305,10 @@ extern TclIntStubs *tclIntStubsPtr;
 #define TclpSetInitialEncodings \
 	(tclIntStubsPtr->tclpSetInitialEncodings) /* 165 */
 #endif
+#ifndef TclListObjSetElement
+#define TclListObjSetElement \
+	(tclIntStubsPtr->tclListObjSetElement) /* 166 */
+#endif
 
 #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
 
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index fabe581..39f45d4 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -6,11 +6,12 @@
  *
  * Copyright (c) 1995-1997 Sun Microsystems, Inc.
  * Copyright (c) 1998 by Scriptics Corporation.
+ * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
  *
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclListObj.c,v 1.9 2001/04/04 16:07:21 kennykb Exp $
+ * RCS: @(#) $Id: tclListObj.c,v 1.10 2001/11/14 23:17:03 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -29,6 +30,15 @@ static void		UpdateStringOfList _ANSI_ARGS_((Tcl_Obj *listPtr));
 /*
  * The structure below defines the list Tcl object type by means of
  * procedures that can be invoked by generic object code.
+ *
+ * The internal representation of a list object is a two-pointer
+ * representation.  The first pointer designates a List structure that
+ * contains an array of pointers to the element objects, together with
+ * integers that represent the current element count and the allocated
+ * size of the array.  The second pointer is normally NULL; during
+ * execution of functions in this file that operate on nested sublists,
+ * it is occasionally used as working storage to avoid an auxiliary
+ * stack.
  */
 
 Tcl_ObjType tclListType = {
@@ -105,7 +115,8 @@ Tcl_NewListObj(objc, objv)
 	listRepPtr->elemCount    = objc;
 	listRepPtr->elements     = elemPtrs;
 	
-	listPtr->internalRep.otherValuePtr = (VOID *) listRepPtr;
+	listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
+	listPtr->internalRep.twoPtrValue.ptr2 = NULL;
 	listPtr->typePtr = &tclListType;
     }
     return listPtr;
@@ -174,7 +185,8 @@ Tcl_DbNewListObj(objc, objv, file, line)
 	listRepPtr->elemCount    = objc;
 	listRepPtr->elements     = elemPtrs;
 	
-	listPtr->internalRep.otherValuePtr = (VOID *) listRepPtr;
+	listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
+	listPtr->internalRep.twoPtrValue.ptr2 = NULL;
 	listPtr->typePtr = &tclListType;
     }
     return listPtr;
@@ -261,7 +273,8 @@ Tcl_SetListObj(objPtr, objc, objv)
 	listRepPtr->elemCount    = objc;
 	listRepPtr->elements     = elemPtrs;
 	
-	objPtr->internalRep.otherValuePtr = (VOID *) listRepPtr;
+	objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
+	objPtr->internalRep.twoPtrValue.ptr2 = NULL;
 	objPtr->typePtr = &tclListType;
     } else {
 	objPtr->bytes = tclEmptyStringRep;
@@ -317,7 +330,7 @@ Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr)
 	    return result;
 	}
     }
-    listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
+    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
     *objcPtr = listRepPtr->elemCount;
     *objvPtr = listRepPtr->elements;
     return TCL_OK;
@@ -368,7 +381,7 @@ Tcl_ListObjAppendList(interp, listPtr, elemListPtr)
 	    return result;
 	}
     }
-    listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
+    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
     listLen = listRepPtr->elemCount;
 
     result = Tcl_ListObjGetElements(interp, elemListPtr, &objc, &objv);
@@ -431,7 +444,7 @@ Tcl_ListObjAppendElement(interp, listPtr, objPtr)
 	}
     }
 
-    listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
+    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
     elemPtrs = listRepPtr->elements;
     numElems = listRepPtr->elemCount;
     numRequired = numElems + 1 ;
@@ -515,7 +528,7 @@ Tcl_ListObjIndex(interp, listPtr, index, objPtrPtr)
 	}
     }
 
-    listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
+    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
     if ((index < 0) || (index >= listRepPtr->elemCount)) {
 	*objPtrPtr = NULL;
     } else {
@@ -562,7 +575,7 @@ Tcl_ListObjLength(interp, listPtr, intPtr)
 	}
     }
 
-    listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
+    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
     *intPtr = listRepPtr->elemCount;
     return TCL_OK;
 }
@@ -630,7 +643,7 @@ Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv)
 	    return result;
 	}
     }
-    listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
+    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
     elemPtrs = listRepPtr->elements;
     numElems = listRepPtr->elemCount;
 
@@ -763,6 +776,586 @@ Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv)
 /*
  *----------------------------------------------------------------------
  *
+ * TclLsetList --
+ *	
+ *	Core of the 'lset' command when objc == 4.  Objv[2] may be
+ *	either a scalar index or a list of indices.
+ *
+ * Results:
+ *	Returns the new value of the list variable, or NULL if an
+ *	error occurs.
+ *
+ * Side effects:
+ *	Surgery is performed on the list value to produce the
+ *	result.
+ *
+ * On entry, the reference count of the variable value does not reflect
+ * any references held on the stack.  The first action of this function
+ * is to determine whether the object is shared, and to duplicate it if
+ * it is.  The reference count of the duplicate is incremented.
+ * At this point, the reference count will be 1 for either case, so that
+ * the object will appear to be unshared.
+ *
+ * If an error occurs, and the object has been duplicated, the reference
+ * count on the duplicate is decremented so that it is now 0: this dismisses
+ * any memory that was allocated by this procedure.
+ *
+ * If no error occurs, the reference count of the original object is
+ * incremented if the object has not been duplicated, and nothing is
+ * done to a reference count of the duplicate.  Now the reference count
+ * of an unduplicated object is 2 (the returned pointer, plus the one
+ * stored in the variable).  The reference count of a duplicate object
+ * is 1, reflecting that the returned pointer is the only active
+ * reference.  The caller is expected to store the returned value back
+ * in the variable and decrement its reference count.  (INST_STORE_*
+ * does exactly this.)
+ *
+ * Tcl_LsetFlat and related functions maintain a linked list of
+ * Tcl_Obj's whose string representations must be spoilt by threading
+ * via 'ptr2' of the two-pointer internal representation.  On entry
+ * to Tcl_LsetList, the values of 'ptr2' are immaterial; on exit,
+ * the 'ptr2' field of any Tcl_Obj that has been modified is set to
+ * NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+TclLsetList( interp, listPtr, indexArgPtr, valuePtr )
+    Tcl_Interp* interp;		/* Tcl interpreter */
+    Tcl_Obj* listPtr;		/* Pointer to the list being modified */
+    Tcl_Obj* indexArgPtr;	/* Index or index-list arg to 'lset' */
+    Tcl_Obj* valuePtr;		/* Value arg to 'lset' */
+{
+    int indexCount;		/* Number of indices in the index list */
+    Tcl_Obj** indices;		/* Vector of indices in the index list*/
+
+    int duplicated;		/* Flag == 1 if the obj has been
+				 * duplicated, 0 otherwise */
+    Tcl_Obj* retValuePtr;	/* Pointer to the list to be returned */
+    int index;			/* Current index in the list - discarded */
+    int result;			/* Status return from library calls */
+    Tcl_Obj* subListPtr;	/* Pointer to the current sublist */
+    int elemCount;		/* Count of elements in the current sublist */
+    Tcl_Obj** elemPtrs;		/* Pointers to elements of current sublist  */
+    Tcl_Obj* chainPtr;		/* Pointer to the enclosing sublist
+				 * of the current sublist */
+    int i;
+
+
+    /*
+     * Determine whether the index arg designates a list or a single
+     * index.  We have to be careful about the order of the checks to
+     * avoid repeated shimmering; see TIP #22 and #23 for details.
+     */
+
+    if ( indexArgPtr->typePtr != &tclListType
+	 && TclGetIntForIndex( NULL, indexArgPtr, 0, &index ) == TCL_OK ) {
+
+	/*
+	 * indexArgPtr designates a single index.
+	 */
+
+	return TclLsetFlat( interp, listPtr, 1, &indexArgPtr, valuePtr );
+
+    } else if ( Tcl_ListObjGetElements( NULL, indexArgPtr,
+					&indexCount, &indices ) != TCL_OK ) {
+
+	/*
+	 * indexArgPtr designates something that is neither an index nor a
+	 * well formed list.  Report the error via TclLsetFlat.
+	 */
+
+	return TclLsetFlat( interp, listPtr, 1, &indexArgPtr, valuePtr );
+
+    }
+
+    /*
+     * At this point, we know that argPtr designates a well formed list,
+     * and the 'else if' above has parsed it into indexCount and indices.
+     * If there are no indices, simply return 'valuePtr', counting the
+     * returned pointer as a reference.
+     */
+
+    if ( indexCount == 0 ) {
+	Tcl_IncrRefCount( valuePtr );
+	return valuePtr;
+    }
+
+    /*
+     * Duplicate the list arg if necessary.
+     */
+
+    if ( Tcl_IsShared( listPtr ) ) {
+	duplicated = 1;
+	listPtr = Tcl_DuplicateObj( listPtr );
+	Tcl_IncrRefCount( listPtr );
+    } else {
+	duplicated = 0;
+    }
+
+    /*
+     * It would be tempting simply to go off to TclLsetFlat to finish the
+     * processing.  Alas, it is also incorrect!  The problem is that
+     * 'indexArgPtr' may designate a sublist of 'listPtr' whose value
+     * is to be manipulated.  The fact that 'listPtr' is itself unshared
+     * does not guarantee that no sublist is.  Therefore, it's necessary
+     * to replicate all the work here, expanding the index list on each
+     * trip through the loop.
+     */
+
+    /*
+     * Anchor the linked list of Tcl_Obj's whose string reps must be
+     * invalidated if the operation succeeds.
+     */
+
+    retValuePtr = listPtr;
+    chainPtr = NULL;
+
+    /*
+     * Handle each index arg by diving into the appropriate sublist
+     */
+
+    for ( i = 0; ; ++i ) {
+
+	/*
+	 * Take the sublist apart.
+	 */
+
+	result = Tcl_ListObjGetElements( interp, listPtr,
+					 &elemCount, &elemPtrs );
+	if ( result != TCL_OK ) {
+	    break;
+	}
+	listPtr->internalRep.twoPtrValue.ptr2 = chainPtr;
+
+	/*
+	 * Reconstitute the index array
+	 */
+
+	result = Tcl_ListObjGetElements( interp, indexArgPtr,
+					 &indexCount, &indices );
+	if ( result != TCL_OK ) {
+	    /* 
+	     * Shouldn't be able to get here, because we already
+	     * parsed the thing successfully once.
+	     */
+	    break;
+	}
+
+	/*
+	 * Determine the index of the requested element.
+	 */
+
+	result = TclGetIntForIndex( interp, indices[ i ],
+				    (elemCount - 1), &index );
+	if ( result != TCL_OK ) {
+	    break;
+	}
+	
+	/*
+	 * Check that the index is in range.
+	 */
+
+	if ( ( index < 0 ) || ( index >= elemCount ) ) {
+	    Tcl_SetObjResult( interp,
+			      Tcl_NewStringObj( "list index out of range",
+						-1 ) );
+	    result = TCL_ERROR;
+	    break;
+	}
+
+	/*
+	 * Break the loop after extracting the innermost sublist
+	 */
+
+	if ( i >= indexCount-1 ) {
+	    result = TCL_OK;
+	    break;
+	}
+	
+	/*
+	 * Extract the appropriate sublist, and make sure that it is unshared.
+	 */
+
+	subListPtr = elemPtrs[ index ];
+	if ( Tcl_IsShared( subListPtr ) ) {
+	    subListPtr = Tcl_DuplicateObj( subListPtr );
+	    result = TclListObjSetElement( interp, listPtr, index,
+					    subListPtr );
+	    if ( result != TCL_OK ) {
+		/* 
+		 * We actually shouldn't be able to get here, because
+		 * we've already checked everything that TclListObjSetElement
+		 * checks. If we were to get here, it would result in leaking
+		 * subListPtr.
+		 */
+		break;
+	    }
+	}
+
+	/* 
+	 * Chain the current sublist onto the linked list of Tcl_Obj's
+	 * whose string reps must be spoilt.
+	 */
+
+	chainPtr = listPtr;
+	listPtr = subListPtr;
+
+    }
+
+    /*
+     * Store the new element into the correct slot in the innermost sublist.
+     */
+
+    if ( result == TCL_OK ) {
+	result = TclListObjSetElement( interp, listPtr, index, valuePtr );
+    }
+
+    if ( result == TCL_OK ) {
+
+	listPtr->internalRep.twoPtrValue.ptr2 = chainPtr;
+
+	/* Spoil all the string reps */
+	
+	while ( listPtr != NULL ) {
+	    subListPtr = listPtr->internalRep.twoPtrValue.ptr2;
+	    Tcl_InvalidateStringRep( listPtr );
+	    listPtr->internalRep.twoPtrValue.ptr2 = NULL;
+	    listPtr = subListPtr;
+	}
+
+	/* Return the new list if everything worked. */
+	
+	if ( !duplicated ) {
+	    Tcl_IncrRefCount( retValuePtr );
+	}
+	return retValuePtr;
+    }
+
+    /* Clean up the one dangling reference otherwise */
+
+    if ( duplicated ) {
+	Tcl_DecrRefCount( retValuePtr );
+    }
+    return NULL;
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclLsetFlat --
+ *
+ *	Core of the 'lset' command when objc>=5.  Objv[2], ... ,
+ *	objv[objc-2] contain scalar indices.
+ *
+ * Results:
+ *	Returns the new value of the list variable, or NULL if an
+ *	error occurs.
+ *
+ * Side effects:
+ *	Surgery is performed on the list value to produce the
+ *	result.
+ *
+ * On entry, the reference count of the variable value does not reflect
+ * any references held on the stack.  The first action of this function
+ * is to determine whether the object is shared, and to duplicate it if
+ * it is.  The reference count of the duplicate is incremented.
+ * At this point, the reference count will be 1 for either case, so that
+ * the object will appear to be unshared.
+ *
+ * If an error occurs, and the object has been duplicated, the reference
+ * count on the duplicate is decremented so that it is now 0: this dismisses
+ * any memory that was allocated by this procedure.
+ *
+ * If no error occurs, the reference count of the original object is
+ * incremented if the object has not been duplicated, and nothing is
+ * done to a reference count of the duplicate.  Now the reference count
+ * of an unduplicated object is 2 (the returned pointer, plus the one
+ * stored in the variable).  The reference count of a duplicate object
+ * is 1, reflecting that the returned pointer is the only active
+ * reference.  The caller is expected to store the returned value back
+ * in the variable and decrement its reference count.  (INST_STORE_*
+ * does exactly this.)
+ *
+ * Tcl_LsetList and related functions maintain a linked list of
+ * Tcl_Obj's whose string representations must be spoilt by threading
+ * via 'ptr2' of the two-pointer internal representation.  On entry
+ * to Tcl_LsetList, the values of 'ptr2' are immaterial; on exit,
+ * the 'ptr2' field of any Tcl_Obj that has been modified is set to
+ * NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+TclLsetFlat( interp, listPtr, indexCount, indexArray, valuePtr )
+    Tcl_Interp* interp;		/* Tcl interpreter */
+    Tcl_Obj* listPtr;		/* Pointer to the list being modified */
+    int indexCount;		/* Number of index args */
+    Tcl_Obj *CONST indexArray[];
+				/* Index args */
+    Tcl_Obj* valuePtr;		/* Value arg to 'lset' */
+{
+
+    int duplicated;		/* Flag == 1 if the obj has been
+				 * duplicated, 0 otherwise */
+    Tcl_Obj* retValuePtr;	/* Pointer to the list to be returned */
+
+    int elemCount;		/* Length of one sublist being changed */
+    Tcl_Obj** elemPtrs;		/* Pointers to the elements of a sublist */
+
+    Tcl_Obj* subListPtr;	/* Pointer to the current sublist */
+
+    int index;			/* Index of the element to replace in the
+				 * current sublist */
+    Tcl_Obj* chainPtr;		/* Pointer to the enclosing list of
+				 * the current sublist. */
+
+    int result;			/* Status return from library calls */
+
+
+
+    int i;
+
+    /*
+     * If there are no indices, then simply return the new value,
+     * counting the returned pointer as a reference
+     */
+
+    if ( indexCount == 0 ) {
+	Tcl_IncrRefCount( valuePtr );
+	return valuePtr;
+    }
+
+    /*
+     * If the list is shared, make a private copy.
+     */
+
+    if ( Tcl_IsShared( listPtr ) ) {
+	duplicated = 1;
+	listPtr = Tcl_DuplicateObj( listPtr );
+	Tcl_IncrRefCount( listPtr );
+    } else {
+	duplicated = 0;
+    }
+
+    /*
+     * Anchor the linked list of Tcl_Obj's whose string reps must be
+     * invalidated if the operation succeeds.
+     */
+
+    retValuePtr = listPtr;
+    chainPtr = NULL;
+
+    /*
+     * Handle each index arg by diving into the appropriate sublist
+     */
+
+    for ( i = 0; ; ++i ) {
+
+	/*
+	 * Take the sublist apart.
+	 */
+
+	result = Tcl_ListObjGetElements( interp, listPtr,
+					 &elemCount, &elemPtrs );
+	if ( result != TCL_OK ) {
+	    break;
+	}
+	listPtr->internalRep.twoPtrValue.ptr2 = chainPtr;
+
+	/*
+	 * Determine the index of the requested element.
+	 */
+
+	result = TclGetIntForIndex( interp, indexArray[ i ],
+				    (elemCount - 1), &index );
+	if ( result != TCL_OK ) {
+	    break;
+	}
+	
+	/*
+	 * Check that the index is in range.
+	 */
+
+	if ( ( index < 0 ) || ( index >= elemCount ) ) {
+	    Tcl_SetObjResult( interp,
+			      Tcl_NewStringObj( "list index out of range",
+						-1 ) );
+	    result = TCL_ERROR;
+	    break;
+	}
+
+	/*
+	 * Break the loop after extracting the innermost sublist
+	 */
+
+	if ( i >= indexCount-1 ) {
+	    result = TCL_OK;
+	    break;
+	}
+	
+	/*
+	 * Extract the appropriate sublist, and make sure that it is unshared.
+	 */
+
+	subListPtr = elemPtrs[ index ];
+	if ( Tcl_IsShared( subListPtr ) ) {
+	    subListPtr = Tcl_DuplicateObj( subListPtr );
+	    result = TclListObjSetElement( interp, listPtr, index,
+					    subListPtr );
+	    if ( result != TCL_OK ) {
+		/* 
+		 * We actually shouldn't be able to get here.
+		 * If we do, it would result in leaking subListPtr,
+		 * but everything's been validated already; the error
+		 * exit from TclListObjSetElement should never happen.
+		 */
+		break;
+	    }
+	}
+
+	/* 
+	 * Chain the current sublist onto the linked list of Tcl_Obj's
+	 * whose string reps must be spoilt.
+	 */
+
+	chainPtr = listPtr;
+	listPtr = subListPtr;
+
+    }
+
+    /* Store the result in the list element */
+
+    if ( result == TCL_OK ) {
+	result = TclListObjSetElement( interp, listPtr, index, valuePtr );
+    }
+
+    if ( result == TCL_OK ) {
+
+	listPtr->internalRep.twoPtrValue.ptr2 = chainPtr;
+
+	/* Spoil all the string reps */
+	
+	while ( listPtr != NULL ) {
+	    subListPtr = listPtr->internalRep.twoPtrValue.ptr2;
+	    Tcl_InvalidateStringRep( listPtr );
+	    listPtr->internalRep.twoPtrValue.ptr2 = NULL;
+	    listPtr = subListPtr;
+	}
+
+	/* Return the new list if everything worked. */
+	
+	if ( !duplicated ) {
+	    Tcl_IncrRefCount( retValuePtr );
+	}
+	return retValuePtr;
+    }
+
+    /* Clean up the one dangling reference otherwise */
+
+    if ( duplicated ) {
+	Tcl_DecrRefCount( retValuePtr );
+    }
+    return NULL;
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclListObjSetElement --
+ *
+ *	Set a single element of a list to a specified value
+ *
+ * Results:
+ *
+ *	The return value is normally TCL_OK.  If listPtr does not
+ *	refer to a list object and cannot be converted to one, TCL_ERROR
+ *	is returned and an error message will be left in the interpreter
+ *	result if interp is not NULL.  Similarly, if index designates
+ *	an element outside the range [0..listLength-1], where
+ *	listLength is the count of elements in the list object designated
+ *	by listPtr, TCL_ERROR is returned and an error message is left
+ *	in the interpreter result.
+ *
+ * Side effects:
+ *
+ *	Panics if listPtr designates a shared object.  Otherwise, attempts
+ *	to convert it to a list.  Decrements the ref count of the object
+ *	at the specified index within the list, replaces with the
+ *	object designated by valuePtr, and increments the ref count
+ *	of the replacement object.  
+ *
+ * It is the caller's responsibility to invalidate the string
+ * representation of the object.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclListObjSetElement( interp, listPtr, index, valuePtr )
+    Tcl_Interp* interp;		/* Tcl interpreter; used for error reporting
+				 * if not NULL */
+    Tcl_Obj* listPtr;		/* List object in which element should be
+				 * stored */
+    int index;			/* Index of element to store */
+    Tcl_Obj* valuePtr;		/* Tcl object to store in the designated
+				 * list element */
+{
+    int result;			/* Return value from this function */
+    List* listRepPtr;		/* Internal representation of the list
+				 * being modified */
+    Tcl_Obj** elemPtrs;		/* Pointers to elements of the list */
+    int elemCount;		/* Number of elements in the list */
+
+    /* Ensure that the listPtr parameter designates an unshared list */
+
+    if ( Tcl_IsShared( listPtr ) ) {
+	panic( "Tcl_ListObjSetElement called with shared object" );
+    }
+    if ( listPtr->typePtr != &tclListType ) {
+	result = SetListFromAny( interp, listPtr );
+	if ( result != TCL_OK ) {
+	    return result;
+	}
+    }
+    listRepPtr = (List*) listPtr->internalRep.twoPtrValue.ptr1;
+    elemPtrs = listRepPtr->elements;
+    elemCount = listRepPtr->elemCount;
+
+    /* Ensure that the index is in bounds */
+
+    if ( index < 0 || index >= elemCount ) {
+	if ( interp != NULL ) {
+	    Tcl_SetObjResult( interp,
+			      Tcl_NewStringObj( "list index out of range",
+						-1 ) );
+	    return TCL_ERROR;
+	}
+    }
+
+    /* Add a reference to the new list element */
+
+    Tcl_IncrRefCount( valuePtr );
+
+    /* Remove a reference from the old list element */
+
+    Tcl_DecrRefCount( elemPtrs[ index ] );
+
+    /* Stash the new object in the list */
+
+    elemPtrs[ index ] = valuePtr;
+
+    return TCL_OK;
+    
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * FreeListInternalRep --
  *
  *	Deallocate the storage associated with a list object's internal
@@ -773,7 +1366,7 @@ Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv)
  *
  * Side effects:
  *	Frees listPtr's List* internal representation and sets listPtr's
- *	internalRep.otherValuePtr to NULL. Decrements the ref counts
+ *	internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts
  *	of all element objects, which may free them.
  *
  *----------------------------------------------------------------------
@@ -783,7 +1376,7 @@ static void
 FreeListInternalRep(listPtr)
     Tcl_Obj *listPtr;		/* List object with internal rep to free. */
 {
-    register List *listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
+    register List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
     register Tcl_Obj **elemPtrs = listRepPtr->elements;
     register Tcl_Obj *objPtr;
     int numElems = listRepPtr->elemCount;
@@ -795,6 +1388,9 @@ FreeListInternalRep(listPtr)
     }
     ckfree((char *) elemPtrs);
     ckfree((char *) listRepPtr);
+    // KBK temp
+    listPtr->internalRep.twoPtrValue.ptr1 = NULL;
+    listPtr->internalRep.twoPtrValue.ptr2 = NULL;
 }
 
 /*
@@ -824,7 +1420,7 @@ DupListInternalRep(srcPtr, copyPtr)
     Tcl_Obj *srcPtr;		/* Object with internal rep to copy. */
     Tcl_Obj *copyPtr;		/* Object with internal rep to set. */
 {
-    List *srcListRepPtr = (List *) srcPtr->internalRep.otherValuePtr;
+    List *srcListRepPtr = (List *) srcPtr->internalRep.twoPtrValue.ptr1;
     int numElems = srcListRepPtr->elemCount;
     int maxElems = srcListRepPtr->maxElemCount;
     register Tcl_Obj **srcElemPtrs = srcListRepPtr->elements;
@@ -850,7 +1446,8 @@ DupListInternalRep(srcPtr, copyPtr)
     copyListRepPtr->elemCount    = numElems;
     copyListRepPtr->elements     = copyElemPtrs;
     
-    copyPtr->internalRep.otherValuePtr = (VOID *) copyListRepPtr;
+    copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) copyListRepPtr;
+    copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
     copyPtr->typePtr = &tclListType;
 }
 
@@ -976,7 +1573,8 @@ SetListFromAny(interp, objPtr)
 	oldTypePtr->freeIntRepProc(objPtr);
     }
 
-    objPtr->internalRep.otherValuePtr = (VOID *) listRepPtr;
+    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
+    objPtr->internalRep.twoPtrValue.ptr2 = NULL;
     objPtr->typePtr = &tclListType;
     return TCL_OK;
 }
@@ -1008,7 +1606,7 @@ UpdateStringOfList(listPtr)
 {
 #   define LOCAL_SIZE 20
     int localFlags[LOCAL_SIZE], *flagPtr;
-    List *listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
+    List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
     int numElems = listRepPtr->elemCount;
     register int i;
     char *elem, *dst;
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 09d9428..0c66135 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -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: tclObj.c,v 1.23 2001/06/28 01:22:21 hobbs Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.24 2001/11/14 23:17:04 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -150,6 +150,7 @@ TclInitObjSubsystem()
     Tcl_RegisterObjType(&tclBooleanType);
     Tcl_RegisterObjType(&tclByteArrayType);
     Tcl_RegisterObjType(&tclDoubleType);
+    Tcl_RegisterObjType(&tclEndOffsetType);
     Tcl_RegisterObjType(&tclIntType);
     Tcl_RegisterObjType(&tclStringType);
     Tcl_RegisterObjType(&tclListType);
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 6b59f55..d054121 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -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.62 2001/10/15 20:26:58 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.63 2001/11/14 23:17:04 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -245,6 +245,7 @@ TclIntStubs tclIntStubs = {
     TclGetInstructionTable, /* 163 */
     TclExpandCodeArray, /* 164 */
     TclpSetInitialEncodings, /* 165 */
+    TclListObjSetElement, /* 166 */
 };
 
 TclIntPlatStubs tclIntPlatStubs = {
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 8232175..d423308 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclTestObj.c,v 1.7 2000/11/24 11:27:37 dkf Exp $
+ * RCS: @(#) $Id: tclTestObj.c,v 1.8 2001/11/14 23:17:04 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -774,6 +774,19 @@ TestobjCmd(clientData, interp, objc, objv)
                 varPtr[i] = NULL;
             }
         }
+    } else if ( strcmp ( subCmd, "invalidateStringRep" ) == 0 ) {
+	if ( objc != 3 ) {
+	    goto wrongNumArgs;
+	}
+	index = Tcl_GetString( objv[2] );
+	if ( GetVariableIndex( interp, index, &varIndex ) != TCL_OK ) {
+	    return TCL_ERROR;
+	}
+        if (CheckIfVarUnset(interp, varIndex)) {
+	    return TCL_ERROR;
+	}
+	Tcl_InvalidateStringRep( varPtr[varIndex] );
+	Tcl_SetObjResult( interp, varPtr[varIndex] );
     } else if (strcmp(subCmd, "newobj") == 0) {
         if (objc != 3) {
             goto wrongNumArgs;
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 0eca255..19f4850 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -6,11 +6,12 @@
  *
  * Copyright (c) 1987-1993 The Regents of the University of California.
  * Copyright (c) 1994-1998 Sun Microsystems, Inc.
+ * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
  *
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- *  RCS: @(#) $Id: tclUtil.c,v 1.24 2001/09/24 21:10:32 dgp Exp $
+ *  RCS: @(#) $Id: tclUtil.c,v 1.25 2001/11/14 23:17:04 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -62,6 +63,30 @@ static char precisionFormat[10] = "%.12g";
 				 * to sprintf. */
 TCL_DECLARE_MUTEX(precisionMutex)
 
+/*
+ * Prototypes for procedures defined later in this file.
+ */
+
+static void UpdateStringOfEndOffset _ANSI_ARGS_(( Tcl_Obj* objPtr ));
+static int SetEndOffsetFromAny _ANSI_ARGS_(( Tcl_Interp* interp,
+					     Tcl_Obj* objPtr ));
+
+/*
+ * The following is the Tcl object type definition for an object
+ * that represents a list index in the form, "end-offset".  It is
+ * used as a performance optimization in TclGetIntForIndex.  The
+ * internal rep is an integer, so no memory management is required
+ * for it.
+ */
+
+Tcl_ObjType tclEndOffsetType = {
+    "end-offset",			/* name */
+    (Tcl_FreeInternalRepProc*) NULL,    /* freeIntRepProc */
+    (Tcl_DupInternalRepProc*) NULL,     /* dupIntRepProc */
+    UpdateStringOfEndOffset,		/* updateStringProc */
+    SetEndOffsetFromAny    
+};
+
 
 /*
  *----------------------------------------------------------------------
@@ -2160,45 +2185,187 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr)
     char *bytes;
     int length, offset;
 
+    /* If the object is already an integer, use it. */
+
     if (objPtr->typePtr == &tclIntType) {
 	*indexPtr = (int)objPtr->internalRep.longValue;
 	return TCL_OK;
     }
 
-    bytes = Tcl_GetStringFromObj(objPtr, &length);
+    if ( SetEndOffsetFromAny( NULL, objPtr ) == TCL_OK ) {
+
+	/*
+	 * If the object is already an offset from the end of the list, or
+	 * can be converted to one, use it.
+	 */
+
+	*indexPtr = endValue + objPtr->internalRep.longValue;
+
+    } else if ( Tcl_GetIntFromObj( NULL, objPtr, &offset ) == TCL_OK ) {
+
+	/*
+	 * If the object can be converted to an integer, use that.
+	 */
+
+	*indexPtr = offset;
+
+    } else {
+
+	/*
+	 * Report a parse error.
+	 */
+
+	if ((Interp *)interp != NULL) {
+	    bytes = Tcl_GetStringFromObj( objPtr, &length );
+	    Tcl_AppendStringsToObj( Tcl_GetObjResult(interp),
+				    "bad index \"", bytes,
+				    "\": must be integer or end?-integer?",
+				    (char *) NULL);
+	    if ( !strncmp ( bytes, "end-", 3 ) ) {
+		bytes += 3;
+	    }
+	    TclCheckBadOctal(interp, bytes);
+	}
+
+	return TCL_ERROR;
+    }
+	    
+    return TCL_OK;
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfEndOffset --
+ *
+ *	Update the string rep of a Tcl object holding an "end-offset"
+ *	expression.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Stores a valid string in the object's string rep.
+ *
+ * This procedure does NOT free any earlier string rep.  If it is
+ * called on an object that already has a valid string rep, it will
+ * leak memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+UpdateStringOfEndOffset( objPtr )
+    register Tcl_Obj* objPtr;
+{
+    char buffer[ TCL_INTEGER_SPACE + sizeof("end") + 1 ];
+    register int len;
+
+    strcpy( buffer, "end" );
+    len = sizeof( "end" ) - 1;
+    if ( objPtr->internalRep.longValue != 0 ) {
+	buffer[len++] = '-';
+	len += TclFormatInt( buffer + len,
+			     -( objPtr->internalRep.longValue ) );
+    }
+    objPtr->bytes = ckalloc( (unsigned) ( len + 1 ) );
+    strcpy( objPtr->bytes, buffer );
+    objPtr->length = len;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetEndOffsetFromAny --
+ *
+ *	Look for a string of the form "end-offset" and convert it
+ *	to an internal representation holding the offset.
+ *
+ * Results:
+ *	Returns TCL_OK if ok, TCL_ERROR if the string was badly formed.
+ *
+ * Side effects:
+ *	If interp is not NULL, stores an error message in the
+ *	interpreter result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetEndOffsetFromAny( Tcl_Interp* interp,
+				/* Tcl interpreter or NULL */
+		     Tcl_Obj* objPtr )
+				/* Pointer to the object to parse */
+{
+    int offset;			/* Offset in the "end-offset" expression */
+    Tcl_ObjType* oldTypePtr = objPtr->typePtr;
+				/* Old internal rep type of the object */
+    register char* bytes;	/* String rep of the object */
+    int length;			/* Length of the object's string rep */
 
+    /* If it's already the right type, we're fine. */
+
+    if ( objPtr->typePtr == &tclEndOffsetType ) {
+	return TCL_OK;
+    }
+
+    /* Check for a string rep of the right form. */
+
+    bytes = Tcl_GetStringFromObj(objPtr, &length);
     if ((*bytes != 'e') || (strncmp(bytes, "end",
 	    (size_t)((length > 3) ? 3 : length)) != 0)) {
-	if (Tcl_GetIntFromObj(NULL, objPtr, &offset) != TCL_OK) {
-	    goto intforindex_error;
+	if ( interp != NULL ) {
+	    Tcl_AppendStringsToObj( Tcl_GetObjResult( interp ),
+				    "bad index \"", bytes,
+				    "\": must be end?-integer?",
+				    (char*) NULL );
 	}
-	*indexPtr = offset;
-	return TCL_OK;
+	return TCL_ERROR;
     }
 
+    /* Convert the string rep */
+
     if (length <= 3) {
-	*indexPtr = endValue;
+	offset = 0;
     } else if (bytes[3] == '-') {
+
 	/*
 	 * This is our limited string expression evaluator
 	 */
 	if (Tcl_GetInt(interp, bytes+3, &offset) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	*indexPtr = endValue + offset;
+
     } else {
-	intforindex_error:
-	if ((Interp *)interp != NULL) {
-	    Tcl_ResetResult(interp);
+
+	/* Conversion failed.  Report the error. */
+
+
+	if ( interp != NULL ) {
 	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
-		    "bad index \"", bytes,
-		    "\": must be integer or end?-integer?", (char *) NULL);
-	    TclCheckBadOctal(interp, bytes);
+				   "bad index \"", bytes,
+				   "\": must be integer or end?-integer?",
+				   (char *) NULL);
 	}
 	return TCL_ERROR;
+
     }
+
+    /*
+     * The conversion succeeded. Free the old internal rep and set
+     * the new one.
+     */
+
+    if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
+	oldTypePtr->freeIntRepProc(objPtr);
+    }
+    
+    objPtr->internalRep.longValue = offset;
+    objPtr->typePtr = &tclEndOffsetType;
+
     return TCL_OK;
-}
+}    
 
 /*
  *----------------------------------------------------------------------
diff --git a/generic/tclVar.c b/generic/tclVar.c
index d4290d0..530b3d8 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -10,11 +10,12 @@
  * Copyright (c) 1987-1994 The Regents of the University of California.
  * Copyright (c) 1994-1997 Sun Microsystems, Inc.
  * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
  *
  * 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.39 2001/11/09 23:06:04 dgp Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.40 2001/11/14 23:17:04 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -2936,7 +2937,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv)
 		return result;
 	    }
 	}
-	listRepPtr = (List *) varValuePtr->internalRep.otherValuePtr;
+	listRepPtr = (List *) varValuePtr->internalRep.twoPtrValue.ptr1;
 	elemPtrs = listRepPtr->elements;
 	numElems = listRepPtr->elemCount;
 
-- 
cgit v0.12