Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | merge updates from HEAD |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | kennykb-numerics-branch |
| Files: | files | file ages | folders |
| SHA1: |
29cc0feeb262c62f98476658f71677b1 |
| User & Date: | dgp 2005-09-15 20:58:38 |
Context
|
2005-09-16
| ||
| 15:35 |
[kennykb-numerics-branch] * generic/tclTomMath.h: Added mp_cmp_d to routines from ...check-in: f5324453ec user: dgp tags: kennykb-numerics-branch | |
|
2005-09-15
| ||
| 20:58 | merge updates from HEAD check-in: 29cc0feeb2 user: dgp tags: kennykb-numerics-branch | |
|
2005-09-12
| ||
| 19:39 | uninitialized vars are bad, mm'kay? check-in: 948d18b8f7 user: dgp tags: kennykb-numerics-branch | |
Changes
Changes to ChangeLog.
1 +2005-09-15 Don Porter <[email protected]> 2 + 3 + [kennykb-numerics-branch] Merge updates from HEAD. 4 + 5 + * generic/tclStringObj.c (TclAppendFormattedObjs): Revision 6 + to eliminate one round of string copying. 7 + 8 + * generic/tclBasic.c: More callers of TclObjPrintf and 9 + * generic/tclCkalloc.c: TclFormatToErrorInfo. 10 + * generic/tclCmdMZ.c: 11 + * generic/tclExecute.c: 12 + * generic/tclIORChan.c: 13 + * generic/tclMain.c: 14 + * generic/tclProc.c: 15 + * generic/tclTimer.c: 16 + * generic/tclUtil.c: 17 + * unix/tclUnixFCmd.c 18 + 19 + * unix/configure: autoconf-2.59 20 + 21 +2005-09-15 Donal K. Fellows <[email protected]> 22 + 23 + * unix/tcl.m4 (SC_TCL_EARLY_FLAGS): Added extra hack to allow Tcl 24 + to transparently open large files on RHEL 3. [Bug 1287638] 25 + 26 +2005-09-14 Don Porter <[email protected]> 27 + 28 + * generic/tclStringObj.c: Bug fixes: ObjPrintfVA needed to 29 + support "*" fields and needed to interpret precision limits on 30 + %s conversions as a maximum number of bytes, not Tcl_UniChars, to 31 + take from the (char *) argument. 32 + 33 + * generic/tclBasic.c: Updated several callers to use 34 + * generic/tclCkalloc.c: TclFormatToErrorInfo() and/or 35 + * generic/tclCmdAH.c: TclObjPrintf(). 36 + * generic/tclCmdIL.c: 37 + * generic/tclCmdMZ.c: 38 + * generic/tclDictObj.c: 39 + * generic/tclExecute.c: 40 + * generic/tclIORChan.c: 41 + * generic/tclIOUtil.c: 42 + * generic/tclNamesp.c: 43 + * generic/tclProc.c: 44 + 45 + * library/init.tcl: Keep [unknown] in sync with errorInfo 46 + formatting rules. 47 + 48 +2005-09-13 Don Porter <[email protected]> 49 + 50 + * generic/tclBasic.c: First caller of TclFormatToErrorInfo. 51 + 52 + * generic/tclInt.h: Using stdarg.h conventions, add more 53 + * generic/tclStringObj.c: fixed arguments to TclFormatObj() and 54 + TclObjPrintf(). Added new routine TclFormatToErrorInfo(). 55 + 56 + * generic/tcl.h: Explicitly standardized on the use of stdarg.h 57 + * generic/tclBasic.c: conventions for functions with variable number 58 + * generic/tclInt.h: of arguments. Support for varargs.h has been 59 + * generic/tclPanic.c: implicitly gone for some time now. All 60 + * generic/tclResult.c: TCL_VARARGS* macros purged from Tcl sources, 61 + * generic/tclStringObj.c: leaving only some deprecated #define's 62 + * tools/genStubs.tcl: in tcl.h for the sake of older extensions. 63 + 64 + * generic/tclDecls.h: make genstubs 65 + 66 + * doc/AddErrInfo.3: Replaced all documented requirement for use 67 + * doc/Eval.3: of TCL_VARARGS_START() with requirement for 68 + * doc/Panic.3: use of va_start(). 69 + * doc/SetResult.3: 70 + * doc/StringObj.3: 71 + 1 72 2005-09-12 Don Porter <[email protected]> 2 73 3 74 [kennykb-numerics-branch] Merge updates from HEAD. 4 75 5 76 * generic/tclCmdAH.c: Added support for the "ll" width 6 77 * generic/tclStringObj.c: specifier to [format]. 7 78
Changes to doc/AddErrInfo.3.
1 1 '\" 2 2 '\" Copyright (c) 1989-1993 The Regents of the University of California. 3 3 '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. 4 4 '\" 5 5 '\" See the file "license.terms" for information on usage and redistribution 6 6 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 7 7 '\" 8 -'\" RCS: @(#) $Id: AddErrInfo.3,v 1.13.2.1 2005/08/15 18:13:58 dgp Exp $ 8 +'\" RCS: @(#) $Id: AddErrInfo.3,v 1.13.2.2 2005/09/15 20:58:38 dgp Exp $ 9 9 '\" 10 10 .so man.macros 11 -.TH Tcl_AddErrorInfo 3 8.0 Tcl "Tcl Library Procedures" 11 +.TH Tcl_AddErrorInfo 3 8.5 Tcl "Tcl Library Procedures" 12 12 .BS 13 13 .SH NAME 14 14 Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options 15 15 .SH SYNOPSIS 16 16 .nf 17 17 \fB#include <tcl.h>\fR 18 18 .VS 8.5 ................................................................................ 62 62 .AP Tcl_Obj *errorObjPtr in 63 63 The \fB-errorcode\fR return option will be set to this value. 64 64 .AP char *element in 65 65 String to record as one element of the \fB-errorcode\fR return option. 66 66 Last \fIelement\fR argument must be NULL. 67 67 .AP va_list argList in 68 68 An argument list which must have been initialized using 69 -\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR. 69 +\fBva_start\fR, and cleared using \fBva_end\fR. 70 70 .AP "const char" *script in 71 71 Pointer to first character in script containing command (must be <= command) 72 72 .AP "const char" *command in 73 73 Pointer to first character in command that generated the error 74 74 .AP int commandLength in 75 75 Number of bytes in command; -1 means use all bytes up to first null byte 76 76 .BE
Changes to doc/Eval.3.
2 2 '\" Copyright (c) 1989-1993 The Regents of the University of California. 3 3 '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. 4 4 '\" Copyright (c) 2000 Scriptics Corporation. 5 5 '\" 6 6 '\" See the file "license.terms" for information on usage and redistribution 7 7 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 8 8 '\" 9 -'\" RCS: @(#) $Id: Eval.3,v 1.18.2.2 2005/05/05 17:55:20 kennykb Exp $ 9 +'\" RCS: @(#) $Id: Eval.3,v 1.18.2.3 2005/09/15 20:58:38 dgp Exp $ 10 10 '\" 11 11 .so man.macros 12 12 .TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures" 13 13 .BS 14 14 .SH NAME 15 15 Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA \- execute Tcl scripts 16 16 .SH SYNOPSIS ................................................................................ 67 67 first null byte are used. 68 68 .AP "const char" *script in 69 69 Points to first byte of script to execute (null-terminated and UTF-8). 70 70 .AP char *part in 71 71 String forming part of a Tcl script. 72 72 .AP va_list argList in 73 73 An argument list which must have been initialized using 74 -\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR. 74 +\fBva_start\fR, and cleared using \fBva_end\fR. 75 75 .BE 76 76 77 77 .SH DESCRIPTION 78 78 .PP 79 79 The procedures described here are invoked to execute Tcl scripts in 80 80 various forms. 81 81 \fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others.
Changes to doc/Panic.3.
1 1 '\" 2 2 '\" See the file "license.terms" for information on usage and redistribution 3 3 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 4 4 '\" 5 -'\" RCS: @(#) $Id: Panic.3,v 1.7 2004/10/07 15:15:47 dkf Exp $ 5 +'\" RCS: @(#) $Id: Panic.3,v 1.7.2.1 2005/09/15 20:58:38 dgp Exp $ 6 6 '\" 7 7 .so man.macros 8 8 .TH Tcl_Panic 3 8.4 Tcl "Tcl Library Procedures" 9 9 .BS 10 10 '\" Note: do not modify the .SH NAME line immediately below! 11 11 .SH NAME 12 12 Tcl_Panic, Tcl_PanicVA, Tcl_SetPanicProc \- report fatal error and abort ................................................................................ 27 27 .AS Tcl_PanicProc *panicProc 28 28 .AP "const char*" format in 29 29 A printf-style format string. 30 30 .AP "" arg in 31 31 Arguments matching the format string. 32 32 .AP va_list argList in 33 33 An argument list of arguments matching the format string. 34 -Must have been initialized using \fBTCL_VARARGS_START\fR, 34 +Must have been initialized using \fBva_start\fR, 35 35 and cleared using \fBva_end\fR. 36 36 .AP Tcl_PanicProc *panicProc in 37 37 Procedure to report fatal error message and abort. 38 38 39 39 .BE 40 40 41 41 .SH DESCRIPTION
Changes to doc/SetResult.3.
1 1 '\" 2 2 '\" Copyright (c) 1989-1993 The Regents of the University of California. 3 3 '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. 4 4 '\" 5 5 '\" See the file "license.terms" for information on usage and redistribution 6 6 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 7 7 '\" 8 -'\" RCS: @(#) $Id: SetResult.3,v 1.11.2.1 2005/05/05 17:55:23 kennykb Exp $ 8 +'\" RCS: @(#) $Id: SetResult.3,v 1.11.2.2 2005/09/15 20:58:38 dgp Exp $ 9 9 '\" 10 10 .so man.macros 11 11 .TH Tcl_SetResult 3 8.0 Tcl "Tcl Library Procedures" 12 12 .BS 13 13 .SH NAME 14 14 Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendResultVA, Tcl_AppendElement, Tcl_ResetResult, Tcl_FreeResult \- manipulate Tcl result 15 15 .SH SYNOPSIS ................................................................................ 49 49 to the existing result of \fIinterp\fR. 50 50 .AP Tcl_FreeProc *freeProc in 51 51 Address of procedure to call to release storage at 52 52 \fIresult\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or 53 53 \fBTCL_VOLATILE\fR. 54 54 .AP va_list argList in 55 55 An argument list which must have been initialized using 56 -\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR. 56 +\fBva_start\fR, and cleared using \fBva_end\fR. 57 57 .BE 58 58 59 59 .SH DESCRIPTION 60 60 .PP 61 61 The procedures described here are utilities for manipulating the 62 62 result value in a Tcl interpreter. 63 63 The interpreter result may be either a Tcl object or a string.
Changes to doc/StringObj.3.
1 1 '\" 2 2 '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. 3 3 '\" 4 4 '\" See the file "license.terms" for information on usage and redistribution 5 5 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 6 '\" 7 -'\" RCS: @(#) $Id: StringObj.3,v 1.17.2.1 2005/04/10 23:14:42 kennykb Exp $ 7 +'\" RCS: @(#) $Id: StringObj.3,v 1.17.2.2 2005/09/15 20:58:39 dgp Exp $ 8 8 '\" 9 9 .so man.macros 10 10 .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" 11 11 .BS 12 12 .SH NAME 13 13 Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendObjToObj, Tcl_SetObjLength, Tcl_ConcatObj, Tcl_AttemptSetObjLength \- manipulate Tcl objects as strings 14 14 .SH SYNOPSIS ................................................................................ 109 109 .AP int *lengthPtr out 110 110 If non-NULL, the location where \fBTcl_GetStringFromObj\fR will store 111 111 the length of an object's string representation. 112 112 .AP "const char" *string in 113 113 Null-terminated string value to append to \fIobjPtr\fR. 114 114 .AP va_list argList in 115 115 An argument list which must have been initialised using 116 -\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR. 116 +\fBva_start\fR, and cleared using \fBva_end\fR. 117 117 .AP int newLength in 118 118 New length for the string value of \fIobjPtr\fR, not including the 119 119 final null character. 120 120 .AP int objc in 121 121 The number of elements to concatenate. 122 122 .AP Tcl_Obj *objv[] in 123 123 The array of objects to concatenate.
Changes to generic/tcl.h.
9 9 * Copyright (c) 1994-1998 Sun Microsystems, Inc. 10 10 * Copyright (c) 1998-2000 by Scriptics Corporation. 11 11 * Copyright (c) 2002 by Kevin B. Kenny. All rights reserved. 12 12 * 13 13 * See the file "license.terms" for information on usage and redistribution of 14 14 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 15 15 * 16 - * RCS: @(#) $Id: tcl.h,v 1.191.2.9 2005/09/09 18:48:40 dgp Exp $ 16 + * RCS: @(#) $Id: tcl.h,v 1.191.2.10 2005/09/15 20:58:39 dgp Exp $ 17 17 */ 18 18 19 19 #ifndef _TCL 20 20 #define _TCL 21 21 22 22 /* 23 23 * For C++ compilers, use extern "C" ................................................................................ 149 149 * should, so also for their sake, we keep the #include to be consistent with 150 150 * prior Tcl releases. 151 151 */ 152 152 153 153 #include <stdio.h> 154 154 155 155 /* 156 - * Definitions that allow Tcl functions with variable numbers of arguments to 157 - * be used with either varargs.h or stdarg.h. TCL_VARARGS is used in function 158 - * prototypes. TCL_VARARGS_DEF is used to declare the arguments in a function 159 - * definiton: it takes the type and name of the first argument and supplies 160 - * the appropriate argument declaration string for use in the function 161 - * definition. TCL_VARARGS_START initializes the va_list data structure and 162 - * returns the first argument. 156 + * Support for functions with a variable number of arguments. 157 + * 158 + * The following TCL_VARARGS* macros are to support old extensions 159 + * written for older versions of Tcl where the macros permitted 160 + * support for the varargs.h system as well as stdarg.h . 161 + * 162 + * New code should just directly be written to use stdarg.h conventions. 163 163 */ 164 164 165 -#if !defined(NO_STDARG) 166 -# include <stdarg.h> 167 -# define TCL_VARARGS(type, name) (type name, ...) 168 -# define TCL_VARARGS_DEF(type, name) (type name, ...) 169 -# define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) 170 -#else 171 -# include <varargs.h> 172 -# define TCL_VARARGS(type, name) () 173 -# define TCL_VARARGS_DEF(type, name) (va_alist) 174 -# define TCL_VARARGS_START(type, name, list) \ 175 - (va_start(list), va_arg(list, type)) 165 +#include <stdarg.h> 166 +#ifndef TCL_NO_DEPRECATED 167 +# define TCL_VARARGS(type, name) (type name, ...) 168 +# define TCL_VARARGS_DEF(type, name) (type name, ...) 169 +# define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) 176 170 #endif 177 171 178 172 /* 179 173 * Macros used to declare a function to be exported by a DLL. Used by Windows, 180 174 * maps to no-op declarations on non-Windows systems. The default build on 181 175 * windows is for a DLL, which causes the DLLIMPORT and DLLEXPORT macros to be 182 176 * nonempty. To build a static library, the macro STATIC_BUILD should be ................................................................................ 690 684 Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); 691 685 typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData)); 692 686 typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData, 693 687 Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv)); 694 688 typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); 695 689 typedef int (Tcl_PackageUnloadProc) _ANSI_ARGS_((Tcl_Interp *interp, 696 690 int flags)); 697 -typedef void (Tcl_PanicProc) _ANSI_ARGS_(TCL_VARARGS(CONST char *, format)); 691 +typedef void (Tcl_PanicProc) _ANSI_ARGS_((CONST char *format, ...)); 698 692 typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData, 699 693 Tcl_Channel chan, char *address, int port)); 700 694 typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData)); 701 695 typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp, 702 696 struct Tcl_Obj *objPtr)); 703 697 typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr)); 704 698 typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,
Changes to generic/tclBasic.c.
9 9 * Copyright (c) 1994-1997 Sun Microsystems, Inc. 10 10 * Copyright (c) 1998-1999 by Scriptics Corporation. 11 11 * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. 12 12 * 13 13 * See the file "license.terms" for information on usage and redistribution of 14 14 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 15 15 * 16 - * RCS: @(#) $Id: tclBasic.c,v 1.136.2.33 2005/09/09 18:48:40 dgp Exp $ 16 + * RCS: @(#) $Id: tclBasic.c,v 1.136.2.34 2005/09/15 20:58:39 dgp Exp $ 17 17 */ 18 18 19 19 #include "tclInt.h" 20 20 #include "tclCompile.h" 21 21 #include <float.h> 22 22 #include <math.h> 23 23 #include "tommath.h" ................................................................................ 3598 3598 CONST char *command; /* First character in command that generated 3599 3599 * the error. */ 3600 3600 int length; /* Number of bytes in command (-1 means use 3601 3601 * all bytes up to first null byte). */ 3602 3602 { 3603 3603 register CONST char *p; 3604 3604 Interp *iPtr = (Interp *) interp; 3605 - Tcl_Obj *message; 3605 + int overflow, limit = 150; 3606 3606 3607 3607 if (iPtr->flags & ERR_ALREADY_LOGGED) { 3608 3608 /* 3609 3609 * Someone else has already logged error information for this command; 3610 3610 * we shouldn't add anything more. 3611 3611 */ 3612 3612 ................................................................................ 3620 3620 iPtr->errorLine = 1; 3621 3621 for (p = script; p != command; p++) { 3622 3622 if (*p == '\n') { 3623 3623 iPtr->errorLine++; 3624 3624 } 3625 3625 } 3626 3626 3627 - if (iPtr->errorInfo == NULL) { 3628 - message = Tcl_NewStringObj("\n while executing\n\"", -1); 3629 - } else { 3630 - message = Tcl_NewStringObj("\n invoked from within\n\"", -1); 3631 - } 3632 - Tcl_IncrRefCount(message); 3633 - TclAppendLimitedToObj(message, command, length, 153, NULL); 3634 - Tcl_AppendToObj(message, "\"", -1); 3635 - TclAppendObjToErrorInfo(interp, message); 3636 - Tcl_DecrRefCount(message); 3627 + overflow = (length > limit); 3628 + TclFormatToErrorInfo(interp, "\n %s\n\"%.*s%s\"", 3629 + ((iPtr->errorInfo == NULL) 3630 + ? "while executing" : "invoked from within"), 3631 + (overflow ? limit : length), command, (overflow ? "..." : "")); 3637 3632 } 3638 3633 3639 3634 /* 3640 3635 *---------------------------------------------------------------------- 3641 3636 * 3642 3637 * Tcl_EvalTokensStandard -- 3643 3638 * ................................................................................ 3827 3822 Tcl_IncrRefCount(objv[objectsUsed]); 3828 3823 if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { 3829 3824 int numElements; 3830 3825 3831 3826 code = Tcl_ListObjLength(interp, 3832 3827 objv[objectsUsed], &numElements); 3833 3828 if (code == TCL_ERROR) { 3834 - /* 3835 - * Attempt to expand a non-list. 3836 - */ 3837 - 3838 - Tcl_Obj *msg; 3839 - Tcl_Obj *wordNum; 3840 - 3841 - msg = Tcl_NewStringObj("\n (expanding word ", -1); 3842 - TclNewIntObj(wordNum, objectsUsed); 3843 - Tcl_IncrRefCount(wordNum); 3844 - Tcl_IncrRefCount(msg); 3845 - Tcl_AppendObjToObj(msg, wordNum); 3846 - Tcl_DecrRefCount(wordNum); 3847 - Tcl_AppendToObj(msg, ")", -1); 3848 - TclAppendObjToErrorInfo(interp, msg); 3849 - Tcl_DecrRefCount(msg); 3829 + /* Attempt to expand a non-list. */ 3830 + TclFormatToErrorInfo(interp, 3831 + "\n (expanding word %d)", objectsUsed); 3850 3832 Tcl_DecrRefCount(objv[objectsUsed]); 3851 3833 goto error; 3852 3834 } 3853 3835 expandRequested = 1; 3854 3836 expand[objectsUsed] = 1; 3855 3837 objectsNeeded += (numElements ? numElements : 1); 3856 3838 } else { ................................................................................ 4232 4214 if (returnCode == TCL_BREAK) { 4233 4215 Tcl_AppendResult(interp, 4234 4216 "invoked \"break\" outside of a loop", (char *) NULL); 4235 4217 } else if (returnCode == TCL_CONTINUE) { 4236 4218 Tcl_AppendResult(interp, 4237 4219 "invoked \"continue\" outside of a loop", (char *) NULL); 4238 4220 } else { 4239 - char buf[30 + TCL_INTEGER_SPACE]; 4240 - 4241 - sprintf(buf, "command returned bad code: %d", returnCode); 4242 - Tcl_SetResult(interp, buf, TCL_VOLATILE); 4221 + Tcl_Obj *objPtr = Tcl_NewObj(); 4222 + TclObjPrintf(NULL, objPtr, "command returned bad code: %d", returnCode); 4223 + Tcl_SetObjResult(interp, objPtr); 4243 4224 } 4244 4225 } 4245 4226 4246 4227 /* 4247 4228 *--------------------------------------------------------------------------- 4248 4229 * 4249 4230 * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- ................................................................................ 4837 4818 * left in interp->result. 4838 4819 * 4839 4820 * Side effects: 4840 4821 * Depends on what was done by the command. 4841 4822 * 4842 4823 *---------------------------------------------------------------------- 4843 4824 */ 4844 - /* VARARGS2 */ /* ARGSUSED */ 4825 + /* ARGSUSED */ 4845 4826 int 4846 -Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) 4827 +Tcl_VarEval(Tcl_Interp *interp, ...) 4847 4828 { 4848 - Tcl_Interp *interp; 4849 4829 va_list argList; 4850 4830 int result; 4851 4831 4852 - interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); 4832 + va_start(argList, interp); 4853 4833 result = Tcl_VarEvalVA(interp, argList); 4854 4834 va_end(argList); 4855 4835 4856 4836 return result; 4857 4837 } 4858 4838 4859 4839 /*
Changes to generic/tclCkalloc.c.
10 10 * Copyright (c) 1998-1999 by Scriptics Corporation. 11 11 * 12 12 * See the file "license.terms" for information on usage and redistribution of 13 13 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 14 14 * 15 15 * This code contributed by Karl Lehenbauer and Mark Diekhans 16 16 * 17 - * RCS: @(#) $Id: tclCkalloc.c,v 1.22.2.1 2005/08/02 18:15:12 dgp Exp $ 17 + * RCS: @(#) $Id: tclCkalloc.c,v 1.22.2.2 2005/09/15 20:58:39 dgp Exp $ 18 18 */ 19 19 20 20 #include "tclInt.h" 21 21 22 22 #define FALSE 0 23 23 #define TRUE 1 24 24 ................................................................................ 839 839 } 840 840 if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) { 841 841 return TCL_ERROR; 842 842 } 843 843 return TCL_OK; 844 844 } 845 845 if (strcmp(argv[1],"info") == 0) { 846 - char buf[400]; 847 - sprintf(buf, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n", 846 + Tcl_Obj *objPtr = Tcl_NewObj(); 847 + TclObjPrintf(NULL, objPtr, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n", 848 848 "total mallocs", total_mallocs, "total frees", total_frees, 849 849 "current packets allocated", current_malloc_packets, 850 850 "current bytes allocated", current_bytes_malloced, 851 851 "maximum packets allocated", maximum_malloc_packets, 852 852 "maximum bytes allocated", maximum_bytes_malloced); 853 - Tcl_SetResult(interp, buf, TCL_VOLATILE); 853 + Tcl_SetObjResult(interp, objPtr); 854 854 return TCL_OK; 855 855 } 856 856 if (strcmp(argv[1],"init") == 0) { 857 857 if (argc != 3) { 858 858 goto bad_suboption; 859 859 } 860 860 init_malloced_bodies = (strcmp(argv[2],"on") == 0);
Changes to generic/tclCmdAH.c.
6 6 * 7 7 * Copyright (c) 1987-1993 The Regents of the University of California. 8 8 * Copyright (c) 1994-1997 Sun Microsystems, Inc. 9 9 * 10 10 * See the file "license.terms" for information on usage and redistribution of 11 11 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 12 * 13 - * RCS: @(#) $Id: tclCmdAH.c,v 1.57.2.9 2005/09/12 19:12:27 dgp Exp $ 13 + * RCS: @(#) $Id: tclCmdAH.c,v 1.57.2.10 2005/09/15 20:58:39 dgp Exp $ 14 14 */ 15 15 16 16 #include "tclInt.h" 17 17 #include <locale.h> 18 18 19 19 #define NEW_FORMAT 1 20 20 ................................................................................ 183 183 } 184 184 185 185 match: 186 186 if (body != -1) { 187 187 armPtr = caseObjv[body - 1]; 188 188 result = Tcl_EvalObjEx(interp, caseObjv[body], 0); 189 189 if (result == TCL_ERROR) { 190 - char msg[100 + TCL_INTEGER_SPACE]; 191 - 192 - arg = TclGetString(armPtr); 193 - sprintf(msg, "\n (\"%.50s\" arm line %d)", arg, 194 - interp->errorLine); 195 - Tcl_AddObjErrorInfo(interp, msg, -1); 190 + TclFormatToErrorInfo(interp, "\n (\"%.50s\" arm line %d)", 191 + TclGetString(armPtr), interp->errorLine); 196 192 } 197 193 return result; 198 194 } 199 195 200 196 /* 201 197 * Nothing matched: return nothing. 202 198 */ ................................................................................ 249 245 result = Tcl_EvalObjEx(interp, objv[1], 0); 250 246 251 247 /* 252 248 * We disable catch in interpreters where the limit has been exceeded. 253 249 */ 254 250 255 251 if (Tcl_LimitExceeded(interp)) { 256 - char msg[32 + TCL_INTEGER_SPACE]; 257 - 258 - sprintf(msg, "\n (\"catch\" body line %d)", interp->errorLine); 259 - Tcl_AddErrorInfo(interp, msg); 252 + TclFormatToErrorInfo(interp, "\n (\"catch\" body line %d)", 253 + interp->errorLine); 260 254 return TCL_ERROR; 261 255 } 262 256 263 257 if (objc >= 3) { 264 258 if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL, 265 259 Tcl_GetObjResult(interp), 0)) { 266 260 Tcl_ResetResult(interp); ................................................................................ 659 653 * object when it decrements its refcount after eval'ing it. 660 654 */ 661 655 662 656 objPtr = Tcl_ConcatObj(objc-1, objv+1); 663 657 result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); 664 658 } 665 659 if (result == TCL_ERROR) { 666 - char msg[32 + TCL_INTEGER_SPACE]; 667 - 668 - sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine); 669 - Tcl_AddObjErrorInfo(interp, msg, -1); 660 + TclFormatToErrorInfo(interp,"\n (\"eval\" body line %d)", 661 + interp->errorLine); 670 662 } 671 663 return result; 672 664 } 673 665 674 666 /* 675 667 *---------------------------------------------------------------------- 676 668 * ................................................................................ 1625 1617 } 1626 1618 if (!value) { 1627 1619 break; 1628 1620 } 1629 1621 result = Tcl_EvalObjEx(interp, objv[4], 0); 1630 1622 if ((result != TCL_OK) && (result != TCL_CONTINUE)) { 1631 1623 if (result == TCL_ERROR) { 1632 - char msg[32 + TCL_INTEGER_SPACE]; 1633 - 1634 - sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine); 1635 - Tcl_AddErrorInfo(interp, msg); 1624 + TclFormatToErrorInfo(interp, "\n (\"for\" body line %d)", 1625 + interp->errorLine); 1636 1626 } 1637 1627 break; 1638 1628 } 1639 1629 result = Tcl_EvalObjEx(interp, objv[3], 0); 1640 1630 if (result == TCL_BREAK) { 1641 1631 break; 1642 1632 } else if (result != TCL_OK) { ................................................................................ 1842 1832 if (result != TCL_OK) { 1843 1833 if (result == TCL_CONTINUE) { 1844 1834 result = TCL_OK; 1845 1835 } else if (result == TCL_BREAK) { 1846 1836 result = TCL_OK; 1847 1837 break; 1848 1838 } else if (result == TCL_ERROR) { 1849 - char msg[32 + TCL_INTEGER_SPACE]; 1850 - 1851 - sprintf(msg, "\n (\"foreach\" body line %d)", 1852 - interp->errorLine); 1853 - Tcl_AddObjErrorInfo(interp, msg, -1); 1839 + TclFormatToErrorInfo(interp, 1840 + "\n (\"foreach\" body line %d)", interp->errorLine); 1854 1841 break; 1855 1842 } else { 1856 1843 break; 1857 1844 } 1858 1845 } 1859 1846 } 1860 1847 if (result == TCL_OK) {
Changes to generic/tclCmdIL.c.
12 12 * Copyright (c) 1998-1999 by Scriptics Corporation. 13 13 * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. 14 14 * Copyright (c) 2005 Donal K. Fellows. 15 15 * 16 16 * See the file "license.terms" for information on usage and redistribution of 17 17 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 18 18 * 19 - * RCS: @(#) $Id: tclCmdIL.c,v 1.70.2.8 2005/08/29 18:38:45 dgp Exp $ 19 + * RCS: @(#) $Id: tclCmdIL.c,v 1.70.2.9 2005/09/15 20:58:39 dgp Exp $ 20 20 */ 21 21 22 22 #include "tclInt.h" 23 23 #include "tclRegexp.h" 24 24 25 25 /* 26 26 * During execution of the "lsort" command, structures of the following type ................................................................................ 3415 3415 * their scale is sensible yet, but we at least perform the 3416 3416 * syntactic check here. 3417 3417 */ 3418 3418 3419 3419 for (j=0 ; j<sortInfo.indexc ; j++) { 3420 3420 if (TclGetIntForIndex(interp, indices[j], SORTIDX_END, 3421 3421 &sortInfo.indexv[j]) != TCL_OK) { 3422 - char buffer[TCL_INTEGER_SPACE]; 3423 - 3424 3422 if (sortInfo.indexc > 1) { 3425 3423 ckfree((char *) sortInfo.indexv); 3426 3424 } 3427 - sprintf(buffer, "%d", j); 3428 - Tcl_AddErrorInfo(interp, 3429 - "\n (-index option item number "); 3430 - Tcl_AddErrorInfo(interp, buffer); 3431 - Tcl_AddErrorInfo(interp, ")"); 3425 + TclFormatToErrorInfo(interp, 3426 + "\n (-index option item number %d)", j); 3432 3427 return TCL_ERROR; 3433 3428 } 3434 3429 } 3435 3430 break; 3436 3431 } 3437 3432 } 3438 3433 } ................................................................................ 4030 4025 * their scale is sensible yet, but we at least perform the 4031 4026 * syntactic check here. 4032 4027 */ 4033 4028 4034 4029 for (j=0 ; j<sortInfo.indexc ; j++) { 4035 4030 if (TclGetIntForIndex(interp, indices[j], SORTIDX_END, 4036 4031 &sortInfo.indexv[j]) != TCL_OK) { 4037 - char buffer[TCL_INTEGER_SPACE]; 4038 - 4039 4032 if (sortInfo.indexc > 1) { 4040 4033 ckfree((char *) sortInfo.indexv); 4041 4034 } 4042 - sprintf(buffer, "%d", j); 4043 - Tcl_AddErrorInfo(interp, 4044 - "\n (-index option item number "); 4045 - Tcl_AddErrorInfo(interp, buffer); 4046 - Tcl_AddErrorInfo(interp, ")"); 4035 + TclFormatToErrorInfo(interp, 4036 + "\n (-index option item number %d)", j); 4047 4037 return TCL_ERROR; 4048 4038 } 4049 4039 } 4050 4040 i++; 4051 4041 break; 4052 4042 } 4053 4043 case LSORT_INTEGER:
Changes to generic/tclCmdMZ.c.
11 11 * Copyright (c) 1998-2000 Scriptics Corporation. 12 12 * Copyright (c) 2002 ActiveState Corporation. 13 13 * Copyright (c) 2003 Donal K. Fellows. 14 14 * 15 15 * See the file "license.terms" for information on usage and redistribution of 16 16 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 17 17 * 18 - * RCS: @(#) $Id: tclCmdMZ.c,v 1.115.2.12 2005/08/29 18:38:45 dgp Exp $ 18 + * RCS: @(#) $Id: tclCmdMZ.c,v 1.115.2.13 2005/09/15 20:58:39 dgp Exp $ 19 19 */ 20 20 21 21 #include "tclInt.h" 22 22 #include "tclRegexp.h" 23 23 24 24 /* 25 25 *---------------------------------------------------------------------- ................................................................................ 2122 2122 * with back-division. [Bug #714106] 2123 2123 */ 2124 2124 2125 2125 Tcl_Obj *resultPtr; 2126 2126 2127 2127 length2 = length1 * count; 2128 2128 if ((length2 / count) != length1) { 2129 - char buf[TCL_INTEGER_SPACE+1]; 2130 - 2131 - sprintf(buf, "%d", INT_MAX); 2132 - Tcl_AppendResult(interp, 2133 - "string size overflow, must be less than ", 2134 - buf, (char *) NULL); 2129 + resultPtr = Tcl_NewObj(); 2130 + TclObjPrintf(NULL, resultPtr, 2131 + "string size overflow, must be less than %d", 2132 + INT_MAX); 2133 + Tcl_SetObjResult(interp, resultPtr); 2135 2134 return TCL_ERROR; 2136 2135 } 2137 2136 2138 2137 /* 2139 2138 * Include space for the NULL. 2140 2139 */ 2141 2140 ................................................................................ 2530 2529 Tcl_SwitchObjCmd(dummy, interp, objc, objv) 2531 2530 ClientData dummy; /* Not used. */ 2532 2531 Tcl_Interp *interp; /* Current interpreter. */ 2533 2532 int objc; /* Number of arguments. */ 2534 2533 Tcl_Obj *CONST objv[]; /* Argument objects. */ 2535 2534 { 2536 2535 int i,j, index, mode, foundmode, result, splitObjs, numMatchesSaved, noCase; 2536 + int patternLength; 2537 2537 char *pattern; 2538 2538 Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; 2539 2539 Tcl_Obj *CONST *savedObjv = objv; 2540 2540 Tcl_RegExp regExpr = NULL; 2541 2541 2542 2542 /* 2543 2543 * If you add options that make -e and -g not unique prefixes of -exact or ................................................................................ 2709 2709 } 2710 2710 2711 2711 for (i = 0; i < objc; i += 2) { 2712 2712 /* 2713 2713 * See if the pattern matches the string. 2714 2714 */ 2715 2715 2716 - pattern = TclGetString(objv[i]); 2716 + pattern = Tcl_GetStringFromObj(objv[i], &patternLength); 2717 2717 2718 2718 if ((i == objc - 2) && (*pattern == 'd') 2719 2719 && (strcmp(pattern, "default") == 0)) { 2720 2720 Tcl_Obj *emptyObj = NULL; 2721 2721 2722 2722 /* 2723 2723 * If either indexVarObj or matchVarObj are non-NULL, we're in ................................................................................ 2884 2884 result = Tcl_EvalObjEx(interp, objv[j], 0); 2885 2885 2886 2886 /* 2887 2887 * Generate an error message if necessary. 2888 2888 */ 2889 2889 2890 2890 if (result == TCL_ERROR) { 2891 - Tcl_Obj *msg = Tcl_NewStringObj("\n (\"", -1); 2892 - Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); 2893 - 2894 - Tcl_IncrRefCount(msg); 2895 - Tcl_IncrRefCount(errorLine); 2896 - TclAppendLimitedToObj(msg, pattern, -1, 50, ""); 2897 - Tcl_AppendToObj(msg,"\" arm line ", -1); 2898 - Tcl_AppendObjToObj(msg, errorLine); 2899 - Tcl_DecrRefCount(errorLine); 2900 - Tcl_AppendToObj(msg,")", -1); 2901 - TclAppendObjToErrorInfo(interp, msg); 2902 - Tcl_DecrRefCount(msg); 2891 + int limit = 50; 2892 + int overflow = (patternLength > limit); 2893 + TclFormatToErrorInfo(interp, "\n (\"%.*s%s\" arm line %d)", 2894 + (overflow ? limit : patternLength), pattern, 2895 + (overflow ? "..." : ""), interp->errorLine); 2903 2896 } 2904 2897 return result; 2905 2898 } 2906 2899 2907 2900 /* 2908 2901 *---------------------------------------------------------------------- 2909 2902 * ................................................................................ 3028 3021 } 3029 3022 if (!value) { 3030 3023 break; 3031 3024 } 3032 3025 result = Tcl_EvalObjEx(interp, objv[2], 0); 3033 3026 if ((result != TCL_OK) && (result != TCL_CONTINUE)) { 3034 3027 if (result == TCL_ERROR) { 3035 - char msg[32 + TCL_INTEGER_SPACE]; 3036 - 3037 - sprintf(msg, "\n (\"while\" body line %d)", 3028 + TclFormatToErrorInfo(interp, "\n (\"while\" body line %d)", 3038 3029 interp->errorLine); 3039 - Tcl_AddErrorInfo(interp, msg); 3040 3030 } 3041 3031 break; 3042 3032 } 3043 3033 } 3044 3034 if (result == TCL_BREAK) { 3045 3035 result = TCL_OK; 3046 3036 }
Changes to generic/tclDecls.h.
4 4 * Declarations of functions in the platform independent public Tcl API. 5 5 * 6 6 * Copyright (c) 1998-1999 by Scriptics Corporation. 7 7 * 8 8 * See the file "license.terms" for information on usage and redistribution 9 9 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10 10 * 11 - * RCS: @(#) $Id: tclDecls.h,v 1.107.2.7 2005/08/25 15:46:30 dgp Exp $ 11 + * RCS: @(#) $Id: tclDecls.h,v 1.107.2.8 2005/09/15 20:58:39 dgp Exp $ 12 12 */ 13 13 14 14 #ifndef _TCLDECLS 15 15 #define _TCLDECLS 16 16 17 17 #undef TCL_STORAGE_CLASS 18 18 #ifdef BUILD_tcl ................................................................................ 51 51 Tcl_Interp * interp, CONST char * name, 52 52 CONST char * version, int exact, 53 53 ClientData * clientDataPtr)); 54 54 #endif 55 55 #ifndef Tcl_Panic_TCL_DECLARED 56 56 #define Tcl_Panic_TCL_DECLARED 57 57 /* 2 */ 58 -EXTERN void Tcl_Panic _ANSI_ARGS_(TCL_VARARGS(CONST char *,format)); 58 +EXTERN void Tcl_Panic _ANSI_ARGS_((CONST char *format, ...)); 59 59 #endif 60 60 #ifndef Tcl_Alloc_TCL_DECLARED 61 61 #define Tcl_Alloc_TCL_DECLARED 62 62 /* 3 */ 63 63 EXTERN char * Tcl_Alloc _ANSI_ARGS_((unsigned int size)); 64 64 #endif 65 65 #ifndef Tcl_Free_TCL_DECLARED ................................................................................ 127 127 /* 14 */ 128 128 EXTERN int Tcl_AppendAllObjTypes _ANSI_ARGS_(( 129 129 Tcl_Interp * interp, Tcl_Obj * objPtr)); 130 130 #endif 131 131 #ifndef Tcl_AppendStringsToObj_TCL_DECLARED 132 132 #define Tcl_AppendStringsToObj_TCL_DECLARED 133 133 /* 15 */ 134 -EXTERN void Tcl_AppendStringsToObj _ANSI_ARGS_(TCL_VARARGS(Tcl_Obj *,objPtr)); 134 +EXTERN void Tcl_AppendStringsToObj _ANSI_ARGS_((Tcl_Obj *objPtr, ...)); 135 135 #endif 136 136 #ifndef Tcl_AppendToObj_TCL_DECLARED 137 137 #define Tcl_AppendToObj_TCL_DECLARED 138 138 /* 16 */ 139 139 EXTERN void Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj* objPtr, 140 140 CONST char* bytes, int length)); 141 141 #endif ................................................................................ 457 457 /* 69 */ 458 458 EXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp * interp, 459 459 CONST char * element)); 460 460 #endif 461 461 #ifndef Tcl_AppendResult_TCL_DECLARED 462 462 #define Tcl_AppendResult_TCL_DECLARED 463 463 /* 70 */ 464 -EXTERN void Tcl_AppendResult _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); 464 +EXTERN void Tcl_AppendResult _ANSI_ARGS_((Tcl_Interp *interp, ...)); 465 465 #endif 466 466 #ifndef Tcl_AsyncCreate_TCL_DECLARED 467 467 #define Tcl_AsyncCreate_TCL_DECLARED 468 468 /* 71 */ 469 469 EXTERN Tcl_AsyncHandler Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc * proc, 470 470 ClientData clientData)); 471 471 #endif ................................................................................ 1446 1446 #define Tcl_SetErrno_TCL_DECLARED 1447 1447 /* 227 */ 1448 1448 EXTERN void Tcl_SetErrno _ANSI_ARGS_((int err)); 1449 1449 #endif 1450 1450 #ifndef Tcl_SetErrorCode_TCL_DECLARED 1451 1451 #define Tcl_SetErrorCode_TCL_DECLARED 1452 1452 /* 228 */ 1453 -EXTERN void Tcl_SetErrorCode _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); 1453 +EXTERN void Tcl_SetErrorCode _ANSI_ARGS_((Tcl_Interp *interp, ...)); 1454 1454 #endif 1455 1455 #ifndef Tcl_SetMaxBlockTime_TCL_DECLARED 1456 1456 #define Tcl_SetMaxBlockTime_TCL_DECLARED 1457 1457 /* 229 */ 1458 1458 EXTERN void Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time * timePtr)); 1459 1459 #endif 1460 1460 #ifndef Tcl_SetPanicProc_TCL_DECLARED ................................................................................ 1649 1649 CONST char * frameName, CONST char * part1, 1650 1650 CONST char * part2, CONST char * localName, 1651 1651 int flags)); 1652 1652 #endif 1653 1653 #ifndef Tcl_VarEval_TCL_DECLARED 1654 1654 #define Tcl_VarEval_TCL_DECLARED 1655 1655 /* 260 */ 1656 -EXTERN int Tcl_VarEval _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); 1656 +EXTERN int Tcl_VarEval _ANSI_ARGS_((Tcl_Interp *interp, ...)); 1657 1657 #endif 1658 1658 #ifndef Tcl_VarTraceInfo_TCL_DECLARED 1659 1659 #define Tcl_VarTraceInfo_TCL_DECLARED 1660 1660 /* 261 */ 1661 1661 EXTERN ClientData Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp * interp, 1662 1662 CONST char * varName, int flags, 1663 1663 Tcl_VarTraceProc * procPtr, ................................................................................ 3529 3529 3530 3530 typedef struct TclStubs { 3531 3531 int magic; 3532 3532 struct TclStubHooks *hooks; 3533 3533 3534 3534 int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* name, CONST char* version, ClientData clientData)); /* 0 */ 3535 3535 CONST84_RETURN char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 1 */ 3536 - void (*tcl_Panic) _ANSI_ARGS_(TCL_VARARGS(CONST char *,format)); /* 2 */ 3536 + void (*tcl_Panic) _ANSI_ARGS_((CONST char *format, ...)); /* 2 */ 3537 3537 char * (*tcl_Alloc) _ANSI_ARGS_((unsigned int size)); /* 3 */ 3538 3538 void (*tcl_Free) _ANSI_ARGS_((char * ptr)); /* 4 */ 3539 3539 char * (*tcl_Realloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 5 */ 3540 3540 char * (*tcl_DbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char * file, int line)); /* 6 */ 3541 3541 int (*tcl_DbCkfree) _ANSI_ARGS_((char * ptr, CONST char * file, int line)); /* 7 */ 3542 3542 char * (*tcl_DbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, CONST char * file, int line)); /* 8 */ 3543 3543 #if !defined(__WIN32__) /* UNIX */ ................................................................................ 3552 3552 #ifdef __WIN32__ 3553 3553 void *reserved10; 3554 3554 #endif /* __WIN32__ */ 3555 3555 void (*tcl_SetTimer) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 11 */ 3556 3556 void (*tcl_Sleep) _ANSI_ARGS_((int ms)); /* 12 */ 3557 3557 int (*tcl_WaitForEvent) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 13 */ 3558 3558 int (*tcl_AppendAllObjTypes) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 14 */ 3559 - void (*tcl_AppendStringsToObj) _ANSI_ARGS_(TCL_VARARGS(Tcl_Obj *,objPtr)); /* 15 */ 3559 + void (*tcl_AppendStringsToObj) _ANSI_ARGS_((Tcl_Obj *objPtr, ...)); /* 15 */ 3560 3560 void (*tcl_AppendToObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 16 */ 3561 3561 Tcl_Obj * (*tcl_ConcatObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 17 */ 3562 3562 int (*tcl_ConvertToType) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_ObjType * typePtr)); /* 18 */ 3563 3563 void (*tcl_DbDecrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 19 */ 3564 3564 void (*tcl_DbIncrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 20 */ 3565 3565 int (*tcl_DbIsShared) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 21 */ 3566 3566 Tcl_Obj * (*tcl_DbNewBooleanObj) _ANSI_ARGS_((int boolValue, CONST char * file, int line)); /* 22 */ ................................................................................ 3607 3607 void (*tcl_SetLongObj) _ANSI_ARGS_((Tcl_Obj * objPtr, long longValue)); /* 63 */ 3608 3608 void (*tcl_SetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 64 */ 3609 3609 void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 65 */ 3610 3610 void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message)); /* 66 */ 3611 3611 void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message, int length)); /* 67 */ 3612 3612 void (*tcl_AllowExceptions) _ANSI_ARGS_((Tcl_Interp * interp)); /* 68 */ 3613 3613 void (*tcl_AppendElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * element)); /* 69 */ 3614 - void (*tcl_AppendResult) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 70 */ 3614 + void (*tcl_AppendResult) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 70 */ 3615 3615 Tcl_AsyncHandler (*tcl_AsyncCreate) _ANSI_ARGS_((Tcl_AsyncProc * proc, ClientData clientData)); /* 71 */ 3616 3616 void (*tcl_AsyncDelete) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 72 */ 3617 3617 int (*tcl_AsyncInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int code)); /* 73 */ 3618 3618 void (*tcl_AsyncMark) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 74 */ 3619 3619 int (*tcl_AsyncReady) _ANSI_ARGS_((void)); /* 75 */ 3620 3620 void (*tcl_BackgroundError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 76 */ 3621 3621 char (*tcl_Backslash) _ANSI_ARGS_((CONST char * src, int * readPtr)); /* 77 */ ................................................................................ 3785 3785 int (*tcl_ServiceAll) _ANSI_ARGS_((void)); /* 221 */ 3786 3786 int (*tcl_ServiceEvent) _ANSI_ARGS_((int flags)); /* 222 */ 3787 3787 void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */ 3788 3788 void (*tcl_SetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan, int sz)); /* 224 */ 3789 3789 int (*tcl_SetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, CONST char * newValue)); /* 225 */ 3790 3790 int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST Tcl_CmdInfo * infoPtr)); /* 226 */ 3791 3791 void (*tcl_SetErrno) _ANSI_ARGS_((int err)); /* 227 */ 3792 - void (*tcl_SetErrorCode) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 228 */ 3792 + void (*tcl_SetErrorCode) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 228 */ 3793 3793 void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 229 */ 3794 3794 void (*tcl_SetPanicProc) _ANSI_ARGS_((Tcl_PanicProc * panicProc)); /* 230 */ 3795 3795 int (*tcl_SetRecursionLimit) _ANSI_ARGS_((Tcl_Interp * interp, int depth)); /* 231 */ 3796 3796 void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * result, Tcl_FreeProc * freeProc)); /* 232 */ 3797 3797 int (*tcl_SetServiceMode) _ANSI_ARGS_((int mode)); /* 233 */ 3798 3798 void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * errorObjPtr)); /* 234 */ 3799 3799 void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 235 */ ................................................................................ 3817 3817 int (*tcl_UnsetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 253 */ 3818 3818 int (*tcl_UnsetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 254 */ 3819 3819 void (*tcl_UntraceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 255 */ 3820 3820 void (*tcl_UntraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 256 */ 3821 3821 void (*tcl_UpdateLinkedVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 257 */ 3822 3822 int (*tcl_UpVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * varName, CONST char * localName, int flags)); /* 258 */ 3823 3823 int (*tcl_UpVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * part1, CONST char * part2, CONST char * localName, int flags)); /* 259 */ 3824 - int (*tcl_VarEval) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 260 */ 3824 + int (*tcl_VarEval) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 260 */ 3825 3825 ClientData (*tcl_VarTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 261 */ 3826 3826 ClientData (*tcl_VarTraceInfo2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 262 */ 3827 3827 int (*tcl_Write) _ANSI_ARGS_((Tcl_Channel chan, CONST char * s, int slen)); /* 263 */ 3828 3828 void (*tcl_WrongNumArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], CONST char * message)); /* 264 */ 3829 3829 int (*tcl_DumpActiveMemory) _ANSI_ARGS_((CONST char * fileName)); /* 265 */ 3830 3830 void (*tcl_ValidateAllMemory) _ANSI_ARGS_((CONST char * file, int line)); /* 266 */ 3831 3831 void (*tcl_AppendResultVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 267 */
Changes to generic/tclDictObj.c.
5 5 * type and its accessor command. 6 6 * 7 7 * Copyright (c) 2002 by Donal K. Fellows. 8 8 * 9 9 * See the file "license.terms" for information on usage and redistribution 10 10 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 11 11 * 12 - * RCS: @(#) $Id: tclDictObj.c,v 1.27.2.4 2005/08/18 18:18:45 dgp Exp $ 12 + * RCS: @(#) $Id: tclDictObj.c,v 1.27.2.5 2005/09/15 20:58:39 dgp Exp $ 13 13 */ 14 14 15 15 #include "tclInt.h" 16 16 #include "tommath.h" 17 17 18 18 /* 19 19 * Forward declaration. ................................................................................ 2358 2358 result = Tcl_EvalObjEx(interp, scriptObj, 0); 2359 2359 if (result == TCL_CONTINUE) { 2360 2360 result = TCL_OK; 2361 2361 } else if (result != TCL_OK) { 2362 2362 if (result == TCL_BREAK) { 2363 2363 result = TCL_OK; 2364 2364 } else if (result == TCL_ERROR) { 2365 - char msg[32 + TCL_INTEGER_SPACE]; 2366 - 2367 - sprintf(msg, "\n (\"dict for\" body line %d)", 2368 - interp->errorLine); 2369 - Tcl_AddObjErrorInfo(interp, msg, -1); 2365 + TclFormatToErrorInfo(interp, 2366 + "\n (\"dict for\" body line %d)", interp->errorLine); 2370 2367 } 2371 2368 break; 2372 2369 } 2373 2370 2374 2371 Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); 2375 2372 } 2376 2373 ................................................................................ 2541 2538 FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES 2542 2539 }; 2543 2540 Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; 2544 2541 Tcl_Obj **varv, *keyObj, *valueObj, *resultObj, *boolObj; 2545 2542 Tcl_DictSearch search; 2546 2543 int index, varc, done, result, satisfied; 2547 2544 char *pattern; 2548 - char msg[32 + TCL_INTEGER_SPACE]; 2549 2545 2550 2546 if (objc < 4) { 2551 2547 Tcl_WrongNumArgs(interp, 2, objv, "dictionary filterType ..."); 2552 2548 return TCL_ERROR; 2553 2549 } 2554 2550 if (Tcl_GetIndexFromObj(interp, objv[3], filters, "filterType", 2555 2551 0, &index) != TCL_OK) { ................................................................................ 2706 2702 */ 2707 2703 Tcl_ResetResult(interp); 2708 2704 Tcl_DictObjDone(&search); 2709 2705 case TCL_CONTINUE: 2710 2706 result = TCL_OK; 2711 2707 break; 2712 2708 case TCL_ERROR: 2713 - sprintf(msg, "\n (\"dict filter\" script line %d)", 2709 + TclFormatToErrorInfo(interp, 2710 + "\n (\"dict filter\" script line %d)", 2714 2711 interp->errorLine); 2715 - Tcl_AddObjErrorInfo(interp, msg, -1); 2716 2712 default: 2717 2713 goto abnormalResult; 2718 2714 } 2719 2715 2720 2716 TclDecrRefCount(keyObj); 2721 2717 TclDecrRefCount(valueObj); 2722 2718
Changes to generic/tclExecute.c.
8 8 * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. 9 9 * Copyright (c) 2002-2005 by Miguel Sofer. 10 10 * Copyright (c) 2005 by Donal K. Fellows. 11 11 * 12 12 * See the file "license.terms" for information on usage and redistribution of 13 13 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 14 14 * 15 - * RCS: @(#) $Id: tclExecute.c,v 1.167.2.38 2005/08/25 21:21:33 dgp Exp $ 15 + * RCS: @(#) $Id: tclExecute.c,v 1.167.2.39 2005/09/15 20:58:39 dgp Exp $ 16 16 */ 17 17 18 18 #include "tclInt.h" 19 19 #include "tclCompile.h" 20 20 #include "tommath.h" 21 21 22 22 #include <math.h> ................................................................................ 6889 6889 Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL); 6890 6890 } else { 6891 6891 s = "floating-point value too large to represent"; 6892 6892 Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); 6893 6893 Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL); 6894 6894 } 6895 6895 } else { 6896 - char msg[64 + TCL_INTEGER_SPACE]; 6897 - 6898 - sprintf(msg, "unknown floating-point error, errno = %d", errno); 6899 - Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); 6900 - Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL); 6896 + Tcl_Obj *objPtr = Tcl_NewObj(); 6897 + TclObjPrintf(NULL, objPtr, 6898 + "unknown floating-point error, errno = %d", errno); 6899 + Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", 6900 + Tcl_GetString(objPtr), (char *) NULL); 6901 + Tcl_SetObjResult(interp, objPtr); 6901 6902 } 6902 6903 } 6903 6904 6904 6905 #ifdef TCL_COMPILE_STATS 6905 6906 /* 6906 6907 *---------------------------------------------------------------------- 6907 6908 *
Changes to generic/tclIORChan.c.
11 11 * See TIP #219 for the specification of this functionality. 12 12 * 13 13 * Copyright (c) 2004-2005 ActiveState, a divison of Sophos 14 14 * 15 15 * See the file "license.terms" for information on usage and redistribution 16 16 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 17 17 * 18 - * RCS: @(#) $Id: tclIORChan.c,v 1.1.2.4 2005/09/12 14:47:16 dgp Exp $ 18 + * RCS: @(#) $Id: tclIORChan.c,v 1.1.2.5 2005/09/15 20:58:39 dgp Exp $ 19 19 */ 20 20 21 21 #include <tclInt.h> 22 22 #include <tclIO.h> 23 23 #include <assert.h> 24 24 25 25 #ifndef EINVAL ................................................................................ 1719 1719 Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ 1720 1720 return res; 1721 1721 } 1722 1722 1723 1723 if ((listc % 2) == 1) { 1724 1724 /* Odd number of elements is wrong. 1725 1725 */ 1726 - 1727 - char buf [20]; 1728 - 1729 - sprintf (buf, "%d", listc); 1730 - Tcl_ResetResult (interp); 1731 - Tcl_AppendResult (interp, 1732 - "Expected list with even number of elements, got ", 1733 - buf, (listc == 1 ? " element" : " elements"), 1734 - " instead", (char*) NULL); 1735 - 1726 + Tcl_Obj *objPtr = Tcl_NewObj(); 1727 + Tcl_ResetResult(interp); 1728 + TclObjPrintf(NULL, objPtr, "Expected list with even number of " 1729 + "elements, got %d element%s instead", listc, 1730 + (listc == 1 ? "" : "s")); 1731 + Tcl_SetObjResult(interp, objPtr); 1736 1732 Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ 1737 1733 return TCL_ERROR; 1738 1734 } 1739 1735 1740 1736 1741 1737 { 1742 1738 int len; ................................................................................ 1961 1957 */ 1962 1958 1963 1959 #ifdef TCL_THREADS 1964 1960 TCL_DECLARE_MUTEX (rcCounterMutex) 1965 1961 #endif 1966 1962 static unsigned long rcCounter = 0; 1967 1963 1968 - char channelName [50]; 1969 - Tcl_Obj* res = Tcl_NewStringObj ("rc", -1); 1964 + Tcl_Obj* res = Tcl_NewObj (); 1970 1965 1971 1966 #ifdef TCL_THREADS 1972 1967 Tcl_MutexLock (&rcCounterMutex); 1973 1968 #endif 1974 1969 1975 - sprintf (channelName, "%lu", (unsigned long) rcCounter); 1970 + TclObjPrintf(NULL, res, "rc%lu", rcCounter); 1976 1971 rcCounter ++; 1977 1972 1978 1973 #ifdef TCL_THREADS 1979 1974 Tcl_MutexUnlock (&rcCounterMutex); 1980 1975 #endif 1981 1976 1982 - Tcl_AppendStringsToObj (res, channelName, (char*) NULL); 1983 1977 return res; 1984 1978 } 1985 1979 1986 1980 1987 1981 static void 1988 1982 RcFree (rcPtr) 1989 1983 ReflectingChannel* rcPtr;
Changes to generic/tclIOUtil.c.
13 13 * Copyright (c) 1991-1994 The Regents of the University of California. 14 14 * Copyright (c) 1994-1997 Sun Microsystems, Inc. 15 15 * Copyright (c) 2001-2004 Vincent Darley. 16 16 * 17 17 * See the file "license.terms" for information on usage and redistribution of 18 18 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 19 19 * 20 - * RCS: @(#) $Id: tclIOUtil.c,v 1.113.2.6 2005/09/09 18:48:40 dgp Exp $ 20 + * RCS: @(#) $Id: tclIOUtil.c,v 1.113.2.7 2005/09/15 20:58:39 dgp Exp $ 21 21 */ 22 22 23 23 #include "tclInt.h" 24 24 #ifdef __WIN32__ 25 25 # include "tclWinInt.h" 26 26 #endif 27 27 #include "tclFileSystem.h" ................................................................................ 1808 1808 1809 1809 if (result == TCL_RETURN) { 1810 1810 result = TclUpdateReturnInfo(iPtr); 1811 1811 } else if (result == TCL_ERROR) { 1812 1812 /* 1813 1813 * Record information telling where the error occurred. 1814 1814 */ 1815 - 1816 - Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); 1817 - Tcl_Obj *msg = Tcl_NewStringObj("\n (file \"", -1); 1818 1815 CONST char *pathString = Tcl_GetStringFromObj(pathPtr, &length); 1819 - Tcl_IncrRefCount(msg); 1820 - Tcl_IncrRefCount(errorLine); 1821 - TclAppendLimitedToObj(msg, pathString, length, 150, ""); 1822 - Tcl_AppendToObj(msg, "\" line ", -1); 1823 - Tcl_AppendObjToObj(msg, errorLine); 1824 - Tcl_DecrRefCount(errorLine); 1825 - Tcl_AppendToObj(msg, ")", -1); 1826 - TclAppendObjToErrorInfo(interp, msg); 1827 - Tcl_DecrRefCount(msg); 1816 + int limit = 150; 1817 + int overflow = (length > limit); 1818 + 1819 + TclFormatToErrorInfo(interp, "\n (file \"%.*s%s\" line %d)", 1820 + (overflow ? limit : length), pathString, 1821 + (overflow ? "..." : ""), interp->errorLine); 1828 1822 } 1829 1823 1830 1824 end: 1831 1825 Tcl_DecrRefCount(objPtr); 1832 1826 return result; 1833 1827 } 1834 1828
Changes to generic/tclInt.h.
8 8 * Copyright (c) 1994-1998 Sun Microsystems, Inc. 9 9 * Copyright (c) 1998-19/99 by Scriptics Corporation. 10 10 * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. 11 11 * 12 12 * See the file "license.terms" for information on usage and redistribution of 13 13 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 14 14 * 15 - * RCS: @(#) $Id: tclInt.h,v 1.202.2.38 2005/09/09 18:48:40 dgp Exp $ 15 + * RCS: @(#) $Id: tclInt.h,v 1.202.2.39 2005/09/15 20:58:39 dgp Exp $ 16 16 */ 17 17 18 18 #ifndef _TCLINT 19 19 #define _TCLINT 20 20 21 21 /* 22 22 * Some numerics configuration options ................................................................................ 2034 2034 MODULE_SCOPE void TclFinalizeNotifier(void); 2035 2035 MODULE_SCOPE void TclFinalizeObjects(void); 2036 2036 MODULE_SCOPE void TclFinalizePreserve(void); 2037 2037 MODULE_SCOPE void TclFinalizeSynchronization(void); 2038 2038 MODULE_SCOPE void TclFinalizeThreadData(void); 2039 2039 MODULE_SCOPE double TclFloor(mp_int* a); 2040 2040 MODULE_SCOPE void TclFormatNaN(double value, char* buffer); 2041 -MODULE_SCOPE int TclFormatObj TCL_VARARGS(Tcl_Interp *, arg1); 2041 +MODULE_SCOPE int TclFormatObj(Tcl_Interp *interp, Tcl_Obj *objPtr, 2042 + CONST char *format, ...); 2043 +MODULE_SCOPE int TclFormatToErrorInfo(Tcl_Interp *interp, 2044 + CONST char *format, ...); 2042 2045 MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, 2043 2046 CONST char *attributeName, int *indexPtr); 2044 2047 MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp); 2045 2048 MODULE_SCOPE int TclGetEncodingFromObj(Tcl_Interp *interp, 2046 2049 Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr); 2047 2050 MODULE_SCOPE int TclGetNamespaceFromObj(Tcl_Interp *interp, 2048 2051 Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); ................................................................................ 2092 2095 Tcl_Obj* valuePtr); 2093 2096 MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, 2094 2097 Tcl_Obj *CONST objv[], Tcl_Obj **optionsPtrPtr, 2095 2098 int *codePtr, int *levelPtr); 2096 2099 MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp, 2097 2100 int objc, Tcl_Obj *CONST objv[], 2098 2101 Tcl_Namespace *nsPtr, int flags); 2099 -MODULE_SCOPE int TclObjPrintf TCL_VARARGS(Tcl_Interp *, arg1); 2102 +MODULE_SCOPE int TclObjPrintf(Tcl_Interp *interp, Tcl_Obj *objPtr, 2103 + CONST char *format, ...); 2100 2104 MODULE_SCOPE int TclParseBackslash(CONST char *src, 2101 2105 int numBytes, int *readPtr, char *dst); 2102 2106 MODULE_SCOPE int TclParseHex(CONST char *src, int numBytes, 2103 2107 Tcl_UniChar *resultPtr); 2104 2108 MODULE_SCOPE int TclParseNumber(Tcl_Interp* interp, Tcl_Obj* objPtr, 2105 2109 CONST char* type, CONST char* string, 2106 2110 size_t length, CONST char** endPtrPtr, int flags); ................................................................................ 2156 2160 MODULE_SCOPE ClientData TclpGetNativeCwd(ClientData clientData); 2157 2161 MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep; 2158 2162 MODULE_SCOPE Tcl_Obj* TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, 2159 2163 int linkType); 2160 2164 MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr); 2161 2165 MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr, 2162 2166 Tcl_PathPart portion); 2163 -MODULE_SCOPE void TclpPanic TCL_VARARGS(CONST char *, format); 2167 +MODULE_SCOPE void TclpPanic(CONST char *format, ...); 2164 2168 MODULE_SCOPE char * TclpReadlink(CONST char *fileName, 2165 2169 Tcl_DString *linkPtr); 2166 2170 MODULE_SCOPE void TclpReleaseFile(TclFile file); 2167 2171 MODULE_SCOPE void TclpSetInterfaces(void); 2168 2172 MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp); 2169 2173 MODULE_SCOPE void TclpUnloadFile(Tcl_LoadHandle loadHandle); 2170 2174 MODULE_SCOPE VOID * TclpThreadDataKeyGet(Tcl_ThreadDataKey *keyPtr);
Changes to generic/tclMain.c.
6 6 * Copyright (c) 1988-1994 The Regents of the University of California. 7 7 * Copyright (c) 1994-1997 Sun Microsystems, Inc. 8 8 * Copyright (c) 2000 Ajuba Solutions. 9 9 * 10 10 * See the file "license.terms" for information on usage and redistribution of 11 11 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 12 * 13 - * RCS: @(#) $Id: tclMain.c,v 1.30.2.1 2005/08/02 18:16:01 dgp Exp $ 13 + * RCS: @(#) $Id: tclMain.c,v 1.30.2.2 2005/09/15 20:58:39 dgp Exp $ 14 14 */ 15 15 16 16 #include "tclInt.h" 17 17 18 18 #undef TCL_STORAGE_CLASS 19 19 #define TCL_STORAGE_CLASS DLLEXPORT 20 20 ................................................................................ 651 651 if (commandPtr != NULL) { 652 652 Tcl_DecrRefCount(commandPtr); 653 653 } 654 654 655 655 /* 656 656 * Rather than calling exit, invoke the "exit" command so that users can 657 657 * replace "exit" with some other command to do additional cleanup on 658 - * exit. The Tcl_Eval call should never return. 658 + * exit. The Tcl_EvalObjEx call should never return. 659 659 */ 660 660 661 661 if (!Tcl_InterpDeleted(interp)) { 662 662 if (!Tcl_LimitExceeded(interp)) { 663 - char buffer[TCL_INTEGER_SPACE + 5]; 664 - 665 - sprintf(buffer, "exit %d", exitCode); 666 - Tcl_Eval(interp, buffer); 663 + Tcl_Obj *cmd = Tcl_NewObj(); 664 + TclObjPrintf(NULL, cmd, "exit %d", exitCode); 665 + Tcl_IncrRefCount(cmd); 666 + Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); 667 + Tcl_DecrRefCount(cmd); 667 668 } 668 669 669 670 /* 670 - * If Tcl_Eval returns, trying to eval [exit], something unusual is 671 - * happening. Maybe interp has been deleted; maybe [exit] was 671 + * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual 672 + * is happening. Maybe interp has been deleted; maybe [exit] was 672 673 * redefined, maybe we've blown up because of an exceeded limit. We 673 674 * still want to cleanup and exit. 674 675 */ 675 676 676 677 if (!Tcl_InterpDeleted(interp)) { 677 678 Tcl_DeleteInterp(interp); 678 679 }
Changes to generic/tclNamesp.c.
17 17 * Michael J. McLennan 18 18 * Bell Labs Innovations for Lucent Technologies 19 19 * [email protected] 20 20 * 21 21 * See the file "license.terms" for information on usage and redistribution 22 22 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 23 23 * 24 - * RCS: @(#) $Id: tclNamesp.c,v 1.66.2.9 2005/08/29 18:38:45 dgp Exp $ 24 + * RCS: @(#) $Id: tclNamesp.c,v 1.66.2.10 2005/09/15 20:58:39 dgp Exp $ 25 25 */ 26 26 27 27 #include "tclInt.h" 28 28 29 29 /* 30 30 * Initial size of stack allocated space for tail list - used when resetting 31 31 * shadowed command references in the functin: TclResetShadowedCmdRefs. ................................................................................ 3399 3399 */ 3400 3400 3401 3401 objPtr = Tcl_ConcatObj(objc-3, objv+3); 3402 3402 result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); 3403 3403 } 3404 3404 3405 3405 if (result == TCL_ERROR) { 3406 - Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); 3407 - Tcl_Obj *msg = Tcl_NewStringObj("\n (in namespace eval \"", -1); 3408 - Tcl_IncrRefCount(errorLine); 3409 - Tcl_IncrRefCount(msg); 3410 - TclAppendLimitedToObj(msg, namespacePtr->fullName, -1, 200, ""); 3411 - Tcl_AppendToObj(msg, "\" script line ", -1); 3412 - Tcl_AppendObjToObj(msg, errorLine); 3413 - Tcl_DecrRefCount(errorLine); 3414 - Tcl_AppendToObj(msg, ")", -1); 3415 - TclAppendObjToErrorInfo(interp, msg); 3416 - Tcl_DecrRefCount(msg); 3406 + int length = strlen(namespacePtr->fullName); 3407 + int limit = 200; 3408 + int overflow = (length > limit); 3409 + 3410 + TclFormatToErrorInfo(interp, 3411 + "\n (in namespace eval \"%.*s%s\" script line %d)", 3412 + (overflow ? limit : length), namespacePtr->fullName, 3413 + (overflow ? "..." : ""), interp->errorLine); 3417 3414 } 3418 3415 3419 3416 /* 3420 3417 * Restore the previous "current" namespace. 3421 3418 */ 3422 3419 3423 3420 TclPopStackFrame(interp); ................................................................................ 3812 3809 concatObjv[1] = listPtr; 3813 3810 cmdObjPtr = Tcl_ConcatObj(2, concatObjv); 3814 3811 result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT); 3815 3812 Tcl_DecrRefCount(listPtr); /* we're done with the list object */ 3816 3813 } 3817 3814 3818 3815 if (result == TCL_ERROR) { 3819 - Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); 3820 - Tcl_Obj *msg = Tcl_NewStringObj("\n (in namespace inscope \"", -1); 3816 + int length = strlen(namespacePtr->fullName); 3817 + int limit = 200; 3818 + int overflow = (length > limit); 3821 3819 3822 - Tcl_IncrRefCount(errorLine); 3823 - Tcl_IncrRefCount(msg); 3824 - TclAppendLimitedToObj(msg, namespacePtr->fullName, -1, 200, ""); 3825 - Tcl_AppendToObj(msg, "\" script line ", -1); 3826 - Tcl_AppendObjToObj(msg, errorLine); 3827 - Tcl_DecrRefCount(errorLine); 3828 - Tcl_AppendToObj(msg, ")", -1); 3829 - TclAppendObjToErrorInfo(interp, msg); 3830 - Tcl_DecrRefCount(msg); 3820 + TclFormatToErrorInfo(interp, 3821 + "\n (in namespace inscope \"%.*s%s\" script line %d)", 3822 + (overflow ? limit : length), namespacePtr->fullName, 3823 + (overflow ? "..." : ""), interp->errorLine); 3831 3824 } 3832 3825 3833 3826 /* 3834 3827 * Restore the previous "current" namespace. 3835 3828 */ 3836 3829 3837 3830 TclPopStackFrame(interp);
Changes to generic/tclPanic.c.
8 8 * Copyright (c) 1988-1993 The Regents of the University of California. 9 9 * Copyright (c) 1994 Sun Microsystems, Inc. 10 10 * Copyright (c) 1998-1999 by Scriptics Corporation. 11 11 * 12 12 * See the file "license.terms" for information on usage and redistribution of 13 13 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 14 14 * 15 - * RCS: @(#) $Id: tclPanic.c,v 1.5.2.1 2005/08/02 18:16:04 dgp Exp $ 15 + * RCS: @(#) $Id: tclPanic.c,v 1.5.2.2 2005/09/15 20:58:40 dgp Exp $ 16 16 */ 17 17 18 18 #include "tclInt.h" 19 19 20 20 /* 21 21 * The panicProc variable contains a pointer to an application specific panic 22 22 * procedure. ................................................................................ 116 116 * 117 117 * Side effects: 118 118 * The process dies, entering the debugger if possible. 119 119 * 120 120 *---------------------------------------------------------------------- 121 121 */ 122 122 123 - /* VARARGS ARGSUSED */ 123 + /* ARGSUSED */ 124 124 void 125 -Tcl_Panic TCL_VARARGS_DEF(CONST char *,arg1) 125 +Tcl_Panic(CONST char *format, ...) 126 126 { 127 127 va_list argList; 128 - CONST char *format; 129 128 130 - format = TCL_VARARGS_START(CONST char *,arg1,argList); 129 + va_start(argList, format); 131 130 Tcl_PanicVA(format, argList); 132 131 va_end (argList); 133 132 } 134 133 135 134 /* 136 135 * Local Variables: 137 136 * mode: c 138 137 * c-basic-offset: 4 139 138 * fill-column: 78 140 139 * End: 141 140 */
Changes to generic/tclProc.c.
6 6 * 7 7 * Copyright (c) 1987-1993 The Regents of the University of California. 8 8 * Copyright (c) 1994-1998 Sun Microsystems, Inc. 9 9 * 10 10 * See the file "license.terms" for information on usage and redistribution of 11 11 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 12 * 13 - * RCS: @(#) $Id: tclProc.c,v 1.66.2.6 2005/08/19 21:55:21 dgp Exp $ 13 + * RCS: @(#) $Id: tclProc.c,v 1.66.2.7 2005/09/15 20:58:40 dgp Exp $ 14 14 */ 15 15 16 16 #include "tclInt.h" 17 17 #include "tclCompile.h" 18 18 19 19 /* 20 20 * Prototypes for static functions in this file ................................................................................ 333 333 result = Tcl_SplitList(interp, args, &numArgs, &argArray); 334 334 if (result != TCL_OK) { 335 335 goto procError; 336 336 } 337 337 338 338 if (precompiled) { 339 339 if (numArgs > procPtr->numArgs) { 340 - char buf[40 + TCL_INTEGER_SPACE + TCL_INTEGER_SPACE]; 341 - sprintf(buf, "%d entries, precompiled header expects %d", 342 - numArgs, procPtr->numArgs); 343 - Tcl_AppendResult(interp, "procedure \"", procName, 344 - "\": arg list contains ", buf, NULL); 340 + Tcl_Obj *objPtr = Tcl_NewObj(); 341 + TclObjPrintf(NULL, objPtr, 342 + "procedure \"%s\": arg list contains %d entries, " 343 + "precompiled header expects %d", procName, numArgs, 344 + procPtr->numArgs); 345 + Tcl_SetObjResult(interp, objPtr); 345 346 goto procError; 346 347 } 347 348 localPtr = procPtr->firstLocalPtr; 348 349 } else { 349 350 procPtr->numArgs = numArgs; 350 351 procPtr->numCompiledLocals = numArgs; 351 352 } ................................................................................ 424 425 if ((localPtr->nameLength != nameLength) 425 426 || (strcmp(localPtr->name, fieldValues[0])) 426 427 || (localPtr->frameIndex != i) 427 428 || ((localPtr->flags & ~VAR_UNDEFINED) 428 429 != (VAR_SCALAR | VAR_ARGUMENT)) 429 430 || (localPtr->defValuePtr == NULL && fieldCount == 2) 430 431 || (localPtr->defValuePtr != NULL && fieldCount != 2)) { 431 - char buf[40 + TCL_INTEGER_SPACE]; 432 - 432 + Tcl_Obj *objPtr = Tcl_NewObj(); 433 + TclObjPrintf(NULL, objPtr, 434 + "procedure \"%s\": formal parameter %d is " 435 + "inconsistent with precompiled body", procName, i); 436 + Tcl_SetObjResult(interp, objPtr); 433 437 ckfree((char *) fieldValues); 434 - sprintf(buf, "%d is inconsistent with precompiled body", i); 435 - Tcl_AppendResult(interp, "procedure \"", procName, 436 - "\": formal parameter ", buf, (char *) NULL); 437 438 goto procError; 438 439 } 439 440 440 441 /* 441 442 * compare the default value if any 442 443 */ 443 444 444 445 if (localPtr->defValuePtr != NULL) { 445 446 int tmpLength; 446 447 char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr, 447 448 &tmpLength); 448 449 if ((valueLength != tmpLength) || 449 450 strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) { 450 - Tcl_AppendResult(interp, "procedure \"", procName, 451 - "\": formal parameter \"", fieldValues[0], 452 - "\" has default value inconsistent with ", 453 - "precompiled body", (char *) NULL); 451 + Tcl_Obj *objPtr = Tcl_NewObj(); 452 + 453 + TclObjPrintf(NULL, objPtr, 454 + "procedure \"%s\": formal parameter \"%s\" has " 455 + "default value inconsistent with precompiled body", 456 + procName, fieldValues[0]); 457 + Tcl_SetObjResult(interp, objPtr); 454 458 ckfree((char *) fieldValues); 455 459 goto procError; 456 460 } 457 461 if ((i == numArgs - 1) 458 462 && (localPtr->nameLength == 4) 459 463 && (localPtr->name[0] == 'a') 460 464 && (strcmp(localPtr->name, "args") == 0)) { ................................................................................ 814 818 815 819 Tcl_Obj *objPtr; 816 820 817 821 objPtr = Tcl_ConcatObj(objc, objv); 818 822 result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); 819 823 } 820 824 if (result == TCL_ERROR) { 821 - char msg[32 + TCL_INTEGER_SPACE]; 822 - sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine); 823 - Tcl_AddObjErrorInfo(interp, msg, -1); 825 + TclFormatToErrorInfo(interp, "\n (\"uplevel\" body line %d)", 826 + interp->errorLine); 824 827 } 825 828 826 829 /* 827 830 * Restore the variable frame, and return. 828 831 */ 829 832 830 833 iPtr->varFramePtr = savedVarFramePtr; ................................................................................ 1492 1495 TclPopStackFrame(interp); 1493 1496 } 1494 1497 1495 1498 iPtr->compiledProcPtr = saveProcPtr; 1496 1499 1497 1500 if (result != TCL_OK) { 1498 1501 if (result == TCL_ERROR) { 1499 - Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); 1500 - Tcl_Obj *message = 1501 - Tcl_NewStringObj("\n (compiling ", -1); 1502 + int length = strlen(procName); 1503 + int limit = 50; 1504 + int overflow = (length > limit); 1502 1505 1503 - Tcl_IncrRefCount(message); 1504 - Tcl_AppendStringsToObj(message, description, " \"", NULL); 1505 - TclAppendLimitedToObj(message, procName, -1, 50, NULL); 1506 - Tcl_AppendToObj(message, "\", line ", -1); 1507 - Tcl_AppendObjToObj(message, errorLine); 1508 - Tcl_DecrRefCount(errorLine); 1509 - Tcl_AppendToObj(message, ")", -1); 1510 - TclAppendObjToErrorInfo(interp, message); 1511 - Tcl_DecrRefCount(message); 1506 + TclFormatToErrorInfo(interp, 1507 + "\n (compiling %s \"%.*s%s\", line %d)", 1508 + description, (overflow ? limit : length), procName, 1509 + (overflow ? "..." : ""), interp->errorLine); 1512 1510 } 1513 1511 return result; 1514 1512 } 1515 1513 } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) { 1516 1514 /* 1517 1515 * The resolver epoch has changed, but we only need to invalidate the 1518 1516 * resolver cache. ................................................................................ 1550 1548 * called and returned returnCode. */ 1551 1549 char *procName; /* Name of the procedure. Used for error 1552 1550 * messages and trace information. */ 1553 1551 int nameLen; /* Number of bytes in procedure's name. */ 1554 1552 int returnCode; /* The unexpected result code. */ 1555 1553 { 1556 1554 Interp *iPtr = (Interp *) interp; 1557 - Tcl_Obj *message, *errorLine; 1555 + int overflow, limit = 60; 1558 1556 1559 1557 if (returnCode == TCL_OK) { 1560 1558 return TCL_OK; 1561 1559 } 1562 1560 if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) { 1563 1561 return returnCode; 1564 1562 } ................................................................................ 1567 1565 } 1568 1566 if (returnCode != TCL_ERROR) { 1569 1567 Tcl_ResetResult(interp); 1570 1568 Tcl_AppendResult(interp, "invoked \"", 1571 1569 ((returnCode == TCL_BREAK) ? "break" : "continue"), 1572 1570 "\" outside of a loop", NULL); 1573 1571 } 1574 - errorLine = Tcl_NewIntObj(interp->errorLine); 1575 - message = Tcl_NewStringObj("\n (procedure \"", -1); 1576 - Tcl_IncrRefCount(message); 1577 - TclAppendLimitedToObj(message, procName, nameLen, 60, NULL); 1578 - Tcl_AppendToObj(message, "\" line ", -1); 1579 - Tcl_AppendObjToObj(message, errorLine); 1580 - Tcl_DecrRefCount(errorLine); 1581 - Tcl_AppendToObj(message, ")", -1); 1582 - TclAppendObjToErrorInfo(interp, message); 1583 - Tcl_DecrRefCount(message); 1572 + overflow = (nameLen > limit); 1573 + TclFormatToErrorInfo(interp, "\n (procedure \"%.*s%s\" line %d)", 1574 + (overflow ? limit : nameLen), procName, 1575 + (overflow ? "..." : ""), interp->errorLine); 1584 1576 return TCL_ERROR; 1585 1577 } 1586 1578 1587 1579 /* 1588 1580 *---------------------------------------------------------------------- 1589 1581 * 1590 1582 * TclProcDeleteProc --
Changes to generic/tclResult.c.
4 4 * This file contains code to manage the interpreter result. 5 5 * 6 6 * Copyright (c) 1997 by Sun Microsystems, Inc. 7 7 * 8 8 * See the file "license.terms" for information on usage and redistribution of 9 9 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 10 10 * 11 - * RCS: @(#) $Id: tclResult.c,v 1.23.2.4 2005/09/09 18:48:40 dgp Exp $ 11 + * RCS: @(#) $Id: tclResult.c,v 1.23.2.5 2005/09/15 20:58:40 dgp Exp $ 12 12 */ 13 13 14 14 #include "tclInt.h" 15 15 16 16 /* 17 17 * Indices of the standard return options dictionary keys. 18 18 */ ................................................................................ 659 659 * If the string result is non-empty, the object result forced to be a 660 660 * duplicate of it first. There will be a string result afterwards. 661 661 * 662 662 *---------------------------------------------------------------------- 663 663 */ 664 664 665 665 void 666 -Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1) 666 +Tcl_AppendResult(Tcl_Interp *interp, ...) 667 667 { 668 - Tcl_Interp *interp; 669 668 va_list argList; 670 669 671 - interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); 670 + va_start(argList, interp); 672 671 Tcl_AppendResultVA(interp, argList); 673 672 va_end(argList); 674 673 } 675 674 676 675 /* 677 676 *---------------------------------------------------------------------- 678 677 * ................................................................................ 1026 1025 * The errorCode field of the interp is modified to hold all of the 1027 1026 * arguments to this function, in a list form with each argument becoming 1028 1027 * one element of the list. 1029 1028 * 1030 1029 *---------------------------------------------------------------------- 1031 1030 */ 1032 1031 1033 - /* VARARGS2 */ 1034 1032 void 1035 -Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1) 1033 +Tcl_SetErrorCode(Tcl_Interp *interp, ...) 1036 1034 { 1037 - Tcl_Interp *interp; 1038 1035 va_list argList; 1039 1036 1040 1037 /* 1041 1038 * Scan through the arguments one at a time, appending them to the 1042 1039 * errorCode field as list elements. 1043 1040 */ 1044 1041 1045 - interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); 1042 + va_start(argList, interp); 1046 1043 Tcl_SetErrorCodeVA(interp, argList); 1047 1044 va_end(argList); 1048 1045 } 1049 1046 1050 1047 /* 1051 1048 *---------------------------------------------------------------------- 1052 1049 *
Changes to generic/tclStringObj.c.
29 29 * 30 30 * Copyright (c) 1995-1997 Sun Microsystems, Inc. 31 31 * Copyright (c) 1999 by Scriptics Corporation. 32 32 * 33 33 * See the file "license.terms" for information on usage and redistribution of 34 34 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 35 35 * 36 - * RCS: @(#) $Id: tclStringObj.c,v 1.35.2.8 2005/09/12 19:39:01 dgp Exp $ */ 36 + * RCS: @(#) $Id: tclStringObj.c,v 1.35.2.9 2005/09/15 20:58:40 dgp Exp $ */ 37 37 38 38 #include "tclInt.h" 39 39 #include "tommath.h" 40 40 41 41 /* 42 42 * Prototypes for functions defined later in this file: 43 43 */ ................................................................................ 50 50 int numChars)); 51 51 static void AppendUtfToUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr, 52 52 CONST char *bytes, int numBytes)); 53 53 static void AppendUtfToUtfRep _ANSI_ARGS_((Tcl_Obj *objPtr, 54 54 CONST char *bytes, int numBytes)); 55 55 static void FillUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr)); 56 56 static int FormatObjVA _ANSI_ARGS_((Tcl_Interp *interp, 57 + Tcl_Obj *objPtr, CONST char *format, 57 58 va_list argList)); 58 59 static int ObjPrintfVA _ANSI_ARGS_((Tcl_Interp *interp, 60 + Tcl_Obj *objPtr, CONST char *format, 59 61 va_list argList)); 60 62 static void FreeStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); 61 63 static void DupStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, 62 64 Tcl_Obj *copyPtr)); 63 65 static int SetStringFromAny _ANSI_ARGS_((Tcl_Interp *interp, 64 66 Tcl_Obj *objPtr)); 65 67 static void UpdateStringOfString _ANSI_ARGS_((Tcl_Obj *objPtr)); ................................................................................ 1661 1663 * The contents of all the string arguments are appended to the string 1662 1664 * representation of objPtr. 1663 1665 * 1664 1666 *---------------------------------------------------------------------- 1665 1667 */ 1666 1668 1667 1669 void 1668 -Tcl_AppendStringsToObj TCL_VARARGS_DEF(Tcl_Obj *,arg1) 1670 +Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...) 1669 1671 { 1670 - register Tcl_Obj *objPtr; 1671 1672 va_list argList; 1672 1673 1673 - objPtr = TCL_VARARGS_START(Tcl_Obj *,arg1,argList); 1674 + va_start(argList, objPtr); 1674 1675 Tcl_AppendStringsToObjVA(objPtr, argList); 1675 1676 va_end(argList); 1676 1677 } 1677 1678 1678 1679 /* 1679 1680 *---------------------------------------------------------------------- 1680 1681 * ................................................................................ 1692 1693 * Side effects: 1693 1694 * None. 1694 1695 * 1695 1696 *---------------------------------------------------------------------- 1696 1697 */ 1697 1698 1698 1699 int 1699 -TclAppendFormattedObjs(interp, baseObj, format, objc, objv) 1700 +TclAppendFormattedObjs(interp, appendObj, format, objc, objv) 1700 1701 Tcl_Interp *interp; 1701 - Tcl_Obj *baseObj; 1702 + Tcl_Obj *appendObj; 1702 1703 CONST char *format; 1703 1704 int objc; 1704 1705 Tcl_Obj *CONST objv[]; 1705 1706 { 1706 1707 CONST char *span = format; 1707 1708 int numBytes = 0; 1708 1709 int objIndex = 0; 1709 1710 int gotXpg = 0, gotSequential = 0; 1710 - Tcl_Obj *appendObj = Tcl_NewObj(); 1711 + int originalLength; 1711 1712 CONST char *msg; 1712 1713 CONST char *mixedXPG = "cannot mix \"%\" and \"%n$\" conversion specifiers"; 1713 1714 CONST char *badIndex[2] = { 1714 1715 "not enough arguments for all format specifiers", 1715 1716 "\"%n$\" argument index out of range" 1716 1717 }; 1717 1718 1718 - if (Tcl_IsShared(baseObj)) { 1719 + if (Tcl_IsShared(appendObj)) { 1719 1720 Tcl_Panic("TclAppendFormattedObjs called with shared object"); 1720 1721 } 1722 + Tcl_GetStringFromObj(appendObj, &originalLength); 1721 1723 1722 - Tcl_IncrRefCount(appendObj); 1723 1724 /* format string is NUL-terminated */ 1724 1725 while (*format != '\0') { 1725 1726 char *end; 1726 1727 int gotMinus, gotHash, gotZero, gotSpace, gotPlus, sawFlag; 1727 1728 int width, gotPrecision, precision, useShort, useWide, useBig; 1728 1729 int newXpg, numChars, allocSegment = 0; 1729 1730 Tcl_Obj *segment; ................................................................................ 2231 2232 objIndex += gotSequential; 2232 2233 } 2233 2234 if (numBytes) { 2234 2235 Tcl_AppendToObj(appendObj, span, numBytes); 2235 2236 numBytes = 0; 2236 2237 } 2237 2238 2238 - Tcl_AppendObjToObj(baseObj, appendObj); 2239 - Tcl_DecrRefCount(appendObj); 2240 2239 return TCL_OK; 2241 2240 2242 2241 errorMsg: 2243 2242 if (interp != NULL) { 2244 2243 Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); 2245 2244 } 2246 2245 error: 2247 - Tcl_DecrRefCount(appendObj); 2246 + Tcl_SetObjLength(appendObj, originalLength); 2248 2247 return TCL_ERROR; 2249 2248 } 2250 2249 2251 2250 /* 2252 2251 *--------------------------------------------------------------------------- 2253 2252 * 2254 2253 * FormatObjVA -- ................................................................................ 2262 2261 * Side effects: 2263 2262 * Reallocates the String internal rep. 2264 2263 * 2265 2264 *--------------------------------------------------------------------------- 2266 2265 */ 2267 2266 2268 2267 static int 2269 -FormatObjVA(interp, argList) 2270 - Tcl_Interp *interp; 2271 - va_list argList; 2268 +FormatObjVA(Tcl_Interp *interp, 2269 + Tcl_Obj *objPtr, 2270 + CONST char *format, 2271 + va_list argList) 2272 2272 { 2273 2273 int code, objc; 2274 2274 Tcl_Obj **objv, *element, *list = Tcl_NewObj(); 2275 - CONST char *format; 2276 - Tcl_Obj *objPtr = va_arg(argList, Tcl_Obj *); 2277 - 2278 - if (objPtr == NULL) { 2279 - Tcl_Panic("TclFormatObj: no Tcl_Obj to append to"); 2280 - } 2281 - 2282 - format = va_arg(argList, CONST char *); 2283 - if (format == NULL) { 2284 - Tcl_Panic("TclFormatObj: no format string argument"); 2285 - } 2286 2275 2287 2276 Tcl_IncrRefCount(list); 2288 2277 element = va_arg(argList, Tcl_Obj *); 2289 2278 while (element != NULL) { 2290 2279 Tcl_ListObjAppendElement(NULL, list, element); 2291 2280 element = va_arg(argList, Tcl_Obj *); 2292 2281 } ................................................................................ 2307 2296 * Side effects: 2308 2297 * None. 2309 2298 * 2310 2299 *--------------------------------------------------------------------------- 2311 2300 */ 2312 2301 2313 2302 int 2314 -TclFormatObj TCL_VARARGS_DEF(Tcl_Interp *,arg1) 2303 +TclFormatObj(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, ...) 2315 2304 { 2316 2305 va_list argList; 2317 2306 int result; 2318 - Tcl_Interp *interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); 2319 - result = FormatObjVA(interp, argList); 2307 + 2308 + va_start(argList, format); 2309 + result = FormatObjVA(interp, objPtr, format, argList); 2320 2310 va_end(argList); 2321 2311 return result; 2322 2312 } 2323 2313 2324 2314 /* 2325 2315 *--------------------------------------------------------------------------- 2326 2316 * ................................................................................ 2330 2320 * 2331 2321 * Side effects: 2332 2322 * 2333 2323 *--------------------------------------------------------------------------- 2334 2324 */ 2335 2325 2336 2326 static int 2337 -ObjPrintfVA(interp, argList) 2338 - Tcl_Interp *interp; 2339 - va_list argList; 2327 +ObjPrintfVA( 2328 + Tcl_Interp *interp, 2329 + Tcl_Obj *objPtr, 2330 + CONST char *format, 2331 + va_list argList) 2340 2332 { 2341 2333 int code, objc; 2342 2334 Tcl_Obj **objv, *list = Tcl_NewObj(); 2343 - CONST char *format, *p; 2344 - Tcl_Obj *objPtr = va_arg(argList, Tcl_Obj *); 2335 + CONST char *p; 2336 + char *end; 2345 2337 2346 - if (objPtr == NULL) { 2347 - Tcl_Panic("TclObjPrintf: no Tcl_Obj to append to"); 2348 - } 2349 - 2350 - p = format = va_arg(argList, CONST char *); 2351 - if (format == NULL) { 2352 - Tcl_Panic("TclObjPrintf: no format string argument"); 2353 - } 2354 - 2338 + p = format; 2355 2339 Tcl_IncrRefCount(list); 2356 2340 while (*p != '\0') { 2357 - int size = 0; 2358 - int seekingConversion = 1; 2341 + int size = 0, seekingConversion = 1, gotPrecision = 0; 2342 + int lastNum = -1, numBytes = -1; 2343 + 2359 2344 if (*p++ != '%') { 2360 2345 continue; 2361 2346 } 2362 2347 if (*p == '%') { 2363 2348 p++; 2364 2349 continue; 2365 2350 } 2366 2351 do { 2367 2352 switch (*p) { 2368 2353 2369 2354 case '\0': 2370 2355 seekingConversion = 0; 2371 2356 break; 2372 - case 's': 2373 - Tcl_ListObjAppendElement(NULL, list, Tcl_NewStringObj( 2374 - va_arg(argList, char *), -1)); 2357 + case 's': { 2358 + char *bytes = va_arg(argList, char *); 2375 2359 seekingConversion = 0; 2360 + if (gotPrecision) { 2361 + char *end = bytes + lastNum; 2362 + char *q = bytes; 2363 + while ((q < end) && (*q != '\0')) { 2364 + q++; 2365 + } 2366 + numBytes = (int)(q - bytes); 2367 + } 2368 + Tcl_ListObjAppendElement(NULL, list, 2369 + Tcl_NewStringObj(bytes , numBytes)); 2370 + /* We took no more than numBytes bytes from the (char *). 2371 + * In turn, [format] will take no more than numBytes 2372 + * characters from the Tcl_Obj. Since numBytes characters 2373 + * must be no less than numBytes bytes, the character limit 2374 + * will have no effect and we can just pass it through. 2375 + */ 2376 2376 break; 2377 + } 2377 2378 case 'c': 2378 2379 case 'i': 2379 2380 case 'u': 2380 2381 case 'd': 2381 2382 case 'o': 2382 2383 case 'x': 2383 2384 case 'X': ................................................................................ 2399 2400 case 'f': 2400 2401 case 'g': 2401 2402 case 'G': 2402 2403 Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj( 2403 2404 va_arg(argList, double))); 2404 2405 seekingConversion = 0; 2405 2406 break; 2407 + case '*': 2408 + lastNum = (int)va_arg(argList, int); 2409 + Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(lastNum)); 2410 + p++; 2411 + break; 2412 + case '0': case '1': case '2': case '3': case '4': 2413 + case '5': case '6': case '7': case '8': case '9': 2414 + lastNum = (int) strtoul(p, &end, 10); 2415 + p = end; 2416 + break; 2417 + case '.': 2418 + gotPrecision = 1; 2419 + p++; 2420 + break; 2421 + /* TODO: support for wide (and bignum?) arguments */ 2406 2422 case 'l': 2407 2423 size = 1; 2408 2424 p++; 2409 2425 break; 2410 2426 case 'h': 2411 2427 size = -1; 2412 2428 default: ................................................................................ 2431 2447 * Side effects: 2432 2448 * None. 2433 2449 * 2434 2450 *--------------------------------------------------------------------------- 2435 2451 */ 2436 2452 2437 2453 int 2438 -TclObjPrintf TCL_VARARGS_DEF(Tcl_Interp *,arg1) 2454 +TclObjPrintf(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, ...) 2439 2455 { 2440 2456 va_list argList; 2441 2457 int result; 2442 - Tcl_Interp *interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); 2443 - result = ObjPrintfVA(interp, argList); 2458 + 2459 + va_start(argList, format); 2460 + result = ObjPrintfVA(interp, objPtr, format, argList); 2444 2461 va_end(argList); 2445 2462 return result; 2446 2463 } 2464 + 2465 +/* 2466 + *---------------------------------------------------------------------- 2467 + * 2468 + * TclFormatToErrorInfo -- 2469 + * 2470 + * Results: 2471 + * 2472 + * Side effects: 2473 + * 2474 + *---------------------------------------------------------------------- 2475 + */ 2476 + 2477 +int 2478 +TclFormatToErrorInfo(Tcl_Interp *interp, CONST char *format, ...) 2479 +{ 2480 + int code; 2481 + va_list argList; 2482 + Tcl_Obj *objPtr = Tcl_NewObj(); 2483 + 2484 + va_start(argList, format); 2485 + code = ObjPrintfVA(interp, objPtr, format, argList); 2486 + va_end(argList); 2487 + if (code != TCL_OK) { 2488 + return code; 2489 + } 2490 + TclAppendObjToErrorInfo(interp, objPtr); 2491 + Tcl_DecrRefCount(objPtr); 2492 + return TCL_OK; 2493 +} 2447 2494 2448 2495 /* 2449 2496 *--------------------------------------------------------------------------- 2450 2497 * 2451 2498 * FillUnicodeRep -- 2452 2499 * 2453 2500 * Populate the Unicode internal rep with the Unicode form of its string
Changes to generic/tclTimer.c.
5 5 * including the "after" command. 6 6 * 7 7 * Copyright (c) 1997 by Sun Microsystems, Inc. 8 8 * 9 9 * See the file "license.terms" for information on usage and redistribution of 10 10 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 11 11 * 12 - * RCS: @(#) $Id: tclTimer.c,v 1.12.2.4 2005/08/02 18:16:10 dgp Exp $ 12 + * RCS: @(#) $Id: tclTimer.c,v 1.12.2.5 2005/09/15 20:58:40 dgp Exp $ 13 13 */ 14 14 15 15 #include "tclInt.h" 16 16 17 17 /* 18 18 * For each timer callback that's pending there is one record of the following 19 19 * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained ................................................................................ 777 777 int length; 778 778 char *argString; 779 779 int index; 780 780 char buf[16 + TCL_INTEGER_SPACE]; 781 781 static CONST char *afterSubCmds[] = { 782 782 "cancel", "idle", "info", (char *) NULL 783 783 }; 784 + Tcl_Obj *objPtr; 784 785 enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO}; 785 786 ThreadSpecificData *tsdPtr = InitTimer(); 786 787 787 788 if (objc < 2) { 788 789 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); 789 790 return TCL_ERROR; 790 791 } ................................................................................ 844 845 845 846 afterPtr->id = tsdPtr->afterId; 846 847 tsdPtr->afterId += 1; 847 848 afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc, 848 849 (ClientData) afterPtr); 849 850 afterPtr->nextPtr = assocPtr->firstAfterPtr; 850 851 assocPtr->firstAfterPtr = afterPtr; 851 - sprintf(buf, "after#%d", afterPtr->id); 852 - Tcl_AppendResult(interp, buf, (char *) NULL); 852 + objPtr = Tcl_NewObj(); 853 + TclObjPrintf(NULL, objPtr, "after#%d", afterPtr->id); 854 + Tcl_SetObjResult(interp, objPtr); 853 855 return TCL_OK; 854 856 } 855 857 856 858 /* 857 859 * If it's not a number it must be a subcommand. Note that we're using a 858 860 * custom error message here, so we do not pass an interpreter to T_GIFO. 859 861 */ ................................................................................ 922 924 Tcl_IncrRefCount(afterPtr->commandPtr); 923 925 afterPtr->id = tsdPtr->afterId; 924 926 tsdPtr->afterId += 1; 925 927 afterPtr->token = NULL; 926 928 afterPtr->nextPtr = assocPtr->firstAfterPtr; 927 929 assocPtr->firstAfterPtr = afterPtr; 928 930 Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); 929 - sprintf(buf, "after#%d", afterPtr->id); 930 - Tcl_AppendResult(interp, buf, (char *) NULL); 931 + objPtr = Tcl_NewObj(); 932 + TclObjPrintf(NULL, objPtr, "after#%d", afterPtr->id); 933 + Tcl_SetObjResult(interp, objPtr); 931 934 break; 932 935 case AFTER_INFO: { 933 936 Tcl_Obj *resultListPtr; 934 937 935 938 if (objc == 2) { 936 939 for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; 937 940 afterPtr = afterPtr->nextPtr) {
Changes to generic/tclUtil.c.
7 7 * Copyright (c) 1987-1993 The Regents of the University of California. 8 8 * Copyright (c) 1994-1998 Sun Microsystems, Inc. 9 9 * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. 10 10 * 11 11 * See the file "license.terms" for information on usage and redistribution of 12 12 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 13 * 14 - * RCS: @(#) $Id: tclUtil.c,v 1.51.2.19 2005/09/09 18:48:40 dgp Exp $ 14 + * RCS: @(#) $Id: tclUtil.c,v 1.51.2.20 2005/09/15 20:58:40 dgp Exp $ 15 15 */ 16 16 17 17 #include "tclInt.h" 18 18 #include <float.h> 19 19 #include <math.h> 20 20 21 21 /* ................................................................................ 213 213 } 214 214 215 215 /* 216 216 * Garbage after the closing brace; return an error. 217 217 */ 218 218 219 219 if (interp != NULL) { 220 - char buf[100]; 221 - 220 + Tcl_Obj *objPtr = Tcl_NewObj(); 222 221 p2 = p; 223 222 while ((p2 < limit) 224 223 && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */ 225 224 && (p2 < p+20)) { 226 225 p2++; 227 226 } 228 - sprintf(buf, 229 - "list element in braces followed by \"%.*s\" instead of space", 230 - (int) (p2-p), p); 231 - Tcl_SetResult(interp, buf, TCL_VOLATILE); 227 + TclObjPrintf(NULL, objPtr, 228 + "list element in braces followed by \"%.*s\" " 229 + "instead of space", (int) (p2-p), p); 230 + Tcl_SetObjResult(interp, objPtr); 232 231 } 233 232 return TCL_ERROR; 234 233 } 235 234 break; 236 235 237 236 /* 238 237 * Backslash: skip over everything up to the end of the backslash ................................................................................ 275 274 } 276 275 277 276 /* 278 277 * Garbage after the closing quote; return an error. 279 278 */ 280 279 281 280 if (interp != NULL) { 282 - char buf[100]; 283 - 281 + Tcl_Obj *objPtr = Tcl_NewObj(); 284 282 p2 = p; 285 283 while ((p2 < limit) 286 284 && (!isspace(UCHAR(*p2))) /* INTL: ISO space */ 287 285 && (p2 < p+20)) { 288 286 p2++; 289 287 } 290 - sprintf(buf, 291 - "list element in quotes followed by \"%.*s\" %s", 292 - (int) (p2-p), p, "instead of space"); 293 - Tcl_SetResult(interp, buf, TCL_VOLATILE); 288 + TclObjPrintf(NULL, objPtr, 289 + "list element in quotes followed by \"%.*s\" " 290 + "instead of space", (int) (p2-p), p); 291 + Tcl_SetObjResult(interp, objPtr); 294 292 } 295 293 return TCL_ERROR; 296 294 } 297 295 break; 298 296 } 299 297 p++; 300 298 }
Changes to library/init.tcl.
1 1 # init.tcl -- 2 2 # 3 3 # Default system startup file for Tcl-based applications. Defines 4 4 # "unknown" procedure and auto-load facilities. 5 5 # 6 -# RCS: @(#) $Id: init.tcl,v 1.69.2.5 2005/08/25 15:46:31 dgp Exp $ 6 +# RCS: @(#) $Id: init.tcl,v 1.69.2.6 2005/09/15 20:58:40 dgp Exp $ 7 7 # 8 8 # Copyright (c) 1991-1993 The Regents of the University of California. 9 9 # Copyright (c) 1994-1996 Sun Microsystems, Inc. 10 10 # Copyright (c) 1998-1999 Scriptics Corporation. 11 11 # Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. 12 12 # 13 13 # See the file "license.terms" for information on usage and redistribution ................................................................................ 268 268 # Compute stack trace contribution from the [uplevel]. 269 269 # Note the dependence on how Tcl_AddErrorInfo, etc. 270 270 # construct the stack trace. 271 271 # 272 272 set errorInfo [dict get $opts -errorinfo] 273 273 set errorCode [dict get $opts -errorcode] 274 274 set cinfo $args 275 - if {[string bytelength $cinfo] > 153} { 276 - set cinfo [string range $cinfo 0 152] 275 + if {[string bytelength $cinfo] > 150} { 276 + set cinfo [string range $cinfo 0 150] 277 277 while {[string bytelength $cinfo] > 150} { 278 278 set cinfo [string range $cinfo 0 end-1] 279 279 } 280 280 append cinfo ... 281 281 } 282 282 append cinfo "\"\n (\"uplevel\" body line 1)" 283 283 append cinfo "\n invoked from within"
Changes to tools/genStubs.tcl.
4 4 # interface. 5 5 # 6 6 # 7 7 # Copyright (c) 1998-1999 by Scriptics Corporation. 8 8 # See the file "license.terms" for information on usage and redistribution 9 9 # of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10 10 # 11 -# RCS: @(#) $Id: genStubs.tcl,v 1.17 2004/03/17 18:14:18 das Exp $ 11 +# RCS: @(#) $Id: genStubs.tcl,v 1.17.2.1 2005/09/15 20:58:40 dgp Exp $ 12 12 13 13 package require Tcl 8 14 14 15 15 namespace eval genStubs { 16 16 # libraryName -- 17 17 # 18 18 # The name of the entire library. This value is used to compute ................................................................................ 367 367 set arg1 [lindex $args 0] 368 368 switch -exact $arg1 { 369 369 void { 370 370 append line "(void)" 371 371 } 372 372 TCL_VARARGS { 373 373 set arg [lindex $args 1] 374 - append line "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])" 374 + append line "([lindex $arg 0][lindex $arg 1], ...)" 375 375 } 376 376 default { 377 377 set sep "(" 378 378 foreach arg $args { 379 379 append line $sep 380 380 set next {} 381 381 append next [lindex $arg 0] " " [lindex $arg 1] \ ................................................................................ 460 460 461 461 append text "/* Slot $index */\n" $rtype "\n" $fname 462 462 463 463 set arg1 [lindex $args 0] 464 464 465 465 if {![string compare $arg1 "TCL_VARARGS"]} { 466 466 lassign [lindex $args 1] type argName 467 - append text " TCL_VARARGS_DEF($type,$argName)\n\{\n" 467 + append text " ($type$argName, ...)\n\{\n" 468 468 append text " " $type " var;\n va_list argList;\n" 469 469 if {[string compare $rtype "void"]} { 470 470 append text " " $rtype " resultValue;\n" 471 471 } 472 - append text "\n var = (" $type ") TCL_VARARGS_START(" \ 473 - $type "," $argName ",argList);\n\n " 472 + append text "\n var = (" $type ") (va_start(argList, " \ 473 + $argName "), " $argName ");\n\n " 474 474 if {[string compare $rtype "void"]} { 475 475 append text "resultValue = " 476 476 } 477 477 append text "(" $name "StubsPtr->" $lfname "VA)(var, argList);\n" 478 478 append text " va_end(argList);\n" 479 479 if {[string compare $rtype "void"]} { 480 480 append text "return resultValue;\n" ................................................................................ 529 529 set arg1 [lindex $args 0] 530 530 switch -exact $arg1 { 531 531 void { 532 532 append text "(void)" 533 533 } 534 534 TCL_VARARGS { 535 535 set arg [lindex $args 1] 536 - append text "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])" 536 + append text "([lindex $arg 0][lindex $arg 1], ...)" 537 537 } 538 538 default { 539 539 set sep "(" 540 540 foreach arg $args { 541 541 append text $sep [lindex $arg 0] " " [lindex $arg 1] \ 542 542 [lindex $arg 2] 543 543 set sep ", "
Changes to unix/configure.
8948 8948 8949 8949 cat >>confdefs.h <<\_ACEOF 8950 8950 #define _LARGEFILE64_SOURCE 1 8951 8951 _ACEOF 8952 8952 8953 8953 tcl_flags="$tcl_flags _LARGEFILE64_SOURCE" 8954 8954 fi 8955 + 8956 + if test "${tcl_cv_flag__largefile_source64+set}" = set; then 8957 + echo $ECHO_N "(cached) $ECHO_C" >&6 8958 +else 8959 + cat >conftest.$ac_ext <<_ACEOF 8960 +/* confdefs.h. */ 8961 +_ACEOF 8962 +cat confdefs.h >>conftest.$ac_ext 8963 +cat >>conftest.$ac_ext <<_ACEOF 8964 +/* end confdefs.h. */ 8965 +#include <sys/stat.h> 8966 +int 8967 +main () 8968 +{ 8969 +char *p = (char *)open64; 8970 + ; 8971 + return 0; 8972 +} 8973 +_ACEOF 8974 +rm -f conftest.$ac_objext 8975 +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 8976 + (eval $ac_compile) 2>conftest.er1 8977 + ac_status=$? 8978 + grep -v '^ *+' conftest.er1 >conftest.err 8979 + rm -f conftest.er1 8980 + cat conftest.err >&5 8981 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 8982 + (exit $ac_status); } && 8983 + { ac_try='test -z "$ac_c_werror_flag" 8984 + || test ! -s conftest.err' 8985 + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 8986 + (eval $ac_try) 2>&5 8987 + ac_status=$? 8988 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 8989 + (exit $ac_status); }; } && 8990 + { ac_try='test -s conftest.$ac_objext' 8991 + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 8992 + (eval $ac_try) 2>&5 8993 + ac_status=$? 8994 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 8995 + (exit $ac_status); }; }; then 8996 + tcl_cv_flag__largefile_source64=no 8997 +else 8998 + echo "$as_me: failed program was:" >&5 8999 +sed 's/^/| /' conftest.$ac_ext >&5 9000 + 9001 +cat >conftest.$ac_ext <<_ACEOF 9002 +/* confdefs.h. */ 9003 +_ACEOF 9004 +cat confdefs.h >>conftest.$ac_ext 9005 +cat >>conftest.$ac_ext <<_ACEOF 9006 +/* end confdefs.h. */ 9007 +#define _LARGEFILE_SOURCE64 1 9008 +#include <sys/stat.h> 9009 +int 9010 +main () 9011 +{ 9012 +char *p = (char *)open64; 9013 + ; 9014 + return 0; 9015 +} 9016 +_ACEOF 9017 +rm -f conftest.$ac_objext 9018 +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 9019 + (eval $ac_compile) 2>conftest.er1 9020 + ac_status=$? 9021 + grep -v '^ *+' conftest.er1 >conftest.err 9022 + rm -f conftest.er1 9023 + cat conftest.err >&5 9024 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 9025 + (exit $ac_status); } && 9026 + { ac_try='test -z "$ac_c_werror_flag" 9027 + || test ! -s conftest.err' 9028 + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 9029 + (eval $ac_try) 2>&5 9030 + ac_status=$? 9031 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 9032 + (exit $ac_status); }; } && 9033 + { ac_try='test -s conftest.$ac_objext' 9034 + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 9035 + (eval $ac_try) 2>&5 9036 + ac_status=$? 9037 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 9038 + (exit $ac_status); }; }; then 9039 + tcl_cv_flag__largefile_source64=yes 9040 +else 9041 + echo "$as_me: failed program was:" >&5 9042 +sed 's/^/| /' conftest.$ac_ext >&5 9043 + 9044 +tcl_cv_flag__largefile_source64=no 9045 +fi 9046 +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext 9047 +fi 9048 +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext 9049 +fi 9050 + 9051 + if test "x${tcl_cv_flag__largefile_source64}" = "xyes" ; then 9052 + 9053 +cat >>confdefs.h <<\_ACEOF 9054 +#define _LARGEFILE_SOURCE64 1 9055 +_ACEOF 9056 + 9057 + tcl_flags="$tcl_flags _LARGEFILE_SOURCE64" 9058 + fi 8955 9059 if test "x${tcl_flags}" = "x" ; then 8956 9060 echo "$as_me:$LINENO: result: none" >&5 8957 9061 echo "${ECHO_T}none" >&6 8958 9062 else 8959 9063 echo "$as_me:$LINENO: result: ${tcl_flags}" >&5 8960 9064 echo "${ECHO_T}${tcl_flags}" >&6 8961 9065 fi
Changes to unix/tcl.m4.
2518 2518 AC_DEFUN(SC_TCL_EARLY_FLAGS,[ 2519 2519 AC_MSG_CHECKING([for required early compiler flags]) 2520 2520 tcl_flags="" 2521 2521 SC_TCL_EARLY_FLAG(_ISOC99_SOURCE,[#include <stdlib.h>], 2522 2522 [char *p = (char *)strtoll; char *q = (char *)strtoull;]) 2523 2523 SC_TCL_EARLY_FLAG(_LARGEFILE64_SOURCE,[#include <sys/stat.h>], 2524 2524 [struct stat64 buf; int i = stat64("/", &buf);]) 2525 + SC_TCL_EARLY_FLAG(_LARGEFILE_SOURCE64,[#include <sys/stat.h>], 2526 + [char *p = (char *)open64;]) 2525 2527 if test "x${tcl_flags}" = "x" ; then 2526 2528 AC_MSG_RESULT(none) 2527 2529 else 2528 2530 AC_MSG_RESULT(${tcl_flags}) 2529 2531 fi]) 2530 2532 2531 2533 #--------------------------------------------------------------------
Changes to unix/tclUnixFCmd.c.
6 6 * already be translated to native format. 7 7 * 8 8 * Copyright (c) 1996-1998 Sun Microsystems, Inc. 9 9 * 10 10 * See the file "license.terms" for information on usage and redistribution of 11 11 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 12 * 13 - * RCS: @(#) $Id: tclUnixFCmd.c,v 1.40.2.3 2005/08/02 18:16:56 dgp Exp $ 13 + * RCS: @(#) $Id: tclUnixFCmd.c,v 1.40.2.4 2005/09/15 20:58:40 dgp Exp $ 14 14 * 15 15 * Portions of this code were derived from NetBSD source code which has the 16 16 * following copyright notice: 17 17 * 18 18 * Copyright (c) 1988, 1993, 1994 19 19 * The Regents of the University of California. All rights reserved. 20 20 * ................................................................................ 1282 1282 GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr) 1283 1283 Tcl_Interp *interp; /* The interp we are using for errors. */ 1284 1284 int objIndex; /* The index of the attribute. */ 1285 1285 Tcl_Obj *fileName; /* The name of the file (UTF-8). */ 1286 1286 Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ 1287 1287 { 1288 1288 Tcl_StatBuf statBuf; 1289 - char returnString[7]; 1290 1289 int result; 1291 1290 1292 1291 result = TclpObjStat(fileName, &statBuf); 1293 1292 1294 1293 if (result != 0) { 1295 1294 if (interp != NULL) { 1296 1295 Tcl_AppendResult(interp, "could not read \"", 1297 1296 Tcl_GetString(fileName), "\": ", 1298 1297 Tcl_PosixError(interp), (char *) NULL); 1299 1298 } 1300 1299 return TCL_ERROR; 1301 1300 } 1302 1301 1303 - sprintf(returnString, "%0#5lo", (long) (statBuf.st_mode & 0x00007FFF)); 1304 - 1305 - *attributePtrPtr = Tcl_NewStringObj(returnString, -1); 1302 + *attributePtrPtr = Tcl_NewObj(); 1303 + TclObjPrintf(NULL, *attributePtrPtr, "%0#5lo", 1304 + (long) (statBuf.st_mode & 0x00007FFF)); 1306 1305 1307 1306 return TCL_OK; 1308 1307 } 1309 1308 1310 1309 /* 1311 1310 *--------------------------------------------------------------------------- 1312 1311 *