From 845f29c25c98e563d2887cbfcf16f1963ecc20bb Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Sat, 2 Oct 2010 16:04:29 +0000 Subject: * generic/tclAssembly.c: * generic/tclAssembly.h: * tests/assemble.test: Added dictAppend, dictIncrImm, dictLappend, dictSet, dictUnset, nsupvar, upvar, and variable. (Still need tests for the last three.) Merged changes from HEAD. --- ChangeLog | 245 ++++++++++++++++++++++++++------------------------ generic/tclAssembly.c | 58 ++++++++++++ generic/tclAssembly.h | 10 ++- generic/tclExecute.c | 25 +++++- generic/tclObj.c | 51 ++++++++--- tests/assemble.test | 240 ++++++++++++++++++++++++++++++++++++++++++++++++- tests/dict.test | 8 +- 7 files changed, 504 insertions(+), 133 deletions(-) diff --git a/ChangeLog b/ChangeLog index 2ca7ca1..0d2f292 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,11 +1,26 @@ +2010-10-02 Kevin B. Kenny + + [dogeen-assembler-branch] + + * generic/tclAssembly.c: + * generic/tclAssembly.h: + * tests/assemble.test: Added dictAppend, dictIncrImm, dictLappend, + dictSet, dictUnset, nsupvar, upvar, and variable. (Still need tests + for the last three.) + +2010-10-02 Donal K. Fellows + + * generic/tclExecute.c (TEBCresume): [Bug 3079830]: Added invalidation + of string representations of dictionaries in some cases. + 2010-10-01 Jeff Hobbs - * generic/tclExecute.c (EvalStatsCmd): change 'evalstats' to - return data to interp by default, or if given an arg, use that as - filename to output to (accepts 'stdout' and 'stderr'). - Fix output to print used inst count data. - * generic/tclCkalloc.c: change TclDumpMemoryInfo sig to allow - * generic/tclInt.decls: objPtr as well as FILE* as output. + * generic/tclExecute.c (EvalStatsCmd): change 'evalstats' to return + data to interp by default, or if given an arg, use that as filename to + output to (accepts 'stdout' and 'stderr'). Fix output to print used + inst count data. + * generic/tclCkalloc.c: Change TclDumpMemoryInfo sig to allow objPtr + * generic/tclInt.decls: as well as FILE* as output. * generic/tclIntDecls.h: 2010-10-01 Donal K. Fellows @@ -44,39 +59,38 @@ 2010-09-29 Jan Nijtmans - * unix/configure: re-generate with autoconf-2.59 + * unix/configure: Re-generate with autoconf-2.59 * win/configure: - * generic/tclMain.c make compilable with -DUNICODE as well + * generic/tclMain.c: Make compilable with -DUNICODE as well 2010-09-28 Reinhard Max - Implementation of TIP #162, "IPv6 Sockets for Tcl" + TIP #162 IMPLEMENTATION - * doc/socket.n: Document the changes to the [socket] and - [fconfigure] commands. + * doc/socket.n: Document the changes to the [socket] and + [fconfigure] commands. - * generic/tclInt.h: Introduce TclCreateSocketAddress() as a - * generic/tclIOSock.c: replacement for the platform-dependent - * unix/tclUnixSock.c: TclpCreateSocketAddress() functions. - * unix/tclUnixChan.c: Extend the [socket] and [fconfigure] - * unix/tclUnixPort.h: commands to behave as proposed in - * win/tclWinSock.c: TIP #162. - * win/tclWinPort.h: + * generic/tclInt.h: Introduce TclCreateSocketAddress() as a + * generic/tclIOSock.c: replacement for the platform-dependent + * unix/tclUnixSock.c: TclpCreateSocketAddress() functions. Extend + * unix/tclUnixChan.c: the [socket] and [fconfigure] commands to + * unix/tclUnixPort.h: behave as proposed in TIP #162. This is the + * win/tclWinSock.c: core of what is required to support the use of + * win/tclWinPort.h: IPv6 sockets in Tcl. - * compat/fake-rfc2553.c: A compat implementation of the APIs - * compat/fake-rfc2553.h: defined in RFC-2553 (getaddrinfo() and - friends) on top of the existing - gethostbyname() etc. + * compat/fake-rfc2553.c: A compat implementation of the APIs defined + * compat/fake-rfc2553.h: in RFC-2553 (getaddrinfo() and friends) on + top of the existing gethostbyname() etc. * unix/configure.in: Test whether the fake-implementation is * unix/tcl.m4: needed. * unix/Makefile.in: Add a compile target for fake-rfc2553. - * win/configure.in: Allow cross-compilation by default + * win/configure.in: Allow cross-compilation by default. - * tests/socket.test: Improve the test suite to make more use of - * tests/remote.tcl: randomized ports to reduce interference with - tests running in parallel or other services - on the machine. + * tests/socket.test: Improve the test suite to make more use of + * tests/remote.tcl: randomized ports to reduce interference with + tests running in parallel or other services on + the machine. 2010-09-28 Kevin B. Kenny @@ -112,9 +126,9 @@ * generic/tclBasic.c: [Patch 3072080] (minus the itcl * generic/tclCmdIL.c: update): a saner NRE. * generic/tclCompExpr.c: - * generic/tclCompile.c: This makes TclNRExecuteByteCode - * generic/tclCompile.h: (ex TEBC) to be a normal NRE - * generic/tclExecute.c: citizen: it loses its special status. + * generic/tclCompile.c: This makes TclNRExecuteByteCode (ex TEBC) + * generic/tclCompile.h: to be a normal NRE citizen: it loses its + * generic/tclExecute.c: special status. * generic/tclInt.decls: The logic flow within the BC engine is * generic/tclInt.h: simplified considerably. * generic/tclIntDecls.h: @@ -122,7 +136,7 @@ * generic/tclProc.c: * generic/tclTest.c: - * generic/tclVar.c: use the macro HasLocalVars everywhere + * generic/tclVar.c: Use the macro HasLocalVars everywhere * generic/tclOOMethod.c (ProcedureMethodVarResolver): avoid code duplication, let the runtime var resolver call the compiled var @@ -156,16 +170,15 @@ 2010-09-24 Jeff Hobbs * tests/stringComp.test: improved string eq/cmp test coverage - * generic/tclExecute.c (TclExecuteByteCode): merge INST_STR_CMP - and INST_STR_EQ/INST_STR_NEQ paths. Speeds up eq/ne/[string eq] - with obj-aware comparisons and eq/==/ne/!= with length equality - check. + * generic/tclExecute.c (TclExecuteByteCode): merge INST_STR_CMP and + INST_STR_EQ/INST_STR_NEQ paths. Speeds up eq/ne/[string eq] with + obj-aware comparisons and eq/==/ne/!= with length equality check. 2010-09-24 Andreas Kupries - * tclWinsock.c: [Bug 3056775]: Fixed race condition between thread - and internal co-thread access of a socket's structure because of - the thread not using the socketListLock in TcpAccept(). Added + * tclWinsock.c: [Bug 3056775]: Fixed race condition between thread and + internal co-thread access of a socket's structure because of the + thread not using the socketListLock in TcpAccept(). Added documentation on how the module works to the top. 2010-09-23 Jan Nijtmans @@ -183,27 +196,27 @@ 2010-09-23 Jan Nijtmans - * unix/tclAppInit.c: Make compilable with -DUNICODE (not - * win/tclAppInit.c: actived yet), many clean-ups in comments. + * unix/tclAppInit.c: Make compilable with -DUNICODE (not activated + * win/tclAppInit.c: yet), many clean-ups in comments. 2010-09-22 Miguel Sofer - * generic/tclExecute: one more DECACHE_STACK_INFO() missing; this - fixes [Bug 3072640] + * generic/tclExecute: [Bug 3072640]: One more DECACHE_STACK_INFO() was + missing. - * tests/execute.test: added execute-10.3 for [Bug 3072640]. The - test causes a mem failure. + * tests/execute.test: Added execute-10.3 for [Bug 3072640]. The test + causes a mem failure. - * generic/tclExecute: protect all possible writes to ::errorInfo - or ::errorCode with DECACHE_STACK_INFO(), as they could run - traces. The new calls to be protected are Tcl_ResetResult(), - Tcl_SetErrorCode(), IllegalExprOperandType(), - TclExprFloatError(). The error was triggered by [Patch 3072080]. + * generic/tclExecute: Protect all possible writes to ::errorInfo or + ::errorCode with DECACHE_STACK_INFO(), as they could run traces. The + new calls to be protected are Tcl_ResetResult(), Tcl_SetErrorCode(), + IllegalExprOperandType(), TclExprFloatError(). The error was triggered + by [Patch 3072080]. 2010-09-22 Jan Nijtmans - * win/tcl.m4: Add kernel32 to LIBS, so the link line for mingw - * win/configure: is exactly the same as for MSVC++. + * win/tcl.m4: Add kernel32 to LIBS, so the link line for + * win/configure: mingw is exactly the same as for MSVC++. 2010-09-21 Jeff Hobbs @@ -212,7 +225,7 @@ * generic/tclVar.c (TclLookupSimpleVar, CompareVarKeys): * generic/tclPathObj.c (Tcl_FSGetNormalizedPath, Tcl_FSEqualPaths): * generic/tclIOUtil.c (TclFSCwdPointerEquals): peephole opt - * generic/tclResult.c (TclMergeReturnOptions): use memcmp where + * generic/tclResult.c (TclMergeReturnOptions): Use memcmp where applicable as possible speedup on some libc variants. 2010-09-21 Kevin B. Kenny @@ -234,10 +247,10 @@ 2010-09-21 Jan Nijtmans * win/tclWinFile.c: Fix declaration after statement. - * win/tcl.m4: Add -Wdeclaration-after-statement, so - * win/configure: this mistake cannot happen again. - * win/tclWinFCmd.c: [Bug 3069278]: Breakage on head Windows triggered - * win/tclWinPipe.c: by install-tzdata, final fix + * win/tcl.m4: Add -Wdeclaration-after-statement, so this + * win/configure: mistake cannot happen again. + * win/tclWinFCmd.c: [Bug 3069278]: Breakage on head Windows + * win/tclWinPipe.c: triggered by install-tzdata, final fix 2010-09-20 Jan Nijtmans @@ -265,10 +278,10 @@ 2010-09-16 Jan Nijtmans - * generic/tclDecls.h Make Tcl_FindExecutable() work in UNICODE - * generic/tclEncoding.c compiles (windows-only) as well as ASCII. - * generic/tclStubInit.c Needed for [FRQ 491789]: setargv() doesn't - support a unicode cmdline + * generic/tclDecls.h: Make Tcl_FindExecutable() work in UNICODE + * generic/tclEncoding.c: compiles (windows-only) as well as ASCII. + * generic/tclStubInit.c: Needed for [FRQ 491789]: setargv() doesn't + support a unicode cmdline. 2010-09-15 Donal K. Fellows @@ -915,7 +928,7 @@ 2010-05-06 Jan Nijtmans - * generic/tclPkg.c Unnecessary type casts, See Tcl [Patch #2997087] + * generic/tclPkg.c: Unnecessary type casts, see [Patch 2997087] 2010-05-04 Jan Nijtmans @@ -1342,7 +1355,7 @@ * generic/tclIndexObj: [FRQ 2974744]: share exception codes * generic/tclResult.c: further optimization, making use of indexType. - * generic/tclZlib.c [Bug 2979399]: uninitialized value troubles + * generic/tclZlib.c: [Bug 2979399]: uninitialized value troubles 2010-03-30 Donal K. Fellows @@ -2626,23 +2639,23 @@ 2009-11-19 Jan Nijtmans - * generic/tclInt.h Make all internal initialization - * generic/tclTest.c routines MODULE_SCOPE - * generic/tclTestObj.c - * generic/tclTestProcBodyObj.c - * generic/tclThreadTest.c - * unix/Makefile.in Fix [Bug 2883850]: pkgIndex.tcl doesn't - * unix/tclAppInit.c get created with static Tcl build - * unix/tclXtTest.c - * unix/tclXtNotify.c - * unix/tclUnixTest.c - * win/Makefile.in - * win/tcl.m4 - * win/configure (regenerated) - * win/tclAppInit.c - * win/tclWinDde.c Always compile with Stubs. - * win/tclWinReg.c - * win/tclWinTest.c + * generic/tclInt.h: Make all internal initialization + * generic/tclTest.c: routines MODULE_SCOPE + * generic/tclTestObj.c: + * generic/tclTestProcBodyObj.c: + * generic/tclThreadTest.c: + * unix/Makefile.in: Fix [Bug 2883850]: pkgIndex.tcl doesn't + * unix/tclAppInit.c: get created with static Tcl build + * unix/tclXtTest.c: + * unix/tclXtNotify.c: + * unix/tclUnixTest.c: + * win/Makefile.in: + * win/tcl.m4: + * win/configure: (regenerated) + * win/tclAppInit.c: + * win/tclWinDde.c: Always compile with Stubs. + * win/tclWinReg.c: + * win/tclWinTest.c: 2009-11-18 Jan Nijtmans @@ -3300,9 +3313,9 @@ * unix/dltest/pkge.c: const addition * unix/tclUnixThrd.c: Use in stead of "pthread.h" * win/tclWinDde.c: Eliminate some more gcc warnings - * win/tclWinReg.c - * generic/tclInt.h Change ForIterData, make it const-safe. - * generic/tclCmdAH.c + * win/tclWinReg.c: + * generic/tclInt.h: Change ForIterData, make it const-safe. + * generic/tclCmdAH.c: 2009-08-12 Don Porter @@ -3803,7 +3816,7 @@ 2009-04-27 Jan Nijtmans * generic/tclIndexObj.c: Reset internal INTERP_ALTERNATE_WRONG_ARGS - * generic/tclIOCmd.c flag inside the Tcl_WrongNumArgs function, + * generic/tclIOCmd.c: flag inside the Tcl_WrongNumArgs function, so the caller no longer has to do the reset. 2009-04-24 Stuart Cassoff @@ -4087,7 +4100,7 @@ * generic/tcl.decls: [Bug 218977]: Tcl_DbCkfree needs return value * generic/tclCkalloc.c - * generic/tclDecls.h (regenerated) + * generic/tclDecls.h: (regenerated) * generic/tclInt.decls: don't use CONST84/CONST86 here * generic/tclCompile.h: don't use CONST86 here, comment fixing. * generic/tclIO.h: don't use CONST86 here, comment fixing. @@ -4292,41 +4305,41 @@ 2009-02-10 Jan Nijtmans - * generic/tclEncoding.c Eliminate some unnessary type casts - * generic/tclEvent.c some internal const decorations - * generic/tclExecute.c spacing - * generic/tclIndexObj.c - * generic/tclInterp.c - * generic/tclIO.c - * generic/tclIOCmd.c - * generic/tclIORChan.c - * generic/tclIOUtil.c - * generic/tclListObj.c - * generic/tclLiteral.c - * generic/tclNamesp.c - * generic/tclObj.c - * generic/tclOOBasic.c - * generic/tclPathObj.c - * generic/tclPkg.c - * generic/tclProc.c - * generic/tclRegexp.c - * generic/tclScan.c - * generic/tclStringObj.c - * generic/tclTest.c - * generic/tclTestProcBodyObj.c - * generic/tclThread.c - * generic/tclThreadTest.c - * generic/tclTimer.c - * generic/tclTrace.c - * generic/tclUtil.c - * generic/tclVar.c - * generic/tclStubInit.c (regenerated) + * generic/tclEncoding.c: Eliminate some unnessary type casts + * generic/tclEvent.c: some internal const decorations + * generic/tclExecute.c: spacing + * generic/tclIndexObj.c: + * generic/tclInterp.c: + * generic/tclIO.c: + * generic/tclIOCmd.c: + * generic/tclIORChan.c: + * generic/tclIOUtil.c: + * generic/tclListObj.c: + * generic/tclLiteral.c: + * generic/tclNamesp.c: + * generic/tclObj.c: + * generic/tclOOBasic.c: + * generic/tclPathObj.c: + * generic/tclPkg.c: + * generic/tclProc.c: + * generic/tclRegexp.c: + * generic/tclScan.c: + * generic/tclStringObj.c: + * generic/tclTest.c: + * generic/tclTestProcBodyObj.c: + * generic/tclThread.c: + * generic/tclThreadTest.c: + * generic/tclTimer.c: + * generic/tclTrace.c: + * generic/tclUtil.c: + * generic/tclVar.c: + * generic/tclStubInit.c: (regenerated) 2009-02-10 Jan Nijtmans - * unix/tcl.m4: fix [tcl-Bug 2502365] Building of head on HPUX is - broken when using the native CC. - * unix/configure (autoconf-2.59) + * unix/tcl.m4: [Bug 2502365]: Building of head on HPUX is broken when + using the native CC. + * unix/configure: (autoconf-2.59) 2009-02-10 Don Porter diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 94b1ff8..8232551 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -102,7 +102,21 @@ TalInstDesc TalInstructionTable[] = { {"bitor", ASSEM_1BYTE , INST_BITOR , 2 , 1}, {"bitxor", ASSEM_1BYTE , INST_BITXOR , 2 , 1}, {"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1}, + {"dictAppend", + ASSEM_LVT4, INST_DICT_APPEND, + 2, 1}, {"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1}, + {"dictIncrImm", + ASSEM_SINT4_LVT4, + INST_DICT_INCR_IMM, + 1, 1}, + {"dictLappend", + ASSEM_LVT4, INST_DICT_LAPPEND, + 2, 1}, + {"dictSet", ASSEM_DICT_SET, INST_DICT_SET, INT_MIN,1}, + {"dictUnset", + ASSEM_DICT_UNSET, + INST_DICT_UNSET,INT_MIN,1}, {"div", ASSEM_1BYTE, INST_DIV, 2, 1}, {"dup", ASSEM_1BYTE , INST_DUP , 1 , 2}, {"eq", ASSEM_1BYTE , INST_EQ , 2 , 1}, @@ -215,6 +229,7 @@ TalInstDesc TalInstructionTable[] = { {"mult", ASSEM_1BYTE , INST_MULT , 2 , 1}, {"neq", ASSEM_1BYTE , INST_NEQ , 2 , 1}, {"not", ASSEM_1BYTE, INST_LNOT, 1, 1}, + {"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1}. {"over", ASSEM_OVER, INST_OVER, INT_MIN, -1-1}, {"pop", ASSEM_1BYTE , INST_POP , 1 , 0}, {"reverse", ASSEM_REVERSE, INST_REVERSE, INT_MIN, -1-0}, @@ -258,6 +273,8 @@ TalInstDesc TalInstructionTable[] = { {"unsetStk", ASSEM_BOOL, INST_UNSET_STK, 1, 0}, {"uplus", ASSEM_1BYTE, INST_UPLUS, 1, 1}, + {"upvar", ASSEM_LVT4, INST_UPVAR, 2, 1}. + {"variable",ASSEM_LVT4, INST_VARIABLE, 2, 1}. {NULL, 0, 0,0} }; @@ -1032,6 +1049,34 @@ AssembleOneLine(AssembleEnv* assemEnvPtr) BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd+1); break; + case ASSEM_DICT_SET: + if (parsePtr->numWords != 3) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckStrictlyPositive(interp, opnd) != TCL_OK + || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd+1); + TclEmitInt4(localVar, envPtr); + break; + + case ASSEM_DICT_UNSET: + if (parsePtr->numWords != 3) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckStrictlyPositive(interp, opnd) != TCL_OK + || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd); + TclEmitInt4(localVar, envPtr); + break; + case ASSEM_EVAL: /* TODO - Refactor this stuff into a subroutine * that takes the inst code, the message ("script" or "expression") @@ -1287,6 +1332,19 @@ AssembleOneLine(AssembleEnv* assemEnvPtr) BBEmitInstInt1(assemEnvPtr, tblind, opnd, 0); break; + case ASSEM_SINT4_LVT4: + if (parsePtr->numWords != 3) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblind, opnd, 0); + TclEmitInt4(localVar, envPtr); + break; + default: Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n", Tcl_GetString(instNameObj)); diff --git a/generic/tclAssembly.h b/generic/tclAssembly.h index 0c8cd61..7f1a36e 100644 --- a/generic/tclAssembly.h +++ b/generic/tclAssembly.h @@ -49,7 +49,12 @@ typedef enum TalInstType { ASSEM_CONCAT1, /* 1-byte unsigned-integer operand count, must be * strictly positive, consumes N, produces 1 */ ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1 operands, - * produces 1, N >= 0 */ + * produces 1, N > 0 */ + ASSEM_DICT_SET, /* specifies key count and LVT index, consumes N+1 operands, + * produces 1, N > 0 */ + ASSEM_DICT_UNSET, + /* specifies key count and LVT index, consumes N operands, + * produces 1, N > 0 */ ASSEM_EVAL, /* 'eval' - evaluate a constant script (by compiling it * in line with the assembly code! I love Tcl!) */ ASSEM_INDEX, /* 4 byte operand, integer or end-integer */ @@ -74,6 +79,9 @@ typedef enum TalInstType { ASSEM_PUSH, /* one literal operand */ ASSEM_REVERSE, /* REVERSE: 4-byte operand count, consumes N, produces N */ ASSEM_SINT1, /* One 1-byte signed-integer operand (INCR_STK_IMM) */ + ASSEM_SINT4_LVT4, + /* Signed 4-byte integer operand followed by LVT entry. + * Fixed arity */ } TalInstType; /* Description of an instruction recognized by the assembler. */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 6f3701c..3f7c420 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.494.2.4 2010/10/02 01:38:27 kennykb Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.494.2.5 2010/10/02 16:04:29 kennykb Exp $ */ #include "tclInt.h" @@ -5768,6 +5768,16 @@ TEBCresume( Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); } else { Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS); + + /* + * Must invalidate the string representation of dictionary + * here because we have directly updated the internal + * representation; if we don't, callers could see the wrong + * string rep despite the internal version of the dictionary + * having the correct value. [Bug 3079830] + */ + + TclInvalidateStringRep(dictPtr); } break; case INST_DICT_LAPPEND: @@ -5798,6 +5808,16 @@ TEBCresume( } goto gotError; } + + /* + * Must invalidate the string representation of dictionary + * here because we have directly updated the internal + * representation; if we don't, callers could see the wrong + * string rep despite the internal version of the dictionary + * having the correct value. [Bug 3079830] + */ + + TclInvalidateStringRep(dictPtr); } break; default: @@ -6021,6 +6041,9 @@ TEBCresume( if (allocdict) { dictPtr = Tcl_DuplicateObj(dictPtr); } + if (length > 0) { + TclInvalidateStringRep(dictPtr); + } for (i=0 ; ivarIndices[i]); diff --git a/generic/tclObj.c b/generic/tclObj.c index 24a29a5..3161a46 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclObj.c,v 1.174.2.2 2010/10/01 13:34:09 kennykb Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.174.2.3 2010/10/02 16:04:29 kennykb Exp $ */ #include "tclInt.h" @@ -55,9 +55,9 @@ char *tclEmptyStringRep = &tclEmptyString; #if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) /* - * Structure for tracking the source file and line number where a given Tcl_Obj - * was allocated. We also track the pointer to the Tcl_Obj itself, for sanity - * checking purposes. + * Structure for tracking the source file and line number where a given + * Tcl_Obj was allocated. We also track the pointer to the Tcl_Obj itself, + * for sanity checking purposes. */ typedef struct ObjData { @@ -1486,7 +1486,7 @@ TclFreeObj( } } } -#endif +#endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- @@ -1512,7 +1512,6 @@ TclObjBeingDeleted( { return (objPtr->length == -1); } - /* *---------------------------------------------------------------------- @@ -1706,7 +1705,6 @@ Tcl_InvalidateStringRep( { TclInvalidateStringRep(objPtr); } - /* *---------------------------------------------------------------------- @@ -3259,7 +3257,7 @@ UpdateStringOfBignum( Tcl_Panic("conversion failure in UpdateStringOfBignum"); } objPtr->bytes = stringVal; - objPtr->length = size - 1; /* size includes a trailing null byte */ + objPtr->length = size - 1; /* size includes a trailing NUL byte. */ } /* @@ -3566,6 +3564,24 @@ Tcl_SetBignumObj( TclSetBignumIntRep(objPtr, bignumValue); } +/* + *---------------------------------------------------------------------- + * + * TclSetBignumIntRep -- + * + * Install a bignum into the internal representation of an object. + * + * Results: + * None. + * + * Side effects: + * Object internal representation is updated and object type is set. The + * bignum value is cleared, since ownership has transferred to the + * object. + * + *---------------------------------------------------------------------- + */ + void TclSetBignumIntRep( Tcl_Obj *objPtr, @@ -3576,8 +3592,9 @@ TclSetBignumIntRep( /* * Clear the mp_int value. - * Don't call mp_clear() because it would free the digit array - * we just packed into the Tcl_Obj. + * + * Don't call mp_clear() because it would free the digit array we just + * packed into the Tcl_Obj. */ bignumValue->dp = NULL; @@ -3590,9 +3607,17 @@ TclSetBignumIntRep( * * TclGetNumberFromObj -- * + * Extracts a number (of any possible numeric type) from an object. + * * Results: + * Whether the extraction worked. The type is stored in the variable + * referred to by the typePtr argument, and a pointer to the + * representation is stored in the variable referred to by the + * clientDataPtr. * * Side effects: + * Can allocate thread-specific data for handling the copy-out space for + * bignums; this space is shared within a thread. * *---------------------------------------------------------------------- */ @@ -3611,18 +3636,18 @@ TclGetNumberFromObj( } else { *typePtr = TCL_NUMBER_DOUBLE; } - *clientDataPtr = &(objPtr->internalRep.doubleValue); + *clientDataPtr = &objPtr->internalRep.doubleValue; return TCL_OK; } if (objPtr->typePtr == &tclIntType) { *typePtr = TCL_NUMBER_LONG; - *clientDataPtr = &(objPtr->internalRep.longValue); + *clientDataPtr = &objPtr->internalRep.longValue; return TCL_OK; } #ifndef NO_WIDE_TYPE if (objPtr->typePtr == &tclWideIntType) { *typePtr = TCL_NUMBER_WIDE; - *clientDataPtr = &(objPtr->internalRep.wideValue); + *clientDataPtr = &objPtr->internalRep.wideValue; return TCL_OK; } #endif diff --git a/tests/assemble.test b/tests/assemble.test index e901e38..b86e728 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -1255,7 +1255,7 @@ test assemble-10.7 {expr - noncompilable} { -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} } -# assemble-11 - ASSEM_LVT4 (exist and existArray) +# assemble-11 - ASSEM_LVT4 (exist, existArray, dictAppend, dictLappend) test assemble-11.1 {exist - wrong # args} { -body { @@ -1310,6 +1310,30 @@ test assemble-11.5 {existArray} { -cleanup {rename x {}} } +test assemble-11.6 {dictAppend} { + -body { + proc x {} { + set dict {a 1 b 2 c 3} + assemble {push b; push 22; dictAppend dict} + } + x + } + -result {a 1 b 222 c 3} + -cleanup {rename x {}} +} + +test assemble-11.7 {dictLappend} { + -body { + proc x {} { + set dict {a 1 b 2 c 3} + assemble {push b; push 2; dictLappend dict} + } + x + } + -result {a 1 b {2 2} c 3} + -cleanup {rename x {}} +} + # assemble-12 - ASSEM_LVT1 (incr and incrArray) test assemble-12.1 {incr - wrong # args} { @@ -2642,6 +2666,220 @@ test assemble-25.6 {dictGet - 1 index} { -result 1 } +# assemble-26 - dict set + +test assemble-26.1 {dict set - wrong # args} { + -body { + assemble {dictSet 1} + } + -returnCodes error + -match glob + -result {wrong # args*} +} + +test assemble-26.2 {dict get - wrong # args} { + -body { + assemble {dictSet too many args} + } + -returnCodes error + -match glob + -result {wrong # args*} +} + +test assemble-26.3 {dictSet - bad subst} { + -body { + assemble {dictSet 1 $foo} + } + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} +} + +test assemble-26.4 {dictSet - not a number} { + -body { + proc x {} { + assemble {dictSet rubbish foo} + } + x + } + -returnCodes error + -result {expected integer but got "rubbish"} + -cleanup {rename x {}} +} + +test assemble-26.5 {dictSet - zero operand count} { + -body { + proc x {} { + assemble {dictSet 0 foo} + } + list [catch x result] $result $::errorCode + } + -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} + -cleanup {rename x {}; unset result} +} + +test assemble-26.6 {dictSet - bad local} { + -body { + proc x {} { + assemble {dictSet 1 ::foo::bar} + } + list [catch x result] $result $::errorCode + } + -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}} + -cleanup {rename x {}; unset result} +} + +test assemble-26.7 {dictSet} { + -body { + proc x {} { + set dict {a 1 b 2 c 3} + assemble {push b; push 4; dictSet 1 dict} + } + x + } + -result {a 1 b 4 c 3} + -cleanup {rename x {}} +} + +# assemble-27 - dictUnset + +test assemble-27.1 {dictUnset - wrong # args} { + -body { + assemble {dictUnset 1} + } + -returnCodes error + -match glob + -result {wrong # args*} +} + +test assemble-27.2 {dictUnset - wrong # args} { + -body { + assemble {dictUnset too many args} + } + -returnCodes error + -match glob + -result {wrong # args*} +} + +test assemble-27.3 {dictUnset - bad subst} { + -body { + assemble {dictUnset 1 $foo} + } + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} +} + +test assemble-27.4 {dictUnset - not a number} { + -body { + proc x {} { + assemble {dictUnset rubbish foo} + } + x + } + -returnCodes error + -result {expected integer but got "rubbish"} + -cleanup {rename x {}} +} + +test assemble-27.5 {dictUnset - zero operand count} { + -body { + proc x {} { + assemble {dictUnset 0 foo} + } + list [catch x result] $result $::errorCode + } + -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} + -cleanup {rename x {}; unset result} +} + +test assemble-27.6 {dictUnset - bad local} { + -body { + proc x {} { + assemble {dictUnset 1 ::foo::bar} + } + list [catch x result] $result $::errorCode + } + -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}} + -cleanup {rename x {}; unset result} +} + +test assemble-27.7 {dictUnset} { + -body { + proc x {} { + set dict {a 1 b 2 c 3} + assemble {push b; dictUnset 1 dict} + } + x + } + -result {a 1 c 3} + -cleanup {rename x {}} +} + +# assemble-28 - dictIncrImm + +test assemble-28.1 {dictIncrImm - wrong # args} { + -body { + assemble {dictIncrImm 1} + } + -returnCodes error + -match glob + -result {wrong # args*} +} + +test assemble-28.2 {dictIncrImm - wrong # args} { + -body { + assemble {dictIncrImm too many args} + } + -returnCodes error + -match glob + -result {wrong # args*} +} + +test assemble-28.3 {dictIncrImm - bad subst} { + -body { + assemble {dictIncrImm 1 $foo} + } + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} +} + +test assemble-28.4 {dictIncrImm - not a number} { + -body { + proc x {} { + assemble {dictIncrImm rubbish foo} + } + x + } + -returnCodes error + -result {expected integer but got "rubbish"} + -cleanup {rename x {}} +} + +test assemble-28.5 {dictIncrImm - bad local} { + -body { + proc x {} { + assemble {dictIncrImm 1 ::foo::bar} + } + list [catch x result] $result $::errorCode + } + -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}} + -cleanup {rename x {}; unset result} +} + +test assemble-28.6 {dictIncrImm} { + -body { + proc x {} { + set dict {a 1 b 2 c 3} + assemble {push b; dictIncrImm 42 dict} + } + x + } + -result {a 1 b 44 c 3} + -cleanup {rename x {}} +} + test assemble-30.1 {unbalanced stack} { -body { list \ diff --git a/tests/dict.test b/tests/dict.test index c7d186d..b05208f 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: dict.test,v 1.37 2010/05/20 08:37:09 ferrieux Exp $ +# RCS: @(#) $Id: dict.test,v 1.37.2.1 2010/10/02 16:04:29 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -426,6 +426,9 @@ test dict-12.10 {dict lappend command: write failure} -setup { } -returnCodes error -cleanup { unset dictVar } -result {can't set "dictVar": variable is array} +test dict-12.11 {compiled dict append: invalidate string rep - Bug 3079830} { + apply {{} {set d {a 1 b 2 c 3}; dict lappend d b 22}} +} {a 1 b {2 22} c 3} test dict-13.1 {dict append command} -body { set dictv {a a} @@ -487,6 +490,9 @@ test dict-13.9 {dict append command: write failure} -setup { test dict-13.10 {compiled dict append: crash case} { apply {{} {dict append dictVar a o k}} } {a ok} +test dict-13.11 {compiled dict append: invalidate string rep - Bug 3079830} { + apply {{} {set d {a 1 b 2 c 3}; dict append d b 22}} +} {a 1 b 222 c 3} test dict-14.1 {dict for command: syntax} -returnCodes error -body { dict for -- cgit v0.12