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