/*
 * tclProc.c --
 *
 *	This file contains routines that implement Tcl procedures, including
 *	the "proc" and "uplevel" commands.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 2004-2006 Miguel Sofer
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclProc.c,v 1.121 2007/06/14 21:02:20 msofer Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Prototypes for static functions in this file

     */

    if (iPtr->cmdFramePtr) {
	CmdFrame context = *iPtr->cmdFramePtr;

	if (context.type == TCL_LOCATION_BC) {
	    /*
	     * Retrieve source information from the bytecode, if possible.
	     * If the information is retrieved successfully, context.type
	     * will be TCL_LOCATION_SOURCE and the reference held by
	     * context.data.eval.path will be counted.
	     */

	    TclGetSrcInfoForPc(&context);
	} else if (context.type == TCL_LOCATION_SOURCE) {
	    /*
	     * The copy into 'context' up above has created another
	     * reference to 'context.data.eval.path'; account for it.
	     */

	    Tcl_IncrRefCount(context.data.eval.path);
	}

	if (context.type == TCL_LOCATION_SOURCE) {

	    /*
	     * We can account for source location within a proc only
	     * if the proc body was not created by substitution.
	     */

	    if (context.line
		&& (context.nline >= 4) && (context.line[3] >= 0)) {
		int isNew;
		CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
		
		cfPtr->level = -1;
		cfPtr->type = context.type;
		cfPtr->line = (int *) ckalloc(sizeof(int));
		cfPtr->line[0] = context.line[3];
		cfPtr->nline = 1;
		cfPtr->framePtr = NULL;
		cfPtr->nextPtr = NULL;
		
		cfPtr->data.eval.path = context.data.eval.path;
		Tcl_IncrRefCount(cfPtr->data.eval.path);

		cfPtr->cmd.str.cmd = NULL;
		cfPtr->cmd.str.len = 0;
		
		Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr,
						     (char *) procPtr, &isNew),
				 cfPtr);
	    }

	    /*
	     * 'context' is going out of scope; account for the reference
	     * that it's holding to the path name.
	     */

	    Tcl_DecrRefCount(context.data.eval.path);
	    context.data.eval.path = NULL;
	}
    }

	precompiled = 1;
    } else {
	/*
	 * If the procedure's body object is shared because its string value
	 * is identical to, e.g., the body of another procedure, we must
	 * create a private copy for this procedure to use. Such sharing of
	 * procedure bodies is rare but can cause problems. A procedure body
	 * is compiled in a context that includes the number of
	 * compiler-allocated "slots" for local variables. Each formal
	 * parameter is given a local variable slot (the
	 * "procPtr->numCompiledLocals = numArgs" assignment below). This
	 * means that the same code can not be shared by two procedures that
	 * have a different number of arguments, even if their bodies are
	 * identical. Note that we don't use Tcl_DuplicateObj since we would
	 * not want any bytecode internal representation.
	 */


/*
 *----------------------------------------------------------------------
 *
 * InitArgsAndLocals --
 *
 *	This routine is invoked in order to initialize the arguments and other
 *	compiled locals	table for a new call frame. 
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *      Allocates memory on the stack for the compiled local variables, the
 *      caller is responsible for freeing them. Initialises all variables.
 *	May invoke various name resolvers in order to determine which
 *	variables are being referenced at runtime. 
 *
 *----------------------------------------------------------------------
 */

static int
InitArgsAndLocals(
    register Tcl_Interp *interp,/* Interpreter in which procedure was

    register Var *varPtr;
    register CompiledLocal *localPtr;
    int localCt, numArgs, argCt, i, imax;
    Var *compiledLocals;
    Tcl_Obj *const *argObjs;
    Tcl_Obj **desiredObjs;
    const char *final;
    
    /*
     * Create the "compiledLocals" array. Make sure it is large enough to hold
     * all the procedure's compiled local variables, including its formal
     * parameters.
     */

    localCt = procPtr->numCompiledLocals;

    if (numArgs == 0) {
	if (argCt) {
	    goto incorrectArgs;
	} else {
	    goto correctArgs;
	}
    }
    imax = ((argCt < numArgs - 1)? argCt : (numArgs - 1));
    for (i = 0; i < imax; i++) {
	/*
	 * "Normal" arguments; last formal is special, depends on it being
	 * 'args'.
	 */

	Tcl_Obj *objPtr = argObjs[i];

	varPtr->value.objPtr = objPtr;
	Tcl_IncrRefCount(objPtr);	/* Local var is a reference. */
	varPtr->name = localPtr->name;
	varPtr->nsPtr = NULL;
	varPtr->hPtr = NULL;
	varPtr->refCount = 0;
	varPtr->tracePtr = NULL;
	varPtr->searchPtr = NULL;
	varPtr->flags = localPtr->flags;
	varPtr++;
	localPtr = localPtr->nextPtr;
    }
    for (; i < (numArgs - 1); i++) {
	/*
	 * This loop is entered if argCt < (numArgs-1). Set default values;
	 * last formal is special.
	 */

	if (localPtr->defValuePtr != NULL) {
	    Tcl_Obj *objPtr = localPtr->defValuePtr;

	Tcl_IncrRefCount(objPtr);	/* Local var is a reference. */
    } else if ((argCt < numArgs) && (localPtr->defValuePtr != NULL)) {
	Tcl_Obj *objPtr = localPtr->defValuePtr;

	varPtr->value.objPtr = objPtr;
	Tcl_IncrRefCount(objPtr);	/* Local var is a reference. */
    } else {

	goto incorrectArgs;
    }

    varPtr->name = localPtr->name;
    varPtr->nsPtr = NULL;
    varPtr->hPtr = NULL;
    varPtr->refCount = 0;

    /*
     * Do initialise all compiled locals, to avoid problems at
     * DeleteLocalVars.
     */

    final = NULL;
    InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr);
    
    /*
     * Build up desired argument list for Tcl_WrongNumArgs
     */
    
    desiredObjs = (Tcl_Obj **) TclStackAlloc(interp,
	    (int) sizeof(Tcl_Obj *) * (numArgs+1));
    
#ifdef AVOID_HACKS_FOR_ITCL
    desiredObjs[0] = framePtr->objv[skip-1];
#else
    desiredObjs[0] = ((framePtr->isProcCallFrame & FRAME_IS_LAMBDA)
	    ? framePtr->objv[skip-1]
	    : Tcl_NewListObj(skip, framePtr->objv));
#endif /* AVOID_HACKS_FOR_ITCL */
    Tcl_IncrRefCount(desiredObjs[0]);
    
    localPtr = procPtr->firstLocalPtr;
    for (i=1 ; i<=numArgs ; i++) {
	Tcl_Obj *argObj;
	
	if (localPtr->defValuePtr != NULL) {
	    TclNewObj(argObj);
	    Tcl_AppendStringsToObj(argObj, "?", localPtr->name, "?", NULL);
	} else if ((i==numArgs) && !strcmp(localPtr->name, "args")) {
	    numArgs--;
	    final = "...";
	    break;
	} else {
	    argObj = Tcl_NewStringObj(localPtr->name, -1);
	}
	desiredObjs[i] = argObj;
	localPtr = localPtr->nextPtr;
    }
    
    Tcl_ResetResult(interp);
    Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, final);
    
    for (i=0 ; i<=numArgs ; i++) {
	Tcl_DecrRefCount(desiredObjs[i]);
    }
    TclStackFree(interp);
    return TCL_ERROR;
}


    register Tcl_Interp *interp,/* Interpreter in which procedure was
				 * invoked. */
    int objc,			/* Count of number of arguments to this
				 * procedure. */
    Tcl_Obj *CONST objv[])	/* Argument value objects. */
{
    int result;
    
    result = PushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0);
    if (result == TCL_OK) {
	return TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError);
    } else {
	return TCL_ERROR;
    }
}

				 * invoked. */
    Tcl_Obj *procNameObj,	/* Procedure name for error reporting. */
    int skip,			/* Number of initial arguments to be skipped,
				 * i.e., words in the "command name". */
    ProcErrorProc errorProc)	/* How to convert results from the script into
				 * results of the overall procedure. */
{
    CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
    register Proc *procPtr = framePtr->procPtr;
    ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
    int result;

    result = InitArgsAndLocals(interp, procNameObj, skip);
    if (result != TCL_OK) {
	goto procDone;
    }

#if defined(TCL_COMPILE_DEBUG)
    if (tclTraceExec >= 1) {


	if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
	    fprintf(stdout, "Calling lambda ");
	} else {
	    fprintf(stdout, "Calling proc ");
	}
	for (i = 0; i < framePtr->objc; i++) {
	    TclPrintObject(stdout, framePtr->objv[i], 15);

    procPtr->refCount++;
    ((Interp *)interp)->numLevels++;

    if (TclInterpReady(interp) == TCL_ERROR) {
	result = TCL_ERROR;
    } else {



	codePtr->refCount++;
	result = TclExecuteByteCode(interp, codePtr);
	codePtr->refCount--;
	if (codePtr->refCount <= 0) {
	    TclCleanupByteCode(codePtr);
	}
    }
    
    ((Interp *)interp)->numLevels--;
    procPtr->refCount--;
    if (procPtr->refCount <= 0) {
	TclProcCleanupProc(procPtr);
    }

    /*
     * If the procedure is completing normally, we can skip directly to the
     * part where we clean up any associated memory.
     */

    if (result == TCL_OK) {
	goto procDone;
    }

    /*
     * Non-standard results are processed by passing them through quickly.
     * This means they all work as exceptions, unwinding the stack quickly and
     * neatly. Who knows how well they are handled by third-party code
     * though...
     */

    if ((result > TCL_CONTINUE) || (result < TCL_OK)) {
	goto procDone;
    }

    /*
     * If it is a 'return', do the TIP#90 processing now.
     */

    if (result == TCL_RETURN) {
	result = TclUpdateReturnInfo((Interp *) interp);
	goto procDone;
    }


    /*
     * Must be an error, a 'break' or a 'continue'. It's an error to get to
     * this point from a 'break' or 'continue' though, so transform to an
     * error now.
     */

    if (result != TCL_ERROR) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "invoked \"",
		((result == TCL_BREAK) ? "break" : "continue"),
		"\" outside of a loop", NULL);
	result = TCL_ERROR;
    }





    /*
     * Now it _must_ be an error, so we need to log it as such. This means
     * filling out the error trace.

     */

    (*errorProc)(interp, procNameObj);
















  procDone:
    /*
     * Free the stack-allocated compiled locals and CallFrame. It is important
     * to pop the call frame without freeing it first: the compiledLocals
     * cannot be freed before the frame is popped, as the local variables must
     * be deleted. But the compiledLocals must be freed first, as they were