diff options
Diffstat (limited to 'generic')
37 files changed, 478 insertions, 455 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index 7e5bbbb..8355d99 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -774,10 +774,10 @@ declare 216 { declare 217 { void Tcl_ResetResult(Tcl_Interp *interp) } -declare 218 generic { +declare 218 { int Tcl_ScanElement(const char *src, int *flagPtr) } -declare 219 generic { +declare 219 { int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr) } # Obsolete @@ -2311,7 +2311,7 @@ declare 627 { Tcl_LoadHandle *handlePtr) } declare 628 { - void* Tcl_FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle handle, + void *Tcl_FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol) } declare 629 { diff --git a/generic/tcl.h b/generic/tcl.h index 875a171..729e521 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -163,6 +163,23 @@ extern "C" { #endif /* + * Allow a part of Tcl's API to be explicitly marked as deprecated. + * + * Used to make TIP 330/336 generate moans even if people use the + * compatibility macros. Change your code, guys! We won't support you forever. + */ + +#if defined(__GNUC__) && ((__GNUC__ >= 4) || ((__GNUC__ == 3) && (__GNUC_MINOR__ >= 1))) +# if (__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC__MINOR__ >= 5)) +# define TCL_DEPRECATED_API(msg) __attribute__ ((__deprecated__ (msg))) +# else +# define TCL_DEPRECATED_API(msg) __attribute__ ((__deprecated__)) +# endif +#else +# define TCL_DEPRECATED_API(msg) /* nothing portable */ +#endif + +/* *---------------------------------------------------------------------------- * Macros used to declare a function to be exported by a DLL. Used by Windows, * maps to no-op declarations on non-Windows systems. The default build on @@ -487,9 +504,11 @@ typedef struct Tcl_Interp { /* TIP #330: Strongly discourage extensions from using the string * result. */ #ifdef USE_INTERP_RESULT - char *result; /* If the last command returned a string + char *result TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult"); + /* If the last command returned a string * result, this points to it. */ - void (*freeProc) (char *blockPtr); + void (*freeProc) (char *blockPtr) + TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult"); /* Zero means the string result is statically * allocated. TCL_DYNAMIC means it was * allocated with ckalloc and should be freed @@ -498,15 +517,16 @@ typedef struct Tcl_Interp { * Tcl_Eval must free it before executing next * command. */ #else - char *unused3; - void (*unused4) (char *); + char *unused3 TCL_DEPRECATED_API("bad field access"); + void (*unused4) (char *) TCL_DEPRECATED_API("bad field access"); #endif #ifdef USE_INTERP_ERRORLINE - int errorLine; /* When TCL_ERROR is returned, this gives the + int errorLine TCL_DEPRECATED_API("use Tcl_GetErrorLine/Tcl_SetErrorLine"); + /* When TCL_ERROR is returned, this gives the * line number within the command where the * error occurred (1 if first line). */ #else - int unused5; + int unused5 TCL_DEPRECATED_API("bad field access"); #endif } Tcl_Interp; diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 6fff92b..ae61e85 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -26,12 +26,6 @@ #if USE_TCLALLOC -#ifdef TCL_DEBUG -# define DEBUG -/* #define MSTATS */ -# define RCHECK -#endif - /* * We should really make use of AC_CHECK_TYPE(caddr_t) here, but it can wait * until Tcl uses config.h properly. @@ -60,7 +54,7 @@ union overhead { unsigned char index; /* bucket # */ unsigned char unused; /* unused */ unsigned char magic1; /* other magic number */ -#ifdef RCHECK +#ifndef NDEBUG unsigned short rmagic; /* range magic number */ unsigned long size; /* actual block size */ unsigned short unused2; /* padding to 8-byte align */ @@ -77,7 +71,7 @@ union overhead { #define MAGIC 0xef /* magic # on accounting info */ #define RMAGIC 0x5555 /* magic # on range info */ -#ifdef RCHECK +#ifndef NDEBUG #define RSLOP sizeof(unsigned short) #else #define RSLOP 0 @@ -142,7 +136,7 @@ static int allocInit = 0; static unsigned int numMallocs[NBUCKETS+1]; #endif -#if defined(DEBUG) || defined(RCHECK) +#if !defined(NDEBUG) #define ASSERT(p) if (!(p)) Tcl_Panic(# p) #define RANGE_ASSERT(p) if (!(p)) Tcl_Panic(# p) #else @@ -299,7 +293,7 @@ TclpAlloc( numMallocs[NBUCKETS]++; #endif -#ifdef RCHECK +#ifndef NDEBUG /* * Record allocated size of block and bound space with magic numbers. */ @@ -357,7 +351,7 @@ TclpAlloc( numMallocs[bucket]++; #endif -#ifdef RCHECK +#ifndef NDEBUG /* * Record allocated size of block and bound space with magic numbers. */ @@ -577,7 +571,7 @@ TclpRealloc( numMallocs[NBUCKETS]++; #endif -#ifdef RCHECK +#ifndef NDEBUG /* * Record allocated size of block and update magic number bounds. */ @@ -619,7 +613,7 @@ TclpRealloc( * Ok, we don't have to copy, it fits as-is */ -#ifdef RCHECK +#ifndef NDEBUG overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); BLOCK_END(overPtr) = RMAGIC; #endif diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 5b32ab0..02144a1 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -492,7 +492,7 @@ TalInstDesc TalInstructionTable[] = { * The instructions must be in ascending order by numeric operation code. */ -static unsigned char NonThrowingByteCodes[] = { +static const unsigned char NonThrowingByteCodes[] = { INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, /* 1-4 */ INST_JUMP1, INST_JUMP4, /* 34-35 */ INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 70-72 */ diff --git a/generic/tclBasic.c b/generic/tclBasic.c index c07fa70..e09ea1e 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -258,6 +258,7 @@ static const CmdInfo builtInCmds[] = { {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1}, {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, 1}, {"yield", NULL, NULL, TclNRYieldObjCmd, 1}, + {"yieldto", NULL, NULL, TclNRYieldToObjCmd, 1}, /* * Commands in the OS-interface. Note that many of these are unsafe. @@ -830,13 +831,9 @@ Tcl_CreateInterp(void) TclNRAssembleObjCmd, NULL, NULL); cmdPtr->compileProc = &TclCompileAssembleCmd; - Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldTo", NULL, - TclNRYieldToObjCmd, NULL, NULL); - Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldm", NULL, - TclNRYieldObjCmd, INT2PTR(CORO_ACTIVATE_YIELDM), NULL); Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL, NRCoroInjectObjCmd, NULL, NULL); - + #ifdef USE_DTRACE /* * Register the tcl::dtrace command. @@ -3127,8 +3124,8 @@ Tcl_DeleteCommandFromToken( * from a CmdName Tcl object in some ByteCode code sequence. In that case, * delay the cleanup until all references are either discarded (when a * ByteCode is freed) or replaced by a new reference (when a cached - * CmdName Command reference is found to be invalid and TclNRExecuteByteCode - * looks up the command in the command hashtable). + * CmdName Command reference is found to be invalid and + * TclNRExecuteByteCode looks up the command in the command hashtable). */ TclCleanupCommandMacro(cmdPtr); @@ -4317,7 +4314,7 @@ TclNREvalObjv( return TCL_OK; } else { return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } + } } void @@ -8347,7 +8344,7 @@ TclNRTailcallObjCmd( Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; Tcl_Namespace *ns1Ptr; NRE_callback *tailcallPtr; - + listPtr = Tcl_NewListObj(objc-1, objv+1); Tcl_IncrRefCount(listPtr); @@ -8358,7 +8355,8 @@ TclNRTailcallObjCmd( } Tcl_IncrRefCount(nsObjPtr); - TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL); + TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, + NULL, NULL); tailcallPtr = TOP_CB(interp); TOP_CB(interp) = tailcallPtr->nextPtr; iPtr->varFramePtr->tailcallPtr = tailcallPtr; @@ -8388,7 +8386,7 @@ NRTailcallEval( * Tailcall execution was preempted, eg by an intervening catch or by * a now-gone namespace: cleanup and return. */ - + TailcallCleanup(data, interp, result); return result; } @@ -8471,6 +8469,7 @@ TclNRYieldObjCmd( Tcl_Obj *const objv[]) { CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?"); return TCL_ERROR; @@ -8511,7 +8510,7 @@ TclNRYieldToObjCmd( } if (!corPtr) { - Tcl_SetResult(interp, "yieldTo can only be called in a coroutine", + Tcl_SetResult(interp, "yieldto can only be called in a coroutine", TCL_STATIC); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); return TCL_ERROR; @@ -8529,7 +8528,7 @@ TclNRYieldToObjCmd( nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) || (nsPtr != ns1Ptr)) { - Tcl_Panic("yieldTo failed to find the proper namespace"); + Tcl_Panic("yieldto failed to find the proper namespace"); } Tcl_IncrRefCount(nsObjPtr); @@ -8542,7 +8541,7 @@ TclNRYieldToObjCmd( NULL); iPtr->execEnvPtr = corPtr->eePtr; - return TclNRYieldObjCmd(clientData, interp, 1, objv); + return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv); } static int @@ -8640,7 +8639,7 @@ NRCoroutineCallerCallback( NRE_ASSERT(COR_IS_SUSPENDED(corPtr)); SAVE_CONTEXT(corPtr->running); RESTORE_CONTEXT(corPtr->caller); - + if (cmdPtr->flags & CMD_IS_DELETED) { /* * The command was deleted while it was running: wind down the @@ -8702,16 +8701,21 @@ NRCoroutineExitCallback( return result; } - /* + *---------------------------------------------------------------------- + * * NRCoroutineActivateCallback -- * - * This is the workhorse for coroutines: it implements both yield and resume. + * This is the workhorse for coroutines: it implements both yield and + * resume. * - * It is important that both be implemented in the same callback: the - * detection of the impossibility to suspend due to a busy C-stack relies on - * the precise position of a local variable in the stack. We do not want the - * compiler to play tricks on us, either by moving things around or inlining. + * It is important that both be implemented in the same callback: the + * detection of the impossibility to suspend due to a busy C-stack relies + * on the precise position of a local variable in the stack. We do not + * want the compiler to play tricks on us, either by moving things around + * or inlining. + * + *---------------------------------------------------------------------- */ static int @@ -8728,18 +8732,18 @@ NRCoroutineActivateCallback( if (!corPtr->stackLevel) { /* * -- Coroutine is suspended -- - * Push the callback to restore the caller's context on yield or return + * Push the callback to restore the caller's context on yield or + * return. */ - TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, NULL, NULL, - NULL); + TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, + NULL, NULL, NULL); /* * Record the stackLevel at which the resume is happening, then swap - * the interp's environment to make it suitable to run this - * coroutine. + * the interp's environment to make it suitable to run this coroutine. */ - + corPtr->stackLevel = stackLevel; numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = iPtr->numLevels; @@ -8749,8 +8753,6 @@ NRCoroutineActivateCallback( RESTORE_CONTEXT(corPtr->running); iPtr->execEnvPtr = corPtr->eePtr; iPtr->numLevels += numLevels; - - return TCL_OK; } else { /* * Coroutine is active: yield @@ -8763,15 +8765,15 @@ NRCoroutineActivateCallback( NULL); return TCL_ERROR; } - - if (type == CORO_ACTIVATE_YIELD) { + + if (type == CORO_ACTIVATE_YIELD) { corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL; } else if (type == CORO_ACTIVATE_YIELDM) { corPtr->nargs = COROUTINE_ARGUMENTS_ARBITRARY; } else { Tcl_Panic("Yield received an option which is not implemented"); } - + corPtr->stackLevel = NULL; numLevels = iPtr->numLevels; @@ -8779,10 +8781,20 @@ NRCoroutineActivateCallback( corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; iPtr->execEnvPtr = corPtr->callerEEPtr; - return TCL_OK; } + + return TCL_OK; } +/* + *---------------------------------------------------------------------- + * + * NRCoroInjectObjCmd -- + * + * Implementation of [::tcl::unsupported::inject] command. + * + *---------------------------------------------------------------------- + */ static int NRCoroInjectObjCmd( @@ -8794,7 +8806,7 @@ NRCoroInjectObjCmd( Command *cmdPtr; CoroutineData *corPtr; ExecEnv *savedEEPtr = iPtr->execEnvPtr; - + /* * Usage more or less like tailcall: * inject coroName cmd ?arg1 arg2 ...? @@ -8807,25 +8819,30 @@ NRCoroInjectObjCmd( cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); if ((!cmdPtr) || (cmdPtr->nreProc != NRInterpCoroutine)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("can only inject a command into a coroutine", -1)); + Tcl_AppendResult(interp, "can only inject a command into a coroutine", + NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", + TclGetString(objv[1]), NULL); return TCL_ERROR; } - corPtr = (CoroutineData *) cmdPtr->objClientData; + corPtr = cmdPtr->objClientData; if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("can only inject a command into a suspended coroutine", -1)); + Tcl_AppendResult(interp, + "can only inject a command into a suspended coroutine", NULL); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); return TCL_ERROR; } /* * Add the callback to the coro's execEnv, so that it is the first thing - * to happen when the coro is resumed + * to happen when the coro is resumed. */ - + iPtr->execEnvPtr = corPtr->eePtr; - Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0); + TclNREvalObjEx(interp, Tcl_NewListObj(objc-2, objv+2), 0, NULL, INT_MIN); iPtr->execEnvPtr = savedEEPtr; - + return TCL_OK; } @@ -8882,6 +8899,17 @@ NRInterpCoroutine( return TCL_OK; } +/* + *---------------------------------------------------------------------- + * + * TclNRCoroutineObjCmd -- + * + * Implementation of [coroutine] command; see documentation for + * description of what this does. + * + *---------------------------------------------------------------------- + */ + int TclNRCoroutineObjCmd( ClientData dummy, /* Not used. */ @@ -8895,7 +8923,7 @@ TclNRCoroutineObjCmd( Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_DString ds; Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr; - + if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?"); return TCL_ERROR; @@ -8991,16 +9019,16 @@ TclNRCoroutineObjCmd( corPtr->stackLevel = NULL; corPtr->auxNumLevels = 0; iPtr->numLevels--; - + /* * Create the coro's execEnv, switch to it to push the exit and coro - * command callbacks, then switch back. + * command callbacks, then switch back. */ corPtr->eePtr = TclCreateExecEnv(interp, CORO_STACK_INITIAL_SIZE); corPtr->callerEEPtr = iPtr->execEnvPtr; corPtr->eePtr->corPtr = corPtr; - + SAVE_CONTEXT(corPtr->caller); corPtr->callerEEPtr = iPtr->execEnvPtr; RESTORE_CONTEXT(corPtr->running); @@ -9015,7 +9043,7 @@ TclNRCoroutineObjCmd( SAVE_CONTEXT(corPtr->running); RESTORE_CONTEXT(corPtr->caller); iPtr->execEnvPtr = corPtr->callerEEPtr; - + /* * Now just resume the coroutine. Take care to insure that the command is * looked up in the correct namespace. diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index ff300b0..c5bb72d 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -18,7 +18,6 @@ #include "tclInt.h" #include "tclRegexp.h" -#include "tommath.h" static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode, Tcl_Obj *oldOptions, Tcl_Obj *errorInfo); @@ -1434,7 +1433,6 @@ StringIsCmd( int i, failat = 0, result = 1, strict = 0, index, length1, length2; Tcl_Obj *objPtr, *failVarObj = NULL; Tcl_WideInt w; - mp_int big; static const char *const isClasses[] = { "alnum", "alpha", "ascii", "control", @@ -1579,10 +1577,50 @@ StringIsCmd( } goto failedIntParse; case STR_IS_ENTIER: - if (TCL_OK == Tcl_GetBignumFromObj(NULL, objPtr, &big)) { + if ((objPtr->typePtr == &tclIntType) || +#ifndef NO_WIDE_TYPE + (objPtr->typePtr == &tclWideIntType) || +#endif + (objPtr->typePtr == &tclBignumType)) { break; } - goto failedIntParse; + string1 = TclGetStringFromObj(objPtr, &length1); + if (length1 == 0) { + if (strict) { + result = 0; + } + goto str_is_done; + } + end = string1 + length1; + if (TclParseNumber(NULL, objPtr, NULL, NULL, -1, + (const char **) &stop, TCL_PARSE_INTEGER_ONLY) == TCL_OK) { + if (stop == end) { + /* + * Entire string parses as an integer. + */ + + break; + } else { + /* + * Some prefix parsed as an integer, but not the whole string, + * so return failure index as the point where parsing stopped. + * Clear out the internal rep, since keeping it would leave + * *objPtr in an inconsistent state. + */ + + result = 0; + failat = stop - string1; + TclFreeIntRep(objPtr); + } + } else { + /* + * No prefix is a valid integer. Fail at beginning. + */ + + result = 0; + failat = 0; + } + break; case STR_IS_WIDE: if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) { break; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index b043fed..4212b6d 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -436,7 +436,7 @@ static const unsigned char instruction[] = { * ParseLexeme(). */ -static unsigned char Lexeme[] = { +static const unsigned char Lexeme[] = { INVALID /* NUL */, INVALID /* SOH */, INVALID /* STX */, INVALID /* ETX */, INVALID /* EOT */, INVALID /* ENQ */, diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 1f7dfe6..75dbd9a 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1802,7 +1802,7 @@ EXTERN int Tcl_LoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 628 */ -EXTERN void* Tcl_FindSymbol(Tcl_Interp *interp, +EXTERN void * Tcl_FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 629 */ EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp, @@ -2470,7 +2470,7 @@ typedef struct TclStubs { int (*tcl_NRExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *resultPtr); /* 625 */ int (*tcl_NRSubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 626 */ int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */ - void* (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ + void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ } TclStubs; diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 1283446..1e1a901 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -1823,11 +1823,6 @@ NsEnsembleImplementationCmdNR( * count both as inserted and removed arguments. */ -#if 0 - if (TclInitRewriteEnsemble(interp, 2 + ensemblePtr->numParameters, prefixObjc + ensemblePtr->numParameters, objv)) { - TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); - } -#else if (iPtr->ensembleRewrite.sourceObjs == NULL) { iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = @@ -1848,14 +1843,13 @@ NsEnsembleImplementationCmdNR( iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-2; } } -#endif /* * Hand off to the target command. */ iPtr->evalFlags |= TCL_EVAL_REDIRECT; - return Tcl_NREvalObj(interp, copyPtr, TCL_EVAL_INVOKE); + return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN); } unknownOrAmbiguousSubcommand: diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 980a785..72d6fba 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -45,11 +45,8 @@ MODULE_SCOPE void TclSetEnv(const char *name, const char *value); MODULE_SCOPE void TclUnsetEnv(const char *name); #if defined(__CYGWIN__) -/* On Cygwin, the environment is imported from the Cygwin DLL. */ - DLLIMPORT extern int cygwin_posix_to_win32_path_list_buf_size(char *value); - DLLIMPORT extern void cygwin_posix_to_win32_path_list(char *buf, char *value); -# define putenv TclCygwinPutenv -static void TclCygwinPutenv(char *string); + static void TclCygwinPutenv(char *string); +# define putenv TclCygwinPutenv #endif /* @@ -754,15 +751,11 @@ TclCygwinPutenv( */ if (strcmp(name, "Path") == 0) { -#ifdef __WIN32__ SetEnvironmentVariableA("PATH", NULL); -#endif unsetenv("PATH"); } -#ifdef __WIN32__ SetEnvironmentVariableA(name, value); -#endif } else { char *buf; @@ -770,9 +763,7 @@ TclCygwinPutenv( * Eliminate any Path variable, to prevent any confusion. */ -#ifdef __WIN32__ SetEnvironmentVariableA("Path", NULL); -#endif unsetenv("Path"); if (value == NULL) { @@ -785,9 +776,7 @@ TclCygwinPutenv( cygwin_posix_to_win32_path_list(value, buf); } -#ifdef __WIN32__ SetEnvironmentVariableA(name, buf); -#endif } } #endif /* __CYGWIN__ */ diff --git a/generic/tclFileName.c b/generic/tclFileName.c index adfa2fd..b6b89dd 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -2160,67 +2160,6 @@ DoGlob( } /* - * This block of code is not exercised by the Tcl test suite as of Tcl - * 8.5a0. Simplifications to the calling paths suggest it may not be - * necessary any more, since path separators are handled elsewhere. It is - * left in place in case new bugs are reported. - */ - -#if 0 /* PROBABLY_OBSOLETE */ - /* - * Deal with path separators. - */ - - if (pathPtr == NULL) { - /* - * Length used to be the length of the prefix, and lastChar the - * lastChar of the prefix. But, none of this is used any more. - */ - - int length = 0; - char lastChar = 0; - - switch (tclPlatform) { - case TCL_PLATFORM_WINDOWS: - /* - * If this is a drive relative path, add the colon and the - * trailing slash if needed. Otherwise add the slash if this is - * the first absolute element, or a later relative element. Add an - * extra slash if this is a UNC path. - */ - - if (*name == ':') { - Tcl_DStringAppend(&append, ":", 1); - if (count > 1) { - Tcl_DStringAppend(&append, "/", 1); - } - } else if ((*pattern != '\0') && (((length > 0) - && (strchr(separators, lastChar) == NULL)) - || ((length == 0) && (count > 0)))) { - Tcl_DStringAppend(&append, "/", 1); - if ((length == 0) && (count > 1)) { - Tcl_DStringAppend(&append, "/", 1); - } - } - - break; - case TCL_PLATFORM_UNIX: - /* - * Add a separator if this is the first absolute element, or a - * later relative element. - */ - - if ((*pattern != '\0') && (((length > 0) - && (strchr(separators, lastChar) == NULL)) - || ((length == 0) && (count > 0)))) { - Tcl_DStringAppend(&append, "/", 1); - } - break; - } - } -#endif /* PROBABLY_OBSOLETE */ - - /* * Look for the first matching pair of braces or the first directory * separator that is not inside a pair of braces. */ @@ -2278,8 +2217,8 @@ DoGlob( if (openBrace != NULL) { char *element; - Tcl_DString newName; + Tcl_DStringInit(&newName); /* @@ -2328,12 +2267,13 @@ DoGlob( */ if (*p != '\0') { + char savedChar = *p; + /* * Note that we are modifying the string in place. This won't work if * the string is a static. */ - char savedChar = *p; *p = '\0'; firstSpecialChar = strpbrk(pattern, "*[]?\\"); *p = savedChar; @@ -2398,6 +2338,7 @@ DoGlob( const char *bytes; int numBytes; Tcl_Obj *fixme, *newObj; + Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme); bytes = Tcl_GetStringFromObj(fixme, &numBytes); newObj = Tcl_NewStringObj(bytes+2, numBytes-2); @@ -2418,6 +2359,9 @@ DoGlob( */ if (*p == '\0') { + int length; + Tcl_DString append; + /* * This is the code path reached by a command like 'glob foo'. * @@ -2430,9 +2374,6 @@ DoGlob( * approach). */ - int length; - Tcl_DString append; - Tcl_DStringInit(&append); Tcl_DStringAppend(&append, pattern, p-pattern); @@ -2453,15 +2394,6 @@ DoGlob( } } -#if defined(__CYGWIN__) && defined(__WIN32__) - { - char winbuf[MAX_PATH+1]; - - cygwin_conv_to_win32_path(Tcl_DStringValue(&append), winbuf); - Tcl_DStringFree(&append); - Tcl_DStringAppend(&append, winbuf, -1); - } -#endif /* __CYGWIN__ && __WIN32__ */ break; case TCL_PLATFORM_UNIX: @@ -2473,8 +2405,9 @@ DoGlob( } } #if defined(__CYGWIN__) && !defined(__WIN32__) - DLLIMPORT extern int cygwin_conv_to_posix_path(const char *, char *); { + DLLIMPORT extern int cygwin_conv_to_posix_path(const char *, + char *); char winbuf[MAXPATHLEN+1]; cygwin_conv_to_posix_path(Tcl_DStringValue(&append), winbuf); diff --git a/generic/tclHash.c b/generic/tclHash.c index c8dc939..90be511 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -46,7 +46,9 @@ static int CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr); static unsigned int HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); /* - * Prototypes for the one word hash key methods. + * Prototypes for the one word hash key methods. Not actually declared because + * this is a critical path that is implemented in the core hash table access + * function. */ #if 0 diff --git a/generic/tclIO.c b/generic/tclIO.c index 7888352..e1e1193 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8851,7 +8851,7 @@ Tcl_FileEventObjCmd( int modeIndex; /* Index of mode argument. */ int mask; static const char *const modeOptions[] = {"readable", "writable", NULL}; - static int maskArray[] = {TCL_READABLE, TCL_WRITABLE}; + static CONST int maskArray[] = {TCL_READABLE, TCL_WRITABLE}; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId event ?script?"); diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 349814a..b22d746 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -521,7 +521,7 @@ Tcl_SeekObjCmd( static const char *const originOptions[] = { "start", "current", "end", NULL }; - static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END}; + static CONST int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END}; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?"); @@ -648,7 +648,7 @@ Tcl_CloseObjCmd( static const char *const dirOptions[] = { "read", "write", NULL }; - static int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE}; + static const int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE}; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId ?direction?"); diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 768428f..7b7b647 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -87,30 +87,29 @@ TclSockGetPort( *---------------------------------------------------------------------- */ -#ifdef _WIN32 -# define PTR2SOCK(a) (SOCKET)a -#else -# define PTR2SOCK(a) PTR2INT(a) +#ifndef _WIN32 +# define SOCKET size_t #endif + int TclSockMinimumBuffers( - ClientData sock, /* Socket file descriptor */ + void *sock, /* Socket file descriptor */ int size) /* Minimum buffer size */ { int current; socklen_t len; len = sizeof(int); - getsockopt(PTR2SOCK(sock), SOL_SOCKET, SO_SNDBUF, (char *)¤t, &len); + getsockopt((SOCKET)sock, SOL_SOCKET, SO_SNDBUF, (char *)¤t, &len); if (current < size) { len = sizeof(int); - setsockopt(PTR2SOCK(sock), SOL_SOCKET, SO_SNDBUF, (char *)&size, len); + setsockopt((SOCKET)sock, SOL_SOCKET, SO_SNDBUF, (char *)&size, len); } len = sizeof(int); - getsockopt(PTR2SOCK(sock), SOL_SOCKET, SO_RCVBUF, (char *)¤t, &len); + getsockopt((SOCKET)sock, SOL_SOCKET, SO_RCVBUF, (char *)¤t, &len); if (current < size) { len = sizeof(int); - setsockopt(PTR2SOCK(sock), SOL_SOCKET, SO_RCVBUF, (char *)&size, len); + setsockopt((SOCKET)sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len); } return TCL_OK; } @@ -178,6 +177,7 @@ TclCreateSocketAddress( } hints.ai_socktype = SOCK_STREAM; + #if 0 /* * We found some problems when using AI_ADDRCONFIG, e.g. on systems that @@ -185,15 +185,16 @@ TclCreateSocketAddress( * localhost. See bugs 3385024, 3382419, 3382431. As the advantage of * using AI_ADDRCONFIG in situations where it works, is probably low, * we'll leave it out for now. After all, it is just an optimisation. - */ -#if defined(AI_ADDRCONFIG) && !defined(_AIX) && !defined(__hpux) - /* + * * Missing on: OpenBSD, NetBSD. * Causes failure when used on AIX 5.1 and HP-UX */ + +#if defined(AI_ADDRCONFIG) && !defined(_AIX) && !defined(__hpux) hints.ai_flags |= AI_ADDRCONFIG; -#endif -#endif +#endif /* AI_ADDRCONFIG && !_AIX && !__hpux */ +#endif /* 0 */ + if (willBind) { hints.ai_flags |= AI_PASSIVE; } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 9905256..c4e7db0 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1729,9 +1729,12 @@ Tcl_FSEvalFileEx( 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. + + /* + * Try to read first character of stream, so we can check for utf-8 BOM to + * be handled especially. */ + if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { Tcl_Close(interp, chan); Tcl_AppendResult(interp, "couldn't read file \"", @@ -1739,10 +1742,12 @@ Tcl_FSEvalFileEx( goto end; } string = Tcl_GetString(objPtr); + /* * If first character is not a BOM, append the remaining characters, - * otherwise replace them [Bug 3466099]. + * otherwise replace them. [Bug 3466099] */ + if (Tcl_ReadChars(chan, objPtr, -1, memcmp(string, "\xef\xbb\xbf", 3)) < 0) { Tcl_Close(interp, chan); @@ -1766,7 +1771,7 @@ Tcl_FSEvalFileEx( */ iPtr->evalFlags |= TCL_EVAL_FILE; - result = Tcl_EvalEx(interp, string, length, 0); + result = TclEvalEx(interp, string, length, 0, 1, NULL, string); /* * Now we have to be careful; the script may have changed the @@ -1855,9 +1860,12 @@ TclNREvalFile( 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. + + /* + * Try to read first character of stream, so we can check for utf-8 BOM to + * be handled especially. */ + if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { Tcl_Close(interp, chan); Tcl_AppendResult(interp, "couldn't read file \"", @@ -1866,15 +1874,17 @@ TclNREvalFile( return TCL_ERROR; } string = Tcl_GetString(objPtr); + /* * If first character is not a BOM, append the remaining characters, - * otherwise replace them [Bug 3466099]. + * otherwise replace them. [Bug 3466099] */ + if (Tcl_ReadChars(chan, objPtr, -1, memcmp(string, "\xef\xbb\xbf", 3)) < 0) { Tcl_Close(interp, chan); Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); Tcl_DecrRefCount(objPtr); return TCL_ERROR; } diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 8651542..b206b35 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -1350,7 +1350,7 @@ PrintUsage( register const Tcl_ArgvInfo *infoPtr; int width, numSpaces; #define NUM_SPACES 20 - static char spaces[] = " "; + static const char spaces[] = " "; char tmp[TCL_DOUBLE_SPACE]; /* diff --git a/generic/tclInt.decls b/generic/tclInt.decls index cb01b22..ddda097 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -126,8 +126,8 @@ declare 25 { # } # Removed in 8.5 #declare 27 { -# int TclGetDate(char *p, unsigned long now, long zone, -# unsigned long *timePtr) +# int TclGetDate(char *p, Tcl_WideInt now, long zone, +# Tcl_WideInt *timePtr) #} declare 28 { Tcl_Channel TclpGetDefaultStdChannel(int type) @@ -319,9 +319,10 @@ declare 76 { declare 77 { void TclpGetTime(Tcl_Time *time) } -declare 78 { - int TclpGetTimeZone(unsigned long time) -} +# Removed in 8.6: +#declare 78 { +# int TclpGetTimeZone(unsigned long time) +#} # Replaced by Tcl_FSListVolumes in 8.4: #declare 79 { # int TclpListVolumes(Tcl_Interp *interp) @@ -420,7 +421,10 @@ declare 103 { int *portPtr) } declare 104 { - int TclSockMinimumBuffers(ClientData sock, int size) + int TclSockMinimumBuffersOld(int sock, int size) +} +declare 110 { + int TclSockMinimumBuffers(void *sock, int size) } # Replaced by Tcl_FSStat in 8.4: #declare 105 { @@ -735,16 +739,6 @@ declare 177 { # Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr) #} -# REMOVED -# Allocate lists without copying arrays -# declare 180 { -# Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj **objv) -# } -#declare 181 { -# Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv, -# const char *file, int line) -#} - # TclpGmtime and TclpLocaltime promoted to the generic interface from unix declare 182 { @@ -995,8 +989,8 @@ declare 248 { } declare 249 { - char* TclDoubleDigits(double dv, int ndigits, int flags, - int* decpt, int* signum, char** endPtr) + char *TclDoubleDigits(double dv, int ndigits, int flags, + int *decpt, int *signum, char **endPtr) } # TIP #285: Script cancellation support. declare 250 { @@ -1025,7 +1019,7 @@ declare 2 win { } declare 3 win { int TclWinGetSockOpt(SOCKET s, int level, int optname, - char FAR *optval, int FAR *optlen) + char *optval, int *optlen) } declare 4 win { HINSTANCE TclWinGetTclInstance(void) @@ -1039,7 +1033,7 @@ declare 6 win { } declare 7 win { int TclWinSetSockOpt(SOCKET s, int level, int optname, - const char FAR *optval, int optlen) + const char *optval, int optlen) } declare 8 win { unsigned long TclpGetPid(Tcl_Pid pid) @@ -1098,9 +1092,10 @@ declare 20 win { declare 22 win { TclFile TclpCreateTempFile(const char *contents) } -declare 23 win { - char *TclpGetTZName(int isdst) -} +# Removed in 8.6: +#declare 23 win { +# char *TclpGetTZName(int isdst) +#} declare 24 win { char *TclWinNoBackslash(char *path) } @@ -1149,7 +1144,7 @@ declare 3 unix { } # On non-cygwin, this is actually a reference to TclpCreateProcess declare 4 unix { - int TclWinGetTclInstance(void) + void *TclWinGetTclInstance(void) } # Signature changed in 8.1: # declare 5 unix { @@ -1162,7 +1157,7 @@ declare 6 unix { } # On non-cygwin, this is actually a reference to TclpOpenFile declare 7 unix { - int TclWinSetSockOpt(int s, int level, int optname, + int TclWinSetSockOpt(void *s, int level, int optname, const char *optval, int optlen) } declare 8 unix { @@ -1229,14 +1224,11 @@ declare 19 {unix macosx} { void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) } declare 20 unix { - void TclWinAddProcess(void *hProcess, unsigned long id) + void TclWinAddProcess(void *hProcess, unsigned int id) } declare 22 unix { TclFile TclpCreateTempFile(const char *contents) } -declare 23 unix { - char *TclpGetTZName(int isdst) -} declare 24 unix { char *TclWinNoBackslash(char *path) } diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index b294e4f..d01d10a 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -214,8 +214,7 @@ EXTERN unsigned long TclpGetClicks(void); EXTERN unsigned long TclpGetSeconds(void); /* 77 */ EXTERN void TclpGetTime(Tcl_Time *time); -/* 78 */ -EXTERN int TclpGetTimeZone(unsigned long time); +/* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ /* 81 */ @@ -263,7 +262,7 @@ EXTERN void TclSetupEnv(Tcl_Interp *interp); EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 104 */ -EXTERN int TclSockMinimumBuffers(ClientData sock, int size); +EXTERN int TclSockMinimumBuffersOld(int sock, int size); /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ @@ -271,7 +270,8 @@ EXTERN int TclSockMinimumBuffers(ClientData sock, int size); EXTERN void TclTeardownNamespace(Namespace *nsPtr); /* 109 */ EXTERN int TclUpdateReturnInfo(Interp *iPtr); -/* Slot 110 is reserved */ +/* 110 */ +EXTERN int TclSockMinimumBuffers(void *sock, int size); /* 111 */ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name, @@ -596,8 +596,8 @@ EXTERN int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 249 */ -EXTERN char* TclDoubleDigits(double dv, int ndigits, int flags, - int*decpt, int*signum, char**endPtr); +EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, + int *decpt, int *signum, char **endPtr); /* 250 */ EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force); @@ -684,7 +684,7 @@ typedef struct TclIntStubs { unsigned long (*tclpGetClicks) (void); /* 75 */ unsigned long (*tclpGetSeconds) (void); /* 76 */ void (*tclpGetTime) (Tcl_Time *time); /* 77 */ - int (*tclpGetTimeZone) (unsigned long time); /* 78 */ + void (*reserved78)(void); void (*reserved79)(void); void (*reserved80)(void); char * (*tclpRealloc) (char *ptr, unsigned int size); /* 81 */ @@ -710,13 +710,13 @@ typedef struct TclIntStubs { CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */ void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */ int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */ - int (*tclSockMinimumBuffers) (ClientData sock, int size); /* 104 */ + int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ void (*reserved105)(void); void (*reserved106)(void); void (*reserved107)(void); void (*tclTeardownNamespace) (Namespace *nsPtr); /* 108 */ int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ - void (*reserved110)(void); + int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */ void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */ int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ @@ -855,7 +855,7 @@ typedef struct TclIntStubs { int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, int numRemoved, int numInserted, Tcl_Obj *const *objv); /* 246 */ void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */ int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */ - char* (*tclDoubleDigits) (double dv, int ndigits, int flags, int*decpt, int*signum, char**endPtr); /* 249 */ + char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ } TclIntStubs; @@ -995,8 +995,7 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclpGetSeconds) /* 76 */ #define TclpGetTime \ (tclIntStubsPtr->tclpGetTime) /* 77 */ -#define TclpGetTimeZone \ - (tclIntStubsPtr->tclpGetTimeZone) /* 78 */ +/* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ #define TclpRealloc \ @@ -1034,8 +1033,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclSetupEnv) /* 102 */ #define TclSockGetPort \ (tclIntStubsPtr->tclSockGetPort) /* 103 */ -#define TclSockMinimumBuffers \ - (tclIntStubsPtr->tclSockMinimumBuffers) /* 104 */ +#define TclSockMinimumBuffersOld \ + (tclIntStubsPtr->tclSockMinimumBuffersOld) /* 104 */ /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ @@ -1043,7 +1042,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclTeardownNamespace) /* 108 */ #define TclUpdateReturnInfo \ (tclIntStubsPtr->tclUpdateReturnInfo) /* 109 */ -/* Slot 110 is reserved */ +#define TclSockMinimumBuffers \ + (tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */ #define Tcl_AddInterpResolvers \ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ #define Tcl_AppendExportList \ diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 5d3e2ab..bea9037 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -58,12 +58,12 @@ EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ -EXTERN int TclWinGetTclInstance(void); +EXTERN void * TclWinGetTclInstance(void); /* Slot 5 is reserved */ /* 6 */ EXTERN unsigned short TclWinNToHS(unsigned short ns); /* 7 */ -EXTERN int TclWinSetSockOpt(int s, int level, int optname, +EXTERN int TclWinSetSockOpt(void *s, int level, int optname, const char *optval, int optlen); /* 8 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); @@ -96,12 +96,11 @@ EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* 20 */ -EXTERN void TclWinAddProcess(void *hProcess, unsigned long id); +EXTERN void TclWinAddProcess(void *hProcess, unsigned int id); /* Slot 21 is reserved */ /* 22 */ EXTERN TclFile TclpCreateTempFile(const char *contents); -/* 23 */ -EXTERN char * TclpGetTZName(int isdst); +/* Slot 23 is reserved */ /* 24 */ EXTERN char * TclWinNoBackslash(char *path); /* Slot 25 is reserved */ @@ -129,7 +128,7 @@ EXTERN struct servent * TclWinGetServByName(const char *nm, const char *proto); /* 3 */ EXTERN int TclWinGetSockOpt(SOCKET s, int level, int optname, - char FAR *optval, int FAR *optlen); + char *optval, int *optlen); /* 4 */ EXTERN HINSTANCE TclWinGetTclInstance(void); /* Slot 5 is reserved */ @@ -137,7 +136,7 @@ EXTERN HINSTANCE TclWinGetTclInstance(void); EXTERN u_short TclWinNToHS(u_short ns); /* 7 */ EXTERN int TclWinSetSockOpt(SOCKET s, int level, int optname, - const char FAR *optval, int optlen); + const char *optval, int optlen); /* 8 */ EXTERN unsigned long TclpGetPid(Tcl_Pid pid); /* 9 */ @@ -170,8 +169,7 @@ EXTERN void TclWinAddProcess(HANDLE hProcess, DWORD id); /* Slot 21 is reserved */ /* 22 */ EXTERN TclFile TclpCreateTempFile(const char *contents); -/* 23 */ -EXTERN char * TclpGetTZName(int isdst); +/* Slot 23 is reserved */ /* 24 */ EXTERN char * TclWinNoBackslash(char *path); /* Slot 25 is reserved */ @@ -196,12 +194,12 @@ EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ -EXTERN int TclWinGetTclInstance(void); +EXTERN void * TclWinGetTclInstance(void); /* Slot 5 is reserved */ /* 6 */ EXTERN unsigned short TclWinNToHS(unsigned short ns); /* 7 */ -EXTERN int TclWinSetSockOpt(int s, int level, int optname, +EXTERN int TclWinSetSockOpt(void *s, int level, int optname, const char *optval, int optlen); /* 8 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); @@ -240,12 +238,11 @@ EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* 20 */ -EXTERN void TclWinAddProcess(void *hProcess, unsigned long id); +EXTERN void TclWinAddProcess(void *hProcess, unsigned int id); /* Slot 21 is reserved */ /* 22 */ EXTERN TclFile TclpCreateTempFile(const char *contents); -/* 23 */ -EXTERN char * TclpGetTZName(int isdst); +/* Slot 23 is reserved */ /* 24 */ EXTERN char * TclWinNoBackslash(char *path); /* Slot 25 is reserved */ @@ -273,10 +270,10 @@ typedef struct TclIntPlatStubs { void (*tclWinConvertWSAError) (unsigned int errCode); /* 1 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ - int (*tclWinGetTclInstance) (void); /* 4 */ + void * (*tclWinGetTclInstance) (void); /* 4 */ void (*reserved5)(void); unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */ - int (*tclWinSetSockOpt) (int s, int level, int optname, const char *optval, int optlen); /* 7 */ + int (*tclWinSetSockOpt) (void *s, int level, int optname, const char *optval, int optlen); /* 7 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ int (*tclWinGetPlatformId) (void); /* 9 */ Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */ @@ -289,10 +286,10 @@ typedef struct TclIntPlatStubs { void (*reserved17)(void); int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ - void (*tclWinAddProcess) (void *hProcess, unsigned long id); /* 20 */ + void (*tclWinAddProcess) (void *hProcess, unsigned int id); /* 20 */ void (*reserved21)(void); TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ - char * (*tclpGetTZName) (int isdst); /* 23 */ + void (*reserved23)(void); char * (*tclWinNoBackslash) (char *path); /* 24 */ void (*reserved25)(void); void (*tclWinSetInterfaces) (int wide); /* 26 */ @@ -306,11 +303,11 @@ typedef struct TclIntPlatStubs { void (*tclWinConvertError) (DWORD errCode); /* 0 */ void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */ struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */ - int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char FAR *optval, int FAR *optlen); /* 3 */ + int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char *optval, int *optlen); /* 3 */ HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */ void (*reserved5)(void); u_short (*tclWinNToHS) (u_short ns); /* 6 */ - int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char FAR *optval, int optlen); /* 7 */ + int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char *optval, int optlen); /* 7 */ unsigned long (*tclpGetPid) (Tcl_Pid pid); /* 8 */ int (*tclWinGetPlatformId) (void); /* 9 */ void (*reserved10)(void); @@ -326,7 +323,7 @@ typedef struct TclIntPlatStubs { void (*tclWinAddProcess) (HANDLE hProcess, DWORD id); /* 20 */ void (*reserved21)(void); TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ - char * (*tclpGetTZName) (int isdst); /* 23 */ + void (*reserved23)(void); char * (*tclWinNoBackslash) (char *path); /* 24 */ void (*reserved25)(void); void (*tclWinSetInterfaces) (int wide); /* 26 */ @@ -339,10 +336,10 @@ typedef struct TclIntPlatStubs { void (*tclWinConvertWSAError) (unsigned int errCode); /* 1 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ - int (*tclWinGetTclInstance) (void); /* 4 */ + void * (*tclWinGetTclInstance) (void); /* 4 */ void (*reserved5)(void); unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */ - int (*tclWinSetSockOpt) (int s, int level, int optname, const char *optval, int optlen); /* 7 */ + int (*tclWinSetSockOpt) (void *s, int level, int optname, const char *optval, int optlen); /* 7 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ int (*tclWinGetPlatformId) (void); /* 9 */ Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */ @@ -355,10 +352,10 @@ typedef struct TclIntPlatStubs { int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ - void (*tclWinAddProcess) (void *hProcess, unsigned long id); /* 20 */ + void (*tclWinAddProcess) (void *hProcess, unsigned int id); /* 20 */ void (*reserved21)(void); TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ - char * (*tclpGetTZName) (int isdst); /* 23 */ + void (*reserved23)(void); char * (*tclWinNoBackslash) (char *path); /* 24 */ void (*reserved25)(void); void (*tclWinSetInterfaces) (int wide); /* 26 */ @@ -427,8 +424,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; /* Slot 21 is reserved */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ -#define TclpGetTZName \ - (tclIntPlatStubsPtr->tclpGetTZName) /* 23 */ +/* Slot 23 is reserved */ #define TclWinNoBackslash \ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ /* Slot 25 is reserved */ @@ -487,8 +483,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; /* Slot 21 is reserved */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ -#define TclpGetTZName \ - (tclIntPlatStubsPtr->tclpGetTZName) /* 23 */ +/* Slot 23 is reserved */ #define TclWinNoBackslash \ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ /* Slot 25 is reserved */ @@ -546,8 +541,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; /* Slot 21 is reserved */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ -#define TclpGetTZName \ - (tclIntPlatStubsPtr->tclpGetTZName) /* 23 */ +/* Slot 23 is reserved */ #define TclWinNoBackslash \ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ /* Slot 25 is reserved */ @@ -573,6 +567,9 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #define TCL_STORAGE_CLASS DLLIMPORT #undef TclpLocaltime_unix #undef TclpGmtime_unix +#undef TclWinConvertWSAError +#define TclWinConvertWSAError TclWinConvertError + #if !defined(__WIN32__) && defined(USE_TCL_STUBS) # ifdef __CYGWIN__ diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 202e66a..008a99d 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -873,40 +873,10 @@ Tcl_UnloadObjCmd( done: Tcl_DStringFree(&pkgName); Tcl_DStringFree(&tmp); - if (!complain && code!=TCL_OK) { + if (!complain && (code != TCL_OK)) { code = TCL_OK; Tcl_ResetResult(interp); } - if (code == TCL_OK) { -#if 0 - /* - * Result of [unload] was not documented in TIP#100, so force to be - * the empty string by commenting this out. DKF. - */ - - Tcl_Obj *resultObjPtr, *objPtr[2]; - - /* - * Our result is the two reference counts. - */ - - TclNewIntObj(objPtr[0], trustedRefCount); - TclNewIntObj(objPtr[1], safeRefCount); - if (objPtr[0] == NULL || objPtr[1] == NULL) { - if (objPtr[0]) { - Tcl_DecrRefCount(objPtr[0]); - } - if (objPtr[1]) { - Tcl_DecrRefCount(objPtr[1]); - } - } else { - TclNewListObj(resultObjPtr, 2, objPtr); - if (resultObjPtr != NULL) { - Tcl_SetObjResult(interp, resultObjPtr); - } - } -#endif - } return code; } diff --git a/generic/tclOO.c b/generic/tclOO.c index 9dd8162..d5cc6e1 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1624,6 +1624,15 @@ Tcl_NewObjectInstance( state = Tcl_SaveInterpState(interp, TCL_OK); contextPtr->callPtr->flags |= CONSTRUCTOR; contextPtr->skip = skip; + + /* + * Adjust the ensmble tracking record if necessary. [Bug 3514761] + */ + + if (((Interp*) interp)->ensembleRewrite.sourceObjs) { + ((Interp*) interp)->ensembleRewrite.numInsertedObjs += skip-1; + ((Interp*) interp)->ensembleRewrite.numRemovedObjs += skip-1; + } result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, objc, objv); @@ -1742,6 +1751,15 @@ TclNRNewObjectInstance( contextPtr->skip = skip; /* + * Adjust the ensmble tracking record if necessary. [Bug 3514761] + */ + + if (((Interp *) interp)->ensembleRewrite.sourceObjs) { + ((Interp *) interp)->ensembleRewrite.numInsertedObjs += skip - 1; + ((Interp *) interp)->ensembleRewrite.numRemovedObjs += skip - 1; + } + + /* * Fire off the constructors non-recursively. */ @@ -1762,7 +1780,6 @@ FinalizeAlloc( Object *oPtr = data[1]; Tcl_InterpState state = data[2]; Tcl_Object *objectPtr = data[3]; - //int flags = oPtr->flags; /* * It's an error if the object was whacked in the constructor. Force this @@ -2050,6 +2067,7 @@ Tcl_CopyObjectInstance( } } + TclResetRewriteEnsemble(interp, 1); contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL); if (contextPtr) { args[0] = TclOOObjectName(interp, o2Ptr); @@ -2064,6 +2082,10 @@ Tcl_CopyObjectInstance( TclDecrRefCount(args[1]); TclDecrRefCount(args[2]); TclOODeleteContext(contextPtr); + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (while performing post-copy callback)"); + } if (result != TCL_OK) { Tcl_DeleteCommandFromToken(interp, o2Ptr->command); return NULL; diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 926966b..3d72690 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -2306,11 +2306,32 @@ ClassVarsSet( ckalloc(sizeof(Tcl_Obj *) * varc); } } + + oPtr->classPtr->variables.num = 0; if (varc > 0) { - memcpy(oPtr->classPtr->variables.list, varv, - sizeof(Tcl_Obj *) * varc); + int created, n; + Tcl_HashTable uniqueTable; + + Tcl_InitObjHashTable(&uniqueTable); + for (i=n=0 ; i<varc ; i++) { + Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); + if (created) { + oPtr->classPtr->variables.list[n++] = varv[i]; + } else { + Tcl_DecrRefCount(varv[i]); + } + } + oPtr->classPtr->variables.num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + oPtr->classPtr->variables.list = (Tcl_Obj **) + ckrealloc((char *) oPtr->classPtr->variables.list, + sizeof(Tcl_Obj *) * n); + Tcl_DeleteHashTable(&uniqueTable); } - oPtr->classPtr->variables.num = varc; return TCL_OK; } @@ -2563,10 +2584,31 @@ ObjVarsSet( ckalloc(sizeof(Tcl_Obj *) * varc); } } + oPtr->variables.num = 0; if (varc > 0) { - memcpy(oPtr->variables.list, varv, sizeof(Tcl_Obj *)*varc); + int created, n; + Tcl_HashTable uniqueTable; + + Tcl_InitObjHashTable(&uniqueTable); + for (i=n=0 ; i<varc ; i++) { + Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); + if (created) { + oPtr->variables.list[n++] = varv[i]; + } else { + Tcl_DecrRefCount(varv[i]); + } + } + oPtr->variables.num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + oPtr->variables.list = (Tcl_Obj **) + ckrealloc((char *) oPtr->variables.list, + sizeof(Tcl_Obj *) * n); + Tcl_DeleteHashTable(&uniqueTable); } - oPtr->variables.num = varc; return TCL_OK; } diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 2d6f324..7988452 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -381,21 +381,6 @@ typedef struct CallContext { #define DESTRUCTOR 0x10 /* This is a destructor. */ /* - * Assorted flags for call frames. Note that bits 1 and 2 are already taken by - * Tcl itself. - */ - -#if 0 -#define FRAME_IS_METHOD 0x4 /* The frame is a method body, and the frame's - * clientData field contains a CallContext - * reference. */ -#define FRAME_IS_OO_DEFINE 0x8 /* The frame is part of the inside workings of - * the [oo::define] command; the clientData - * field contains an Object reference that has - * been confirmed to refer to a class. */ -#endif - -/* * Structure containing definition information about basic class methods. */ diff --git a/generic/tclPanic.c b/generic/tclPanic.c index 2cb8aff..84a9136 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -14,7 +14,7 @@ */ #include "tclInt.h" -#ifdef _WIN32 +#if defined(_WIN32) || defined(__CYGWIN__) MODULE_SCOPE void tclWinDebugPanic(const char *format, ...); #endif @@ -23,7 +23,11 @@ * procedure. */ +#if defined(__CYGWIN__) +static Tcl_PanicProc *panicProc = tclWinDebugPanic; +#else static Tcl_PanicProc *panicProc = NULL; +#endif /* *---------------------------------------------------------------------- @@ -45,7 +49,7 @@ void Tcl_SetPanicProc( Tcl_PanicProc *proc) { -#ifdef _WIN32 +#if defined(_WIN32) /* tclWinDebugPanic only installs if there is no panicProc yet. */ if ((proc != tclWinDebugPanic) || (panicProc == NULL)) #endif @@ -100,7 +104,7 @@ Tcl_PanicVA( fflush(stderr); } /* In case the users panic proc does not abort, we do it here */ -#ifdef _WIN32 +#if defined(_WIN32) || defined(__CYGWIN__) # if defined(__GNUC__) __builtin_trap(); # elif defined(_WIN64) @@ -110,6 +114,8 @@ Tcl_PanicVA( # else DebugBreak(); # endif +#endif +#if defined(_WIN32) ExitProcess(1); #else abort(); diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 7ab8a4e..ba07808 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2346,9 +2346,6 @@ SetFsPathFromAny( FsPath *fsPathPtr; Tcl_Obj *transPtr; char *name; -#if defined(__CYGWIN__) && defined(__WIN32__) - int copied = 0; -#endif ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); if (pathPtr->typePtr == &tclFsPathType) { @@ -2496,30 +2493,6 @@ SetFsPathFromAny( transPtr = TclJoinPath(1, &pathPtr); } -#if defined(__CYGWIN__) && defined(__WIN32__) - { - char winbuf[MAX_PATH+1]; - - /* - * In the Cygwin world, call conv_to_win32_path in order to use the - * mount table to translate the file name into something Windows will - * understand. Take care when converting empty strings! - */ - - name = Tcl_GetStringFromObj(transPtr, &len); - if (len > 0) { - cygwin_conv_to_win32_path(name, winbuf); - TclWinNoBackslash(winbuf); - if (Tcl_IsShared(transPtr)) { - copied = 1; - transPtr = Tcl_DuplicateObj(transPtr); - Tcl_IncrRefCount(transPtr); - } - Tcl_SetStringObj(transPtr, winbuf, -1); - } - } -#endif /* __CYGWIN__ && __WIN32__ */ - /* * Now we have a translated filename in 'transPtr'. This will have forward * slashes on Windows, and will not contain any ~user sequences. @@ -2545,12 +2518,6 @@ SetFsPathFromAny( SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; pathPtr->typePtr = &tclFsPathType; -#if defined(__CYGWIN__) && defined(__WIN32__) - if (copied) { - Tcl_DecrRefCount(transPtr); - } -#endif - return TCL_OK; } diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c index 5907a03..466d535 100644 --- a/generic/tclPkgConfig.c +++ b/generic/tclPkgConfig.c @@ -22,7 +22,7 @@ * - TCL_COMPILE_STATS OSCMa bytecode compiler statistics. * * - TCL_CFG_DO64BIT NSCMdt tcl is compiled for a 64bit system. - * - TCL_CFG_DEBUG NSCMdt tcl is compiled with symbol info on. + * - NDEBUG NSCMdt tcl is compiled with symbol info off. * - TCL_CFG_OPTIMIZED NSCMdt tcl is compiled with cc optimizations on * - TCL_CFG_PROFILED NSCMdt tcl is compiled with profiling info. * @@ -70,7 +70,7 @@ # define CFG_64 "0" #endif -#ifdef TCL_CFG_DEBUG +#ifndef NDEBUG # define CFG_DEBUG "1" #else # define CFG_DEBUG "0" diff --git a/generic/tclPort.h b/generic/tclPort.h index 23c6191..79bea88 100644 --- a/generic/tclPort.h +++ b/generic/tclPort.h @@ -29,10 +29,13 @@ # define USE_PUTENV 1 # define USE_PUTENV_FOR_UNSET 1 /* On Cygwin, the environment is imported from the Cygwin DLL. */ - DLLIMPORT extern char **__cygwin_environ; - DLLIMPORT extern int cygwin_conv_to_win32_path(const char *, char *); # define environ __cygwin_environ # define timezone _timezone + DLLIMPORT extern char **__cygwin_environ; + DLLIMPORT extern int cygwin_conv_to_win32_path(const char *, char *); + DLLIMPORT extern int cygwin_posix_to_win32_path_list_buf_size(char *value); + DLLIMPORT extern void cygwin_posix_to_win32_path_list(char *buf, char *value); + DLLIMPORT extern void __stdcall SetEnvironmentVariableA(const char*, const char *); #endif #if !defined(LLONG_MIN) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 32e9557..a300afc 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -39,19 +39,35 @@ #undef Tcl_CreateHashEntry #undef Tcl_Panic #undef Tcl_FindExecutable +#undef TclSockMinimumBuffers + +/* See bug 510001: TclSockMinimumBuffers needs plat imp */ +#ifdef _WIN64 +# define TclSockMinimumBuffersOld 0 +#else +#define TclSockMinimumBuffersOld sockMinimumBuffersOld +static int TclSockMinimumBuffersOld(int sock, int size) +{ + return TclSockMinimumBuffers(INT2PTR(sock), size); +} +#endif #ifdef __CYGWIN__ +/* Trick, so we don't have to include <windows.h> here, which + * - b.t.w. - lacks this function anyway */ +#define GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS 0x00000004 +int __stdcall GetModuleHandleExW(unsigned int, const char *, void *); + #define TclWinGetPlatformId winGetPlatformId #define Tcl_WinUtfToTChar winUtfToTChar #define Tcl_WinTCharToUtf winTCharToUtf #define TclWinGetTclInstance winGetTclInstance #define TclWinNToHS winNToHS #define TclWinSetSockOpt winSetSockOpt -#define TclWinAddProcess winAddProcess -#define TclpGetTZName pGetTZName #define TclWinNoBackslash winNoBackslash -#define TclWinSetInterfaces (void (*) _ANSI_ARGS_((int))) doNothing +#define TclWinSetInterfaces (void (*) (int)) doNothing +#define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing #define TclWinFlushDirtyChannels doNothing #define TclWinResetInterfaces doNothing @@ -65,38 +81,25 @@ TclWinGetPlatformId() return 2; /* VER_PLATFORM_WIN32_NT */; } -static int TclWinGetTclInstance() +static void *TclWinGetTclInstance() { - Tcl_Panic("TclWinGetTclInstance not yet implemented for CYGWIN"); - return 0; + void *hInstance = NULL; + GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, + (const char *)&winTCharEncoding, &hInstance); + return hInstance; } static unsigned short TclWinNToHS(unsigned short ns) { - Tcl_Panic("TclWinNToHS not yet implemented for CYGWIN"); - return (unsigned short) -1; + return ntohs(ns); } + static int -TclWinSetSockOpt(int s, int level, int optname, +TclWinSetSockOpt(void *s, int level, int optname, const char *optval, int optlen) { - Tcl_Panic("TclWinSetSockOpt not yet implemented for CYGWIN"); - return -1; -} - -static void -TclWinAddProcess(void *hProcess, unsigned long id) -{ - Tcl_Panic("TclWinAddProcess not yet implemented for CYGWIN"); -} - -static char * -TclpGetTZName(int isdst) -{ - /* TODO: implementation */ - Tcl_Panic("TclpGetTZName not yet implemented for CYGWIN"); - return 0; + return setsockopt((int) s, level, optname, optval, optlen); } static char * @@ -120,7 +123,7 @@ doNothing(void) static char * Tcl_WinUtfToTChar(string, len, dsPtr) - CONST char *string; + const char *string; int len; Tcl_DString *dsPtr; { @@ -133,7 +136,7 @@ Tcl_WinUtfToTChar(string, len, dsPtr) static char * Tcl_WinTCharToUtf( - CONST char *string, + const char *string, int len, Tcl_DString *dsPtr) { @@ -145,26 +148,26 @@ Tcl_WinTCharToUtf( } #define Tcl_MacOSXOpenBundleResources (int (*) _ANSI_ARGS_(( \ - Tcl_Interp *, CONST char *, int, int, char *))) Tcl_WinUtfToTChar + Tcl_Interp *, const char *, int, int, char *))) Tcl_WinUtfToTChar #define Tcl_MacOSXOpenVersionedBundleResources (int (*) _ANSI_ARGS_(( \ - Tcl_Interp *, CONST char *, CONST char *, int, int, char *))) Tcl_WinTCharToUtf + Tcl_Interp *, const char *, const char *, int, int, char *))) Tcl_WinTCharToUtf #define TclMacOSXGetFileAttribute (int (*) _ANSI_ARGS_((Tcl_Interp *, \ int, Tcl_Obj *, Tcl_Obj **))) TclpCreateProcess -#define TclMacOSXMatchType (int (*) _ANSI_ARGS_((Tcl_Interp *, CONST char *, \ - CONST char *, Tcl_StatBuf *, Tcl_GlobTypeData *))) TclpMakeFile -#define TclMacOSXNotifierAddRunLoopMode (void (*) _ANSI_ARGS_((CONST void *))) TclpOpenFile -#define TclpLocaltime_unix (struct tm *(*) _ANSI_ARGS_((CONST time_t *))) TclGetAndDetachPids -#define TclpGmtime_unix (struct tm *(*) _ANSI_ARGS_((CONST time_t *))) TclpCloseFile +#define TclMacOSXMatchType (int (*) _ANSI_ARGS_((Tcl_Interp *, const char *, \ + const char *, Tcl_StatBuf *, Tcl_GlobTypeData *))) TclpMakeFile +#define TclMacOSXNotifierAddRunLoopMode (void (*) _ANSI_ARGS_((const void *))) TclpOpenFile +#define TclpLocaltime_unix (struct tm *(*) _ANSI_ARGS_((const time_t *))) TclGetAndDetachPids +#define TclpGmtime_unix (struct tm *(*) _ANSI_ARGS_((const time_t *))) TclpCloseFile #elif !defined(__WIN32__) /* UNIX and MAC */ # define TclWinConvertError (void (*) _ANSI_ARGS_((unsigned int))) TclGetAndDetachPids +# undef TclWinConvertWSAError # define TclWinConvertWSAError (void (*) _ANSI_ARGS_((unsigned int))) TclpCloseFile # define TclWinGetPlatformId (int (*)()) TclpCreateTempFile -# define TclWinGetTclInstance (int (*)()) TclpCreateProcess +# define TclWinGetTclInstance (void *(*)()) TclpCreateProcess # define TclWinNToHS (unsigned short (*) _ANSI_ARGS_((unsigned short ns))) TclpMakeFile -# define TclWinSetSockOpt (int (*) _ANSI_ARGS_((int, int, int, const char *, int))) TclpOpenFile +# define TclWinSetSockOpt (int (*) _ANSI_ARGS_((void *, int, int, const char *, int))) TclpOpenFile # define TclWinAddProcess 0 -# define TclpGetTZName 0 # define TclWinNoBackslash 0 # define TclWinSetInterfaces 0 # define TclWinFlushDirtyChannels 0 @@ -272,7 +275,7 @@ static const TclIntStubs tclIntStubs = { TclpGetClicks, /* 75 */ TclpGetSeconds, /* 76 */ TclpGetTime, /* 77 */ - TclpGetTimeZone, /* 78 */ + 0, /* 78 */ 0, /* 79 */ 0, /* 80 */ TclpRealloc, /* 81 */ @@ -298,13 +301,13 @@ static const TclIntStubs tclIntStubs = { TclSetPreInitScript, /* 101 */ TclSetupEnv, /* 102 */ TclSockGetPort, /* 103 */ - TclSockMinimumBuffers, /* 104 */ + TclSockMinimumBuffersOld, /* 104 */ 0, /* 105 */ 0, /* 106 */ 0, /* 107 */ TclTeardownNamespace, /* 108 */ TclUpdateReturnInfo, /* 109 */ - 0, /* 110 */ + TclSockMinimumBuffers, /* 110 */ Tcl_AddInterpResolvers, /* 111 */ Tcl_AppendExportList, /* 112 */ Tcl_CreateNamespace, /* 113 */ @@ -474,7 +477,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclWinAddProcess, /* 20 */ 0, /* 21 */ TclpCreateTempFile, /* 22 */ - TclpGetTZName, /* 23 */ + 0, /* 23 */ TclWinNoBackslash, /* 24 */ 0, /* 25 */ TclWinSetInterfaces, /* 26 */ @@ -508,7 +511,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclWinAddProcess, /* 20 */ 0, /* 21 */ TclpCreateTempFile, /* 22 */ - TclpGetTZName, /* 23 */ + 0, /* 23 */ TclWinNoBackslash, /* 24 */ 0, /* 25 */ TclWinSetInterfaces, /* 26 */ @@ -540,7 +543,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclWinAddProcess, /* 20 */ 0, /* 21 */ TclpCreateTempFile, /* 22 */ - TclpGetTZName, /* 23 */ + 0, /* 23 */ TclWinNoBackslash, /* 24 */ 0, /* 25 */ TclWinSetInterfaces, /* 26 */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 37ec751..004fadc 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -3262,7 +3262,7 @@ TestlocaleCmd( "ctype", "numeric", "time", "collate", "monetary", "all", NULL }; - static int lcTypes[] = { + static CONST int lcTypes[] = { LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY, LC_ALL }; diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index ad1d510..e4261d6 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -812,15 +812,7 @@ LockBucket( Cache *cachePtr, int bucket) { -#if 0 - if (Tcl_MutexTryLock(bucketInfo[bucket].lockPtr) != TCL_OK) { - Tcl_MutexLock(bucketInfo[bucket].lockPtr); - cachePtr->buckets[bucket].numWaits++; - sharedPtr->buckets[bucket].numWaits++; - } -#else Tcl_MutexLock(bucketInfo[bucket].lockPtr); -#endif cachePtr->buckets[bucket].numLocks++; sharedPtr->buckets[bucket].numLocks++; } diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index 29a6a03..ea3abb1 100644 --- a/generic/tclTomMath.decls +++ b/generic/tclTomMath.decls @@ -213,11 +213,11 @@ declare 60 { int TclBN_s_mp_sub(mp_int *a, mp_int *b, mp_int *c) } declare 61 { - int TclBN_mp_init_set_int(mp_int* a, unsigned long i) + int TclBN_mp_init_set_int(mp_int *a, unsigned long i) } declare 62 { - int TclBN_mp_set_int(mp_int* a, unsigned long i) + int TclBN_mp_set_int(mp_int *a, unsigned long i) } declare 63 { - int TclBN_mp_cnt_lsb(const mp_int* a) + int TclBN_mp_cnt_lsb(const mp_int *a) } diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index feaefb3..4f6c3bf 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -270,11 +270,11 @@ EXTERN int TclBN_s_mp_sqr(mp_int *a, mp_int *b); /* 60 */ EXTERN int TclBN_s_mp_sub(mp_int *a, mp_int *b, mp_int *c); /* 61 */ -EXTERN int TclBN_mp_init_set_int(mp_int*a, unsigned long i); +EXTERN int TclBN_mp_init_set_int(mp_int *a, unsigned long i); /* 62 */ -EXTERN int TclBN_mp_set_int(mp_int*a, unsigned long i); +EXTERN int TclBN_mp_set_int(mp_int *a, unsigned long i); /* 63 */ -EXTERN int TclBN_mp_cnt_lsb(const mp_int*a); +EXTERN int TclBN_mp_cnt_lsb(const mp_int *a); typedef struct TclTomMathStubs { int magic; @@ -341,9 +341,9 @@ typedef struct TclTomMathStubs { int (*tclBN_s_mp_mul_digs) (mp_int *a, mp_int *b, mp_int *c, int digs); /* 58 */ int (*tclBN_s_mp_sqr) (mp_int *a, mp_int *b); /* 59 */ int (*tclBN_s_mp_sub) (mp_int *a, mp_int *b, mp_int *c); /* 60 */ - int (*tclBN_mp_init_set_int) (mp_int*a, unsigned long i); /* 61 */ - int (*tclBN_mp_set_int) (mp_int*a, unsigned long i); /* 62 */ - int (*tclBN_mp_cnt_lsb) (const mp_int*a); /* 63 */ + int (*tclBN_mp_init_set_int) (mp_int *a, unsigned long i); /* 61 */ + int (*tclBN_mp_set_int) (mp_int *a, unsigned long i); /* 62 */ + int (*tclBN_mp_cnt_lsb) (const mp_int *a); /* 63 */ } TclTomMathStubs; #ifdef __cplusplus diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 2e38086..25abdff 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -113,7 +113,7 @@ static const char *const traceTypeOptions[] = { static Tcl_TraceTypeObjCmd *const traceSubCmds[] = { TraceExecutionObjCmd, TraceCommandObjCmd, - TraceVariableObjCmd, + TraceVariableObjCmd }; /* diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 6ce430b..a1c1996 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4121,20 +4121,9 @@ TclReToGlob( *exactPtr = (anchorLeft && anchorRight); } -#if 0 - fprintf(stderr, "INPUT RE '%.*s' OUTPUT GLOB '%s' anchor %d:%d \n", - reStrLen, reStr, - Tcl_DStringValue(dsPtr), anchorLeft, anchorRight); - fflush(stderr); -#endif return TCL_OK; invalidGlob: -#if 0 - fprintf(stderr, "INPUT RE '%.*s' NO OUTPUT GLOB %s (%c)\n", - reStrLen, reStr, msg, *p); - fflush(stderr); -#endif if (interp != NULL) { Tcl_AppendResult(interp, msg, NULL); Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL); diff --git a/generic/tclVar.c b/generic/tclVar.c index 4df5d43..e92dc5f 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -18,6 +18,7 @@ */ #include "tclInt.h" +#include "tclOOInt.h" /* * Prototypes for the variable hash key methods. @@ -762,7 +763,7 @@ TclObjLookupVarEx( } donePart1: -#if 0 +#if 0 /* ENABLE_NS_VARNAME_CACHING perhaps? */ if (varPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { part1 = TclGetString(part1Ptr); @@ -1892,7 +1893,7 @@ TclPtrSetVar( varPtr->value.objPtr = NULL; } if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) { -#if 0 +#if 0 /* ENABLE_NS_VARNAME_CACHING perhaps? */ /* * Can't happen now! */ @@ -6083,7 +6084,7 @@ TclInfoVarsCmd( } } } - } else if (((Interp *)interp)->varFramePtr->procPtr != NULL) { + } else if (iPtr->varFramePtr->procPtr != NULL) { AppendLocals(interp, listPtr, simplePatternPtr, 1); } @@ -6269,17 +6270,21 @@ AppendLocals( { Interp *iPtr = (Interp *) interp; Var *varPtr; - int i, localVarCt; + int i, localVarCt, added; Tcl_Obj **varNamePtr, *objNamePtr; const char *varName; TclVarHashTable *localVarTablePtr; Tcl_HashSearch search; + Tcl_HashTable addedTable; const char *pattern = patternPtr? TclGetString(patternPtr) : NULL; localVarCt = iPtr->varFramePtr->numCompiledLocals; varPtr = iPtr->varFramePtr->compiledLocals; localVarTablePtr = iPtr->varFramePtr->varTablePtr; varNamePtr = &iPtr->varFramePtr->localCachePtr->varName0; + if (includeLinks) { + Tcl_InitObjHashTable(&addedTable); + } for (i = 0; i < localVarCt; i++, varNamePtr++) { /* @@ -6291,6 +6296,9 @@ AppendLocals( varName = TclGetString(*varNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); + if (includeLinks) { + Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added); + } } } varPtr++; @@ -6301,7 +6309,7 @@ AppendLocals( */ if (localVarTablePtr == NULL) { - return; + goto objectVars; } /* @@ -6315,9 +6323,13 @@ AppendLocals( && (includeLinks || !TclIsVarLink(varPtr))) { Tcl_ListObjAppendElement(interp, listPtr, VarHashGetKey(varPtr)); + if (includeLinks) { + Tcl_CreateHashEntry(&addedTable, VarHashGetKey(varPtr), + &added); + } } } - return; + goto objectVars; } /* @@ -6333,9 +6345,41 @@ AppendLocals( varName = TclGetString(objNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); + if (includeLinks) { + Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); + } + } + } + } + + objectVars: + if (!includeLinks) { + return; + } + + if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) { + CallContext *contextPtr = iPtr->varFramePtr->clientData; + Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; + + if (mPtr->declaringObjectPtr) { + FOREACH(objNamePtr, mPtr->declaringObjectPtr->variables) { + Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); + if (added && (!pattern || + Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { + Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); + } + } + } else { + FOREACH(objNamePtr, mPtr->declaringClassPtr->variables) { + Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); + if (added && (!pattern || + Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { + Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); + } } } } + Tcl_DeleteHashTable(&addedTable); } /* diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 81012dc..341f8e0 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2495,27 +2495,29 @@ ZlibTransformSetOption( /* not used */ */ cd->outStream.avail_in = 0; - do { + while (1) { int e; cd->outStream.next_out = (Bytef *) cd->outBuffer; cd->outStream.avail_out = cd->outAllocated; e = deflate(&cd->outStream, flushType); - if (e != Z_OK) { + if (e == Z_BUF_ERROR) { + break; + } else if (e != Z_OK) { ConvertError(interp, e); return TCL_ERROR; + } else if (cd->outStream.avail_out == 0) { + break; } - if (cd->outStream.avail_out > 0) { - if (Tcl_WriteRaw(cd->parent, cd->outBuffer, - PTR2INT(cd->outStream.next_out)) < 0) { - Tcl_AppendResult(interp, "problem flushing channel: ", - Tcl_PosixError(interp), NULL); - return TCL_ERROR; - } + if (Tcl_WriteRaw(cd->parent, cd->outBuffer, + cd->outStream.next_out - (Bytef*)cd->outBuffer) < 0) { + Tcl_AppendResult(interp, "problem flushing channel: ", + Tcl_PosixError(interp), NULL); + return TCL_ERROR; } - } while (cd->outStream.avail_out > 0); + } return TCL_OK; } |