tclcmdil.c

CMX990 demonstration board (DE9901)

 *
 *	This procedure is invoked to process the "list" 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_ListCmd(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],
                     " arg ?arg ...?\"", (char *) NULL);
    return TCL_ERROR;
  }
  interp->result = Tcl_Merge(argc-1, argv+1);
  interp->freeProc = (Tcl_FreeProc *) free;
  return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LlengthCmd --
 *
 *	This procedure is invoked to process the "llength" 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_LlengthCmd(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 count, result;
  char *element, *p;

  if (argc != 2) {
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                     " list\"", (char *) NULL);
    return TCL_ERROR;
  }
  for (count = 0, p = argv[1]; *p != 0 ; count++) {
    result = TclFindElement(interp, p, &element, &p, (int *) NULL,
                            (int *) NULL);
    if (result != TCL_OK) {
      return result;
    }
    if (*element == 0) {
      break;
    }
  }
  sprintf(interp->result, "%d", count);
  return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LrangeCmd --
 *
 *	This procedure is invoked to process the "lrange" 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_LrangeCmd(ClientData notUsed, Tcl_Interp *interp, int argc, char **argv)
  //ClientData notUsed;			/* Not used. */
  //Tcl_Interp *interp;			/* Current interpreter. */
  //int argc;				/* Number of arguments. */
  //char **argv;			/* Argument strings. */
{
  int first, last, result;
  char *begin, *end, c, *dummy;
  int count;

  if (argc != 4) {
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                     " list first last\"", (char *) NULL);
    return TCL_ERROR;
  }
  if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
    return TCL_ERROR;
  }
  if (first < 0) {
    first = 0;
  }
  if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
    last = 1000000;
  } else {
    if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) {
      Tcl_ResetResult(interp);
      Tcl_AppendResult(interp,
                       "expected integer or \"end\" but got \"",
                       argv[3], "\"", (char *) NULL);
      return TCL_ERROR;
    }
  }
  if (first > last) {
    return TCL_OK;
  }

  /*
   * Extract a range of fields.
   */

  for (count = 0, begin = argv[1]; count < first; count++) {
    result = TclFindElement(interp, begin, &dummy, &begin, (int *) NULL,
                            (int *) NULL);
    if (result != TCL_OK) {
      return result;
    }
    if (*begin == 0) {
      break;
    }
  }
  for (count = first, end = begin; (count <= last) && (*end != 0);
       count++) {
    result = TclFindElement(interp, end, &dummy, &end, (int *) NULL,
                            (int *) NULL);
    if (result != TCL_OK) {
      return result;
    }
  }

  /*
   * Chop off trailing spaces.
   */

  while (isspace(end[-1])) {
    end--;
  }
  c = *end;
  *end = 0;
  Tcl_SetResult(interp, begin, TCL_VOLATILE);
  *end = c;
  return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LreplaceCmd --
 *
 *	This procedure is invoked to process the "lreplace" 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_LreplaceCmd(ClientData notUsed, Tcl_Interp *interp, int argc, char **argv)
  //ClientData notUsed;			/* Not used. */
  //Tcl_Interp *interp;			/* Current interpreter. */
  //int argc;				/* Number of arguments. */
  //char **argv;			/* Argument strings. */
{
  char *p1, *p2, *element, savedChar, *dummy;
  int i, first, last, count, result, size;

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

  /*
   * Skip over the elements of the list before "first".
   */

  size = 0;
  element = argv[1];
  for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) {
    result = TclFindElement(interp, p1, &element, &p1, &size,
                            (int *) NULL);
    if (result != TCL_OK) {
      return result;
    }
  }
  if (*p1 == 0) {
    Tcl_AppendResult(interp, "list doesn't contain element ",
                     argv[2], (char *) NULL);
    return TCL_ERROR;
  }

  /*
   * Skip over the elements of the list up through "last".
   */

  for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) {
    result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL,
                            (int *) NULL);
    if (result != TCL_OK) {
      return result;
    }
  }

  /*
   * Add the elements before "first" to the result.  Be sure to
   * include quote or brace characters that might terminate the
   * last of these elements.
   */

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

  /*
   * Add the new list elements.
   */

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

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

  if (*p2 != 0) {
    if (*interp->result == 0) {
      Tcl_SetResult(interp, p2, TCL_VOLATILE);
    } else {
      Tcl_AppendResult(interp, " ", p2, (char *) NULL);
    }
  }
  return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LsearchCmd --
 *
 *	This procedure is invoked to process the "lsearch" 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_LsearchCmd(ClientData notUsed, Tcl_Interp *interp, int argc, char **argv)
  //ClientData notUsed;			/* Not used. */
  //Tcl_Interp *interp;			/* Current interpreter. */
  //int argc;				/* Number of arguments. */
  //char **argv;			/* Argument strings. */
{
  int listArgc;
  char **listArgv;
  int i, match;

  if (argc != 3) {
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                     " list pattern\"", (char *) NULL);
    return TCL_ERROR;
  }
  if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
    return TCL_ERROR;
  }
  match = -1;
  for (i = 0; i < listArgc; i++) {
    if (Tcl_StringMatch(listArgv[i], argv[2])) {
      match = i;
      break;
    }
  }
  sprintf(interp->result, "%d", match);
  ckfree((char *) listArgv);
  return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LsortCmd --
 *
 *	This procedure is invoked to process the "lsort" 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_LsortCmd(ClientData notUsed, Tcl_Interp *interp, int argc, char **argv)
  //ClientData notUsed;			/* Not used. */
  //Tcl_Interp *interp;			/* Current interpreter. */
  //int argc;				/* Number of arguments. */
  //char **argv;			/* Argument strings. */
{
  int listArgc;
  char **listArgv;

  if (argc != 2) {
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                     " list\"", (char *) NULL);
    return TCL_ERROR;
  }
  if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
    return TCL_ERROR;
  }
  qsort((VOID *) listArgv, listArgc, sizeof (char *), SortCompareProc);
  interp->result = Tcl_Merge(listArgc, listArgv);
  interp->freeProc = (Tcl_FreeProc *) free;
  ckfree((char *) listArgv);
  return TCL_OK;
}

/*
 * The procedure below is called back by qsort to determine
 * the proper ordering between two elements.
 */
static int SortCompareProc(CONST VOID *first, CONST VOID *second)
  //  CONST VOID *first, *second;		/* Elements to be compared. */
{
  return strcmp(*((char **) first), *((char **) second));
}