diff options
author | dgp <dgp@users.sourceforge.net> | 2006-10-31 20:19:43 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2006-10-31 20:19:43 (GMT) |
commit | ce16019300e66b466f8ad327c5b3a03fe6876f8e (patch) | |
tree | 75652e34b31819c0360f9598db333054faffde99 /generic | |
parent | 20c1156972864f916da62a217137e346eb93ac79 (diff) | |
download | tcl-ce16019300e66b466f8ad327c5b3a03fe6876f8e.zip tcl-ce16019300e66b466f8ad327c5b3a03fe6876f8e.tar.gz tcl-ce16019300e66b466f8ad327c5b3a03fe6876f8e.tar.bz2 |
* generic/tclBasic.c: Refactored and renamed the routines
* generic/tclCkalloc.c: TclObjPrintf, TclFormatObj, and
* generic/tclCmdAH.c: TclFormatToErrorInfo to a new set of
* generic/tclCmdIL.c: routines TclAppendPrintfToObj,
* generic/tclCmdMZ.c: TclAppendFormatToObj, TclObjPrintf, and
* generic/tclDictObj.c: TclObjFormat, with the intent of making
* generic/tclExecute.c: the latter list, plus TclAppendLimitedToObj
* generic/tclIORChan.c: and TclAppendObjToErrorInfo, public via
* generic/tclIOUtil.c: a revised TIP 270.
* generic/tclInt.h:
* generic/tclMain.c:
* generic/tclNamesp.c:
* generic/tclParseExpr.c:
* generic/tclPkg.c:
* generic/tclProc.c:
* generic/tclStringObj.c:
* generic/tclTimer.c:
* generic/tclUtil.c:
* unix/tclUnixFCmd.c:
Diffstat (limited to 'generic')
-rw-r--r-- | generic/tclBasic.c | 19 | ||||
-rw-r--r-- | generic/tclCkalloc.c | 9 | ||||
-rw-r--r-- | generic/tclCmdAH.c | 23 | ||||
-rw-r--r-- | generic/tclCmdIL.c | 10 | ||||
-rw-r--r-- | generic/tclCmdMZ.c | 17 | ||||
-rw-r--r-- | generic/tclDictObj.c | 10 | ||||
-rw-r--r-- | generic/tclExecute.c | 11 | ||||
-rw-r--r-- | generic/tclIORChan.c | 23 | ||||
-rw-r--r-- | generic/tclIOUtil.c | 7 | ||||
-rw-r--r-- | generic/tclInt.h | 16 | ||||
-rw-r--r-- | generic/tclMain.c | 5 | ||||
-rw-r--r-- | generic/tclNamesp.c | 24 | ||||
-rw-r--r-- | generic/tclParseExpr.c | 45 | ||||
-rw-r--r-- | generic/tclPkg.c | 6 | ||||
-rw-r--r-- | generic/tclProc.c | 43 | ||||
-rw-r--r-- | generic/tclStringObj.c | 85 | ||||
-rw-r--r-- | generic/tclTimer.c | 10 | ||||
-rw-r--r-- | generic/tclUtil.c | 14 |
18 files changed, 187 insertions, 190 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 2be44d3..2ef6a8d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.208 2006/10/31 15:23:41 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.209 2006/10/31 20:19:44 dgp Exp $ */ #include "tclInt.h" @@ -3765,8 +3765,8 @@ Tcl_EvalEx( * Attempt to expand a non-list. */ - TclFormatToErrorInfo(interp, - "\n (expanding word %d)", objectsUsed); + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, + "\n (expanding word %d)", objectsUsed)); Tcl_DecrRefCount(objv[objectsUsed]); goto error; } @@ -4156,10 +4156,8 @@ ProcessUnexpectedResult( Tcl_AppendResult(interp, "invoked \"continue\" outside of a loop", NULL); } else { - Tcl_Obj *objPtr = Tcl_NewObj(); - TclObjPrintf(NULL, objPtr, "command returned bad code: %d", - returnCode); - Tcl_SetObjResult(interp, objPtr); + Tcl_SetObjResult(interp, TclObjPrintf(NULL, + "command returned bad code: %d", returnCode)); } } @@ -5777,7 +5775,6 @@ MathFuncWrongNumArgs( int found, /* Actual parameter count */ Tcl_Obj *CONST *objv) /* Actual parameter vector */ { - Tcl_Obj *errorMessage; CONST char *name = Tcl_GetString(objv[0]); CONST char *tail = name + strlen(name); @@ -5788,11 +5785,9 @@ MathFuncWrongNumArgs( break; } } - TclNewObj(errorMessage); - TclObjPrintf(NULL, errorMessage, + Tcl_SetObjResult(interp, TclObjPrintf(NULL, "too %s arguments for math function \"%s\"", - (found < expected ? "few" : "many"), name); - Tcl_SetObjResult(interp, errorMessage); + (found < expected ? "few" : "many"), name)); } /* diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index d04b45a..ee7419c 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -14,7 +14,7 @@ * * This code contributed by Karl Lehenbauer and Mark Diekhans * - * RCS: @(#) $Id: tclCkalloc.c,v 1.26 2005/11/01 15:30:52 dkf Exp $ + * RCS: @(#) $Id: tclCkalloc.c,v 1.27 2006/10/31 20:19:44 dgp Exp $ */ #include "tclInt.h" @@ -842,14 +842,13 @@ MemoryCmd( return TCL_OK; } if (strcmp(argv[1],"info") == 0) { - Tcl_Obj *objPtr = Tcl_NewObj(); - TclObjPrintf(NULL, objPtr, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n", + Tcl_SetObjResult(interp, TclObjPrintf(NULL, + "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n", "total mallocs", total_mallocs, "total frees", total_frees, "current packets allocated", current_malloc_packets, "current bytes allocated", current_bytes_malloced, "maximum packets allocated", maximum_malloc_packets, - "maximum bytes allocated", maximum_bytes_malloced); - Tcl_SetObjResult(interp, objPtr); + "maximum bytes allocated", maximum_bytes_malloced)); return TCL_OK; } if (strcmp(argv[1],"init") == 0) { diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index f2c49cb..07164d9 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.75 2006/08/10 12:15:30 dkf Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.76 2006/10/31 20:19:44 dgp Exp $ */ #include "tclInt.h" @@ -188,8 +188,9 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) armPtr = caseObjv[body - 1]; result = Tcl_EvalObjEx(interp, caseObjv[body], 0); if (result == TCL_ERROR) { - TclFormatToErrorInfo(interp, "\n (\"%.50s\" arm line %d)", - TclGetString(armPtr), interp->errorLine); + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, + "\n (\"%.50s\" arm line %d)", + TclGetString(armPtr), interp->errorLine)); } return result; } @@ -250,8 +251,8 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) */ if (Tcl_LimitExceeded(interp)) { - TclFormatToErrorInfo(interp, "\n (\"catch\" body line %d)", - interp->errorLine); + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, + "\n (\"catch\" body line %d)", interp->errorLine)); return TCL_ERROR; } @@ -659,8 +660,8 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv) result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); } if (result == TCL_ERROR) { - TclFormatToErrorInfo(interp,"\n (\"eval\" body line %d)", - interp->errorLine); + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, + "\n (\"eval\" body line %d)", interp->errorLine)); } return result; } @@ -1611,8 +1612,8 @@ Tcl_ForObjCmd(dummy, interp, objc, objv) result = Tcl_EvalObjEx(interp, objv[4], 0); if ((result != TCL_OK) && (result != TCL_CONTINUE)) { if (result == TCL_ERROR) { - TclFormatToErrorInfo(interp, "\n (\"for\" body line %d)", - interp->errorLine); + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, + "\n (\"for\" body line %d)", interp->errorLine)); } break; } @@ -1821,8 +1822,8 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) result = TCL_OK; break; } else if (result == TCL_ERROR) { - TclFormatToErrorInfo(interp, - "\n (\"foreach\" body line %d)", interp->errorLine); + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, + "\n (\"foreach\" body line %d)", interp->errorLine)); break; } else { break; diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 8bf2dd3..ba10ca0 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.90 2006/10/23 21:36:54 msofer Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.91 2006/10/31 20:19:44 dgp Exp $ */ #include "tclInt.h" @@ -3362,8 +3362,8 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) if (sortInfo.indexc > 1) { ckfree((char *) sortInfo.indexv); } - TclFormatToErrorInfo(interp, - "\n (-index option item number %d)", j); + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, + "\n (-index option item number %d)", j)); return TCL_ERROR; } } @@ -4000,8 +4000,8 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) if (sortInfo.indexc > 1) { ckfree((char *) sortInfo.indexv); } - TclFormatToErrorInfo(interp, - "\n (-index option item number %d)", j); + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, + "\n (-index option item number %d)", j)); return TCL_ERROR; } } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index a77431c..578e977 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.135 2006/08/21 01:08:41 das Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.136 2006/10/31 20:19:45 dgp Exp $ */ #include "tclInt.h" @@ -2128,11 +2128,9 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) length2 = length1 * count; if ((length2 / count) != length1) { - resultPtr = Tcl_NewObj(); - TclObjPrintf(NULL, resultPtr, + Tcl_SetObjResult(interp, TclObjPrintf(NULL, "string size overflow, must be less than %d", - INT_MAX); - Tcl_SetObjResult(interp, resultPtr); + INT_MAX)); return TCL_ERROR; } @@ -2884,9 +2882,10 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) if (result == TCL_ERROR) { int limit = 50; int overflow = (patternLength > limit); - TclFormatToErrorInfo(interp, "\n (\"%.*s%s\" arm line %d)", + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, + "\n (\"%.*s%s\" arm line %d)", (overflow ? limit : patternLength), pattern, - (overflow ? "..." : ""), interp->errorLine); + (overflow ? "..." : ""), interp->errorLine)); } return result; } @@ -3031,8 +3030,8 @@ Tcl_WhileObjCmd(dummy, interp, objc, objv) result = Tcl_EvalObjEx(interp, objv[2], 0); if ((result != TCL_OK) && (result != TCL_CONTINUE)) { if (result == TCL_ERROR) { - TclFormatToErrorInfo(interp, "\n (\"while\" body line %d)", - interp->errorLine); + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, + "\n (\"while\" body line %d)", interp->errorLine)); } break; } diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 114d933..8efc7aa 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDictObj.c,v 1.41 2006/08/10 12:15:31 dkf Exp $ + * RCS: @(#) $Id: tclDictObj.c,v 1.42 2006/10/31 20:19:45 dgp Exp $ */ #include "tclInt.h" @@ -2229,9 +2229,9 @@ DictForCmd( if (result == TCL_BREAK) { result = TCL_OK; } else if (result == TCL_ERROR) { - TclFormatToErrorInfo(interp, + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, "\n (\"dict for\" body line %d)", - interp->errorLine); + interp->errorLine)); } break; } @@ -2575,9 +2575,9 @@ DictFilterCmd( result = TCL_OK; break; case TCL_ERROR: - TclFormatToErrorInfo(interp, + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, "\n (\"dict filter\" script line %d)", - interp->errorLine); + interp->errorLine)); default: goto abnormalResult; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b33e6b2b..d77ef69 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.247 2006/10/30 16:30:35 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.248 2006/10/31 20:19:45 dgp Exp $ */ #include "tclInt.h" @@ -6350,7 +6350,6 @@ IllegalExprOperandType( int type; unsigned char opcode = *pc; CONST char *description, *operator = operatorStrings[opcode - INST_LOR]; - Tcl_Obj *msg = Tcl_NewObj(); if (opcode == INST_EXPON) { operator = "**"; @@ -6375,9 +6374,8 @@ IllegalExprOperandType( description = "(big) integer"; } - TclObjPrintf(NULL, msg, "can't use %s as operand of \"%s\"", - description, operator); - Tcl_SetObjResult(interp, msg); + Tcl_SetObjResult(interp, TclObjPrintf(NULL, + "can't use %s as operand of \"%s\"", description, operator)); } /* @@ -6640,8 +6638,7 @@ TclExprFloatError( Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL); } } else { - Tcl_Obj *objPtr = Tcl_NewObj(); - TclObjPrintf(NULL, objPtr, + Tcl_Obj *objPtr = TclObjPrintf(NULL, "unknown floating-point error, errno = %d", errno); Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", Tcl_GetString(objPtr), (char *) NULL); diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index a69ea2e..d944287 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIORChan.c,v 1.15 2006/03/27 18:08:51 andreas_kupries Exp $ + * RCS: @(#) $Id: tclIORChan.c,v 1.16 2006/10/31 20:19:45 dgp Exp $ */ #include <tclInt.h> @@ -1651,13 +1651,11 @@ ReflectGetOption( * Odd number of elements is wrong. */ - Tcl_Obj *objPtr = Tcl_NewObj(); - Tcl_ResetResult(interp); - TclObjPrintf(NULL, objPtr, "Expected list with even number of " + Tcl_SetObjResult(interp, TclObjPrintf(NULL, + "Expected list with even number of " "elements, got %d element%s instead", listc, - (listc == 1 ? "" : "s")); - Tcl_SetObjResult(interp, objPtr); + (listc == 1 ? "" : "s"))); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ return TCL_ERROR; } else { @@ -1910,9 +1908,8 @@ NextHandle(void) static unsigned long rcCounter = 0; Tcl_Obj *resObj; - TclNewObj(resObj); Tcl_MutexLock(&rcCounterMutex); - TclObjPrintf(NULL, resObj, "rc%lu", rcCounter); + resObj = TclObjPrintf(NULL, "rc%lu", rcCounter); rcCounter++; Tcl_MutexUnlock(&rcCounterMutex); @@ -2043,19 +2040,17 @@ InvokeTclMethod( Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rcPtr->argv); int cmdLen; CONST char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); - Tcl_Obj *msg = Tcl_NewObj(); Tcl_IncrRefCount(cmd); - TclObjPrintf(NULL, msg, "chan handler returned bad code: %d", - result); Tcl_ResetResult(rcPtr->interp); - Tcl_SetObjResult(rcPtr->interp, msg); + Tcl_SetObjResult(rcPtr->interp, TclObjPrintf(NULL, + "chan handler returned bad code: %d", result)); Tcl_LogCommandInfo(rcPtr->interp, cmdString, cmdString, cmdLen); Tcl_DecrRefCount(cmd); result = TCL_ERROR; } - TclFormatToErrorInfo(rcPtr->interp, - "\n (chan handler subcommand \"%s\")", method); + TclAppendObjToErrorInfo(rcPtr->interp, TclObjPrintf(NULL, + "\n (chan handler subcommand \"%s\")", method)); resObj = MarshallError(rcPtr->interp); } Tcl_IncrRefCount(resObj); diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 68cac51..fb4f71b 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -17,7 +17,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.134 2006/08/29 00:36:57 coldstore Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.135 2006/10/31 20:19:45 dgp Exp $ */ #include "tclInt.h" @@ -1830,9 +1830,10 @@ Tcl_FSEvalFileEx( int limit = 150; int overflow = (length > limit); - TclFormatToErrorInfo(interp, "\n (file \"%.*s%s\" line %d)", + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, + "\n (file \"%.*s%s\" line %d)", (overflow ? limit : length), pathString, - (overflow ? "..." : ""), interp->errorLine); + (overflow ? "..." : ""), interp->errorLine)); } end: diff --git a/generic/tclInt.h b/generic/tclInt.h index 25a150a..2faf993 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.289 2006/10/31 13:46:31 dkf Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.290 2006/10/31 20:19:45 dgp Exp $ */ #ifndef _TCLINT @@ -2038,9 +2038,13 @@ MODULE_SCOPE char tclEmptyString; MODULE_SCOPE int TclAppendFormattedObjs(Tcl_Interp *interp, Tcl_Obj *appendObj, CONST char *format, int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int TclAppendFormatToObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, CONST char *format, ...); MODULE_SCOPE void TclAppendLimitedToObj(Tcl_Obj *objPtr, CONST char *bytes, int length, int limit, CONST char *ellipsis); +MODULE_SCOPE int TclAppendPrintfToObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, CONST char *format, ...); MODULE_SCOPE void TclAppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE int TclArraySet(Tcl_Interp *interp, @@ -2089,10 +2093,6 @@ MODULE_SCOPE void TclFinalizeSynchronization(void); MODULE_SCOPE void TclFinalizeThreadData(void); MODULE_SCOPE double TclFloor(mp_int *a); MODULE_SCOPE void TclFormatNaN(double value, char *buffer); -MODULE_SCOPE int TclFormatObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - CONST char *format, ...); -MODULE_SCOPE int TclFormatToErrorInfo(Tcl_Interp *interp, - CONST char *format, ...); MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, CONST char *attributeName, int *indexPtr); MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp); @@ -2147,14 +2147,16 @@ MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); MODULE_SCOPE int TclNokia770Doubles(); +MODULE_SCOPE Tcl_Obj * TclObjFormat(Tcl_Interp *interp, + CONST char *format, ...); MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], Tcl_Namespace *nsPtr, int flags); +MODULE_SCOPE Tcl_Obj * TclObjPrintf(Tcl_Interp *interp, + CONST char *format, ...); MODULE_SCOPE int TclPtrMakeUpvar (Tcl_Interp *interp, Var *otherP1Ptr, CONST char *myName, int myFlags, int index); -MODULE_SCOPE int TclObjPrintf(Tcl_Interp *interp, Tcl_Obj *objPtr, - CONST char *format, ...); MODULE_SCOPE int TclParseBackslash(CONST char *src, int numBytes, int *readPtr, char *dst); MODULE_SCOPE int TclParseHex(CONST char *src, int numBytes, diff --git a/generic/tclMain.c b/generic/tclMain.c index c3a75ef..841d6bd 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMain.c,v 1.36 2006/05/05 18:09:47 dgp Exp $ + * RCS: @(#) $Id: tclMain.c,v 1.37 2006/10/31 20:19:45 dgp Exp $ */ #include "tclInt.h" @@ -652,8 +652,7 @@ Tcl_Main( if (!Tcl_InterpDeleted(interp)) { if (!Tcl_LimitExceeded(interp)) { - Tcl_Obj *cmd = Tcl_NewObj(); - TclObjPrintf(NULL, cmd, "exit %d", exitCode); + Tcl_Obj *cmd = TclObjPrintf(NULL, "exit %d", exitCode); Tcl_IncrRefCount(cmd); Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(cmd); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index bbb8a7b..412e0c7 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -22,7 +22,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.113 2006/10/31 15:23:41 msofer Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.114 2006/10/31 20:19:45 dgp Exp $ */ #include "tclInt.h" @@ -3454,10 +3454,10 @@ NamespaceEvalCmd( int limit = 200; int overflow = (length > limit); - TclFormatToErrorInfo(interp, + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, "\n (in namespace eval \"%.*s%s\" script line %d)", (overflow ? limit : length), namespacePtr->fullName, - (overflow ? "..." : ""), interp->errorLine); + (overflow ? "..." : ""), interp->errorLine)); } /* @@ -3872,10 +3872,10 @@ NamespaceInscopeCmd( int limit = 200; int overflow = (length > limit); - TclFormatToErrorInfo(interp, + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, "\n (in namespace inscope \"%.*s%s\" script line %d)", (overflow ? limit : length), namespacePtr->fullName, - (overflow ? "..." : ""), interp->errorLine); + (overflow ? "..." : ""), interp->errorLine)); } /* @@ -4602,12 +4602,8 @@ NamespaceUpvarCmd( /* * The namespace does not exist, leave an error message. */ - - Tcl_Obj *resPtr; - - TclNewObj(resPtr); - TclFormatObj(NULL, resPtr, "namespace \"%s\" does not exist", objv[2]); - Tcl_SetObjResult(interp, resPtr); + Tcl_SetObjResult(interp, TclObjFormat(NULL, + "namespace \"%s\" does not exist", objv[2])); return TCL_ERROR; } @@ -6997,10 +6993,10 @@ Tcl_LogCommandInfo( } overflow = (length > limit); - TclFormatToErrorInfo(interp, "\n %s\n\"%.*s%s\"", - ((iPtr->errorInfo == NULL) + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, + "\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL) ? "while executing" : "invoked from within"), - (overflow ? limit : length), command, (overflow ? "..." : "")); + (overflow ? limit : length), command, (overflow ? "..." : ""))); varPtr = TclObjLookupVar(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY, NULL, 0, 0, &arrayPtr); diff --git a/generic/tclParseExpr.c b/generic/tclParseExpr.c index c6471a2..f3d9d45 100644 --- a/generic/tclParseExpr.c +++ b/generic/tclParseExpr.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclParseExpr.c,v 1.44 2006/08/30 20:46:20 dgp Exp $ + * RCS: @(#) $Id: tclParseExpr.c,v 1.45 2006/10/31 20:19:45 dgp Exp $ */ #include "tclInt.h" @@ -225,14 +225,12 @@ Tcl_ParseExpr( if ((NODE_TYPE & nodePtr->lexeme) == 0) { switch (nodePtr->lexeme) { case INVALID: - msg = Tcl_NewObj(); - TclObjPrintf(NULL, msg, + msg = TclObjPrintf(NULL, "invalid character \"%.*s\"", scanned, start); code = TCL_ERROR; continue; case INCOMPLETE: - msg = Tcl_NewObj(); - TclObjPrintf(NULL, msg, + msg = TclObjPrintf(NULL, "incomplete operator \"%.*s\"", scanned, start); code = TCL_ERROR; continue; @@ -248,18 +246,18 @@ Tcl_ParseExpr( if (code == TCL_OK) { nodePtr->lexeme = BOOLEAN; } else { - msg = Tcl_NewObj(); - TclObjPrintf(NULL, msg, "invalid bareword \"%.*s%s\"", + msg = TclObjPrintf(NULL, + "invalid bareword \"%.*s%s\"", (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "..."); - post = Tcl_NewObj(); - TclObjPrintf(NULL, post, + post = TclObjPrintf(NULL, "should be \"$%.*s%s\" or \"{%.*s%s}\"", (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "...", (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "..."); - TclObjPrintf(NULL, post, " or \"%.*s%s(...)\" or ...", + TclAppendPrintfToObj(NULL, post, + " or \"%.*s%s(...)\" or ...", (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "..."); continue; @@ -286,8 +284,7 @@ Tcl_ParseExpr( CONST char *operand = scratch.tokenPtr[lastNodePtr->token].start; - msg = Tcl_NewObj(); - TclObjPrintf(NULL, msg, "missing operator at %s", mark); + msg = TclObjPrintf(NULL, "missing operator at %s", mark); if (operand[0] == '0') { Tcl_Obj *copy = Tcl_NewStringObj(operand, start + scanned - operand); @@ -421,8 +418,7 @@ Tcl_ParseExpr( case UNARY: if ((NODE_TYPE & lastNodePtr->lexeme) == LEAF) { - msg = Tcl_NewObj(); - TclObjPrintf(NULL, msg, "missing operator at %s", mark); + msg = TclObjPrintf(NULL, "missing operator at %s", mark); scanned = 0; insertMark = 1; code = TCL_ERROR; @@ -468,8 +464,7 @@ Tcl_ParseExpr( break; } - msg = Tcl_NewObj(); - TclObjPrintf(NULL, msg, "empty subexpression at %s", mark); + msg = TclObjPrintf(NULL, "empty subexpression at %s", mark); scanned = 0; insertMark = 1; code = TCL_ERROR; @@ -482,8 +477,7 @@ Tcl_ParseExpr( if (lastNodePtr->lexeme == OPEN_PAREN) { msg = Tcl_NewStringObj("unbalanced open paren", -1); } else if (lastNodePtr->lexeme == COMMA) { - msg = Tcl_NewObj(); - TclObjPrintf(NULL, msg, + msg = TclObjPrintf(NULL, "missing function argument at %s", mark); scanned = 0; insertMark = 1; @@ -496,16 +490,14 @@ Tcl_ParseExpr( } else if ((nodePtr->lexeme == COMMA) && (lastNodePtr->lexeme == OPEN_PAREN) && (lastNodePtr[-1].lexeme == FUNCTION)) { - msg = Tcl_NewObj(); - TclObjPrintf(NULL, msg, + msg = TclObjPrintf(NULL, "missing function argument at %s", mark); scanned = 0; insertMark = 1; } } if (msg == NULL) { - msg = Tcl_NewObj(); - TclObjPrintf(NULL, msg, "missing operand at %s", mark); + msg = TclObjPrintf(NULL, "missing operand at %s", mark); scanned = 0; insertMark = 1; } @@ -551,8 +543,7 @@ Tcl_ParseExpr( } if ((otherPtr->lexeme == QUESTION) && (lastOrphanPtr->lexeme != COLON)) { - msg = Tcl_NewObj(); - TclObjPrintf(NULL, msg, + msg = TclObjPrintf(NULL, "missing operator \":\" at %s", mark); scanned = 0; insertMark = 1; @@ -657,7 +648,7 @@ Tcl_ParseExpr( if (msg == NULL) { msg = Tcl_GetObjResult(interp); } - TclObjPrintf(NULL, msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"", + TclAppendPrintfToObj(NULL, msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"", ((start - limit) < scratch.string) ? "" : "...", ((start - limit) < scratch.string) ? (start - scratch.string) : limit - 3, @@ -678,10 +669,10 @@ Tcl_ParseExpr( } Tcl_SetObjResult(interp, msg); numBytes = scratch.end - scratch.string; - TclFormatToErrorInfo(interp, + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, "\n (parsing expression \"%.*s%s\")", (numBytes < limit) ? numBytes : limit - 3, - scratch.string, (numBytes < limit) ? "" : "..."); + scratch.string, (numBytes < limit) ? "" : "...")); } } diff --git a/generic/tclPkg.c b/generic/tclPkg.c index ea10e18..e0f6615 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPkg.c,v 1.21 2006/10/16 17:43:20 dgp Exp $ + * RCS: @(#) $Id: tclPkg.c,v 1.22 2006/10/31 20:19:45 dgp Exp $ * * TIP #268. * Heavily rewritten to handle the extend version numbers, and extended @@ -508,9 +508,9 @@ Tcl_PkgRequireProc( } if (code == TCL_ERROR) { - TclFormatToErrorInfo(interp, + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, "\n (\"package ifneeded %s %s\" script)", - name, versionToProvide); + name, versionToProvide)); } Tcl_Release((ClientData) versionToProvide); diff --git a/generic/tclProc.c b/generic/tclProc.c index 1dfe606..90e6970 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.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: tclProc.c,v 1.102 2006/10/31 13:46:32 dkf Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.103 2006/10/31 20:19:45 dgp Exp $ */ #include "tclInt.h" @@ -369,12 +369,10 @@ TclCreateProc( if (precompiled) { if (numArgs > procPtr->numArgs) { - Tcl_Obj *objPtr = Tcl_NewObj(); - TclObjPrintf(NULL, objPtr, + Tcl_SetObjResult(interp, TclObjPrintf(NULL, "procedure \"%s\": arg list contains %d entries, " "precompiled header expects %d", procName, numArgs, - procPtr->numArgs); - Tcl_SetObjResult(interp, objPtr); + procPtr->numArgs)); goto procError; } localPtr = procPtr->firstLocalPtr; @@ -460,11 +458,9 @@ TclCreateProc( != (VAR_SCALAR | VAR_ARGUMENT)) || (localPtr->defValuePtr == NULL && fieldCount == 2) || (localPtr->defValuePtr != NULL && fieldCount != 2)) { - Tcl_Obj *objPtr = Tcl_NewObj(); - TclObjPrintf(NULL, objPtr, + Tcl_SetObjResult(interp, TclObjPrintf(NULL, "procedure \"%s\": formal parameter %d is " - "inconsistent with precompiled body", procName, i); - Tcl_SetObjResult(interp, objPtr); + "inconsistent with precompiled body", procName, i)); ckfree((char *) fieldValues); goto procError; } @@ -479,13 +475,10 @@ TclCreateProc( &tmpLength); if ((valueLength != tmpLength) || strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) { - Tcl_Obj *objPtr = Tcl_NewObj(); - - TclObjPrintf(NULL, objPtr, + Tcl_SetObjResult(interp, TclObjPrintf(NULL, "procedure \"%s\": formal parameter \"%s\" has " "default value inconsistent with precompiled body", - procName, fieldValues[0]); - Tcl_SetObjResult(interp, objPtr); + procName, fieldValues[0])); ckfree((char *) fieldValues); goto procError; } @@ -846,8 +839,8 @@ Tcl_UplevelObjCmd( result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); } if (result == TCL_ERROR) { - TclFormatToErrorInfo(interp, "\n (\"uplevel\" body line %d)", - interp->errorLine); + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, + "\n (\"uplevel\" body line %d)", interp->errorLine)); } /* @@ -1699,10 +1692,10 @@ ProcCompileProc( int limit = 50; int overflow = (length > limit); - TclFormatToErrorInfo(interp, + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, "\n (compiling %s \"%.*s%s\", line %d)", description, (overflow ? limit : length), procName, - (overflow ? "..." : ""), interp->errorLine); + (overflow ? "..." : ""), interp->errorLine)); } return result; } @@ -1746,9 +1739,10 @@ MakeProcError( const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); - TclFormatToErrorInfo(interp, "\n (procedure \"%.*s%s\" line %d)", + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, + "\n (procedure \"%.*s%s\" line %d)", (overflow ? limit : nameLen), procName, - (overflow ? "..." : ""), interp->errorLine); + (overflow ? "..." : ""), interp->errorLine)); } /* @@ -2083,8 +2077,8 @@ SetLambdaFromAny( if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, name, argsPtr, bodyPtr, &procPtr) != TCL_OK) { - TclFormatToErrorInfo(interp, - "\n (parsing lambda expression \"%s\")", name, NULL); + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, + "\n (parsing lambda expression \"%s\")", name)); return TCL_ERROR; } @@ -2273,9 +2267,10 @@ MakeLambdaError( const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); - TclFormatToErrorInfo(interp, "\n (lambda term \"%.*s%s\" line %d)", + TclAppendObjToErrorInfo(interp, TclObjPrintf(NULL, + "\n (lambda term \"%.*s%s\" line %d)", (overflow ? limit : nameLen), procName, - (overflow ? "..." : ""), interp->errorLine); + (overflow ? "..." : ""), interp->errorLine)); } /* diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index af94b6d..c3ba0f0 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -33,7 +33,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStringObj.c,v 1.58 2006/09/24 20:46:40 msofer Exp $ */ + * RCS: @(#) $Id: tclStringObj.c,v 1.59 2006/10/31 20:19:45 dgp Exp $ */ #include "tclInt.h" #include "tommath.h" @@ -51,9 +51,9 @@ static void AppendUtfToUnicodeRep(Tcl_Obj *objPtr, static void AppendUtfToUtfRep(Tcl_Obj *objPtr, CONST char *bytes, int numBytes); static void FillUnicodeRep(Tcl_Obj *objPtr); -static int FormatObjVA(Tcl_Interp *interp, Tcl_Obj *objPtr, +static int AppendFormatToObjVA(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, va_list argList); -static int ObjPrintfVA(Tcl_Interp *interp, Tcl_Obj *objPtr, +static int AppendPrintfToObjVA(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, va_list argList); static void FreeStringInternalRep(Tcl_Obj *objPtr); static void DupStringInternalRep(Tcl_Obj *objPtr, @@ -2293,7 +2293,7 @@ TclAppendFormattedObjs( /* *--------------------------------------------------------------------------- * - * FormatObjVA -- + * AppendFormatToObjVA -- * * Populate the Unicode internal rep with the Unicode form of its string * rep. The object must alread have a "String" internal rep. @@ -2308,7 +2308,7 @@ TclAppendFormattedObjs( */ static int -FormatObjVA( +AppendFormatToObjVA( Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, @@ -2339,7 +2339,7 @@ FormatObjVA( /* *--------------------------------------------------------------------------- * - * TclFormatObj -- + * TclAppendFormatToObj -- * * Results: * A standard Tcl result. @@ -2351,7 +2351,7 @@ FormatObjVA( */ int -TclFormatObj( +TclAppendFormatToObj( Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, @@ -2361,7 +2361,7 @@ TclFormatObj( int result; va_start(argList, format); - result = FormatObjVA(interp, objPtr, format, argList); + result = AppendFormatToObjVA(interp, objPtr, format, argList); va_end(argList); return result; } @@ -2369,7 +2369,41 @@ TclFormatObj( /* *--------------------------------------------------------------------------- * - * ObjPrintfVA -- + * TclObjFormat-- + * + * Results: + * A refcount zero Tcl_Obj. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclObjFormat( + Tcl_Interp *interp, + CONST char *format, + ...) +{ + va_list argList; + int result; + Tcl_Obj *objPtr = Tcl_NewObj(); + + va_start(argList, format); + result = AppendFormatToObjVA(interp, objPtr, format, argList); + va_end(argList); + if (result != TCL_OK) { + Tcl_DecrRefCount(objPtr); + return NULL; + } + return objPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * AppendPrintfToObjVA -- * * Results: * @@ -2379,7 +2413,7 @@ TclFormatObj( */ static int -ObjPrintfVA( +AppendPrintfToObjVA( Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, @@ -2510,7 +2544,7 @@ ObjPrintfVA( /* *--------------------------------------------------------------------------- * - * TclObjPrintf -- + * TclAppendPrintfToObj -- * * Results: * A standard Tcl result. @@ -2522,7 +2556,7 @@ ObjPrintfVA( */ int -TclObjPrintf( +TclAppendPrintfToObj( Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, @@ -2532,42 +2566,43 @@ TclObjPrintf( int result; va_start(argList, format); - result = ObjPrintfVA(interp, objPtr, format, argList); + result = AppendPrintfToObjVA(interp, objPtr, format, argList); va_end(argList); return result; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * TclFormatToErrorInfo -- + * TclObjPrintf -- * * Results: + * A refcount zero Tcl_Obj. * * Side effects: + * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -int -TclFormatToErrorInfo( +Tcl_Obj * +TclObjPrintf( Tcl_Interp *interp, CONST char *format, ...) { - int code; va_list argList; + int result; Tcl_Obj *objPtr = Tcl_NewObj(); va_start(argList, format); - code = ObjPrintfVA(interp, objPtr, format, argList); + result = AppendPrintfToObjVA(interp, objPtr, format, argList); va_end(argList); - if (code != TCL_OK) { - return code; + if (result != TCL_OK) { + Tcl_DecrRefCount(objPtr); + return NULL; } - TclAppendObjToErrorInfo(interp, objPtr); - Tcl_DecrRefCount(objPtr); - return TCL_OK; + return objPtr; } /* diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 49e0e6e..6f7a20e 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTimer.c,v 1.23 2006/09/26 00:05:03 patthoyts Exp $ + * RCS: @(#) $Id: tclTimer.c,v 1.24 2006/10/31 20:19:46 dgp Exp $ */ #include "tclInt.h" @@ -870,9 +870,7 @@ Tcl_AfterObjCmd( (ClientData) afterPtr); afterPtr->nextPtr = assocPtr->firstAfterPtr; assocPtr->firstAfterPtr = afterPtr; - objPtr = Tcl_NewObj(); - TclObjPrintf(NULL, objPtr, "after#%d", afterPtr->id); - Tcl_SetObjResult(interp, objPtr); + Tcl_SetObjResult(interp, TclObjPrintf(NULL, "after#%d", afterPtr->id)); return TCL_OK; } case AFTER_CANCEL: { @@ -935,9 +933,7 @@ Tcl_AfterObjCmd( afterPtr->nextPtr = assocPtr->firstAfterPtr; assocPtr->firstAfterPtr = afterPtr; Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); - objPtr = Tcl_NewObj(); - TclObjPrintf(NULL, objPtr, "after#%d", afterPtr->id); - Tcl_SetObjResult(interp, objPtr); + Tcl_SetObjResult(interp, TclObjPrintf(NULL, "after#%d", afterPtr->id)); break; case AFTER_INFO: { Tcl_Obj *resultListPtr; diff --git a/generic/tclUtil.c b/generic/tclUtil.c index ab6c0c8..febe94c 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.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: tclUtil.c,v 1.71 2006/09/30 19:15:21 msofer Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.72 2006/10/31 20:19:46 dgp Exp $ */ #include "tclInt.h" @@ -215,17 +215,15 @@ TclFindElement( */ if (interp != NULL) { - Tcl_Obj *objPtr = Tcl_NewObj(); p2 = p; while ((p2 < limit) && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */ && (p2 < p+20)) { p2++; } - TclObjPrintf(NULL, objPtr, + Tcl_SetObjResult(interp, TclObjPrintf(NULL, "list element in braces followed by \"%.*s\" " - "instead of space", (int) (p2-p), p); - Tcl_SetObjResult(interp, objPtr); + "instead of space", (int) (p2-p), p)); } return TCL_ERROR; } @@ -276,17 +274,15 @@ TclFindElement( */ if (interp != NULL) { - Tcl_Obj *objPtr = Tcl_NewObj(); p2 = p; while ((p2 < limit) && (!isspace(UCHAR(*p2))) /* INTL: ISO space */ && (p2 < p+20)) { p2++; } - TclObjPrintf(NULL, objPtr, + Tcl_SetObjResult(interp, TclObjPrintf(NULL, "list element in quotes followed by \"%.*s\" " - "instead of space", (int) (p2-p), p); - Tcl_SetObjResult(interp, objPtr); + "instead of space", (int) (p2-p), p)); } return TCL_ERROR; } |