From 790913f75a784d5e869e4dc7b8c7aa36494005eb Mon Sep 17 00:00:00 2001 From: hobbs Date: Wed, 14 Nov 2001 23:17:01 +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) FossilOrigin-Name: 8e0db83abc5d97d0c5f9c8cbb3229ddc8e3a78da --- 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 + + * 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 * 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 * 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