/* Agent Tcl
 * Bob Gray
 * 25 January 1995
 * 
 * *** ADAPTED FROM THE THE STANDARD TCL DISTRIBUTION ***
 *
 * tclStackCmd.c --
 *
 *      All of the command routines -- e.g. Tcl_WhileCmd -- that
 *      must examine or change 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"

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

#define CMD_CaseBody	1

static int TclCaseBody (dummy, interp, argc, argv)
     ClientData dummy;
     Tcl_Interp *interp;
     int argc;
     char **argv;
{
    /* get the element on the top of the stack */

  Interp *iPtr           = (Interp *) interp;
  Stack  *stack          = &iPtr -> execution_stack;
  Stack_Element *element = stack -> slots[stack -> top];
 
    /* handle errors */

  if (iPtr -> resultCode == TCL_ERROR) {
    char msg[100];
    char *arm = get_state_variable (interp, "case_arm");
    sprintf (msg, "\n    (\"%.50s\" arm line %d)", arm, interp -> errorLine);
    Tcl_AddErrorInfo (interp, msg);
  }

    /* move on the rest of the script */

  element -> flag = CMD_REST_OF_SCRIPT;
  return (iPtr -> resultCode);
}

int Tcl_CaseCmd (dummy, interp, argc, argv)
     ClientData dummy;
     Tcl_Interp *interp;
     int argc;
     char **argv;
{
    int i, result;
    int body;
    char *string;
    int caseArgc, splitArgs;
    char **caseArgv;

      /* get the element on the top of the stack */

    Interp *iPtr           = (Interp *) interp;
    Stack  *stack          = &iPtr -> execution_stack;
    Stack_Element *element = stack -> slots[stack -> top];

      /* have we just executed an arm of the "case" command? */

    if (element -> flag == CMD_CaseBody)
      return TclCaseBody (dummy, interp, argc, argv);

      /* or are we just starting the "case" command? */
 
    if (argc < 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		argv[0], " string ?in? patList body ... ?default body?\"",
		(char *) NULL);
	return TCL_ERROR;
    }
    string = argv[1];
    body = -1;
    if (strcmp(argv[2], "in") == 0) {
	i = 3;
    } else {
	i = 2;
    }
    caseArgc = argc - i;
    caseArgv = argv + i;

    /*
     * If all of the pattern/command pairs are lumped into a single
     * argument, split them out again.
     */

    splitArgs = 0;
    if (caseArgc == 1) {
	result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv);
	if (result != TCL_OK) {
	    return result;
	}
	splitArgs = 1;
    }

    for (i = 0; i < caseArgc; i += 2) {
	int patArgc, j;
	char **patArgv;
	register char *p;

	if (i == (caseArgc-1)) {
	    interp->result = "extra case pattern with no body";
	    result = TCL_ERROR;
	    goto cleanup;
	}

	/*
	 * Check for special case of single pattern (no list) with
	 * no backslash sequences.
	 */

	for (p = caseArgv[i]; *p != 0; p++) {
	    if (isspace(UCHAR(*p)) || (*p == '\\')) {
		break;
	    }
	}
	if (*p == 0) {
	    if ((*caseArgv[i] == 'd')
		    && (strcmp(caseArgv[i], "default") == 0)) {
		body = i+1;
	    }
	    if (Tcl_StringMatch(string, caseArgv[i])) {
		body = i+1;
		goto match;
	    }
	    continue;
	}

	/*
	 * Break up pattern lists, then check each of the patterns
	 * in the list.
	 */

	result = Tcl_SplitList(interp, caseArgv[i], &patArgc, &patArgv);
	if (result != TCL_OK) {
	    goto cleanup;
	}
	for (j = 0; j < patArgc; j++) {
	    if (Tcl_StringMatch(string, patArgv[j])) {
		body = i+1;
		break;
	    }
	}
	ckfree((char *) patArgv);
	if (j < patArgc) {
	    break;
	}
    }

    match:
    if (body != -1) {
        char arm[100];
        sprintf (arm, "%.50s", caseArgv[body - 1]);
        set_state_variable (interp, "case_arm", arm);

        element -> flag        = CMD_CaseBody;
        element -> commandProc = TclCaseBody;
        TclPushStack (stack, CMD_REST_OF_SCRIPT, caseArgv[body], TCL_VOLATILE);

        result = TCL_OK;
	goto cleanup;
    }

    /*
     * Nothing matched:  return nothing.
     */

    result = TCL_OK;

    cleanup:
    if (splitArgs) {
	ckfree((char *) caseArgv);
    }
    return result;
}
/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalCmd --
 *
 *	This procedure is invoked to process the "eval" Tcl command.
 *      See the user documentation for details on what the "eval" command
 *      does.
 *
 * Results:
 *	A standard Tcl result.
 *
 *----------------------------------------------------------------------
 */

#define CMD_EvalResult 1

static int TclEvalResult (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 (iPtr -> resultCode == TCL_ERROR)
  {
    char msg[60];
    sprintf (msg, "\n    (\"eval\" body line %d)", interp -> errorLine);
    Tcl_AddErrorInfo (interp, msg);
  }

  element -> flag = CMD_REST_OF_SCRIPT;
  return (iPtr -> resultCode);
}

int Tcl_EvalCmd (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_EvalResult)
  {
    return TclEvalResult (dummy, interp, argc, argv);
  }
  else 
  {
    char *cmd;
    Tcl_FreeProc *freeProc;

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

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

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

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CatchCmd --
 *
 *	This procedure is invoked to process the "catch" Tcl command.
 *      The procedure calls procedure Tcl_CatchResult
 *      to handle the result of the body.  See the user documentation for
 *      details on what "catch" does. 
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation. 
 *
 *----------------------------------------------------------------------
 */

#define CMD_CatchResult 1

static int TclCatchResult (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             = interp -> resultCode;

    /* move on to the rest of the script */
 
  element -> flag = CMD_REST_OF_SCRIPT;

    /* TCL_PERMIT can not be caught */

  if (result == TCL_PERMIT)  {
    return (result);
  }

    /* everything else can be caught */

  if (argc == 3) {
    if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) {
      Tcl_SetResult(interp, "couldn't save command result in variable", TCL_STATIC);
      return TCL_ERROR;
    }
  }

  Tcl_ResetResult(interp);
  sprintf(interp -> result, "%d", result);
  return TCL_OK;
}

int Tcl_CatchCmd (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_CatchResult) {
    return TclCatchResult (dummy, interp, argc, argv);
  } else {
    if ((argc != 2) && (argc != 3)) {
      Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " command ?varName?\"", (char *) NULL);
      return TCL_ERROR;
    }

    element -> flag        = CMD_CatchResult;
    element -> commandProc = TclCatchResult;
    TclPushStack (stack, CMD_REST_OF_SCRIPT, argv[1], TCL_STATIC);
    return TCL_OK;
  }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WhileCmd --
 *
 *	This procedure is invoked to process the "while" Tcl command.
 *      Procedure TclWhileTest evaluates the control expression.
 *      Procedure TclWhileBody evaluates the body.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 *----------------------------------------------------------------------
 */

#define CMD_WhileBody 1

static int TclWhileBody _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv));

static int TclWhileExpression (interp, stack, element, expression, body)
     Tcl_Interp *interp;
     Stack *stack;
     Stack_Element *element;
     char *expression;
     char *body;
{
  int result;   /* error code from boolean expression evaluation */
  int value;    /* value of boolean expression                   */

  result = Tcl_ExprBoolean(interp, expression, &value);

  if (result != TCL_OK)
  {
    element -> flag = CMD_REST_OF_SCRIPT;
    return result;
  }

  if (!value)
  {
    element -> flag = CMD_REST_OF_SCRIPT;
    Tcl_ResetResult (interp);
    return TCL_OK;
  }
  else
  {
    element -> flag        = CMD_WhileBody;
    element -> commandProc = TclWhileBody;
    TclPushStack (stack, CMD_REST_OF_SCRIPT, body, TCL_STATIC);
    return TCL_OK;
  }
}   

