From c0c57878754090d7e406bf6944d8f210c851396f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 23 Sep 2012 16:48:49 +0000 Subject: tip 318 update --- generic/regc_locale.c | 5 +++-- generic/tclCmdMZ.c | 35 +++++++++++++++++++++++++++++++---- generic/tclUtf.c | 4 ++++ tests/string.test | 12 ++++++------ 4 files changed, 44 insertions(+), 12 deletions(-) diff --git a/generic/regc_locale.c b/generic/regc_locale.c index 40791f4..8591311b 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -354,13 +354,14 @@ static const chr punctCharTable[] = { */ static const crange spaceRangeTable[] = { - {0x9, 0xd}, {0x2000, 0x200a} + {0x9, 0xd}, {0x2000, 0x200b} }; #define NUM_SPACE_RANGE (sizeof(spaceRangeTable)/sizeof(crange)) static const chr spaceCharTable[] = { - 0x20, 0xa0, 0x1680, 0x180e, 0x2028, 0x2029, 0x202f, 0x205f, 0x3000 + 0x20, 0x82, 0x83, 0x85, 0xa0, 0x1680, 0x180e, 0x2028, 0x2029, + 0x202f, 0x205f, 0x2060, 0x3000, 0xfeff }; #define NUM_SPACE_CHAR (sizeof(spaceCharTable)/sizeof(chr)) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 9e720ea..e9cbd5e 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -34,12 +34,39 @@ static int UniCharIsHexDigit(int character); /* * Default set of characters to trim in [string trim] and friends. This is a - * UTF-8 literal string containing space, tab, newline, carriage return, - * ethiopic wordspace (U+1361), ogham space mark (U+1680), and ideographic - * space (U+3000). [TIP #318] + * UTF-8 literal string containing all Unicode space characters [TIP #318] */ -#define DEFAULT_TRIM_SET " \t\n\r\xe1\x8d\xa1\xe1\x9a\x80\xe3\x80\x80" +#define DEFAULT_TRIM_SET \ + "\x09\x0a\x0b\x0c\x0d " /* ASCII */\ + "\xc0\x80" /* nul (U+0000) */\ + "\xc2\x82" /* break permitted here (U+0082) */\ + "\xc2\x83" /* no break here (U+0083) */\ + "\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\x8c" /* zero width non-joiner (U+200c) */\ + "\xe2\x80\x8d" /* zero width joiner (U+200d) */\ + "\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) */ /* *---------------------------------------------------------------------- diff --git a/generic/tclUtf.c b/generic/tclUtf.c index f0d08e7..d2bcc4c 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1516,6 +1516,10 @@ Tcl_UniCharIsSpace( if (((Tcl_UniChar) ch) < ((Tcl_UniChar) 0x80)) { return isspace(UCHAR(ch)); /* INTL: ISO space */ + } else if ((Tcl_UniChar) ch == 0x0082 || (Tcl_UniChar) ch == 0x0083 + || (Tcl_UniChar) ch == 0x0085 || (Tcl_UniChar) ch == 0x200b + || (Tcl_UniChar) ch == 0x2060 || (Tcl_UniChar) ch == 0xfeff) { + return 1; } else { return ((SPACE_BITS >> GetCategory(ch)) & 1); } diff --git a/tests/string.test b/tests/string.test index e86c0de..f558d30 100644 --- a/tests/string.test +++ b/tests/string.test @@ -1484,8 +1484,8 @@ test string-18.11 {string trim, unicode} { string trim "\xe7\xe8 AB\xe7C \xe8\xe7" \xe7\xe8 } " AB\xe7C " test string-18.12 {string trim, unicode default} { - string trim ABC\u1361\u1680\u3000 -} ABC + string trim \ufeff\x00\u0085\u00a0\u1680\u180eABC\u1361\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000 +} ABC\u1361 test string-19.1 {string trimleft} { list [catch {string trimleft} msg] $msg @@ -1494,8 +1494,8 @@ test string-19.2 {string trimleft} { string trimleft " XYZ " } {XYZ } test string-19.3 {string trimleft, unicode default} { - string trimleft \u1361\u1680\u3000ABC -} ABC + string trimleft \ufeff\u0085\u00a0\x00\u1680\u180e\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000\u1361ABC +} \u1361ABC test string-20.1 {string trimright errors} { list [catch {string trimright} msg] $msg @@ -1513,8 +1513,8 @@ test string-20.5 {string trimright} { string trimright "" } {} test string-20.6 {string trimright, unicode default} { - string trimright ABC\u1361\u1680\u3000 -} ABC + string trimright ABC\u1361\u0085\x00\u00a0\u1680\u180e\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000 +} ABC\u1361 test string-21.1 {string wordend} { list [catch {string wordend a} msg] $msg -- cgit v0.12 From f4dc9848bf926e38c4ce3c0a3682b6a673f79c1d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 9 Oct 2012 01:55:04 +0000 Subject: and remove the two characters from string trim as well --- generic/tclCmdMZ.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index e9cbd5e..d24b872 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -40,8 +40,6 @@ static int UniCharIsHexDigit(int character); #define DEFAULT_TRIM_SET \ "\x09\x0a\x0b\x0c\x0d " /* ASCII */\ "\xc0\x80" /* nul (U+0000) */\ - "\xc2\x82" /* break permitted here (U+0082) */\ - "\xc2\x83" /* no break here (U+0083) */\ "\xc2\x85" /* next line (U+0085) */\ "\xc2\xa0" /* non-breaking space (U+00a0) */\ "\xe1\x9a\x80" /* ogham space mark (U+1680) */ \ -- cgit v0.12 From 87086952e1b827b071a8e5454895c795bb71ee04 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 16 Oct 2012 13:58:16 +0000 Subject: doc fix --- doc/string.n | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/doc/string.n b/doc/string.n index 905f00a..3eae964 100644 --- a/doc/string.n +++ b/doc/string.n @@ -149,9 +149,8 @@ Any Unicode printing character, including space. .IP \fBpunct\fR 12 Any Unicode punctuation character. .IP \fBspace\fR 12 -Any Unicode whitespace character, break permitted here (U+0082), -no break here (U+0083), zero with space (U+200b), word joiner -(U+2060) and zero width no-break space (U+feff) (=BOM). +Any Unicode whitespace character, zero width space (U+200b), +word joiner (U+2060) and zero width no-break space (U+feff) (=BOM). .IP \fBtrue\fR 12 Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is true. -- cgit v0.12 From 07c7107940a7846e7eb6636927feb79f31e94659 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 16 Oct 2012 14:25:18 +0000 Subject: Remove two characters, zero width non-joiner (U+200c) and zero width joiner (U+200d), which were finally left out of TIP #413 --- generic/tclCmdMZ.c | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index d24b872..88b3420 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -34,7 +34,7 @@ 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 #318] + * UTF-8 literal string containing all Unicode space characters [TIP #413] */ #define DEFAULT_TRIM_SET \ @@ -56,8 +56,6 @@ static int UniCharIsHexDigit(int character); "\xe2\x80\x89" /* thin space (U+2009) */\ "\xe2\x80\x8a" /* hair space (U+200a) */\ "\xe2\x80\x8b" /* zero width space (U+200b) */\ - "\xe2\x80\x8c" /* zero width non-joiner (U+200c) */\ - "\xe2\x80\x8d" /* zero width joiner (U+200d) */\ "\xe2\x80\xa8" /* line separator (U+2028) */\ "\xe2\x80\xa9" /* paragraph separator (U+2029) */\ "\xe2\x80\xaf" /* narrow no-break space (U+202f) */\ -- cgit v0.12 From a2c4054ebe553c1610490de7db25616221463db6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 31 Oct 2012 13:09:23 +0000 Subject: Dde version number to 1.4.0, ready for Tcl 8.6.0rc1 --- ChangeLog | 8 ++++++++ library/dde/pkgIndex.tcl | 4 ++-- tests/winDde.test | 4 ++-- win/Makefile.in | 4 ++-- win/makefile.vc | 4 ++-- win/tclWinDde.c | 2 +- 6 files changed, 17 insertions(+), 9 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4964249..7f75101 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2012-10-31 Jan Nijtmans + + * win/Makefile.in: Dde version number to 1.4.0, ready for Tcl 8.6.0rc1 + * win/makefile.vc + * win/tclWinDde.c + * library/dde/pkgIndex.tcl + * tests/winDde.test + 2012-10-24 Donal K. Fellows * generic/tclCompCmds.c (TclCompileDictUnsetCmd): Added compilation of diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index 8758bd2..4cf73d0 100644 --- a/library/dde/pkgIndex.tcl +++ b/library/dde/pkgIndex.tcl @@ -1,7 +1,7 @@ if {([info commands ::tcl::pkgconfig] eq "") || ([info sharedlibextension] ne ".dll")} return if {[::tcl::pkgconfig get debug]} { - package ifneeded dde 1.4.0b2 [list load [file join $dir tcldde14g.dll] dde] + package ifneeded dde 1.4.0 [list load [file join $dir tcldde14g.dll] dde] } else { - package ifneeded dde 1.4.0b2 [list load [file join $dir tcldde14.dll] dde] + package ifneeded dde 1.4.0 [list load [file join $dir tcldde14.dll] dde] } diff --git a/tests/winDde.test b/tests/winDde.test index 9411c92..f04fb45 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -20,7 +20,7 @@ testConstraint dde 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::ddever [package require dde 1.4.0b2] + set ::ddever [package require dde 1.4.0] set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} { testConstraint dde 1 } @@ -104,7 +104,7 @@ proc createChildProcess {ddeServerName args} { # ------------------------------------------------------------------------- test winDde-1.0 {check if we are testing the right dll} {win dde} { set ::ddever -} {1.4.0b2} +} {1.4.0} test winDde-1.1 {Settings the server's topic name} -constraints dde -body { list [dde servername foobar] [dde servername] [dde servername self] diff --git a/win/Makefile.in b/win/Makefile.in index fad1f09..e0f3cee 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -695,14 +695,14 @@ test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE) TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \ - package ifneeded dde 1.4.0b2 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ + package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ package ifneeded registry 1.3.0 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32) # Useful target to launch a built tclsh with the proper path,... runtest: binaries $(TCLSH) $(TEST_DLL_FILE) @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ ./$(TCLSH) $(TESTFLAGS) -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \ - package ifneeded dde 1.4.0b2 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ + package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ package ifneeded registry 1.3.0 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT) # This target can be used to run tclsh from the build directory via diff --git a/win/makefile.vc b/win/makefile.vc index d097e26..2784140 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -578,13 +578,13 @@ test-core: setup $(TCLTEST) dlls $(CAT32) set TCL_LIBRARY=$(ROOT:\=/)/library !if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << - package ifneeded dde 1.4.0b2 [list load "$(TCLDDELIB:\=/)" dde] + package ifneeded dde 1.4.0 [list load "$(TCLDDELIB:\=/)" dde] package ifneeded registry 1.3.0 [list load "$(TCLREGLIB:\=/)" registry] << !else @echo Please wait while the tests are collected... $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log - package ifneeded dde 1.4.0b2 "$(TCLDDELIB:\=/)" dde] + package ifneeded dde 1.4.0 "$(TCLDDELIB:\=/)" dde] package ifneeded registry 1.3.0 "$(TCLREGLIB:\=/)" registry] << type tests.log | more diff --git a/win/tclWinDde.c b/win/tclWinDde.c index f5c0484..d0600e6 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -96,7 +96,7 @@ static DWORD ddeInstance; /* The application instance handle given to us * by DdeInitialize. */ static int ddeIsServer = 0; -#define TCL_DDE_VERSION "1.4.0b2" +#define TCL_DDE_VERSION "1.4.0" #define TCL_DDE_PACKAGE_NAME "dde" #define TCL_DDE_SERVICE_NAME TEXT("TclEval") #define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT") -- cgit v0.12 From ce7c13b7962d2ebcd432dfb05fffe812c4d172d2 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 2 Nov 2012 18:13:20 +0000 Subject: Added more TclOO introspection bytecodes ([info object class], [info object namespace]). Also moved TclOO-in-8.6 to using the main Tcl internal ensemble builder. --- generic/tclAssembly.c | 2 ++ generic/tclCompCmds.c | 40 ++++++++++++++++++++++++ generic/tclCompile.c | 8 +++++ generic/tclCompile.h | 4 ++- generic/tclExecute.c | 28 +++++++++++++++++ generic/tclInt.h | 6 ++++ generic/tclOOInfo.c | 85 +++++++++++++++++++-------------------------------- 7 files changed, 119 insertions(+), 54 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index f5f2469..19d6232 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -480,6 +480,8 @@ static const TalInstDesc TalInstructionTable[] = { {"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1}, {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, + {"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1}, + {"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1}, {"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1}, {"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1}, {"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1}, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 5beb7bd..e476cf0 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -3666,6 +3666,46 @@ TclCompileInfoLevelCmd( } return TCL_OK; } + +int +TclCompileInfoObjectClassCmd( + 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) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_TCLOO_CLASS, envPtr); + return TCL_OK; +} + +int +TclCompileInfoObjectNamespaceCmd( + 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) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_TCLOO_NS, envPtr); + return TCL_OK; +} /* *---------------------------------------------------------------------- diff --git a/generic/tclCompile.c b/generic/tclCompile.c index ee8511c..d47e0f6 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -487,6 +487,14 @@ 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. */ + {"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}}, + /* Push the namespace of the TclOO object named at the top of the + * stack onto the stack. + * Stack: ... object => ... namespace */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 08d59fd..a31a33b 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -699,9 +699,11 @@ typedef struct ByteCode { #define INST_INFO_LEVEL_ARGS 151 #define INST_RESOLVE_COMMAND 152 #define INST_TCLOO_SELF 153 +#define INST_TCLOO_CLASS 154 +#define INST_TCLOO_NS 155 /* The last opcode */ -#define LAST_INST_OPCODE 153 +#define LAST_INST_OPCODE 155 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 1e24cb3..bf07dd7 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4231,6 +4231,34 @@ TEBCresume( TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); } + { + Object *oPtr; + + case INST_TCLOO_CLASS: + oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); + if (oPtr == NULL) { + TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS))); + goto gotError; + } + objResultPtr = TclOOObjectName(interp, oPtr->selfCls->thisPtr); + TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); + NEXT_INST_F(1, 1, 1); + case INST_TCLOO_NS: + oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); + if (oPtr == NULL) { + TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS))); + goto gotError; + } + + /* + * TclOO objects *never* have the global namespace as their NS. + */ + + TclNewStringObj(objResultPtr, oPtr->namespacePtr->fullName, + strlen(oPtr->namespacePtr->fullName)); + TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); + NEXT_INST_F(1, 1, 1); + } /* * ----------------------------------------------------------------- diff --git a/generic/tclInt.h b/generic/tclInt.h index 1fffa1f..06bcd95 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3575,6 +3575,12 @@ MODULE_SCOPE int TclCompileInfoExistsCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileInfoLevelCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoObjectClassCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoObjectNamespaceCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 1a94e69..ff3e1e5 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -43,47 +43,45 @@ static Tcl_ObjCmdProc InfoClassSubsCmd; static Tcl_ObjCmdProc InfoClassSupersCmd; static Tcl_ObjCmdProc InfoClassVariablesCmd; -struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; }; - /* * List of commands that are used to implement the [info object] subcommands. */ -static const struct NameProcMap infoObjectCmds[] = { - {"::oo::InfoObject::call", InfoObjectCallCmd}, - {"::oo::InfoObject::class", InfoObjectClassCmd}, - {"::oo::InfoObject::definition", InfoObjectDefnCmd}, - {"::oo::InfoObject::filters", InfoObjectFiltersCmd}, - {"::oo::InfoObject::forward", InfoObjectForwardCmd}, - {"::oo::InfoObject::isa", InfoObjectIsACmd}, - {"::oo::InfoObject::methods", InfoObjectMethodsCmd}, - {"::oo::InfoObject::methodtype", InfoObjectMethodTypeCmd}, - {"::oo::InfoObject::mixins", InfoObjectMixinsCmd}, - {"::oo::InfoObject::namespace", InfoObjectNsCmd}, - {"::oo::InfoObject::variables", InfoObjectVariablesCmd}, - {"::oo::InfoObject::vars", InfoObjectVarsCmd}, - {NULL, NULL} +static const EnsembleImplMap infoObjectCmds[] = { + {"call", InfoObjectCallCmd, NULL, NULL, NULL, 0}, + {"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0}, + {"definition", InfoObjectDefnCmd, NULL, NULL, NULL, 0}, + {"filters", InfoObjectFiltersCmd, NULL, NULL, NULL, 0}, + {"forward", InfoObjectForwardCmd, NULL, NULL, NULL, 0}, + {"isa", InfoObjectIsACmd, NULL, NULL, NULL, 0}, + {"methods", InfoObjectMethodsCmd, NULL, NULL, NULL, 0}, + {"methodtype", InfoObjectMethodTypeCmd, NULL, NULL, NULL, 0}, + {"mixins", InfoObjectMixinsCmd, NULL, NULL, NULL, 0}, + {"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0}, + {"variables", InfoObjectVariablesCmd, NULL, NULL, NULL, 0}, + {"vars", InfoObjectVarsCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; /* * List of commands that are used to implement the [info class] subcommands. */ -static const struct NameProcMap infoClassCmds[] = { - {"::oo::InfoClass::call", InfoClassCallCmd}, - {"::oo::InfoClass::constructor", InfoClassConstrCmd}, - {"::oo::InfoClass::definition", InfoClassDefnCmd}, - {"::oo::InfoClass::destructor", InfoClassDestrCmd}, - {"::oo::InfoClass::filters", InfoClassFiltersCmd}, - {"::oo::InfoClass::forward", InfoClassForwardCmd}, - {"::oo::InfoClass::instances", InfoClassInstancesCmd}, - {"::oo::InfoClass::methods", InfoClassMethodsCmd}, - {"::oo::InfoClass::methodtype", InfoClassMethodTypeCmd}, - {"::oo::InfoClass::mixins", InfoClassMixinsCmd}, - {"::oo::InfoClass::subclasses", InfoClassSubsCmd}, - {"::oo::InfoClass::superclasses", InfoClassSupersCmd}, - {"::oo::InfoClass::variables", InfoClassVariablesCmd}, - {NULL, NULL} +static const EnsembleImplMap infoClassCmds[] = { + {"call", InfoClassCallCmd, NULL, NULL, NULL, 0}, + {"constructor", InfoClassConstrCmd, NULL, NULL, NULL, 0}, + {"definition", InfoClassDefnCmd, NULL, NULL, NULL, 0}, + {"destructor", InfoClassDestrCmd, NULL, NULL, NULL, 0}, + {"filters", InfoClassFiltersCmd, NULL, NULL, NULL, 0}, + {"forward", InfoClassForwardCmd, NULL, NULL, NULL, 0}, + {"instances", InfoClassInstancesCmd, NULL, NULL, NULL, 0}, + {"methods", InfoClassMethodsCmd, NULL, NULL, NULL, 0}, + {"methodtype", InfoClassMethodTypeCmd, NULL, NULL, NULL, 0}, + {"mixins", InfoClassMixinsCmd, NULL, NULL, NULL, 0}, + {"subclasses", InfoClassSubsCmd, NULL, NULL, NULL, 0}, + {"superclasses", InfoClassSupersCmd, NULL, NULL, NULL, 0}, + {"variables", InfoClassVariablesCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; /* @@ -101,33 +99,14 @@ void TclOOInitInfo( Tcl_Interp *interp) { - Tcl_Namespace *nsPtr; Tcl_Command infoCmd; - int i; - - /* - * Build the ensemble used to implement [info object]. - */ - - nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoObject", NULL, NULL); - Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX); - Tcl_Export(interp, nsPtr, "[a-z]*", 1); - for (i=0 ; infoObjectCmds[i].name!=NULL ; i++) { - Tcl_CreateObjCommand(interp, infoObjectCmds[i].name, - infoObjectCmds[i].proc, NULL, NULL); - } /* - * Build the ensemble used to implement [info class]. + * Build the ensembles used to implement [info object] and [info class]. */ - nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoClass", NULL, NULL); - Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX); - Tcl_Export(interp, nsPtr, "[a-z]*", 1); - for (i=0 ; infoClassCmds[i].name!=NULL ; i++) { - Tcl_CreateObjCommand(interp, infoClassCmds[i].name, - infoClassCmds[i].proc, NULL, NULL); - } + TclMakeEnsemble(interp, "::oo::InfoObject", infoObjectCmds); + TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds); /* * Install into the master [info] ensemble. -- cgit v0.12 From ecb5e9981dc6a833c08ccd3c8a2aba31db07061d Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 3 Nov 2012 12:48:08 +0000 Subject: Added compilation of [info object isa object] (i.e., object verification). --- generic/tclAssembly.c | 1 + generic/tclCompCmds.c | 36 ++++++++++++++++++++++++++++++++++++ generic/tclCompile.c | 10 ++++++++-- generic/tclCompile.h | 3 ++- generic/tclExecute.c | 5 +++++ generic/tclInt.h | 3 +++ generic/tclOOInfo.c | 2 +- 7 files changed, 56 insertions(+), 4 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 19d6232..9256556 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -481,6 +481,7 @@ static const TalInstDesc TalInstructionTable[] = { {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 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}, {"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1}, {"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1}, {"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1}, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index e476cf0..0829072 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -3688,6 +3688,42 @@ TclCompileInfoObjectClassCmd( } int +TclCompileInfoObjectIsACmd( + 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) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + + /* + * We only handle [info object isa object ]. The first three + * words are compressed to a single token by the ensemble compilation + * engine. + */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1 + || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + + /* + * Issue the code. + */ + + CompileWord(envPtr, tokenPtr, interp, 2); + TclEmitOpcode( INST_TCLOO_IS_OBJECT, envPtr); + return TCL_OK; +} + +int TclCompileInfoObjectNamespaceCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command diff --git a/generic/tclCompile.c b/generic/tclCompile.c index d47e0f6..475a85e 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -487,14 +487,20 @@ 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. */ - {"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 */ + {"tclooIsObject", 1, 0, 0, {OPERAND_NONE}}, + /* Push whether the value named at the top of the stack is a TclOO + * object (i.e., a boolean). Can corrupt the interpreter result + * despite not throwing, so not safe for use in a post-exception + * context. + * Stack: ... value => ... boolean */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index a31a33b..3db3a78 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -701,9 +701,10 @@ typedef struct ByteCode { #define INST_TCLOO_SELF 153 #define INST_TCLOO_CLASS 154 #define INST_TCLOO_NS 155 +#define INST_TCLOO_IS_OBJECT 156 /* The last opcode */ -#define LAST_INST_OPCODE 155 +#define LAST_INST_OPCODE 156 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index bf07dd7..ad79482 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4234,6 +4234,11 @@ TEBCresume( { Object *oPtr; + case INST_TCLOO_IS_OBJECT: + oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); + objResultPtr = TCONST(oPtr != NULL ? 1 : 0); + TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); + NEXT_INST_F(1, 1, 1); case INST_TCLOO_CLASS: oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); if (oPtr == NULL) { diff --git a/generic/tclInt.h b/generic/tclInt.h index 06bcd95..48297b9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3578,6 +3578,9 @@ MODULE_SCOPE int TclCompileInfoLevelCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileInfoObjectClassCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoObjectIsACmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileInfoObjectNamespaceCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index ff3e1e5..e09ee4e 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -53,7 +53,7 @@ static const EnsembleImplMap infoObjectCmds[] = { {"definition", InfoObjectDefnCmd, NULL, NULL, NULL, 0}, {"filters", InfoObjectFiltersCmd, NULL, NULL, NULL, 0}, {"forward", InfoObjectForwardCmd, NULL, NULL, NULL, 0}, - {"isa", InfoObjectIsACmd, NULL, NULL, NULL, 0}, + {"isa", InfoObjectIsACmd, TclCompileInfoObjectIsACmd, NULL, NULL, 0}, {"methods", InfoObjectMethodsCmd, NULL, NULL, NULL, 0}, {"methodtype", InfoObjectMethodTypeCmd, NULL, NULL, NULL, 0}, {"mixins", InfoObjectMixinsCmd, NULL, NULL, NULL, 0}, -- cgit v0.12 From 259635cd9b7b5e6be9e1bc44a5d2a7d3a2536743 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 3 Nov 2012 20:21:13 +0000 Subject: Added compilation of [string last] and improved the compilation of [string range]. This in turn enables compilation of [namespace qualifiers] and [namespace tail] (also done). --- generic/tclAssembly.c | 10 +- generic/tclCmdMZ.c | 2 +- generic/tclCompCmds.c | 73 ++++++++++++++ generic/tclCompCmdsSZ.c | 252 +++++++++++++++--------------------------------- generic/tclCompile.c | 7 ++ generic/tclCompile.h | 28 +++--- generic/tclExecute.c | 48 ++++++++- generic/tclInt.h | 9 ++ generic/tclNamesp.c | 38 ++++---- 9 files changed, 253 insertions(+), 214 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 9256556..3b02ca2 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -479,6 +479,8 @@ static const TalInstDesc TalInstructionTable[] = { {"strmap", ASSEM_1BYTE, INST_STR_MAP, 3, 1}, {"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1}, {"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}, {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, {"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1}, {"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1}, @@ -516,10 +518,10 @@ static const unsigned char NonThrowingByteCodes[] = { INST_NOP, /* 132 */ INST_STR_MAP, /* 143 */ INST_STR_FIND, /* 144 */ - INST_COROUTINE_NAME, /* 147 */ - INST_NS_CURRENT, /* 149 */ - INST_INFO_LEVEL_NUM, /* 150 */ - INST_RESOLVE_COMMAND /* 152 */ + INST_COROUTINE_NAME, /* 149 */ + INST_NS_CURRENT, /* 151 */ + INST_INFO_LEVEL_NUM, /* 152 */ + INST_RESOLVE_COMMAND /* 154 */ }; /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index de32fce..c14f543 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3307,7 +3307,7 @@ TclInitStringCmd( {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, {"is", StringIsCmd, NULL, NULL, NULL, 0}, - {"last", StringLastCmd, NULL, NULL, NULL, 0}, + {"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0}, {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, {"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0}, {"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0}, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 0829072..463e82c 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -4683,6 +4683,79 @@ TclCompileNamespaceCodeCmd( } int +TclCompileNamespaceQualifiersCmd( + 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. */ +{ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + DefineLineInformation; /* TIP #280 */ + int off; + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + CompileWord(envPtr, tokenPtr, interp, 1); + PushLiteral(envPtr, "0", 1); + PushLiteral(envPtr, "::", 2); + TclEmitInstInt4( INST_OVER, 2, envPtr); + TclEmitOpcode( INST_STR_FIND_LAST, envPtr); + off = CurrentOffset(envPtr); + PushLiteral(envPtr, "1", 1); + TclEmitOpcode( INST_SUB, envPtr); + TclEmitInstInt4( INST_OVER, 2, envPtr); + TclEmitInstInt4( INST_OVER, 1, envPtr); + TclEmitOpcode( INST_STR_INDEX, envPtr); + PushLiteral(envPtr, ":", 1); + TclEmitOpcode( INST_STR_EQ, envPtr); + off = off - CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr); + TclEmitOpcode( INST_STR_RANGE, envPtr); + return TCL_OK; +} + +int +TclCompileNamespaceTailCmd( + 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. */ +{ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + DefineLineInformation; /* TIP #280 */ + JumpFixup jumpFixup; + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + /* + * Take care; only add 2 to found index if the string was actually found. + */ + + CompileWord(envPtr, tokenPtr, interp, 1); + PushLiteral(envPtr, "::", 2); + TclEmitInstInt4( INST_OVER, 1, envPtr); + TclEmitOpcode( INST_STR_FIND_LAST, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + PushLiteral(envPtr, "0", 1); + TclEmitOpcode( INST_GE, envPtr); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup); + PushLiteral(envPtr, "2", 1); + TclEmitOpcode( INST_ADD, envPtr); + TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); + PushLiteral(envPtr, "end", 3); + TclEmitOpcode( INST_STR_RANGE, envPtr); + return TCL_OK; +} + +int TclCompileNamespaceUpvarCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 57cb992..090f996 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -251,18 +251,18 @@ TclCompileSetCmd( /* *---------------------------------------------------------------------- * - * TclCompileStringCmpCmd -- + * TclCompileString*Cmd -- * - * Procedure called to compile the simplest and most common form of the - * "string compare" command. + * Procedures called to compile various subcommands of the "string" + * 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 compare" - * command at runtime. + * Instructions are added to envPtr to execute the "string" command at + * runtime. * *---------------------------------------------------------------------- */ @@ -298,25 +298,6 @@ TclCompileStringCmpCmd( TclEmitOpcode(INST_STR_CMP, envPtr); return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringEqualCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string equal" 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 equal" command - * at runtime. - * - *---------------------------------------------------------------------- - */ int TclCompileStringEqualCmd( @@ -349,25 +330,6 @@ TclCompileStringEqualCmd( TclEmitOpcode(INST_STR_EQ, envPtr); return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringFirstCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string first" 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 first" - * command at runtime. - * - *---------------------------------------------------------------------- - */ int TclCompileStringFirstCmd( @@ -400,25 +362,38 @@ TclCompileStringFirstCmd( OP(STR_FIND); return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringIndexCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string index" 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 index" command - * at runtime. - * - *---------------------------------------------------------------------- - */ + +int +TclCompileStringLastCmd( + 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; + + /* + * We don't support any flags; the bytecode isn't that sophisticated. + */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + + /* + * Push the two operands onto the stack and then the test. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + OP(STR_FIND_LAST); + return TCL_OK; +} int TclCompileStringIndexCmd( @@ -447,25 +422,6 @@ TclCompileStringIndexCmd( TclEmitOpcode(INST_STR_INDEX, envPtr); return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringMatchCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string match" 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 match" command - * at runtime. - * - *---------------------------------------------------------------------- - */ int TclCompileStringMatchCmd( @@ -547,25 +503,6 @@ TclCompileStringMatchCmd( } return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringLenCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string length" 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 length" - * command at runtime. - * - *---------------------------------------------------------------------- - */ int TclCompileStringLenCmd( @@ -606,25 +543,6 @@ TclCompileStringLenCmd( TclDecrRefCount(objPtr); return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringMapCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string map" 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 map" command - * at runtime. - * - *---------------------------------------------------------------------- - */ int TclCompileStringMapCmd( @@ -688,25 +606,6 @@ TclCompileStringMapCmd( Tcl_DecrRefCount(mapObj); return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringRangeCmd -- - * - * Procedure called to compile the "string range" command (with constant - * indices). - * - * 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 compare" - * command at runtime. - * - *---------------------------------------------------------------------- - */ int TclCompileStringRangeCmd( @@ -718,18 +617,16 @@ TclCompileStringRangeCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Token *stringTokenPtr, *tokenPtr; + Tcl_Token *stringTokenPtr, *fromTokenPtr, *toTokenPtr; Tcl_Obj *tmpObj; int idx1, idx2, result; - /* - * We don't support any flags; the bytecode isn't that sophisticated. - */ - if (parsePtr->numWords != 4) { return TCL_ERROR; } stringTokenPtr = TokenAfter(parsePtr->tokenPtr); + fromTokenPtr = TokenAfter(stringTokenPtr); + toTokenPtr = TokenAfter(fromTokenPtr); /* * Parse the first index. Will only compile if it is constant and not an @@ -737,26 +634,22 @@ TclCompileStringRangeCmd( * end-relative indexing). */ - tokenPtr = TokenAfter(stringTokenPtr); tmpObj = Tcl_NewObj(); - if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { - Tcl_DecrRefCount(tmpObj); - return TCL_ERROR; - } - result = TclGetIntFromObj(NULL, tmpObj, &idx1); - if (result == TCL_OK) { - if (idx1 < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1); - if (result == TCL_OK && idx1 > -2) { - result = TCL_ERROR; + result = TCL_ERROR; + if (TclWordKnownAtCompileTime(fromTokenPtr, tmpObj)) { + if (TclGetIntFromObj(NULL, tmpObj, &idx1) == TCL_OK) { + if (idx1 >= 0) { + result = TCL_OK; + } + } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx1) == TCL_OK) { + if (idx1 <= -2) { + result = TCL_OK; + } } } TclDecrRefCount(tmpObj); if (result != TCL_OK) { - return TCL_ERROR; + goto nonConstantIndices; } /* @@ -765,34 +658,41 @@ TclCompileStringRangeCmd( * end-relative indexing). */ - tokenPtr = TokenAfter(tokenPtr); tmpObj = Tcl_NewObj(); - if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { - Tcl_DecrRefCount(tmpObj); - return TCL_ERROR; - } - result = TclGetIntFromObj(NULL, tmpObj, &idx2); - if (result == TCL_OK) { - if (idx2 < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2); - if (result == TCL_OK && idx2 > -2) { - result = TCL_ERROR; + result = TCL_ERROR; + if (TclWordKnownAtCompileTime(toTokenPtr, tmpObj)) { + if (TclGetIntFromObj(NULL, tmpObj, &idx2) == TCL_OK) { + if (idx2 >= 0) { + result = TCL_OK; + } + } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx2) == TCL_OK) { + if (idx2 <= -2) { + result = TCL_OK; + } } } TclDecrRefCount(tmpObj); if (result != TCL_OK) { - return TCL_ERROR; + goto nonConstantIndices; } /* - * Push the two operands onto the stack and then the test. + * Push the operand onto the stack and then the substring operation. */ - CompileWord(envPtr, stringTokenPtr, interp, 1); - OP44( STR_RANGE_IMM, idx1, idx2); + CompileWord(envPtr, stringTokenPtr, interp, 1); + OP44( STR_RANGE_IMM, idx1, idx2); + return TCL_OK; + + /* + * Push the operands onto the stack and then the substring operation. + */ + + nonConstantIndices: + CompileWord(envPtr, stringTokenPtr, interp, 1); + CompileWord(envPtr, fromTokenPtr, interp, 2); + CompileWord(envPtr, toTokenPtr, interp, 3); + OP( STR_RANGE); return TCL_OK; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 475a85e..2c87b34 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -453,8 +453,15 @@ InstructionDesc const tclInstructionTable[] = { /* Find the first index of a needle string in a haystack string, * producing the index (integer) or -1 if nothing found. * Stack: ... needle haystack => ... index */ + {"strrfind", 1, -1, 0, {OPERAND_NONE}}, + /* Find the last index of a needle string in a haystack string, + * producing the index (integer) or -1 if nothing found. + * Stack: ... needle haystack => ... index */ {"strrangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, /* String Range: push (string range stktop op4 op4) */ + {"strrange", 1, -2, 0, {OPERAND_NONE}}, + /* String Range with non-constant arguments. + * Stack: ... string idxA idxB => ... substring */ {"yield", 1, 0, 0, {OPERAND_NONE}}, /* Makes the current coroutine yield the value at the top of the diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 3db3a78..b080d33 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -686,25 +686,27 @@ typedef struct ByteCode { /* For [string map] and [regsub] compilation */ #define INST_STR_MAP 143 #define INST_STR_FIND 144 -#define INST_STR_RANGE_IMM 145 +#define INST_STR_FIND_LAST 145 +#define INST_STR_RANGE_IMM 146 +#define INST_STR_RANGE 147 /* For operations to do with coroutines and other NRE-manipulators */ -#define INST_YIELD 146 -#define INST_COROUTINE_NAME 147 -#define INST_TAILCALL 148 +#define INST_YIELD 148 +#define INST_COROUTINE_NAME 149 +#define INST_TAILCALL 150 /* For compilation of basic information operations */ -#define INST_NS_CURRENT 149 -#define INST_INFO_LEVEL_NUM 150 -#define INST_INFO_LEVEL_ARGS 151 -#define INST_RESOLVE_COMMAND 152 -#define INST_TCLOO_SELF 153 -#define INST_TCLOO_CLASS 154 -#define INST_TCLOO_NS 155 -#define INST_TCLOO_IS_OBJECT 156 +#define INST_NS_CURRENT 151 +#define INST_INFO_LEVEL_NUM 152 +#define INST_INFO_LEVEL_ARGS 153 +#define INST_RESOLVE_COMMAND 154 +#define INST_TCLOO_SELF 155 +#define INST_TCLOO_CLASS 156 +#define INST_TCLOO_NS 157 +#define INST_TCLOO_IS_OBJECT 158 /* The last opcode */ -#define LAST_INST_OPCODE 156 +#define LAST_INST_OPCODE 158 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ad79482..2b29d5c 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4814,12 +4814,37 @@ TEBCresume( O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); + case INST_STR_RANGE: + TRACE(("\"%.20s\" %s %s =>", + O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); + length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1; + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, + &fromIdx) != TCL_OK + || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, + &toIdx) != TCL_OK) { + goto gotError; + } + + if (fromIdx < 0) { + fromIdx = 0; + } + if (toIdx >= length) { + toIdx = length; + } + if (toIdx >= fromIdx) { + objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); + } else { + TclNewObj(objResultPtr); + } + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_V(1, 3, 1); + case INST_STR_RANGE_IMM: valuePtr = OBJ_AT_TOS; fromIdx = TclGetInt4AtPtr(pc+1); toIdx = TclGetInt4AtPtr(pc+5); length = Tcl_GetCharLength(valuePtr); - TRACE(("\"%.20s\" %d %d", O2S(valuePtr), fromIdx, toIdx)); + TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx)); /* * Adjust indices for end-based indexing. @@ -4939,6 +4964,27 @@ TEBCresume( TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); + + case INST_STR_FIND_LAST: + ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ + ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ + + match = -1; + if (length2 > 0 && length2 <= length) { + for (p=ustring1+length-length2 ; p>=ustring1 ; p--) { + if ((*p == *ustring2) && + memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) { + match = p - ustring1; + break; + } + } + } + + TRACE(("%.20s %.20s => %d\n", + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); + + TclNewIntObj(objResultPtr, match); + NEXT_INST_F(1, 2, 1); } case INST_STR_MATCH: diff --git a/generic/tclInt.h b/generic/tclInt.h index 48297b9..7dc21c1 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3620,6 +3620,12 @@ MODULE_SCOPE int TclCompileNamespaceCodeCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileNamespaceCurrentCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceQualifiersCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceTailCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNamespaceUpvarCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3656,6 +3662,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 TclCompileStringLastCmd(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); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 60c40d0..02d517f 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -160,25 +160,25 @@ static const Tcl_ObjType nsNameType = { */ static const EnsembleImplMap defaultNamespaceMap[] = { - {"children", NamespaceChildrenCmd, NULL, NULL, NULL, 0}, - {"code", NamespaceCodeCmd, TclCompileNamespaceCodeCmd, NULL, NULL, 0}, - {"current", NamespaceCurrentCmd, TclCompileNamespaceCurrentCmd, NULL, NULL, 0}, - {"delete", NamespaceDeleteCmd, NULL, NULL, NULL, 0}, - {"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0}, - {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0}, - {"exists", NamespaceExistsCmd, NULL, NULL, NULL, 0}, - {"export", NamespaceExportCmd, NULL, NULL, NULL, 0}, - {"forget", NamespaceForgetCmd, NULL, NULL, NULL, 0}, - {"import", NamespaceImportCmd, NULL, NULL, NULL, 0}, - {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0}, - {"origin", NamespaceOriginCmd, NULL, NULL, NULL, 0}, - {"parent", NamespaceParentCmd, NULL, NULL, NULL, 0}, - {"path", NamespacePathCmd, NULL, NULL, NULL, 0}, - {"qualifiers", NamespaceQualifiersCmd, NULL, NULL, NULL, 0}, - {"tail", NamespaceTailCmd, NULL, NULL, NULL, 0}, - {"unknown", NamespaceUnknownCmd, NULL, NULL, NULL, 0}, - {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0}, - {"which", NamespaceWhichCmd, TclCompileNamespaceWhichCmd, NULL, NULL, 0}, + {"children", NamespaceChildrenCmd, NULL, NULL, NULL, 0}, + {"code", NamespaceCodeCmd, TclCompileNamespaceCodeCmd, NULL, NULL, 0}, + {"current", NamespaceCurrentCmd, TclCompileNamespaceCurrentCmd, NULL, NULL, 0}, + {"delete", NamespaceDeleteCmd, NULL, NULL, NULL, 0}, + {"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0}, + {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0}, + {"exists", NamespaceExistsCmd, NULL, NULL, NULL, 0}, + {"export", NamespaceExportCmd, NULL, NULL, NULL, 0}, + {"forget", NamespaceForgetCmd, NULL, NULL, NULL, 0}, + {"import", NamespaceImportCmd, NULL, NULL, NULL, 0}, + {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0}, + {"origin", NamespaceOriginCmd, NULL, NULL, NULL, 0}, + {"parent", NamespaceParentCmd, NULL, NULL, NULL, 0}, + {"path", NamespacePathCmd, NULL, NULL, NULL, 0}, + {"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0}, + {"tail", NamespaceTailCmd, TclCompileNamespaceTailCmd, NULL, NULL, 0}, + {"unknown", NamespaceUnknownCmd, NULL, NULL, NULL, 0}, + {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0}, + {"which", NamespaceWhichCmd, TclCompileNamespaceWhichCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; -- cgit v0.12 From a573f6dc86fd4e5c16c4e9d7167d12f50208374b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 4 Nov 2012 16:57:43 +0000 Subject: fix Tcl_FSFileAttrStrings doc --- doc/FileSystem.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index d7198b1..d3ee454 100644 --- a/doc/FileSystem.3 +++ b/doc/FileSystem.3 @@ -86,7 +86,7 @@ int int \fBTcl_FSFileAttrsSet\fR(\fIinterp, int index, pathPtr, Tcl_Obj *objPtr\fR) .sp -const char ** +const char *const * \fBTcl_FSFileAttrStrings\fR(\fIpathPtr, objPtrRef\fR) .sp int -- cgit v0.12 From cd1f27f0cf22ec6b5b83f2fd48c1ba93e5c27be2 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 5 Nov 2012 14:34:36 +0000 Subject: Added compilation of [array exists], [array set] and [array unset]. Fixed a whole bunch of issues with opcode issuing that were causing problems with stack depth calculations. --- generic/tclAssembly.c | 4 + generic/tclCompCmds.c | 279 ++++++++++++++++++++++++++++++++++++++++++++---- generic/tclCompCmdsSZ.c | 19 +++- generic/tclCompile.c | 48 ++++++++- generic/tclCompile.h | 8 +- generic/tclExecute.c | 114 ++++++++++++++++++-- generic/tclInt.h | 9 ++ generic/tclVar.c | 6 +- 8 files changed, 451 insertions(+), 36 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 3b02ca2..7833105 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -362,6 +362,10 @@ static const TalInstDesc TalInstructionTable[] = { | INST_APPEND_ARRAY4), 2, 1}, {"appendArrayStk", ASSEM_1BYTE, INST_APPEND_ARRAY_STK, 3, 1}, {"appendStk", ASSEM_1BYTE, INST_APPEND_STK, 2, 1}, + {"arrayExistsImm", ASSEM_LVT4, INST_ARRAY_EXISTS_IMM, 0, 1}, + {"arrayExistsStk", ASSEM_1BYTE, INST_ARRAY_EXISTS_STK, 1, 1}, + {"arrayMakeImm", ASSEM_LVT4, INST_ARRAY_MAKE_IMM, 0, 0}, + {"arrayMakeStk", ASSEM_1BYTE, INST_ARRAY_MAKE_STK, 1, 0}, {"beginCatch", ASSEM_BEGIN_CATCH, INST_BEGIN_CATCH4, 0, 0}, {"bitand", ASSEM_1BYTE, INST_BITAND, 2, 1}, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 463e82c..160fa3c 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -15,6 +15,7 @@ #include "tclInt.h" #include "tclCompile.h" +#include /* * Prototypes for procedures defined later in this file: @@ -225,6 +226,245 @@ TclCompileAppendCmd( /* *---------------------------------------------------------------------- * + * TclCompileArray*Cmd -- + * + * Functions called to compile "array" sucommands. + * + * Results: + * All return TCL_OK for a successful compile, and TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "array" subcommand at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileArrayExistsCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + 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; + int simpleVarName, isScalar, localIndex; + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, tokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); + if (!isScalar) { + return TCL_ERROR; + } + + if (localIndex >= 0) { + TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + } else { + TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); + } + return TCL_OK; +} + +int +TclCompileArraySetCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + 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; + int simpleVarName, isScalar, localIndex; + int dataVar, iterVar, keyVar, valVar, infoIndex; + int back, fwd, offsetBack, offsetFwd, savedStackDepth; + ForeachInfo *infoPtr; + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, tokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); + if (!isScalar) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + + /* + * Special case: literal empty value argument is just an "ensure array" + * operation. + */ + + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD && tokenPtr[1].size == 0) { + if (localIndex >= 0) { + TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); + TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); + } else { + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 5, envPtr); + savedStackDepth = envPtr->currStackDepth; + TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); + TclEmitInstInt1(INST_JUMP1, 3, envPtr); + envPtr->currStackDepth = savedStackDepth; + TclEmitOpcode( INST_POP, envPtr); + } + PushLiteral(envPtr, "", 0); + return TCL_OK; + } + + /* + * Prepare for the internal foreach. + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + iterVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + + infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *)); + infoPtr->numLists = 1; + infoPtr->firstValueTemp = dataVar; + infoPtr->loopCtTemp = iterVar; + infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) * 2*sizeof(int)); + infoPtr->varLists[0]->numVars = 2; + infoPtr->varLists[0]->varIndexes[0] = keyVar; + infoPtr->varLists[0]->varIndexes[1] = valVar; + infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr); + + /* + * Start issuing instructions to write to the array. + */ + + CompileWord(envPtr, tokenPtr, interp, 2); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + PushLiteral(envPtr, "1", 1); + TclEmitOpcode( INST_BITAND, envPtr); + offsetFwd = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); + savedStackDepth = envPtr->currStackDepth; + PushLiteral(envPtr, "list must have an even number of elements", + strlen("list must have an even number of elements")); + PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}", + strlen("-errorCode {TCL ARGUMENT FORMAT}")); + TclEmitInstInt4( INST_RETURN_IMM, 1, envPtr); + TclEmitInt4( 0, envPtr); + envPtr->currStackDepth = savedStackDepth; + fwd = CurrentOffset(envPtr) - offsetFwd; + TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); + Emit14Inst( INST_STORE_SCALAR, dataVar, envPtr); + TclEmitOpcode( INST_POP, envPtr); + + if (localIndex >= 0) { + TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); + TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); + TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); + offsetBack = CurrentOffset(envPtr); + TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); + offsetFwd = CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); + savedStackDepth = envPtr->currStackDepth; + Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); + Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); + Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + back = offsetBack - CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP1, back, envPtr); + fwd = CurrentOffset(envPtr) - offsetFwd; + TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); + envPtr->currStackDepth = savedStackDepth; + } else { + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 4, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); + TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); + offsetBack = CurrentOffset(envPtr); + TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); + offsetFwd = CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); + savedStackDepth = envPtr->currStackDepth; + TclEmitOpcode( INST_DUP, envPtr); + Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); + Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); + TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); + TclEmitOpcode( INST_POP, envPtr); + back = offsetBack - CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP1, back, envPtr); + fwd = CurrentOffset(envPtr) - offsetFwd; + TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); + envPtr->currStackDepth = savedStackDepth; + TclEmitOpcode( INST_POP, envPtr); + } + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( dataVar, envPtr); + PushLiteral(envPtr, "", 0); + return TCL_OK; +} + +int +TclCompileArrayUnsetCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + 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 simpleVarName, isScalar, localIndex, savedStackDepth; + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + PushVarNameWord(interp, tokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); + if (!isScalar) { + return TCL_ERROR; + } + + if (localIndex >= 0) { + TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + TclEmitInstInt1(INST_JUMP_FALSE1, 8, envPtr); + TclEmitInstInt1(INST_UNSET_SCALAR, 1, envPtr); + TclEmitInt4( localIndex, envPtr); + } else { + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); + TclEmitInstInt1(INST_JUMP_FALSE1, 6, envPtr); + savedStackDepth = envPtr->currStackDepth; + TclEmitInstInt1(INST_UNSET_STK, 1, envPtr); + TclEmitInstInt1(INST_JUMP1, 3, envPtr); + envPtr->currStackDepth = savedStackDepth; + TclEmitOpcode( INST_POP, envPtr); + } + PushLiteral(envPtr, "", 0); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileBreakCmd -- * * Procedure called to compile the "break" command. @@ -258,6 +498,7 @@ TclCompileBreakCmd( */ TclEmitOpcode(INST_BREAK, envPtr); + PushLiteral(envPtr, "", 0); /* Evil hack! */ return TCL_OK; } @@ -564,6 +805,7 @@ TclCompileContinueCmd( */ TclEmitOpcode(INST_CONTINUE, envPtr); + PushLiteral(envPtr, "", 0); /* Evil hack! */ return TCL_OK; } @@ -582,26 +824,6 @@ TclCompileContinueCmd( * Instructions are added to envPtr to execute the "dict" subcommand at * runtime. * - * Notes: - * The following commands are in fairly common use and are possibly worth - * bytecoding: - * dict append - * dict create [*] - * dict exists [*] - * dict for - * dict get [*] - * dict incr - * dict keys [*] - * dict lappend - * dict map - * dict set - * dict unset - * - * In practice, those that are pure-value operators (marked with [*]) can - * probably be left alone (except perhaps [dict get] which is very very - * common) and [dict update] should be considered instead (really big - * win!) - * *---------------------------------------------------------------------- */ @@ -666,6 +888,7 @@ TclCompileDictSetCmd( TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr); TclEmitInt4( dictVarIndex, envPtr); + TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -783,6 +1006,7 @@ TclCompileDictGetCmd( tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr); + TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -819,6 +1043,7 @@ TclCompileDictExistsCmd( tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_DICT_EXISTS, numWords-1, envPtr); + TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -879,7 +1104,7 @@ TclCompileDictUnsetCmd( */ TclEmitInstInt4( INST_DICT_UNSET, parsePtr->numWords-2, envPtr); - TclEmitInt4( dictVarIndex, envPtr); + TclEmitInt4( dictVarIndex, envPtr); return TCL_OK; } @@ -967,6 +1192,7 @@ TclCompileDictCreateCmd( tokenPtr = TokenAfter(tokenPtr); TclEmitInstInt4( INST_DICT_SET, 1, envPtr); TclEmitInt4( worker, envPtr); + TclAdjustStackDepth(-1, envPtr); TclEmitOpcode( INST_POP, envPtr); } Emit14Inst( INST_LOAD_SCALAR, worker, envPtr); @@ -1048,6 +1274,7 @@ TclCompileDictMergeCmd( TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitInstInt4( INST_DICT_SET, 1, envPtr); TclEmitInt4( workerIndex, envPtr); + TclAdjustStackDepth(-1, envPtr); TclEmitOpcode( INST_POP, envPtr); TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); TclEmitInstInt1( INST_JUMP_FALSE1, -20, envPtr); @@ -1275,6 +1502,7 @@ CompileDictEachCmd( TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitInstInt4(INST_DICT_SET, 1, envPtr); TclEmitInt4( collectVar, envPtr); + TclAdjustStackDepth(-1, envPtr); TclEmitOpcode( INST_POP, envPtr); } TclEmitOpcode( INST_POP, envPtr); @@ -1337,7 +1565,7 @@ CompileDictEachCmd( * easy!) Note that we skip the END_CATCH. [Bug 1382528] */ - envPtr->currStackDepth = savedStackDepth+2; + envPtr->currStackDepth = savedStackDepth + 2; jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset; TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement, envPtr->codeStart + emptyTargetOffset); @@ -1533,6 +1761,7 @@ TclCompileDictUpdateCmd( (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); } TclStackFree(interp, keyTokenPtrs); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -1781,6 +2010,7 @@ TclCompileDictWithCmd( PushLiteral(envPtr, "", 0); } } + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -1899,6 +2129,7 @@ TclCompileDictWithCmd( * Prepare for the start of the next command. */ + envPtr->currStackDepth = savedStackDepth + 1; if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); @@ -1998,6 +2229,7 @@ TclCompileErrorCmd( * However, we only deal with the case where there is just a message. */ Tcl_Token *messageTokenPtr; + int savedStackDepth = envPtr->currStackDepth; DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 2) { @@ -2008,6 +2240,7 @@ TclCompileErrorCmd( PushLiteral(envPtr, "-code error -level 0", 20); CompileWord(envPtr, messageTokenPtr, interp, 1); TclEmitOpcode(INST_RETURN_STK, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -5238,6 +5471,7 @@ TclCompileReturnCmd( int numWords = parsePtr->numWords; int explicitResult = (0 == (numWords % 2)); int numOptionWords = numWords - 1 - explicitResult; + int savedStackDepth = envPtr->currStackDepth; Tcl_Obj *returnOpts, **objv; Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); DefineLineInformation; /* TIP #280 */ @@ -5260,6 +5494,7 @@ TclCompileReturnCmd( CompileWord(envPtr, optsTokenPtr, interp, 2); CompileWord(envPtr, msgTokenPtr, interp, 3); TclEmitOpcode(INST_RETURN_STK, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 090f996..be63e0e 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -995,6 +995,7 @@ TclSubstCompile( if (state != NULL) { Tcl_RestoreInterpState(interp, state); TclCompileSyntaxError(interp, envPtr); + TclAdjustStackDepth(-1, envPtr); } /* Final target of the multi-jump from all BREAKs */ @@ -1639,6 +1640,7 @@ IssueSwitchJumpTable( int **bodyContLines) /* Array of continuation line info. */ { JumptableInfo *jtPtr; + int savedStackDepth = envPtr->currStackDepth; int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; int mustGenerate, foundDefault, jumpToDefault, i; Tcl_DString buffer; @@ -1751,6 +1753,7 @@ IssueSwitchJumpTable( * Compile the body of the arm. */ + envPtr->currStackDepth = savedStackDepth; envPtr->line = bodyLines[i+1]; /* TIP #280 */ envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); @@ -1782,6 +1785,7 @@ IssueSwitchJumpTable( */ if (!foundDefault) { + envPtr->currStackDepth = savedStackDepth; TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, envPtr->codeStart+jumpToDefault+1); PushLiteral(envPtr, "", 0); @@ -1802,6 +1806,7 @@ IssueSwitchJumpTable( */ TclStackFree(interp, finalFixups); + envPtr->currStackDepth = savedStackDepth + 1; } /* @@ -1957,6 +1962,7 @@ TclCompileThrowCmd( { DefineLineInformation; /* TIP #280 */ int numWords = parsePtr->numWords; + int savedStackDepth = envPtr->currStackDepth; Tcl_Token *codeToken, *msgToken; Tcl_Obj *objPtr; @@ -1987,6 +1993,7 @@ TclCompileThrowCmd( CompileWord(envPtr, msgToken, interp, 2); TclCompileSyntaxError(interp, envPtr); Tcl_DecrRefCount(objPtr); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } if (len == 0) { @@ -2007,6 +2014,7 @@ TclCompileThrowCmd( PushLiteral(envPtr, string, len); TclDecrRefCount(dictPtr); OP44( RETURN_IMM, 1, 0); + envPtr->currStackDepth = savedStackDepth + 1; } else { /* * When the code token is not known at compilation time, we need to do @@ -2035,6 +2043,7 @@ TclCompileThrowCmd( PUSH( ""); OP44( RETURN_IMM, 1, 0); } + envPtr->currStackDepth = savedStackDepth + 1; TclDecrRefCount(objPtr); return TCL_OK; } @@ -2302,6 +2311,7 @@ IssueTryInstructions( { DefineLineInformation; /* TIP #280 */ int range, resultVar, optionsVar; + int savedStackDepth = envPtr->currStackDepth; int i, j, len, forwardsNeedFixing = 0; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; char buf[TCL_INTEGER_SPACE]; @@ -2363,6 +2373,7 @@ IssueTryInstructions( LOAD( optionsVar); PUSH( "-errorcode"); OP4( DICT_GET, 1); + TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); PUSH( TclGetString(matchClauses[i])); OP( STR_EQ); @@ -2403,6 +2414,7 @@ IssueTryInstructions( forwardsToFix[j] = -1; } } + envPtr->currStackDepth = savedStackDepth; BODY( handlerTokens[i], 5+i*4); } @@ -2434,6 +2446,7 @@ IssueTryInstructions( } TclStackFree(interp, forwardsToFix); TclStackFree(interp, addrsToFix); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -2470,6 +2483,7 @@ IssueTryFinallyInstructions( range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); OP4( BEGIN_CATCH4, range); ExceptionRangeStarts(envPtr, range); + envPtr->currStackDepth = savedStackDepth; BODY( bodyToken, 1); ExceptionRangeEnds(envPtr, range); PUSH( "0"); @@ -2514,6 +2528,7 @@ IssueTryFinallyInstructions( LOAD( optionsVar); PUSH( "-errorcode"); OP4( DICT_GET, 1); + TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); PUSH( TclGetString(matchClauses[i])); OP( STR_EQ); @@ -2586,6 +2601,7 @@ IssueTryFinallyInstructions( } OP4( BEGIN_CATCH4, range); } + envPtr->currStackDepth = savedStackDepth; BODY( handlerTokens[i], 5+i*4); ExceptionRangeEnds(envPtr, range); OP( PUSH_RETURN_OPTIONS); @@ -2637,7 +2653,6 @@ IssueTryFinallyInstructions( */ OP( POP); - envPtr->currStackDepth = savedStackDepth; /* * Process the finally clause (at last!) Note that we do not wrap this in @@ -2647,11 +2662,13 @@ IssueTryFinallyInstructions( * next command (or some inter-command manipulation). */ + envPtr->currStackDepth = savedStackDepth; BODY( finallyToken, 3 + 4*numHandlers); OP( POP); LOAD( optionsVar); LOAD( resultVar); OP( RETURN_STK); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 2c87b34..309682d 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -372,13 +372,13 @@ InstructionDesc const tclInstructionTable[] = { * Stack: ... value => ... * Note that the jump table contains offsets relative to the PC when * it points to this instruction; the code is relocatable. */ - {"upvar", 5, 0, 1, {OPERAND_LVT4}}, + {"upvar", 5, -1, 1, {OPERAND_LVT4}}, /* finds level and otherName in stack, links to local variable at * index op1. Leaves the level on stack. */ - {"nsupvar", 5, 0, 1, {OPERAND_LVT4}}, + {"nsupvar", 5, -1, 1, {OPERAND_LVT4}}, /* finds namespace and otherName in stack, links to local variable at * index op1. Leaves the namespace on stack. */ - {"variable", 5, 0, 1, {OPERAND_LVT4}}, + {"variable", 5, -1, 1, {OPERAND_LVT4}}, /* finds namespace and otherName in stack, links to local variable at * index op1. Leaves the namespace on stack. */ {"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, @@ -509,6 +509,26 @@ InstructionDesc const tclInstructionTable[] = { * context. * Stack: ... value => ... boolean */ + {"arrayExistsStk", 1, 0, 0, {OPERAND_NONE}}, + /* Looks up the element on the top of the stack and tests whether it + * is an array. Pushes a boolean describing whether this is the + * case. Also runs the whole-array trace on the named variable, so can + * throw anything. + * Stack: ... varName => ... boolean */ + {"arrayExistsImm", 5, +1, 1, {OPERAND_UINT4}}, + /* Looks up the variable indexed by opnd and tests whether it is an + * array. Pushes a boolean describing whether this is the case. Also + * runs the whole-array trace on the named variable, so can throw + * anything. + * Stack: ... => ... boolean */ + {"arrayMakeStk", 1, -1, 0, {OPERAND_NONE}}, + /* Forces the element on the top of the stack to be the name of an + * array. + * Stack: ... varName => ... */ + {"arrayMakeImm", 5, 0, 1, {OPERAND_UINT4}}, + /* Forces the variable indexed by opnd to be an array. Does not touch + * the stack. */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -1751,6 +1771,9 @@ TclCompileScript( unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; int update = 0; +#ifdef TCL_COMPILE_DEBUG + int startStackDepth = envPtr->currStackDepth; +#endif /* * Mark the start of the command; the proper bytecode @@ -1794,6 +1817,25 @@ TclCompileScript( envPtr); if (code == TCL_OK) { + /* + * Confirm that the command compiler generated a + * single value on the stack as its result. This + * is only done in debugging mode, as it *should* + * be correct and normal users have no reasonable + * way to fix it anyway. + */ + +#ifdef TCL_COMPILE_DEBUG + int diff = envPtr->currStackDepth-startStackDepth; + + if (diff != 1 && (diff != 0 || + *(envPtr->codeNext-1) != INST_DONE)) { + Tcl_Panic("bad stack adjustment when compiling" + " %.*s (was %d instead of 1)", + parsePtr->tokenPtr->size, + parsePtr->tokenPtr->start, diff); + } +#endif if (update) { /* * Fix the bytecode length. diff --git a/generic/tclCompile.h b/generic/tclCompile.h index b080d33..3302f9b 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -705,8 +705,14 @@ typedef struct ByteCode { #define INST_TCLOO_NS 157 #define INST_TCLOO_IS_OBJECT 158 +/* For compilation of [array] subcommands */ +#define INST_ARRAY_EXISTS_STK 159 +#define INST_ARRAY_EXISTS_IMM 160 +#define INST_ARRAY_MAKE_STK 161 +#define INST_ARRAY_MAKE_IMM 162 + /* The last opcode */ -#define LAST_INST_OPCODE 158 +#define LAST_INST_OPCODE 162 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2b29d5c..caf35ba 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2389,14 +2389,18 @@ TEBCresume( } #ifdef TCL_COMPILE_DEBUG - TRACE(("%d [", opnd)); - for (i=opnd-1 ; i>=0 ; i++) { - TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i)))); - if (i > 0) { - TRACE_APPEND((" ")); + { + register int i; + + TRACE(("%d [", opnd)); + for (i=opnd-1 ; i>=0 ; i++) { + TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i)))); + if (i > 0) { + TRACE_APPEND((" ")); + } } + TRACE_APPEND(("] => RETURN...")); } - TRACE_APPEND(("] => RETURN...")); #endif /* @@ -3877,6 +3881,104 @@ TEBCresume( /* * End of INST_UNSET instructions. * ----------------------------------------------------------------- + * Start of INST_ARRAY instructions. + */ + + case INST_ARRAY_EXISTS_IMM: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + cleanup = 0; + part1Ptr = NULL; + arrayPtr = NULL; + TRACE(("%u => ", opnd)); + varPtr = LOCAL(opnd); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + goto doArrayExists; + case INST_ARRAY_EXISTS_STK: + opnd = -1; + pcAdjustment = 1; + cleanup = 1; + part1Ptr = OBJ_AT_TOS; + TRACE(("\"%.30s\" => ", O2S(part1Ptr))); + varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, + /*createPart1*/0, /*createPart2*/0, &arrayPtr); + doArrayExists: + if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + DECACHE_STACK_INFO(); + result = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr, + NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY| + TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd); + CACHE_STACK_INFO(); + if (result == TCL_ERROR) { + TRACE_APPEND(("ERROR: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + } + if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + objResultPtr = TCONST(1); + } else { + objResultPtr = TCONST(0); + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); + + case INST_ARRAY_MAKE_IMM: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + cleanup = 0; + part1Ptr = NULL; + arrayPtr = NULL; + TRACE(("%u => ", opnd)); + varPtr = LOCAL(opnd); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + goto doArrayMake; + case INST_ARRAY_MAKE_STK: + opnd = -1; + pcAdjustment = 1; + cleanup = 1; + part1Ptr = OBJ_AT_TOS; + TRACE(("\"%.30s\" => ", O2S(part1Ptr))); + varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG, + "set", /*createPart1*/1, /*createPart2*/0, &arrayPtr); + if (varPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + doArrayMake: + if (varPtr && !TclIsVarArray(varPtr)) { + if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) { + /* + * Either an array element, or a scalar: lose! + */ + + TclObjVarErrMsg(interp, part1Ptr, NULL, "array set", + "variable isn't array", opnd); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + TRACE_APPEND(("ERROR: bad array ref: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + TclSetVarArray(varPtr); + varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); + TclInitVarHashTable(varPtr->value.tablePtr, + TclGetVarNsPtr(varPtr)); +#ifdef TCL_COMPILE_DEBUG + TRACE_APPEND(("done\n")); + } else { + TRACE_APPEND(("nothing to do\n")); +#endif + } + NEXT_INST_V(pcAdjustment, cleanup, 0); + + /* + * End of INST_ARRAY instructions. + * ----------------------------------------------------------------- * Start of variable linking instructions. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 7dc21c1..1d04c82 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3491,6 +3491,15 @@ MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData, MODULE_SCOPE int TclCompileAppendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileArrayExistsCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileArraySetCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileArrayUnsetCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/generic/tclVar.c b/generic/tclVar.c index e31e9cf..1c01e41 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -4224,15 +4224,15 @@ TclInitArrayCmd( static const EnsembleImplMap arrayImplMap[] = { {"anymore", ArrayAnyMoreCmd, NULL, NULL, NULL, 0}, {"donesearch", ArrayDoneSearchCmd, NULL, NULL, NULL, 0}, - {"exists", ArrayExistsCmd, NULL, NULL, NULL, 0}, + {"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0}, {"get", ArrayGetCmd, NULL, NULL, NULL, 0}, {"names", ArrayNamesCmd, NULL, NULL, NULL, 0}, {"nextelement", ArrayNextElementCmd, NULL, NULL, NULL, 0}, - {"set", ArraySetCmd, NULL, NULL, NULL, 0}, + {"set", ArraySetCmd, TclCompileArraySetCmd, NULL, NULL, 0}, {"size", ArraySizeCmd, NULL, NULL, NULL, 0}, {"startsearch", ArrayStartSearchCmd, NULL, NULL, NULL, 0}, {"statistics", ArrayStatsCmd, NULL, NULL, NULL, 0}, - {"unset", ArrayUnsetCmd, NULL, NULL, NULL, 0}, + {"unset", ArrayUnsetCmd, TclCompileArrayUnsetCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; -- cgit v0.12