/* 
 * 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.
 *
 * 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.61 2004/10/15 21:02:36 dgp Exp $
 */

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

/*
 * Prototypes for static functions in this file


/*
 *----------------------------------------------------------------------
 *
 * TclUpdateReturnInfo --
 *
 *	This procedure is called when procedures return, and at other
 *	points where the TCL_RETURN code is used.  It examines values
 *	stored in the iPtr->returnOpts dictionary and modifies
 *	the real return status accordingly.
 *
 * Results:
 *	The return value is the true completion code to use for
 *	the procedure, instead of TCL_RETURN.
 *
 * Side effects:
 *	The errorInfo and errorCode fields may get set.
 *
 *----------------------------------------------------------------------
 */

int
TclUpdateReturnInfo(iPtr)
    Interp *iPtr;		/* Interpreter for which TCL_RETURN
				 * exception is being processed. */
{
    int level, code = TCL_RETURN;
    Tcl_Obj *valuePtr;

    Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnLevelKey, &valuePtr);
    Tcl_GetIntFromObj(NULL, valuePtr, &level);
    level--;
    if (level < 0) {
	Tcl_Panic("TclUpdateReturnInfo: negative return level");
    }
    if (Tcl_IsShared(iPtr->returnOpts)) {
	Tcl_DecrRefCount(iPtr->returnOpts);
	iPtr->returnOpts = Tcl_DuplicateObj(iPtr->returnOpts);
	Tcl_IncrRefCount(iPtr->returnOpts);
    }
    Tcl_DictObjPut(NULL, iPtr->returnOpts,
	    iPtr->returnLevelKey, Tcl_NewIntObj(level));

    if (level == 0) {
	/* Now we've reached the level to return the requested -code */
	Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnCodeKey, &valuePtr);
	Tcl_GetIntFromObj(NULL, valuePtr, &code);
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *