tclcmdil.c

CMX990 demonstration board (DE9901)

/* 
 * tclCmdIL.c --
 *
 *	This file contains the top-level command routines for most of
 *	the Tcl built-in commands whose names begin with the letters
 *	I through L.  It contains only commands in the generic core
 *	(i.e. those that don't depend much upon UNIX facilities).
 *
 * 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: tclCmdIL.c,v 1.1.1.1 2001/04/29 20:34:30 karll Exp $
 */

#include "tclInt.h"

/*
 * Forward declarations for procedures defined in this file:
 */

static int SortCompareProc _ANSI_ARGS_((CONST VOID *first,
                                        CONST VOID *second));

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */
int Tcl_IfCmd(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, value;

  i = 1;
  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;
    }
    result = Tcl_ExprBoolean(interp, argv[i], &value);
    if (result != 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) {
      return Tcl_Eval(interp, argv[i], 0, (char **) NULL);
    }

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

    i++;
    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") == 0) {
    i++;
    if (i >= argc) {
      Tcl_AppendResult(interp,
                       "wrong # args: no script following \"else\" argument",
                       (char *) NULL);
      return TCL_ERROR;
    }
  }
  return Tcl_Eval(interp, argv[i], 0, (char **) NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_IncrCmd --
 *
 *	This procedure is invoked to process the "incr" 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_IncrCmd(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 value;
  char *oldString, *result;
  char newString[30];

  if ((argc != 2) && (argc != 3)) {
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                     " varName ?increment?\"", (char *) NULL);
    return TCL_ERROR;
  }

  oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
  if (oldString == NULL) {
    return TCL_ERROR;
  }
  if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
    Tcl_AddErrorInfo(interp,
                     "\n    (reading value of variable to increment)");
    return TCL_ERROR;
  }
  if (argc == 2) {
    value += 1;
  } else {
    int increment;

    if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
      Tcl_AddErrorInfo(interp,
                       "\n    (reading increment)");
      return TCL_ERROR;
    }
    value += increment;
  }
  sprintf(newString, "%d", value);
  result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
  if (result == NULL) {
    return TCL_ERROR;
  }
  interp->result = result;
  return TCL_OK; 
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InfoCmd --
 *
 *	This procedure is invoked to process the "info" 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_InfoCmd(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. */
{
  register Interp *iPtr = (Interp *) interp;
  int length;
  char c;
  Arg *argPtr;
  Proc *procPtr;
  Var *varPtr;
  Command *cmdPtr;
  Tcl_HashEntry *hPtr;
  Tcl_HashSearch search;

  if (argc < 2) {
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                     " option ?arg arg ...?\"", (char *) NULL);
    return TCL_ERROR;
  }
  c = argv[1][0];
  length = strlen(argv[1]);
  if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) {
    if (argc != 3) {
      Tcl_AppendResult(interp, "wrong # args: should be \"",
                       argv[0], " args procname\"", (char *) NULL);
      return TCL_ERROR;
    }
    procPtr = TclFindProc(iPtr, argv[2]);
    if (procPtr == NULL) {
    infoNoSuchProc:
      Tcl_AppendResult(interp, "\"", argv[2],
                       "\" isn't a procedure", (char *) NULL);
      return TCL_ERROR;
    }
    for (argPtr = procPtr->argPtr; argPtr != NULL;
         argPtr = argPtr->nextPtr) {
      Tcl_AppendElement(interp, argPtr->name, 0);
    }
    return TCL_OK;
  } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {
    if (argc != 3) {
      Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                       " body procname\"", (char *) NULL);
      return TCL_ERROR;
    }
    procPtr = TclFindProc(iPtr, argv[2]);
    if (procPtr == NULL) {
      goto infoNoSuchProc;
    }
    iPtr->result = procPtr->command;
    return TCL_OK;
  } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0)
             && (length >= 2)) {
    if (argc != 2) {
      Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                       " cmdcount\"", (char *) NULL);
      return TCL_ERROR;
    }
    sprintf(iPtr->result, "%d", iPtr->cmdCount);
    return TCL_OK;
  } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0)
             && (length >= 4)) {
    if (argc > 3) {
      Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                       " commands [pattern]\"", (char *) NULL);
      return TCL_ERROR;
    }
    for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
      char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
      if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
        continue;
      }
      Tcl_AppendElement(interp, name, 0);
    }
    return TCL_OK;
  } else if ((c == 'c') && (strncmp(argv[1], "complete", length) == 0)
             && (length >= 4)) {
    if (argc != 3) {
      Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                       " complete command\"", (char *) NULL);
      return TCL_ERROR;
    }
    if (Tcl_CommandComplete(argv[2])) {
      interp->result = "1";
    } else {
      interp->result = "0";
    }
    return TCL_OK;
  } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {
    if (argc != 5) {
      Tcl_AppendResult(interp, "wrong # args: should be \"",
                       argv[0], " default procname arg varname\"",
                       (char *) NULL);
      return TCL_ERROR;
    }
    procPtr = TclFindProc(iPtr, argv[2]);
    if (procPtr == NULL) {
      goto infoNoSuchProc;
    }
    for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) {
      if (argPtr == NULL) {
        Tcl_AppendResult(interp, "procedure \"", argv[2],
                         "\" doesn't have an argument \"", argv[3],
                         "\"", (char *) NULL);
        return TCL_ERROR;
      }
      if (strcmp(argv[3], argPtr->name) == 0) {
        if (argPtr->defValue != NULL) {
          if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4],
                         argPtr->defValue, 0) == NULL) {
          defStoreError:
            Tcl_AppendResult(interp,
                             "couldn't store default value in variable \"",
                             argv[4], "\"", (char *) NULL);
            return TCL_ERROR;
          }
          iPtr->result = "1";
        } else {
          if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0)
              == NULL) {
            goto defStoreError;
          }
          iPtr->result = "0";
        }
        return TCL_OK;
      }
    }
  } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {
    char *p;
    if (argc != 3) {
      Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                       " exists varName\"", (char *) NULL);
      return TCL_ERROR;
    }
    p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0);

    /*
     * The code below handles the special case where the name is for
     * an array:  Tcl_GetVar will reject this since you can't read
     * an array variable without an index.
     */

    if (p == NULL) {
      Tcl_HashEntry *hPtr;
      Var *varPtr;

      if (strchr(argv[2], '(') != NULL) {
      noVar:
        iPtr->result = "0";
        return TCL_OK;
      }
      if (iPtr->varFramePtr == NULL) {
        hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
      } else {
        hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
      }
      if (hPtr == NULL) {
        goto noVar;
      }
      varPtr = (Var *) Tcl_GetHashValue(hPtr);
      if (varPtr->flags & VAR_UPVAR) {
        varPtr = (Var *) Tcl_GetHashValue(varPtr->value.upvarPtr);
      }
      if (!(varPtr->flags & VAR_ARRAY)) {
        goto noVar;
      }
    }
    iPtr->result = "1";
    return TCL_OK;
  } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {
    char *name;

    if (argc > 3) {
      Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                       " globals [pattern]\"", (char *) NULL);