static int TclWhileBody (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;
   
  if ((result != TCL_OK) && (result != TCL_CONTINUE))
  {
     if (result == TCL_ERROR) 
     {
       char msg[60];
       sprintf(msg, "\n    (\"while\" body line %d)", interp->errorLine);
       Tcl_AddErrorInfo(interp, msg);
     }
     else if (result == TCL_BREAK)
     {
       result = TCL_OK;
       Tcl_ResetResult(interp);
     }

     element -> flag = CMD_REST_OF_SCRIPT;
     return result;
  }

  /* evaluate the test expression */

  return TclWhileExpression (interp, stack, element, argv[1], argv[2]);
}

int Tcl_WhileCmd (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_WhileBody)
    {
      return TclWhileBody (dummy, interp, argc, argv);
    }
    else
    {
      if (argc != 3) 
      {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " test command\"", (char *) NULL);
	return TCL_ERROR;
      }

        /* evaluate the test expression */

      return TclWhileExpression (interp, stack, element, argv[1], argv[2]);
   }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ForCmd --
 *
 *	This procedure is invoked to process the "for" Tcl command.
 *      TclForTest evaluates the FOR loop test.  TclForBody executes
 *      the FOR loop body.  TclForReinit executes the FOR loop reinit.
 *      See the user documentation for details on the FOR command.
 *
 * Results:
 *	A standard Tcl result.
 *
 *----------------------------------------------------------------------
 */

#define CMD_ForInit 1 
#define CMD_ForBody 2  
#define CMD_ForReinit 3 

static int TclForInit _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv));
static int TclForBody _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv));
static int TclForReinit _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv));

static int TclForExpression (interp, stack, element, expression, body)
     Tcl_Interp *interp;
     Stack *stack;
     Stack_Element *element;
     char *expression;
     char *body;
{
  int result;  /* error code from boolean expression evaluation */
  int value;   /* value of boolean expression                   */ 

  result = Tcl_ExprBoolean (interp, expression, &value);

  if (result != TCL_OK) {
    element -> flag = CMD_REST_OF_SCRIPT;
    return result;
  }

  if (!value) {
    element -> flag = CMD_REST_OF_SCRIPT;
    Tcl_ResetResult (interp);
    return TCL_OK;
  } else {
    element -> flag        = CMD_ForBody; 
    element -> commandProc = TclForBody;
    TclPushStack (stack, CMD_REST_OF_SCRIPT, body, TCL_STATIC); 
    return TCL_OK;
  }
}
 
static int TclForInit (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;

    /* see if the INIT command succeded */

  if (result != TCL_OK) {
    if (result == TCL_ERROR) {
       Tcl_AddErrorInfo(interp, "\n    (\"for\" initial command)");
    }

    return result;
  }

    /* evaluate the expression */

  return TclForExpression (interp, stack, element, argv[2], argv[4]);
}

static int TclForBody (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;

  if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
     if (result == TCL_ERROR) {
       char msg[60];
       sprintf(msg, "\n    (\"for\" body line %d)", interp->errorLine);
       Tcl_AddErrorInfo(interp, msg);
     } else if (result == TCL_BREAK) {
       result = TCL_OK;
       Tcl_ResetResult(interp);
     }

     element -> flag = CMD_REST_OF_SCRIPT;
     return result;
  }

  element -> flag        = CMD_ForReinit;
  element -> commandProc = TclForReinit;
  TclPushStack (stack, CMD_REST_OF_SCRIPT, argv[3], TCL_STATIC);
  return TCL_OK;
}

static int TclForReinit (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;

  if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
     if (result == TCL_ERROR) {
       char msg[60];
       sprintf(msg, "\n    (\"for\" loop-end command line %d)", interp->errorLine);
       Tcl_AddErrorInfo(interp, msg);
     } else if (result == TCL_BREAK) {
       result = TCL_OK;
       Tcl_ResetResult(interp);
     }

     element -> flag = CMD_REST_OF_SCRIPT;
     return result;
  }

    /* evaluate the test expression */

  return TclForExpression (interp, stack, element, argv[2], argv[4]);
}

int Tcl_ForCmd (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_ForBody)
    return TclForBody (dummy, interp, argc, argv);
  else if (element -> flag == CMD_ForReinit)
    return TclForReinit (dummy, interp, argc, argv);
  else if (element -> flag == CMD_ForInit)
    return TclForInit (dummy, interp, argc, argv);
  else
  {
    if (argc != 5) 
    {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " start test next command\"", (char *) NULL);
	return TCL_ERROR;
    }

    element -> flag        = CMD_ForInit;
    element -> commandProc = TclForInit;
    TclPushStack (stack, CMD_REST_OF_SCRIPT, argv[1], TCL_STATIC);
    return TCL_OK;
  }
}

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

int Tcl_IfCmd (dummy, interp, argc, argv)
     ClientData dummy;
     Tcl_Interp *interp;
     int argc;
     char **argv;
{
  int i = 1;
  int result;      /* error code from boolean expression evaluation */
  int value;       /* value of boolean expression                   */
  Interp *iPtr = (Interp *) interp;
  Stack *stack = &iPtr -> execution_stack;

  while (1) 
  {
    /*
     * At this point in the loop, argv and argc refer to an expression
     * to test, either for the main expression or an expression
     * following an "elseif".  The arguments after the expression must
     * be "then" (optional) and a script to execute if the expression is
     * true.
     */

    if (i >= argc) 
    {
      Tcl_AppendResult(interp, "wrong # args: no expression after \"", argv[i-1], "\" argument", (char *) NULL);
      return TCL_ERROR;
    }

    if ((result = Tcl_ExprBoolean(interp, argv[i], &value)) != TCL_OK)
      return result;

    i++;
    if ((i < argc) && (strcmp(argv[i], "then") == 0)) 
      i++;

    if (i >= argc) 
    {
      Tcl_AppendResult(interp, "wrong # args: no script following \"", argv[i-1], "\" argument", (char *) NULL);
      return TCL_ERROR;
    }

    if (value) 
    {
      TclPushStack (stack, CMD_REST_OF_SCRIPT, argv[i], TCL_STATIC);
      return TCL_OK;
    }

    /*
     * The expression evaluated to false.  Skip the command, then
     * see if there is an "else" or "elseif" clause.
     */

    if (++i >= argc) 
      return TCL_OK;

    if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0))
    {
      i++;
      continue;
    }

    break;
  }

  /*
   * Couldn't find a "then" or "elseif" clause to execute.  Check now
   * for an "else" clause.  We know that there's at least one more
   * argument when we get here.
   */

  if (!strcmp(argv[i], "else"))
  {
    if (++i >= argc) 
    {
      Tcl_AppendResult(interp, "wrong # args: no script following \"else\" argument", (char *) NULL);
      return TCL_ERROR;
    }
  }

  TclPushStack (stack, CMD_REST_OF_SCRIPT, argv[i], TCL_STATIC);
  return TCL_OK;
}

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

#define CMD_SwitchBody	1

#define EXACT		0
#define GLOB		1
#define REGEXP		2

static int TclSwitchBody (dummy, interp, argc, argv)
     ClientData dummy;
     Tcl_Interp *interp;
     int argc;
     char **argv;
{
    /* get the top element of the stack */

  Interp        *iPtr    = (Interp *) interp;
  Stack         *stack   = &iPtr -> execution_stack;
  Stack_Element *element = stack -> slots[stack -> top];

    /* check for an error message */

  if (iPtr -> resultCode == TCL_ERROR) {
    char msg[100];
    char *arm = get_state_variable (interp, "switch_arm");
    sprintf (msg, "\n    (\"%s\" arm line %d)", arm, interp -> errorLine);
    Tcl_AddErrorInfo (interp, msg);
  }
  
    /* move on the rest of the script */

  element -> flag = CMD_REST_OF_SCRIPT;
  return (iPtr -> resultCode);  
}



