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