From 33dbda15badb308ceba71336a5fc9b2ee711250f Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Tue, 11 Jun 2002 13:22:35 +0000 Subject: Fix for [info locals] bug #567386; added compile functions for [global], [upvar] and [variable]. --- ChangeLog | 17 ++++- doc/global.n | 5 +- doc/info.n | 6 +- generic/tclBasic.c | 8 +-- generic/tclCmdIL.c | 5 +- generic/tclCompCmds.c | 175 +++++++++++++++++++++++++++++++++++++++++++++++++- generic/tclInt.h | 8 ++- tests/info.test | 4 +- 8 files changed, 211 insertions(+), 17 deletions(-) diff --git a/ChangeLog b/ChangeLog index eaa3333..ca8212a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,19 @@ -2002-06-10 Miguel Sofer +2002-06-11 Miguel Sofer + + * doc/global.n: + * doc/info.n: + * test/info.test: + * generic/tclCmdIL.c: fix for [Bug 567386], [info locals] was + reporting some linked variables. + + * generic/tclBasic.c: + * generic/tclCompCmds.c: + * generic/tclInt.h: added compile functions for [global], + [variable] and [upvar]. They just declare the new local variables, + the commands themselves are not compiled-in. This gives a notably + faster read access to these linked variables. + +2002-06-11 Miguel Sofer * generic/tclExecute.c: optimised algorithm for exception range lookup; part of [Patch 453709]. diff --git a/doc/global.n b/doc/global.n index 2b8787a..d4fd4c0 100644 --- a/doc/global.n +++ b/doc/global.n @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: global.n,v 1.3 2000/11/21 15:56:21 dkf Exp $ +'\" RCS: @(#) $Id: global.n,v 1.4 2002/06/11 13:22:35 msofer Exp $ '\" .so man.macros .TH global n "" Tcl "Tcl Built-In Commands" @@ -28,9 +28,6 @@ For the duration of the current procedure any reference to any of the \fIvarname\fRs will refer to the global variable by the same name. .PP -Please note that this is done by creating local variables that are -linked to the global variables, and therefore that these variables -will be listed by \fBinfo locals\fR like all other local variables. .SH "SEE ALSO" namespace(n), upvar(n), variable(n) diff --git a/doc/info.n b/doc/info.n index 3ddd9e9..ab78347 100644 --- a/doc/info.n +++ b/doc/info.n @@ -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. '\" -'\" RCS: @(#) $Id: info.n,v 1.7 2001/05/30 08:57:06 dkf Exp $ +'\" RCS: @(#) $Id: info.n,v 1.8 2002/06/11 13:22:35 msofer Exp $ '\" .so man.macros .TH info n 8.4 Tcl "Tcl Built-In Commands" @@ -140,8 +140,8 @@ an empty string for the \fIinterp\fR argument. If \fIpattern\fR isn't specified, returns a list of all the names of currently-defined local variables, including arguments to the current procedure, if any. -Variables defined with the \fBglobal\fR and \fBupvar\fR commands -will not be returned. +Variables defined with the \fBglobal\fR, \fBupvar\fR and +\fBvariable\fR commands will not be returned. If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. diff --git a/generic/tclBasic.c b/generic/tclBasic.c index bb72114..7be14aa 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.56 2002/03/29 21:01:11 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.57 2002/06/11 13:22:35 msofer Exp $ */ #include "tclInt.h" @@ -109,7 +109,7 @@ static CmdInfo builtInCmds[] = { {"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd, (CompileProc *) NULL, 1}, {"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd, - (CompileProc *) NULL, 1}, + TclCompileGlobalCmd, 1}, {"if", (Tcl_CmdProc *) NULL, Tcl_IfObjCmd, TclCompileIfCmd, 1}, {"incr", (Tcl_CmdProc *) NULL, Tcl_IncrObjCmd, @@ -173,9 +173,9 @@ static CmdInfo builtInCmds[] = { {"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd, (CompileProc *) NULL, 1}, {"upvar", (Tcl_CmdProc *) NULL, Tcl_UpvarObjCmd, - (CompileProc *) NULL, 1}, + TclCompileUpvarCmd, 1}, {"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd, - (CompileProc *) NULL, 1}, + TclCompileVariableCmd, 1}, {"while", (Tcl_CmdProc *) NULL, Tcl_WhileObjCmd, TclCompileWhileCmd, 1}, diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 3e1f0da..36b1ef5 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.43 2002/04/18 14:12:07 dkf Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.44 2002/06/11 13:22:36 msofer Exp $ */ #include "tclInt.h" @@ -1387,7 +1387,8 @@ AppendLocals(interp, listPtr, pattern, includeLinks) * Skip nameless (temporary) variables and undefined variables */ - if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)) { + if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr) + && (includeLinks || !TclIsVarLink(varPtr))) { varName = varPtr->name; if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { Tcl_ListObjAppendElement(interp, listPtr, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index fefc33a..a9b04a2 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.28 2002/05/29 09:09:12 hobbs Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.29 2002/06/11 13:22:36 msofer Exp $ */ #include "tclInt.h" @@ -1117,6 +1117,59 @@ FreeForeachInfo(clientData) /* *---------------------------------------------------------------------- * + * TclCompileGlobalCmd -- + * + * Procedure called to reserve the local variables for the + * "global" command. The command itself is *not* compiled. + * + * Results: + * Always returns TCL_OUT_LINE_COMPILE. + * + * Side effects: + * Indexed local variables are added to the environment. + * + *---------------------------------------------------------------------- + */ +int +TclCompileGlobalCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr; + int i, numWords; + char *varName, *tail; + + if (envPtr->procPtr == NULL) { + return TCL_OUT_LINE_COMPILE; + } + numWords = parsePtr->numWords; + + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + for (i = 1; i < numWords; i++) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + varName = varTokenPtr[1].start; + tail = varName + varTokenPtr[1].size - 1; + if ((*tail == ')') || (tail < varName)) continue; + while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) { + tail--; + } + if ((*tail == ':') && (tail > varName)) { + tail++; + } + (void) TclFindCompiledLocal(tail, (tail-varName+1), + /*create*/ 1, /*flags*/ 0, envPtr->procPtr); + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + } + } + return TCL_OUT_LINE_COMPILE; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileIfCmd -- * * Procedure called to compile the "if" command. @@ -2845,6 +2898,126 @@ TclCompileStringCmd(interp, parsePtr, envPtr) /* *---------------------------------------------------------------------- * + * TclCompileUpvarCmd -- + * + * Procedure called to reserve the local variables for the + * "upvar" command. The command itself is *not* compiled. + * + * Results: + * Always returns TCL_OUT_LINE_COMPILE. + * + * Side effects: + * Indexed local variables are added to the environment. + * + *---------------------------------------------------------------------- + */ +int +TclCompileUpvarCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr; + int i, numWords; + char *varName, *tail; + + if (envPtr->procPtr == NULL) { + return TCL_OUT_LINE_COMPILE; + } + + numWords = parsePtr->numWords; + + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + varName = varTokenPtr[1].start; + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + i = 2; + + if ((*varName == '#') || (isdigit(UCHAR(*varName)))) { + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + i++; + } + + for (; i < numWords; i += 2) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + varName = varTokenPtr[1].start; + tail = varName + varTokenPtr[1].size - 1; + if ((*tail == ')') || (tail < varName)) { + break; + } + while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) { + tail--; + } + if (tail != varName) { + break; + } + (void) TclFindCompiledLocal(tail, (tail-varName+1), + /*create*/ 1, /*flags*/ 0, envPtr->procPtr); + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + } + } + return TCL_OUT_LINE_COMPILE; +} + + +/* + *---------------------------------------------------------------------- + * + * TclCompileVariableCmd -- + * + * Procedure called to reserve the local variables for the + * "variable" command. The command itself is *not* compiled. + * + * Results: + * Always returns TCL_OUT_LINE_COMPILE. + * + * Side effects: + * Indexed local variables are added to the environment. + * + *---------------------------------------------------------------------- + */ +int +TclCompileVariableCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr; + int i, numWords; + char *varName, *tail; + + if (envPtr->procPtr == NULL) { + return TCL_OUT_LINE_COMPILE; + } + + numWords = parsePtr->numWords; + + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + for (i = 1; i < numWords; i += 2) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + varName = varTokenPtr[1].start; + tail = varName + varTokenPtr[1].size - 1; + if ((*tail == ')') || (tail < varName)) continue; + while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) { + tail--; + } + if ((*tail == ':') && (tail > varName)) { + tail++; + } + (void) TclFindCompiledLocal(tail, (tail-varName+1), + /*create*/ 1, /*flags*/ 0, envPtr->procPtr); + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + } + } + return TCL_OUT_LINE_COMPILE; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileWhileCmd -- * * Procedure called to compile the "while" command. diff --git a/generic/tclInt.h b/generic/tclInt.h index 9cea9d7..a6d5259 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.91 2002/05/31 22:20:20 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.92 2002/06/11 13:22:36 msofer Exp $ */ #ifndef _TCLINT @@ -2127,6 +2127,8 @@ EXTERN int TclCompileForCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileForeachCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileGlobalCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileIfCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileIncrCmd _ANSI_ARGS_((Tcl_Interp *interp, @@ -2149,6 +2151,10 @@ EXTERN int TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileStringCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileUpvarCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileVariableCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); diff --git a/tests/info.test b/tests/info.test index 801df6f..686aa35 100644 --- a/tests/info.test +++ b/tests/info.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: info.test,v 1.20 2002/04/18 18:05:59 msofer Exp $ +# RCS: @(#) $Id: info.test,v 1.21 2002/06/11 13:22:36 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -371,6 +371,8 @@ test info-12.1 {info locals option} { set b 13 set c testing global a + global aa + set aa 23 return [info locals] } lsort [t1 23 24] -- cgit v0.12