Reference implementation of TIP's #22, #33 and #45. Adds the

	ability of the [lindex] command to have multiple index arguments,
	and adds the [lset] command.  Both commands are byte-code compiled.
	[Patch #471874] (work by Kenny, commited by Hobbs)

1 files changed, 182 insertions, 15 deletions

diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 0eca255..19f4850 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -6,11 +6,12 @@
  *
  * Copyright (c) 1987-1993 The Regents of the University of California.
  * Copyright (c) 1994-1998 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: tclUtil.c,v 1.24 2001/09/24 21:10:32 dgp Exp $
+ *  RCS: @(#) $Id: tclUtil.c,v 1.25 2001/11/14 23:17:04 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -62,6 +63,30 @@ static char precisionFormat[10] = "%.12g";
 				 * to sprintf. */
 TCL_DECLARE_MUTEX(precisionMutex)
 
+/*
+ * Prototypes for procedures defined later in this file.
+ */
+
+static void UpdateStringOfEndOffset _ANSI_ARGS_(( Tcl_Obj* objPtr ));
+static int SetEndOffsetFromAny _ANSI_ARGS_(( Tcl_Interp* interp,
+					     Tcl_Obj* objPtr ));
+
+/*
+ * The following is the Tcl object type definition for an object
+ * that represents a list index in the form, "end-offset".  It is
+ * used as a performance optimization in TclGetIntForIndex.  The
+ * internal rep is an integer, so no memory management is required
+ * for it.
+ */
+
+Tcl_ObjType tclEndOffsetType = {
+    "end-offset",			/* name */
+    (Tcl_FreeInternalRepProc*) NULL,    /* freeIntRepProc */
+    (Tcl_DupInternalRepProc*) NULL,     /* dupIntRepProc */
+    UpdateStringOfEndOffset,		/* updateStringProc */
+    SetEndOffsetFromAny    
+};
+
 
 /*
  *----------------------------------------------------------------------
@@ -2160,45 +2185,187 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr)
     char *bytes;
     int length, offset;
 
+    /* If the object is already an integer, use it. */
+
     if (objPtr->typePtr == &tclIntType) {
 	*indexPtr = (int)objPtr->internalRep.longValue;
 	return TCL_OK;
     }
 
-    bytes = Tcl_GetStringFromObj(objPtr, &length);
+    if ( SetEndOffsetFromAny( NULL, objPtr ) == TCL_OK ) {
+
+	/*
+	 * If the object is already an offset from the end of the list, or
+	 * can be converted to one, use it.
+	 */
+
+	*indexPtr = endValue + objPtr->internalRep.longValue;
+
+    } else if ( Tcl_GetIntFromObj( NULL, objPtr, &offset ) == TCL_OK ) {
+
+	/*
+	 * If the object can be converted to an integer, use that.
+	 */
+
+	*indexPtr = offset;
+
+    } else {
+
+	/*
+	 * Report a parse error.
+	 */
+
+	if ((Interp *)interp != NULL) {
+	    bytes = Tcl_GetStringFromObj( objPtr, &length );
+	    Tcl_AppendStringsToObj( Tcl_GetObjResult(interp),
+				    "bad index \"", bytes,
+				    "\": must be integer or end?-integer?",
+				    (char *) NULL);
+	    if ( !strncmp ( bytes, "end-", 3 ) ) {
+		bytes += 3;
+	    }
+	    TclCheckBadOctal(interp, bytes);
+	}
+
+	return TCL_ERROR;
+    }
+	    
+    return TCL_OK;
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfEndOffset --
+ *
+ *	Update the string rep of a Tcl object holding an "end-offset"
+ *	expression.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Stores a valid string in the object's string rep.
+ *
+ * This procedure does NOT free any earlier string rep.  If it is
+ * called on an object that already has a valid string rep, it will
+ * leak memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+UpdateStringOfEndOffset( objPtr )
+    register Tcl_Obj* objPtr;
+{
+    char buffer[ TCL_INTEGER_SPACE + sizeof("end") + 1 ];
+    register int len;
+
+    strcpy( buffer, "end" );
+    len = sizeof( "end" ) - 1;
+    if ( objPtr->internalRep.longValue != 0 ) {
+	buffer[len++] = '-';
+	len += TclFormatInt( buffer + len,
+			     -( objPtr->internalRep.longValue ) );
+    }
+    objPtr->bytes = ckalloc( (unsigned) ( len + 1 ) );
+    strcpy( objPtr->bytes, buffer );
+    objPtr->length = len;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetEndOffsetFromAny --
+ *
+ *	Look for a string of the form "end-offset" and convert it
+ *	to an internal representation holding the offset.
+ *
+ * Results:
+ *	Returns TCL_OK if ok, TCL_ERROR if the string was badly formed.
+ *
+ * Side effects:
+ *	If interp is not NULL, stores an error message in the
+ *	interpreter result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetEndOffsetFromAny( Tcl_Interp* interp,
+				/* Tcl interpreter or NULL */
+		     Tcl_Obj* objPtr )
+				/* Pointer to the object to parse */
+{
+    int offset;			/* Offset in the "end-offset" expression */
+    Tcl_ObjType* oldTypePtr = objPtr->typePtr;
+				/* Old internal rep type of the object */
+    register char* bytes;	/* String rep of the object */
+    int length;			/* Length of the object's string rep */
 
+    /* If it's already the right type, we're fine. */
+
+    if ( objPtr->typePtr == &tclEndOffsetType ) {
+	return TCL_OK;
+    }
+
+    /* Check for a string rep of the right form. */
+
+    bytes = Tcl_GetStringFromObj(objPtr, &length);
     if ((*bytes != 'e') || (strncmp(bytes, "end",
 	    (size_t)((length > 3) ? 3 : length)) != 0)) {
-	if (Tcl_GetIntFromObj(NULL, objPtr, &offset) != TCL_OK) {
-	    goto intforindex_error;
+	if ( interp != NULL ) {
+	    Tcl_AppendStringsToObj( Tcl_GetObjResult( interp ),
+				    "bad index \"", bytes,
+				    "\": must be end?-integer?",
+				    (char*) NULL );
 	}
-	*indexPtr = offset;
-	return TCL_OK;
+	return TCL_ERROR;
     }
 
+    /* Convert the string rep */
+
     if (length <= 3) {
-	*indexPtr = endValue;
+	offset = 0;
     } else if (bytes[3] == '-') {
+
 	/*
 	 * This is our limited string expression evaluator
 	 */
 	if (Tcl_GetInt(interp, bytes+3, &offset) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	*indexPtr = endValue + offset;
+
     } else {
-	intforindex_error:
-	if ((Interp *)interp != NULL) {
-	    Tcl_ResetResult(interp);
+
+	/* Conversion failed.  Report the error. */
+
+
+	if ( interp != NULL ) {
 	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
-		    "bad index \"", bytes,
-		    "\": must be integer or end?-integer?", (char *) NULL);
-	    TclCheckBadOctal(interp, bytes);
+				   "bad index \"", bytes,
+				   "\": must be integer or end?-integer?",
+				   (char *) NULL);
 	}
 	return TCL_ERROR;
+
     }
+
+    /*
+     * The conversion succeeded. Free the old internal rep and set
+     * the new one.
+     */
+
+    if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
+	oldTypePtr->freeIntRepProc(objPtr);
+    }
+    
+    objPtr->internalRep.longValue = offset;
+    objPtr->typePtr = &tclEndOffsetType;
+
     return TCL_OK;
-}
+}    
 
 /*
  *----------------------------------------------------------------------