Fix for [info locals] bug #567386; added compile functions for

[global], [upvar] and [variable].

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  <msofer@users.sourceforge.net>
+2002-06-11  Miguel Sofer  <msofer@users.sourceforge.net>
+
+	* 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  <msofer@users.sourceforge.net>
 
 	* 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]