/*
 * 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.84 2006/01/23 11:01:59 msofer Exp $
 * RCS: @(#) $Id: tclProc.c,v 1.85 2006/02/01 19:26:02 dgp Exp $
 */

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

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

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,
			    char *procName, int nameLen, int returnCode);
static int		TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr,
			    struct CompileEnv *envPtr);
static void		InitCompiledLocals(Tcl_Interp *interp,

    /*
     * Create the data structure to represent the procedure.
     */

    if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
	    &procPtr) != TCL_OK) {
	Tcl_AddErrorInfo(interp, "\n    (creating proc \"");
	Tcl_AddErrorInfo(interp, procName);
	Tcl_AddErrorInfo(interp, "\")");
	return TCL_ERROR;
    }

    /*
     * Now create a command for the procedure. This will initially be in the
     * current namespace unless the procedure's name included namespace
     * qualifiers. To create the new command in the right namespace, we

	    Tcl_AppendResult(interp,
		    "too many fields in argument specifier \"",
		    argArray[i], "\"", NULL);
	    goto procError;
	}
	if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
	    ckfree((char *) fieldValues);
	    Tcl_AppendResult(interp, "procedure \"", procName,
	    Tcl_AppendResult(interp, "argument with no name", NULL);
		    "\" has argument with no name", NULL);
	    goto procError;
	}

	nameLength = strlen(fieldValues[0]);
	if (fieldCount == 2) {
	    valueLength = strlen(fieldValues[1]);
	} else {

	    if (*p == '(') {
		CONST char *q = p;
		do {
		    q++;
		} while (*q != '\0');
		q--;
		if (*q == ')') { /* we have an array element */
		    Tcl_AppendResult(interp, "procedure \"", procName,
			    "\" has formal parameter \"", fieldValues[0],
			    "\" that is an array element", NULL);
		    Tcl_AppendResult(interp, "formal parameter \"",
			    fieldValues[0],
			    "\" is an array element", NULL);
		    ckfree((char *) fieldValues);
		    goto procError;
		}
	    } else if ((*p == ':') && (*(p+1) == ':')) {
		Tcl_AppendResult(interp, "procedure \"", procName,
			"\" has formal parameter \"", fieldValues[0],
			"\" that is not a simple name", NULL);
		Tcl_AppendResult(interp, "formal parameter \"",
			fieldValues[0],
			"\" is not a simple name", NULL);
		ckfree((char *) fieldValues);
		goto procError;
	    }
	    p++;
	}

	if (precompiled) {

				 * 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,
				 * ie, words in the "command name" */ 
{
    register Proc *procPtr = (Proc *) clientData;
    Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
    CallFrame *framePtr, **framePtrPtr;
    register Var *varPtr;
    register CompiledLocal *localPtr;
    char *procName;
    int nameLen, localCt, numArgs, argCt, i, imax, result;
    Var *compiledLocals;
    Tcl_Obj *CONST *argObjs;

    /*
     * Get the procedure's name.
     */

    procName = Tcl_GetStringFromObj(objv[0], &nameLen);

     * 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 = objc-1; /* set it to the number of args to the proc */
    argCt = objc-skip; /* set it to the number of args to the proc */
    argObjs = &objv[skip];
    varPtr = framePtr->compiledLocals;
    localPtr = procPtr->firstLocalPtr;
    if (numArgs == 0) {
	if (argCt) {
	    goto incorrectArgs;
	} else {
	    goto runProc;
	}
    }
    imax = ((argCt < numArgs - 1)? argCt : (numArgs - 1));
    for (i = 1; i <= imax; i++) {
    for (i = 0; i < imax; i++) {
	/*
	 * "Normal" arguments; last formal is special, depends on it being
	 * 'args'.
	 */

	Tcl_Obj *objPtr = objv[i];
	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; i++) {
    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;

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

    if (localPtr->flags & VAR_IS_ARGS) {
	Tcl_Obj *listPtr = Tcl_NewListObj(objc-numArgs, &(objv[numArgs]));
	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 = objv[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 {

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

#ifdef AVOID_HACKS_FOR_ITCL
	desiredObjs[0] = objv[0];
#else
	desiredObjs[0] = Tcl_NewListObj(1, objv);
	desiredObjs[0] = Tcl_NewListObj(skip, 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);

	    TclEmitOpcode(INST_POP, envPtr);
	}
    }
    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    return TCL_OK;
}

/*
 * LAMBDA and APPLY implementation
 *
 */

static void		DupLambdaInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    Tcl_Obj *copyPtr));
static void		FreeLambdaInternalRep _ANSI_ARGS_((
    			    Tcl_Obj *objPtr));
static int		SetLambdaFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));

