merge 8.7

1 files changed, 491 insertions, 16 deletions

diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index cdc302c..4d478eb 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -19,6 +19,8 @@
 
 #include "tclInt.h"
 #include "tclRegexp.h"
+#include "tclArithSeries.h"
+#include <math.h>
 #include <assert.h>
 
 /*
@@ -95,6 +97,23 @@ typedef struct {
 #define SORTMODE_ASCII_NC	8
 
 /*
+ * Definitions for [lseq] command
+ */
+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;
+
+/*
  * Forward declarations for procedures defined in this file:
  */
 
@@ -2182,7 +2201,7 @@ Tcl_JoinObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* The argument objects. */
 {
-    int length, listLen;
+    int length, listLen, isArithSeries = 0;
     Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs;
 
     if ((objc < 2) || (objc > 3)) {
@@ -2195,9 +2214,14 @@ Tcl_JoinObjCmd(
      * pointer to its array of element pointers.
      */
 
-    if (TclListObjGetElementsM(interp, objv[1], &listLen,
+    if (TclHasInternalRep(objv[1],&tclArithSeriesType)) {
+	isArithSeries = 1;
+	listLen = TclArithSeriesObjLength(objv[1]);
+    } else {
+	if (TclListObjGetElementsM(interp, objv[1], &listLen,
 	    &elemPtrs) != TCL_OK) {
-	return TCL_ERROR;
+	    return TCL_ERROR;
+	}
     }
 
     if (listLen == 0) {
@@ -2206,7 +2230,15 @@ Tcl_JoinObjCmd(
     }
     if (listLen == 1) {
 	/* One element; return it */
-	Tcl_SetObjResult(interp, elemPtrs[0]);
+	if (isArithSeries) {
+	    Tcl_Obj *valueObj;
+	    if (TclArithSeriesObjIndex(objv[1], 0, &valueObj) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    Tcl_SetObjResult(interp, valueObj);
+	} else {
+	    Tcl_SetObjResult(interp, elemPtrs[0]);
+	}
 	return TCL_OK;
     }
 
@@ -2220,19 +2252,41 @@ Tcl_JoinObjCmd(
 	int i;
 
 	TclNewObj(resObjPtr);
-	for (i = 0;  i < listLen;  i++) {
-	    if (i > 0) {
+	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);
+		}
+		if (TclArithSeriesObjIndex(objv[1], i, &valueObj) != TCL_OK) {
+		    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.
-		 */
+		    /*
+		     * 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, joinObjPtr);
+		}
+		Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]);
 	    }
-	    Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]);
 	}
     }
     Tcl_DecrRefCount(joinObjPtr);
@@ -2689,7 +2743,11 @@ Tcl_LrangeObjCmd(
 	return result;
     }
 
-    Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last));
+    if (TclHasInternalRep(objv[1],&tclArithSeriesType)) {
+	Tcl_SetObjResult(interp, TclArithSeriesObjRange(objv[1], first, last));
+    } else {
+	Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last));
+    }
     return TCL_OK;
 }
 
@@ -3073,6 +3131,17 @@ Tcl_LreverseObjCmd(
 	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_SetObjResult(interp, TclArithSeriesObjReverse(objv[1]));
+	return TCL_OK;
+    } /* end ArithSeries */
+
+    /* True List */
     if (TclListObjGetElementsM(interp, objv[1], &elemc, &elemv) != TCL_OK) {
 	return TCL_ERROR;
     }
@@ -3973,6 +4042,407 @@ Tcl_LsetObjCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * 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;
+    union {
+	Tcl_WideInt i;
+	double d;
+    } nvalue;
+
+    status = Tcl_GetNumberFromObj(NULL, argPtr, (ClientData*)&nvalue, 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) {
+		    exprValueObj = Tcl_NewWideIntObj(value);
+		    keyword = TCL_NUMBER_INT;
+		} else {
+		    exprValueObj = Tcl_NewDoubleObj(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(ClientData),
+    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;
+
+/*    range n */
+    case 1:
+	start = zero;
+	elementCount = numValues[0];
+	end = NULL;
+	step = one;
+	break;
+
+/*    range n n */
+    case 11:
+	start = numValues[0];
+	end = numValues[1];
+	break;
+
+/*    range n n n */
+    case 111:
+	start = numValues[0];
+	end = numValues[1];
+	step = numValues[2];
+	break;
+
+/*    range n 'to' n    */
+/*    range n 'count' n */
+/*    range 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;
+
+/*    range n 'to' n n    */
+/*    range 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;
+
+/*    range 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;
+
+/*    range n 'to' n 'by' n    */
+/*    range 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.
+     */
+    arithSeriesPtr = TclNewArithSeriesObj(useDoubles, start, end, step, elementCount);
+
+    Tcl_SetObjResult(interp, arithSeriesPtr);
+    status = TCL_OK;
+
+ 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_LsortObjCmd --
  *
  *	This procedure is invoked to process the "lsort" Tcl command. See the
@@ -4238,8 +4708,13 @@ Tcl_LsortObjCmd(
 	sortInfo.compareCmdPtr = newCommandPtr;
     }
 
-    sortInfo.resultCode = TclListObjGetElementsM(interp, listObj,
+    if (TclHasInternalRep(listObj,&tclArithSeriesType)) {
+	sortInfo.resultCode = TclArithSeriesGetElements(interp,
+	    listObj, &length, &listObjPtrs);
+    } else {
+	sortInfo.resultCode = TclListObjGetElementsM(interp, listObj,
 	    &length, &listObjPtrs);
+    }
     if (sortInfo.resultCode != TCL_OK || length <= 0) {
 	goto done;
     }