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

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

1 files changed, 174 insertions, 1 deletions

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.