/*
 * 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.94 2006/10/20 14:04:01 dkf Exp $
 */

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

/*
 * Prototypes for static functions in this file
 */

static void		DupLambdaInternalRep(Tcl_Obj *objPtr,
			    Tcl_Obj *copyPtr);
static void		FreeLambdaInternalRep(Tcl_Obj *objPtr);
static void		InitCompiledLocals(Tcl_Interp *interp,
			    ByteCode *codePtr, CompiledLocal *localPtr,
			    Var *varPtr, Namespace *nsPtr);
static int		ObjInterpProcEx(ClientData clientData,
			    register Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[], int skip);
static void		ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
static void		ProcBodyFree(Tcl_Obj *objPtr);
static int		ProcessProcResultCode(Tcl_Interp *interp,
			    Tcl_Obj *procNameObj, int returnCode,
			    int isMethod);
static int		SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int		ProcCompileProc (Tcl_Interp *interp, Proc *procPtr,
			    Tcl_Obj *bodyPtr, Namespace *nsPtr, 
			    CONST char *description, CONST char *procName,
			    Proc **procPtrPtr);

/*

	/* ARGSUSED */
int
Tcl_ProcObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    register Interp *iPtr = (Interp *) interp;
    Proc *procPtr;
    char *fullName;
    const char *procName, *procArgs, *procBody;
    Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
    Tcl_Command cmd;
    Tcl_DString ds;

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "name args body");
	return TCL_ERROR;

 *----------------------------------------------------------------------
 */

