tclcmdah.c

CMX990 demonstration board (DE9901)

/* 
 * tclCmdAH.c --
 *
 *	This file contains the top-level command routines for most of
 *	the Tcl built-in commands whose names begin with the letters
 *	A to H.
 *
 * Copyright 1987-1991 Regents of the University of California
 * Permission to use, copy, modify, and distribute this
 * software and its documentation for any purpose and without
 * fee is hereby granted, provided that the above copyright
 * notice appear in all copies.  The University of California
 * makes no representations about the suitability of this
 * software for any purpose.  It is provided "as is" without
 * express or implied warranty.
 *
 * $Id: tclCmdAH.c,v 1.1.1.1 2001/04/29 20:34:26 karll Exp $
 */

#include "tclInt.h"


/*
 *----------------------------------------------------------------------
 *
 * Tcl_BreakCmd --
 *
 *	This procedure is invoked to process the "break" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */
int Tcl_BreakCmd(ClientData dummy, Tcl_Interp *interp, int argc, char **argv)
  //  ClientData dummy;			/* Not used. */
  //Tcl_Interp *interp;			/* Current interpreter. */
  //int argc;				/* Number of arguments. */
  //char **argv;			/* Argument strings. */
{
  if (argc != 1) {
    Tcl_AppendResult(interp, "wrong # args: should be \"",
                     argv[0], "\"", (char *) NULL);
    return TCL_ERROR;
  }
  return TCL_BREAK;
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 *----------------------------------------------------------------------
 */
int Tcl_CaseCmd(ClientData dummy, Tcl_Interp *interp, int argc, char **argv)
  //ClientData dummy;			/* Not used. */
  //Tcl_Interp *interp;			/* Current interpreter. */
  //int argc;				/* Number of arguments. */
  //char **argv;			/* Argument strings. */
{
  int i, result;
  int body;
  char *string;
  int caseArgc, splitArgs;
  char **caseArgv;

  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(*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) {
    result = Tcl_Eval(interp, caseArgv[body], 0, (char **) NULL);
    if (result == TCL_ERROR) {
      char msg[100];
      sprintf(msg, "\n    (\"%.50s\" arm line %d)", caseArgv[body-1],
              interp->errorLine);
      Tcl_AddErrorInfo(interp, msg);
    }
    goto cleanup;
  }

  /*
   * Nothing matched:  return nothing.
   */

  result = TCL_OK;

 cleanup:
  if (splitArgs) {
    ckfree((char *) caseArgv);
  }
  return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CatchCmd --
 *
 *	This procedure is invoked to process the "catch" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */
int Tcl_CatchCmd(ClientData dummy, Tcl_Interp *interp, int argc, char **argv)
  //ClientData dummy;			/* Not used. */
  //Tcl_Interp *interp;			/* Current interpreter. */
  //int argc;				/* Number of arguments. */
  //char **argv;			/* Argument strings. */
{
  int result;

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

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConcatCmd --
 *
 *	This procedure is invoked to process the "concat" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */
int Tcl_ConcatCmd(ClientData dummy, Tcl_Interp *interp, int argc, char **argv)
  //ClientData dummy;			/* Not used. */
  //Tcl_Interp *interp;			/* Current interpreter. */
  //int argc;				/* Number of arguments. */
  //char **argv;			/* Argument strings. */
{
  if (argc == 1) {
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                     " arg ?arg ...?\"", (char *) NULL);
    return TCL_ERROR;
  }

  interp->result = Tcl_Concat(argc-1, argv+1);
  interp->freeProc = (Tcl_FreeProc *) free;
  return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ContinueCmd --
 *
 *	This procedure is invoked to process the "continue" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */
int Tcl_ContinueCmd(ClientData dummy, Tcl_Interp *interp, int argc, char **argv)
  //ClientData dummy;			/* Not used. */
  //Tcl_Interp *interp;			/* Current interpreter. */
  //int argc;				/* Number of arguments. */
  //char **argv;			/* Argument strings. */
{
  if (argc != 1) {
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                     "\"", (char *) NULL);
    return TCL_ERROR;
  }
  return TCL_CONTINUE;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ErrorCmd --
 *
 *	This procedure is invoked to process the "error" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */
int Tcl_ErrorCmd(ClientData dummy, Tcl_Interp *interp, int argc, char **argv)
  //ClientData dummy;			/* Not used. */
  //Tcl_Interp *interp;			/* Current interpreter. */
  //int argc;				/* Number of arguments. */
  //char **argv;			/* Argument strings. */
{
  Interp *iPtr = (Interp *) interp;

  if ((argc < 2) || (argc > 4)) {
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                     " message ?errorInfo? ?errorCode?\"", (char *) NULL);
    return TCL_ERROR;
  }
  if ((argc >= 3) && (argv[2][0] != 0)) {
    Tcl_AddErrorInfo(interp, argv[2]);
    iPtr->flags |= ERR_ALREADY_LOGGED;
  }
  if (argc == 4) {
    Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3],
		TCL_GLOBAL_ONLY);
    iPtr->flags |= ERROR_CODE_SET;
  }
  Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
  return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalCmd --
 *
 *	This procedure is invoked to process the "eval" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */
int Tcl_EvalCmd(ClientData dummy, Tcl_Interp *interp, int argc, char **argv)
  //ClientData dummy;			/* Not used. */
  //Tcl_Interp *interp;			/* Current interpreter. */
  //int argc;				/* Number of arguments. */
  //char **argv;			/* Argument strings. */
{
  int result;
  char *cmd;

  if (argc < 2) {
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                     " arg ?arg ...?\"", (char *) NULL);
    return TCL_ERROR;
  }
  if (argc == 2) {
    result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
  } else {
    
    /*
     * More than one argument:  concatenate them together with spaces
     * between, then evaluate the result.
     */
    
    cmd = Tcl_Concat(argc-1, argv+1);
    result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
    ckfree(cmd);
  }
  if (result == TCL_ERROR) {
    char msg[60];
    sprintf(msg, "\n    (\"eval\" body line %d)", interp->errorLine);
    Tcl_AddErrorInfo(interp, msg);
  }
  return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ExprCmd --
 *
 *	This procedure is invoked to process the "expr" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */
int Tcl_ExprCmd(ClientData dummy, Tcl_Interp *interp, int argc, char **argv)
  //ClientData dummy;			/* Not used. */
  //Tcl_Interp *interp;			/* Current interpreter. */
  //int argc;				/* Number of arguments. */
  //char **argv;			/* Argument strings. */
{
  if (argc != 2) {
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                     " expression\"", (char *) NULL);
    return TCL_ERROR;
  }

  return Tcl_ExprString(interp, argv[1]);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ForCmd --
 *
 *	This procedure is invoked to process the "for" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */
int Tcl_ForCmd(ClientData dummy, Tcl_Interp *interp, int argc, char **argv)
  //ClientData dummy;			/* Not used. */
  //Tcl_Interp *interp;			/* Current interpreter. */
  //int argc;				/* Number of arguments. */
  //char **argv;			/* Argument strings. */
{
  int result, value;