int Tcl_SwitchCmd (dummy, interp, argc, argv)
     ClientData dummy;
     Tcl_Interp *interp;
     int argc;
     char **argv;
{
    int i, code, mode, matched;
    int body;
    char *string;
    int switchArgc, splitArgs;
    char **switchArgv;

      /* get the top element of the stack */

    Interp        *iPtr    = (Interp *) interp;
    Stack         *stack   = &iPtr -> execution_stack;
    Stack_Element *element = stack -> slots[stack -> top];

      /* have we just executed an arm of the "switch" command? */

    if (element -> flag == CMD_SwitchBody)
      return TclSwitchBody (dummy, interp, argc, argv);

      /* or are we just starting the command? */

    switchArgc = argc-1;
    switchArgv = argv+1;
    mode = EXACT;
    while ((switchArgc > 0) && (*switchArgv[0] == '-')) {
	if (strcmp(*switchArgv, "-exact") == 0) {
	    mode = EXACT;
	} else if (strcmp(*switchArgv, "-glob") == 0) {
	    mode = GLOB;
	} else if (strcmp(*switchArgv, "-regexp") == 0) {
	    mode = REGEXP;
	} else if (strcmp(*switchArgv, "--") == 0) {
	    switchArgc--;
	    switchArgv++;
	    break;
	} else {
	    Tcl_AppendResult(interp, "bad option \"", switchArgv[0],
		    "\": should be -exact, -glob, -regexp, or --",
		    (char *) NULL);
	    return TCL_ERROR;
	}
	switchArgc--;
	switchArgv++;
    }
    if (switchArgc < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		argv[0], " ?switches? string pattern body ... ?default body?\"",
		(char *) NULL);
	return TCL_ERROR;
    }
    string = *switchArgv;
    switchArgc--;
    switchArgv++;

    /*
     * If all of the pattern/command pairs are lumped into a single
     * argument, split them out again.
     */

    splitArgs = 0;
    if (switchArgc == 1) {
	code = Tcl_SplitList(interp, switchArgv[0], &switchArgc, &switchArgv);
	if (code != TCL_OK) {
	    return code;
	}
	splitArgs = 1;
    }

    for (i = 0; i < switchArgc; i += 2) 
    {
      if (i == (switchArgc-1)) 
      {
	interp->result = "extra switch pattern with no body";
        if (splitArgs) ckfree ((char *) switchArgv);
        return TCL_ERROR;
      }

      /*
       * See if the pattern matches the string.
       */

      matched = 0;
      if ((*switchArgv[i] == 'd') && (i == switchArgc-2)
		&& (strcmp(switchArgv[i], "default") == 0)) {
        matched = 1;
      } else {
        switch (mode) {
    	  case EXACT:
	     matched = (strcmp(string, switchArgv[i]) == 0);
	     break;
	  case GLOB:
	     matched = Tcl_StringMatch(string, switchArgv[i]);
	     break;
  	  case REGEXP:
	     matched = Tcl_RegExpMatch(interp, string, switchArgv[i]);
	     if (matched < 0) 
             {
               if (splitArgs) ckfree ((char *) switchArgv);
               return TCL_ERROR;
             }
	     break;
	}
      }
      if (!matched) {
        continue;
      }

	/*
	 * We've got a match.  Find a body to execute, skipping bodies
	 * that are "-".
	 */

	for (body = i + 1; ; body += 2) 
        {
	  if (body >= switchArgc) 
          {
	     Tcl_AppendResult(interp, "no body specified for pattern \"", switchArgv[i], "\"", (char *) NULL);
             if (splitArgs) ckfree ((char *) switchArgv);
             return TCL_ERROR;
	  }

	  if ((switchArgv[body][0] != '-') || (switchArgv[body][1] != 0))
          {
	     char arm[100];
             sprintf (arm, "%.50s", switchArgv[i]);
	     set_state_variable (interp, "switch_arm", arm);

             element -> flag        = CMD_SwitchBody;
             element -> commandProc = TclSwitchBody; 
             TclPushStack (stack, CMD_REST_OF_SCRIPT, switchArgv[body], TCL_VOLATILE);

             if (splitArgs) ckfree ((char *) switchArgv);
             return TCL_OK;
          } 
	}
    }

    if (splitArgs) ckfree ((char *) switchArgv);
    return TCL_OK;
}

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

