Attachment "tcl843-lrepeat.patch" to
ticket [784208ffff]
added by
dkf
2003-08-06 21:29:01.
diff -Naru tcl8.4.3/doc/lrepeat.n tcl8.4.3-lrepeat/doc/lrepeat.n
--- tcl8.4.3/doc/lrepeat.n 1970-01-01 01:00:00.000000000 +0100
+++ tcl8.4.3-lrepeat/doc/lrepeat.n 2003-05-30 07:54:34.000000000 +0100
@@ -0,0 +1,46 @@
+'\"
+'\" Copyright (c) 1993 The Regents of the University of California.
+'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+'\" RCS: @(#) $Id: lindex.n,v 1.7 2001/11/14 23:15:33 hobbs Exp $
+'\"
+.so man.macros
+.TH lrepeat n 8.4 Tcl "Tcl Built-In Commands"
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+lrepeat \- Initialize a list
+.SH SYNOPSIS
+\fBlrepeat \fInumber element1 \fR?\fIelement2 element3 ...\fR?
+.BE
+.SH DESCRIPTION
+.PP
+.VS 8.4
+The \fBlrepeat\fP command creates a list of size \fInumber * number of elements\fP. The resultant list
+contains the given element sequence repeated \fInumber\fR times. \fInumber\fP must be a positive integer,
+\fIelementn\fP can be any tcl object. \fBlrepeat 1 arg ...\fR is identicat to \fBlist arg ...\fR.
+.PP
+When presented with a single index, the \fBlindex\fR command
+treats \fIlist\fR as a Tcl list and returns the
+.VE
+.SH EXAMPLES
+.CS
+lrepeat 3 a => a a a
+lrepeat 3 [lrepeat 3 0] => {{0 0 0} {0 0 0} {0 0 0}}
+lrepeat 3 a b c => {a b c a b c a b c}
+.CE
+.VE
+.SH "SEE ALSO"
+list(n), lappend(n), linsert(n), llength(n), lsearch(n),
+.VS 8.4
+lset(n),
+.VE
+lsort(n),
+lrange(n), lreplace(n)
+
+.SH KEYWORDS
+element, index, list
diff -Naru tcl8.4.3/generic/tclBasic.c tcl8.4.3-lrepeat/generic/tclBasic.c
--- tcl8.4.3/generic/tclBasic.c 2003-05-13 21:27:20.000000000 +0100
+++ tcl8.4.3-lrepeat/generic/tclBasic.c 2003-05-30 07:48:49.000000000 +0100
@@ -122,6 +122,8 @@
TclCompileLappendCmd, 1},
{"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd,
TclCompileLindexCmd, 1},
+ {"lrepeat", (Tcl_CmdProc *) NULL, Tcl_LrepeatObjCmd,
+ (CompileProc *) NULL, 1},
{"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd,
(CompileProc *) NULL, 1},
{"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd,
diff -Naru tcl8.4.3/generic/tclCmdIL.c tcl8.4.3-lrepeat/generic/tclCmdIL.c
--- tcl8.4.3/generic/tclCmdIL.c 2003-05-10 23:42:21.000000000 +0100
+++ tcl8.4.3-lrepeat/generic/tclCmdIL.c 2003-05-30 07:49:33.000000000 +0100
@@ -157,7 +157,7 @@
SortElement *rightPtr, SortInfo *infoPtr));
static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr,
Tcl_Obj *second, SortInfo *infoPtr));
-
+
/*
*----------------------------------------------------------------------
*
@@ -278,7 +278,7 @@
}
return Tcl_EvalObjEx(interp, objv[i], 0);
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -370,7 +370,7 @@
Tcl_SetObjResult(interp, newValuePtr);
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -490,7 +490,7 @@
}
return result;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -552,7 +552,7 @@
Tcl_SetObjResult(interp, listObjPtr);
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -620,7 +620,7 @@
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -659,7 +659,7 @@
Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount);
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -789,7 +789,7 @@
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -831,7 +831,7 @@
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -916,7 +916,7 @@
argName, "\"", (char *) NULL);
return TCL_ERROR;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -961,7 +961,7 @@
}
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1009,7 +1009,7 @@
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1076,7 +1076,7 @@
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1120,7 +1120,7 @@
return TCL_ERROR;
}
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1193,7 +1193,7 @@
Tcl_WrongNumArgs(interp, 2, objv, "?number?");
return TCL_ERROR;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1238,7 +1238,7 @@
"no library has been specified for Tcl", -1);
return TCL_ERROR;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1283,7 +1283,7 @@
result = TclGetLoadedPackages(interp, interpName);
return result;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1340,7 +1340,7 @@
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1413,7 +1413,7 @@
}
}
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1456,7 +1456,7 @@
}
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1500,7 +1500,7 @@
}
return TCL_ERROR;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1656,7 +1656,7 @@
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1706,7 +1706,7 @@
}
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1745,7 +1745,7 @@
#endif
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1788,7 +1788,7 @@
}
return TCL_ERROR;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1942,7 +1942,7 @@
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -2009,7 +2009,7 @@
}
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -2072,7 +2072,7 @@
return TCL_OK;
}
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -2099,7 +2099,7 @@
*
*----------------------------------------------------------------------
*/
-
+
Tcl_Obj *
TclLindexList( interp, listPtr, argPtr )
Tcl_Interp* interp; /* Tcl interpreter */
@@ -2242,7 +2242,7 @@
return listPtr;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -2364,7 +2364,7 @@
return listPtr;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -2453,7 +2453,73 @@
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
-
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_LrepeatObjCmd --
+ *
+ * This procedure is invoked to process the "lrepeat" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+Tcl_LrepeatObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ register int objc; /* Number of arguments. */
+ register Tcl_Obj *CONST objv[]; /* The argument objects. */
+{
+ int elementCount, i, j, res;
+ Tcl_Obj **dataArray;
+
+ /*
+ * Check args:
+ * lrepeat <number> <init-object>
+ *
+ */
+ if (objc <= 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "<number> <init-object> ?<init-object>? ...");
+ return TCL_ERROR;
+ }
+ elementCount = 0;
+ res = Tcl_GetIntFromObj(interp, objv[1], &elementCount);
+ if (res == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if (elementCount <= 0) {
+ Tcl_WrongNumArgs(interp, 1, objv, "<positive-integer> <init-object> ?<init-object>? ...");
+ return TCL_ERROR;
+ }
+
+ /* Create an array of <number> Tcl_Obj pointers */
+ dataArray = (Tcl_Obj **) ckalloc(elementCount * (objc-2) * sizeof(Tcl_Obj));
+
+ /* Set the elements */
+ for (i = 0; i < elementCount; i++) {
+ for (j = 2; j < objc; j++) {
+ dataArray[i*(objc-2)+j-2] = objv[j];
+ }
+ }
+
+ /* Send data to a list in the interpreter */
+ Tcl_SetListObj(Tcl_GetObjResult(interp), elementCount * (objc-2), dataArray);
+
+ /* Tidy up */
+ ckfree((char*) dataArray);
+
+ return TCL_OK;
+}
+
/*
*----------------------------------------------------------------------
*
@@ -2489,7 +2555,7 @@
}
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -2535,7 +2601,7 @@
Tcl_SetIntObj(Tcl_GetObjResult(interp), listLen);
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -2629,7 +2695,7 @@
Tcl_SetListObj(Tcl_GetObjResult(interp), numElems, &(elemPtrs[first]));
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -2744,7 +2810,7 @@
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -3150,7 +3216,7 @@
}
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -3230,7 +3296,7 @@
return TCL_OK;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -3405,7 +3471,7 @@
}
return sortInfo.resultCode;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -3463,7 +3529,7 @@
}
return elementPtr;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -3535,7 +3601,7 @@
}
return headPtr;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -3709,7 +3775,7 @@
}
return order;
}
-
+
/*
*----------------------------------------------------------------------
*
diff -Naru tcl8.4.3/generic/tclInt.h tcl8.4.3-lrepeat/generic/tclInt.h
--- tcl8.4.3/generic/tclInt.h 2003-05-10 23:42:22.000000000 +0100
+++ tcl8.4.3-lrepeat/generic/tclInt.h 2003-05-30 07:50:09.000000000 +0100
@@ -1872,6 +1872,8 @@
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_LlengthObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int Tcl_LrepeatObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ListObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_LoadObjCmd _ANSI_ARGS_((ClientData clientData,
diff -Naru tcl8.4.3/tests/lrepeat.test tcl8.4.3-lrepeat/tests/lrepeat.test
--- tcl8.4.3/tests/lrepeat.test 1970-01-01 01:00:00.000000000 +0100
+++ tcl8.4.3-lrepeat/tests/lrepeat.test 2003-05-30 07:57:56.000000000 +0100
@@ -0,0 +1,39 @@
+# Commands covered: list
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1991-1993 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: list.test,v 1.5.24.1 2003/03/27 13:11:15 dkf Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import -force ::tcltest::*
+}
+
+## Arg errors
+# 0 args - error
+test lrepeat-1.1 {arg errors} -body {lrepeat} -returnCodes {1} -result {wrong # args: should be "lrepeat <number> <init-object>"}
+# 1 args - error
+test lrepeat-1.2 {arg errors} -body {lrepeat 1} -returnCodes {1} -result {wrong # args: should be "lrepeat <number> <init-object>"}
+# 2 args: 1st arg not an integer - error
+test lrepeat-1.3 {arg errors} -body {lrepeat a 1} -returnCodes {1} -result {expected integer but got "a"}
+# 2 args: 1st arg a negative number
+test lrepeat-1.4 {arg tests} -body {lrepeat -3 1} -returnCodes {1} -result {wrong # args: should be "lrepeat <positive-integer> <init-object>"}
+# 2 args: 1st arg 0 - error
+test lrepeat-1.5 {arg tests} -body {lrepeat 0} -returnCodes {1} -result {wrong # args: should be "lrepeat <number> <init-object>"}
+
+## Okay
+test lrepeat-2.1 {basic tests} {lrepeat 10 a} {a a a a a a a a a a}
+test lrepeat-2.2 {basic tests} {lrepeat 3 [lrepeat 3 0]} {{0 0 0} {0 0 0} {0 0 0}}
+
+# cleanup
+::tcltest::cleanupTests
+return
