* Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 2004-2006 Miguel Sofer
 * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
 *
 * 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.145 2008/07/14 08:22:14 dkf Exp $
 * RCS: @(#) $Id: tclProc.c,v 1.146 2008/07/14 14:15:11 dkf Exp $
 */

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

/*
 * Variables that are part of the [apply] command implementation and which
 * have to be passed to the other side of the NRE call.
 */

typedef struct {
    int isRootEnsemble;
    Command cmd;
    ExtraFrameInfo efi;
} ApplyExtraData;

static TclNR_PostProc ApplyNR2;
static TclNR_PostProc InterpProcNR2;

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

static void		DupLambdaInternalRep(Tcl_Obj *objPtr,
			    Tcl_Obj *copyPtr);
static void		FreeLambdaInternalRep(Tcl_Obj *objPtr);

static void		MakeLambdaError(Tcl_Interp *interp,
			    Tcl_Obj *procNameObj);
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);

static TclNR_PostProc ApplyNR2;
static TclNR_PostProc InterpProcNR2;
static TclNR_PostProc Uplevel_Callback;

/*
 * The ProcBodyObjType type
 */

Tcl_ObjType tclProcBodyType = {

    if (nsPtr != iPtr->globalNsPtr) {
	Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
	Tcl_DStringAppend(&ds, "::", 2);
    }
    Tcl_DStringAppend(&ds, procName, -1);

    cmd = TclNR_CreateCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc,
	    TclNRInterpProc, (ClientData) procPtr, TclProcDeleteProc);
	    TclNRInterpProc, procPtr, TclProcDeleteProc);
    Tcl_DStringFree(&ds);

    /*
     * Now initialize the new procedure's cmdPtr field. This will be used
     * later when the procedure is called to determine what namespace the
     * procedure will run in. This will be different than the current
     * namespace if the proc was renamed into a different namespace.

	 * between, then evaluate the result. Tcl_EvalObjEx will delete the
	 * object when it decrements its refcount after eval'ing it.
	 */

	objPtr = Tcl_ConcatObj(objc, objv);
    }

    TclNR_AddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL, NULL);
    TclNR_AddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL,
	    NULL);
    return TclNREvalObjEx(interp, objPtr, 0, NULL, 0);
}

/*
 *----------------------------------------------------------------------
 *
 * TclFindProc --

    }

    /*
     * When we get here, the last formal argument remains to be defined:
     * defPtr and varPtr point to the last argument to be initialized.
     */


    varPtr->flags = 0;
    if (defPtr->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) {

    /*
     * Initialise and resolve the remaining compiledLocals. In the absence of
     * resolvers, they are undefined local vars: (flags=0, value=NULL).
     */

  correctArgs:
    if (numArgs < localCt) {
	if (!framePtr->nsPtr->compiledVarResProc && !((Interp *)interp)->resolverPtr) {
	if (!framePtr->nsPtr->compiledVarResProc
		&& !((Interp *)interp)->resolverPtr) {
	    memset(varPtr, 0, (localCt - numArgs)*sizeof(Var));
	} else {
	    InitResolvedLocals(interp, codePtr, varPtr, framePtr->nsPtr);
	}
    }

    return TCL_OK;


    incorrectArgs:
    /*
     * Initialise all compiled locals to avoid problems at DeleteLocalVars.
     */

  incorrectArgs:
    memset(varPtr, 0,
    memset(varPtr, 0, ((framePtr->compiledLocals + localCt)-varPtr)*sizeof(Var));
	    ((framePtr->compiledLocals + localCt)-varPtr) * sizeof(Var));
    return ProcWrongNumArgs(interp, skip);
}

/*
 *----------------------------------------------------------------------
 *
 * PushProcCallFrame --

    framePtr->objc = objc;
    framePtr->objv = objv;
    framePtr->procPtr = procPtr;

    return TCL_OK;
}


static int
TclNR_BC(
    Tcl_Interp * interp,
    Tcl_Interp *interp,
    ByteCode *codePtr,
    TclNR_PostProc *postProcPtr,
    Tcl_Obj *procNameObj,
    ProcErrorProc errorProc)
{
    TEOV_record *recordPtr = TOP_RECORD(interp);

    recordPtr->type         = TCL_NR_BC_TYPE;
    recordPtr->type = TCL_NR_BC_TYPE;
    recordPtr->data.codePtr = codePtr;
    TclNR_AddCallback(interp, postProcPtr, procNameObj, errorProc, NULL, NULL);
    TclNR_AddCallback(interp, postProcPtr, procNameObj, errorProc, NULL,
	    NULL);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjInterpProc --

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

    /*
     * Not used in the core; external interface for iTcl and XOTcl
     */
    
    result = PushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0);
    if (result == TCL_OK) {
    int result = PushProcCallFrame(clientData, interp, objc, objv,
	    /*isLambda*/ 0);

    if (result != TCL_OK) {
	return TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError);
    } else {
	return TCL_ERROR;
    }
    return TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError);
}

