sl@0: /* 
sl@0:  * tclProc.c --
sl@0:  *
sl@0:  *	This file contains routines that implement Tcl procedures,
sl@0:  *	including the "proc" and "uplevel" commands.
sl@0:  *
sl@0:  * Copyright (c) 1987-1993 The Regents of the University of California.
sl@0:  * Copyright (c) 1994-1998 Sun Microsystems, Inc.
sl@0:  * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.  
sl@0:  *
sl@0:  * See the file "license.terms" for information on usage and redistribution
sl@0:  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0:  *
sl@0:  * RCS: @(#) $Id: tclProc.c,v 1.44.2.6 2006/11/28 22:20:02 andreas_kupries Exp $
sl@0:  */
sl@0: 
sl@0: #include "tclInt.h"
sl@0: #include "tclCompile.h"
sl@0: 
sl@0: /*
sl@0:  * Prototypes for static functions in this file
sl@0:  */
sl@0: 
sl@0: static void	ProcBodyDup _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr));
sl@0: static void	ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr));
sl@0: static int	ProcBodySetFromAny _ANSI_ARGS_((Tcl_Interp *interp,
sl@0: 		Tcl_Obj *objPtr));
sl@0: static void	ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr));
sl@0: static int	ProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp,
sl@0: 		    Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr,
sl@0: 		    CONST char *description, CONST char *procName,
sl@0: 		    Proc **procPtrPtr));
sl@0: static  int	ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp,
sl@0: 		    char *procName, int nameLen, int returnCode));
sl@0: static int	TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp,
sl@0: 		    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
sl@0: 
sl@0: /*
sl@0:  * The ProcBodyObjType type
sl@0:  */
sl@0: 
sl@0: Tcl_ObjType tclProcBodyType = {
sl@0:     "procbody",			/* name for this type */
sl@0:     ProcBodyFree,		/* FreeInternalRep procedure */
sl@0:     ProcBodyDup,		/* DupInternalRep procedure */
sl@0:     ProcBodyUpdateString,	/* UpdateString procedure */
sl@0:     ProcBodySetFromAny		/* SetFromAny procedure */
sl@0: };
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * Tcl_ProcObjCmd --
sl@0:  *
sl@0:  *	This object-based procedure is invoked to process the "proc" Tcl 
sl@0:  *	command. See the user documentation for details on what it does.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl object result value.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	A new procedure gets created.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: 	/* ARGSUSED */
sl@0: EXPORT_C int
sl@0: Tcl_ProcObjCmd(dummy, interp, objc, objv)
sl@0:     ClientData dummy;		/* Not used. */
sl@0:     Tcl_Interp *interp;		/* Current interpreter. */
sl@0:     int objc;			/* Number of arguments. */
sl@0:     Tcl_Obj *CONST objv[];	/* Argument objects. */
sl@0: {
sl@0:     register Interp *iPtr = (Interp *) interp;
sl@0:     Proc *procPtr;
sl@0:     char *fullName;
sl@0:     CONST char *procName, *procArgs, *procBody;
sl@0:     Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
sl@0:     Tcl_Command cmd;
sl@0:     Tcl_DString ds;
sl@0: 
sl@0:     if (objc != 4) {
sl@0: 	Tcl_WrongNumArgs(interp, 1, objv, "name args body");
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      * Determine the namespace where the procedure should reside. Unless
sl@0:      * the command name includes namespace qualifiers, this will be the
sl@0:      * current namespace.
sl@0:      */
sl@0:     
sl@0:     fullName = TclGetString(objv[1]);
sl@0:     TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL,
sl@0: 	    0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
sl@0: 
sl@0:     if (nsPtr == NULL) {
sl@0:         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0: 		"can't create procedure \"", fullName,
sl@0: 		"\": unknown namespace", (char *) NULL);
sl@0:         return TCL_ERROR;
sl@0:     }
sl@0:     if (procName == NULL) {
sl@0: 	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0: 		"can't create procedure \"", fullName,
sl@0: 		"\": bad procedure name", (char *) NULL);
sl@0:         return TCL_ERROR;
sl@0:     }
sl@0:     if ((nsPtr != iPtr->globalNsPtr)
sl@0: 	    && (procName != NULL) && (procName[0] == ':')) {
sl@0: 	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0: 		"can't create procedure \"", procName,
sl@0: 		"\" in non-global namespace with name starting with \":\"",
sl@0: 	        (char *) NULL);
sl@0:         return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      *  Create the data structure to represent the procedure.
sl@0:      */
sl@0:     if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
sl@0:         &procPtr) != TCL_OK) {
sl@0:         return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      * Now create a command for the procedure. This will initially be in
sl@0:      * the current namespace unless the procedure's name included namespace
sl@0:      * qualifiers. To create the new command in the right namespace, we
sl@0:      * generate a fully qualified name for it.
sl@0:      */
sl@0: 
sl@0:     Tcl_DStringInit(&ds);
sl@0:     if (nsPtr != iPtr->globalNsPtr) {
sl@0: 	Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
sl@0: 	Tcl_DStringAppend(&ds, "::", 2);
sl@0:     }
sl@0:     Tcl_DStringAppend(&ds, procName, -1);
sl@0:     
sl@0:     Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), TclProcInterpProc,
sl@0: 	    (ClientData) procPtr, TclProcDeleteProc);
sl@0:     cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
sl@0: 	    TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc);
sl@0: 
sl@0:     Tcl_DStringFree(&ds);
sl@0:     /*
sl@0:      * Now initialize the new procedure's cmdPtr field. This will be used
sl@0:      * later when the procedure is called to determine what namespace the
sl@0:      * procedure will run in. This will be different than the current
sl@0:      * namespace if the proc was renamed into a different namespace.
sl@0:      */
sl@0:     
sl@0:     procPtr->cmdPtr = (Command *) cmd;
sl@0: 
sl@0: #ifdef TCL_TIP280
sl@0:     /* TIP #280 Remember the line the procedure body is starting on. In a
sl@0:      * Byte code context we ask the engine to provide us with the necessary
sl@0:      * information. This is for the initialization of the byte code compiler
sl@0:      * when the body is used for the first time.
sl@0:      */
sl@0: 
sl@0:     if (iPtr->cmdFramePtr) {
sl@0:         CmdFrame context = *iPtr->cmdFramePtr;
sl@0: 
sl@0: 	if (context.type == TCL_LOCATION_BC) {
sl@0: 	    TclGetSrcInfoForPc (&context);
sl@0: 	    /* May get path in context */
sl@0: 	} else if (context.type == TCL_LOCATION_SOURCE) {
sl@0: 	    /* context now holds another reference */
sl@0: 	    Tcl_IncrRefCount (context.data.eval.path);
sl@0: 	}
sl@0: 
sl@0: 	/* type == TCL_LOCATION_PREBC implies that 'line' is NULL here!  We
sl@0: 	 * cannot assume that 'line' is valid here, we have to check. If the
sl@0: 	 * outer context is an eval (bc, prebc, eval) we do not save any
sl@0: 	 * information. Counting relative to the beginning of the proc body is
sl@0: 	 * more sensible than counting relative to the outer eval block.
sl@0: 	 */
sl@0: 
sl@0: 	if ((context.type == TCL_LOCATION_SOURCE) &&
sl@0: 	    context.line &&
sl@0: 	    (context.nline >= 4) &&
sl@0: 	    (context.line [3] >= 0)) {
sl@0: 	    int       new;
sl@0: 	    CmdFrame* cfPtr = (CmdFrame*) ckalloc (sizeof (CmdFrame));
sl@0: 
sl@0: 	    cfPtr->level    = -1;
sl@0: 	    cfPtr->type     = context.type;
sl@0: 	    cfPtr->line     = (int*) ckalloc (sizeof (int));
sl@0: 	    cfPtr->line [0] = context.line [3];
sl@0: 	    cfPtr->nline    = 1;
sl@0: 	    cfPtr->framePtr = NULL;
sl@0: 	    cfPtr->nextPtr  = NULL;
sl@0: 
sl@0: 	    if (context.type == TCL_LOCATION_SOURCE) {
sl@0: 	        cfPtr->data.eval.path = context.data.eval.path;
sl@0: 		/* Transfer of reference. The reference going away (release of
sl@0: 		 * the context) is replaced by the reference in the
sl@0: 		 * constructed cmdframe */
sl@0: 	    } else {
sl@0: 	        cfPtr->type = TCL_LOCATION_EVAL;
sl@0: 		cfPtr->data.eval.path = NULL;
sl@0: 	    }
sl@0: 
sl@0: 	    cfPtr->cmd.str.cmd = NULL;
sl@0: 	    cfPtr->cmd.str.len = 0;
sl@0: 
sl@0: 	    Tcl_SetHashValue (Tcl_CreateHashEntry (iPtr->linePBodyPtr,
sl@0: 						   (char*) procPtr, &new),
sl@0: 			      cfPtr);
sl@0: 	}
sl@0:     }
sl@0: #endif
sl@0: 
sl@0:     /*
sl@0:      * Optimize for noop procs: if the body is not precompiled (like a TclPro
sl@0:      * procbody), and the argument list is just "args" and the body is empty,
sl@0:      * define a compileProc to compile a noop.
sl@0:      *
sl@0:      * Notes: 
sl@0:      *   - cannot be done for any argument list without having different
sl@0:      *     compiled/not-compiled behaviour in the "wrong argument #" case, 
sl@0:      *     or making this code much more complicated. In any case, it doesn't 
sl@0:      *     seem to make a lot of sense to verify the number of arguments we 
sl@0:      *     are about to ignore ...
sl@0:      *   - could be enhanced to handle also non-empty bodies that contain 
sl@0:      *     only comments; however, parsing the body will slow down the 
sl@0:      *     compilation of all procs whose argument list is just _args_ */
sl@0: 
sl@0:     if (objv[3]->typePtr == &tclProcBodyType) {
sl@0: 	goto done;
sl@0:     }
sl@0: 
sl@0:     procArgs = Tcl_GetString(objv[2]);
sl@0:     
sl@0:     while (*procArgs == ' ') {
sl@0: 	procArgs++;
sl@0:     }
sl@0:     
sl@0:     if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
sl@0: 	procArgs +=4;
sl@0: 	while(*procArgs != '\0') {
sl@0: 	    if (*procArgs != ' ') {
sl@0: 		goto done;
sl@0: 	    }
sl@0: 	    procArgs++;
sl@0: 	}	
sl@0: 	
sl@0: 	/* 
sl@0: 	 * The argument list is just "args"; check the body
sl@0: 	 */
sl@0: 	
sl@0: 	procBody = Tcl_GetString(objv[3]);
sl@0: 	while (*procBody != '\0') {
sl@0: 	    if (!isspace(UCHAR(*procBody))) {
sl@0: 		goto done;
sl@0: 	    }
sl@0: 	    procBody++;
sl@0: 	}	
sl@0: 	
sl@0: 	/* 
sl@0: 	 * The body is just spaces: link the compileProc
sl@0: 	 */
sl@0: 	
sl@0: 	((Command *) cmd)->compileProc = TclCompileNoOp;
sl@0:     }
sl@0: 
sl@0:  done:
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclCreateProc --
sl@0:  *
sl@0:  *	Creates the data associated with a Tcl procedure definition.
sl@0:  *	This procedure knows how to handle two types of body objects:
sl@0:  *	strings and procbody. Strings are the traditional (and common) value
sl@0:  *	for bodies, procbody are values created by extensions that have
sl@0:  *	loaded a previously compiled script.
sl@0:  *
sl@0:  * Results:
sl@0:  *	Returns TCL_OK on success, along with a pointer to a Tcl
sl@0:  *	procedure definition in procPtrPtr.  This definition should
sl@0:  *	be freed by calling TclCleanupProc() when it is no longer
sl@0:  *	needed.  Returns TCL_ERROR if anything goes wrong.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	If anything goes wrong, this procedure returns an error
sl@0:  *	message in the interpreter.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: int
sl@0: TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
sl@0:     Tcl_Interp *interp;         /* interpreter containing proc */
sl@0:     Namespace *nsPtr;           /* namespace containing this proc */
sl@0:     CONST char *procName;       /* unqualified name of this proc */
sl@0:     Tcl_Obj *argsPtr;           /* description of arguments */
sl@0:     Tcl_Obj *bodyPtr;           /* command body */
sl@0:     Proc **procPtrPtr;          /* returns:  pointer to proc data */
sl@0: {
sl@0:     Interp *iPtr = (Interp*)interp;
sl@0:     CONST char **argArray = NULL;
sl@0: 
sl@0:     register Proc *procPtr;
sl@0:     int i, length, result, numArgs;
sl@0:     CONST char *args, *bytes, *p;
sl@0:     register CompiledLocal *localPtr = NULL;
sl@0:     Tcl_Obj *defPtr;
sl@0:     int precompiled = 0;
sl@0:     
sl@0:     if (bodyPtr->typePtr == &tclProcBodyType) {
sl@0:         /*
sl@0:          * Because the body is a TclProProcBody, the actual body is already
sl@0:          * compiled, and it is not shared with anyone else, so it's OK not to
sl@0:          * unshare it (as a matter of fact, it is bad to unshare it, because
sl@0:          * there may be no source code).
sl@0:          *
sl@0:          * We don't create and initialize a Proc structure for the procedure;
sl@0:          * rather, we use what is in the body object. Note that
sl@0:          * we initialize its cmdPtr field below after we've created the command
sl@0:          * for the procedure. We increment the ref count of the Proc struct
sl@0:          * since the command (soon to be created) will be holding a reference
sl@0:          * to it.
sl@0:          */
sl@0:     
sl@0:         procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr;
sl@0:         procPtr->iPtr = iPtr;
sl@0:         procPtr->refCount++;
sl@0:         precompiled = 1;
sl@0:     } else {
sl@0:         /*
sl@0:          * If the procedure's body object is shared because its string value is
sl@0:          * identical to, e.g., the body of another procedure, we must create a
sl@0:          * private copy for this procedure to use. Such sharing of procedure
sl@0:          * bodies is rare but can cause problems. A procedure body is compiled
sl@0:          * in a context that includes the number of compiler-allocated "slots"
sl@0:          * for local variables. Each formal parameter is given a local variable
sl@0:          * slot (the "procPtr->numCompiledLocals = numArgs" assignment
sl@0:          * below). This means that the same code can not be shared by two
sl@0:          * procedures that have a different number of arguments, even if their
sl@0:          * bodies are identical. Note that we don't use Tcl_DuplicateObj since
sl@0:          * we would not want any bytecode internal representation.
sl@0:          */
sl@0: 
sl@0:         if (Tcl_IsShared(bodyPtr)) {
sl@0:             bytes = Tcl_GetStringFromObj(bodyPtr, &length);
sl@0:             bodyPtr = Tcl_NewStringObj(bytes, length);
sl@0:         }
sl@0: 
sl@0:         /*
sl@0:          * Create and initialize a Proc structure for the procedure. Note that
sl@0:          * we initialize its cmdPtr field below after we've created the command
sl@0:          * for the procedure. We increment the ref count of the procedure's
sl@0:          * body object since there will be a reference to it in the Proc
sl@0:          * structure.
sl@0:          */
sl@0:     
sl@0:         Tcl_IncrRefCount(bodyPtr);
sl@0: 
sl@0:         procPtr = (Proc *) ckalloc(sizeof(Proc));
sl@0:         procPtr->iPtr = iPtr;
sl@0:         procPtr->refCount = 1;
sl@0:         procPtr->bodyPtr = bodyPtr;
sl@0:         procPtr->numArgs  = 0;	/* actual argument count is set below. */
sl@0:         procPtr->numCompiledLocals = 0;
sl@0:         procPtr->firstLocalPtr = NULL;
sl@0:         procPtr->lastLocalPtr = NULL;
sl@0:     }
sl@0:     
sl@0:     /*
sl@0:      * Break up the argument list into argument specifiers, then process
sl@0:      * each argument specifier.
sl@0:      * If the body is precompiled, processing is limited to checking that
sl@0:      * the the parsed argument is consistent with the one stored in the
sl@0:      * Proc.
sl@0:      * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS.
sl@0:      */
sl@0: 
sl@0:     args = Tcl_GetStringFromObj(argsPtr, &length);
sl@0:     result = Tcl_SplitList(interp, args, &numArgs, &argArray);
sl@0:     if (result != TCL_OK) {
sl@0:         goto procError;
sl@0:     }
sl@0: 
sl@0:     if (precompiled) {
sl@0:         if (numArgs > procPtr->numArgs) {
sl@0:             char buf[64 + TCL_INTEGER_SPACE + TCL_INTEGER_SPACE];
sl@0:             sprintf(buf, "\": arg list contains %d entries, precompiled header expects %d",
sl@0:                     numArgs, procPtr->numArgs);
sl@0:             Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0:                     "procedure \"", procName,
sl@0:                     buf, (char *) NULL);
sl@0:             goto procError;
sl@0:         }
sl@0:         localPtr = procPtr->firstLocalPtr;
sl@0:     } else {
sl@0:         procPtr->numArgs = numArgs;
sl@0:         procPtr->numCompiledLocals = numArgs;
sl@0:     }
sl@0:     for (i = 0;  i < numArgs;  i++) {
sl@0:         int fieldCount, nameLength, valueLength;
sl@0:         CONST char **fieldValues;
sl@0: 
sl@0:         /*
sl@0:          * Now divide the specifier up into name and default.
sl@0:          */
sl@0: 
sl@0:         result = Tcl_SplitList(interp, argArray[i], &fieldCount,
sl@0:                 &fieldValues);
sl@0:         if (result != TCL_OK) {
sl@0:             goto procError;
sl@0:         }
sl@0:         if (fieldCount > 2) {
sl@0:             ckfree((char *) fieldValues);
sl@0:             Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0:                     "too many fields in argument specifier \"",
sl@0:                     argArray[i], "\"", (char *) NULL);
sl@0:             goto procError;
sl@0:         }
sl@0:         if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
sl@0:             ckfree((char *) fieldValues);
sl@0:             Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0:                     "procedure \"", procName,
sl@0:                     "\" has argument with no name", (char *) NULL);
sl@0:             goto procError;
sl@0:         }
sl@0: 	
sl@0:         nameLength = strlen(fieldValues[0]);
sl@0:         if (fieldCount == 2) {
sl@0:             valueLength = strlen(fieldValues[1]);
sl@0:         } else {
sl@0:             valueLength = 0;
sl@0:         }
sl@0: 
sl@0:         /*
sl@0:          * Check that the formal parameter name is a scalar.
sl@0:          */
sl@0: 
sl@0:         p = fieldValues[0];
sl@0:         while (*p != '\0') {
sl@0:             if (*p == '(') {
sl@0:                 CONST char *q = p;
sl@0:                 do {
sl@0: 		    q++;
sl@0: 		} while (*q != '\0');
sl@0: 		q--;
sl@0: 		if (*q == ')') { /* we have an array element */
sl@0: 		    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0: 		            "procedure \"", procName,
sl@0: 		            "\" has formal parameter \"", fieldValues[0],
sl@0: 			    "\" that is an array element",
sl@0: 			    (char *) NULL);
sl@0: 		    ckfree((char *) fieldValues);
sl@0: 		    goto procError;
sl@0: 		}
sl@0: 	    } else if ((*p == ':') && (*(p+1) == ':')) {
sl@0: 		Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0: 		        "procedure \"", procName,
sl@0: 		        "\" has formal parameter \"", fieldValues[0],
sl@0: 			"\" that is not a simple name",
sl@0: 			(char *) NULL);
sl@0: 		ckfree((char *) fieldValues);
sl@0: 		goto procError;
sl@0: 	    }
sl@0: 	    p++;
sl@0: 	}
sl@0: 
sl@0: 	if (precompiled) {
sl@0: 	    /*
sl@0: 	     * Compare the parsed argument with the stored one.
sl@0: 	     * For the flags, we and out VAR_UNDEFINED to support bridging
sl@0: 	     * precompiled <= 8.3 code in 8.4 where this is now used as an
sl@0: 	     * optimization indicator.	Yes, this is a hack. -- hobbs
sl@0: 	     */
sl@0: 
sl@0: 	    if ((localPtr->nameLength != nameLength)
sl@0: 		    || (strcmp(localPtr->name, fieldValues[0]))
sl@0: 		    || (localPtr->frameIndex != i)
sl@0: 		    || ((localPtr->flags & ~VAR_UNDEFINED)
sl@0: 			    != (VAR_SCALAR | VAR_ARGUMENT))
sl@0: 		    || ((localPtr->defValuePtr == NULL)
sl@0: 			    && (fieldCount == 2))
sl@0: 		    || ((localPtr->defValuePtr != NULL)
sl@0: 			    && (fieldCount != 2))) {
sl@0: 		char buf[80 + TCL_INTEGER_SPACE];
sl@0: 		sprintf(buf, "\": formal parameter %d is inconsistent with precompiled body",
sl@0: 			i);
sl@0: 		Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0: 			"procedure \"", procName,
sl@0: 			buf, (char *) NULL);
sl@0: 		ckfree((char *) fieldValues);
sl@0: 		goto procError;
sl@0: 	    }
sl@0: 
sl@0:             /*
sl@0:              * compare the default value if any
sl@0:              */
sl@0: 
sl@0:             if (localPtr->defValuePtr != NULL) {
sl@0:                 int tmpLength;
sl@0:                 char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr,
sl@0:                         &tmpLength);
sl@0:                 if ((valueLength != tmpLength)
sl@0:                         || (strncmp(fieldValues[1], tmpPtr,
sl@0:                                 (size_t) tmpLength))) {
sl@0:                     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0:                             "procedure \"", procName,
sl@0:                             "\": formal parameter \"",
sl@0:                             fieldValues[0],
sl@0:                             "\" has default value inconsistent with precompiled body",
sl@0:                             (char *) NULL);
sl@0:                     ckfree((char *) fieldValues);
sl@0:                     goto procError;
sl@0:                 }
sl@0:             }
sl@0: 
sl@0:             localPtr = localPtr->nextPtr;
sl@0:         } else {
sl@0:             /*
sl@0:              * Allocate an entry in the runtime procedure frame's array of
sl@0:              * local variables for the argument. 
sl@0:              */
sl@0: 
sl@0:             localPtr = (CompiledLocal *) ckalloc((unsigned) 
sl@0:                     (sizeof(CompiledLocal) - sizeof(localPtr->name)
sl@0:                             + nameLength+1));
sl@0:             if (procPtr->firstLocalPtr == NULL) {
sl@0:                 procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
sl@0:             } else {
sl@0:                 procPtr->lastLocalPtr->nextPtr = localPtr;
sl@0:                 procPtr->lastLocalPtr = localPtr;
sl@0:             }
sl@0:             localPtr->nextPtr = NULL;
sl@0:             localPtr->nameLength = nameLength;
sl@0:             localPtr->frameIndex = i;
sl@0:             localPtr->flags = VAR_SCALAR | VAR_ARGUMENT;
sl@0:             localPtr->resolveInfo = NULL;
sl@0: 	
sl@0:             if (fieldCount == 2) {
sl@0:                 localPtr->defValuePtr =
sl@0: 		    Tcl_NewStringObj(fieldValues[1], valueLength);
sl@0:                 Tcl_IncrRefCount(localPtr->defValuePtr);
sl@0:             } else {
sl@0:                 localPtr->defValuePtr = NULL;
sl@0:             }
sl@0:             strcpy(localPtr->name, fieldValues[0]);
sl@0: 	}
sl@0: 
sl@0:         ckfree((char *) fieldValues);
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      * Now initialize the new procedure's cmdPtr field. This will be used
sl@0:      * later when the procedure is called to determine what namespace the
sl@0:      * procedure will run in. This will be different than the current
sl@0:      * namespace if the proc was renamed into a different namespace.
sl@0:      */
sl@0:     
sl@0:     *procPtrPtr = procPtr;
sl@0:     ckfree((char *) argArray);
sl@0:     return TCL_OK;
sl@0: 
sl@0: procError:
sl@0:     if (precompiled) {
sl@0:         procPtr->refCount--;
sl@0:     } else {
sl@0:         Tcl_DecrRefCount(bodyPtr);
sl@0:         while (procPtr->firstLocalPtr != NULL) {
sl@0:             localPtr = procPtr->firstLocalPtr;
sl@0:             procPtr->firstLocalPtr = localPtr->nextPtr;
sl@0: 	
sl@0:             defPtr = localPtr->defValuePtr;
sl@0:             if (defPtr != NULL) {
sl@0:                 Tcl_DecrRefCount(defPtr);
sl@0:             }
sl@0: 	
sl@0:             ckfree((char *) localPtr);
sl@0:         }
sl@0:         ckfree((char *) procPtr);
sl@0:     }
sl@0:     if (argArray != NULL) {
sl@0: 	ckfree((char *) argArray);
sl@0:     }
sl@0:     return TCL_ERROR;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclGetFrame --
sl@0:  *
sl@0:  *	Given a description of a procedure frame, such as the first
sl@0:  *	argument to an "uplevel" or "upvar" command, locate the
sl@0:  *	call frame for the appropriate level of procedure.
sl@0:  *
sl@0:  * Results:
sl@0:  *	The return value is -1 if an error occurred in finding the frame
sl@0:  *	(in this case an error message is left in the interp's result).
sl@0:  *	1 is returned if string was either a number or a number preceded
sl@0:  *	by "#" and it specified a valid frame.  0 is returned if string
sl@0:  *	isn't one of the two things above (in this case, the lookup
sl@0:  *	acts as if string were "1").  The variable pointed to by
sl@0:  *	framePtrPtr is filled in with the address of the desired frame
sl@0:  *	(unless an error occurs, in which case it isn't modified).
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	None.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int
sl@0: TclGetFrame(interp, string, framePtrPtr)
sl@0:     Tcl_Interp *interp;		/* Interpreter in which to find frame. */
sl@0:     CONST char *string;		/* String describing frame. */
sl@0:     CallFrame **framePtrPtr;	/* Store pointer to frame here (or NULL
sl@0: 				 * if global frame indicated). */
sl@0: {
sl@0:     register Interp *iPtr = (Interp *) interp;
sl@0:     int curLevel, level, result;
sl@0:     CallFrame *framePtr;
sl@0: 
sl@0:     /*
sl@0:      * Parse string to figure out which level number to go to.
sl@0:      */
sl@0: 
sl@0:     result = 1;
sl@0:     curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
sl@0:     if (*string == '#') {
sl@0: 	if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
sl@0: 	    return -1;
sl@0: 	}
sl@0: 	if (level < 0) {
sl@0: 	    levelError:
sl@0: 	    Tcl_AppendResult(interp, "bad level \"", string, "\"",
sl@0: 		    (char *) NULL);
sl@0: 	    return -1;
sl@0: 	}
sl@0:     } else if (isdigit(UCHAR(*string))) { /* INTL: digit */
sl@0: 	if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
sl@0: 	    return -1;
sl@0: 	}
sl@0: 	level = curLevel - level;
sl@0:     } else {
sl@0: 	level = curLevel - 1;
sl@0: 	result = 0;
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      * Figure out which frame to use, and modify the interpreter so
sl@0:      * its variables come from that frame.
sl@0:      */
sl@0: 
sl@0:     if (level == 0) {
sl@0: 	framePtr = NULL;
sl@0:     } else {
sl@0: 	for (framePtr = iPtr->varFramePtr; framePtr != NULL;
sl@0: 		framePtr = framePtr->callerVarPtr) {
sl@0: 	    if (framePtr->level == level) {
sl@0: 		break;
sl@0: 	    }
sl@0: 	}
sl@0: 	if (framePtr == NULL) {
sl@0: 	    goto levelError;
sl@0: 	}
sl@0:     }
sl@0:     *framePtrPtr = framePtr;
sl@0:     return result;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * Tcl_UplevelObjCmd --
sl@0:  *
sl@0:  *	This object procedure is invoked to process the "uplevel" Tcl
sl@0:  *	command. See the user documentation for details on what it does.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl object result value.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	See the user documentation.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: 	/* ARGSUSED */
sl@0: int
sl@0: Tcl_UplevelObjCmd(dummy, interp, objc, objv)
sl@0:     ClientData dummy;		/* Not used. */
sl@0:     Tcl_Interp *interp;		/* Current interpreter. */
sl@0:     int objc;			/* Number of arguments. */
sl@0:     Tcl_Obj *CONST objv[];	/* Argument objects. */
sl@0: {
sl@0:     register Interp *iPtr = (Interp *) interp;
sl@0:     char *optLevel;
sl@0:     int result;
sl@0:     CallFrame *savedVarFramePtr, *framePtr;
sl@0: 
sl@0:     if (objc < 2) {
sl@0: 	uplevelSyntax:
sl@0: 	Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      * Find the level to use for executing the command.
sl@0:      */
sl@0: 
sl@0:     optLevel = TclGetString(objv[1]);
sl@0:     result = TclGetFrame(interp, optLevel, &framePtr);
sl@0:     if (result == -1) {
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     objc -= (result+1);
sl@0:     if (objc == 0) {
sl@0: 	goto uplevelSyntax;
sl@0:     }
sl@0:     objv += (result+1);
sl@0: 
sl@0:     /*
sl@0:      * Modify the interpreter state to execute in the given frame.
sl@0:      */
sl@0: 
sl@0:     savedVarFramePtr = iPtr->varFramePtr;
sl@0:     iPtr->varFramePtr = framePtr;
sl@0: 
sl@0:     /*
sl@0:      * Execute the residual arguments as a command.
sl@0:      */
sl@0: 
sl@0:     if (objc == 1) {
sl@0: 	result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT);
sl@0:     } else {
sl@0: 	/*
sl@0: 	 * More than one argument: concatenate them together with spaces
sl@0: 	 * between, then evaluate the result.  Tcl_EvalObjEx will delete
sl@0: 	 * the object when it decrements its refcount after eval'ing it.
sl@0: 	 */
sl@0: 	Tcl_Obj *objPtr;
sl@0: 
sl@0: 	objPtr = Tcl_ConcatObj(objc, objv);
sl@0: 	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
sl@0:     }
sl@0:     if (result == TCL_ERROR) {
sl@0: 	char msg[32 + TCL_INTEGER_SPACE];
sl@0: 	sprintf(msg, "\n    (\"uplevel\" body line %d)", interp->errorLine);
sl@0: 	Tcl_AddObjErrorInfo(interp, msg, -1);
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      * Restore the variable frame, and return.
sl@0:      */
sl@0: 
sl@0:     iPtr->varFramePtr = savedVarFramePtr;
sl@0:     return result;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclFindProc --
sl@0:  *
sl@0:  *	Given the name of a procedure, return a pointer to the
sl@0:  *	record describing the procedure. The procedure will be
sl@0:  *	looked up using the usual rules: first in the current
sl@0:  *	namespace and then in the global namespace.
sl@0:  *
sl@0:  * Results:
sl@0:  *	NULL is returned if the name doesn't correspond to any
sl@0:  *	procedure. Otherwise, the return value is a pointer to
sl@0:  *	the procedure's record. If the name is found but refers
sl@0:  *	to an imported command that points to a "real" procedure
sl@0:  *	defined in another namespace, a pointer to that "real"
sl@0:  *	procedure's structure is returned.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	None.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: Proc *
sl@0: TclFindProc(iPtr, procName)
sl@0:     Interp *iPtr;		/* Interpreter in which to look. */
sl@0:     CONST char *procName;		/* Name of desired procedure. */
sl@0: {
sl@0:     Tcl_Command cmd;
sl@0:     Tcl_Command origCmd;
sl@0:     Command *cmdPtr;
sl@0:     
sl@0:     cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName,
sl@0:             (Tcl_Namespace *) NULL, /*flags*/ 0);
sl@0:     if (cmd == (Tcl_Command) NULL) {
sl@0:         return NULL;
sl@0:     }
sl@0:     cmdPtr = (Command *) cmd;
sl@0: 
sl@0:     origCmd = TclGetOriginalCommand(cmd);
sl@0:     if (origCmd != NULL) {
sl@0: 	cmdPtr = (Command *) origCmd;
sl@0:     }
sl@0:     if (cmdPtr->proc != TclProcInterpProc) {
sl@0: 	return NULL;
sl@0:     }
sl@0:     return (Proc *) cmdPtr->clientData;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclIsProc --
sl@0:  *
sl@0:  *	Tells whether a command is a Tcl procedure or not.
sl@0:  *
sl@0:  * Results:
sl@0:  *	If the given command is actually a Tcl procedure, the
sl@0:  *	return value is the address of the record describing
sl@0:  *	the procedure.  Otherwise the return value is 0.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	None.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: Proc *
sl@0: TclIsProc(cmdPtr)
sl@0:     Command *cmdPtr;		/* Command to test. */
sl@0: {
sl@0:     Tcl_Command origCmd;
sl@0: 
sl@0:     origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr);
sl@0:     if (origCmd != NULL) {
sl@0: 	cmdPtr = (Command *) origCmd;
sl@0:     }
sl@0:     if (cmdPtr->proc == TclProcInterpProc) {
sl@0: 	return (Proc *) cmdPtr->clientData;
sl@0:     }
sl@0:     return (Proc *) 0;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclProcInterpProc --
sl@0:  *
sl@0:  *	When a Tcl procedure gets invoked with an argc/argv array of
sl@0:  *	strings, this routine gets invoked to interpret the procedure.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl result value, usually TCL_OK.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Depends on the commands in the procedure.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int
sl@0: TclProcInterpProc(clientData, interp, argc, argv)
sl@0:     ClientData clientData;	/* Record describing procedure to be
sl@0: 				 * interpreted. */
sl@0:     Tcl_Interp *interp;		/* Interpreter in which procedure was
sl@0: 				 * invoked. */
sl@0:     int argc;			/* Count of number of arguments to this
sl@0: 				 * procedure. */
sl@0:     register CONST char **argv;	/* Argument values. */
sl@0: {
sl@0:     register Tcl_Obj *objPtr;
sl@0:     register int i;
sl@0:     int result;
sl@0: 
sl@0:     /*
sl@0:      * This procedure generates an objv array for object arguments that hold
sl@0:      * the argv strings. It starts out with stack-allocated space but uses
sl@0:      * dynamically-allocated storage if needed.
sl@0:      */
sl@0: 
sl@0: #define NUM_ARGS 20
sl@0:     Tcl_Obj *(objStorage[NUM_ARGS]);
sl@0:     register Tcl_Obj **objv = objStorage;
sl@0: 
sl@0:     /*
sl@0:      * Create the object argument array "objv". Make sure objv is large
sl@0:      * enough to hold the objc arguments plus 1 extra for the zero
sl@0:      * end-of-objv word.
sl@0:      */
sl@0: 
sl@0:     if ((argc + 1) > NUM_ARGS) {
sl@0: 	objv = (Tcl_Obj **)
sl@0: 	    ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
sl@0:     }
sl@0: 
sl@0:     for (i = 0;  i < argc;  i++) {
sl@0: 	objv[i] = Tcl_NewStringObj(argv[i], -1);
sl@0: 	Tcl_IncrRefCount(objv[i]);
sl@0:     }
sl@0:     objv[argc] = 0;
sl@0: 
sl@0:     /*
sl@0:      * Use TclObjInterpProc to actually interpret the procedure.
sl@0:      */
sl@0: 
sl@0:     result = TclObjInterpProc(clientData, interp, argc, objv);
sl@0: 
sl@0:     /*
sl@0:      * Move the interpreter's object result to the string result, 
sl@0:      * then reset the object result.
sl@0:      */
sl@0:     
sl@0:     Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
sl@0: 	    TCL_VOLATILE);
sl@0: 
sl@0:     /*
sl@0:      * Decrement the ref counts on the objv elements since we are done
sl@0:      * with them.
sl@0:      */
sl@0: 
sl@0:     for (i = 0;  i < argc;  i++) {
sl@0: 	objPtr = objv[i];
sl@0: 	TclDecrRefCount(objPtr);
sl@0:     }
sl@0:     
sl@0:     /*
sl@0:      * Free the objv array if malloc'ed storage was used.
sl@0:      */
sl@0: 
sl@0:     if (objv != objStorage) {
sl@0: 	ckfree((char *) objv);
sl@0:     }
sl@0:     return result;
sl@0: #undef NUM_ARGS
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclObjInterpProc --
sl@0:  *
sl@0:  *	When a Tcl procedure gets invoked during bytecode evaluation, this 
sl@0:  *	object-based routine gets invoked to interpret the procedure.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl object result value.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Depends on the commands in the procedure.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int
sl@0: TclObjInterpProc(clientData, interp, objc, objv)
sl@0:     ClientData clientData; 	 /* Record describing procedure to be
sl@0: 				  * interpreted. */
sl@0:     register Tcl_Interp *interp; /* Interpreter in which procedure was
sl@0: 				  * invoked. */
sl@0:     int objc;			 /* Count of number of arguments to this
sl@0: 				  * procedure. */
sl@0:     Tcl_Obj *CONST objv[];	 /* Argument value objects. */
sl@0: {
sl@0:     Interp *iPtr = (Interp *) interp;
sl@0:     Proc *procPtr = (Proc *) clientData;
sl@0:     Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
sl@0:     CallFrame frame;
sl@0:     register CallFrame *framePtr = &frame;
sl@0:     register Var *varPtr;
sl@0:     register CompiledLocal *localPtr;
sl@0:     char *procName;
sl@0:     int nameLen, localCt, numArgs, argCt, i, result;
sl@0: 
sl@0:     /*
sl@0:      * This procedure generates an array "compiledLocals" that holds the
sl@0:      * storage for local variables. It starts out with stack-allocated space
sl@0:      * but uses dynamically-allocated storage if needed.
sl@0:      */
sl@0: 
sl@0: #define NUM_LOCALS 20
sl@0:     Var localStorage[NUM_LOCALS];
sl@0:     Var *compiledLocals = localStorage;
sl@0: 
sl@0:     /*
sl@0:      * Get the procedure's name.
sl@0:      */
sl@0:     
sl@0:     procName = Tcl_GetStringFromObj(objv[0], &nameLen);
sl@0: 
sl@0:     /*
sl@0:      * If necessary, compile the procedure's body. The compiler will
sl@0:      * allocate frame slots for the procedure's non-argument local
sl@0:      * variables.  Note that compiling the body might increase
sl@0:      * procPtr->numCompiledLocals if new local variables are found
sl@0:      * while compiling.
sl@0:      */
sl@0: 
sl@0:     result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
sl@0: 	    "body of proc", procName, &procPtr);
sl@0:     
sl@0:     if (result != TCL_OK) {
sl@0:         return result;
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      * Create the "compiledLocals" array. Make sure it is large enough to
sl@0:      * hold all the procedure's compiled local variables, including its
sl@0:      * formal parameters.
sl@0:      */
sl@0: 
sl@0:     localCt = procPtr->numCompiledLocals;
sl@0:     if (localCt > NUM_LOCALS) {
sl@0: 	compiledLocals = (Var *) ckalloc((unsigned) localCt * sizeof(Var));
sl@0:     }
sl@0:     
sl@0:     /*
sl@0:      * Set up and push a new call frame for the new procedure invocation.
sl@0:      * This call frame will execute in the proc's namespace, which might
sl@0:      * be different than the current namespace. The proc's namespace is
sl@0:      * that of its command, which can change if the command is renamed
sl@0:      * from one namespace to another.
sl@0:      */
sl@0: 
sl@0:     result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
sl@0:             (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1);
sl@0: 
sl@0:     if (result != TCL_OK) {
sl@0:         return result;
sl@0:     }
sl@0: 
sl@0:     framePtr->objc = objc;
sl@0:     framePtr->objv = objv;  /* ref counts for args are incremented below */
sl@0: 
sl@0:     /*
sl@0:      * Initialize and resolve compiled variable references.
sl@0:      */
sl@0: 
sl@0:     framePtr->procPtr = procPtr;
sl@0:     framePtr->numCompiledLocals = localCt;
sl@0:     framePtr->compiledLocals = compiledLocals;
sl@0: 
sl@0:     TclInitCompiledLocals(interp, framePtr, nsPtr);
sl@0: 
sl@0:     /*
sl@0:      * Match and assign the call's actual parameters to the procedure's
sl@0:      * formal arguments. The formal arguments are described by the first
sl@0:      * numArgs entries in both the Proc structure's local variable list and
sl@0:      * the call frame's local variable array.
sl@0:      */
sl@0: 
sl@0:     numArgs = procPtr->numArgs;
sl@0:     varPtr = framePtr->compiledLocals;
sl@0:     localPtr = procPtr->firstLocalPtr;
sl@0:     argCt = objc;
sl@0:     for (i = 1, argCt -= 1;  i <= numArgs;  i++, argCt--) {
sl@0: 	if (!TclIsVarArgument(localPtr)) {
sl@0: 	    panic("TclObjInterpProc: local variable %s is not argument but should be",
sl@0: 		  localPtr->name);
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	if (TclIsVarTemporary(localPtr)) {
sl@0: 	    panic("TclObjInterpProc: local variable %d is temporary but should be an argument", i);
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 
sl@0: 	/*
sl@0: 	 * Handle the special case of the last formal being "args".  When
sl@0: 	 * it occurs, assign it a list consisting of all the remaining
sl@0: 	 * actual arguments.
sl@0: 	 */
sl@0: 
sl@0: 	if ((i == numArgs) && ((localPtr->name[0] == 'a')
sl@0: 	        && (strcmp(localPtr->name, "args") == 0))) {
sl@0: 	    Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i]));
sl@0: 	    varPtr->value.objPtr = listPtr;
sl@0: 	    Tcl_IncrRefCount(listPtr); /* local var is a reference */
sl@0: 	    TclClearVarUndefined(varPtr);
sl@0: 	    argCt = 0;
sl@0: 	    break;		/* done processing args */
sl@0: 	} else if (argCt > 0) {
sl@0: 	    Tcl_Obj *objPtr = objv[i];
sl@0: 	    varPtr->value.objPtr = objPtr;
sl@0: 	    TclClearVarUndefined(varPtr);
sl@0: 	    Tcl_IncrRefCount(objPtr);  /* since the local variable now has
sl@0: 					* another reference to object. */
sl@0: 	} else if (localPtr->defValuePtr != NULL) {
sl@0: 	    Tcl_Obj *objPtr = localPtr->defValuePtr;
sl@0: 	    varPtr->value.objPtr = objPtr;
sl@0: 	    TclClearVarUndefined(varPtr);
sl@0: 	    Tcl_IncrRefCount(objPtr);  /* since the local variable now has
sl@0: 					* another reference to object. */
sl@0: 	} else {
sl@0: 	    goto incorrectArgs;
sl@0: 	}
sl@0: 	varPtr++;
sl@0: 	localPtr = localPtr->nextPtr;
sl@0:     }
sl@0:     if (argCt > 0) {
sl@0: 	Tcl_Obj *objResult;
sl@0: 	int len, flags;
sl@0: 
sl@0: 	incorrectArgs:
sl@0: 	/*
sl@0: 	 * Build up equivalent to Tcl_WrongNumArgs message for proc
sl@0: 	 */
sl@0: 
sl@0: 	Tcl_ResetResult(interp);
sl@0: 	objResult = Tcl_GetObjResult(interp);
sl@0: 	Tcl_AppendToObj(objResult, "wrong # args: should be \"", -1);
sl@0: 
sl@0: 	/*
sl@0: 	 * Quote the proc name if it contains spaces (Bug 942757).
sl@0: 	 */
sl@0: 	
sl@0: 	len = Tcl_ScanCountedElement(procName, nameLen, &flags);
sl@0: 	if (len != nameLen) {
sl@0: 	    char *procName1 = ckalloc((unsigned) len);
sl@0: 	    len = Tcl_ConvertCountedElement(procName, nameLen, procName1, flags);
sl@0: 	    Tcl_AppendToObj(objResult, procName1, len);
sl@0: 	    ckfree(procName1);
sl@0: 	} else {
sl@0: 	    Tcl_AppendToObj(objResult, procName, len);
sl@0: 	}
sl@0: 
sl@0: 	localPtr = procPtr->firstLocalPtr;
sl@0: 	for (i = 1;  i <= numArgs;  i++) {
sl@0: 	    if (localPtr->defValuePtr != NULL) {
sl@0: 		Tcl_AppendStringsToObj(objResult,
sl@0: 			" ?", localPtr->name, "?", (char *) NULL);
sl@0: 	    } else {
sl@0: 		Tcl_AppendStringsToObj(objResult,
sl@0: 			" ", localPtr->name, (char *) NULL);
sl@0: 	    }
sl@0: 	    localPtr = localPtr->nextPtr;
sl@0: 	}
sl@0: 	Tcl_AppendStringsToObj(objResult, "\"", (char *) NULL);
sl@0: 
sl@0: 	result = TCL_ERROR;
sl@0: 	goto procDone;
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      * Invoke the commands in the procedure's body.
sl@0:      */
sl@0: 
sl@0: #ifdef TCL_COMPILE_DEBUG
sl@0:     if (tclTraceExec >= 1) {
sl@0: 	fprintf(stdout, "Calling proc ");
sl@0: 	for (i = 0;  i < objc;  i++) {
sl@0: 	    TclPrintObject(stdout, objv[i], 15);
sl@0: 	    fprintf(stdout, " ");
sl@0: 	}
sl@0: 	fprintf(stdout, "\n");
sl@0: 	fflush(stdout);
sl@0:     }
sl@0: #endif /*TCL_COMPILE_DEBUG*/
sl@0: 
sl@0:     iPtr->returnCode = TCL_OK;
sl@0:     procPtr->refCount++;
sl@0: #ifndef TCL_TIP280
sl@0:     result = TclCompEvalObj(interp, procPtr->bodyPtr);
sl@0: #else
sl@0:     /* TIP #280: No need to set the invoking context here. The body has
sl@0:      * already been compiled, so the part of CompEvalObj using it is bypassed.
sl@0:      */
sl@0: 
sl@0:     result = TclCompEvalObj(interp, procPtr->bodyPtr, NULL, 0);
sl@0: #endif
sl@0:     procPtr->refCount--;
sl@0:     if (procPtr->refCount <= 0) {
sl@0: 	TclProcCleanupProc(procPtr);
sl@0:     }
sl@0: 
sl@0:     if (result != TCL_OK) {
sl@0: 	result = ProcessProcResultCode(interp, procName, nameLen, result);
sl@0:     }
sl@0:     
sl@0:     /*
sl@0:      * Pop and free the call frame for this procedure invocation, then
sl@0:      * free the compiledLocals array if malloc'ed storage was used.
sl@0:      */
sl@0:     
sl@0:     procDone:
sl@0:     Tcl_PopCallFrame(interp);
sl@0:     if (compiledLocals != localStorage) {
sl@0: 	ckfree((char *) compiledLocals);
sl@0:     }
sl@0:     return result;
sl@0: #undef NUM_LOCALS
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclProcCompileProc --
sl@0:  *
sl@0:  *	Called just before a procedure is executed to compile the
sl@0:  *	body to byte codes.  If the type of the body is not
sl@0:  *	"byte code" or if the compile conditions have changed
sl@0:  *	(namespace context, epoch counters, etc.) then the body
sl@0:  *	is recompiled.  Otherwise, this procedure does nothing.
sl@0:  *
sl@0:  * Results:
sl@0:  *	None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	May change the internal representation of the body object
sl@0:  *	to compiled code.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0:  
sl@0: int
sl@0: TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
sl@0:     Tcl_Interp *interp;		/* Interpreter containing procedure. */
sl@0:     Proc *procPtr;		/* Data associated with procedure. */
sl@0:     Tcl_Obj *bodyPtr;		/* Body of proc. (Usually procPtr->bodyPtr,
sl@0:  				 * but could be any code fragment compiled
sl@0:  				 * in the context of this procedure.) */
sl@0:     Namespace *nsPtr;		/* Namespace containing procedure. */
sl@0:     CONST char *description;	/* string describing this body of code. */
sl@0:     CONST char *procName;	/* Name of this procedure. */
sl@0: {
sl@0:     return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr,
sl@0: 	    description, procName, NULL);
sl@0: }
sl@0: 
sl@0: static int
sl@0: ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description,
sl@0: 		procName, procPtrPtr)
sl@0:     Tcl_Interp *interp;		/* Interpreter containing procedure. */
sl@0:     Proc *procPtr;		/* Data associated with procedure. */
sl@0:     Tcl_Obj *bodyPtr;		/* Body of proc. (Usually procPtr->bodyPtr,
sl@0:  				 * but could be any code fragment compiled
sl@0:  				 * in the context of this procedure.) */
sl@0:     Namespace *nsPtr;		/* Namespace containing procedure. */
sl@0:     CONST char *description;	/* string describing this body of code. */
sl@0:     CONST char *procName;	/* Name of this procedure. */
sl@0:     Proc **procPtrPtr;		/* points to storage where a replacement
sl@0: 				 * (Proc *) value may be written, when
sl@0: 				 * appropriate */
sl@0: {
sl@0:     Interp *iPtr = (Interp*)interp;
sl@0:     int i, result;
sl@0:     Tcl_CallFrame frame;
sl@0:     Proc *saveProcPtr;
sl@0:     ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;
sl@0:     CompiledLocal *localPtr;
sl@0:  
sl@0:     /*
sl@0:      * If necessary, compile the procedure's body. The compiler will
sl@0:      * allocate frame slots for the procedure's non-argument local
sl@0:      * variables. If the ByteCode already exists, make sure it hasn't been
sl@0:      * invalidated by someone redefining a core command (this might make the
sl@0:      * compiled code wrong). Also, if the code was compiled in/for a
sl@0:      * different interpreter, we recompile it. Note that compiling the body
sl@0:      * might increase procPtr->numCompiledLocals if new local variables are
sl@0:      * found while compiling.
sl@0:      *
sl@0:      * Precompiled procedure bodies, however, are immutable and therefore
sl@0:      * they are not recompiled, even if things have changed.
sl@0:      */
sl@0:  
sl@0:     if (bodyPtr->typePtr == &tclByteCodeType) {
sl@0:  	if (((Interp *) *codePtr->interpHandle != iPtr)
sl@0:  	        || (codePtr->compileEpoch != iPtr->compileEpoch)
sl@0:  	        || (codePtr->nsPtr != nsPtr)) {
sl@0:             if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
sl@0:                 if ((Interp *) *codePtr->interpHandle != iPtr) {
sl@0:                     Tcl_AppendResult(interp,
sl@0:                             "a precompiled script jumped interps", NULL);
sl@0:                     return TCL_ERROR;
sl@0:                 }
sl@0: 	        codePtr->compileEpoch = iPtr->compileEpoch;
sl@0:                 codePtr->nsPtr = nsPtr;
sl@0:             } else {
sl@0:                 (*tclByteCodeType.freeIntRepProc)(bodyPtr);
sl@0:                 bodyPtr->typePtr = (Tcl_ObjType *) NULL;
sl@0:             }
sl@0:  	}
sl@0:     }
sl@0:     if (bodyPtr->typePtr != &tclByteCodeType) {
sl@0:  	int numChars;
sl@0:  	char *ellipsis;
sl@0:  	
sl@0: #ifdef TCL_COMPILE_DEBUG
sl@0:  	if (tclTraceCompile >= 1) {
sl@0:  	    /*
sl@0:  	     * Display a line summarizing the top level command we
sl@0:  	     * are about to compile.
sl@0:  	     */
sl@0:  
sl@0:  	    numChars = strlen(procName);
sl@0:  	    ellipsis = "";
sl@0:  	    if (numChars > 50) {
sl@0:  		numChars = 50;
sl@0:  		ellipsis = "...";
sl@0:  	    }
sl@0:  	    fprintf(stdout, "Compiling %s \"%.*s%s\"\n",
sl@0:  		    description, numChars, procName, ellipsis);
sl@0:  	}
sl@0: #endif
sl@0:  	
sl@0:  	/*
sl@0:  	 * Plug the current procPtr into the interpreter and coerce
sl@0:  	 * the code body to byte codes.  The interpreter needs to
sl@0:  	 * know which proc it's compiling so that it can access its
sl@0:  	 * list of compiled locals.
sl@0:  	 *
sl@0:  	 * TRICKY NOTE:  Be careful to push a call frame with the
sl@0:  	 *   proper namespace context, so that the byte codes are
sl@0:  	 *   compiled in the appropriate class context.
sl@0:  	 */
sl@0: 
sl@0:  	saveProcPtr = iPtr->compiledProcPtr;
sl@0: 
sl@0: 	if (procPtrPtr != NULL && procPtr->refCount > 1) {
sl@0: 	    Tcl_Command token;
sl@0: 	    Tcl_CmdInfo info;
sl@0: 	    Proc *new = (Proc *) ckalloc(sizeof(Proc));
sl@0: 
sl@0: 	    new->iPtr = procPtr->iPtr;
sl@0: 	    new->refCount = 1;
sl@0: 	    new->cmdPtr = procPtr->cmdPtr;
sl@0: 	    token = (Tcl_Command) new->cmdPtr;
sl@0: 	    new->bodyPtr = Tcl_DuplicateObj(bodyPtr);
sl@0: 	    bodyPtr = new->bodyPtr;
sl@0: 	    Tcl_IncrRefCount(bodyPtr);
sl@0: 	    new->numArgs = procPtr->numArgs;
sl@0: 
sl@0: 	    new->numCompiledLocals = new->numArgs;
sl@0: 	    new->firstLocalPtr = NULL;
sl@0: 	    new->lastLocalPtr = NULL;
sl@0: 	    localPtr = procPtr->firstLocalPtr;
sl@0: 	    for (i = 0; i < new->numArgs; i++, localPtr = localPtr->nextPtr) {
sl@0: 		CompiledLocal *copy = (CompiledLocal *) ckalloc((unsigned)
sl@0: 			(sizeof(CompiledLocal) -sizeof(localPtr->name)
sl@0: 			 + localPtr->nameLength + 1));
sl@0: 		if (new->firstLocalPtr == NULL) {
sl@0: 		    new->firstLocalPtr = new->lastLocalPtr = copy;
sl@0: 		} else {
sl@0: 		    new->lastLocalPtr->nextPtr = copy;
sl@0: 		    new->lastLocalPtr = copy;
sl@0: 		}
sl@0: 		copy->nextPtr = NULL;
sl@0: 		copy->nameLength = localPtr->nameLength;
sl@0: 		copy->frameIndex = localPtr->frameIndex;
sl@0: 		copy->flags = localPtr->flags;
sl@0: 		copy->defValuePtr = localPtr->defValuePtr;
sl@0: 		if (copy->defValuePtr) {
sl@0: 		    Tcl_IncrRefCount(copy->defValuePtr);
sl@0: 		}
sl@0: 		copy->resolveInfo = localPtr->resolveInfo;
sl@0: 		strcpy(copy->name, localPtr->name);
sl@0: 	    }
sl@0: 
sl@0: 
sl@0: 	    /* Reset the ClientData */
sl@0: 	    Tcl_GetCommandInfoFromToken(token, &info);
sl@0: 	    if (info.objClientData == (ClientData) procPtr) {
sl@0: 	        info.objClientData = (ClientData) new;
sl@0: 	    }
sl@0: 	    if (info.clientData == (ClientData) procPtr) {
sl@0: 	        info.clientData = (ClientData) new;
sl@0: 	    }
sl@0: 	    if (info.deleteData == (ClientData) procPtr) {
sl@0: 	        info.deleteData = (ClientData) new;
sl@0: 	    }
sl@0: 	    Tcl_SetCommandInfoFromToken(token, &info);
sl@0: 
sl@0: 	    procPtr->refCount--;
sl@0: 	    *procPtrPtr = procPtr = new;
sl@0: 	}
sl@0:  	iPtr->compiledProcPtr = procPtr;
sl@0:  
sl@0:  	result = Tcl_PushCallFrame(interp, &frame,
sl@0: 		(Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0);
sl@0:  
sl@0:  	if (result == TCL_OK) {
sl@0: #ifdef TCL_TIP280
sl@0: 	    /* TIP #280. We get the invoking context from the cmdFrame
sl@0: 	     * which was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr).
sl@0: 	     */
sl@0: 
sl@0: 	    Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr);
sl@0: 
sl@0: 	    /* Constructed saved frame has body as word 0. See Tcl_ProcObjCmd.
sl@0: 	     */
sl@0: 	    iPtr->invokeWord        = 0;
sl@0: 	    iPtr->invokeCmdFramePtr = (hePtr
sl@0: 				       ? (CmdFrame*) Tcl_GetHashValue (hePtr)
sl@0: 				       : NULL);
sl@0: #endif
sl@0: 	    result = tclByteCodeType.setFromAnyProc(interp, bodyPtr);
sl@0: #ifdef TCL_TIP280
sl@0: 	    iPtr->invokeCmdFramePtr = NULL;
sl@0: #endif
sl@0: 	    Tcl_PopCallFrame(interp);
sl@0: 	}
sl@0:  
sl@0:  	iPtr->compiledProcPtr = saveProcPtr;
sl@0:  	
sl@0:  	if (result != TCL_OK) {
sl@0:  	    if (result == TCL_ERROR) {
sl@0: 		char buf[100 + TCL_INTEGER_SPACE];
sl@0: 
sl@0: 		numChars = strlen(procName);
sl@0:  		ellipsis = "";
sl@0:  		if (numChars > 50) {
sl@0:  		    numChars = 50;
sl@0:  		    ellipsis = "...";
sl@0:  		}
sl@0: 		while ( (procName[numChars] & 0xC0) == 0x80 ) {
sl@0: 	            /*
sl@0: 		     * Back up truncation point so that we don't truncate
sl@0: 		     * in the middle of a multi-byte character (in UTF-8)
sl@0: 		     */
sl@0: 		    numChars--;
sl@0: 		    ellipsis = "...";
sl@0: 		}
sl@0:  		sprintf(buf, "\n    (compiling %s \"%.*s%s\", line %d)",
sl@0:  			description, numChars, procName, ellipsis,
sl@0:  			interp->errorLine);
sl@0:  		Tcl_AddObjErrorInfo(interp, buf, -1);
sl@0:  	    }
sl@0:  	    return result;
sl@0:  	}
sl@0:     } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
sl@0:  	
sl@0: 	/*
sl@0: 	 * The resolver epoch has changed, but we only need to invalidate
sl@0: 	 * the resolver cache.
sl@0: 	 */
sl@0: 
sl@0: 	for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;
sl@0: 	    localPtr = localPtr->nextPtr) {
sl@0: 	    localPtr->flags &= ~(VAR_RESOLVED);
sl@0: 	    if (localPtr->resolveInfo) {
sl@0: 		if (localPtr->resolveInfo->deleteProc) {
sl@0: 		    localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
sl@0: 		} else {
sl@0: 		    ckfree((char*)localPtr->resolveInfo);
sl@0: 		}
sl@0: 		localPtr->resolveInfo = NULL;
sl@0: 	    }
sl@0: 	}
sl@0:     }
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * ProcessProcResultCode --
sl@0:  *
sl@0:  *	Procedure called by TclObjInterpProc to process a return code other
sl@0:  *	than TCL_OK returned by a Tcl procedure.
sl@0:  *
sl@0:  * Results:
sl@0:  *	Depending on the argument return code, the result returned is
sl@0:  *	another return code and the interpreter's result is set to a value
sl@0:  *	to supplement that return code.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	If the result returned is TCL_ERROR, traceback information about
sl@0:  *	the procedure just executed is appended to the interpreter's
sl@0:  *	"errorInfo" variable.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: ProcessProcResultCode(interp, procName, nameLen, returnCode)
sl@0:     Tcl_Interp *interp;		/* The interpreter in which the procedure
sl@0: 				 * was called and returned returnCode. */
sl@0:     char *procName;		/* Name of the procedure. Used for error
sl@0: 				 * messages and trace information. */
sl@0:     int nameLen;		/* Number of bytes in procedure's name. */
sl@0:     int returnCode;		/* The unexpected result code. */
sl@0: {
sl@0:     Interp *iPtr = (Interp *) interp;
sl@0:     char msg[100 + TCL_INTEGER_SPACE];
sl@0:     char *ellipsis = "";
sl@0: 
sl@0:     if (returnCode == TCL_OK) {
sl@0: 	return TCL_OK;
sl@0:     }
sl@0:     if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) {
sl@0: 	return returnCode;
sl@0:     }
sl@0:     if (returnCode == TCL_RETURN) {
sl@0: 	return TclUpdateReturnInfo(iPtr);
sl@0:     } 
sl@0:     if (returnCode != TCL_ERROR) {
sl@0: 	Tcl_ResetResult(interp);
sl@0: 	Tcl_AppendToObj(Tcl_GetObjResult(interp), ((returnCode == TCL_BREAK) 
sl@0: 		? "invoked \"break\" outside of a loop"
sl@0: 		: "invoked \"continue\" outside of a loop"), -1);
sl@0:     }
sl@0:     if (nameLen > 60) {
sl@0: 	nameLen = 60;
sl@0: 	ellipsis = "...";
sl@0:     }
sl@0:     while ( (procName[nameLen] & 0xC0) == 0x80 ) {
sl@0:         /*
sl@0: 	 * Back up truncation point so that we don't truncate in the
sl@0: 	 * middle of a multi-byte character (in UTF-8)
sl@0: 	 */
sl@0: 	nameLen--;
sl@0: 	ellipsis = "...";
sl@0:     }
sl@0:     sprintf(msg, "\n    (procedure \"%.*s%s\" line %d)", nameLen, procName,
sl@0: 	    ellipsis, iPtr->errorLine);
sl@0:     Tcl_AddObjErrorInfo(interp, msg, -1);
sl@0:     return TCL_ERROR;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclProcDeleteProc --
sl@0:  *
sl@0:  *	This procedure is invoked just before a command procedure is
sl@0:  *	removed from an interpreter.  Its job is to release all the
sl@0:  *	resources allocated to the procedure.
sl@0:  *
sl@0:  * Results:
sl@0:  *	None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Memory gets freed, unless the procedure is actively being
sl@0:  *	executed.  In this case the cleanup is delayed until the
sl@0:  *	last call to the current procedure completes.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: void
sl@0: TclProcDeleteProc(clientData)
sl@0:     ClientData clientData;		/* Procedure to be deleted. */
sl@0: {
sl@0:     Proc *procPtr = (Proc *) clientData;
sl@0: 
sl@0:     procPtr->refCount--;
sl@0:     if (procPtr->refCount <= 0) {
sl@0: 	TclProcCleanupProc(procPtr);
sl@0:     }
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclProcCleanupProc --
sl@0:  *
sl@0:  *	This procedure does all the real work of freeing up a Proc
sl@0:  *	structure.  It's called only when the structure's reference
sl@0:  *	count becomes zero.
sl@0:  *
sl@0:  * Results:
sl@0:  *	None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Memory gets freed.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: void
sl@0: TclProcCleanupProc(procPtr)
sl@0:     register Proc *procPtr;		/* Procedure to be deleted. */
sl@0: {
sl@0:     register CompiledLocal *localPtr;
sl@0:     Tcl_Obj *bodyPtr = procPtr->bodyPtr;
sl@0:     Tcl_Obj *defPtr;
sl@0:     Tcl_ResolvedVarInfo *resVarInfo;
sl@0: #ifdef TCL_TIP280
sl@0:     Tcl_HashEntry* hePtr = NULL;
sl@0:     CmdFrame*      cfPtr = NULL;
sl@0:     Interp*        iPtr  = procPtr->iPtr;
sl@0: #endif
sl@0: 
sl@0:     if (bodyPtr != NULL) {
sl@0: 	Tcl_DecrRefCount(bodyPtr);
sl@0:     }
sl@0:     for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;  ) {
sl@0: 	CompiledLocal *nextPtr = localPtr->nextPtr;
sl@0: 
sl@0:         resVarInfo = localPtr->resolveInfo;
sl@0: 	if (resVarInfo) {
sl@0: 	    if (resVarInfo->deleteProc) {
sl@0: 		(*resVarInfo->deleteProc)(resVarInfo);
sl@0: 	    } else {
sl@0: 		ckfree((char *) resVarInfo);
sl@0: 	    }
sl@0:         }
sl@0: 
sl@0: 	if (localPtr->defValuePtr != NULL) {
sl@0: 	    defPtr = localPtr->defValuePtr;
sl@0: 	    Tcl_DecrRefCount(defPtr);
sl@0: 	}
sl@0: 	ckfree((char *) localPtr);
sl@0: 	localPtr = nextPtr;
sl@0:     }
sl@0:     ckfree((char *) procPtr);
sl@0: 
sl@0: #ifdef TCL_TIP280
sl@0:     /* TIP #280. Release the location data associated with this Proc
sl@0:      * structure, if any. The interpreter may not exist (For example for
sl@0:      * procbody structurues created by tbcload.
sl@0:      */
sl@0: 
sl@0:     if (!iPtr) return;
sl@0: 
sl@0:     hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr);
sl@0:     if (!hePtr) return;
sl@0: 
sl@0:     cfPtr = (CmdFrame*) Tcl_GetHashValue (hePtr);
sl@0: 
sl@0:     if (cfPtr->type == TCL_LOCATION_SOURCE) {
sl@0:         Tcl_DecrRefCount (cfPtr->data.eval.path);
sl@0: 	cfPtr->data.eval.path = NULL;
sl@0:     }
sl@0:     ckfree ((char*) cfPtr->line); cfPtr->line = NULL;
sl@0:     ckfree ((char*) cfPtr);
sl@0:     Tcl_DeleteHashEntry (hePtr);
sl@0: #endif
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclUpdateReturnInfo --
sl@0:  *
sl@0:  *	This procedure is called when procedures return, and at other
sl@0:  *	points where the TCL_RETURN code is used.  It examines fields
sl@0:  *	such as iPtr->returnCode and iPtr->errorCode and modifies
sl@0:  *	the real return status accordingly.
sl@0:  *
sl@0:  * Results:
sl@0:  *	The return value is the true completion code to use for
sl@0:  *	the procedure, instead of TCL_RETURN.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	The errorInfo and errorCode variables may get modified.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int
sl@0: TclUpdateReturnInfo(iPtr)
sl@0:     Interp *iPtr;		/* Interpreter for which TCL_RETURN
sl@0: 				 * exception is being processed. */
sl@0: {
sl@0:     int code;
sl@0:     char *errorCode;
sl@0:     Tcl_Obj *objPtr;
sl@0: 
sl@0:     code = iPtr->returnCode;
sl@0:     iPtr->returnCode = TCL_OK;
sl@0:     if (code == TCL_ERROR) {
sl@0: 	errorCode = ((iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE");
sl@0: 	objPtr = Tcl_NewStringObj(errorCode, -1);
sl@0: 	Tcl_IncrRefCount(objPtr);
sl@0: 	Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode,
sl@0: 	        NULL, objPtr, TCL_GLOBAL_ONLY);
sl@0: 	Tcl_DecrRefCount(objPtr);
sl@0: 	iPtr->flags |= ERROR_CODE_SET;
sl@0: 	if (iPtr->errorInfo != NULL) {
sl@0: 	    objPtr = Tcl_NewStringObj(iPtr->errorInfo, -1);
sl@0: 	    Tcl_IncrRefCount(objPtr);
sl@0: 	    Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo,
sl@0: 		    NULL, objPtr, TCL_GLOBAL_ONLY);
sl@0: 	    Tcl_DecrRefCount(objPtr);
sl@0: 	    iPtr->flags |= ERR_IN_PROGRESS;
sl@0: 	}
sl@0:     }
sl@0:     return code;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclGetInterpProc --
sl@0:  *
sl@0:  *  Returns a pointer to the TclProcInterpProc procedure; this is different
sl@0:  *  from the value obtained from the TclProcInterpProc reference on systems
sl@0:  *  like Windows where import and export versions of a procedure exported
sl@0:  *  by a DLL exist.
sl@0:  *
sl@0:  * Results:
sl@0:  *  Returns the internal address of the TclProcInterpProc procedure.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *  None.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: TclCmdProcType
sl@0: TclGetInterpProc()
sl@0: {
sl@0:     return (TclCmdProcType) TclProcInterpProc;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclGetObjInterpProc --
sl@0:  *
sl@0:  *  Returns a pointer to the TclObjInterpProc procedure; this is different
sl@0:  *  from the value obtained from the TclObjInterpProc reference on systems
sl@0:  *  like Windows where import and export versions of a procedure exported
sl@0:  *  by a DLL exist.
sl@0:  *
sl@0:  * Results:
sl@0:  *  Returns the internal address of the TclObjInterpProc procedure.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *  None.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: TclObjCmdProcType
sl@0: TclGetObjInterpProc()
sl@0: {
sl@0:     return (TclObjCmdProcType) TclObjInterpProc;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclNewProcBodyObj --
sl@0:  *
sl@0:  *  Creates a new object, of type "procbody", whose internal
sl@0:  *  representation is the given Proc struct.
sl@0:  *  The newly created object's reference count is 0.
sl@0:  *
sl@0:  * Results:
sl@0:  *  Returns a pointer to a newly allocated Tcl_Obj, 0 on error.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *  The reference count in the ByteCode attached to the Proc is bumped up
sl@0:  *  by one, since the internal rep stores a pointer to it.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: Tcl_Obj *
sl@0: TclNewProcBodyObj(procPtr)
sl@0:     Proc *procPtr;	/* the Proc struct to store as the internal
sl@0:                          * representation. */
sl@0: {
sl@0:     Tcl_Obj *objPtr;
sl@0: 
sl@0:     if (!procPtr) {
sl@0:         return (Tcl_Obj *) NULL;
sl@0:     }
sl@0:     
sl@0:     objPtr = Tcl_NewStringObj("", 0);
sl@0: 
sl@0:     if (objPtr) {
sl@0:         objPtr->typePtr = &tclProcBodyType;
sl@0:         objPtr->internalRep.otherValuePtr = (VOID *) procPtr;
sl@0: 
sl@0:         procPtr->refCount++;
sl@0:     }
sl@0: 
sl@0:     return objPtr;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * ProcBodyDup --
sl@0:  *
sl@0:  *  Tcl_ObjType's Dup function for the proc body object.
sl@0:  *  Bumps the reference count on the Proc stored in the internal
sl@0:  *  representation.
sl@0:  *
sl@0:  * Results:
sl@0:  *  None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *  Sets up the object in dupPtr to be a duplicate of the one in srcPtr.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static void ProcBodyDup(srcPtr, dupPtr)
sl@0:     Tcl_Obj *srcPtr;		/* object to copy */
sl@0:     Tcl_Obj *dupPtr;		/* target object for the duplication */
sl@0: {
sl@0:     Proc *procPtr = (Proc *) srcPtr->internalRep.otherValuePtr;
sl@0:     
sl@0:     dupPtr->typePtr = &tclProcBodyType;
sl@0:     dupPtr->internalRep.otherValuePtr = (VOID *) procPtr;
sl@0:     procPtr->refCount++;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * ProcBodyFree --
sl@0:  *
sl@0:  *  Tcl_ObjType's Free function for the proc body object.
sl@0:  *  The reference count on its Proc struct is decreased by 1; if the count
sl@0:  *  reaches 0, the proc is freed.
sl@0:  *
sl@0:  * Results:
sl@0:  *  None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *  If the reference count on the Proc struct reaches 0, the struct is freed.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static void
sl@0: ProcBodyFree(objPtr)
sl@0:     Tcl_Obj *objPtr;		/* the object to clean up */
sl@0: {
sl@0:     Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr;
sl@0:     procPtr->refCount--;
sl@0:     if (procPtr->refCount <= 0) {
sl@0:         TclProcCleanupProc(procPtr);
sl@0:     }
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * ProcBodySetFromAny --
sl@0:  *
sl@0:  *  Tcl_ObjType's SetFromAny function for the proc body object.
sl@0:  *  Calls panic.
sl@0:  *
sl@0:  * Results:
sl@0:  *  Theoretically returns a TCL result code.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *  Calls panic, since we can't set the value of the object from a string
sl@0:  *  representation (or any other internal ones).
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: ProcBodySetFromAny(interp, objPtr)
sl@0:     Tcl_Interp *interp;			/* current interpreter */
sl@0:     Tcl_Obj *objPtr;			/* object pointer */
sl@0: {
sl@0:     panic("called ProcBodySetFromAny");
sl@0: 
sl@0:     /*
sl@0:      * this to keep compilers happy.
sl@0:      */
sl@0:     
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * ProcBodyUpdateString --
sl@0:  *
sl@0:  *  Tcl_ObjType's UpdateString function for the proc body object.
sl@0:  *  Calls panic.
sl@0:  *
sl@0:  * Results:
sl@0:  *  None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *  Calls panic, since we this type has no string representation.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static void
sl@0: ProcBodyUpdateString(objPtr)
sl@0:     Tcl_Obj *objPtr;		/* the object to update */
sl@0: {
sl@0:     panic("called ProcBodyUpdateString");
sl@0: }
sl@0: 
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclCompileNoOp --
sl@0:  *
sl@0:  *	Procedure called to compile noOp's
sl@0:  *
sl@0:  * Results:
sl@0:  *	The return value is TCL_OK, indicating successful compilation.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Instructions are added to envPtr to execute a noOp at runtime.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: TclCompileNoOp(interp, parsePtr, envPtr)
sl@0:     Tcl_Interp *interp;         /* Used for error reporting. */
sl@0:     Tcl_Parse *parsePtr;        /* Points to a parse structure for the
sl@0:                                  * command created by Tcl_ParseCommand. */
sl@0:     CompileEnv *envPtr;         /* Holds resulting instructions. */
sl@0: {
sl@0:     Tcl_Token *tokenPtr;
sl@0:     int i, code;
sl@0:     int savedStackDepth = envPtr->currStackDepth;
sl@0: 
sl@0:     tokenPtr = parsePtr->tokenPtr;
sl@0:     for(i = 1; i < parsePtr->numWords; i++) {
sl@0: 	tokenPtr = tokenPtr + tokenPtr->numComponents + 1;
sl@0: 	envPtr->currStackDepth = savedStackDepth;
sl@0: 
sl@0: 	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { 
sl@0: 	    code = TclCompileTokens(interp, tokenPtr+1,
sl@0: 	            tokenPtr->numComponents, envPtr);
sl@0: 	    if (code != TCL_OK) {
sl@0: 		return code;
sl@0: 	    }
sl@0: 	    TclEmitOpcode(INST_POP, envPtr);
sl@0: 	} 
sl@0:     }
sl@0:     envPtr->currStackDepth = savedStackDepth;
sl@0:     TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  * Local Variables:
sl@0:  * mode: c
sl@0:  * c-basic-offset: 4
sl@0:  * fill-column: 78
sl@0:  * End:
sl@0:  */
sl@0: