summaryrefslogtreecommitdiffstats
path: root/Source/cmSeparateArgumentsCommand.h
blob: a527ae7b2b2bcd351d3662a8953d9f1c27beb7a8 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
/*============================================================================
  CMake - Cross Platform Makefile Generator
  Copyright 2000-2009 Kitware, Inc., Insight Software Consortium

  Distributed under the OSI-approved BSD License (the "License");
  see accompanying file Copyright.txt for details.

  This software is distributed WITHOUT ANY WARRANTY; without even the
  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  See the License for more information.
============================================================================*/
#ifndef cmSeparateArgumentsCommand_h
#define cmSeparateArgumentsCommand_h

#include "cmCommand.h"

/** \class cmSeparateArgumentsCommand
 * \brief separate_arguments command
 *
 * cmSeparateArgumentsCommand implements the separate_arguments CMake command
 */
class cmSeparateArgumentsCommand : public cmCommand
{
public:
  /**
   * This is a virtual constructor for the command.
   */
  virtual cmCommand* Clone()
    {
    return new cmSeparateArgumentsCommand;
    }

  /**
   * This is called when the command is first encountered in
   * the CMakeLists.txt file.
   */
  virtual bool InitialPass(std::vector<std::string> const& args,
                           cmExecutionStatus &status);

  /**
   * This determines if the command is invoked when in script mode.
   */
  virtual bool IsScriptable() const { return true; }

  /**
   * The name of the command as specified in CMakeList.txt.
   */
  virtual std::string GetName() const {return "separate_arguments";}

  cmTypeMacro(cmSeparateArgumentsCommand, cmCommand);
};



