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