diff options
Diffstat (limited to 'generic/tclUtil.c')
| -rw-r--r-- | generic/tclUtil.c | 197 |
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; -} +} /* *---------------------------------------------------------------------- |