From cf4d5a8cfe114d1b687b43c361a25182eba9597c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 8 Nov 2017 11:50:55 +0000 Subject: TIP #485 implementation: "Remove Deprecated API". Based on Tcl 8.7 (core-8-branch). --- generic/tcl.decls | 16 ++--- generic/tclBasic.c | 2 +- generic/tclCmdAH.c | 2 +- generic/tclDecls.h | 40 +++++++----- generic/tclIOCmd.c | 6 +- generic/tclInt.h | 2 +- generic/tclStubInit.c | 8 +++ generic/tclTest.c | 163 ------------------------------------------------ tests/case.test | 94 ---------------------------- tests/compExpr-old.test | 22 ------- tests/compExpr.test | 12 ---- tests/expr-old.test | 17 ----- tests/expr.test | 39 ------------ 13 files changed, 46 insertions(+), 377 deletions(-) delete mode 100644 tests/case.test diff --git a/generic/tcl.decls b/generic/tcl.decls index b2b91a9..f7ffd29 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -285,7 +285,7 @@ declare 75 { declare 76 { void Tcl_BackgroundError(Tcl_Interp *interp) } -declare 77 { +declare 77 {deprecated {Use Tcl_UtfBackslash}} { char Tcl_Backslash(const char *src, int *readPtr) } declare 78 { @@ -352,7 +352,7 @@ declare 93 { declare 94 { Tcl_Interp *Tcl_CreateInterp(void) } -declare 95 { +declare 95 {deprecated {}} { void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData) @@ -470,7 +470,7 @@ declare 129 { int Tcl_Eval(Tcl_Interp *interp, const char *script) } # This is obsolete, use Tcl_FSEvalFile -declare 130 { +declare 130 {deprecated {Use Tcl_FSEvalFile}} { int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName) } declare 131 { @@ -1214,10 +1214,10 @@ declare 339 { declare 340 { char *Tcl_GetString(Tcl_Obj *objPtr) } -declare 341 { +declare 341 {deprecated {Use Tcl_GetEncodingSearchPath}} { CONST84_RETURN char *Tcl_GetDefaultEncodingDir(void) } -declare 342 { +declare 342 {deprecated {Use Tcl_SetEncodingSearchPath}} { void Tcl_SetDefaultEncodingDir(const char *path) } declare 343 { @@ -1266,7 +1266,7 @@ declare 356 { Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags) } -declare 357 { +declare 357 {deprecated {Use Tcl_EvalTokensStandard}} { Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count) } @@ -1548,12 +1548,12 @@ declare 434 { } # TIP#15 (math function introspection) dkf -declare 435 { +declare 435 {deprecated {}} { int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr) } -declare 436 { +declare 436 {deprecated {}} { Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern) } diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e6022ac..c334fb8 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -203,7 +203,7 @@ static const CmdInfo builtInCmds[] = { {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE}, {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 {"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE}, #endif {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 807a1ac..49c8c56 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -164,7 +164,7 @@ Tcl_BreakObjCmd( * *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* ARGSUSED */ int Tcl_CaseObjCmd( diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 464fc0f..c521845 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -263,7 +263,8 @@ EXTERN int Tcl_AsyncReady(void); /* 76 */ EXTERN void Tcl_BackgroundError(Tcl_Interp *interp); /* 77 */ -EXTERN char Tcl_Backslash(const char *src, int *readPtr); +TCL_DEPRECATED("Use Tcl_UtfBackslash") +char Tcl_Backslash(const char *src, int *readPtr); /* 78 */ EXTERN int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName, @@ -322,7 +323,8 @@ EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc, /* 94 */ EXTERN Tcl_Interp * Tcl_CreateInterp(void); /* 95 */ -EXTERN void Tcl_CreateMathFunc(Tcl_Interp *interp, +TCL_DEPRECATED("") +void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); @@ -418,7 +420,8 @@ EXTERN CONST84_RETURN char * Tcl_ErrnoMsg(int err); /* 129 */ EXTERN int Tcl_Eval(Tcl_Interp *interp, const char *script); /* 130 */ -EXTERN int Tcl_EvalFile(Tcl_Interp *interp, +TCL_DEPRECATED("Use Tcl_FSEvalFile") +int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName); /* 131 */ EXTERN int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -1010,9 +1013,11 @@ EXTERN int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 340 */ EXTERN char * Tcl_GetString(Tcl_Obj *objPtr); /* 341 */ -EXTERN CONST84_RETURN char * Tcl_GetDefaultEncodingDir(void); +TCL_DEPRECATED("Use Tcl_GetEncodingSearchPath") +CONST84_RETURN char * Tcl_GetDefaultEncodingDir(void); /* 342 */ -EXTERN void Tcl_SetDefaultEncodingDir(const char *path); +TCL_DEPRECATED("Use Tcl_SetEncodingSearchPath") +void Tcl_SetDefaultEncodingDir(const char *path); /* 343 */ EXTERN void Tcl_AlertNotifier(ClientData clientData); /* 344 */ @@ -1047,7 +1052,8 @@ EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString(const char *src, int length, EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 357 */ -EXTERN Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp, +TCL_DEPRECATED("Use Tcl_EvalTokensStandard") +Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 358 */ EXTERN void Tcl_FreeParse(Tcl_Parse *parsePtr); @@ -1268,13 +1274,15 @@ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr); /* 435 */ -EXTERN int Tcl_GetMathFuncInfo(Tcl_Interp *interp, +TCL_DEPRECATED("") +int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 436 */ -EXTERN Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp, +TCL_DEPRECATED("") +Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern); /* 437 */ EXTERN Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -1935,7 +1943,7 @@ typedef struct TclStubs { void (*tcl_AsyncMark) (Tcl_AsyncHandler async); /* 74 */ int (*tcl_AsyncReady) (void); /* 75 */ void (*tcl_BackgroundError) (Tcl_Interp *interp); /* 76 */ - char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */ + TCL_DEPRECATED_API("Use Tcl_UtfBackslash") char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */ int (*tcl_BadChannelOption) (Tcl_Interp *interp, const char *optionName, const char *optionList); /* 78 */ void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 79 */ void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, ClientData clientData); /* 80 */ @@ -1953,7 +1961,7 @@ typedef struct TclStubs { void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData); /* 92 */ void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 93 */ Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */ - void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */ + TCL_DEPRECATED_API("") void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */ Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, const char *slaveName, int isSafe); /* 97 */ Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 98 */ @@ -1988,7 +1996,7 @@ typedef struct TclStubs { CONST84_RETURN char * (*tcl_ErrnoId) (void); /* 127 */ CONST84_RETURN char * (*tcl_ErrnoMsg) (int err); /* 128 */ int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */ - int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */ + TCL_DEPRECATED_API("Use Tcl_FSEvalFile") int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */ int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */ void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */ TCL_NORETURN1 void (*tcl_Exit) (int status); /* 133 */ @@ -2207,8 +2215,8 @@ typedef struct TclStubs { int (*tcl_WriteChars) (Tcl_Channel chan, const char *src, int srcLen); /* 338 */ int (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */ - CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */ - void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */ + TCL_DEPRECATED_API("Use Tcl_GetEncodingSearchPath") CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */ + TCL_DEPRECATED_API("Use Tcl_SetEncodingSearchPath") void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */ void (*tcl_AlertNotifier) (ClientData clientData); /* 343 */ void (*tcl_ServiceModeHook) (int mode); /* 344 */ int (*tcl_UniCharIsAlnum) (int ch); /* 345 */ @@ -2223,7 +2231,7 @@ typedef struct TclStubs { char * (*tcl_UniCharToUtfDString) (const Tcl_UniChar *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */ Tcl_UniChar * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */ - Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */ + TCL_DEPRECATED_API("Use Tcl_EvalTokensStandard") Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */ void (*tcl_FreeParse) (Tcl_Parse *parsePtr); /* 358 */ void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, int length); /* 359 */ int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 360 */ @@ -2301,8 +2309,8 @@ typedef struct TclStubs { int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */ Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ - int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */ - Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */ + TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */ + TCL_DEPRECATED_API("") Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */ Tcl_Obj * (*tcl_SubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 437 */ int (*tcl_DetachChannel) (Tcl_Interp *interp, Tcl_Channel channel); /* 438 */ int (*tcl_IsStandardChannel) (Tcl_Channel channel); /* 439 */ diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 6e8bd09..87bf415 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -137,7 +137,7 @@ Tcl_PutsObjCmd( chanObjPtr = objv[2]; string = objv[3]; break; -#if TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 } else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) { /* * The code below provides backwards compatibility with an old @@ -439,7 +439,7 @@ Tcl_ReadObjCmd( if (i < objc) { if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) || (toRead < 0)) { -#if TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* * The code below provides backwards compatibility with an old * form of the command that is no longer recommended or @@ -454,7 +454,7 @@ Tcl_ReadObjCmd( TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); return TCL_ERROR; -#if TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 } newline = 1; #endif diff --git a/generic/tclInt.h b/generic/tclInt.h index 29392b6..6b61af1 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3240,7 +3240,7 @@ MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index ebd2086..03ef7d6 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -72,6 +72,14 @@ static int TclSockMinimumBuffersOld(int sock, int size) # define TclBNInitBignumFromWideUInt 0 # define TclBNInitBignumFromWideInt 0 # define TclBNInitBignumFromLong 0 +# define Tcl_BackSlash 0 +# define Tcl_EvalFile 0 +# define Tcl_GetDefaultEncodingDir 0 +# define Tcl_SetDefaultEncodingDir 0 +# define Tcl_EvalTokens 0 +# define Tcl_CreateMathFunc 0 +# define Tcl_GetMathFuncInfo 0 +# define Tcl_ListMathFuncs 0 #else #define TclSetStartupScriptPath setStartupScriptPath static void TclSetStartupScriptPath(Tcl_Obj *path) diff --git a/generic/tclTest.c b/generic/tclTest.c index 834cd79..3aa853f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -305,14 +305,6 @@ static int TestlinkCmd(ClientData dummy, static int TestlocaleCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -#ifndef TCL_NO_DEPRECATED -static int TestMathFunc(ClientData clientData, - Tcl_Interp *interp, Tcl_Value *args, - Tcl_Value *resultPtr); -static int TestMathFunc2(ClientData clientData, - Tcl_Interp *interp, Tcl_Value *args, - Tcl_Value *resultPtr); -#endif /* TCL_NO_DEPRECATED */ static int TestmainthreadCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestsetmainloopCmd(ClientData dummy, @@ -549,10 +541,6 @@ int Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { -#ifndef TCL_NO_DEPRECATED - Tcl_ValueType t3ArgTypes[2]; -#endif /* TCL_NO_DEPRECATED */ - Tcl_Obj *listPtr; Tcl_Obj **objv; int objc, index; @@ -701,10 +689,6 @@ Tcltest_Init( Tcl_CreateCommand(interp, "testtranslatefilename", TesttranslatefilenameCmd, NULL, NULL); Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL); -#ifndef TCL_NO_DEPRECATED - Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123); - Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345); -#endif /* TCL_NO_DEPRECATED */ Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd, @@ -715,13 +699,6 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, (ClientData) 0, NULL); #endif -#ifndef TCL_NO_DEPRECATED - t3ArgTypes[0] = TCL_EITHER; - t3ArgTypes[1] = TCL_EITHER; - Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, - NULL); -#endif /* TCL_NO_DEPRECATED */ - Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind, NULL, NULL); Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, @@ -3347,146 +3324,6 @@ TestlocaleCmd( /* *---------------------------------------------------------------------- * - * TestMathFunc -- - * - * This is a user-defined math procedure to test out math procedures - * with no arguments. - * - * Results: - * A normal Tcl completion code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -#ifndef TCL_NO_DEPRECATED -static int -TestMathFunc( - ClientData clientData, /* Integer value to return. */ - Tcl_Interp *interp, /* Not used. */ - Tcl_Value *args, /* Not used. */ - Tcl_Value *resultPtr) /* Where to store result. */ -{ - resultPtr->type = TCL_INT; - resultPtr->intValue = PTR2INT(clientData); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestMathFunc2 -- - * - * This is a user-defined math procedure to test out math procedures - * that do have arguments, in this case 2. - * - * Results: - * A normal Tcl completion code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestMathFunc2( - ClientData clientData, /* Integer value to return. */ - Tcl_Interp *interp, /* Used to report errors. */ - Tcl_Value *args, /* Points to an array of two Tcl_Value structs - * for the two arguments. */ - Tcl_Value *resultPtr) /* Where to store the result. */ -{ - int result = TCL_OK; - - /* - * Return the maximum of the two arguments with the correct type. - */ - - if (args[0].type == TCL_INT) { - int i0 = args[0].intValue; - - if (args[1].type == TCL_INT) { - int i1 = args[1].intValue; - - resultPtr->type = TCL_INT; - resultPtr->intValue = ((i0 > i1)? i0 : i1); - } else if (args[1].type == TCL_DOUBLE) { - double d0 = i0; - double d1 = args[1].doubleValue; - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else if (args[1].type == TCL_WIDE_INT) { - Tcl_WideInt w0 = Tcl_LongAsWide(i0); - Tcl_WideInt w1 = args[1].wideValue; - - resultPtr->type = TCL_WIDE_INT; - resultPtr->wideValue = ((w0 > w1)? w0 : w1); - } else { - Tcl_AppendResult(interp, "T3: wrong type for arg 2", NULL); - result = TCL_ERROR; - } - } else if (args[0].type == TCL_DOUBLE) { - double d0 = args[0].doubleValue; - - if (args[1].type == TCL_INT) { - double d1 = args[1].intValue; - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else if (args[1].type == TCL_DOUBLE) { - double d1 = args[1].doubleValue; - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else if (args[1].type == TCL_WIDE_INT) { - double d1 = Tcl_WideAsDouble(args[1].wideValue); - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else { - Tcl_AppendResult(interp, "T3: wrong type for arg 2", NULL); - result = TCL_ERROR; - } - } else if (args[0].type == TCL_WIDE_INT) { - Tcl_WideInt w0 = args[0].wideValue; - - if (args[1].type == TCL_INT) { - Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue); - - resultPtr->type = TCL_WIDE_INT; - resultPtr->wideValue = ((w0 > w1)? w0 : w1); - } else if (args[1].type == TCL_DOUBLE) { - double d0 = Tcl_WideAsDouble(w0); - double d1 = args[1].doubleValue; - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else if (args[1].type == TCL_WIDE_INT) { - Tcl_WideInt w1 = args[1].wideValue; - - resultPtr->type = TCL_WIDE_INT; - resultPtr->wideValue = ((w0 > w1)? w0 : w1); - } else { - Tcl_AppendResult(interp, "T3: wrong type for arg 2", NULL); - result = TCL_ERROR; - } - } else { - Tcl_AppendResult(interp, "T3: wrong type for arg 1", NULL); - result = TCL_ERROR; - } - return result; -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * CleanupTestSetassocdataTests -- * * This function is called when an interpreter is deleted to clean diff --git a/tests/case.test b/tests/case.test deleted file mode 100644 index d7558a9..0000000 --- a/tests/case.test +++ /dev/null @@ -1,94 +0,0 @@ -# Commands covered: case -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -if {![llength [info commands case]]} { - # No "case" command? So no need to test - return -} - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} - -test case-1.1 {simple pattern} { - case a in a {format 1} b {format 2} c {format 3} default {format 4} -} 1 -test case-1.2 {simple pattern} { - case b a {format 1} b {format 2} c {format 3} default {format 4} -} 2 -test case-1.3 {simple pattern} { - case x in a {format 1} b {format 2} c {format 3} default {format 4} -} 4 -test case-1.4 {simple pattern} { - case x a {format 1} b {format 2} c {format 3} -} {} -test case-1.5 {simple pattern matches many times} { - case b a {format 1} b {format 2} b {format 3} b {format 4} -} 2 -test case-1.6 {fancier pattern} { - case cx a {format 1} *c {format 2} *x {format 3} default {format 4} -} 3 -test case-1.7 {list of patterns} { - case abc in {a b c} {format 1} {def abc ghi} {format 2} -} 2 - -test case-2.1 {error in executed command} { - list [catch {case a in a {error "Just a test"} default {format 1}} msg] \ - $msg $::errorInfo -} {1 {Just a test} {Just a test - while executing -"error "Just a test"" - ("a" arm line 1) - invoked from within -"case a in a {error "Just a test"} default {format 1}"}} -test case-2.2 {error: not enough args} { - list [catch {case} msg] $msg -} {1 {wrong # args: should be "case string ?in? ?pattern body ...? ?default body?"}} -test case-2.3 {error: pattern with no body} { - list [catch {case a b} msg] $msg -} {1 {extra case pattern with no body}} -test case-2.4 {error: pattern with no body} { - list [catch {case a in b {format 1} c} msg] $msg -} {1 {extra case pattern with no body}} -test case-2.5 {error in default command} { - list [catch {case foo in a {error case1} default {error case2} \ - b {error case 3}} msg] $msg $::errorInfo -} {1 case2 {case2 - while executing -"error case2" - ("default" arm line 1) - invoked from within -"case foo in a {error case1} default {error case2} b {error case 3}"}} - -test case-3.1 {single-argument form for pattern/command pairs} { - case b in { - a {format 1} - b {format 2} - default {format 6} - } -} {2} -test case-3.2 {single-argument form for pattern/command pairs} { - case b { - a {format 1} - b {format 2} - default {format 6} - } -} {2} -test case-3.3 {single-argument form for pattern/command pairs} { - list [catch {case z in {a 2 b}} msg] $msg -} {1 {extra case pattern with no body}} - -# cleanup -::tcltest::cleanupTests -return diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index bae26a0..0136ccd 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -20,12 +20,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { - testConstraint testmathfunctions 0 -} else { - testConstraint testmathfunctions 1 -} - # Big test for correct ordering of data in [expr] proc testIEEE {} { @@ -602,22 +596,6 @@ test compExpr-old-15.5 {CompileMathFuncCall: too few arguments} -body { test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body { expr sin(1 } -returnCodes error -match glob -result * -test compExpr-old-15.7 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr 2*T1() -} 246 -test compExpr-old-15.8 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T2()*3 -} 1035 -test compExpr-old-15.9 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T3(21, 37) -} 37 -test compExpr-old-15.10 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T3(21.2, 37) -} 37.0 -test compExpr-old-15.11 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T3(-21.2, -17.5) -} -17.5 - test compExpr-old-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} { catch {unset a} set a(VALUE) ff15 diff --git a/tests/compExpr.test b/tests/compExpr.test index 14c875d..3b44af8 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -16,12 +16,6 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { - testConstraint testmathfunctions 0 -} else { - testConstraint testmathfunctions 1 -} - # Constrain memory leak tests testConstraint memory [llength [info commands memory]] @@ -319,12 +313,6 @@ test compExpr-5.1 {CompileMathFuncCall procedure, math function found} { test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} -body { expr {do_it()} } -returnCodes error -match glob -result {* "*do_it"} -test compExpr-5.3 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr 3*T1()-1 -} 368 -test compExpr-5.4 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T2()*3 -} 1035 test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} -body { expr {atan2(1.0)} } -returnCodes error -match glob -result {too few arguments for math function*} diff --git a/tests/expr-old.test b/tests/expr-old.test index 3adfb63..cea20f1 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -24,12 +24,6 @@ testConstraint testexprdouble [llength [info commands testexprdouble]] testConstraint testexprstring [llength [info commands testexprstring]] testConstraint longIs32bit [expr {int(0x80000000) < 0}] -if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { - testConstraint testmathfunctions 0 -} else { - testConstraint testmathfunctions 1 -} - # Big test for correct ordering of data in [expr] proc testIEEE {} { @@ -847,12 +841,6 @@ test expr-old-32.41 {math functions in expressions} { test expr-old-32.42 {math functions in expressions} { list [catch {expr hypot(5*.8,3)} msg] $msg } {0 5.0} -test expr-old-32.43 {math functions in expressions} testmathfunctions { - expr 2*T1() -} 246 -test expr-old-32.44 {math functions in expressions} testmathfunctions { - expr T2()*3 -} 1035 test expr-old-32.45 {math functions in expressions} { expr (0 <= rand()) && (rand() < 1) } {1} @@ -952,11 +940,6 @@ test expr-old-34.15 {errors in math functions} { test expr-old-34.16 {errors in math functions} { expr round(-1.0e30) } -1000000000000000019884624838656 -test expr-old-34.17 {errors in math functions} -constraints testmathfunctions \ - -body { - list [catch {expr T1(4)} msg] $msg - } -match glob -result {1 {too many arguments for math function*}} - test expr-old-36.1 {ExprLooksLikeInt procedure} -body { expr 0o289 } -returnCodes error -match glob -result {*invalid octal number*} diff --git a/tests/expr.test b/tests/expr.test index 8e083c5..0b3620a 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -18,10 +18,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -testConstraint testmathfunctions [expr { - ([catch {expr T1()} msg] != 1) || ($msg ne {invalid command name "tcl::mathfunc::T1"}) -}] - # Determine if "long int" type is a 32 bit number and if the wide # type is a 64 bit number on this machine. @@ -685,41 +681,6 @@ test expr-15.5 {CompileMathFuncCall: too few arguments} -body { test expr-15.6 {CompileMathFuncCall: missing ')'} -body { expr sin(1 } -returnCodes error -match glob -result * -test expr-15.7 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr 2*T1() -} 246 -test expr-15.8 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr T2()*3 -} 1035 -test expr-15.9 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr T3(21, 37) -} 37 -test expr-15.10 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr T3(21.2, 37) -} 37.0 -test expr-15.11 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr T3(-21.2, -17.5) -} -17.5 -test expr-15.12 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(21, wide(37)) -} 37 -test expr=15.13 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(wide(21), 37) -} 37 -test expr=15.14 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(wide(21), wide(37)) -} 37 -test expr-15.15 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(21.0, wide(37)) -} 37.0 -test expr-15.16 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(wide(21), 37.0) -} 37.0 -test expr-15.17 {ExprCallMathFunc: non-numeric arg} -constraints { - testmathfunctions -} -body { - expr T3(0,"a") -} -returnCodes error -result {argument to math function didn't have numeric value} test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} { -- cgit v0.12 From 429acda3ee22bea891e82e69efc09872e7608915 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 9 Nov 2017 10:34:10 +0000 Subject: Put Tcl_EvalFile back, but then as a macro in terms of Tcl_FSEvalFileEx(). --- generic/tclDecls.h | 3 +++ generic/tclIOUtil.c | 24 +++++++++++------------- generic/tclStubInit.c | 2 ++ 3 files changed, 16 insertions(+), 13 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index c521845..7718588 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3984,5 +3984,8 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GlobalEvalObj #define Tcl_GlobalEvalObj(interp, objPtr) \ Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL) +#undef Tcl_EvalFile +#define Tcl_EvalFile(interp, fileName) \ + Tcl_FSEvalFileEx(interp, Tcl_NewStringObj(filename, -1), NULL); #endif /* _TCLDECLS */ diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 2c389c6..39a9474 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -412,21 +412,18 @@ Tcl_GetCwd( return Tcl_DStringValue(cwdPtr); } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* Obsolete */ +#undef Tcl_EvalFile int Tcl_EvalFile( Tcl_Interp *interp, /* Interpreter in which to process file. */ const char *fileName) /* Name of file to process. Tilde-substitution * will be performed on this name. */ { - int ret; - Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1); - - Tcl_IncrRefCount(pathPtr); - ret = Tcl_FSEvalFile(interp, pathPtr); - Tcl_DecrRefCount(pathPtr); - return ret; + return Tcl_FSEvalFileEx(interp, Tcl_NewStringObj(fileName, -1), NULL); } +#endif /* * Now move on to the basic filesystem implementation. @@ -1740,8 +1737,11 @@ Tcl_FSEvalFileEx( Tcl_Channel chan; Tcl_Obj *objPtr; + Tcl_IncrRefCount(pathPtr); + objPtr = Tcl_NewObj(); + Tcl_IncrRefCount(objPtr); if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { - return result; + goto end; } if (Tcl_FSStat(pathPtr, &statBuf) == -1) { @@ -1756,7 +1756,7 @@ Tcl_FSEvalFileEx( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", Tcl_GetString(pathPtr), Tcl_PosixError(interp))); - return result; + goto end; } /* @@ -1775,13 +1775,10 @@ Tcl_FSEvalFileEx( if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) != TCL_OK) { Tcl_Close(interp,chan); - return result; + goto end; } } - objPtr = Tcl_NewObj(); - Tcl_IncrRefCount(objPtr); - /* * Try to read first character of stream, so we can check for utf-8 BOM to * be handled especially. @@ -1857,6 +1854,7 @@ Tcl_FSEvalFileEx( end: Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(pathPtr); return result; } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 03ef7d6..eacc8ca 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -371,6 +371,8 @@ static int formatInt(char *buffer, int n){ # define Tcl_EvalObj 0 # undef Tcl_GlobalEvalObj # define Tcl_GlobalEvalObj 0 +# undef Tcl_EvalFile +# define Tcl_EvalFile 0 # define TclBackgroundException 0 # undef TclpReaddir # define TclpReaddir 0 -- cgit v0.12 From 56e7df256a6fc22cd478e4be02a8dca93634e942 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 9 Nov 2017 11:04:49 +0000 Subject: No longer mark Tcl_EvalFile() as obsolete/deprecated. Thanks to all feedback to TIP #485! --- generic/tcl.decls | 4 ++-- generic/tclDecls.h | 5 ++--- generic/tclEncoding.c | 2 ++ generic/tclStubInit.c | 3 +-- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index f7ffd29..1083adc 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -469,8 +469,8 @@ declare 128 { declare 129 { int Tcl_Eval(Tcl_Interp *interp, const char *script) } -# This is obsolete, use Tcl_FSEvalFile -declare 130 {deprecated {Use Tcl_FSEvalFile}} { +# Stub entry no longer needed. It is now a macro in terms of Tcl_FSEvalFileEx(). +declare 130 { int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName) } declare 131 { diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 7718588..9241175 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -420,8 +420,7 @@ EXTERN CONST84_RETURN char * Tcl_ErrnoMsg(int err); /* 129 */ EXTERN int Tcl_Eval(Tcl_Interp *interp, const char *script); /* 130 */ -TCL_DEPRECATED("Use Tcl_FSEvalFile") -int Tcl_EvalFile(Tcl_Interp *interp, +EXTERN int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName); /* 131 */ EXTERN int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -1996,7 +1995,7 @@ typedef struct TclStubs { CONST84_RETURN char * (*tcl_ErrnoId) (void); /* 127 */ CONST84_RETURN char * (*tcl_ErrnoMsg) (int err); /* 128 */ int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */ - TCL_DEPRECATED_API("Use Tcl_FSEvalFile") int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */ + int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */ int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */ void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */ TCL_NORETURN1 void (*tcl_Exit) (int status); /* 133 */ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 1f48a1c..b0c595c 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -693,6 +693,7 @@ TclFinalizeEncodingSubsystem(void) *------------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 const char * Tcl_GetDefaultEncodingDir(void) { @@ -736,6 +737,7 @@ Tcl_SetDefaultEncodingDir( Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory); Tcl_SetEncodingSearchPath(searchPath); } +#endif /* *------------------------------------------------------------------------- diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index eacc8ca..d276dbc 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -72,8 +72,7 @@ static int TclSockMinimumBuffersOld(int sock, int size) # define TclBNInitBignumFromWideUInt 0 # define TclBNInitBignumFromWideInt 0 # define TclBNInitBignumFromLong 0 -# define Tcl_BackSlash 0 -# define Tcl_EvalFile 0 +# define Tcl_Backslash 0 # define Tcl_GetDefaultEncodingDir 0 # define Tcl_SetDefaultEncodingDir 0 # define Tcl_EvalTokens 0 -- cgit v0.12 From a037934e2165dc52888a2daa656c9e5d5ddc980e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 9 Nov 2017 11:49:10 +0000 Subject: Get rid of Tcl_DStringTrunc et al, as described in the TIP (Thanks, Don!). --- generic/tcl.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 80c8dcb..54c6b73 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -997,7 +997,7 @@ typedef struct Tcl_DString { #define Tcl_DStringLength(dsPtr) ((dsPtr)->length) #define Tcl_DStringValue(dsPtr) ((dsPtr)->string) -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # define Tcl_DStringTrunc Tcl_DStringSetLength #endif /* !TCL_NO_DEPRECATED */ @@ -2615,7 +2615,7 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); * Deprecated Tcl functions: */ -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* * These function have been renamed. The old names are deprecated, but we * define these macros for backwards compatibilty. -- cgit v0.12 From 52b098ca11d6cbae8661a4d1e1461335674f2ce2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Nov 2017 16:26:03 +0000 Subject: Deprecate support for macro's like CONST, CONST84, _ANSI_ARGS_, INLINE, TCL_VARARGS --- generic/tcl.decls | 82 +++++++++++------------ generic/tcl.h | 41 +++--------- generic/tclDecls.h | 181 ++++++++++++++++++++++++-------------------------- generic/tclInt.decls | 10 +-- generic/tclInt.h | 6 +- generic/tclIntDecls.h | 14 ++-- 6 files changed, 153 insertions(+), 181 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index fd7468a..60aebfd 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -32,7 +32,7 @@ declare 0 { const char *version, const void *clientData) } declare 1 { - CONST84_RETURN char *Tcl_PkgRequireEx(Tcl_Interp *interp, + const char *Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr) } @@ -154,7 +154,7 @@ declare 35 { } declare 36 { int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr) + const char *const *tablePtr, const char *msg, int flags, int *indexPtr) } declare 37 { int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr) @@ -306,7 +306,7 @@ declare 82 { int Tcl_CommandComplete(const char *cmd) } declare 83 { - char *Tcl_Concat(int argc, CONST84 char *const *argv) + char *Tcl_Concat(int argc, const char *const *argv) } declare 84 { int Tcl_ConvertElement(const char *src, char *dst, int flags) @@ -318,7 +318,7 @@ declare 85 { declare 86 { int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, - CONST84 char *const *argv) + const char *const *argv) } declare 87 { int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd, @@ -461,10 +461,10 @@ declare 126 { int Tcl_Eof(Tcl_Channel chan) } declare 127 { - CONST84_RETURN char *Tcl_ErrnoId(void) + const char *Tcl_ErrnoId(void) } declare 128 { - CONST84_RETURN char *Tcl_ErrnoMsg(int err) + const char *Tcl_ErrnoMsg(int err) } declare 129 { int Tcl_Eval(Tcl_Interp *interp, const char *script) @@ -528,12 +528,12 @@ declare 147 { } declare 148 { int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, - Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, - int *argcPtr, CONST84 char ***argvPtr) + Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, + int *argcPtr, const char ***argvPtr) } declare 149 { int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd, - Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, + Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv) } declare 150 { @@ -558,7 +558,7 @@ declare 155 { int Tcl_GetChannelMode(Tcl_Channel chan) } declare 156 { - CONST84_RETURN char *Tcl_GetChannelName(Tcl_Channel chan) + const char *Tcl_GetChannelName(Tcl_Channel chan) } declare 157 { int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, @@ -572,14 +572,14 @@ declare 159 { Tcl_CmdInfo *infoPtr) } declare 160 { - CONST84_RETURN char *Tcl_GetCommandName(Tcl_Interp *interp, + const char *Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command) } declare 161 { int Tcl_GetErrno(void) } declare 162 { - CONST84_RETURN char *Tcl_GetHostName(void) + const char *Tcl_GetHostName(void) } declare 163 { int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp) @@ -622,14 +622,14 @@ declare 173 { Tcl_Channel Tcl_GetStdChannel(int type) } declare 174 { - CONST84_RETURN char *Tcl_GetStringResult(Tcl_Interp *interp) + const char *Tcl_GetStringResult(Tcl_Interp *interp) } declare 175 { - CONST84_RETURN char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, + const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, int flags) } declare 176 { - CONST84_RETURN char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1, + const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags) } declare 177 { @@ -662,7 +662,7 @@ declare 185 { } # Obsolete, use Tcl_FSJoinPath declare 186 { - char *Tcl_JoinPath(int argc, CONST84 char *const *argv, + char *Tcl_JoinPath(int argc, const char *const *argv, Tcl_DString *resultPtr) } declare 187 { @@ -685,7 +685,7 @@ declare 191 { Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket) } declare 192 { - char *Tcl_Merge(int argc, CONST84 char *const *argv) + char *Tcl_Merge(int argc, const char *const *argv) } declare 193 { Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr) @@ -703,7 +703,7 @@ declare 196 { } declare 197 { Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, - CONST84 char **argv, int flags) + const char **argv, int flags) } # This is obsolete, use Tcl_FSOpenFileChannel declare 198 { @@ -729,7 +729,7 @@ declare 203 { int Tcl_PutEnv(const char *assignment) } declare 204 { - CONST84_RETURN char *Tcl_PosixError(Tcl_Interp *interp) + const char *Tcl_PosixError(Tcl_Interp *interp) } declare 205 { void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position) @@ -765,7 +765,7 @@ declare 214 { } declare 215 { void Tcl_RegExpRange(Tcl_RegExp regexp, int index, - CONST84 char **startPtr, CONST84 char **endPtr) + const char **startPtr, const char **endPtr) } declare 216 { void Tcl_Release(ClientData clientData) @@ -835,29 +835,29 @@ declare 236 { void Tcl_SetStdChannel(Tcl_Channel channel, int type) } declare 237 { - CONST84_RETURN char *Tcl_SetVar(Tcl_Interp *interp, const char *varName, + const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName, const char *newValue, int flags) } declare 238 { - CONST84_RETURN char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1, + const char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags) } declare 239 { - CONST84_RETURN char *Tcl_SignalId(int sig) + const char *Tcl_SignalId(int sig) } declare 240 { - CONST84_RETURN char *Tcl_SignalMsg(int sig) + const char *Tcl_SignalMsg(int sig) } declare 241 { void Tcl_SourceRCFile(Tcl_Interp *interp) } declare 242 { int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, - CONST84 char ***argvPtr) + const char ***argvPtr) } # Obsolete, use Tcl_FSSplitPath declare 243 { - void Tcl_SplitPath(const char *path, int *argcPtr, CONST84 char ***argvPtr) + void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr) } declare 244 { void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, @@ -952,15 +952,15 @@ declare 269 { char *Tcl_HashStats(Tcl_HashTable *tablePtr) } declare 270 { - CONST84_RETURN char *Tcl_ParseVar(Tcl_Interp *interp, const char *start, - CONST84 char **termPtr) + const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start, + const char **termPtr) } declare 271 { - CONST84_RETURN char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name, + const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name, const char *version, int exact) } declare 272 { - CONST84_RETURN char *Tcl_PkgPresentEx(Tcl_Interp *interp, + const char *Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr) } @@ -970,7 +970,7 @@ declare 273 { } # TIP #268: The internally used new Require function is in slot 573. declare 274 { - CONST84_RETURN char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, + const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, const char *version, int exact) } declare 275 {deprecated {see TIP #422}} { @@ -1084,7 +1084,7 @@ declare 301 { Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name) } declare 302 { - CONST84_RETURN char *Tcl_GetEncodingName(Tcl_Encoding encoding) + const char *Tcl_GetEncodingName(Tcl_Encoding encoding) } declare 303 { void Tcl_GetEncodingNames(Tcl_Interp *interp) @@ -1160,7 +1160,7 @@ declare 324 { int Tcl_UniCharToUtf(int ch, char *buf) } declare 325 { - CONST84_RETURN char *Tcl_UtfAtIndex(const char *src, int index) + const char *Tcl_UtfAtIndex(const char *src, int index) } declare 326 { int Tcl_UtfCharComplete(const char *src, int length) @@ -1169,16 +1169,16 @@ declare 327 { int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst) } declare 328 { - CONST84_RETURN char *Tcl_UtfFindFirst(const char *src, int ch) + const char *Tcl_UtfFindFirst(const char *src, int ch) } declare 329 { - CONST84_RETURN char *Tcl_UtfFindLast(const char *src, int ch) + const char *Tcl_UtfFindLast(const char *src, int ch) } declare 330 { - CONST84_RETURN char *Tcl_UtfNext(const char *src) + const char *Tcl_UtfNext(const char *src) } declare 331 { - CONST84_RETURN char *Tcl_UtfPrev(const char *src, const char *start) + const char *Tcl_UtfPrev(const char *src, const char *start) } declare 332 { int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, @@ -1212,7 +1212,7 @@ declare 340 { char *Tcl_GetString(Tcl_Obj *objPtr) } declare 341 {deprecated {Use Tcl_GetEncodingSearchPath}} { - CONST84_RETURN char *Tcl_GetDefaultEncodingDir(void) + const char *Tcl_GetDefaultEncodingDir(void) } declare 342 {deprecated {Use Tcl_SetEncodingSearchPath}} { void Tcl_SetDefaultEncodingDir(const char *path) @@ -1276,7 +1276,7 @@ declare 359 { } declare 360 { int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, int numBytes, - Tcl_Parse *parsePtr, int append, CONST84 char **termPtr) + Tcl_Parse *parsePtr, int append, const char **termPtr) } declare 361 { int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes, @@ -1289,7 +1289,7 @@ declare 362 { declare 363 { int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, - CONST84 char **termPtr) + const char **termPtr) } declare 364 { int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes, @@ -1405,7 +1405,7 @@ declare 397 { int Tcl_ChannelBuffered(Tcl_Channel chan) } declare 398 { - CONST84_RETURN char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr) + const char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr) } declare 399 { Tcl_ChannelTypeVersion Tcl_ChannelVersion( diff --git a/generic/tcl.h b/generic/tcl.h index 23a0a9a..e054c19 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -137,7 +137,7 @@ extern "C" { */ #include -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # define TCL_VARARGS(type, name) (type name, ...) # define TCL_VARARGS_DEF(type, name) (type name, ...) # define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) @@ -254,10 +254,9 @@ extern "C" { * New code should use prototypes. */ -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # undef _ANSI_ARGS_ # define _ANSI_ARGS_(x) x -#endif /* !TCL_NO_DEPRECATED */ /* * Definitions that allow this header file to be used either with or without @@ -267,34 +266,16 @@ extern "C" { #ifndef INLINE # define INLINE #endif - -#ifdef NO_CONST -# ifndef const -# define const -# endif -#endif #ifndef CONST # define CONST const #endif +#define CONST84 const +#define CONST84_RETURN const -#ifdef USE_NON_CONST -# ifdef USE_COMPAT_CONST -# error define at most one of USE_NON_CONST and USE_COMPAT_CONST -# endif -# define CONST84 -# define CONST84_RETURN -#else -# ifdef USE_COMPAT_CONST -# define CONST84 -# define CONST84_RETURN const -# else -# define CONST84 const -# define CONST84_RETURN const -# endif -#endif +#endif /* !TCL_NO_DEPRECATED */ #ifndef CONST86 -# define CONST86 CONST84 +# define CONST86 const #endif /* @@ -720,10 +701,10 @@ typedef void (Tcl_ChannelProc) (ClientData clientData, int mask); typedef void (Tcl_CloseProc) (ClientData data); typedef void (Tcl_CmdDeleteProc) (ClientData clientData); typedef int (Tcl_CmdProc) (ClientData clientData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); + int argc, const char *argv[]); typedef void (Tcl_CmdTraceProc) (ClientData clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, - ClientData cmdClientData, int argc, CONST84 char *argv[]); + ClientData cmdClientData, int argc, const char *argv[]); typedef int (Tcl_CmdObjTraceProc) (ClientData clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj *const *objv); @@ -760,7 +741,7 @@ typedef void (Tcl_TimerProc) (ClientData clientData); typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr); typedef void (Tcl_UpdateStringProc) (struct Tcl_Obj *objPtr); typedef char * (Tcl_VarTraceProc) (ClientData clientData, Tcl_Interp *interp, - CONST84 char *part1, CONST84 char *part2, int flags); + const char *part1, const char *part2, int flags); typedef void (Tcl_CommandTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); typedef void (Tcl_CreateFileHandlerProc) (int fd, int mask, Tcl_FileProc *proc, @@ -1478,14 +1459,14 @@ typedef int (Tcl_DriverClose2Proc) (ClientData instanceData, typedef int (Tcl_DriverInputProc) (ClientData instanceData, char *buf, int toRead, int *errorCodePtr); typedef int (Tcl_DriverOutputProc) (ClientData instanceData, - CONST84 char *buf, int toWrite, int *errorCodePtr); + const char *buf, int toWrite, int *errorCodePtr); typedef int (Tcl_DriverSeekProc) (ClientData instanceData, long offset, int mode, int *errorCodePtr); typedef int (Tcl_DriverSetOptionProc) (ClientData instanceData, Tcl_Interp *interp, const char *optionName, const char *value); typedef int (Tcl_DriverGetOptionProc) (ClientData instanceData, - Tcl_Interp *interp, CONST84 char *optionName, + Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); typedef void (Tcl_DriverWatchProc) (ClientData instanceData, int mask); typedef int (Tcl_DriverGetHandleProc) (ClientData instanceData, diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 3afe45a..0c1505b 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -53,7 +53,7 @@ EXTERN int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 1 */ -EXTERN CONST84_RETURN char * Tcl_PkgRequireEx(Tcl_Interp *interp, +EXTERN const char * Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 2 */ @@ -159,8 +159,7 @@ EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 36 */ EXTERN int Tcl_GetIndexFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, - CONST84 char *const *tablePtr, + Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 37 */ EXTERN int Tcl_GetInt(Tcl_Interp *interp, const char *src, @@ -281,7 +280,7 @@ EXTERN int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan); /* 82 */ EXTERN int Tcl_CommandComplete(const char *cmd); /* 83 */ -EXTERN char * Tcl_Concat(int argc, CONST84 char *const *argv); +EXTERN char * Tcl_Concat(int argc, const char *const *argv); /* 84 */ EXTERN int Tcl_ConvertElement(const char *src, char *dst, int flags); @@ -292,7 +291,7 @@ EXTERN int Tcl_ConvertCountedElement(const char *src, EXTERN int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, - CONST84 char *const *argv); + const char *const *argv); /* 87 */ EXTERN int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, @@ -414,9 +413,9 @@ EXTERN void Tcl_DStringStartSublist(Tcl_DString *dsPtr); /* 126 */ EXTERN int Tcl_Eof(Tcl_Channel chan); /* 127 */ -EXTERN CONST84_RETURN char * Tcl_ErrnoId(void); +EXTERN const char * Tcl_ErrnoId(void); /* 128 */ -EXTERN CONST84_RETURN char * Tcl_ErrnoMsg(int err); +EXTERN const char * Tcl_ErrnoMsg(int err); /* 129 */ EXTERN int Tcl_Eval(Tcl_Interp *interp, const char *script); /* 130 */ @@ -471,13 +470,13 @@ EXTERN void Tcl_FreeResult(Tcl_Interp *interp); EXTERN int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, - CONST84 char **targetCmdPtr, int *argcPtr, - CONST84 char ***argvPtr); + const char **targetCmdPtr, int *argcPtr, + const char ***argvPtr); /* 149 */ EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, - CONST84 char **targetCmdPtr, int *objcPtr, + const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 150 */ EXTERN ClientData Tcl_GetAssocData(Tcl_Interp *interp, @@ -496,7 +495,7 @@ EXTERN ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan); /* 155 */ EXTERN int Tcl_GetChannelMode(Tcl_Channel chan); /* 156 */ -EXTERN CONST84_RETURN char * Tcl_GetChannelName(Tcl_Channel chan); +EXTERN const char * Tcl_GetChannelName(Tcl_Channel chan); /* 157 */ EXTERN int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, @@ -507,12 +506,12 @@ EXTERN CONST86 Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan); EXTERN int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 160 */ -EXTERN CONST84_RETURN char * Tcl_GetCommandName(Tcl_Interp *interp, +EXTERN const char * Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command); /* 161 */ EXTERN int Tcl_GetErrno(void); /* 162 */ -EXTERN CONST84_RETURN char * Tcl_GetHostName(void); +EXTERN const char * Tcl_GetHostName(void); /* 163 */ EXTERN int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp); @@ -548,14 +547,13 @@ EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel(int type); /* 174 */ -EXTERN CONST84_RETURN char * Tcl_GetStringResult(Tcl_Interp *interp); +EXTERN const char * Tcl_GetStringResult(Tcl_Interp *interp); /* 175 */ -EXTERN CONST84_RETURN char * Tcl_GetVar(Tcl_Interp *interp, - const char *varName, int flags); -/* 176 */ -EXTERN CONST84_RETURN char * Tcl_GetVar2(Tcl_Interp *interp, - const char *part1, const char *part2, +EXTERN const char * Tcl_GetVar(Tcl_Interp *interp, const char *varName, int flags); +/* 176 */ +EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1, + const char *part2, int flags); /* 177 */ EXTERN int Tcl_GlobalEval(Tcl_Interp *interp, const char *command); @@ -580,7 +578,7 @@ EXTERN int Tcl_InterpDeleted(Tcl_Interp *interp); /* 185 */ EXTERN int Tcl_IsSafe(Tcl_Interp *interp); /* 186 */ -EXTERN char * Tcl_JoinPath(int argc, CONST84 char *const *argv, +EXTERN char * Tcl_JoinPath(int argc, const char *const *argv, Tcl_DString *resultPtr); /* 187 */ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, @@ -593,7 +591,7 @@ EXTERN int Tcl_MakeSafe(Tcl_Interp *interp); /* 191 */ EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket); /* 192 */ -EXTERN char * Tcl_Merge(int argc, CONST84 char *const *argv); +EXTERN char * Tcl_Merge(int argc, const char *const *argv); /* 193 */ EXTERN Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr); /* 194 */ @@ -607,7 +605,7 @@ EXTERN Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, int flags); /* 197 */ EXTERN Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, - CONST84 char **argv, int flags); + const char **argv, int flags); /* 198 */ EXTERN Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, const char *fileName, const char *modeString, @@ -629,7 +627,7 @@ EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value, /* 203 */ EXTERN int Tcl_PutEnv(const char *assignment); /* 204 */ -EXTERN CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp); +EXTERN const char * Tcl_PosixError(Tcl_Interp *interp); /* 205 */ EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position); @@ -659,8 +657,7 @@ EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, const char *pattern); /* 215 */ EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, int index, - CONST84 char **startPtr, - CONST84 char **endPtr); + const char **startPtr, const char **endPtr); /* 216 */ EXTERN void Tcl_Release(ClientData clientData); /* 217 */ @@ -716,26 +713,25 @@ EXTERN void Tcl_SetObjResult(Tcl_Interp *interp, /* 236 */ EXTERN void Tcl_SetStdChannel(Tcl_Channel channel, int type); /* 237 */ -EXTERN CONST84_RETURN char * Tcl_SetVar(Tcl_Interp *interp, - const char *varName, const char *newValue, - int flags); -/* 238 */ -EXTERN CONST84_RETURN char * Tcl_SetVar2(Tcl_Interp *interp, - const char *part1, const char *part2, +EXTERN const char * Tcl_SetVar(Tcl_Interp *interp, const char *varName, const char *newValue, int flags); +/* 238 */ +EXTERN const char * Tcl_SetVar2(Tcl_Interp *interp, const char *part1, + const char *part2, const char *newValue, + int flags); /* 239 */ -EXTERN CONST84_RETURN char * Tcl_SignalId(int sig); +EXTERN const char * Tcl_SignalId(int sig); /* 240 */ -EXTERN CONST84_RETURN char * Tcl_SignalMsg(int sig); +EXTERN const char * Tcl_SignalMsg(int sig); /* 241 */ EXTERN void Tcl_SourceRCFile(Tcl_Interp *interp); /* 242 */ EXTERN int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, - CONST84 char ***argvPtr); + const char ***argvPtr); /* 243 */ EXTERN void Tcl_SplitPath(const char *path, int *argcPtr, - CONST84 char ***argvPtr); + const char ***argvPtr); /* 244 */ EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, @@ -826,23 +822,21 @@ void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, /* 269 */ EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr); /* 270 */ -EXTERN CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp, - const char *start, CONST84 char **termPtr); +EXTERN const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start, + const char **termPtr); /* 271 */ -EXTERN CONST84_RETURN char * Tcl_PkgPresent(Tcl_Interp *interp, - const char *name, const char *version, - int exact); +EXTERN const char * Tcl_PkgPresent(Tcl_Interp *interp, const char *name, + const char *version, int exact); /* 272 */ -EXTERN CONST84_RETURN char * Tcl_PkgPresentEx(Tcl_Interp *interp, +EXTERN const char * Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 273 */ EXTERN int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, const char *version); /* 274 */ -EXTERN CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp, - const char *name, const char *version, - int exact); +EXTERN const char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name, + const char *version, int exact); /* 275 */ TCL_DEPRECATED("see TIP #422") void Tcl_SetErrorCodeVA(Tcl_Interp *interp, @@ -919,7 +913,7 @@ EXTERN Tcl_ThreadId Tcl_GetCurrentThread(void); /* 301 */ EXTERN Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name); /* 302 */ -EXTERN CONST84_RETURN char * Tcl_GetEncodingName(Tcl_Encoding encoding); +EXTERN const char * Tcl_GetEncodingName(Tcl_Encoding encoding); /* 303 */ EXTERN void Tcl_GetEncodingNames(Tcl_Interp *interp); /* 304 */ @@ -978,20 +972,20 @@ EXTERN Tcl_UniChar Tcl_UniCharToUpper(int ch); /* 324 */ EXTERN int Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ -EXTERN CONST84_RETURN char * Tcl_UtfAtIndex(const char *src, int index); +EXTERN const char * Tcl_UtfAtIndex(const char *src, int index); /* 326 */ EXTERN int Tcl_UtfCharComplete(const char *src, int length); /* 327 */ EXTERN int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst); /* 328 */ -EXTERN CONST84_RETURN char * Tcl_UtfFindFirst(const char *src, int ch); +EXTERN const char * Tcl_UtfFindFirst(const char *src, int ch); /* 329 */ -EXTERN CONST84_RETURN char * Tcl_UtfFindLast(const char *src, int ch); +EXTERN const char * Tcl_UtfFindLast(const char *src, int ch); /* 330 */ -EXTERN CONST84_RETURN char * Tcl_UtfNext(const char *src); +EXTERN const char * Tcl_UtfNext(const char *src); /* 331 */ -EXTERN CONST84_RETURN char * Tcl_UtfPrev(const char *src, const char *start); +EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); /* 332 */ EXTERN int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, @@ -1020,7 +1014,7 @@ EXTERN int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); EXTERN char * Tcl_GetString(Tcl_Obj *objPtr); /* 341 */ TCL_DEPRECATED("Use Tcl_GetEncodingSearchPath") -CONST84_RETURN char * Tcl_GetDefaultEncodingDir(void); +const char * Tcl_GetDefaultEncodingDir(void); /* 342 */ TCL_DEPRECATED("Use Tcl_SetEncodingSearchPath") void Tcl_SetDefaultEncodingDir(const char *path); @@ -1071,7 +1065,7 @@ EXTERN void Tcl_LogCommandInfo(Tcl_Interp *interp, EXTERN int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, - CONST84 char **termPtr); + const char **termPtr); /* 361 */ EXTERN int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes, int nested, @@ -1083,7 +1077,7 @@ EXTERN int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, EXTERN int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, - CONST84 char **termPtr); + const char **termPtr); /* 364 */ EXTERN int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes, @@ -1173,8 +1167,7 @@ EXTERN Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan); /* 397 */ EXTERN int Tcl_ChannelBuffered(Tcl_Channel chan); /* 398 */ -EXTERN CONST84_RETURN char * Tcl_ChannelName( - const Tcl_ChannelType *chanTypePtr); +EXTERN const char * Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr); /* 399 */ EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion( const Tcl_ChannelType *chanTypePtr); @@ -1857,7 +1850,7 @@ typedef struct TclStubs { const TclStubHooks *hooks; int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */ - CONST84_RETURN char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */ + const char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */ TCL_NORETURN1 void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */ char * (*tcl_Alloc) (unsigned int size); /* 3 */ void (*tcl_Free) (char *ptr); /* 4 */ @@ -1908,7 +1901,7 @@ typedef struct TclStubs { unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */ int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */ int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */ - int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */ + int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */ int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */ int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */ int (*tcl_GetLongFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 39 */ @@ -1955,10 +1948,10 @@ typedef struct TclStubs { void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, ClientData clientData); /* 80 */ int (*tcl_Close) (Tcl_Interp *interp, Tcl_Channel chan); /* 81 */ int (*tcl_CommandComplete) (const char *cmd); /* 82 */ - char * (*tcl_Concat) (int argc, CONST84 char *const *argv); /* 83 */ + char * (*tcl_Concat) (int argc, const char *const *argv); /* 83 */ int (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */ int (*tcl_ConvertCountedElement) (const char *src, int length, char *dst, int flags); /* 85 */ - int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 86 */ + int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */ int (*tcl_CreateAliasObj) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */ Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, ClientData instanceData, int mask); /* 88 */ void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData); /* 89 */ @@ -1999,8 +1992,8 @@ typedef struct TclStubs { void (*tcl_DStringSetLength) (Tcl_DString *dsPtr, int length); /* 124 */ void (*tcl_DStringStartSublist) (Tcl_DString *dsPtr); /* 125 */ int (*tcl_Eof) (Tcl_Channel chan); /* 126 */ - CONST84_RETURN char * (*tcl_ErrnoId) (void); /* 127 */ - CONST84_RETURN char * (*tcl_ErrnoMsg) (int err); /* 128 */ + const char * (*tcl_ErrnoId) (void); /* 127 */ + const char * (*tcl_ErrnoMsg) (int err); /* 128 */ int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */ int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */ int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */ @@ -2020,21 +2013,21 @@ typedef struct TclStubs { Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */ int (*tcl_Flush) (Tcl_Channel chan); /* 146 */ void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ - int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */ - int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ + int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */ + int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ ClientData (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */ int (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */ int (*tcl_GetChannelHandle) (Tcl_Channel chan, int direction, ClientData *handlePtr); /* 153 */ ClientData (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */ int (*tcl_GetChannelMode) (Tcl_Channel chan); /* 155 */ - CONST84_RETURN char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */ + const char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */ int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 157 */ CONST86 Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */ int (*tcl_GetCommandInfo) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 159 */ - CONST84_RETURN char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ + const char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ int (*tcl_GetErrno) (void); /* 161 */ - CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */ + const char * (*tcl_GetHostName) (void); /* 162 */ int (*tcl_GetInterpPath) (Tcl_Interp *askInterp, Tcl_Interp *slaveInterp); /* 163 */ Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */ const char * (*tcl_GetNameOfExecutable) (void); /* 165 */ @@ -2054,9 +2047,9 @@ typedef struct TclStubs { int (*tcl_GetServiceMode) (void); /* 171 */ Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */ Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */ - CONST84_RETURN char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */ - CONST84_RETURN char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */ - CONST84_RETURN char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */ + const char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */ + const char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */ + const char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */ int (*tcl_GlobalEval) (Tcl_Interp *interp, const char *command); /* 177 */ int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */ int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */ @@ -2066,25 +2059,25 @@ typedef struct TclStubs { int (*tcl_InputBuffered) (Tcl_Channel chan); /* 183 */ int (*tcl_InterpDeleted) (Tcl_Interp *interp); /* 184 */ int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */ - char * (*tcl_JoinPath) (int argc, CONST84 char *const *argv, Tcl_DString *resultPtr); /* 186 */ + char * (*tcl_JoinPath) (int argc, const char *const *argv, Tcl_DString *resultPtr); /* 186 */ int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, char *addr, int type); /* 187 */ void (*reserved188)(void); Tcl_Channel (*tcl_MakeFileChannel) (ClientData handle, int mode); /* 189 */ int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */ Tcl_Channel (*tcl_MakeTcpClientChannel) (ClientData tcpSocket); /* 191 */ - char * (*tcl_Merge) (int argc, CONST84 char *const *argv); /* 192 */ + char * (*tcl_Merge) (int argc, const char *const *argv); /* 192 */ Tcl_HashEntry * (*tcl_NextHashEntry) (Tcl_HashSearch *searchPtr); /* 193 */ void (*tcl_NotifyChannel) (Tcl_Channel channel, int mask); /* 194 */ Tcl_Obj * (*tcl_ObjGetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 195 */ Tcl_Obj * (*tcl_ObjSetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 196 */ - Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, CONST84 char **argv, int flags); /* 197 */ + Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, const char **argv, int flags); /* 197 */ Tcl_Channel (*tcl_OpenFileChannel) (Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions); /* 198 */ Tcl_Channel (*tcl_OpenTcpClient) (Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int async); /* 199 */ Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 200 */ void (*tcl_Preserve) (ClientData data); /* 201 */ void (*tcl_PrintDouble) (Tcl_Interp *interp, double value, char *dst); /* 202 */ int (*tcl_PutEnv) (const char *assignment); /* 203 */ - CONST84_RETURN char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */ + const char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */ void (*tcl_QueueEvent) (Tcl_Event *evPtr, Tcl_QueuePosition position); /* 205 */ int (*tcl_Read) (Tcl_Channel chan, char *bufPtr, int toRead); /* 206 */ void (*tcl_ReapDetachedProcs) (void); /* 207 */ @@ -2095,7 +2088,7 @@ typedef struct TclStubs { Tcl_RegExp (*tcl_RegExpCompile) (Tcl_Interp *interp, const char *pattern); /* 212 */ int (*tcl_RegExpExec) (Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 213 */ int (*tcl_RegExpMatch) (Tcl_Interp *interp, const char *text, const char *pattern); /* 214 */ - void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, CONST84 char **startPtr, CONST84 char **endPtr); /* 215 */ + void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, const char **startPtr, const char **endPtr); /* 215 */ void (*tcl_Release) (ClientData clientData); /* 216 */ void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */ int (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */ @@ -2117,13 +2110,13 @@ typedef struct TclStubs { void (*tcl_SetObjErrorCode) (Tcl_Interp *interp, Tcl_Obj *errorObjPtr); /* 234 */ void (*tcl_SetObjResult) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 235 */ void (*tcl_SetStdChannel) (Tcl_Channel channel, int type); /* 236 */ - CONST84_RETURN char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */ - CONST84_RETURN char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */ - CONST84_RETURN char * (*tcl_SignalId) (int sig); /* 239 */ - CONST84_RETURN char * (*tcl_SignalMsg) (int sig); /* 240 */ + const char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */ + const char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */ + const char * (*tcl_SignalId) (int sig); /* 239 */ + const char * (*tcl_SignalMsg) (int sig); /* 240 */ void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */ - int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, CONST84 char ***argvPtr); /* 242 */ - void (*tcl_SplitPath) (const char *path, int *argcPtr, CONST84 char ***argvPtr); /* 243 */ + int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 242 */ + void (*tcl_SplitPath) (const char *path, int *argcPtr, const char ***argvPtr); /* 243 */ void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */ int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */ TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ @@ -2150,11 +2143,11 @@ typedef struct TclStubs { TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */ char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */ - CONST84_RETURN char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, CONST84 char **termPtr); /* 270 */ - CONST84_RETURN char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */ - CONST84_RETURN char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ + const char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, const char **termPtr); /* 270 */ + const char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */ + const char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */ - CONST84_RETURN char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */ + const char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */ TCL_DEPRECATED_API("see TIP #422") void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */ TCL_DEPRECATED_API("see TIP #422") int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */ Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */ @@ -2182,7 +2175,7 @@ typedef struct TclStubs { void (*tcl_FreeEncoding) (Tcl_Encoding encoding); /* 299 */ Tcl_ThreadId (*tcl_GetCurrentThread) (void); /* 300 */ Tcl_Encoding (*tcl_GetEncoding) (Tcl_Interp *interp, const char *name); /* 301 */ - CONST84_RETURN char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */ + const char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */ void (*tcl_GetEncodingNames) (Tcl_Interp *interp); /* 303 */ int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, int offset, const char *msg, int flags, int *indexPtr); /* 304 */ void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, int size); /* 305 */ @@ -2205,13 +2198,13 @@ typedef struct TclStubs { Tcl_UniChar (*tcl_UniCharToTitle) (int ch); /* 322 */ Tcl_UniChar (*tcl_UniCharToUpper) (int ch); /* 323 */ int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ - CONST84_RETURN char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */ + const char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */ int (*tcl_UtfCharComplete) (const char *src, int length); /* 326 */ int (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ - CONST84_RETURN char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ - CONST84_RETURN char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */ - CONST84_RETURN char * (*tcl_UtfNext) (const char *src); /* 330 */ - CONST84_RETURN char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */ + const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ + const char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */ + const char * (*tcl_UtfNext) (const char *src); /* 330 */ + const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */ int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */ char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 333 */ int (*tcl_UtfToLower) (char *src); /* 334 */ @@ -2221,7 +2214,7 @@ typedef struct TclStubs { int (*tcl_WriteChars) (Tcl_Channel chan, const char *src, int srcLen); /* 338 */ int (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */ - TCL_DEPRECATED_API("Use Tcl_GetEncodingSearchPath") CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */ + TCL_DEPRECATED_API("Use Tcl_GetEncodingSearchPath") const char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */ TCL_DEPRECATED_API("Use Tcl_SetEncodingSearchPath") void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */ void (*tcl_AlertNotifier) (ClientData clientData); /* 343 */ void (*tcl_ServiceModeHook) (int mode); /* 344 */ @@ -2240,10 +2233,10 @@ typedef struct TclStubs { TCL_DEPRECATED_API("Use Tcl_EvalTokensStandard") Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */ void (*tcl_FreeParse) (Tcl_Parse *parsePtr); /* 358 */ void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, int length); /* 359 */ - int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 360 */ + int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 360 */ int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, int numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */ int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr); /* 362 */ - int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 363 */ + int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 363 */ int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append); /* 364 */ char * (*tcl_GetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 365 */ int (*tcl_Chdir) (const char *dirName); /* 366 */ @@ -2278,7 +2271,7 @@ typedef struct TclStubs { int (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, int srcLen); /* 395 */ Tcl_Channel (*tcl_GetTopChannel) (Tcl_Channel chan); /* 396 */ int (*tcl_ChannelBuffered) (Tcl_Channel chan); /* 397 */ - CONST84_RETURN char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */ + const char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */ Tcl_ChannelTypeVersion (*tcl_ChannelVersion) (const Tcl_ChannelType *chanTypePtr); /* 399 */ Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) (const Tcl_ChannelType *chanTypePtr); /* 400 */ Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) (const Tcl_ChannelType *chanTypePtr); /* 401 */ diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 33bf0b3..3fe3e8f 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -187,7 +187,7 @@ declare 42 { } # Removed in 8.5a2: #declare 43 { -# int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, +# int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv, # int flags) #} declare 44 { @@ -222,12 +222,12 @@ declare 51 { } # Removed in 8.5a2: #declare 52 { -# int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, +# int TclInvoke(Tcl_Interp *interp, int argc, const char **argv, # int flags) #} declare 53 { int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, - int argc, CONST84 char **argv) + int argc, const char **argv) } declare 54 { int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, @@ -548,7 +548,7 @@ declare 133 {deprecated {}} { # int TclpChdir(const char *dirName) #} declare 138 { - CONST84_RETURN char *TclGetEnv(const char *name, Tcl_DString *valuePtr) + const char *TclGetEnv(const char *name, Tcl_DString *valuePtr) } #declare 139 { # int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, @@ -560,7 +560,7 @@ declare 138 { #} # This is used by TclX, but should otherwise be considered private declare 141 { - CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) + const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) } declare 142 { int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, diff --git a/generic/tclInt.h b/generic/tclInt.h index 8aaa7a8..ecd2924 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -160,13 +160,13 @@ typedef struct Tcl_ResolvedVarInfo { } Tcl_ResolvedVarInfo; typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp, - CONST84 char *name, int length, Tcl_Namespace *context, + const char *name, int length, Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr); -typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, CONST84 char *name, +typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, const char *name, Tcl_Namespace *context, int flags, Tcl_Var *rPtr); -typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, CONST84 char *name, +typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, const char *name, Tcl_Namespace *context, int flags, Tcl_Command *rPtr); typedef struct Tcl_ResolverInfo { diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 22b8072..cd494f4 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -158,7 +158,7 @@ EXTERN int TclInterpInit(Tcl_Interp *interp); /* 53 */ EXTERN int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, int argc, - CONST84 char **argv); + const char **argv); /* 54 */ EXTERN int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, int objc, @@ -344,13 +344,11 @@ struct tm * TclpGetDate(const time_t *time, int useGMT); /* Slot 136 is reserved */ /* Slot 137 is reserved */ /* 138 */ -EXTERN CONST84_RETURN char * TclGetEnv(const char *name, - Tcl_DString *valuePtr); +EXTERN const char * TclGetEnv(const char *name, Tcl_DString *valuePtr); /* Slot 139 is reserved */ /* Slot 140 is reserved */ /* 141 */ -EXTERN CONST84_RETURN char * TclpGetCwd(Tcl_Interp *interp, - Tcl_DString *cwdPtr); +EXTERN const char * TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 142 */ EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, @@ -692,7 +690,7 @@ typedef struct TclIntStubs { void (*tclInitCompiledLocals) (Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 50 */ int (*tclInterpInit) (Tcl_Interp *interp); /* 51 */ void (*reserved52)(void); - int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, CONST84 char **argv); /* 53 */ + int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, const char **argv); /* 53 */ int (*tclInvokeStringCommand) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 54 */ Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */ void (*reserved56)(void); @@ -777,10 +775,10 @@ typedef struct TclIntStubs { void (*reserved135)(void); void (*reserved136)(void); void (*reserved137)(void); - CONST84_RETURN char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */ + const char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */ void (*reserved139)(void); void (*reserved140)(void); - CONST84_RETURN char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */ + const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */ int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData); /* 142 */ int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */ void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */ -- cgit v0.12 From 011dd7b0f6b3f7eae43f139e2c0b654387718fd8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 21 Nov 2017 09:13:08 +0000 Subject: Revert [d874801c57]: putting back "string bytelength". It turns out to be too complicated to take along with the other deprecations in TIP #485 --- doc/string.n | 4 ++-- generic/tclCmdMZ.c | 4 ---- library/init.tcl | 4 ++-- tests/info.test | 4 ++-- tests/regexp.test | 4 ++-- tests/regexpComp.test | 4 ++-- 6 files changed, 10 insertions(+), 14 deletions(-) diff --git a/doc/string.n b/doc/string.n index 730f49e..00ce85c 100644 --- a/doc/string.n +++ b/doc/string.n @@ -386,8 +386,8 @@ store the representation is of very low value (except to C extension code, which has direct access for the purpose of memory management, etc.) .PP -\fICompatibility note:\fR this subcommand will be gone in -Tcl 9.0. It is better to use the +\fICompatibility note:\fR it is likely that this subcommand will be +withdrawn in a future version of Tcl. It is better to use the \fBencoding convertto\fR command to convert a string to a known encoding and then apply \fBstring length\fR to that. .PP diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 14ea6ad..67fbc94 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2893,7 +2893,6 @@ StringCatCmd( * *---------------------------------------------------------------------- */ -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 static int StringBytesCmd( ClientData dummy, /* Not used. */ @@ -2912,7 +2911,6 @@ StringBytesCmd( Tcl_SetObjResult(interp, Tcl_NewIntObj(length)); return TCL_OK; } -#endif /* !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 */ /* *---------------------------------------------------------------------- @@ -3370,9 +3368,7 @@ TclInitStringCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap stringImplMap[] = { -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 {"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, -#endif {"cat", StringCatCmd, TclCompileStringCatCmd, NULL, NULL, 0}, {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0}, {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, diff --git a/library/init.tcl b/library/init.tcl index a3ee05f..13a4300 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -279,9 +279,9 @@ proc unknown args { set errInfo [dict get $opts -errorinfo] set errCode [dict get $opts -errorcode] set cinfo $args - if {[string length $cinfo] > 150} { + if {[string bytelength $cinfo] > 150} { set cinfo [string range $cinfo 0 150] - while {[string length $cinfo] > 150} { + while {[string bytelength $cinfo] > 150} { set cinfo [string range $cinfo 0 end-1] } append cinfo ... diff --git a/tests/info.test b/tests/info.test index ac4b98c..fd89b47 100644 --- a/tests/info.test +++ b/tests/info.test @@ -103,8 +103,8 @@ test info-2.5 {info body option, returning bytecompiled bodies} -body { # causing an empty string to be returned [Bug #545644] test info-2.6 {info body option, returning list bodies} { proc foo args [list subst bar] - list [string length [info body foo]] \ - [foo; string length [info body foo]] + list [string bytelength [info body foo]] \ + [foo; string bytelength [info body foo]] } {9 9} proc testinfocmdcount {} { diff --git a/tests/regexp.test b/tests/regexp.test index 62cadd3..7367af7 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -760,8 +760,8 @@ test regexp-20.1 {regsub shared object shimmering} { set b $a set c abcdefghijklmnopqurstuvwxyz0123456789 regsub $a $c $b d - list $d [string length $d] -} [list abcdefghijklmnopqurstuvwxyz0123456789 37] + list $d [string length $d] [string bytelength $d] +} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37] test regexp-20.2 {regsub shared object shimmering with -about} { eval regexp -about abc } {0 {}} diff --git a/tests/regexpComp.test b/tests/regexpComp.test index dc7b909..fbf8012 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -798,9 +798,9 @@ test regexpComp-20.1 {regsub shared object shimmering} { set b $a set c abcdefghijklmnopqurstuvwxyz0123456789 regsub $a $c $b d - list $d [string length $d] + list $d [string length $d] [string bytelength $d] } -} [list abcdefghijklmnopqurstuvwxyz0123456789 37] +} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37] test regexpComp-20.2 {regsub shared object shimmering with -about} { evalInProc { eval regexp -about abc -- cgit v0.12 From 119652bd95761672adbaaae020c3c30141104a19 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 21 Nov 2017 09:48:36 +0000 Subject: deprecate VOID/CHAR/SHORT/LONG (windows-only) as well. --- generic/tcl.h | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index e054c19..e85988f 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -299,6 +299,7 @@ extern "C" { * VOID. This block is skipped under Cygwin and Mingw. */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 #if defined(_WIN32) && !defined(HAVE_WINNT_IGNORE_VOID) #ifndef VOID #define VOID void @@ -314,23 +315,16 @@ typedef long LONG; */ #ifndef __VXWORKS__ -# ifndef NO_VOID -# define VOID void -# else -# define VOID char -# endif +# define VOID void #endif +#endif /* !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 */ /* * Miscellaneous declarations. */ #ifndef _CLIENTDATA -# ifndef NO_VOID - typedef void *ClientData; -# else - typedef int *ClientData; -# endif + typedef void *ClientData; # define _CLIENTDATA #endif -- cgit v0.12 From 2555e0d7e6f980833f0369e83b81b0c37050c3f5 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 10 Dec 2017 21:45:26 +0000 Subject: Streamline TclOO object cleanup routines. --- generic/tclBasic.c | 2 + generic/tclOO.c | 619 ++++++++++++++++++---------------------------- generic/tclOOBasic.c | 5 - generic/tclOOCall.c | 4 +- generic/tclOODefineCmds.c | 62 ++++- generic/tclOOInt.h | 46 ++-- tests/oo.test | 13 +- 7 files changed, 326 insertions(+), 425 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index eceea31..a23100e 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3152,6 +3152,8 @@ Tcl_DeleteCommandFromToken( */ cmdPtr->nsPtr->refCount++; + + cmdPtr->nsPtr->refCount++; if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); diff --git a/generic/tclOO.c b/generic/tclOO.c index 84380e0..ae1ae3f 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -60,8 +60,6 @@ static const struct { static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj); static Object * AllocObject(Tcl_Interp *interp, const char *nameStr, Namespace *nsPtr, const char *nsNameStr); -static void ClearMixins(Class *clsPtr); -static void ClearSuperclasses(Class *clsPtr); static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, Method *mPtr, Tcl_Obj *namePtr, Method **newMPtrPtr); @@ -73,6 +71,7 @@ static void DeletedHelpersNamespace(ClientData clientData); static Tcl_NRPostProc FinalizeAlloc; static Tcl_NRPostProc FinalizeNext; static Tcl_NRPostProc FinalizeObjectCall; +static void initClassPath(Tcl_Interp * interp, Class *clsPtr); static int InitFoundation(Tcl_Interp *interp); static void KillFoundation(ClientData clientData, Tcl_Interp *interp); @@ -82,6 +81,7 @@ static void ObjectRenamedTrace(ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr); +static void DeleteDescendants(Tcl_Interp *interp,Object *oPtr); static inline void SquelchCachedName(Object *oPtr); static int PublicObjectCmd(ClientData clientData, @@ -96,6 +96,8 @@ static int PrivateObjectCmd(ClientData clientData, static int PrivateNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +static void RemoveClass(Class ** list, int num, int idx); +static void RemoveObject(Object ** list, int num, int idx); /* * Methods in the oo::object and oo::class classes. First, we define a helper @@ -228,10 +230,14 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; * ROOT_CLASS respectively. */ -#define Deleted(oPtr) (((Object *)(oPtr))->command == NULL) +#define Deleted(oPtr) ((oPtr)->flags & OBJECT_DELETED) #define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT) #define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS) #define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) + +#define RemoveItem(type, lst, i) \ + Remove ## type ((lst).list, (lst).num, i); \ + (lst).num-- /* * ---------------------------------------------------------------------- @@ -313,6 +319,10 @@ InitFoundation( Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); Foundation *fPtr = ckalloc(sizeof(Foundation)); Tcl_Obj *namePtr, *argsPtr, *bodyPtr; + + Class fakeCls; + Object fakeObject; + Tcl_DString buffer; Command *cmdPtr; int i; @@ -379,24 +389,43 @@ InitFoundation( * spliced manually. */ + /* Stand up a phony class for bootstrapping. */ + fPtr->objectCls = &fakeCls; + /* referenced in AllocClass to increment the refCount. */ + fakeCls.thisPtr = &fakeObject; + fPtr->objectCls = AllocClass(interp, AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); fPtr->classCls = AllocClass(interp, AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); + + /* Rewire bootstrapped objects. */ fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; + fPtr->classCls->thisPtr->selfCls = fPtr->classCls; + + AddRef(fPtr->objectCls->thisPtr); + AddRef(fPtr->classCls->thisPtr); + AddRef(fPtr->classCls->thisPtr->selfCls->thisPtr); + AddRef(fPtr->objectCls->thisPtr->selfCls->thisPtr); + + /* special initialization for the primordial objects */ fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; fPtr->objectCls->flags |= ROOT_OBJECT; + + /* This is why it is unnecessary in this routine to make up for the + * incremented reference count of fPtr->objectCls that was sallwed by + * fakeObject. */ fPtr->objectCls->superclasses.num = 0; ckfree(fPtr->objectCls->superclasses.list); fPtr->objectCls->superclasses.list = NULL; - fPtr->classCls->thisPtr->selfCls = fPtr->classCls; + fPtr->classCls->thisPtr->flags |= ROOT_CLASS; fPtr->classCls->flags |= ROOT_CLASS; + + /* Standard initialization for new Objects */ TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); - AddRef(fPtr->objectCls->thisPtr); - AddRef(fPtr->objectCls); /* * Basic method declarations for the core classes. @@ -522,8 +551,6 @@ KillFoundation( { Foundation *fPtr = GetFoundation(interp); - DelRef(fPtr->objectCls->thisPtr); - DelRef(fPtr->objectCls); TclDecrRefCount(fPtr->unknownMethodNameObj); TclDecrRefCount(fPtr->constructorName); TclDecrRefCount(fPtr->destructorName); @@ -538,8 +565,11 @@ KillFoundation( * AllocObject -- * * Allocate an object of basic type. Does not splice the object into its - * class's instance list. The caller must set the classPtr on the object, - * either to a class or to NULL. + * class's instance list. The caller must set the classPtr on the object + * to either a class or NULL, call TclOOAddToInstances to add the object + * to the class's instance list, and if the object itself is a class, use + * call TclOOAddToSubclasses() to add it to the right class's list of + * subclasses. * * ---------------------------------------------------------------------- */ @@ -564,7 +594,7 @@ AllocObject( Object *oPtr; Command *cmdPtr; CommandTrace *tracePtr; - int creationEpoch, ignored; + int creationEpoch; oPtr = ckalloc(sizeof(Object)); memset(oPtr, 0, sizeof(Object)); @@ -641,9 +671,15 @@ AllocObject( */ oPtr->fPtr = fPtr; - oPtr->selfCls = fPtr->objectCls; oPtr->creationEpoch = creationEpoch; - oPtr->refCount = 1; + + /* + * An object starts life with a refCount of 2 to mark the two stages of + * destruction it occur: A call to ObjectRenamedTrace(), and a call to + * ObjectNamespaceDeleted(). + */ + oPtr->refCount = 2; + oPtr->flags = USE_CLASS_CACHE; /* @@ -655,6 +691,10 @@ AllocObject( if (!nameStr) { nameStr = oPtr->namespacePtr->name; nsPtr = (Namespace *)oPtr->namespacePtr; + if (nsPtr->parentPtr != NULL) { + nsPtr = nsPtr->parentPtr; + } + } oPtr->command = TclCreateObjCommandInNs(interp, nameStr, (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL); @@ -673,26 +713,8 @@ AllocObject( tracePtr->nextPtr = NULL; tracePtr->refCount = 1; - /* - * Access the namespace command table directly when creating "my" to avoid - * a bottleneck in string manipulation. Another abstraction-buster. - */ - - cmdPtr = ckalloc(sizeof(Command)); - memset(cmdPtr, 0, sizeof(Command)); - cmdPtr->nsPtr = (Namespace *) oPtr->namespacePtr; - cmdPtr->hPtr = Tcl_CreateHashEntry(&cmdPtr->nsPtr->cmdTable, "my", - &ignored); - cmdPtr->refCount = 1; - cmdPtr->objProc = PrivateObjectCmd; - cmdPtr->deleteProc = MyDeleted; - cmdPtr->objClientData = cmdPtr->deleteData = oPtr; - cmdPtr->proc = TclInvokeObjectCommand; - cmdPtr->clientData = cmdPtr; - cmdPtr->nreProc = PrivateNRObjectCmd; - Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr); - oPtr->myCommand = (Tcl_Command) cmdPtr; - + oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, + PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); return oPtr; } @@ -774,88 +796,20 @@ ObjectRenamedTrace( /* * The namespace is only deleted if it hasn't already been deleted. [Bug - * 2950259]. If the namespace has already been deleted, then - * ObjectNamespaceDeleted() has already cleaned up this command. + * 2950259]. */ - if (oPtr->namespacePtr == NULL) { - /* - * ObjectNamespaceDeleted() has already done all the cleanup, but - * detected that the command was in the process of being deleted, and - * left the pointer allocated for us. - */ - DelRef(oPtr); - } else { - if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc == NULL) { - /* - * ObjectNamespaceDeleted() called us, and still has some work to - * do, so we leave the pointer allocated for it to finish, and then - * it will deallocate the pointer. - */ - } else { - Tcl_DeleteNamespace(oPtr->namespacePtr); - /* - * ObjectNamespaceDeleted() doesn't know it was us that just - * called, so it left the pointer allocated. - */ - DelRef(oPtr); - } + if (!Deleted(oPtr)) { + Tcl_DeleteNamespace(oPtr->namespacePtr); } + oPtr->command = NULL; + TclOODecrRefCount(oPtr); return; } /* * ---------------------------------------------------------------------- * - * ClearMixins, ClearSuperclasses -- - * - * Utility functions for correctly clearing the list of mixins or - * superclasses of a class. Will ckfree() the list storage. - * - * ---------------------------------------------------------------------- - */ - -static void -ClearMixins( - Class *clsPtr) -{ - int i; - Class *mixinPtr; - - if (clsPtr->mixins.num == 0) { - return; - } - - FOREACH(mixinPtr, clsPtr->mixins) { - TclOORemoveFromMixinSubs(clsPtr, mixinPtr); - } - ckfree(clsPtr->mixins.list); - clsPtr->mixins.list = NULL; - clsPtr->mixins.num = 0; -} - -static void -ClearSuperclasses( - Class *clsPtr) -{ - int i; - Class *superPtr; - - if (clsPtr->superclasses.num == 0) { - return; - } - - FOREACH(superPtr, clsPtr->superclasses) { - TclOORemoveFromSubclasses(clsPtr, superPtr); - } - ckfree(clsPtr->superclasses.list); - clsPtr->superclasses.list = NULL; - clsPtr->superclasses.num = 0; -} - -/* - * ---------------------------------------------------------------------- - * * ReleaseClassContents -- * * Tear down the special class data structure, including deleting all @@ -865,122 +819,39 @@ ClearSuperclasses( */ static void -ReleaseClassContents( +DeleteDescendants( Tcl_Interp *interp, /* The interpreter containing the class. */ Object *oPtr) /* The object representing the class. */ { - FOREACH_HASH_DECLS; - int i; - Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr; + Class *clsPtr = oPtr->classPtr, *subclassPtr, *mixinSubclassPtr; Object *instancePtr; - Method *mPtr; - Foundation *fPtr = oPtr->fPtr; - Tcl_Obj *variableObj; - - /* - * Sanity check! - */ - - if (!Deleted(oPtr)) { - if (IsRootClass(oPtr)) { - Tcl_Panic("deleting class structure for non-deleted %s", - "::oo::class"); - } else if (IsRootObject(oPtr)) { - Tcl_Panic("deleting class structure for non-deleted %s", - "::oo::object"); - } else { - Tcl_Panic("deleting class structure for non-deleted %s", - "general object"); - } - } - - /* - * Lock a number of dependent objects until we've stopped putting our - * fingers in them. - */ - - FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { - if (mixinSubclassPtr != NULL) { - AddRef(mixinSubclassPtr); - AddRef(mixinSubclassPtr->thisPtr); - } - } - FOREACH(subclassPtr, clsPtr->subclasses) { - if (subclassPtr != NULL && !IsRoot(subclassPtr)) { - AddRef(subclassPtr); - AddRef(subclassPtr->thisPtr); - } - } - if (!IsRootClass(oPtr)) { - FOREACH(instancePtr, clsPtr->instances) { - if (instancePtr != oPtr) { - int j; - if (instancePtr->selfCls == clsPtr) { - instancePtr->flags |= CLASS_GONE; - } - for(j=0 ; jmixins.num ; j++) { - Class *mixin = instancePtr->mixins.list[j]; - Class *nextMixin = NULL; - if (mixin == clsPtr) { - if (j < instancePtr->mixins.num - 1) { - nextMixin = instancePtr->mixins.list[j+1]; - } - if (j == 0) { - instancePtr->mixins.num = 0; - instancePtr->mixins.list = NULL; - } else { - instancePtr->mixins.list[j-1] = nextMixin; - } - instancePtr->mixins.num -= 1; - } - } - if (instancePtr != NULL && !IsRoot(instancePtr)) { - AddRef(instancePtr); - } - } - } - } + int i; /* * Squelch classes that this class has been mixed into. */ FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { - if (mixinSubclassPtr != clsPtr) { - if (!Deleted(mixinSubclassPtr->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, - mixinSubclassPtr->thisPtr->command); - } - ClearMixins(mixinSubclassPtr); - DelRef(mixinSubclassPtr->thisPtr); - DelRef(mixinSubclassPtr); + /* This condition also covers the case where mixinSubclassPtr == + * clsPtr + */ + if (!Deleted(mixinSubclassPtr->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, + mixinSubclassPtr->thisPtr->command); } + i -= TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr); + TclOODecrRefCount(mixinSubclassPtr->thisPtr); } - if (clsPtr->mixinSubs.list != NULL) { - ckfree(clsPtr->mixinSubs.list); - clsPtr->mixinSubs.list = NULL; - clsPtr->mixinSubs.num = 0; - } - /* * Squelch subclasses of this class. */ FOREACH(subclassPtr, clsPtr->subclasses) { - if (IsRoot(subclassPtr)) { - continue; - } - if (!Deleted(subclassPtr->thisPtr)) { + if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)) { Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command); } - ClearSuperclasses(subclassPtr); - DelRef(subclassPtr->thisPtr); - DelRef(subclassPtr); - } - if (clsPtr->subclasses.list != NULL) { - ckfree(clsPtr->subclasses.list); - clsPtr->subclasses.list = NULL; - clsPtr->subclasses.num = 0; + i -= TclOORemoveFromSubclasses(subclassPtr, clsPtr); + TclOODecrRefCount(subclassPtr->thisPtr); } /* @@ -989,35 +860,43 @@ ReleaseClassContents( if (!IsRootClass(oPtr)) { FOREACH(instancePtr, clsPtr->instances) { - if (instancePtr != oPtr) { - if (instancePtr == NULL || IsRoot(instancePtr)) { - continue; - } - if (!Deleted(instancePtr)) { - Tcl_DeleteCommandFromToken(interp, instancePtr->command); - /* - * Tcl_DeleteCommandFromToken() may have done to whole - * job for us. Roll back and check again. - */ - i--; - continue; - } - DelRef(instancePtr); + /* This condition also covers the case where instancePtr == oPtr */ + if (!Deleted(instancePtr) && !IsRoot(instancePtr)) { + Tcl_DeleteCommandFromToken(interp, instancePtr->command); } + i -= TclOORemoveFromInstances(instancePtr, clsPtr); } } - if (clsPtr->instances.list != NULL) { - ckfree(clsPtr->instances.list); - clsPtr->instances.list = NULL; - clsPtr->instances.num = 0; - } +} + + +static void +ReleaseClassContents( + Tcl_Interp *interp, /* The interpreter containing the class. */ + Object *oPtr) /* The object representing the class. */ +{ + FOREACH_HASH_DECLS; + int i; + Class *clsPtr = oPtr->classPtr, *tmpClsPtr; + Method *mPtr; + Foundation *fPtr = oPtr->fPtr; + Tcl_Obj *variableObj; /* - * Special: We delete these after everything else. + * Sanity check! */ - if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); + if (!Deleted(oPtr)) { + if (IsRootClass(oPtr)) { + Tcl_Panic("deleting class structure for non-deleted %s", + "::oo::class"); + } else if (IsRootObject(oPtr)) { + Tcl_Panic("deleting class structure for non-deleted %s", + "::oo::object"); + } else { + Tcl_Panic("deleting class structure for non-deleted %s", + "general object"); + } } /* @@ -1073,8 +952,12 @@ ReleaseClassContents( clsPtr->metadataPtr = NULL; } - ClearMixins(clsPtr); - ClearSuperclasses(clsPtr); + FOREACH(tmpClsPtr, clsPtr->mixins) { + TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr); + } + FOREACH(tmpClsPtr, clsPtr->superclasses) { + TclOORemoveFromSubclasses(clsPtr, tmpClsPtr); + } FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { TclOODelMethodRef(mPtr); @@ -1090,12 +973,9 @@ ReleaseClassContents( ckfree(clsPtr->variables.list); } - /* Tell oPtr that it's class is gone so that it doesn't try to remove - * itself from it's classe's list of instances - */ - oPtr->flags |= CLASS_GONE; - DelRef(clsPtr); - + if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); + } } /* @@ -1123,13 +1003,26 @@ ObjectNamespaceDeleted( Method *mPtr; Tcl_Obj *filterObj, *variableObj; Tcl_Interp *interp = oPtr->fPtr->interp; - int finished = 0, i; + int i; + if (Deleted(oPtr)) { + /* To do: Can ObjectNamespaceDeleted ever be called twice? If not, + * this guard could be removed. + */ + return; + } - AddRef(fPtr->classCls); - AddRef(fPtr->objectCls); - AddRef(fPtr->classCls->thisPtr); - AddRef(fPtr->objectCls->thisPtr); + /* + * One rule for the teardown routines is that if an object is in the + * process of being deleted, nothing else may modify its bookeeping + * records. This is the flag that + */ + oPtr->flags |= OBJECT_DELETED; + + /* Let the dominoes fall */ + if (oPtr->classPtr) { + DeleteDescendants(interp, oPtr); + } /* * We do not run destructors on the core class objects when the @@ -1137,15 +1030,14 @@ ObjectNamespaceDeleted( * in that case when the destructor is partially deleted before the uses * of it have gone. [Bug 2949397] */ - - if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) { + if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) { CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); int result; Tcl_InterpState state; - oPtr->flags |= DESTRUCTOR_CALLED; + if (contextPtr != NULL) { contextPtr->callPtr->flags |= DESTRUCTOR; contextPtr->skip = 0; @@ -1167,7 +1059,7 @@ ObjectNamespaceDeleted( * points into freed memory. */ - if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) { + if (((Command *)oPtr->command)->flags && CMD_IS_DELETED) { /* * Something has already started the command deletion process. We can * go ahead and clean up the the namespace, @@ -1178,9 +1070,7 @@ ObjectNamespaceDeleted( * as well. */ Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); - finished = 1; } - oPtr->command = NULL; if (oPtr->myCommand) { Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand); @@ -1191,14 +1081,13 @@ ObjectNamespaceDeleted( * methods on the object. */ - if (!IsRootObject(oPtr) && !(oPtr->flags & CLASS_GONE)) { - TclOORemoveFromInstances(oPtr, oPtr->selfCls); - } + /* To do: Get dkf to weigh in on wether this should be protected with a + * !IsRoot() condition. + */ + TclOORemoveFromInstances(oPtr, oPtr->selfCls); FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr && mixinPtr != oPtr->classPtr) { - TclOORemoveFromInstances(oPtr, mixinPtr); - } + i -= TclOORemoveFromInstances(oPtr, mixinPtr); } if (i) { ckfree(oPtr->mixins.list); @@ -1258,8 +1147,9 @@ ObjectNamespaceDeleted( * classes, if one goes the other must too and yet the tangle can * sometimes not go away automatically; we force it here. [Bug 2962664] */ - if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr) - && !Deleted(fPtr->classCls->thisPtr)) { + if (IsRootObject(oPtr) && !Deleted(fPtr->classCls->thisPtr) + && !Tcl_InterpDeleted(interp)) { + Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); } @@ -1267,35 +1157,59 @@ ObjectNamespaceDeleted( ReleaseClassContents(interp, oPtr); } - /* * Delete the object structure itself. */ - oPtr->classPtr = NULL; oPtr->namespacePtr = NULL; - - DelRef(fPtr->classCls->thisPtr); - DelRef(fPtr->objectCls->thisPtr); - DelRef(fPtr->classCls); - DelRef(fPtr->objectCls); - if (finished) { - /* - * ObjectRenamedTrace called us, and not the other way around. - */ - DelRef(oPtr); - } else { - /* - * ObjectRenamedTrace will call DelRef(oPtr). - */ - } + oPtr->selfCls = NULL; + TclOODecrRefCount(oPtr); return; - } /* * ---------------------------------------------------------------------- * + * TclOODecrRef -- + * + * Decrement the refcount of an object and deallocate storage then object + * is no longer referenced. Returns 1 if storage was deallocated, and 0 + * otherwise. + * + * ---------------------------------------------------------------------- + */ +int TclOODecrRefCount(Object *oPtr) { + if (oPtr->refCount-- <= 1) { + Class *clsPtr = oPtr->classPtr; + if (oPtr->classPtr != NULL) { + ckfree(clsPtr->superclasses.list); + ckfree(clsPtr->subclasses.list); + ckfree(clsPtr->instances.list); + ckfree(clsPtr->mixinSubs.list); + ckfree(clsPtr->mixins.list); + ckfree(oPtr->classPtr); + } + ckfree(oPtr); + return 1; + } + return 0; +} + +/* setting the "empty" location to NULL makes debugging a little easier */ +#define REMOVEBODY { \ + for (; idx < num - 1; idx++) { \ + list[idx] = list[idx+1]; \ + } \ + list[idx] = NULL; \ + return; \ +} +void RemoveClass(Class **list, int num, int idx) REMOVEBODY + +void RemoveObject(Object **list, int num, int idx) REMOVEBODY + +/* + * ---------------------------------------------------------------------- + * * TclOORemoveFromInstances -- * * Utility function to remove an object from the list of instances within @@ -1304,36 +1218,27 @@ ObjectNamespaceDeleted( * ---------------------------------------------------------------------- */ -void +int TclOORemoveFromInstances( Object *oPtr, /* The instance to remove. */ Class *clsPtr) /* The class (possibly) containing the * reference to the instance. */ { - int i; + int i, res = 0; Object *instPtr; + if (Deleted(clsPtr->thisPtr)) { + return res; + } FOREACH(instPtr, clsPtr->instances) { if (oPtr == instPtr) { - goto removeInstance; - } - } - return; - - removeInstance: - if (Deleted(clsPtr->thisPtr)) { - if (!IsRootClass(clsPtr)) { - DelRef(clsPtr->instances.list[i]); - } - clsPtr->instances.list[i] = NULL; - } else { - clsPtr->instances.num--; - if (i < clsPtr->instances.num) { - clsPtr->instances.list[i] = - clsPtr->instances.list[clsPtr->instances.num]; + RemoveItem(Object, clsPtr->instances, i); + TclOODecrRefCount(oPtr); + res++; + break; } - clsPtr->instances.list[clsPtr->instances.num] = NULL; } + return res; } /* @@ -1354,9 +1259,6 @@ TclOOAddToInstances( * assumed that the class is not already * present as an instance in the class. */ { - if (Deleted(clsPtr->thisPtr)) { - return; - } if (clsPtr->instances.num >= clsPtr->instances.size) { clsPtr->instances.size += ALLOC_CHUNK; if (clsPtr->instances.size == ALLOC_CHUNK) { @@ -1367,6 +1269,7 @@ TclOOAddToInstances( } } clsPtr->instances.list[clsPtr->instances.num++] = oPtr; + AddRef(oPtr); } /* @@ -1375,36 +1278,31 @@ TclOOAddToInstances( * TclOORemoveFromSubclasses -- * * Utility function to remove a class from the list of subclasses within - * another class. + * another class. Returns the number of removals performed. * * ---------------------------------------------------------------------- */ -void +int TclOORemoveFromSubclasses( Class *subPtr, /* The subclass to remove. */ Class *superPtr) /* The superclass to possibly remove the * subclass reference from. */ { - int i; + int i, res = 0; Class *subclsPtr; + if (Deleted(superPtr->thisPtr)) { + return res; + } FOREACH(subclsPtr, superPtr->subclasses) { if (subPtr == subclsPtr) { - goto removeSubclass; - } - } - return; - - removeSubclass: - if (!Deleted(superPtr->thisPtr)) { - superPtr->subclasses.num--; - if (i < superPtr->subclasses.num) { - superPtr->subclasses.list[i] = - superPtr->subclasses.list[superPtr->subclasses.num]; + RemoveItem(Class, superPtr->subclasses, i); + TclOODecrRefCount(subPtr->thisPtr); + res++; } - superPtr->subclasses.list[superPtr->subclasses.num] = NULL; } + return res; } /* @@ -1431,13 +1329,13 @@ TclOOAddToSubclasses( if (superPtr->subclasses.num >= superPtr->subclasses.size) { superPtr->subclasses.size += ALLOC_CHUNK; if (superPtr->subclasses.size == ALLOC_CHUNK) { - superPtr->subclasses.list = ckalloc(sizeof(Class*) * ALLOC_CHUNK); + superPtr->subclasses.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK); } else { - superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list, - sizeof(Class *) * superPtr->subclasses.size); + superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list, sizeof(Class *) * superPtr->subclasses.size); } } superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr; + AddRef(subPtr->thisPtr); } /* @@ -1451,31 +1349,28 @@ TclOOAddToSubclasses( * ---------------------------------------------------------------------- */ -void +int TclOORemoveFromMixinSubs( Class *subPtr, /* The subclass to remove. */ Class *superPtr) /* The superclass to possibly remove the * subclass reference from. */ { - int i; + int i, res = 0; Class *subclsPtr; - FOREACH(subclsPtr, superPtr->mixinSubs) { - if (subPtr == subclsPtr) { - goto removeSubclass; - } + if (Deleted(superPtr->thisPtr)) { + return res; } - return; - removeSubclass: - if (!Deleted(superPtr->thisPtr)) { - superPtr->mixinSubs.num--; - if (i < superPtr->mixinSubs.num) { - superPtr->mixinSubs.list[i] = - superPtr->mixinSubs.list[superPtr->mixinSubs.num]; + FOREACH(subclsPtr, superPtr->mixinSubs) { + if (subPtr == subclsPtr) { + RemoveItem(Class, superPtr->mixinSubs, i); + TclOODecrRefCount(subPtr->thisPtr); + res++; + break; } - superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL; } + return res; } /* @@ -1509,6 +1404,7 @@ TclOOAddToMixinSubs( } } superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr; + AddRef(subPtr->thisPtr); } /* @@ -1516,7 +1412,7 @@ TclOOAddToMixinSubs( * * AllocClass -- * - * Allocate a basic class. Does not splice the class object into its + * Allocate a basic class. Does not add class to its * class's instance list. * * ---------------------------------------------------------------------- @@ -1527,44 +1423,18 @@ AllocClass( Tcl_Interp *interp, /* Interpreter within which to allocate the * class. */ Object *useThisObj) /* Object that is to act as the class - * representation, or NULL if a new object - * with automatic name is to be used. */ + * representation. */ { Foundation *fPtr = GetFoundation(interp); Class *clsPtr = ckalloc(sizeof(Class)); - /* - * Make an object if we haven't been given one. - */ - memset(clsPtr, 0, sizeof(Class)); - if (useThisObj == NULL) { - clsPtr->thisPtr = AllocObject(interp, NULL, NULL, NULL); - } else { - clsPtr->thisPtr = useThisObj; - } + clsPtr->thisPtr = useThisObj; /* * Configure the namespace path for the class's object. */ - - if (fPtr->helpersNs != NULL) { - Tcl_Namespace *path[2]; - - path[0] = fPtr->helpersNs; - path[1] = fPtr->ooNs; - TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); - } else { - TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1, - &fPtr->ooNs); - } - - /* - * Class objects inherit from the class of classes unless they inherit - * from some subclass of it. Enforce this right now. - */ - - clsPtr->thisPtr->selfCls = fPtr->classCls; + initClassPath(interp, clsPtr); /* * Classes are subclasses of oo::object, i.e. the objects they create are @@ -1574,6 +1444,7 @@ AllocClass( clsPtr->superclasses.num = 1; clsPtr->superclasses.list = ckalloc(sizeof(Class *)); clsPtr->superclasses.list[0] = fPtr->objectCls; + AddRef(fPtr->objectCls->thisPtr); /* * Finish connecting the class structure to the object structure. @@ -1586,10 +1457,22 @@ AllocClass( * fields. */ - clsPtr->refCount = 1; Tcl_InitObjHashTable(&clsPtr->classMethods); return clsPtr; } +static void +initClassPath(Tcl_Interp *interp, Class *clsPtr) { + Foundation *fPtr = GetFoundation(interp); + if (fPtr->helpersNs != NULL) { + Tcl_Namespace *path[2]; + path[0] = fPtr->helpersNs; + path[1] = fPtr->ooNs; + TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); + } else { + TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1, + &fPtr->ooNs); + } +} /* * ---------------------------------------------------------------------- @@ -1640,7 +1523,7 @@ Tcl_NewObjectInstance( contextPtr->skip = skip; /* - * Adjust the ensmble tracking record if necessary. [Bug 3514761] + * Adjust the ensemble tracking record if necessary. [Bug 3514761] */ isRoot = TclInitRewriteEnsemble(interp, skip, skip, objv); @@ -1656,7 +1539,6 @@ Tcl_NewObjectInstance( clientData[2] = state; clientData[3] = &oPtr; - AddRef(oPtr); result = FinalizeAlloc(clientData, interp, result); if (result != TCL_OK) { return NULL; @@ -1723,7 +1605,6 @@ TclNRNewObjectInstance( * Fire off the constructors non-recursively. */ - AddRef(oPtr); TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state, objectPtr); TclPushTailcallPoint(interp); @@ -1771,18 +1652,9 @@ TclNewObjectInstanceCommon( * Create the object. */ - /* - * The command for the object could have the same name as the command - * associated with classPtr, so protect the structure from deallocation - * here. - */ - AddRef(classPtr); - oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr); - DelRef(classPtr); oPtr->selfCls = classPtr; TclOOAddToInstances(oPtr, classPtr); - /* * Check to see if we're really creating a class. If so, allocate the * class structure as well. @@ -1797,7 +1669,6 @@ TclNewObjectInstanceCommon( */ AllocClass(interp, oPtr); - oPtr->selfCls = classPtr; TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); } else { oPtr->classPtr = NULL; @@ -1829,7 +1700,6 @@ FinalizeAlloc( Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); result = TCL_ERROR; } - TclOODeleteContext(contextPtr); if (result != TCL_OK) { Tcl_DiscardInterpState(state); @@ -1843,12 +1713,14 @@ FinalizeAlloc( (void) TclOOObjectName(interp, oPtr); Tcl_DeleteCommandFromToken(interp, oPtr->command); } - DelRef(oPtr); + /* This decrements the refcount of oPtr */ + TclOODeleteContext(contextPtr); return TCL_ERROR; } Tcl_RestoreInterpState(interp, state); *objectPtr = (Tcl_Object) oPtr; - DelRef(oPtr); + /* This decrements the refcount of oPtr */ + TclOODeleteContext(contextPtr); return TCL_OK; } @@ -1956,8 +1828,7 @@ Tcl_CopyObjectInstance( */ o2Ptr->flags = oPtr->flags & ~( - OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); - + OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); /* * Copy the object's metadata. */ @@ -2969,7 +2840,7 @@ int Tcl_ObjectDeleted( Tcl_Object object) { - return Deleted(object) ? 1 : 0; + return Deleted((Object *)object) ? 1 : 0; } Tcl_Object diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index b2c06a7..84f414d 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -340,11 +340,6 @@ TclOO_Object_Destroy( Object *oPtr = (Object *) Tcl_ObjectContextObject(context); CallContext *contextPtr; - if (objc != Tcl_ObjectContextSkippedArgs(context)) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } if (!(oPtr->flags & DESTRUCTOR_CALLED)) { oPtr->flags |= DESTRUCTOR_CALLED; contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index d4e1e34..c71425b 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -110,7 +110,8 @@ TclOODeleteContext( TclOODeleteChain(contextPtr->callPtr); if (oPtr != NULL) { TclStackFree(oPtr->fPtr->interp, contextPtr); - DelRef(oPtr); + /* Corresponding AddRef() in TclOO.c/TclOOObjectCmdCore */ + TclOODecrRefCount(oPtr); } } @@ -1171,6 +1172,7 @@ TclOOGetCallContext( returnContext: contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext)); contextPtr->oPtr = oPtr; + /* Corresponding TclOODecrRefCount() in TclOODeleteContext */ AddRef(oPtr); contextPtr->callPtr = callPtr; contextPtr->skip = 2; diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index b0bfd9c..7f3ea18 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -326,9 +326,7 @@ TclOOObjectSetMixins( if (numMixins == 0) { if (oPtr->mixins.num != 0) { FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr) { - TclOORemoveFromInstances(oPtr, mixinPtr); - } + TclOORemoveFromInstances(oPtr, mixinPtr); } ckfree(oPtr->mixins.list); oPtr->mixins.num = 0; @@ -352,6 +350,10 @@ TclOOObjectSetMixins( FOREACH(mixinPtr, oPtr->mixins) { if (mixinPtr != oPtr->selfCls) { TclOOAddToInstances(oPtr, mixinPtr); + /* Corresponding TclOODecrRefCount() is in the caller of this + * function. + */ + TclOODecrRefCount(mixinPtr->thisPtr); } } } @@ -399,6 +401,10 @@ TclOOClassSetMixins( memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); FOREACH(mixinPtr, classPtr->mixins) { TclOOAddToMixinSubs(classPtr, mixinPtr); + /* Corresponding TclOODecrRefCount() is in the caller of this + * function + */ + TclOODecrRefCount(mixinPtr->thisPtr); } } BumpGlobalEpoch(interp, classPtr); @@ -914,7 +920,7 @@ TclOODefineObjCmd( } else { result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv); } - DelRef(oPtr); + TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. @@ -981,7 +987,7 @@ TclOOObjDefObjCmd( } else { result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv); } - DelRef(oPtr); + TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. @@ -1048,7 +1054,7 @@ TclOODefineSelfObjCmd( } else { result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv); } - DelRef(oPtr); + TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. @@ -1168,11 +1174,11 @@ TclOODefineClassObjCmd( if (oPtr->selfCls != clsPtr) { TclOORemoveFromInstances(oPtr, oPtr->selfCls); + + /* Reference count already incremented 3 lines up. */ oPtr->selfCls = clsPtr; + TclOOAddToInstances(oPtr, oPtr->selfCls); - if (!(clsPtr->thisPtr->flags & OBJECT_DELETED)) { - oPtr->flags &= ~CLASS_GONE; - } if (oPtr->classPtr != NULL) { BumpGlobalEpoch(interp, oPtr->classPtr); } else { @@ -1628,6 +1634,10 @@ TclOODefineMixinObjCmd( goto freeAndError; } mixins[i-1] = clsPtr; + /* Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins, + * TclOOClassSetMixinsk, or just below if this function fails. + */ + AddRef(mixins[i-1]->thisPtr); } if (isInstanceMixin) { @@ -1640,6 +1650,9 @@ TclOODefineMixinObjCmd( return TCL_OK; freeAndError: + while (--i > 0) { + TclOODecrRefCount(mixins[i]->thisPtr); + } TclStackFree(interp, mixins); return TCL_ERROR; } @@ -2055,6 +2068,7 @@ ClassMixinSet( mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { + i--; goto freeAndError; } if (TclOOIsReachable(oPtr->classPtr, mixins[i])) { @@ -2063,6 +2077,10 @@ ClassMixinSet( Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); goto freeAndError; } + /* Corresponding TclOODecrRefCount() is in TclOOClassSetMixins, or just + * below if this function fails + */ + AddRef(mixins[i]->thisPtr); } TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins); @@ -2070,6 +2088,9 @@ ClassMixinSet( return TCL_OK; freeAndError: + while (i-- > 0) { + TclOODecrRefCount(mixins[i]->thisPtr); + } TclStackFree(interp, mixins); return TCL_ERROR; } @@ -2172,16 +2193,20 @@ ClassSuperSet( if (superc == 0) { superclasses = ckrealloc(superclasses, sizeof(Class *)); - superclasses[0] = oPtr->fPtr->objectCls; - superc = 1; if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) { superclasses[0] = oPtr->fPtr->classCls; + } else { + superclasses[0] = oPtr->fPtr->objectCls; } + superc = 1; + /* Corresponding TclOODecrRefCount is near the end of this function */ + AddRef(superclasses[0]->thisPtr); } else { for (i=0 ; i 0; i--) { + TclOODecrRefCount(superclasses[i]->thisPtr); + } ckfree(superclasses); return TCL_ERROR; } + /* Corresponding TclOODecrRefCount() is near the end of this + * function */ + AddRef(superclasses[i]->thisPtr); } } @@ -2221,6 +2252,8 @@ ClassSuperSet( oPtr->classPtr->superclasses.num = superc; FOREACH(superPtr, oPtr->classPtr->superclasses) { TclOOAddToSubclasses(oPtr->classPtr, superPtr); + /* To account for the AddRef() earlier in this function */ + TclOODecrRefCount(superPtr->thisPtr); } BumpGlobalEpoch(interp, oPtr->classPtr); @@ -2511,9 +2544,16 @@ ObjMixinSet( mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { + while (i-- > 0) { + TclOODecrRefCount(mixins[i]->thisPtr); + } TclStackFree(interp, mixins); return TCL_ERROR; } + /* Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins() or + * just above if this function fails. + */ + AddRef(mixins[i]->thisPtr); } TclOOObjectSetMixins(oPtr, mixinc, mixins); diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 83b4d58..084c026 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -193,9 +193,10 @@ typedef struct Object { * destroyed. */ #define DESTRUCTOR_CALLED 2 /* Flag to say that the destructor has been * called. */ -#define CLASS_GONE 4 /* Indicates that the class of this object has - * been deleted, and so the object should not - * attempt to remove itself from its class. */ +#define CLASS_GONE 4 /* Obsolete. Indicates that the class of this + * object has been deleted, and so the object + * should not attempt to remove itself from its + * class. */ #define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of * the class hierarchy and should be treated * specially during teardown. */ @@ -222,10 +223,6 @@ typedef struct Object { typedef struct Class { Object *thisPtr; /* Reference to the object associated with * this class. */ - int refCount; /* Number of strong references to this class. - * Weak references are not counted; the - * purpose of this is to avoid Tcl_Preserve as - * that is quite slow. */ int flags; /* Assorted flags. */ LIST_STATIC(struct Class *) superclasses; /* List of superclasses, used for generation @@ -499,6 +496,7 @@ MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp, Class *classPtr, const char *nameStr, const char *nsNameStr); +MODULE_SCOPE int TclOODecrRefCount(Object *oPtr); MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr); MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr); MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr); @@ -528,10 +526,10 @@ MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr, const DeclaredClassMethod *dcm); MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr); -MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); -MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr, +MODULE_SCOPE int TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); +MODULE_SCOPE int TclOORemoveFromMixinSubs(Class *subPtr, Class *mixinPtr); -MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr, +MODULE_SCOPE int TclOORemoveFromSubclasses(Class *subPtr, Class *superPtr); MODULE_SCOPE Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp, CallChain *callPtr); @@ -546,18 +544,21 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); #include "tclOOIntDecls.h" /* + * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release. + */ + +#define AddRef(ptr) ((ptr)->refCount++) + +/* * A convenience macro for iterating through the lists used in the internal - * memory management of objects. This is a bit gnarly because we want to do - * the assignment of the picked-out value only when the body test succeeds, - * but we cannot rely on the assigned value being useful, forcing us to do - * some nasty stuff with the comma operator. The compiler's optimizer should - * be able to sort it all out! - * + * memory management of objects. * REQUIRES DECLARATION: int i; */ #define FOREACH(var,ary) \ - for(i=0 ; (i<(ary).num?((var=(ary).list[i]),1):0) ; i++) + for(i=0 ; i<(ary).num; i++) if ((ary).list[i] == NULL) { \ + continue; \ + } else if (var = (ary).list[i], 1) /* * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS @@ -592,17 +593,6 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); } \ } while(0) -/* - * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release. - */ - -#define AddRef(ptr) ((ptr)->refCount++) -#define DelRef(ptr) do { \ - if ((ptr)->refCount-- <= 1) { \ - ckfree(ptr); \ - } \ - } while(0) - #endif /* TCL_OO_INTERNAL_H */ /* diff --git a/tests/oo.test b/tests/oo.test index b9c5067..3be5f79 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -47,7 +47,7 @@ test oo-0.2 {basic test of OO's ability to clean up its initial state} { } {} test oo-0.3 {basic test of OO's ability to clean up its initial state} -body { leaktest { - [oo::object new] destroy + [oo::object new] destroy } } -constraints memory -result 0 test oo-0.4 {basic test of OO's ability to clean up its initial state} -body { @@ -131,6 +131,10 @@ test oo-1.4 {basic test of OO functionality} -body { test oo-1.4.1 {fully-qualified nested name} -body { oo::object create ::one::two::three } -result {::one::two::three} +test oo-1.4.2 {automatic command name has same name as namespace} -body { + set obj [oo::object new] + expr {[info object namespace $obj] == $obj} +} -result 1 test oo-1.5 {basic test of OO functionality} -body { oo::object doesnotexist } -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new} @@ -1514,9 +1518,9 @@ test oo-11.6 { # No segmentation fault return done -} -cleanup { +} -result done -cleanup { rename obj1 {} -} -result done +} test oo-12.1 {OO: filters} { oo::class create Aclass @@ -3891,9 +3895,6 @@ test oo-35.6 { rename obj {} } -result done - - - test oo-36.1 {TIP #470: introspection within oo::define} { oo::define oo::object self } ::oo::object -- cgit v0.12 From 0239e7e77f3f12c24179f6c021d3f7b40dfcf981 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 11 Dec 2017 23:50:22 +0000 Subject: Add the check for wrong arguments back to TclOO_Object_Destroy, remove inadvertant increment of Namespace->refCount. --- generic/tclBasic.c | 1 - generic/tclOO.c | 4 +++- generic/tclOOBasic.c | 5 +++++ 3 files changed, 8 insertions(+), 2 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a23100e..ce46cd4 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3153,7 +3153,6 @@ Tcl_DeleteCommandFromToken( cmdPtr->nsPtr->refCount++; - cmdPtr->nsPtr->refCount++; if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); diff --git a/generic/tclOO.c b/generic/tclOO.c index ae1ae3f..1a9bfc4 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -236,8 +236,10 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; #define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) #define RemoveItem(type, lst, i) \ + do { \ Remove ## type ((lst).list, (lst).num, i); \ - (lst).num-- + (lst).num-- \ + } while 0 /* * ---------------------------------------------------------------------- diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 84f414d..b2c06a7 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -340,6 +340,11 @@ TclOO_Object_Destroy( Object *oPtr = (Object *) Tcl_ObjectContextObject(context); CallContext *contextPtr; + if (objc != Tcl_ObjectContextSkippedArgs(context)) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); + return TCL_ERROR; + } if (!(oPtr->flags & DESTRUCTOR_CALLED)) { oPtr->flags |= DESTRUCTOR_CALLED; contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); -- cgit v0.12 From 3ddcb1cfb5dd70afa094e3113ab1946df9cbe222 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 13 Dec 2017 12:56:02 +0000 Subject: Fix syntax error in previous commit. --- generic/tclOO.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 1a9bfc4..0243c15 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -238,8 +238,8 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; #define RemoveItem(type, lst, i) \ do { \ Remove ## type ((lst).list, (lst).num, i); \ - (lst).num-- \ - } while 0 + (lst).num--; \ + } while (0) /* * ---------------------------------------------------------------------- -- cgit v0.12 From 6c799d891d69e04b9e0f32ca59719b4b23dc311a Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 4 Jan 2018 02:32:46 +0000 Subject: Minimal fixes to stop the [package files] machinery writing to freed mem. This contribution needs a careful review from someone who actually knows how Tcl_Preserve, etc. work. --- generic/tclPkg.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index cdf9a8b..288d5dc 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -948,6 +948,7 @@ Tcl_PackageObjCmd( Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); if (availPtr->pkgIndex) { Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + availPtr->pkgIndex = NULL; } ckfree(availPtr); } @@ -1001,6 +1002,7 @@ Tcl_PackageObjCmd( Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); if (availPtr->pkgIndex) { Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + availPtr->pkgIndex = NULL; } break; } @@ -1012,7 +1014,7 @@ Tcl_PackageObjCmd( } if (availPtr == NULL) { availPtr = ckalloc(sizeof(PkgAvail)); - availPtr->pkgIndex = 0; + availPtr->pkgIndex = NULL; DupBlock(availPtr->version, argv3, (unsigned) length + 1); if (prevPtr == NULL) { @@ -1384,6 +1386,7 @@ TclFreePackageInfo( Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); if (availPtr->pkgIndex) { Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + availPtr->pkgIndex = NULL; } ckfree(availPtr); } -- cgit v0.12 From 26b5bf3eca7b04ccab8b69c78ffd578425e8f6f0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 4 Jan 2018 12:58:31 +0000 Subject: (cherry-pick): Use http 2 instead of http 1 for Safe Base testing. --- tests/safe.test | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/safe.test b/tests/safe.test index 6784bb9..5bed5ff 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -172,17 +172,17 @@ test safe-6.3 {test safe interpreters knowledge of the world} { # aren't leaking infos, but they still do... # high level general test -test safe-7.1 {tests that everything works at high level} { +test safe-7.1 {tests that everything works at high level} -body { set i [safe::interpCreate]; # no error shall occur: # (because the default access_path shall include 1st level sub dirs # so package require in a slave works like in the master) - set v [interp eval $i {package require http 1}] + set v [interp eval $i {package require http 2}] # no error shall occur: - interp eval $i {http_config}; + interp eval $i {http::config} safe::interpDelete $i set v -} 1.0 +} -match glob -result 2.* test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]; # should not add anything (p0) -- cgit v0.12 From 7e4261e22c5e89d5591793bf264bdc35eb154653 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 8 Jan 2018 17:03:07 +0000 Subject: Rearrange a few lines TclRenameCommand to reduce operations. --- generic/tclBasic.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 3ed3447..d2e96b8 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -2626,10 +2626,6 @@ TclRenameCommand( Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL); return TCL_ERROR; } - cmdNsPtr = cmdPtr->nsPtr; - oldFullName = Tcl_NewObj(); - Tcl_IncrRefCount(oldFullName); - Tcl_GetCommandFullName(interp, cmd, oldFullName); /* * If the new command name is NULL or empty, delete the command. Do this @@ -2638,10 +2634,14 @@ TclRenameCommand( if ((newName == NULL) || (*newName == '\0')) { Tcl_DeleteCommandFromToken(interp, cmd); - result = TCL_OK; - goto done; + return TCL_OK; } + cmdNsPtr = cmdPtr->nsPtr; + oldFullName = Tcl_NewObj(); + Tcl_IncrRefCount(oldFullName); + Tcl_GetCommandFullName(interp, cmd, oldFullName); + /* * Make sure that the destination command does not already exist. The * rename operation is like creating a command, so we should automatically -- cgit v0.12 From b40ed15606db487315736beef3d23679445b122e Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 8 Jan 2018 17:36:00 +0000 Subject: Rearrange a few lines TclRenameCommand to reduce operations. --- generic/tclBasic.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index ad81bb8..26a4843 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -2590,10 +2590,6 @@ TclRenameCommand( Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL); return TCL_ERROR; } - cmdNsPtr = cmdPtr->nsPtr; - oldFullName = Tcl_NewObj(); - Tcl_IncrRefCount(oldFullName); - Tcl_GetCommandFullName(interp, cmd, oldFullName); /* * If the new command name is NULL or empty, delete the command. Do this @@ -2602,10 +2598,14 @@ TclRenameCommand( if ((newName == NULL) || (*newName == '\0')) { Tcl_DeleteCommandFromToken(interp, cmd); - result = TCL_OK; - goto done; + return TCL_OK; } + cmdNsPtr = cmdPtr->nsPtr; + oldFullName = Tcl_NewObj(); + Tcl_IncrRefCount(oldFullName); + Tcl_GetCommandFullName(interp, cmd, oldFullName); + /* * Make sure that the destination command does not already exist. The * rename operation is like creating a command, so we should automatically -- cgit v0.12 From 4a5058fc1bd50653d1de1db7f43ed983b4c8fd72 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 8 Jan 2018 18:21:40 +0000 Subject: Udate Tcl_ObjectDeleted to reflect recent changes. --- generic/tclOO.c | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 0243c15..7719f50 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1083,9 +1083,7 @@ ObjectNamespaceDeleted( * methods on the object. */ - /* To do: Get dkf to weigh in on wether this should be protected with a - * !IsRoot() condition. - */ + /* To do: Should this be protected with a * !IsRoot() condition? */ TclOORemoveFromInstances(oPtr, oPtr->selfCls); FOREACH(mixinPtr, oPtr->mixins) { @@ -2842,7 +2840,7 @@ int Tcl_ObjectDeleted( Tcl_Object object) { - return Deleted((Object *)object) ? 1 : 0; + return ((Object *)object)->command == NULL; } Tcl_Object -- cgit v0.12 From 6d9902632c27a3a3a46f9ea9506555027acac8ac Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 9 Jan 2018 00:10:22 +0000 Subject: Some refactoring and tidying up of comments. --- generic/tclOO.c | 340 ++++++++++++++++++++++++++++++---------------- generic/tclOOCall.c | 13 +- generic/tclOODefineCmds.c | 95 +++++++++++-- 3 files changed, 318 insertions(+), 130 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 7719f50..39e3fb2 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -71,7 +71,9 @@ static void DeletedHelpersNamespace(ClientData clientData); static Tcl_NRPostProc FinalizeAlloc; static Tcl_NRPostProc FinalizeNext; static Tcl_NRPostProc FinalizeObjectCall; -static void initClassPath(Tcl_Interp * interp, Class *clsPtr); +static inline void InitClassPath(Tcl_Interp * interp, Class *clsPtr); +static void InitClassSystemRoots(Tcl_Interp *interp, + Foundation *fPtr); static int InitFoundation(Tcl_Interp *interp); static void KillFoundation(ClientData clientData, Tcl_Interp *interp); @@ -82,6 +84,8 @@ static void ObjectRenamedTrace(ClientData clientData, const char *newName, int flags); static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr); static void DeleteDescendants(Tcl_Interp *interp,Object *oPtr); +static inline void RemoveClass(Class **list, int num, int idx); +static inline void RemoveObject(Object **list, int num, int idx); static inline void SquelchCachedName(Object *oPtr); static int PublicObjectCmd(ClientData clientData, @@ -96,8 +100,6 @@ static int PrivateObjectCmd(ClientData clientData, static int PrivateNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static void RemoveClass(Class ** list, int num, int idx); -static void RemoveObject(Object ** list, int num, int idx); /* * Methods in the oo::object and oo::class classes. First, we define a helper @@ -236,14 +238,50 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; #define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) #define RemoveItem(type, lst, i) \ - do { \ - Remove ## type ((lst).list, (lst).num, i); \ - (lst).num--; \ + do { \ + Remove ## type ((lst).list, (lst).num, i); \ + (lst).num--; \ } while (0) /* * ---------------------------------------------------------------------- * + * RemoveClass, RemoveObject -- + * + * Helpers for the RemoveItem macro for deleting a class or object from a + * list. Setting the "empty" location to NULL makes debugging a little + * easier. + * + * ---------------------------------------------------------------------- + */ + +static inline void +RemoveClass( + Class **list, + int num, + int idx) +{ + for (; idx < num - 1; idx++) { + list[idx] = list[idx + 1]; + } + list[idx] = NULL; +} + +static inline void +RemoveObject( + Object **list, + int num, + int idx) +{ + for (; idx < num - 1; idx++) { + list[idx] = list[idx + 1]; + } + list[idx] = NULL; +} + +/* + * ---------------------------------------------------------------------- + * * TclOOInit -- * * Called to initialise the OO system within an interpreter. @@ -321,10 +359,6 @@ InitFoundation( Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); Foundation *fPtr = ckalloc(sizeof(Foundation)); Tcl_Obj *namePtr, *argsPtr, *bodyPtr; - - Class fakeCls; - Object fakeObject; - Tcl_DString buffer; Command *cmdPtr; int i; @@ -387,47 +421,10 @@ InitFoundation( Tcl_CallWhenDeleted(interp, KillFoundation, NULL); /* - * Create the objects at the core of the object system. These need to be - * spliced manually. + * Create the special objects at the core of the object system. */ - /* Stand up a phony class for bootstrapping. */ - fPtr->objectCls = &fakeCls; - /* referenced in AllocClass to increment the refCount. */ - fakeCls.thisPtr = &fakeObject; - - fPtr->objectCls = AllocClass(interp, - AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); - fPtr->classCls = AllocClass(interp, - AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); - - /* Rewire bootstrapped objects. */ - fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; - fPtr->classCls->thisPtr->selfCls = fPtr->classCls; - - AddRef(fPtr->objectCls->thisPtr); - AddRef(fPtr->classCls->thisPtr); - AddRef(fPtr->classCls->thisPtr->selfCls->thisPtr); - AddRef(fPtr->objectCls->thisPtr->selfCls->thisPtr); - - /* special initialization for the primordial objects */ - fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; - fPtr->objectCls->flags |= ROOT_OBJECT; - - /* This is why it is unnecessary in this routine to make up for the - * incremented reference count of fPtr->objectCls that was sallwed by - * fakeObject. */ - fPtr->objectCls->superclasses.num = 0; - ckfree(fPtr->objectCls->superclasses.list); - fPtr->objectCls->superclasses.list = NULL; - - fPtr->classCls->thisPtr->flags |= ROOT_CLASS; - fPtr->classCls->flags |= ROOT_CLASS; - - /* Standard initialization for new Objects */ - TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); - TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); - TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); + InitClassSystemRoots(interp, fPtr); /* * Basic method declarations for the core classes. @@ -494,6 +491,88 @@ InitFoundation( } return Tcl_EvalEx(interp, slotScript, -1, 0); } + +/* + * ---------------------------------------------------------------------- + * + * InitClassSystemRoots -- + * + * Creates the objects at the core of the object system. These need to be + * spliced manually. + * + * ---------------------------------------------------------------------- + */ + +static void +InitClassSystemRoots( + Tcl_Interp *interp, + Foundation *fPtr) +{ + Class fakeCls; + Object fakeObject; + + /* + * Stand up a phony class for bootstrapping. + */ + + fPtr->objectCls = &fakeCls; + + /* + * Referenced in AllocClass to increment the refCount. + */ + + fakeCls.thisPtr = &fakeObject; + + fPtr->objectCls = AllocClass(interp, + AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); + fPtr->classCls = AllocClass(interp, + AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); + + /* + * Rewire bootstrapped objects. + */ + + fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; + fPtr->classCls->thisPtr->selfCls = fPtr->classCls; + + AddRef(fPtr->objectCls->thisPtr); + AddRef(fPtr->classCls->thisPtr); + AddRef(fPtr->classCls->thisPtr->selfCls->thisPtr); + AddRef(fPtr->objectCls->thisPtr->selfCls->thisPtr); + + /* + * Special initialization for the primordial objects. + */ + + fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; + fPtr->objectCls->flags |= ROOT_OBJECT; + + /* + * This is why it is unnecessary in this routine to make up for the + * incremented reference count of fPtr->objectCls that was sallwed by + * fakeObject. + */ + + fPtr->objectCls->superclasses.num = 0; + ckfree(fPtr->objectCls->superclasses.list); + fPtr->objectCls->superclasses.list = NULL; + + fPtr->classCls->thisPtr->flags |= ROOT_CLASS; + fPtr->classCls->flags |= ROOT_CLASS; + + /* + * Standard initialization for new Objects. + */ + + TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); + TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); + TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); + + /* + * THIS IS THE ONLY FUNCTION THAT DOES NON-STANDARD CLASS SPLICING. + * Everything else is careful to prohibit looping. + */ +} /* * ---------------------------------------------------------------------- @@ -584,8 +663,8 @@ AllocObject( * if the OO system should pick the object * name itself (equal to the namespace * name). */ - Namespace *nsPtr, /* The namespace to create the object in, - or NULL if *nameStr is NULL */ + Namespace *nsPtr, /* The namespace to create the object in, or + * NULL if *nameStr is NULL */ const char *nsNameStr) /* The name of the namespace to create, or * NULL if the OO system should pick a unique * name itself. If this is non-NULL but names @@ -678,10 +757,10 @@ AllocObject( /* * An object starts life with a refCount of 2 to mark the two stages of * destruction it occur: A call to ObjectRenamedTrace(), and a call to - * ObjectNamespaceDeleted(). + * ObjectNamespaceDeleted(). */ - oPtr->refCount = 2; + oPtr->refCount = 2; oPtr->flags = USE_CLASS_CACHE; /* @@ -716,7 +795,7 @@ AllocObject( tracePtr->refCount = 1; oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, - PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); + PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); return oPtr; } @@ -786,6 +865,7 @@ ObjectRenamedTrace( int flags) /* Why was the object deleted? */ { Object *oPtr = clientData; + /* * If this is a rename and not a delete of the object, we just flush the * cache of the object name. @@ -812,7 +892,7 @@ ObjectRenamedTrace( /* * ---------------------------------------------------------------------- * - * ReleaseClassContents -- + * DeleteDescendants, ReleaseClassContents -- * * Tear down the special class data structure, including deleting all * dependent classes and objects. @@ -834,9 +914,11 @@ DeleteDescendants( */ FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { - /* This condition also covers the case where mixinSubclassPtr == + /* + * This condition also covers the case where mixinSubclassPtr == * clsPtr */ + if (!Deleted(mixinSubclassPtr->thisPtr)) { Tcl_DeleteCommandFromToken(interp, mixinSubclassPtr->thisPtr->command); @@ -844,6 +926,7 @@ DeleteDescendants( i -= TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr); TclOODecrRefCount(mixinSubclassPtr->thisPtr); } + /* * Squelch subclasses of this class. */ @@ -862,7 +945,10 @@ DeleteDescendants( if (!IsRootClass(oPtr)) { FOREACH(instancePtr, clsPtr->instances) { - /* This condition also covers the case where instancePtr == oPtr */ + /* + * This condition also covers the case where instancePtr == oPtr + */ + if (!Deleted(instancePtr) && !IsRoot(instancePtr)) { Tcl_DeleteCommandFromToken(interp, instancePtr->command); } @@ -870,7 +956,6 @@ DeleteDescendants( } } } - static void ReleaseClassContents( @@ -878,7 +963,7 @@ ReleaseClassContents( Object *oPtr) /* The object representing the class. */ { FOREACH_HASH_DECLS; - int i; + int i; Class *clsPtr = oPtr->classPtr, *tmpClsPtr; Method *mPtr; Foundation *fPtr = oPtr->fPtr; @@ -1008,9 +1093,11 @@ ObjectNamespaceDeleted( int i; if (Deleted(oPtr)) { - /* To do: Can ObjectNamespaceDeleted ever be called twice? If not, - * this guard could be removed. + /* + * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, this + * guard could be removed. */ + return; } @@ -1019,6 +1106,7 @@ ObjectNamespaceDeleted( * process of being deleted, nothing else may modify its bookeeping * records. This is the flag that */ + oPtr->flags |= OBJECT_DELETED; /* Let the dominoes fall */ @@ -1032,6 +1120,7 @@ ObjectNamespaceDeleted( * in that case when the destructor is partially deleted before the uses * of it have gone. [Bug 2949397] */ + if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) { CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); @@ -1071,6 +1160,7 @@ ObjectNamespaceDeleted( * The namespace must have been deleted directly. Delete the command * as well. */ + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); } @@ -1083,7 +1173,10 @@ ObjectNamespaceDeleted( * methods on the object. */ - /* To do: Should this be protected with a * !IsRoot() condition? */ + /* + * TODO: Should this be protected with a * !IsRoot() condition? + */ + TclOORemoveFromInstances(oPtr, oPtr->selfCls); FOREACH(mixinPtr, oPtr->mixins) { @@ -1134,22 +1227,19 @@ ObjectNamespaceDeleted( } /* - * Because an object can be a class that is an instance of itself, the - * A class object's class structure should only be cleaned after most of - * the cleanup on the object is done. - */ - - - /* + * Because an object can be a class that is an instance of itself, the + * class object's class structure should only be cleaned after most of the + * cleanup on the object is done. + * * The class of objects needs some special care; if it is deleted (and * we're not killing the whole interpreter) we force the delete of the * class of classes now as well. Due to the incestuous nature of those two * classes, if one goes the other must too and yet the tangle can * sometimes not go away automatically; we force it here. [Bug 2962664] */ - if (IsRootObject(oPtr) && !Deleted(fPtr->classCls->thisPtr) - && !Tcl_InterpDeleted(interp)) { + if (IsRootObject(oPtr) && !Deleted(fPtr->classCls->thisPtr) + && !Tcl_InterpDeleted(interp)) { Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); } @@ -1170,7 +1260,7 @@ ObjectNamespaceDeleted( /* * ---------------------------------------------------------------------- * - * TclOODecrRef -- + * TclOODecrRefCount -- * * Decrement the refcount of an object and deallocate storage then object * is no longer referenced. Returns 1 if storage was deallocated, and 0 @@ -1178,9 +1268,14 @@ ObjectNamespaceDeleted( * * ---------------------------------------------------------------------- */ -int TclOODecrRefCount(Object *oPtr) { + +int +TclOODecrRefCount( + Object *oPtr) +{ if (oPtr->refCount-- <= 1) { Class *clsPtr = oPtr->classPtr; + if (oPtr->classPtr != NULL) { ckfree(clsPtr->superclasses.list); ckfree(clsPtr->subclasses.list); @@ -1195,18 +1290,6 @@ int TclOODecrRefCount(Object *oPtr) { return 0; } -/* setting the "empty" location to NULL makes debugging a little easier */ -#define REMOVEBODY { \ - for (; idx < num - 1; idx++) { \ - list[idx] = list[idx+1]; \ - } \ - list[idx] = NULL; \ - return; \ -} -void RemoveClass(Class **list, int num, int idx) REMOVEBODY - -void RemoveObject(Object **list, int num, int idx) REMOVEBODY - /* * ---------------------------------------------------------------------- * @@ -1226,6 +1309,7 @@ TclOORemoveFromInstances( { int i, res = 0; Object *instPtr; + if (Deleted(clsPtr->thisPtr)) { return res; } @@ -1291,6 +1375,7 @@ TclOORemoveFromSubclasses( { int i, res = 0; Class *subclsPtr; + if (Deleted(superPtr->thisPtr)) { return res; } @@ -1331,7 +1416,8 @@ TclOOAddToSubclasses( if (superPtr->subclasses.size == ALLOC_CHUNK) { superPtr->subclasses.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK); } else { - superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list, sizeof(Class *) * superPtr->subclasses.size); + superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list, + sizeof(Class *) * superPtr->subclasses.size); } } superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr; @@ -1418,6 +1504,25 @@ TclOOAddToMixinSubs( * ---------------------------------------------------------------------- */ +static inline void +InitClassPath( + Tcl_Interp *interp, + Class *clsPtr) +{ + Foundation *fPtr = GetFoundation(interp); + + if (fPtr->helpersNs != NULL) { + Tcl_Namespace *path[2]; + + path[0] = fPtr->helpersNs; + path[1] = fPtr->ooNs; + TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); + } else { + TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1, + &fPtr->ooNs); + } +} + static Class * AllocClass( Tcl_Interp *interp, /* Interpreter within which to allocate the @@ -1434,7 +1539,8 @@ AllocClass( /* * Configure the namespace path for the class's object. */ - initClassPath(interp, clsPtr); + + InitClassPath(interp, clsPtr); /* * Classes are subclasses of oo::object, i.e. the objects they create are @@ -1460,19 +1566,6 @@ AllocClass( Tcl_InitObjHashTable(&clsPtr->classMethods); return clsPtr; } -static void -initClassPath(Tcl_Interp *interp, Class *clsPtr) { - Foundation *fPtr = GetFoundation(interp); - if (fPtr->helpersNs != NULL) { - Tcl_Namespace *path[2]; - path[0] = fPtr->helpersNs; - path[1] = fPtr->ooNs; - TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); - } else { - TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1, - &fPtr->ooNs); - } -} /* * ---------------------------------------------------------------------- @@ -1503,7 +1596,9 @@ Tcl_NewObjectInstance( ClientData clientData[4]; oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); - if (oPtr == NULL) {return NULL;} + if (oPtr == NULL) { + return NULL; + } /* * Run constructors, except when objc < 0, which is a special flag case @@ -1572,7 +1667,9 @@ TclNRNewObjectInstance( Object *oPtr; oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); - if (oPtr == NULL) {return TCL_ERROR;} + if (oPtr == NULL) { + return TCL_ERROR; + } /* * Run constructors, except when objc < 0 (a special flag case used for @@ -1623,29 +1720,33 @@ TclNewObjectInstanceCommon( Foundation *fPtr = GetFoundation(interp); Object *oPtr; const char *simpleName = NULL; - Namespace *nsPtr = NULL, *dummy, - *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp); + Namespace *nsPtr = NULL, *dummy; + Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp); int isNew; if (nameStr) { - TclGetNamespaceForQualName(interp, nameStr, inNsPtr, TCL_CREATE_NS_IF_UNKNOWN, - &nsPtr, &dummy, &dummy, &simpleName); + TclGetNamespaceForQualName(interp, nameStr, inNsPtr, + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy, &dummy, &simpleName); /* * Disallow creation of an object over an existing command. */ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, simpleName, &isNew); - if (isNew) { - /* Just kidding */ - Tcl_DeleteHashEntry(hPtr); - } else { + if (!isNew) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create object \"%s\": command already exists with" " that name", nameStr)); Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); return NULL; } + + /* + * We could make a hash entry! Don't actually want to do that here so + * nuke it immediately because we'll create it properly soon. + */ + + Tcl_DeleteHashEntry(hPtr); } /* @@ -1655,6 +1756,7 @@ TclNewObjectInstanceCommon( oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr); oPtr->selfCls = classPtr; TclOOAddToInstances(oPtr, classPtr); + /* * Check to see if we're really creating a class. If so, allocate the * class structure as well. @@ -1690,8 +1792,8 @@ FinalizeAlloc( Tcl_Object *objectPtr = data[3]; /* - * Ensure an error if the object was deleted in the constructor. - * Don't want to lose errors by accident. [Bug 2903011] + * Ensure an error if the object was deleted in the constructor. Don't + * want to lose errors by accident. [Bug 2903011] */ if (result != TCL_ERROR && Deleted(oPtr)) { @@ -1713,13 +1815,21 @@ FinalizeAlloc( (void) TclOOObjectName(interp, oPtr); Tcl_DeleteCommandFromToken(interp, oPtr->command); } - /* This decrements the refcount of oPtr */ + + /* + * This decrements the refcount of oPtr. + */ + TclOODeleteContext(contextPtr); return TCL_ERROR; } Tcl_RestoreInterpState(interp, state); *objectPtr = (Tcl_Object) oPtr; - /* This decrements the refcount of oPtr */ + + /* + * This decrements the refcount of oPtr. + */ + TclOODeleteContext(contextPtr); return TCL_OK; } @@ -1828,7 +1938,7 @@ Tcl_CopyObjectInstance( */ o2Ptr->flags = oPtr->flags & ~( - OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); + OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); /* * Copy the object's metadata. */ diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index c71425b..7da9da0 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -110,7 +110,11 @@ TclOODeleteContext( TclOODeleteChain(contextPtr->callPtr); if (oPtr != NULL) { TclStackFree(oPtr->fPtr->interp, contextPtr); - /* Corresponding AddRef() in TclOO.c/TclOOObjectCmdCore */ + + /* + * Corresponding AddRef() in TclOO.c/TclOOObjectCmdCore + */ + TclOODecrRefCount(oPtr); } } @@ -901,6 +905,7 @@ InitCallChain( * ---------------------------------------------------------------------- * * IsStillValid -- + * * Calculates whether the given call chain can be used for executing a * method for the given object. The condition on a chain from a cached * location being reusable is: @@ -1172,7 +1177,11 @@ TclOOGetCallContext( returnContext: contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext)); contextPtr->oPtr = oPtr; - /* Corresponding TclOODecrRefCount() in TclOODeleteContext */ + + /* + * Corresponding TclOODecrRefCount() in TclOODeleteContext + */ + AddRef(oPtr); contextPtr->callPtr = callPtr; contextPtr->skip = 2; diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 7f3ea18..c08b350 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -123,6 +123,7 @@ static const struct DeclaredSlot slots[] = { * ---------------------------------------------------------------------- * * BumpGlobalEpoch -- + * * Utility that ensures that call chains that are invalid will get thrown * away at an appropriate time. Note that exactly which epoch gets * advanced will depend on exactly what the class is tangled up in; in @@ -167,6 +168,7 @@ BumpGlobalEpoch( * ---------------------------------------------------------------------- * * RecomputeClassCacheFlag -- + * * Determine whether the object is prototypical of its class, and hence * able to use the class's method chain cache. * @@ -189,6 +191,7 @@ RecomputeClassCacheFlag( * ---------------------------------------------------------------------- * * TclOOObjectSetFilters -- + * * Install a list of filter method names into an object. * * ---------------------------------------------------------------------- @@ -247,6 +250,7 @@ TclOOObjectSetFilters( * ---------------------------------------------------------------------- * * TclOOClassSetFilters -- + * * Install a list of filter method names into a class. * * ---------------------------------------------------------------------- @@ -309,6 +313,7 @@ TclOOClassSetFilters( * ---------------------------------------------------------------------- * * TclOOObjectSetMixins -- + * * Install a list of mixin classes into an object. * * ---------------------------------------------------------------------- @@ -350,9 +355,12 @@ TclOOObjectSetMixins( FOREACH(mixinPtr, oPtr->mixins) { if (mixinPtr != oPtr->selfCls) { TclOOAddToInstances(oPtr, mixinPtr); - /* Corresponding TclOODecrRefCount() is in the caller of this + + /* + * Corresponding TclOODecrRefCount() is in the caller of this * function. */ + TclOODecrRefCount(mixinPtr->thisPtr); } } @@ -364,6 +372,7 @@ TclOOObjectSetMixins( * ---------------------------------------------------------------------- * * TclOOClassSetMixins -- + * * Install a list of mixin classes into a class. * * ---------------------------------------------------------------------- @@ -401,9 +410,12 @@ TclOOClassSetMixins( memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); FOREACH(mixinPtr, classPtr->mixins) { TclOOAddToMixinSubs(classPtr, mixinPtr); - /* Corresponding TclOODecrRefCount() is in the caller of this - * function + + /* + * Corresponding TclOODecrRefCount() is in the caller of this + * function. */ + TclOODecrRefCount(mixinPtr->thisPtr); } } @@ -414,6 +426,7 @@ TclOOClassSetMixins( * ---------------------------------------------------------------------- * * RenameDeleteMethod -- + * * Core of the code to rename and delete methods. * * ---------------------------------------------------------------------- @@ -503,6 +516,7 @@ RenameDeleteMethod( * ---------------------------------------------------------------------- * * TclOOUnknownDefinition -- + * * Handles what happens when an unknown command is encountered during the * processing of a definition script. Works by finding a command in the * operating definition namespace that the requested command is a unique @@ -581,6 +595,7 @@ TclOOUnknownDefinition( * ---------------------------------------------------------------------- * * FindCommand -- + * * Specialized version of Tcl_FindCommand that handles command prefixes * and disallows namespace magic. * @@ -641,6 +656,7 @@ FindCommand( * ---------------------------------------------------------------------- * * InitDefineContext -- + * * Does the magic incantations necessary to push the special stack frame * used when processing object definitions. It is up to the caller to * dispose of the frame (with TclPopStackFrame) when finished. @@ -666,7 +682,9 @@ InitDefineContext( return TCL_ERROR; } - /* framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules */ + /* + * framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules. + */ (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, FRAME_IS_OO_DEFINE); @@ -681,6 +699,7 @@ InitDefineContext( * ---------------------------------------------------------------------- * * TclOOGetDefineCmdContext -- + * * Extracts the magic token from the current stack frame, or returns NULL * (and leaves an error message) otherwise. * @@ -717,6 +736,7 @@ TclOOGetDefineCmdContext( * ---------------------------------------------------------------------- * * GetClassInOuterContext -- + * * Wrapper round Tcl_GetObjectFromObj to perform the lookup in the * context that called oo::define (or equivalent). Note that this may * have to go up multiple levels to get the level that we started doing @@ -759,6 +779,7 @@ GetClassInOuterContext( * ---------------------------------------------------------------------- * * GenerateErrorInfo -- + * * Factored out code to generate part of the error trace messages. * * ---------------------------------------------------------------------- @@ -797,6 +818,7 @@ GenerateErrorInfo( * ---------------------------------------------------------------------- * * MagicDefinitionInvoke -- + * * Part of the implementation of the "oo::define" and "oo::objdefine" * commands that is used to implement the more-than-one-argument case, * applying ensemble-like tricks with dispatch so that error messages are @@ -860,6 +882,7 @@ MagicDefinitionInvoke( * ---------------------------------------------------------------------- * * TclOODefineObjCmd -- + * * Implementation of the "oo::define" command. Works by effectively doing * the same as 'namespace eval', but with extra magic applied so that the * object to be modified is known to the commands in the target @@ -934,6 +957,7 @@ TclOODefineObjCmd( * ---------------------------------------------------------------------- * * TclOOObjDefObjCmd -- + * * Implementation of the "oo::objdefine" command. Works by effectively * doing the same as 'namespace eval', but with extra magic applied so * that the object to be modified is known to the commands in the target @@ -1001,6 +1025,7 @@ TclOOObjDefObjCmd( * ---------------------------------------------------------------------- * * TclOODefineSelfObjCmd -- + * * Implementation of the "self" subcommand of the "oo::define" command. * Works by effectively doing the same as 'namespace eval', but with * extra magic applied so that the object to be modified is known to the @@ -1068,6 +1093,7 @@ TclOODefineSelfObjCmd( * ---------------------------------------------------------------------- * * TclOODefineObjSelfObjCmd -- + * * Implementation of the "self" subcommand of the "oo::objdefine" * command. * @@ -1101,6 +1127,7 @@ TclOODefineObjSelfObjCmd( * ---------------------------------------------------------------------- * * TclOODefineClassObjCmd -- + * * Implementation of the "class" subcommand of the "oo::objdefine" * command. * @@ -1175,7 +1202,10 @@ TclOODefineClassObjCmd( if (oPtr->selfCls != clsPtr) { TclOORemoveFromInstances(oPtr, oPtr->selfCls); - /* Reference count already incremented 3 lines up. */ + /* + * Reference count already incremented a few lines up. + */ + oPtr->selfCls = clsPtr; TclOOAddToInstances(oPtr, oPtr->selfCls); @@ -1192,6 +1222,7 @@ TclOODefineClassObjCmd( * ---------------------------------------------------------------------- * * TclOODefineConstructorObjCmd -- + * * Implementation of the "constructor" subcommand of the "oo::define" * command. * @@ -1260,6 +1291,7 @@ TclOODefineConstructorObjCmd( * ---------------------------------------------------------------------- * * TclOODefineDeleteMethodObjCmd -- + * * Implementation of the "deletemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. * @@ -1316,6 +1348,7 @@ TclOODefineDeleteMethodObjCmd( * ---------------------------------------------------------------------- * * TclOODefineDestructorObjCmd -- + * * Implementation of the "destructor" subcommand of the "oo::define" * command. * @@ -1380,6 +1413,7 @@ TclOODefineDestructorObjCmd( * ---------------------------------------------------------------------- * * TclOODefineExportObjCmd -- + * * Implementation of the "export" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1474,6 +1508,7 @@ TclOODefineExportObjCmd( * ---------------------------------------------------------------------- * * TclOODefineForwardObjCmd -- + * * Implementation of the "forward" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1534,6 +1569,7 @@ TclOODefineForwardObjCmd( * ---------------------------------------------------------------------- * * TclOODefineMethodObjCmd -- + * * Implementation of the "method" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1591,6 +1627,7 @@ TclOODefineMethodObjCmd( * ---------------------------------------------------------------------- * * TclOODefineMixinObjCmd -- + * * Implementation of the "mixin" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1634,9 +1671,12 @@ TclOODefineMixinObjCmd( goto freeAndError; } mixins[i-1] = clsPtr; - /* Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins, + + /* + * Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins, * TclOOClassSetMixinsk, or just below if this function fails. */ + AddRef(mixins[i-1]->thisPtr); } @@ -1661,6 +1701,7 @@ TclOODefineMixinObjCmd( * ---------------------------------------------------------------------- * * TclOODefineRenameMethodObjCmd -- + * * Implementation of the "renamemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. * @@ -1717,6 +1758,7 @@ TclOODefineRenameMethodObjCmd( * ---------------------------------------------------------------------- * * TclOODefineUnexportObjCmd -- + * * Implementation of the "unexport" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1811,6 +1853,7 @@ TclOODefineUnexportObjCmd( * ---------------------------------------------------------------------- * * Tcl_ClassSetConstructor, Tcl_ClassSetDestructor -- + * * How to install a constructor or destructor into a class; API to call * from C. * @@ -1865,6 +1908,7 @@ Tcl_ClassSetDestructor( * ---------------------------------------------------------------------- * * TclOODefineSlots -- + * * Create the "::oo::Slot" class and its standard instances. Class * definition is empty at the stage (added by scripting). * @@ -1908,6 +1952,7 @@ TclOODefineSlots( * ---------------------------------------------------------------------- * * ClassFilterGet, ClassFilterSet -- + * * Implementation of the "filter" slot accessors of the "oo::define" * command. * @@ -1987,6 +2032,7 @@ ClassFilterSet( * ---------------------------------------------------------------------- * * ClassMixinGet, ClassMixinSet -- + * * Implementation of the "mixin" slot accessors of the "oo::define" * command. * @@ -2077,9 +2123,12 @@ ClassMixinSet( Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); goto freeAndError; } - /* Corresponding TclOODecrRefCount() is in TclOOClassSetMixins, or just - * below if this function fails + + /* + * Corresponding TclOODecrRefCount() is in TclOOClassSetMixins, or + * just below if this function fails. */ + AddRef(mixins[i]->thisPtr); } @@ -2099,6 +2148,7 @@ ClassMixinSet( * ---------------------------------------------------------------------- * * ClassSuperGet, ClassSuperSet -- + * * Implementation of the "superclass" slot accessors of the "oo::define" * command. * @@ -2199,7 +2249,11 @@ ClassSuperSet( superclasses[0] = oPtr->fPtr->objectCls; } superc = 1; - /* Corresponding TclOODecrRefCount is near the end of this function */ + + /* + * Corresponding TclOODecrRefCount is near the end of this function. + */ + AddRef(superclasses[0]->thisPtr); } else { for (i=0 ; ithisPtr); } } @@ -2252,7 +2310,11 @@ ClassSuperSet( oPtr->classPtr->superclasses.num = superc; FOREACH(superPtr, oPtr->classPtr->superclasses) { TclOOAddToSubclasses(oPtr->classPtr, superPtr); - /* To account for the AddRef() earlier in this function */ + + /* + * To account for the AddRef() earlier in this function. + */ + TclOODecrRefCount(superPtr->thisPtr); } BumpGlobalEpoch(interp, oPtr->classPtr); @@ -2264,6 +2326,7 @@ ClassSuperSet( * ---------------------------------------------------------------------- * * ClassVarsGet, ClassVarsSet -- + * * Implementation of the "variable" slot accessors of the "oo::define" * command. * @@ -2406,6 +2469,7 @@ ClassVarsSet( * ---------------------------------------------------------------------- * * ObjectFilterGet, ObjectFilterSet -- + * * Implementation of the "filter" slot accessors of the "oo::objdefine" * command. * @@ -2473,6 +2537,7 @@ ObjFilterSet( * ---------------------------------------------------------------------- * * ObjectMixinGet, ObjectMixinSet -- + * * Implementation of the "mixin" slot accessors of the "oo::objdefine" * command. * @@ -2550,9 +2615,12 @@ ObjMixinSet( TclStackFree(interp, mixins); return TCL_ERROR; } - /* Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins() or + + /* + * Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins() or * just above if this function fails. */ + AddRef(mixins[i]->thisPtr); } @@ -2565,6 +2633,7 @@ ObjMixinSet( * ---------------------------------------------------------------------- * * ObjectVarsGet, ObjectVarsSet -- + * * Implementation of the "variable" slot accessors of the "oo::objdefine" * command. * -- cgit v0.12 From 48456596fff560a8a2e3bb709c7683d07874d306 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 9 Jan 2018 11:15:14 +0000 Subject: (partial) fix for [https://core.tcl.tk/tk/info/00a27923ee26437611e1ed83f96e15b6caabcd8b|00a27923ee]: text/entry dysfunctional when pasting an emoji on MacOSX. Don't handle incoming valid 4-byte UTF-8 characters as invalid byte sequences (since they aren't), but as being the Unicode replacement character. --- generic/tclUtf.c | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 6255a4e..f7ceaab 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -68,11 +68,7 @@ static const unsigned char totalBytes[256] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, -#if TCL_UTF_MAX > 3 4,4,4,4,4,4,4,4, -#else - 1,1,1,1,1,1,1,1, -#endif 1,1,1,1,1,1,1,1 }; @@ -334,13 +330,22 @@ Tcl_UtfToUniChar( * represents itself. */ } -#if TCL_UTF_MAX > 3 else if (byte < 0xF8) { if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) { /* * Four-byte-character lead byte followed by three trail bytes. */ -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX == 3 + byte = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12) + | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F)) - 0x10000; + if (byte & 0x100000) { + /* out of range, < 0x10000 or > 0x10ffff */ + } else { + /* produce replacement character, and advance source pointer */ + *chPtr = (Tcl_UniChar) 0xFFFD; + return 4; + } +#elif TCL_UTF_MAX == 4 Tcl_UniChar surrogate; byte = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12) @@ -371,7 +376,6 @@ Tcl_UtfToUniChar( * represents itself. */ } -#endif *chPtr = (Tcl_UniChar) byte; return 1; @@ -505,13 +509,13 @@ Tcl_NumUtfChars( } if (i < 0) i = INT_MAX; /* Bug [2738427] */ } else { - register const char *endPtr = src + length - TCL_UTF_MAX; + register const char *endPtr = src + length - 4; while (src < endPtr) { src += TclUtfToUniChar(src, &ch); i++; } - endPtr += TCL_UTF_MAX; + endPtr += 4; while ((src < endPtr) && Tcl_UtfCharComplete(src, endPtr - src)) { src += TclUtfToUniChar(src, &ch); i++; @@ -683,7 +687,7 @@ Tcl_UtfPrev( int i, byte; look = --src; - for (i = 0; i < TCL_UTF_MAX; i++) { + for (i = 0; i < 4; i++) { if (look < start) { if (src < start) { src = start; -- cgit v0.12 From 48d6a20861f95be856bef0e780c054757c9c3803 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 10 Jan 2018 14:02:03 +0000 Subject: Re-implement Tcl_WinTCharToUtf/Tcl_WinUtfToTChar in pure win32 api, even for TCL_UTF_MAX=3. We can do that now safely, because of the changed handling of valid 4-byte UTF-8 characters in the previous commit. --- generic/tclEvent.c | 1 - generic/tclIOUtil.c | 9 ------ generic/tclInt.h | 1 - generic/tclIntPlatDecls.h | 4 +++ generic/tclStubInit.c | 39 +++++++----------------- unix/tclUnixInit.c | 6 ---- win/tclWin32Dll.c | 76 ++--------------------------------------------- win/tclWinInit.c | 7 ----- 8 files changed, 17 insertions(+), 126 deletions(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 49fd2ae..93cf983 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1057,7 +1057,6 @@ TclInitSubsystems(void) * mutexes. */ TclInitIOSubsystem(); /* Inits a tsd key (noop). */ TclInitEncodingSubsystem(); /* Process wide encoding init. */ - TclpSetInterfaces(); TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ subsystemsInitialized = 1; } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 8fb3aa8..144bab0 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -830,15 +830,6 @@ TclResetFilesystem(void) if (++theFilesystemEpoch == 0) { ++theFilesystemEpoch; } - -#ifdef _WIN32 - /* - * Cleans up the win32 API filesystem proc lookup table. This must happen - * very late in finalization so that deleting of copied dlls can occur. - */ - - TclWinResetInterfaces(); -#endif } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 2ba0493..888adca 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3157,7 +3157,6 @@ MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_PathPart portion); MODULE_SCOPE char * TclpReadlink(const char *fileName, Tcl_DString *linkPtr); -MODULE_SCOPE void TclpSetInterfaces(void); MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp); MODULE_SCOPE void * TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr); MODULE_SCOPE void TclThreadStorageKeySet(Tcl_ThreadDataKey *keyPtr, diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 1222cee..ada1d2b 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -549,6 +549,10 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #define TclWinConvertWSAError TclWinConvertError #undef TclpInetNtoa #define TclpInetNtoa inet_ntoa +#undef TclWinResetInterfaces +#define TclWinResetInterfaces() /* nop */ +#undef TclWinSetInterfaces +#define TclWinSetInterfaces(dummy) /* nop */ #if defined(_WIN32) # undef TclWinNToHS diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 227bf02..e25b148 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -104,6 +104,13 @@ static const char *TclGetStartupScriptFileName(void) #if defined(_WIN32) || defined(__CYGWIN__) #undef TclWinNToHS #undef TclWinGetPlatformId +#undef TclWinResetInterfaces +#undef TclWinSetInterfaces +static void +doNothing(void) +{ + /* dummy implementation, no need to do anything */ +} #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 #define TclWinNToHS winNToHS static unsigned short TclWinNToHS(unsigned short ns) { @@ -115,9 +122,13 @@ TclWinGetPlatformId(void) { return 2; /* VER_PLATFORM_WIN32_NT */; } +#define TclWinResetInterfaces doNothing +#define TclWinSetInterfaces (void (*) (int)) doNothing #else #define TclWinNToHS 0 #define TclWinGetPlatformId 0 +#define TclWinResetInterfaces 0 +#define TclWinSetInterfaces 0 #endif #endif # define TclBNInitBignumFromWideUInt TclInitBignumFromWideUInt @@ -133,14 +144,8 @@ TclWinGetPlatformId(void) # define TclpIsAtty 0 #elif defined(__CYGWIN__) # define TclpIsAtty TclPlatIsAtty -# define TclWinSetInterfaces (void (*) (int)) doNothing # define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing # define TclWinFlushDirtyChannels doNothing -# define TclWinResetInterfaces doNothing - -#if TCL_UTF_MAX < 4 -static Tcl_Encoding winTCharEncoding; -#endif static int TclpIsAtty(int fd) @@ -201,19 +206,12 @@ TclpGetPid(Tcl_Pid pid) return (int) (size_t) pid; } -static void -doNothing(void) -{ - /* dummy implementation, no need to do anything */ -} - char * Tcl_WinUtfToTChar( const char *string, int len, Tcl_DString *dsPtr) { -#if TCL_UTF_MAX > 3 WCHAR *wp; int size = MultiByteToWideChar(CP_UTF8, 0, string, len, 0, 0); @@ -225,13 +223,6 @@ Tcl_WinUtfToTChar( Tcl_DStringSetLength(dsPtr, 2*size); wp[size] = 0; return (char *)wp; -#else - if (!winTCharEncoding) { - winTCharEncoding = Tcl_GetEncoding(0, "unicode"); - } - return Tcl_UtfToExternalDString(winTCharEncoding, - string, len, dsPtr); -#endif } char * @@ -240,7 +231,6 @@ Tcl_WinTCharToUtf( int len, Tcl_DString *dsPtr) { -#if TCL_UTF_MAX > 3 char *p; int size; @@ -256,13 +246,6 @@ Tcl_WinTCharToUtf( Tcl_DStringSetLength(dsPtr, size); p[size] = 0; return p; -#else - if (!winTCharEncoding) { - winTCharEncoding = Tcl_GetEncoding(0, "unicode"); - } - return Tcl_ExternalToUtfDString(winTCharEncoding, - string, len, dsPtr); -#endif } #if defined(TCL_WIDE_INT_IS_LONG) diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index cc66569..630460a 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -577,12 +577,6 @@ TclpSetInitialEncodings(void) Tcl_DStringFree(&encodingName); } -void -TclpSetInterfaces(void) -{ - /* do nothing */ -} - static const char * SearchKnownEncodings( const char *encoding) diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index da1cdfe..599c126 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -32,10 +32,6 @@ static HINSTANCE hInstance; /* HINSTANCE of this DLL. */ #define cpuid __asm __emit 0fh __asm __emit 0a2h #endif -#if TCL_UTF_MAX < 4 -static Tcl_Encoding winTCharEncoding = NULL; -#endif - /* * The following declaration is for the VC++ DLL entry point. */ @@ -196,8 +192,6 @@ TclWinInit( if (os.dwPlatformId != VER_PLATFORM_WIN32_NT) { Tcl_Panic("Windows NT is the only supported platform"); } - - TclWinResetInterfaces(); } /* @@ -234,38 +228,10 @@ TclWinNoBackslash( /* *--------------------------------------------------------------------------- * - * TclpSetInterfaces -- - * - * A helper proc. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -void -TclpSetInterfaces(void) -{ -#if TCL_UTF_MAX < 4 - TclWinResetInterfaces(); - winTCharEncoding = Tcl_GetEncoding(NULL, "unicode"); -#endif -} - -/* - *--------------------------------------------------------------------------- - * * TclWinEncodingsCleanup -- * - * Called during finalization to free up any encodings we use. - * - * We also clean up any memory allocated in our mount point map which is - * used to follow certain kinds of symlinks. That code should never be - * used once encodings are taken down. + * Called during finalization to clean up any memory allocated in our + * mount point map which is used to follow certain kinds of symlinks. * * Results: * None. @@ -281,8 +247,6 @@ TclWinEncodingsCleanup(void) { MountPointMap *dlIter, *dlIter2; - TclWinResetInterfaces(); - /* * Clean up the mount point map. */ @@ -299,32 +263,6 @@ TclWinEncodingsCleanup(void) } /* - *--------------------------------------------------------------------------- - * - * TclWinResetInterfaces -- - * - * Called during finalization to reset us to a safe state for reuse. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ -void -TclWinResetInterfaces(void) -{ -#if TCL_UTF_MAX < 4 - if (winTCharEncoding != NULL) { - Tcl_FreeEncoding(winTCharEncoding); - winTCharEncoding = NULL; - } -#endif -} - -/* *-------------------------------------------------------------------- * * TclWinDriveLetterForVolMountPoint @@ -533,7 +471,6 @@ Tcl_WinUtfToTChar( Tcl_DString *dsPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { -#if TCL_UTF_MAX > 3 TCHAR *wp; int size = MultiByteToWideChar(CP_UTF8, 0, string, len, 0, 0); @@ -545,10 +482,6 @@ Tcl_WinUtfToTChar( Tcl_DStringSetLength(dsPtr, 2*size); wp[size] = 0; return wp; -#else - return (TCHAR *) Tcl_UtfToExternalDString(winTCharEncoding, - string, len, dsPtr); -#endif } char * @@ -559,7 +492,6 @@ Tcl_WinTCharToUtf( Tcl_DString *dsPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { -#if TCL_UTF_MAX > 3 char *p; int size; @@ -575,10 +507,6 @@ Tcl_WinTCharToUtf( Tcl_DStringSetLength(dsPtr, size); p[size] = 0; return p; -#else - return Tcl_ExternalToUtfDString(winTCharEncoding, - (const char *) string, len, dsPtr); -#endif } /* diff --git a/win/tclWinInit.c b/win/tclWinInit.c index dc8bba7..91f149b 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -487,18 +487,11 @@ TclpSetInitialEncodings(void) { Tcl_DString encodingName; - TclpSetInterfaces(); Tcl_SetSystemEncoding(NULL, Tcl_GetEncodingNameFromEnvironment(&encodingName)); Tcl_DStringFree(&encodingName); } -void TclWinSetInterfaces( - int dummy) /* Not used. */ -{ - TclpSetInterfaces(); -} - const char * Tcl_GetEncodingNameFromEnvironment( Tcl_DString *bufPtr) -- cgit v0.12 From 45e646472daf2fe6beb41555fe088b929cd2ce6c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 11 Jan 2018 15:44:05 +0000 Subject: Fix behavior of Tcl_GetRange() and "string range" regarding surrogates, when Tcl is compiled with -DTCL_UTF_MAX=4. Partial fix for bug [11ae2be95dac9417]. Also, fix typo. --- generic/tclStringObj.c | 13 ++++++++++++- tests/string.test | 4 ++++ 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 0f238cf..1b35c56 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -533,7 +533,7 @@ Tcl_GetUniChar( * * Get the Unicode form of the String object. If the object is not * already a String object, it will be converted to one. If the String - * object does not have a Unicode rep, then one is create from the UTF + * object does not have a Unicode rep, then one is created from the UTF * string format. * * Results: @@ -667,6 +667,17 @@ Tcl_GetRange( stringPtr = GET_STRING(objPtr); } +#if TCL_UTF_MAX == 4 + /* See: bug [11ae2be95dac9417] */ + if ((first>0) && ((stringPtr->unicode[first]&0xFC00) == 0xDC00) + && ((stringPtr->unicode[first-1]&0xFC00) == 0xD800)) { + ++first; + } + if ((last+1numChars) && ((stringPtr->unicode[last+1]&0xFC00) == 0xDC00) + && ((stringPtr->unicode[last]&0xFC00) == 0xD800)) { + ++last; + } +#endif return Tcl_NewUnicodeObj(stringPtr->unicode + first, last-first+1); } diff --git a/tests/string.test b/tests/string.test index bbba5eb..53f1cfb 100644 --- a/tests/string.test +++ b/tests/string.test @@ -24,6 +24,7 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testobj [expr {[info commands testobj] != {}}] testConstraint testindexobj [expr {[info commands testindexobj] != {}}] +testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] @@ -1276,6 +1277,9 @@ test string-12.22 {string range, shimmering binary/index} { binary scan $s a* x string range $s $s end } 000000001 +test string-12.23 {string range, surrogates, bug [11ae2be95dac9417]} fullutf { + list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3] +} [list \U100000 {} b] test string-13.1 {string repeat} { list [catch {string repeat} msg] $msg -- cgit v0.12 From 5fea88381c81c486e138059e2c86318935148e8f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 17 Jan 2018 10:06:30 +0000 Subject: typo's (found by Gustaf Neumann). Thanks! --- generic/tcl.h | 4 ++-- generic/tclInt.h | 12 ++++++------ 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index b43b2d7..36001ca 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1986,7 +1986,7 @@ typedef struct Tcl_Token { * TCL_TOKEN_OPERATOR - The token describes one expression operator. * An operator might be the name of a math * function such as "abs". A TCL_TOKEN_OPERATOR - * token is always preceeded by one + * token is always preceded by one * TCL_TOKEN_SUB_EXPR token for the operator's * subexpression, and is followed by zero or more * TCL_TOKEN_SUB_EXPR tokens for the operator's @@ -2622,7 +2622,7 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); #ifndef TCL_NO_DEPRECATED /* * These function have been renamed. The old names are deprecated, but we - * define these macros for backwards compatibilty. + * define these macros for backwards compatibility. */ # define Tcl_Ckalloc Tcl_Alloc diff --git a/generic/tclInt.h b/generic/tclInt.h index 91c8b96..4967cd3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -413,7 +413,7 @@ struct NamespacePathEntry { */ typedef struct EnsembleConfig { - Namespace *nsPtr; /* The namspace backing this ensemble up. */ + Namespace *nsPtr; /* The namespace backing this ensemble up. */ Tcl_Command token; /* The token for the command that provides * ensemble support for the namespace, or NULL * if the command has been deleted (or never @@ -1813,7 +1813,7 @@ typedef struct Interp { * unused space in interp was repurposed for * pluggable bytecode optimizers. The core * contains one optimizer, which can be - * selectively overriden by extensions. */ + * selectively overridden by extensions. */ } extra; /* @@ -2228,7 +2228,7 @@ typedef struct Interp { * use the rand() or srand() functions. * SAFE_INTERP: Non zero means that the current interp is a safe * interp (i.e. it has only the safe commands installed, - * less priviledge than a regular interp). + * less privilege than a regular interp). * INTERP_DEBUG_FRAME: Used for switching on various extra interpreter * debug/info mechanisms (e.g. info frame eval/uplevel * tracing) which are performance intensive. @@ -2369,7 +2369,7 @@ typedef struct List { * be ignored if there is no string rep at * all.*/ Tcl_Obj *elements; /* First list element; the struct is grown to - * accomodate all elements. */ + * accommodate all elements. */ } List; #define LIST_MAX \ @@ -2491,13 +2491,13 @@ typedef struct List { * tip of the path, so duplication of shared objects should be done along the * way. * - * DICT_PATH_EXISTS indicates that we are performing an existance test and a + * DICT_PATH_EXISTS indicates that we are performing an existence test and a * lookup failure should therefore not be an error. If (and only if) this flag * is set, TclTraceDictPath() will return the special value * DICT_PATH_NON_EXISTENT if the path is not traceable. * * DICT_PATH_CREATE (which also requires the DICT_PATH_UPDATE bit to be set) - * indicates that we are to create non-existant dictionaries on the path. + * indicates that we are to create non-existent dictionaries on the path. */ #define DICT_PATH_READ 0 -- cgit v0.12 From 1c58e29da28ad2a5a2307da0d8384bedc8891040 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 17 Jan 2018 12:56:22 +0000 Subject: Remove Tcl_CaseObjCmd from tclInt.h as well (was missing in previous commit) --- generic/tclCmdMZ.c | 1 + generic/tclInt.h | 5 ----- generic/tclIntPlatDecls.h | 1 - 3 files changed, 1 insertion(+), 6 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 1fc2d17..a206cc5 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2893,6 +2893,7 @@ StringCatCmd( * *---------------------------------------------------------------------- */ + static int StringBytesCmd( ClientData dummy, /* Not used. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index e9b9936..eadcb8e 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3221,11 +3221,6 @@ MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 -MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -#endif MODULE_SCOPE int Tcl_CatchObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 437ed24..99d6753 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -504,7 +504,6 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT -#define TclWinGetPlatformId() (2) /* VER_PLATFORM_WIN32_NT */ #define TclWinConvertWSAError TclWinConvertError #if !defined(_WIN32) -- cgit v0.12 From d695e02d2fd744a4391dcf3c4a8a20e499cc47b1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 17 Jan 2018 14:17:21 +0000 Subject: Remove obsolete documentation (belonging to now-removed functions). Remove obsolete 8.4 bytecodes. And a few other (internal) macro's which are no longer in use. --- doc/Backslash.3 | 47 --------------- doc/CrtMathFnc.3 | 162 -------------------------------------------------- doc/DString.3 | 6 -- doc/Encoding.3 | 19 +----- doc/ParseCmd.3 | 24 ++------ doc/case.n | 60 ------------------- doc/mathfunc.n | 5 +- generic/tcl.decls | 7 +-- generic/tcl.h | 64 +------------------- generic/tclBasic.c | 12 ---- generic/tclCompile.h | 2 - generic/tclDecls.h | 14 ++--- generic/tclEvent.c | 6 +- generic/tclExecute.c | 143 -------------------------------------------- generic/tclIndexObj.c | 10 ---- generic/tclInt.h | 13 ---- generic/tclPanic.c | 4 +- generic/tclProc.c | 4 -- tests/execute.test | 4 -- tools/genStubs.tcl | 2 - 20 files changed, 24 insertions(+), 584 deletions(-) delete mode 100644 doc/Backslash.3 delete mode 100644 doc/CrtMathFnc.3 delete mode 100644 doc/case.n diff --git a/doc/Backslash.3 b/doc/Backslash.3 deleted file mode 100644 index 0805f8e..0000000 --- a/doc/Backslash.3 +++ /dev/null @@ -1,47 +0,0 @@ -'\" -'\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tcl_Backslash 3 "8.1" Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -Tcl_Backslash \- parse a backslash sequence -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -char -\fBTcl_Backslash\fR(\fIsrc, countPtr\fR) -.SH ARGUMENTS -.AS char *countPtr out -.AP char *src in -Pointer to a string starting with a backslash. -.AP int *countPtr out -If \fIcountPtr\fR is not NULL, \fI*countPtr\fR gets filled -in with number of characters in the backslash sequence, including -the backslash character. -.BE - -.SH DESCRIPTION -.PP -The use of \fBTcl_Backslash\fR is deprecated in favor of -\fBTcl_UtfBackslash\fR. -.PP -This is a utility procedure provided for backwards compatibility with -non-internationalized Tcl extensions. It parses a backslash sequence and -returns the low byte of the Unicode character corresponding to the sequence. -\fBTcl_Backslash\fR modifies \fI*countPtr\fR to contain the number of -characters in the backslash sequence. -.PP -See the Tcl manual entry for information on the valid backslash sequences. -All of the sequences described in the Tcl manual entry are supported by -\fBTcl_Backslash\fR. -.SH "SEE ALSO" -Tcl(n), Tcl_UtfBackslash(3) - -.SH KEYWORDS -backslash, parse diff --git a/doc/CrtMathFnc.3 b/doc/CrtMathFnc.3 deleted file mode 100644 index acceb5b..0000000 --- a/doc/CrtMathFnc.3 +++ /dev/null @@ -1,162 +0,0 @@ -'\" -'\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -Tcl_CreateMathFunc, Tcl_GetMathFuncInfo, Tcl_ListMathFuncs \- Define, query and enumerate math functions for expressions -.SH "NOTICE OF EVENTUAL DEPRECATION" -.PP -The \fBTcl_CreateMathFunc\fR and \fBTcl_GetMathFuncInfo\fR functions -are rendered somewhat obsolete by the ability to create functions for -expressions by placing commands in the \fBtcl::mathfunc\fR namespace, -as described in the \fBmathfunc\fR manual page; the API described on -this page is not expected to be maintained indefinitely. -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -void -\fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR) -.sp -int -\fBTcl_GetMathFuncInfo\fR(\fIinterp, name, numArgsPtr, argTypesPtr, procPtr, - clientDataPtr\fR) -.sp -Tcl_Obj * -\fBTcl_ListMathFuncs\fR(\fIinterp, pattern\fR) -.SH ARGUMENTS -.AS Tcl_ValueType *clientDataPtr out -.AP Tcl_Interp *interp in -Interpreter in which new function will be defined. -.AP "const char" *name in -Name for new function. -.AP int numArgs in -Number of arguments to new function; also gives size of \fIargTypes\fR array. -.AP Tcl_ValueType *argTypes in -Points to an array giving the permissible types for each argument to -function. -.AP Tcl_MathProc *proc in -Procedure that implements the function. -.AP ClientData clientData in -Arbitrary one-word value to pass to \fIproc\fR when it is invoked. -.AP int *numArgsPtr out -Points to a variable that will be set to contain the number of -arguments to the function. -.AP Tcl_ValueType **argTypesPtr out -Points to a variable that will be set to contain a pointer to an array -giving the permissible types for each argument to the function which -will need to be freed up using \fITcl_Free\fR. -.AP Tcl_MathProc **procPtr out -Points to a variable that will be set to contain a pointer to the -implementation code for the function (or NULL if the function is -implemented directly in bytecode). -.AP ClientData *clientDataPtr out -Points to a variable that will be set to contain the clientData -argument passed to \fITcl_CreateMathFunc\fR when the function was -created if the function is not implemented directly in bytecode. -.AP "const char" *pattern in -Pattern to match against function names so as to filter them (by -passing to \fITcl_StringMatch\fR), or NULL to not apply any filter. -.BE -.SH DESCRIPTION -.PP -Tcl allows a number of mathematical functions to be used in -expressions, such as \fBsin\fR, \fBcos\fR, and \fBhypot\fR. -These functions are represented by commands in the namespace, -\fBtcl::mathfunc\fR. The \fBTcl_CreateMathFunc\fR function is -an obsolete way for applications to add additional functions -to those already provided by Tcl or to replace existing functions. -It should not be used by new applications, which should create -math functions using \fBTcl_CreateObjCommand\fR to create a command -in the \fBtcl::mathfunc\fR namespace. -.PP -In the \fBTcl_CreateMathFunc\fR interface, -\fIName\fR is the name of the function as it will appear in expressions. -If \fIname\fR does not already exist in the \fB::tcl::mathfunc\fR -namespace, then a new command is created in that namespace. -If \fIname\fR does exist, then the existing function is replaced. -\fINumArgs\fR and \fIargTypes\fR describe the arguments to the function. -Each entry in the \fIargTypes\fR array must be -one of \fBTCL_INT\fR, \fBTCL_DOUBLE\fR, \fBTCL_WIDE_INT\fR, -or \fBTCL_EITHER\fR to indicate whether the corresponding argument must be an -integer, a double-precision floating value, a wide (64-bit) integer, -or any, respectively. -.PP -Whenever the function is invoked in an expression Tcl will invoke -\fIproc\fR. \fIProc\fR should have arguments and result that match -the type \fBTcl_MathProc\fR: -.PP -.CS -typedef int \fBTcl_MathProc\fR( - ClientData \fIclientData\fR, - Tcl_Interp *\fIinterp\fR, - Tcl_Value *\fIargs\fR, - Tcl_Value *\fIresultPtr\fR); -.CE -.PP -When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR -arguments will be the same as those passed to \fBTcl_CreateMathFunc\fR. -\fIArgs\fR will point to an array of \fInumArgs\fR Tcl_Value structures, -which describe the actual arguments to the function: -.PP -.CS -typedef struct Tcl_Value { - Tcl_ValueType \fItype\fR; - long \fIintValue\fR; - double \fIdoubleValue\fR; - Tcl_WideInt \fIwideValue\fR; -} \fBTcl_Value\fR; -.CE -.PP -The \fItype\fR field indicates the type of the argument and is -one of \fBTCL_INT\fR, \fBTCL_DOUBLE\fR or \fBTCL_WIDE_INT\fR. -It will match the \fIargTypes\fR value specified for the function unless -the \fIargTypes\fR value was \fBTCL_EITHER\fR. Tcl converts -the argument supplied in the expression to the type requested in -\fIargTypes\fR, if that is necessary. -Depending on the value of the \fItype\fR field, the \fIintValue\fR, -\fIdoubleValue\fR or \fIwideValue\fR -field will contain the actual value of the argument. -.PP -\fIProc\fR should compute its result and store it either as an integer -in \fIresultPtr->intValue\fR or as a floating value in -\fIresultPtr->doubleValue\fR. -It should set also \fIresultPtr->type\fR to one of -\fBTCL_INT\fR, \fBTCL_DOUBLE\fR or \fBTCL_WIDE_INT\fR -to indicate which value was set. -Under normal circumstances \fIproc\fR should return \fBTCL_OK\fR. -If an error occurs while executing the function, \fIproc\fR should -return \fBTCL_ERROR\fR and leave an error message in the interpreter's result. -.PP -\fBTcl_GetMathFuncInfo\fR retrieves the values associated with -function \fIname\fR that were passed to a preceding -\fBTcl_CreateMathFunc\fR call. Normally, the return code is -\fBTCL_OK\fR but if the named function does not exist, \fBTCL_ERROR\fR -is returned and an error message is placed in the interpreter's -result. -.PP -If an error did not occur, the array reference placed in the variable -pointed to by \fIargTypesPtr\fR is newly allocated, and should be -released by passing it to \fBTcl_Free\fR. Some functions (the -standard set implemented in the core, and those defined by placing -commands in the \fBtcl::mathfunc\fR namespace) do not have -argument type information; attempting to retrieve values for -them causes a NULL to be stored in the variable pointed to by -\fIprocPtr\fR and the variable pointed to by \fIclientDataPtr\fR -will not be modified. The variable pointed to by \fInumArgsPointer\fR -will contain -1, and no argument types will be stored in the variable -pointed to by \fIargTypesPointer\fR. -.PP -\fBTcl_ListMathFuncs\fR returns a Tcl value containing a list of all -the math functions defined in the interpreter whose name matches -\fIpattern\fR. The returned value has a reference count of zero. -.SH "SEE ALSO" -expr(n), info(n), Tcl_CreateObjCommand(3), Tcl_Free(3), Tcl_NewListObj(3) -.SH KEYWORDS -expression, mathematical function diff --git a/doc/DString.3 b/doc/DString.3 index 00f1b8a..2828278 100644 --- a/doc/DString.3 +++ b/doc/DString.3 @@ -34,8 +34,6 @@ char * .sp \fBTcl_DStringSetLength\fR(\fIdsPtr, newLength\fR) .sp -\fBTcl_DStringTrunc\fR(\fIdsPtr, newLength\fR) -.sp \fBTcl_DStringFree\fR(\fIdsPtr\fR) .sp \fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR) @@ -128,10 +126,6 @@ caller to fill in the new space. even if the string is truncated to zero length, so \fBTcl_DStringFree\fR will still need to be called. .PP -\fBTcl_DStringTrunc\fR changes the length of a dynamic string. -This procedure is now deprecated. \fBTcl_DStringSetLength\fR should -be used instead. -.PP \fBTcl_DStringFree\fR should be called when you are finished using the string. It frees up any memory that was allocated for the string and reinitializes the string's value to an empty string. diff --git a/doc/Encoding.3 b/doc/Encoding.3 index 79fca0f..40eb614 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_GetEncodingFromObj, Tcl_ExternalToUtfDString, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternal, Tcl_WinTCharToUtf, Tcl_WinUtfToTChar, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNameFromEnvironment, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetEncodingSearchPath, Tcl_SetEncodingSearchPath, Tcl_GetDefaultEncodingDir, Tcl_SetDefaultEncodingDir \- procedures for creating and using encodings +Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_GetEncodingFromObj, Tcl_ExternalToUtfDString, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternal, Tcl_WinTCharToUtf, Tcl_WinUtfToTChar, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNameFromEnvironment, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetEncodingSearchPath, Tcl_SetEncodingSearchPath \- procedures for creating and using encodings .SH SYNOPSIS .nf \fB#include \fR @@ -62,12 +62,6 @@ Tcl_Obj * .sp int \fBTcl_SetEncodingSearchPath\fR(\fIsearchPath\fR) -.sp -const char * -\fBTcl_GetDefaultEncodingDir\fR(\fIvoid\fR) -.sp -void -\fBTcl_SetDefaultEncodingDir\fR(\fIpath\fR) .SH ARGUMENTS .AS "const Tcl_EncodingType" *dstWrotePtr in/out .AP Tcl_Interp *interp in @@ -287,7 +281,7 @@ the encoding name to it. The \fBTcl_DStringValue\fR is returned. \fBTcl_GetEncodingNames\fR sets the \fIinterp\fR result to a list consisting of the names of all the encodings that are currently defined or can be dynamically loaded, searching the encoding path specified by -\fBTcl_SetDefaultEncodingDir\fR. This procedure does not ensure that the +\fBTcl_SetEncodingSearchPath\fR. This procedure does not ensure that the dynamically-loadable encoding files contain valid data, but merely that they exist. .PP @@ -402,15 +396,6 @@ are not verified as existing readable filesystem directories. When searching for encoding data files takes place, and non-existent or non-readable filesystem directories on the \fIsearchPath\fR are silently ignored. -.PP -\fBTcl_GetDefaultEncodingDir\fR and \fBTcl_SetDefaultEncodingDir\fR -are obsolete interfaces best replaced with calls to -\fBTcl_GetEncodingSearchPath\fR and \fBTcl_SetEncodingSearchPath\fR. -They are called to access and set the first element of the \fIsearchPath\fR -list. Since Tcl searches \fIsearchPath\fR for encoding data files in -list order, these routines establish the -.QW default -directory in which to find encoding data files. .SH "ENCODING FILES" Space would prohibit precompiling into Tcl every possible encoding algorithm, so many encodings are stored on disk as dynamically-loadable diff --git a/doc/ParseCmd.3 b/doc/ParseCmd.3 index 667d697..01b4065 100644 --- a/doc/ParseCmd.3 +++ b/doc/ParseCmd.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_ParseVar, Tcl_FreeParse, Tcl_EvalTokens, Tcl_EvalTokensStandard \- parse Tcl scripts and expressions +Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_ParseVar, Tcl_FreeParse, Tcl_EvalTokensStandard \- parse Tcl scripts and expressions .SH SYNOPSIS .nf \fB#include \fR @@ -33,20 +33,16 @@ const char * .sp \fBTcl_FreeParse\fR(\fIusedParsePtr\fR) .sp -Tcl_Obj * -\fBTcl_EvalTokens\fR(\fIinterp, tokenPtr, numTokens\fR) -.sp int \fBTcl_EvalTokensStandard\fR(\fIinterp, tokenPtr, numTokens\fR) .SH ARGUMENTS .AS Tcl_Interp *usedParsePtr out .AP Tcl_Interp *interp out -For procedures other than \fBTcl_FreeParse\fR, \fBTcl_EvalTokens\fR -and \fBTcl_EvalTokensStandard\fR, used only for error reporting; +For procedures other than \fBTcl_FreeParse\fR and +\fBTcl_EvalTokensStandard\fR, used only for error reporting; if NULL, then no error messages are left after errors. -For \fBTcl_EvalTokens\fR and \fBTcl_EvalTokensStandard\fR, -determines the context for evaluating the -script and also is used for error reporting; must not be NULL. +For \fBTcl_EvalTokensStandard\fR, determines the context for evaluating +the script and also is used for error reporting; must not be NULL. .AP "const char" *start in Pointer to first character in string to parse. .AP int numBytes in @@ -191,16 +187,6 @@ code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR, some other integer value originating in an extension. In addition, a result value or error message is left in \fIinterp\fR's result; it can be retrieved using \fBTcl_GetObjResult\fR. -.PP -\fBTcl_EvalTokens\fR differs from \fBTcl_EvalTokensStandard\fR only in -the return convention used: it returns the result in a new Tcl_Obj. -The reference count of the value returned as result has been -incremented, so the caller must -invoke \fBTcl_DecrRefCount\fR when it is finished with the value. -If an error or other exception occurs while evaluating the tokens -(such as a reference to a non-existent variable) then the return value -is NULL and an error message is left in \fIinterp\fR's result. The use -of \fBTcl_EvalTokens\fR is deprecated. .SH "TCL_PARSE STRUCTURE" .PP \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, diff --git a/doc/case.n b/doc/case.n deleted file mode 100644 index c48d634..0000000 --- a/doc/case.n +++ /dev/null @@ -1,60 +0,0 @@ -'\" -'\" Copyright (c) 1993 The Regents of the University of California. -'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH case n 7.0 Tcl "Tcl Built-In Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -case \- Evaluate one of several scripts, depending on a given value -.SH SYNOPSIS -\fBcase\fI string \fR?\fBin\fR? \fIpatList body \fR?\fIpatList body \fR...? -.sp -\fBcase\fI string \fR?\fBin\fR? {\fIpatList body \fR?\fIpatList body \fR...?} -.BE - -.SH DESCRIPTION -.PP -\fINote: the \fBcase\fI command is obsolete and is supported only -for backward compatibility. At some point in the future it may be -removed entirely. You should use the \fBswitch\fI command instead.\fR -.PP -The \fBcase\fR command matches \fIstring\fR against each of -the \fIpatList\fR arguments in order. -Each \fIpatList\fR argument is a list of one or -more patterns. If any of these patterns matches \fIstring\fR then -\fBcase\fR evaluates the following \fIbody\fR argument -by passing it recursively to the Tcl interpreter and returns the result -of that evaluation. -Each \fIpatList\fR argument consists of a single -pattern or list of patterns. Each pattern may contain any of the wild-cards -described under \fBstring match\fR. If a \fIpatList\fR -argument is \fBdefault\fR, the corresponding body will be evaluated -if no \fIpatList\fR matches \fIstring\fR. If no \fIpatList\fR argument -matches \fIstring\fR and no default is given, then the \fBcase\fR -command returns an empty string. -.PP -Two syntaxes are provided for the \fIpatList\fR and \fIbody\fR arguments. -The first uses a separate argument for each of the patterns and commands; -this form is convenient if substitutions are desired on some of the -patterns or commands. -The second form places all of the patterns and commands together into -a single argument; the argument must have proper list structure, with -the elements of the list being the patterns and commands. -The second form makes it easy to construct multi-line case commands, -since the braces around the whole list make it unnecessary to include a -backslash at the end of each line. -Since the \fIpatList\fR arguments are in braces in the second form, -no command or variable substitutions are performed on them; this makes -the behavior of the second form different than the first form in some -cases. - -.SH "SEE ALSO" -switch(n) - -.SH KEYWORDS -case, match, regular expression diff --git a/doc/mathfunc.n b/doc/mathfunc.n index 7233d46..ca091c1 100644 --- a/doc/mathfunc.n +++ b/doc/mathfunc.n @@ -106,10 +106,7 @@ of which work solely with floating-point numbers unless otherwise noted: In addition to these predefined functions, applications may define additional functions by using \fBproc\fR (or any other method, such as \fBinterp alias\fR or \fBTcl_CreateObjCommand\fR) to define -new commands in the \fBtcl::mathfunc\fR namespace. In addition, an -obsolete interface named \fBTcl_CreateMathFunc\fR() is available to -extensions that are written in C. The latter interface is not recommended -for new implementations. +new commands in the \fBtcl::mathfunc\fR namespace. .SS "DETAILED DEFINITIONS" .TP \fBabs \fIarg\fR diff --git a/generic/tcl.decls b/generic/tcl.decls index 5a261cb..c1930f6 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -818,7 +818,7 @@ declare 229 { void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr) } declare 230 { - void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) + void Tcl_SetPanicProc(TCL_NORETURN Tcl_PanicProc *panicProc) } declare 231 { int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth) @@ -1887,7 +1887,7 @@ declare 518 { # TIP#121 (exit handler) dkf for Joe Mistachkin declare 519 { - Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc) + Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN Tcl_ExitProc *proc) } # TIP#143 (resource limits) dkf @@ -2394,9 +2394,6 @@ declare 1 macosx { # Public functions that are not accessible via the stubs table. export { - void Tcl_Main(int argc, char **argv, Tcl_AppInitProc *appInitProc) -} -export { const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version, int exact) } diff --git a/generic/tcl.h b/generic/tcl.h index 3724083..8eb8f49 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -74,7 +74,7 @@ extern "C" { # define JOIN(a,b) JOIN1(a,b) # define JOIN1(a,b) a##b #endif -#endif /* !RC_INVOKED */ +#endif /* RC_INVOKED */ /* * A special definition used to allow this header file to be included from @@ -114,11 +114,6 @@ extern "C" { # define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) # define TCL_NORETURN __attribute__ ((noreturn)) # define TCL_NOINLINE __attribute__ ((noinline)) -# if defined(BUILD_tcl) || defined(BUILD_tk) -# define TCL_NORETURN1 __attribute__ ((noreturn)) -# else -# define TCL_NORETURN1 /* nothing */ -# endif #else # define TCL_FORMAT_PRINTF(a,b) # if defined(_MSC_VER) && (_MSC_VER >= 1310) @@ -128,7 +123,6 @@ extern "C" { # define TCL_NORETURN /* nothing */ # define TCL_NOINLINE /* nothing */ # endif -# define TCL_NORETURN1 /* nothing */ #endif /* @@ -233,46 +227,10 @@ extern "C" { #endif /* - *---------------------------------------------------------------------------- - * The following code is copied from winnt.h. If we don't replicate it here, - * then can't be included after tcl.h, since tcl.h also defines - * VOID. This block is skipped under Cygwin and Mingw. - */ - -#if defined(_WIN32) && !defined(HAVE_WINNT_IGNORE_VOID) -#ifndef VOID -#define VOID void -typedef char CHAR; -typedef short SHORT; -typedef long LONG; -#endif -#endif /* _WIN32 && !HAVE_WINNT_IGNORE_VOID */ - -/* - * Macro to use instead of "void" for arguments that must have type "void *" - * in ANSI C; maps them to type "char *" in non-ANSI systems. - */ - -#ifndef __VXWORKS__ -# ifndef NO_VOID -# define VOID void -# else -# define VOID char -# endif -#endif - -/* * Miscellaneous declarations. */ -#ifndef _CLIENTDATA -# ifndef NO_VOID - typedef void *ClientData; -# else - typedef int *ClientData; -# endif -# define _CLIENTDATA -#endif +typedef void *ClientData; /* * Darwin specific configure overrides (to support fat compiles, where @@ -573,22 +531,6 @@ typedef struct stat *Tcl_OldStat_; #define TCL_SUBST_ALL 007 /* - * Argument descriptors for math function callbacks in expressions: - */ - -typedef enum { - TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT -} Tcl_ValueType; - -typedef struct Tcl_Value { - Tcl_ValueType type; /* Indicates intValue or doubleValue is valid, - * or both. */ - long intValue; /* Integer value. */ - double doubleValue; /* Double-precision floating value. */ - Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */ -} Tcl_Value; - -/* * Forward declaration of Tcl_Obj to prevent an error when the forward * reference to Tcl_Obj is encountered in the function types declared below. */ @@ -633,8 +575,6 @@ typedef void (Tcl_FreeProc) (char *blockPtr); typedef void (Tcl_IdleProc) (ClientData clientData); typedef void (Tcl_InterpDeleteProc) (ClientData clientData, Tcl_Interp *interp); -typedef int (Tcl_MathProc) (ClientData clientData, Tcl_Interp *interp, - Tcl_Value *args, Tcl_Value *resultPtr); typedef void (Tcl_NamespaceDeleteProc) (ClientData clientData); typedef int (Tcl_ObjCmdProc) (ClientData clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj *const *objv); diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 841dd1f..463e455 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -38,18 +38,6 @@ #endif /* - * The following structure defines the client data for a math function - * registered with Tcl_CreateMathFunc - */ - -typedef struct OldMathFuncData { - Tcl_MathProc *proc; /* Handler function */ - int numArgs; /* Number of args expected */ - Tcl_ValueType *argTypes; /* Types of the args */ - ClientData clientData; /* Client data for the handler function */ -} OldMathFuncData; - -/* * This is the script cancellation struct and hash table. The hash table is * used to keep track of the information necessary to process script * cancellation requests, including the original interp, asynchronous handler diff --git a/generic/tclCompile.h b/generic/tclCompile.h index fcf6d91..2b752ff 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -594,8 +594,6 @@ typedef struct ByteCode { #define INST_UMINUS 59 #define INST_BITNOT 60 #define INST_LNOT 61 -#define INST_CALL_BUILTIN_FUNC1 62 -#define INST_CALL_FUNC1 63 #define INST_TRY_CVT_TO_NUMERIC 64 /* Opcodes 65 to 66 */ diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 3a0db04..ba335ef 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -684,7 +684,7 @@ EXTERN void Tcl_SetErrorCode(Tcl_Interp *interp, ...); EXTERN void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr); /* 230 */ EXTERN void Tcl_SetPanicProc( - TCL_NORETURN1 Tcl_PanicProc *panicProc); + TCL_NORETURN Tcl_PanicProc *panicProc); /* 231 */ EXTERN int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth); /* 232 */ @@ -1469,7 +1469,7 @@ EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp, EXTERN int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 519 */ -EXTERN Tcl_ExitProc * Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc); +EXTERN Tcl_ExitProc * Tcl_SetExitProc(TCL_NORETURN Tcl_ExitProc *proc); /* 520 */ EXTERN void Tcl_LimitAddHandler(Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, @@ -1804,7 +1804,7 @@ typedef struct TclStubs { int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */ const char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */ - TCL_NORETURN1 void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */ + TCL_NORETURN void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */ char * (*tcl_Alloc) (unsigned int size); /* 3 */ void (*tcl_Free) (char *ptr); /* 4 */ char * (*tcl_Realloc) (char *ptr, unsigned int size); /* 5 */ @@ -1951,7 +1951,7 @@ typedef struct TclStubs { int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */ void (*reserved131)(void); void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */ - TCL_NORETURN1 void (*tcl_Exit) (int status); /* 133 */ + TCL_NORETURN void (*tcl_Exit) (int status); /* 133 */ int (*tcl_ExposeCommand) (Tcl_Interp *interp, const char *hiddenCmdToken, const char *cmdName); /* 134 */ int (*tcl_ExprBoolean) (Tcl_Interp *interp, const char *expr, int *ptr); /* 135 */ int (*tcl_ExprBooleanObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr); /* 136 */ @@ -2056,7 +2056,7 @@ typedef struct TclStubs { void (*tcl_SetErrno) (int err); /* 227 */ void (*tcl_SetErrorCode) (Tcl_Interp *interp, ...); /* 228 */ void (*tcl_SetMaxBlockTime) (const Tcl_Time *timePtr); /* 229 */ - void (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */ + void (*tcl_SetPanicProc) (TCL_NORETURN Tcl_PanicProc *panicProc); /* 230 */ int (*tcl_SetRecursionLimit) (Tcl_Interp *interp, int depth); /* 231 */ void (*tcl_SetResult) (Tcl_Interp *interp, char *result, Tcl_FreeProc *freeProc); /* 232 */ int (*tcl_SetServiceMode) (int mode); /* 233 */ @@ -2120,7 +2120,7 @@ typedef struct TclStubs { int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, int numBytes, int flags); /* 291 */ int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */ int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */ - TCL_NORETURN1 void (*tcl_ExitThread) (int status); /* 294 */ + TCL_NORETURN void (*tcl_ExitThread) (int status); /* 294 */ int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */ char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 296 */ void (*tcl_FinalizeThread) (void); /* 297 */ @@ -2345,7 +2345,7 @@ typedef struct TclStubs { Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 516 */ void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 517 */ int (*tcl_FSEvalFileEx) (Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 518 */ - Tcl_ExitProc * (*tcl_SetExitProc) (TCL_NORETURN1 Tcl_ExitProc *proc); /* 519 */ + Tcl_ExitProc * (*tcl_SetExitProc) (TCL_NORETURN Tcl_ExitProc *proc); /* 519 */ void (*tcl_LimitAddHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */ void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData); /* 521 */ int (*tcl_LimitReady) (Tcl_Interp *interp); /* 522 */ diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 93cf983..f806516 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -89,7 +89,7 @@ static int subsystemsInitialized = 0; * non-NULL value. */ -static TCL_NORETURN1 Tcl_ExitProc *appExitPtr = NULL; +static TCL_NORETURN Tcl_ExitProc *appExitPtr = NULL; typedef struct ThreadSpecificData { ExitHandler *firstExitPtr; /* First in list of all exit handlers for this @@ -857,7 +857,7 @@ Tcl_DeleteThreadExitHandler( Tcl_ExitProc * Tcl_SetExitProc( - TCL_NORETURN1 Tcl_ExitProc *proc) /* New exit handler for app or NULL */ + TCL_NORETURN Tcl_ExitProc *proc) /* New exit handler for app or NULL */ { Tcl_ExitProc *prevExitProc; @@ -938,7 +938,7 @@ Tcl_Exit( int status) /* Exit status for application; typically 0 * for normal return, 1 for error return. */ { - TCL_NORETURN1 Tcl_ExitProc *currentAppExitPtr; + TCL_NORETURN Tcl_ExitProc *currentAppExitPtr; Tcl_MutexLock(&exitMutex); currentAppExitPtr = appExitPtr; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 935e864..42da922 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -101,64 +101,6 @@ long tclObjsAlloced = 0; long tclObjsFreed = 0; long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; #endif /* TCL_COMPILE_STATS */ - -/* - * Support pre-8.5 bytecodes unless specifically requested otherwise. - */ - -#ifndef TCL_SUPPORT_84_BYTECODE -#define TCL_SUPPORT_84_BYTECODE 1 -#endif - -#if TCL_SUPPORT_84_BYTECODE -/* - * We need to know the tclBuiltinFuncTable to support translation of pre-8.5 - * math functions to the namespace-based ::tcl::mathfunc::op in 8.5+. - */ - -typedef struct { - const char *name; /* Name of function. */ - int numArgs; /* Number of arguments for function. */ -} BuiltinFunc; - -/* - * Table describing the built-in math functions. Entries in this table are - * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's - * operand byte. - */ - -static BuiltinFunc const tclBuiltinFuncTable[] = { - {"acos", 1}, - {"asin", 1}, - {"atan", 1}, - {"atan2", 2}, - {"ceil", 1}, - {"cos", 1}, - {"cosh", 1}, - {"exp", 1}, - {"floor", 1}, - {"fmod", 2}, - {"hypot", 2}, - {"log", 1}, - {"log10", 1}, - {"pow", 2}, - {"sin", 1}, - {"sinh", 1}, - {"sqrt", 1}, - {"tan", 1}, - {"tanh", 1}, - {"abs", 1}, - {"double", 1}, - {"int", 1}, - {"rand", 0}, - {"round", 1}, - {"srand", 1}, - {"wide", 1}, - {NULL, 0}, -}; - -#define LAST_BUILTIN_FUNC 25 -#endif /* * NR_TEBC @@ -2900,91 +2842,6 @@ TEBCresume( return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL); -#if TCL_SUPPORT_84_BYTECODE - case INST_CALL_BUILTIN_FUNC1: - /* - * Call one of the built-in pre-8.5 Tcl math functions. This - * translates to INST_INVOKE_STK1 with the first argument of - * ::tcl::mathfunc::$objv[0]. We need to insert the named math - * function into the stack. - */ - - opnd = TclGetUInt1AtPtr(pc+1); - if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { - TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); - Tcl_Panic("TclNRExecuteByteCode: unrecognized builtin function code %d", opnd); - } - - TclNewLiteralStringObj(objPtr, "::tcl::mathfunc::"); - Tcl_AppendToObj(objPtr, tclBuiltinFuncTable[opnd].name, -1); - - /* - * Only 0, 1 or 2 args. - */ - - { - int numArgs = tclBuiltinFuncTable[opnd].numArgs; - Tcl_Obj *tmpPtr1, *tmpPtr2; - - if (numArgs == 0) { - PUSH_OBJECT(objPtr); - } else if (numArgs == 1) { - tmpPtr1 = POP_OBJECT(); - PUSH_OBJECT(objPtr); - PUSH_OBJECT(tmpPtr1); - Tcl_DecrRefCount(tmpPtr1); - } else { - tmpPtr2 = POP_OBJECT(); - tmpPtr1 = POP_OBJECT(); - PUSH_OBJECT(objPtr); - PUSH_OBJECT(tmpPtr1); - PUSH_OBJECT(tmpPtr2); - Tcl_DecrRefCount(tmpPtr1); - Tcl_DecrRefCount(tmpPtr2); - } - objc = numArgs + 1; - } - pcAdjustment = 2; - goto doInvocation; - - case INST_CALL_FUNC1: - /* - * Call a non-builtin Tcl math function previously registered by a - * call to Tcl_CreateMathFunc pre-8.5. This is essentially - * INST_INVOKE_STK1 converting the first arg to - * ::tcl::mathfunc::$objv[0]. - */ - - objc = TclGetUInt1AtPtr(pc+1); /* Number of arguments. The function - * name is the 0-th argument. */ - - objPtr = OBJ_AT_DEPTH(objc-1); - TclNewLiteralStringObj(tmpPtr, "::tcl::mathfunc::"); - Tcl_AppendObjToObj(tmpPtr, objPtr); - Tcl_DecrRefCount(objPtr); - - /* - * Variation of PUSH_OBJECT. - */ - - OBJ_AT_DEPTH(objc-1) = tmpPtr; - Tcl_IncrRefCount(tmpPtr); - - pcAdjustment = 2; - goto doInvocation; -#else - /* - * INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 were made obsolete by the - * changes to add a ::tcl::mathfunc namespace in 8.5. Optional support - * remains for existing bytecode precompiled files. - */ - - case INST_CALL_BUILTIN_FUNC1: - Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found"); - case INST_CALL_FUNC1: - Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found"); -#endif - case INST_INVOKE_REPLACE: objc = TclGetUInt4AtPtr(pc+1); opnd = TclGetUInt1AtPtr(pc+5); diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index eeed0e5..ce6ab68 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -891,18 +891,8 @@ Tcl_WrongNumArgs( * future... */ -#ifndef AVOID_HACKS_FOR_ITCL - int isFirst = 1; /* Special flag used to inhibit the treating - * of the first word as a list element so the - * hacky way Itcl generates error messages for - * its ensembles will still work. [Bug - * 1066837] */ -# define MAY_QUOTE_WORD (!isFirst) -# define AFTER_FIRST_WORD (isFirst = 0) -#else /* !AVOID_HACKS_FOR_ITCL */ # define MAY_QUOTE_WORD 1 # define AFTER_FIRST_WORD (void) 0 -#endif /* AVOID_HACKS_FOR_ITCL */ TclNewObj(objPtr); if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) { diff --git a/generic/tclInt.h b/generic/tclInt.h index eadcb8e..fe7b93d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -26,19 +26,6 @@ #undef ACCEPT_NAN /* - * In Tcl 8.7, stop supporting special hacks for legacy Itcl 3. - * Itcl 4 doesn't need them. Itcl 3 can be updated to not need them - * using the Tcl(Init|Reset)RewriteEnsemble() routines in all Tcl 8.6+ - * releases. Perhaps Tcl 8.7 will add even better public interfaces - * supporting all the re-invocation mechanisms extensions like Itcl 3 - * need. As an absolute last resort, folks who must make Itcl 3 work - * unchanged with Tcl 8.7 can remove this line to regain the migration - * support. Tcl 9 will no longer offer even that option. - */ - -#define AVOID_HACKS_FOR_ITCL 1 - -/* * Common include files needed by most of the Tcl source files are included * here, so that system-dependent personalizations for the include files only * have to be made in once place. This results in a few extra includes, but diff --git a/generic/tclPanic.c b/generic/tclPanic.c index 78ccf7c..c9ccf8a 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -26,7 +26,7 @@ #if defined(__CYGWIN__) static TCL_NORETURN Tcl_PanicProc *panicProc = tclWinDebugPanic; #else -static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL; +static TCL_NORETURN Tcl_PanicProc *panicProc = NULL; #endif /* @@ -47,7 +47,7 @@ static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL; void Tcl_SetPanicProc( - TCL_NORETURN1 Tcl_PanicProc *proc) + TCL_NORETURN Tcl_PanicProc *proc) { #if defined(_WIN32) /* tclWinDebugPanic only installs if there is no panicProc yet. */ diff --git a/generic/tclProc.c b/generic/tclProc.c index 70dc4dc..f5b3a64 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1051,11 +1051,7 @@ ProcWrongNumArgs( if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1); } else { -#ifdef AVOID_HACKS_FOR_ITCL - desiredObjs[0] = framePtr->objv[skip-1]; -#else desiredObjs[0] = Tcl_NewListObj(1, framePtr->objv + skip - 1); -#endif /* AVOID_HACKS_FOR_ITCL */ } Tcl_IncrRefCount(desiredObjs[0]); diff --git a/tests/execute.test b/tests/execute.test index 7bd2601..91a7de2 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -459,10 +459,6 @@ test execute-3.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} { list [catch {expr {! $x}} msg] $msg } {1 {can't use non-numeric string "foo" as operand of "!"}} -# INST_BITNOT not tested -# INST_CALL_BUILTIN_FUNC1 not tested -# INST_CALL_FUNC1 not tested - # INST_TRY_CVT_TO_NUMERIC is partially tested: test execute-3.72 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is int} {testobj} { set x [testintobj set 1 1] diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl index 830ba2b..a345437 100644 --- a/tools/genStubs.tcl +++ b/tools/genStubs.tcl @@ -600,8 +600,6 @@ proc genStubs::makeSlot {name decl index} { } if {[string range $rtype end-8 end] eq "__stdcall"} { append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") " - } elseif {[string range $rtype 0 11] eq "TCL_NORETURN"} { - append text "TCL_NORETURN1 " [string trim [string range $rtype 12 end]] " (*" $lfname ") " } else { append text $rtype " (*" $lfname ") " } -- cgit v0.12 From 4786f9814b9d6bf0d105c2c0a38082df4c26296e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 17 Jan 2018 16:01:42 +0000 Subject: clean-up some more remainings of the Itcl hack. Taken over from "novem". --- generic/tclIndexObj.c | 23 ++--------------------- generic/tclProc.c | 4 ++-- 2 files changed, 4 insertions(+), 23 deletions(-) diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index ce6ab68..bb329ad 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -881,19 +881,6 @@ Tcl_WrongNumArgs( Interp *iPtr = (Interp *) interp; const char *elementStr; - /* - * [incr Tcl] does something fairly horrific when generating error - * messages for its ensembles; it passes the whole set of ensemble - * arguments as a list in the first argument. This means that this code - * causes a problem in iTcl if it attempts to correctly quote all - * arguments, which would be the correct thing to do. We work around this - * nasty behaviour for now, and hope that we can remove it all in the - * future... - */ - -# define MAY_QUOTE_WORD 1 -# define AFTER_FIRST_WORD (void) 0 - TclNewObj(objPtr); if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) { iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; @@ -960,7 +947,7 @@ Tcl_WrongNumArgs( flags = 0; len = TclScanElement(elementStr, elemLen, &flags); - if (MAY_QUOTE_WORD && len != elemLen) { + if (len != elemLen) { char *quotedElementStr = TclStackAlloc(interp, (unsigned)len + 1); @@ -972,8 +959,6 @@ Tcl_WrongNumArgs( Tcl_AppendToObj(objPtr, elementStr, elemLen); } - AFTER_FIRST_WORD; - /* * Add a space if the word is not the last one (which has a * moderately complex condition here). @@ -1011,7 +996,7 @@ Tcl_WrongNumArgs( flags = 0; len = TclScanElement(elementStr, elemLen, &flags); - if (MAY_QUOTE_WORD && len != elemLen) { + if (len != elemLen) { char *quotedElementStr = TclStackAlloc(interp, (unsigned) len + 1); @@ -1024,8 +1009,6 @@ Tcl_WrongNumArgs( } } - AFTER_FIRST_WORD; - /* * Append a space character (" ") if there is more text to follow * (either another element from objv, or the message string). @@ -1048,8 +1031,6 @@ Tcl_WrongNumArgs( Tcl_AppendStringsToObj(objPtr, "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); Tcl_SetObjResult(interp, objPtr); -#undef MAY_QUOTE_WORD -#undef AFTER_FIRST_WORD } /* diff --git a/generic/tclProc.c b/generic/tclProc.c index f5b3a64..da729ef 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1051,7 +1051,7 @@ ProcWrongNumArgs( if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1); } else { - desiredObjs[0] = Tcl_NewListObj(1, framePtr->objv + skip - 1); + desiredObjs[0] = framePtr->objv[skip-1]; } Tcl_IncrRefCount(desiredObjs[0]); @@ -1310,7 +1310,7 @@ InitLocalCache( *namePtr = NULL; } else { *namePtr = TclCreateLiteral(iPtr, localPtr->name, - localPtr->nameLength, /* hash */ (unsigned int) -1, + localPtr->nameLength, /* hash */ -1, &new, /* nsPtr */ NULL, 0, NULL); Tcl_IncrRefCount(*namePtr); } -- cgit v0.12 From eb5da6ae825ef4d30e2d0c2caff0055ca60bb05c Mon Sep 17 00:00:00 2001 From: stu Date: Wed, 17 Jan 2018 19:01:03 +0000 Subject: OpenBSD now has AI_ADDRCONFIG. --- generic/tclIOSock.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 6abfa60..24c26f6 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -223,7 +223,7 @@ TclCreateSocketAddress( * using AI_ADDRCONFIG is probably low even in situations where it works, * we'll leave it out for now. After all, it is just an optimisation. * - * Missing on: OpenBSD, NetBSD. + * Missing on NetBSD. * Causes failure when used on AIX 5.1 and HP-UX */ -- cgit v0.12 From 93fa41f6c79f481b1325108db444ed1de7d3cfd4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 19 Jan 2018 15:17:45 +0000 Subject: Now really remove Tcl_EvalTokens/Tcl_Backslash as promised in the TIP. And remove library/tzdata/SystemV/* which contains non-standard timezones. See: [d3c5f2eb2ff63f10] They were originally gone since the tzdata2014f update, but it's unwise to do that in a patch release. Some documentation updates. --- doc/DString.3 | 2 +- doc/Eval.3 | 10 ++------- generic/tclBasic.c | 48 ------------------------------------------ generic/tclDictObj.c | 2 +- generic/tclExecute.c | 2 +- generic/tclInt.h | 3 --- generic/tclOO.h | 4 ++-- generic/tclUtil.c | 34 ------------------------------ library/tzdata/SystemV/AST4 | 5 ----- library/tzdata/SystemV/AST4ADT | 5 ----- library/tzdata/SystemV/CST6 | 5 ----- library/tzdata/SystemV/CST6CDT | 5 ----- library/tzdata/SystemV/EST5 | 5 ----- library/tzdata/SystemV/EST5EDT | 5 ----- library/tzdata/SystemV/HST10 | 5 ----- library/tzdata/SystemV/MST7 | 5 ----- library/tzdata/SystemV/MST7MDT | 5 ----- library/tzdata/SystemV/PST8 | 5 ----- library/tzdata/SystemV/PST8PDT | 5 ----- library/tzdata/SystemV/YST9 | 5 ----- library/tzdata/SystemV/YST9YDT | 5 ----- tools/checkLibraryDoc.tcl | 2 -- 22 files changed, 7 insertions(+), 165 deletions(-) delete mode 100644 library/tzdata/SystemV/AST4 delete mode 100644 library/tzdata/SystemV/AST4ADT delete mode 100644 library/tzdata/SystemV/CST6 delete mode 100644 library/tzdata/SystemV/CST6CDT delete mode 100644 library/tzdata/SystemV/EST5 delete mode 100644 library/tzdata/SystemV/EST5EDT delete mode 100644 library/tzdata/SystemV/HST10 delete mode 100644 library/tzdata/SystemV/MST7 delete mode 100644 library/tzdata/SystemV/MST7MDT delete mode 100644 library/tzdata/SystemV/PST8 delete mode 100644 library/tzdata/SystemV/PST8PDT delete mode 100644 library/tzdata/SystemV/YST9 delete mode 100644 library/tzdata/SystemV/YST9YDT diff --git a/doc/DString.3 b/doc/DString.3 index 2828278..b93f119 100644 --- a/doc/DString.3 +++ b/doc/DString.3 @@ -9,7 +9,7 @@ .so man.macros .BS .SH NAME -Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringTrunc, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult \- manipulate dynamic strings +Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult \- manipulate dynamic strings .SH SYNOPSIS .nf \fB#include \fR diff --git a/doc/Eval.3 b/doc/Eval.3 index 6596e44..7fd7bfa 100644 --- a/doc/Eval.3 +++ b/doc/Eval.3 @@ -122,16 +122,10 @@ might be a UTF-8 special code. The string is parsed and executed directly bytecodes. In situations where it is known that the script will never be executed again, \fBTcl_Eval\fR may be faster than \fBTcl_EvalObjEx\fR. \fBTcl_Eval\fR returns a completion code and result just like -\fBTcl_EvalObjEx\fR. Note: for backward compatibility with versions before -Tcl 8.0, \fBTcl_Eval\fR copies the value result in \fIinterp\fR to -\fIinterp->result\fR (use is deprecated) where it can be accessed directly. - This makes \fBTcl_Eval\fR somewhat slower than \fBTcl_EvalEx\fR, which -does not do the copy. +\fBTcl_EvalObjEx\fR. .PP \fBTcl_EvalEx\fR is an extended version of \fBTcl_Eval\fR that takes -additional arguments \fInumBytes\fR and \fIflags\fR. For the -efficiency reason given above, \fBTcl_EvalEx\fR is generally preferred -over \fBTcl_Eval\fR. +additional arguments \fInumBytes\fR and \fIflags\fR. .PP \fBTcl_GlobalEval\fR and \fBTcl_GlobalEvalObj\fR are older procedures that are now deprecated. They are similar to \fBTcl_EvalEx\fR and diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 463e455..7fdcb24 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4514,54 +4514,6 @@ Tcl_EvalTokensStandard( /* *---------------------------------------------------------------------- * - * Tcl_EvalTokens -- - * - * Given an array of tokens parsed from a Tcl command (e.g., the tokens - * that make up a word or the index for an array variable) this function - * evaluates the tokens and concatenates their values to form a single - * result value. - * - * Results: - * The return value is a pointer to a newly allocated Tcl_Obj containing - * the value of the array of tokens. The reference count of the returned - * object has been incremented. If an error occurs in evaluating the - * tokens then a NULL value is returned and an error message is left in - * interp's result. - * - * Side effects: - * A new object is allocated to hold the result. - * - *---------------------------------------------------------------------- - * - * This uses a non-standard return convention; its use is now deprecated. It - * is a wrapper for the new function Tcl_EvalTokensStandard, and is not used - * in the core any longer. It is only kept for backward compatibility. - */ - -Tcl_Obj * -Tcl_EvalTokens( - Tcl_Interp *interp, /* Interpreter in which to lookup variables, - * execute nested commands, and report - * errors. */ - Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to - * evaluate and concatenate. */ - int count) /* Number of tokens to consider at tokenPtr. - * Must be at least 1. */ -{ - Tcl_Obj *resPtr; - - if (Tcl_EvalTokensStandard(interp, tokenPtr, count) != TCL_OK) { - return NULL; - } - resPtr = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(resPtr); - Tcl_ResetResult(interp); - return resPtr; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_EvalEx, TclEvalEx -- * * This function evaluates a Tcl script without using the compiler or diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 3b983e3..e9018db 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -235,7 +235,7 @@ AllocChainEntry( cPtr = ckalloc(sizeof(ChainEntry)); cPtr->entry.key.objPtr = objPtr; Tcl_IncrRefCount(objPtr); - cPtr->entry.clientData = NULL; + Tcl_SetHashValue(&cPtr->entry, NULL); cPtr->prevPtr = cPtr->nextPtr = NULL; return &cPtr->entry; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 42da922..9b9c3fa 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -73,7 +73,7 @@ int tclTraceExec = 0; * expression opcodes (e.g., INST_LOR) in tclCompile.h. * * Does not include the string for INST_EXPON (and beyond), as that is - * disjoint for backward-compatability reasons. + * disjoint for backward-compatibility reasons. */ static const char *const operatorStrings[] = { diff --git a/generic/tclInt.h b/generic/tclInt.h index fe7b93d..7996100 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -178,9 +178,6 @@ typedef struct Tcl_ResolverInfo { * - Bug #696893 - variable is either proc-local or in the current * namespace; never follow the second (global) resolution path * - Bug #631741 - do not use special namespace or interp resolvers - * - * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag - * (Bug #835020) */ #define TCL_AVOID_RESOLVERS 0x40000 diff --git a/generic/tclOO.h b/generic/tclOO.h index d051e79..13a4a10 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -95,7 +95,7 @@ typedef struct { /* * The correct value for the version field of the Tcl_MethodType structure. * This allows new versions of the structure to be introduced without breaking - * binary compatability. + * binary compatibility. */ #define TCL_OO_METHOD_VERSION_CURRENT 1 @@ -122,7 +122,7 @@ typedef struct { /* * The correct value for the version field of the Tcl_ObjectMetadataType * structure. This allows new versions of the structure to be introduced - * without breaking binary compatability. + * without breaking binary compatibility. */ #define TCL_OO_METADATA_VERSION_CURRENT 1 diff --git a/generic/tclUtil.c b/generic/tclUtil.c index efb51ca..7b969af 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1600,40 +1600,6 @@ Tcl_Merge( /* *---------------------------------------------------------------------- * - * Tcl_Backslash -- - * - * Figure out how to handle a backslash sequence. - * - * Results: - * The return value is the character that should be substituted in place - * of the backslash sequence that starts at src. If readPtr isn't NULL - * then it is filled in with a count of the number of characters in the - * backslash sequence. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char -Tcl_Backslash( - const char *src, /* Points to the backslash character of a - * backslash sequence. */ - int *readPtr) /* Fill in with number of characters read from - * src, unless NULL. */ -{ - char buf[TCL_UTF_MAX]; - Tcl_UniChar ch = 0; - - Tcl_UtfBackslash(src, readPtr, buf); - TclUtfToUniChar(buf, &ch); - return (char) ch; -} - -/* - *---------------------------------------------------------------------- - * * TclTrimRight -- * * Takes two counted strings in the Tcl encoding which must both be null diff --git a/library/tzdata/SystemV/AST4 b/library/tzdata/SystemV/AST4 deleted file mode 100644 index eced0d2..0000000 --- a/library/tzdata/SystemV/AST4 +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Puerto_Rico)]} { - LoadTimeZoneFile America/Puerto_Rico -} -set TZData(:SystemV/AST4) $TZData(:America/Puerto_Rico) diff --git a/library/tzdata/SystemV/AST4ADT b/library/tzdata/SystemV/AST4ADT deleted file mode 100644 index c24308f..0000000 --- a/library/tzdata/SystemV/AST4ADT +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Halifax)]} { - LoadTimeZoneFile America/Halifax -} -set TZData(:SystemV/AST4ADT) $TZData(:America/Halifax) diff --git a/library/tzdata/SystemV/CST6 b/library/tzdata/SystemV/CST6 deleted file mode 100644 index d46c015..0000000 --- a/library/tzdata/SystemV/CST6 +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Regina)]} { - LoadTimeZoneFile America/Regina -} -set TZData(:SystemV/CST6) $TZData(:America/Regina) diff --git a/library/tzdata/SystemV/CST6CDT b/library/tzdata/SystemV/CST6CDT deleted file mode 100644 index 234af89..0000000 --- a/library/tzdata/SystemV/CST6CDT +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Chicago)]} { - LoadTimeZoneFile America/Chicago -} -set TZData(:SystemV/CST6CDT) $TZData(:America/Chicago) diff --git a/library/tzdata/SystemV/EST5 b/library/tzdata/SystemV/EST5 deleted file mode 100644 index 52818c1..0000000 --- a/library/tzdata/SystemV/EST5 +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Indianapolis)]} { - LoadTimeZoneFile America/Indianapolis -} -set TZData(:SystemV/EST5) $TZData(:America/Indianapolis) diff --git a/library/tzdata/SystemV/EST5EDT b/library/tzdata/SystemV/EST5EDT deleted file mode 100644 index 6cf2743..0000000 --- a/library/tzdata/SystemV/EST5EDT +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/New_York)]} { - LoadTimeZoneFile America/New_York -} -set TZData(:SystemV/EST5EDT) $TZData(:America/New_York) diff --git a/library/tzdata/SystemV/HST10 b/library/tzdata/SystemV/HST10 deleted file mode 100644 index a4316af..0000000 --- a/library/tzdata/SystemV/HST10 +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(Pacific/Honolulu)]} { - LoadTimeZoneFile Pacific/Honolulu -} -set TZData(:SystemV/HST10) $TZData(:Pacific/Honolulu) diff --git a/library/tzdata/SystemV/MST7 b/library/tzdata/SystemV/MST7 deleted file mode 100644 index e67a781..0000000 --- a/library/tzdata/SystemV/MST7 +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Phoenix)]} { - LoadTimeZoneFile America/Phoenix -} -set TZData(:SystemV/MST7) $TZData(:America/Phoenix) diff --git a/library/tzdata/SystemV/MST7MDT b/library/tzdata/SystemV/MST7MDT deleted file mode 100644 index fda5bf1..0000000 --- a/library/tzdata/SystemV/MST7MDT +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Denver)]} { - LoadTimeZoneFile America/Denver -} -set TZData(:SystemV/MST7MDT) $TZData(:America/Denver) diff --git a/library/tzdata/SystemV/PST8 b/library/tzdata/SystemV/PST8 deleted file mode 100644 index 8e30bb8..0000000 --- a/library/tzdata/SystemV/PST8 +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(Pacific/Pitcairn)]} { - LoadTimeZoneFile Pacific/Pitcairn -} -set TZData(:SystemV/PST8) $TZData(:Pacific/Pitcairn) diff --git a/library/tzdata/SystemV/PST8PDT b/library/tzdata/SystemV/PST8PDT deleted file mode 100644 index 8281a9a..0000000 --- a/library/tzdata/SystemV/PST8PDT +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Los_Angeles)]} { - LoadTimeZoneFile America/Los_Angeles -} -set TZData(:SystemV/PST8PDT) $TZData(:America/Los_Angeles) diff --git a/library/tzdata/SystemV/YST9 b/library/tzdata/SystemV/YST9 deleted file mode 100644 index 32d3717..0000000 --- a/library/tzdata/SystemV/YST9 +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(Pacific/Gambier)]} { - LoadTimeZoneFile Pacific/Gambier -} -set TZData(:SystemV/YST9) $TZData(:Pacific/Gambier) diff --git a/library/tzdata/SystemV/YST9YDT b/library/tzdata/SystemV/YST9YDT deleted file mode 100644 index fba405f..0000000 --- a/library/tzdata/SystemV/YST9YDT +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Anchorage)]} { - LoadTimeZoneFile America/Anchorage -} -set TZData(:SystemV/YST9YDT) $TZData(:America/Anchorage) diff --git a/tools/checkLibraryDoc.tcl b/tools/checkLibraryDoc.tcl index a220ea8..47063c0 100755 --- a/tools/checkLibraryDoc.tcl +++ b/tools/checkLibraryDoc.tcl @@ -50,8 +50,6 @@ set StructList { Tcl_TimerToken \ Tcl_Token \ Tcl_Trace \ - Tcl_Value \ - Tcl_ValueType \ Tcl_Var \ Tk_3DBorder \ Tk_ArgvInfo \ -- cgit v0.12 From a43cab006e1fbad733c53c09c3f2f78d4fc8ad60 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 19 Jan 2018 16:08:02 +0000 Subject: No longer use (the undocumented) CONST86 anywhere, just keep the define in tcl.h. --- generic/tcl.decls | 8 ++++---- generic/tcl.h | 8 ++++---- generic/tclDecls.h | 16 ++++++++-------- generic/tclInt.decls | 4 ++-- generic/tclIntDecls.h | 8 ++++---- 5 files changed, 22 insertions(+), 22 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index c1930f6..5a8d00b 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -166,7 +166,7 @@ declare 39 { int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr) } declare 40 { - CONST86 Tcl_ObjType *Tcl_GetObjType(const char *typeName) + const Tcl_ObjType *Tcl_GetObjType(const char *typeName) } declare 41 { char *Tcl_GetStringFromObj(Tcl_Obj *objPtr, int *lengthPtr) @@ -568,7 +568,7 @@ declare 157 { const char *optionName, Tcl_DString *dsPtr) } declare 158 { - CONST86 Tcl_ChannelType *Tcl_GetChannelType(Tcl_Channel chan) + const Tcl_ChannelType *Tcl_GetChannelType(Tcl_Channel chan) } declare 159 { int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName, @@ -1632,7 +1632,7 @@ declare 452 { int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr) } declare 453 { - const char *CONST86 *Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, + const char *const *Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef) } declare 454 { @@ -1710,7 +1710,7 @@ declare 476 { Tcl_Obj *pathPtr) } declare 477 { - CONST86 Tcl_Filesystem *Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr) + const Tcl_Filesystem *Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr) } declare 478 { Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathPtr) diff --git a/generic/tcl.h b/generic/tcl.h index 8eb8f49..b913ee3 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -208,7 +208,7 @@ extern "C" { # endif #endif -#ifndef CONST86 +#if !defined(CONST86) # define CONST86 const #endif @@ -1205,8 +1205,8 @@ typedef struct Tcl_Time { long usec; /* Microseconds. */ } Tcl_Time; -typedef void (Tcl_SetTimerProc) (CONST86 Tcl_Time *timePtr); -typedef int (Tcl_WaitForEventProc) (CONST86 Tcl_Time *timePtr); +typedef void (Tcl_SetTimerProc) (const Tcl_Time *timePtr); +typedef int (Tcl_WaitForEventProc) (const Tcl_Time *timePtr); /* * TIP #233 (Virtualized Time) @@ -1478,7 +1478,7 @@ typedef int (Tcl_FSNormalizePathProc) (Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint); typedef int (Tcl_FSFileAttrsGetProc) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); -typedef const char *CONST86 * (Tcl_FSFileAttrStringsProc) (Tcl_Obj *pathPtr, +typedef const char *const * (Tcl_FSFileAttrStringsProc) (Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); typedef int (Tcl_FSFileAttrsSetProc) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); diff --git a/generic/tclDecls.h b/generic/tclDecls.h index ba335ef..995878c 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -171,7 +171,7 @@ EXTERN int Tcl_GetIntFromObj(Tcl_Interp *interp, EXTERN int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 40 */ -EXTERN CONST86 Tcl_ObjType * Tcl_GetObjType(const char *typeName); +EXTERN const Tcl_ObjType * Tcl_GetObjType(const char *typeName); /* 41 */ EXTERN char * Tcl_GetStringFromObj(Tcl_Obj *objPtr, int *lengthPtr); /* 42 */ @@ -493,7 +493,7 @@ EXTERN int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 158 */ -EXTERN CONST86 Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan); +EXTERN const Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan); /* 159 */ EXTERN int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); @@ -1285,7 +1285,7 @@ EXTERN int Tcl_FSFileAttrsGet(Tcl_Interp *interp, int index, EXTERN int Tcl_FSFileAttrsSet(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); /* 453 */ -EXTERN const char *CONST86 * Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, +EXTERN const char *const * Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 454 */ EXTERN int Tcl_FSStat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); @@ -1346,7 +1346,7 @@ EXTERN ClientData Tcl_FSData(const Tcl_Filesystem *fsPtr); EXTERN const char * Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 477 */ -EXTERN CONST86 Tcl_Filesystem * Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr); +EXTERN const Tcl_Filesystem * Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr); /* 478 */ EXTERN Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathPtr); /* 479 */ @@ -1858,7 +1858,7 @@ typedef struct TclStubs { int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */ int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */ int (*tcl_GetLongFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 39 */ - CONST86 Tcl_ObjType * (*tcl_GetObjType) (const char *typeName); /* 40 */ + const Tcl_ObjType * (*tcl_GetObjType) (const char *typeName); /* 40 */ char * (*tcl_GetStringFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 41 */ void (*tcl_InvalidateStringRep) (Tcl_Obj *objPtr); /* 42 */ int (*tcl_ListObjAppendList) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr); /* 43 */ @@ -1976,7 +1976,7 @@ typedef struct TclStubs { int (*tcl_GetChannelMode) (Tcl_Channel chan); /* 155 */ const char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */ int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 157 */ - CONST86 Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */ + const Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */ int (*tcl_GetCommandInfo) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 159 */ const char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ int (*tcl_GetErrno) (void); /* 161 */ @@ -2279,7 +2279,7 @@ typedef struct TclStubs { int (*tcl_FSUtime) (Tcl_Obj *pathPtr, struct utimbuf *tval); /* 450 */ int (*tcl_FSFileAttrsGet) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 451 */ int (*tcl_FSFileAttrsSet) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); /* 452 */ - const char *CONST86 * (*tcl_FSFileAttrStrings) (Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 453 */ + const char *const * (*tcl_FSFileAttrStrings) (Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 453 */ int (*tcl_FSStat) (Tcl_Obj *pathPtr, Tcl_StatBuf *buf); /* 454 */ int (*tcl_FSAccess) (Tcl_Obj *pathPtr, int mode); /* 455 */ Tcl_Channel (*tcl_FSOpenFileChannel) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *modeString, int permissions); /* 456 */ @@ -2303,7 +2303,7 @@ typedef struct TclStubs { int (*tcl_FSUnregister) (const Tcl_Filesystem *fsPtr); /* 474 */ ClientData (*tcl_FSData) (const Tcl_Filesystem *fsPtr); /* 475 */ const char * (*tcl_FSGetTranslatedStringPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 476 */ - CONST86 Tcl_Filesystem * (*tcl_FSGetFileSystemForPath) (Tcl_Obj *pathPtr); /* 477 */ + const Tcl_Filesystem * (*tcl_FSGetFileSystemForPath) (Tcl_Obj *pathPtr); /* 477 */ Tcl_PathType (*tcl_FSGetPathType) (Tcl_Obj *pathPtr); /* 478 */ int (*tcl_OutputBuffered) (Tcl_Channel chan); /* 479 */ void (*tcl_FSMountsChanged) (const Tcl_Filesystem *fsPtr); /* 480 */ diff --git a/generic/tclInt.decls b/generic/tclInt.decls index c7a2efc..35116da 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -184,7 +184,7 @@ declare 41 { Tcl_Command TclGetOriginalCommand(Tcl_Command command) } declare 42 { - CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) + const char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } # Removed in 8.5a2: #declare 43 { @@ -412,7 +412,7 @@ declare 98 { # Tcl_Obj *objPtr, int flags) #} declare 101 { - CONST86 char *TclSetPreInitScript(const char *string) + const char *TclSetPreInitScript(const char *string) } declare 102 { void TclSetupEnv(Tcl_Interp *interp) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index ec6a889..85353f9 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -132,7 +132,7 @@ EXTERN int TclGetOpenMode(Tcl_Interp *interp, const char *str, /* 41 */ EXTERN Tcl_Command TclGetOriginalCommand(Tcl_Command command); /* 42 */ -EXTERN CONST86 char * TclpGetUserHome(const char *name, +EXTERN const char * TclpGetUserHome(const char *name, Tcl_DString *bufferPtr); /* Slot 43 is reserved */ /* 44 */ @@ -237,7 +237,7 @@ EXTERN int TclServiceIdle(void); /* Slot 99 is reserved */ /* Slot 100 is reserved */ /* 101 */ -EXTERN CONST86 char * TclSetPreInitScript(const char *string); +EXTERN const char * TclSetPreInitScript(const char *string); /* 102 */ EXTERN void TclSetupEnv(Tcl_Interp *interp); /* 103 */ @@ -626,7 +626,7 @@ typedef struct TclIntStubs { TclObjCmdProcType (*tclGetObjInterpProc) (void); /* 39 */ int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */ Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */ - CONST86 char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */ + const char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */ void (*reserved43)(void); int (*tclGuessPackageName) (const char *fileName, Tcl_DString *bufPtr); /* 44 */ int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */ @@ -685,7 +685,7 @@ typedef struct TclIntStubs { int (*tclServiceIdle) (void); /* 98 */ void (*reserved99)(void); void (*reserved100)(void); - CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */ + const char * (*tclSetPreInitScript) (const char *string); /* 101 */ void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */ int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */ void (*reserved104)(void); -- cgit v0.12 From 1c35ed873acea5b757b3236e5b04e551eba800aa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 20 Jan 2018 16:02:31 +0000 Subject: Follow-up to previous commit (TIP #485 implementation). Actually remove Tcl_Backslash and Tcl_EvalTokens when compiling with -DTCL_NO_DEPRECATED. --- generic/tclBasic.c | 2 ++ generic/tclUtil.c | 2 ++ 2 files changed, 4 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 52f26a9..c23491c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4937,6 +4937,7 @@ Tcl_EvalTokensStandard( NULL, NULL); } +#if !defined(TCL_NO_DEPRECATED) && TCL_MINOR_VERSION < 9 /* *---------------------------------------------------------------------- * @@ -4984,6 +4985,7 @@ Tcl_EvalTokens( Tcl_ResetResult(interp); return resPtr; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 15018de..dcd0415 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1604,6 +1604,7 @@ Tcl_Merge( return result; } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* *---------------------------------------------------------------------- * @@ -1637,6 +1638,7 @@ Tcl_Backslash( TclUtfToUniChar(buf, &ch); return (char) ch; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- -- cgit v0.12 From 92c0d0a0116d9bf6af0b41c0206824f23953f9c2 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 22 Jan 2018 13:38:47 +0000 Subject: typo --- generic/tclBasic.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index c23491c..fa54551 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4937,7 +4937,7 @@ Tcl_EvalTokensStandard( NULL, NULL); } -#if !defined(TCL_NO_DEPRECATED) && TCL_MINOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* *---------------------------------------------------------------------- * -- cgit v0.12 From 0abda82b1ef6d5a059df46d1706ae64157523fe7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 23 Jan 2018 14:52:34 +0000 Subject: In Tcl 9.0, don't register oldBooleanType any more. And rename "booleanString" to "boolean" in tclBooleanType. Many extensions (e.g. [http://cyqlite.sourceforge.net/cgi-bin/sqlite/info/451bb2c1f8554eee|sqlite]) still test for "boolean", although that stopped working already for a long time. In Tcl 8.7, do the same when compiled with -DTCL_NO_DEPRECATED. --- generic/tclObj.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/generic/tclObj.c b/generic/tclObj.c index 4ec0a57..b922c39 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -242,6 +242,7 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); * implementations. */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 static const Tcl_ObjType oldBooleanType = { "boolean", /* name */ NULL, /* freeIntRepProc */ @@ -249,8 +250,13 @@ static const Tcl_ObjType oldBooleanType = { NULL, /* updateStringProc */ TclSetBooleanFromAny /* setFromAnyProc */ }; +#endif const Tcl_ObjType tclBooleanType = { +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 "booleanString", /* name */ +#else + "boolean", /* name */ +#endif NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ @@ -406,7 +412,9 @@ TclInitObjSubsystem(void) Tcl_RegisterObjType(&tclProcBodyType); /* For backward compatibility only ... */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 Tcl_RegisterObjType(&oldBooleanType); +#endif #ifndef TCL_WIDE_INT_IS_LONG Tcl_RegisterObjType(&tclWideIntType); #endif -- cgit v0.12 From e403ff8f45f2d5327b449d9131d2a06896fe34f3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 24 Jan 2018 09:59:15 +0000 Subject: Documentation fix: there is no "O" conversion, just "o" for octal. Also, "b" conversions normally don't produce a sign. --- doc/format.n | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/format.n b/doc/format.n index ba044f2..1c511e8 100644 --- a/doc/format.n +++ b/doc/format.n @@ -83,7 +83,7 @@ Specifies that the number should be padded on the left with zeroes instead of spaces. .TP 10 \fB#\fR -Requests an alternate output form. For \fBo\fR and \fBO\fR +Requests an alternate output form. For \fBo\fR conversions it guarantees that the first digit is always \fB0\fR. For \fBx\fR or \fBX\fR conversions, \fB0x\fR or \fB0X\fR (respectively) will be added to the beginning of the result unless it is zero. @@ -169,7 +169,7 @@ for \fBx\fR and for \fBX\fR). .TP 10 \fBb\fR -Convert integer to binary string, using digits 0 and 1. +Convert integer to unsigned binary string, using digits 0 and 1. .TP 10 \fBc\fR Convert integer to the Unicode character it represents. -- cgit v0.12 From f08ea445641489126720965930b2f1e96d44696c Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 25 Jan 2018 20:28:15 +0000 Subject: Dup test names --- tests/info.test | 2 +- tests/link.test | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/info.test b/tests/info.test index d30bf9a..fbc65ba 100644 --- a/tests/info.test +++ b/tests/info.test @@ -1818,7 +1818,7 @@ test info-38.2 {location information for uplevel, dl, direct-literal} -match glo * {type source line 1814 file info.test cmd etrace level 1} * {type source line 1812 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub} -test info-39.0 {Bug 4b61afd660} -setup { +test info-39.2 {Bug 4b61afd660} -setup { proc probe {} { return [dict get [info frame -1] line] } diff --git a/tests/link.test b/tests/link.test index 7bde482..22a1fc2 100644 --- a/tests/link.test +++ b/tests/link.test @@ -141,7 +141,7 @@ test link-2.8 {writing C variables from Tcl} -constraints {testlink} -setup { set uwide "0O" concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide } -result {0 0.0 0 0 0 0 0 0 0 0 0 0 0.0 0 | 0x 0b 0 0 0O 0X 0B 0O 0x 0b 0o 0X 0B 0O} -test link-2.8 {writing C variables from Tcl} -constraints {testlink} -setup { +test link-2.9 {writing C variables from Tcl} -constraints {testlink} -setup { testlink delete } -body { testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234 -- cgit v0.12 From 189d0a83d2df3b9f47e30232bdf377d4daeaba2b Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 25 Jan 2018 21:15:36 +0000 Subject: lifetime management of files generated by tests --- tests/chanio.test | 5 +++++ tests/exec.test | 1 - tests/io.test | 5 +++++ tests/ioCmd.test | 5 +---- 4 files changed, 11 insertions(+), 5 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 2f2540e..541c20d 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -5732,6 +5732,8 @@ test chan-io-47.6 {file events on shared files, deleting file events} {testfeven chan close $f set x } {{script 1} {}} +unset path(foo) +removeFile foo set path(bar) [makeFile {} bar] @@ -5834,6 +5836,9 @@ test chan-io-48.3 {testing readability conditions} {stdio unix nonBlockFiles ope chan close $f list $x $l } {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} +unset path(bar) +removeFile bar + test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] diff --git a/tests/exec.test b/tests/exec.test index 810dfa6..7bb8579 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -287,7 +287,6 @@ test exec-6.3 {redirecting stderr through a pipeline} {exec stdio} { # I/O redirection: combinations. set path(gorp.file2) [makeFile {} gorp.file2] -file delete $path(gorp.file2) test exec-7.1 {multiple I/O redirections} {exec} { exec << "command input" > $path(gorp.file2) [interpreter] $path(cat) < $path(gorp.file) diff --git a/tests/io.test b/tests/io.test index 7275b42..5529881 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6130,6 +6130,8 @@ test io-47.6 {file events on shared files, deleting file events} {testfevent fil close $f set x } {{script 1} {}} +unset path(foo) +removeFile foo set path(bar) [makeFile {} bar] @@ -6232,6 +6234,9 @@ test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe close $f list $x $l } {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} +unset path(bar) +removeFile bar + test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 5a76d48..1cb7c74 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -366,7 +366,6 @@ test iocmd-10.5 {fblocked command} { set path(test4) [makeFile {} test4] set path(test5) [makeFile {} test5] -file delete $path(test5) test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} { set f [open $path(test4) w] close $f @@ -3643,8 +3642,6 @@ foreach file [list test1 test2 test3 test4] { } # delay long enough for background processes to finish after 500 -foreach file [list test5] { - removeFile $file -} +removeFile test5 cleanupTests return -- cgit v0.12