Tcl Source Code

Artifact e2ee307bd844c965d27ec4e93700608ca347b1ac:

Index: generic/tclInt.decls
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.decls,v
retrieving revision 1.91
diff -u -r1.91 tclInt.decls
--- generic/tclInt.decls	21 Jul 2005 21:50:47 -0000	1.91
+++ generic/tclInt.decls	1 Aug 2005 22:29:28 -0000
@@ -903,6 +903,11 @@
 	    int keyc, Tcl_Obj *CONST keyv[], int flags)
 }
 
+# access to the basic increment engine
+declare 226 generic {
+    int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr)
+}
+
 ##############################################################################
 
 # Define the platform specific internal Tcl interface. These functions are
Index: generic/tclObj.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclObj.c,v
retrieving revision 1.88
diff -u -r1.88 tclObj.c
--- generic/tclObj.c	17 Jul 2005 21:17:44 -0000	1.88
+++ generic/tclObj.c	1 Aug 2005 22:28:18 -0000
@@ -2810,6 +2810,101 @@
 /*
  *----------------------------------------------------------------------
  *
+ * TclIncrObj --
+ *
+ *	Increment a numeric value in a Tcl_Obj by the numeric value held in
+ *	another Tcl_Obj. Tricky because of type promotions. Caller is
+ *	responsible for making sure we can update the first object.
+ *
+ * Results:
+ *	TCL_ERROR if either object is non-numeric, and TCL_OK otherwise. On
+ *	error, an error message is left in the interpreter (if it is not NULL,
+ *	of course).
+ *
+ * Side effects:
+ *	valuePtr will no longer have a string rep, and incrPtr may gain either
+ *	an int or a wide-int rep.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclIncrObj(
+    Tcl_Interp *interp,		/* Interpreter for error messages, or NULL. */
+    Tcl_Obj *valuePtr,		/* Unshared numeric value to increment. */
+    Tcl_Obj *incrPtr)		/* Value to increment by. */
+{
+    long lValue, incrValue;
+    Tcl_WideInt wValue, wideIncrValue;
+    int isWide = 0, result;
+
+    if (Tcl_IsShared(valuePtr)) {
+	Tcl_Panic("shared object passed to TclIncrObj");
+    }
+
+    if (incrPtr->typePtr == &tclIntType) {
+	incrValue = incrPtr->internalRep.longValue;
+    } else if (incrPtr->typePtr == &tclWideIntType) {
+	wideIncrValue = incrPtr->internalRep.wideValue;
+	isWide = 1;
+    } else {
+	result = Tcl_GetWideIntFromObj(interp, incrPtr, &wideIncrValue);
+	if (result != TCL_OK) {
+	    return result;
+	}
+	if (wideIncrValue <= Tcl_LongAsWide(LONG_MAX)
+		&& wideIncrValue >= Tcl_LongAsWide(LONG_MIN)) {
+	    incrValue = Tcl_WideAsLong(wideIncrValue);
+	    incrPtr->typePtr = &tclIntType;
+	} else {
+	    isWide = 1;
+	}
+    }
+
+    if (valuePtr->typePtr == &tclWideIntType) {
+	Tcl_GetWideIntFromObj(NULL, valuePtr, &wValue);
+	if (isWide) {
+	    Tcl_SetWideIntObj(valuePtr, wValue + wideIncrValue);
+	} else {
+	    Tcl_SetWideIntObj(valuePtr, wValue + incrValue);
+	}
+    } else if (valuePtr->typePtr == &tclIntType) {
+	Tcl_GetLongFromObj(NULL, valuePtr, &lValue);
+	if (isWide) {
+	    Tcl_SetWideIntObj(valuePtr, lValue + wideIncrValue);
+	} else {
+	    Tcl_SetLongObj(valuePtr, lValue + incrValue);
+	}
+    } else {
+	/*
+	 * Note that these operations on wide ints should work fine where they
+	 * are the same as normal longs, though the compiler might complain
+	 * about trivially satisifed tests.
+	 */
+
+	result = Tcl_GetWideIntFromObj(interp, valuePtr, &wValue);
+	if (result != TCL_OK) {
+	    return result;
+	}
+
+	/*
+	 * Determine if we should have got a standard long instead.
+	 */
+
+	if (isWide) {
+	    Tcl_SetWideIntObj(valuePtr, wValue + wideIncrValue);
+	} else if (wValue >= LONG_MIN && wValue <= LONG_MAX) {
+	    Tcl_SetLongObj(valuePtr, Tcl_WideAsLong(wValue) + incrValue);
+	} else {
+	    Tcl_SetWideIntObj(valuePtr, wValue + incrValue);
+	}
+    }
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * FreeBignum --
  *
  *	This procedure frees the internal rep of a bignum.