/*
 * 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.115 2007/05/11 09:17:01 dkf Exp $
 */

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

/*
 * Prototypes for static functions in this file

 *	interpreter.
 *
 *----------------------------------------------------------------------
 */

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;

	Tcl_IncrRefCount(bodyPtr);

	procPtr = (Proc *) ckalloc(sizeof(Proc));
	procPtr->iPtr = iPtr;
	procPtr->refCount = 1;
	procPtr->bodyPtr = bodyPtr;
	procPtr->numArgs = 0;	/* Actual argument count is set below. */
	procPtr->numCompiledLocals = 0;
	procPtr->firstLocalPtr = NULL;
	procPtr->lastLocalPtr = NULL;
    }

    /*
     * Break up the argument list into argument specifiers, then process each

	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],
			    "\" is an array element", NULL);
		    ckfree((char *) fieldValues);
		    goto procError;
		}
	    } else if ((*p == ':') && (*(p+1) == ':')) {

	     * compare the default value if any
	     */

	    if (localPtr->defValuePtr != NULL) {
		int tmpLength;
		char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr,
			&tmpLength);

		if ((valueLength != tmpLength) ||
			strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "procedure \"%s\": formal parameter \"%s\" has "
			    "default value inconsistent with precompiled body",
			    procName, fieldValues[0]));
		    ckfree((char *) fieldValues);

{
    Proc *procPtr = (Proc *) clientData;
    Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
    CallFrame *framePtr, **framePtrPtr;
    int result;

    /*
     * If necessary (i.e. if we haven't got a suitable compilation already
     * cached) 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.
     */

    if (procPtr->bodyPtr->typePtr == &tclByteCodeType) {
	Interp *iPtr = (Interp *) interp;
	ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;

	/*
	 * When we've got bytecode, this is the check for validity. That is,
	 * the bytecode must be for the right interpreter (no cross-leaks!),
	 * the code must be from the current epoch (so subcommand compilation
	 * is up-to-date), and the namespace must match (so variable handling
	 * is right).
	 */

 	if (((Interp *) *codePtr->interpHandle != iPtr)
		|| (codePtr->compileEpoch != iPtr->compileEpoch)
		|| (codePtr->nsPtr != nsPtr)) {
	    goto doCompilation;
	}
    } else {
    doCompilation:
	result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
		(isLambda ? "body of lambda term" : "body of proc"),
		TclGetString(objv[isLambda]), &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;
    framePtr->procPtr = procPtr;

	 * "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;

	    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;

     * localPtr and varPtr point to the last argument to be initialized.
     */

    if (localPtr->flags & VAR_IS_ARGS) {
	Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i);

	varPtr->value.objPtr = listPtr;
	Tcl_IncrRefCount(listPtr);	/* Local var is a reference. */
    } else if (argCt == numArgs) {
	Tcl_Obj *objPtr = argObjs[i];

	varPtr->value.objPtr = objPtr;
	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 {
	Tcl_Obj **desiredObjs;
	ByteCode *codePtr;
	const char *final;

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

		if (copy->defValuePtr) {
		    Tcl_IncrRefCount(copy->defValuePtr);
		}
		copy->resolveInfo = localPtr->resolveInfo;
		strcpy(copy->name, localPtr->name);
	    }

	    /*
	     * Reset the ClientData
	     */

	    Tcl_GetCommandInfoFromToken(token, &info);
	    if (info.objClientData == (ClientData) procPtr) {
		info.objClientData = (ClientData) newProc;
	    }
	    if (info.clientData == (ClientData) procPtr) {
		info.clientData = (ClientData) newProc;
	    }

 *	Sets up the object in dupPtr to be a duplicate of the one in srcPtr.
 *
 *----------------------------------------------------------------------
 */

static void
ProcBodyDup(
    Tcl_Obj *srcPtr,		/* Object to copy. */
    Tcl_Obj *dupPtr)		/* Target object for the duplication. */
{
    Proc *procPtr = srcPtr->internalRep.otherValuePtr;

    dupPtr->typePtr = &tclProcBodyType;
    dupPtr->internalRep.otherValuePtr = procPtr;
    procPtr->refCount++;
}

 *	freed.
 *
 *----------------------------------------------------------------------
 */

static void
ProcBodyFree(
    Tcl_Obj *objPtr)		/* The object to clean up. */
{
    Proc *procPtr = objPtr->internalRep.otherValuePtr;

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

    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, isRootEnsemble;
    Command cmd;
    Tcl_Namespace *nsPtr;

    ExtraFrameInfo efi;

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