Tcl_ObjType lambdaType = {
    "lambda",				/* name */
    FreeLambdaInternalRep,	        /* freeIntRepProc */
    DupLambdaInternalRep,	        /* dupIntRepProc */
    (Tcl_UpdateStringProc *) NULL,	/* updateStringProc */
    SetLambdaFromAny			/* setFromAnyProc */
};

/*
 * a Lambda Tcl_Obj has the form
 *
 *  ptr1 is a *Proc:     pointer to a proc structure
 *  ptr2 is a *Tcl_Obj:  the lambda's namespace
 */

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

    copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr;
    copyPtr->internalRep.twoPtrValue.ptr2 = (VOID *) nsObjPtr;

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

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

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


static int
SetLambdaFromAny(interp, objPtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object to convert. */
{
    char *name;
    Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr;
    int objc;
    Proc *procPtr;
    int result;

    /*
     * Convert objPtr to list type first; if it cannot be
     * converted, or if its length is not 2, then it cannot
     * be converted to lambdaType.
     */

    result = Tcl_ListObjGetElements(interp, objPtr, &objc, &objv);
    if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
	errPtr = Tcl_NewStringObj("can't interpret \"",-1);
	Tcl_IncrRefCount(errPtr);
	Tcl_AppendObjToObj(errPtr, objPtr);
	Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1);
	Tcl_SetObjResult(interp, errPtr);
	Tcl_DecrRefCount(errPtr);
	return TCL_ERROR;
    }

    argsPtr = objv[0];
    bodyPtr = objv[1];

    /*
     * Create and initialize the Proc struct. The cmdPtr field is
     * set to NULL to signal that this is an anonymous function.
     */

    name = TclGetString(objPtr);
    
    if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, name, argsPtr,
		bodyPtr, &procPtr) != TCL_OK) {
	Tcl_AddErrorInfo(interp, "\n    (parsing lambda expression \"");
	Tcl_AddErrorInfo(interp, name);
	Tcl_AddErrorInfo(interp, "\")");
        return TCL_ERROR;
    }
    procPtr->refCount++;
    procPtr->cmdPtr = (Command *) NULL;

    /*
     * Set the namespace for this lambda: given by objv[2] understood
     * as a global reference, or else global per default.
     */
    
    nsObjPtr = Tcl_NewStringObj("::", 2);
    Tcl_IncrRefCount(nsObjPtr);    

    if (objc == 3) {
	Tcl_AppendObjToObj(nsObjPtr, objv[2]);
    }
	    	
    
    /*
     * 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 = (VOID *) procPtr;
    objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) nsObjPtr;
    objPtr->typePtr = &lambdaType;
    return TCL_OK;
}

int
Tcl_ApplyObjCmd(dummy, interp, objc, objv)
    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;

#define JOE_EXTENSION 0
#if JOE_EXTENSION
    Tcl_Obj *elemPtr;
    int numElem;
#endif
    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 = (Proc *) lambdaPtr->internalRep.twoPtrValue.ptr1;

#if JOE_EXTENSION
/*
 * Joe English's suggestion to allow cmdNames to function as lambdas. Requires
 * also making tclCmdNameType non-static in tclObj.c
 *
 */ 
    } else if ((lambdaPtr->typePtr == &tclCmdNameType)
	    || (TCL_OK == (Tcl_ListObjGetElements(interp, lambdaPtr, &numElem, &elemPtr))
		    && (numElem == 1))) {
	return Tcl_EvalObjv(interp, objc-1, objv+1, 0);
#endif
    }

    if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) {
	result = SetLambdaFromAny(interp, lambdaPtr);
	if (result != TCL_OK) {
	    return result;
	}
	procPtr = (Proc *) 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 = (Tcl_Obj *) lambdaPtr->internalRep.twoPtrValue.ptr2;
    result  = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
    if (result != TCL_OK) {
	return result;
    }
    if (nsPtr == (Tcl_Namespace *) NULL) {
	errPtr = Tcl_NewStringObj("cannot find namespace \"",-1);
	Tcl_IncrRefCount(errPtr);
	Tcl_AppendObjToObj(errPtr, nsObjPtr);
	Tcl_AppendToObj(errPtr, "\"", -1);
	Tcl_SetObjResult(interp, errPtr);
	Tcl_DecrRefCount(errPtr);
	return TCL_ERROR;
    }

    /*
      cmd = *((Command *) Tcl_GetCommandFromObj(interp, objv[0]));
    */
    cmd.nsPtr = (Namespace *) nsPtr;

    return ObjInterpProcEx((ClientData) procPtr, interp, objc, objv, 2);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */