diff options
Diffstat (limited to 'generic/tclCmdIL.c')
| -rw-r--r-- | generic/tclCmdIL.c | 414 |
1 files changed, 384 insertions, 30 deletions
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. |