diff options
Diffstat (limited to 'generic/tclCmdIL.c')
| -rw-r--r-- | generic/tclCmdIL.c | 3478 |
1 files changed, 1705 insertions, 1773 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index e61a42d..41c1eb6 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -3,20 +3,18 @@ * * This file contains the top-level command routines for most of the Tcl * built-in commands whose names begin with the letters I through L. It - * contains only commands in the generic core (i.e. those that don't + * contains only commands in the generic core (i.e., those that don't * depend much upon UNIX facilities). * * Copyright (c) 1987-1993 The Regents of the University of California. * 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. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2005 Donal K. Fellows. * * 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.86 2005/12/09 14:13:00 dkf Exp $ */ #include "tclInt.h" @@ -29,8 +27,16 @@ */ typedef struct SortElement { - Tcl_Obj *objPtr; /* Object being sorted. */ - int count; /* number of same elements in list */ + union { /* The value that we sorting by. */ + const char *strValuePtr; + long intValue; + double doubleValue; + Tcl_Obj *objValuePtr; + } collationKey; + union { /* Object being sorted, or its index. */ + Tcl_Obj *objPtr; + int index; + } payload; struct SortElement *nextPtr;/* Next element in the list, or NULL for end * of list. */ } SortElement; @@ -53,12 +59,10 @@ typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t); typedef struct SortInfo { int isIncreasing; /* Nonzero means sort in increasing order. */ int sortMode; /* The sort mode. One of SORTMODE_* values - * defined below */ - SortStrCmpFn_t strCmpFn; /* Basic string compare command (used with - * ASCII mode). */ + * defined below. */ Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode is * SORTMODE_COMMAND. Pre-initialized to hold - * base of command.*/ + * base of command. */ int *indexv; /* If the -index option was specified, this * holds the indexes contained in the list * supplied as an argument to that option. @@ -67,6 +71,8 @@ typedef struct SortInfo { * supplied. */ int indexc; /* Number of indexes in indexv array. */ int singleIndex; /* Static space for common index case. */ + int unique; + int numElements; Tcl_Interp *interp; /* The interpreter in which the sort is being * done. */ int resultCode; /* Completion code for the lsort command. If @@ -84,6 +90,7 @@ typedef struct SortInfo { #define SORTMODE_REAL 2 #define SORTMODE_COMMAND 3 #define SORTMODE_DICTIONARY 4 +#define SORTMODE_ASCII_NC 8 /* * Magic values for the index field of the SortInfo structure. Note that the @@ -97,59 +104,89 @@ typedef struct SortInfo { * Forward declarations for procedures defined in this file: */ -static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, - CONST char *pattern, int includeLinks); -static int DictionaryCompare(char *left, char *right); +static int DictionaryCompare(const char *left, const char *right); +static int IfConditionCallback(ClientData data[], + Tcl_Interp *interp, int result); static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int InfoBodyCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int InfoCmdCountCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int InfoCommandsCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int InfoCompleteCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); -static int InfoExistsCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); +/* TIP #348 - New 'info' subcommand 'errorstack' */ +static int InfoErrorStackCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +/* TIP #280 - New 'info' subcommand 'frame' */ +static int InfoFrameCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); static int InfoFunctionsCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); -static int InfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int InfoHostnameCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int InfoLevelCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int InfoLibraryCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int InfoLoadedCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); -static int InfoLocalsCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int InfoNameOfExecutableCmd(ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); static int InfoPatchLevelCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int InfoProcsCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); -static int InfoVarsCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); -static SortElement * MergeSort(SortElement *headPt, SortInfo *infoPtr); -static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr, + int objc, Tcl_Obj *const objv[]); +static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr, SortInfo *infoPtr); -static int SortCompare(Tcl_Obj *firstPtr, Tcl_Obj *second, +static int SortCompare(SortElement *firstPtr, SortElement *second, SortInfo *infoPtr); static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr, SortInfo *infoPtr); + +/* + * Array of values describing how to implement each standard subcommand of the + * "info" command. + */ + +static const EnsembleImplMap defaultInfoMap[] = { + {"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, + {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, + {"default", InfoDefaultCmd, TclCompileBasic3ArgCmd, NULL, NULL, 0}, + {"errorstack", InfoErrorStackCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0}, + {"frame", InfoFrameCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"functions", InfoFunctionsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"globals", TclInfoGlobalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"hostname", InfoHostnameCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"level", InfoLevelCmd, TclCompileInfoLevelCmd, NULL, NULL, 0}, + {"library", InfoLibraryCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"loaded", InfoLoadedCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"locals", TclInfoLocalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"patchlevel", InfoPatchLevelCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"procs", InfoProcsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"sharedlibextension", InfoSharedlibCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"tclversion", InfoTclVersionCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"vars", TclInfoVarsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} +}; /* *---------------------------------------------------------------------- @@ -172,46 +209,73 @@ static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr, *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_IfObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_IfObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - int thenScriptIndex = 0; /* "then" script to be evaled after - * syntax check */ - int i, result, value; - char *clause; - i = 1; - while (1) { - /* - * At this point in the loop, objv and objc refer to an expression to - * test, either for the main expression or an expression following an - * "elseif". The arguments after the expression must be "then" - * (optional) and a script to execute if the expression is true. - */ + return Tcl_NRCallObjProc(interp, TclNRIfObjCmd, dummy, objc, objv); +} - if (i >= objc) { - clause = TclGetString(objv[i-1]); - Tcl_AppendResult(interp, "wrong # args: no expression after \"", - clause, "\" argument", (char *) NULL); - return TCL_ERROR; - } - if (!thenScriptIndex) { - result = Tcl_ExprBooleanObj(interp, objv[i], &value); - if (result != TCL_OK) { - return result; - } - } +int +TclNRIfObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *boolObj; + + if (objc <= 1) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: no expression after \"%s\" argument", + TclGetString(objv[0]))); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + return TCL_ERROR; + } + + /* + * At this point, objv[1] refers to the main expression to test. The + * arguments after the expression must be "then" (optional) and a script + * to execute if the expression is true. + */ + + TclNewObj(boolObj); + Tcl_NRAddCallback(interp, IfConditionCallback, INT2PTR(objc), + (ClientData) objv, INT2PTR(1), boolObj); + return Tcl_NRExprObj(interp, objv[1], boolObj); +} + +static int +IfConditionCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + int objc = PTR2INT(data[0]); + Tcl_Obj *const *objv = data[1]; + int i = PTR2INT(data[2]); + Tcl_Obj *boolObj = data[3]; + int value, thenScriptIndex = 0; + const char *clause; + + if (result != TCL_OK) { + TclDecrRefCount(boolObj); + return result; + } + if (Tcl_GetBooleanFromObj(interp, boolObj, &value) != TCL_OK) { + TclDecrRefCount(boolObj); + return TCL_ERROR; + } + TclDecrRefCount(boolObj); + + while (1) { i++; if (i >= objc) { - missingScript: - clause = TclGetString(objv[i-1]); - Tcl_AppendResult(interp, "wrong # args: no script following \"", - clause, "\" argument", (char *) NULL); - return TCL_ERROR; + goto missingScript; } clause = TclGetString(objv[i]); if ((i < objc) && (strcmp(clause, "then") == 0)) { @@ -233,16 +297,41 @@ Tcl_IfObjCmd(dummy, interp, objc, objv) i++; if (i >= objc) { if (thenScriptIndex) { - return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); + /* + * TIP #280. Make invoking context available to branch. + */ + + return TclNREvalObjEx(interp, objv[thenScriptIndex], 0, + iPtr->cmdFramePtr, thenScriptIndex); } return TCL_OK; } clause = TclGetString(objv[i]); - if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) { - i++; - continue; + if ((clause[0] != 'e') || (strcmp(clause, "elseif") != 0)) { + break; + } + i++; + + /* + * At this point in the loop, objv and objc refer to an expression to + * test, either for the main expression or an expression following an + * "elseif". The arguments after the expression must be "then" + * (optional) and a script to execute if the expression is true. + */ + + if (i >= objc) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: no expression after \"%s\" argument", + clause)); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + return TCL_ERROR; + } + if (!thenScriptIndex) { + TclNewObj(boolObj); + Tcl_NRAddCallback(interp, IfConditionCallback, data[0], data[1], + INT2PTR(i), boolObj); + return Tcl_NRExprObj(interp, objv[i], boolObj); } - break; } /* @@ -254,22 +343,32 @@ Tcl_IfObjCmd(dummy, interp, objc, objv) if (strcmp(clause, "else") == 0) { i++; if (i >= objc) { - Tcl_AppendResult(interp, - "wrong # args: no script following \"else\" argument", - (char *) NULL); - return TCL_ERROR; + goto missingScript; } } if (i < objc - 1) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "wrong # args: extra words after \"else\" clause in \"if\" command", - (char *) NULL); + -1)); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); return TCL_ERROR; } if (thenScriptIndex) { - return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); + /* + * TIP #280. Make invoking context available to branch/else. + */ + + return TclNREvalObjEx(interp, objv[thenScriptIndex], 0, + iPtr->cmdFramePtr, thenScriptIndex); } - return Tcl_EvalObjEx(interp, objv[i], 0); + return TclNREvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i); + + missingScript: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: no script following \"%s\" argument", + TclGetString(objv[i-1]))); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + return TCL_ERROR; } /* @@ -293,13 +392,12 @@ Tcl_IfObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_IncrObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_IncrObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *newValuePtr, *incrPtr; @@ -334,121 +432,25 @@ Tcl_IncrObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_InfoObjCmd -- + * TclInitInfoCmd -- * - * This procedure is invoked to process the "info" Tcl command. See the - * user documentation for details on what it does. + * This function is called to create the "info" Tcl command. See the user + * documentation for details on what it does. * * Results: - * A standard Tcl result. + * Handle for the info command, or NULL on failure. * * Side effects: - * See the user documentation. + * none * *---------------------------------------------------------------------- */ - /* ARGSUSED */ -int -Tcl_InfoObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Arbitrary value passed to the command. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_Command +TclInitInfoCmd( + Tcl_Interp *interp) /* Current interpreter. */ { - static CONST char *subCmds[] = { - "args", "body", "cmdcount", "commands", - "complete", "default", "exists", "functions", "globals", - "hostname", "level", "library", "loaded", - "locals", "nameofexecutable", "patchlevel", "procs", - "script", "sharedlibextension", "tclversion", "vars", - (char *) NULL}; - enum ISubCmdIdx { - IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx, - ICompleteIdx, IDefaultIdx, IExistsIdx, IFunctionsIdx, IGlobalsIdx, - IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, - ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx, - IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx - }; - int index, result; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); - return TCL_ERROR; - } - - result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0, - (int *) &index); - if (result != TCL_OK) { - return result; - } - - switch (index) { - case IArgsIdx: - result = InfoArgsCmd(clientData, interp, objc, objv); - break; - case IBodyIdx: - result = InfoBodyCmd(clientData, interp, objc, objv); - break; - case ICmdCountIdx: - result = InfoCmdCountCmd(clientData, interp, objc, objv); - break; - case ICommandsIdx: - result = InfoCommandsCmd(clientData, interp, objc, objv); - break; - case ICompleteIdx: - result = InfoCompleteCmd(clientData, interp, objc, objv); - break; - case IDefaultIdx: - result = InfoDefaultCmd(clientData, interp, objc, objv); - break; - case IExistsIdx: - result = InfoExistsCmd(clientData, interp, objc, objv); - break; - case IFunctionsIdx: - result = InfoFunctionsCmd(clientData, interp, objc, objv); - break; - case IGlobalsIdx: - result = InfoGlobalsCmd(clientData, interp, objc, objv); - break; - case IHostnameIdx: - result = InfoHostnameCmd(clientData, interp, objc, objv); - break; - case ILevelIdx: - result = InfoLevelCmd(clientData, interp, objc, objv); - break; - case ILibraryIdx: - result = InfoLibraryCmd(clientData, interp, objc, objv); - break; - case ILoadedIdx: - result = InfoLoadedCmd(clientData, interp, objc, objv); - break; - case ILocalsIdx: - result = InfoLocalsCmd(clientData, interp, objc, objv); - break; - case INameOfExecutableIdx: - result = InfoNameOfExecutableCmd(clientData, interp, objc, objv); - break; - case IPatchLevelIdx: - result = InfoPatchLevelCmd(clientData, interp, objc, objv); - break; - case IProcsIdx: - result = InfoProcsCmd(clientData, interp, objc, objv); - break; - case IScriptIdx: - result = InfoScriptCmd(clientData, interp, objc, objv); - break; - case ISharedLibExtensionIdx: - result = InfoSharedlibCmd(clientData, interp, objc, objv); - break; - case ITclVersionIdx: - result = InfoTclVersionCmd(clientData, interp, objc, objv); - break; - case IVarsIdx: - result = InfoVarsCmd(clientData, interp, objc, objv); - break; - } - return result; + return TclMakeEnsemble(interp, "info", defaultInfoMap); } /* @@ -472,28 +474,29 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) */ static int -InfoArgsCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +InfoArgsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { register Interp *iPtr = (Interp *) interp; - char *name; + const char *name; Proc *procPtr; CompiledLocal *localPtr; Tcl_Obj *listObjPtr; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "procname"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "procname"); return TCL_ERROR; } - name = TclGetString(objv[2]); + name = TclGetString(objv[1]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", name, - "\" isn't a procedure", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", name)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL); return TCL_ERROR; } @@ -501,7 +504,7 @@ InfoArgsCmd(dummy, interp, objc, objv) * Build a return list containing the arguments. */ - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + listObjPtr = Tcl_NewListObj(0, NULL); for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; localPtr = localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { @@ -534,27 +537,28 @@ InfoArgsCmd(dummy, interp, objc, objv) */ static int -InfoBodyCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +InfoBodyCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { register Interp *iPtr = (Interp *) interp; - char *name; + const char *name; Proc *procPtr; Tcl_Obj *bodyPtr, *resultPtr; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "procname"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "procname"); return TCL_ERROR; } - name = TclGetString(objv[2]); + name = TclGetString(objv[1]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", name, - "\" isn't a procedure", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", name)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL); return TCL_ERROR; } @@ -574,7 +578,7 @@ InfoBodyCmd(dummy, interp, objc, objv) * run before. [Bug #545644] */ - (void) Tcl_GetString(bodyPtr); + TclGetString(bodyPtr); } resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); @@ -604,16 +608,16 @@ InfoBodyCmd(dummy, interp, objc, objv) */ static int -InfoCmdCountCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +InfoCmdCountCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -646,14 +650,14 @@ InfoCmdCountCmd(dummy, interp, objc, objv) */ static int -InfoCommandsCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +InfoCommandsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - char *cmdName, *pattern; - CONST char *simplePattern; + const char *cmdName, *pattern; + const char *simplePattern; register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Namespace *nsPtr; @@ -669,11 +673,11 @@ InfoCommandsCmd(dummy, interp, objc, objv) * commands. */ - if (objc == 2) { + if (objc == 1) { simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; - } else if (objc == 3) { + } else if (objc == 2) { /* * From the pattern, get the effective namespace and the simple * pattern (no namespace qualifiers or ::'s) at the end. If an error @@ -684,15 +688,15 @@ InfoCommandsCmd(dummy, interp, objc, objv) Namespace *dummy1NsPtr, *dummy2NsPtr; - pattern = TclGetString(objv[2]); - TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, 0, - &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + pattern = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, pattern, NULL, 0, &nsPtr, + &dummy1NsPtr, &dummy2NsPtr, &simplePattern); - if (nsPtr != NULL) { /* we successfully found the pattern's ns */ + if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } @@ -711,7 +715,7 @@ InfoCommandsCmd(dummy, interp, objc, objv) * name. */ - listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + listPtr = Tcl_NewListObj(0, NULL); if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { /* @@ -722,7 +726,7 @@ InfoCommandsCmd(dummy, interp, objc, objv) entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); if (entryPtr != NULL) { if (specificNsInPattern) { - cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); + cmd = Tcl_GetHashValue(entryPtr); elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, cmd, elemObjPtr); } else { @@ -734,7 +738,7 @@ InfoCommandsCmd(dummy, interp, objc, objv) return TCL_OK; } if ((nsPtr != globalNsPtr) && !specificNsInPattern) { - Tcl_HashTable *tablePtr = NULL; /* Quell warning */ + Tcl_HashTable *tablePtr = NULL; /* Quell warning. */ for (i=0 ; i<nsPtr->commandPathLength ; i++) { Namespace *pathNsPtr = nsPtr->commandPathArray[i].nsPtr; @@ -773,7 +777,7 @@ InfoCommandsCmd(dummy, interp, objc, objv) if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { if (specificNsInPattern) { - cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); + cmd = Tcl_GetHashValue(entryPtr); elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, cmd, elemObjPtr); } else { @@ -798,7 +802,7 @@ InfoCommandsCmd(dummy, interp, objc, objv) cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { - if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) { + if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(cmdName, -1)); } @@ -832,7 +836,7 @@ InfoCommandsCmd(dummy, interp, objc, objv) elemObjPtr = Tcl_NewStringObj(cmdName, -1); Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); (void) Tcl_CreateHashEntry(&addedCommandsTable, - (char *)elemObjPtr, &isNew); + elemObjPtr, &isNew); } entryPtr = Tcl_NextHashEntry(&search); } @@ -857,7 +861,7 @@ InfoCommandsCmd(dummy, interp, objc, objv) || Tcl_StringMatch(cmdName, simplePattern)) { elemObjPtr = Tcl_NewStringObj(cmdName, -1); (void) Tcl_CreateHashEntry(&addedCommandsTable, - (char *) elemObjPtr, &isNew); + elemObjPtr, &isNew); if (isNew) { Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); } else { @@ -923,23 +927,19 @@ InfoCommandsCmd(dummy, interp, objc, objv) */ static int -InfoCompleteCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +InfoCompleteCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "command"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "command"); return TCL_ERROR; } - if (TclObjCommandComplete(objv[2])) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - } - + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + TclObjCommandComplete(objv[1]))); return TCL_OK; } @@ -964,30 +964,32 @@ InfoCompleteCmd(dummy, interp, objc, objv) */ static int -InfoDefaultCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +InfoDefaultCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - char *procName, *argName, *varName; + const char *procName, *argName; Proc *procPtr; CompiledLocal *localPtr; Tcl_Obj *valueObjPtr; - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname"); + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "procname arg varname"); return TCL_ERROR; } - procName = TclGetString(objv[2]); - argName = TclGetString(objv[3]); + procName = TclGetString(objv[1]); + argName = TclGetString(objv[2]); procPtr = TclFindProc(iPtr, procName); if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", procName, - "\" isn't a procedure", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", procName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName, + NULL); return TCL_ERROR; } @@ -996,23 +998,19 @@ InfoDefaultCmd(dummy, interp, objc, objv) if (TclIsVarArgument(localPtr) && (strcmp(argName, localPtr->name) == 0)) { if (localPtr->defValuePtr != NULL) { - valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, - localPtr->defValuePtr, 0); + valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, + localPtr->defValuePtr, TCL_LEAVE_ERR_MSG); if (valueObjPtr == NULL) { - defStoreError: - varName = TclGetString(objv[4]); - Tcl_AppendResult(interp, - "couldn't store default value in variable \"", - varName, "\"", (char *) NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); } else { Tcl_Obj *nullObjPtr = Tcl_NewObj(); - valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, - nullObjPtr, 0); + + valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, + nullObjPtr, TCL_LEAVE_ERR_MSG); if (valueObjPtr == NULL) { - goto defStoreError; + return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } @@ -1020,20 +1018,22 @@ InfoDefaultCmd(dummy, interp, objc, objv) } } - Tcl_AppendResult(interp, "procedure \"", procName, - "\" doesn't have an argument \"", argName, "\"", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "procedure \"%s\" doesn't have an argument \"%s\"", + procName, argName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * InfoExistsCmd -- + * InfoErrorStackCmd -- * - * Called to implement the "info exists" command that determines whether - * a variable exists. Handles the following syntax: + * Called to implement the "info errorstack" command that returns information + * about the last error's call stack. Handles the following syntax: * - * info exists varName + * info errorstack ?interp? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -1046,40 +1046,43 @@ InfoDefaultCmd(dummy, interp, objc, objv) */ static int -InfoExistsCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +InfoErrorStackCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - char *varName; - Var *varPtr; + Tcl_Interp *target; + Interp *iPtr; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "varName"); + if ((objc != 1) && (objc != 2)) { + Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); return TCL_ERROR; } - varName = TclGetString(objv[2]); - varPtr = TclVarTraceExists(interp, varName); - if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + target = interp; + if (objc == 2) { + target = Tcl_GetSlave(interp, Tcl_GetString(objv[1])); + if (target == NULL) { + return TCL_ERROR; + } } + + iPtr = (Interp *) target; + Tcl_SetObjResult(interp, iPtr->errorStack); + return TCL_OK; } /* *---------------------------------------------------------------------- * - * InfoFunctionsCmd -- + * TclInfoExistsCmd -- * - * Called to implement the "info functions" command that returns the list - * of math functions matching an optional pattern. Handles the following - * syntax: + * Called to implement the "info exists" command that determines whether + * a variable exists. Handles the following syntax: * - * info functions ?pattern? + * info exists varName * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -1091,43 +1094,40 @@ InfoExistsCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ -static int -InfoFunctionsCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +int +TclInfoExistsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - char *pattern; - Tcl_Obj *listPtr; + const char *varName; + Var *varPtr; - if (objc == 2) { - pattern = NULL; - } else if (objc == 3) { - pattern = TclGetString(objv[2]); - } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "varName"); return TCL_ERROR; } - listPtr = Tcl_ListMathFuncs(interp, pattern); - if (listPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, listPtr); + varName = TclGetString(objv[1]); + varPtr = TclVarTraceExists(interp, varName); + + Tcl_SetObjResult(interp, + Tcl_NewBooleanObj(varPtr && varPtr->value.objPtr)); return TCL_OK; } /* *---------------------------------------------------------------------- * - * InfoGlobalsCmd -- + * InfoFrameCmd -- + * TIP #280 * - * Called to implement the "info globals" command that returns the list - * of global variables matching an optional pattern. Handles the + * Called to implement the "info frame" command that returns the location + * of either the currently executing command, or its caller. Handles the * following syntax: * - * info globals ?pattern? + * info frame ?number? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -1140,69 +1140,380 @@ InfoFunctionsCmd(dummy, interp, objc, objv) */ static int -InfoGlobalsCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +InfoFrameCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - char *varName, *pattern; - Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); - register Tcl_HashEntry *entryPtr; - Tcl_HashSearch search; - Var *varPtr; - Tcl_Obj *listPtr; + Interp *iPtr = (Interp *) interp; + int level, code = TCL_OK; + CmdFrame *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr; + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + int topLevel = 0; - if (objc == 2) { - pattern = NULL; - } else if (objc == 3) { - pattern = TclGetString(objv[2]); + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?number?"); + return TCL_ERROR; + } + + while (corPtr) { + while (*cmdFramePtrPtr) { + topLevel++; + cmdFramePtrPtr = &((*cmdFramePtrPtr)->nextPtr); + } + if (corPtr->caller.cmdFramePtr) { + *cmdFramePtrPtr = corPtr->caller.cmdFramePtr; + } + corPtr = corPtr->callerEEPtr->corPtr; + } + topLevel += (*cmdFramePtrPtr)->level; + + if (topLevel != iPtr->cmdFramePtr->level) { + framePtr = iPtr->cmdFramePtr; + while (framePtr) { + framePtr->level = topLevel--; + framePtr = framePtr->nextPtr; + } + if (topLevel) { + Tcl_Panic("Broken frame level calculation"); + } + topLevel = iPtr->cmdFramePtr->level; + } + + if (objc == 1) { /* - * Strip leading global-namespace qualifiers. [Bug 1057461] + * Just "info frame". */ - if (pattern[0] == ':' && pattern[1] == ':') { - while (*pattern == ':') { - pattern++; + Tcl_SetObjResult(interp, Tcl_NewIntObj(topLevel)); + goto done; + } + + /* + * We've got "info frame level" and must parse the level first. + */ + + if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) { + code = TCL_ERROR; + goto done; + } + + if ((level > topLevel) || (level <= - topLevel)) { + levelError: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad level \"%s\"", TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_FRAME", + TclGetString(objv[1]), NULL); + code = TCL_ERROR; + goto done; + } + + /* + * Let us convert to relative so that we know how many levels to go back + */ + + if (level > 0) { + level -= topLevel; + } + + framePtr = iPtr->cmdFramePtr; + while (++level <= 0) { + framePtr = framePtr->nextPtr; + if (!framePtr) { + goto levelError; + } + } + + Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr)); + + done: + cmdFramePtrPtr = &iPtr->cmdFramePtr; + corPtr = iPtr->execEnvPtr->corPtr; + while (corPtr) { + CmdFrame *endPtr = corPtr->caller.cmdFramePtr; + + if (endPtr) { + if (*cmdFramePtrPtr == endPtr) { + *cmdFramePtrPtr = NULL; + } else { + CmdFrame *runPtr = *cmdFramePtrPtr; + + while (runPtr->nextPtr != endPtr) { + runPtr->level -= endPtr->level; + runPtr = runPtr->nextPtr; + } + runPtr->level = 1; + runPtr->nextPtr = NULL; } + cmdFramePtrPtr = &corPtr->caller.cmdFramePtr; } - } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); - return TCL_ERROR; + corPtr = corPtr->callerEEPtr->corPtr; } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclInfoFrame -- + * + * Core of InfoFrameCmd, returns TIP280 dict for a given frame. + * + * Results: + * Returns TIP280 dict. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +Tcl_Obj * +TclInfoFrame( + Tcl_Interp *interp, /* Current interpreter. */ + CmdFrame *framePtr) /* Frame to get info for. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *tmpObj; + Tcl_Obj *lv[20]; /* Keep uptodate when more keys are added to + * the dict. */ + int lc = 0; /* - * Scan through the global :: namespace's variable table and create a list - * of all global variables that match the pattern. + * This array is indexed by the TCL_LOCATION_... values, except + * for _LAST. */ + static const char *const typeString[TCL_LOCATION_LAST] = { + "eval", "eval", "eval", "precompiled", "source", "proc" + }; + Proc *procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; - listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - if (pattern != NULL && TclMatchIsTrivial(pattern)) { - entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, pattern); - if (entryPtr != NULL) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (!TclIsVarUndefined(varPtr)) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(pattern, -1)); - } + /* + * Pull the information and construct the dictionary to return, as list. + * Regarding use of the CmdFrame fields see tclInt.h, and its definition. + */ + +#define ADD_PAIR(name, value) \ + TclNewLiteralStringObj(tmpObj, name); \ + lv[lc++] = tmpObj; \ + lv[lc++] = (value) + + switch (framePtr->type) { + case TCL_LOCATION_EVAL: + /* + * Evaluation, dynamic script. Type, line, cmd, the latter through + * str. + */ + + ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); + if (framePtr->line) { + ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); + } else { + ADD_PAIR("line", Tcl_NewIntObj(1)); } - } else { - for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (TclIsVarUndefined(varPtr)) { - continue; + ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); + break; + + case TCL_LOCATION_PREBC: + /* + * Precompiled. Result contains the type as signal, nothing else. + */ + + ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); + break; + + case TCL_LOCATION_BC: { + /* + * Execution of bytecode. Talk to the BC engine to fill out the frame. + */ + + CmdFrame *fPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + + *fPtr = *framePtr; + + /* + * Note: + * Type BC => f.data.eval.path is not used. + * f.data.tebc.codePtr is used instead. + */ + + TclGetSrcInfoForPc(fPtr); + + /* + * Now filled: cmd.str.(cmd,len), line + * Possibly modified: type, path! + */ + + ADD_PAIR("type", Tcl_NewStringObj(typeString[fPtr->type], -1)); + if (fPtr->line) { + ADD_PAIR("line", Tcl_NewIntObj(fPtr->line[0])); + } + + if (fPtr->type == TCL_LOCATION_SOURCE) { + ADD_PAIR("file", fPtr->data.eval.path); + + /* + * Death of reference by TclGetSrcInfoForPc. + */ + + Tcl_DecrRefCount(fPtr->data.eval.path); + } + + ADD_PAIR("cmd", TclGetSourceFromFrame(fPtr, 0, NULL)); + TclStackFree(interp, fPtr); + break; + } + + case TCL_LOCATION_SOURCE: + /* + * Evaluation of a script file. + */ + + ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); + ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); + ADD_PAIR("file", framePtr->data.eval.path); + + /* + * Refcount framePtr->data.eval.path goes up when lv is converted into + * the result list object. + */ + + ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); + break; + + case TCL_LOCATION_PROC: + Tcl_Panic("TCL_LOCATION_PROC found in standard frame"); + break; + } + + /* + * 'proc'. Common to all frame types. Conditional on having an associated + * Procedure CallFrame. + */ + + if (procPtr != NULL) { + Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr; + + if (namePtr) { + Tcl_Obj *procNameObj; + + /* + * This is a regular command. + */ + + TclNewObj(procNameObj); + Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr, + procNameObj); + ADD_PAIR("proc", procNameObj); + } else if (procPtr->cmdPtr->clientData) { + ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData; + int i; + + /* + * This is a non-standard command. Luckily, it's told us how to + * render extra information about its frame. + */ + + for (i=0 ; i<efiPtr->length ; i++) { + lv[lc++] = Tcl_NewStringObj(efiPtr->fields[i].name, -1); + if (efiPtr->fields[i].proc) { + lv[lc++] = + efiPtr->fields[i].proc(efiPtr->fields[i].clientData); + } else { + lv[lc++] = efiPtr->fields[i].clientData; + } } - varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr); - if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(varName, -1)); + } + } + + /* + * 'level'. Common to all frame types. Conditional on having an associated + * _visible_ CallFrame. + */ + + if ((framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) { + CallFrame *current = framePtr->framePtr; + CallFrame *top = iPtr->varFramePtr; + CallFrame *idx; + + for (idx=top ; idx!=NULL ; idx=idx->callerVarPtr) { + if (idx == current) { + int c = framePtr->framePtr->level; + int t = iPtr->varFramePtr->level; + + ADD_PAIR("level", Tcl_NewIntObj(t - c)); + break; } } } - Tcl_SetObjResult(interp, listPtr); - return TCL_OK; + + return Tcl_NewListObj(lc, lv); +} + +/* + *---------------------------------------------------------------------- + * + * InfoFunctionsCmd -- + * + * Called to implement the "info functions" command that returns the list + * of math functions matching an optional pattern. Handles the following + * syntax: + * + * info functions ?pattern? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoFunctionsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *script; + int code; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); + return TCL_ERROR; + } + + script = Tcl_NewStringObj( +" ::apply [::list {{pattern *}} {\n" +" ::set cmds {}\n" +" ::foreach cmd [::info commands ::tcl::mathfunc::$pattern] {\n" +" ::lappend cmds [::namespace tail $cmd]\n" +" }\n" +" ::foreach cmd [::info commands tcl::mathfunc::$pattern] {\n" +" ::set cmd [::namespace tail $cmd]\n" +" ::if {$cmd ni $cmds} {\n" +" ::lappend cmds $cmd\n" +" }\n" +" }\n" +" ::return $cmds\n" +" } [::namespace current]] ", -1); + + if (objc == 2) { + Tcl_Obj *arg = Tcl_NewListObj(1, &(objv[1])); + + Tcl_AppendObjToObj(script, arg); + Tcl_DecrRefCount(arg); + } + + Tcl_IncrRefCount(script); + code = Tcl_EvalObjEx(interp, script, 0); + + Tcl_DecrRefCount(script); + + return code; } /* @@ -1226,15 +1537,16 @@ InfoGlobalsCmd(dummy, interp, objc, objv) */ static int -InfoHostnameCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +InfoHostnameCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - CONST char *name; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + const char *name; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -1242,11 +1554,12 @@ InfoHostnameCmd(dummy, interp, objc, objv) if (name) { Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1)); return TCL_OK; - } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unable to determine name of host", -1)); - return TCL_ERROR; } + + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to determine name of host", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", NULL); + return TCL_ERROR; } /* @@ -1270,53 +1583,55 @@ InfoHostnameCmd(dummy, interp, objc, objv) */ static int -InfoLevelCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +InfoLevelCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - int level; - CallFrame *framePtr; - Tcl_Obj *listPtr; - if (objc == 2) { /* just "info level" */ - if (iPtr->varFramePtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->varFramePtr->level)); - } + if (objc == 1) { /* Just "info level" */ + Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->varFramePtr->level)); return TCL_OK; - } else if (objc == 3) { - if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) { + } + + if (objc == 2) { + int level; + CallFrame *framePtr, *rootFramePtr = iPtr->rootFramePtr; + + if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) { return TCL_ERROR; } if (level <= 0) { - if (iPtr->varFramePtr == NULL) { - levelError: - Tcl_AppendResult(interp, "bad level \"", - TclGetString(objv[2]), "\"", (char *) NULL); - return TCL_ERROR; + if (iPtr->varFramePtr == rootFramePtr) { + goto levelError; } level += iPtr->varFramePtr->level; } - for (framePtr = iPtr->varFramePtr; framePtr != NULL; - framePtr = framePtr->callerVarPtr) { + for (framePtr=iPtr->varFramePtr ; framePtr!=rootFramePtr; + framePtr=framePtr->callerVarPtr) { if (framePtr->level == level) { break; } } - if (framePtr == NULL) { + if (framePtr == rootFramePtr) { goto levelError; } - listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); - Tcl_SetObjResult(interp, listPtr); + Tcl_SetObjResult(interp, + Tcl_NewListObj(framePtr->objc, framePtr->objv)); return TCL_OK; } - Tcl_WrongNumArgs(interp, 2, objv, "?number?"); + Tcl_WrongNumArgs(interp, 1, objv, "?number?"); + return TCL_ERROR; + + levelError: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad level \"%s\"", TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", + TclGetString(objv[1]), NULL); return TCL_ERROR; } @@ -1342,16 +1657,16 @@ InfoLevelCmd(dummy, interp, objc, objv) */ static int -InfoLibraryCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +InfoLibraryCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - CONST char *libDirName; + const char *libDirName; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -1360,8 +1675,10 @@ InfoLibraryCmd(dummy, interp, objc, objv) Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1)); return TCL_OK; } + Tcl_SetObjResult(interp, Tcl_NewStringObj( "no library has been specified for Tcl", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library",NULL); return TCL_ERROR; } @@ -1387,184 +1704,25 @@ InfoLibraryCmd(dummy, interp, objc, objv) */ static int -InfoLoadedCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +InfoLoadedCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - char *interpName; - int result; + const char *interpName; - if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?interp?"); + if ((objc != 1) && (objc != 2)) { + Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); return TCL_ERROR; } - if (objc == 2) { /* get loaded pkgs in all interpreters */ + if (objc == 1) { /* Get loaded pkgs in all interpreters. */ interpName = NULL; - } else { /* get pkgs just in specified interp */ - interpName = TclGetString(objv[2]); - } - result = TclGetLoadedPackages(interp, interpName); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * InfoLocalsCmd -- - * - * Called to implement the "info locals" command to return a list of - * local variables that match an optional pattern. Handles the following - * syntax: - * - * info locals ?pattern? - * - * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. - * - * Side effects: - * Returns a result in the interpreter's result object. If there is an - * error, the result is an error message. - * - *---------------------------------------------------------------------- - */ - -static int -InfoLocalsCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - Interp *iPtr = (Interp *) interp; - char *pattern; - Tcl_Obj *listPtr; - - if (objc == 2) { - pattern = NULL; - } else if (objc == 3) { - pattern = TclGetString(objv[2]); - } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); - return TCL_ERROR; - } - - if (iPtr->varFramePtr == NULL || - !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC )) { - return TCL_OK; - } - - /* - * Return a list containing names of first the compiled locals (i.e. the - * ones stored in the call frame), then the variables in the local hash - * table (if one exists). - */ - - listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - AppendLocals(interp, listPtr, pattern, 0); - Tcl_SetObjResult(interp, listPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * AppendLocals -- - * - * Append the local variables for the current frame to the specified list - * object. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -AppendLocals(interp, listPtr, pattern, includeLinks) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Obj *listPtr; /* List object to append names to. */ - CONST char *pattern; /* Pattern to match against. */ - int includeLinks; /* 1 if upvars should be included, else 0. */ -{ - Interp *iPtr = (Interp *) interp; - CompiledLocal *localPtr; - Var *varPtr; - int i, localVarCt; - char *varName; - Tcl_HashTable *localVarTablePtr; - register Tcl_HashEntry *entryPtr; - Tcl_HashSearch search; - - localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr; - localVarCt = iPtr->varFramePtr->numCompiledLocals; - varPtr = iPtr->varFramePtr->compiledLocals; - localVarTablePtr = iPtr->varFramePtr->varTablePtr; - - for (i = 0; i < localVarCt; i++) { - /* - * Skip nameless (temporary) variables and undefined variables - */ - - if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr) - && (includeLinks || !TclIsVarLink(varPtr))) { - varName = varPtr->name; - if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(varName, -1)); - } - } - varPtr++; - localPtr = localPtr->nextPtr; - } - - /* - * Do nothing if no local variables. - */ - - if (localVarTablePtr == NULL) { - return; - } - - /* - * Check for the simple and fast case. - */ - - if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { - entryPtr = Tcl_FindHashEntry(localVarTablePtr, pattern); - if (entryPtr != NULL) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (!TclIsVarUndefined(varPtr) - && (includeLinks || !TclIsVarLink(varPtr))) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(pattern,-1)); - } - } - return; - } - - /* - * Scan over and process all local variables. - */ - - for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (!TclIsVarUndefined(varPtr) - && (includeLinks || !TclIsVarLink(varPtr))) { - varName = Tcl_GetHashKey(localVarTablePtr, entryPtr); - if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(varName, -1)); - } - } + } else { /* Get pkgs just in specified interp. */ + interpName = TclGetString(objv[1]); } + return TclGetLoadedPackages(interp, interpName); } /* @@ -1589,14 +1747,14 @@ AppendLocals(interp, listPtr, pattern, includeLinks) */ static int -InfoNameOfExecutableCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +InfoNameOfExecutableCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, TclGetObjNameOfExecutable()); @@ -1625,16 +1783,16 @@ InfoNameOfExecutableCmd(dummy, interp, objc, objv) */ static int -InfoPatchLevelCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +InfoPatchLevelCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - CONST char *patchlevel; + const char *patchlevel; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -1672,14 +1830,14 @@ InfoPatchLevelCmd(dummy, interp, objc, objv) */ static int -InfoProcsCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +InfoProcsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - char *cmdName, *pattern; - CONST char *simplePattern; + const char *cmdName, *pattern; + const char *simplePattern; Namespace *nsPtr; #ifdef INFO_PROCS_SEARCH_GLOBAL_NS Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); @@ -1696,11 +1854,11 @@ InfoProcsCmd(dummy, interp, objc, objv) * procs. */ - if (objc == 2) { + if (objc == 1) { simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; - } else if (objc == 3) { + } else if (objc == 2) { /* * From the pattern, get the effective namespace and the simple * pattern (no namespace qualifiers or ::'s) at the end. If an error @@ -1711,16 +1869,15 @@ InfoProcsCmd(dummy, interp, objc, objv) Namespace *dummy1NsPtr, *dummy2NsPtr; - pattern = TclGetString(objv[2]); - TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, - /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, - &simplePattern); + pattern = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, pattern, NULL, /*flags*/ 0, &nsPtr, + &dummy1NsPtr, &dummy2NsPtr, &simplePattern); - if (nsPtr != NULL) { /* we successfully found the pattern's ns */ + if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } @@ -1735,12 +1892,12 @@ InfoProcsCmd(dummy, interp, objc, objv) * name. */ - listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + listPtr = Tcl_NewListObj(0, NULL); #ifndef INFO_PROCS_SEARCH_GLOBAL_NS if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); if (entryPtr != NULL) { - cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + cmdPtr = Tcl_GetHashValue(entryPtr); if (!TclIsProc(cmdPtr)) { realCmdPtr = (Command *) @@ -1768,7 +1925,7 @@ InfoProcsCmd(dummy, interp, objc, objv) cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { - cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + cmdPtr = Tcl_GetHashValue(entryPtr); if (!TclIsProc(cmdPtr)) { realCmdPtr = (Command *) @@ -1814,8 +1971,8 @@ InfoProcsCmd(dummy, interp, objc, objv) cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { - if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) { - cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) { + cmdPtr = Tcl_GetHashValue(entryPtr); realCmdPtr = (Command *) TclGetOriginalCommand( (Tcl_Command) cmdPtr); @@ -1860,23 +2017,23 @@ InfoProcsCmd(dummy, interp, objc, objv) */ static int -InfoScriptCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +InfoScriptCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?filename?"); + if ((objc != 1) && (objc != 2)) { + Tcl_WrongNumArgs(interp, 1, objv, "?filename?"); return TCL_ERROR; } - if (objc == 3) { + if (objc == 2) { if (iPtr->scriptFile != NULL) { Tcl_DecrRefCount(iPtr->scriptFile); } - iPtr->scriptFile = objv[2]; + iPtr->scriptFile = objv[1]; Tcl_IncrRefCount(iPtr->scriptFile); } if (iPtr->scriptFile != NULL) { @@ -1907,14 +2064,14 @@ InfoScriptCmd(dummy, interp, objc, objv) */ static int -InfoSharedlibCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +InfoSharedlibCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -1945,16 +2102,16 @@ InfoSharedlibCmd(dummy, interp, objc, objv) */ static int -InfoTclVersionCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +InfoTclVersionCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *version; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -1970,198 +2127,6 @@ InfoTclVersionCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * InfoVarsCmd -- - * - * Called to implement the "info vars" command that returns the list of - * variables in the interpreter that match an optional pattern. The - * pattern, if any, consists of an optional sequence of namespace names - * separated by "::" qualifiers, which is followed by a glob-style - * pattern that restricts which variables are returned. Handles the - * following syntax: - * - * info vars ?pattern? - * - * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. - * - * Side effects: - * Returns a result in the interpreter's result object. If there is an - * error, the result is an error message. - * - *---------------------------------------------------------------------- - */ - -static int -InfoVarsCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - Interp *iPtr = (Interp *) interp; - char *varName, *pattern; - CONST char *simplePattern; - register Tcl_HashEntry *entryPtr; - Tcl_HashSearch search; - Var *varPtr; - Namespace *nsPtr; - Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); - Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - Tcl_Obj *listPtr, *elemObjPtr; - int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ - - /* - * Get the pattern and find the "effective namespace" in which to list - * variables. We only use this effective namespace if there's no active - * Tcl procedure frame. - */ - - if (objc == 2) { - simplePattern = NULL; - nsPtr = currNsPtr; - specificNsInPattern = 0; - } else if (objc == 3) { - /* - * From the pattern, get the effective namespace and the simple - * pattern (no namespace qualifiers or ::'s) at the end. If an error - * was found while parsing the pattern, return it. Otherwise, if the - * namespace wasn't found, just leave nsPtr NULL: we will return an - * empty list since no variables there can be found. - */ - - Namespace *dummy1NsPtr, *dummy2NsPtr; - - pattern = TclGetString(objv[2]); - TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, - /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, - &simplePattern); - - if (nsPtr != NULL) { /* We successfully found the pattern's ns */ - specificNsInPattern = (strcmp(simplePattern, pattern) != 0); - } - } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); - return TCL_ERROR; - } - - /* - * If the namespace specified in the pattern wasn't found, just return. - */ - - if (nsPtr == NULL) { - return TCL_OK; - } - - listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - - if ((iPtr->varFramePtr == NULL) - || !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC) - || specificNsInPattern) { - /* - * There is no frame pointer, the frame pointer was pushed only to - * activate a namespace, or we are in a procedure call frame but a - * specific namespace was specified. Create a list containing only the - * variables in the effective namespace's variable table. - */ - - if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { - /* - * If we can just do hash lookups, that simplifies things a lot. - */ - - entryPtr = Tcl_FindHashEntry(&nsPtr->varTable, simplePattern); - if (entryPtr != NULL) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (!TclIsVarUndefined(varPtr) - || TclIsVarNamespaceVar(varPtr)) { - if (specificNsInPattern) { - elemObjPtr = Tcl_NewObj(); - Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, - elemObjPtr); - } else { - elemObjPtr = Tcl_NewStringObj(simplePattern, -1); - } - Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); - } - } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) { - entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, - simplePattern); - if (entryPtr != NULL) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (!TclIsVarUndefined(varPtr) - || TclIsVarNamespaceVar(varPtr)) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(simplePattern, -1)); - } - } - } - } else { - /* - * Have to scan the tables of variables. - */ - - entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search); - while (entryPtr != NULL) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (!TclIsVarUndefined(varPtr) - || TclIsVarNamespaceVar(varPtr)) { - varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr); - if ((simplePattern == NULL) - || Tcl_StringMatch(varName, simplePattern)) { - if (specificNsInPattern) { - elemObjPtr = Tcl_NewObj(); - Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, - elemObjPtr); - } else { - elemObjPtr = Tcl_NewStringObj(varName, -1); - } - Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); - } - } - entryPtr = Tcl_NextHashEntry(&search); - } - - /* - * If the effective namespace isn't the global :: namespace, and a - * specific namespace wasn't requested in the pattern (i.e., the - * pattern only specifies variable names), then add in all global - * :: variables that match the simple pattern. Of course, add in - * only those variables that aren't hidden by a variable in the - * effective namespace. - */ - - if ((nsPtr != globalNsPtr) && !specificNsInPattern) { - entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search); - while (entryPtr != NULL) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (!TclIsVarUndefined(varPtr) - || TclIsVarNamespaceVar(varPtr)) { - varName = Tcl_GetHashKey(&globalNsPtr->varTable, - entryPtr); - if ((simplePattern == NULL) - || Tcl_StringMatch(varName, simplePattern)) { - if (Tcl_FindHashEntry(&nsPtr->varTable, - varName) == NULL) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(varName, -1)); - } - } - } - entryPtr = Tcl_NextHashEntry(&search); - } - } - } - } else if (((Interp *)interp)->varFramePtr->procPtr != NULL) { - AppendLocals(interp, listPtr, simplePattern, 1); - } - - Tcl_SetObjResult(interp, listPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_JoinObjCmd -- * * This procedure is invoked to process the "join" Tcl command. See the @@ -2176,25 +2141,17 @@ InfoVarsCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_JoinObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ +Tcl_JoinObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ { - char *joinString, *bytes; - int joinLength, listLen, length, i, result; - Tcl_Obj **elemPtrs; - Tcl_Obj *resObjPtr; + int listLen, i; + Tcl_Obj *resObjPtr, *joinObjPtr, **elemPtrs; - if (objc == 2) { - joinString = " "; - joinLength = 1; - } else if (objc == 3) { - joinString = Tcl_GetStringFromObj(objv[2], &joinLength); - } else { + if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?"); return TCL_ERROR; } @@ -2204,23 +2161,22 @@ Tcl_JoinObjCmd(dummy, interp, objc, objv) * pointer to its array of element pointers. */ - result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs); - if (result != TCL_OK) { - return result; + if (TclListObjGetElements(interp, objv[1], &listLen, + &elemPtrs) != TCL_OK) { + return TCL_ERROR; } - /* - * Now concatenate strings to form the "joined" result. - */ + joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; + Tcl_IncrRefCount(joinObjPtr); resObjPtr = Tcl_NewObj(); for (i = 0; i < listLen; i++) { - bytes = Tcl_GetStringFromObj(elemPtrs[i], &length); if (i > 0) { - Tcl_AppendToObj(resObjPtr, joinString, joinLength); + Tcl_AppendObjToObj(resObjPtr, joinObjPtr); } - Tcl_AppendToObj(resObjPtr, bytes, length); + Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); } + Tcl_DecrRefCount(joinObjPtr); Tcl_SetObjResult(interp, resObjPtr); return TCL_OK; } @@ -2242,95 +2198,61 @@ Tcl_JoinObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_LassignObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_LassignObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj *valueObj; /* Value to assign to variable, as read from - * the list object or created in the emptyObj - * variable. */ - Tcl_Obj *emptyObj = NULL; /* If non-NULL, an empty object created for - * being assigned to variables once we have - * run out of values from the list object. */ + Tcl_Obj *listCopyPtr; Tcl_Obj **listObjv; /* The contents of the list. */ int listObjc; /* The length of the list. */ - int i; - Tcl_Obj *resPtr; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "list varname ?varname ...?"); + int code = TCL_OK; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "list ?varName ...?"); return TCL_ERROR; } - /* - * First assign values out of the list to variables. - */ + listCopyPtr = TclListObjCopy(interp, objv[1]); + if (listCopyPtr == NULL) { + return TCL_ERROR; + } - for (i=0 ; i+2<objc ; i++) { - /* - * We do this each time round the loop because that is robust against - * shimmering nasties. - */ + TclListObjGetElements(NULL, listCopyPtr, &listObjc, &listObjv); - if (Tcl_ListObjIndex(interp, objv[1], i, &valueObj) != TCL_OK) { - return TCL_ERROR; - } - if (valueObj == NULL) { - if (emptyObj == NULL) { - TclNewObj(emptyObj); - Tcl_IncrRefCount(emptyObj); - } - valueObj = emptyObj; + objc -= 2; + objv += 2; + while (code == TCL_OK && objc > 0 && listObjc > 0) { + if (Tcl_ObjSetVar2(interp, *objv++, NULL, *listObjv++, + TCL_LEAVE_ERR_MSG) == NULL) { + code = TCL_ERROR; } + objc--; + listObjc--; + } - /* - * Make sure the reference count for the value being assigned is - * greater than one (other reference minimally in the list) so we - * can't get hammered by shimmering. - */ + if (code == TCL_OK && objc > 0) { + Tcl_Obj *emptyObj; - Tcl_IncrRefCount(valueObj); - resPtr = Tcl_ObjSetVar2(interp, objv[i+2], NULL, valueObj, - TCL_LEAVE_ERR_MSG); - TclDecrRefCount(valueObj); - if (resPtr == NULL) { - if (emptyObj != NULL) { - Tcl_DecrRefCount(emptyObj); + TclNewObj(emptyObj); + Tcl_IncrRefCount(emptyObj); + while (code == TCL_OK && objc-- > 0) { + if (Tcl_ObjSetVar2(interp, *objv++, NULL, emptyObj, + TCL_LEAVE_ERR_MSG) == NULL) { + code = TCL_ERROR; } - return TCL_ERROR; } - } - if (emptyObj != NULL) { Tcl_DecrRefCount(emptyObj); } - /* - * Now place a list of any values left over into the interpreter result. - * - * First, figure out how many values were not assigned by getting the - * length of the list. Note that I do not expect this operation to fail. - */ - - if (Tcl_ListObjGetElements(interp, objv[1], - &listObjc, &listObjv) != TCL_OK) { - return TCL_ERROR; + if (code == TCL_OK && listObjc > 0) { + Tcl_SetObjResult(interp, Tcl_NewListObj(listObjc, listObjv)); } - if (listObjc > objc-2) { - /* - * OK, there were left-overs. Make a list of them and slap that back - * in the interpreter result. - */ - - Tcl_SetObjResult(interp, - Tcl_NewListObj(listObjc - objc + 2, listObjv + objc - 2)); - } - - return TCL_OK; + Tcl_DecrRefCount(listCopyPtr); + return code; } /* @@ -2350,19 +2272,18 @@ Tcl_LassignObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_LindexObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_LindexObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj *elemPtr; /* Pointer to the element being extracted */ + Tcl_Obj *elemPtr; /* Pointer to the element being extracted. */ if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?"); + Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?"); return TCL_ERROR; } @@ -2385,290 +2306,11 @@ Tcl_LindexObjCmd(dummy, interp, objc, objv) if (elemPtr == NULL) { return TCL_ERROR; - } else { - Tcl_SetObjResult(interp, elemPtr); - Tcl_DecrRefCount(elemPtr); - return TCL_OK; - } -} - -/* - *---------------------------------------------------------------------- - * - * 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. - * - * Notes: - * 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) { - /* - * argPtr designates a single index. - */ - - return TclLindexFlat(interp, listPtr, 1, &argPtr); - } - - 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 TclLindexFlat(interp, listPtr, 1, &argPtr); - } - - /* - * Record the reference to the list that we are maintaining in the - * activation record. - */ - - 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) { - 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; - } - } - - /* - * Return the last object extracted. Its reference count will include the - * reference being returned. - */ - - 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. - * - * Notes: - * 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; + Tcl_SetObjResult(interp, elemPtr); + Tcl_DecrRefCount(elemPtr); + return TCL_OK; } /* @@ -2689,23 +2331,22 @@ TclLindexFlat(interp, listPtr, indexCount, indexArray) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_LinsertObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - register int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_LinsertObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + register int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *listPtr; - int index, isDuplicate, len, result; + int index, len, result; - if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?"); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?"); return TCL_ERROR; } - result = Tcl_ListObjLength(interp, objv[1], &len); + result = TclListObjLength(interp, objv[1], &len); if (result != TCL_OK) { return result; } @@ -2716,7 +2357,7 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv) * appended to the list. */ - result = TclGetIntForIndex(interp, objv[2], /*end*/ len, &index); + result = TclGetIntForIndexM(interp, objv[2], /*end*/ len, &index); if (result != TCL_OK) { return result; } @@ -2730,10 +2371,8 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv) */ listPtr = objv[1]; - isDuplicate = 0; if (Tcl_IsShared(listPtr)) { - listPtr = Tcl_DuplicateObj(listPtr); - isDuplicate = 1; + listPtr = TclListObjCopy(NULL, listPtr); } if ((objc == 4) && (index == len)) { @@ -2741,16 +2380,9 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv) * Special case: insert one element at the end of the list. */ - result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]); - } else if (objc > 3) { - result = Tcl_ListObjReplace(interp, listPtr, index, 0, - (objc-3), &(objv[3])); - } - if (result != TCL_OK) { - if (isDuplicate) { - Tcl_DecrRefCount(listPtr); /* free unneeded obj */ - } - return result; + Tcl_ListObjAppendElement(NULL, listPtr, objv[3]); + } else { + Tcl_ListObjReplace(NULL, listPtr, index, 0, (objc-3), &(objv[3])); } /* @@ -2778,13 +2410,13 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_ListObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - register int objc; /* Number of arguments. */ - register Tcl_Obj *CONST objv[]; /* The argument objects. */ +Tcl_ListObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + register int objc, /* Number of arguments. */ + register Tcl_Obj *const objv[]) + /* The argument objects. */ { /* * If there are no list elements, the result is an empty object. @@ -2792,7 +2424,7 @@ Tcl_ListObjCmd(dummy, interp, objc, objv) */ if (objc > 1) { - Tcl_SetObjResult(interp, Tcl_NewListObj((objc-1), &(objv[1]))); + Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, &objv[1])); } return TCL_OK; } @@ -2814,13 +2446,13 @@ Tcl_ListObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_LlengthObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - register Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_LlengthObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + register Tcl_Obj *const objv[]) + /* Argument objects. */ { int listLen, result; @@ -2829,7 +2461,7 @@ Tcl_LlengthObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - result = Tcl_ListObjLength(interp, objv[1], &listLen); + result = TclListObjLength(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } @@ -2860,39 +2492,28 @@ Tcl_LlengthObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_LrangeObjCmd(notUsed, interp, objc, objv) - ClientData notUsed; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - register Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_LrangeObjCmd( + ClientData notUsed, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + register Tcl_Obj *const objv[]) + /* Argument objects. */ { - Tcl_Obj *listPtr; Tcl_Obj **elemPtrs; - int listLen, first, last, numElems, result; + int listLen, first, last, result; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "list first last"); return TCL_ERROR; } - /* - * Make sure the list argument is a list object and get its length and a - * pointer to its array of element pointers. - */ - - listPtr = objv[1]; - result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs); + result = TclListObjLength(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } - /* - * Get the first and last indexes. - */ - - result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1), + result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1, &first); if (result != TCL_OK) { return result; @@ -2901,39 +2522,51 @@ Tcl_LrangeObjCmd(notUsed, interp, objc, objv) first = 0; } - result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1), + result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1, &last); if (result != TCL_OK) { return result; } if (last >= listLen) { - last = (listLen - 1); + last = listLen - 1; } if (first > last) { - return TCL_OK; /* the result is an empty object */ + /* + * Returning an empty list is easy. + */ + + return TCL_OK; } - /* - * Make sure listPtr still refers to a list object. It might have been - * converted to an int above if the argument objects were shared. - */ + result = TclListObjGetElements(interp, objv[1], &listLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } - if (listPtr->typePtr != &tclListType) { - result = Tcl_ListObjGetElements(interp, listPtr, &listLen, - &elemPtrs); - if (result != TCL_OK) { - return result; + if (Tcl_IsShared(objv[1]) || + ((ListRepPtr(objv[1])->refCount > 1))) { + Tcl_SetObjResult(interp, Tcl_NewListObj(last - first + 1, + &elemPtrs[first])); + } else { + /* + * In-place is possible. + */ + + if (last < (listLen - 1)) { + Tcl_ListObjReplace(interp, objv[1], last + 1, listLen - 1 - last, + 0, NULL); } - } - /* - * Extract a range of fields. We modify the interpreter's result object to - * be a list object containing the specified elements. - */ + /* + * This one is not conditioned on (first > 0) in order to preserve the + * string-canonizing effect of [lrange 0 end]. + */ + + Tcl_ListObjReplace(interp, objv[1], 0, first, 0, NULL); + Tcl_SetObjResult(interp, objv[1]); + } - numElems = (last - first + 1); - Tcl_SetObjResult(interp, Tcl_NewListObj(numElems, &(elemPtrs[first]))); return TCL_OK; } @@ -2954,35 +2587,34 @@ Tcl_LrangeObjCmd(notUsed, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_LrepeatObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - register int objc; /* Number of arguments. */ - register Tcl_Obj *CONST objv[]; +Tcl_LrepeatObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + register int objc, /* Number of arguments. */ + register Tcl_Obj *const objv[]) /* The argument objects. */ { - int elementCount, i, result; - Tcl_Obj *listPtr, **dataArray; - List *listRepPtr; + int elementCount, i, totalElems; + Tcl_Obj *listPtr, **dataArray = NULL; /* * Check arguments for legality: - * lrepeat posInt value ?value ...? + * lrepeat count ?value ...? */ - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "positiveCount value ?value ...?"); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "count ?value ...?"); return TCL_ERROR; } - elementCount = 0; - result = Tcl_GetIntFromObj(interp, objv[1], &elementCount); - if (result == TCL_ERROR) { + if (TCL_OK != TclGetIntFromObj(interp, objv[1], &elementCount)) { return TCL_ERROR; } - if (elementCount < 1) { - Tcl_AppendResult(interp, "must have a count of at least 1", NULL); + if (elementCount < 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad count \"%d\": must be integer >= 0", elementCount)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG", + NULL); return TCL_ERROR; } @@ -2993,15 +2625,28 @@ Tcl_LrepeatObjCmd(dummy, interp, objc, objv) objc -= 2; objv += 2; + /* Final sanity check. Do not exceed limits on max list length. */ + + if (elementCount && objc > LIST_MAX/elementCount) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + return TCL_ERROR; + } + totalElems = objc * elementCount; + /* * Get an empty list object that is allocated large enough to hold each * init value elementCount times. */ - listPtr = Tcl_NewListObj(elementCount*objc, NULL); - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; - listRepPtr->elemCount = elementCount*objc; - dataArray = &listRepPtr->elements; + listPtr = Tcl_NewListObj(totalElems, NULL); + if (totalElems) { + List *listRepPtr = ListRepPtr(listPtr); + + listRepPtr->elemCount = elementCount*objc; + dataArray = &listRepPtr->elements; + } /* * Set the elements. Note that we handle the common degenerate case of a @@ -3010,6 +2655,7 @@ Tcl_LrepeatObjCmd(dummy, interp, objc, objv) * number of times. */ + CLANG_ASSERT(dataArray); if (objc == 1) { register Tcl_Obj *tmpPtr = objv[0]; @@ -3050,24 +2696,23 @@ Tcl_LrepeatObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_LreplaceObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_LreplaceObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { register Tcl_Obj *listPtr; - int isDuplicate, first, last, listLen, numToDelete, result; + int first, last, listLen, numToDelete, result; if (objc < 4) { Tcl_WrongNumArgs(interp, 1, objv, - "list first last ?element element ...?"); + "list first last ?element ...?"); return TCL_ERROR; } - result = Tcl_ListObjLength(interp, objv[1], &listLen); + result = TclListObjLength(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } @@ -3078,37 +2723,39 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv) * included for deletion. */ - result = TclGetIntForIndex(interp, objv[2], /*end*/ (listLen - 1), &first); + result = TclGetIntForIndexM(interp, objv[2], /*end*/ listLen-1, &first); if (result != TCL_OK) { return result; } - result = TclGetIntForIndex(interp, objv[3], /*end*/ (listLen - 1), &last); + result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last); if (result != TCL_OK) { return result; } if (first < 0) { - first = 0; + first = 0; } /* * Complain if the user asked for a start element that is greater than the - * list length. This won't ever trigger for the "end*" case as that will + * list length. This won't ever trigger for the "end-*" case as that will * be properly constrained by TclGetIntForIndex because we use listLen-1 * (to allow for replacing the last elem). */ if ((first >= listLen) && (listLen > 0)) { - Tcl_AppendResult(interp, "list doesn't contain element ", - TclGetString(objv[2]), (int *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "list doesn't contain element %s", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPLACE", "BADIDX", + NULL); return TCL_ERROR; } if (last >= listLen) { - last = (listLen - 1); + last = listLen - 1; } if (first <= last) { - numToDelete = (last - first + 1); + numToDelete = last - first + 1; } else { numToDelete = 0; } @@ -3119,26 +2766,21 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv) */ listPtr = objv[1]; - isDuplicate = 0; if (Tcl_IsShared(listPtr)) { - listPtr = Tcl_DuplicateObj(listPtr); - isDuplicate = 1; - } - if (objc > 4) { - result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete, - (objc-4), &(objv[4])); - } else { - result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete, - 0, NULL); - } - if (result != TCL_OK) { - if (isDuplicate) { - Tcl_DecrRefCount(listPtr); /* free unneeded obj */ - } - return result; + listPtr = TclListObjCopy(NULL, listPtr); } /* + * Note that we call Tcl_ListObjReplace even when numToDelete == 0 and + * objc == 4. In this case, the list value of listPtr is not changed (no + * elements are removed or added), but by making the call we are assured + * we end up with a list in canonical form. Resist any temptation to + * optimize this case away. + */ + + Tcl_ListObjReplace(NULL, listPtr, first, numToDelete, objc-4, objv+4); + + /* * Set the interpreter's object result. */ @@ -3149,6 +2791,85 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * + * Tcl_LreverseObjCmd -- + * + * This procedure is invoked to process the "lreverse" 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_LreverseObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument values. */ +{ + Tcl_Obj **elemv; + int elemc, i, j; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "list"); + return TCL_ERROR; + } + if (TclListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) { + return TCL_ERROR; + } + + /* + * If the list is empty, just return it. [Bug 1876793] + */ + + if (!elemc) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } + + if (Tcl_IsShared(objv[1]) + || (ListRepPtr(objv[1])->refCount > 1)) { /* Bug 1675044 */ + Tcl_Obj *resultObj, **dataArray; + List *listRepPtr; + + resultObj = Tcl_NewListObj(elemc, NULL); + listRepPtr = ListRepPtr(resultObj); + listRepPtr->elemCount = elemc; + dataArray = &listRepPtr->elements; + + for (i=0,j=elemc-1 ; i<elemc ; i++,j--) { + dataArray[j] = elemv[i]; + Tcl_IncrRefCount(elemv[i]); + } + + Tcl_SetObjResult(interp, resultObj); + } else { + + /* + * Not shared, so swap "in place". This relies on Tcl_LOGE above + * returning a pointer to the live array of Tcl_Obj values. + */ + + for (i=0,j=elemc-1 ; i<j ; i++,j--) { + Tcl_Obj *tmp = elemv[i]; + + elemv[i] = elemv[j]; + elemv[j] = tmp; + } + TclInvalidateStringRep(objv[1]); + Tcl_SetObjResult(interp, objv[1]); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_LsearchObjCmd -- * * This procedure is invoked to process the "lsearch" Tcl command. See @@ -3164,34 +2885,34 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv) */ int -Tcl_LsearchObjCmd(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_LsearchObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument values. */ { - char *bytes, *patternBytes; - int i, match, mode, index, result, listc, length, elemLen; + const char *bytes, *patternBytes; + int i, match, index, result, listc, length, elemLen, bisect; int dataType, isIncreasing, lower, upper, patInt, objInt, offset; int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; + SortStrCmpFn_t strCmpFn = strcmp; Tcl_RegExp regexp = NULL; - static CONST char *options[] = { - "-all", "-ascii", "-decreasing", "-dictionary", + static const char *const options[] = { + "-all", "-ascii", "-bisect", "-decreasing", "-dictionary", "-exact", "-glob", "-increasing", "-index", "-inline", "-integer", "-nocase", "-not", "-real", "-regexp", "-sorted", "-start", - "-subindices", - NULL + "-subindices", NULL }; enum options { - LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, LSEARCH_DICTIONARY, - LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INDEX, - LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE, LSEARCH_NOT, - LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED, LSEARCH_START, - LSEARCH_SUBINDICES + LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_BISECT, LSEARCH_DECREASING, + LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, + LSEARCH_INDEX, LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE, + LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED, + LSEARCH_START, LSEARCH_SUBINDICES }; enum datatypes { ASCII, DICTIONARY, INTEGER, REAL @@ -3199,7 +2920,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) enum modes { EXACT, GLOB, REGEXP, SORTED }; - SortStrCmpFn_t strCmpFn = strcmp; + enum modes mode; mode = GLOB; dataType = ASCII; @@ -3208,12 +2929,13 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) inlineReturn = 0; returnSubindices = 0; negatedMatch = 0; + bisect = 0; listPtr = NULL; startPtr = NULL; offset = 0; noCase = 0; sortInfo.compareCmdPtr = NULL; - sortInfo.isIncreasing = 0; + sortInfo.isIncreasing = 1; sortInfo.sortMode = 0; sortInfo.interp = interp; sortInfo.resultCode = TCL_OK; @@ -3221,7 +2943,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) sortInfo.indexc = 0; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?options? list pattern"); + Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list pattern"); return TCL_ERROR; } @@ -3231,10 +2953,8 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); - } - return TCL_ERROR; + result = TCL_ERROR; + goto done; } switch ((enum options) index) { case LSEARCH_ALL: /* -all */ @@ -3243,8 +2963,13 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) case LSEARCH_ASCII: /* -ascii */ dataType = ASCII; break; + case LSEARCH_BISECT: /* -bisect */ + mode = SORTED; + bisect = 1; + break; case LSEARCH_DECREASING: /* -decreasing */ isIncreasing = 0; + sortInfo.isIncreasing = 0; break; case LSEARCH_DICTIONARY: /* -dictionary */ dataType = DICTIONARY; @@ -3257,6 +2982,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) break; case LSEARCH_INCREASING: /* -increasing */ isIncreasing = 1; + sortInfo.isIncreasing = 1; break; case LSEARCH_INLINE: /* -inline */ inlineReturn = 1; @@ -3265,7 +2991,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) dataType = INTEGER; break; case LSEARCH_NOCASE: /* -nocase */ - strCmpFn = strcasecmp; + strCmpFn = TclUtfCasecmp; noCase = 1; break; case LSEARCH_NOT: /* -not */ @@ -3293,19 +3019,19 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) Tcl_DecrRefCount(startPtr); } if (i > objc-4) { - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); - } - Tcl_AppendResult(interp, "missing starting index", NULL); - return TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "missing starting index", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + result = TCL_ERROR; + goto done; } i++; if (objv[i] == objv[objc - 2]) { /* - * Take copy to prevent shimmering problems. Note that it - * does not matter if the index obj is also a component of the - * list being searched. We only need to copy where the list - * and the index are one-and-the-same. + * Take copy to prevent shimmering problems. Note that it does + * not matter if the index obj is also a component of the list + * being searched. We only need to copy where the list and the + * index are one-and-the-same. */ startPtr = Tcl_DuplicateObj(objv[i]); @@ -3317,16 +3043,18 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) case LSEARCH_INDEX: { /* -index */ Tcl_Obj **indices; int j; + if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); + TclStackFree(interp, sortInfo.indexv); } if (i > objc-4) { if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-index\" option must be followed by list index", - NULL); + -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } @@ -3337,7 +3065,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) */ i++; - if (Tcl_ListObjGetElements(interp, objv[i], + if (TclListObjGetElements(interp, objv[i], &sortInfo.indexc, &indices) != TCL_OK) { if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); @@ -3352,8 +3080,8 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) sortInfo.indexv = &sortInfo.singleIndex; break; default: - sortInfo.indexv = (int *) - ckalloc(sizeof(int) * sortInfo.indexc); + sortInfo.indexv = + TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); } /* @@ -3363,14 +3091,12 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) */ for (j=0 ; j<sortInfo.indexc ; j++) { - if (TclGetIntForIndex(interp, indices[j], SORTIDX_END, + if (TclGetIntForIndexM(interp, indices[j], SORTIDX_END, &sortInfo.indexv[j]) != TCL_OK) { - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); - } - TclFormatToErrorInfo(interp, - "\n (-index option item number %d)", j); - return TCL_ERROR; + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (-index option item number %d)", j)); + result = TCL_ERROR; + goto done; } } break; @@ -3386,12 +3112,22 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } - Tcl_AppendResult(interp, - "-subindices cannot be used without -index option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "-subindices cannot be used without -index option", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", + "BAD_OPTION_MIX", NULL); + return TCL_ERROR; + } + + if (bisect && (allMatches || negatedMatch)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "-bisect is not compatible with -all or -not", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", + "BAD_OPTION_MIX", NULL); return TCL_ERROR; } - if ((enum modes) mode == REGEXP) { + if (mode == REGEXP) { /* * We can shimmer regexp/list if listv[i] == pattern, so get the * regexp rep before the list rep. First time round, omit the interp @@ -3405,9 +3141,8 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) if (regexp == NULL) { /* * Failed to compile the RE. Try again without the TCL_REG_NOSUB - * flag in case the RE had sub-expressions in it [Bug 1366683]. - * If this fails, an error message will be left in the - * interpreter. + * flag in case the RE had sub-expressions in it [Bug 1366683]. If + * this fails, an error message will be left in the interpreter. */ regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1], @@ -3418,10 +3153,8 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); - } - return TCL_ERROR; + result = TCL_ERROR; + goto done; } } @@ -3430,15 +3163,12 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) * pointer to its array of element pointers. */ - result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv); + result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv); if (result != TCL_OK) { if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); - } - return result; + goto done; } /* @@ -3446,13 +3176,10 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) */ if (startPtr) { - result = TclGetIntForIndex(interp, startPtr, listc-1, &offset); + result = TclGetIntForIndexM(interp, startPtr, listc-1, &offset); Tcl_DecrRefCount(startPtr); if (result != TCL_OK) { - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); - } - return result; + goto done; } if (offset < 0) { offset = 0; @@ -3465,7 +3192,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) if (offset > listc-1) { if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); + TclStackFree(interp, sortInfo.indexv); } if (allMatches || inlineReturn) { Tcl_ResetResult(interp); @@ -3478,33 +3205,41 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) patObj = objv[objc - 1]; patternBytes = NULL; - if ((enum modes) mode == EXACT || (enum modes) mode == SORTED) { + if (mode == EXACT || mode == SORTED) { switch ((enum datatypes) dataType) { case ASCII: case DICTIONARY: - patternBytes = Tcl_GetStringFromObj(patObj, &length); + patternBytes = TclGetStringFromObj(patObj, &length); break; case INTEGER: - result = Tcl_GetIntFromObj(interp, patObj, &patInt); + result = TclGetIntFromObj(interp, patObj, &patInt); if (result != TCL_OK) { - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); - } - return result; + goto done; } + + /* + * List representation might have been shimmered; restore it. [Bug + * 1844789] + */ + + TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv); break; case REAL: result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble); if (result != TCL_OK) { - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); - } - return result; + goto done; } + + /* + * List representation might have been shimmered; restore it. [Bug + * 1844789] + */ + + TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv); break; } } else { - patternBytes = Tcl_GetStringFromObj(patObj, &length); + patternBytes = TclGetStringFromObj(patObj, &length); } /* @@ -3515,7 +3250,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) index = -1; match = 0; - if ((enum modes) mode == SORTED && !allMatches && !negatedMatch) { + if (mode == SORTED && !allMatches && !negatedMatch) { /* * If the data is sorted, we can do a more intelligent search. Note * that there is no point in being smart when -all was specified; in @@ -3527,12 +3262,14 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) upper = listc; while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) { i = (lower + upper)/2; - itemPtr = SelectObjFromSublist(listv[i], &sortInfo); - if (sortInfo.resultCode != TCL_OK) { - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); + if (sortInfo.indexc != 0) { + itemPtr = SelectObjFromSublist(listv[i], &sortInfo); + if (sortInfo.resultCode != TCL_OK) { + result = sortInfo.resultCode; + goto done; } - return sortInfo.resultCode; + } else { + itemPtr = listv[i]; } switch ((enum datatypes) dataType) { case ASCII: @@ -3544,12 +3281,9 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) match = DictionaryCompare(patternBytes, bytes); break; case INTEGER: - result = Tcl_GetIntFromObj(interp, itemPtr, &objInt); + result = TclGetIntFromObj(interp, itemPtr, &objInt); if (result != TCL_OK) { - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); - } - return result; + goto done; } if (patInt == objInt) { match = 0; @@ -3562,10 +3296,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) case REAL: result = Tcl_GetDoubleFromObj(interp, itemPtr, &objDouble); if (result != TCL_OK) { - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); - } - return result; + goto done; } if (patDouble == objDouble) { match = 0; @@ -3589,10 +3320,16 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) * variation means that a search always makes log n * comparisons (normal binary search might "get lucky" with an * early comparison). + * + * In bisect mode though, we want the last of equals. */ index = i; - upper = i; + if (bisect) { + lower = i; + } else { + upper = i; + } } else if (match > 0) { if (isIncreasing) { lower = i; @@ -3607,7 +3344,9 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) } } } - + if (bisect && index < 0) { + index = lower; + } } else { /* * We need to do a linear search, because (at least one) of: @@ -3617,69 +3356,67 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) */ if (allMatches) { - listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + listPtr = Tcl_NewListObj(0, NULL); } for (i = offset; i < listc; i++) { match = 0; - itemPtr = SelectObjFromSublist(listv[i], &sortInfo); - if (sortInfo.resultCode != TCL_OK) { - if (listPtr != NULL) { - Tcl_DecrRefCount(listPtr); - } - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); + if (sortInfo.indexc != 0) { + itemPtr = SelectObjFromSublist(listv[i], &sortInfo); + if (sortInfo.resultCode != TCL_OK) { + if (listPtr != NULL) { + Tcl_DecrRefCount(listPtr); + } + result = sortInfo.resultCode; + goto done; } - return sortInfo.resultCode; + } else { + itemPtr = listv[i]; } - switch ((enum modes) mode) { + + switch (mode) { case SORTED: case EXACT: switch ((enum datatypes) dataType) { case ASCII: - bytes = Tcl_GetStringFromObj(itemPtr, &elemLen); + bytes = TclGetStringFromObj(itemPtr, &elemLen); if (length == elemLen) { /* * This split allows for more optimal compilation of - * memcmp/ + * memcmp/strcasecmp. */ if (noCase) { - match = (strcasecmp(bytes, patternBytes) == 0); + match = (TclUtfCasecmp(bytes, patternBytes) == 0); } else { match = (memcmp(bytes, patternBytes, (size_t) length) == 0); } } break; + case DICTIONARY: bytes = TclGetString(itemPtr); match = (DictionaryCompare(bytes, patternBytes) == 0); break; case INTEGER: - result = Tcl_GetIntFromObj(interp, itemPtr, &objInt); + result = TclGetIntFromObj(interp, itemPtr, &objInt); if (result != TCL_OK) { if (listPtr != NULL) { Tcl_DecrRefCount(listPtr); } - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); - } - return result; + goto done; } match = (objInt == patInt); break; case REAL: - result = Tcl_GetDoubleFromObj(interp, itemPtr, &objDouble); + result = Tcl_GetDoubleFromObj(interp,itemPtr, &objDouble); if (result != TCL_OK) { if (listPtr) { Tcl_DecrRefCount(listPtr); } - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); - } - return result; + goto done; } match = (objDouble == patDouble); break; @@ -3690,6 +3427,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) match = Tcl_StringCaseMatch(TclGetString(itemPtr), patternBytes, noCase); break; + case REGEXP: match = Tcl_RegExpExecObj(interp, regexp, itemPtr, 0, 0, 0); if (match < 0) { @@ -3697,16 +3435,14 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) if (listPtr != NULL) { Tcl_DecrRefCount(listPtr); } - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); - } - return TCL_ERROR; + result = TCL_ERROR; + goto done; } break; } /* - * Invert match condition for -not + * Invert match condition for -not. */ if (negatedMatch) { @@ -3723,7 +3459,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) * Note that these appends are not expected to fail. */ - if (returnSubindices) { + if (returnSubindices && (sortInfo.indexc != 0)) { itemPtr = SelectObjFromSublist(listv[i], &sortInfo); } else { itemPtr = listv[i]; @@ -3731,6 +3467,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } else if (returnSubindices) { int j; + itemPtr = Tcl_NewIntObj(i); for (j=0 ; j<sortInfo.indexc ; j++) { Tcl_ListObjAppendElement(interp, itemPtr, @@ -3752,6 +3489,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) } else if (!inlineReturn) { if (returnSubindices) { int j; + itemPtr = Tcl_NewIntObj(index); for (j=0 ; j<sortInfo.indexc ; j++) { Tcl_ListObjAppendElement(interp, itemPtr, @@ -3771,15 +3509,17 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) } else { Tcl_SetObjResult(interp, listv[index]); } + result = TCL_OK; /* * Cleanup the index list array. */ + done: if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); + TclStackFree(interp, sortInfo.indexv); } - return TCL_OK; + return result; } /* @@ -3800,21 +3540,22 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) */ 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_LsetObjCmd( + 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. */ + 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"); + Tcl_WrongNumArgs(interp, 1, objv, + "listVar ?index? ?index ...? value"); return TCL_ERROR; } @@ -3822,8 +3563,7 @@ Tcl_LsetObjCmd(clientData, interp, objc, objv) * Look up the list variable's value. */ - listPtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, - TCL_LEAVE_ERR_MSG); + listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (listPtr == NULL) { return TCL_ERROR; } @@ -3885,33 +3625,38 @@ Tcl_LsetObjCmd(clientData, interp, objc, objv) */ int -Tcl_LsortObjCmd(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_LsortObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument values. */ { - int i, index, unique, indices; - Tcl_Obj *resultPtr; - int length; - Tcl_Obj *cmdPtr, **listObjPtrs; - SortElement *elementArray; - SortElement *elementPtr; + int i, j, index, indices, length, nocase = 0, indexc; + int sortMode = SORTMODE_ASCII; + int group, groupSize, groupOffset, idx, allocatedIndexVector = 0; + Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr; + SortElement *elementArray, *elementPtr; SortInfo sortInfo; /* Information about this sort that needs to * be passed to the comparison function. */ - static CONST char *switches[] = { +# define NUM_LISTS 30 + SortElement *subList[NUM_LISTS+1]; + /* This array holds pointers to temporary + * lists built during the merge sort. Element + * i of the array holds a list of length + * 2**i. */ + static const char *const switches[] = { "-ascii", "-command", "-decreasing", "-dictionary", "-increasing", - "-index", "-indices", "-integer", "-nocase", "-real", "-unique", - (char *) NULL + "-index", "-indices", "-integer", "-nocase", "-real", "-stride", + "-unique", NULL }; enum Lsort_Switches { LSORT_ASCII, LSORT_COMMAND, LSORT_DECREASING, LSORT_DICTIONARY, LSORT_INCREASING, LSORT_INDEX, LSORT_INDICES, LSORT_INTEGER, - LSORT_NOCASE, LSORT_REAL, LSORT_UNIQUE + LSORT_NOCASE, LSORT_REAL, LSORT_STRIDE, LSORT_UNIQUE }; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?options? list"); + Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list"); return TCL_ERROR; } @@ -3921,32 +3666,35 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) sortInfo.isIncreasing = 1; sortInfo.sortMode = SORTMODE_ASCII; - sortInfo.strCmpFn = strcmp; sortInfo.indexv = NULL; sortInfo.indexc = 0; + sortInfo.unique = 0; sortInfo.interp = interp; sortInfo.resultCode = TCL_OK; cmdPtr = NULL; - unique = 0; indices = 0; + group = 0; + groupSize = 1; + groupOffset = 0; + indexPtr = NULL; for (i = 1; i < objc-1; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) != TCL_OK) { - return TCL_ERROR; + sortInfo.resultCode = TCL_ERROR; + goto done2; } switch ((enum Lsort_Switches) index) { case LSORT_ASCII: sortInfo.sortMode = SORTMODE_ASCII; break; case LSORT_COMMAND: - if (i == (objc-2)) { - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); - } - Tcl_AppendResult(interp, - "\"-command\" option must be followed ", - "by comparison command", NULL); - return TCL_ERROR; + if (i == objc-2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-command\" option must be followed " + "by comparison command", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + sortInfo.resultCode = TCL_ERROR; + goto done2; } sortInfo.sortMode = SORTMODE_COMMAND; cmdPtr = objv[i+1]; @@ -3962,55 +3710,41 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) sortInfo.isIncreasing = 1; break; case LSORT_INDEX: { - int j; - Tcl_Obj **indices; + int indexc, dummy; + Tcl_Obj **indexv; - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); - } - if (i == (objc-2)) { - Tcl_AppendResult(interp, "\"-index\" option must be ", - "followed by list index", NULL); - return TCL_ERROR; - } - - /* - * Take copy to prevent shimmering problems. - */ - - if (Tcl_ListObjGetElements(interp, objv[i+1], &sortInfo.indexc, - &indices) != TCL_OK) { - return TCL_ERROR; + if (i == objc-2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-index\" option must be followed by list index", + -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + sortInfo.resultCode = TCL_ERROR; + goto done2; } - switch (sortInfo.indexc) { - case 0: - sortInfo.indexv = NULL; - break; - case 1: - sortInfo.indexv = &sortInfo.singleIndex; - break; - default: - sortInfo.indexv = (int *) - ckalloc(sizeof(int) * sortInfo.indexc); + if (TclListObjGetElements(interp, objv[i+1], &indexc, + &indexv) != TCL_OK) { + sortInfo.resultCode = TCL_ERROR; + goto done2; } /* - * Fill the array by parsing each index. We don't know whether - * their scale is sensible yet, but we at least perform the - * syntactic check here. + * Check each of the indices for syntactic correctness. Note that + * we do not store the converted values here because we do not + * know if this is the only -index option yet and so we can't + * allocate any space; that happens after the scan through all the + * options is done. */ - for (j=0 ; j<sortInfo.indexc ; j++) { - if (TclGetIntForIndex(interp, indices[j], SORTIDX_END, - &sortInfo.indexv[j]) != TCL_OK) { - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); - } - TclFormatToErrorInfo(interp, - "\n (-index option item number %d)", j); - return TCL_ERROR; + for (j=0 ; j<indexc ; j++) { + if (TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, + &dummy) != TCL_OK) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (-index option item number %d)", j)); + sortInfo.resultCode = TCL_ERROR; + goto done2; } } + indexPtr = objv[i+1]; i++; break; } @@ -4018,157 +3752,339 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) sortInfo.sortMode = SORTMODE_INTEGER; break; case LSORT_NOCASE: - sortInfo.strCmpFn = strcasecmp; + nocase = 1; break; case LSORT_REAL: sortInfo.sortMode = SORTMODE_REAL; break; case LSORT_UNIQUE: - unique = 1; + sortInfo.unique = 1; break; case LSORT_INDICES: indices = 1; break; + case LSORT_STRIDE: + if (i == objc-2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-stride\" option must be " + "followed by stride length", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + sortInfo.resultCode = TCL_ERROR; + goto done2; + } + if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) { + sortInfo.resultCode = TCL_ERROR; + goto done2; + } + if (groupSize < 2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "stride length must be at least 2", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", + "BADSTRIDE", NULL); + sortInfo.resultCode = TCL_ERROR; + goto done2; + } + group = 1; + i++; + break; + } + } + if (nocase && (sortInfo.sortMode == SORTMODE_ASCII)) { + sortInfo.sortMode = SORTMODE_ASCII_NC; + } + + /* + * Now extract the -index list for real, if present. No failures are + * expected here; the values are all of the right type or convertible to + * it. + */ + + if (indexPtr) { + Tcl_Obj **indexv; + + TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv); + switch (sortInfo.indexc) { + case 0: + sortInfo.indexv = NULL; + break; + case 1: + sortInfo.indexv = &sortInfo.singleIndex; + break; + default: + sortInfo.indexv = + TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); + allocatedIndexVector = 1; /* Cannot use indexc field, as it + * might be decreased by 1 later. */ + } + for (j=0 ; j<sortInfo.indexc ; j++) { + TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, + &sortInfo.indexv[j]); } } + listObj = objv[objc-1]; + if (sortInfo.sortMode == SORTMODE_COMMAND) { + Tcl_Obj *newCommandPtr, *newObjPtr; + + /* + * When sorting using a command, we are reentrant and therefore might + * have the representation of the list being sorted shimmered out from + * underneath our feet. Take a copy (cheap) to prevent this. [Bug + * 1675116] + */ + + listObj = TclListObjCopy(interp, listObj); + if (listObj == NULL) { + sortInfo.resultCode = TCL_ERROR; + goto done2; + } + /* * The existing command is a list. We want to flatten it, append two * dummy arguments on the end, and replace these arguments later. */ - Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr); - Tcl_Obj *newObjPtr = Tcl_NewObj(); - + newCommandPtr = Tcl_DuplicateObj(cmdPtr); + TclNewObj(newObjPtr); Tcl_IncrRefCount(newCommandPtr); if (Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr) != TCL_OK) { - Tcl_DecrRefCount(newCommandPtr); + TclDecrRefCount(newCommandPtr); + TclDecrRefCount(listObj); Tcl_IncrRefCount(newObjPtr); - Tcl_DecrRefCount(newObjPtr); - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); - } - return TCL_ERROR; + TclDecrRefCount(newObjPtr); + sortInfo.resultCode = TCL_ERROR; + goto done2; } Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj()); sortInfo.compareCmdPtr = newCommandPtr; } - sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1], + sortInfo.resultCode = TclListObjGetElements(interp, listObj, &length, &listObjPtrs); if (sortInfo.resultCode != TCL_OK || length <= 0) { goto done; } - elementArray = (SortElement *) ckalloc(length * sizeof(SortElement)); - for (i=0; i < length; i++){ - elementArray[i].objPtr = listObjPtrs[i]; - elementArray[i].count = 0; - elementArray[i].nextPtr = &elementArray[i+1]; - } - elementArray[length-1].nextPtr = NULL; - elementPtr = MergeSort(elementArray, &sortInfo); - if (sortInfo.resultCode == TCL_OK) { - resultPtr = Tcl_NewObj(); - if (unique) { - if (indices) { - for (; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { - if (elementPtr->count == 0) { - Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewIntObj(elementPtr - &elementArray[0])); - } - } - } else { - for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr) { - if (elementPtr->count == 0) { - Tcl_ListObjAppendElement(interp, resultPtr, - elementPtr->objPtr); - } - } + + /* + * Check for sanity when grouping elements of the overall list together + * because of the -stride option. [TIP #326] + */ + + if (group) { + if (length % groupSize) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "list size must be a multiple of the stride length", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE", + NULL); + sortInfo.resultCode = TCL_ERROR; + goto done; + } + length = length / groupSize; + if (sortInfo.indexc > 0) { + /* + * Use the first value in the list supplied to -index as the + * offset of the element within each group by which to sort. + */ + + groupOffset = sortInfo.indexv[0]; + if (groupOffset <= SORTIDX_END) { + groupOffset = (groupOffset - SORTIDX_END) + groupSize - 1; } - } else { - if (indices) { - for (; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { - Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewIntObj(elementPtr - &elementArray[0])); - } + if (groupOffset < 0 || groupOffset >= groupSize) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "when used with \"-stride\", the leading \"-index\"" + " value must be within the group", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", + "BADINDEX", NULL); + sortInfo.resultCode = TCL_ERROR; + goto done; + } + if (sortInfo.indexc == 1) { + sortInfo.indexc = 0; + sortInfo.indexv = NULL; } else { - for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){ - Tcl_ListObjAppendElement(interp, resultPtr, - elementPtr->objPtr); + sortInfo.indexc--; + + /* + * Do not shrink the actual memory block used; that doesn't + * work with TclStackAlloc-allocated memory. [Bug 2918962] + */ + + for (i = 0; i < sortInfo.indexc; i++) { + sortInfo.indexv[i] = sortInfo.indexv[i+1]; } } } - Tcl_SetObjResult(interp, resultPtr); } - ckfree((char*) elementArray); - done: - if (sortInfo.sortMode == SORTMODE_COMMAND) { - Tcl_DecrRefCount(sortInfo.compareCmdPtr); - sortInfo.compareCmdPtr = NULL; + sortInfo.numElements = length; + + indexc = sortInfo.indexc; + sortMode = sortInfo.sortMode; + if ((sortMode == SORTMODE_ASCII_NC) + || (sortMode == SORTMODE_DICTIONARY)) { + /* + * For this function's purpose all string-based modes are equivalent + */ + + sortMode = SORTMODE_ASCII; } - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); + + /* + * Initialize the sublists. After the following loop, subList[i] will + * contain a sorted sublist of length 2**i. Use one extra subList at the + * end, always at NULL, to indicate the end of the lists. + */ + + for (j=0 ; j<=NUM_LISTS ; j++) { + subList[j] = NULL; } - return sortInfo.resultCode; -} - -/* - *---------------------------------------------------------------------- - * - * MergeSort - - * - * This procedure sorts a linked list of SortElement structures use the - * merge-sort algorithm. - * - * Results: - * A pointer to the head of the list after sorting is returned. - * - * Side effects: - * None, unless a user-defined comparison command does something weird. - * - *---------------------------------------------------------------------- - */ -static SortElement * -MergeSort(headPtr, infoPtr) - SortElement *headPtr; /* First element on the list. */ - SortInfo *infoPtr; /* Information needed by the comparison - * operator. */ -{ /* - * The subList array below holds pointers to temporary lists built during - * the merge sort. Element i of the array holds a list of length 2**i. + * The following loop creates a SortElement for each list element and + * begins sorting it into the sublists as it appears. */ -# define NUM_LISTS 30 - SortElement *subList[NUM_LISTS]; - SortElement *elementPtr; - int i; + elementArray = TclStackAlloc(interp, length * sizeof(SortElement)); - for (i=0 ; i<NUM_LISTS ; i++) { - subList[i] = NULL; - } - while (headPtr != NULL) { - elementPtr = headPtr; - headPtr = headPtr->nextPtr; - elementPtr->nextPtr = 0; - for (i=0 ; i<NUM_LISTS && subList[i]!=NULL ; i++) { - elementPtr = MergeLists(subList[i], elementPtr, infoPtr); - subList[i] = NULL; + for (i=0; i < length; i++){ + idx = groupSize * i + groupOffset; + if (indexc) { + /* + * If this is an indexed sort, retrieve the corresponding element + */ + indexPtr = SelectObjFromSublist(listObjPtrs[idx], &sortInfo); + if (sortInfo.resultCode != TCL_OK) { + goto done1; + } + } else { + indexPtr = listObjPtrs[idx]; } - if (i >= NUM_LISTS) { - i = NUM_LISTS-1; + + /* + * Determine the "value" of this object for sorting purposes + */ + + if (sortMode == SORTMODE_ASCII) { + elementArray[i].collationKey.strValuePtr = TclGetString(indexPtr); + } else if (sortMode == SORTMODE_INTEGER) { + long a; + + if (TclGetLongFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { + sortInfo.resultCode = TCL_ERROR; + goto done1; + } + elementArray[i].collationKey.intValue = a; + } else if (sortMode == SORTMODE_REAL) { + double a; + + if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr, + &a) != TCL_OK) { + sortInfo.resultCode = TCL_ERROR; + goto done1; + } + elementArray[i].collationKey.doubleValue = a; + } else { + elementArray[i].collationKey.objValuePtr = indexPtr; + } + + /* + * Determine the representation of this element in the result: either + * the objPtr itself, or its index in the original list. + */ + + if (indices || group) { + elementArray[i].payload.index = idx; + } else { + elementArray[i].payload.objPtr = listObjPtrs[idx]; } - subList[i] = elementPtr; + + /* + * Merge this element in the pre-existing sublists (and merge together + * sublists when we have two of the same size). + */ + + elementArray[i].nextPtr = NULL; + elementPtr = &elementArray[i]; + for (j=0 ; subList[j] ; j++) { + elementPtr = MergeLists(subList[j], elementPtr, &sortInfo); + subList[j] = NULL; + } + if (j >= NUM_LISTS) { + j = NUM_LISTS-1; + } + subList[j] = elementPtr; } - elementPtr = NULL; - for (i=0 ; i<NUM_LISTS ; i++) { - elementPtr = MergeLists(subList[i], elementPtr, infoPtr); + + /* + * Merge all sublists + */ + + elementPtr = subList[0]; + for (j=1 ; j<NUM_LISTS ; j++) { + elementPtr = MergeLists(subList[j], elementPtr, &sortInfo); } - return elementPtr; + + /* + * Now store the sorted elements in the result list. + */ + + if (sortInfo.resultCode == TCL_OK) { + List *listRepPtr; + Tcl_Obj **newArray, *objPtr; + + resultPtr = Tcl_NewListObj(sortInfo.numElements * groupSize, NULL); + listRepPtr = ListRepPtr(resultPtr); + newArray = &listRepPtr->elements; + if (group) { + for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) { + idx = elementPtr->payload.index; + for (j = 0; j < groupSize; j++) { + if (indices) { + objPtr = Tcl_NewIntObj(idx + j - groupOffset); + newArray[i++] = objPtr; + Tcl_IncrRefCount(objPtr); + } else { + objPtr = listObjPtrs[idx + j - groupOffset]; + newArray[i++] = objPtr; + Tcl_IncrRefCount(objPtr); + } + } + } + } else if (indices) { + for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { + objPtr = Tcl_NewIntObj(elementPtr->payload.index); + newArray[i++] = objPtr; + Tcl_IncrRefCount(objPtr); + } + } else { + for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { + objPtr = elementPtr->payload.objPtr; + newArray[i++] = objPtr; + Tcl_IncrRefCount(objPtr); + } + } + listRepPtr->elemCount = i; + Tcl_SetObjResult(interp, resultPtr); + } + + done1: + TclStackFree(interp, elementArray); + + done: + if (sortMode == SORTMODE_COMMAND) { + TclDecrRefCount(sortInfo.compareCmdPtr); + TclDecrRefCount(listObj); + sortInfo.compareCmdPtr = NULL; + } + done2: + if (allocatedIndexVector) { + TclStackFree(interp, sortInfo.indexv); + } + return sortInfo.resultCode; } /* @@ -4183,20 +4099,34 @@ MergeSort(headPtr, infoPtr) * The unified list of SortElement structures. * * Side effects: - * None, unless a user-defined comparison command does something weird. + * If infoPtr->unique is set then infoPtr->numElements may be updated. + * Possibly others, if a user-defined comparison command does something + * weird. + * + * Note: + * If infoPtr->unique is set, the merge assumes that there are no + * "repeated" elements in each of the left and right lists. In that case, + * if any element of the left list is equivalent to one in the right list + * it is omitted from the merged list. + * + * This simplified mechanism works because of the special way our + * MergeSort creates the sublists to be merged and will fail to eliminate + * all repeats in the general case where they are already present in + * either the left or right list. A general code would need to skip + * adjacent initial repeats in the left and right lists before comparing + * their initial elements, at each step. * *---------------------------------------------------------------------- */ static SortElement * -MergeLists(leftPtr, rightPtr, infoPtr) - SortElement *leftPtr; /* First list to be merged; may be NULL. */ - SortElement *rightPtr; /* Second list to be merged; may be NULL. */ - SortInfo *infoPtr; /* Information needed by the comparison +MergeLists( + SortElement *leftPtr, /* First list to be merged; may be NULL. */ + SortElement *rightPtr, /* Second list to be merged; may be NULL. */ + SortInfo *infoPtr) /* Information needed by the comparison * operator. */ { - SortElement *headPtr; - SortElement *tailPtr; + SortElement *headPtr, *tailPtr; int cmp; if (leftPtr == NULL) { @@ -4205,31 +4135,48 @@ MergeLists(leftPtr, rightPtr, infoPtr) if (rightPtr == NULL) { return leftPtr; } - cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr); - if (cmp > 0) { + cmp = SortCompare(leftPtr, rightPtr, infoPtr); + if (cmp > 0 || (cmp == 0 && infoPtr->unique)) { + if (cmp == 0) { + infoPtr->numElements--; + leftPtr = leftPtr->nextPtr; + } tailPtr = rightPtr; rightPtr = rightPtr->nextPtr; } else { - if (cmp == 0) { - leftPtr->count++; - } tailPtr = leftPtr; leftPtr = leftPtr->nextPtr; } headPtr = tailPtr; - while ((leftPtr != NULL) && (rightPtr != NULL)) { - cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr); - if (cmp > 0) { - tailPtr->nextPtr = rightPtr; - tailPtr = rightPtr; - rightPtr = rightPtr->nextPtr; - } else { - if (cmp == 0) { - leftPtr->count++; + if (!infoPtr->unique) { + while ((leftPtr != NULL) && (rightPtr != NULL)) { + cmp = SortCompare(leftPtr, rightPtr, infoPtr); + if (cmp > 0) { + tailPtr->nextPtr = rightPtr; + tailPtr = rightPtr; + rightPtr = rightPtr->nextPtr; + } else { + tailPtr->nextPtr = leftPtr; + tailPtr = leftPtr; + leftPtr = leftPtr->nextPtr; + } + } + } else { + while ((leftPtr != NULL) && (rightPtr != NULL)) { + cmp = SortCompare(leftPtr, rightPtr, infoPtr); + if (cmp >= 0) { + if (cmp == 0) { + infoPtr->numElements--; + leftPtr = leftPtr->nextPtr; + } + tailPtr->nextPtr = rightPtr; + tailPtr = rightPtr; + rightPtr = rightPtr->nextPtr; + } else { + tailPtr->nextPtr = leftPtr; + tailPtr = leftPtr; + leftPtr = leftPtr->nextPtr; } - tailPtr->nextPtr = leftPtr; - tailPtr = leftPtr; - leftPtr = leftPtr->nextPtr; } } if (leftPtr != NULL) { @@ -4261,67 +4208,52 @@ MergeLists(leftPtr, rightPtr, infoPtr) */ static int -SortCompare(objPtr1, objPtr2, infoPtr) - Tcl_Obj *objPtr1, *objPtr2; /* Values to be compared. */ - SortInfo *infoPtr; /* Information passed from the top-level +SortCompare( + SortElement *elemPtr1, SortElement *elemPtr2, + /* Values to be compared. */ + SortInfo *infoPtr) /* Information passed from the top-level * "lsort" command. */ { - int order; - - order = 0; - if (infoPtr->resultCode != TCL_OK) { - /* - * Once an error has occurred, skip any future comparisons so as to - * preserve the error message in sortInterp->result. - */ - - return order; - } - - objPtr1 = SelectObjFromSublist(objPtr1, infoPtr); - if (infoPtr->resultCode != TCL_OK) { - return order; - } - objPtr2 = SelectObjFromSublist(objPtr2, infoPtr); - if (infoPtr->resultCode != TCL_OK) { - return order; - } + int order = 0; if (infoPtr->sortMode == SORTMODE_ASCII) { - order = infoPtr->strCmpFn(TclGetString(objPtr1), TclGetString(objPtr2)); + order = strcmp(elemPtr1->collationKey.strValuePtr, + elemPtr2->collationKey.strValuePtr); + } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { + order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr, + elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { - order = DictionaryCompare( - TclGetString(objPtr1), TclGetString(objPtr2)); + order = DictionaryCompare(elemPtr1->collationKey.strValuePtr, + elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_INTEGER) { long a, b; - if ((Tcl_GetLongFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK) - || (Tcl_GetLongFromObj(infoPtr->interp, objPtr2, &b) - != TCL_OK)) { - infoPtr->resultCode = TCL_ERROR; - return order; - } - if (a > b) { - order = 1; - } else if (b > a) { - order = -1; - } + a = elemPtr1->collationKey.intValue; + b = elemPtr2->collationKey.intValue; + order = ((a >= b) - (a <= b)); } else if (infoPtr->sortMode == SORTMODE_REAL) { double a, b; - if (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK - || Tcl_GetDoubleFromObj(infoPtr->interp,objPtr2,&b) != TCL_OK){ - infoPtr->resultCode = TCL_ERROR; - return order; - } - if (a > b) { - order = 1; - } else if (b > a) { - order = -1; - } + a = elemPtr1->collationKey.doubleValue; + b = elemPtr2->collationKey.doubleValue; + order = ((a >= b) - (a <= b)); } else { Tcl_Obj **objv, *paramObjv[2]; int objc; + Tcl_Obj *objPtr1, *objPtr2; + + if (infoPtr->resultCode != TCL_OK) { + /* + * Once an error has occurred, skip any future comparisons so as + * to preserve the error message in sortInterp->result. + */ + + return 0; + } + + + objPtr1 = elemPtr1->collationKey.objValuePtr; + objPtr2 = elemPtr2->collationKey.objValuePtr; paramObjv[0] = objPtr1; paramObjv[1] = objPtr2; @@ -4331,31 +4263,31 @@ SortCompare(objPtr1, objPtr2, infoPtr) * Replace them and evaluate the result. */ - Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); + TclListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2, 2, 2, paramObjv); - Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr, + TclListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr, &objc, &objv); infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0); if (infoPtr->resultCode != TCL_OK) { - Tcl_AddErrorInfo(infoPtr->interp, - "\n (-compare command)"); - return order; + Tcl_AddErrorInfo(infoPtr->interp, "\n (-compare command)"); + return 0; } /* * Parse the result of the command. */ - if (Tcl_GetIntFromObj(infoPtr->interp, + if (TclGetIntFromObj(infoPtr->interp, Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) { - Tcl_ResetResult(infoPtr->interp); - Tcl_AppendResult(infoPtr->interp, - "-compare command returned non-integer result", NULL); + Tcl_SetObjResult(infoPtr->interp, Tcl_NewStringObj( + "-compare command returned non-integer result", -1)); + Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", + "COMPARISONFAILED", NULL); infoPtr->resultCode = TCL_ERROR; - return order; + return 0; } } if (!infoPtr->isIncreasing) { @@ -4389,8 +4321,8 @@ SortCompare(objPtr1, objPtr2, infoPtr) */ static int -DictionaryCompare(left, right) - char *left, *right; /* The strings to compare. */ +DictionaryCompare( + const char *left, const char *right) /* The strings to compare. */ { Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower; int diff, zeros; @@ -4407,11 +4339,11 @@ DictionaryCompare(left, right) */ zeros = 0; - while ((*right == '0') && (isdigit(UCHAR(right[1])))) { + while ((*right == '0') && isdigit(UCHAR(right[1]))) { right++; zeros--; } - while ((*left == '0') && (isdigit(UCHAR(left[1])))) { + while ((*left == '0') && isdigit(UCHAR(left[1]))) { left++; zeros++; } @@ -4468,7 +4400,7 @@ DictionaryCompare(left, right) * Convert both chars to lower for the comparison, because * dictionary sorts are case insensitve. Covert to lower, not * upper, so chars between Z and a will sort before A (where most - * other interesting punctuations occur) + * other interesting punctuations occur). */ uniLeftLower = Tcl_UniCharToLower(uniLeft); @@ -4481,7 +4413,8 @@ DictionaryCompare(left, right) diff = uniLeftLower - uniRightLower; if (diff) { return diff; - } else if (secondaryDiff == 0) { + } + if (secondaryDiff == 0) { if (Tcl_UniCharIsUpper(uniLeft) && Tcl_UniCharIsLower(uniRight)) { secondaryDiff = -1; } else if (Tcl_UniCharIsUpper(uniRight) @@ -4501,9 +4434,8 @@ DictionaryCompare(left, right) * * SelectObjFromSublist -- * - * This procedure is invoked from lsearch and SortCompare. It is used - * for implementing the -index option, for the lsort and lsearch - * commands. + * This procedure is invoked from lsearch and SortCompare. It is used for + * implementing the -index option, for the lsort and lsearch commands. * * Results: * Returns NULL if a failure occurs, and sets the result in the infoPtr. @@ -4519,10 +4451,10 @@ DictionaryCompare(left, right) *---------------------------------------------------------------------- */ -static Tcl_Obj* -SelectObjFromSublist(objPtr, infoPtr) - Tcl_Obj *objPtr; /* Obj to select sublist from. */ - SortInfo *infoPtr; /* Information passed from the top-level +static Tcl_Obj * +SelectObjFromSublist( + Tcl_Obj *objPtr, /* Obj to select sublist from. */ + SortInfo *infoPtr) /* Information passed from the top-level * "lsearch" or "lsort" command. */ { int i; @@ -4544,8 +4476,7 @@ SelectObjFromSublist(objPtr, infoPtr) int listLen, index; Tcl_Obj *currentObj; - if (Tcl_ListObjLength(infoPtr->interp, objPtr, - &listLen) != TCL_OK) { + if (TclListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; return NULL; } @@ -4565,11 +4496,11 @@ SelectObjFromSublist(objPtr, infoPtr) return NULL; } if (currentObj == NULL) { - char buffer[TCL_INTEGER_SPACE]; - TclFormatInt(buffer, index); - Tcl_AppendResult(infoPtr->interp, - "element ", buffer, " missing from sublist \"", - TclGetString(objPtr), "\"", (char *) NULL); + Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( + "element %d missing from sublist \"%s\"", + index, TclGetString(objPtr))); + Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", + "INDEXFAILED", NULL); infoPtr->resultCode = TCL_ERROR; return NULL; } @@ -4583,5 +4514,6 @@ SelectObjFromSublist(objPtr, infoPtr) * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 * End: */ |