cvs.zerfleddert.de Git - micropolis/blob - src/tcl/tclcmdil.c

   1 /*
   2  * tclCmdIL.c --
   3  *
   4  *      This file contains the top-level command routines for most of
   5  *      the Tcl built-in commands whose names begin with the letters
   6  *      I through L.  It contains only commands in the generic core
   7  *      (i.e. those that don't depend much upon UNIX facilities).
   8  *
   9  * Copyright 1987-1991 Regents of the University of California
  10  * Permission to use, copy, modify, and distribute this
  11  * software and its documentation for any purpose and without
  12  * fee is hereby granted, provided that the above copyright
  13  * notice appear in all copies.  The University of California
  14  * makes no representations about the suitability of this
  15  * software for any purpose.  It is provided "as is" without
  16  * express or implied warranty.
  17  */
  18
  19 #ifndef lint
  20 static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdIL.c,v 1.84 91/12/06 10:42:36 ouster Exp $ SPRITE (Berkeley)";
  21 #endif
  22
  23 #include "tclint.h"
  24
  25 /*
  26  * Global absolute file name:
  27  */
  28
  29 char *TCL_Library = TCL_LIBRARY;
  30
  31 /*
  32  * Forward declarations for procedures defined in this file:
  33  */
  34
  35 static int              SortCompareProc _ANSI_ARGS_((CONST VOID *first,
  36                             CONST VOID *second));
  37 \f
  38 /*
  39  *----------------------------------------------------------------------
  40  *
  41  * Tcl_IfCmd --
  42  *
  43  *      This procedure is invoked to process the "if" Tcl command.
  44  *      See the user documentation for details on what it does.
  45  *
  46  * Results:
  47  *      A standard Tcl result.
  48  *
  49  * Side effects:
  50  *      See the user documentation.
  51  *
  52  *----------------------------------------------------------------------
  53  */
  54
  55         /* ARGSUSED */
  56 int
  57 Tcl_IfCmd(dummy, interp, argc, argv)
  58     ClientData dummy;                   /* Not used. */
  59     Tcl_Interp *interp;                 /* Current interpreter. */
  60     int argc;                           /* Number of arguments. */
  61     char **argv;                        /* Argument strings. */
  62 {
  63     char *condition, *ifPart, *elsePart, *cmd, *name;
  64     char *clause;
  65     int result, value;
  66
  67     name = argv[0];
  68     if (argc < 3) {
  69         ifSyntax:
  70         Tcl_AppendResult(interp, "wrong # args: should be \"", name,
  71                 " bool ?then? command ?else? ?command?\"", (char *) NULL);
  72         return TCL_ERROR;
  73     }
  74     condition = argv[1];
  75     argc -= 2;
  76     argv += 2;
  77     if ((**argv == 't') && (strncmp(*argv, "then", strlen(*argv)) == 0)) {
  78         argc--;
  79         argv++;
  80     }
  81     if (argc < 1) {
  82         goto ifSyntax;
  83     }
  84     ifPart = *argv;
  85     argv++;
  86     argc--;
  87     if (argc == 0) {
  88         elsePart = "";
  89     } else {
  90         if ((**argv == 'e') && (strncmp(*argv, "else", strlen(*argv)) == 0)) {
  91             argc--;
  92             argv++;
  93         }
  94         if (argc != 1) {
  95             goto ifSyntax;
  96         }
  97         elsePart = *argv;
  98     }
  99
 100     cmd = ifPart;
 101     clause = "\"then\" clause";
 102     result = Tcl_ExprBoolean(interp, condition, &value);
 103     if (result != TCL_OK) {
 104         if (result == TCL_ERROR) {
 105             char msg[60];
 106             sprintf(msg, "\n    (\"if\" test line %d)", interp->errorLine);
 107             Tcl_AddErrorInfo(interp, msg);
 108         }
 109         return result;
 110     }
 111     if (value == 0) {
 112         cmd = elsePart;
 113         clause = "\"else\" clause";
 114     }
 115     if (*cmd == 0) {
 116         return TCL_OK;
 117     }
 118     result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
 119     if (result == TCL_ERROR) {
 120         char msg[60];
 121         sprintf(msg, "\n    (%s line %d)", clause, interp->errorLine);
 122         Tcl_AddErrorInfo(interp, msg);
 123     }
 124     return result;
 125 }
 126 \f
 127 /*
 128  *----------------------------------------------------------------------
 129  *
 130  * Tcl_IncrCmd --
 131  *
 132  *      This procedure is invoked to process the "incr" Tcl command.
 133  *      See the user documentation for details on what it does.
 134  *
 135  * Results:
 136  *      A standard Tcl result.
 137  *
 138  * Side effects:
 139  *      See the user documentation.
 140  *
 141  *----------------------------------------------------------------------
 142  */
 143
 144     /* ARGSUSED */
 145 int
 146 Tcl_IncrCmd(dummy, interp, argc, argv)
 147     ClientData dummy;                   /* Not used. */
 148     Tcl_Interp *interp;                 /* Current interpreter. */
 149     int argc;                           /* Number of arguments. */
 150     char **argv;                        /* Argument strings. */
 151 {
 152     int value;
 153     char *oldString, *result;
 154     char newString[30];
 155
 156     if ((argc != 2) && (argc != 3)) {
 157         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 158                 " varName ?increment?\"", (char *) NULL);
 159         return TCL_ERROR;
 160     }
 161
 162     oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
 163     if (oldString == NULL) {
 164         return TCL_ERROR;
 165     }
 166     if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
 167         Tcl_AddErrorInfo(interp,
 168                 "\n    (reading value of variable to increment)");
 169         return TCL_ERROR;
 170     }
 171     if (argc == 2) {
 172         value += 1;
 173     } else {
 174         int increment;
 175
 176         if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
 177             Tcl_AddErrorInfo(interp,
 178                     "\n    (reading increment)");
 179             return TCL_ERROR;
 180         }
 181         value += increment;
 182     }
 183     sprintf(newString, "%d", value);
 184     result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
 185     if (result == NULL) {
 186         return TCL_ERROR;
 187     }
 188     interp->result = result;
 189     return TCL_OK;
 190 }
 191 \f
 192 /*
 193  *----------------------------------------------------------------------
 194  *
 195  * Tcl_InfoCmd --
 196  *
 197  *      This procedure is invoked to process the "info" Tcl command.
 198  *      See the user documentation for details on what it does.
 199  *
 200  * Results:
 201  *      A standard Tcl result.
 202  *
 203  * Side effects:
 204  *      See the user documentation.
 205  *
 206  *----------------------------------------------------------------------
 207  */
 208
 209         /* ARGSUSED */
 210 int
 211 Tcl_InfoCmd(dummy, interp, argc, argv)
 212     ClientData dummy;                   /* Not used. */
 213     Tcl_Interp *interp;                 /* Current interpreter. */
 214     int argc;                           /* Number of arguments. */
 215     char **argv;                        /* Argument strings. */
 216 {
 217     register Interp *iPtr = (Interp *) interp;
 218     int length;
 219     char c;
 220     Arg *argPtr;
 221     Proc *procPtr;
 222     Var *varPtr;
 223     Command *cmdPtr;
 224     Tcl_HashEntry *hPtr;
 225     Tcl_HashSearch search;
 226
 227     if (argc < 2) {
 228         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 229                 " option ?arg arg ...?\"", (char *) NULL);
 230         return TCL_ERROR;
 231     }
 232     c = argv[1][0];
 233     length = strlen(argv[1]);
 234     if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) {
 235         if (argc != 3) {
 236             Tcl_AppendResult(interp, "wrong # args: should be \"",
 237                     argv[0], " args procname\"", (char *) NULL);
 238             return TCL_ERROR;
 239         }
 240         procPtr = TclFindProc(iPtr, argv[2]);
 241         if (procPtr == NULL) {
 242             infoNoSuchProc:
 243             Tcl_AppendResult(interp, "\"", argv[2],
 244                     "\" isn't a procedure", (char *) NULL);
 245             return TCL_ERROR;
 246         }
 247         for (argPtr = procPtr->argPtr; argPtr != NULL;
 248                 argPtr = argPtr->nextPtr) {
 249             Tcl_AppendElement(interp, argPtr->name, 0);
 250         }
 251         return TCL_OK;
 252     } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {
 253         if (argc != 3) {
 254             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 255                     " body procname\"", (char *) NULL);
 256             return TCL_ERROR;
 257         }
 258         procPtr = TclFindProc(iPtr, argv[2]);
 259         if (procPtr == NULL) {
 260             goto infoNoSuchProc;
 261         }
 262         iPtr->result = procPtr->command;
 263         return TCL_OK;
 264     } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0)
 265             && (length >= 2)) {
 266         if (argc != 2) {
 267             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 268                     " cmdcount\"", (char *) NULL);
 269             return TCL_ERROR;
 270         }
 271         sprintf(iPtr->result, "%d", iPtr->cmdCount);
 272         return TCL_OK;
 273     } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0)
 274             && (length >= 2)){
 275         if (argc > 3) {
 276             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 277                     " commands [pattern]\"", (char *) NULL);
 278             return TCL_ERROR;
 279         }
 280         for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
 281                 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
 282             char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
 283             if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
 284                 continue;
 285             }
 286             Tcl_AppendElement(interp, name, 0);
 287         }
 288         return TCL_OK;
 289     } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {
 290         if (argc != 5) {
 291             Tcl_AppendResult(interp, "wrong # args: should be \"",
 292                     argv[0], " default procname arg varname\"",
 293                     (char *) NULL);
 294             return TCL_ERROR;
 295         }
 296         procPtr = TclFindProc(iPtr, argv[2]);
 297         if (procPtr == NULL) {
 298             goto infoNoSuchProc;
 299         }
 300         for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) {
 301             if (argPtr == NULL) {
 302                 Tcl_AppendResult(interp, "procedure \"", argv[2],
 303                         "\" doesn't have an argument \"", argv[3],
 304                         "\"", (char *) NULL);
 305                 return TCL_ERROR;
 306             }
 307             if (strcmp(argv[3], argPtr->name) == 0) {
 308                 if (argPtr->defValue != NULL) {
 309                     if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4],
 310                             argPtr->defValue, 0) == NULL) {
 311                         defStoreError:
 312                         Tcl_AppendResult(interp,
 313                                 "couldn't store default value in variable \"",
 314                                 argv[4], "\"", (char *) NULL);
 315                         return TCL_ERROR;
 316                     }
 317                     iPtr->result = "1";
 318                 } else {
 319                     if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0)
 320                             == NULL) {
 321                         goto defStoreError;
 322                     }
 323                     iPtr->result = "0";
 324                 }
 325                 return TCL_OK;
 326             }
 327         }
 328     } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {
 329         char *p;
 330         if (argc != 3) {
 331             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 332                     " exists varName\"", (char *) NULL);
 333             return TCL_ERROR;
 334         }
 335         p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0);
 336
 337         /*
 338          * The code below handles the special case where the name is for
 339          * an array:  Tcl_GetVar will reject this since you can't read
 340          * an array variable without an index.
 341          */
 342
 343         if (p == NULL) {
 344             Tcl_HashEntry *hPtr;
 345             Var *varPtr;
 346
 347             if (strchr(argv[2], '(') != NULL) {
 348                 noVar:
 349                 iPtr->result = "0";
 350                 return TCL_OK;
 351             }
 352             if (iPtr->varFramePtr == NULL) {
 353                 hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
 354             } else {
 355                 hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
 356             }
 357             if (hPtr == NULL) {
 358                 goto noVar;
 359             }
 360             varPtr = (Var *) Tcl_GetHashValue(hPtr);
 361             if (varPtr->flags & VAR_UPVAR) {
 362                 varPtr = (Var *) Tcl_GetHashValue(varPtr->value.upvarPtr);
 363             }
 364             if (!(varPtr->flags & VAR_ARRAY)) {
 365                 goto noVar;
 366             }
 367         }
 368         iPtr->result = "1";
 369         return TCL_OK;
 370     } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {
 371         char *name;
 372
 373         if (argc > 3) {
 374             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 375                     " globals [pattern]\"", (char *) NULL);
 376             return TCL_ERROR;
 377         }
 378         for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search);
 379                 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
 380             varPtr = (Var *) Tcl_GetHashValue(hPtr);
 381             if (varPtr->flags & VAR_UNDEFINED) {
 382                 continue;
 383             }
 384             name = Tcl_GetHashKey(&iPtr->globalTable, hPtr);
 385             if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
 386                 continue;
 387             }
 388             Tcl_AppendElement(interp, name, 0);
 389         }
 390         return TCL_OK;
 391     } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0)
 392             && (length >= 2)) {
 393         if (argc == 2) {
 394             if (iPtr->varFramePtr == NULL) {
 395                 iPtr->result = "0";
 396             } else {
 397                 sprintf(iPtr->result, "%d", iPtr->varFramePtr->level);
 398             }
 399             return TCL_OK;
 400         } else if (argc == 3) {
 401             int level;
 402             CallFrame *framePtr;
 403
 404             if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) {
 405                 return TCL_ERROR;
 406             }
 407             if (level <= 0) {
 408                 if (iPtr->varFramePtr == NULL) {
 409                     levelError:
 410                     Tcl_AppendResult(interp, "bad level \"", argv[2],
 411                             "\"", (char *) NULL);
 412                     return TCL_ERROR;
 413                 }
 414                 level += iPtr->varFramePtr->level;
 415             }
 416             for (framePtr = iPtr->varFramePtr; framePtr != NULL;
 417                     framePtr = framePtr->callerVarPtr) {
 418                 if (framePtr->level == level) {
 419                     break;
 420                 }
 421             }
 422             if (framePtr == NULL) {
 423                 goto levelError;
 424             }
 425             iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv);
 426             iPtr->freeProc = (Tcl_FreeProc *) free;
 427             return TCL_OK;
 428         }
 429         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 430                 " level [number]\"", (char *) NULL);
 431         return TCL_ERROR;
 432     } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0)
 433             && (length >= 2)) {
 434         if (argc != 2) {
 435             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 436                     " library\"", (char *) NULL);
 437             return TCL_ERROR;
 438         }
 439 #ifdef TCL_LIBRARY
 440         interp->result = TCL_Library;
 441         return TCL_OK;
 442 #else
 443         interp->result = "there is no Tcl library at this installation";
 444         return TCL_ERROR;
 445 #endif
 446     } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
 447             && (length >= 2)) {
 448         char *name;
 449
 450         if (argc > 3) {
 451             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 452                     " locals [pattern]\"", (char *) NULL);
 453             return TCL_ERROR;
 454         }
 455         if (iPtr->varFramePtr == NULL) {
 456             return TCL_OK;
 457         }
 458         for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search);
 459                 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
 460             varPtr = (Var *) Tcl_GetHashValue(hPtr);
 461             if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) {
 462                 continue;
 463             }
 464             name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr);
 465             if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
 466                 continue;
 467             }
 468             Tcl_AppendElement(interp, name, 0);
 469         }
 470         return TCL_OK;
 471     } else if ((c == 'p') && (strncmp(argv[1], "procs", length)) == 0) {
 472         if (argc > 3) {
 473             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 474                     " procs [pattern]\"", (char *) NULL);
 475             return TCL_ERROR;
 476         }
 477         for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
 478                 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
 479             char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
 480
 481             cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
 482             if (!TclIsProc(cmdPtr)) {
 483                 continue;
 484             }
 485             if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
 486                 continue;
 487             }
 488             Tcl_AppendElement(interp, name, 0);
 489         }
 490         return TCL_OK;
 491     } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)) {
 492         if (argc != 2) {
 493             Tcl_AppendResult(interp, "wrong # args: should be \"",
 494                     argv[0], " script\"", (char *) NULL);
 495             return TCL_ERROR;
 496         }
 497         if (iPtr->scriptFile != NULL) {
 498             interp->result = iPtr->scriptFile;
 499         }
 500         return TCL_OK;
 501     } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {
 502         if (argc != 2) {
 503             Tcl_AppendResult(interp, "wrong # args: should be \"",
 504                     argv[0], " tclversion\"", (char *) NULL);
 505             return TCL_ERROR;
 506         }
 507
 508         /*
 509          * Note:  TCL_VERSION below is expected to be set with a "-D"
 510          * switch in the Makefile.
 511          */
 512
 513         strcpy(iPtr->result, TCL_VERSION);
 514         return TCL_OK;
 515     } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) {
 516         Tcl_HashTable *tablePtr;
 517         char *name;
 518
 519         if (argc > 3) {
 520             Tcl_AppendResult(interp, "wrong # args: should be \"",
 521                     argv[0], " vars [pattern]\"", (char *) NULL);
 522             return TCL_ERROR;
 523         }
 524         if (iPtr->varFramePtr == NULL) {
 525             tablePtr = &iPtr->globalTable;
 526         } else {
 527             tablePtr = &iPtr->varFramePtr->varTable;
 528         }
 529         for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);
 530                 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
 531             varPtr = (Var *) Tcl_GetHashValue(hPtr);
 532             if (varPtr->flags & VAR_UNDEFINED) {
 533                 continue;
 534             }
 535             name = Tcl_GetHashKey(tablePtr, hPtr);
 536             if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
 537                 continue;
 538             }
 539             Tcl_AppendElement(interp, name, 0);
 540         }
 541         return TCL_OK;
 542     } else {
 543         Tcl_AppendResult(interp, "bad option \"", argv[1],
 544                 "\": should be args, body, commands, cmdcount, default, ",
 545                 "exists, globals, level, library, locals, procs, ",
 546                 "script, tclversion, or vars",
 547                 (char *) NULL);
 548         return TCL_ERROR;
 549     }
 550 }
 551 \f
 552 /*
 553  *----------------------------------------------------------------------
 554  *
 555  * Tcl_JoinCmd --
 556  *
 557  *      This procedure is invoked to process the "join" Tcl command.
 558  *      See the user documentation for details on what it does.
 559  *
 560  * Results:
 561  *      A standard Tcl result.
 562  *
 563  * Side effects:
 564  *      See the user documentation.
 565  *
 566  *----------------------------------------------------------------------
 567  */
 568
 569         /* ARGSUSED */
 570 int
 571 Tcl_JoinCmd(dummy, interp, argc, argv)
 572     ClientData dummy;                   /* Not used. */
 573     Tcl_Interp *interp;                 /* Current interpreter. */
 574     int argc;                           /* Number of arguments. */
 575     char **argv;                        /* Argument strings. */
 576 {
 577     char *joinString;
 578     char **listArgv;
 579     int listArgc, i;
 580
 581     if (argc == 2) {
 582         joinString = " ";
 583     } else if (argc == 3) {
 584         joinString = argv[2];
 585     } else {
 586         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 587                 " list ?joinString?\"", (char *) NULL);
 588         return TCL_ERROR;
 589     }
 590
 591     if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
 592         return TCL_ERROR;
 593     }
 594     for (i = 0; i < listArgc; i++) {
 595         if (i == 0) {
 596             Tcl_AppendResult(interp, listArgv[0], (char *) NULL);
 597         } else  {
 598             Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL);
 599         }
 600     }
 601     ckfree((char *) listArgv);
 602     return TCL_OK;
 603 }
 604 \f
 605 /*
 606  *----------------------------------------------------------------------
 607  *
 608  * Tcl_LindexCmd --
 609  *
 610  *      This procedure is invoked to process the "lindex" Tcl command.
 611  *      See the user documentation for details on what it does.
 612  *
 613  * Results:
 614  *      A standard Tcl result.
 615  *
 616  * Side effects:
 617  *      See the user documentation.
 618  *
 619  *----------------------------------------------------------------------
 620  */
 621
 622     /* ARGSUSED */
 623 int
 624 Tcl_LindexCmd(dummy, interp, argc, argv)
 625     ClientData dummy;                   /* Not used. */
 626     Tcl_Interp *interp;                 /* Current interpreter. */
 627     int argc;                           /* Number of arguments. */
 628     char **argv;                        /* Argument strings. */
 629 {
 630     char *p, *element;
 631     int index, size, parenthesized, result;
 632
 633     if (argc != 3) {
 634         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 635                 " list index\"", (char *) NULL);
 636         return TCL_ERROR;
 637     }
 638     if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
 639         return TCL_ERROR;
 640     }
 641     if (index < 0) {
 642         return TCL_OK;
 643     }
 644     for (p = argv[1] ; index >= 0; index--) {
 645         result = TclFindElement(interp, p, &element, &p, &size,
 646                 &parenthesized);
 647         if (result != TCL_OK) {
 648             return result;
 649         }
 650     }
 651     if (size == 0) {
 652         return TCL_OK;
 653     }
 654     if (size >= TCL_RESULT_SIZE) {
 655         interp->result = (char *) ckalloc((unsigned) size+1);
 656         interp->freeProc = (Tcl_FreeProc *) free;
 657     }
 658     if (parenthesized) {
 659         memcpy((VOID *) interp->result, (VOID *) element, size);
 660         interp->result[size] = 0;
 661     } else {
 662         TclCopyAndCollapse(size, element, interp->result);
 663     }
 664     return TCL_OK;
 665 }
 666 \f
 667 /*
 668  *----------------------------------------------------------------------
 669  *
 670  * Tcl_LinsertCmd --
 671  *
 672  *      This procedure is invoked to process the "linsert" Tcl command.
 673  *      See the user documentation for details on what it does.
 674  *
 675  * Results:
 676  *      A standard Tcl result.
 677  *
 678  * Side effects:
 679  *      See the user documentation.
 680  *
 681  *----------------------------------------------------------------------
 682  */
 683
 684         /* ARGSUSED */
 685 int
 686 Tcl_LinsertCmd(dummy, interp, argc, argv)
 687     ClientData dummy;                   /* Not used. */
 688     Tcl_Interp *interp;                 /* Current interpreter. */
 689     int argc;                           /* Number of arguments. */
 690     char **argv;                        /* Argument strings. */
 691 {
 692     char *p, *element, savedChar;
 693     int i, index, count, result, size;
 694
 695     if (argc < 4) {
 696         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 697                 " list index element ?element ...?\"", (char *) NULL);
 698         return TCL_ERROR;
 699     }
 700     if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
 701         return TCL_ERROR;
 702     }
 703
 704     /*
 705      * Skip over the first "index" elements of the list, then add
 706      * all of those elements to the result.
 707      */
 708
 709     size = 0;
 710     element = argv[1];
 711     for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) {
 712         result = TclFindElement(interp, p, &element, &p, &size, (int *) NULL);
 713         if (result != TCL_OK) {
 714             return result;
 715         }
 716     }
 717     if (*p == 0) {
 718         Tcl_AppendResult(interp, argv[1], (char *) NULL);
 719     } else {
 720         char *end;
 721
 722         end = element+size;
 723         if (element != argv[1]) {
 724             while ((*end != 0) && !isspace(*end)) {
 725                 end++;
 726             }
 727         }
 728         savedChar = *end;
 729         *end = 0;
 730         Tcl_AppendResult(interp, argv[1], (char *) NULL);
 731         *end = savedChar;
 732     }
 733
 734     /*
 735      * Add the new list elements.
 736      */
 737
 738     for (i = 3; i < argc; i++) {
 739         Tcl_AppendElement(interp, argv[i], 0);
 740     }
 741
 742     /*
 743      * Append the remainder of the original list.
 744      */
 745
 746     if (*p != 0) {
 747         Tcl_AppendResult(interp, " ", p, (char *) NULL);
 748     }
 749     return TCL_OK;
 750 }
 751 \f
 752 /*
 753  *----------------------------------------------------------------------
 754  *
 755  * Tcl_ListCmd --
 756  *
 757  *      This procedure is invoked to process the "list" Tcl command.
 758  *      See the user documentation for details on what it does.
 759  *
 760  * Results:
 761  *      A standard Tcl result.
 762  *
 763  * Side effects:
 764  *      See the user documentation.
 765  *
 766  *----------------------------------------------------------------------
 767  */
 768
 769         /* ARGSUSED */
 770 int
 771 Tcl_ListCmd(dummy, interp, argc, argv)
 772     ClientData dummy;                   /* Not used. */
 773     Tcl_Interp *interp;                 /* Current interpreter. */
 774     int argc;                           /* Number of arguments. */
 775     char **argv;                        /* Argument strings. */
 776 {
 777     if (argc < 2) {
 778         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 779                 " arg ?arg ...?\"", (char *) NULL);
 780         return TCL_ERROR;
 781     }
 782     interp->result = Tcl_Merge(argc-1, argv+1);
 783     interp->freeProc = (Tcl_FreeProc *) free;
 784     return TCL_OK;
 785 }
 786 \f
 787 /*
 788  *----------------------------------------------------------------------
 789  *
 790  * Tcl_LlengthCmd --
 791  *
 792  *      This procedure is invoked to process the "llength" Tcl command.
 793  *      See the user documentation for details on what it does.
 794  *
 795  * Results:
 796  *      A standard Tcl result.
 797  *
 798  * Side effects:
 799  *      See the user documentation.
 800  *
 801  *----------------------------------------------------------------------
 802  */
 803
 804         /* ARGSUSED */
 805 int
 806 Tcl_LlengthCmd(dummy, interp, argc, argv)
 807     ClientData dummy;                   /* Not used. */
 808     Tcl_Interp *interp;                 /* Current interpreter. */
 809     int argc;                           /* Number of arguments. */
 810     char **argv;                        /* Argument strings. */
 811 {
 812     int count, result;
 813     char *element, *p;
 814
 815     if (argc != 2) {
 816         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 817                 " list\"", (char *) NULL);
 818         return TCL_ERROR;
 819     }
 820     for (count = 0, p = argv[1]; *p != 0 ; count++) {
 821         result = TclFindElement(interp, p, &element, &p, (int *) NULL,
 822                 (int *) NULL);
 823         if (result != TCL_OK) {
 824             return result;
 825         }
 826         if (*element == 0) {
 827             break;
 828         }
 829     }
 830     sprintf(interp->result, "%d", count);
 831     return TCL_OK;
 832 }
 833 \f
 834 /*
 835  *----------------------------------------------------------------------
 836  *
 837  * Tcl_LrangeCmd --
 838  *
 839  *      This procedure is invoked to process the "lrange" Tcl command.
 840  *      See the user documentation for details on what it does.
 841  *
 842  * Results:
 843  *      A standard Tcl result.
 844  *
 845  * Side effects:
 846  *      See the user documentation.
 847  *
 848  *----------------------------------------------------------------------
 849  */
 850
 851         /* ARGSUSED */
 852 int
 853 Tcl_LrangeCmd(notUsed, interp, argc, argv)
 854     ClientData notUsed;                 /* Not used. */
 855     Tcl_Interp *interp;                 /* Current interpreter. */
 856     int argc;                           /* Number of arguments. */
 857     char **argv;                        /* Argument strings. */
 858 {
 859     int first, last, result;
 860     char *begin, *end, c, *dummy;
 861     int count;
 862
 863     if (argc != 4) {
 864         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 865                 " list first last\"", (char *) NULL);
 866         return TCL_ERROR;
 867     }
 868     if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
 869         return TCL_ERROR;
 870     }
 871     if (first < 0) {
 872         first = 0;
 873     }
 874     if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
 875         last = 1000000;
 876     } else {
 877         if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) {
 878             Tcl_ResetResult(interp);
 879             Tcl_AppendResult(interp,
 880                     "expected integer or \"end\" but got \"",
 881                     argv[3], "\"", (char *) NULL);
 882             return TCL_ERROR;
 883         }
 884     }
 885     if (first > last) {
 886         return TCL_OK;
 887     }
 888
 889     /*
 890      * Extract a range of fields.
 891      */
 892
 893     for (count = 0, begin = argv[1]; count < first; count++) {
 894         result = TclFindElement(interp, begin, &dummy, &begin, (int *) NULL,
 895                 (int *) NULL);
 896         if (result != TCL_OK) {
 897             return result;
 898         }
 899         if (*begin == 0) {
 900             break;
 901         }
 902     }
 903     for (count = first, end = begin; (count <= last) && (*end != 0);
 904             count++) {
 905         result = TclFindElement(interp, end, &dummy, &end, (int *) NULL,
 906                 (int *) NULL);
 907         if (result != TCL_OK) {
 908             return result;
 909         }
 910     }
 911
 912     /*
 913      * Chop off trailing spaces.
 914      */
 915
 916     while (isspace(end[-1])) {
 917         end--;
 918     }
 919     c = *end;
 920     *end = 0;
 921     Tcl_SetResult(interp, begin, TCL_VOLATILE);
 922     *end = c;
 923     return TCL_OK;
 924 }
 925 \f
 926 /*
 927  *----------------------------------------------------------------------
 928  *
 929  * Tcl_LreplaceCmd --
 930  *
 931  *      This procedure is invoked to process the "lreplace" Tcl command.
 932  *      See the user documentation for details on what it does.
 933  *
 934  * Results:
 935  *      A standard Tcl result.
 936  *
 937  * Side effects:
 938  *      See the user documentation.
 939  *
 940  *----------------------------------------------------------------------
 941  */
 942
 943         /* ARGSUSED */
 944 int
 945 Tcl_LreplaceCmd(notUsed, interp, argc, argv)
 946     ClientData notUsed;                 /* Not used. */
 947     Tcl_Interp *interp;                 /* Current interpreter. */
 948     int argc;                           /* Number of arguments. */
 949     char **argv;                        /* Argument strings. */
 950 {
 951     char *p1, *p2, *element, savedChar, *dummy;
 952     int i, first, last, count, result, size;
 953
 954     if (argc < 4) {
 955         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 956                 " list first last ?element element ...?\"", (char *) NULL);
 957         return TCL_ERROR;
 958     }
 959     if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
 960         return TCL_ERROR;
 961     }
 962     if (TclGetListIndex(interp, argv[3], &last) != TCL_OK) {
 963         return TCL_ERROR;
 964     }
 965     if (first < 0) {
 966         first = 0;
 967     }
 968     if (last < 0) {
 969         last = 0;
 970     }
 971     if (first > last) {
 972         Tcl_AppendResult(interp, "first index must not be greater than second",
 973                 (char *) NULL);
 974         return TCL_ERROR;
 975     }
 976
 977     /*
 978      * Skip over the elements of the list before "first".
 979      */
 980
 981     size = 0;
 982     element = argv[1];
 983     for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) {
 984         result = TclFindElement(interp, p1, &element, &p1, &size,
 985                                 (int *) NULL);
 986         if (result != TCL_OK) {
 987             return result;
 988         }
 989     }
 990     if (*p1 == 0) {
 991         Tcl_AppendResult(interp, "list doesn't contain element ",
 992                 argv[2], (char *) NULL);
 993         return TCL_ERROR;
 994     }
 995
 996     /*
 997      * Skip over the elements of the list up through "last".
 998      */
 999
