summaryrefslogtreecommitdiffstats
path: root/generic/tclUtil.c
diff options
context:
space:
mode:
authorhobbs <hobbs>2001-11-14 23:17:02 (GMT)
committerhobbs <hobbs>2001-11-14 23:17:02 (GMT)
commit03bf512eba9ec5dde914e6b2cb171b35cf297b08 (patch)
treee2099b7a9dc4bb4dc572f484ee86baf5db2c28ae /generic/tclUtil.c
parent6b5ff76e865f488dd08efe0bd2a280b7ceda4543 (diff)
downloadtcl-03bf512eba9ec5dde914e6b2cb171b35cf297b08.zip
tcl-03bf512eba9ec5dde914e6b2cb171b35cf297b08.tar.gz
tcl-03bf512eba9ec5dde914e6b2cb171b35cf297b08.tar.bz2
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)
Diffstat (limited to 'generic/tclUtil.c')
-rw-r--r--generic/tclUtil.c197
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;
-}
+}
/*
*----------------------------------------------------------------------