tclcmdil.c

CMX990 demonstration board (DE9901)

      return TCL_ERROR;
    }
    for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search);
         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
      varPtr = (Var *) Tcl_GetHashValue(hPtr);
      if (varPtr->flags & VAR_UNDEFINED) {
        continue;
      }
      name = Tcl_GetHashKey(&iPtr->globalTable, hPtr);
      if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
        continue;
      }
      Tcl_AppendElement(interp, name, 0);
    }
    return TCL_OK;
  } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0)
             && (length >= 2)) {
    if (argc == 2) {
      if (iPtr->varFramePtr == NULL) {
        iPtr->result = "0";
      } else {
        sprintf(iPtr->result, "%d", iPtr->varFramePtr->level);
      }
      return TCL_OK;
    } else if (argc == 3) {
      int level;
      CallFrame *framePtr;

      if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) {
        return TCL_ERROR;
      }
      if (level <= 0) {
        if (iPtr->varFramePtr == NULL) {
        levelError:
          Tcl_AppendResult(interp, "bad level \"", argv[2],
                           "\"", (char *) NULL);
          return TCL_ERROR;
        }
        level += iPtr->varFramePtr->level;
      }
      for (framePtr = iPtr->varFramePtr; framePtr != NULL;
           framePtr = framePtr->callerVarPtr) {
        if (framePtr->level == level) {
          break;
        }
      }
      if (framePtr == NULL) {
        goto levelError;
      }
      iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv);
      iPtr->freeProc = (Tcl_FreeProc *) free;
      return TCL_OK;
    }
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                     " level [number]\"", (char *) NULL);
    return TCL_ERROR;
  } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0)
             && (length >= 2)) {
    if (argc != 2) {
      Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                       " library\"", (char *) NULL);
      return TCL_ERROR;
    }
    interp->result = getenv("TCL_LIBRARY");
    if (interp->result == NULL) {
#ifdef TCL_LIBRARY
      interp->result = TCL_LIBRARY;
#else
      interp->result = "there is no Tcl library at this installation";
      return TCL_ERROR;
#endif
    }
    return TCL_OK;
  } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
             && (length >= 2)) {
    char *name;

    if (argc > 3) {
      Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                       " locals [pattern]\"", (char *) NULL);
      return TCL_ERROR;
    }
    if (iPtr->varFramePtr == NULL) {
      return TCL_OK;
    }
    for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search);
         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
      varPtr = (Var *) Tcl_GetHashValue(hPtr);
      if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) {
        continue;
      }
      name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr);
      if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
        continue;
      }
      Tcl_AppendElement(interp, name, 0);
    }
    return TCL_OK;
  } else if ((c == 'p') && (strncmp(argv[1], "procs", length)) == 0) {
    if (argc > 3) {
      Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                       " procs [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);

      cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
      if (!TclIsProc(cmdPtr)) {
        continue;
      }
      if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
        continue;
      }
      Tcl_AppendElement(interp, name, 0);
    }
    return TCL_OK;
  } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)) {
    if (argc != 2) {
      Tcl_AppendResult(interp, "wrong # args: should be \"",
                       argv[0], " script\"", (char *) NULL);
      return TCL_ERROR;
    }
    if (iPtr->scriptFile != NULL) {
      interp->result = iPtr->scriptFile;
    }
    return TCL_OK;
  } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {
    if (argc != 2) {
      Tcl_AppendResult(interp, "wrong # args: should be \"",
                       argv[0], " tclversion\"", (char *) NULL);
      return TCL_ERROR;
    }

    /*
     * Note:  TCL_VERSION below is expected to be set with a "-D"
     * switch in the Makefile.
     */

    strcpy(iPtr->result, TCL_VERSION);
    return TCL_OK;
  } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) {
    Tcl_HashTable *tablePtr;
    char *name;

    if (argc > 3) {
      Tcl_AppendResult(interp, "wrong # args: should be \"",
                       argv[0], " vars [pattern]\"", (char *) NULL);
      return TCL_ERROR;
    }
    if (iPtr->varFramePtr == NULL) {
      tablePtr = &iPtr->globalTable;
    } else {
      tablePtr = &iPtr->varFramePtr->varTable;
    }
    for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);
         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
      varPtr = (Var *) Tcl_GetHashValue(hPtr);
      if (varPtr->flags & VAR_UNDEFINED) {
        continue;
      }
      name = Tcl_GetHashKey(tablePtr, hPtr);
      if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
        continue;
      }
      Tcl_AppendElement(interp, name, 0);
    }
    return TCL_OK;
  } else {
    Tcl_AppendResult(interp, "bad option \"", argv[1],
                     "\": should be args, body, cmdcount, commands, ",
                     "complete, default, ",
                     "exists, globals, level, library, locals, procs, ",
                     "script, tclversion, or vars",
                     (char *) NULL);
    return TCL_ERROR;
  }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_JoinCmd --
 *
 *	This procedure is invoked to process the "join" 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_JoinCmd(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. */
{
  char *joinString;
  char **listArgv;
  int listArgc, i;

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

  if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
    return TCL_ERROR;
  }
  for (i = 0; i < listArgc; i++) {
    if (i == 0) {
      Tcl_AppendResult(interp, listArgv[0], (char *) NULL);
    } else  {
      Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL);
    }
  }
  ckfree((char *) listArgv);
  return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LindexCmd --
 *
 *	This procedure is invoked to process the "lindex" 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_LindexCmd(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. */
{
  char *p, *element;
  int index, size, parenthesized, result;

  if (argc != 3) {
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                     " list index\"", (char *) NULL);
    return TCL_ERROR;
  }
  if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
    return TCL_ERROR;
  }
  if (index < 0) {
    return TCL_OK;
  }
  for (p = argv[1] ; index >= 0; index--) {
    result = TclFindElement(interp, p, &element, &p, &size,
                            &parenthesized);
    if (result != TCL_OK) {
      return result;
    }
  }
  if (size == 0) {
    return TCL_OK;
  }
  if (size >= TCL_RESULT_SIZE) {
    interp->result = (char *) ckalloc((unsigned) size+1);
    interp->freeProc = (Tcl_FreeProc *) free;
  }
  if (parenthesized) {
    memcpy((VOID *) interp->result, (VOID *) element, size);
    interp->result[size] = 0;
  } else {
    TclCopyAndCollapse(size, element, interp->result);
  }
  return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LinsertCmd --
 *
 *	This procedure is invoked to process the "linsert" 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_LinsertCmd(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. */
{
  char *p, *element, savedChar;
  int i, index, count, result, size;

  if (argc < 4) {
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                     " list index element ?element ...?\"", (char *) NULL);
    return TCL_ERROR;
  }
  if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
    return TCL_ERROR;
  }

  /*
   * Skip over the first "index" elements of the list, then add
   * all of those elements to the result.
   */

  size = 0;
  element = argv[1];
  for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) {
    result = TclFindElement(interp, p, &element, &p, &size, (int *) NULL);
    if (result != TCL_OK) {
      return result;
    }
  }
  if (*p == 0) {
    Tcl_AppendResult(interp, argv[1], (char *) NULL);
  } else {
    char *end;

    end = element+size;
    if (element != argv[1]) {
      while ((*end != 0) && !isspace(*end)) {
        end++;
      }
    }
    savedChar = *end;
    *end = 0;
    Tcl_AppendResult(interp, argv[1], (char *) NULL);
    *end = savedChar;
  }

  /*
   * Add the new list elements.
   */

  for (i = 3; i < argc; i++) {
    Tcl_AppendElement(interp, argv[i], 0);
  }

  /*
   * Append the remainder of the original list.
   */

  if (*p != 0) {
    Tcl_AppendResult(interp, " ", p, (char *) NULL);
  }
  return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListCmd --