Increased robustness and speed for [lrepeat] with help of new list constructor

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