* Copyright (c) 1987-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclVar.c,v 1.32 2001/05/17 02:13:03 hobbs Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * The strings below are used to indicate what went wrong when a

 *	allocated local variables.
 *
 * Results:
 *	The return value points to the current object value of the variable
 *	given by localIndex. If the specified variable doesn't exist, or
 *	there is a clash in array usage, or an error occurs while executing
 *	variable traces, then NULL is returned and a message will be left in
 *	the interpreter's result if TCL_LEAVE_ERR_MSG is set in flags.
 *
 * Side effects:
 *	The ref count for the returned object is _not_ incremented to
 *	reflect the returned reference; if you want to keep a reference to
 *	the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclGetIndexedScalar(interp, localIndex, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    register int localIndex;	/* Index of variable in procedure's array
				 * of local variables. */
    int flags;			/* TCL_LEAVE_ERR_MSG if to leave an error
				 * message in interpreter's result on an error.
				 * Otherwise no error message is left. */
{
    Interp *iPtr = (Interp *) interp;
    CallFrame *varFramePtr = iPtr->varFramePtr;
				/* Points to the procedure call frame whose
				 * variables are currently in use. Same as
				 * the current procedure's frame, if any,

     * Invoke any traces that have been set for the variable.
     */

    if (varPtr->tracePtr != NULL) {
	msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL,
		TCL_TRACE_READS);
	if (msg != NULL) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		VarErrMsg(interp, varName, NULL, "read", msg);
	    }
	    return NULL;
	}
    }

    /*
     * Make sure we're dealing with a scalar variable and not an array, and
     * that the variable exists (isn't undefined).
     */

    if (!TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    if (TclIsVarArray(varPtr)) {
		msg = isArray;
	    } else {
		msg = noSuchVar;
	    }
	    VarErrMsg(interp, varName, NULL, "read", msg);

 *	of compiler allocated local variables.
 *
 * Results:
 *	The return value points to the current object value of the
 *	element. If the specified array or element doesn't exist, or there
 *	is a clash in array usage, or an error occurs while executing
 *	variable traces, then NULL is returned and a message will be left in
 *	the interpreter's result if TCL_LEAVE_ERR_MSG is set in flags.
 *
 * Side effects:
 *	The ref count for the returned object is _not_ incremented to
 *	reflect the returned reference; if you want to keep a reference to
 *	the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclGetElementOfIndexedArray(interp, localIndex, elemPtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    int localIndex;		/* Index of array variable in procedure's
				 * array of local variables. */
    Tcl_Obj *elemPtr;		/* Points to an object holding the name of
				 * an element to get in the array. */
    int flags;			/* TCL_LEAVE_ERR_MSG if to leave an error
				 * message in interpreter's result on an error.
				 * Otherwise no error message is left. */
{
    Interp *iPtr = (Interp *) interp;
    CallFrame *varFramePtr = iPtr->varFramePtr;
				/* Points to the procedure call frame whose
				 * variables are currently in use. Same as
				 * the current procedure's frame, if any,

    /*
     * Make sure we're dealing with an array and that the array variable
     * exists (isn't undefined).
     */

    if (!TclIsVarArray(arrayPtr) || TclIsVarUndefined(arrayPtr)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    VarErrMsg(interp, arrayName, elem, "read", noSuchVar);
	}
	goto errorReturn;
    } 

    /*
     * Look up the element. Note that we must create the element (but leave

     */

    if ((varPtr->tracePtr != NULL)
            || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem,
	        TCL_TRACE_READS);
	if (msg != NULL) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		VarErrMsg(interp, arrayName, elem, "read", msg);
	    }
	    goto errorReturn;
	}
    }

    /*
     * Return the element if it's an existing scalar variable.
     */
    
    if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
	return varPtr->value.objPtr;
    }
    
    if (flags & TCL_LEAVE_ERR_MSG) {
	if (TclIsVarArray(varPtr)) {
	    msg = isArray;
	} else {
	    msg = noSuchVar;
	}
	VarErrMsg(interp, arrayName, elem, "read", msg);
    }

				 * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
{
    Interp *iPtr = (Interp *) interp;
    register Var *varPtr;
    Var *arrayPtr;
    Tcl_Obj *oldValuePtr;
    Tcl_Obj *resultPtr = NULL;

    int result;

    varPtr = TclLookupVar(interp, part1, part2, flags, "set",
	    /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return NULL;
    }

		return NULL;
	    }
	} else {		               /* append string */
	    /*
	     * We append newValuePtr's bytes but don't change its ref count.
	     */


	    if (oldValuePtr == NULL) {
		varPtr->value.objPtr = newValuePtr;
		Tcl_IncrRefCount(newValuePtr);
	    } else {
		if (Tcl_IsShared(oldValuePtr)) {   /* append to copy */
		    varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
		    TclDecrRefCount(oldValuePtr);
		    oldValuePtr = varPtr->value.objPtr;
		    Tcl_IncrRefCount(oldValuePtr); /* since var is ref */
		}
		Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
	    }
	}
    } else if (newValuePtr != oldValuePtr) {



	/*
	 * In this case we are replacing the value, so we don't need to


	 * do more than swap the objects.
	 */














	varPtr->value.objPtr = newValuePtr;
	Tcl_IncrRefCount(newValuePtr);      /* var is another ref */
	if (oldValuePtr != NULL) {
	    TclDecrRefCount(oldValuePtr);   /* discard old value */

	}
    }
    TclSetVarScalar(varPtr);
    TclClearVarUndefined(varPtr);
    if (arrayPtr != NULL) {
	TclClearVarUndefined(arrayPtr);
    }

 *	array of local variables.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable given by localIndex. If the specified variable doesn't
 *	exist, or there is a clash in array usage, or an error occurs while
 *	executing variable traces, then NULL is returned and a message will
 *	be left in the interpreter's result if flags has TCL_LEAVE_ERR_MSG.
 *	Note that the returned object may not be the same one referenced by
 *	newValuePtr; this is because variable traces may modify the
 *	variable's value.
 *
 * Side effects:
 *	The value of the given variable is set. The reference count is
 *	decremented for any old value of the variable and incremented for
 *	its new value. If as a result of a variable trace the new value for
 *	the variable is not the same one referenced by newValuePtr, then
 *	newValuePtr's ref count is left unchanged. The ref count for the
 *	returned object is _not_ incremented to reflect the returned
 *	reference; if you want to keep a reference to the object you must
 *	increment its ref count yourself. This procedure does not create
 *	new variables, but only sets those recognized at compile time.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclSetIndexedScalar(interp, localIndex, newValuePtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be found. */
    int localIndex;		/* Index of variable in procedure's array
				 * of local variables. */
    Tcl_Obj *newValuePtr;	/* New value for variable. */
    int flags;			/* Various flags that tell how to set value:
				 * any of TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
{
    Interp *iPtr = (Interp *) interp;
    CallFrame *varFramePtr = iPtr->varFramePtr;
				/* Points to the procedure call frame whose
				 * variables are currently in use. Same as
				 * the current procedure's frame, if any,
				 * unless an "uplevel" is executing. */

     * may have an upvar to an array element where the array was deleted
     * or an upvar to a namespace variable whose namespace was deleted.
     * Generate an error (allowing the variable to be reset would screw up
     * our storage allocation and is meaningless anyway).
     */

    if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    if (TclIsVarArrayElement(varPtr)) {
		VarErrMsg(interp, varName, NULL, "set", danglingElement);
	    } else {
		VarErrMsg(interp, varName, NULL, "set", danglingVar);
	    }
	}
	return NULL;
    }

    /*
     * It's an error to try to set an array variable itself.
     */

    if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    VarErrMsg(interp, varName, NULL, "set", isArray);
	}
	return NULL;
    }

    /*
     * Set the variable's new value and discard its old value.
     */

    oldValuePtr = varPtr->value.objPtr;
    if (flags & TCL_APPEND_VALUE) {
	if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) {
	    Tcl_DecrRefCount(oldValuePtr);     /* discard old value */
	    varPtr->value.objPtr = NULL;
	    oldValuePtr = NULL;
	}
	if (flags & TCL_LIST_ELEMENT) {	/* append list element */
	    if (oldValuePtr == NULL) {
		TclNewObj(oldValuePtr);
		varPtr->value.objPtr = oldValuePtr;
		Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
	    } else if (Tcl_IsShared(oldValuePtr)) {
		varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
		Tcl_DecrRefCount(oldValuePtr);
		oldValuePtr = varPtr->value.objPtr;
		Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
	    }
	    if (Tcl_ListObjAppendElement(interp, oldValuePtr,
		    newValuePtr) != TCL_OK) {
		return NULL;
	    }
	} else {				/* append string */
	    /*
	     * We append newValuePtr's bytes but don't change its ref count.
	     */

	    if (oldValuePtr == NULL) {
		varPtr->value.objPtr = newValuePtr;
		Tcl_IncrRefCount(newValuePtr);
	    } else {
		if (Tcl_IsShared(oldValuePtr)) {	/* append to copy */
		    varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
		    TclDecrRefCount(oldValuePtr);
		    oldValuePtr = varPtr->value.objPtr;
		    Tcl_IncrRefCount(oldValuePtr);	/* since var is ref */
		}
		Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
	    }
	}
    } else if (newValuePtr != oldValuePtr) {        /* set new value */
	/*
	 * In this case we are replacing the value, so we don't need to
	 * do more than swap the objects.
	 */

	varPtr->value.objPtr = newValuePtr;
	Tcl_IncrRefCount(newValuePtr);       /* var is another ref to obj */
	if (oldValuePtr != NULL) {
	    TclDecrRefCount(oldValuePtr);    /* discard old value */
	}
    }
    TclSetVarScalar(varPtr);
    TclClearVarUndefined(varPtr);

    /*
     * Invoke any write traces for the variable.
     */

    if (varPtr->tracePtr != NULL) {
	char *msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr,
	        varName, (char *) NULL, TCL_TRACE_WRITES);
	if (msg != NULL) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		VarErrMsg(interp, varName, NULL, "set", msg);
	    }
	    goto cleanup;
	}
    }

    /*

 *	compiler allocated local variables.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	element. If the specified array or element doesn't exist, or there
 *	is a clash in array usage, or an error occurs while executing
 *	variable traces, then NULL is returned and a message will be left in
 *	the interpreter's result if flags has TCL_LEAVE_ERR_MSG. Note that the
 *	returned object may not be the same one referenced by newValuePtr;
 *	this is because variable traces may modify the variable's value.
 *
 * Side effects:
 *	The value of the given array element is set. The reference count is
 *	decremented for any old value of the element and incremented for its
 *	new value. If as a result of a variable trace the new value for the
 *	element is not the same one referenced by newValuePtr, then
 *	newValuePtr's ref count is left unchanged. The ref count for the
 *	returned object is _not_ incremented to reflect the returned
 *	reference; if you want to keep a reference to the object you must
 *	increment its ref count yourself. This procedure will not create new
 *	array variables, but only sets elements of those arrays recognized
 *	at compile time. However, if the entry doesn't exist then a new
 *	variable is created.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, flags)

    Tcl_Interp *interp;		/* Command interpreter in which the array is
				 * to be found. */
    int localIndex;		/* Index of array variable in procedure's
				 * array of local variables. */
    Tcl_Obj *elemPtr;		/* Points to an object holding the name of
				 * an element to set in the array. */
    Tcl_Obj *newValuePtr;	/* New value for variable. */
    int flags;			/* Various flags that tell how to set value:
				 * any of TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
{
    Interp *iPtr = (Interp *) interp;
    CallFrame *varFramePtr = iPtr->varFramePtr;
				/* Points to the procedure call frame whose
				 * variables are currently in use. Same as
				 * the current procedure's frame, if any,
				 * unless an "uplevel" is executing. */

    if (compiledLocals == NULL) {
	fprintf(stderr, "\nTclSetElementOfIndexedArray: can't set element of local %i in frame 0x%x, no compiled locals\n",
		localIndex, (unsigned int) varFramePtr);
	panic("TclSetIndexedScalar: no compiled locals in frame 0x%x",
		(unsigned int) varFramePtr);
    }
    if ((localIndex < 0) || (localIndex >= localCt)) {
	fprintf(stderr, "\nTclSetIndexedScalar: can't set element of local %i in frame 0x%x with %i locals\n",
		localIndex, (unsigned int) varFramePtr, localCt);
	panic("TclSetElementOfIndexedArray: bad local index %i in frame 0x%x",
		localIndex, (unsigned int) varFramePtr);
    }
