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