int
TclCreateProc(
    Tcl_Interp *interp,		/* interpreter containing proc */
    Namespace *nsPtr,		/* namespace containing this proc */
    const char *procName,	/* unqualified name of this proc */
    Tcl_Obj *argsPtr,		/* description of arguments */
    Tcl_Obj *bodyPtr,		/* command body */
    Proc **procPtrPtr)		/* returns: pointer to proc data */
{
    Interp *iPtr = (Interp*)interp;
    const char **argArray = NULL;

    register Proc *procPtr;
    int i, length, result, numArgs;
    const char *args, *bytes, *p;
    register CompiledLocal *localPtr = NULL;
    Tcl_Obj *defPtr;
    int precompiled = 0;

    if (bodyPtr->typePtr == &tclProcBodyType) {
	/*
	 * Because the body is a TclProProcBody, the actual body is already

    } else {
	procPtr->numArgs = numArgs;
	procPtr->numCompiledLocals = numArgs;
    }

    for (i = 0; i < numArgs; i++) {
	int fieldCount, nameLength, valueLength;
	const char **fieldValues;

	/*
	 * Now divide the specifier up into name and default.
	 */

	result = Tcl_SplitList(interp, argArray[i], &fieldCount,
		&fieldValues);

	/*
	 * Check that the formal parameter name is a scalar.
	 */

	p = fieldValues[0];
	while (*p != '\0') {
	    if (*p == '(') {
		const char *q = p;
		do {
		    q++;
		} while (*q != '\0');
		q--;
		if (*q == ')') { /* we have an array element */
		    Tcl_AppendResult(interp, "formal parameter \"",
			    fieldValues[0],

 *
 *----------------------------------------------------------------------
 */

int
TclGetFrame(
    Tcl_Interp *interp,		/* Interpreter in which to find frame. */
    const char *name,		/* String describing frame. */
    CallFrame **framePtrPtr)	/* Store pointer to frame here (or NULL if
				 * global frame indicated). */
{
    register Interp *iPtr = (Interp *) interp;
    int curLevel, level, result;
    CallFrame *framePtr;

    Tcl_Obj *objPtr,		/* Object describing frame. */
    CallFrame **framePtrPtr)	/* Store pointer to frame here (or NULL if
				 * global frame indicated). */
{
    register Interp *iPtr = (Interp *) interp;
    int curLevel, level, result;
    CallFrame *framePtr;
    const char *name = TclGetString(objPtr);

    /*
     * Parse object to figure out which level number to go to.
     */

    result = 1;
    curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;

	/* ARGSUSED */
int
Tcl_UplevelObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    register Interp *iPtr = (Interp *) interp;
    int result;
    CallFrame *savedVarFramePtr, *framePtr;

    if (objc < 2) {
    uplevelSyntax:

 *
 *----------------------------------------------------------------------
 */

Proc *
TclFindProc(
    Interp *iPtr,		/* Interpreter in which to look. */
    const char *procName)	/* Name of desired procedure. */
{
    Tcl_Command cmd;
    Tcl_Command origCmd;
    Command *cmdPtr;

    cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, NULL, /*flags*/ 0);
    if (cmd == (Tcl_Command) NULL) {

    InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjInterpProc, ObjInterpProcEx --
 *
 *	When a Tcl procedure gets invoked during bytecode evaluation, this
 *	object-based routine gets invoked to interpret the procedure.
 *
 * Results:
 *	A standard Tcl object result value.
 *

TclObjInterpProc(
    ClientData clientData, 	/* Record describing procedure to be
				 * interpreted. */
    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. */
{

    return ObjInterpProcEx(clientData, interp, objc, objv, /*skip*/ 1);
}
	
static int
ObjInterpProcEx(
    ClientData clientData, 	/* Record describing procedure to be
				 * interpreted. */
    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 skip)			/* Number of initial arguments to be skipped,
				 * i.e., words in the "command name" */ 
{
    Proc *procPtr = (Proc *) clientData;
    Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
    CallFrame *framePtr, **framePtrPtr;






    int result;






    /*
     * If necessary, compile the procedure's body. The compiler will allocate
     * frame slots for the procedure's non-argument local variables. Note that
     * compiling the body might increase procPtr->numCompiledLocals if new
     * local variables are found while compiling.
     */

    result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
	    "body of proc", TclGetString(objv[0]), &procPtr);

    if (result != TCL_OK) {
	return result;
    }


    /*
     * Set up and push a new call frame for the new procedure invocation.
     * This call frame will execute in the proc's namespace, which might be
     * different than the current namespace. The proc's namespace is that of
     * its command, which can change if the command is renamed from one
     * namespace to another.
     */

    framePtrPtr = &framePtr;
    result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
	    (Tcl_Namespace *) nsPtr, FRAME_IS_PROC);

    if (result != TCL_OK) {
	return result;
    }


    framePtr->objc = objc;
    framePtr->objv = objv;	/* ref counts for args are incremented below */
    framePtr->procPtr = procPtr;

    return TclObjInterpProcCore(interp, framePtr, objv[0], skip);
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjInterpProcCore --
 *
 *	When a Tcl procedure, procedure-like method or lambda term gets
 *	invoked during bytecode evaluation, this object-based routine gets
 *	invoked to interpret the body.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	Depends on the commands in the procedure body.
 *
 *----------------------------------------------------------------------
 */

int
TclObjInterpProcCore(
    register Tcl_Interp *interp,/* Interpreter in which procedure was
				 * invoked. */
    CallFrame *framePtr,	/* The context to execute. The procPtr field
				 * must be non-NULL. */
    Tcl_Obj *procNameObj,	/* Procedure name for error reporting. */
    int skip)			/* Number of initial arguments to be skipped,
				 * i.e., words in the "command name". */
{
    register Proc *procPtr = framePtr->procPtr;
    register Var *varPtr;
    register CompiledLocal *localPtr;
    int localCt, numArgs, argCt, i, imax, result;
    Var *compiledLocals;
    Tcl_Obj *const *argObjs;
    int isMethod = (framePtr->isProcCallFrame &
	    (FRAME_IS_METHOD | FRAME_IS_CONSTRUCTOR | FRAME_IS_DESTRUCTOR));

    /*
     * 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;
    compiledLocals = (Var *) TclStackAlloc(interp, (int)(localCt*sizeof(Var)));
    framePtr->numCompiledLocals = localCt;
    framePtr->compiledLocals = compiledLocals;

    /*
     * Match and assign the call's actual parameters to the procedure's formal
     * arguments. The formal arguments are described by the first numArgs
     * entries in both the Proc structure's local variable list and the call
     * frame's local variable array.
     */

    numArgs = procPtr->numArgs;
    argCt = framePtr->objc-skip; /* set it to the number of args to the proc */
    argObjs = &framePtr->objv[skip];
    varPtr = framePtr->compiledLocals;
    localPtr = procPtr->firstLocalPtr;
    if (numArgs == 0) {
	if (argCt) {
	    goto incorrectArgs;
	} else {
	    goto runProc;

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

    incorrectArgs:
	codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr;
	InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr);

	/*
	 * Build up desired argument list for Tcl_WrongNumArgs
	 */

	desiredObjs = (Tcl_Obj **)
		ckalloc(sizeof(Tcl_Obj *) * (unsigned)(numArgs+1));

#ifdef AVOID_HACKS_FOR_ITCL
	desiredObjs[0] = framePtr->objv[0];
#else
	desiredObjs[0] = Tcl_NewListObj(skip, framePtr->objv);
#endif /* AVOID_HACKS_FOR_ITCL */

	localPtr = procPtr->firstLocalPtr;
	for (i=1 ; i<=numArgs ; i++) {
	    TclNewObj(argObj);
	    if (localPtr->defValuePtr != NULL) {
		Tcl_AppendStringsToObj(argObj, "?", localPtr->name, "?", NULL);

     */

  runProc:
    if (localPtr) {
	ByteCode *codePtr = (ByteCode *)
		procPtr->bodyPtr->internalRep.otherValuePtr;

	InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr);
    }

    /*
     * Invoke the commands in the procedure's body.
     */

#ifdef TCL_COMPILE_DEBUG
    if (tclTraceExec >= 1) {
	fprintf(stdout, "Calling proc ");
	for (i = 0; i < framePtr->objc; i++) {
	    TclPrintObject(stdout, framePtr->objv[i], 15);
	    fprintf(stdout, " ");
	}
	fprintf(stdout, "\n");
	fflush(stdout);
    }
#endif /*TCL_COMPILE_DEBUG*/

    procPtr->refCount++;
    result = TclCompEvalObj(interp, procPtr->bodyPtr);
    procPtr->refCount--;
    if (procPtr->refCount <= 0) {
	TclProcCleanupProc(procPtr);
    }

    if (result != TCL_OK) {
	if (skip == 1) {
	    result = ProcessProcResultCode(interp, procNameObj, result,
		    isMethod);
	} else {
	    /*
	     * Use a 'procName' that contains the first skip elements of objv
	     * for error reporting. This insures that we do not see just
	     * 'apply', but also the lambda expression that caused the error.
	     */

	    Tcl_Obj *namePtr;

	    namePtr = Tcl_NewListObj(skip, framePtr->objv);

	    result = ProcessProcResultCode(interp, namePtr, result, isMethod);
	    TclDecrRefCount(namePtr);
	}
    }

    /*
     * Pop and free the call frame for this procedure invocation, then free
     * the compiledLocals array if malloc'ed storage was used.

TclProcCompileProc(
    Tcl_Interp *interp,		/* Interpreter containing procedure. */
    Proc *procPtr,		/* Data associated with procedure. */
    Tcl_Obj *bodyPtr,		/* Body of proc. (Usually procPtr->bodyPtr,
 				 * but could be any code fragment compiled in
 				 * the context of this procedure.) */
    Namespace *nsPtr,		/* Namespace containing procedure. */
    const char *description,	/* string describing this body of code. */
    const char *procName)	/* Name of this procedure. */
{
    return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description,
	    procName, NULL);
}

static int
ProcCompileProc(

 *----------------------------------------------------------------------
 */

static int
ProcessProcResultCode(
    Tcl_Interp *interp,		/* The interpreter in which the procedure was
				 * called and returned returnCode. */
    Tcl_Obj *procNameObj,	/* Name of the procedure. Used for error
				 * messages and trace information. */

    int returnCode,		/* The unexpected result code. */
    int isMethod)		/* Whether this is a procedure, method,
				 * constructor or destructor. */
{
    Interp *iPtr = (Interp *) interp;
    int overflow, limit = 60;

    if (returnCode == TCL_OK) {
	return TCL_OK;
    }
    if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) {
	return returnCode;
    }
    if (returnCode == TCL_RETURN) {
	return TclUpdateReturnInfo(iPtr);
    }
    if (returnCode != TCL_ERROR) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "invoked \"",
		((returnCode == TCL_BREAK) ? "break" : "continue"),
		"\" outside of a loop", NULL);
    }
    if (isMethod & FRAME_IS_CONSTRUCTOR) {
	if (interp->errorLine != 0xDEADBEEF) { /* hack! */
	    CallContext *contextPtr =
		    ((Interp *) interp)->varFramePtr->ooContextPtr;
	    Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
	    Tcl_Command declarer;
	    Tcl_Obj *objectNameObj;
	    const char *objectName, *kindName;
	    int objectNameLen;

	    if (mPtr->declaringObjectPtr != NULL) {
		declarer = mPtr->declaringObjectPtr->command;
		kindName = "object";
	    } else {
		if (mPtr->declaringClassPtr == NULL) {
		    Tcl_Panic("method not declared in class or object");
		}
		declarer = mPtr->declaringClassPtr->thisPtr->command;
		kindName = "class";
	    }
	    TclNewObj(objectNameObj);
	    Tcl_GetCommandFullName(interp, declarer, objectNameObj);
	    objectName = Tcl_GetStringFromObj(objectNameObj, &objectNameLen);
	    overflow = (objectNameLen > limit);

	    TclFormatToErrorInfo(interp,
		    "\n    (%s \"%.*s%s\" constructor line %d)",
		    kindName, (overflow ? limit : objectNameLen), objectName,
		    (overflow ? "..." : ""), interp->errorLine);

	    TclDecrRefCount(objectNameObj);
	}
    } else if (isMethod & FRAME_IS_DESTRUCTOR) {
	CallContext *contextPtr =
		((Interp *) interp)->varFramePtr->ooContextPtr;
	Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
	Tcl_Command declarer;
	Tcl_Obj *objectNameObj;
	const char *objectName, *kindName;
	int objectNameLen;

	if (mPtr->declaringObjectPtr != NULL) {
	    declarer = mPtr->declaringObjectPtr->command;
	    kindName = "object";
	} else {
	    if (mPtr->declaringClassPtr == NULL) {
		Tcl_Panic("method not declared in class or object");
	    }
	    declarer = mPtr->declaringClassPtr->thisPtr->command;
	    kindName = "class";
	}
	TclNewObj(objectNameObj);
	Tcl_GetCommandFullName(interp, declarer, objectNameObj);
	objectName = Tcl_GetStringFromObj(objectNameObj, &objectNameLen);
	overflow = (objectNameLen > limit);

	TclFormatToErrorInfo(interp,
		"\n    (%s \"%.*s%s\" destructor line %d)",
		kindName, (overflow ? limit : objectNameLen), objectName,
		(overflow ? "..." : ""), interp->errorLine);

	TclDecrRefCount(objectNameObj);
    } else if (isMethod & FRAME_IS_METHOD) {
	int nameLen, objectNameLen, objNameOverflow;
	CallContext *contextPtr =
		((Interp *) interp)->varFramePtr->ooContextPtr;
	Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
	Tcl_Obj *objectNameObj;
	const char *objectName, *kindName, *methodName =
		Tcl_GetStringFromObj(mPtr->namePtr, &nameLen);
	Tcl_Command declarer;

	if (mPtr->declaringObjectPtr != NULL) {
	    declarer = mPtr->declaringObjectPtr->command;
	    kindName = "object";
	} else {
	    if (mPtr->declaringClassPtr == NULL) {
		Tcl_Panic("method not declared in class or object");
	    }
	    declarer = mPtr->declaringClassPtr->thisPtr->command;
	    kindName = "class";
	}
	TclNewObj(objectNameObj);
	Tcl_GetCommandFullName(interp, declarer, objectNameObj);
	objectName = Tcl_GetStringFromObj(objectNameObj, &objectNameLen);
	overflow = (nameLen > limit);
	objNameOverflow = (objectNameLen > limit);

	TclFormatToErrorInfo(interp,
		"\n    (%s \"%.*s%s\" method \"%.*s%s\" line %d)", kindName,
		(objNameOverflow ? limit : objectNameLen), objectName,
		(objNameOverflow ? "..." : ""), (overflow ? limit : nameLen),
		methodName, (overflow ? "..." : ""), interp->errorLine);

	TclDecrRefCount(objectNameObj);
    } else {
	int nameLen;
	const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);

    overflow = (nameLen > limit);

    TclFormatToErrorInfo(interp, "\n    (procedure \"%.*s%s\" line %d)",
	    (overflow ? limit : nameLen), procName,
	    (overflow ? "..." : ""), interp->errorLine);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclProcDeleteProc --

 */

static void
DupLambdaInternalRep(
    Tcl_Obj *srcPtr,		/* Object with internal rep to copy. */
    register Tcl_Obj *copyPtr)	/* Object with internal rep to set. */
{
    Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
    Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2;

    copyPtr->internalRep.twoPtrValue.ptr1 = procPtr;
    copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;

    procPtr->refCount++;
    Tcl_IncrRefCount(nsObjPtr);
    copyPtr->typePtr = &lambdaType;
}

static void
FreeLambdaInternalRep(
    register Tcl_Obj *objPtr)	/* CmdName object with internal representation
				 * to free. */
{
    Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
    Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2;

    procPtr->refCount--;
    if (procPtr->refCount == 0) {
	TclProcCleanupProc(procPtr);
    }
    TclDecrRefCount(nsObjPtr);
}

    name = TclGetString(objPtr);
    
    if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, name, argsPtr,
	    bodyPtr, &procPtr) != TCL_OK) {
	TclFormatToErrorInfo(interp,
		"\n    (parsing lambda expression \"%s\")",
		TclGetString(objPtr), NULL);
	return TCL_ERROR;
    }

    /* CAREFUL: TclCreateProc returns refCount==1! [Bug 1578454]
     * procPtr->refCount = 1;
     */
    

     * Free the list internalrep of objPtr - this will free argsPtr, but
     * bodyPtr retains a reference from the Proc structure. Then finish the
     * conversion to lambdaType.
     */

    objPtr->typePtr->freeIntRepProc(objPtr);

    objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
    objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
    objPtr->typePtr = &lambdaType;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ApplyObjCmd --
 *
 *	This object-based function is invoked to process the "apply" Tcl
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	Depends on the content of the lambda term (i.e., objv[1]).
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ApplyObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Interp *iPtr = (Interp *) interp;
    Proc *procPtr = NULL;
    Tcl_Obj *lambdaPtr, *nsObjPtr, *errPtr;
    int result;
    Command cmd;
    Tcl_Namespace *nsPtr;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?");
	return TCL_ERROR;
    }

    /*
     * Set lambdaPtr, convert it to lambdaType in the current interp if
     * necessary.
     */
 
    lambdaPtr = objv[1];
    if (lambdaPtr->typePtr == &lambdaType) {
	procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
    }

#define JOE_EXTENSION 0
#if JOE_EXTENSION
    /*
     * Joe English's suggestion to allow cmdNames to function as lambdas.
     * Requires also making tclCmdNameType non-static in tclObj.c

#endif

    if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) {
	result = SetLambdaFromAny(interp, lambdaPtr);
	if (result != TCL_OK) {
	    return result;
	}
	procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
    }
    procPtr->cmdPtr = &cmd;
    
    /*
     * Find the namespace where this lambda should run, and push a call frame
     * for that namespace. Note that TclObjInterpProc() will pop it.
     */
    
    nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2;
    result  = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
    if (result != TCL_OK) {
	return result;
    }

    if (nsPtr == NULL) {
	errPtr = Tcl_NewStringObj("cannot find namespace \"",-1);