/* Agent Tcl
 * Bob Gray
 * 25 January 1995
 * 
 * *** ADAPTED FROM THE STANDARD TCL DISTRIBUTION ***
 *
 * tclStackProcCmd.c --
 *
 *	All of the procedure-related command routines -- e.g. InterpProc -- 
 *	that must examine or modify the execution stack have been moved into
 *	this file.
 *
 * Copyright (c) 1995, Robert S. Gray, Dartmouth College
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 *
 * See the file "agent.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"

/*
 *----------------------------------------------------------------------
 *
 * InterpProc --
 *
 *	When a Tcl procedure gets invoked, this routine gets invoked
 *	to interpret the procedure.
 *
 * Results:
 *	A standard Tcl result value, usually TCL_OK.
 *
 * Side effects:
 *	Depends on the commands in the procedure.
 *
 *----------------------------------------------------------------------
 */

#define CMD_ProcBody 1

static int TclProcBody _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv));

static void FinishProc (iPtr, frame)
     Interp *iPtr;
     CallFrame *frame;
{
  iPtr->framePtr    = frame -> callerPtr;
  iPtr->varFramePtr = frame -> callerVarPtr;

  /*
   * The check below is a hack.  The problem is that there could be
   * unset traces on the variables, which cause scripts to be evaluated.
   * This will clear the ERR_IN_PROGRESS flag, losing stack trace
   * information if the procedure was exiting with an error.  The
   * code below preserves the flag.  Unfortunately, that isn't
   * really enough:  we really should preserve the errorInfo variable
   * too (otherwise a nested error in the trace script will trash
   * errorInfo).  What's really needed is a general-purpose
   * mechanism for saving and restoring interpreter state.
   */

  if (iPtr->flags & ERR_IN_PROGRESS) 
  {
    TclDeleteVars(iPtr, &frame -> varTable);
    iPtr->flags |= ERR_IN_PROGRESS;
  } 
  else 
  {
    TclDeleteVars(iPtr, &frame -> varTable);
  }

  ckfree ((char *) frame); 
}

static int TclProcBody (clientData, interp, argc, argv)
     ClientData clientData;
     Tcl_Interp *interp;
     int argc;
     char **argv;
{
  Interp *iPtr           = (Interp *) interp;
  int result             = iPtr -> resultCode;
  Stack *stack           = &iPtr -> execution_stack;
  Stack_Element *element = stack -> slots[stack -> top];
  Proc *procPtr          = (Proc *) clientData;
  CallFrame *frame       = iPtr -> framePtr;
 
  procPtr->refCount--;

  if (procPtr->refCount <= 0) 
    CleanupProc(procPtr);

  if (result == TCL_RETURN) 
  {
    result = TclUpdateReturnInfo (iPtr);
  } 
  else if (result == TCL_ERROR) 
  {
    char msg[100];
    sprintf(msg, "\n    (procedure \"%.50s\" line %d)", argv[0], iPtr->errorLine);
    Tcl_AddErrorInfo(interp, msg);
  } 
  else if (result == TCL_BREAK) 
  {
    iPtr->result = "invoked \"break\" outside of a loop";
    result = TCL_ERROR;
  }  
  else if (result == TCL_CONTINUE) 
  {
    iPtr->result = "invoked \"continue\" outside of a loop";
    result = TCL_ERROR;
  }

      /* delete the procedure data structures */

  FinishProc (iPtr, frame);
  element -> flag = CMD_REST_OF_SCRIPT;
  return result;  
}
      