#endif /* TCL_COMPILE_DEBUG */

    elem = TclGetString(elemPtr);
    arrayPtr = &(compiledLocals[localIndex]);
    arrayName = arrayPtr->name;

    /*
     * If arrayPtr is a link variable, we have a reference to some variable
     * that was created through an "upvar" or "global" command, or we have a
     * reference to a variable in an enclosing namespace. Traverse through
     * any links until we find the referenced variable.
     */

    while (TclIsVarLink(arrayPtr)) {
	arrayPtr = arrayPtr->value.linkPtr;
    }

    /*
     * If the variable is in a hashtable and its hPtr field is NULL, then we
     * may have an upvar to an array element where the array was deleted
     * or an upvar to a namespace variable whose namespace was deleted.
     * Generate an error (allowing the variable to be reset would screw up
     * our storage allocation and is meaningless anyway).
     */

    if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    if (TclIsVarArrayElement(arrayPtr)) {
		VarErrMsg(interp, arrayName, elem, "set", danglingElement);
	    } else {
		VarErrMsg(interp, arrayName, elem, "set", danglingVar);
	    }
	}
	goto errorReturn;
    }

    /*
     * Make sure we're dealing with an array.
     */

    if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) {
	TclSetVarArray(arrayPtr);
	arrayPtr->value.tablePtr =
	    (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS);
	TclClearVarUndefined(arrayPtr);
    } else if (!TclIsVarArray(arrayPtr)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    VarErrMsg(interp, arrayName, elem, "set", needArray);
	}
	goto errorReturn;
    }

    /*
     * Look up the element.
     */

    hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new);
    if (new) {

    varPtr = (Var *) Tcl_GetHashValue(hPtr);

    /*
     * It's an error to try to set an array variable itself.
     */

    if (TclIsVarArray(varPtr)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    VarErrMsg(interp, arrayName, elem, "set", isArray);
	}
	goto errorReturn;
    }

    /*
     * Set the variable's new value and discard the old one.
     */

    oldValuePtr = varPtr->value.objPtr;
    if (flags & TCL_APPEND_VALUE) {
	if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) {
	    Tcl_DecrRefCount(oldValuePtr);     /* discard old value */
	    varPtr->value.objPtr = NULL;
	    oldValuePtr = NULL;
	}
	if (flags & TCL_LIST_ELEMENT) {	/* append list element */
	    if (oldValuePtr == NULL) {
		TclNewObj(oldValuePtr);
		varPtr->value.objPtr = oldValuePtr;
		Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
	    } else if (Tcl_IsShared(oldValuePtr)) {
		varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
		Tcl_DecrRefCount(oldValuePtr);
		oldValuePtr = varPtr->value.objPtr;
		Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
	    }
	    if (Tcl_ListObjAppendElement(interp, oldValuePtr,
		    newValuePtr) != TCL_OK) {
		return NULL;
	    }
	} else {				/* append string */
	    /*
	     * We append newValuePtr's bytes but don't change its ref count.
	     */

	    if (oldValuePtr == NULL) {
		varPtr->value.objPtr = newValuePtr;
		Tcl_IncrRefCount(newValuePtr);
	    } else {
		if (Tcl_IsShared(oldValuePtr)) {	/* append to copy */
		    varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
		    TclDecrRefCount(oldValuePtr);
		    oldValuePtr = varPtr->value.objPtr;
		    Tcl_IncrRefCount(oldValuePtr);	/* since var is ref */
		}
		Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
	    }
	}
    } else if (newValuePtr != oldValuePtr) {	/* set new value */
	/*
	 * In this case we are replacing the value, so we don't need to
	 * do more than swap the objects.
	 */

	varPtr->value.objPtr = newValuePtr;
	Tcl_IncrRefCount(newValuePtr);		/* var is another ref to obj */
	if (oldValuePtr != NULL) {
	    TclDecrRefCount(oldValuePtr);	/* discard old value */
	}
    }
    TclSetVarScalar(varPtr);
    TclClearVarUndefined(varPtr);

    /*
     * Invoke any write traces for the element variable.
     */

    if ((varPtr->tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	char *msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem,
		TCL_TRACE_WRITES);
	if (msg != NULL) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		VarErrMsg(interp, arrayName, elem, "set", msg);
	    }
	    goto errorReturn;
	}
    }

    /*

    Tcl_Obj *resultPtr;
    int createdNewObj;		/* Set 1 if var's value object is shared
				 * so we must increment a copy (i.e. copy
				 * on write). */
    long i;
    int result;

    varValuePtr = TclGetIndexedScalar(interp, localIndex, TCL_LEAVE_ERR_MSG);

    if (varValuePtr == NULL) {
	Tcl_AddObjErrorInfo(interp,
		"\n    (reading value of variable to increment)", -1);
	return NULL;
    }

    /*

    Tcl_SetLongObj(varValuePtr, (i + incrAmount));

    /*
     * Store the variable's new value and run any write traces.
     */
    
    resultPtr = TclSetIndexedScalar(interp, localIndex, varValuePtr,
	    TCL_LEAVE_ERR_MSG);
    if (resultPtr == NULL) {
	return NULL;
    }
    return resultPtr;
}

/*

    int createdNewObj;		/* Set 1 if var's value object is shared
				 * so we must increment a copy (i.e. copy
				 * on write). */
    long i;
    int result;

    varValuePtr = TclGetElementOfIndexedArray(interp, localIndex, elemPtr,
	    TCL_LEAVE_ERR_MSG);
    if (varValuePtr == NULL) {
	Tcl_AddObjErrorInfo(interp,
		"\n    (reading value of variable to increment)", -1);
	return NULL;
    }

    /*

    Tcl_SetLongObj(varValuePtr, (i + incrAmount));
    
    /*
     * Store the variable's new value and run any write traces.
     */
    
    resultPtr = TclSetElementOfIndexedArray(interp, localIndex, elemPtr,
	    varValuePtr, TCL_LEAVE_ERR_MSG);

    if (resultPtr == NULL) {
	return NULL;
    }
    return resultPtr;
}

/*