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 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 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