1000     for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) {
1001         result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL,
1002                 (int *) NULL);
1003         if (result != TCL_OK) {
1004             return result;
1005         }
1006     }
1007
1008     /*
1009      * Add the elements before "first" to the result.  Be sure to
1010      * include quote or brace characters that might terminate the
1011      * last of these elements.
1012      */
1013
1014     p1 = element+size;
1015     if (element != argv[1]) {
1016         while ((*p1 != 0) && !isspace(*p1)) {
1017             p1++;
1018         }
1019     }
1020     savedChar = *p1;
1021     *p1 = 0;
1022     Tcl_AppendResult(interp, argv[1], (char *) NULL);
1023     *p1 = savedChar;
1024
1025     /*
1026      * Add the new list elements.
1027      */
1028
1029     for (i = 4; i < argc; i++) {
1030         Tcl_AppendElement(interp, argv[i], 0);
1031     }
1032
1033     /*
1034      * Append the remainder of the original list.
1035      */
1036
1037     if (*p2 != 0) {
1038         if (*interp->result == 0) {
1039             Tcl_SetResult(interp, p2, TCL_VOLATILE);
1040         } else {
1041             Tcl_AppendResult(interp, " ", p2, (char *) NULL);
1042         }
1043     }
1044     return TCL_OK;
1045 }
1046 \f
1047 /*
1048  *----------------------------------------------------------------------
1049  *
1050  * Tcl_LsearchCmd --
1051  *
1052  *      This procedure is invoked to process the "lsearch" Tcl command.
1053  *      See the user documentation for details on what it does.
1054  *
1055  * Results:
1056  *      A standard Tcl result.
1057  *
1058  * Side effects:
1059  *      See the user documentation.
1060  *
1061  *----------------------------------------------------------------------
1062  */
1063
1064         /* ARGSUSED */
1065 int
1066 Tcl_LsearchCmd(notUsed, interp, argc, argv)
1067     ClientData notUsed;                 /* Not used. */
1068     Tcl_Interp *interp;                 /* Current interpreter. */
1069     int argc;                           /* Number of arguments. */
1070     char **argv;                        /* Argument strings. */
1071 {
1072     int listArgc;
1073     char **listArgv;
1074     int i, match;
1075
1076     if (argc != 3) {
1077         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1078                 " list pattern\"", (char *) NULL);
1079         return TCL_ERROR;
1080     }
1081     if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
1082         return TCL_ERROR;
1083     }
1084     match = -1;
1085     for (i = 0; i < listArgc; i++) {
1086         if (Tcl_StringMatch(listArgv[i], argv[2])) {
1087             match = i;
1088             break;
1089         }
1090     }
1091     sprintf(interp->result, "%d", match);
1092     ckfree((char *) listArgv);
1093     return TCL_OK;
1094 }
1095 \f
1096 /*
1097  *----------------------------------------------------------------------
1098  *
1099  * Tcl_LsortCmd --
1100  *
1101  *      This procedure is invoked to process the "lsort" Tcl command.
1102  *      See the user documentation for details on what it does.
1103  *
1104  * Results:
1105  *      A standard Tcl result.
1106  *
1107  * Side effects:
1108  *      See the user documentation.
1109  *
1110  *----------------------------------------------------------------------
1111  */
1112
1113         /* ARGSUSED */
1114 int
1115 Tcl_LsortCmd(notUsed, interp, argc, argv)
1116     ClientData notUsed;                 /* Not used. */
1117     Tcl_Interp *interp;                 /* Current interpreter. */
1118     int argc;                           /* Number of arguments. */
1119     char **argv;                        /* Argument strings. */
1120 {
1121     int listArgc;
1122     char **listArgv;
1123
1124     if (argc != 2) {
1125         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1126                 " list\"", (char *) NULL);
1127         return TCL_ERROR;
1128     }
1129     if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
1130         return TCL_ERROR;
1131     }
1132     qsort((VOID *) listArgv, listArgc, sizeof (char *), SortCompareProc);
1133     interp->result = Tcl_Merge(listArgc, listArgv);
1134     interp->freeProc = (Tcl_FreeProc *) free;
1135     ckfree((char *) listArgv);
1136     return TCL_OK;
1137 }
1138
1139 /*
1140  * The procedure below is called back by qsort to determine
1141  * the proper ordering between two elements.
1142  */
1143
1144 static int
1145 SortCompareProc(first, second)
1146     CONST VOID *first, *second;         /* Elements to be compared. */
1147 {
1148     return strcmp(*((char **) first), *((char **) second));
1149 }