int InterpProc(clientData, interp, argc, argv)
     ClientData clientData;
     Tcl_Interp *interp;
     int argc;
     char **argv;
{
  Interp *iPtr           = (Interp *) interp;
  Stack *stack           = &iPtr -> execution_stack;
  Stack_Element *element = stack -> slots[stack -> top];

  if (element -> flag == CMD_ProcBody) {
    return TclProcBody (clientData, interp, argc, argv);
  } else {
    register Proc *procPtr = (Proc *) clientData;
    register Interp *iPtr = (Interp *) interp;
    register Arg *argPtr;
    char **args;
    CallFrame *frame;
    char *value;

    /*
     * Set up a call frame for the new procedure invocation.
     */

    frame = (CallFrame *) ckalloc ((unsigned) sizeof(CallFrame));
    Tcl_InitHashTable(&frame -> varTable, TCL_STRING_KEYS);

    if (iPtr -> framePtr == NULL) {
      frame -> level = 1;
    } else {
      frame -> level = iPtr -> framePtr -> level + 1;
    }

    if (iPtr -> varFramePtr == NULL) {
      frame -> varLevel = 1;
    } else {
      frame -> varLevel = iPtr -> varFramePtr -> varLevel + 1;
    }

    frame -> stackIndex   = stack -> top; 
    frame -> callerPtr    = iPtr -> framePtr;
    frame -> callerVarPtr = iPtr -> varFramePtr;
    iPtr  -> framePtr     = frame;
    iPtr  -> varFramePtr  = frame;
    iPtr  -> returnCode   = TCL_OK;

    /*
     * Match the actual arguments against the procedure's formal
     * parameters to compute local variables.
     */

    for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1;
	 argPtr != NULL;
	 argPtr = argPtr->nextPtr, args++, argc--) 
    {
	/*
	 * Handle the special case of the last formal being "args".  When
	 * it occurs, assign it a list consisting of all the remaining
	 * actual arguments.
	 */

	if ((argPtr->nextPtr == NULL)
		&& (strcmp(argPtr->name, "args") == 0)) {
	    if (argc < 0) {
		argc = 0;
	    }
	    value = Tcl_Merge(argc, args);
	    Tcl_SetVar(interp, argPtr->name, value, 0);
	    ckfree(value);
	    argc = 0;
	    break;
	} else if (argc > 0) {
	    value = *args;
	} else if (argPtr->defValue != NULL) {
	    value = argPtr->defValue;
	} else {
	    Tcl_AppendResult(interp, "no value given for parameter \"",
		    argPtr->name, "\" to \"", argv[0], "\"",
		    (char *) NULL);
            FinishProc (iPtr, frame);  
            return TCL_ERROR;
	}

	Tcl_SetVar(interp, argPtr->name, value, 0);
    }

    if (argc > 0) 
    {
      Tcl_AppendResult(interp, "called \"", argv[0], "\" with too many arguments", (char *) NULL);
      FinishProc (iPtr, frame);
      return TCL_ERROR;	
    }
    else
    {
      procPtr -> refCount++;
      element -> flag        = CMD_ProcBody;
      element -> commandProc = TclProcBody;
      TclPushStack (stack, CMD_REST_OF_SCRIPT, procPtr -> command, TCL_STATIC);
      return TCL_OK;
    }
  }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UplevelCmd --
 *
 *	This procedure is invoked to process the "uplevel" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result value.
 *
 *----------------------------------------------------------------------
 */

#define CMD_UplevelBody 1
   
static int TclUplevelBody (dummy, interp, argc, argv)
     ClientData dummy;
     Tcl_Interp *interp;
     int argc;
     char **argv;
{
  Interp *iPtr           = (Interp *) interp;
  Stack *stack           = &iPtr -> execution_stack;
  Stack_Element *element = stack -> slots[stack -> top];   
  int result             = iPtr -> resultCode;
  CallFrame *frame;

  if (result == TCL_ERROR) 
  {
    char msg[60];
    sprintf(msg, "\n    (\"uplevel\" body line %d)", interp->errorLine);
    Tcl_AddErrorInfo(interp, msg);
  }

  frame               = iPtr -> framePtr;
  iPtr -> framePtr    = frame -> callerPtr;
  iPtr -> varFramePtr = frame -> callerVarPtr;
  element -> flag     = CMD_REST_OF_SCRIPT;
  ckfree ((char *) frame);
  return result;  
}

int Tcl_UplevelCmd (dummy, interp, argc, argv)
     ClientData dummy;
     Tcl_Interp *interp;
     int argc;
     char **argv;
{ 
  Interp *iPtr           = (Interp *) interp;
  Stack *stack           = &iPtr -> execution_stack;
  Stack_Element *element = stack -> slots[stack -> top];   

  if (element -> flag == CMD_UplevelBody)
  {
    return TclUplevelBody (dummy, interp, argc, argv);
  }
  else
  { 
    char *cmd;
    int result; 
    CallFrame *frame;
    CallFrame *executionFrame;
    Tcl_FreeProc *freeProc;

    if (argc < 2) 
    {
      Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ?level? command ?arg ...?\"", (char *) NULL);
      return TCL_ERROR;
    }

    /*
     * Find the level to use for executing the command.
     */

    if ((result = TclGetFrame(interp, argv[1], &executionFrame)) == -1)
      return TCL_ERROR;
  
    argc -= (result+1);

    if (argc == 0) 
    {
      Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ?level? command ?arg ...?\"", (char *) NULL);
      return TCL_ERROR;
    }

    argv += (result+1);

    /*
     * create a frame to save the current frame pointers 
     */

    frame = (CallFrame *) ckalloc ((unsigned) sizeof(CallFrame));
    frame -> varLevel     = -1;
    frame -> callerPtr    = iPtr -> framePtr;
    frame -> callerVarPtr = iPtr -> varFramePtr;
    frame -> stackIndex   = stack -> top;
 
    if (iPtr -> framePtr == NULL) 
      frame -> level = 1;
    else
      frame -> level = iPtr -> framePtr -> level + 1;

    iPtr  -> framePtr     = frame;
    iPtr  -> varFramePtr  = executionFrame;

    /*
     * Execute the residual arguments as a command.
     */

    if (argc == 1)
    {
      cmd      = argv[0];
      freeProc = TCL_STATIC;
    }
    else
    {
      cmd      = Tcl_Concat (argc, argv);
      freeProc = TCL_DYNAMIC;
    } 

    element -> flag        = CMD_UplevelBody;
    element -> commandProc = TclUplevelBody;
    TclPushStack (stack, CMD_REST_OF_SCRIPT, cmd, freeProc);
    return TCL_OK;
  } 
}
