summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c7
-rw-r--r--generic/tclCmdIL.c414
-rw-r--r--generic/tclCompCmds.c308
-rw-r--r--generic/tclCompile.c17
-rw-r--r--generic/tclCompile.h18
-rw-r--r--generic/tclExecute.c235
-rw-r--r--generic/tclInt.decls12
-rw-r--r--generic/tclInt.h28
-rw-r--r--generic/tclIntDecls.h11
-rw-r--r--generic/tclListObj.c630
-rw-r--r--generic/tclObj.c3
-rw-r--r--generic/tclStubInit.c3
-rw-r--r--generic/tclTestObj.c15
-rw-r--r--generic/tclUtil.c197
-rw-r--r--generic/tclVar.c5
15 files changed, 1770 insertions, 133 deletions
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;
generated by cgit v0.12 at 2024-11-10 13:46:45 (GMT)