diff options
Diffstat (limited to 'generic/tclObj.c')
| -rw-r--r-- | generic/tclObj.c | 424 |
1 files changed, 417 insertions, 7 deletions
diff --git a/generic/tclObj.c b/generic/tclObj.c index c895237..c5f7f12 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclObj.c,v 1.28 2002/01/25 21:36:09 dgp Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.29 2002/02/15 14:28:49 dkf Exp $ */ #include "tclInt.h" @@ -63,6 +63,11 @@ static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr)); static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr)); static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr)); +#ifndef TCL_WIDE_INT_IS_LONG +static int SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr)); +#endif /* * Prototypes for the array hash key methods. @@ -121,6 +126,16 @@ Tcl_ObjType tclIntType = { SetIntFromAny /* setFromAnyProc */ }; +#ifndef TCL_WIDE_INT_IS_LONG +Tcl_ObjType tclWideIntType = { + "wideInt", /* name */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ + UpdateStringOfWideInt, /* updateStringProc */ + SetWideIntFromAny /* setFromAnyProc */ +}; +#endif + /* * The structure below defines the Tcl obj hash key type. */ @@ -218,6 +233,9 @@ TclInitObjSubsystem() Tcl_RegisterObjType(&tclDoubleType); Tcl_RegisterObjType(&tclEndOffsetType); Tcl_RegisterObjType(&tclIntType); +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_RegisterObjType(&tclWideIntType); +#endif Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclByteCodeType); @@ -826,11 +844,11 @@ Tcl_GetString(objPtr) char * Tcl_GetStringFromObj(objPtr, lengthPtr) - register Tcl_Obj *objPtr; /* Object whose string rep byte pointer - * should be returned. */ - register int *lengthPtr; /* If non-NULL, the location where the - * string rep's byte array length should be - * stored. If NULL, no length is stored. */ + register Tcl_Obj *objPtr; /* Object whose string rep byte pointer should + * be returned. */ + register int *lengthPtr; /* If non-NULL, the location where the string + * rep's byte array length should * be stored. + * If NULL, no length is stored. */ { if (objPtr->bytes == NULL) { if (objPtr->typePtr->updateStringProc == NULL) { @@ -1092,7 +1110,6 @@ SetBooleanFromAny(interp, objPtr) char lowerCase[10]; int newBool, length; register int i; - double dbl; /* * Get the string representation. Make it up-to-date if necessary. @@ -1148,6 +1165,24 @@ SetBooleanFromAny(interp, objPtr) goto badBoolean; } } else { + double dbl; +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_WideInt wide = strtoll(string, &end, 0); + if (end != string) { + /* + * Make sure the string has no garbage after the end of + * the wide int. + */ + while ((end < (string+length)) + && isspace(UCHAR(*end))) { /* INTL: ISO only */ + end++; + } + if (end == (string+length)) { + newBool = (wide != Tcl_LongAsWide(0)); + goto goodBoolean; + } + } +#endif /* * Still might be a string containing the characters representing an * int or double that wasn't handled above. This would be a string @@ -1182,6 +1217,7 @@ SetBooleanFromAny(interp, objPtr) * Tcl_GetStringFromObj, to use that old internalRep. */ + goodBoolean: if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { oldTypePtr->freeIntRepProc(objPtr); } @@ -2060,6 +2096,380 @@ Tcl_GetLongFromObj(interp, objPtr, longPtr) /* *---------------------------------------------------------------------- * + * SetWideIntFromAny -- + * + * Attempt to generate an integer internal form for the Tcl object + * "objPtr". + * + * Results: + * The return value is a standard object Tcl result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If no error occurs, an int is stored as "objPtr"s internal + * representation. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_WIDE_INT_IS_LONG +static int +SetWideIntFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + char *string, *end; + int length; + register char *p; + Tcl_WideInt newWide; + + /* + * Get the string representation. Make it up-to-date if necessary. + */ + + string = Tcl_GetStringFromObj(objPtr, &length); + + /* + * Now parse "objPtr"s string as an int. We use an implementation here + * that doesn't report errors in interp if interp is NULL. Note: use + * strtoull instead of strtoll for integer conversions to allow full-size + * unsigned numbers, but don't depend on strtoull to handle sign + * characters; it won't in some implementations. + */ + + errno = 0; + for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */ + /* Empty loop body. */ + } + if (*p == '-') { + p++; + newWide = -((Tcl_WideInt)strtoull(p, &end, 0)); + } else if (*p == '+') { + p++; + newWide = strtoull(p, &end, 0); + } else { + newWide = strtoull(p, &end, 0); + } + if (end == p) { + badInteger: + if (interp != NULL) { + /* + * Must copy string before resetting the result in case a caller + * is trying to convert the interpreter's result to an int. + */ + + char buf[100]; + sprintf(buf, "expected integer but got \"%.50s\"", string); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + TclCheckBadOctal(interp, string); + } + return TCL_ERROR; + } + if (errno == ERANGE) { + if (interp != NULL) { + char *s = "integer value too large to represent"; + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); + } + return TCL_ERROR; + } + + /* + * Make sure that the string has no garbage after the end of the int. + */ + + while ((end < (string+length)) + && isspace(UCHAR(*end))) { /* INTL: ISO space. */ + end++; + } + if (end != (string+length)) { + goto badInteger; + } + + /* + * The conversion to int succeeded. Free the old internalRep before + * setting the new one. We do this as late as possible to allow the + * conversion code, in particular Tcl_GetStringFromObj, to use that old + * internalRep. + */ + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.wideValue = newWide; + objPtr->typePtr = &tclWideIntType; + return TCL_OK; +} +#endif + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfWideInt -- + * + * Update the string representation for a wide integer object. + * Note: This procedure does not free an existing old string rep + * so storage will be lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a valid string that results from + * the wideInt-to-string conversion. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_WIDE_INT_IS_LONG +static void +UpdateStringOfWideInt(objPtr) + register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ +{ + char buffer[TCL_INTEGER_SPACE+2]; + register unsigned len; + register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; + + sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); + len = strlen(buffer); + objPtr->bytes = ckalloc((unsigned) len + 1); + memcpy(objPtr->bytes, buffer, len + 1); + objPtr->length = len; +} +#endif /* TCL_WIDE_INT_IS_LONG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewWideIntObj -- + * + * If a client is compiled with TCL_MEM_DEBUG defined, calls to + * Tcl_NewWideIntObj to create a new 64-bit integer object end up calling + * the debugging procedure Tcl_DbNewWideIntObj instead. + * + * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, + * calls to Tcl_NewWideIntObj result in a call to one of the two + * Tcl_NewWideIntObj implementations below. We provide two implementations + * so that the Tcl core can be compiled to do memory debugging of the + * core even if a client does not request it for itself. + * + * Results: + * The newly created object is returned. This object will have an + * invalid string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewWideIntObj + +Tcl_Obj * +Tcl_NewWideIntObj(wideValue) + register Tcl_WideInt wideValue; /* Wide integer used to initialize + * the new object. */ +{ + return Tcl_DbNewWideIntObj(wideValue, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewWideIntObj(wideValue) + register Tcl_WideInt wideValue; /* Wide integer used to initialize + * the new object. */ +{ +#ifdef TCL_WIDE_INT_IS_LONG + return Tcl_NewLongObj(wideValue); +#else + register Tcl_Obj *objPtr; + + TclNewObj(objPtr); + objPtr->bytes = NULL; + + objPtr->internalRep.wideValue = wideValue; + objPtr->typePtr = &tclWideIntType; + return objPtr; +#endif /* TCL_WIDE_INT_IS_LONG */ +} +#endif /* if TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewWideIntObj -- + * + * If a client is compiled with TCL_MEM_DEBUG defined, calls to + * Tcl_NewWideIntObj to create new wide integer end up calling + * the debugging procedure Tcl_DbNewWideIntObj instead. We + * provide two implementations of Tcl_DbNewWideIntObj so that + * whether the Tcl core is compiled to do memory debugging of the + * core is independent of whether a client requests debugging for + * itself. + * + * When the core is compiled with TCL_MEM_DEBUG defined, + * Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file + * name and line number from its caller. This simplifies + * debugging since then the checkmem command will report the + * caller's file name and line number when reporting objects that + * haven't been freed. + * + * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, + * this procedure just returns the result of calling Tcl_NewWideIntObj. + * + * Results: + * The newly created wide integer object is returned. This object + * will have an invalid string representation. The returned object has + * ref count 0. + * + * Side effects: + * Allocates memory. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_DbNewWideIntObj(wideValue, file, line) + register Tcl_WideInt wideValue; /* Wide integer used to initialize + * the new object. */ + CONST char *file; /* The name of the source file + * calling this procedure; used for + * debugging. */ + int line; /* Line number in the source file; + * used for debugging. */ +{ +#ifdef TCL_WIDE_INT_IS_LONG + return Tcl_DbNewLongObj(wideValue, file, line); +#else + register Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + objPtr->bytes = NULL; + + objPtr->internalRep.wideValue = wideValue; + objPtr->typePtr = &tclWideIntType; + return objPtr; +#endif +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewWideIntObj(wideValue, file, line) + register Tcl_WideInt wideValue; /* Long integer used to initialize + * the new object. */ + CONST char *file; /* The name of the source file + * calling this procedure; used for + * debugging. */ + int line; /* Line number in the source file; + * used for debugging. */ +{ + return Tcl_NewWideIntObj(wideValue); +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetWideIntObj -- + * + * Modify an object to be a wide integer object and to have the + * specified wide integer value. + * + * Results: + * None. + * + * Side effects: + * The object's old string rep, if any, is freed. Also, any old + * internal rep is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetWideIntObj(objPtr, wideValue) + register Tcl_Obj *objPtr; /* Object w. internal rep to init. */ + register Tcl_WideInt wideValue; /* Wide integer used to initialize + * the object's value. */ +{ +#ifdef TCL_WIDE_INT_IS_LONG + Tcl_SetLongObj(objPtr, wideValue); +#else + register Tcl_ObjType *oldTypePtr = objPtr->typePtr; + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_SetWideIntObj called with shared object"); + } + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.wideValue = wideValue; + objPtr->typePtr = &tclWideIntType; + Tcl_InvalidateStringRep(objPtr); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetWideIntFromObj -- + * + * Attempt to return a wide integer from the Tcl object "objPtr". If + * the object is not already a wide int object, an attempt will be made + * to convert it to one. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If the object is not already an int object, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* Object from which to get a wide int. */ + register Tcl_WideInt *wideIntPtr; /* Place to store resulting long. */ +{ +#ifdef TCL_WIDE_INT_IS_LONG + /* + * Next line is type-safe because we only do this when long = Tcl_WideInt + */ + return Tcl_GetLongFromObj(interp, objPtr, wideIntPtr); +#else + register int result; + + if (objPtr->typePtr == &tclWideIntType) { + *wideIntPtr = objPtr->internalRep.wideValue; + return TCL_OK; + } + result = SetWideIntFromAny(interp, objPtr); + if (result == TCL_OK) { + *wideIntPtr = objPtr->internalRep.wideValue; + } + return result; +#endif +} + +/* + *---------------------------------------------------------------------- + * * Tcl_DbIncrRefCount -- * * This procedure is normally called when debugging: i.e., when |