#endif
[string is]. Hit some problem edge cases with differences in strictness of edge cases that will force a rethink ([string is boolean] is significantly more strict than Tcl_GetBooleanFromObj). --- generic/tclCmdMZ.c | 2 +- generic/tclCompCmdsSZ.c | 190 ++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 3 + 3 files changed, 194 insertions(+), 1 deletion(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index de32fce..0526325 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3306,7 +3306,7 @@ TclInitStringCmd( {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, - {"is", StringIsCmd, NULL, NULL, NULL, 0}, + {"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0}, {"last", StringLastCmd, NULL, NULL, NULL, 0}, {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, {"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0}, diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 57cb992..b9309ec 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -451,6 +451,196 @@ TclCompileStringIndexCmd( /* *---------------------------------------------------------------------- * + * TclCompileStringIsCmd -- + * + * Procedure called to compile the simplest and most common form of the + * "string is" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "string is" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileStringIsCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + int numWords = parsePtr->numWords; + enum IsType { + TypeBool, TypeBoolFalse, TypeBoolTrue, + TypeFloat, + TypeInteger, TypeNarrowInt, TypeWideInt, + TypeList /*, TypeDict */ + }; + enum IsType t; + JumpFixup jumpFixup; + int start, range; + int allowEmpty = 0; + + if (numWords < 2 || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } +#define GotLiteral(tokenPtr,word) \ + ((tokenPtr)[1].size > 1 && (tokenPtr)[1].start[0] == word[0] && \ + strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0) + + if (GotLiteral(tokenPtr, "boolean")) { + t = TypeBool; + } else if (GotLiteral(tokenPtr, "double")) { + t = TypeFloat; + } else if (GotLiteral(tokenPtr, "entier")) { + t = TypeInteger; + } else if (GotLiteral(tokenPtr, "false")) { + t = TypeBoolFalse; + } else if (GotLiteral(tokenPtr, "integer")) { + t = TypeNarrowInt; + return TCL_ERROR; // Not yet implemented + } else if (GotLiteral(tokenPtr, "list")) { + t = TypeList; + } else if (GotLiteral(tokenPtr, "true")) { + t = TypeBoolTrue; + } else if (GotLiteral(tokenPtr, "wideinteger")) { + t = TypeWideInt; + return TCL_ERROR; // Not yet implemented + } else { + /* + * We don't handle character class checks in bytecode currently. + */ + + return TCL_ERROR; + } + if (numWords != 3 && numWords != 4) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + if (numWords == 3) { + allowEmpty = (t != TypeList); + } else { + if (!GotLiteral(tokenPtr, "-strict")) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + } +#undef GotLiteral + + /* + * Push the word to check. + */ + + CompileWord(envPtr, tokenPtr, interp, numWords-1); + + /* + * Next, do the type check. First, we push a catch range; most of the + * type-check operations throw an exception on failure. + */ + + range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + start = 0; + TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); + ExceptionRangeStarts(envPtr, range); + + /* + * Issue the type-check itself for the specific type. + */ + + switch (t) { + case TypeBool: + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LNOT, envPtr); + TclEmitOpcode( INST_POP, envPtr); + break; + case TypeBoolFalse: + TclEmitOpcode( INST_DUP, envPtr); + start = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + break; + case TypeBoolTrue: + TclEmitOpcode( INST_DUP, envPtr); + start = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); + break; + case TypeFloat: + /* + * Careful! Preserve behavior of NaN which is a double (that is, true + * for the purposes of a type check) but most math ops fail on it. The + * key is that it is not == to itself (and is the only value which + * this is true for). + */ + + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_NEQ, envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 5, envPtr); + + /* + * Type check for all other double values. + */ + + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_UMINUS, envPtr); + TclEmitOpcode( INST_POP, envPtr); + break; + case TypeInteger: + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_BITNOT, envPtr); + TclEmitOpcode( INST_POP, envPtr); + break; + case TypeNarrowInt: + Tcl_Panic("not yet implemented"); + case TypeWideInt: + Tcl_Panic("not yet implemented"); + case TypeList: + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + break; + } + + /* + * Based on whether the exception was thrown (or conditional branch taken, + * in the case of true/false checks), push the correct boolean value. This + * is also where we deal with what happens with empty values in non-strict + * mode. + */ + + ExceptionRangeEnds(envPtr, range); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + PushLiteral(envPtr, "1", 1); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + ExceptionRangeTarget(envPtr, range, catchOffset); + if (start != 0) { + TclStoreInt1AtPtr(CurrentOffset(envPtr) - start, + envPtr->codeStart + start + 1); + } + TclEmitOpcode( INST_END_CATCH, envPtr); + if (allowEmpty) { + PushLiteral(envPtr, "", 0); + TclEmitOpcode( INST_STR_EQ, envPtr); + } else { + TclEmitOpcode( INST_POP, envPtr); + PushLiteral(envPtr, "0", 1); + } + TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileStringMatchCmd -- * * Procedure called to compile the simplest and most common form of the diff --git a/generic/tclInt.h b/generic/tclInt.h index 1fffa1f..e513a6e 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3647,6 +3647,9 @@ MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringLenCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From eaaed023dfb41a1d60c320fccf77c54204c4143e Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 2 Nov 2012 20:39:10 +0000 Subject: reorder to preserve main BC development branch sequence better --- generic/tclCompile.c | 10 +++++----- generic/tclCompile.h | 6 +++--- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 7036f6a..c390971 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -488,17 +488,17 @@ InstructionDesc const tclInstructionTable[] = { {"tclooSelf", 1, +1, 0, {OPERAND_NONE}}, /* Push the identity of the current TclOO object (i.e., the name of * its current public access command) on the stack. */ - {"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}}, - /* Push the identity of the current TclOO object (i.e., the name of - * its current public access command) on the stack. */ - {"tclooClass", 1, 0, 0, {OPERAND_NONE}}, + {"tclooClass", 1, 0, 0, {OPERAND_NONE}}, /* Push the class of the TclOO object named at the top of the stack * onto the stack. * Stack: ... object => ... class */ - {"tclooNamespace", 1, 0, 0, {OPERAND_NONE}}, + {"tclooNamespace", 1, 0, 0, {OPERAND_NONE}}, /* Push the namespace of the TclOO object named at the top of the * stack onto the stack. * Stack: ... object => ... namespace */ + {"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Push the identity of the current TclOO object (i.e., the name of + * its current public access command) on the stack. */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index cab517d..c860307 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -701,9 +701,9 @@ typedef struct ByteCode { /* For compilation relating to TclOO */ #define INST_TCLOO_SELF 153 -#define INST_TCLOO_NEXT 154 -#define INST_TCLOO_CLASS 155 -#define INST_TCLOO_NS 156 +#define INST_TCLOO_CLASS 154 +#define INST_TCLOO_NS 155 +#define INST_TCLOO_NEXT 156 /* The last opcode */ #define LAST_INST_OPCODE 156 -- cgit v0.12 From 7ef78ec33dcd4cf57d272e36d542a1c3c088495a Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 21 Aug 2013 09:35:50 +0000 Subject: define tests for this bug; no fix yet --- tests/oo.test | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/tests/oo.test b/tests/oo.test index e0e0791..054bc46 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1839,6 +1839,36 @@ test oo-15.9 {ensemble rewriting must not bleed through oo::copy} -setup { } -returnCodes error -cleanup { Foo destroy } -result {wrong # args: should be "::bar a b"} +test oo-15.10 {variable binding must not bleed through oo::copy} -setup { + oo::class create FooClass + set result {} +} -body { + set obj1 [FooClass new] + oo::objdefine $obj1 { + variable var + method m {} { + set var foo + } + method get {} { + return $var + } + export eval + } + + $obj1 m + lappend result [$obj1 get] + set obj2 [oo::copy $obj1] + $obj2 eval { + set var bar + } + lappend result [$obj2 get] + $obj1 eval { + set var grill + } + lappend result [$obj1 get] [$obj2 get] +} -cleanup { + FooClass destroy +} -result {foo bar grill bar} test oo-16.1 {OO: object introspection} -body { info object -- cgit v0.12 From a1f0dd74ffe8b407f725f089784f2dd51c2ab548 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 30 Aug 2013 22:04:12 +0000 Subject: Bump version number to 8.6.1. --- ChangeLog | 12 ++++++++++++ README | 2 +- generic/tcl.h | 4 ++-- library/init.tcl | 2 +- unix/configure | 2 +- unix/configure.in | 2 +- unix/tcl.spec | 2 +- win/configure | 2 +- win/configure.in | 2 +- 9 files changed, 21 insertions(+), 9 deletions(-) diff --git a/ChangeLog b/ChangeLog index ddde893..13fd83b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,15 @@ +2013-08-30 Don Porter + + * generic/tcl.h: Bump version number to 8.6.1. + * library/init.tcl: + * unix/configure.in: + * win/configure.in: + * unix/tcl.spec: + * README: + + * unix/configure: autoconf-2.59 + * win/configure: + 2013-08-03 Donal Fellows * library/auto.tcl: [Patch 3611643]: Allow TclOO classes to be found diff --git a/README b/README index 8ecd7a9..7004bc5 100644 --- a/README +++ b/README @@ -1,5 +1,5 @@ README: Tcl - This is the Tcl 8.6.0 source distribution. + This is the Tcl 8.6.1 source distribution. http://sourceforge.net/projects/tcl/files/Tcl/ You can get any source release of Tcl from the URL above. diff --git a/generic/tcl.h b/generic/tcl.h index a833218..1b120fb 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -56,10 +56,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 0 +#define TCL_RELEASE_SERIAL 1 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6.0" +#define TCL_PATCH_LEVEL "8.6.1" /* *---------------------------------------------------------------------------- diff --git a/library/init.tcl b/library/init.tcl index bedc06e..1ca6413 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -16,7 +16,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.6.0 +package require -exact Tcl 8.6.1 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/unix/configure b/unix/configure index 9b3c298..06ff7a4 100755 --- a/unix/configure +++ b/unix/configure @@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/configure.in b/unix/configure.in index 1a9bb31..61ad30f 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -25,7 +25,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/tcl.spec b/unix/tcl.spec index 27f7189..678222c 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.6.0 +Version: 8.6.1 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index fc453f8..e7c1329 100755 --- a/win/configure +++ b/win/configure @@ -1311,7 +1311,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/configure.in b/win/configure.in index 373cfcc..6e1af50 100644 --- a/win/configure.in +++ b/win/configure.in @@ -14,7 +14,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 -- cgit v0.12 From 05fa6e93c1f1952c259e23fca85fe2cae122ad47 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 16:04:30 +0000 Subject: update changes --- changes | 128 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 127 insertions(+), 1 deletion(-) diff --git a/changes b/changes index d3bbb43..0339919 100644 --- a/changes +++ b/changes @@ -8164,6 +8164,132 @@ Dropped support for OS X versions less than 10.4 (Tiger) (fellows) --- Released 8.6.0, December 20, 2012 --- See ChangeLog for details --- -2013-05-08 (bug fix)[3036566] Honor language packs on Vista+ to get initial locale (oehlmann) +2012-12-22 (bug fix)[3598150] DString to Tcl_Obj memleak (afredd) + +2012-12-27 (bug fix)[3598580] Tcl_ListObjReplace() refcount fix (nijtmans) + +2013-01-04 (bug fix) memleak in [format] compiler (fellows) + +2013-01-08 (bug fix)[3092089,3587096] [file normalize] on junction points + +2013-01-09 (bug fix)[3599395] status line processing (nijtmans) +2013-01-23 (bug fix)[2911139] repair async connection management (fellows) +=> http 2.8.6 + +2013-01-26 (bug fix)[3601804] Darwin segfault platformCPUID (nijtmans) + +2013-01-28 (enhancement) improve ensemble bytecode (fellows) + +2013-01-30 (enhancement) selected script code improvements (fradin) +=> tcltest 2.3.6 + +2013-01-30 (bug fix)[3599098] update to handle glibc banner changes (kupries) +=> platform 1.0.11 + +2013-01-31 (bug fix)[3598282] make install DESTDIR support (cassoff) + +2013-02-05 (bug fix)[3603434] [file normalize a:/] flaw in VFS (porter,griffin) + +2013-02-09 (bug fix)[3603695] $obj varname resolution rules (venable,fellows) + +2013-02-11 (bug fix)[3603553] zlib flushing errors (vampiera,fellows) + +2013-02-14 (bug fix)[3604576] msgcat use of Windows registry (oehlmann,nijtmans) +=> msgcat 1.5.1 + +2013-02-19 (bug fix)[2438181] report errors in trace handlers (yorick) + +2013-02-21 (bug fix)[3605447] unbreak [namespace export -clear] (porter) + +2013-02-23 (bug fix)[3599194] fallback IPv6 routines (afredd,max) + +2013-02-27 (bug fix)[3606139] stop crash in [regexp] (lane) + +2013-03-03 (bug fix)[3606258] major serial port update (english) + +2013-03-06 (bug fix)[3606683] [regexp (((((a)*)*)*)*)* {}] hangs +(grathwohl,lane,porter) + +2013-03-12 (enhancement) better build support for Debian arch (shadura) + +2013-03-19 (bug fix)[2893771] [file stat] on locked files (thoyts,nijtmans) + +2013-03-21 (bug fix)[2102614] [auto_mkindex] ensemble support (griffin) + +2013-03-27 Tcl_Zlib*() routines tolerate NULL interps (porter + +2013-04-04 (bug fix) Support URLs with query but no path (max) +=> http 2.8.7 + +2013-04-08 (bug fix)[3610026] regexp crash on color overflow (linnakangas) + +2013-04-29 (enhancement) [array set] compile improvement (fellows) + +2013-04-30 (enhancement) broaden glibc version detection (kupries) +=> platform 1.0.12 + +2013-05-06 (platform support) Cygwin64 (nijtmans) + +2013-05-15 (enhancement) Improved [list {*}...] compile (fellows) + +2013-05-16 (platform support) mingw-4.0 (nijtmans) + +2013-05-19 (platform support) FreeBSD updates (cerutti) + +2013-05-20 (bug fix)[3613567] access error temp file creation (keene) + +2013-05-20 (bug fix)[3613569] temp file open fail can crash [load] (keene) + +2013-05-22 (bug fix)[3613609] [lsort -nocase] failed on non-ASCII (fellows) + +2013-05-28 (bug fix)[3036566] Use language packs (Vista+) locale (oehlmann) => msgcat 1.5.2 +2013-05-29 (bug fix)[3614102] [apply {{} {list [if 1]}}] stack woes (porter) + +2013-06-03 Restored lost performance appending to long strings (elby,porter) + +2013-06-05 (bug fix)[2835313] [while 1 {foo [continue]}] crash (fellows) + +2013-06-17 (bug fix)[a876646] [:cntrl:] includes \x00 to \x1f (nijtmans) + +2013-06-27 (bug fix)[983509] missing encodings for config values (nijtmans) + +2013-06-27 (bug fix)[34538b] apply DST in 2099 (lang) + +2013-07-02 (bug fix)[32afa6] corrected dirent64 check (griffin) + +2013-07-06 tzdata updated to Olson's tzdata2013d (kenny) + +2013-07-10 (bug fix)[86fb5e] [info frame] in compiled ensembles (porter) + +2013-07-18 (bug fix)[1c17fb] revisd syntax errorinfo that shows error (porter) + +2013-07-26 (bug fix)[6585b2] regexp {(\w).*?\1} abb (lane) + +2013-07-29 [string is space \u202f] => 1 (nijtmans) + +2013-08-01 [a0bc85] Limited support for fork with threads (for Rivet) (nijtmans) + +2013-08-01 (bug fix)[1905562] RE recursion limit increased to support +reported usage of large expressions (porter) + +2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows)2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows) + +2013-08-03 (enhancement)[3611643] [auto_mkindex] support TclOO (fellows) + +2013-08-14 (bug fix)[a16752] Missing command delete callbacks (porter) + +2013-08-15 (bug fix)[3610404] reresolve traced forwards (porter) + +2013-08-15 Errors from execution traces become errors of the command (porter) + +2013-08-23 (bug fix)[8ff0cb9] Tcl_NR*Eval*() schedule only, as doc'd (porter) + +2013-08-29 (bug fix)[2486550] enable [interp invokehidden {} yield] (porter) + +2013-09-01 (bug fix)[b98fa55] [binary decode] fail on whitespace (reche,fellows) + +Many optmizations, improvements, and tightened stack management in bytecode. + +--- Released 8.6.1, Septemer 18, 2013 --- See ChangeLog for details --- -- cgit v0.12 From 8bc4ab1c8756c1abaefa435e76d7a4ab6458bdb9 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 16:47:50 +0000 Subject: Favor timeline over ChangeLog --- changes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changes b/changes index 0339919..5428c3e 100644 --- a/changes +++ b/changes @@ -8292,4 +8292,4 @@ reported usage of large expressions (porter) Many optmizations, improvements, and tightened stack management in bytecode. ---- Released 8.6.1, Septemer 18, 2013 --- See ChangeLog for details --- +--- Released 8.6.1, Septemer 18, 2013 --- http://core.tcl.tk/tcl/ for details -- cgit v0.12 From da0f4e22533c85ac4c70e6a45cb88cd87176cb66 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 17:07:41 +0000 Subject: typo --- pkgs/README | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pkgs/README b/pkgs/README index 01c6f43..868bd4f 100644 --- a/pkgs/README +++ b/pkgs/README @@ -39,7 +39,7 @@ needs to conform to the following conventions. distclean: Delete all generated files. dist: Produce a copy of the package's source code distribution. - Must respect the DIST_ROOT variable determing where to + Must respect the DIST_ROOT variable determining where to write the generated directory. Packages that are written to make use of the Tcl Extension Architecture (TEA) -- cgit v0.12 From a7ced6a9fdfa214f263e10b93d9d93b4f22d739d Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 17:39:34 +0000 Subject: make dist --- unix/tclConfig.h.in | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index 23d6026..e55dcd0 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -115,6 +115,9 @@ /* Define to 1 if you have the `gmtime_r' function. */ #undef HAVE_GMTIME_R +/* Compiler support for module scope symbols */ +#undef HAVE_HIDDEN + /* Do we have the intptr_t type? */ #undef HAVE_INTPTR_T @@ -343,9 +346,6 @@ /* Do we have ? */ #undef NO_VALUES_H -/* Compiler support for module scope symbols */ -#undef HAVE_HIDDEN - /* Do we have wait3() */ #undef NO_WAIT3 -- cgit v0.12 From ee5dada68d84581a9b0c3ac970c11b862f0eb186 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 18:50:08 +0000 Subject: doc fix exposed by `make html` --- doc/file.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/file.n b/doc/file.n index 0b0ee9d..c117ee1 100644 --- a/doc/file.n +++ b/doc/file.n @@ -484,7 +484,7 @@ not the effective ones. .TP \fBWindows\fR\0\0\0\0 . -The \fbfile owned\fR subcommand currently always reports that the current user +The \fBfile owned\fR subcommand currently always reports that the current user is the owner of the file, without regard for what the operating system believes to be true, making an ownership test useless. This issue (#3613671) may be fixed in a future release of Tcl. -- cgit v0.12 From 991ddbd26c7c24de6598ff9fe61a1d9f13186548 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 8 Sep 2013 10:21:37 +0000 Subject: [3611643] Stop polluting the global namespace. Refactor the index entry generation so it is done right, once. Handle more of [namespace ensemble create]'s behavior. --- library/auto.tcl | 69 +++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 43 insertions(+), 26 deletions(-) diff --git a/library/auto.tcl b/library/auto.tcl index 78c219e..02edcc4 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -513,6 +513,32 @@ proc auto_mkindex_parser::fullname {name} { return [string map [list \0 \$] $name] } +# auto_mkindex_parser::indexEntry -- +# +# Used by commands like "proc" within the auto_mkindex parser to add a +# correctly-quoted entry to the index. This is shared code so it is done +# *right*, in one place. +# +# Arguments: +# name - Name that is being added to index. + +proc auto_mkindex_parser::indexEntry {name} { + variable index + variable scriptFile + + # We convert all metacharacters to their backslashed form, and pre-split + # the file name that we know about (which will be a proper list, and so + # correctly quoted). + + set name [string range [list \}[fullname $name]] 2 end] + set filenameParts [file split $scriptFile] + + append index [format \ + {set auto_index(%s) [list source [file join $dir %s]]%s} \ + $name $filenameParts \n] + return +} + if {[llength $::auto_mkindex_parser::initCommands]} { return } @@ -524,15 +550,7 @@ if {[llength $::auto_mkindex_parser::initCommands]} { # Adds an entry to the auto index list for the given procedure name. auto_mkindex_parser::command proc {name args} { - variable index - variable scriptFile - # Do some fancy reformatting on the "source" call to handle platform - # differences with respect to pathnames. Use format just so that the - # command is a little easier to read (otherwise it'd be full of - # backslashed dollar signs, etc. - append index [list set auto_index([fullname $name])] \ - [format { [list source [file join $dir %s]]} \ - [file split $scriptFile]] "\n" + indexEntry $name } # Conditionally add support for Tcl byte code files. There are some tricky @@ -559,14 +577,7 @@ auto_mkindex_parser::hook { # procedure name. auto_mkindex_parser::commandInit tbcload::bcproc {name args} { - variable index - variable scriptFile - # Do some nice reformatting of the "source" call, to get around - # path differences on different platforms. We use the format - # command just so that the code is a little easier to read. - append index [list set auto_index([fullname $name])] \ - [format { [list source [file join $dir %s]]} \ - [file split $scriptFile]] "\n" + indexEntry $name } } } @@ -610,6 +621,13 @@ auto_mkindex_parser::command namespace {op args} { variable contextStack if {[lindex $args 0] eq "create"} { set name ::[join [lreverse $contextStack] ::] + catch { + set name [dict get [lrange $args 1 end] -command] + if {![string match ::* $name]} { + set name ::[join [lreverse $contextStack] ::]$name + } + regsub -all ::+ $name :: name + } # create artifical proc to force an entry in the tclIndex $parser eval [list ::proc $name {} {}] } @@ -619,15 +637,14 @@ auto_mkindex_parser::command namespace {op args} { # AUTO MKINDEX: oo::class create name ?definition? # Adds an entry to the auto index list for the given class name. -foreach cmd {oo::class class} { - auto_mkindex_parser::command $cmd {ecmd name {body ""}} { - if {$cmd eq "create"} { - variable index - variable scriptFile - append index [format "set %s \[list source \[%s]]\n" \ - [list auto_index([fullname $name])] \ - [list file join $dir {*}[file split $scriptFile]]] - } +auto_mkindex_parser::command oo::class {op name {body ""}} { + if {$op eq "create"} { + indexEntry $name + } +} +auto_mkindex_parser::command class {op name {body ""}} { + if {$op eq "create"} { + indexEntry $name } } -- cgit v0.12 From 6652de82ba5502a042b2be29a5cf7e04b73fca4b Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 9 Sep 2013 13:34:06 +0000 Subject: [3609693] Must strip the internal representation of procedure-like methods in order to ensure that any bound references to instance variables are removed. --- generic/tclOOMethod.c | 50 ++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 48 insertions(+), 2 deletions(-) diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 81293c7..61215de 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1290,11 +1290,57 @@ CloneProcedureMethod( ClientData *newClientData) { ProcedureMethod *pmPtr = clientData; - ProcedureMethod *pm2Ptr = ckalloc(sizeof(ProcedureMethod)); + ProcedureMethod *pm2Ptr; + Tcl_Obj *bodyObj, *argsObj; + CompiledLocal *localPtr; + /* + * Copy the argument list. + */ + + argsObj = Tcl_NewObj(); + for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL; + localPtr=localPtr->nextPtr) { + if (TclIsVarArgument(localPtr)) { + Tcl_Obj *argObj = Tcl_NewObj(); + + Tcl_ListObjAppendElement(NULL, argObj, + Tcl_NewStringObj(localPtr->name, -1)); + if (localPtr->defValuePtr != NULL) { + Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); + } + Tcl_ListObjAppendElement(NULL, argsObj, argObj); + } + } + + /* + * Must strip the internal representation in order to ensure that any + * bound references to instance variables are removed. [Bug 3609693] + */ + + bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); + TclFreeIntRep(bodyObj); + + /* + * Create the actual copy of the method record, manufacturing a new proc + * record. + */ + + pm2Ptr = ckalloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; - pm2Ptr->procPtr->refCount++; + Tcl_IncrRefCount(argsObj); + Tcl_IncrRefCount(bodyObj); + if (TclCreateProc(interp, NULL, "", argsObj, bodyObj, + &pm2Ptr->procPtr) != TCL_OK) { + Tcl_DecrRefCount(argsObj); + Tcl_DecrRefCount(bodyObj); + ckfree(pm2Ptr); + return TCL_ERROR; + } + Tcl_DecrRefCount(argsObj); + Tcl_DecrRefCount(bodyObj); + if (pmPtr->cloneClientdataProc) { pm2Ptr->clientData = pmPtr->cloneClientdataProc(pmPtr->clientData); } -- cgit v0.12 From 28bb618586416fbb3c1c9a710cf88e5f8d924025 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 11 Sep 2013 02:32:04 +0000 Subject: Stop the save and restore of currStackDepth. Just manage it correctly so it doesn't need correcting. --- generic/tclCompExpr.c | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 2a48117..c2b5a1a 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -490,8 +490,6 @@ typedef struct JumpList { JumpFixup jump; /* Pass this argument to matching calls of * TclEmitForwardJump() and * TclFixupForwardJump(). */ - int depth; /* Remember the currStackDepth of the - * CompileEnv here. */ int offset; /* Data used to compute jump lengths to pass * to TclFixupForwardJump() */ int convert; /* Temporary storage used to compute whether @@ -2269,7 +2267,6 @@ CompileExprTree( newJump = TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - jumpPtr->depth = envPtr->currStackDepth; convert = 1; break; case AND: @@ -2283,7 +2280,6 @@ CompileExprTree( newJump = TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - jumpPtr->depth = envPtr->currStackDepth; break; } } else if (nodePtr->mark == MARK_RIGHT) { @@ -2323,7 +2319,7 @@ CompileExprTree( CLANG_ASSERT(jumpPtr); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpPtr->next->jump); - envPtr->currStackDepth = jumpPtr->depth; + TclAdjustStackDepth(-1, envPtr); jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart); jumpPtr->convert = convert; convert = 1; @@ -2383,7 +2379,6 @@ CompileExprTree( TclFixupForwardJump(envPtr, &jumpPtr->jump, jumpPtr->offset - jumpPtr->jump.codeOffset, 127); convert |= jumpPtr->convert; - envPtr->currStackDepth = jumpPtr->depth + 1; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); @@ -2411,7 +2406,6 @@ CompileExprTree( TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->next->jump, 127); convert = 0; - envPtr->currStackDepth = jumpPtr->depth + 1; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); -- cgit v0.12 From 7eabd2838a8210a30da24672179294fd7d8b1b0a Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 11 Sep 2013 04:49:08 +0000 Subject: Make use of the existing JumpFixup fields. Eliminate extra storage field 'offset' in JumpList that we don't require. --- generic/tclCompExpr.c | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index c2b5a1a..0021323 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -490,8 +490,6 @@ typedef struct JumpList { JumpFixup jump; /* Pass this argument to matching calls of * TclEmitForwardJump() and * TclFixupForwardJump(). */ - int offset; /* Data used to compute jump lengths to pass - * to TclFixupForwardJump() */ int convert; /* Temporary storage used to compute whether * numeric conversion will be needed following * the operator we're compiling. */ @@ -2320,7 +2318,6 @@ CompileExprTree( TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpPtr->next->jump); TclAdjustStackDepth(-1, envPtr); - jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart); jumpPtr->convert = convert; convert = 1; break; @@ -2374,10 +2371,10 @@ CompileExprTree( if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump, (envPtr->codeNext - envPtr->codeStart) - jumpPtr->next->jump.codeOffset, 127)) { - jumpPtr->offset += 3; + jumpPtr->next->jump.codeOffset += 3; } TclFixupForwardJump(envPtr, &jumpPtr->jump, - jumpPtr->offset - jumpPtr->jump.codeOffset, 127); + jumpPtr->next->jump.codeOffset + 2 -jumpPtr->jump.codeOffset, 127); convert |= jumpPtr->convert; freePtr = jumpPtr; jumpPtr = jumpPtr->next; -- cgit v0.12 From 23bb5a2c20bd07e4b66ad4293fb927128e9e975b Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 11 Sep 2013 05:07:52 +0000 Subject: Eliminate another surplus storage field. Make a(n ab)use of the existing JumpFixup fields instead. --- generic/tclCompExpr.c | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 0021323..4afb069 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -490,9 +490,6 @@ typedef struct JumpList { JumpFixup jump; /* Pass this argument to matching calls of * TclEmitForwardJump() and * TclFixupForwardJump(). */ - int convert; /* Temporary storage used to compute whether - * numeric conversion will be needed following - * the operator we're compiling. */ struct JumpList *next; /* Point to next item on the stack */ } JumpList; @@ -2318,7 +2315,9 @@ CompileExprTree( TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpPtr->next->jump); TclAdjustStackDepth(-1, envPtr); - jumpPtr->convert = convert; + if (convert) { + jumpPtr->jump.jumpType = TCL_TRUE_JUMP; + } convert = 1; break; case AND: @@ -2368,6 +2367,10 @@ CompileExprTree( break; case COLON: CLANG_ASSERT(jumpPtr); + if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) { + jumpPtr->jump.jumpType = TCL_FALSE_JUMP; + convert = 1; + } if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump, (envPtr->codeNext - envPtr->codeStart) - jumpPtr->next->jump.codeOffset, 127)) { @@ -2375,7 +2378,6 @@ CompileExprTree( } TclFixupForwardJump(envPtr, &jumpPtr->jump, jumpPtr->next->jump.codeOffset + 2 -jumpPtr->jump.codeOffset, 127); - convert |= jumpPtr->convert; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); -- cgit v0.12 From 3e3fe2606ae5233ae213b95fd91d7d05d2987659 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 12 Sep 2013 17:42:36 +0000 Subject: Stop allocating JumpFixups for jumps that can never need any fixing up. --- generic/tclCompExpr.c | 37 +++++++++++++++---------------------- 1 file changed, 15 insertions(+), 22 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 4afb069..7684c70 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2269,12 +2269,6 @@ CompileExprTree( newJump = TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; break; } } else if (nodePtr->mark == MARK_RIGHT) { @@ -2328,6 +2322,8 @@ CompileExprTree( break; } } else { + int pc1, pc2; + switch (nodePtr->lexeme) { case START: case QUESTION: @@ -2377,7 +2373,9 @@ CompileExprTree( jumpPtr->next->jump.codeOffset += 3; } TclFixupForwardJump(envPtr, &jumpPtr->jump, - jumpPtr->next->jump.codeOffset + 2 -jumpPtr->jump.codeOffset, 127); + jumpPtr->next->jump.codeOffset + 2 + - jumpPtr->jump.codeOffset, 127); + freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); @@ -2388,32 +2386,27 @@ CompileExprTree( case AND: case OR: CLANG_ASSERT(jumpPtr); - TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) - ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, - &jumpPtr->next->jump); + pc1 = CurrentOffset(envPtr); + TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 + : INST_JUMP_TRUE1, 0, envPtr); TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpPtr->next->next->jump); + pc2 = CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP1, 0, envPtr); TclAdjustStackDepth(-1, envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->jump, 127); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc1, + envPtr->codeStart + pc1 + 1); if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { - jumpPtr->next->next->jump.codeOffset += 3; + pc2 += 3; } TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->next->jump, - 127); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, + envPtr->codeStart + pc2 + 1); convert = 0; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); - freePtr = jumpPtr; - jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); - freePtr = jumpPtr; - jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); break; default: TclEmitOpcode(instruction[nodePtr->lexeme], envPtr); -- cgit v0.12 From c12159563db8f0ecce0a00351e1cb0caed2a7acc Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 12 Sep 2013 19:21:20 +0000 Subject: Swap the two fixups used when compiling the ternary operator. Push them on the stack only when needed, and pop as soon as possible. --- generic/tclCompExpr.c | 33 ++++++++++++++++----------------- 1 file changed, 16 insertions(+), 17 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 7684c70..106855a 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2256,12 +2256,6 @@ CompileExprTree( switch (nodePtr->lexeme) { case QUESTION: - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; convert = 1; break; case AND: @@ -2302,12 +2296,17 @@ CompileExprTree( break; } case QUESTION: + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); break; case COLON: - CLANG_ASSERT(jumpPtr); + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpPtr->next->jump); + &jumpPtr->jump); TclAdjustStackDepth(-1, envPtr); if (convert) { jumpPtr->jump.jumpType = TCL_TRUE_JUMP; @@ -2322,7 +2321,7 @@ CompileExprTree( break; } } else { - int pc1, pc2; + int pc1, pc2, target; switch (nodePtr->lexeme) { case START: @@ -2364,21 +2363,21 @@ CompileExprTree( case COLON: CLANG_ASSERT(jumpPtr); if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) { - jumpPtr->jump.jumpType = TCL_FALSE_JUMP; + jumpPtr->jump.jumpType = TCL_UNCONDITIONAL_JUMP; convert = 1; } - if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump, + target = jumpPtr->jump.codeOffset + 2; + if (TclFixupForwardJump(envPtr, &jumpPtr->jump, (envPtr->codeNext - envPtr->codeStart) - - jumpPtr->next->jump.codeOffset, 127)) { - jumpPtr->next->jump.codeOffset += 3; + - jumpPtr->jump.codeOffset, 127)) { + target += 3; } - TclFixupForwardJump(envPtr, &jumpPtr->jump, - jumpPtr->next->jump.codeOffset + 2 - - jumpPtr->jump.codeOffset, 127); - freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); + TclFixupForwardJump(envPtr, &jumpPtr->jump, + target - jumpPtr->jump.codeOffset, 127); + freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); -- cgit v0.12 From c34e729136c3608344a630fc086235da2a4092e4 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 12 Sep 2013 19:27:48 +0000 Subject: Push fixup on the stack only when needed. --- generic/tclCompExpr.c | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 106855a..fce870b 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2254,16 +2254,8 @@ CompileExprTree( if (nodePtr->mark == MARK_LEFT) { next = nodePtr->left; - switch (nodePtr->lexeme) { - case QUESTION: + if (nodePtr->lexeme == QUESTION) { convert = 1; - break; - case AND: - case OR: - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - break; } } else if (nodePtr->mark == MARK_RIGHT) { next = nodePtr->right; @@ -2314,10 +2306,12 @@ CompileExprTree( convert = 1; break; case AND: - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); - break; case OR: - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpPtr->jump); + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) + ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, &jumpPtr->jump); break; } } else { -- cgit v0.12 From 6fef99593ff6cf1e4f504ca2a9ddabbd0d17c04b Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 13 Sep 2013 03:33:43 +0000 Subject: More macro use. --- generic/tclCompCmds.c | 8 ++------ generic/tclCompExpr.c | 4 +--- 2 files changed, 3 insertions(+), 9 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 8edb2d9..fdc8ec1 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2228,7 +2228,7 @@ TclCompileForCmd( { Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; - int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist; + int bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange; DefineLineInformation; /* TIP #280 */ @@ -2309,13 +2309,9 @@ TclCompileForCmd( * terminates the for. */ - testCodeOffset = CurrentOffset(envPtr); - - jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { + if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) { bodyCodeOffset += 3; nextCodeOffset += 3; - testCodeOffset += 3; } SetLineInformation(2); diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index fce870b..d8e4d9f 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2361,9 +2361,7 @@ CompileExprTree( convert = 1; } target = jumpPtr->jump.codeOffset + 2; - if (TclFixupForwardJump(envPtr, &jumpPtr->jump, - (envPtr->codeNext - envPtr->codeStart) - - jumpPtr->jump.codeOffset, 127)) { + if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { target += 3; } freePtr = jumpPtr; -- cgit v0.12 From 92eea63a7df5071fddef9b89b9122a5761670908 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 14 Sep 2013 07:07:03 +0000 Subject: [2152292] Corrected implementation of uuencoding. --- doc/binary.n | 17 +++---- generic/tclBinary.c | 125 ++++++++++++++++++++++++++++++++++++++++++++++++++-- tests/binary.test | 43 ++++++++++++------ 3 files changed, 158 insertions(+), 27 deletions(-) diff --git a/doc/binary.n b/doc/binary.n index a40afe6..95be36e 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -96,25 +96,22 @@ largely superseded by the \fBbase64\fR binary encoding. .RS .PP During encoding, the following options are supported: -'\" This is wrong! The uuencode format had more complexity than this! .TP \fB\-maxlen \fIlength\fR . Indicates that the output should be split into lines of no more than -\fIlength\fR characters. By default, lines are not split. -.TP -\fB\-wrapchar \fIcharacter\fR -. -Indicates that, when lines are split because of the \fB\-maxlen\fR option, -\fIcharacter\fR should be used to separate lines. By default, this is a -newline character, -.QW \en . +\fIlength\fR characters. By default, lines are split every 61 characters, and +this must be in the range 3 to 85 due to limitations in the encoding. .PP During decoding, the following options are supported: .TP \fB\-strict\fR . -Instructs the decoder to throw an error if it encounters whitespace characters. Otherwise it ignores them. +Instructs the decoder to throw an error if it encounters whitespace +characters. Otherwise it ignores them. +.PP +Note that neither the encoder nor the decoder handle the header and footer of +the uuencode format. .RE .VE 8.6 .SH "BINARY FORMAT" diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 7625d39..71da309 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -87,10 +87,13 @@ static int BinaryDecodeHex(ClientData clientData, static int BinaryEncode64(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int BinaryDecodeUu(ClientData clientData, +static int BinaryDecode64(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int BinaryDecode64(ClientData clientData, +static int BinaryEncodeUu(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int BinaryDecodeUu(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -140,7 +143,7 @@ static const EnsembleImplMap binaryMap[] = { }; static const EnsembleImplMap encodeMap[] = { { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, (ClientData)HexDigits, 0 }, - { "uuencode", BinaryEncode64, NULL, NULL, (ClientData)UueDigits, 0 }, + { "uuencode", BinaryEncodeUu, NULL, NULL, NULL, 0 }, { "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 }, { NULL, NULL, NULL, NULL, NULL, 0 } }; @@ -2439,7 +2442,7 @@ BinaryDecodeHex( * This implements a generic 6 bit binary encoding. Input is broken into * 6 bit chunks and a lookup table passed in via clientData is used to * turn these values into output characters. This is used to implement - * base64 and uuencode binary encodings. + * base64 binary encodings. * * Results: * Interp result set to an encoded byte array object @@ -2498,6 +2501,12 @@ BinaryEncode64( if (Tcl_GetIntFromObj(interp, objv[i+1], &maxlen) != TCL_OK) { return TCL_ERROR; } + if (maxlen < 0) { + Tcl_SetResult(interp, "line length out of range", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", + "LINE_LENGTH", NULL); + return TCL_ERROR; + } break; case OPT_WRAPCHAR: wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); @@ -2550,6 +2559,114 @@ BinaryEncode64( /* *---------------------------------------------------------------------- * + * BinaryEncodeUu -- + * + * This implements the uuencode binary encoding. Input is broken into 6 + * bit chunks and a lookup table is used to turn these values into output + * characters. This differs from the generic code above in that line + * lengths are also encoded. + * + * Results: + * Interp result set to an encoded byte array object + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +static int +BinaryEncodeUu( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *resultObj; + unsigned char *data, *start, *cursor; + int offset, count, rawLength, n, i, bits, index; + int lineLength = 61; + enum {OPT_MAXLEN}; + static const char *const optStrings[] = { "-maxlen", NULL }; + + if (objc < 2 || objc%2 != 0) { + Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? data"); + return TCL_ERROR; + } + for (i = 1; i < objc-1; i += 2) { + if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", + TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case OPT_MAXLEN: + if (Tcl_GetIntFromObj(interp, objv[i+1], &lineLength) != TCL_OK) { + return TCL_ERROR; + } + if (lineLength < 3 || lineLength > 85) { + Tcl_SetResult(interp, "line length out of range", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", + "LINE_LENGTH", NULL); + return TCL_ERROR; + } + break; + } + } + + /* + * Allocate the buffer. This is a little bit too long, but is "good + * enough". + */ + + resultObj = Tcl_NewObj(); + offset = 0; + data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); + rawLength = (lineLength - 1) * 3 / 4; + start = cursor = Tcl_SetByteArrayLength(resultObj, + (lineLength + 1) * ((count + (rawLength - 1)) / rawLength)); + n = bits = 0; + + /* + * Encode the data. Each output line first has the length of raw data + * encoded by the output line described in it by one encoded byte, then + * the encoded data follows (encoding each 6 bits as one character). + * Encoded lines are always terminated by a newline. + */ + + while (offset < count) { + int lineLen = count - offset; + + if (lineLen > rawLength) { + lineLen = rawLength; + } + *cursor++ = UueDigits[lineLen]; + for (i=0 ; i 6 ; bits -= 6) { + *cursor++ = UueDigits[(n >> (bits-6)) & 0x3f]; + } + } + if (bits > 0) { + n <<= 8; + *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f]; + bits = 0; + } + *cursor++ = '\n'; + } + + /* + * Fix the length of the output bytearray. + */ + + Tcl_SetByteArrayLength(resultObj, cursor-start); + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * BinaryDecodeUu -- * * Decode a uuencoded string. diff --git a/tests/binary.test b/tests/binary.test index d424837..4b71b77 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2705,34 +2705,51 @@ test binary-74.1 {binary encode uuencode} -body { } -returnCodes error -match glob -result "wrong # args: *" test binary-74.2 {binary encode uuencode} -body { binary encode uuencode abc -} -result {86)C} +} -result {#86)C +} test binary-74.3 {binary encode uuencode} -body { binary encode uuencode {} } -result {} test binary-74.4 {binary encode uuencode} -body { binary encode uuencode [string repeat abc 20] -} -result [string repeat 86)C 20] +} -result "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n" test binary-74.5 {binary encode uuencode} -body { binary encode uuencode \0\1\2\3\4\0\1\2\3 -} -result "``\$\"`P0``0(#" +} -result ")``\$\"`P0``0(#\n" test binary-74.6 {binary encode uuencode} -body { binary encode uuencode \0 -} -result {````} +} -result {!`` +} test binary-74.7 {binary encode uuencode} -body { binary encode uuencode \0\0 -} -result {````} +} -result "\"``` +" test binary-74.8 {binary encode uuencode} -body { binary encode uuencode \0\0\0 -} -result {````} +} -result {#```` +} test binary-74.9 {binary encode uuencode} -body { binary encode uuencode \0\0\0\0 -} -result {````````} -test binary-74.10 {binary encode uuencode} -body { - binary encode uuencode -maxlen 0 -wrapchar | abcabcabc -} -result {86)C86)C86)C} -test binary-74.11 {binary encode uuencode} -body { - binary encode uuencode -maxlen 1 -wrapchar | abcabcabc -} -result {8|6|)|C|8|6|)|C|8|6|)|C} +} -result {$`````` +} +test binary-74.10 {binary encode uuencode} -returnCodes error -body { + binary encode uuencode -maxlen 30 -wrapchar | abcabcabc +} -result {bad option "-wrapchar": must be -maxlen} +test binary-74.11 {binary encode uuencode} -returnCodes error -body { + binary encode uuencode -maxlen 1 abcabcabc +} -result {line length out of range} +test binary-74.12 {binary encode uuencode} -body { + binary encode uuencode -maxlen 3 abcabcabc +} -result {!80 +!8@ +!8P +!80 +!8@ +!8P +!80 +!8@ +!8P +} test binary-75.1 {binary decode uuencode} -body { binary decode uuencode -- cgit v0.12 From b1264cd184de3c9ba370ae1e9cb9bb029b12872b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 14 Sep 2013 08:51:23 +0000 Subject: Add back -wrapchar option to "binary encode uuencode". --- doc/binary.n | 9 ++++++++- generic/tclBinary.c | 25 +++++++++++++++++++------ tests/binary.test | 17 ++++------------- 3 files changed, 31 insertions(+), 20 deletions(-) diff --git a/doc/binary.n b/doc/binary.n index 95be36e..9f22fb1 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -64,7 +64,7 @@ Indicates that the output should be split into lines of no more than . Indicates that, when lines are split because of the \fB\-maxlen\fR option, \fIcharacter\fR should be used to separate lines. By default, this is a -newline character, +newline character. .QW \en . .PP During decoding, the following options are supported: @@ -102,6 +102,13 @@ During encoding, the following options are supported: Indicates that the output should be split into lines of no more than \fIlength\fR characters. By default, lines are split every 61 characters, and this must be in the range 3 to 85 due to limitations in the encoding. +.TP +\fB\-wrapchar \fIcharacter\fR +. +Indicates that, when lines are split because of the \fB\-maxlen\fR option, +\fIcharacter\fR should be used to separate lines. By default, this is a +newline character. +.QW \en . .PP During decoding, the following options are supported: .TP diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 71da309..98a4d31 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2584,13 +2584,15 @@ BinaryEncodeUu( { Tcl_Obj *resultObj; unsigned char *data, *start, *cursor; - int offset, count, rawLength, n, i, bits, index; + int offset, count, rawLength, n, i, j, bits, index; int lineLength = 61; - enum {OPT_MAXLEN}; - static const char *const optStrings[] = { "-maxlen", NULL }; + const char *wrapchar = "\n"; + int wrapcharlen = 1; + enum {OPT_MAXLEN, OPT_WRAPCHAR }; + static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; if (objc < 2 || objc%2 != 0) { - Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? ?-wrapchar char? data"); return TCL_ERROR; } for (i = 1; i < objc-1; i += 2) { @@ -2610,6 +2612,15 @@ BinaryEncodeUu( return TCL_ERROR; } break; + case OPT_WRAPCHAR: + wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); + if (wrapcharlen < 0 || wrapcharlen > 2) { + Tcl_SetResult(interp, "wrap char out of range", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", + "WRAP_CHAR", NULL); + return TCL_ERROR; + } + break; } } @@ -2623,7 +2634,7 @@ BinaryEncodeUu( data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); rawLength = (lineLength - 1) * 3 / 4; start = cursor = Tcl_SetByteArrayLength(resultObj, - (lineLength + 1) * ((count + (rawLength - 1)) / rawLength)); + (lineLength + wrapcharlen) * ((count + (rawLength - 1)) / rawLength)); n = bits = 0; /* @@ -2652,7 +2663,9 @@ BinaryEncodeUu( *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f]; bits = 0; } - *cursor++ = '\n'; + for (j=0; j Date: Sat, 14 Sep 2013 08:59:41 +0000 Subject: Hm, this check doesn't really add anything. --- generic/tclBinary.c | 6 ------ 1 file changed, 6 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 98a4d31..69f5baf 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2614,12 +2614,6 @@ BinaryEncodeUu( break; case OPT_WRAPCHAR: wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); - if (wrapcharlen < 0 || wrapcharlen > 2) { - Tcl_SetResult(interp, "wrap char out of range", TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", - "WRAP_CHAR", NULL); - return TCL_ERROR; - } break; } } -- cgit v0.12 From 0f1f636a50239c2409172a34da5fa1b1f45bf9c4 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 14 Sep 2013 18:25:45 +0000 Subject: And the decoder too. --- doc/binary.n | 2 +- generic/tclBinary.c | 104 +++++++++++++++++++++++++++++++++++++++++++--------- tests/binary.test | 41 +++++++++++---------- 3 files changed, 109 insertions(+), 38 deletions(-) diff --git a/doc/binary.n b/doc/binary.n index 95be36e..b301f4d 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -107,7 +107,7 @@ During decoding, the following options are supported: .TP \fB\-strict\fR . -Instructs the decoder to throw an error if it encounters whitespace +Instructs the decoder to throw an error if it encounters unexpected whitespace characters. Otherwise it ignores them. .PP Note that neither the encoder nor the decoder handle the header and footer of diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 71da309..c0dd926 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2690,8 +2690,8 @@ BinaryDecodeUu( Tcl_Obj *resultObj = NULL; unsigned char *data, *datastart, *dataend; unsigned char *begin, *cursor; - int i, index, size, count = 0, cut = 0, strict = 0; - char c; + int i, index, size, count = 0, strict = 0, lineLen; + unsigned char c; enum {OPT_STRICT }; static const char *const optStrings[] = { "-strict", NULL }; @@ -2717,44 +2717,112 @@ BinaryDecodeUu( dataend = data + count; size = ((count + 3) & ~3) * 3 / 4; begin = cursor = Tcl_SetByteArrayLength(resultObj, size); + lineLen = -1; + + /* + * The decoding loop. First, we get the length of line (strictly, the + * number of data bytes we expect to generate from the line) we're + * processing this time round if it is not already known (i.e., when the + * lineLen variable is set to the magic value, -1). + */ + while (data < dataend) { char d[4] = {0, 0, 0, 0}; + if (lineLen < 0) { + c = *data++; + if (c < 32 || c > 96) { + if (strict || !isspace(c)) { + goto badUu; + } + i--; + continue; + } + lineLen = (c - 32) & 0x3f; + } + + /* + * Now we read a four-character grouping. + */ + for (i=0 ; i<4 ; i++) { if (data < dataend) { d[i] = c = *data++; - if (c < 33 || c > 96) { - if (strict || !isspace(UCHAR(c))) { - goto badUu; + if (c < 32 || c > 96) { + if (strict) { + if (!isspace(c)) { + goto badUu; + } else if (c == '\n') { + goto shortUu; + } } i--; continue; } - } else { - cut++; } } - if (cut > 3) { - cut = 3; + + /* + * Translate that grouping into (up to) three binary bytes output. + */ + + if (lineLen > 0) { + *cursor++ = (((d[0] - 0x20) & 0x3f) << 2) + | (((d[1] - 0x20) & 0x3f) >> 4); + if (--lineLen > 0) { + *cursor++ = (((d[1] - 0x20) & 0x3f) << 4) + | (((d[2] - 0x20) & 0x3f) >> 2); + if (--lineLen > 0) { + *cursor++ = (((d[2] - 0x20) & 0x3f) << 6) + | (((d[3] - 0x20) & 0x3f)); + lineLen--; + } + } + } + + /* + * If we've reached the end of the line, skip until we process a + * newline. + */ + + if (lineLen == 0 && data < dataend) { + lineLen = -1; + do { + c = *data++; + if (c == '\n') { + break; + } else if (c >= 32 && c <= 96) { + data--; + break; + } else if (strict || !isspace(c)) { + goto badUu; + } + } while (data < dataend); } - *cursor++ = (((d[0] - 0x20) & 0x3f) << 2) - | (((d[1] - 0x20) & 0x3f) >> 4); - *cursor++ = (((d[1] - 0x20) & 0x3f) << 4) - | (((d[2] - 0x20) & 0x3f) >> 2); - *cursor++ = (((d[2] - 0x20) & 0x3f) << 6) - | (((d[3] - 0x20) & 0x3f)); } - if (cut > size) { - cut = size; + + /* + * Sanity check, clean up and finish. + */ + + if (lineLen > 0 && strict) { + goto shortUu; } - Tcl_SetByteArrayLength(resultObj, cursor - begin - cut); + Tcl_SetByteArrayLength(resultObj, cursor - begin); Tcl_SetObjResult(interp, resultObj); return TCL_OK; + shortUu: + Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data")); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL); + TclDecrRefCount(resultObj); + return TCL_ERROR; + badUu: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid uuencode character \"%c\" at position %d", c, (int) (data - datastart - 1))); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL); TclDecrRefCount(resultObj); return TCL_ERROR; } diff --git a/tests/binary.test b/tests/binary.test index 4b71b77..607a070 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2755,72 +2755,75 @@ test binary-75.1 {binary decode uuencode} -body { binary decode uuencode } -returnCodes error -match glob -result "wrong # args: *" test binary-75.2 {binary decode uuencode} -body { - binary decode uuencode 86)C + binary decode uuencode "#86)C\n" } -result {abc} test binary-75.3 {binary decode uuencode} -body { binary decode uuencode {} } -result {} +test binary-75.3.1 {binary decode uuencode} -body { + binary decode uuencode `\n +} -result {} test binary-75.4 {binary decode uuencode} -body { - binary decode uuencode [string repeat "86)C" 20] + binary decode uuencode "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n" } -result [string repeat abc 20] test binary-75.5 {binary decode uuencode} -body { - binary decode uuencode "``\$\"`P0``0(#" + binary decode uuencode ")``\$\"`P0``0(#" } -result "\0\1\2\3\4\0\1\2\3" test binary-75.6 {binary decode uuencode} -body { - string length [binary decode uuencode {`}] + string length [binary decode uuencode "`\n"] } -result 0 test binary-75.7 {binary decode uuencode} -body { - string length [binary decode uuencode {``}] + string length [binary decode uuencode "!`\n"] } -result 1 test binary-75.8 {binary decode uuencode} -body { - string length [binary decode uuencode {```}] + string length [binary decode uuencode "\"``\n"] } -result 2 test binary-75.9 {binary decode uuencode} -body { - string length [binary decode uuencode {````}] + string length [binary decode uuencode "#```\n"] } -result 3 test binary-75.10 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n[string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\n>[string repeat 86)C 10]" binary decode uuencode $s } -result [string repeat abc 20] test binary-75.11 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n [string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\n\t>\t[string repeat 86)C 10]\r" binary decode uuencode $s } -result [string repeat abc 20] test binary-75.12 {binary decode uuencode} -body { binary decode uuencode -strict "|86)C" } -returnCodes error -match glob -result {invalid uuencode character "|" at position 0} test binary-75.13 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]|[string repeat 86)C 10]" + set s ">[string repeat 86)C 10]|[string repeat 86)C 10]" binary decode uuencode -strict $s -} -returnCodes error -match glob -result {invalid uuencode character "|" at position 40} +} -returnCodes error -match glob -result {invalid uuencode character "|" at position 41} test binary-75.14 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n [string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\na[string repeat 86)C 10]" binary decode uuencode -strict $s } -returnCodes error -match glob -result {invalid uuencode character *} test binary-75.20 {binary decode uuencode} -body { - set r [binary decode uuencode 8] + set r [binary decode uuencode " 8"] list [string length $r] $r } -result {0 {}} test binary-75.21 {binary decode uuencode} -body { - set r [binary decode uuencode 86] + set r [binary decode uuencode "!86"] list [string length $r] $r } -result {1 a} test binary-75.22 {binary decode uuencode} -body { - set r [binary decode uuencode 86)] + set r [binary decode uuencode "\"86)"] list [string length $r] $r } -result {2 ab} test binary-75.23 {binary decode uuencode} -body { - set r [binary decode uuencode 86)C] + set r [binary decode uuencode "#86)C"] list [string length $r] $r } -result {3 abc} test binary-75.24 {binary decode uuencode} -body { - set s "04)\# " + set s "#04)\# " binary decode uuencode $s } -result ABC test binary-75.25 {binary decode uuencode} -body { - set s "04)\#z" + set s "#04)\#z" binary decode uuencode $s -} -returnCodes error -match glob -result {invalid uuencode character "z" at position 4} +} -returnCodes error -match glob -result {invalid uuencode character "z" at position 5} test binary-75.26 {binary decode uuencode} -body { string length [binary decode uuencode " "] } -result 0 -- cgit v0.12 From 826a355cc84e880287a692ccc1c3c48c915f5f4a Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 16 Sep 2013 08:52:12 +0000 Subject: Be careful: separator needs to be bytes, not internal-encoded. --- generic/tclBinary.c | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 2053319..114984f 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2586,13 +2586,15 @@ BinaryEncodeUu( unsigned char *data, *start, *cursor; int offset, count, rawLength, n, i, j, bits, index; int lineLength = 61; - const char *wrapchar = "\n"; - int wrapcharlen = 1; - enum {OPT_MAXLEN, OPT_WRAPCHAR }; + const unsigned char SingleNewline[] = { (unsigned char) '\n' }; + const unsigned char *wrapchar = SingleNewline; + int wrapcharlen = sizeof(SingleNewline); + enum { OPT_MAXLEN, OPT_WRAPCHAR }; static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; if (objc < 2 || objc%2 != 0) { - Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? ?-wrapchar char? data"); + Tcl_WrongNumArgs(interp, 1, objv, + "?-maxlen len? ?-wrapchar char? data"); return TCL_ERROR; } for (i = 1; i < objc-1; i += 2) { @@ -2613,7 +2615,7 @@ BinaryEncodeUu( } break; case OPT_WRAPCHAR: - wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); + wrapchar = Tcl_GetByteArrayFromObj(objv[i+1], &wrapcharlen); break; } } @@ -2628,7 +2630,8 @@ BinaryEncodeUu( data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); rawLength = (lineLength - 1) * 3 / 4; start = cursor = Tcl_SetByteArrayLength(resultObj, - (lineLength + wrapcharlen) * ((count + (rawLength - 1)) / rawLength)); + (lineLength + wrapcharlen) * + ((count + (rawLength - 1)) / rawLength)); n = bits = 0; /* @@ -2657,7 +2660,7 @@ BinaryEncodeUu( *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f]; bits = 0; } - for (j=0; j Date: Mon, 16 Sep 2013 09:03:50 +0000 Subject: Refactor to remove unused flexibility. --- generic/tclBinary.c | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 114984f..58583f4 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -142,9 +142,9 @@ static const EnsembleImplMap binaryMap[] = { { NULL, NULL, NULL, NULL, NULL, 0 } }; static const EnsembleImplMap encodeMap[] = { - { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, (ClientData)HexDigits, 0 }, + { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, { "uuencode", BinaryEncodeUu, NULL, NULL, NULL, 0 }, - { "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 }, + { "base64", BinaryEncode64, NULL, NULL, NULL, 0 }, { NULL, NULL, NULL, NULL, NULL, 0 } }; static const EnsembleImplMap decodeMap[] = { @@ -2315,7 +2315,6 @@ BinaryEncodeHex( Tcl_Obj *resultObj = NULL; unsigned char *data = NULL; unsigned char *cursor = NULL; - const char *digits = clientData; int offset = 0, count = 0; if (objc != 2) { @@ -2327,8 +2326,8 @@ BinaryEncodeHex( data = Tcl_GetByteArrayFromObj(objv[1], &count); cursor = Tcl_SetByteArrayLength(resultObj, count * 2); for (offset = 0; offset < count; ++offset) { - *cursor++ = digits[((data[offset] >> 4) & 0x0f)]; - *cursor++ = digits[(data[offset] & 0x0f)]; + *cursor++ = HexDigits[((data[offset] >> 4) & 0x0f)]; + *cursor++ = HexDigits[(data[offset] & 0x0f)]; } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -2478,7 +2477,6 @@ BinaryEncode64( { Tcl_Obj *resultObj; unsigned char *data, *cursor, *limit; - const char *digits = clientData; int maxlen = 0; const char *wrapchar = "\n"; int wrapcharlen = 1; @@ -2537,17 +2535,17 @@ BinaryEncode64( for (i = 0; i < 3 && offset+i < count; ++i) { d[i] = data[offset + i]; } - OUTPUT(digits[d[0] >> 2]); - OUTPUT(digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]); + OUTPUT(B64Digits[d[0] >> 2]); + OUTPUT(B64Digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]); if (offset+1 < count) { - OUTPUT(digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]); + OUTPUT(B64Digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]); } else { - OUTPUT(digits[64]); + OUTPUT(B64Digits[64]); } if (offset+2 < count) { - OUTPUT(digits[d[2] & 0x3f]); + OUTPUT(B64Digits[d[2] & 0x3f]); } else { - OUTPUT(digits[64]); + OUTPUT(B64Digits[64]); } } } -- cgit v0.12 From e1a2deb52347de47b6357eb9662c56ee98a4d81e Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 16 Sep 2013 23:18:54 +0000 Subject: [7b32d8d13b] Insert missing field initialization. --- generic/tclAssembly.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 100e9ef..946c729 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -2617,6 +2617,7 @@ AllocBB( bb->minStackDepth = 0; bb->maxStackDepth = 0; bb->finalStackDepth = 0; + bb->catchDepth = 0; bb->enclosingCatch = NULL; bb->foreignExceptionBase = -1; bb->foreignExceptionCount = 0; -- cgit v0.12 From 081808cdabb46c7e3f387d766ca6e58cc5c9af8f Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 17 Sep 2013 09:13:40 +0000 Subject: small improvements to the documentation --- doc/binary.n | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/doc/binary.n b/doc/binary.n index 0cdf465..cbbebd1 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -36,6 +36,13 @@ The \fBbinary encode\fR and \fBbinary decode\fR subcommands convert binary data to or from string encodings such as base64 (used in MIME messages for example). .VE 8.6 +.PP +Note that other operations on binary data, such as taking a subsequence of it, +getting its length, or reinterpreting it as a string in some encoding, are +done by other Tcl commands (respectively \fBstring range\fR, +\fBstring length\fR and \fBencoding convertfrom\fR in the example cases). A +binary string in Tcl is merely one where all the characters it contains are in +the range \eu0000\-\eu00FF. .SH "BINARY ENCODE AND DECODE" .VS 8.6 .PP @@ -64,7 +71,7 @@ Indicates that the output should be split into lines of no more than . Indicates that, when lines are split because of the \fB\-maxlen\fR option, \fIcharacter\fR should be used to separate lines. By default, this is a -newline character. +newline character, .QW \en . .PP During decoding, the following options are supported: @@ -95,7 +102,8 @@ between Unix systems and on USENET, but is less common these days, having been largely superseded by the \fBbase64\fR binary encoding. .RS .PP -During encoding, the following options are supported: +During encoding, the following options are supported (though changing them may +produce files that other implementations of decoders cannot process): .TP \fB\-maxlen \fIlength\fR . @@ -107,7 +115,7 @@ this must be in the range 3 to 85 due to limitations in the encoding. . Indicates that, when lines are split because of the \fB\-maxlen\fR option, \fIcharacter\fR should be used to separate lines. By default, this is a -newline character. +newline character, .QW \en . .PP During decoding, the following options are supported: @@ -859,6 +867,7 @@ architectures, use their textual representation (as produced by .PP This is a procedure to write a Tcl string to a binary-encoded channel as UTF-8 data preceded by a length word: +.PP .CS proc \fIwriteString\fR {channel string} { set data [encoding convertto utf-8 $string] @@ -869,6 +878,7 @@ proc \fIwriteString\fR {channel string} { .PP This procedure reads a string from a channel that was written by the previously presented \fIwriteString\fR procedure: +.PP .CS proc \fIreadString\fR {channel} { if {![\fBbinary scan\fR [read $channel 4] I length]} { @@ -881,6 +891,7 @@ proc \fIreadString\fR {channel} { .PP This converts the contents of a file (named in the variable \fIfilename\fR) to base64 and prints them: +.PP .CS set f [open $filename rb] set data [read $f] @@ -888,9 +899,10 @@ close $f puts [\fBbinary encode\fR base64 \-maxlen 64 $data] .CE .SH "SEE ALSO" -format(n), scan(n), tcl_platform(n) +encoding(n), format(n), scan(n), string(n), tcl_platform(n) .SH KEYWORDS binary, format, scan '\" Local Variables: '\" mode: nroff +'\" fill-column: 78 '\" End: -- cgit v0.12 From 485b7e865a78e8d32056d25dc181e4b19e07be0c Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 17 Sep 2013 09:20:58 +0000 Subject: ChangeLog entry --- ChangeLog | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/ChangeLog b/ChangeLog index 8e1a8b9..eaa5fc8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +2013-09-17 Donal Fellows + + * generic/tclBinary.c (BinaryEncodeUu, BinaryDecodeUu): [Bug 2152292]: + Corrected implementation of the core of uuencode handling so that the + line length processing is correctly applied. + ***POTENTIAL INCOMPATIBILITY*** + Existing code that was using the old versions and working around the + limitations will now need to do far less. The -maxlen option now has + strict limits on the range of supported lengths; this is a limitation + of the format itself. + 2013-09-09 Donal Fellows * generic/tclOOMethod.c (CloneProcedureMethod): [Bug 3609693]: Strip -- cgit v0.12 From 868b8031fd65e9786ac1484f3fe1261c176ad5c0 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 18 Sep 2013 12:32:26 +0000 Subject: Bump TclOO version to 1.0.1 --- ChangeLog | 25 +++++++++++++++---------- generic/tclOO.h | 2 +- generic/tclOOBasic.c | 2 +- generic/tclOODefineCmds.c | 2 +- tests/oo.test | 4 ++-- tests/ooNext2.test | 2 +- unix/tclooConfig.sh | 2 +- win/tclooConfig.sh | 2 +- 8 files changed, 23 insertions(+), 18 deletions(-) diff --git a/ChangeLog b/ChangeLog index eaa5fc8..3dc8c5e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,8 @@ -2013-09-17 Donal Fellows +2013-09-18 Donal Fellows + + Bump TclOO version to 1.0.1 for release. + +2013-09-17 Donal Fellows * generic/tclBinary.c (BinaryEncodeUu, BinaryDecodeUu): [Bug 2152292]: Corrected implementation of the core of uuencode handling so that the @@ -59,12 +63,13 @@ 2013-06-27 Jan Nijtmans - * generic/tclConfig.c: Bug [9b2e636361]: Tcl_CreateInterp() needs initialized - * generic/tclMain.c: encodings. + * generic/tclConfig.c: Bug [9b2e636361]: Tcl_CreateInterp() needs + * generic/tclMain.c: initialized encodings. 2013-06-18 Jan Nijtmans - * generic/tclEvent.c: Bug [3611974]: InitSubsystems multiple thread issue. + * generic/tclEvent.c: Bug [3611974]: InitSubsystems multiple thread + issue. 2013-06-17 Jan Nijtmans @@ -176,10 +181,10 @@ * generic/tclStubInit.c: Add support for Cygwin64, which has a 64-bit * generic/tclDecls.h: "long" type. Binary compatibility with win64 - requires that all stub entries use 32-bit long's, therefore the - need for various wrapper functions/macros. For Tcl 9 a better - solution is needed, but that cannot be done without introducing - binary incompatibility. + requires that all stub entries use 32-bit long's, therefore the need + for various wrapper functions/macros. For Tcl 9 a better solution is + needed, but that cannot be done without introducing binary + incompatibility. 2013-04-30 Andreas Kupries @@ -197,8 +202,8 @@ * generic/tclDecls.h: Implement Tcl_NewBooleanObj, Tcl_DbNewBooleanObj and Tcl_SetBooleanObj as macros using Tcl_NewIntObj, Tcl_DbNewLongObj - and Tcl_SetIntObj. Starting with Tcl 8.5, this is exactly the same, - it only eliminates code duplication. + and Tcl_SetIntObj. Starting with Tcl 8.5, this is exactly the same, it + only eliminates code duplication. * generic/tclInt.h: Eliminate use of NO_WIDE_TYPE everywhere: It's exactly the same as TCL_WIDE_INT_IS_LONG diff --git a/generic/tclOO.h b/generic/tclOO.h index cf253b1..d5ab8a0 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -39,7 +39,7 @@ extern const char *TclOOInitializeStubs( * win/tclooConfig.sh */ -#define TCLOO_VERSION "1.0" +#define TCLOO_VERSION "1.0.1" #define TCLOO_PATCHLEVEL TCLOO_VERSION /* diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index aba06a5..853e2ec 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -4,7 +4,7 @@ * This file contains implementations of the "simple" commands and * methods from the object-system core. * - * Copyright (c) 2005-2012 by Donal K. Fellows + * Copyright (c) 2005-2013 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index f0983cc..5a6c0ad 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -4,7 +4,7 @@ * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2012 by Donal K. Fellows + * Copyright (c) 2006-2013 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tests/oo.test b/tests/oo.test index 054bc46..37bbadb 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2,12 +2,12 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 2006-2012 Donal K. Fellows +# Copyright (c) 2006-2013 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0 +package require TclOO 1.0.1 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* diff --git a/tests/ooNext2.test b/tests/ooNext2.test index d77e8d1..a47aa91 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0 +package require TclOO 1.0.1 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* diff --git a/unix/tclooConfig.sh b/unix/tclooConfig.sh index 721825b..08cc4c5 100644 --- a/unix/tclooConfig.sh +++ b/unix/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.0 +TCLOO_VERSION=1.0.1 diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh index 721825b..08cc4c5 100644 --- a/win/tclooConfig.sh +++ b/win/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.0 +TCLOO_VERSION=1.0.1 -- cgit v0.12 From 5260904a408218366fe2ef7a780eea2dc5922c9b Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 04:11:01 +0000 Subject: [3487626] knownBug tests dict-23.2 and dist-24.21 already fixed on trunk. --- tests/dict.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/dict.test b/tests/dict.test index 02c9050..e898637 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1604,7 +1604,7 @@ test dict-23.1 {dict compilation crash: Bug 3487626} { } }} [linenumber]}} } 5 -test dict-23.2 {dict compilation crash: Bug 3487626} knownBug { +test dict-23.2 {dict compilation crash: Bug 3487626} { # Something isn't quite right in line number and continuation line # tracking; at time of writing, this test produces 7, not 5, which # indicates that the extra newlines in the non-script argument are @@ -1838,7 +1838,7 @@ test dict-24.20.1 {dict compilation crash: 'dict for' bug 3487626} { } }} [linenumber]}} } 5 -test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} knownBug { +test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} { apply {{} {apply {n { set e {} set k {} -- cgit v0.12 From 0467fcff78969cf483da62fc1c7b7cb9309cf16b Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 13:39:40 +0000 Subject: [31661d2135] Plug memory leak. --- generic/tclExecute.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e402634..4d7bdd5 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4327,7 +4327,7 @@ TEBCresume( if (listPtr->refCount == 1) { TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5))); - for (index=toIdx+1 ; indexelemCount = toIdx+1; -- cgit v0.12 From b9d177cec41c6ca4abcb019b38e7da7739ded8e7 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 19 Sep 2013 14:21:21 +0000 Subject: [3606943]: Corrected description of method search order. --- ChangeLog | 5 +++++ doc/next.n | 11 +++++++---- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/ChangeLog b/ChangeLog index 3dc8c5e..b144110 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2013-09-19 Donal Fellows + + * doc/next.n (METHOD SEARCH ORDER): Bug [3606943]: Corrected + description of method search order. + 2013-09-18 Donal Fellows Bump TclOO version to 1.0.1 for release. diff --git a/doc/next.n b/doc/next.n index 0ad752a..fe7bddf 100644 --- a/doc/next.n +++ b/doc/next.n @@ -62,14 +62,14 @@ The method chain is cached for future use. When constructing the method chain, method implementations are searched for in the following order: .IP [1] -In the object. -.IP [2] In the classes mixed into the object, in class traversal order. The list of mixins is checked in natural order. -.IP [3] +.IP [2] In the classes mixed into the classes of the object, with sources of mixing in being searched in class traversal order. Within each class, the list of mixins is processed in natural order. +.IP [3] +In the object itself. .IP [4] In the object's class. .IP [5] @@ -77,7 +77,10 @@ In the superclasses of the class, following each superclass in a depth-first fashion in the natural order of the superclass list. .PP Any particular method implementation always comes as \fIlate\fR in the -resulting list of implementations as possible. +resulting list of implementations as possible; this means that if some class, +A, is both mixed into a class, B, and is also a superclass of B, the instances +of B will always treat A as a superclass from the perspective of inheritance. +This is true even when the multiple inheritance is processed indirectly. .SS FILTERS .PP When an object has a list of filter names set upon it, or is an instance of a -- cgit v0.12 From b290b21a4427ac5d1584ad6fcf61e4934f1bf505 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 17:01:58 +0000 Subject: Line numbers wrong in compiled [dict exists]. --- generic/tclCompCmds.c | 7 +++---- tests/dict.test | 6 ++++++ 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 9829b9c..64c110d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1002,7 +1002,7 @@ TclCompileDictExistsCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i; + int i; DefineLineInformation; /* TIP #280 */ /* @@ -1015,17 +1015,16 @@ TclCompileDictExistsCmd( return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - numWords = parsePtr->numWords-1; /* * Now we do the code generation. */ - for (i=0 ; inumWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_EXISTS, numWords-1, envPtr); + TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } diff --git a/tests/dict.test b/tests/dict.test index 797ab46..6c254eb 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1899,6 +1899,12 @@ test dict-23.8 {CompileWord OBOE} { } [return [incr n -[linenumber]]] x {} }} [linenumber] } 1 +test dict-23.9 {CompileWord OBOE} { + apply {n { + dict exists {} {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} 1 rename linenumber {} test dict-24.22 {dict map results (non-compiled)} { -- cgit v0.12 From 91ec52b16e7cd903ca196560e5ddb1d5ca1c60a9 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 17:21:41 +0000 Subject: Line numbers wrong in compiled [dict with]. --- generic/tclCompCmds.c | 10 +++++----- tests/dict.test | 30 ++++++++++++++++++++++++++++++ 2 files changed, 35 insertions(+), 5 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 64c110d..7e6b6da 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1875,7 +1875,7 @@ TclCompileDictWithCmd( tokenPtr = TokenAfter(varTokenPtr); for (i=2 ; inumWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); @@ -1902,7 +1902,7 @@ TclCompileDictWithCmd( tokenPtr = varTokenPtr; for (i=1 ; inumWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); @@ -1916,7 +1916,7 @@ TclCompileDictWithCmd( * Case: Direct dict in non-simple var with empty body. */ - CompileWord(envPtr, varTokenPtr, interp, 0); + CompileWord(envPtr, varTokenPtr, interp, 1); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LOAD_STK, envPtr); PushStringLiteral(envPtr, ""); @@ -1951,13 +1951,13 @@ TclCompileDictWithCmd( */ if (dictVar == -1) { - CompileWord(envPtr, varTokenPtr, interp, 0); + CompileWord(envPtr, varTokenPtr, interp, 1); Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr); } tokenPtr = TokenAfter(varTokenPtr); if (gotPath) { for (i=2 ; inumWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); diff --git a/tests/dict.test b/tests/dict.test index 6c254eb..a583de8 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1905,6 +1905,36 @@ test dict-23.9 {CompileWord OBOE} { } [return [incr n -[linenumber]]] }} [linenumber] } 1 +test dict-23.10 {CompileWord OBOE} { + apply {n { + dict with foo {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.11 {CompileWord OBOE} { + apply {n { + dict with ::foo {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.12 {CompileWord OBOE} { + apply {n { + dict with {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.13 {CompileWord OBOE} { + apply {n { + dict with {*}{ + } [return [incr n -[linenumber]]] {bar} + }} [linenumber] +} 1 +test dict-23.14 {CompileWord OBOE} { + apply {n { + dict with foo {*}{ + } [return [incr n -[linenumber]]] {bar} + }} [linenumber] +} 1 rename linenumber {} test dict-24.22 {dict map results (non-compiled)} { -- cgit v0.12 From 7b3702821be88e66474de1c1b1aa84c381276668 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 18:53:01 +0000 Subject: Line numbers wrong in compiled [unset]. --- generic/tclCompCmdsGR.c | 1 + generic/tclCompCmdsSZ.c | 14 +++++++------- tests/var.test | 13 +++++++++++++ 3 files changed, 21 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 4e4a3af..43ea3d3 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -587,6 +587,7 @@ TclCompileInfoCommandsCmd( * that the result needs to be list-ified. */ + /* TODO: Just push the known value */ CompileWord(envPtr, tokenPtr, interp, 1); TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); TclEmitOpcode( INST_DUP, envPtr); diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index d1eb9db..6c55e2e 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2814,26 +2814,26 @@ TclCompileUnsetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int isScalar, localIndex, numWords, flags, i; + int isScalar, localIndex, flags, i; Tcl_Obj *leadingWord; DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ - numWords = parsePtr->numWords-1; flags = 1; + i = 1; varTokenPtr = TokenAfter(parsePtr->tokenPtr); leadingWord = Tcl_NewObj(); - if (numWords > 0 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { + if (parsePtr->numWords > 1 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { int len; const char *bytes = Tcl_GetStringFromObj(leadingWord, &len); if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { flags = 0; varTokenPtr = TokenAfter(varTokenPtr); - numWords--; + i++; } else if (len == 2 && !strncmp("--", bytes, 2)) { varTokenPtr = TokenAfter(varTokenPtr); - numWords--; + i++; } } else { /* @@ -2846,7 +2846,7 @@ TclCompileUnsetCmd( } TclDecrRefCount(leadingWord); - for (i=0 ; inumWords ; i++) { /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a @@ -2856,7 +2856,7 @@ TclCompileUnsetCmd( */ PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); + &localIndex, &isScalar, i); /* * Emit instructions to unset the variable. diff --git a/tests/var.test b/tests/var.test index 5939100..6d4be26 100644 --- a/tests/var.test +++ b/tests/var.test @@ -862,6 +862,19 @@ test var-20.8 {array set compilation correctness: Bug 3603163} -setup { }} array size x } -result 0 + +test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + set foo bar + unset foo {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 + catch {namespace delete ns} catch {unset arr} -- cgit v0.12 From f19c90364c590451e85ba125933b3aa1fd9acd20 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 19:02:42 +0000 Subject: comment --- generic/tclCompCmdsSZ.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 6c55e2e..468c1c0 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1864,6 +1864,7 @@ TclCompileTailcallCmd( } /* make room for the nsObjPtr */ + /* TODO: Doesn't this have to be a known value? */ CompileWord(envPtr, tokenPtr, interp, 0); for (i=1 ; inumWords ; i++) { tokenPtr = TokenAfter(tokenPtr); -- cgit v0.12 From cadf55303e72b696eedb9b29a469156b27fffa47 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 19 Sep 2013 19:37:05 +0000 Subject: [3970f54c4e]: Corrected regression in argument order processing in [unset]. --- generic/tclCompCmdsSZ.c | 40 +++++++++++++++++++++++++--------------- tests/var.test | 3 +++ 2 files changed, 28 insertions(+), 15 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 468c1c0..b90bff8 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2815,19 +2815,37 @@ TclCompileUnsetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int isScalar, localIndex, flags, i; - Tcl_Obj *leadingWord; + int isScalar, localIndex, flags = 1, i; DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ - flags = 1; - i = 1; + + /* + * Verify that all words are known at compile time so that we can handle + * them without needing to do a nasty push/rotate. [Bug 3970f54c4e] + */ + + for (i=1,varTokenPtr=parsePtr->tokenPtr ; inumWords ; i++) { + varTokenPtr = TokenAfter(varTokenPtr); + if (!TclWordKnownAtCompileTime(varTokenPtr, NULL)) { + return TCL_ERROR; + } + } + + /* + * Check for options; if they're present we'll know for sure because we + * know we're all constant arguments. + */ + varTokenPtr = TokenAfter(parsePtr->tokenPtr); - leadingWord = Tcl_NewObj(); - if (parsePtr->numWords > 1 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { + i = 1; + if (parsePtr->numWords > 1) { + Tcl_Obj *leadingWord = Tcl_NewObj(); + const char *bytes; int len; - const char *bytes = Tcl_GetStringFromObj(leadingWord, &len); + (void) TclWordKnownAtCompileTime(varTokenPtr, leadingWord); + bytes = Tcl_GetStringFromObj(leadingWord, &len); if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { flags = 0; varTokenPtr = TokenAfter(varTokenPtr); @@ -2836,16 +2854,8 @@ TclCompileUnsetCmd( varTokenPtr = TokenAfter(varTokenPtr); i++; } - } else { - /* - * Cannot guarantee that the first word is not '-nocomplain' at - * evaluation with reasonable effort, so spill to interpreted version. - */ - TclDecrRefCount(leadingWord); - return TCL_ERROR; } - TclDecrRefCount(leadingWord); for ( ; inumWords ; i++) { /* diff --git a/tests/var.test b/tests/var.test index 6d4be26..208b361 100644 --- a/tests/var.test +++ b/tests/var.test @@ -748,6 +748,9 @@ test var-15.1 {segfault in [unset], [Bug 735335]} { namespace eval test A useSomeUnlikelyNameHere namespace eval test unset useSomeUnlikelyNameHere } {} +test var-15.2 {compiled unset evaluation order, Bug 3970f54c4e} { + apply {{} {unset foo [return ok]}} +} ok test var-16.1 {CallVarTraces: save/restore interp error state} { trace add variable ::errorCode write " ;#" -- cgit v0.12 From 2139c0e39e6fb83eb76edc0088de73b9caa7cdb3 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 19 Sep 2013 22:37:06 +0000 Subject: [3970f54c4e]: Improved fix that is more tolerant of a single variable varname. --- generic/tclCompCmdsSZ.c | 82 ++++++++++++++++++++++++++++++++++--------------- 1 file changed, 57 insertions(+), 25 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index b90bff8..44cb66e 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2815,49 +2815,81 @@ TclCompileUnsetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int isScalar, localIndex, flags = 1, i; + int isScalar, localIndex, flags = 1, i, varCount = 0, haveFlags = 0; DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ /* - * Verify that all words are known at compile time so that we can handle - * them without needing to do a nasty push/rotate. [Bug 3970f54c4e] + * Verify that all words - except the first non-option one - are known at + * compile time so that we can handle them without needing to do a nasty + * push/rotate. [Bug 3970f54c4e] */ for (i=1,varTokenPtr=parsePtr->tokenPtr ; inumWords ; i++) { + Tcl_Obj *leadingWord = Tcl_NewObj(); + varTokenPtr = TokenAfter(varTokenPtr); - if (!TclWordKnownAtCompileTime(varTokenPtr, NULL)) { + if (!TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { + TclDecrRefCount(leadingWord); + + /* + * We can tolerate non-trivial substitutions in the first variable + * to be unset. If a '--' or '-nocomplain' was present, anything + * goes in that one place! (All subsequent variable names must be + * constants since we don't want to have to push them all first.) + */ + + if (varCount == 0) { + if (haveFlags) { + continue; + } + + /* + * In fact, we're OK as long as we're the first argument *and* + * we provably don't start with a '-'. If that is true, then + * even if everything else is varying, we still can't be a + * flag. Otherwise we'll spill to runtime to place a limit on + * the trickiness. + */ + + if (varTokenPtr->type == TCL_TOKEN_WORD + && varTokenPtr[1].type == TCL_TOKEN_TEXT + && varTokenPtr[1].size > 0 + && varTokenPtr[1].start[0] != '-') { + continue; + } + } return TCL_ERROR; } + if (i == 1) { + const char *bytes; + int len; + + bytes = Tcl_GetStringFromObj(leadingWord, &len); + if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { + flags = 0; + haveFlags = 1; + } else if (len == 2 && !strncmp("--", bytes, 2)) { + haveFlags = 1; + } else { + varCount++; + } + } else { + varCount++; + } + TclDecrRefCount(leadingWord); } /* - * Check for options; if they're present we'll know for sure because we - * know we're all constant arguments. + * Issue instructions to unset each of the named variables. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - i = 1; - if (parsePtr->numWords > 1) { - Tcl_Obj *leadingWord = Tcl_NewObj(); - const char *bytes; - int len; - - (void) TclWordKnownAtCompileTime(varTokenPtr, leadingWord); - bytes = Tcl_GetStringFromObj(leadingWord, &len); - if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { - flags = 0; - varTokenPtr = TokenAfter(varTokenPtr); - i++; - } else if (len == 2 && !strncmp("--", bytes, 2)) { - varTokenPtr = TokenAfter(varTokenPtr); - i++; - } - TclDecrRefCount(leadingWord); + if (haveFlags) { + varTokenPtr = TokenAfter(varTokenPtr); } - - for ( ; inumWords ; i++) { + for (i=1+haveFlags ; inumWords ; i++) { /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a -- cgit v0.12 From c4175e0434a242a24610b0c3a70214885b897006 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 20 Sep 2013 09:11:51 +0000 Subject: Make sure that panic's during finalization are handled by the custom panicproc not by the default panicproc, because stderr might not be available. When the default panicproc is in use, this doesn't make any difference. --- generic/tclEvent.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 686b80d..941d566 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1171,8 +1171,6 @@ Tcl_Finalize(void) TclFinalizeEncodingSubsystem(); - Tcl_SetPanicProc(NULL); - /* * Repeat finalization of the thread local storage once more. Although * this step is already done by the Tcl_FinalizeThread call above, series -- cgit v0.12 From b54c2a5958b12875dc5a32cc1f09da20e23b087d Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 23 Sep 2013 12:18:45 +0000 Subject: revert mistaken commit of experiment --- generic/tclIOUtil.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 6332453..6259216 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1944,7 +1944,7 @@ TclNREvalFile( iPtr->evalFlags |= TCL_EVAL_FILE; TclNRAddCallback(interp, EvalFileCallback, oldScriptFile, pathPtr, objPtr, NULL); - return TclNREvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, INT_MIN); + return TclNREvalObjEx(interp, objPtr, 0, NULL, INT_MIN); } static int -- cgit v0.12 From 38f8605a8d202951bbf792a4813b9b48a20910fb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 26 Sep 2013 14:27:37 +0000 Subject: Tcl_SetResult -> Tcl_SetObjResult --- generic/tclBinary.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 58583f4..4e977f2 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2500,7 +2500,8 @@ BinaryEncode64( return TCL_ERROR; } if (maxlen < 0) { - Tcl_SetResult(interp, "line length out of range", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "line length out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", "LINE_LENGTH", NULL); return TCL_ERROR; @@ -2606,7 +2607,8 @@ BinaryEncodeUu( return TCL_ERROR; } if (lineLength < 3 || lineLength > 85) { - Tcl_SetResult(interp, "line length out of range", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "line length out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", "LINE_LENGTH", NULL); return TCL_ERROR; -- cgit v0.12 From 790f8f7114d0cc7b44cbaddc66e36c877c9c55b6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 27 Sep 2013 09:18:36 +0000 Subject: Workaround for [http://sourceforge.net/p/mingw/bugs/2065/|MinGW bug #2065]. Both MinGW and MinGW-w64 (32-bit) are affected. Even though Win64 is not affected, adding -static-libgcc doesn't harm there, and we don't want to distrubute additional dll's with MinGW-compiled Tcl anyway. --- win/configure | 3 +-- win/tcl.m4 | 3 +-- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/win/configure b/win/configure index be9c98a..d09b588 100755 --- a/win/configure +++ b/win/configure @@ -3450,7 +3450,7 @@ echo "${ECHO_T}yes" >&6 if test "${GCC}" = "yes" ; then extra_cflags="-pipe" - extra_ldflags="-pipe" + extra_ldflags="-pipe -static-libgcc" echo "$as_me:$LINENO: checking for mingw32 version of gcc" >&5 echo $ECHO_N "checking for mingw32 version of gcc... $ECHO_C" >&6 if test "${ac_cv_win32+set}" = set; then @@ -3579,7 +3579,6 @@ echo "${ECHO_T}$ac_cv_municode" >&6 extra_ldflags="$extra_ldflags -municode" else extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS" - extra_ldflags="$extra_ldflags -static-libgcc" fi fi diff --git a/win/tcl.m4 b/win/tcl.m4 index 335494b..7ea7fad 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -634,7 +634,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ if test "${GCC}" = "yes" ; then extra_cflags="-pipe" - extra_ldflags="-pipe" + extra_ldflags="-pipe -static-libgcc" AC_CACHE_CHECK(for mingw32 version of gcc, ac_cv_win32, AC_TRY_COMPILE([ @@ -665,7 +665,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ extra_ldflags="$extra_ldflags -municode" else extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS" - extra_ldflags="$extra_ldflags -static-libgcc" fi fi -- cgit v0.12 From a5a2f896bb91053061b5a83f09cb0778c3b53e3b Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 27 Sep 2013 10:29:43 +0000 Subject: =?UTF-8?q?[219226]:=20Rewrote=20how=20::env=20is=20synchronized?= =?UTF-8?q?=20to=20the=20environment=20so=20it=20no=20longer=20smashes=20t?= =?UTF-8?q?he=20array=20or=20its=20elements=20flat,=20This=20affects=20tra?= =?UTF-8?q?ces=20on=20env,=20links=20to=20env,=20and=20iterations=20over?= =?UTF-8?q?=20env:=20it=20makes=20them=20work=20as=20na=C3=AFvely=20expect?= =?UTF-8?q?ed.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- generic/tclEnv.c | 81 +++++++++++++++++++++++++++++++++++++++++++++----------- generic/tclInt.h | 2 ++ generic/tclVar.c | 47 ++++++++++++++++++++++++++++++++ tests/env.test | 23 ++++++++++++++++ 4 files changed, 137 insertions(+), 16 deletions(-) diff --git a/generic/tclEnv.c b/generic/tclEnv.c index b5ae6ea..6a21947 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -76,36 +76,56 @@ TclSetupEnv( Tcl_Interp *interp) /* Interpreter whose "env" array is to be * managed. */ { + Var *varPtr, *arrayPtr; + Tcl_Obj *varNamePtr; Tcl_DString envString; - char *p1, *p2; - int i; + Tcl_HashTable namesHash; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; /* * Synchronize the values in the environ array with the contents of the * Tcl "env" variable. To do this: - * 1) Remove the trace that fires when the "env" var is unset. - * 2) Unset the "env" variable. - * 3) If there are no environ variables, create an empty "env" array. - * Otherwise populate the array with current values. - * 4) Add a trace that synchronizes the "env" array. + * 1) Remove the trace that fires when the "env" var is updated. + * 2) Find the existing contents of the "env", storing in a hash table. + * 3) Create/update elements for each environ variable, removing + * elements from the hash table as we go. + * 4) Remove the elements for each remaining entry in the hash table, + * which must have existed before yet have no analog in the environ + * variable. + * 5) Add a trace that synchronizes the "env" array. */ Tcl_UntraceVar2(interp, "env", NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL); - Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY); + /* + * Find out what elements are currently in the global env array. + */ - if (environ[0] == NULL) { - Tcl_Obj *varNamePtr; + TclNewLiteralStringObj(varNamePtr, "env"); + Tcl_IncrRefCount(varNamePtr); + Tcl_InitObjHashTable(&namesHash); + varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_GLOBAL_ONLY, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + TclFindArrayPtrElements(varPtr, &namesHash); + + /* + * Go through the environment array and transfer its values into Tcl. At + * the same time, remove those elements we add/update from the hash table + * of existing elements, so that after this part processes, that table + * will hold just the parts to remove. + */ + + if (environ[0] != NULL) { + int i; - TclNewLiteralStringObj(varNamePtr, "env"); - Tcl_IncrRefCount(varNamePtr); - TclArraySet(interp, varNamePtr, NULL); - Tcl_DecrRefCount(varNamePtr); - } else { Tcl_MutexLock(&envMutex); for (i = 0; environ[i] != NULL; i++) { + Tcl_Obj *obj1, *obj2; + char *p1, *p2; + p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString); p2 = strchr(p1, '='); if (p2 == NULL) { @@ -119,12 +139,41 @@ TclSetupEnv( } p2++; p2[-1] = '\0'; - Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY); + obj1 = Tcl_NewStringObj(p1, -1); + obj2 = Tcl_NewStringObj(p2, -1); Tcl_DStringFree(&envString); + + Tcl_IncrRefCount(obj1); + Tcl_IncrRefCount(obj2); + Tcl_ObjSetVar2(interp, varNamePtr, obj1, obj2, TCL_GLOBAL_ONLY); + hPtr = Tcl_FindHashEntry(&namesHash, obj1); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DecrRefCount(obj1); + Tcl_DecrRefCount(obj2); } Tcl_MutexUnlock(&envMutex); } + /* + * Delete those elements that existed in the array but which had no + * counterparts in the environment array. + */ + + for (hPtr=Tcl_FirstHashEntry(&namesHash, &search); hPtr!=NULL; + hPtr=Tcl_NextHashEntry(&search)) { + Tcl_Obj *elemName = Tcl_GetHashValue(hPtr); + + TclObjUnsetVar2(interp, varNamePtr, elemName, TCL_GLOBAL_ONLY); + } + Tcl_DeleteHashTable(&namesHash); + Tcl_DecrRefCount(varNamePtr); + + /* + * Re-establish the trace. + */ + Tcl_TraceVar2(interp, "env", NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL); diff --git a/generic/tclInt.h b/generic/tclInt.h index 380284f..feea6dd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3857,6 +3857,8 @@ MODULE_SCOPE int TclPtrUnsetVar(Tcl_Interp *interp, Var *varPtr, Tcl_Obj *part2Ptr, const int flags, int index); MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr); +MODULE_SCOPE void TclFindArrayPtrElements(Var *arrayPtr, + Tcl_HashTable *tablePtr); /* * The new extended interface to the variable traces. diff --git a/generic/tclVar.c b/generic/tclVar.c index af1a563..4694cd8 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -3850,6 +3850,53 @@ ArrayNamesCmd( /* *---------------------------------------------------------------------- * + * TclFindArrayPtrElements -- + * + * Fill out a hash table (which *must* use Tcl_Obj* keys) with an entry + * for each existing element of the given array. The provided hash table + * is assumed to be initially empty. + * + * Result: + * none + * + * Side effects: + * The keys of the array gain an extra reference. The supplied hash table + * has elements added to it. + * + *---------------------------------------------------------------------- + */ + +void +TclFindArrayPtrElements( + Var *arrayPtr, + Tcl_HashTable *tablePtr) +{ + Var *varPtr; + Tcl_HashSearch search; + + if ((arrayPtr == NULL) || !TclIsVarArray(arrayPtr) + || TclIsVarUndefined(arrayPtr)) { + return; + } + + for (varPtr=VarHashFirstVar(arrayPtr->value.tablePtr, &search); + varPtr!=NULL ; varPtr=VarHashNextVar(&search)) { + Tcl_HashEntry *hPtr; + Tcl_Obj *nameObj; + int dummy; + + if (TclIsVarUndefined(varPtr)) { + continue; + } + nameObj = VarHashGetKey(varPtr); + hPtr = Tcl_CreateHashEntry(tablePtr, (char *) nameObj, &dummy); + Tcl_SetHashValue(hPtr, nameObj); + } +} + +/* + *---------------------------------------------------------------------- + * * ArraySetCmd -- * * This object-based function is invoked to process the "array set" Tcl diff --git a/tests/env.test b/tests/env.test index fa76433..8115652 100644 --- a/tests/env.test +++ b/tests/env.test @@ -291,6 +291,29 @@ test env-6.1 {corner cases - add lots of env variables} {} { expr {[array size env] - $size} } 100 +test env-7.1 {[219226]: whole env array should not be unset by read} { + set n [array size env] + set s [array startsearch env] + while {[array anymore env $s]} { + array nextelement env $s + incr n -1 + } + array donesearch env $s + return $n +} 0 +test env-7.2 {[219226]: links to env elements should not be removed by read} { + apply {{} { + set ::env(test7_2) ok + upvar env(test7_2) elem + set ::env(PATH) + try { + return $elem + } finally { + unset ::env(test7_2) + } + }} +} ok + # Restore the environment variables at the end of the test. foreach name [array names env] { -- cgit v0.12 From ad4355066f0d4cdafaa288933a1517e6c79817ad Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 27 Sep 2013 17:33:17 +0000 Subject: Fix test source-4.1 --- generic/tclCompile.c | 6 +++++- tests/source.test | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f5c8d41..d15ef3a 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2229,7 +2229,7 @@ TclCompileTokens( Tcl_DString textBuffer; /* Holds concatenated chars from adjacent * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ char buffer[TCL_UTF_MAX]; - int i, numObjsToConcat, length; + int i, numObjsToConcat, length, adjust; unsigned char *entryCodeNext = envPtr->codeNext; #define NUM_STATIC_POS 20 int isLiteral, maxNumCL, numCL; @@ -2266,6 +2266,7 @@ TclCompileTokens( clPosition = ckalloc(maxNumCL * sizeof(int)); } + adjust = 0; Tcl_DStringInit(&textBuffer); numObjsToConcat = 0; for ( ; count > 0; count--, tokenPtr++) { @@ -2309,6 +2310,7 @@ TclCompileTokens( clPosition[numCL] = clPos; numCL ++; } + adjust++; } break; @@ -2331,8 +2333,10 @@ TclCompileTokens( numCL = 0; } + envPtr->line += adjust; TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr); + envPtr->line -= adjust; numObjsToConcat++; break; diff --git a/tests/source.test b/tests/source.test index 6ee2198..0235bd1 100644 --- a/tests/source.test +++ b/tests/source.test @@ -187,7 +187,7 @@ test source-3.5 {return with special code etc.} -setup { invoked from within "source $sourcefile"} {a b c}} -test source-4.1 {continuation line parsing} -constraints knownBug -setup { +test source-4.1 {continuation line parsing} -setup { set sourcefile [makeFile [string map {CL \\\n} { format %s "[dict get [info frame 0] type]:CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]" }] source.file] -- cgit v0.12 From 789e4ada24cc5f08a6d5300e354a752cdb066eec Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 28 Sep 2013 21:10:22 +0000 Subject: [dfc08326e3]: Corrected symbol export for TclOO to match Tcl so things work as expected in a static build. --- generic/tclOO.decls | 21 +++++++++++++++--- generic/tclOODecls.h | 58 ++++++++++++++++++++++++------------------------- generic/tclOOIntDecls.h | 32 +++++++++++++-------------- 3 files changed, 63 insertions(+), 48 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 31d1113..19d3f03 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -1,12 +1,25 @@ +# tclOO.decls -- +# +# This file contains the declarations for all supported public functions +# that are exported by the TclOO package that is embedded within the Tcl +# library via the stubs table. This file is used to generate the +# tclOODecls.h, tclOOIntDecls.h, tclOOStubInit.c, and tclOOStubLib.c +# files. +# +# Copyright (c) 2008-2013 by Donal K. Fellows. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + library tclOO +scspec EXTERN ###################################################################### -# public API +# Public API, exposed for general users of TclOO. # interface tclOO hooks tclOOInt -scspec TCLOOAPI declare 0 { Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, @@ -116,7 +129,9 @@ declare 28 { } ###################################################################### -# private API, exposed to support advanced OO systems that plug in on top +# Private API, exposed to support advanced OO systems that plug in on top of +# TclOO; not intended for general use and does not have any commitment to +# long-term support. # interface tclOOInt diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 58871c6..9cb704e 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -12,92 +12,92 @@ */ /* 0 */ -TCLOOAPI Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, +EXTERN Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 1 */ -TCLOOAPI Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); +EXTERN Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); /* 2 */ -TCLOOAPI Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); +EXTERN Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); /* 3 */ -TCLOOAPI Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); +EXTERN Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); /* 4 */ -TCLOOAPI Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, +EXTERN Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 5 */ -TCLOOAPI Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); +EXTERN Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); /* 6 */ -TCLOOAPI Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); +EXTERN Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); /* 7 */ -TCLOOAPI Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); +EXTERN Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); /* 8 */ -TCLOOAPI int Tcl_MethodIsPublic(Tcl_Method method); +EXTERN int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ -TCLOOAPI int Tcl_MethodIsType(Tcl_Method method, +EXTERN int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 10 */ -TCLOOAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); +EXTERN Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ -TCLOOAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, +EXTERN Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ -TCLOOAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, +EXTERN Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ -TCLOOAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, +EXTERN Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 14 */ -TCLOOAPI int Tcl_ObjectDeleted(Tcl_Object object); +EXTERN int Tcl_ObjectDeleted(Tcl_Object object); /* 15 */ -TCLOOAPI int Tcl_ObjectContextIsFiltering( +EXTERN int Tcl_ObjectContextIsFiltering( Tcl_ObjectContext context); /* 16 */ -TCLOOAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); +EXTERN Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); /* 17 */ -TCLOOAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); +EXTERN Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); /* 18 */ -TCLOOAPI int Tcl_ObjectContextSkippedArgs( +EXTERN int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ -TCLOOAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, +EXTERN ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ -TCLOOAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, +EXTERN void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 21 */ -TCLOOAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, +EXTERN ClientData Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ -TCLOOAPI void Tcl_ObjectSetMetadata(Tcl_Object object, +EXTERN void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 23 */ -TCLOOAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, +EXTERN int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 24 */ -TCLOOAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( +EXTERN Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( Tcl_Object object); /* 25 */ -TCLOOAPI void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, +EXTERN void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 26 */ -TCLOOAPI void Tcl_ClassSetConstructor(Tcl_Interp *interp, +EXTERN void Tcl_ClassSetConstructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ -TCLOOAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, +EXTERN void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 28 */ -TCLOOAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, +EXTERN Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); typedef struct { diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index acafb18..834d8cb 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -12,46 +12,46 @@ */ /* 0 */ -TCLOOAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); +EXTERN Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); /* 1 */ -TCLOOAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, +EXTERN Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 2 */ -TCLOOAPI Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, +EXTERN Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 3 */ -TCLOOAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, +EXTERN Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */ -TCLOOAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, +EXTERN Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 5 */ -TCLOOAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, +EXTERN int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 6 */ -TCLOOAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr); +EXTERN int TclOOIsReachable(Class *targetPtr, Class *startPtr); /* 7 */ -TCLOOAPI Method * TclOONewForwardMethod(Tcl_Interp *interp, +EXTERN Method * TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */ -TCLOOAPI Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, +EXTERN Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 9 */ -TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, +EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -60,7 +60,7 @@ TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ -TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, +EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -69,22 +69,22 @@ TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 11 */ -TCLOOAPI int TclOOInvokeObject(Tcl_Interp *interp, +EXTERN int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 12 */ -TCLOOAPI void TclOOObjectSetFilters(Object *oPtr, int numFilters, +EXTERN void TclOOObjectSetFilters(Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */ -TCLOOAPI void TclOOClassSetFilters(Tcl_Interp *interp, +EXTERN void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 14 */ -TCLOOAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins, +EXTERN void TclOOObjectSetMixins(Object *oPtr, int numMixins, Class *const *mixins); /* 15 */ -TCLOOAPI void TclOOClassSetMixins(Tcl_Interp *interp, +EXTERN void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); -- cgit v0.12 From 6a1cc41ccac84140abbe6011995eefbf2e8a4435 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 28 Sep 2013 22:52:11 +0000 Subject: typo; spotted by stu --- doc/Class.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/Class.3 b/doc/Class.3 index 28cea9b..febe703 100644 --- a/doc/Class.3 +++ b/doc/Class.3 @@ -111,7 +111,7 @@ function. Note that the Tcl_Obj reference returned by \fBTcl_GetObjectName\fR is a shared reference. .PP Instances of classes are created using \fBTcl_NewObjectInstance\fR, which -takes creates an object from any class (and which is internally called by both +creates an object from any class (and which is internally called by both the \fBcreate\fR and \fBnew\fR methods of the \fBoo::class\fR class). It takes parameters that optionally give the name of the object and namespace to create, and which describe the arguments to pass to the class's constructor -- cgit v0.12 From 11fdcc3fedcd680e93a93d28bf862d388ada3f9d Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 30 Sep 2013 03:00:06 +0000 Subject: First attempt at [string trim] compilation. --- generic/tclAssembly.c | 5 +- generic/tclCmdMZ.c | 8 +-- generic/tclCompCmdsSZ.c | 135 ++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclCompile.c | 11 ++++ generic/tclCompile.h | 6 ++- generic/tclExecute.c | 33 ++++++++++++ generic/tclInt.h | 9 ++++ 7 files changed, 202 insertions(+), 5 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 946c729..659f483 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -462,6 +462,8 @@ static const TalInstDesc TalInstructionTable[] = { {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1}, {"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1}, + {"strtrimLeft", ASSEM_1BYTE, INST_STRTRIM_LEFT, 2, 1}, + {"strtrimRight", ASSEM_1BYTE, INST_STRTRIM_RIGHT, 2, 1}, {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, {"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1}, {"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1}, @@ -502,7 +504,8 @@ static const unsigned char NonThrowingByteCodes[] = { INST_COROUTINE_NAME, /* 149 */ INST_NS_CURRENT, /* 151 */ INST_INFO_LEVEL_NUM, /* 152 */ - INST_RESOLVE_COMMAND /* 154 */ + INST_RESOLVE_COMMAND, /* 154 */ + INST_STRTRIM_LEFT, INST_STRTRIM_RIGHT /* 166,167 */ }; /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 5087fbb..2b5e995 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -35,6 +35,8 @@ static int UniCharIsHexDigit(int character); /* * Default set of characters to trim in [string trim] and friends. This is a * UTF-8 literal string containing all Unicode space characters [TIP #413] + * + * Synch with tclCompCmdsSZ.c */ #define DEFAULT_TRIM_SET \ @@ -3342,9 +3344,9 @@ TclInitStringCmd( {"tolower", StringLowerCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, {"toupper", StringUpperCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, {"totitle", StringTitleCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, - {"trim", StringTrimCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"trimleft", StringTrimLCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"trimright", StringTrimRCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"trim", StringTrimCmd, TclCompileStringTrimCmd, NULL, NULL, 0}, + {"trimleft", StringTrimLCmd, TclCompileStringTrimLCmd, NULL, NULL, 0}, + {"trimright", StringTrimRCmd, TclCompileStringTrimRCmd, NULL, NULL, 0}, {"wordend", StringEndCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"wordstart", StringStartCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 44cb66e..0177b2d 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -640,6 +640,141 @@ TclCompileStringRangeCmd( OP( STR_RANGE); return TCL_OK; } + +/* + * Synch with tclCmdMZ.c + */ + +#define DEFAULT_TRIM_SET \ + "\x09\x0a\x0b\x0c\x0d " /* ASCII */\ + "\xc0\x80" /* nul (U+0000) */\ + "\xc2\x85" /* next line (U+0085) */\ + "\xc2\xa0" /* non-breaking space (U+00a0) */\ + "\xe1\x9a\x80" /* ogham space mark (U+1680) */ \ + "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */\ + "\xe2\x80\x80" /* en quad (U+2000) */\ + "\xe2\x80\x81" /* em quad (U+2001) */\ + "\xe2\x80\x82" /* en space (U+2002) */\ + "\xe2\x80\x83" /* em space (U+2003) */\ + "\xe2\x80\x84" /* three-per-em space (U+2004) */\ + "\xe2\x80\x85" /* four-per-em space (U+2005) */\ + "\xe2\x80\x86" /* six-per-em space (U+2006) */\ + "\xe2\x80\x87" /* figure space (U+2007) */\ + "\xe2\x80\x88" /* punctuation space (U+2008) */\ + "\xe2\x80\x89" /* thin space (U+2009) */\ + "\xe2\x80\x8a" /* hair space (U+200a) */\ + "\xe2\x80\x8b" /* zero width space (U+200b) */\ + "\xe2\x80\xa8" /* line separator (U+2028) */\ + "\xe2\x80\xa9" /* paragraph separator (U+2029) */\ + "\xe2\x80\xaf" /* narrow no-break space (U+202f) */\ + "\xe2\x81\x9f" /* medium mathematical space (U+205f) */\ + "\xe2\x81\xa0" /* word joiner (U+2060) */\ + "\xe3\x80\x80" /* ideographic space (U+3000) */\ + "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ + +int +TclCompileStringTrimLCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + if (parsePtr->numWords == 3) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + } else { + PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); + } + OP( STRTRIM_LEFT); + return TCL_OK; +} + +int +TclCompileStringTrimRCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + if (parsePtr->numWords == 3) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + } else { + PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); + } + OP( STRTRIM_RIGHT); + return TCL_OK; +} + +int +TclCompileStringTrimCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + Tcl_Obj *objPtr; + + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + if (parsePtr->numWords == 3) { + tokenPtr = TokenAfter(tokenPtr); + TclNewObj(objPtr); + if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + int len; + const char *p = Tcl_GetStringFromObj(objPtr, &len); + + PushLiteral(envPtr, p, len); + OP( STRTRIM_LEFT); + PushLiteral(envPtr, p, len); + OP( STRTRIM_RIGHT); + } else { + CompileWord(envPtr, tokenPtr, interp, 2); + OP4( REVERSE, 2); + OP4( OVER, 1); + OP( STRTRIM_LEFT); + OP4( REVERSE, 2); + OP( STRTRIM_RIGHT); + } + TclDecrRefCount(objPtr); + } else { + PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); + OP( STRTRIM_LEFT); + PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); + OP( STRTRIM_RIGHT); + } + return TCL_OK; +} /* *---------------------------------------------------------------------- diff --git a/generic/tclCompile.c b/generic/tclCompile.c index d15ef3a..cdedbda 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -545,6 +545,17 @@ InstructionDesc const tclInstructionTable[] = { /* Drops an element from the auxiliary stack, popping stack elements * until the matching stack depth is reached. */ + {"strtrimLeft", 1, -1, 0, {OPERAND_NONE}}, + /* [string trimleft] core: removes the characters (designated by the + * value at the top of the stack) from the left of the string and + * pushes the resulting string. + * Stack: ... string charset => ... trimmedString */ + {"strtrimRight", 1, -1, 0, {OPERAND_NONE}}, + /* [string trimright] core: removes the characters (designated by the + * value at the top of the stack) from the right of the string and + * pushes the resulting string. + * Stack: ... string charset => ... trimmedString */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5660055..08eb393 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -768,8 +768,12 @@ typedef struct ByteCode { #define INST_EXPAND_DROP 165 +/* For compilation of [string trim] and related */ +#define INST_STRTRIM_LEFT 166 +#define INST_STRTRIM_RIGHT 167 + /* The last opcode */ -#define LAST_INST_OPCODE 165 +#define LAST_INST_OPCODE 167 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0ca393b..b4785bf 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5252,6 +5252,39 @@ TEBCresume( objResultPtr = TCONST(match); NEXT_INST_F(0, 2, 1); + { + const char *string1, *string2; + + case INST_STRTRIM_LEFT: + valuePtr = OBJ_UNDER_TOS; /* String */ + value2Ptr = OBJ_AT_TOS; /* TrimSet */ + string2 = TclGetStringFromObj(value2Ptr, &length2); + string1 = TclGetStringFromObj(valuePtr, &length); + match = TclTrimLeft(string1, length, string2, length2); + if (match == 0) { + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), + valuePtr); + NEXT_INST_F(1, 1, 0); + } else { + objResultPtr = Tcl_NewStringObj(string1+match, length-match); + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), + objResultPtr); + NEXT_INST_F(1, 2, 1); + } + case INST_STRTRIM_RIGHT: + valuePtr = OBJ_UNDER_TOS; /* String */ + value2Ptr = OBJ_AT_TOS; /* TrimSet */ + string2 = TclGetStringFromObj(value2Ptr, &length2); + string1 = TclGetStringFromObj(valuePtr, &length); + match = TclTrimRight(string1, length, string2, length2); + if (match == 0) { + NEXT_INST_F(1, 1, 0); + } else { + objResultPtr = Tcl_NewStringObj(string1, length-match); + NEXT_INST_F(1, 2, 1); + } + } + case INST_REGEXP: cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */ valuePtr = OBJ_AT_TOS; /* String */ diff --git a/generic/tclInt.h b/generic/tclInt.h index feea6dd..2312734 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3614,6 +3614,15 @@ MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringRangeCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringTrimCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringTrimLCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringTrimRCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From 5d83a3919d8912254cb477b87abab826cf78bc53 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 30 Sep 2013 09:03:20 +0000 Subject: Fix [f51efe99a7] by reverting [371bcd0714] --- generic/tclOO.decls | 21 +++--------------- generic/tclOODecls.h | 58 ++++++++++++++++++++++++------------------------- generic/tclOOIntDecls.h | 32 +++++++++++++-------------- 3 files changed, 48 insertions(+), 63 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 19d3f03..31d1113 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -1,25 +1,12 @@ -# tclOO.decls -- -# -# This file contains the declarations for all supported public functions -# that are exported by the TclOO package that is embedded within the Tcl -# library via the stubs table. This file is used to generate the -# tclOODecls.h, tclOOIntDecls.h, tclOOStubInit.c, and tclOOStubLib.c -# files. -# -# Copyright (c) 2008-2013 by Donal K. Fellows. -# -# See the file "license.terms" for information on usage and redistribution of -# this file, and for a DISCLAIMER OF ALL WARRANTIES. - library tclOO -scspec EXTERN ###################################################################### -# Public API, exposed for general users of TclOO. +# public API # interface tclOO hooks tclOOInt +scspec TCLOOAPI declare 0 { Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, @@ -129,9 +116,7 @@ declare 28 { } ###################################################################### -# Private API, exposed to support advanced OO systems that plug in on top of -# TclOO; not intended for general use and does not have any commitment to -# long-term support. +# private API, exposed to support advanced OO systems that plug in on top # interface tclOOInt diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 9cb704e..58871c6 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -12,92 +12,92 @@ */ /* 0 */ -EXTERN Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, +TCLOOAPI Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 1 */ -EXTERN Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); +TCLOOAPI Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); /* 2 */ -EXTERN Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); +TCLOOAPI Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); /* 3 */ -EXTERN Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); +TCLOOAPI Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); /* 4 */ -EXTERN Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, +TCLOOAPI Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 5 */ -EXTERN Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); +TCLOOAPI Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); /* 6 */ -EXTERN Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); +TCLOOAPI Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); /* 7 */ -EXTERN Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); +TCLOOAPI Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); /* 8 */ -EXTERN int Tcl_MethodIsPublic(Tcl_Method method); +TCLOOAPI int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ -EXTERN int Tcl_MethodIsType(Tcl_Method method, +TCLOOAPI int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 10 */ -EXTERN Tcl_Obj * Tcl_MethodName(Tcl_Method method); +TCLOOAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ -EXTERN Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, +TCLOOAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ -EXTERN Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, +TCLOOAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ -EXTERN Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, +TCLOOAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 14 */ -EXTERN int Tcl_ObjectDeleted(Tcl_Object object); +TCLOOAPI int Tcl_ObjectDeleted(Tcl_Object object); /* 15 */ -EXTERN int Tcl_ObjectContextIsFiltering( +TCLOOAPI int Tcl_ObjectContextIsFiltering( Tcl_ObjectContext context); /* 16 */ -EXTERN Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); +TCLOOAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); /* 17 */ -EXTERN Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); +TCLOOAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); /* 18 */ -EXTERN int Tcl_ObjectContextSkippedArgs( +TCLOOAPI int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ -EXTERN ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, +TCLOOAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ -EXTERN void Tcl_ClassSetMetadata(Tcl_Class clazz, +TCLOOAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 21 */ -EXTERN ClientData Tcl_ObjectGetMetadata(Tcl_Object object, +TCLOOAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ -EXTERN void Tcl_ObjectSetMetadata(Tcl_Object object, +TCLOOAPI void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 23 */ -EXTERN int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, +TCLOOAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 24 */ -EXTERN Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( +TCLOOAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( Tcl_Object object); /* 25 */ -EXTERN void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, +TCLOOAPI void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 26 */ -EXTERN void Tcl_ClassSetConstructor(Tcl_Interp *interp, +TCLOOAPI void Tcl_ClassSetConstructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ -EXTERN void Tcl_ClassSetDestructor(Tcl_Interp *interp, +TCLOOAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 28 */ -EXTERN Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, +TCLOOAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); typedef struct { diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index 834d8cb..acafb18 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -12,46 +12,46 @@ */ /* 0 */ -EXTERN Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); +TCLOOAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); /* 1 */ -EXTERN Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, +TCLOOAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 2 */ -EXTERN Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, +TCLOOAPI Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 3 */ -EXTERN Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, +TCLOOAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */ -EXTERN Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, +TCLOOAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 5 */ -EXTERN int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, +TCLOOAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 6 */ -EXTERN int TclOOIsReachable(Class *targetPtr, Class *startPtr); +TCLOOAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr); /* 7 */ -EXTERN Method * TclOONewForwardMethod(Tcl_Interp *interp, +TCLOOAPI Method * TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */ -EXTERN Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, +TCLOOAPI Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 9 */ -EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, +TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -60,7 +60,7 @@ EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ -EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, +TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -69,22 +69,22 @@ EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 11 */ -EXTERN int TclOOInvokeObject(Tcl_Interp *interp, +TCLOOAPI int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 12 */ -EXTERN void TclOOObjectSetFilters(Object *oPtr, int numFilters, +TCLOOAPI void TclOOObjectSetFilters(Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */ -EXTERN void TclOOClassSetFilters(Tcl_Interp *interp, +TCLOOAPI void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 14 */ -EXTERN void TclOOObjectSetMixins(Object *oPtr, int numMixins, +TCLOOAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins, Class *const *mixins); /* 15 */ -EXTERN void TclOOClassSetMixins(Tcl_Interp *interp, +TCLOOAPI void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); -- cgit v0.12 From 09b2762b8a6317ae6ef595df2c9dd239fd4749b3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 30 Sep 2013 09:38:49 +0000 Subject: Restore copyright assignments and some improved comments in tclOO.decls: previous commit was a blind revert of [371bcd0714], but those changes should not have been reverted. --- generic/tclOO.decls | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 31d1113..f22390e 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -1,12 +1,25 @@ +# tclOO.decls -- +# +# This file contains the declarations for all supported public functions +# that are exported by the TclOO package that is embedded within the Tcl +# library via the stubs table. This file is used to generate the +# tclOODecls.h, tclOOIntDecls.h, tclOOStubInit.c, and tclOOStubLib.c +# files. +# +# Copyright (c) 2008-2013 by Donal K. Fellows. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + library tclOO +scspec TCLOOAPI ###################################################################### -# public API +# Public API, exposed for general users of TclOO. # interface tclOO hooks tclOOInt -scspec TCLOOAPI declare 0 { Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, @@ -116,7 +129,9 @@ declare 28 { } ###################################################################### -# private API, exposed to support advanced OO systems that plug in on top +# Private API, exposed to support advanced OO systems that plug in on top of +# TclOO; not intended for general use and does not have any commitment to +# long-term support. # interface tclOOInt -- cgit v0.12 From b43170300d1edfb68bdc87f81aa4399d909177ee Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Oct 2013 08:46:29 +0000 Subject: Expand subset of lreplace functionality that is compiled. --- generic/tclCompCmdsGR.c | 159 ++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 142 insertions(+), 17 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 43ea3d3..e695068 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1430,9 +1430,9 @@ TclCompileLreplaceCmd( Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ Tcl_Obj *tmpObj; - int idx1, idx2, result, guaranteedDropAll = 0; + int idx1, idx2, result, i, offset; - if (parsePtr->numWords != 4) { + if (parsePtr->numWords < 4) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1492,38 +1492,163 @@ TclCompileLreplaceCmd( } /* - * Sanity check: can only issue when we're removing a range at one or - * other end of the list. If we're at one end or the other, convert the - * indices into the equivalent for an [lrange]. + * Work out what this [lreplace] is actually doing. */ + tmpObj = NULL; + CompileWord(envPtr, listTokenPtr, interp, 1); + if (parsePtr->numWords == 4) { + if (idx1 == 0) { + if (idx2 == -2) { + goto dropAll; + } + idx1 = idx2 + 1; + idx2 = -2; + goto dropEnd; + } else if (idx2 == -2) { + idx2 = idx1 - 1; + idx1 = 0; + goto dropEnd; + } else { + if (idx1 > 0) { + tmpObj = Tcl_NewIntObj(idx1); + Tcl_IncrRefCount(tmpObj); + } + goto dropRange; + } + } + + tokenPtr = TokenAfter(tokenPtr); + for (i=4 ; inumWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt4( INST_LIST, i - 4, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); if (idx1 == 0) { if (idx2 == -2) { - guaranteedDropAll = 1; + goto replaceAll; } idx1 = idx2 + 1; idx2 = -2; + goto replaceHead; } else if (idx2 == -2) { idx2 = idx1 - 1; idx1 = 0; + goto replaceTail; } else { - return TCL_ERROR; + if (idx1 > 0 && idx2 > 0 && idx2 < idx1) { + idx2 = idx1 - 1; + } else if (idx1 < 0 && idx2 < 0 && idx2 < idx1) { + idx2 = idx1 - 1; + } + if (idx1 > 0) { + tmpObj = Tcl_NewIntObj(idx1); + Tcl_IncrRefCount(tmpObj); + } + goto replaceRange; } /* - * Issue instructions. It's not safe to skip doing the LIST_RANGE, as - * we've not proved that the 'list' argument is really a list. Not that it - * is worth trying to do that given current knowledge. + * Issue instructions to perform the operations relating to configurations + * that just drop. The only argument pushed on the stack is the list to + * operate on. */ - CompileWord(envPtr, listTokenPtr, interp, 1); - if (guaranteedDropAll) { + dropAll: + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + PushStringLiteral(envPtr, ""); + goto done; + + dropEnd: + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); + TclEmitInt4( idx2, envPtr); + goto done; + + dropRange: + if (tmpObj != NULL) { + TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LIST_LENGTH, envPtr); - TclEmitOpcode( INST_POP, envPtr); - PushStringLiteral(envPtr, ""); - } else { - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); - TclEmitInt4( idx2, envPtr); + TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr); + TclEmitOpcode( INST_GT, envPtr); + offset = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( + "list doesn't contain element %d", idx1), NULL), envPtr); + CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, + Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, + envPtr->codeStart + offset + 1); + } + TclEmitOpcode( INST_DUP, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( idx1 - 1, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx2 + 1, envPtr); + TclEmitInt4( -2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + goto done; + + /* + * Issue instructions to perform the operations relating to configurations + * that do real replacement. All arguments are pushed and assembled into a + * pair: the list of values to replace with, and the list to do the + * surgery on. + */ + + replaceAll: + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + goto done; + + replaceHead: + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); + TclEmitInt4( idx2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + goto done; + + replaceTail: + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); + TclEmitInt4( idx2, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + goto done; + + replaceRange: + if (tmpObj != NULL) { + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr); + TclEmitOpcode( INST_GT, envPtr); + offset = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( + "list doesn't contain element %d", idx1), NULL), envPtr); + CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, + Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, + envPtr->codeStart + offset + 1); + } + TclEmitOpcode( INST_DUP, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( idx1 - 1, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx2 + 1, envPtr); + TclEmitInt4( -2, envPtr); + TclEmitInstInt4( INST_REVERSE, 3, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + goto done; + + /* + * Clean up the allocated memory. + */ + + done: + if (tmpObj != NULL) { + Tcl_DecrRefCount(tmpObj); } return TCL_OK; } -- cgit v0.12 From 6671b7930273fc4c18dedbe929e2f3d67e1dedf0 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Oct 2013 09:41:01 +0000 Subject: Fix TclOO API export rules. --- generic/tclOO.decls | 1 - generic/tclOO.h | 33 ++++++++++++----------- generic/tclOODecls.h | 72 +++++++++++++++++++++++++++++-------------------- generic/tclOOIntDecls.h | 46 ++++++++++++++++++++----------- 4 files changed, 91 insertions(+), 61 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index f22390e..4f1987c 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -12,7 +12,6 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. library tclOO -scspec TCLOOAPI ###################################################################### # Public API, exposed for general users of TclOO. diff --git a/generic/tclOO.h b/generic/tclOO.h index d5ab8a0..4a6cda7 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -12,21 +12,6 @@ #ifndef TCLOO_H_INCLUDED #define TCLOO_H_INCLUDED -#include "tcl.h" - -#ifndef TCLOOAPI -# if defined(BUILD_tcl) || defined(BUILD_TclOO) -# define TCLOOAPI MODULE_SCOPE -# else -# define TCLOOAPI extern -# undef USE_TCLOO_STUBS -# define USE_TCLOO_STUBS 1 -# endif -#endif - -extern const char *TclOOInitializeStubs( - Tcl_Interp *, const char *version); -#define Tcl_OOInitStubs(interp) TclOOInitializeStubs((interp), TCLOO_VERSION) /* * Be careful when it comes to versioning; need to make sure that the @@ -42,6 +27,21 @@ extern const char *TclOOInitializeStubs( #define TCLOO_VERSION "1.0.1" #define TCLOO_PATCHLEVEL TCLOO_VERSION +#include "tcl.h" + +/* + * For C++ compilers, use extern "C" + */ + +#ifdef __cplusplus +extern "C" { +#endif + +extern const char *TclOOInitializeStubs( + Tcl_Interp *, const char *version); +#define Tcl_OOInitStubs(interp) \ + TclOOInitializeStubs((interp), TCLOO_VERSION) + /* * These are opaque types. */ @@ -130,6 +130,9 @@ typedef struct { #include "tclOODecls.h" +#ifdef __cplusplus +} +#endif #endif /* diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 58871c6..c2a5615 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -5,6 +5,17 @@ #ifndef _TCLOODECLS #define _TCLOODECLS +#undef TCL_STORAGE_CLASS +#ifdef BUILD_tcl +# define TCL_STORAGE_CLASS DLLEXPORT +#else +# ifdef USE_TCL_STUBS +# define TCL_STORAGE_CLASS +# else +# define TCL_STORAGE_CLASS DLLIMPORT +# endif +#endif + /* !BEGIN!: Do not edit below this line. */ /* @@ -12,92 +23,92 @@ */ /* 0 */ -TCLOOAPI Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, +EXTERN Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 1 */ -TCLOOAPI Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); +EXTERN Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); /* 2 */ -TCLOOAPI Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); +EXTERN Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); /* 3 */ -TCLOOAPI Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); +EXTERN Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); /* 4 */ -TCLOOAPI Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, +EXTERN Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 5 */ -TCLOOAPI Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); +EXTERN Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); /* 6 */ -TCLOOAPI Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); +EXTERN Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); /* 7 */ -TCLOOAPI Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); +EXTERN Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); /* 8 */ -TCLOOAPI int Tcl_MethodIsPublic(Tcl_Method method); +EXTERN int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ -TCLOOAPI int Tcl_MethodIsType(Tcl_Method method, +EXTERN int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 10 */ -TCLOOAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); +EXTERN Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ -TCLOOAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, +EXTERN Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ -TCLOOAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, +EXTERN Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ -TCLOOAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, +EXTERN Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 14 */ -TCLOOAPI int Tcl_ObjectDeleted(Tcl_Object object); +EXTERN int Tcl_ObjectDeleted(Tcl_Object object); /* 15 */ -TCLOOAPI int Tcl_ObjectContextIsFiltering( +EXTERN int Tcl_ObjectContextIsFiltering( Tcl_ObjectContext context); /* 16 */ -TCLOOAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); +EXTERN Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); /* 17 */ -TCLOOAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); +EXTERN Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); /* 18 */ -TCLOOAPI int Tcl_ObjectContextSkippedArgs( +EXTERN int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ -TCLOOAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, +EXTERN ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ -TCLOOAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, +EXTERN void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 21 */ -TCLOOAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, +EXTERN ClientData Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ -TCLOOAPI void Tcl_ObjectSetMetadata(Tcl_Object object, +EXTERN void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 23 */ -TCLOOAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, +EXTERN int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 24 */ -TCLOOAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( +EXTERN Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( Tcl_Object object); /* 25 */ -TCLOOAPI void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, +EXTERN void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 26 */ -TCLOOAPI void Tcl_ClassSetConstructor(Tcl_Interp *interp, +EXTERN void Tcl_ClassSetConstructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ -TCLOOAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, +EXTERN void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 28 */ -TCLOOAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, +EXTERN Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); typedef struct { @@ -215,4 +226,7 @@ extern const TclOOStubs *tclOOStubsPtr; #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLOODECLS */ diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index acafb18..f0e3ee5 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -5,6 +5,17 @@ #ifndef _TCLOOINTDECLS #define _TCLOOINTDECLS +#undef TCL_STORAGE_CLASS +#ifdef BUILD_tcl +# define TCL_STORAGE_CLASS DLLEXPORT +#else +# ifdef USE_TCL_STUBS +# define TCL_STORAGE_CLASS +# else +# define TCL_STORAGE_CLASS DLLIMPORT +# endif +#endif + /* !BEGIN!: Do not edit below this line. */ /* @@ -12,46 +23,46 @@ */ /* 0 */ -TCLOOAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); +EXTERN Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); /* 1 */ -TCLOOAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, +EXTERN Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 2 */ -TCLOOAPI Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, +EXTERN Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 3 */ -TCLOOAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, +EXTERN Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */ -TCLOOAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, +EXTERN Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 5 */ -TCLOOAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, +EXTERN int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 6 */ -TCLOOAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr); +EXTERN int TclOOIsReachable(Class *targetPtr, Class *startPtr); /* 7 */ -TCLOOAPI Method * TclOONewForwardMethod(Tcl_Interp *interp, +EXTERN Method * TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */ -TCLOOAPI Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, +EXTERN Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 9 */ -TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, +EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -60,7 +71,7 @@ TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ -TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, +EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -69,22 +80,22 @@ TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 11 */ -TCLOOAPI int TclOOInvokeObject(Tcl_Interp *interp, +EXTERN int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 12 */ -TCLOOAPI void TclOOObjectSetFilters(Object *oPtr, int numFilters, +EXTERN void TclOOObjectSetFilters(Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */ -TCLOOAPI void TclOOClassSetFilters(Tcl_Interp *interp, +EXTERN void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 14 */ -TCLOOAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins, +EXTERN void TclOOObjectSetMixins(Object *oPtr, int numMixins, Class *const *mixins); /* 15 */ -TCLOOAPI void TclOOClassSetMixins(Tcl_Interp *interp, +EXTERN void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); @@ -160,4 +171,7 @@ extern const TclOOIntStubs *tclOOIntStubsPtr; #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLOOINTDECLS */ -- cgit v0.12 From 0bb601dd7253b545f4f9723a05bdd71c23421c77 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Oct 2013 10:01:50 +0000 Subject: Turn Tcl_OOInitStubs into a no-op in non-stub-enabled usage. --- generic/tclOO.h | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclOO.h b/generic/tclOO.h index 4a6cda7..e5ed10d 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -37,10 +37,14 @@ extern "C" { #endif +#ifdef USE_TCLOO_STUBS extern const char *TclOOInitializeStubs( Tcl_Interp *, const char *version); #define Tcl_OOInitStubs(interp) \ TclOOInitializeStubs((interp), TCLOO_VERSION) +#else +#define Tcl_OOInitStubs(interp) (TCL_OK) +#endif /* * These are opaque types. -- cgit v0.12 From 497f593fcdae942fd1be5b1f8c9b6bfa22b77b97 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 2 Oct 2013 10:30:19 +0000 Subject: Fix compilation of Itcl and Tdbc --- generic/tclOO.h | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclOO.h b/generic/tclOO.h index e5ed10d..b77faf4 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -37,6 +37,10 @@ extern "C" { #endif +#ifdef USE_TCL_STUBS +# define USE_TCLOO_STUBS +#endif + #ifdef USE_TCLOO_STUBS extern const char *TclOOInitializeStubs( Tcl_Interp *, const char *version); -- cgit v0.12 From 1153158b42de547b96903291c168db993b64d960 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Oct 2013 13:14:29 +0000 Subject: silence warnings with clang --- generic/tclExecute.c | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0ca393b..fd91bdb 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -293,12 +293,14 @@ VarHashCreateVar( switch (nCleanup) { \ case 1: goto cleanup1_pushObjResultPtr; \ case 2: goto cleanup2_pushObjResultPtr; \ + case 0: break; \ } \ } else { \ pc += (pcAdjustment); \ switch (nCleanup) { \ case 1: goto cleanup1; \ case 2: goto cleanup2; \ + case 0: break; \ } \ } \ } while (0) @@ -360,6 +362,8 @@ VarHashCreateVar( #define CURR_DEPTH ((ptrdiff_t) (tosPtr - initTosPtr)) +#define STACK_BASE(esPtr) ((esPtr)->stackWords - 1) + /* * Macros used to trace instruction execution. The macros TRACE, * TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is @@ -451,7 +455,7 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) #else /* !TCL_WIDE_INT_IS_LONG */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ @@ -471,7 +475,7 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) #endif /* TCL_WIDE_INT_IS_LONG */ @@ -885,7 +889,7 @@ TclCreateExecEnv( esPtr->nextPtr = NULL; esPtr->markerPtr = NULL; esPtr->endPtr = &esPtr->stackWords[size-1]; - esPtr->tosPtr = &esPtr->stackWords[-1]; + esPtr->tosPtr = STACK_BASE(esPtr); Tcl_MutexLock(&execMutex); if (!execInitialized) { @@ -1106,8 +1110,8 @@ GrowEvaluationStack( if (esPtr->nextPtr) { oldPtr = esPtr; esPtr = oldPtr->nextPtr; - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; - if (esPtr->markerPtr || (esPtr->tosPtr != &esPtr->stackWords[-1])) { + currElems = esPtr->endPtr - STACK_BASE(esPtr); + if (esPtr->markerPtr || (esPtr->tosPtr != STACK_BASE(esPtr))) { Tcl_Panic("STACK: Stack after current is in use"); } if (esPtr->nextPtr) { @@ -1119,7 +1123,7 @@ GrowEvaluationStack( DeleteExecStack(esPtr); esPtr = oldPtr; } else { - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; + currElems = esPtr->endPtr - STACK_BASE(esPtr); } /* @@ -1273,10 +1277,10 @@ TclStackFree( while (esPtr->nextPtr) { esPtr = esPtr->nextPtr; } - esPtr->tosPtr = &esPtr->stackWords[-1]; + esPtr->tosPtr = STACK_BASE(esPtr); while (esPtr->prevPtr) { ExecStack *tmpPtr = esPtr->prevPtr; - if (tmpPtr->tosPtr == &tmpPtr->stackWords[-1]) { + if (tmpPtr->tosPtr == STACK_BASE(tmpPtr)) { DeleteExecStack(tmpPtr); } else { break; -- cgit v0.12 From 08c51736454ed20f4975179188a837a41f8f9d15 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Oct 2013 13:16:10 +0000 Subject: neater --- generic/tclOO.h | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/generic/tclOO.h b/generic/tclOO.h index b77faf4..e19510d 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -37,11 +37,7 @@ extern "C" { #endif -#ifdef USE_TCL_STUBS -# define USE_TCLOO_STUBS -#endif - -#ifdef USE_TCLOO_STUBS +#if (defined(USE_TCLOO_STUBS) || defined(USE_TCL_STUBS)) extern const char *TclOOInitializeStubs( Tcl_Interp *, const char *version); #define Tcl_OOInitStubs(interp) \ -- cgit v0.12 From 5871b801b3da2d89d15ea3d66bcb3b216f7584fe Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Oct 2013 14:35:30 +0000 Subject: minor: whitespace correction (my bad!) --- generic/tclExecute.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index fd91bdb..d3c1227 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -455,7 +455,7 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) #else /* !TCL_WIDE_INT_IS_LONG */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ @@ -475,7 +475,7 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) #endif /* TCL_WIDE_INT_IS_LONG */ -- cgit v0.12 From f9427cdbfd828dbabe79facdc3d757146c090563 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 3 Oct 2013 13:32:06 +0000 Subject: cleaner and faster 'string trim' --- generic/tclAssembly.c | 3 ++- generic/tclCompCmdsSZ.c | 24 ++---------------------- generic/tclCompile.c | 5 +++++ generic/tclCompile.h | 7 ++++--- generic/tclExecute.c | 34 ++++++++++++++++++++++++++++------ 5 files changed, 41 insertions(+), 32 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 659f483..44cddba 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -462,6 +462,7 @@ static const TalInstDesc TalInstructionTable[] = { {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1}, {"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1}, + {"strtrim", ASSEM_1BYTE, INST_STRTRIM, 2, 1}, {"strtrimLeft", ASSEM_1BYTE, INST_STRTRIM_LEFT, 2, 1}, {"strtrimRight", ASSEM_1BYTE, INST_STRTRIM_RIGHT, 2, 1}, {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, @@ -505,7 +506,7 @@ static const unsigned char NonThrowingByteCodes[] = { INST_NS_CURRENT, /* 151 */ INST_INFO_LEVEL_NUM, /* 152 */ INST_RESOLVE_COMMAND, /* 154 */ - INST_STRTRIM_LEFT, INST_STRTRIM_RIGHT /* 166,167 */ + INST_STRTRIM, INST_STRTRIM_LEFT, INST_STRTRIM_RIGHT /* 166-168 */ }; /* diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 0177b2d..12f6167 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -739,7 +739,6 @@ TclCompileStringTrimCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - Tcl_Obj *objPtr; if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { return TCL_ERROR; @@ -749,30 +748,11 @@ TclCompileStringTrimCmd( CompileWord(envPtr, tokenPtr, interp, 1); if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(tokenPtr); - TclNewObj(objPtr); - if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - int len; - const char *p = Tcl_GetStringFromObj(objPtr, &len); - - PushLiteral(envPtr, p, len); - OP( STRTRIM_LEFT); - PushLiteral(envPtr, p, len); - OP( STRTRIM_RIGHT); - } else { - CompileWord(envPtr, tokenPtr, interp, 2); - OP4( REVERSE, 2); - OP4( OVER, 1); - OP( STRTRIM_LEFT); - OP4( REVERSE, 2); - OP( STRTRIM_RIGHT); - } - TclDecrRefCount(objPtr); + CompileWord(envPtr, tokenPtr, interp, 2); } else { PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); - OP( STRTRIM_LEFT); - PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); - OP( STRTRIM_RIGHT); } + OP( STRTRIM); return TCL_OK; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index cdedbda..7e72d84 100644 --- a/generic/tclCompile.c +++