#define CMD_ForeachBody 1

typedef struct ForeachData
{
  int count;
  int argc;
  char **argv;
} ForeachData;

static int TclForeachBody (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];  
  int result             = iPtr -> resultCode;
  ForeachData *data      = (ForeachData *) clientData;
  char value_scratch[16];

  if (result == TCL_BREAK)
  {
    result = TCL_OK;
  }
  else if (result == TCL_ERROR)
  {
    char msg[100];
    sprintf(msg, "\n    (\"foreach\" body line %d)", interp->errorLine);
    Tcl_AddErrorInfo(interp, msg);
  }
  else if ((result == TCL_OK) || (result == TCL_CONTINUE))
  {
    if (++data -> count == data -> argc)
    {
      result = TCL_OK;
    }
    else if (Tcl_SetVar (interp, argv[1], data -> argv[data -> count], 0) == NULL)
    {
      Tcl_AppendResult (interp, "unable to set loop variable", (char *) NULL);
      result = TCL_ERROR;
    }
    else 
    {
      sprintf (value_scratch, "%d", data -> count);
      set_state_variable (interp, "foreach_count", value_scratch);
      TclPushStack (stack, CMD_REST_OF_SCRIPT, argv[3], TCL_STATIC); 
      return TCL_OK;
    }
  }

  if (result == TCL_OK) {
    Tcl_ResetResult (interp);
  }

  element -> flag = CMD_REST_OF_SCRIPT;
  ckfree ((char *) data -> argv);
  ckfree ((char *) data);
  return result;  
}

int Tcl_ForeachCmd (dummy, interp, argc, argv)
     ClientData dummy;
     Tcl_Interp *interp;
     int argc;
     char **argv;
{
  int result;
  int listArgc;
  char **listArgv;
  Interp *iPtr           = (Interp *) interp;
  Stack *stack           = &iPtr -> execution_stack;
  Stack_Element *element = stack -> slots[stack -> top];  
  ForeachData *data;
 
    /* check the arguments */
 
  if (argc != 4) 
  {
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " varName list command\"", (char *) NULL);
    return TCL_ERROR;
  }

    /* split the list */

  if ((result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv)) != TCL_OK)
    return result;
  else if (listArgc == 0)
    return TCL_OK;
 
  data                   = (ForeachData *) ckalloc ((unsigned) sizeof(ForeachData));
  data -> argc           = listArgc;
  data -> argv           = listArgv;
  element -> commandData = (ClientData) data;

    /* pick correct list element */

  if (element -> flag == CMD_ForeachBody)
    Tcl_GetInt (interp, get_state_variable(interp, "foreach_count"), &data -> count);
  else
    data -> count = 0;

    /* set the loop control variable */

  if (Tcl_SetVar(interp, argv[1], listArgv[data -> count], 0) == NULL)
  {
    Tcl_SetResult(interp, "couldn't set loop variable", TCL_STATIC);
    ckfree ((char *) listArgv); 
    return TCL_ERROR;
  }

    /* either push body or check body result */

  if (element -> flag == CMD_ForeachBody)
  {
    return TclForeachBody ((ClientData) data, interp, argc, argv);
  }  
  else
  {
    element -> flag        = CMD_ForeachBody;
    element -> commandProc = TclForeachBody;
    set_state_variable (interp, "foreach_count", "0");
    TclPushStack (stack, CMD_REST_OF_SCRIPT, argv[3], TCL_STATIC);
    return TCL_OK;
  }
}