int
TclNRInterpProc(
    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. */
    Tcl_Obj *const objv[])	/* Argument value objects. */
{
    int result;
    int result = PushProcCallFrame(clientData, interp, objc, objv,
	    /*isLambda*/ 0);

    result = PushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0);
    if (result == TCL_OK) {
    if (result != TCL_OK) {
	return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
    } else {
	return TCL_ERROR;
    }
    return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjInterpProcCore --
 *

    int result;
    CallFrame *freePtr;
    ByteCode *codePtr;

    result = InitArgsAndLocals(interp, procNameObj, skip);
    if (result != TCL_OK) {
	freePtr = iPtr->framePtr;
	Tcl_PopCallFrame(interp);	 /* Pop but do not free. */
	Tcl_PopCallFrame(interp);	/* Pop but do not free. */
	TclStackFree(interp, freePtr->compiledLocals);
	                                /* Free compiledLocals. */
	TclStackFree(interp, freePtr);	/* Free CallFrame. */
	return TCL_ERROR;
    }

#if defined(TCL_COMPILE_DEBUG)

	fprintf(stdout, "\n");
	fflush(stdout);
    }
#endif /*TCL_COMPILE_DEBUG*/

    if (TCL_DTRACE_PROC_ARGS_ENABLED()) {
	char *a[10];
	int i = 0;
	int i;
	int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;

	while (i < 10) {
	for (i=0 ; i<10 ; i++) {
	    a[i] = (l < iPtr->varFramePtr->objc ? 
		    TclGetString(iPtr->varFramePtr->objv[l]) : NULL); i++; l++;
		    TclGetString(iPtr->varFramePtr->objv[l]) : NULL);
	    l++;
	}
	TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
		a[8], a[9]);
    }
    if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) {
	Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr);
	char *a[4]; int i[2];

	l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 2 : 1;
	TCL_DTRACE_PROC_ENTRY(TclGetString(procNameObj),
		iPtr->varFramePtr->objc - l,
		(Tcl_Obj **)(iPtr->varFramePtr->objv + l));
    }

    TclNR_BC(interp, codePtr, InterpProcNR2, procNameObj, errorProc);
    
    return TCL_OK;
}

static int
InterpProcNR2(
    ClientData data[],
    Tcl_Interp *interp,

    if (bodyPtr->typePtr == &tclByteCodeType) {
 	if (((Interp *) *codePtr->interpHandle == iPtr)
		&& (codePtr->compileEpoch == iPtr->compileEpoch)
		&& (codePtr->nsPtr == nsPtr)
		&& (codePtr->nsEpoch == nsPtr->resolverEpoch)) {
	    return TCL_OK;
	}
	} else {
	    if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
		if ((Interp *) *codePtr->interpHandle != iPtr) {
		    Tcl_AppendResult(interp,
			    "a precompiled script jumped interps", NULL);
		    return TCL_ERROR;
		}
		codePtr->compileEpoch = iPtr->compileEpoch;
		codePtr->nsPtr = nsPtr;
	    } else {
		bodyPtr->typePtr->freeIntRepProc(bodyPtr);
		bodyPtr->typePtr = NULL;
	    }
 	}
    }

	if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
	    if ((Interp *) *codePtr->interpHandle != iPtr) {
		Tcl_AppendResult(interp,
			"a precompiled script jumped interps", NULL);
		return TCL_ERROR;
	    }
	    codePtr->compileEpoch = iPtr->compileEpoch;
	    codePtr->nsPtr = nsPtr;
	} else {
	    bodyPtr->typePtr->freeIntRepProc(bodyPtr);
	    bodyPtr->typePtr = NULL;
 	}
    }

    if (bodyPtr->typePtr != &tclByteCodeType) {
	Tcl_HashEntry *hePtr;

#ifdef TCL_COMPILE_DEBUG
 	if (tclTraceCompile >= 1) {
 	    /*
 	     * Display a line summarizing the top level command we are about

    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    return TclNR_CallObjProc(interp, TclNRApplyObjCmd, dummy, objc, objv);
}


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

    overflow = (nameLen > limit);
    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
	    "\n    (lambda term \"%.*s%s\" line %d)",
	    (overflow ? limit : nameLen), procName,
	    (overflow ? "..." : ""), interp->errorLine));
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_DisassembleObjCmd --
 *
 *	Implementation of the "::tcl::unsupported::disassemble" command. This