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

   1 /*
   2  * tclCmdAH.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  *      A to H.
   7  *
   8  * Copyright 1987-1991 Regents of the University of California
   9  * Permission to use, copy, modify, and distribute this
  10  * software and its documentation for any purpose and without
  11  * fee is hereby granted, provided that the above copyright
  12  * notice appear in all copies.  The University of California
  13  * makes no representations about the suitability of this
  14  * software for any purpose.  It is provided "as is" without
  15  * express or implied warranty.
  16  */
  17
  18 #ifndef lint
  19 static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdAH.c,v 1.76 92/07/06 09:49:41 ouster Exp $ SPRITE (Berkeley)";
  20 #endif
  21
  22 #include "tclint.h"
  23
  24 \f
  25 /*
  26  *----------------------------------------------------------------------
  27  *
  28  * Tcl_BreakCmd --
  29  *
  30  *      This procedure is invoked to process the "break" Tcl command.
  31  *      See the user documentation for details on what it does.
  32  *
  33  * Results:
  34  *      A standard Tcl result.
  35  *
  36  * Side effects:
  37  *      See the user documentation.
  38  *
  39  *----------------------------------------------------------------------
  40  */
  41
  42         /* ARGSUSED */
  43 int
  44 Tcl_BreakCmd(dummy, interp, argc, argv)
  45     ClientData dummy;                   /* Not used. */
  46     Tcl_Interp *interp;                 /* Current interpreter. */
  47     int argc;                           /* Number of arguments. */
  48     char **argv;                        /* Argument strings. */
  49 {
  50     if (argc != 1) {
  51         Tcl_AppendResult(interp, "wrong # args: should be \"",
  52                 argv[0], "\"", (char *) NULL);
  53         return TCL_ERROR;
  54     }
  55     return TCL_BREAK;
  56 }
  57 \f
  58 /*
  59  *----------------------------------------------------------------------
  60  *
  61  * Tcl_CaseCmd --
  62  *
  63  *      This procedure is invoked to process the "case" Tcl command.
  64  *      See the user documentation for details on what it does.
  65  *
  66  * Results:
  67  *      A standard Tcl result.
  68  *
  69  * Side effects:
  70  *      See the user documentation.
  71  *
  72  *----------------------------------------------------------------------
  73  */
  74
  75         /* ARGSUSED */
  76 int
  77 Tcl_CaseCmd(dummy, interp, argc, argv)
  78     ClientData dummy;                   /* Not used. */
  79     Tcl_Interp *interp;                 /* Current interpreter. */
  80     int argc;                           /* Number of arguments. */
  81     char **argv;                        /* Argument strings. */
  82 {
  83     int i, result;
  84     int body;
  85     char *string;
  86     int caseArgc, splitArgs;
  87     char **caseArgv;
  88
  89     if (argc < 3) {
  90         Tcl_AppendResult(interp, "wrong # args: should be \"",
  91                 argv[0], " string ?in? patList body ... ?default body?\"",
  92                 (char *) NULL);
  93         return TCL_ERROR;
  94     }
  95     string = argv[1];
  96     body = -1;
  97     if (strcmp(argv[2], "in") == 0) {
  98         i = 3;
  99     } else {
 100         i = 2;
 101     }
 102     caseArgc = argc - i;
 103     caseArgv = argv + i;
 104
 105     /*
 106      * If all of the pattern/command pairs are lumped into a single
 107      * argument, split them out again.
 108      */
 109
 110     splitArgs = 0;
 111     if (caseArgc == 1) {
 112         result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv);
 113         if (result != TCL_OK) {
 114             return result;
 115         }
 116         splitArgs = 1;
 117     }
 118
 119     for (i = 0; i < caseArgc; i += 2) {
 120         int patArgc, j;
 121         char **patArgv;
 122         register char *p;
 123
 124         if (i == (caseArgc-1)) {
 125             interp->result = "extra case pattern with no body";
 126             result = TCL_ERROR;
 127             goto cleanup;
 128         }
 129
 130         /*
 131          * Check for special case of single pattern (no list) with
 132          * no backslash sequences.
 133          */
 134
 135         for (p = caseArgv[i]; *p != 0; p++) {
 136             if (isspace(*p) || (*p == '\\')) {
 137                 break;
 138             }
 139         }
 140         if (*p == 0) {
 141             if ((*caseArgv[i] == 'd')
 142                     && (strcmp(caseArgv[i], "default") == 0)) {
 143                 body = i+1;
 144             }
 145             if (Tcl_StringMatch(string, caseArgv[i])) {
 146                 body = i+1;
 147                 goto match;
 148             }
 149             continue;
 150         }
 151
 152         /*
 153          * Break up pattern lists, then check each of the patterns
 154          * in the list.
 155          */
 156
 157         result = Tcl_SplitList(interp, caseArgv[i], &patArgc, &patArgv);
 158         if (result != TCL_OK) {
 159             goto cleanup;
 160         }
 161         for (j = 0; j < patArgc; j++) {
 162             if (Tcl_StringMatch(string, patArgv[j])) {
 163                 body = i+1;
 164                 break;
 165             }
 166         }
 167         ckfree((char *) patArgv);
 168         if (j < patArgc) {
 169             break;
 170         }
 171     }
 172
 173     match:
 174     if (body != -1) {
 175         result = Tcl_Eval(interp, caseArgv[body], 0, (char **) NULL);
 176         if (result == TCL_ERROR) {
 177             char msg[100];
 178             sprintf(msg, "\n    (\"%.50s\" arm line %d)", caseArgv[body-1],
 179                     interp->errorLine);
 180             Tcl_AddErrorInfo(interp, msg);
 181         }
 182         goto cleanup;
 183     }
 184
 185     /*
 186      * Nothing matched:  return nothing.
 187      */
 188
 189     result = TCL_OK;
 190
 191     cleanup:
 192     if (splitArgs) {
 193         ckfree((char *) caseArgv);
 194     }
 195     return result;
 196 }
 197 \f
 198 /*
 199  *----------------------------------------------------------------------
 200  *
 201  * Tcl_CatchCmd --
 202  *
 203  *      This procedure is invoked to process the "catch" Tcl command.
 204  *      See the user documentation for details on what it does.
 205  *
 206  * Results:
 207  *      A standard Tcl result.
 208  *
 209  * Side effects:
 210  *      See the user documentation.
 211  *
 212  *----------------------------------------------------------------------
 213  */
 214
 215         /* ARGSUSED */
 216 int
 217 Tcl_CatchCmd(dummy, interp, argc, argv)
 218     ClientData dummy;                   /* Not used. */
 219     Tcl_Interp *interp;                 /* Current interpreter. */
 220     int argc;                           /* Number of arguments. */
 221     char **argv;                        /* Argument strings. */
 222 {
 223     int result;
 224
 225     if ((argc != 2) && (argc != 3)) {
 226         Tcl_AppendResult(interp, "wrong # args: should be \"",
 227                 argv[0], " command ?varName?\"", (char *) NULL);
 228         return TCL_ERROR;
 229     }
 230     result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
 231     if (argc == 3) {
 232         if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) {
 233             Tcl_SetResult(interp, "couldn't save command result in variable",
 234                     TCL_STATIC);
 235             return TCL_ERROR;
 236         }
 237     }
 238     Tcl_ResetResult(interp);
 239     sprintf(interp->result, "%d", result);
 240     return TCL_OK;
 241 }
 242 \f
 243 /*
 244  *----------------------------------------------------------------------
 245  *
 246  * Tcl_ConcatCmd --
 247  *
 248  *      This procedure is invoked to process the "concat" Tcl command.
 249  *      See the user documentation for details on what it does.
 250  *
 251  * Results:
 252  *      A standard Tcl result.
 253  *
 254  * Side effects:
 255  *      See the user documentation.
 256  *
 257  *----------------------------------------------------------------------
 258  */
 259
 260         /* ARGSUSED */
 261 int
 262 Tcl_ConcatCmd(dummy, interp, argc, argv)
 263     ClientData dummy;                   /* Not used. */
 264     Tcl_Interp *interp;                 /* Current interpreter. */
 265     int argc;                           /* Number of arguments. */
 266     char **argv;                        /* Argument strings. */
 267 {
 268     if (argc == 1) {
 269         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 270                 " arg ?arg ...?\"", (char *) NULL);
 271         return TCL_ERROR;
 272     }
 273
 274     interp->result = Tcl_Concat(argc-1, argv+1);
 275     interp->freeProc = (Tcl_FreeProc *) free;
 276     return TCL_OK;
 277 }
 278 \f
 279 /*
 280  *----------------------------------------------------------------------
 281  *
 282  * Tcl_ContinueCmd --
 283  *
 284  *      This procedure is invoked to process the "continue" Tcl command.
 285  *      See the user documentation for details on what it does.
 286  *
 287  * Results:
 288  *      A standard Tcl result.
 289  *
 290  * Side effects:
 291  *      See the user documentation.
 292  *
 293  *----------------------------------------------------------------------
 294  */
 295
 296         /* ARGSUSED */
 297 int
 298 Tcl_ContinueCmd(dummy, interp, argc, argv)
 299     ClientData dummy;                   /* Not used. */
 300     Tcl_Interp *interp;                 /* Current interpreter. */
 301     int argc;                           /* Number of arguments. */
 302     char **argv;                        /* Argument strings. */
 303 {
 304     if (argc != 1) {
 305         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 306                 "\"", (char *) NULL);
 307         return TCL_ERROR;
 308     }
 309     return TCL_CONTINUE;
 310 }
 311 \f
 312 /*
 313  *----------------------------------------------------------------------
 314  *
 315  * Tcl_ErrorCmd --
 316  *
 317  *      This procedure is invoked to process the "error" Tcl command.
 318  *      See the user documentation for details on what it does.
 319  *
 320  * Results:
 321  *      A standard Tcl result.
 322  *
 323  * Side effects:
 324  *      See the user documentation.
 325  *
 326  *----------------------------------------------------------------------
 327  */
 328
 329         /* ARGSUSED */
 330 int
 331 Tcl_ErrorCmd(dummy, interp, argc, argv)
 332     ClientData dummy;                   /* Not used. */
 333     Tcl_Interp *interp;                 /* Current interpreter. */
 334     int argc;                           /* Number of arguments. */
 335     char **argv;                        /* Argument strings. */
 336 {
 337     Interp *iPtr = (Interp *) interp;
 338
 339     if ((argc < 2) || (argc > 4)) {
 340         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 341                 " message ?errorInfo? ?errorCode?\"", (char *) NULL);
 342         return TCL_ERROR;
 343     }
 344     if ((argc >= 3) && (argv[2][0] != 0)) {
 345         Tcl_AddErrorInfo(interp, argv[2]);
 346         iPtr->flags |= ERR_ALREADY_LOGGED;
 347     }
 348     if (argc == 4) {
 349         Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3],
 350                 TCL_GLOBAL_ONLY);
 351         iPtr->flags |= ERROR_CODE_SET;
 352     }
 353     Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
 354     return TCL_ERROR;
 355 }
 356 \f
 357 /*
 358  *----------------------------------------------------------------------
 359  *
 360  * Tcl_EvalCmd --
 361  *
 362  *      This procedure is invoked to process the "eval" Tcl command.
 363  *      See the user documentation for details on what it does.
 364  *
 365  * Results:
 366  *      A standard Tcl result.
 367  *
 368  * Side effects:
 369  *      See the user documentation.
 370  *
 371  *----------------------------------------------------------------------
 372  */
 373
 374         /* ARGSUSED */
 375 int
 376 Tcl_EvalCmd(dummy, interp, argc, argv)
 377     ClientData dummy;                   /* Not used. */
 378     Tcl_Interp *interp;                 /* Current interpreter. */
 379     int argc;                           /* Number of arguments. */
 380     char **argv;                        /* Argument strings. */
 381 {
 382     int result;
 383     char *cmd;
 384
 385     if (argc < 2) {
 386         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 387                 " arg ?arg ...?\"", (char *) NULL);
 388         return TCL_ERROR;
 389     }
 390     if (argc == 2) {
 391         result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
 392     } else {
 393
 394         /*
 395          * More than one argument:  concatenate them together with spaces
 396          * between, then evaluate the result.
 397          */
 398
 399         cmd = Tcl_Concat(argc-1, argv+1);
 400         result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
 401         ckfree(cmd);
 402     }
 403     if (result == TCL_ERROR) {
 404         char msg[60];
 405         sprintf(msg, "\n    (\"eval\" body line %d)", interp->errorLine);
 406         Tcl_AddErrorInfo(interp, msg);
 407     }
 408     return result;
 409 }
 410 \f
 411 /*
 412  *----------------------------------------------------------------------
 413  *
 414  * Tcl_ExprCmd --
 415  *
 416  *      This procedure is invoked to process the "expr" Tcl command.
 417  *      See the user documentation for details on what it does.
 418  *
 419  * Results:
 420  *      A standard Tcl result.
 421  *
 422  * Side effects:
 423  *      See the user documentation.
 424  *
 425  *----------------------------------------------------------------------
 426  */
 427
 428         /* ARGSUSED */
 429 int
 430 Tcl_ExprCmd(dummy, interp, argc, argv)
 431     ClientData dummy;                   /* Not used. */
 432     Tcl_Interp *interp;                 /* Current interpreter. */
 433     int argc;                           /* Number of arguments. */
 434     char **argv;                        /* Argument strings. */
 435 {
 436     if (argc != 2) {
 437         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 438                 " expression\"", (char *) NULL);
 439         return TCL_ERROR;
 440     }
 441
 442     return Tcl_ExprString(interp, argv[1]);
 443 }
 444 \f
 445 /*
 446  *----------------------------------------------------------------------
 447  *
 448  * Tcl_ForCmd --
 449  *
 450  *      This procedure is invoked to process the "for" Tcl command.
 451  *      See the user documentation for details on what it does.
 452  *
 453  * Results:
 454  *      A standard Tcl result.
 455  *
 456  * Side effects:
 457  *      See the user documentation.
 458  *
 459  *----------------------------------------------------------------------
 460  */
 461
 462         /* ARGSUSED */
 463 int
 464 Tcl_ForCmd(dummy, interp, argc, argv)
 465     ClientData dummy;                   /* Not used. */
 466     Tcl_Interp *interp;                 /* Current interpreter. */
 467     int argc;                           /* Number of arguments. */
 468     char **argv;                        /* Argument strings. */
 469 {
 470     int result, value;
 471
 472     if (argc != 5) {
 473         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 474                 " start test next command\"", (char *) NULL);
 475         return TCL_ERROR;
 476     }
 477
 478     result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
 479     if (result != TCL_OK) {
 480         if (result == TCL_ERROR) {
 481             Tcl_AddErrorInfo(interp, "\n    (\"for\" initial command)");
 482         }
 483         return result;
 484     }
 485     while (1) {
 486         result = Tcl_ExprBoolean(interp, argv[2], &value);
 487         if (result != TCL_OK) {
 488             return result;
 489         }
 490         if (!value) {
 491             break;
 492         }
 493         result = Tcl_Eval(interp, argv[4], 0, (char **) NULL);
 494         if (result == TCL_CONTINUE) {
 495             result = TCL_OK;
 496         } else if (result != TCL_OK) {
 497             if (result == TCL_ERROR) {
 498                 char msg[60];
 499                 sprintf(msg, "\n    (\"for\" body line %d)", interp->errorLine);
 500                 Tcl_AddErrorInfo(interp, msg);
 501             }
 502             break;
 503         }
 504         result = Tcl_Eval(interp, argv[3], 0, (char **) NULL);
 505         if (result == TCL_BREAK) {
 506             break;
 507         } else if (result != TCL_OK) {
 508             if (result == TCL_ERROR) {
 509                 Tcl_AddErrorInfo(interp, "\n    (\"for\" loop-end command)");
 510             }
 511             return result;
 512         }
 513     }
 514     if (result == TCL_BREAK) {
 515         result = TCL_OK;
 516     }
 517     if (result == TCL_OK) {
 518         Tcl_ResetResult(interp);
 519     }
 520     return result;
 521 }
 522 \f
 523 /*
 524  *----------------------------------------------------------------------
 525  *
 526  * Tcl_ForeachCmd --
 527  *
 528  *      This procedure is invoked to process the "foreach" Tcl command.
 529  *      See the user documentation for details on what it does.
 530  *
 531  * Results:
 532  *      A standard Tcl result.
 533  *
 534  * Side effects:
 535  *      See the user documentation.
 536  *
 537  *----------------------------------------------------------------------
 538  */
 539
 540         /* ARGSUSED */
 541 int
 542 Tcl_ForeachCmd(dummy, interp, argc, argv)
 543     ClientData dummy;                   /* Not used. */
 544     Tcl_Interp *interp;                 /* Current interpreter. */
 545     int argc;                           /* Number of arguments. */
 546     char **argv;                        /* Argument strings. */
 547 {
 548     int listArgc, i, result;
 549     char **listArgv;
 550
 551     if (argc != 4) {
 552         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 553                 " varName list command\"", (char *) NULL);
 554         return TCL_ERROR;
 555     }
 556
 557     /*
 558      * Break the list up into elements, and execute the command once
 559      * for each value of the element.
 560      */
 561
 562     result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv);
 563     if (result != TCL_OK) {
 564         return result;
 565     }
 566     for (i = 0; i < listArgc; i++) {
 567         if (Tcl_SetVar(interp, argv[1], listArgv[i], 0) == NULL) {
 568             Tcl_SetResult(interp, "couldn't set loop variable", TCL_STATIC);
 569             result = TCL_ERROR;
 570             break;
 571         }
 572
 573         result = Tcl_Eval(interp, argv[3], 0, (char **) NULL);
 574         if (result != TCL_OK) {
 575             if (result == TCL_CONTINUE) {
 576                 result = TCL_OK;
 577             } else if (result == TCL_BREAK) {
 578                 result = TCL_OK;
 579                 break;
 580             } else if (result == TCL_ERROR) {
 581                 char msg[100];
 582                 sprintf(msg, "\n    (\"foreach\" body line %d)",
 583                         interp->errorLine);
 584                 Tcl_AddErrorInfo(interp, msg);
 585                 break;
 586             } else {
 587                 break;
 588             }
 589         }
 590     }
 591     ckfree((char *) listArgv);
 592     if (result == TCL_OK) {
 593         Tcl_ResetResult(interp);
 594     }
 595     return result;
 596 }
 597 \f
 598 /*
 599  *----------------------------------------------------------------------
 600  *
 601  * Tcl_FormatCmd --
 602  *
 603  *      This procedure is invoked to process the "format" Tcl command.
 604  *      See the user documentation for details on what it does.
 605  *
 606  * Results:
 607  *      A standard Tcl result.
 608  *
 609  * Side effects:
 610  *      See the user documentation.
 611  *
 612  *----------------------------------------------------------------------
 613  */
 614
 615         /* ARGSUSED */
 616 int
 617 Tcl_FormatCmd(dummy, interp, argc, argv)
 618     ClientData dummy;                   /* Not used. */
 619     Tcl_Interp *interp;                 /* Current interpreter. */
 620     int argc;                           /* Number of arguments. */
 621     char **argv;                        /* Argument strings. */
 622 {
 623     register char *format;      /* Used to read characters from the format
 624                                  * string. */
 625     char newFormat[40];         /* A new format specifier is generated here. */
 626     int width;                  /* Field width from field specifier, or 0 if
 627                                  * no width given. */
 628     int precision;              /* Field precision from field specifier, or 0
 629                                  * if no precision given. */
 630     int size;                   /* Number of bytes needed for result of
 631                                  * conversion, based on type of conversion
 632                                  * ("e", "s", etc.) and width from above. */
 633     char *oneWordValue = NULL;  /* Used to hold value to pass to sprintf, if
 634                                  * it's a one-word value. */
 635     double twoWordValue;        /* Used to hold value to pass to sprintf if
 636                                  * it's a two-word value. */
 637     int useTwoWords;            /* 0 means use oneWordValue, 1 means use
 638                                  * twoWordValue. */
 639     char *dst = interp->result; /* Where result is stored.  Starts off at
 640                                  * interp->resultSpace, but may get dynamically
 641                                  * re-allocated if this isn't enough. */
 642     int dstSize = 0;            /* Number of non-null characters currently
 643                                  * stored at dst. */
 644     int dstSpace = TCL_RESULT_SIZE;
 645                                 /* Total amount of storage space available
 646                                  * in dst (not including null terminator. */
 647     int noPercent;              /* Special case for speed:  indicates there's
 648                                  * no field specifier, just a string to copy. */
 649     char **curArg;              /* Remainder of argv array. */
 650     int useShort;               /* Value to be printed is short (half word). */
 651
 652     /*
 653      * This procedure is a bit nasty.  The goal is to use sprintf to
 654      * do most of the dirty work.  There are several problems:
 655      * 1. this procedure can't trust its arguments.
 656      * 2. we must be able to provide a large enough result area to hold
 657      *    whatever's generated.  This is hard to estimate.
 658      * 2. there's no way to move the arguments from argv to the call
 659      *    to sprintf in a reasonable way.  This is particularly nasty
 660      *    because some of the arguments may be two-word values (doubles).
 661      * So, what happens here is to scan the format string one % group
 662      * at a time, making many individual calls to sprintf.
 663      */
 664
 665     if (argc < 2) {
 666         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 667                 " formatString ?arg arg ...?\"", (char *) NULL);
 668         return TCL_ERROR;
 669     }
 670     curArg = argv+2;
 671     argc -= 2;
 672     for (format = argv[1]; *format != 0; ) {
 673         register char *newPtr = newFormat;
 674
 675         width = precision = useTwoWords = noPercent = useShort = 0;
 676
 677         /*
 678          * Get rid of any characters before the next field specifier.
 679          * Collapse backslash sequences found along the way.
 680          */
 681
 682         if (*format != '%') {
 683             register char *p;
 684             int bsSize;
 685
 686             oneWordValue = p = format;
 687             while ((*format != '%') && (*format != 0)) {
 688                 if (*format == '\\') {
 689                     *p = Tcl_Backslash(format, &bsSize);
 690                     if (*p != 0) {
 691                         p++;
 692                     }
 693                     format += bsSize;
 694                 } else {
 695                     *p = *format;
 696                     p++;
 697                     format++;
 698                 }
 699             }
 700             size = p - oneWordValue;
 701             noPercent = 1;
 702             goto doField;
 703         }
 704
 705         if (format[1] == '%') {
 706             oneWordValue = format;
 707             size = 1;
 708             noPercent = 1;
 709             format += 2;
 710             goto doField;
 711         }
 712
 713         /*
 714          * Parse off a field specifier, compute how many characters
 715          * will be needed to store the result, and substitute for
 716          * "*" size specifiers.
 717          */
 718
 719         *newPtr = '%';
 720         newPtr++;
 721         format++;
 722         while ((*format == '-') || (*format == '#')) {
 723             *newPtr = *format;
 724             newPtr++;
 725             format++;
 726         }
 727         if (*format == '0') {
 728             *newPtr = '0';
 729             newPtr++;
 730             format++;
 731         }
 732         if (isdigit(*format)) {
 733             width = atoi(format);
 734             do {
 735                 format++;
 736             } while (isdigit(*format));
 737         } else if (*format == '*') {
 738             if (argc <= 0) {
 739                 goto notEnoughArgs;
 740             }
 741             if (Tcl_GetInt(interp, *curArg, &width) != TCL_OK) {
 742                 goto fmtError;
 743             }
 744             argc--;
 745             curArg++;
 746             format++;
 747         }
 748         if (width != 0) {
 749             sprintf(newPtr, "%d", width);
 750             while (*newPtr != 0) {
 751                 newPtr++;
 752             }
 753         }
 754         if (*format == '.') {
 755             *newPtr = '.';
 756             newPtr++;
 757             format++;
 758         }
 759         if (isdigit(*format)) {
 760             precision = atoi(format);
 761             do {
 762                 format++;
 763             } while (isdigit(*format));
 764         } else if (*format == '*') {
 765             if (argc <= 0) {
 766                 goto notEnoughArgs;
 767             }
 768             if (Tcl_GetInt(interp, *curArg, &precision) != TCL_OK) {
 769                 goto fmtError;
 770             }
 771             argc--;
 772             curArg++;
 773             format++;
 774         }
 775         if (precision != 0) {
 776             sprintf(newPtr, "%d", precision);
 777             while (*newPtr != 0) {
 778                 newPtr++;
 779             }
 780         }
 781         if (*format == 'l') {
 782             format++;
 783         } else if (*format == 'h') {
 784             useShort = 1;
 785             *newPtr = 'h';
 786             newPtr++;
 787             format++;
 788         }
 789         *newPtr = *format;
 790         newPtr++;
 791         *newPtr = 0;
 792         if (argc <= 0) {
 793             goto notEnoughArgs;
 794         }
 795         switch (*format) {
 796             case 'D':
 797             case 'O':
 798             case 'U':
 799                 if (!useShort) {
 800                     newPtr++;
 801                 } else {
 802                     useShort = 0;
 803                 }
 804                 newPtr[-1] = tolower(*format);
 805                 newPtr[-2] = 'l';
 806                 *newPtr = 0;
 807             case 'd':
 808             case 'o':
 809             case 'u':
 810             case 'x':
 811             case 'X':
 812                 if (Tcl_GetInt(interp, *curArg, (int *) &oneWordValue)
 813                         != TCL_OK) {
 814                     goto fmtError;
 815                 }
 816                 size = 40;
 817                 break;
 818             case 's':
 819                 oneWordValue = *curArg;
 820                 size = strlen(*curArg);
 821                 break;
 822             case 'c':
 823                 if (Tcl_GetInt(interp, *curArg, (int *) &oneWordValue)
 824                         != TCL_OK) {
 825                     goto fmtError;
 826                 }
 827                 size = 1;
 828                 break;
 829             case 'F':
 830                 newPtr[-1] = tolower(newPtr[-1]);
 831             case 'e':
 832             case 'E':
 833             case 'f':
 834             case 'g':
 835             case 'G':
 836                 if (Tcl_GetDouble(interp, *curArg, &twoWordValue) != TCL_OK) {
 837                     goto fmtError;
 838                 }
 839                 useTwoWords = 1;
 840                 size = 320;
 841                 if (precision > 10) {
 842                     size += precision;
 843                 }
 844                 break;
 845             case 0:
 846                 interp->result =
 847                         "format string ended in middle of field specifier";
 848                 goto fmtError;
 849             default:
 850                 sprintf(interp->result, "bad field specifier \"%c\"", *format);
 851                 goto fmtError;
 852         }
 853         argc--;
 854         curArg++;
 855         format++;
 856
 857         /*
 858          * Make sure that there's enough space to hold the formatted
 859          * result, then format it.
 860          */
 861
 862         doField:
 863         if (width > size) {
 864             size = width;
 865         }
 866         if ((dstSize + size) > dstSpace) {
 867             char *newDst;
 868             int newSpace;
 869
 870             newSpace = 2*(dstSize + size);
 871             newDst = (char *) ckalloc((unsigned) newSpace+1);
 872             if (dstSize != 0) {
 873                 memcpy((VOID *) newDst, (VOID *) dst, dstSize);
 874             }
 875             if (dstSpace != TCL_RESULT_SIZE) {
 876                 ckfree(dst);
 877             }
 878             dst = newDst;
 879             dstSpace = newSpace;
 880         }
 881         if (noPercent) {
 882             memcpy((VOID *) (dst+dstSize), (VOID *) oneWordValue, size);
 883             dstSize += size;
 884             dst[dstSize] = 0;
 885         } else {
 886             if (useTwoWords) {
 887                 sprintf(dst+dstSize, newFormat, twoWordValue);
 888             } else if (useShort) {
 889                 int tmp = (int)oneWordValue;
 890                 sprintf(dst+dstSize, newFormat, (short)tmp);
 891             } else {
 892                 sprintf(dst+dstSize, newFormat, oneWordValue);
 893             }
 894             dstSize += strlen(dst+dstSize);
 895         }
 896     }
 897
 898     interp->result = dst;
 899     if (dstSpace != TCL_RESULT_SIZE) {
 900         interp->freeProc = (Tcl_FreeProc *) free;
 901     } else {
 902         interp->freeProc = 0;
 903     }
 904     return TCL_OK;
 905
 906     notEnoughArgs:
 907     interp->result = "not enough arguments for all format specifiers";
 908     fmtError:
 909     if (dstSpace != TCL_RESULT_SIZE) {
 910         ckfree(dst);
 911     }
 912     return TCL_ERROR;
 913 }