diff options
Diffstat (limited to 'generic/tclCmdIL.c')
| -rw-r--r-- | generic/tclCmdIL.c | 2858 |
1 files changed, 769 insertions, 2089 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index de96267..02e5812 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -3,15 +3,15 @@ * * 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 © 1987-1993 The Regents of the University of California. - * Copyright © 1993-1997 Lucent Technologies. - * Copyright © 1994-1997 Sun Microsystems, Inc. - * Copyright © 1998-1999 Scriptics Corporation. - * Copyright © 2001 Kevin B. Kenny. All rights reserved. - * Copyright © 2005 Donal K. Fellows. + * 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) 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. @@ -19,9 +19,6 @@ #include "tclInt.h" #include "tclRegexp.h" -#include "tclTomMath.h" -#include <math.h> -#include <assert.h> /* * During execution of the "lsort" command, structures of the following type @@ -30,16 +27,13 @@ */ typedef struct SortElement { - union { /* The value that we sorting by. */ - const char *strValuePtr; - Tcl_WideInt wideValue; + union { + char *strValuePtr; + long intValue; double doubleValue; Tcl_Obj *objValuePtr; - } collationKey; - union { /* Object being sorted, or its index. */ - Tcl_Obj *objPtr; - Tcl_Size index; - } payload; + } index; + Tcl_Obj *objPtr; /* Object being sorted, or its index. */ struct SortElement *nextPtr;/* Next element in the list, or NULL for end * of list. */ } SortElement; @@ -50,6 +44,7 @@ typedef struct SortElement { */ typedef int (*SortStrCmpFn_t) (const char *, const char *); +typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t); /* * The "lsort" command needs to pass certain information down to the function @@ -58,21 +53,20 @@ typedef int (*SortStrCmpFn_t) (const char *, const char *); * The following structure is used to pass this information. */ -typedef struct { +typedef struct SortInfo { int isIncreasing; /* Nonzero means sort in increasing order. */ int sortMode; /* The sort mode. One of SORTMODE_* values * defined below. */ Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode is - * SORTMODE_COMMAND. Preinitialized to hold + * SORTMODE_COMMAND. Pre-initialized to hold * base of command. */ int *indexv; /* If the -index option was specified, this - * holds an encoding of the indexes contained - * in the list supplied as an argument to - * that option. + * holds the indexes contained in the list + * supplied as an argument to that option. * NULL if no indexes supplied, and points to * singleIndex field when only one * supplied. */ - Tcl_Size indexc; /* Number of indexes in indexv array. */ + int indexc; /* Number of indexes in indexv array. */ int singleIndex; /* Static space for common index case. */ int unique; int numElements; @@ -96,51 +90,57 @@ typedef struct { #define SORTMODE_ASCII_NC 8 /* - * Definitions for [lseq] command + * Magic values for the index field of the SortInfo structure. Note that the + * index "end-1" will be translated to SORTIDX_END-1, etc. */ -static const char *const seq_operations[] = { - "..", "to", "count", "by", NULL -}; -typedef enum Sequence_Operators { - LSEQ_DOTS, LSEQ_TO, LSEQ_COUNT, LSEQ_BY -} SequenceOperators; -static const char *const seq_step_keywords[] = {"by", NULL}; -typedef enum Step_Operators { - STEP_BY = 4 -} SequenceByMode; -typedef enum Sequence_Decoded { - NoneArg, NumericArg, RangeKeywordArg, ByKeywordArg -} SequenceDecoded; + +#define SORTIDX_NONE -1 /* Not indexed; use whole value. */ +#define SORTIDX_END -2 /* Indexed from end. */ /* * Forward declarations for procedures defined in this file: */ -static int DictionaryCompare(const char *left, const char *right); -static Tcl_NRPostProc IfConditionCallback; -static Tcl_ObjCmdProc InfoArgsCmd; -static Tcl_ObjCmdProc InfoBodyCmd; -static Tcl_ObjCmdProc InfoCmdCountCmd; -static Tcl_ObjCmdProc InfoCommandsCmd; -static Tcl_ObjCmdProc InfoCompleteCmd; -static Tcl_ObjCmdProc InfoDefaultCmd; -/* TIP #348 - New 'info' subcommand 'errorstack' */ -static Tcl_ObjCmdProc InfoErrorStackCmd; +static int DictionaryCompare(char *left, char *right); +static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoBodyCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoCmdCountCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoCommandsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoCompleteCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); /* TIP #280 - New 'info' subcommand 'frame' */ -static Tcl_ObjCmdProc InfoFrameCmd; -static Tcl_ObjCmdProc InfoFunctionsCmd; -static Tcl_ObjCmdProc InfoHostnameCmd; -static Tcl_ObjCmdProc InfoLevelCmd; -static Tcl_ObjCmdProc InfoLibraryCmd; -static Tcl_ObjCmdProc InfoLoadedCmd; -static Tcl_ObjCmdProc InfoNameOfExecutableCmd; -static Tcl_ObjCmdProc InfoPatchLevelCmd; -static Tcl_ObjCmdProc InfoProcsCmd; -static Tcl_ObjCmdProc InfoScriptCmd; -static Tcl_ObjCmdProc InfoSharedlibCmd; -static Tcl_ObjCmdProc InfoCmdTypeCmd; -static Tcl_ObjCmdProc InfoTclVersionCmd; -static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr, +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 InfoHostnameCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoLevelCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoLibraryCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoLoadedCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoNameOfExecutableCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int InfoPatchLevelCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoProcsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr, SortInfo *infoPtr); static int SortCompare(SortElement *firstPtr, SortElement *second, SortInfo *infoPtr); @@ -153,32 +153,29 @@ static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr, */ static const EnsembleImplMap defaultInfoMap[] = { - {"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, - {"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"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, 1}, - {"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} + {"args", InfoArgsCmd, NULL}, + {"body", InfoBodyCmd, NULL}, + {"cmdcount", InfoCmdCountCmd, NULL}, + {"commands", InfoCommandsCmd, NULL}, + {"complete", InfoCompleteCmd, NULL}, + {"default", InfoDefaultCmd, NULL}, + {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd}, + {"frame", InfoFrameCmd, NULL}, + {"functions", InfoFunctionsCmd, NULL}, + {"globals", TclInfoGlobalsCmd, NULL}, + {"hostname", InfoHostnameCmd, NULL}, + {"level", InfoLevelCmd, NULL}, + {"library", InfoLibraryCmd, NULL}, + {"loaded", InfoLoadedCmd, NULL}, + {"locals", TclInfoLocalsCmd, NULL}, + {"nameofexecutable", InfoNameOfExecutableCmd, NULL}, + {"patchlevel", InfoPatchLevelCmd, NULL}, + {"procs", InfoProcsCmd, NULL}, + {"script", InfoScriptCmd, NULL}, + {"sharedlibextension", InfoSharedlibCmd, NULL}, + {"tclversion", InfoTclVersionCmd, NULL}, + {"vars", TclInfoVarsCmd, NULL}, + {NULL, NULL, NULL} }; /* @@ -204,71 +201,45 @@ static const EnsembleImplMap defaultInfoMap[] = { int Tcl_IfObjCmd( - void *clientData, - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, TclNRIfObjCmd, clientData, objc, objv); -} - -int -TclNRIfObjCmd( - TCL_UNUSED(void *), + 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", (void *)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), - (void *) objv, INT2PTR(1), boolObj); - return Tcl_NRExprObj(interp, objv[1], boolObj); -} - -static int -IfConditionCallback( - void *data[], - Tcl_Interp *interp, - int result) -{ + int thenScriptIndex = 0; /* "then" script to be evaled after syntax + * check. */ Interp *iPtr = (Interp *) interp; - int objc = PTR2INT(data[0]); - Tcl_Obj *const *objv = (Tcl_Obj *const *)data[1]; - int i = PTR2INT(data[2]); - Tcl_Obj *boolObj = (Tcl_Obj *)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); + 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. + */ + + if (i >= objc) { + clause = TclGetString(objv[i-1]); + Tcl_AppendResult(interp, "wrong # args: ", + "no expression after \"", clause, "\" argument", NULL); + return TCL_ERROR; + } + if (!thenScriptIndex) { + result = Tcl_ExprBooleanObj(interp, objv[i], &value); + if (result != TCL_OK) { + return result; + } + } i++; if (i >= objc) { - goto missingScript; + missingScript: + clause = TclGetString(objv[i-1]); + Tcl_AppendResult(interp, "wrong # args: ", + "no script following \"", clause, "\" argument", NULL); + return TCL_ERROR; } clause = TclGetString(objv[i]); if ((i < objc) && (strcmp(clause, "then") == 0)) { @@ -294,37 +265,17 @@ IfConditionCallback( * TIP #280. Make invoking context available to branch. */ - return TclNREvalObjEx(interp, objv[thenScriptIndex], 0, + return TclEvalObjEx(interp, objv[thenScriptIndex], 0, iPtr->cmdFramePtr, thenScriptIndex); } return TCL_OK; } clause = TclGetString(objv[i]); - 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", (void *)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); + if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) { + i++; + continue; } + break; } /* @@ -336,14 +287,14 @@ IfConditionCallback( if (strcmp(clause, "else") == 0) { i++; if (i >= objc) { - goto missingScript; + Tcl_AppendResult(interp, "wrong # args: ", + "no script following \"else\" argument", NULL); + return TCL_ERROR; } } if (i < objc - 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "wrong # args: extra words after \"else\" clause in \"if\" command", - -1)); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (void *)NULL); + Tcl_AppendResult(interp, "wrong # args: ", + "extra words after \"else\" clause in \"if\" command", NULL); return TCL_ERROR; } if (thenScriptIndex) { @@ -351,17 +302,10 @@ IfConditionCallback( * TIP #280. Make invoking context available to branch/else. */ - return TclNREvalObjEx(interp, objv[thenScriptIndex], 0, + return TclEvalObjEx(interp, objv[thenScriptIndex], 0, iPtr->cmdFramePtr, thenScriptIndex); } - 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", (void *)NULL); - return TCL_ERROR; + return TclEvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i); } /* @@ -387,7 +331,7 @@ IfConditionCallback( int Tcl_IncrObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -402,7 +346,7 @@ Tcl_IncrObjCmd( if (objc == 3) { incrPtr = objv[2]; } else { - TclNewIntObj(incrPtr, 1); + incrPtr = Tcl_NewIntObj(1); } Tcl_IncrRefCount(incrPtr); newValuePtr = TclIncrObjVar2(interp, objv[1], NULL, @@ -431,7 +375,7 @@ Tcl_IncrObjCmd( * documentation for details on what it does. * * Results: - * Handle for the info command, or NULL on failure. + * FIXME * * Side effects: * none @@ -468,13 +412,13 @@ TclInitInfoCmd( static int InfoArgsCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Interp *iPtr = (Interp *) interp; - const char *name; + register Interp *iPtr = (Interp *) interp; + char *name; Proc *procPtr; CompiledLocal *localPtr; Tcl_Obj *listObjPtr; @@ -487,9 +431,7 @@ InfoArgsCmd( name = TclGetString(objv[1]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't a procedure", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, (void *)NULL); + Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL); return TCL_ERROR; } @@ -531,15 +473,15 @@ InfoArgsCmd( static int InfoBodyCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Interp *iPtr = (Interp *) interp; - const char *name, *bytes; + register Interp *iPtr = (Interp *) interp; + char *name; Proc *procPtr; - Tcl_Size numBytes; + Tcl_Obj *bodyPtr, *resultPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "procname"); @@ -549,9 +491,7 @@ InfoBodyCmd( name = TclGetString(objv[1]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't a procedure", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, (void *)NULL); + Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL); return TCL_ERROR; } @@ -564,8 +504,18 @@ InfoBodyCmd( * the object do not invalidate the internal rep. */ - bytes = TclGetStringFromObj(procPtr->bodyPtr, &numBytes); - Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes)); + bodyPtr = procPtr->bodyPtr; + if (bodyPtr->bytes == NULL) { + /* + * The string rep might not be valid if the procedure has never been + * run before. [Bug #545644] + */ + + (void) TclGetString(bodyPtr); + } + resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); + + Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } @@ -592,7 +542,7 @@ InfoBodyCmd( static int InfoCmdCountCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -604,7 +554,7 @@ InfoCmdCountCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->cmdCount)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->cmdCount)); return TCL_OK; } @@ -634,14 +584,14 @@ InfoCmdCountCmd( static int InfoCommandsCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *cmdName, *pattern; + char *cmdName, *pattern; const char *simplePattern; - Tcl_HashEntry *entryPtr; + register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Namespace *nsPtr; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); @@ -649,7 +599,7 @@ InfoCommandsCmd( Tcl_Obj *listPtr, *elemObjPtr; int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ Tcl_Command cmd; - Tcl_Size i; + int i; /* * Get the pattern and find the "effective namespace" in which to list @@ -672,8 +622,8 @@ InfoCommandsCmd( Namespace *dummy1NsPtr, *dummy2NsPtr; pattern = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, pattern, NULL, 0, &nsPtr, - &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, 0, + &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ specificNsInPattern = (strcmp(simplePattern, pattern) != 0); @@ -709,11 +659,11 @@ InfoCommandsCmd( entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); if (entryPtr != NULL) { if (specificNsInPattern) { - cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr); - TclNewObj(elemObjPtr); + cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); + elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, cmd, elemObjPtr); } else { - cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); elemObjPtr = Tcl_NewStringObj(cmdName, -1); } Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); @@ -740,7 +690,7 @@ InfoCommandsCmd( entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern); } if (entryPtr != NULL) { - cmdName = (const char *)Tcl_GetHashKey(tablePtr, entryPtr); + cmdName = Tcl_GetHashKey(tablePtr, entryPtr); Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(cmdName, -1)); Tcl_SetObjResult(interp, listPtr); @@ -756,12 +706,12 @@ InfoCommandsCmd( entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); while (entryPtr != NULL) { - cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { if (specificNsInPattern) { - cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr); - TclNewObj(elemObjPtr); + cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); + elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, cmd, elemObjPtr); } else { elemObjPtr = Tcl_NewStringObj(cmdName, -1); @@ -782,7 +732,7 @@ InfoCommandsCmd( if ((nsPtr != globalNsPtr) && !specificNsInPattern) { entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); while (entryPtr != NULL) { - cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); + cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) { @@ -813,13 +763,13 @@ InfoCommandsCmd( entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); while (entryPtr != NULL) { - cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { elemObjPtr = Tcl_NewStringObj(cmdName, -1); Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); (void) Tcl_CreateHashEntry(&addedCommandsTable, - elemObjPtr, &isNew); + (char *)elemObjPtr, &isNew); } entryPtr = Tcl_NextHashEntry(&search); } @@ -839,12 +789,12 @@ InfoCommandsCmd( } entryPtr = Tcl_FirstHashEntry(&pathNsPtr->cmdTable, &search); while (entryPtr != NULL) { - cmdName = (const char *)Tcl_GetHashKey(&pathNsPtr->cmdTable, entryPtr); + cmdName = Tcl_GetHashKey(&pathNsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { elemObjPtr = Tcl_NewStringObj(cmdName, -1); (void) Tcl_CreateHashEntry(&addedCommandsTable, - elemObjPtr, &isNew); + (char *) elemObjPtr, &isNew); if (isNew) { Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); } else { @@ -866,7 +816,7 @@ InfoCommandsCmd( if (!foundGlobal) { entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); while (entryPtr != NULL) { - cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); + cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { elemObjPtr = Tcl_NewStringObj(cmdName, -1); @@ -911,7 +861,7 @@ InfoCommandsCmd( static int InfoCompleteCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -948,13 +898,13 @@ InfoCompleteCmd( static int InfoDefaultCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - const char *procName, *argName; + char *procName, *argName, *varName; Proc *procPtr; CompiledLocal *localPtr; Tcl_Obj *valueObjPtr; @@ -969,10 +919,7 @@ InfoDefaultCmd( procPtr = TclFindProc(iPtr, procName); if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't a procedure", procName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName, - (void *)NULL); + Tcl_AppendResult(interp, "\"", procName, "\" isn't a procedure",NULL); return TCL_ERROR; } @@ -982,80 +929,33 @@ InfoDefaultCmd( && (strcmp(argName, localPtr->name) == 0)) { if (localPtr->defValuePtr != NULL) { valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, - localPtr->defValuePtr, TCL_LEAVE_ERR_MSG); + localPtr->defValuePtr, 0); if (valueObjPtr == NULL) { - return TCL_ERROR; + goto defStoreError; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); } else { - Tcl_Obj *nullObjPtr; - - TclNewObj(nullObjPtr); + Tcl_Obj *nullObjPtr = Tcl_NewObj(); valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, - nullObjPtr, TCL_LEAVE_ERR_MSG); + nullObjPtr, 0); if (valueObjPtr == NULL) { - return TCL_ERROR; + goto defStoreError; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } return TCL_OK; } } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\" doesn't have an argument \"%s\"", - procName, argName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, (void *)NULL); + Tcl_AppendResult(interp, "procedure \"", procName, + "\" doesn't have an argument \"", argName, "\"", NULL); return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * InfoErrorStackCmd -- - * - * Called to implement the "info errorstack" command that returns information - * about the last error's call stack. Handles the following syntax: - * - * info errorstack ?interp? - * - * 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 -InfoErrorStackCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *target; - Interp *iPtr; - - if ((objc != 1) && (objc != 2)) { - Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); - return TCL_ERROR; - } - - target = interp; - if (objc == 2) { - target = Tcl_GetChild(interp, TclGetString(objv[1])); - if (target == NULL) { - return TCL_ERROR; - } - } - - iPtr = (Interp *) target; - Tcl_SetObjResult(interp, iPtr->errorStack); - return TCL_OK; + defStoreError: + varName = TclGetString(objv[3]); + Tcl_AppendResult(interp, "couldn't store default value in variable \"", + varName, "\"", NULL); + return TCL_ERROR; } /* @@ -1080,12 +980,12 @@ InfoErrorStackCmd( int TclInfoExistsCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *varName; + char *varName; Var *varPtr; if (objc != 2) { @@ -1125,53 +1025,28 @@ TclInfoExistsCmd( static int InfoFrameCmd( - TCL_UNUSED(void *), + 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, code = TCL_OK; - CmdFrame *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr; - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - int topLevel = 0; - - 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; - } + int level; + CmdFrame *framePtr; if (objc == 1) { /* * Just "info frame". */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(topLevel)); - goto done; + int levels = + (iPtr->cmdFramePtr == NULL ? 0 : iPtr->cmdFramePtr->level); + + Tcl_SetObjResult(interp, Tcl_NewIntObj (levels)); + return TCL_OK; + } else if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?number?"); + return TCL_ERROR; } /* @@ -1179,62 +1054,40 @@ InfoFrameCmd( */ if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) { - code = TCL_ERROR; - goto done; + return TCL_ERROR; } + if (level <= 0) { + /* + * Negative levels are adressing relative to the current frame's + * depth. + */ - if ((level > topLevel) || (level <= - topLevel)) { - levelError: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad level \"%s\"", TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", - TclGetString(objv[1]), (void *)NULL); - code = TCL_ERROR; - goto done; - } + if (iPtr->cmdFramePtr == NULL) { + levelError: + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad level \"", + TclGetString(objv[1]), "\"", NULL); + return TCL_ERROR; + } - /* - * Let us convert to relative so that we know how many levels to go back - */ + /* + * Convert to absolute. + */ - if (level > 0) { - level -= topLevel; + level += iPtr->cmdFramePtr->level; } - framePtr = iPtr->cmdFramePtr; - while (++level <= 0) { - framePtr = framePtr->nextPtr; - if (!framePtr) { - goto levelError; + for (framePtr = iPtr->cmdFramePtr; framePtr != NULL; + framePtr = framePtr->nextPtr) { + if (framePtr->level == level) { + break; } } + if (framePtr == NULL) { + 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; - } - corPtr = corPtr->callerEEPtr->corPtr; - } - return code; + return TCL_OK; } /* @@ -1259,21 +1112,21 @@ TclInfoFrame( CmdFrame *framePtr) /* Frame to get info for. */ { Interp *iPtr = (Interp *) interp; - Tcl_Obj *tmpObj; - Tcl_Obj *lv[20] = {NULL}; /* Keep uptodate when more keys are added to + Tcl_Obj *lv[20]; /* Keep uptodate when more keys are added to * the dict. */ int lc = 0; /* * This array is indexed by the TCL_LOCATION_... values, except * for _LAST. */ - static const char *const typeString[TCL_LOCATION_LAST] = { + static const char *typeString[TCL_LOCATION_LAST] = { "eval", "eval", "eval", "precompiled", "source", "proc" }; - Proc *procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; - int needsFree = -1; + Tcl_Obj *tmpObj; + Proc *procPtr = + framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; - /* + /* * Pull the information and construct the dictionary to return, as list. * Regarding use of the CmdFrame fields see tclInt.h, and its definition. */ @@ -1291,12 +1144,28 @@ TclInfoFrame( */ ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); - if (framePtr->line) { - ADD_PAIR("line", Tcl_NewWideIntObj(framePtr->line[0])); - } else { - ADD_PAIR("line", Tcl_NewWideIntObj(1)); - } - ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); + ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); + ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd, + framePtr->cmd.str.len)); + break; + + case TCL_LOCATION_EVAL_LIST: + /* + * List optimized evaluation. Type, line, cmd, the latter through + * listPtr, possibly a frame. + */ + + ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); + ADD_PAIR("line", Tcl_NewIntObj(1)); + + /* + * We put a duplicate of the command list obj into the result to + * ensure that the 'pure List'-property of the command itself is not + * destroyed. Otherwise the query here would disable the list + * optimization path in Tcl_EvalObjEx. + */ + + ADD_PAIR("cmd", Tcl_DuplicateObj(framePtr->cmd.listPtr)); break; case TCL_LOCATION_PREBC: @@ -1312,8 +1181,9 @@ TclInfoFrame( * Execution of bytecode. Talk to the BC engine to fill out the frame. */ - CmdFrame *fPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame)); + CmdFrame *fPtr; + fPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); *fPtr = *framePtr; /* @@ -1331,7 +1201,7 @@ TclInfoFrame( ADD_PAIR("type", Tcl_NewStringObj(typeString[fPtr->type], -1)); if (fPtr->line) { - ADD_PAIR("line", Tcl_NewWideIntObj(fPtr->line[0])); + ADD_PAIR("line", Tcl_NewIntObj(fPtr->line[0])); } if (fPtr->type == TCL_LOCATION_SOURCE) { @@ -1344,10 +1214,8 @@ TclInfoFrame( Tcl_DecrRefCount(fPtr->data.eval.path); } - ADD_PAIR("cmd", TclGetSourceFromFrame(fPtr, 0, NULL)); - if (fPtr->cmdObj && framePtr->cmdObj == NULL) { - needsFree = lc - 1; - } + ADD_PAIR("cmd", + Tcl_NewStringObj(fPtr->cmd.str.cmd, fPtr->cmd.str.len)); TclStackFree(interp, fPtr); break; } @@ -1358,7 +1226,7 @@ TclInfoFrame( */ ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); - ADD_PAIR("line", Tcl_NewWideIntObj(framePtr->line[0])); + ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); ADD_PAIR("file", framePtr->data.eval.path); /* @@ -1366,7 +1234,8 @@ TclInfoFrame( * the result list object. */ - ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); + ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd, + framePtr->cmd.str.len)); break; case TCL_LOCATION_PROC: @@ -1383,19 +1252,22 @@ TclInfoFrame( 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); + char *procName = Tcl_GetHashKey(namePtr->tablePtr, namePtr); + char *nsName = procPtr->cmdPtr->nsPtr->fullName; + + ADD_PAIR("proc", Tcl_NewStringObj(nsName, -1)); + + if (strcmp(nsName, "::") != 0) { + Tcl_AppendToObj(lv[lc-1], "::", -1); + } + Tcl_AppendToObj(lv[lc-1], procName, -1); } else if (procPtr->cmdPtr->clientData) { - ExtraFrameInfo *efiPtr = (ExtraFrameInfo *)procPtr->cmdPtr->clientData; - Tcl_Size i; + ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData; + int i; /* * This is a non-standard command. Luckily, it's told us how to @@ -1408,7 +1280,7 @@ TclInfoFrame( lv[lc++] = efiPtr->fields[i].proc(efiPtr->fields[i].clientData); } else { - lv[lc++] = (Tcl_Obj *)efiPtr->fields[i].clientData; + lv[lc++] = efiPtr->fields[i].clientData; } } } @@ -1429,17 +1301,13 @@ TclInfoFrame( int c = framePtr->framePtr->level; int t = iPtr->varFramePtr->level; - ADD_PAIR("level", Tcl_NewWideIntObj(t - c)); + ADD_PAIR("level", Tcl_NewIntObj(t - c)); break; } } } - tmpObj = Tcl_NewListObj(lc, lv); - if (needsFree >= 0) { - Tcl_DecrRefCount(lv[needsFree]); - } - return tmpObj; + return Tcl_NewListObj(lc, lv); } /* @@ -1465,7 +1333,7 @@ TclInfoFrame( static int InfoFunctionsCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1530,7 +1398,7 @@ InfoFunctionsCmd( static int InfoHostnameCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1547,10 +1415,7 @@ InfoHostnameCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1)); return TCL_OK; } - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unable to determine name of host", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", (void *)NULL); + Tcl_SetResult(interp, "unable to determine name of host", TCL_STATIC); return TCL_ERROR; } @@ -1576,7 +1441,7 @@ InfoHostnameCmd( static int InfoLevelCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1584,7 +1449,7 @@ InfoLevelCmd( Interp *iPtr = (Interp *) interp; if (objc == 1) { /* Just "info level" */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->varFramePtr->level)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->varFramePtr->level)); return TCL_OK; } @@ -1620,10 +1485,8 @@ InfoLevelCmd( return TCL_ERROR; levelError: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad level \"%s\"", TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", - TclGetString(objv[1]), (void *)NULL); + Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"", + NULL); return TCL_ERROR; } @@ -1650,7 +1513,7 @@ InfoLevelCmd( static int InfoLibraryCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1662,15 +1525,12 @@ InfoLibraryCmd( return TCL_ERROR; } - libDirName = Tcl_GetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY); + libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); if (libDirName != NULL) { 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", (void *)NULL); + Tcl_SetResult(interp, "no library has been specified for Tcl",TCL_STATIC); return TCL_ERROR; } @@ -1697,29 +1557,24 @@ InfoLibraryCmd( static int InfoLoadedCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *interpName, *packageName; + char *interpName; - if (objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?interp? ?packageName?"); + 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[1]); } - if (objc < 3) { /* Get loaded files in all packages. */ - packageName = NULL; - } else { /* Get pkgs just in specified interp. */ - packageName = TclGetString(objv[2]); - } - return TclGetLoadedLibraries(interp, interpName, packageName); + return TclGetLoadedPackages(interp, interpName); } /* @@ -1745,7 +1600,7 @@ InfoLoadedCmd( static int InfoNameOfExecutableCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1781,7 +1636,7 @@ InfoNameOfExecutableCmd( static int InfoPatchLevelCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1793,7 +1648,7 @@ InfoPatchLevelCmd( return TCL_ERROR; } - patchlevel = Tcl_GetVar2(interp, "tcl_patchLevel", NULL, + patchlevel = Tcl_GetVar(interp, "tcl_patchLevel", (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); if (patchlevel != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(patchlevel, -1)); @@ -1828,12 +1683,12 @@ InfoPatchLevelCmd( static int InfoProcsCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *cmdName, *pattern; + char *cmdName, *pattern; const char *simplePattern; Namespace *nsPtr; #ifdef INFO_PROCS_SEARCH_GLOBAL_NS @@ -1842,7 +1697,7 @@ InfoProcsCmd( Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_Obj *listPtr, *elemObjPtr; int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ - Tcl_HashEntry *entryPtr; + register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Command *cmdPtr, *realCmdPtr; @@ -1867,8 +1722,9 @@ InfoProcsCmd( Namespace *dummy1NsPtr, *dummy2NsPtr; pattern = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, pattern, NULL, /*flags*/ 0, &nsPtr, - &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + 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); @@ -1894,7 +1750,7 @@ InfoProcsCmd( if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); if (entryPtr != NULL) { - cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); if (!TclIsProc(cmdPtr)) { realCmdPtr = (Command *) @@ -1905,7 +1761,7 @@ InfoProcsCmd( } else { simpleProcOK: if (specificNsInPattern) { - TclNewObj(elemObjPtr); + elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, elemObjPtr); } else { @@ -1919,22 +1775,22 @@ InfoProcsCmd( { entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); while (entryPtr != NULL) { - cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { - cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); if (!TclIsProc(cmdPtr)) { realCmdPtr = (Command *) - TclGetOriginalCommand((Tcl_Command)cmdPtr); + TclGetOriginalCommand((Tcl_Command) cmdPtr); if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { goto procOK; } } else { procOK: if (specificNsInPattern) { - TclNewObj(elemObjPtr); - Tcl_GetCommandFullName(interp, (Tcl_Command)cmdPtr, + elemObjPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, elemObjPtr); } else { elemObjPtr = Tcl_NewStringObj(cmdName, -1); @@ -1957,7 +1813,7 @@ InfoProcsCmd( /* * If "info procs" worked like "info commands", returning the commands * also seen in the global namespace, then you would include this - * code. As this could break backwards compatibility with 8.0-8.2, we + * code. As this could break backwards compatibilty with 8.0-8.2, we * decided not to "fix" it in 8.3, leaving the behavior slightly * different. */ @@ -1965,11 +1821,11 @@ InfoProcsCmd( if ((nsPtr != globalNsPtr) && !specificNsInPattern) { entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); while (entryPtr != NULL) { - cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); + 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); + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); realCmdPtr = (Command *) TclGetOriginalCommand( (Tcl_Command) cmdPtr); @@ -2015,13 +1871,12 @@ InfoProcsCmd( static int InfoScriptCmd( - TCL_UNUSED(void *), + 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 != 1) && (objc != 2)) { Tcl_WrongNumArgs(interp, 1, objv, "?filename?"); return TCL_ERROR; @@ -2063,7 +1918,7 @@ InfoScriptCmd( static int InfoSharedlibCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2101,7 +1956,7 @@ InfoSharedlibCmd( static int InfoTclVersionCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2125,60 +1980,6 @@ InfoTclVersionCmd( /* *---------------------------------------------------------------------- * - * InfoCmdTypeCmd -- - * - * Called to implement the "info cmdtype" command that returns the type - * of a given command. Handles the following syntax: - * - * info cmdtype cmdName - * - * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. - * - * Side effects: - * Returns a type name. If there is an error, the result is an error - * message. - * - *---------------------------------------------------------------------- - */ - -static int -InfoCmdTypeCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Command command; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "commandName"); - return TCL_ERROR; - } - command = Tcl_FindCommand(interp, TclGetString(objv[1]), NULL, - TCL_LEAVE_ERR_MSG); - if (command == NULL) { - return TCL_ERROR; - } - - /* - * There's one special case: safe interpreters can't see aliases as - * aliases as they're part of the security mechanisms. - */ - - if (Tcl_IsSafe(interp) - && (((Command *) command)->objProc == TclAliasObjCmd)) { - Tcl_AppendResult(interp, "native", (void *)NULL); - } else { - Tcl_SetObjResult(interp, - Tcl_NewStringObj(TclGetCommandTypeName(command), -1)); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_JoinObjCmd -- * * This procedure is invoked to process the "join" Tcl command. See the @@ -2195,14 +1996,13 @@ InfoCmdTypeCmd( int Tcl_JoinObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - Tcl_Size length, listLen; - int isArithSeries = 0; - Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs; + int listLen, i; + Tcl_Obj *resObjPtr, *joinObjPtr, **elemPtrs; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?"); @@ -2214,88 +2014,24 @@ Tcl_JoinObjCmd( * pointer to its array of element pointers. */ - if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { - isArithSeries = 1; - listLen = TclArithSeriesObjLength(objv[1]); - } else { - if (TclListObjGetElements(interp, objv[1], &listLen, + if (TclListObjGetElements(interp, objv[1], &listLen, &elemPtrs) != TCL_OK) { - return TCL_ERROR; - } - } - - if (listLen == 0) { - /* No elements to join; default empty result is correct. */ - return TCL_OK; - } - if (listLen == 1) { - /* One element; return it */ - if (isArithSeries) { - Tcl_Obj *valueObj = TclArithSeriesObjIndex(interp, objv[1], 0); - if (valueObj == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, valueObj); - } else { - Tcl_SetObjResult(interp, elemPtrs[0]); - } - return TCL_OK; + return TCL_ERROR; } joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; Tcl_IncrRefCount(joinObjPtr); - (void) TclGetStringFromObj(joinObjPtr, &length); - if (length == 0) { - resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0); - } else { - Tcl_Size i; - - TclNewObj(resObjPtr); - if (isArithSeries) { - Tcl_Obj *valueObj; - for (i = 0; i < listLen; i++) { - if (i > 0) { - - /* - * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** - * to shimmer joinObjPtr. If it did, then the case where - * objv[1] and objv[2] are the same value would not be safe. - * Accessing elemPtrs would crash. - */ - - Tcl_AppendObjToObj(resObjPtr, joinObjPtr); - } - valueObj = TclArithSeriesObjIndex(interp, objv[1], i); - if (valueObj == NULL) { - return TCL_ERROR; - } - Tcl_AppendObjToObj(resObjPtr, valueObj); - Tcl_DecrRefCount(valueObj); - } - } else { - for (i = 0; i < listLen; i++) { - if (i > 0) { - - /* - * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** - * to shimmer joinObjPtr. If it did, then the case where - * objv[1] and objv[2] are the same value would not be safe. - * Accessing elemPtrs would crash. - */ - - Tcl_AppendObjToObj(resObjPtr, joinObjPtr); - } - Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); - } + resObjPtr = Tcl_NewObj(); + for (i = 0; i < listLen; i++) { + if (i > 0) { + Tcl_AppendObjToObj(resObjPtr, joinObjPtr); } + Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); } Tcl_DecrRefCount(joinObjPtr); - if (resObjPtr) { - Tcl_SetObjResult(interp, resObjPtr); - return TCL_OK; - } - return TCL_ERROR; + Tcl_SetObjResult(interp, resObjPtr); + return TCL_OK; } /* @@ -2317,19 +2053,18 @@ Tcl_JoinObjCmd( int Tcl_LassignObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *listCopyPtr; Tcl_Obj **listObjv; /* The contents of the list. */ - Tcl_Size listObjc; /* The length of the list. */ - Tcl_Size origListObjc; /* Original length */ + int listObjc; /* The length of the list. */ int code = TCL_OK; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "list ?varName ...?"); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "list varName ?varName ...?"); return TCL_ERROR; } @@ -2337,30 +2072,26 @@ Tcl_LassignObjCmd( if (listCopyPtr == NULL) { return TCL_ERROR; } - Tcl_IncrRefCount(listCopyPtr); /* Important! fs */ TclListObjGetElements(NULL, listCopyPtr, &listObjc, &listObjv); - origListObjc = listObjc; objc -= 2; objv += 2; while (code == TCL_OK && objc > 0 && listObjc > 0) { - if (Tcl_ObjSetVar2(interp, *objv++, NULL, *listObjv++, - TCL_LEAVE_ERR_MSG) == NULL) { + if (NULL == Tcl_ObjSetVar2(interp, *objv++, NULL, + *listObjv++, TCL_LEAVE_ERR_MSG)) { code = TCL_ERROR; } - objc--; - listObjc--; + objc--; listObjc--; } if (code == TCL_OK && objc > 0) { Tcl_Obj *emptyObj; - TclNewObj(emptyObj); Tcl_IncrRefCount(emptyObj); while (code == TCL_OK && objc-- > 0) { - if (Tcl_ObjSetVar2(interp, *objv++, NULL, emptyObj, - TCL_LEAVE_ERR_MSG) == NULL) { + if (NULL == Tcl_ObjSetVar2(interp, *objv++, NULL, + emptyObj, TCL_LEAVE_ERR_MSG)) { code = TCL_ERROR; } } @@ -2368,13 +2099,7 @@ Tcl_LassignObjCmd( } if (code == TCL_OK && listObjc > 0) { - Tcl_Obj *resultObjPtr = TclListObjRange( - interp, listCopyPtr, origListObjc - listObjc, origListObjc - 1); - if (resultObjPtr == NULL) { - code = TCL_ERROR; - } else { - Tcl_SetObjResult(interp, resultObjPtr); - } + Tcl_SetObjResult(interp, Tcl_NewListObj(listObjc, listObjv)); } Tcl_DecrRefCount(listCopyPtr); @@ -2400,15 +2125,16 @@ Tcl_LassignObjCmd( int Tcl_LindexObjCmd( - TCL_UNUSED(void *), + 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. */ if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?"); return TCL_ERROR; } @@ -2431,11 +2157,11 @@ Tcl_LindexObjCmd( if (elemPtr == NULL) { return TCL_ERROR; + } else { + Tcl_SetObjResult(interp, elemPtr); + Tcl_DecrRefCount(elemPtr); + return TCL_OK; } - - Tcl_SetObjResult(interp, elemPtr); - Tcl_DecrRefCount(elemPtr); - return TCL_OK; } /* @@ -2458,17 +2184,16 @@ Tcl_LindexObjCmd( int Tcl_LinsertObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + register int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *listPtr; - Tcl_Size len, index; - int result; + int index, len, result; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?"); + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?"); return TCL_ERROR; } @@ -2541,10 +2266,10 @@ Tcl_LinsertObjCmd( int Tcl_ListObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) + register int objc, /* Number of arguments. */ + register Tcl_Obj *const objv[]) /* The argument objects. */ { /* @@ -2553,7 +2278,7 @@ Tcl_ListObjCmd( */ if (objc > 1) { - Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, &objv[1])); + Tcl_SetObjResult(interp, Tcl_NewListObj((objc-1), &(objv[1]))); } return TCL_OK; } @@ -2577,15 +2302,13 @@ Tcl_ListObjCmd( int Tcl_LlengthObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) + register Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Size listLen; - int result; - Tcl_Obj *objPtr; + int listLen, result; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "list"); @@ -2602,110 +2325,7 @@ Tcl_LlengthObjCmd( * length. */ - TclNewUIntObj(objPtr, listLen); - Tcl_SetObjResult(interp, objPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LpopObjCmd -- - * - * This procedure is invoked to process the "lpop" Tcl command. See the - * user documentation for details on what it does. - * - * Results: - * A standard Tcl object result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_LpopObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) - /* Argument objects. */ -{ - Tcl_Size listLen; - int result; - Tcl_Obj *elemPtr, *stored; - Tcl_Obj *listPtr, **elemPtrs; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "listvar ?index?"); - return TCL_ERROR; - } - - listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); - if (listPtr == NULL) { - return TCL_ERROR; - } - - result = TclListObjGetElements(interp, listPtr, &listLen, &elemPtrs); - if (result != TCL_OK) { - return result; - } - - /* - * First, extract the element to be returned. - * TclLindexFlat adds a ref count which is handled. - */ - - if (objc == 2) { - if (!listLen) { - /* empty list, throw the same error as with index "end" */ - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "index \"end\" out of range", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" - "OUTOFRANGE", (void *)NULL); - return TCL_ERROR; - } - elemPtr = elemPtrs[listLen - 1]; - Tcl_IncrRefCount(elemPtr); - } else { - elemPtr = TclLindexFlat(interp, listPtr, objc-2, objv+2); - - if (elemPtr == NULL) { - return TCL_ERROR; - } - } - Tcl_SetObjResult(interp, elemPtr); - Tcl_DecrRefCount(elemPtr); - - /* - * Second, remove the element. - * TclLsetFlat adds a ref count which is handled. - */ - - if (objc == 2) { - if (Tcl_IsShared(listPtr)) { - listPtr = TclListObjCopy(NULL, listPtr); - } - result = Tcl_ListObjReplace(interp, listPtr, listLen - 1, 1, 0, NULL); - if (result != TCL_OK) { - return result; - } - Tcl_IncrRefCount(listPtr); - } else { - listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL); - - if (listPtr == NULL) { - return TCL_ERROR; - } - } - - stored = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG); - Tcl_DecrRefCount(listPtr); - if (stored == NULL) { - return TCL_ERROR; - } - + Tcl_SetObjResult(interp, Tcl_NewIntObj(listLen)); return TCL_OK; } @@ -2728,198 +2348,58 @@ Tcl_LpopObjCmd( int Tcl_LrangeObjCmd( - TCL_UNUSED(void *), + ClientData notUsed, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) + register Tcl_Obj *const objv[]) /* Argument objects. */ { - int result; - Tcl_Size listLen, first, last; + Tcl_Obj *listPtr, **elemPtrs; + int listLen, first, result; + if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "list first last"); return TCL_ERROR; } - result = TclListObjLength(interp, objv[1], &listLen); - if (result != TCL_OK) { - return result; - } - - result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1, - &first); - if (result != TCL_OK) { - return result; - } - - result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1, - &last); - if (result != TCL_OK) { - return result; - } - - if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { - Tcl_Obj *rangeObj; - rangeObj = TclArithSeriesObjRange(interp, objv[1], first, last); - if (rangeObj) { - Tcl_SetObjResult(interp, rangeObj); - } else { - return TCL_ERROR; - } - } else { - Tcl_Obj *resultObj = TclListObjRange(interp, objv[1], first, last); - if (resultObj == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, resultObj); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LremoveObjCmd -- - * - * This procedure is invoked to process the "lremove" Tcl command. See the - * user documentation for details on what it does. - * - * Results: - * A standard Tcl object result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -static int -LremoveIndexCompare( - const void *el1Ptr, - const void *el2Ptr) -{ - Tcl_Size idx1 = *((const Tcl_Size *) el1Ptr); - Tcl_Size idx2 = *((const Tcl_Size *) el2Ptr); - - /* - * This will put the larger element first. - */ - - return (idx1 < idx2) ? 1 : (idx1 > idx2) ? -1 : 0; -} - -int -Tcl_LremoveObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Size i, idxc, prevIdx, first, num; - Tcl_Size *idxv, listLen; - Tcl_Obj *listObj; - int copied = 0, status = TCL_OK; - /* - * Parse the arguments. + * Make sure the list argument is a list object and get its length and a + * pointer to its array of element pointers. */ - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?"); - return TCL_ERROR; - } - - listObj = objv[1]; - if (TclListObjLength(interp, listObj, &listLen) != TCL_OK) { + listPtr = TclListObjCopy(interp, objv[1]); + if (listPtr == NULL) { return TCL_ERROR; } + TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs); - idxc = objc - 2; - if (idxc == 0) { - Tcl_SetObjResult(interp, listObj); - return TCL_OK; - } - idxv = (Tcl_Size *)ckalloc((objc - 2) * sizeof(*idxv)); - for (i = 2; i < objc; i++) { - status = (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1, - &idxv[i - 2]) != TCL_OK); - if (status != TCL_OK) { - goto done; - } - } - - /* - * Sort the indices, large to small so that when we remove an index we - * don't change the indices still to be processed. - */ - - if (idxc > 1) { - qsort(idxv, idxc, sizeof(*idxv), LremoveIndexCompare); - } - - /* - * Make our working copy, then do the actual removes piecemeal. - */ - - if (Tcl_IsShared(listObj)) { - listObj = TclListObjCopy(NULL, listObj); - copied = 1; - } - num = 0; - first = listLen; - for (i = 0, prevIdx = -1 ; i < idxc ; i++) { - Tcl_Size idx = idxv[i]; - - /* - * Repeated index and sanity check. - */ + result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1, + &first); + if (result == TCL_OK) { + int last; - if (idx == prevIdx) { - continue; - } - prevIdx = idx; - if (idx < 0 || idx >= listLen) { - continue; + if (first < 0) { + first = 0; } - /* - * Coalesce adjacent removes to reduce the number of copies. - */ + result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1, + &last); + if (result == TCL_OK) { + if (last >= listLen) { + last = (listLen - 1); + } - if (num == 0) { - num = 1; - first = idx; - } else if (idx + 1 == first) { - num++; - first = idx; - } else { - /* - * Note that this operation can't fail now; we know we have a list - * and we're only ever contracting that list. - */ + if (first <= last) { + int numElems = (last - first + 1); - status = Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL); - if (status != TCL_OK) { - goto done; - } - listLen -= num; - num = 1; - first = idx; - } - } - if (num != 0) { - status = Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL); - if (status != TCL_OK) { - if (copied) { - Tcl_DecrRefCount(listObj); + Tcl_SetObjResult(interp, + Tcl_NewListObj(numElems, &(elemPtrs[first]))); } - goto done; } } - Tcl_SetObjResult(interp, listObj); -done: - ckfree(idxv); - return status; + + Tcl_DecrRefCount(listPtr); + return result; } /* @@ -2941,33 +2421,30 @@ done: int Tcl_LrepeatObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) + register int objc, /* Number of arguments. */ + register Tcl_Obj *const objv[]) /* The argument objects. */ { - Tcl_WideInt elementCount, i; - Tcl_Size totalElems; - Tcl_Obj *listPtr, **dataArray = NULL; + int elementCount, i, totalElems; + Tcl_Obj *listPtr, **dataArray; + List *listRepPtr; /* * Check arguments for legality: - * lrepeat count ?value ...? + * lrepeat posInt value ?value ...? */ - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "count ?value ...?"); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "positiveCount value ?value ...?"); return TCL_ERROR; } - if (TCL_OK != TclGetWideIntFromObj(interp, objv[1], &elementCount)) { + if (TCL_ERROR == TclGetIntFromObj(interp, objv[1], &elementCount)) { return TCL_ERROR; } - if (elementCount < 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad count \"%" TCL_LL_MODIFIER "d\": must be integer >= 0", elementCount)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG", - (void *)NULL); + if (elementCount < 1) { + Tcl_AppendResult(interp, "must have a count of at least 1", NULL); return TCL_ERROR; } @@ -2980,10 +2457,9 @@ Tcl_LrepeatObjCmd( /* Final sanity check. Do not exceed limits on max list length. */ - if (elementCount && objc > LIST_MAX/elementCount) { + if (objc > LIST_MAX/elementCount) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max length of a Tcl list (%" TCL_SIZE_MODIFIER "d elements) exceeded", LIST_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); + "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); return TCL_ERROR; } totalElems = objc * elementCount; @@ -2994,17 +2470,9 @@ Tcl_LrepeatObjCmd( */ listPtr = Tcl_NewListObj(totalElems, NULL); - if (totalElems) { - ListRep listRep; - ListObjGetRep(listPtr, &listRep); - dataArray = ListRepElementsBase(&listRep); - listRep.storePtr->numUsed = totalElems; - if (listRep.spanPtr) { - /* Future proofing in case Tcl_NewListObj returns a span */ - listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; - listRep.spanPtr->spanLength = listRep.storePtr->numUsed; - } - } + listRepPtr = ListRepPtr(listPtr); + listRepPtr->elemCount = elementCount*objc; + dataArray = &listRepPtr->elements; /* * Set the elements. Note that we handle the common degenerate case of a @@ -3013,16 +2481,15 @@ Tcl_LrepeatObjCmd( * number of times. */ - CLANG_ASSERT(dataArray || totalElems == 0 ); if (objc == 1) { - Tcl_Obj *tmpPtr = objv[0]; + register Tcl_Obj *tmpPtr = objv[0]; tmpPtr->refCount += elementCount; for (i=0 ; i<elementCount ; i++) { dataArray[i] = tmpPtr; } } else { - Tcl_Size j, k = 0; + int j, k = 0; for (i=0 ; i<elementCount ; i++) { for (j=0 ; j<objc ; j++) { @@ -3056,18 +2523,17 @@ Tcl_LrepeatObjCmd( int Tcl_LreplaceObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj *listPtr; - Tcl_Size numToDelete, listLen, first, last; - int result; + register Tcl_Obj *listPtr; + int first, last, listLen, numToDelete, result; if (objc < 4) { Tcl_WrongNumArgs(interp, 1, objv, - "list first last ?element ...?"); + "list first last ?element element ...?"); return TCL_ERROR; } @@ -3092,17 +2558,27 @@ Tcl_LreplaceObjCmd( return result; } - if (first == TCL_INDEX_NONE) { - first = 0; - } else if (first > listLen) { - first = listLen; + if (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 + * 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]), NULL); + return TCL_ERROR; + } if (last >= listLen) { - last = listLen - 1; + last = (listLen - 1); } if (first <= last) { - numToDelete = (unsigned)last - (unsigned)first + 1; /* See [3d3124d01d] */ + numToDelete = (last - first + 1); } else { numToDelete = 0; } @@ -3126,7 +2602,7 @@ Tcl_LreplaceObjCmd( */ if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, first, numToDelete, - objc-4, objv+4)) { + objc-4, &(objv[4]))) { return TCL_ERROR; } @@ -3157,66 +2633,40 @@ Tcl_LreplaceObjCmd( int Tcl_LreverseObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { Tcl_Obj **elemv; - Tcl_Size elemc, i, j; + int elemc, i, j; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "list"); return TCL_ERROR; } - - /* - * Handle ArithSeries special case - don't shimmer a series into a list - * just to reverse it. - */ - if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { - Tcl_Obj *resObj = TclArithSeriesObjReverse(interp, objv[1]); - if (resObj) { - Tcl_SetObjResult(interp, resObj); - return TCL_OK; - } else { - return TCL_ERROR; - } - } /* end ArithSeries */ - - /* True List */ - if (TclListObjLength(interp, objv[1], &elemc) != TCL_OK) { + if (TclListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) { return TCL_ERROR; } /* - * If the list is empty, just return it. [Bug 1876793] + * If the list is empty, just return it [Bug 1876793] */ if (!elemc) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } - if (TclListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) { - return TCL_ERROR; - } if (Tcl_IsShared(objv[1]) - || ListObjRepIsShared(objv[1])) { /* Bug 1675044 */ + || (ListRepPtr(objv[1])->refCount > 1)) { /* Bug 1675044 */ Tcl_Obj *resultObj, **dataArray; - ListRep listRep; + List *listRepPtr; resultObj = Tcl_NewListObj(elemc, NULL); - - /* Modify the internal rep in-place */ - ListObjGetRep(resultObj, &listRep); - listRep.storePtr->numUsed = elemc; - dataArray = ListRepElementsBase(&listRep); - if (listRep.spanPtr) { - /* Future proofing */ - listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; - listRep.spanPtr->spanLength = listRep.storePtr->numUsed; - } + listRepPtr = ListRepPtr(resultObj); + listRepPtr->elemCount = elemc; + dataArray = &listRepPtr->elements; for (i=0,j=elemc-1 ; i<elemc ; i++,j--) { dataArray[j] = elemv[i]; @@ -3262,37 +2712,33 @@ Tcl_LreverseObjCmd( int Tcl_LsearchObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { - const char *bytes, *patternBytes; - int match, result=TCL_OK, bisect; - Tcl_Size i, length, listc, elemLen, start, index; - Tcl_Size groupSize, groupOffset, lower, upper; - int allocatedIndexVector = 0; - int dataType, isIncreasing; - Tcl_WideInt patWide, objWide, wide; + char *bytes, *patternBytes; + int i, match, mode, index, result, listc, length, elemLen; + 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 = TclUtfCmp; + SortStrCmpFn_t strCmpFn = strcmp; Tcl_RegExp regexp = NULL; - static const char *const options[] = { - "-all", "-ascii", "-bisect", "-decreasing", "-dictionary", + static const char *options[] = { + "-all", "-ascii", "-decreasing", "-dictionary", "-exact", "-glob", "-increasing", "-index", "-inline", "-integer", "-nocase", "-not", - "-real", "-regexp", "-sorted", "-start", "-stride", + "-real", "-regexp", "-sorted", "-start", "-subindices", NULL }; - enum lsearchoptions { - 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_STRIDE, LSEARCH_SUBINDICES + 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 }; enum datatypes { ASCII, DICTIONARY, INTEGER, REAL @@ -3300,7 +2746,6 @@ Tcl_LsearchObjCmd( enum modes { EXACT, GLOB, REGEXP, SORTED }; - enum modes mode; mode = GLOB; dataType = ASCII; @@ -3309,12 +2754,9 @@ Tcl_LsearchObjCmd( inlineReturn = 0; returnSubindices = 0; negatedMatch = 0; - bisect = 0; listPtr = NULL; startPtr = NULL; - groupSize = 1; - groupOffset = 0; - start = 0; + offset = 0; noCase = 0; sortInfo.compareCmdPtr = NULL; sortInfo.isIncreasing = 1; @@ -3325,27 +2767,28 @@ Tcl_LsearchObjCmd( sortInfo.indexc = 0; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list pattern"); + Tcl_WrongNumArgs(interp, 1, objv, "?options? list pattern"); return TCL_ERROR; } for (i = 1; i < objc-2; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { - result = TCL_ERROR; - goto done; + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return TCL_ERROR; } - switch ((enum lsearchoptions) index) { + switch ((enum options) index) { case LSEARCH_ALL: /* -all */ allMatches = 1; break; 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; @@ -3396,14 +2839,13 @@ Tcl_LsearchObjCmd( if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); - startPtr = NULL; } if (i > objc-4) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "missing starting index", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); - result = TCL_ERROR; - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + Tcl_AppendResult(interp, "missing starting index", NULL); + return TCL_ERROR; } i++; if (objv[i] == objv[objc - 2]) { @@ -3417,48 +2859,24 @@ Tcl_LsearchObjCmd( startPtr = Tcl_DuplicateObj(objv[i]); } else { startPtr = objv[i]; + Tcl_IncrRefCount(startPtr); } - Tcl_IncrRefCount(startPtr); - break; - case LSEARCH_STRIDE: /* -stride */ - if (i > objc-4) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"-stride\" option must be " - "followed by stride length", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); - result = TCL_ERROR; - goto done; - } - if (Tcl_GetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) { - result = TCL_ERROR; - goto done; - } - if ((wide < 1) || (wide > LIST_MAX)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "stride length must be between 1 and %d", LIST_MAX)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", - "BADSTRIDE", (void *)NULL); - result = TCL_ERROR; - goto done; - } - groupSize = wide; - i++; break; case LSEARCH_INDEX: { /* -index */ Tcl_Obj **indices; - Tcl_Size j; + int j; - if (allocatedIndexVector) { - TclStackFree(interp, sortInfo.indexv); - allocatedIndexVector = 0; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); } if (i > objc-4) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + Tcl_AppendResult(interp, "\"-index\" option must be followed by list index", - -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); - result = TCL_ERROR; - goto done; + NULL); + return TCL_ERROR; } /* @@ -3470,8 +2888,10 @@ Tcl_LsearchObjCmd( i++; if (TclListObjGetElements(interp, objv[i], &sortInfo.indexc, &indices) != TCL_OK) { - result = TCL_ERROR; - goto done; + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + return TCL_ERROR; } switch (sortInfo.indexc) { case 0: @@ -3482,9 +2902,7 @@ Tcl_LsearchObjCmd( break; default: sortInfo.indexv = (int *) - TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); - allocatedIndexVector = 1; /* Cannot use indexc field, as it - * might be decreased by 1 later. */ + ckalloc(sizeof(int) * sortInfo.indexc); } /* @@ -3494,25 +2912,15 @@ Tcl_LsearchObjCmd( */ for (j=0 ; j<sortInfo.indexc ; j++) { - int encoded = 0; - if (TclIndexEncode(interp, indices[j], TCL_INDEX_NONE, - TCL_INDEX_NONE, &encoded) != TCL_OK) { - result = TCL_ERROR; - } - if (encoded == (int)TCL_INDEX_NONE) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "index \"%s\" out of range", - TclGetString(indices[j]))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" - "OUTOFRANGE", (void *)NULL); - result = TCL_ERROR; - } - if (result == TCL_ERROR) { + if (TclGetIntForIndexM(interp, indices[j], SORTIDX_END, + &sortInfo.indexv[j]) != TCL_OK) { + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (-index option item number %" TCL_SIZE_MODIFIER "d)", j)); - goto done; + "\n (-index option item number %d)", j)); + return TCL_ERROR; } - sortInfo.indexv[j] = encoded; } break; } @@ -3524,24 +2932,15 @@ Tcl_LsearchObjCmd( */ if (returnSubindices && sortInfo.indexc==0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "-subindices cannot be used without -index option", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", - "BAD_OPTION_MIX", (void *)NULL); - result = TCL_ERROR; - goto done; - } - - 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", (void *)NULL); - result = TCL_ERROR; - goto done; + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + Tcl_AppendResult(interp, + "-subindices cannot be used without -index option", NULL); + return TCL_ERROR; } - if (mode == REGEXP) { + if ((enum modes) 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 @@ -3564,8 +2963,13 @@ Tcl_LsearchObjCmd( } if (regexp == NULL) { - result = TCL_ERROR; - goto done; + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return TCL_ERROR; } } @@ -3576,51 +2980,13 @@ Tcl_LsearchObjCmd( result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv); if (result != TCL_OK) { - goto done; - } - - /* - * Check for sanity when grouping elements of the overall list together - * because of the -stride option. [TIP #351] - */ - - if (groupSize > 1) { - if (listc % groupSize) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "list size must be a multiple of the stride length", - -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BADSTRIDE", - (void *)NULL); - result = TCL_ERROR; - goto done; + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); } - 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 = TclIndexDecode(sortInfo.indexv[0], groupSize - 1); - 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", "LSEARCH", - "BADINDEX", (void *)NULL); - result = TCL_ERROR; - goto done; - } - if (sortInfo.indexc == 1) { - sortInfo.indexc = 0; - sortInfo.indexv = NULL; - } else { - sortInfo.indexc--; - - for (i = 0; i < sortInfo.indexc; i++) { - sortInfo.indexv[i] = sortInfo.indexv[i+1]; - } - } + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); } + return result; } /* @@ -3628,12 +2994,16 @@ Tcl_LsearchObjCmd( */ if (startPtr) { - result = TclGetIntForIndexM(interp, startPtr, listc-1, &start); + result = TclGetIntForIndexM(interp, startPtr, listc-1, &offset); + Tcl_DecrRefCount(startPtr); if (result != TCL_OK) { - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return result; } - if (start == TCL_INDEX_NONE) { - start = TCL_INDEX_START; + if (offset < 0) { + offset = 0; } /* @@ -3641,37 +3011,34 @@ Tcl_LsearchObjCmd( * "did not match anything at all" result straight away. [Bug 1374778] */ - if (start >= listc) { + if (offset > listc-1) { + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } if (allMatches || inlineReturn) { Tcl_ResetResult(interp); } else { - TclNewIntObj(itemPtr, -1); - Tcl_SetObjResult(interp, itemPtr); + Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); } - goto done; - } - - /* - * If start points within a group, it points to the start of the group. - */ - - if (groupSize > 1) { - start -= (start % groupSize); + return TCL_OK; } } patObj = objv[objc - 1]; patternBytes = NULL; - if (mode == EXACT || mode == SORTED) { + if ((enum modes) mode == EXACT || (enum modes) mode == SORTED) { switch ((enum datatypes) dataType) { case ASCII: case DICTIONARY: patternBytes = TclGetStringFromObj(patObj, &length); break; case INTEGER: - result = TclGetWideIntFromObj(interp, patObj, &patWide); + result = TclGetIntFromObj(interp, patObj, &patInt); if (result != TCL_OK) { - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return result; } /* @@ -3684,7 +3051,10 @@ Tcl_LsearchObjCmd( case REAL: result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble); if (result != TCL_OK) { - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return result; } /* @@ -3707,7 +3077,7 @@ Tcl_LsearchObjCmd( index = -1; match = 0; - if (mode == SORTED && !allMatches && !negatedMatch) { + if ((enum modes) 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 @@ -3715,23 +3085,20 @@ Tcl_LsearchObjCmd( * sense in doing this when the match sense is inverted. */ - /* - * With -stride, lower, upper and i are kept as multiples of groupSize. - */ - - lower = start - groupSize; + lower = offset - 1; upper = listc; - while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) { + while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) { i = (lower + upper)/2; - i -= i % groupSize; if (sortInfo.indexc != 0) { - itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); + itemPtr = SelectObjFromSublist(listv[i], &sortInfo); if (sortInfo.resultCode != TCL_OK) { - result = sortInfo.resultCode; - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return sortInfo.resultCode; } } else { - itemPtr = listv[i+groupOffset]; + itemPtr = listv[i]; } switch ((enum datatypes) dataType) { case ASCII: @@ -3743,13 +3110,16 @@ Tcl_LsearchObjCmd( match = DictionaryCompare(patternBytes, bytes); break; case INTEGER: - result = TclGetWideIntFromObj(interp, itemPtr, &objWide); + result = TclGetIntFromObj(interp, itemPtr, &objInt); if (result != TCL_OK) { - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return result; } - if (patWide == objWide) { + if (patInt == objInt) { match = 0; - } else if (patWide < objWide) { + } else if (patInt < objInt) { match = -1; } else { match = 1; @@ -3758,7 +3128,10 @@ Tcl_LsearchObjCmd( case REAL: result = Tcl_GetDoubleFromObj(interp, itemPtr, &objDouble); if (result != TCL_OK) { - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return result; } if (patDouble == objDouble) { match = 0; @@ -3773,25 +3146,19 @@ Tcl_LsearchObjCmd( /* * Normally, binary search is written to stop when it finds a * match. If there are duplicates of an element in the list, - * our first match might not be the first occurrence. + * our first match might not be the first occurance. * Consider: 0 0 0 1 1 1 2 2 2 * - * To maintain consistency with standard lsearch semantics, we - * must find the leftmost occurrence of the pattern in the + * To maintain consistancy with standard lsearch semantics, we + * must find the leftmost occurance of the pattern in the * list. Thus we don't just stop searching here. This * 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; - if (bisect) { - lower = i; - } else { - upper = i; - } + upper = i; } else if (match > 0) { if (isIncreasing) { lower = i; @@ -3806,9 +3173,7 @@ Tcl_LsearchObjCmd( } } } - if (bisect && index < 0) { - index = lower; - } + } else { /* * We need to do a linear search, because (at least one) of: @@ -3820,22 +3185,24 @@ Tcl_LsearchObjCmd( if (allMatches) { listPtr = Tcl_NewListObj(0, NULL); } - for (i = start; i < listc; i += groupSize) { + for (i = offset; i < listc; i++) { match = 0; - if (sortInfo.indexc != 0) { - itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); + 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; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return sortInfo.resultCode; } } else { - itemPtr = listv[i+groupOffset]; + itemPtr = listv[i]; } - - switch (mode) { + + switch ((enum modes) mode) { case SORTED: case EXACT: switch ((enum datatypes) dataType) { @@ -3850,7 +3217,8 @@ Tcl_LsearchObjCmd( if (noCase) { match = (TclUtfCasecmp(bytes, patternBytes) == 0); } else { - match = (memcmp(bytes, patternBytes, length) == 0); + match = (memcmp(bytes, patternBytes, + (size_t) length) == 0); } } break; @@ -3861,14 +3229,17 @@ Tcl_LsearchObjCmd( break; case INTEGER: - result = TclGetWideIntFromObj(interp, itemPtr, &objWide); + result = TclGetIntFromObj(interp, itemPtr, &objInt); if (result != TCL_OK) { if (listPtr != NULL) { Tcl_DecrRefCount(listPtr); } - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return result; } - match = (objWide == patWide); + match = (objInt == patInt); break; case REAL: @@ -3877,7 +3248,10 @@ Tcl_LsearchObjCmd( if (listPtr) { Tcl_DecrRefCount(listPtr); } - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return result; } match = (objDouble == patDouble); break; @@ -3896,8 +3270,10 @@ Tcl_LsearchObjCmd( if (listPtr != NULL) { Tcl_DecrRefCount(listPtr); } - result = TCL_ERROR; - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return TCL_ERROR; } break; } @@ -3921,28 +3297,22 @@ Tcl_LsearchObjCmd( */ if (returnSubindices && (sortInfo.indexc != 0)) { - itemPtr = SelectObjFromSublist(listv[i+groupOffset], - &sortInfo); - Tcl_ListObjAppendElement(interp, listPtr, itemPtr); - } else if (groupSize > 1) { - Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, - groupSize, &listv[i]); + itemPtr = SelectObjFromSublist(listv[i], &sortInfo); } else { itemPtr = listv[i]; - Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } + Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } else if (returnSubindices) { - Tcl_Size j; + int j; - TclNewIndexObj(itemPtr, i+groupOffset); + itemPtr = Tcl_NewIntObj(i); for (j=0 ; j<sortInfo.indexc ; j++) { - Tcl_Obj *elObj; - TclNewIndexObj(elObj, TclIndexDecode(sortInfo.indexv[j], listc)); - Tcl_ListObjAppendElement(interp, itemPtr, elObj); + Tcl_ListObjAppendElement(interp, itemPtr, + Tcl_NewIntObj(sortInfo.indexv[j])); } Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } else { - Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewWideIntObj(i)); + Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewIntObj(i)); } } } @@ -3955,19 +3325,16 @@ Tcl_LsearchObjCmd( Tcl_SetObjResult(interp, listPtr); } else if (!inlineReturn) { if (returnSubindices) { - Tcl_Size j; + int j; - TclNewIndexObj(itemPtr, index+groupOffset); + itemPtr = Tcl_NewIntObj(index); for (j=0 ; j<sortInfo.indexc ; j++) { - Tcl_Obj *elObj; - TclNewIndexObj(elObj, TclIndexDecode(sortInfo.indexv[j], listc)); - Tcl_ListObjAppendElement(interp, itemPtr, elObj); + Tcl_ListObjAppendElement(interp, itemPtr, + Tcl_NewIntObj(sortInfo.indexv[j])); } Tcl_SetObjResult(interp, itemPtr); } else { - Tcl_Obj *elObj; - TclNewIndexObj(elObj, index); - Tcl_SetObjResult(interp, elObj); + Tcl_SetObjResult(interp, Tcl_NewIntObj(index)); } } else if (index < 0) { /* @@ -3975,431 +3342,19 @@ Tcl_LsearchObjCmd( * default... */ - Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, Tcl_NewObj()); } else { - if (returnSubindices) { - Tcl_SetObjResult(interp, SelectObjFromSublist(listv[i+groupOffset], - &sortInfo)); - } else if (groupSize > 1) { - Tcl_SetObjResult(interp, Tcl_NewListObj(groupSize, &listv[index])); - } else { - Tcl_SetObjResult(interp, listv[index]); - } + Tcl_SetObjResult(interp, listv[index]); } - result = TCL_OK; /* * Cleanup the index list array. */ - done: - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } - if (allocatedIndexVector) { - TclStackFree(interp, sortInfo.indexv); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * SequenceIdentifyArgument -- - * (for [lseq] command) - * - * Given a Tcl_Obj, identify if it is a keyword or a number - * - * Return Value - * 0 - failure, unexpected value - * 1 - value is a number - * 2 - value is an operand keyword - * 3 - value is a by keyword - * - * The decoded value will be assigned to the appropriate - * pointer, if supplied. - */ - -static SequenceDecoded -SequenceIdentifyArgument( - Tcl_Interp *interp, /* for error reporting */ - Tcl_Obj *argPtr, /* Argument to decode */ - Tcl_Obj **numValuePtr, /* Return numeric value */ - int *keywordIndexPtr) /* Return keyword enum */ -{ - int status; - SequenceOperators opmode; - SequenceByMode bymode; - void *clientData; - - status = Tcl_GetNumberFromObj(NULL, argPtr, &clientData, keywordIndexPtr); - if (status == TCL_OK) { - if (numValuePtr) { - *numValuePtr = argPtr; - } - return NumericArg; - } else { - /* Check for an index expression */ - long value; - double dvalue; - Tcl_Obj *exprValueObj; - int keyword; - Tcl_InterpState savedstate; - savedstate = Tcl_SaveInterpState(interp, status); - if (Tcl_ExprLongObj(interp, argPtr, &value) != TCL_OK) { - status = Tcl_RestoreInterpState(interp, savedstate); - exprValueObj = argPtr; - } else { - // Determine if expression is double or int - if (Tcl_ExprDoubleObj(interp, argPtr, &dvalue) != TCL_OK) { - keyword = TCL_NUMBER_INT; - exprValueObj = argPtr; - } else { - if (floor(dvalue) == dvalue) { - TclNewIntObj(exprValueObj, value); - keyword = TCL_NUMBER_INT; - } else { - TclNewDoubleObj(exprValueObj, dvalue); - keyword = TCL_NUMBER_DOUBLE; - } - } - status = Tcl_RestoreInterpState(interp, savedstate); - if (numValuePtr) { - *numValuePtr = exprValueObj; - } - if (keywordIndexPtr) { - *keywordIndexPtr = keyword ;// type of expression result - } - return NumericArg; - } - } - - status = Tcl_GetIndexFromObj(NULL, argPtr, seq_operations, - "range operation", 0, &opmode); - if (status == TCL_OK) { - if (keywordIndexPtr) { - *keywordIndexPtr = opmode; - } - return RangeKeywordArg; - } - - status = Tcl_GetIndexFromObj(NULL, argPtr, seq_step_keywords, - "step keyword", 0, &bymode); - if (status == TCL_OK) { - if (keywordIndexPtr) { - *keywordIndexPtr = bymode; - } - return ByKeywordArg; - } - return NoneArg; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LseqObjCmd -- - * - * This procedure is invoked to process the "lseq" Tcl command. - * See the user documentation for details on what it does. - * - * Enumerated possible argument patterns: - * - * 1: - * lseq n - * 2: - * lseq n n - * 3: - * lseq n n n - * lseq n 'to' n - * lseq n 'count' n - * lseq n 'by' n - * 4: - * lseq n 'to' n n - * lseq n n 'by' n - * lseq n 'count' n n - * 5: - * lseq n 'to' n 'by' n - * lseq n 'count' n 'by' n - * - * Results: - * A standard Tcl object result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_LseqObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ -{ - Tcl_Obj *elementCount = NULL; - Tcl_Obj *start = NULL, *end = NULL, *step = NULL; - Tcl_WideInt values[5]; - Tcl_Obj *numValues[5]; - Tcl_Obj *numberObj; - int status, keyword, useDoubles = 0; - Tcl_Obj *arithSeriesPtr; - SequenceOperators opmode; - SequenceDecoded decoded; - int i, arg_key = 0, value_i = 0; - // Default constants - Tcl_Obj *zero = Tcl_NewIntObj(0); - Tcl_Obj *one = Tcl_NewIntObj(1); - - /* - * Create a decoding key by looping through the arguments and identify - * what kind of argument each one is. Encode each argument as a decimal - * digit. - */ - if (objc > 6) { - /* Too many arguments */ - arg_key=0; - } else for (i=1; i<objc; i++) { - arg_key = (arg_key * 10); - numValues[value_i] = NULL; - decoded = SequenceIdentifyArgument(interp, objv[i], &numberObj, &keyword); - switch (decoded) { - - case NoneArg: - /* - * Unrecognizable argument - * Reproduce operation error message - */ - status = Tcl_GetIndexFromObj(interp, objv[i], seq_operations, - "operation", 0, &opmode); - goto done; - - case NumericArg: - arg_key += NumericArg; - numValues[value_i] = numberObj; - Tcl_IncrRefCount(numValues[value_i]); - values[value_i] = keyword; // This is the TCL_NUMBER_* value - useDoubles = useDoubles ? useDoubles : keyword == TCL_NUMBER_DOUBLE; - value_i++; - break; - - case RangeKeywordArg: - arg_key += RangeKeywordArg; - values[value_i] = keyword; - value_i++; - break; - - case ByKeywordArg: - arg_key += ByKeywordArg; - values[value_i] = keyword; - value_i++; - break; - - default: - arg_key += 9; // Error state - value_i++; - break; - } - } - - /* - * The key encoding defines a valid set of arguments, or indicates an - * error condition; process the values accordningly. - */ - switch (arg_key) { - -/* No argument */ - case 0: - Tcl_WrongNumArgs(interp, 1, objv, - "n ??op? n ??by? n??"); - status = TCL_ERROR; - goto done; - break; - -/* lseq n */ - case 1: - start = zero; - elementCount = numValues[0]; - end = NULL; - step = one; - break; - -/* lseq n n */ - case 11: - start = numValues[0]; - end = numValues[1]; - break; - -/* lseq n n n */ - case 111: - start = numValues[0]; - end = numValues[1]; - step = numValues[2]; - break; - -/* lseq n 'to' n */ -/* lseq n 'count' n */ -/* lseq n 'by' n */ - case 121: - opmode = (SequenceOperators)values[1]; - switch (opmode) { - case LSEQ_DOTS: - case LSEQ_TO: - start = numValues[0]; - end = numValues[2]; - break; - case LSEQ_BY: - start = zero; - elementCount = numValues[0]; - step = numValues[2]; - break; - case LSEQ_COUNT: - start = numValues[0]; - elementCount = numValues[2]; - step = one; - break; - default: - status = TCL_ERROR; - goto done; - } - break; - -/* lseq n 'to' n n */ -/* lseq n 'count' n n */ - case 1211: - opmode = (SequenceOperators)values[1]; - switch (opmode) { - case LSEQ_DOTS: - case LSEQ_TO: - start = numValues[0]; - end = numValues[2]; - step = numValues[3]; - break; - case LSEQ_COUNT: - start = numValues[0]; - elementCount = numValues[2]; - step = numValues[3]; - break; - case LSEQ_BY: - /* Error case */ - status = TCL_ERROR; - goto done; - break; - default: - status = TCL_ERROR; - goto done; - break; - } - break; - -/* lseq n n 'by' n */ - case 1121: - start = numValues[0]; - end = numValues[1]; - opmode = (SequenceOperators)values[2]; - switch (opmode) { - case LSEQ_BY: - step = numValues[3]; - break; - case LSEQ_DOTS: - case LSEQ_TO: - case LSEQ_COUNT: - default: - status = TCL_ERROR; - goto done; - break; - } - break; - -/* lseq n 'to' n 'by' n */ -/* lseq n 'count' n 'by' n */ - case 12121: - start = numValues[0]; - opmode = (SequenceOperators)values[3]; - switch (opmode) { - case LSEQ_BY: - step = numValues[4]; - break; - default: - status = TCL_ERROR; - goto done; - break; - } - opmode = (SequenceOperators)values[1]; - switch (opmode) { - case LSEQ_DOTS: - case LSEQ_TO: - start = numValues[0]; - end = numValues[2]; - break; - case LSEQ_COUNT: - start = numValues[0]; - elementCount = numValues[2]; - break; - default: - status = TCL_ERROR; - goto done; - break; - } - break; - -/* Error cases: incomplete arguments */ - case 12: - opmode = (SequenceOperators)values[1]; goto KeywordError; break; - case 112: - opmode = (SequenceOperators)values[2]; goto KeywordError; break; - case 1212: - opmode = (SequenceOperators)values[3]; goto KeywordError; break; - KeywordError: - status = TCL_ERROR; - switch (opmode) { - case LSEQ_DOTS: - case LSEQ_TO: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "missing \"to\" value.")); - break; - case LSEQ_COUNT: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "missing \"count\" value.")); - break; - case LSEQ_BY: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "missing \"by\" value.")); - break; - } - status = TCL_ERROR; - goto done; - break; - -/* All other argument errors */ - default: - Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??"); - status = TCL_ERROR; - goto done; - break; - } - - /* - * Success! Now lets create the series object. - */ - status = TclNewArithSeriesObj(interp, &arithSeriesPtr, - useDoubles, start, end, step, elementCount); - - if (status == TCL_OK) { - Tcl_SetObjResult(interp, arithSeriesPtr); + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); } - - done: - // Free number arguments. - while (--value_i>=0) { - if (numValues[value_i]) Tcl_DecrRefCount(numValues[value_i]); - } - - // Free constants - Tcl_DecrRefCount(zero); - Tcl_DecrRefCount(one); - - return status; + return TCL_OK; } /* @@ -4421,7 +3376,7 @@ Tcl_LseqObjCmd( int Tcl_LsetObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ @@ -4434,8 +3389,7 @@ Tcl_LsetObjCmd( */ if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, - "listVar ?index? ?index ...? value"); + Tcl_WrongNumArgs(interp, 1, objv, "listVar ?index? ?index...? value"); return TCL_ERROR; } @@ -4443,7 +3397,8 @@ Tcl_LsetObjCmd( * Look up the list variable's value. */ - listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); + listPtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, + TCL_LEAVE_ERR_MSG); if (listPtr == NULL) { return TCL_ERROR; } @@ -4506,40 +3461,36 @@ Tcl_LsetObjCmd( int Tcl_LsortObjCmd( - TCL_UNUSED(ClientData), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { 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; - size_t elmArrSize; - Tcl_WideInt wide; - SortElement *elementArray = NULL, *elementPtr; + SortElement *elementArray, *elementPtr; SortInfo sortInfo; /* Information about this sort that needs to * be passed to the comparison function. */ -# define MAXCALLOC 1024000 -# 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[] = { + static const char *switches[] = { "-ascii", "-command", "-decreasing", "-dictionary", "-increasing", - "-index", "-indices", "-integer", "-nocase", "-real", "-stride", - "-unique", NULL + "-index", "-indices", "-integer", "-nocase", "-real", "-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_STRIDE, LSORT_UNIQUE + LSORT_NOCASE, LSORT_REAL, LSORT_UNIQUE }; + /* + * 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. + */ +# define NUM_LISTS 30 + SortElement *subList[NUM_LISTS+1]; + if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list"); + Tcl_WrongNumArgs(interp, 1, objv, "?options? list"); return TCL_ERROR; } @@ -4553,31 +3504,30 @@ Tcl_LsortObjCmd( sortInfo.indexc = 0; sortInfo.unique = 0; sortInfo.interp = interp; - sortInfo.resultCode = TCL_OK; + sortInfo.resultCode = TCL_OK; cmdPtr = NULL; 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) { - sortInfo.resultCode = TCL_ERROR; - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return TCL_ERROR; } switch ((enum Lsort_Switches) index) { case LSORT_ASCII: sortInfo.sortMode = SORTMODE_ASCII; break; case LSORT_COMMAND: - if (i == objc-2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( + if (i == (objc-2)) { + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + Tcl_AppendResult(interp, "\"-command\" option must be followed " - "by comparison command", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); - sortInfo.resultCode = TCL_ERROR; - goto done; + "by comparison command", NULL); + return TCL_ERROR; } sortInfo.sortMode = SORTMODE_COMMAND; cmdPtr = objv[i+1]; @@ -4593,52 +3543,54 @@ Tcl_LsortObjCmd( sortInfo.isIncreasing = 1; break; case LSORT_INDEX: { - Tcl_Size sortindex; - Tcl_Obj **indexv; + Tcl_Obj **indices; - if (i == objc-2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"-index\" option must be followed by list index", - -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); - sortInfo.resultCode = TCL_ERROR; - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); } - if (TclListObjGetElements(interp, objv[i+1], &sortindex, - &indexv) != TCL_OK) { - sortInfo.resultCode = TCL_ERROR; - goto done; + if (i == (objc-2)) { + Tcl_AppendResult(interp, "\"-index\" option must be " + "followed by list index", NULL); + return TCL_ERROR; } /* - * 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. + * Take copy to prevent shimmering problems. */ - for (j=0 ; j<sortindex ; j++) { - int encoded = 0; - int result = TclIndexEncode(interp, indexv[j], - TCL_INDEX_NONE, TCL_INDEX_NONE, &encoded); - - if ((result == TCL_OK) && (encoded == (int)TCL_INDEX_NONE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "index \"%s\" out of range", - TclGetString(indexv[j]))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" - "OUTOFRANGE", (void *)NULL); - result = TCL_ERROR; - } - if (result == TCL_ERROR) { + if (TclListObjGetElements(interp, objv[i+1], &sortInfo.indexc, + &indices) != TCL_OK) { + return TCL_ERROR; + } + 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); + } + + /* + * 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. + */ + + for (j=0 ; j<sortInfo.indexc ; j++) { + if (TclGetIntForIndexM(interp, indices[j], SORTIDX_END, + &sortInfo.indexv[j]) != TCL_OK) { + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (-index option item number %d)", j)); - sortInfo.resultCode = TCL_ERROR; - goto done; + return TCL_ERROR; } } - indexPtr = objv[i+1]; i++; break; } @@ -4657,67 +3609,12 @@ Tcl_LsortObjCmd( 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", (void *)NULL); - sortInfo.resultCode = TCL_ERROR; - goto done; - } - if (Tcl_GetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) { - sortInfo.resultCode = TCL_ERROR; - goto done; - } - if ((wide < 2) || (wide > LIST_MAX)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "stride length must be between 2 and %d", LIST_MAX)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", - "BADSTRIDE", (void *)NULL); - sortInfo.resultCode = TCL_ERROR; - goto done; - } - groupSize = wide; - 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 = (int *) - 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++) { - /* Prescreened values, no errors or out of range possible */ - TclIndexEncode(NULL, indexv[j], TCL_INDEX_NONE, - TCL_INDEX_NONE, &sortInfo.indexv[j]); - } - } - listObj = objv[objc-1]; if (sortInfo.sortMode == SORTMODE_COMMAND) { @@ -4732,8 +3629,10 @@ Tcl_LsortObjCmd( listObj = TclListObjCopy(interp, listObj); if (listObj == NULL) { - sortInfo.resultCode = TCL_ERROR; - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return TCL_ERROR; } /* @@ -4750,80 +3649,22 @@ Tcl_LsortObjCmd( TclDecrRefCount(listObj); Tcl_IncrRefCount(newObjPtr); TclDecrRefCount(newObjPtr); - sortInfo.resultCode = TCL_ERROR; - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return TCL_ERROR; } - TclNewObj(newObjPtr); - Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr); + Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj()); sortInfo.compareCmdPtr = newCommandPtr; } - if (TclHasInternalRep(listObj,&tclArithSeriesType)) { - sortInfo.resultCode = TclArithSeriesGetElements(interp, - listObj, &length, &listObjPtrs); - } else { - sortInfo.resultCode = TclListObjGetElements(interp, listObj, + sortInfo.resultCode = TclListObjGetElements(interp, listObj, &length, &listObjPtrs); - } if (sortInfo.resultCode != TCL_OK || length <= 0) { goto done; } - - /* - * 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", - (void *)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 = TclIndexDecode(sortInfo.indexv[0], groupSize - 1); - 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", (void *)NULL); - sortInfo.resultCode = TCL_ERROR; - goto done; - } - if (sortInfo.indexc == 1) { - sortInfo.indexc = 0; - sortInfo.indexv = NULL; - } else { - sortInfo.indexc--; - - /* - * Do not shrink the actual memory block used; that doesn't - * work with TclStackAlloc-allocated memory. [Bug 2918962] - * - * TODO: Consider a pointer increment to replace this - * array shift. - */ - - for (i = 0; i < sortInfo.indexc; i++) { - sortInfo.indexv[i] = sortInfo.indexv[i+1]; - } - } - } - } - sortInfo.numElements = length; - + indexc = sortInfo.indexc; sortMode = sortInfo.sortMode; if ((sortMode == SORTMODE_ASCII_NC) @@ -4831,7 +3672,7 @@ Tcl_LsortObjCmd( /* * For this function's purpose all string-based modes are equivalent */ - + sortMode = SORTMODE_ASCII; } @@ -4840,7 +3681,7 @@ Tcl_LsortObjCmd( * 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; } @@ -4850,77 +3691,57 @@ Tcl_LsortObjCmd( * begins sorting it into the sublists as it appears. */ - elmArrSize = length * sizeof(SortElement); - if (elmArrSize <= MAXCALLOC) { - elementArray = (SortElement *)ckalloc(elmArrSize); - } else { - elementArray = (SortElement *)malloc(elmArrSize); - } - if (!elementArray) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "no enough memory to proccess sort of %d items", length)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); - sortInfo.resultCode = TCL_ERROR; - goto done; - } + elementArray = (SortElement *) ckalloc( length * sizeof(SortElement)); - for (i=0; i < length; i++) { - idx = groupSize * i + groupOffset; + for (i=0; i < length; i++){ if (indexc) { /* * If this is an indexed sort, retrieve the corresponding element */ - indexPtr = SelectObjFromSublist(listObjPtrs[idx], &sortInfo); + indexPtr = SelectObjFromSublist(listObjPtrs[i], &sortInfo); if (sortInfo.resultCode != TCL_OK) { - goto done; + goto done1; } } else { - indexPtr = listObjPtrs[idx]; + indexPtr = listObjPtrs[i]; } /* * Determine the "value" of this object for sorting purposes */ - + if (sortMode == SORTMODE_ASCII) { - elementArray[i].collationKey.strValuePtr = TclGetString(indexPtr); + elementArray[i].index.strValuePtr = TclGetString(indexPtr); } else if (sortMode == SORTMODE_INTEGER) { - Tcl_WideInt a; - - if (TclGetWideIntFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { + long a; + if (TclGetLongFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; - goto done; + goto done1; } - elementArray[i].collationKey.wideValue = a; + elementArray[i].index.intValue = a; } else if (sortMode == SORTMODE_REAL) { double a; - - if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr, - &a) != TCL_OK) { + if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; - goto done; + goto done1; } - elementArray[i].collationKey.doubleValue = a; + elementArray[i].index.doubleValue = a; } else { - elementArray[i].collationKey.objValuePtr = indexPtr; + elementArray[i].index.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]; - } + + elementArray[i].objPtr = (indices ? INT2PTR(i) : listObjPtrs[i]); /* - * Merge this element in the preexisting sublists (and merge together + * 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++) { @@ -4936,74 +3757,53 @@ Tcl_LsortObjCmd( /* * Merge all sublists */ - + elementPtr = subList[0]; for (j=1 ; j<NUM_LISTS ; j++) { elementPtr = MergeLists(subList[j], elementPtr, &sortInfo); } + /* * Now store the sorted elements in the result list. */ - + if (sortInfo.resultCode == TCL_OK) { - ListRep listRep; + List *listRepPtr; Tcl_Obj **newArray, *objPtr; - - resultPtr = Tcl_NewListObj(sortInfo.numElements * groupSize, NULL); - ListObjGetRep(resultPtr, &listRep); - newArray = ListRepElementsBase(&listRep); - if (group) { - for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) { - idx = elementPtr->payload.index; - for (j = 0; j < groupSize; j++) { - if (indices) { - TclNewIndexObj(objPtr, 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) { - TclNewIndexObj(objPtr, elementPtr->payload.index); + int i; + + resultPtr = Tcl_NewListObj(sortInfo.numElements, NULL); + listRepPtr = ListRepPtr(resultPtr); + newArray = &listRepPtr->elements; + if (indices) { + for (i = 0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr){ + objPtr = Tcl_NewIntObj(PTR2INT(elementPtr->objPtr)); newArray[i++] = objPtr; Tcl_IncrRefCount(objPtr); } } else { - for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { - objPtr = elementPtr->payload.objPtr; + for (i = 0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr){ + objPtr = elementPtr->objPtr; newArray[i++] = objPtr; Tcl_IncrRefCount(objPtr); } } - listRep.storePtr->numUsed = i; - if (listRep.spanPtr) { - listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; - listRep.spanPtr->spanLength = listRep.storePtr->numUsed; - } + listRepPtr->elemCount = i; Tcl_SetObjResult(interp, resultPtr); } + done1: + ckfree((char *)elementArray); + done: if (sortMode == SORTMODE_COMMAND) { TclDecrRefCount(sortInfo.compareCmdPtr); TclDecrRefCount(listObj); sortInfo.compareCmdPtr = NULL; } - if (allocatedIndexVector) { - TclStackFree(interp, sortInfo.indexv); - } - if (elementArray) { - if (elmArrSize <= MAXCALLOC) { - ckfree((char *)elementArray); - } else { - free((char *)elementArray); - } + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); } return sortInfo.resultCode; } @@ -5011,123 +3811,6 @@ Tcl_LsortObjCmd( /* *---------------------------------------------------------------------- * - * Tcl_LeditObjCmd -- - * - * This procedure is invoked to process the "ledit" 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_LeditObjCmd( - TCL_UNUSED(void *), - 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. */ - int createdNewObj; - int result; - Tcl_Size first; - Tcl_Size last; - Tcl_Size listLen; - Tcl_Size numToDelete; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, - "listVar first last ?element ...?"); - return TCL_ERROR; - } - - listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); - if (listPtr == NULL) { - return TCL_ERROR; - } - - /* - * TODO - refactor the index extraction into a common function shared - * by Tcl_{Lrange,Lreplace,Ledit}ObjCmd - */ - - result = TclListObjLength(interp, listPtr, &listLen); - if (result != TCL_OK) { - return result; - } - - result = TclGetIntForIndexM(interp, objv[2], /*end*/ listLen-1, &first); - if (result != TCL_OK) { - return result; - } - - result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last); - if (result != TCL_OK) { - return result; - } - - if (first == TCL_INDEX_NONE) { - first = 0; - } else if (first > listLen) { - first = listLen; - } - - if (last >= listLen) { - last = listLen - 1; - } - if (first <= last) { - numToDelete = (unsigned)last - (unsigned)first + 1; /* See [3d3124d01d] */ - } else { - numToDelete = 0; - } - - if (Tcl_IsShared(listPtr)) { - listPtr = TclListObjCopy(NULL, listPtr); - createdNewObj = 1; - } else { - createdNewObj = 0; - } - - result = - Tcl_ListObjReplace(interp, listPtr, first, numToDelete, objc - 4, objv + 4); - if (result != TCL_OK) { - if (createdNewObj) { - Tcl_DecrRefCount(listPtr); - } - return result; - } - - /* - * Tcl_ObjSetVar2 mau return a value different from listPtr in the - * presence of traces etc.. Note that finalValuePtr will always have a - * reference count of at least 1 corresponding to the reference from the - * var. If it is same as listPtr, then ref count will be at least 2 - * since we are incr'ing the latter below (safer when calling - * Tcl_ObjSetVar2 which can release it in some cases). Note that we - * leave the incrref of listPtr this late because we want to pass it as - * unshared to Tcl_ListObjReplace above if possible. - */ - Tcl_IncrRefCount(listPtr); - finalValuePtr = - Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG); - Tcl_DecrRefCount(listPtr); /* safe irrespective of createdNewObj */ - if (finalValuePtr == NULL) { - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, finalValuePtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * MergeLists - * * This procedure combines two sorted lists of SortElement structures @@ -5137,23 +3820,21 @@ Tcl_LeditObjCmd( * The unified list of SortElement structures. * * Side effects: - * If infoPtr->unique is set then infoPtr->numElements may be updated. + * If infoPtr->unique is set then infoPtr->numElements may be updated. * Possibly others, if a user-defined comparison command does something - * weird. + * weird. * * Note: - * If infoPtr->unique is set, the merge assumes that there are no + * 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. - * + * 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. *---------------------------------------------------------------------- */ @@ -5234,7 +3915,7 @@ MergeLists( * ordering between two elements. * * Results: - * A negative results means the first element comes before the + * A negative results means the the first element comes before the * second, and a positive results means that the second element should * come first. A result of zero means the two elements are equal and it * doesn't matter which comes first. @@ -5255,29 +3936,29 @@ SortCompare( int order = 0; if (infoPtr->sortMode == SORTMODE_ASCII) { - order = TclUtfCmp(elemPtr1->collationKey.strValuePtr, - elemPtr2->collationKey.strValuePtr); + order = strcmp(elemPtr1->index.strValuePtr, + elemPtr2->index.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { - order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr, - elemPtr2->collationKey.strValuePtr); + order = TclUtfCasecmp(elemPtr1->index.strValuePtr, + elemPtr2->index.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { - order = DictionaryCompare(elemPtr1->collationKey.strValuePtr, - elemPtr2->collationKey.strValuePtr); + order = DictionaryCompare(elemPtr1->index.strValuePtr, + elemPtr2->index.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_INTEGER) { - Tcl_WideInt a, b; + long a, b; - a = elemPtr1->collationKey.wideValue; - b = elemPtr2->collationKey.wideValue; + a = elemPtr1->index.intValue; + b = elemPtr2->index.intValue; order = ((a >= b) - (a <= b)); } else if (infoPtr->sortMode == SORTMODE_REAL) { double a, b; - a = elemPtr1->collationKey.doubleValue; - b = elemPtr2->collationKey.doubleValue; + a = elemPtr1->index.doubleValue; + b = elemPtr2->index.doubleValue; order = ((a >= b) - (a <= b)); } else { Tcl_Obj **objv, *paramObjv[2]; - Tcl_Size objc; + int objc; Tcl_Obj *objPtr1, *objPtr2; if (infoPtr->resultCode != TCL_OK) { @@ -5285,14 +3966,14 @@ SortCompare( * 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; - + objPtr1 = elemPtr1->index.objValuePtr; + objPtr2 = elemPtr2->index.objValuePtr; + paramObjv[0] = objPtr1; paramObjv[1] = objPtr2; @@ -5310,7 +3991,8 @@ SortCompare( infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0); if (infoPtr->resultCode != TCL_OK) { - Tcl_AddErrorInfo(infoPtr->interp, "\n (-compare command)"); + Tcl_AddErrorInfo(infoPtr->interp, + "\n (-compare command)"); return 0; } @@ -5320,10 +4002,9 @@ SortCompare( if (TclGetIntFromObj(infoPtr->interp, Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) { - Tcl_SetObjResult(infoPtr->interp, Tcl_NewStringObj( - "-compare command returned non-integer result", -1)); - Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", - "COMPARISONFAILED", (void *)NULL); + Tcl_ResetResult(infoPtr->interp); + Tcl_AppendResult(infoPtr->interp, + "-compare command returned non-integer result", NULL); infoPtr->resultCode = TCL_ERROR; return 0; } @@ -5360,9 +4041,9 @@ SortCompare( static int DictionaryCompare( - const char *left, const char *right) /* The strings to compare. */ + char *left, char *right) /* The strings to compare. */ { - int uniLeft = 0, uniRight = 0, uniLeftLower, uniRightLower; + Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower; int diff, zeros; int secondaryDiff = 0; @@ -5377,11 +4058,11 @@ DictionaryCompare( */ 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++; } @@ -5431,12 +4112,12 @@ DictionaryCompare( */ if ((*left != '\0') && (*right != '\0')) { - left += TclUtfToUniChar(left, &uniLeft); - right += TclUtfToUniChar(right, &uniRight); + left += Tcl_UtfToUniChar(left, &uniLeft); + right += Tcl_UtfToUniChar(right, &uniRight); /* * Convert both chars to lower for the comparison, because - * dictionary sorts are case-insensitive. Covert to lower, not + * 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). */ @@ -5495,7 +4176,7 @@ SelectObjFromSublist( SortInfo *infoPtr) /* Information passed from the top-level * "lsearch" or "lsort" command. */ { - Tcl_Size i; + int i; /* * Quick check for case when no "-index" option is there. @@ -5511,16 +4192,22 @@ SelectObjFromSublist( */ for (i=0 ; i<infoPtr->indexc ; i++) { - Tcl_Size listLen; - int index; + int listLen, index; Tcl_Obj *currentObj; if (TclListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; return NULL; } + index = infoPtr->indexv[i]; - index = TclIndexDecode(infoPtr->indexv[i], listLen - 1); + /* + * Adjust for end-based indexing. + */ + + if (index < SORTIDX_NONE) { + index += listLen + 1; + } if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index, ¤tObj) != TCL_OK) { @@ -5528,18 +4215,12 @@ SelectObjFromSublist( return NULL; } if (currentObj == NULL) { - if (index == TCL_INDEX_NONE) { - index = TCL_INDEX_END - infoPtr->indexv[i]; - Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( - "element end-%d missing from sublist \"%s\"", - index, TclGetString(objPtr))); - } else { - Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( - "element %d missing from sublist \"%s\"", - index, TclGetString(objPtr))); - } - Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", - "INDEXFAILED", (void *)NULL); + char buffer[TCL_INTEGER_SPACE]; + + TclFormatInt(buffer, index); + Tcl_AppendResult(infoPtr->interp, "element ", buffer, + " missing from sublist \"", TclGetString(objPtr), "\"", + NULL); infoPtr->resultCode = TCL_ERROR; return NULL; } @@ -5553,6 +4234,5 @@ SelectObjFromSublist( * mode: c * c-basic-offset: 4 * fill-column: 78 - * tab-width: 8 * End: */ |