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

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

4 files changed, 188 insertions, 8 deletions

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));