summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2003-11-01 01:20:32 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2003-11-01 01:20:32 (GMT)
commit9b718efb671760d88cc93cb84eaa73697691e517 (patch)
treebc1721a707ef0e825858ac0ed3ebd0a139809b55 /generic
parentc7138a4395c5e741fedf98722b8fc971e4a74ac3 (diff)
downloadtcl-9b718efb671760d88cc93cb84eaa73697691e517.zip
tcl-9b718efb671760d88cc93cb84eaa73697691e517.tar.gz
tcl-9b718efb671760d88cc93cb84eaa73697691e517.tar.bz2
Increased robustness and speed for [lrepeat] with help of new list constructor
Diffstat (limited to 'generic')
-rw-r--r--generic/tclCmdIL.c53
-rw-r--r--generic/tclConfig.c95
-rw-r--r--generic/tclInt.decls11
-rw-r--r--generic/tclInt.h5
-rw-r--r--generic/tclListObj.c116
5 files changed, 212 insertions, 68 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index c7b5e19..ec8dd4c 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdIL.c,v 1.55 2003/10/15 13:15:45 dkf Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.56 2003/11/01 01:20:33 dkf Exp $
*/
#include "tclInt.h"
@@ -2650,7 +2650,7 @@ Tcl_LrepeatObjCmd(dummy, interp, objc, objv)
register int objc; /* Number of arguments. */
register Tcl_Obj *CONST objv[]; /* The argument objects. */
{
- int elementCount, i, j, k, result;
+ int elementCount, i, result;
Tcl_Obj **dataArray;
/*
@@ -2685,22 +2685,50 @@ Tcl_LrepeatObjCmd(dummy, interp, objc, objv)
* elementCount times. Note that we don't bother with stack
* allocation for this, as we expect this function to be used
* mainly when stack allocation would be inappropriate anyway.
+ * First check to see if we'd overflow and try to allocate an
+ * object larger than our memory allocator allows. Note that this
+ * is actually a fairly small value when you're on a serious
+ * 64-bit machine, but that requires API changes to fix.
*
- * POSSIBLE FUTURE ENHANCEMENT: Build the resulting list object
- * directly and avoid a copy.
+ * We allocate using attemptckalloc() because if we ask for
+ * something big but can't get it, we've still got a high chance
+ * of having a proper failover strategy. If *that* fails to get
+ * memory, panic() will happen just a few lines lower...
*/
- dataArray = (Tcl_Obj **) ckalloc(elementCount * objc * sizeof(Tcl_Obj));
+ if (elementCount > INT_MAX/sizeof(Tcl_Obj *)/objc) {
+ Tcl_AppendResult(interp, "overflow of maximum list length", NULL);
+ return TCL_ERROR;
+ }
+
+ dataArray = (Tcl_Obj **)
+ attemptckalloc(elementCount * objc * sizeof(Tcl_Obj *));
+
+ if (dataArray == NULL) {
+ Tcl_AppendResult(interp, "insufficient memory to create list", NULL);
+ return TCL_ERROR;
+ }
/*
- * Set the elements. Note that this ends up setting k to the
- * total number of elements.
+ * Set the elements. Note that we handle the common degenerate
+ * case of a single value being repeated separately to permit the
+ * compiler as much room as possible to optimize a loop that might
+ * be run a very large number of times.
*/
- k = 0;
- for (i=0 ; i<elementCount ; i++) {
- for (j=0 ; j<objc ; j++) {
- dataArray[k++] = objv[j];
+ if (objc == 1) {
+ register Tcl_Obj *tmpPtr = objv[0];
+
+ for (i=0 ; i<elementCount ; i++) {
+ dataArray[i] = tmpPtr;
+ }
+ } else {
+ int j, k = 0;
+
+ for (i=0 ; i<elementCount ; i++) {
+ for (j=0 ; j<objc ; j++) {
+ dataArray[k++] = objv[j];
+ }
}
}
@@ -2708,8 +2736,7 @@ Tcl_LrepeatObjCmd(dummy, interp, objc, objv)
* Build the result list, clean up and return.
*/
- Tcl_SetObjResult(interp, Tcl_NewListObj(k, dataArray));
- ckfree((char*) dataArray);
+ Tcl_SetObjResult(interp, TclNewListObjDirect(elementCount*objc,dataArray));
return TCL_OK;
}
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index e8c7be6..e1336f2 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclConfig.c,v 1.3 2003/06/10 20:35:48 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclConfig.c,v 1.4 2003/11/01 01:20:34 dkf Exp $
*/
#include "tclInt.h"
@@ -189,26 +189,23 @@ Tcl_RegisterConfig (interp, pkgName, configuration, valEncoding)
*/
static int
-QueryConfigObjCmd (clientData, interp, objc, objv)
+QueryConfigObjCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
- struct Tcl_Obj * CONST * objv;
+ struct Tcl_Obj * CONST *objv;
{
- Tcl_Obj* pkgName = (Tcl_Obj*) clientData;
- Tcl_Obj* pDB;
- Tcl_Obj* pkgDict;
- Tcl_Obj* val;
+ Tcl_Obj *pkgName = (Tcl_Obj*) clientData;
+ Tcl_Obj *pDB, *pkgDict, *val;
Tcl_DictSearch s;
int n, i, res, done, index;
- Tcl_Obj* key;
- Tcl_Obj** vals;
+ Tcl_Obj *key, **vals;
static CONST char *subcmdStrings[] = {
"get", "list", NULL
};
enum subcmds {
- CFG_GET, CFG_LIST
+ CFG_GET, CFG_LIST
};
if ((objc < 2) || (objc > 3)) {
@@ -220,61 +217,55 @@ QueryConfigObjCmd (clientData, interp, objc, objv)
return TCL_ERROR;
}
- pDB = GetConfigDict (interp);
- res = Tcl_DictObjGet (interp, pDB, pkgName, &pkgDict);
- if ((res != TCL_OK) || (pkgDict == NULL)) {
+ pDB = GetConfigDict(interp);
+ res = Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict);
+ if (res!=TCL_OK || pkgDict==NULL) {
/* Maybe a panic is better, because the package data has to be present */
- Tcl_SetObjResult (interp, Tcl_NewStringObj ("package not known", -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
return TCL_ERROR;
}
switch ((enum subcmds) index) {
- case CFG_GET:
- if (objc != 3) {
- Tcl_WrongNumArgs (interp, 0, NULL, "get key");
- return TCL_ERROR;
- }
-
- res = Tcl_DictObjGet (interp, pkgDict, objv [2], &val);
- if ((res != TCL_OK) || (val == NULL)) {
- Tcl_SetObjResult (interp, Tcl_NewStringObj ("key not known", -1));
- return TCL_ERROR;
- }
-
- Tcl_SetObjResult (interp, val);
- return TCL_OK;
+ case CFG_GET:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 0, NULL, "get key");
+ return TCL_ERROR;
+ }
+ res = Tcl_DictObjGet(interp, pkgDict, objv [2], &val);
+ if (res!=TCL_OK || val==NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1));
+ return TCL_ERROR;
+ }
- case CFG_LIST:
- if (objc != 2) {
- Tcl_WrongNumArgs (interp, 0, NULL, "list");
- return TCL_ERROR;
- }
+ Tcl_SetObjResult(interp, val);
+ return TCL_OK;
- Tcl_DictObjSize (interp, pkgDict, &n);
- if (n == 0) {
- Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL));
- return TCL_OK;
- }
+ case CFG_LIST:
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 0, NULL, "list");
+ return TCL_ERROR;
+ }
- vals = (Tcl_Obj**) ckalloc (n * sizeof (Tcl_Obj*));
+ Tcl_DictObjSize(interp, pkgDict, &n);
+ if (n == 0) {
+ Tcl_SetObjResult(interp, Tcl_NewListObj(0, NULL));
+ return TCL_OK;
+ }
- for (i = 0, Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done);
- !done;
- Tcl_DictObjNext (&s, &key, NULL, &done), i++) {
- if (done) break;
- vals [i] = key;
- }
- Tcl_DictObjDone (&s);
+ vals = (Tcl_Obj**) ckalloc(n * sizeof(Tcl_Obj*));
- Tcl_SetObjResult (interp, Tcl_NewListObj (n, vals));
- ckfree ((char*) vals);
+ for (i=0, Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done);
+ !done; Tcl_DictObjNext(&s, &key, NULL, &done), i++) {
+ vals[i] = key;
+ }
- return TCL_OK;
+ Tcl_SetObjResult(interp, TclNewListObjDirect(n, vals));
+ return TCL_OK;
- default:
- Tcl_Panic ("QueryConfigObjCmd: Unknown subcommand to 'pkgconfig'. This can't happen");
- break;
+ default:
+ Tcl_Panic("QueryConfigObjCmd: Unknown subcommand to 'pkgconfig'. This can't happen");
+ break;
}
return TCL_ERROR;
}
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index f04bc4d..8ddba3c 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tclInt.decls,v 1.63 2003/09/05 21:52:12 dgp Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.64 2003/11/01 01:20:34 dkf Exp $
library tcl
@@ -725,6 +725,15 @@ declare 178 generic {
declare 179 generic {
Tcl_Obj *Tcl_GetStartupScript(CONST char **encodingNamePtr)
}
+
+# Allocate lists without copying arrays
+declare 180 generic {
+ Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj *CONST objv[])
+}
+declare 180 generic {
+ Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj *CONST objv[],
+ CONST char *file, int line)
+}
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
diff --git a/generic/tclInt.h b/generic/tclInt.h
index cbdbd10..0b36958 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.136 2003/10/14 15:44:52 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.137 2003/11/01 01:20:34 dkf Exp $
*/
#ifndef _TCLINT
@@ -2143,6 +2143,9 @@ EXTERN void TclDbInitNewObj _ANSI_ARGS_((Tcl_Obj *objPtr));
# define TclDecrRefCount(objPtr) \
Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)
+# define TclNewListObjDirect(objc, objv) \
+ TclDbNewListObjDirect(objc, objv, __FILE__, __LINE__)
+
#elif defined(PURIFY)
/*
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 8284a3e..020c725 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclListObj.c,v 1.15 2003/10/30 22:18:07 dkf Exp $
+ * RCS: @(#) $Id: tclListObj.c,v 1.16 2003/11/01 01:20:35 dkf Exp $
*/
#include "tclInt.h"
@@ -210,6 +210,120 @@ Tcl_DbNewListObj(objc, objv, file, line)
/*
*----------------------------------------------------------------------
*
+ * TclNewListObjDirect, TclDbNewListObjDirect --
+ *
+ * Version of Tcl_NewListOb/Tcl_DbNewListObj that does not copy
+ * the array of Tcl_Objs. It still scans it though to update the
+ * reference counts.
+ *
+ * Results:
+ * A new list object is returned that is initialized from the object
+ * pointers in objv. If objc is less than or equal to zero, an empty
+ * object is returned (and "ownership" of the array of objects is
+ * not transferred.) The new object's string representation is left
+ * NULL. The resulting new list object has ref count 0.
+ *
+ * Side effects:
+ * The ref counts of the elements in objv are incremented since the
+ * resulting list now refers to them.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef TCL_MEM_DEBUG
+#undef TclNewListObjDirect
+Tcl_Obj *
+TclNewListObjDirect(objc, objv)
+ int objc; /* Count of objects referenced by objv. */
+ Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */
+{
+ return TclDbNewListObjDirect(objc, objv, "unknown", 0);
+}
+#else /* !TCL_MEM_DEBUG */
+Tcl_Obj *
+TclNewListObjDirect(objc, objv)
+ int objc; /* Count of objects referenced by objv. */
+ Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */
+{
+ register Tcl_Obj *listPtr;
+
+ TclNewObj(listPtr);
+
+ if (objc > 0) {
+ register List *listRepPtr;
+ int i;
+
+ Tcl_InvalidateStringRep(listPtr);
+
+ for (i=0 ; i<objc ; i++) {
+ Tcl_IncrRefCount(objv[i]);
+ }
+
+ listRepPtr = (List *) ckalloc(sizeof(List));
+ listRepPtr->maxElemCount = objc;
+ listRepPtr->elemCount = objc;
+ listRepPtr->elements = objv;
+
+ listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
+ listPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ listPtr->typePtr = &tclListType;
+ }
+ return listPtr;
+}
+#endif /* TCL_MEM_DEBUG */
+
+#ifdef TCL_MEM_DEBUG
+Tcl_Obj *
+TclDbNewListObjDirect(objc, objv, file, line)
+ int objc; /* Count of objects referenced by objv. */
+ Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */
+ CONST char *file; /* The name of the source file calling this
+ * procedure; used for debugging. */
+ int line; /* Line number in the source file; used
+ * for debugging. */
+{
+ register Tcl_Obj *listPtr;
+
+ TclDbNewObj(listPtr, file, line);
+
+ if (objc > 0) {
+ register List *listRepPtr;
+ int i;
+
+ Tcl_InvalidateStringRep(listPtr);
+
+ for (i=0 ; i<objc ; i++) {
+ Tcl_IncrRefCount(objv[i]);
+ }
+
+ listRepPtr = (List *) ckalloc(sizeof(List));
+ listRepPtr->maxElemCount = objc;
+ listRepPtr->elemCount = objc;
+ listRepPtr->elements = objv;
+
+ listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
+ listPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ listPtr->typePtr = &tclListType;
+ }
+ return listPtr;
+}
+#else /* !TCL_MEM_DEBUG */
+Tcl_Obj *
+TclDbNewListObjDirect(objc, objv, file, line)
+ int objc; /* Count of objects referenced by objv. */
+ Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */
+ CONST char *file; /* The name of the source file calling this
+ * procedure; used for debugging. */
+ int line; /* Line number in the source file; used
+ * for debugging. */
+{
+ return TclNewListObjDirect(objc, objv);
+}
+#endif /* TCL_MEM_DEBUG */
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_SetListObj --
*
* Modify an object to be a list containing each of the objc elements