home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / generic / tclCompile.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  250.5 KB  |  7,829 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tclCompile.c --
  3.  *
  4.  *    This file contains procedures that compile Tcl commands or parts
  5.  *    of commands (like quoted strings or nested sub-commands) into a
  6.  *    sequence of instructions ("bytecodes"). 
  7.  *
  8.  * Copyright (c) 1996-1997 Sun Microsystems, Inc.
  9.  *
  10.  * See the file "license.terms" for information on usage and redistribution
  11.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12.  *
  13.  * SCCS: @(#) tclCompile.c 1.76 97/08/12 13:35:43
  14.  */
  15.  
  16. #include "tclInt.h"
  17. #include "tclCompile.h"
  18.  
  19. /*
  20.  * Variable that controls whether compilation tracing is enabled and, if so,
  21.  * what level of tracing is desired:
  22.  *    0: no compilation tracing
  23.  *    1: summarize compilation of top level cmds and proc bodies
  24.  *    2: display all instructions of each ByteCode compiled
  25.  * This variable is linked to the Tcl variable "tcl_traceCompile".
  26.  */
  27.  
  28. int tclTraceCompile = 0;
  29. static int traceInitialized = 0;
  30.  
  31. /*
  32.  * Count of the number of compilations and various other compilation-
  33.  * related statistics.
  34.  */
  35.  
  36. #ifdef TCL_COMPILE_STATS
  37. long tclNumCompilations = 0;
  38. double tclTotalSourceBytes = 0.0;
  39. double tclTotalCodeBytes = 0.0;
  40.  
  41. double tclTotalInstBytes = 0.0;
  42. double tclTotalObjBytes = 0.0;
  43. double tclTotalExceptBytes = 0.0;
  44. double tclTotalAuxBytes = 0.0;
  45. double tclTotalCmdMapBytes = 0.0;
  46.  
  47. double tclCurrentSourceBytes = 0.0;
  48. double tclCurrentCodeBytes = 0.0;
  49.  
  50. int tclSourceCount[32];
  51. int tclByteCodeCount[32];
  52. #endif /* TCL_COMPILE_STATS */
  53.  
  54. /*
  55.  * A table describing the Tcl bytecode instructions. The entries in this
  56.  * table must correspond to the list of instructions in tclInt.h. The names
  57.  * "op1" and "op4" refer to an instruction's one or four byte first operand.
  58.  * Similarly, "stktop" and "stknext" refer to the topmost and next to
  59.  * topmost stack elements.
  60.  *
  61.  * Note that the load, store, and incr instructions do not distinguish local
  62.  * from global variables; the bytecode interpreter at runtime uses the
  63.  * existence of a procedure call frame to distinguish these.
  64.  */
  65.  
  66. InstructionDesc instructionTable[] = {
  67.    /* Name          Bytes #Opnds Operand types        Stack top, next   */
  68.     {"done",              1,   0,   {OPERAND_NONE}},
  69.         /* Finish ByteCode execution and return stktop (top stack item) */
  70.     {"push1",              2,   1,   {OPERAND_UINT1}},
  71.         /* Push object at ByteCode objArray[op1] */
  72.     {"push4",              5,   1,   {OPERAND_UINT4}},
  73.         /* Push object at ByteCode objArray[op4] */
  74.     {"pop",              1,   0,   {OPERAND_NONE}},
  75.         /* Pop the topmost stack object */
  76.     {"dup",              1,   0,   {OPERAND_NONE}},
  77.         /* Duplicate the topmost stack object and push the result */
  78.     {"concat1",              2,   1,   {OPERAND_UINT1}},
  79.         /* Concatenate the top op1 items and push result */
  80.     {"invokeStk1",        2,   1,   {OPERAND_UINT1}},
  81.         /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */
  82.     {"invokeStk4",        5,   1,   {OPERAND_UINT4}},
  83.         /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
  84.     {"evalStk",           1,   0,   {OPERAND_NONE}},
  85.         /* Evaluate command in stktop using Tcl_EvalObj. */
  86.     {"exprStk",           1,   0,   {OPERAND_NONE}},
  87.         /* Execute expression in stktop using Tcl_ExprStringObj. */
  88.     
  89.     {"loadScalar1",       2,   1,   {OPERAND_UINT1}},
  90.         /* Load scalar variable at index op1 <= 255 in call frame */
  91.     {"loadScalar4",       5,   1,   {OPERAND_UINT4}},
  92.         /* Load scalar variable at index op1 >= 256 in call frame */
  93.     {"loadScalarStk",     1,   0,   {OPERAND_NONE}},
  94.         /* Load scalar variable; scalar's name is stktop */
  95.     {"loadArray1",        2,   1,   {OPERAND_UINT1}},
  96.         /* Load array element; array at slot op1<=255, element is stktop */
  97.     {"loadArray4",        5,   1,   {OPERAND_UINT4}},
  98.         /* Load array element; array at slot op1 > 255, element is stktop */
  99.     {"loadArrayStk",      1,   0,   {OPERAND_NONE}},
  100.         /* Load array element; element is stktop, array name is stknext */
  101.     {"loadStk",           1,   0,   {OPERAND_NONE}},
  102.         /* Load general variable; unparsed variable name is stktop */
  103.     {"storeScalar1",      2,   1,   {OPERAND_UINT1}},
  104.         /* Store scalar variable at op1<=255 in frame; value is stktop */
  105.     {"storeScalar4",      5,   1,   {OPERAND_UINT4}},
  106.         /* Store scalar variable at op1 > 255 in frame; value is stktop */
  107.     {"storeScalarStk",    1,   0,   {OPERAND_NONE}},
  108.         /* Store scalar; value is stktop, scalar name is stknext */
  109.     {"storeArray1",       2,   1,   {OPERAND_UINT1}},
  110.         /* Store array element; array at op1<=255, value is top then elem */
  111.     {"storeArray4",       5,   1,   {OPERAND_UINT4}},
  112.         /* Store array element; array at op1>=256, value is top then elem */
  113.     {"storeArrayStk",     1,   0,   {OPERAND_NONE}},
  114.         /* Store array element; value is stktop, then elem, array names */
  115.     {"storeStk",          1,   0,   {OPERAND_NONE}},
  116.         /* Store general variable; value is stktop, then unparsed name */
  117.     
  118.     {"incrScalar1",       2,   1,   {OPERAND_UINT1}},
  119.         /* Incr scalar at index op1<=255 in frame; incr amount is stktop */
  120.     {"incrScalarStk",     1,   0,   {OPERAND_NONE}},
  121.         /* Incr scalar; incr amount is stktop, scalar's name is stknext */
  122.     {"incrArray1",        2,   1,   {OPERAND_UINT1}},
  123.         /* Incr array elem; arr at slot op1<=255, amount is top then elem */
  124.     {"incrArrayStk",      1,   0,   {OPERAND_NONE}},
  125.         /* Incr array element; amount is top then elem then array names */
  126.     {"incrStk",           1,   0,   {OPERAND_NONE}},
  127.         /* Incr general variable; amount is stktop then unparsed var name */
  128.     {"incrScalar1Imm",    3,   2,   {OPERAND_UINT1, OPERAND_INT1}},
  129.         /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */
  130.     {"incrScalarStkImm",  2,   1,   {OPERAND_INT1}},
  131.         /* Incr scalar; scalar name is stktop; incr amount is op1 */
  132.     {"incrArray1Imm",     3,   2,   {OPERAND_UINT1, OPERAND_INT1}},
  133.         /* Incr array elem; array at slot op1 <= 255, elem is stktop,
  134.      * amount is 2nd operand byte */
  135.     {"incrArrayStkImm",   2,   1,   {OPERAND_INT1}},
  136.         /* Incr array element; elem is top then array name, amount is op1 */
  137.     {"incrStkImm",        2,   1,   {OPERAND_INT1}},
  138.         /* Incr general variable; unparsed name is top, amount is op1 */
  139.     
  140.     {"jump1",             2,   1,   {OPERAND_INT1}},
  141.         /* Jump relative to (pc + op1) */
  142.     {"jump4",             5,   1,   {OPERAND_INT4}},
  143.         /* Jump relative to (pc + op4) */
  144.     {"jumpTrue1",         2,   1,   {OPERAND_INT1}},
  145.         /* Jump relative to (pc + op1) if stktop expr object is true */
  146.     {"jumpTrue4",         5,   1,   {OPERAND_INT4}},
  147.         /* Jump relative to (pc + op4) if stktop expr object is true */
  148.     {"jumpFalse1",        2,   1,   {OPERAND_INT1}},
  149.         /* Jump relative to (pc + op1) if stktop expr object is false */
  150.     {"jumpFalse4",        5,   1,   {OPERAND_INT4}},
  151.         /* Jump relative to (pc + op4) if stktop expr object is false */
  152.  
  153.     {"lor",               1,   0,   {OPERAND_NONE}},
  154.         /* Logical or:    push (stknext || stktop) */
  155.     {"land",              1,   0,   {OPERAND_NONE}},
  156.         /* Logical and:    push (stknext && stktop) */
  157.     {"bitor",             1,   0,   {OPERAND_NONE}},
  158.         /* Bitwise or:    push (stknext | stktop) */
  159.     {"bitxor",            1,   0,   {OPERAND_NONE}},
  160.         /* Bitwise xor    push (stknext ^ stktop) */
  161.     {"bitand",            1,   0,   {OPERAND_NONE}},
  162.         /* Bitwise and:    push (stknext & stktop) */
  163.     {"eq",                1,   0,   {OPERAND_NONE}},
  164.         /* Equal:    push (stknext == stktop) */
  165.     {"neq",               1,   0,   {OPERAND_NONE}},
  166.         /* Not equal:    push (stknext != stktop) */
  167.     {"lt",                1,   0,   {OPERAND_NONE}},
  168.         /* Less:    push (stknext < stktop) */
  169.     {"gt",                1,   0,   {OPERAND_NONE}},
  170.         /* Greater:    push (stknext || stktop) */
  171.     {"le",                1,   0,   {OPERAND_NONE}},
  172.         /* Logical or:    push (stknext || stktop) */
  173.     {"ge",                1,   0,   {OPERAND_NONE}},
  174.         /* Logical or:    push (stknext || stktop) */
  175.     {"lshift",            1,   0,   {OPERAND_NONE}},
  176.         /* Left shift:    push (stknext << stktop) */
  177.     {"rshift",            1,   0,   {OPERAND_NONE}},
  178.         /* Right shift:    push (stknext >> stktop) */
  179.     {"add",               1,   0,   {OPERAND_NONE}},
  180.         /* Add:        push (stknext + stktop) */
  181.     {"sub",               1,   0,   {OPERAND_NONE}},
  182.         /* Sub:        push (stkext - stktop) */
  183.     {"mult",              1,   0,   {OPERAND_NONE}},
  184.         /* Multiply:    push (stknext * stktop) */
  185.     {"div",               1,   0,   {OPERAND_NONE}},
  186.         /* Divide:    push (stknext / stktop) */
  187.     {"mod",               1,   0,   {OPERAND_NONE}},
  188.         /* Mod:        push (stknext % stktop) */
  189.     {"uplus",             1,   0,   {OPERAND_NONE}},
  190.         /* Unary plus:    push +stktop */
  191.     {"uminus",            1,   0,   {OPERAND_NONE}},
  192.         /* Unary minus:    push -stktop */
  193.     {"bitnot",            1,   0,   {OPERAND_NONE}},
  194.         /* Bitwise not:    push ~stktop */
  195.     {"not",               1,   0,   {OPERAND_NONE}},
  196.         /* Logical not:    push !stktop */
  197.     {"callBuiltinFunc1",  2,   1,   {OPERAND_UINT1}},
  198.         /* Call builtin math function with index op1; any args are on stk */
  199.     {"callFunc1",         2,   1,   {OPERAND_UINT1}},
  200.         /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1>  */
  201.     {"tryCvtToNumeric",   1,   0,   {OPERAND_NONE}},
  202.         /* Try converting stktop to first int then double if possible. */
  203.  
  204.     {"break",             1,   0,   {OPERAND_NONE}},
  205.         /* Abort closest enclosing loop; if none, return TCL_BREAK code. */
  206.     {"continue",          1,   0,   {OPERAND_NONE}},
  207.         /* Skip to next iteration of closest enclosing loop; if none,
  208.      * return TCL_CONTINUE code. */
  209.  
  210.     {"foreach_start4",    5,   1,   {OPERAND_UINT4}},
  211.         /* Initialize execution of a foreach loop. Operand is aux data index
  212.      * of the ForeachInfo structure for the foreach command. */
  213.     {"foreach_step4",     5,   1,   {OPERAND_UINT4}},
  214.         /* "Step" or begin next iteration of foreach loop. Push 0 if to
  215.      *  terminate loop, else push 1. */
  216.  
  217.     {"beginCatch4",      5,   1,   {OPERAND_UINT4}},
  218.         /* Record start of catch with the operand's exception range index.
  219.      * Push the current stack depth onto a special catch stack. */
  220.     {"endCatch",      1,   0,   {OPERAND_NONE}},
  221.         /* End of last catch. Pop the bytecode interpreter's catch stack. */
  222.     {"pushResult",      1,   0,   {OPERAND_NONE}},
  223.         /* Push the interpreter's object result onto the stack. */
  224.     {"pushReturnCode",      1,   0,   {OPERAND_NONE}},
  225.         /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as
  226.      * a new object onto the stack. */
  227.     {0}
  228. };
  229.  
  230. /*
  231.  * The following table assigns a type to each character. Only types
  232.  * meaningful to Tcl parsing are represented here. The table is
  233.  * designed to be referenced with either signed or unsigned characters,
  234.  * so it has 384 entries. The first 128 entries correspond to negative
  235.  * character values, the next 256 correspond to positive character
  236.  * values. The last 128 entries are identical to the first 128. The
  237.  * table is always indexed with a 128-byte offset (the 128th entry
  238.  * corresponds to a 0 character value).
  239.  */
  240.  
  241. unsigned char tclTypeTable[] = {
  242.     /*
  243.      * Negative character values, from -128 to -1:
  244.      */
  245.  
  246.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  247.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  248.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  249.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  250.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  251.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  252.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  253.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  254.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  255.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  256.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  257.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  258.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  259.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  260.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  261.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  262.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  263.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  264.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  265.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  266.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  267.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  268.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  269.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  270.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  271.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  272.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  273.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  274.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  275.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  276.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  277.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  278.  
  279.     /*
  280.      * Positive character values, from 0-127:
  281.      */
  282.  
  283.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  284.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  285.     TCL_NORMAL,        TCL_SPACE,         TCL_COMMAND_END,   TCL_SPACE,
  286.     TCL_SPACE,         TCL_SPACE,         TCL_NORMAL,        TCL_NORMAL,
  287.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  288.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  289.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  290.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  291.     TCL_SPACE,         TCL_NORMAL,        TCL_QUOTE,         TCL_NORMAL,
  292.     TCL_DOLLAR,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  293.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  294.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  295.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  296.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  297.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_COMMAND_END,
  298.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  299.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  300.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  301.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  302.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  303.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  304.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  305.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_OPEN_BRACKET,
  306.     TCL_BACKSLASH,     TCL_COMMAND_END,   TCL_NORMAL,        TCL_NORMAL,
  307.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  308.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  309.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  310.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  311.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  312.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  313.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_OPEN_BRACE,
  314.     TCL_NORMAL,        TCL_CLOSE_BRACE,   TCL_NORMAL,        TCL_NORMAL,
  315.  
  316.     /*
  317.      * Large unsigned character values, from 128-255:
  318.      */
  319.  
  320.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  321.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  322.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  323.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  324.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  325.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  326.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  327.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  328.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  329.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  330.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  331.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  332.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  333.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  334.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  335.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  336.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  337.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  338.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  339.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  340.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  341.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  342.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  343.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  344.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  345.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  346.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  347.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  348.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  349.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  350.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  351.     TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
  352. };
  353.  
  354. /*
  355.  * Prototypes for procedures defined later in this file:
  356.  */
  357.  
  358. static void        AdvanceToNextWord _ANSI_ARGS_((char *string,
  359.                 CompileEnv *envPtr));
  360. static int        CollectArgInfo _ANSI_ARGS_((Tcl_Interp *interp,
  361.                 char *string, char *lastChar, int flags,
  362.                 ArgInfo *argInfoPtr));
  363. static int        CompileBraces _ANSI_ARGS_((Tcl_Interp *interp,
  364.                 char *string, char *lastChar, int flags,
  365.                 CompileEnv *envPtr));
  366. static int        CompileCmdWordInline _ANSI_ARGS_((
  367.                     Tcl_Interp *interp, char *string,
  368.                 char *lastChar, int flags, CompileEnv *envPtr));
  369. static int        CompileExprWord _ANSI_ARGS_((Tcl_Interp *interp,
  370.                 char *string, char *lastChar, int flags, 
  371.                 CompileEnv *envPtr));
  372. static int        CompileMultipartWord _ANSI_ARGS_((
  373.                     Tcl_Interp *interp, char *string,
  374.                 char *lastChar, int flags, CompileEnv *envPtr));
  375. static int        CompileWord _ANSI_ARGS_((Tcl_Interp *interp,
  376.                 char *string, char *lastChar, int flags, 
  377.                 CompileEnv *envPtr));
  378. static int        CreateExceptionRange _ANSI_ARGS_((
  379.                 ExceptionRangeType type, CompileEnv *envPtr));
  380. static void        DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
  381.                 Tcl_Obj *copyPtr));
  382. static ClientData    DupForeachInfo _ANSI_ARGS_((ClientData clientData));
  383. static unsigned char *    EncodeCmdLocMap _ANSI_ARGS_((
  384.                 CompileEnv *envPtr, ByteCode *codePtr,
  385.                 unsigned char *startPtr));
  386. static void        EnterCmdExtentData _ANSI_ARGS_((
  387.                     CompileEnv *envPtr, int cmdNumber,
  388.                 int numSrcChars, int numCodeBytes));
  389. static void        EnterCmdStartData _ANSI_ARGS_((
  390.                     CompileEnv *envPtr, int cmdNumber,
  391.                 int srcOffset, int codeOffset));
  392. static void        ExpandObjectArray _ANSI_ARGS_((CompileEnv *envPtr));
  393. static void        FreeForeachInfo _ANSI_ARGS_((
  394.                 ClientData clientData));
  395. static void        FreeByteCodeInternalRep _ANSI_ARGS_((
  396.                     Tcl_Obj *objPtr));
  397. static void        FreeArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr));
  398. static int        GetCmdLocEncodingSize _ANSI_ARGS_((
  399.                 CompileEnv *envPtr));
  400. static void        InitArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr));
  401. static int        LookupCompiledLocal _ANSI_ARGS_((
  402.                     char *name, int nameChars, int createIfNew,
  403.                 int flagsIfCreated, Proc *procPtr));
  404. static int        SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
  405.                 Tcl_Obj *objPtr));
  406. static void        UpdateStringOfByteCode _ANSI_ARGS_((Tcl_Obj *objPtr));
  407.  
  408. /*
  409.  * The structure below defines the bytecode Tcl object type by
  410.  * means of procedures that can be invoked by generic object code.
  411.  */
  412.  
  413. Tcl_ObjType tclByteCodeType = {
  414.     "bytecode",            /* name */
  415.     FreeByteCodeInternalRep,    /* freeIntRepProc */
  416.     DupByteCodeInternalRep,    /* dupIntRepProc */
  417.     UpdateStringOfByteCode,    /* updateStringProc */
  418.     SetByteCodeFromAny        /* setFromAnyProc */
  419. };
  420.  
  421. /*
  422.  *----------------------------------------------------------------------
  423.  *
  424.  * TclPrintByteCodeObj --
  425.  *
  426.  *    This procedure prints ("disassembles") the instructions of a
  427.  *    bytecode object to stdout.
  428.  *
  429.  * Results:
  430.  *    None.
  431.  *
  432.  * Side effects:
  433.  *    None.
  434.  *
  435.  *----------------------------------------------------------------------
  436.  */
  437.  
  438. void
  439. TclPrintByteCodeObj(interp, objPtr)
  440.     Tcl_Interp *interp;        /* Used only for Tcl_GetStringFromObj. */
  441.     Tcl_Obj *objPtr;        /* The bytecode object to disassemble. */
  442. {
  443.     ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
  444.     unsigned char *codeStart, *codeLimit, *pc;
  445.     unsigned char *codeDeltaNext, *codeLengthNext;
  446.     unsigned char *srcDeltaNext, *srcLengthNext;
  447.     int codeOffset, codeLen, srcOffset, srcLen;
  448.     int numCmds, numObjs, delta, objBytes, i;
  449.  
  450.     if (codePtr->refCount <= 0) {
  451.     return;            /* already freed */
  452.     }
  453.  
  454.     codeStart = codePtr->codeStart;
  455.     codeLimit = (codeStart + codePtr->numCodeBytes);
  456.     numCmds = codePtr->numCommands;
  457.     numObjs = codePtr->numObjects;
  458.  
  459.     objBytes = (numObjs * sizeof(Tcl_Obj));
  460.     for (i = 0;  i < numObjs;  i++) {
  461.     Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i];
  462.     if (litObjPtr->bytes != NULL) {
  463.         objBytes += litObjPtr->length;
  464.     }
  465.     }
  466.  
  467.     /*
  468.      * Print header lines describing the ByteCode.
  469.      */
  470.  
  471.     fprintf(stdout, "\nByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n",
  472.         (unsigned int) codePtr, codePtr->refCount,
  473.         codePtr->compileEpoch, (unsigned int) codePtr->iPtr,
  474.         codePtr->iPtr->compileEpoch);
  475.     fprintf(stdout, "  Source ");
  476.     TclPrintSource(stdout, codePtr->source,
  477.         TclMin(codePtr->numSrcChars, 70));
  478.     fprintf(stdout, "\n  Cmds %d, chars %d, inst %d, objs %u, aux %d, stk depth %u, code/src %.2f\n",
  479.         numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs,
  480.         codePtr->numAuxDataItems, codePtr->maxStackDepth,
  481.         (codePtr->numSrcChars?
  482.                 ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0));
  483.     fprintf(stdout, "  Code %d = %d(header)+%d(inst)+%d(objs)+%d(exc)+%d(aux)+%d(cmd map)\n",
  484.         codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes,
  485.         objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)),
  486.         (codePtr->numAuxDataItems * sizeof(AuxData)),
  487.         codePtr->numCmdLocBytes);
  488.  
  489.     /*
  490.      * If the ByteCode is the compiled body of a Tcl procedure, print
  491.      * information about that procedure. Note that we don't know the
  492.      * procedure's name since ByteCode's can be shared among procedures.
  493.      */
  494.     
  495.     if (codePtr->procPtr != NULL) {
  496.     Proc *procPtr = codePtr->procPtr;
  497.     int numCompiledLocals = procPtr->numCompiledLocals;
  498.     fprintf(stdout,
  499.             "  Proc 0x%x, ref ct %d, args %d, compiled locals %d\n",
  500.         (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs,
  501.         numCompiledLocals);
  502.     if (numCompiledLocals > 0) {
  503.         CompiledLocal *localPtr = procPtr->firstLocalPtr;
  504.         for (i = 0;  i < numCompiledLocals;  i++) {
  505.         fprintf(stdout, "      %d: slot %d%s%s%s%s%s",
  506.             i, localPtr->frameIndex,
  507.             ((localPtr->flags & VAR_SCALAR)?  ", scalar"  : ""),
  508.             ((localPtr->flags & VAR_ARRAY)?  ", array"  : ""),
  509.             ((localPtr->flags & VAR_LINK)?  ", link"  : ""),
  510.             (localPtr->isArg?  ", arg"  : ""),
  511.             (localPtr->isTemp? ", temp" : ""));
  512.         if (localPtr->isTemp) {
  513.             fprintf(stdout,    "\n");
  514.         } else {
  515.             fprintf(stdout,    ", name=\"%s\"\n", localPtr->name);
  516.         }
  517.         localPtr = localPtr->nextPtr;
  518.         }
  519.     }
  520.     }
  521.  
  522.     /*
  523.      * Print the ExceptionRange array.
  524.      */
  525.  
  526.     if (codePtr->numExcRanges > 0) {
  527.     fprintf(stdout, "  Exception ranges %d, depth %d:\n",
  528.             codePtr->numExcRanges, codePtr->maxExcRangeDepth);
  529.     for (i = 0;  i < codePtr->numExcRanges;  i++) {
  530.         ExceptionRange *rangePtr = &(codePtr->excRangeArrayPtr[i]);
  531.         fprintf(stdout, "      %d: level %d, %s, pc %d-%d, ",
  532.             i, rangePtr->nestingLevel,
  533.             ((rangePtr->type == LOOP_EXCEPTION_RANGE)? "loop":"catch"),
  534.             rangePtr->codeOffset,
  535.             (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
  536.         switch (rangePtr->type) {
  537.         case LOOP_EXCEPTION_RANGE:
  538.         fprintf(stdout,    "continue %d, break %d\n",
  539.                 rangePtr->continueOffset, rangePtr->breakOffset);
  540.         break;
  541.         case CATCH_EXCEPTION_RANGE:
  542.         fprintf(stdout,    "catch %d\n", rangePtr->catchOffset);
  543.         break;
  544.         default:
  545.         panic("TclPrintSource: unrecognized ExceptionRange type %d\n",
  546.                 rangePtr->type);
  547.         }
  548.     }
  549.     }
  550.     
  551.     /*
  552.      * If there were no commands (e.g., an expression or an empty string
  553.      * was compiled), just print all instructions and return.
  554.      */
  555.  
  556.     if (numCmds == 0) {
  557.     pc = codeStart;
  558.     while (pc < codeLimit) {
  559.         fprintf(stdout, "    ");
  560.         pc += TclPrintInstruction(codePtr, pc);
  561.     }
  562.     return;
  563.     }
  564.     
  565.     /*
  566.      * Print table showing the code offset, source offset, and source
  567.      * length for each command. These are encoded as a sequence of bytes.
  568.      */
  569.  
  570.     fprintf(stdout, "  Commands %d:", numCmds);
  571.     codeDeltaNext = codePtr->codeDeltaStart;
  572.     codeLengthNext = codePtr->codeLengthStart;
  573.     srcDeltaNext  = codePtr->srcDeltaStart;
  574.     srcLengthNext = codePtr->srcLengthStart;
  575.     codeOffset = srcOffset = 0;
  576.     for (i = 0;  i < numCmds;  i++) {
  577.     if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
  578.         codeDeltaNext++;
  579.         delta = TclGetInt4AtPtr(codeDeltaNext);
  580.         codeDeltaNext += 4;
  581.     } else {
  582.         delta = TclGetInt1AtPtr(codeDeltaNext);
  583.         codeDeltaNext++;
  584.     }
  585.     codeOffset += delta;
  586.  
  587.     if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
  588.         codeLengthNext++;
  589.         codeLen = TclGetInt4AtPtr(codeLengthNext);
  590.         codeLengthNext += 4;
  591.     } else {
  592.         codeLen = TclGetInt1AtPtr(codeLengthNext);
  593.         codeLengthNext++;
  594.     }
  595.     
  596.     if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
  597.         srcDeltaNext++;
  598.         delta = TclGetInt4AtPtr(srcDeltaNext);
  599.         srcDeltaNext += 4;
  600.     } else {
  601.         delta = TclGetInt1AtPtr(srcDeltaNext);
  602.         srcDeltaNext++;
  603.     }
  604.     srcOffset += delta;
  605.  
  606.     if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
  607.         srcLengthNext++;
  608.         srcLen = TclGetInt4AtPtr(srcLengthNext);
  609.         srcLengthNext += 4;
  610.     } else {
  611.         srcLen = TclGetInt1AtPtr(srcLengthNext);
  612.         srcLengthNext++;
  613.     }
  614.     
  615.     fprintf(stdout,    "%s%4d: pc %d-%d, source %d-%d",
  616.         ((i % 2)? "    " : "\n   "),
  617.         (i+1), codeOffset, (codeOffset + codeLen - 1),
  618.         srcOffset, (srcOffset + srcLen - 1));
  619.     }
  620.     if ((numCmds > 0) && ((numCmds % 2) != 0)) {
  621.     fprintf(stdout,    "\n");
  622.     }
  623.     
  624.     /*
  625.      * Print each instruction. If the instruction corresponds to the start
  626.      * of a command, print the command's source. Note that we don't need
  627.      * the code length here.
  628.      */
  629.  
  630.     codeDeltaNext = codePtr->codeDeltaStart;
  631.     srcDeltaNext  = codePtr->srcDeltaStart;
  632.     srcLengthNext = codePtr->srcLengthStart;
  633.     codeOffset = srcOffset = 0;
  634.     pc = codeStart;
  635.     for (i = 0;  i < numCmds;  i++) {
  636.     if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
  637.         codeDeltaNext++;
  638.         delta = TclGetInt4AtPtr(codeDeltaNext);
  639.         codeDeltaNext += 4;
  640.     } else {
  641.         delta = TclGetInt1AtPtr(codeDeltaNext);
  642.         codeDeltaNext++;
  643.     }
  644.     codeOffset += delta;
  645.  
  646.     if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
  647.         srcDeltaNext++;
  648.         delta = TclGetInt4AtPtr(srcDeltaNext);
  649.         srcDeltaNext += 4;
  650.     } else {
  651.         delta = TclGetInt1AtPtr(srcDeltaNext);
  652.         srcDeltaNext++;
  653.     }
  654.     srcOffset += delta;
  655.  
  656.     if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
  657.         srcLengthNext++;
  658.         srcLen = TclGetInt4AtPtr(srcLengthNext);
  659.         srcLengthNext += 4;
  660.     } else {
  661.         srcLen = TclGetInt1AtPtr(srcLengthNext);
  662.         srcLengthNext++;
  663.     }
  664.  
  665.     /*
  666.      * Print instructions before command i.
  667.      */
  668.     
  669.     while ((pc-codeStart) < codeOffset) {
  670.         fprintf(stdout, "    ");
  671.         pc += TclPrintInstruction(codePtr, pc);
  672.     }
  673.  
  674.     fprintf(stdout, "  Command %d: ", (i+1));
  675.     TclPrintSource(stdout, (codePtr->source + srcOffset),
  676.             TclMin(srcLen, 70));
  677.     fprintf(stdout, "\n");
  678.     }
  679.     if (pc < codeLimit) {
  680.     /*
  681.      * Print instructions after the last command.
  682.      */
  683.  
  684.     while (pc < codeLimit) {
  685.         fprintf(stdout, "    ");
  686.         pc += TclPrintInstruction(codePtr, pc);
  687.     }
  688.     }
  689. }
  690.  
  691. /*
  692.  *----------------------------------------------------------------------
  693.  *
  694.  * TclPrintInstruction --
  695.  *
  696.  *    This procedure prints ("disassembles") one instruction from a
  697.  *    bytecode object to stdout.
  698.  *
  699.  * Results:
  700.  *    Returns the length in bytes of the current instruiction.
  701.  *
  702.  * Side effects:
  703.  *    None.
  704.  *
  705.  *----------------------------------------------------------------------
  706.  */
  707.  
  708. int
  709. TclPrintInstruction(codePtr, pc)
  710.     ByteCode* codePtr;        /* Bytecode containing the instruction. */
  711.     unsigned char *pc;        /* Points to first byte of instruction. */
  712. {
  713.     Proc *procPtr = codePtr->procPtr;
  714.     unsigned char opCode = *pc;
  715.     register InstructionDesc *instDesc = &instructionTable[opCode];
  716.     unsigned char *codeStart = codePtr->codeStart;
  717.     unsigned int pcOffset = (pc - codeStart);
  718.     int opnd, elemLen, i, j;
  719.     Tcl_Obj *elemPtr;
  720.     char *string;
  721.     
  722.     fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
  723.     for (i = 0;  i < instDesc->numOperands;  i++) {
  724.     switch (instDesc->opTypes[i]) {
  725.     case OPERAND_INT1:
  726.         opnd = TclGetInt1AtPtr(pc+1+i);
  727.         if ((i == 0) && ((opCode == INST_JUMP1)
  728.                  || (opCode == INST_JUMP_TRUE1)
  729.                      || (opCode == INST_JUMP_FALSE1))) {
  730.         fprintf(stdout, "%d    # pc %u", opnd, (pcOffset + opnd));
  731.         } else {
  732.         fprintf(stdout, "%d", opnd);
  733.         }
  734.         break;
  735.     case OPERAND_INT4:
  736.         opnd = TclGetInt4AtPtr(pc+1+i);
  737.         if ((i == 0) && ((opCode == INST_JUMP4)
  738.                  || (opCode == INST_JUMP_TRUE4)
  739.                      || (opCode == INST_JUMP_FALSE4))) {
  740.         fprintf(stdout, "%d    # pc %u", opnd, (pcOffset + opnd));
  741.         } else {
  742.         fprintf(stdout, "%d", opnd);
  743.         }
  744.         break;
  745.     case OPERAND_UINT1:
  746.         opnd = TclGetUInt1AtPtr(pc+1+i);
  747.         if ((i == 0) && (opCode == INST_PUSH1)) {
  748.         elemPtr = codePtr->objArrayPtr[opnd];
  749.         string = Tcl_GetStringFromObj(elemPtr, &elemLen);
  750.         fprintf(stdout, "%u      # ", (unsigned int) opnd);
  751.         TclPrintSource(stdout, string, TclMin(elemLen, 40));
  752.         } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1)
  753.                     || (opCode == INST_LOAD_ARRAY1)
  754.                     || (opCode == INST_STORE_SCALAR1)
  755.                     || (opCode == INST_STORE_ARRAY1))) {
  756.         int localCt = procPtr->numCompiledLocals;
  757.         CompiledLocal *localPtr = procPtr->firstLocalPtr;
  758.         if (opnd >= localCt) {
  759.             panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
  760.                  (unsigned int) opnd, localCt);
  761.             return instDesc->numBytes;
  762.         }
  763.         for (j = 0;  j < opnd;  j++) {
  764.             localPtr = localPtr->nextPtr;
  765.         }
  766.         if (localPtr->isTemp) {
  767.             fprintf(stdout, "%u    # temp var %u",
  768.                 (unsigned int) opnd, (unsigned int) opnd);
  769.         } else {
  770.             fprintf(stdout, "%u    # var ", (unsigned int) opnd);
  771.             TclPrintSource(stdout, localPtr->name, 40);
  772.         }
  773.         } else {
  774.         fprintf(stdout, "%u ", (unsigned int) opnd);
  775.         }
  776.         break;
  777.     case OPERAND_UINT4:
  778.         opnd = TclGetUInt4AtPtr(pc+1+i);
  779.         if (opCode == INST_PUSH4) {
  780.         elemPtr = codePtr->objArrayPtr[opnd];
  781.         string = Tcl_GetStringFromObj(elemPtr, &elemLen);
  782.         fprintf(stdout, "%u      # ", opnd);
  783.         TclPrintSource(stdout, string, TclMin(elemLen, 40));
  784.         } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4)
  785.                     || (opCode == INST_LOAD_ARRAY4)
  786.                     || (opCode == INST_STORE_SCALAR4)
  787.                     || (opCode == INST_STORE_ARRAY4))) {
  788.         int localCt = procPtr->numCompiledLocals;
  789.         CompiledLocal *localPtr = procPtr->firstLocalPtr;
  790.         if (opnd >= localCt) {
  791.             panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
  792.                  (unsigned int) opnd, localCt);
  793.             return instDesc->numBytes;
  794.         }
  795.         for (j = 0;  j < opnd;  j++) {
  796.             localPtr = localPtr->nextPtr;
  797.         }
  798.         if (localPtr->isTemp) {
  799.             fprintf(stdout, "%u    # temp var %u",
  800.                 (unsigned int) opnd, (unsigned int) opnd);
  801.         } else {
  802.             fprintf(stdout, "%u    # var ", (unsigned int) opnd);
  803.             TclPrintSource(stdout, localPtr->name, 40);
  804.         }
  805.         } else {
  806.         fprintf(stdout, "%u ", (unsigned int) opnd);
  807.         }
  808.         break;
  809.     case OPERAND_NONE:
  810.     default:
  811.         break;
  812.     }
  813.     }
  814.     fprintf(stdout, "\n");
  815.     return instDesc->numBytes;
  816. }
  817.  
  818. /*
  819.  *----------------------------------------------------------------------
  820.  *
  821.  * TclPrintSource --
  822.  *
  823.  *    This procedure prints up to a specified number of characters from
  824.  *    the argument string to a specified file. It tries to produce legible
  825.  *    output by adding backslashes as necessary.
  826.  *
  827.  * Results:
  828.  *    None.
  829.  *
  830.  * Side effects:
  831.  *    Outputs characters to the specified file.
  832.  *
  833.  *----------------------------------------------------------------------
  834.  */
  835.  
  836. void
  837. TclPrintSource(outFile, string, maxChars)
  838.     FILE *outFile;        /* The file to print the source to. */
  839.     char *string;        /* The string to print. */
  840.     int maxChars;        /* Maximum number of chars to print. */
  841. {
  842.     register char *p;
  843.     register int i = 0;
  844.  
  845.     if (string == NULL) {
  846.     fprintf(outFile, "\"\"");
  847.     return;
  848.     }
  849.  
  850.     fprintf(outFile, "\"");
  851.     p = string;
  852.     for (;  (*p != '\0') && (i < maxChars);  p++, i++) {
  853.     switch (*p) {
  854.         case '"':
  855.         fprintf(outFile, "\\\"");
  856.         continue;
  857.         case '\f':
  858.         fprintf(outFile, "\\f");
  859.         continue;
  860.         case '\n':
  861.         fprintf(outFile, "\\n");
  862.         continue;
  863.             case '\r':
  864.         fprintf(outFile, "\\r");
  865.         continue;
  866.         case '\t':
  867.         fprintf(outFile, "\\t");
  868.         continue;
  869.             case '\v':
  870.         fprintf(outFile, "\\v");
  871.         continue;
  872.         default:
  873.         fprintf(outFile, "%c", *p);
  874.         continue;
  875.     }
  876.     }
  877.     fprintf(outFile, "\"");
  878. }
  879.  
  880. /*
  881.  *----------------------------------------------------------------------
  882.  *
  883.  * FreeByteCodeInternalRep --
  884.  *
  885.  *    Part of the bytecode Tcl object type implementation. Frees the
  886.  *    storage associated with a bytecode object's internal representation
  887.  *    unless its code is actively being executed.
  888.  *
  889.  * Results:
  890.  *    None.
  891.  *
  892.  * Side effects:
  893.  *    The bytecode object's internal rep is marked invalid and its
  894.  *    code gets freed unless the code is actively being executed.
  895.  *    In that case the cleanup is delayed until the last execution
  896.  *    of the code completes.
  897.  *
  898.  *----------------------------------------------------------------------
  899.  */
  900.  
  901. static void
  902. FreeByteCodeInternalRep(objPtr)
  903.     register Tcl_Obj *objPtr;    /* Object whose internal rep to free. */
  904. {
  905.     register ByteCode *codePtr =
  906.         (ByteCode *) objPtr->internalRep.otherValuePtr;
  907.  
  908.     codePtr->refCount--;
  909.     if (codePtr->refCount <= 0) {
  910.     TclCleanupByteCode(codePtr);
  911.     }
  912.     objPtr->typePtr = NULL;
  913.     objPtr->internalRep.otherValuePtr = NULL;
  914. }
  915.  
  916. /*
  917.  *----------------------------------------------------------------------
  918.  *
  919.  * CleanupByteCode --
  920.  *
  921.  *    This procedure does all the real work of freeing up a bytecode
  922.  *    object's ByteCode structure. It's called only when the structure's
  923.  *    reference count becomes zero.
  924.  *
  925.  * Results:
  926.  *    None.
  927.  *
  928.  * Side effects:
  929.  *    Frees objPtr's bytecode internal representation and sets
  930.  *    its type and objPtr->internalRep.otherValuePtr NULL. Also
  931.  *    decrements the ref counts on each object in its object array,
  932.  *    and frees its auxiliary data items.
  933.  *
  934.  *----------------------------------------------------------------------
  935.  */
  936.  
  937. void
  938. TclCleanupByteCode(codePtr)
  939.     ByteCode *codePtr;        /* ByteCode to free. */
  940. {
  941.     Tcl_Obj **objArrayPtr = codePtr->objArrayPtr;
  942.     int numObjects = codePtr->numObjects;
  943.     int numAuxDataItems = codePtr->numAuxDataItems;
  944.     register AuxData *auxDataPtr;
  945.     register Tcl_Obj *elemPtr;
  946.     register int i;
  947.  
  948. #ifdef TCL_COMPILE_STATS    
  949.     tclCurrentSourceBytes -= (double) codePtr->numSrcChars;
  950.     tclCurrentCodeBytes -= (double) codePtr->totalSize;
  951. #endif /* TCL_COMPILE_STATS */
  952.  
  953.     /*
  954.      * A single heap object holds the ByteCode structure and its code,
  955.      * object, command location, and auxiliary data arrays. This means we
  956.      * only need to 1) decrement the ref counts on the objects in its
  957.      * object array, 2) call the free procs for the auxiliary data items,
  958.      * and 3) free the ByteCode structure's heap object.
  959.      */
  960.  
  961.     for (i = 0;  i < numObjects;  i++) {
  962.     elemPtr = objArrayPtr[i];
  963.     TclDecrRefCount(elemPtr);
  964.     }
  965.  
  966.     auxDataPtr = codePtr->auxDataArrayPtr;
  967.     for (i = 0;  i < numAuxDataItems;  i++) {
  968.     if (auxDataPtr->freeProc != NULL) {
  969.         auxDataPtr->freeProc(auxDataPtr->clientData);
  970.     }
  971.     auxDataPtr++;
  972.     }
  973.     
  974.     ckfree((char *) codePtr);
  975. }
  976.  
  977. /*
  978.  *----------------------------------------------------------------------
  979.  *
  980.  * DupByteCodeInternalRep --
  981.  *
  982.  *    Part of the bytecode Tcl object type implementation. Initializes the
  983.  *    internal representation of a bytecode Tcl_Obj to a copy of the
  984.  *    internal representation of an existing bytecode object.
  985.  *
  986.  * Results:
  987.  *    None.
  988.  *
  989.  * Side effects:
  990.  *    "copyPtr"s internal rep is set to the bytecode sequence
  991.  *    corresponding to "srcPtr"s internal rep. Ref counts for objects
  992.  *    in the existing bytecode object's  object array are incremented
  993.  *    the bytecode copy now also refers to them.
  994.  *
  995.  *----------------------------------------------------------------------
  996.  */
  997.  
  998. static void
  999. DupByteCodeInternalRep(srcPtr, copyPtr)
  1000.     Tcl_Obj *srcPtr;        /* Object with internal rep to copy. */
  1001.     Tcl_Obj *copyPtr;        /* Object with internal rep to set. */
  1002. {
  1003.     ByteCode *codePtr = (ByteCode *) srcPtr->internalRep.otherValuePtr;
  1004.     register ByteCode *dupPtr;
  1005.     register AuxData *srcAuxDataPtr, *dupAuxDataPtr;
  1006.     size_t objArrayBytes, exceptArrayBytes, cmdLocBytes, auxDataBytes;
  1007.     register size_t size;
  1008.     register char *p;
  1009.     int codeBytes, numObjects, i;
  1010.  
  1011.     /*
  1012.      * Allocate a single heap object to hold the copied ByteCode structure
  1013.      * and its code, object, command location, and auxiliary data arrays.
  1014.      */
  1015.  
  1016.     codeBytes = codePtr->numCodeBytes;
  1017.     numObjects = codePtr->numObjects;
  1018.     objArrayBytes = (numObjects * sizeof(Tcl_Obj *));
  1019.     exceptArrayBytes = (codePtr->numExcRanges * sizeof(ExceptionRange));
  1020.     auxDataBytes = (codePtr->numAuxDataItems * sizeof(AuxData));
  1021.     cmdLocBytes = codePtr->numCmdLocBytes;
  1022.  
  1023.     size = sizeof(ByteCode);
  1024.     size += TCL_ALIGN(codeBytes);        /* align object array */
  1025.     size += TCL_ALIGN(objArrayBytes);    /* align exception range array */
  1026.     size += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
  1027.     size += auxDataBytes;
  1028.     size += cmdLocBytes;
  1029.     
  1030.     p = (char *) ckalloc(size);
  1031.     dupPtr = (ByteCode *) p;
  1032.     memcpy((VOID *) dupPtr, (VOID *) codePtr, size);
  1033.  
  1034.     p += sizeof(ByteCode);
  1035.     dupPtr->codeStart = (unsigned char *) p;
  1036.     
  1037.     p += TCL_ALIGN(codeBytes);          /* object array is aligned */
  1038.     dupPtr->objArrayPtr = (Tcl_Obj **) p;
  1039.     
  1040.     p += TCL_ALIGN(objArrayBytes);    /* exception range array is aligned */
  1041.     dupPtr->excRangeArrayPtr = (ExceptionRange *) p;
  1042.     
  1043.     p += TCL_ALIGN(exceptArrayBytes); /* AuxData array is aligned  */
  1044.     dupPtr->auxDataArrayPtr = (AuxData *) p;
  1045.  
  1046.     p += auxDataBytes;
  1047.     dupPtr->codeDeltaStart = ((unsigned char *) dupPtr) + 
  1048.             (codePtr->codeDeltaStart - (unsigned char *) codePtr);
  1049.     dupPtr->srcDeltaStart = ((unsigned char *) dupPtr) +
  1050.             (codePtr->srcDeltaStart - (unsigned char *) codePtr);
  1051.     dupPtr->srcLengthStart = ((unsigned char *) dupPtr) +
  1052.             (codePtr->srcLengthStart - (unsigned char *) codePtr);
  1053.     
  1054.     /*
  1055.      * Increment the ref counts for objects in the object array since we are
  1056.      * creating new references for them in the copied object array.
  1057.      */
  1058.  
  1059.     for (i = 0;  i < numObjects;  i++) {
  1060.         Tcl_IncrRefCount(dupPtr->objArrayPtr[i]);
  1061.     }
  1062.  
  1063.     /*
  1064.      * Duplicate any auxiliary data items.
  1065.      */
  1066.  
  1067.     srcAuxDataPtr = codePtr->auxDataArrayPtr;
  1068.     dupAuxDataPtr = dupPtr->auxDataArrayPtr;
  1069.     for (i = 0;  i < codePtr->numAuxDataItems;  i++) {
  1070.     if (srcAuxDataPtr->dupProc != NULL) {
  1071.         dupAuxDataPtr->clientData =
  1072.         srcAuxDataPtr->dupProc(srcAuxDataPtr->clientData);
  1073.     } else {
  1074.         dupAuxDataPtr->clientData = srcAuxDataPtr->clientData;
  1075.     }
  1076.     srcAuxDataPtr++;
  1077.     dupAuxDataPtr++;
  1078.     }
  1079.  
  1080.     copyPtr->internalRep.otherValuePtr = (VOID *) dupPtr;
  1081.     copyPtr->typePtr = &tclByteCodeType;
  1082.  
  1083. #ifdef TCL_COMPILE_STATS    
  1084.     tclCurrentSourceBytes += (double) codePtr->numSrcChars;
  1085.     tclCurrentCodeBytes += (double) codePtr->totalSize;
  1086. #endif /* TCL_COMPILE_STATS */
  1087. }
  1088.  
  1089. /*
  1090.  *-----------------------------------------------------------------------
  1091.  *
  1092.  * SetByteCodeFromAny --
  1093.  *
  1094.  *    Part of the bytecode Tcl object type implementation. Attempts to
  1095.  *    generate an byte code internal form for the Tcl object "objPtr" by
  1096.  *    compiling its string representation.
  1097.  *
  1098.  * Results:
  1099.  *    The return value is a standard Tcl object result. If an error occurs
  1100.  *    during compilation, an error message is left in the interpreter's
  1101.  *    result unless "interp" is NULL.
  1102.  *
  1103.  * Side effects:
  1104.  *    Frees the old internal representation. If no error occurs, then the
  1105.  *    compiled code is stored as "objPtr"s bytecode representation.
  1106.  *    Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
  1107.  *    used to trace compilations.
  1108.  *
  1109.  *----------------------------------------------------------------------
  1110.  */
  1111.  
  1112. static int
  1113. SetByteCodeFromAny(interp, objPtr)
  1114.     Tcl_Interp *interp;        /* The interpreter for which the code is
  1115.                  * compiled. */
  1116.     Tcl_Obj *objPtr;        /* The object to convert. */
  1117. {
  1118.     Interp *iPtr = (Interp *) interp;
  1119.     char *string;
  1120.     CompileEnv compEnv;        /* Compilation environment structure
  1121.                  * allocated in frame. */
  1122.     AuxData *auxDataPtr;
  1123.     register int i;
  1124.     int length, result;
  1125.  
  1126.     if (!traceInitialized) {
  1127.         if (Tcl_LinkVar(interp, "tcl_traceCompile",
  1128.                 (char *) &tclTraceCompile,  TCL_LINK_INT) != TCL_OK) {
  1129.             panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
  1130.         }
  1131.         traceInitialized = 1;
  1132.     }
  1133.     
  1134.     string = Tcl_GetStringFromObj(objPtr, &length);
  1135.     TclInitCompileEnv(interp, &compEnv, string);
  1136.     result = TclCompileString(interp, string, string+length,
  1137.         iPtr->evalFlags, &compEnv);
  1138.     if (result == TCL_OK) {
  1139.     /*
  1140.      * Add a "done" instruction at the end of the instruction sequence.
  1141.      */
  1142.     
  1143.     TclEmitOpcode(INST_DONE, &compEnv);
  1144.     
  1145.     /*
  1146.      * Convert the object to a ByteCode object.
  1147.      */
  1148.  
  1149.     TclInitByteCodeObj(objPtr, &compEnv);
  1150.     } else {
  1151.     /*
  1152.      * Compilation errors. Decrement the ref counts on any objects in
  1153.      * the object array and free any aux data items prior to freeing
  1154.      * the compilation environment.
  1155.      */
  1156.     
  1157.     for (i = 0;  i < compEnv.objArrayNext;  i++) {
  1158.         Tcl_Obj *elemPtr = compEnv.objArrayPtr[i];
  1159.         Tcl_DecrRefCount(elemPtr);
  1160.     }
  1161.  
  1162.     auxDataPtr = compEnv.auxDataArrayPtr;
  1163.     for (i = 0;  i < compEnv.auxDataArrayNext;  i++) {
  1164.         if (auxDataPtr->freeProc != NULL) {
  1165.         auxDataPtr->freeProc(auxDataPtr->clientData);
  1166.         }
  1167.         auxDataPtr++;
  1168.     }
  1169.     }
  1170.     TclFreeCompileEnv(&compEnv);
  1171.  
  1172.     if (result == TCL_OK) {
  1173.     if (tclTraceCompile == 2) {
  1174.         TclPrintByteCodeObj(interp, objPtr);
  1175.     }
  1176.     }
  1177.     return result;
  1178. }
  1179.  
  1180. /*
  1181.  *----------------------------------------------------------------------
  1182.  *
  1183.  * UpdateStringOfByteCode --
  1184.  *
  1185.  *    Part of the bytecode Tcl object type implementation. Called to
  1186.  *    update the string representation for a byte code object.
  1187.  *    Note: This procedure does not free an existing old string rep
  1188.  *    so storage will be lost if this has not already been done.
  1189.  *
  1190.  * Results:
  1191.  *    None.
  1192.  *
  1193.  * Side effects:
  1194.  *    Generates a panic. 
  1195.  *
  1196.  *----------------------------------------------------------------------
  1197.  */
  1198.  
  1199. static void
  1200. UpdateStringOfByteCode(objPtr)
  1201.     register Tcl_Obj *objPtr;    /* ByteCode object with string rep that 
  1202.                  * needs updating. */
  1203. {
  1204.     /*
  1205.      * This procedure is never invoked since the internal representation of
  1206.      * a bytecode object is never modified.
  1207.      */
  1208.  
  1209.     panic("UpdateStringOfByteCode should never be called.");
  1210. }
  1211.  
  1212. /*
  1213.  *----------------------------------------------------------------------
  1214.  *
  1215.  * TclInitCompileEnv --
  1216.  *
  1217.  *    Initializes a CompileEnv compilation environment structure for the
  1218.  *    compilation of a string in an interpreter.
  1219.  *
  1220.  * Results:
  1221.  *    None.
  1222.  *
  1223.  * Side effects:
  1224.  *    The CompileEnv structure is initialized.
  1225.  *
  1226.  *----------------------------------------------------------------------
  1227.  */
  1228.  
  1229. void
  1230. TclInitCompileEnv(interp, envPtr, string)
  1231.     Tcl_Interp *interp;         /* The interpreter for which a CompileEnv
  1232.                   * structure is initialized. */
  1233.     register CompileEnv *envPtr; /* Points to the CompileEnv structure to
  1234.                   * initialize. */
  1235.     char *string;         /* The source string to be compiled. */
  1236. {
  1237.     Interp *iPtr = (Interp *) interp;
  1238.     
  1239.     envPtr->iPtr = iPtr;
  1240.     envPtr->source = string;
  1241.     envPtr->procPtr = iPtr->compiledProcPtr;
  1242.     envPtr->numCommands = 0;
  1243.     envPtr->excRangeDepth = 0;
  1244.     envPtr->maxExcRangeDepth = 0;
  1245.     envPtr->maxStackDepth = 0;
  1246.     Tcl_InitHashTable(&(envPtr->objTable), TCL_STRING_KEYS);
  1247.     envPtr->pushSimpleWords = 1;
  1248.     envPtr->wordIsSimple = 0;
  1249.     envPtr->numSimpleWordChars = 0;
  1250.     envPtr->exprIsJustVarRef = 0;
  1251.     envPtr->exprIsComparison = 0;
  1252.     envPtr->termOffset = 0;
  1253.  
  1254.     envPtr->codeStart = envPtr->staticCodeSpace;
  1255.     envPtr->codeNext = envPtr->codeStart;
  1256.     envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES);
  1257.     envPtr->mallocedCodeArray = 0;
  1258.  
  1259.     envPtr->objArrayPtr = envPtr->staticObjArraySpace;
  1260.     envPtr->objArrayNext = 0;
  1261.     envPtr->objArrayEnd = COMPILEENV_INIT_NUM_OBJECTS;
  1262.     envPtr->mallocedObjArray = 0;
  1263.     
  1264.     envPtr->excRangeArrayPtr = envPtr->staticExcRangeArraySpace;
  1265.     envPtr->excRangeArrayNext = 0;
  1266.     envPtr->excRangeArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
  1267.     envPtr->mallocedExcRangeArray = 0;
  1268.     
  1269.     envPtr->cmdMapPtr = envPtr->staticCmdMapSpace;
  1270.     envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
  1271.     envPtr->mallocedCmdMap = 0;
  1272.     
  1273.     envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
  1274.     envPtr->auxDataArrayNext = 0;
  1275.     envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE;
  1276.     envPtr->mallocedAuxDataArray = 0;
  1277. }
  1278.  
  1279. /*
  1280.  *----------------------------------------------------------------------
  1281.  *
  1282.  * TclFreeCompileEnv --
  1283.  *
  1284.  *    Free the storage allocated in a CompileEnv compilation environment
  1285.  *    structure.
  1286.  *
  1287.  * Results:
  1288.  *    None.
  1289.  *
  1290.  * Side effects:
  1291.  *    Allocated storage in the CompileEnv structure is freed. Note that
  1292.  *    ref counts for Tcl objects in its object table are not decremented.
  1293.  *    In addition, any storage referenced by any auxiliary data items
  1294.  *    in the CompileEnv structure are not freed either. The expectation
  1295.  *    is that when compilation is successful, "ownership" (i.e., the
  1296.  *    pointers to) these objects and aux data items will just be handed
  1297.  *    over to the corresponding ByteCode structure.
  1298.  *
  1299.  *----------------------------------------------------------------------
  1300.  */
  1301.  
  1302. void
  1303. TclFreeCompileEnv(envPtr)
  1304.     register CompileEnv *envPtr; /* Points to the CompileEnv structure. */
  1305. {
  1306.     Tcl_DeleteHashTable(&(envPtr->objTable));
  1307.     if (envPtr->mallocedCodeArray) {
  1308.     ckfree((char *) envPtr->codeStart);
  1309.     }
  1310.     if (envPtr->mallocedObjArray) {
  1311.     ckfree((char *) envPtr->objArrayPtr);
  1312.     }
  1313.     if (envPtr->mallocedExcRangeArray) {
  1314.     ckfree((char *) envPtr->excRangeArrayPtr);
  1315.     }
  1316.     if (envPtr->mallocedCmdMap) {
  1317.     ckfree((char *) envPtr->cmdMapPtr);
  1318.     }
  1319.     if (envPtr->mallocedAuxDataArray) {
  1320.     ckfree((char *) envPtr->auxDataArrayPtr);
  1321.     }
  1322. }
  1323.  
  1324. /*
  1325.  *----------------------------------------------------------------------
  1326.  *
  1327.  * TclInitByteCodeObj --
  1328.  *
  1329.  *    Create a ByteCode structure and initialize it from a CompileEnv
  1330.  *    compilation environment structure. The ByteCode structure is
  1331.  *    smaller and contains just that information needed to execute
  1332.  *    the bytecode instructions resulting from compiling a Tcl script.
  1333.  *    The resulting structure is placed in the specified object.
  1334.  *
  1335.  * Results:
  1336.  *    A newly constructed ByteCode object is stored in the internal
  1337.  *    representation of the objPtr.
  1338.  *
  1339.  * Side effects:
  1340.  *    A single heap object is allocated to hold the new ByteCode structure
  1341.  *    and its code, object, command location, and aux data arrays. Note
  1342.  *    that "ownership" (i.e., the pointers to) the Tcl objects and aux
  1343.  *    data items will be handed over to the new ByteCode structure from
  1344.  *    the CompileEnv structure.
  1345.  *
  1346.  *----------------------------------------------------------------------
  1347.  */
  1348.  
  1349. void
  1350. TclInitByteCodeObj(objPtr, envPtr)
  1351.     Tcl_Obj *objPtr;         /* Points object that should be
  1352.                   * initialized, and whose string rep
  1353.                   * contains the source code. */
  1354.     register CompileEnv *envPtr; /* Points to the CompileEnv structure from
  1355.                   * which to create a ByteCode structure. */
  1356. {
  1357.     register ByteCode *codePtr;
  1358.     size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
  1359.     size_t auxDataArrayBytes;
  1360.     register size_t size, objBytes, totalSize;
  1361.     register unsigned char *p;
  1362.     unsigned char *nextPtr;
  1363.     int srcLen = envPtr->termOffset;
  1364.     int numObjects, i;
  1365. #ifdef TCL_COMPILE_STATS
  1366.     int srcLenLog2, sizeLog2;
  1367. #endif /*TCL_COMPILE_STATS*/
  1368.  
  1369.     codeBytes = (envPtr->codeNext - envPtr->codeStart);
  1370.     numObjects = envPtr->objArrayNext;
  1371.     objArrayBytes = (envPtr->objArrayNext * sizeof(Tcl_Obj *));
  1372.     exceptArrayBytes = (envPtr->excRangeArrayNext * sizeof(ExceptionRange));
  1373.     auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData));
  1374.     cmdLocBytes = GetCmdLocEncodingSize(envPtr);
  1375.     
  1376.     size = sizeof(ByteCode);
  1377.     size += TCL_ALIGN(codeBytes);       /* align object array */
  1378.     size += TCL_ALIGN(objArrayBytes);   /* align exception range array */
  1379.     size += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
  1380.     size += auxDataArrayBytes;
  1381.     size += cmdLocBytes;
  1382.  
  1383.     /*
  1384.      * Compute the total number of bytes needed for this bytecode
  1385.      * including the storage for the Tcl objects in its object array.
  1386.      */
  1387.  
  1388.     objBytes = (numObjects * sizeof(Tcl_Obj));
  1389.     for (i = 0;  i < numObjects;  i++) {
  1390.     Tcl_Obj *litObjPtr = envPtr->objArrayPtr[i];
  1391.     if (litObjPtr->bytes != NULL) {
  1392.         objBytes += litObjPtr->length;
  1393.     }
  1394.     }
  1395.     totalSize = (size + objBytes);
  1396.  
  1397. #ifdef TCL_COMPILE_STATS
  1398.     tclNumCompilations++;
  1399.     tclTotalSourceBytes += (double) srcLen;
  1400.     tclTotalCodeBytes += (double) totalSize;
  1401.     
  1402.     tclTotalInstBytes += (double) codeBytes;
  1403.     tclTotalObjBytes += (double) objBytes;
  1404.     tclTotalExceptBytes += exceptArrayBytes;
  1405.     tclTotalAuxBytes += (double) auxDataArrayBytes;
  1406.     tclTotalCmdMapBytes += (double) cmdLocBytes;
  1407.  
  1408.     tclCurrentSourceBytes += (double) srcLen;
  1409.     tclCurrentCodeBytes += (double) totalSize;
  1410.  
  1411.     srcLenLog2 = TclLog2(srcLen);
  1412.     sizeLog2 = TclLog2((int) totalSize);
  1413.     if ((srcLenLog2 > 31) || (sizeLog2 > 31)) {
  1414.     panic("TclInitByteCodeObj: bad source or code sizes\n");
  1415.     }
  1416.     tclSourceCount[srcLenLog2]++;
  1417.     tclByteCodeCount[sizeLog2]++;
  1418. #endif /* TCL_COMPILE_STATS */    
  1419.     
  1420.     p = (unsigned char *) ckalloc(size);
  1421.     codePtr = (ByteCode *) p;
  1422.     codePtr->iPtr = envPtr->iPtr;
  1423.     codePtr->compileEpoch = envPtr->iPtr->compileEpoch;
  1424.     codePtr->refCount = 1;
  1425.     codePtr->source = envPtr->source;
  1426.     codePtr->procPtr = envPtr->procPtr;
  1427.     codePtr->totalSize = totalSize;
  1428.     codePtr->numCommands = envPtr->numCommands;
  1429.     codePtr->numSrcChars = srcLen;
  1430.     codePtr->numCodeBytes = codeBytes;
  1431.     codePtr->numObjects = numObjects;
  1432.     codePtr->numExcRanges = envPtr->excRangeArrayNext;
  1433.     codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
  1434.     codePtr->numCmdLocBytes = cmdLocBytes;
  1435.     codePtr->maxExcRangeDepth = envPtr->maxExcRangeDepth;
  1436.     codePtr->maxStackDepth = envPtr->maxStackDepth;
  1437.     
  1438.     p += sizeof(ByteCode);
  1439.     codePtr->codeStart = p;
  1440.     memcpy((VOID *) p, (VOID *) envPtr->codeStart, codeBytes);
  1441.     
  1442.     p += TCL_ALIGN(codeBytes);          /* align object array */
  1443.     codePtr->objArrayPtr = (Tcl_Obj **) p;
  1444.     memcpy((VOID *) p, (VOID *) envPtr->objArrayPtr, objArrayBytes);
  1445.  
  1446.     p += TCL_ALIGN(objArrayBytes);    /* align exception range array */
  1447.     if (exceptArrayBytes > 0) {
  1448.     codePtr->excRangeArrayPtr = (ExceptionRange *) p;
  1449.     memcpy((VOID *) p, (VOID *) envPtr->excRangeArrayPtr,
  1450.             exceptArrayBytes);
  1451.     }
  1452.     
  1453.     p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
  1454.     if (auxDataArrayBytes > 0) {
  1455.     codePtr->auxDataArrayPtr = (AuxData *) p;
  1456.     memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr,
  1457.             auxDataArrayBytes);
  1458.     }
  1459.  
  1460.     p += auxDataArrayBytes;
  1461.     nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
  1462.     if (((size_t)(nextPtr - p)) != cmdLocBytes) {    
  1463.     panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes);
  1464.     }
  1465.     
  1466.     /*
  1467.      * Free the old internal rep then convert the object to a
  1468.      * bytecode object by making its internal rep point to the just
  1469.      * compiled ByteCode.
  1470.      */
  1471.         
  1472.     if ((objPtr->typePtr != NULL) &&
  1473.         (objPtr->typePtr->freeIntRepProc != NULL)) {
  1474.     objPtr->typePtr->freeIntRepProc(objPtr);
  1475.     }
  1476.     objPtr->internalRep.otherValuePtr = (VOID *) codePtr;
  1477.     objPtr->typePtr = &tclByteCodeType;
  1478. }
  1479.  
  1480. /*
  1481.  *----------------------------------------------------------------------
  1482.  *
  1483.  * GetCmdLocEncodingSize --
  1484.  *
  1485.  *    Computes the total number of bytes needed to encode the command
  1486.  *    location information for some compiled code.
  1487.  *
  1488.  * Results:
  1489.  *    The byte count needed to encode the compiled location information.
  1490.  *
  1491.  * Side effects:
  1492.  *    None.
  1493.  *
  1494.  *----------------------------------------------------------------------
  1495.  */
  1496.  
  1497. static int
  1498. GetCmdLocEncodingSize(envPtr)
  1499.      CompileEnv *envPtr;    /* Points to compilation environment
  1500.                  * structure containing the CmdLocation
  1501.                  * structure to encode. */
  1502. {
  1503.     register CmdLocation *mapPtr = envPtr->cmdMapPtr;
  1504.     int numCmds = envPtr->numCommands;
  1505.     int codeDelta, codeLen, srcDelta, srcLen;
  1506.     int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext;
  1507.                 /* The offsets in their respective byte
  1508.                  * sequences where the next encoded offset
  1509.                  * or length should go. */
  1510.     int prevCodeOffset, prevSrcOffset, i;
  1511.  
  1512.     codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0;
  1513.     prevCodeOffset = prevSrcOffset = 0;
  1514.     for (i = 0;  i < numCmds;  i++) {
  1515.     codeDelta = (mapPtr[i].codeOffset - prevCodeOffset);
  1516.     if (codeDelta < 0) {
  1517.         panic("GetCmdLocEncodingSize: bad code offset");
  1518.     } else if (codeDelta <= 127) {
  1519.         codeDeltaNext++;
  1520.     } else {
  1521.         codeDeltaNext += 5;     /* 1 byte for 0xFF, 4 for positive delta */
  1522.     }
  1523.     prevCodeOffset = mapPtr[i].codeOffset;
  1524.  
  1525.     codeLen = mapPtr[i].numCodeBytes;
  1526.     if (codeLen < 0) {
  1527.         panic("GetCmdLocEncodingSize: bad code length");
  1528.     } else if (codeLen <= 127) {
  1529.         codeLengthNext++;
  1530.     } else {
  1531.         codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
  1532.     }
  1533.  
  1534.     srcDelta = (mapPtr[i].srcOffset - prevSrcOffset);
  1535.     if ((-127 <= srcDelta) && (srcDelta <= 127)) {
  1536.         srcDeltaNext++;
  1537.     } else {
  1538.         srcDeltaNext += 5;     /* 1 byte for 0xFF, 4 for delta */
  1539.     }
  1540.     prevSrcOffset = mapPtr[i].srcOffset;
  1541.  
  1542.     srcLen = mapPtr[i].numSrcChars;
  1543.     if (srcLen < 0) {
  1544.         panic("GetCmdLocEncodingSize: bad source length");
  1545.     } else if (srcLen <= 127) {
  1546.         srcLengthNext++;
  1547.     } else {
  1548.         srcLengthNext += 5;     /* 1 byte for 0xFF, 4 for length */
  1549.     }
  1550.     }
  1551.  
  1552.     return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext);
  1553. }
  1554.  
  1555. /*
  1556.  *----------------------------------------------------------------------
  1557.  *
  1558.  * EncodeCmdLocMap --
  1559.  *
  1560.  *    Encode the command location information for some compiled code into
  1561.  *    a ByteCode structure. The encoded command location map is stored as
  1562.  *    three adjacent byte sequences.
  1563.  *
  1564.  * Results:
  1565.  *    Pointer to the first byte after the encoded command location
  1566.  *    information.
  1567.  *
  1568.  * Side effects:
  1569.  *    The encoded information is stored into the block of memory headed
  1570.  *    by codePtr. Also records pointers to the start of the four byte
  1571.  *    sequences in fields in codePtr's ByteCode header structure.
  1572.  *
  1573.  *----------------------------------------------------------------------
  1574.  */
  1575.  
  1576. static unsigned char *
  1577. EncodeCmdLocMap(envPtr, codePtr, startPtr)
  1578.      CompileEnv *envPtr;    /* Points to compilation environment
  1579.                  * structure containing the CmdLocation
  1580.                  * structure to encode. */
  1581.      ByteCode *codePtr;        /* ByteCode in which to encode envPtr's
  1582.                  * command location information. */
  1583.      unsigned char *startPtr;    /* Points to the first byte in codePtr's
  1584.                  * memory block where the location
  1585.                  * information is to be stored. */
  1586. {
  1587.     register CmdLocation *mapPtr = envPtr->cmdMapPtr;
  1588.     int numCmds = envPtr->numCommands;
  1589.     register unsigned char *p = startPtr;
  1590.     int codeDelta, codeLen, srcDelta, srcLen, prevOffset;
  1591.     register int i;
  1592.     
  1593.     /*
  1594.      * Encode the code offset for each command as a sequence of deltas.
  1595.      */
  1596.  
  1597.     codePtr->codeDeltaStart = p;
  1598.     prevOffset = 0;
  1599.     for (i = 0;  i < numCmds;  i++) {
  1600.     codeDelta = (mapPtr[i].codeOffset - prevOffset);
  1601.     if (codeDelta < 0) {
  1602.         panic("EncodeCmdLocMap: bad code offset");
  1603.     } else if (codeDelta <= 127) {
  1604.         TclStoreInt1AtPtr(codeDelta, p);
  1605.         p++;
  1606.     } else {
  1607.         TclStoreInt1AtPtr(0xFF, p);
  1608.         p++;
  1609.         TclStoreInt4AtPtr(codeDelta, p);
  1610.         p += 4;
  1611.     }
  1612.     prevOffset = mapPtr[i].codeOffset;
  1613.     }
  1614.  
  1615.     /*
  1616.      * Encode the code length for each command.
  1617.      */
  1618.  
  1619.     codePtr->codeLengthStart = p;
  1620.     for (i = 0;  i < numCmds;  i++) {
  1621.     codeLen = mapPtr[i].numCodeBytes;
  1622.     if (codeLen < 0) {
  1623.         panic("EncodeCmdLocMap: bad code length");
  1624.     } else if (codeLen <= 127) {
  1625.         TclStoreInt1AtPtr(codeLen, p);
  1626.         p++;
  1627.     } else {
  1628.         TclStoreInt1AtPtr(0xFF, p);
  1629.         p++;
  1630.         TclStoreInt4AtPtr(codeLen, p);
  1631.         p += 4;
  1632.     }
  1633.     }
  1634.  
  1635.     /*
  1636.      * Encode the source offset for each command as a sequence of deltas.
  1637.      */
  1638.  
  1639.     codePtr->srcDeltaStart = p;
  1640.     prevOffset = 0;
  1641.     for (i = 0;  i < numCmds;  i++) {
  1642.     srcDelta = (mapPtr[i].srcOffset - prevOffset);
  1643.     if ((-127 <= srcDelta) && (srcDelta <= 127)) {
  1644.         TclStoreInt1AtPtr(srcDelta, p);
  1645.         p++;
  1646.     } else {
  1647.         TclStoreInt1AtPtr(0xFF, p);
  1648.         p++;
  1649.         TclStoreInt4AtPtr(srcDelta, p);
  1650.         p += 4;
  1651.     }
  1652.     prevOffset = mapPtr[i].srcOffset;
  1653.     }
  1654.  
  1655.     /*
  1656.      * Encode the source length for each command.
  1657.      */
  1658.  
  1659.     codePtr->srcLengthStart = p;
  1660.     for (i = 0;  i < numCmds;  i++) {
  1661.     srcLen = mapPtr[i].numSrcChars;
  1662.     if (srcLen < 0) {
  1663.         panic("EncodeCmdLocMap: bad source length");
  1664.     } else if (srcLen <= 127) {
  1665.         TclStoreInt1AtPtr(srcLen, p);
  1666.         p++;
  1667.     } else {
  1668.         TclStoreInt1AtPtr(0xFF, p);
  1669.         p++;
  1670.         TclStoreInt4AtPtr(srcLen, p);
  1671.         p += 4;
  1672.     }
  1673.     }
  1674.     
  1675.     return p;
  1676. }
  1677.  
  1678. /*
  1679.  *----------------------------------------------------------------------
  1680.  *
  1681.  * TclCompileString --
  1682.  *
  1683.  *    Compile a Tcl script in a null-terminated binary string.
  1684.  *
  1685.  * Results:
  1686.  *    The return value is TCL_OK on a successful compilation and TCL_ERROR
  1687.  *    on failure. If TCL_ERROR is returned, then the interpreter's result
  1688.  *    contains an error message.
  1689.  *
  1690.  *    envPtr->termOffset and interp->termOffset are filled in with the
  1691.  *    offset of the character in the string just after the last one
  1692.  *    successfully processed; this might be the offset of the ']' (if
  1693.  *    flags & TCL_BRACKET_TERM), or the offset of the '\0' at the end of
  1694.  *    the string. Also updates envPtr->maxStackDepth with the maximum
  1695.  *    number of stack elements needed to execute the string's commands.
  1696.  *
  1697.  * Side effects:
  1698.  *    Adds instructions to envPtr to evaluate the string at runtime.
  1699.  *
  1700.  *----------------------------------------------------------------------
  1701.  */
  1702.  
  1703. int
  1704. TclCompileString(interp, string, lastChar, flags, envPtr)
  1705.     Tcl_Interp *interp;        /* Used for error reporting. */
  1706.     char *string;        /* The source string to compile. */
  1707.     char *lastChar;        /* Pointer to terminating character of
  1708.                  * string. */
  1709.     int flags;            /* Flags to control compilation (same as
  1710.                  * passed to Tcl_Eval). */
  1711.     CompileEnv *envPtr;        /* Holds resulting instructions. */
  1712. {
  1713.     Interp *iPtr = (Interp *) interp;
  1714.     register char *src = string;/* Points to current source char. */
  1715.     register char c = *src;    /* The current char. */
  1716.     register int type;        /* Current char's CHAR_TYPE type. */
  1717.     char termChar = (char)((flags & TCL_BRACKET_TERM)? ']' : '\0');
  1718.                 /* Return when this character is found
  1719.                  * (either ']' or '\0'). Zero means newlines
  1720.                  * terminate cmds. */
  1721.     int isFirstCmd = 1;        /* 1 if compiling the first cmd. */
  1722.     char *cmdSrcStart = NULL;    /* Points to first non-blank char in each
  1723.                   * command. Initialized to avoid compiler
  1724.                   * warning. */
  1725.     int cmdIndex;        /* The index of the current command in the
  1726.                   * compilation environment's command
  1727.                   * location table. Initialized to avoid
  1728.                   * compiler warning. */
  1729.     int cmdCodeOffset = -1;    /* Offset of first byte of current command's
  1730.                   * code. Initialized to avoid compiler
  1731.                   * warning. */
  1732.     int cmdCodeBytes;        /* Number of code bytes for current
  1733.                  * command. */
  1734.     int cmdWords;        /* Number of words in current command. */
  1735.     Tcl_Command cmd;        /* Used to search for commands. */
  1736.     Command *cmdPtr;        /* Points to command's Command structure if
  1737.                  * first word is simple and command was
  1738.                  * found; else NULL. */
  1739.     int maxDepth = 0;        /* Maximum number of stack elements needed
  1740.                  * to execute all cmds. */
  1741.     char *termPtr;        /* Points to char that terminated word. */
  1742.     char savedChar;        /* Holds the character from string
  1743.                  * termporarily replaced by a null character
  1744.                  * during processing of words. */
  1745.     int objIndex = -1;        /* The object array index for a pushed
  1746.                   * object holding a word or word part
  1747.                   * Initialized to avoid compiler warning. */
  1748.     unsigned char *entryCodeNext = envPtr->codeNext;
  1749.                     /* Value of envPtr's current instruction
  1750.                  * pointer at entry. Used to tell if any
  1751.                  * instructions generated. */
  1752.     char *ellipsis = "";    /* Used to set errorInfo variable; "..."
  1753.                  * indicates that not all of offending
  1754.                  * command is included in errorInfo. ""
  1755.                  * means that the command is all there. */
  1756.     Tcl_Obj *objPtr;
  1757.     int numChars;
  1758.     int result = TCL_OK;
  1759.     int savePushSimpleWords = envPtr->pushSimpleWords;
  1760.  
  1761.     /*
  1762.      * commands: command {(';' | '\n') command}
  1763.      */
  1764.  
  1765.     while ((src != lastChar) && (c != termChar)) {
  1766.     /*
  1767.      * Skip white space, semicolons, backslash-newlines (treated as
  1768.      * spaces), and comments before command.
  1769.      */
  1770.  
  1771.     type = CHAR_TYPE(src, lastChar);
  1772.     while ((type & (TCL_SPACE | TCL_BACKSLASH))
  1773.             || (c == '\n') || (c == ';')) {
  1774.         if (type == TCL_BACKSLASH) {
  1775.         if (src[1] == '\n') {
  1776.             src += 2;
  1777.         } else {
  1778.             break;
  1779.         }
  1780.         } else {
  1781.         src++;
  1782.         }
  1783.         c = *src;
  1784.         type = CHAR_TYPE(src, lastChar);
  1785.     }
  1786.  
  1787.     if (c == '#') {
  1788.         while (src != lastChar) {
  1789.         if (c == '\\') {
  1790.             int numRead;
  1791.             Tcl_Backslash(src, &numRead);
  1792.             src += numRead;
  1793.         } else if (c == '\n') {
  1794.             src++;
  1795.             c = *src;
  1796.             envPtr->termOffset = (src - string);
  1797.             break;
  1798.         } else {
  1799.             src++;
  1800.         }
  1801.         c = *src;
  1802.         }
  1803.         continue;    /* end of comment, restart outer command loop */
  1804.     }
  1805.  
  1806.     /*
  1807.      * Compile one command: zero or more words terminated by a '\n',
  1808.      * ';', ']' (if command is terminated by close bracket), or
  1809.      * the end of string.
  1810.      *
  1811.      * command: word*
  1812.      */
  1813.  
  1814.     type = CHAR_TYPE(src, lastChar);
  1815.     if ((type == TCL_COMMAND_END) 
  1816.             && ((c != ']') || (flags & TCL_BRACKET_TERM))) {
  1817.         continue;  /* empty command; restart outer cmd loop */
  1818.     }
  1819.  
  1820.     /*
  1821.      * If not the first command, discard the previous command's result.
  1822.      */
  1823.     
  1824.     if (!isFirstCmd) {
  1825.         TclEmitOpcode(INST_POP, envPtr);
  1826.         if (!(flags & TCL_BRACKET_TERM)) {
  1827.         /*
  1828.          * We are compiling a top level command. Update the number
  1829.          * of code bytes for the last command to account for the pop
  1830.          * instruction we just emitted.
  1831.          */
  1832.         
  1833.         int lastCmdIndex = (envPtr->numCommands - 1);
  1834.         cmdCodeBytes =
  1835.             (envPtr->codeNext - envPtr->codeStart - cmdCodeOffset);
  1836.             (envPtr->cmdMapPtr[lastCmdIndex]).numCodeBytes =
  1837.             cmdCodeBytes;
  1838.         }
  1839.     }
  1840.  
  1841.     /*
  1842.      * Compile the words of the command. Process the first word
  1843.      * specially, since it is the name of a command. If it is a "simple"
  1844.      * string (just a sequence of characters), look it up in the table
  1845.      * of compilation procedures. If a word other than the first is
  1846.      * simple and represents an integer whose formatted representation
  1847.      * is the same as the word, just push an integer object. Also record
  1848.      * starting source and object information for the command.
  1849.      */
  1850.  
  1851.     cmdSrcStart = src;
  1852.     cmdCodeOffset = (envPtr->codeNext - envPtr->codeStart);
  1853.     cmdWords = 0;
  1854.     
  1855.     envPtr->numCommands++;
  1856.     cmdIndex = (envPtr->numCommands - 1);
  1857.     EnterCmdStartData(envPtr, cmdIndex,
  1858.             (cmdSrcStart - envPtr->source), cmdCodeOffset);
  1859.         
  1860.     if ((!(flags & TCL_BRACKET_TERM))
  1861.             && (tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
  1862.         /*
  1863.          * Display a line summarizing the top level command we are about
  1864.          * to compile.
  1865.          */
  1866.         
  1867.         char *p = cmdSrcStart;
  1868.         int numChars, complete;
  1869.         
  1870.         while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)
  1871.            || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) {
  1872.         p++;
  1873.         }
  1874.         numChars = (p - cmdSrcStart);
  1875.         complete = 1;
  1876.         if (numChars > 60) {
  1877.         numChars = 60;
  1878.         complete = 0;
  1879.         } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) {
  1880.         complete = 0;
  1881.         }
  1882.         fprintf(stdout, "Compiling: %.*s%s\n",
  1883.             numChars, cmdSrcStart, (complete? "" : " ..."));
  1884.     }
  1885.     
  1886.     while ((type != TCL_COMMAND_END)
  1887.             || ((c == ']') && !(flags & TCL_BRACKET_TERM))) {
  1888.         /*
  1889.          * Skip any leading white space at the start of a word. Note
  1890.          * that a backslash-newline is treated as a space.
  1891.          */
  1892.  
  1893.         while (type & (TCL_SPACE | TCL_BACKSLASH)) {
  1894.         if (type == TCL_BACKSLASH) {
  1895.             if (src[1] == '\n') {
  1896.             src += 2;
  1897.             } else {
  1898.             break;
  1899.             }
  1900.         } else {
  1901.             src++;
  1902.         }
  1903.         c = *src;
  1904.         type = CHAR_TYPE(src, lastChar);
  1905.         }
  1906.         if ((type == TCL_COMMAND_END) 
  1907.                 && ((c != ']') || (flags & TCL_BRACKET_TERM))) {
  1908.         break;        /* no words remain for command. */
  1909.         }
  1910.  
  1911.         /*
  1912.          * Compile one word. We use an inline version of CompileWord to
  1913.          * avoid an extra procedure call.
  1914.          */
  1915.  
  1916.         envPtr->pushSimpleWords = 0;
  1917.         if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
  1918.         src++;
  1919.         if (type == TCL_QUOTE) {
  1920.             result = TclCompileQuotes(interp, src, lastChar,
  1921.                 '"', flags, envPtr);
  1922.         } else {
  1923.             result = CompileBraces(interp, src, lastChar,
  1924.                 flags, envPtr);
  1925.         }
  1926.         termPtr = (src + envPtr->termOffset);
  1927.         if (result != TCL_OK) {
  1928.             src = termPtr;
  1929.             goto done;
  1930.         }
  1931.  
  1932.         /*
  1933.          * Make sure terminating character of the quoted or braced
  1934.          * string is the end of word.
  1935.          */
  1936.         
  1937.         c = *termPtr;
  1938.         if ((c == '\\') && (*(termPtr+1) == '\n')) {
  1939.             /*
  1940.              * Line is continued on next line; the backslash-
  1941.              * newline turns into space, which terminates the word.
  1942.              */
  1943.         } else {
  1944.             type = CHAR_TYPE(termPtr, lastChar);
  1945.             if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) {
  1946.             Tcl_ResetResult(interp);
  1947.             if (*(src-1) == '"') {
  1948.                 Tcl_AppendToObj(Tcl_GetObjResult(interp),
  1949.                     "extra characters after close-quote", -1);
  1950.             } else {
  1951.                 Tcl_AppendToObj(Tcl_GetObjResult(interp),
  1952.                     "extra characters after close-brace", -1);
  1953.             }
  1954.             result = TCL_ERROR;
  1955.             }
  1956.         }
  1957.         } else {
  1958.         result = CompileMultipartWord(interp, src, lastChar,
  1959.             flags, envPtr);
  1960.         termPtr = (src + envPtr->termOffset);
  1961.         }
  1962.         if (result != TCL_OK) {
  1963.         ellipsis = "...";
  1964.         src = termPtr;
  1965.         goto done;
  1966.         }
  1967.         
  1968.         if (envPtr->wordIsSimple) {
  1969.         /*
  1970.          * A simple word. Temporarily replace the terminating
  1971.          * character with a null character.
  1972.          */
  1973.         
  1974.         numChars = envPtr->numSimpleWordChars;
  1975.         savedChar = src[numChars];
  1976.         src[numChars] = '\0';
  1977.  
  1978.         if ((cmdWords == 0)
  1979.                 && (!(iPtr->flags & DONT_COMPILE_CMDS_INLINE))) {
  1980.             /*
  1981.              * The first word of a command and inline command
  1982.              * compilation has not been disabled (e.g., by command
  1983.              * traces). Look up the first word in the interpreter's
  1984.              * hashtable of commands. If a compilation procedure is
  1985.              * found, let it compile the command after resetting
  1986.              * error logging information. Note that if we are
  1987.              * compiling a procedure, we must look up the command
  1988.              * in the procedure's namespace and not the current
  1989.              * namespace.
  1990.              */
  1991.  
  1992.             Namespace *cmdNsPtr;
  1993.  
  1994.             if (envPtr->procPtr != NULL) {
  1995.             cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
  1996.             } else {
  1997.             cmdNsPtr = NULL;
  1998.             }
  1999.  
  2000.             cmdPtr = NULL;
  2001.             cmd = Tcl_FindCommand(interp, src,
  2002.                 (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
  2003.                     if (cmd != (Tcl_Command) NULL) {
  2004.                         cmdPtr = (Command *) cmd;
  2005.                     }
  2006.             if ((cmdPtr != NULL) && (cmdPtr->compileProc != NULL)) {
  2007.             char *firstArg = termPtr;
  2008.             src[numChars] = savedChar;
  2009.             iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS
  2010.                      | ERROR_CODE_SET);
  2011.             result = (*(cmdPtr->compileProc))(interp,
  2012.                 firstArg, lastChar, flags, envPtr);
  2013.             if (result == TCL_OK) {
  2014.                 src = (firstArg + envPtr->termOffset);
  2015.                 maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
  2016.                 goto finishCommand;
  2017.             } else if (result == TCL_OUT_LINE_COMPILE) {
  2018.                 result = TCL_OK;
  2019.                 src[numChars] = '\0';
  2020.             } else {
  2021.                 src = firstArg;
  2022.                 goto done;           /* an error */
  2023.             }
  2024.             }
  2025.  
  2026.             /*
  2027.              * No compile procedure was found for the command: push
  2028.              * the word and continue to compile the remaining
  2029.              * words. If a hashtable entry was found for the
  2030.              * command, push a CmdName object instead to avoid
  2031.              * runtime lookups. If necessary, convert the pushed
  2032.              * object to be a CmdName object. If this is the first
  2033.              * CmdName object in this code unit that refers to the
  2034.              * command, increment the reference count in the
  2035.              * Command structure to reflect the new reference from
  2036.              * the CmdName object and, if the command is deleted
  2037.              * later, to keep the Command structure from being freed
  2038.              * until TclExecuteByteCode has a chance to recognize
  2039.              * that the command was deleted.
  2040.              */
  2041.  
  2042.             objIndex = TclObjIndexForString(src, numChars,
  2043.                 /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
  2044.             if (cmdPtr != NULL) {
  2045.             objPtr = envPtr->objArrayPtr[objIndex];
  2046.             if ((objPtr->typePtr != &tclCmdNameType)
  2047.                     && (objPtr->bytes != NULL)) {
  2048.                 ResolvedCmdName *resPtr = (ResolvedCmdName *)
  2049.                                     ckalloc(sizeof(ResolvedCmdName));
  2050.                             Namespace *nsPtr = (Namespace *) 
  2051.                     Tcl_GetCurrentNamespace(interp);
  2052.  
  2053.                             resPtr->cmdPtr = cmdPtr;
  2054.                             resPtr->refNsPtr = nsPtr;
  2055.                 resPtr->refNsId = nsPtr->nsId;
  2056.                             resPtr->refNsCmdEpoch = nsPtr->cmdRefEpoch;
  2057.                             resPtr->cmdEpoch = cmdPtr->cmdEpoch;
  2058.                             resPtr->refCount = 1;
  2059.                 objPtr->internalRep.twoPtrValue.ptr1 =
  2060.                 (VOID *) resPtr;
  2061.                 objPtr->internalRep.twoPtrValue.ptr2 = NULL;
  2062.                             objPtr->typePtr = &tclCmdNameType;
  2063.                 cmdPtr->refCount++;
  2064.             }
  2065.             }
  2066.         } else {
  2067.             /*
  2068.              * See if the word represents an integer whose formatted
  2069.              * representation is the same as the word (e.g., this is
  2070.              * true for 123 and -1 but not for 00005). If so, just
  2071.              * push an integer object.
  2072.              */
  2073.  
  2074.             int isCompilableInt = 0;
  2075.             long n;
  2076.             char buf[40];
  2077.             
  2078.             if (TclLooksLikeInt(src)) {
  2079.             int code = TclGetLong(interp, src, &n);
  2080.             if (code == TCL_OK) {
  2081.                 TclFormatInt(buf, n);
  2082.                 if (strcmp(src, buf) == 0) {
  2083.                 isCompilableInt = 1;
  2084.                 objIndex = TclObjIndexForString(src,
  2085.                     numChars, /*allocStrRep*/ 0,
  2086.                     /*inHeap*/ 0, envPtr);
  2087.                 objPtr = envPtr->objArrayPtr[objIndex];
  2088.  
  2089.                 Tcl_InvalidateStringRep(objPtr);
  2090.                 objPtr->internalRep.longValue = n;
  2091.                 objPtr->typePtr = &tclIntType;
  2092.                 }
  2093.             } else {
  2094.                 Tcl_ResetResult(interp);
  2095.             }
  2096.             }
  2097.             if (!isCompilableInt) {
  2098.             objIndex = TclObjIndexForString(src, numChars,
  2099.                     /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
  2100.             }
  2101.         }
  2102.         src[numChars] = savedChar;
  2103.         TclEmitPush(objIndex, envPtr);
  2104.         maxDepth = TclMax((cmdWords + 1), maxDepth);
  2105.         } else {        /* not a simple word */
  2106.         maxDepth = TclMax((cmdWords + envPtr->maxStackDepth),
  2107.                    maxDepth);
  2108.         }
  2109.         src = termPtr;
  2110.         c = *src;
  2111.         type = CHAR_TYPE(src, lastChar);
  2112.         cmdWords++;
  2113.     }
  2114.     
  2115.     /*
  2116.      * Emit an invoke instruction for the command. If a compile command
  2117.      * was found for the command we called it and skipped this.
  2118.      */
  2119.  
  2120.     if (cmdWords > 0) {
  2121.         if (cmdWords <= 255) {
  2122.             TclEmitInstUInt1(INST_INVOKE_STK1, cmdWords, envPtr);
  2123.             } else {
  2124.             TclEmitInstUInt4(INST_INVOKE_STK4, cmdWords, envPtr);
  2125.             }
  2126.     }
  2127.  
  2128.     /*
  2129.      * Update the compilation environment structure. Record
  2130.      * source/object information for the command.
  2131.      */
  2132.  
  2133.         finishCommand:
  2134.     cmdCodeBytes = envPtr->codeNext - envPtr->codeStart - cmdCodeOffset;
  2135.     EnterCmdExtentData(envPtr, cmdIndex, src-cmdSrcStart, cmdCodeBytes);
  2136.     
  2137.     isFirstCmd = 0;
  2138.     envPtr->termOffset = (src - string);
  2139.     c = *src;
  2140.     }
  2141.  
  2142.     done:
  2143.     if (result == TCL_OK) {
  2144.     /*
  2145.      * If the source string yielded no instructions (e.g., if it was
  2146.      * empty), push an empty string object as the command's result.
  2147.      */
  2148.     
  2149.     if (entryCodeNext == envPtr->codeNext) {
  2150.         int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0,
  2151.                                                 /*inHeap*/ 0, envPtr);
  2152.         TclEmitPush(objIndex, envPtr);
  2153.         maxDepth = 1;
  2154.     }
  2155.     } else {
  2156.     /*
  2157.      * Add additional error information. First compute the line number
  2158.      * where the error occurred.
  2159.      */
  2160.  
  2161.     register char *p;
  2162.     int numChars;
  2163.     char buf[200];
  2164.  
  2165.     iPtr->errorLine = 1;
  2166.     for (p = string;  p != cmdSrcStart;  p++) {
  2167.         if (*p == '\n') {
  2168.         iPtr->errorLine++;
  2169.         }
  2170.     }
  2171.     for (  ; isspace(UCHAR(*p)) || (*p == ';');  p++) {
  2172.         if (*p == '\n') {
  2173.         iPtr->errorLine++;
  2174.         }
  2175.     }
  2176.  
  2177.     /*
  2178.      * Figure out how much of the command to print (up to a certain
  2179.      * number of characters, or up to the end of the command).
  2180.      */
  2181.  
  2182.     p = cmdSrcStart;
  2183.     while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)
  2184.         || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) {
  2185.         p++;
  2186.     }
  2187.     numChars = (p - cmdSrcStart);
  2188.     if (numChars > 150) {
  2189.         numChars = 150;
  2190.         ellipsis = " ...";
  2191.     } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) {
  2192.         ellipsis = " ...";
  2193.     }
  2194.     
  2195.     sprintf(buf, "\n    while compiling\n\"%.*s%s\"",
  2196.         numChars, cmdSrcStart, ellipsis);
  2197.     Tcl_AddObjErrorInfo(interp, buf, -1);
  2198.     } 
  2199.     
  2200.     envPtr->termOffset = (src - string);
  2201.     iPtr->termOffset = envPtr->termOffset;
  2202.     envPtr->maxStackDepth = maxDepth;
  2203.     envPtr->pushSimpleWords = savePushSimpleWords;
  2204.     return result;
  2205. }
  2206.  
  2207. /*
  2208.  *----------------------------------------------------------------------
  2209.  *
  2210.  * CompileWord --
  2211.  *
  2212.  *    This procedure compiles one word from a command string. It skips
  2213.  *    any leading white space.
  2214.  *
  2215.  *    Ordinarily, callers set envPtr->pushSimpleWords to 1 and this
  2216.  *    procedure emits push and other instructions to compute the
  2217.  *    word on the Tcl evaluation stack at execution time. If a caller sets
  2218.  *    envPtr->pushSimpleWords to 0, CompileWord will _not_ compile
  2219.  *    "simple" words: words that are just a sequence of characters without
  2220.  *    backslashes. It will leave their compilation up to the caller.
  2221.  *
  2222.  *    As an important special case, if the word is simple, this procedure
  2223.  *    sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
  2224.  *    number of characters in the simple word. This allows the caller to
  2225.  *    process these words specially.
  2226.  *
  2227.  * Results:
  2228.  *    The return value is a standard Tcl result. If an error occurs, an
  2229.  *    error message is left in the interpreter's result.
  2230.  *    
  2231.  *    envPtr->termOffset is filled in with the offset of the character in
  2232.  *    "string" just after the last one successfully processed in the last
  2233.  *    word. This is normally the character just after the last one in a
  2234.  *    word (perhaps the command terminator), or the vicinity of an error
  2235.  *    (if the result is not TCL_OK).
  2236.  *
  2237.  *    envPtr->wordIsSimple is set 1 if the word is simple: just a
  2238.  *    sequence of characters without backslashes. If so, the word's
  2239.  *    characters are the envPtr->numSimpleWordChars characters starting 
  2240.  *    at string.
  2241.  *
  2242.  *    envPtr->maxStackDepth is updated with the maximum number of stack
  2243.  *    elements needed to evaluate the word. This is not changed if
  2244.  *    the word is simple and envPtr->pushSimpleWords was 0 (false).
  2245.  *
  2246.  * Side effects:
  2247.  *    Instructions are added to envPtr to compute and push the word
  2248.  *    at runtime.
  2249.  *
  2250.  *----------------------------------------------------------------------
  2251.  */
  2252.  
  2253. static int
  2254. CompileWord(interp, string, lastChar, flags, envPtr)
  2255.     Tcl_Interp *interp;        /* Interpreter to use for nested command
  2256.                  * evaluations and error messages. */
  2257.     char *string;        /* First character of word. */
  2258.     char *lastChar;         /* Pointer to terminating character of
  2259.                   * string. */
  2260.     int flags;            /* Flags to control compilation (same values
  2261.                  * passed to Tcl_EvalObj). */
  2262.     CompileEnv *envPtr;        /* Holds the resulting instructions. */
  2263. {
  2264.     /*
  2265.      * Compile one word: approximately
  2266.      *
  2267.      * word:             quoted_string | braced_string | multipart_word
  2268.      * quoted_string:    '"' char* '"'
  2269.      * braced_string:    '{' char* '}'
  2270.      * multipart_word    (see CompileMultipartWord below)
  2271.      */
  2272.     
  2273.     register char *src = string; /* Points to current source char. */
  2274.     register int type = CHAR_TYPE(src, lastChar);
  2275.                  /* Current char's CHAR_TYPE type. */
  2276.     int maxDepth = 0;         /* Maximum number of stack elements needed
  2277.                   * to compute and push the word. */
  2278.     char *termPtr = src;     /* Points to the character that terminated
  2279.                   * the word. */
  2280.     int result = TCL_OK;
  2281.  
  2282.     /*
  2283.      * Skip any leading white space at the start of a word. Note that a
  2284.      * backslash-newline is treated as a space.
  2285.      */
  2286.  
  2287.     while (type & (TCL_SPACE | TCL_BACKSLASH)) {
  2288.     if (type == TCL_BACKSLASH) {
  2289.         if (src[1] == '\n') {
  2290.         src += 2;
  2291.         } else {
  2292.         break;        /* no longer white space */
  2293.         }
  2294.     } else {
  2295.         src++;
  2296.     }
  2297.     type = CHAR_TYPE(src, lastChar);
  2298.     }
  2299.     if (type == TCL_COMMAND_END) {
  2300.     goto done;
  2301.     }
  2302.  
  2303.     /*
  2304.      * Compile the word. Handle quoted and braced string words here in order
  2305.      * to avoid an extra procedure call.
  2306.      */
  2307.  
  2308.     if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
  2309.     src++;
  2310.     if (type == TCL_QUOTE) {
  2311.         result = TclCompileQuotes(interp, src, lastChar, '"', flags,
  2312.             envPtr);
  2313.     } else {
  2314.         result = CompileBraces(interp, src, lastChar, flags, envPtr);
  2315.     }
  2316.     termPtr = (src + envPtr->termOffset);
  2317.     if (result != TCL_OK) {
  2318.         goto done;
  2319.     }
  2320.     
  2321.     /*
  2322.      * Make sure terminating character of the quoted or braced string is
  2323.      * the end of word.
  2324.      */
  2325.     
  2326.     if ((*termPtr == '\\') && (*(termPtr+1) == '\n')) {
  2327.         /*
  2328.          * Line is continued on next line; the backslash-newline turns
  2329.          * into space, which terminates the word.
  2330.          */
  2331.     } else {
  2332.         type = CHAR_TYPE(termPtr, lastChar);
  2333.         if (!(type & (TCL_SPACE | TCL_COMMAND_END))) {
  2334.         Tcl_ResetResult(interp);
  2335.         if (*(src-1) == '"') {
  2336.             Tcl_AppendToObj(Tcl_GetObjResult(interp),
  2337.                     "extra characters after close-quote", -1);
  2338.         } else {
  2339.             Tcl_AppendToObj(Tcl_GetObjResult(interp),
  2340.                 "extra characters after close-brace", -1);
  2341.         }
  2342.         result = TCL_ERROR;
  2343.         goto done;
  2344.         }
  2345.     }
  2346.     maxDepth = envPtr->maxStackDepth;
  2347.     } else {
  2348.     result = CompileMultipartWord(interp, src, lastChar, flags, envPtr);
  2349.     termPtr = (src + envPtr->termOffset);
  2350.     maxDepth = envPtr->maxStackDepth;
  2351.     }
  2352.  
  2353.     /*
  2354.      * Done processing the word. The values of envPtr->wordIsSimple and
  2355.      * envPtr->numSimpleWordChars are left at the values returned by
  2356.      * TclCompileQuotes/Braces/MultipartWord.
  2357.      */
  2358.     
  2359.     done:
  2360.     envPtr->termOffset = (termPtr - string);
  2361.     envPtr->maxStackDepth = maxDepth;
  2362.     return result;
  2363. }
  2364.  
  2365. /*
  2366.  *----------------------------------------------------------------------
  2367.  *
  2368.  * CompileMultipartWord --
  2369.  *
  2370.  *    This procedure compiles one multipart word: a word comprised of some
  2371.  *    number of nested commands, variable references, or arbitrary
  2372.  *    characters. This procedure assumes that quoted string and braced
  2373.  *    string words and the end of command have already been handled by its
  2374.  *    caller. It also assumes that any leading white space has already
  2375.  *    been consumed.
  2376.  *
  2377.  *    Ordinarily, callers set envPtr->pushSimpleWords to 1 and this
  2378.  *    procedure emits push and other instructions to compute the word on
  2379.  *    the Tcl evaluation stack at execution time. If a caller sets
  2380.  *    envPtr->pushSimpleWords to 0, it will _not_ compile "simple" words:
  2381.  *    words that are just a sequence of characters without backslashes.
  2382.  *    It will leave their compilation up to the caller. This is done, for
  2383.  *    example, to provide special support for the first word of commands,
  2384.  *    which are almost always the (simple) name of a command.
  2385.  *
  2386.  *    As an important special case, if the word is simple, this procedure
  2387.  *    sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
  2388.  *    number of characters in the simple word. This allows the caller to
  2389.  *    process these words specially.
  2390.  *
  2391.  * Results:
  2392.  *    The return value is a standard Tcl result. If an error occurs, an
  2393.  *    error message is left in the interpreter's result.
  2394.  *    
  2395.  *    envPtr->termOffset is filled in with the offset of the character in
  2396.  *    "string" just after the last one successfully processed in the last
  2397.  *    word. This is normally the character just after the last one in a
  2398.  *    word (perhaps the command terminator), or the vicinity of an error
  2399.  *    (if the result is not TCL_OK).
  2400.  *
  2401.  *    envPtr->wordIsSimple is set 1 if the word is simple: just a
  2402.  *    sequence of characters without backslashes. If so, the word's
  2403.  *    characters are the envPtr->numSimpleWordChars characters starting 
  2404.  *    at string.
  2405.  *
  2406.  *    envPtr->maxStackDepth is updated with the maximum number of stack
  2407.  *    elements needed to evaluate the word. This is not changed if
  2408.  *    the word is simple and envPtr->pushSimpleWords was 0 (false).
  2409.  *
  2410.  * Side effects:
  2411.  *    Instructions are added to envPtr to compute and push the word
  2412.  *    at runtime.
  2413.  *
  2414.  *----------------------------------------------------------------------
  2415.  */
  2416.  
  2417. static int
  2418. CompileMultipartWord(interp, string, lastChar, flags, envPtr)
  2419.     Tcl_Interp *interp;        /* Interpreter to use for nested command
  2420.                  * evaluations and error messages. */
  2421.     char *string;        /* First character of word. */
  2422.     char *lastChar;         /* Pointer to terminating character of
  2423.                   * string. */
  2424.     int flags;            /* Flags to control compilation (same values
  2425.                  * passed to Tcl_EvalObj). */
  2426.     CompileEnv *envPtr;        /* Holds the resulting instructions. */
  2427. {
  2428.     /*
  2429.      * Compile one multi_part word:
  2430.      *
  2431.      * multi_part_word:  word_part+
  2432.      * word_part:        nested_cmd | var_reference | char+
  2433.      * nested_cmd:       '[' command ']'
  2434.      * var_reference:    '$' name | '$' name '(' index_string ')' |
  2435.      *                   '$' '{' braced_name '}')
  2436.      * name:             (letter | digit | underscore)+
  2437.      * braced_name:      (non_close_brace_char)*
  2438.      * index_string:     (non_close_paren_char)*
  2439.      */
  2440.     
  2441.     register char *src = string; /* Points to current source char. */
  2442.     register char c = *src;    /* The current char. */
  2443.     register int type;        /* Current char's CHAR_TYPE type. */
  2444.     int bracketNormal = !(flags & TCL_BRACKET_TERM);
  2445.     int simpleWord = 0;        /* Set 1 if word is simple. */
  2446.     int numParts = 0;        /* Count of word_part objs pushed. */
  2447.     int maxDepth = 0;        /* Maximum number of stack elements needed
  2448.                  * to compute and push the word. */
  2449.     char *start;        /* Starting position of char+ word_part. */
  2450.     int hasBackslash;        /* Nonzero if '\' in char+ word_part. */
  2451.     int numChars;        /* Number of chars in char+ word_part. */
  2452.     char savedChar;        /* Holds the character from string
  2453.                  * termporarily replaced by a null character
  2454.                  * during word_part processing. */
  2455.     int objIndex;        /* The object array index for a pushed
  2456.                  * object holding a word_part. */
  2457.     int savePushSimpleWords = envPtr->pushSimpleWords;
  2458.     int result = TCL_OK;
  2459.     int numRead;
  2460.  
  2461.     type = CHAR_TYPE(src, lastChar);
  2462.     while (1) {
  2463.     /*
  2464.      * Process a word_part: a sequence of chars, a var reference, or
  2465.      * a nested command.
  2466.      */
  2467.  
  2468.     if ((type & (TCL_NORMAL | TCL_CLOSE_BRACE | TCL_BACKSLASH |
  2469.              TCL_QUOTE | TCL_OPEN_BRACE)) ||
  2470.         ((c == ']') && bracketNormal)) {
  2471.         /*
  2472.          * A char+ word part. Scan first looking for any backslashes.
  2473.          * Note that a backslash-newline must be treated as a word
  2474.          * separator, as if the backslash-newline had been collapsed
  2475.          * before command parsing began.
  2476.          */
  2477.         
  2478.         start = src;
  2479.         hasBackslash = 0;
  2480.         do {
  2481.         if (type == TCL_BACKSLASH) {
  2482.             hasBackslash = 1;
  2483.             Tcl_Backslash(src, &numRead);
  2484.             if (src[1] == '\n') {
  2485.             src += numRead;
  2486.             type = TCL_SPACE; /* force word end */
  2487.             break;
  2488.             }
  2489.             src += numRead;
  2490.         } else {
  2491.             src++;
  2492.         }
  2493.         c = *src;
  2494.         type = CHAR_TYPE(src, lastChar);
  2495.         } while (type & (TCL_NORMAL | TCL_BACKSLASH | TCL_QUOTE |
  2496.                 TCL_OPEN_BRACE | TCL_CLOSE_BRACE)
  2497.                 || ((c == ']') && bracketNormal));
  2498.  
  2499.         if ((numParts == 0) && !hasBackslash
  2500.             && (type & (TCL_SPACE | TCL_COMMAND_END))) {
  2501.         /*
  2502.          * The word is "simple": just a sequence of characters
  2503.          * without backslashes terminated by a TCL_SPACE or
  2504.          * TCL_COMMAND_END. Just return if we are not to compile
  2505.          * simple words.
  2506.          */
  2507.  
  2508.         simpleWord = 1;
  2509.         if (!envPtr->pushSimpleWords) {
  2510.             envPtr->wordIsSimple = 1;
  2511.             envPtr->numSimpleWordChars = (src - string);
  2512.             envPtr->termOffset = envPtr->numSimpleWordChars;
  2513.             envPtr->pushSimpleWords = savePushSimpleWords;
  2514.             return TCL_OK;
  2515.         }
  2516.         }
  2517.  
  2518.         /*
  2519.          * Create and push a string object for the char+ word_part,
  2520.          * which starts at "start" and ends at the char just before
  2521.          * src. If backslashes were found, copy the word_part's
  2522.          * characters with substituted backslashes into a heap-allocated
  2523.          * buffer and use it to create the string object. Temporarily
  2524.          * replace the terminating character with a null character.
  2525.          */
  2526.  
  2527.         numChars = (src - start);
  2528.         savedChar = start[numChars];
  2529.         start[numChars] = '\0';
  2530.         if ((numChars > 0) && (hasBackslash)) {
  2531.         char *buffer = ckalloc((unsigned) numChars + 1);
  2532.         register char *dst = buffer;
  2533.         register char *p = start;
  2534.         while (p < src) {
  2535.             if (*p == '\\') {    
  2536.             *dst = Tcl_Backslash(p, &numRead);
  2537.             if (p[1] == '\n') {
  2538.                 break;
  2539.             }
  2540.             p += numRead;
  2541.             dst++;
  2542.             } else {
  2543.             *dst++ = *p++;
  2544.             }
  2545.         }
  2546.         *dst = '\0';
  2547.         objIndex = TclObjIndexForString(buffer, dst-buffer,
  2548.             /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr);
  2549.         } else {
  2550.         objIndex = TclObjIndexForString(start, numChars,
  2551.             /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
  2552.         }
  2553.         start[numChars] = savedChar;
  2554.         TclEmitPush(objIndex, envPtr);
  2555.         maxDepth = TclMax((numParts + 1), maxDepth);
  2556.     } else if (type == TCL_DOLLAR) {
  2557.         result = TclCompileDollarVar(interp, src, lastChar,
  2558.             flags, envPtr);
  2559.         src += envPtr->termOffset;
  2560.         if (result != TCL_OK) {
  2561.         goto done;
  2562.         }
  2563.         maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
  2564.         c = *src;
  2565.         type = CHAR_TYPE(src, lastChar);
  2566.     } else if (type == TCL_OPEN_BRACKET) {
  2567.         char *termPtr;
  2568.         envPtr->pushSimpleWords = 1;
  2569.         src++;
  2570.         result = TclCompileString(interp, src, lastChar,
  2571.                       (flags | TCL_BRACKET_TERM), envPtr);
  2572.         termPtr = (src + envPtr->termOffset);
  2573.         if (*termPtr == ']') {
  2574.         termPtr++;
  2575.         } else if (*termPtr == '\0') {
  2576.         /*
  2577.          * Missing ] at end of nested command.
  2578.          */
  2579.         
  2580.         Tcl_ResetResult(interp);
  2581.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  2582.                 "missing close-bracket", -1);
  2583.         result = TCL_ERROR;
  2584.         }
  2585.         src = termPtr;
  2586.         if (result != TCL_OK) {
  2587.         goto done;
  2588.         }
  2589.         maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
  2590.         c = *src;
  2591.         type = CHAR_TYPE(src, lastChar);
  2592.     } else if (type & (TCL_SPACE | TCL_COMMAND_END)) {
  2593.         goto wordEnd;
  2594.     }
  2595.     numParts++;
  2596.     } /* end of infinite loop */
  2597.  
  2598.     wordEnd:
  2599.     /*
  2600.      * End of a non-simple word: TCL_SPACE, TCL_COMMAND_END, or
  2601.      * backslash-newline. Concatenate the word_parts if necessary.
  2602.      */
  2603.  
  2604.     while (numParts > 255) {
  2605.     TclEmitInstUInt1(INST_CONCAT1, 255, envPtr);
  2606.     numParts -= 254;  /* concat pushes 1 obj, the result */
  2607.     }
  2608.     if (numParts > 1) {
  2609.     TclEmitInstUInt1(INST_CONCAT1, numParts, envPtr);
  2610.     }
  2611.  
  2612.     done:
  2613.     if (simpleWord) {
  2614.     envPtr->wordIsSimple = 1;
  2615.     envPtr->numSimpleWordChars = (src - string);
  2616.     } else {
  2617.     envPtr->wordIsSimple = 0;
  2618.     envPtr->numSimpleWordChars = 0;
  2619.     }
  2620.     envPtr->termOffset = (src - string);
  2621.     envPtr->maxStackDepth = maxDepth;
  2622.     envPtr->pushSimpleWords = savePushSimpleWords;
  2623.     return result;
  2624. }
  2625.  
  2626. /*
  2627.  *----------------------------------------------------------------------
  2628.  *
  2629.  * TclCompileQuotes --
  2630.  *
  2631.  *    This procedure compiles a double-quoted string such as a quoted Tcl
  2632.  *    command argument or a quoted value in a Tcl expression. This
  2633.  *    procedure is also used to compile array element names within
  2634.  *    parentheses (where the termChar will be ')' instead of '"'), or
  2635.  *    anything else that needs the substitutions that happen in quotes.
  2636.  *
  2637.  *    Ordinarily, callers set envPtr->pushSimpleWords to 1 and
  2638.  *    TclCompileQuotes always emits push and other instructions to compute
  2639.  *    the word on the Tcl evaluation stack at execution time. If a caller
  2640.  *    sets envPtr->pushSimpleWords to 0, TclCompileQuotes will not compile
  2641.  *    "simple" words: words that are just a sequence of characters without
  2642.  *    backslashes. It will leave their compilation up to the caller. This
  2643.  *    is done to provide special support for the first word of commands,
  2644.  *    which are almost always the (simple) name of a command.
  2645.  *
  2646.  *    As an important special case, if the word is simple, this procedure
  2647.  *    sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
  2648.  *    number of characters in the simple word. This allows the caller to
  2649.  *    process these words specially.
  2650.  *
  2651.  * Results:
  2652.  *    The return value is a standard Tcl result, which is TCL_OK unless
  2653.  *    there was an error while parsing the quoted string. If an error
  2654.  *    occurs then the interpreter's result contains a standard error
  2655.  *    message.
  2656.  *
  2657.  *    envPtr->termOffset is filled in with the offset of the character in
  2658.  *    "string" just after the last one successfully processed; this is
  2659.  *    usually the character just after the matching close-quote.
  2660.  *
  2661.  *    envPtr->wordIsSimple is set 1 if the word is simple: just a
  2662.  *    sequence of characters without backslashes. If so, the word's
  2663.  *    characters are the envPtr->numSimpleWordChars characters starting 
  2664.  *    at string.
  2665.  *
  2666.  *    envPtr->maxStackDepth is updated with the maximum number of stack
  2667.  *    elements needed to evaluate the word. This is not changed if
  2668.  *    the word is simple and envPtr->pushSimpleWords was 0 (false).
  2669.  *
  2670.  * Side effects:
  2671.  *    Instructions are added to envPtr to push the quoted-string
  2672.  *    at runtime.
  2673.  *
  2674.  *----------------------------------------------------------------------
  2675.  */
  2676.  
  2677. int
  2678. TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr)
  2679.     Tcl_Interp *interp;         /* Interpreter to use for nested command
  2680.                   * evaluations and error messages. */
  2681.     char *string;         /* Points to the character just after
  2682.                   * the opening '"' or '('. */
  2683.     char *lastChar;         /* Pointer to terminating character of
  2684.                   * string. */
  2685.     int termChar;         /* Character that terminates the "quoted"
  2686.                   * string (usually double-quote, but might
  2687.                   * be right-paren or something else). */
  2688.     int flags;             /* Flags to control compilation (same 
  2689.                   * values passed to Tcl_Eval). */
  2690.     CompileEnv *envPtr;         /* Holds the resulting instructions. */
  2691. {
  2692.     register char *src = string; /* Points to current source char. */
  2693.     register char c = *src;     /* The current char. */
  2694.     int simpleWord = 0;         /* Set 1 if a simple quoted string word. */
  2695.     char *start;         /* Start position of char+ string_part. */
  2696.     int hasBackslash;              /* 1 if '\' found in char+ string_part. */
  2697.     int numRead;         /* Count of chars read by Tcl_Backslash. */
  2698.     int numParts = 0;             /* Count of string_part objs pushed. */
  2699.     int maxDepth = 0;         /* Maximum number of stack elements needed
  2700.                   * to compute and push the string. */
  2701.     char savedChar;         /* Holds the character from string
  2702.                   * termporarily replaced by a null 
  2703.                   * char during string_part processing. */
  2704.     int objIndex;         /* The object array index for a pushed
  2705.                   * object holding a string_part. */
  2706.     int numChars;         /* Number of chars in string_part. */
  2707.     int savePushSimpleWords = envPtr->pushSimpleWords;
  2708.     int result = TCL_OK;
  2709.     
  2710.     /*
  2711.      * quoted_string: '"' string_part* '"'   (or termChar instead of ")
  2712.      * string_part:   var_reference | nested_cmd | char+
  2713.      */
  2714.  
  2715.  
  2716.     while ((src != lastChar) && (c != termChar)) {
  2717.     if (c == '$') {
  2718.         result = TclCompileDollarVar(interp, src, lastChar, flags,
  2719.             envPtr);
  2720.         src += envPtr->termOffset;
  2721.         if (result != TCL_OK) {
  2722.         goto done;
  2723.         }
  2724.         maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
  2725.         c = *src;
  2726.         } else if (c == '[') {
  2727.         char *termPtr;
  2728.         envPtr->pushSimpleWords = 1;
  2729.         src++;
  2730.         result = TclCompileString(interp, src, lastChar,
  2731.                       (flags | TCL_BRACKET_TERM), envPtr);
  2732.         termPtr = (src + envPtr->termOffset);
  2733.         if (*termPtr == ']') {
  2734.         termPtr++;
  2735.         }
  2736.         src = termPtr;
  2737.         if (result != TCL_OK) {
  2738.         goto done;
  2739.         }
  2740.         if (termPtr == lastChar) {
  2741.         /*
  2742.          * Missing ] at end of nested command.
  2743.          */
  2744.         
  2745.         Tcl_ResetResult(interp);
  2746.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  2747.                 "missing close-bracket", -1);
  2748.         result = TCL_ERROR;
  2749.         goto done;
  2750.         }
  2751.         maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
  2752.         c = *src;
  2753.         } else {
  2754.         /*
  2755.          * Start of a char+ string_part. Scan first looking for any
  2756.          * backslashes.
  2757.          */
  2758.  
  2759.         start = src;
  2760.         hasBackslash = 0;
  2761.         do {
  2762.         if (c == '\\') {
  2763.             hasBackslash = 1;
  2764.             Tcl_Backslash(src, &numRead);
  2765.             src += numRead;
  2766.         } else {
  2767.             src++;
  2768.         }
  2769.         c = *src;
  2770.             } while ((src != lastChar) && (c != '$') && (c != '[')
  2771.             && (c != termChar));
  2772.         
  2773.         if ((numParts == 0) && !hasBackslash
  2774.             && ((src == lastChar) && (c == termChar))) {
  2775.         /*
  2776.          * The quoted string is "simple": just a sequence of
  2777.          * characters without backslashes terminated by termChar or
  2778.          * a null character. Just return if we are not to compile
  2779.          * simple words.
  2780.          */
  2781.  
  2782.         simpleWord = 1;
  2783.         if (!envPtr->pushSimpleWords) {
  2784.             if ((src == lastChar) && (termChar != '\0')) {
  2785.             char buf[40];
  2786.             sprintf(buf, "missing %c", termChar);
  2787.             Tcl_ResetResult(interp);
  2788.             Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
  2789.             result = TCL_ERROR;
  2790.             } else {
  2791.             src++;
  2792.             }
  2793.             envPtr->wordIsSimple = 1;
  2794.             envPtr->numSimpleWordChars = (src - string - 1);
  2795.             envPtr->termOffset = (src - string);
  2796.             envPtr->pushSimpleWords = savePushSimpleWords;
  2797.             return result;
  2798.         }
  2799.         }
  2800.  
  2801.         /*
  2802.          * Create and push a string object for the char+ string_part
  2803.          * that starts at "start" and ends at the char just before
  2804.          * src. If backslashes were found, copy the string_part's
  2805.          * characters with substituted backslashes into a heap-allocated
  2806.          * buffer and use it to create the string object. Temporarily
  2807.          * replace the terminating character with a null character.
  2808.          */
  2809.         
  2810.         numChars = (src - start);
  2811.         savedChar = start[numChars];
  2812.         start[numChars] = '\0';
  2813.         if ((numChars > 0) && (hasBackslash)) {
  2814.         char *buffer = ckalloc((unsigned) numChars + 1);
  2815.         register char *dst = buffer;
  2816.         register char *p = start;
  2817.         while (p < src) {
  2818.             if (*p == '\\') {
  2819.             *dst++ = Tcl_Backslash(p, &numRead);
  2820.             p += numRead;
  2821.             } else {
  2822.             *dst++ = *p++;
  2823.             }
  2824.         }
  2825.         *dst = '\0';
  2826.         objIndex = TclObjIndexForString(buffer, (dst - buffer),
  2827.             /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr);
  2828.         } else {
  2829.         objIndex = TclObjIndexForString(start, numChars,
  2830.             /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
  2831.         }
  2832.         start[numChars] = savedChar;
  2833.         TclEmitPush(objIndex, envPtr);
  2834.         maxDepth = TclMax((numParts + 1), maxDepth);
  2835.         }
  2836.     numParts++;
  2837.     } 
  2838.         
  2839.     /*
  2840.      * End of the quoted string: src points at termChar or '\0'. If
  2841.      * necessary, concatenate the string_part objects on the stack.
  2842.      */
  2843.  
  2844.     if ((src == lastChar) && (termChar != '\0')) {
  2845.     char buf[40];
  2846.     sprintf(buf, "missing %c", termChar);
  2847.     Tcl_ResetResult(interp);
  2848.     Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
  2849.     result = TCL_ERROR;
  2850.     goto done;
  2851.     } else {
  2852.     src++;
  2853.     }
  2854.  
  2855.     if (numParts == 0) {
  2856.     /*
  2857.      * The quoted string was empty. Push an empty string object.
  2858.      */
  2859.  
  2860.     int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0,
  2861.                                             /*inHeap*/ 0, envPtr);
  2862.     TclEmitPush(objIndex, envPtr);
  2863.     } else {
  2864.     /*
  2865.      * Emit any needed concat instructions.
  2866.      */
  2867.     
  2868.     while (numParts > 255) {
  2869.         TclEmitInstUInt1(INST_CONCAT1, 255, envPtr);
  2870.         numParts -= 254;  /* concat pushes 1 obj, the result */
  2871.     }
  2872.     if (numParts > 1) {
  2873.         TclEmitInstUInt1(INST_CONCAT1, numParts, envPtr);
  2874.     }
  2875.     }
  2876.  
  2877.     done:
  2878.     if (simpleWord) {
  2879.     envPtr->wordIsSimple = 1;
  2880.     envPtr->numSimpleWordChars = (src - string - 1);
  2881.     } else {
  2882.     envPtr->wordIsSimple = 0;
  2883.     envPtr->numSimpleWordChars = 0;
  2884.     }
  2885.     envPtr->termOffset = (src - string);
  2886.     envPtr->maxStackDepth = maxDepth;
  2887.     envPtr->pushSimpleWords = savePushSimpleWords;
  2888.     return result;
  2889. }
  2890.  
  2891. /*
  2892.  *--------------------------------------------------------------
  2893.  *
  2894.  * CompileBraces --
  2895.  *
  2896.  *    This procedure compiles characters between matching curly braces.
  2897.  *
  2898.  *    Ordinarily, callers set envPtr->pushSimpleWords to 1 and
  2899.  *    CompileBraces always emits a push instruction to compute the word on
  2900.  *    the Tcl evaluation stack at execution time. However, if a caller
  2901.  *    sets envPtr->pushSimpleWords to 0, CompileBraces will _not_ compile
  2902.  *    "simple" words: words that are just a sequence of characters without
  2903.  *    backslash-newlines. It will leave their compilation up to the
  2904.  *    caller.
  2905.  *
  2906.  *    As an important special case, if the word is simple, this procedure
  2907.  *    sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
  2908.  *    number of characters in the simple word. This allows the caller to
  2909.  *    process these words specially.
  2910.  *
  2911.  * Results:
  2912.  *    The return value is a standard Tcl result, which is TCL_OK unless
  2913.  *    there was an error while parsing string. If an error occurs then
  2914.  *    the interpreter's result contains a standard error message.
  2915.  *
  2916.  *    envPtr->termOffset is filled in with the offset of the character in
  2917.  *    "string" just after the last one successfully processed. This is
  2918.  *    usually the character just after the matching close-brace.
  2919.  *
  2920.  *    envPtr->wordIsSimple is set 1 if the word is simple: just a
  2921.  *    sequence of characters without backslash-newlines. If so, the word's
  2922.  *    characters are the envPtr->numSimpleWordChars characters starting 
  2923.  *    at string.
  2924.  *
  2925.  *    envPtr->maxStackDepth is updated with the maximum number of stack
  2926.  *    elements needed to evaluate the word. This is not changed if
  2927.  *    the word is simple and envPtr->pushSimpleWords was 0 (false).
  2928.  *
  2929.  * Side effects:
  2930.  *    Instructions are added to envPtr to push the braced string
  2931.  *    at runtime.
  2932.  *
  2933.  *--------------------------------------------------------------
  2934.  */
  2935.  
  2936. static int
  2937. CompileBraces(interp, string, lastChar, flags, envPtr)
  2938.     Tcl_Interp *interp;         /* Interpreter to use for nested command
  2939.                   * evaluations and error messages. */
  2940.     char *string;         /* Character just after opening bracket. */
  2941.     char *lastChar;         /* Pointer to terminating character of
  2942.                   * string. */
  2943.     int flags;             /* Flags to control compilation (same 
  2944.                   * values passed to Tcl_Eval). */
  2945.     CompileEnv *envPtr;         /* Holds the resulting instructions. */
  2946. {
  2947.     register char *src = string; /* Points to current source char. */
  2948.     register char c;         /* The current char. */
  2949.     int simpleWord = 0;         /* Set 1 if a simple braced string word. */
  2950.     int level = 1;         /* {} nesting level. Initially 1 since {
  2951.                   * was parsed before we were called. */
  2952.     int hasBackslashNewline = 0; /* Nonzero if '\' found. */
  2953.     char *last;             /* Points just before terminating '}'. */
  2954.     int numChars;         /* Number of chars in braced string. */
  2955.     char savedChar;         /* Holds the character from string
  2956.                   * termporarily replaced by a null 
  2957.                   * char during braced string processing. */
  2958.     int objIndex;         /* The object array index for a pushed
  2959.                   * object holding a braced string. */
  2960.     int numRead;
  2961.     int result = TCL_OK;
  2962.  
  2963.     /*
  2964.      * Check for any backslash-newlines, since we must treat
  2965.      * backslash-newlines specially (they must be replaced by spaces).
  2966.      */
  2967.  
  2968.     while (1) {
  2969.     c = *src;
  2970.     if (src == lastChar) {
  2971.         Tcl_ResetResult(interp);
  2972.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  2973.             "missing close-brace", -1);
  2974.         result = TCL_ERROR;
  2975.         goto done;
  2976.     }
  2977.     if (CHAR_TYPE(src, lastChar) != TCL_NORMAL) {
  2978.         if (c == '{') {
  2979.         level++;
  2980.         } else if (c == '}') {
  2981.         --level;
  2982.         if (level == 0) {
  2983.             src++;
  2984.             last = (src - 2); /* point just before terminating } */
  2985.             break;
  2986.         }
  2987.         } else if (c == '\\') {
  2988.         if (*(src+1) == '\n') {
  2989.             hasBackslashNewline = 1;
  2990.         }
  2991.         (void) Tcl_Backslash(src, &numRead);
  2992.         src += numRead - 1;
  2993.         }
  2994.     }
  2995.     src++;
  2996.     }
  2997.  
  2998.     if (!hasBackslashNewline) {
  2999.     /*
  3000.      * The braced word is "simple": just a sequence of characters
  3001.      * without backslash-newlines. Just return if we are not to compile
  3002.      * simple words.
  3003.      */
  3004.  
  3005.     simpleWord = 1;
  3006.     if (!envPtr->pushSimpleWords) {
  3007.         envPtr->wordIsSimple = 1;
  3008.         envPtr->numSimpleWordChars = (src - string - 1);
  3009.         envPtr->termOffset = (src - string);
  3010.         return TCL_OK;
  3011.     }
  3012.     }
  3013.  
  3014.     /*
  3015.      * Create and push a string object for the braced string. This starts at
  3016.      * "string" and ends just after "last" (which points to the final
  3017.      * character before the terminating '}'). If backslash-newlines were
  3018.      * found, we copy characters one at a time into a heap-allocated buffer
  3019.      * and do backslash-newline substitutions.
  3020.      */
  3021.  
  3022.     numChars = (last - string + 1);
  3023.     savedChar = string[numChars];
  3024.     string[numChars] = '\0';
  3025.     if ((numChars > 0) && (hasBackslashNewline)) {
  3026.     char *buffer = ckalloc((unsigned) numChars + 1);
  3027.     register char *dst = buffer;
  3028.     register char *p = string;
  3029.     while (p <= last) {
  3030.         c = *dst++ = *p++;
  3031.         if (c == '\\') {
  3032.         if (*p == '\n') {
  3033.             dst[-1] = Tcl_Backslash(p-1, &numRead);
  3034.             p += numRead - 1;
  3035.         } else {
  3036.             (void) Tcl_Backslash(p-1, &numRead);
  3037.             while (numRead > 1) {
  3038.             *dst++ = *p++;
  3039.             numRead--;
  3040.             }
  3041.         }
  3042.         }
  3043.     }
  3044.     *dst = '\0';
  3045.     objIndex = TclObjIndexForString(buffer, (dst - buffer),
  3046.         /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr);
  3047.     } else {
  3048.     objIndex = TclObjIndexForString(string, numChars, /*allocStrRep*/ 1,
  3049.                                         /*inHeap*/ 0, envPtr);
  3050.     }
  3051.     string[numChars] = savedChar;
  3052.     TclEmitPush(objIndex, envPtr);
  3053.  
  3054.     done:
  3055.     if (simpleWord) {
  3056.     envPtr->wordIsSimple = 1;
  3057.     envPtr->numSimpleWordChars = (src - string - 1);
  3058.     } else {
  3059.     envPtr->wordIsSimple = 0;
  3060.     envPtr->numSimpleWordChars = 0;
  3061.     }
  3062.     envPtr->termOffset = (src - string);
  3063.     envPtr->maxStackDepth = 1;
  3064.     return result;
  3065. }
  3066.  
  3067. /*
  3068.  *----------------------------------------------------------------------
  3069.  *
  3070.  * TclCompileDollarVar --
  3071.  *
  3072.  *    Given a string starting with a $ sign, parse a variable name
  3073.  *    and compile instructions to push its value. If the variable
  3074.  *    reference is just a '$' (i.e. the '$' isn't followed by anything
  3075.  *    that could possibly be a variable name), just push a string object
  3076.  *    containing '$'.
  3077.  *
  3078.  * Results:
  3079.  *    The return value is a standard Tcl result. If an error occurs
  3080.  *    then an error message is left in the interpreter's result.
  3081.  *
  3082.  *    envPtr->termOffset is filled in with the offset of the character in
  3083.  *    "string" just after the last one in the variable reference.
  3084.  *
  3085.  *    envPtr->wordIsSimple is set 0 (false) because the word is not
  3086.  *    simple: it is not just a sequence of characters without backslashes.
  3087.  *    For the same reason, envPtr->numSimpleWordChars is set 0.
  3088.  *
  3089.  *    envPtr->maxStackDepth is updated with the maximum number of stack
  3090.  *    elements needed to execute the string's commands.
  3091.  *
  3092.  * Side effects:
  3093.  *    Instructions are added to envPtr to look up the variable and
  3094.  *    push its value at runtime.
  3095.  *
  3096.  *----------------------------------------------------------------------
  3097.  */
  3098.     
  3099. int
  3100. TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
  3101.     Tcl_Interp *interp;         /* Interpreter to use for nested command
  3102.                   * evaluations and error messages. */
  3103.     char *string;         /* First char (i.e. $) of var reference. */
  3104.     char *lastChar;         /* Pointer to terminating character of
  3105.                   * string. */
  3106.     int flags;             /* Flags to control compilation (same
  3107.                   * values passed to Tcl_Eval). */
  3108.     CompileEnv *envPtr;         /* Holds the resulting instructions. */
  3109. {
  3110.     register char *src = string; /* Points to current source char. */
  3111.     register char c;         /* The current char. */
  3112.     char *name;             /* Start of 1st part of variable name. */
  3113.     int nameChars;         /* Count of chars in name. */
  3114.     int nameHasNsSeparators = 0; /* Set 1 if name contains "::"s. */
  3115.     char savedChar;         /* Holds the character from string
  3116.                   * termporarily replaced by a null 
  3117.                   * char during name processing. */
  3118.     int objIndex;         /* The object array index for a pushed
  3119.                   * object holding a name part. */
  3120.     int isArrayRef = 0;         /* 1 if reference to array element. */
  3121.     int localIndex = -1;     /* Frame index of local if found.  */
  3122.     int maxDepth = 0;         /* Maximum number of stack elements needed
  3123.                   * to push the variable. */
  3124.     int savePushSimpleWords = envPtr->pushSimpleWords;
  3125.     int result = TCL_OK;
  3126.  
  3127.     /*
  3128.      * var_reference: '$' '{' braced_name '}' |
  3129.      *                '$' name ['(' index_string ')']
  3130.      *
  3131.      * There are three cases:
  3132.      * 1. The $ sign is followed by an open curly brace. Then the variable
  3133.      *    name is everything up to the next close curly brace, and the
  3134.      *    variable is a scalar variable.
  3135.      * 2. The $ sign is not followed by an open curly brace. Then the
  3136.      *    variable name is everything up to the next character that isn't
  3137.      *    a letter, digit, underscore, or a "::" namespace separator. If the
  3138.      *    following character is an open parenthesis, then the information
  3139.      *    between parentheses is the array element name, which can include
  3140.      *    any of the substitutions permissible between quotes.
  3141.      * 3. The $ sign is followed by something that isn't a letter, digit,
  3142.      *    underscore, or a "::" namespace separator: in this case,
  3143.      *    there is no variable name, and "$" is pushed.
  3144.      */
  3145.  
  3146.     src++;            /* advance over the '$'. */
  3147.  
  3148.     /*
  3149.      * Collect the first part of the variable's name into "name" and
  3150.      * determine if it is an array reference and if it contains any
  3151.      * namespace separator (::'s).
  3152.      */
  3153.     
  3154.     if (*src == '{') {
  3155.         /*
  3156.      * A scalar name in braces.
  3157.      */
  3158.  
  3159.     char *p;
  3160.  
  3161.     src++;
  3162.         name = src;
  3163.         c = *src;
  3164.     while (c != '}') {
  3165.         if (src == lastChar) {
  3166.         Tcl_ResetResult(interp);
  3167.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  3168.             "missing close-brace for variable name", -1);
  3169.         result = TCL_ERROR;
  3170.         goto done;
  3171.         }
  3172.         src++;
  3173.         c = *src;
  3174.     }
  3175.     nameChars = (src - name);
  3176.     for (p = name;  p < src;  p++) {
  3177.         if ((*p == ':') && (*(p+1) == ':')) {
  3178.         nameHasNsSeparators = 1;
  3179.         break;
  3180.         }
  3181.     }
  3182.     src++;            /* advance over the '}'. */
  3183.     } else {
  3184.     /*
  3185.      * Scalar name or array reference not in braces.
  3186.      */
  3187.     
  3188.         name = src;
  3189.         c = *src;
  3190.         while (isalnum(UCHAR(c)) || (c == '_') || (c == ':')) {
  3191.         if (c == ':') {
  3192.                 if (*(src+1) == ':') {
  3193.             nameHasNsSeparators = 1;
  3194.                     src += 2;
  3195.             while (*src == ':') {
  3196.             src++;
  3197.             }
  3198.                     c = *src;
  3199.                 } else {
  3200.                     break;    /* : by itself */
  3201.                 }
  3202.             } else {
  3203.                 src++;
  3204.                 c = *src;
  3205.             }
  3206.     }
  3207.     if (src == name) {
  3208.         /*
  3209.          * A '$' by itself, not a name reference. Push a "$" string.
  3210.          */
  3211.  
  3212.         objIndex = TclObjIndexForString("$", 1, /*allocStrRep*/ 1,
  3213.                                             /*inHeap*/ 0, envPtr);
  3214.         TclEmitPush(objIndex, envPtr);
  3215.         maxDepth = 1;
  3216.         goto done;
  3217.     }
  3218.     nameChars = (src - name);
  3219.     isArrayRef = (c == '(');
  3220.     }
  3221.  
  3222.     /*
  3223.      * Now emit instructions to load the variable. First either push the
  3224.      * name of the scalar or array, or determine its index in the array of
  3225.      * local variables in a procedure frame. Push the name if we are not
  3226.      * compiling a procedure body or if the name has namespace
  3227.      * qualifiers ("::"s).
  3228.      */
  3229.     
  3230.     if (!isArrayRef) {        /* scalar reference */
  3231.     if ((envPtr->procPtr == NULL) || nameHasNsSeparators) {
  3232.         savedChar = name[nameChars];
  3233.         name[nameChars] = '\0';
  3234.         objIndex = TclObjIndexForString(name, nameChars,
  3235.             /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
  3236.         name[nameChars] = savedChar;
  3237.         TclEmitPush(objIndex, envPtr);
  3238.         TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
  3239.         maxDepth = 1;
  3240.     } else {
  3241.         localIndex = LookupCompiledLocal(name, nameChars,
  3242.                 /*createIfNew*/ 0, /*flagsIfCreated*/ 0,
  3243.             envPtr->procPtr);
  3244.         if (localIndex >= 0) {
  3245.         if (localIndex <= 255) {
  3246.             TclEmitInstUInt1(INST_LOAD_SCALAR1, localIndex, envPtr);
  3247.         } else {
  3248.             TclEmitInstUInt4(INST_LOAD_SCALAR4, localIndex, envPtr);
  3249.         }
  3250.         maxDepth = 0;
  3251.         } else {
  3252.         savedChar = name[nameChars];
  3253.         name[nameChars] = '\0';
  3254.         objIndex = TclObjIndexForString(name, nameChars,
  3255.             /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
  3256.         name[nameChars] = savedChar;
  3257.         TclEmitPush(objIndex, envPtr); 
  3258.         TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
  3259.         maxDepth = 1;
  3260.         }
  3261.     }
  3262.     } else {            /* array reference */
  3263.     if ((envPtr->procPtr == NULL) || nameHasNsSeparators) {
  3264.         savedChar = name[nameChars];
  3265.         name[nameChars] = '\0';
  3266.         objIndex = TclObjIndexForString(name, nameChars,
  3267.             /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
  3268.         name[nameChars] = savedChar;
  3269.         TclEmitPush(objIndex, envPtr);
  3270.         maxDepth = 1;
  3271.     } else {
  3272.         localIndex = LookupCompiledLocal(name, nameChars,
  3273.                 /*createIfNew*/ 0, /*flagsIfCreated*/ 0,
  3274.             envPtr->procPtr);
  3275.         if (localIndex < 0) {
  3276.         savedChar = name[nameChars];
  3277.         name[nameChars] = '\0';
  3278.         objIndex = TclObjIndexForString(name, nameChars,
  3279.             /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
  3280.         name[nameChars] = savedChar;
  3281.         TclEmitPush(objIndex, envPtr);
  3282.         maxDepth = 1;
  3283.         }
  3284.     }
  3285.  
  3286.     /*
  3287.      * Parse and push the array element. Perform substitutions on it,
  3288.      * just as is done for quoted strings.
  3289.      */
  3290.  
  3291.     src++;
  3292.     envPtr->pushSimpleWords = 1;
  3293.     result = TclCompileQuotes(interp, src, lastChar, ')', flags,
  3294.         envPtr);
  3295.     src += envPtr->termOffset;
  3296.     if (result != TCL_OK) {
  3297.         char msg[200];
  3298.         sprintf(msg, "\n    (parsing index for array \"%.*s\")",
  3299.             (nameChars > 100? 100 : nameChars), name);
  3300.         Tcl_AddObjErrorInfo(interp, msg, -1);
  3301.         goto done;
  3302.     }
  3303.     maxDepth += envPtr->maxStackDepth;
  3304.  
  3305.     /*
  3306.      * Now emit the appropriate load instruction for the array element.
  3307.      */
  3308.  
  3309.     if (localIndex < 0) {    /* a global or an unknown local */
  3310.         TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
  3311.     } else {
  3312.         if (localIndex <= 255) {
  3313.         TclEmitInstUInt1(INST_LOAD_ARRAY1, localIndex, envPtr);
  3314.         } else {
  3315.         TclEmitInstUInt4(INST_LOAD_ARRAY4, localIndex, envPtr);
  3316.         }
  3317.     }
  3318.     }
  3319.  
  3320.     done:
  3321.     envPtr->termOffset = (src - string);
  3322.     envPtr->wordIsSimple = 0;
  3323.     envPtr->numSimpleWordChars = 0;
  3324.     envPtr->maxStackDepth = maxDepth;
  3325.     envPtr->pushSimpleWords = savePushSimpleWords;
  3326.     return result;
  3327. }
  3328.  
  3329. /*
  3330.  *----------------------------------------------------------------------
  3331.  *
  3332.  * TclCompileBreakCmd --
  3333.  *
  3334.  *    Procedure called to compile the "break" command.
  3335.  *
  3336.  * Results:
  3337.  *    The return value is a standard Tcl result, which is TCL_OK unless
  3338.  *    there was an error while parsing string. If an error occurs then
  3339.  *    the interpreter's result contains a standard error message.
  3340.  *
  3341.  *    envPtr->termOffset is filled in with the offset of the character in
  3342.  *    "string" just after the last one successfully processed.
  3343.  *
  3344.  *    envPtr->maxStackDepth is updated with the maximum number of stack
  3345.  *    elements needed to execute the command.
  3346.  *
  3347.  * Side effects:
  3348.  *    Instructions are added to envPtr to evaluate the "break" command
  3349.  *    at runtime.
  3350.  *
  3351.  *----------------------------------------------------------------------
  3352.  */
  3353.  
  3354. int
  3355. TclCompileBreakCmd(interp, string, lastChar, flags, envPtr)
  3356.     Tcl_Interp *interp;        /* Used for error reporting. */
  3357.     char *string;        /* The source string to compile. */
  3358.     char *lastChar;        /* Pointer to terminating character of
  3359.                  * string. */
  3360.     int flags;            /* Flags to control compilation (same as
  3361.                  * passed to Tcl_Eval). */
  3362.     CompileEnv *envPtr;        /* Holds resulting instructions. */
  3363. {
  3364.     register char *src = string;/* Points to current source char. */
  3365.     register int type;        /* Current char's CHAR_TYPE type. */
  3366.     int result = TCL_OK;
  3367.     
  3368.     /*
  3369.      * There should be no argument after the "break".
  3370.      */
  3371.  
  3372.     type = CHAR_TYPE(src, lastChar);
  3373.     if (type != TCL_COMMAND_END) {
  3374.     AdvanceToNextWord(src, envPtr);
  3375.     src += envPtr->termOffset;
  3376.     type = CHAR_TYPE(src, lastChar);
  3377.     if (type != TCL_COMMAND_END) {
  3378.         Tcl_ResetResult(interp);
  3379.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  3380.                 "wrong # args: should be \"break\"", -1);
  3381.         result = TCL_ERROR;
  3382.         goto done;
  3383.     }
  3384.     }
  3385.  
  3386.     /*
  3387.      * Emit a break instruction.
  3388.      */
  3389.  
  3390.     TclEmitOpcode(INST_BREAK, envPtr);
  3391.  
  3392.     done:
  3393.     envPtr->termOffset = (src - string);
  3394.     envPtr->maxStackDepth = 0;
  3395.     return result;
  3396. }
  3397.  
  3398. /*
  3399.  *----------------------------------------------------------------------
  3400.  *
  3401.  * TclCompileCatchCmd --
  3402.  *
  3403.  *    Procedure called to compile the "catch" command.
  3404.  *
  3405.  * Results:
  3406.  *    The return value is a standard Tcl result, which is TCL_OK if
  3407.  *    compilation was successful. If an error occurs then the
  3408.  *    interpreter's result contains a standard error message and TCL_ERROR
  3409.  *    is returned. If compilation failed because the command is too
  3410.  *    complex for TclCompileCatchCmd, TCL_OUT_LINE_COMPILE is returned
  3411.  *    indicating that the catch command should be compiled "out of line"
  3412.  *    by emitting code to invoke its command procedure at runtime.
  3413.  *
  3414.  *    envPtr->termOffset is filled in with the offset of the character in
  3415.  *    "string" just after the last one successfully processed.
  3416.  *
  3417.  *    envPtr->maxStackDepth is updated with the maximum number of stack
  3418.  *    elements needed to execute the command.
  3419.  *
  3420.  * Side effects:
  3421.  *    Instructions are added to envPtr to evaluate the "catch" command
  3422.  *    at runtime.
  3423.  *
  3424.  *----------------------------------------------------------------------
  3425.  */
  3426.  
  3427. int
  3428. TclCompileCatchCmd(interp, string, lastChar, flags, envPtr)
  3429.     Tcl_Interp *interp;        /* Used for error reporting. */
  3430.     char *string;        /* The source string to compile. */
  3431.     char *lastChar;        /* Pointer to terminating character of
  3432.                  * string. */
  3433.     int flags;            /* Flags to control compilation (same as
  3434.                  * passed to Tcl_Eval). */
  3435.     CompileEnv *envPtr;        /* Holds resulting instructions. */
  3436. {
  3437.     Proc *procPtr = envPtr->procPtr;
  3438.                     /* Points to structure describing procedure
  3439.                  * containing the catch cmd, else NULL. */
  3440.     int maxDepth = 0;           /* Maximum number of stack elements needed
  3441.                  * to execute cmd. */
  3442.     ArgInfo argInfo;        /* Structure holding information about the
  3443.                  * start and end of each argument word. */
  3444.     int range = -1;        /* If we compile the catch command, the
  3445.                  * index for its catch range record in the
  3446.                  * ExceptionRange array. -1 if we are not
  3447.                  * compiling the command. */
  3448.     char *name;            /* If a var name appears for a scalar local
  3449.                  * to a procedure, this points to the name's
  3450.                  * 1st char and nameChars is its length. */
  3451.     int nameChars;        /* Length of the variable name, if any. */
  3452.     int localIndex = -1;        /* Index of the variable in the current
  3453.                  * procedure's array of local variables.
  3454.                  * Otherwise -1 if not in a procedure or
  3455.                  * the variable wasn't found. */
  3456.     char savedChar;        /* Holds the character from string
  3457.                  * termporarily replaced by a null character
  3458.                  * during processing of words. */
  3459.     JumpFixup jumpFixup;    /* Used to emit the jump after the "no
  3460.                  * errors" epilogue code. */
  3461.     int numWords, objIndex, jumpDist, result;
  3462.     char *bodyStart, *bodyEnd;
  3463.     Tcl_Obj *objPtr;
  3464.     int savePushSimpleWords = envPtr->pushSimpleWords;
  3465.  
  3466.     /*
  3467.      * Scan the words of the command and record the start and finish of
  3468.      * each argument word.
  3469.      */
  3470.  
  3471.     InitArgInfo(&argInfo);
  3472.     result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
  3473.     numWords = argInfo.numArgs;      /* i.e., the # after the command name */
  3474.     if (result != TCL_OK) {
  3475.     goto done;
  3476.     }
  3477.     if ((numWords != 1) && (numWords != 2)) {
  3478.     Tcl_ResetResult(interp);
  3479.     Tcl_AppendToObj(Tcl_GetObjResult(interp),
  3480.             "wrong # args: should be \"catch command ?varName?\"", -1);
  3481.         result = TCL_ERROR;
  3482.     goto done;
  3483.     }
  3484.  
  3485.     /*
  3486.      * If a variable was specified and the catch command is at global level
  3487.      * (not in a procedure), don't compile it inline: the payoff is
  3488.      * too small.
  3489.      */
  3490.  
  3491.     if ((numWords == 2) && (procPtr == NULL)) {
  3492.     result = TCL_OUT_LINE_COMPILE;
  3493.         goto done;
  3494.     }
  3495.  
  3496.     /*
  3497.      * Make sure the variable name, if any, has no substitutions and just
  3498.      * refers to a local scaler.
  3499.      */
  3500.  
  3501.     if (numWords == 2) {
  3502.     char *firstChar = argInfo.startArray[1];
  3503.     char *lastChar  = argInfo.endArray[1];
  3504.     
  3505.     if (*firstChar == '{') {
  3506.         if (*lastChar != '}') {
  3507.         Tcl_ResetResult(interp);
  3508.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  3509.                 "extra characters after close-brace", -1);
  3510.         result = TCL_ERROR;
  3511.         goto done;
  3512.         }
  3513.         firstChar++;
  3514.         lastChar--;
  3515.     }
  3516.  
  3517.     nameChars = (lastChar - firstChar + 1);
  3518.     if (nameChars > 0) {
  3519.         char *p = firstChar;
  3520.         while (p != lastChar) {
  3521.         if (CHAR_TYPE(p, lastChar) != TCL_NORMAL) {
  3522.             result = TCL_OUT_LINE_COMPILE;
  3523.             goto done;
  3524.         }
  3525.         if (*p == '(') {
  3526.             if (*lastChar == ')') { /* we have an array element */
  3527.             result = TCL_OUT_LINE_COMPILE;
  3528.             goto done; 
  3529.             }
  3530.         }
  3531.         p++;
  3532.         }
  3533.     }
  3534.  
  3535.     name = firstChar;
  3536.     localIndex = LookupCompiledLocal(name, nameChars,
  3537.                     /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR,
  3538.             procPtr);
  3539.     }
  3540.  
  3541.     /*
  3542.      *==== At this point we believe we can compile the catch command ====
  3543.      */
  3544.  
  3545.     /*
  3546.      * Create and initialize a ExceptionRange record to hold information
  3547.      * about this catch command.
  3548.      */
  3549.     
  3550.     envPtr->excRangeDepth++;
  3551.     envPtr->maxExcRangeDepth =
  3552.     TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
  3553.     range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr);
  3554.  
  3555.     /*
  3556.      * Emit the instruction to mark the start of the catch command.
  3557.      */
  3558.     
  3559.     TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr);
  3560.     
  3561.     /*
  3562.      * Inline compile the catch's body word: the command it controls. Also
  3563.      * register the body's starting PC offset and byte length in the
  3564.      * ExceptionRange record.
  3565.      */
  3566.  
  3567.     envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
  3568.  
  3569.     bodyStart = argInfo.startArray[0];
  3570.     bodyEnd   = argInfo.endArray[0];
  3571.     savedChar = *(bodyEnd+1);
  3572.     *(bodyEnd+1) = '\0';
  3573.     result = CompileCmdWordInline(interp, bodyStart, (bodyEnd+1),
  3574.         flags, envPtr);
  3575.     *(bodyEnd+1) = savedChar;
  3576.     
  3577.     if (result != TCL_OK) {
  3578.     if (result == TCL_ERROR) {
  3579.         char msg[60];
  3580.         sprintf(msg, "\n    (\"catch\" body line %d)",
  3581.             interp->errorLine);
  3582.             Tcl_AddObjErrorInfo(interp, msg, -1);
  3583.         }
  3584.     goto done;
  3585.     }
  3586.     maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
  3587.     envPtr->excRangeArrayPtr[range].numCodeBytes =
  3588.     TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
  3589.  
  3590.     /*
  3591.      * Now emit the "no errors" epilogue code for the catch. First, if a
  3592.      * variable was specified, store the body's result into the
  3593.      * variable; otherwise, just discard the body's result. Then push
  3594.      * a "0" object as the catch command's "no error" TCL_OK result,
  3595.      * and jump around the "error case" epilogue code.
  3596.      */
  3597.  
  3598.     if (localIndex != -1) {
  3599.     if (localIndex <= 255) {
  3600.         TclEmitInstUInt1(INST_STORE_SCALAR1, localIndex, envPtr);
  3601.     } else {
  3602.         TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr);
  3603.     }
  3604.     }
  3605.     TclEmitOpcode(INST_POP, envPtr);
  3606.  
  3607.     objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, /*inHeap*/ 0,
  3608.         envPtr);
  3609.     objPtr = envPtr->objArrayPtr[objIndex];
  3610.     
  3611.     Tcl_InvalidateStringRep(objPtr);
  3612.     objPtr->internalRep.longValue = 0;
  3613.     objPtr->typePtr = &tclIntType;
  3614.     
  3615.     TclEmitPush(objIndex, envPtr);
  3616.     if (maxDepth == 0) {
  3617.     maxDepth = 1;    /* since we just pushed one object */
  3618.     }
  3619.     
  3620.     TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
  3621.  
  3622.     /*
  3623.      * Now emit the "error case" epilogue code. First, if a variable was
  3624.      * specified, emit instructions to push the interpreter's object result
  3625.      * and store it into the variable. Then emit an instruction to push the
  3626.      * nonzero error result. Note that the initial PC offset here is the
  3627.      * catch's error target.
  3628.      */
  3629.  
  3630.     envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset();
  3631.     if (localIndex != -1) {
  3632.     TclEmitOpcode(INST_PUSH_RESULT, envPtr);
  3633.     if (localIndex <= 255) {
  3634.         TclEmitInstUInt1(INST_STORE_SCALAR1, localIndex, envPtr);
  3635.     } else {
  3636.         TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr);
  3637.     }
  3638.     TclEmitOpcode(INST_POP, envPtr);
  3639.     }
  3640.     TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
  3641.  
  3642.     /*
  3643.      * Now that we know the target of the jump after the "no errors"
  3644.      * epilogue, update it with the correct distance. This is less
  3645.      * than 127 bytes.
  3646.      */
  3647.  
  3648.     jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
  3649.     if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
  3650.     panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist);
  3651.     }
  3652.  
  3653.     /*
  3654.      * Emit the instruction to mark the end of the catch command.
  3655.      */
  3656.  
  3657.     TclEmitOpcode(INST_END_CATCH, envPtr);
  3658.  
  3659.     done:
  3660.     if (numWords == 0) {
  3661.     envPtr->termOffset = 0;
  3662.     } else {
  3663.     envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
  3664.     }
  3665.     if (range != -1) {        /* we compiled the catch command */
  3666.     envPtr->excRangeDepth--;
  3667.     }
  3668.     envPtr->pushSimpleWords = savePushSimpleWords;
  3669.     envPtr->maxStackDepth = maxDepth;
  3670.     FreeArgInfo(&argInfo);
  3671.     return result;
  3672. }
  3673.  
  3674. /*
  3675.  *----------------------------------------------------------------------
  3676.  *
  3677.  * TclCompileContinueCmd --
  3678.  *
  3679.  *    Procedure called to compile the "continue" command.
  3680.  *
  3681.  * Results:
  3682.  *    The return value is a standard Tcl result, which is TCL_OK unless
  3683.  *    there was an error while parsing string. If an error occurs then
  3684.  *    the interpreter's result contains a standard error message.
  3685.  *
  3686.  *    envPtr->termOffset is filled in with the offset of the character in
  3687.  *    "string" just after the last one successfully processed.
  3688.  *
  3689.  *    envPtr->maxStackDepth is updated with the maximum number of stack
  3690.  *    elements needed to execute the command.
  3691.  *
  3692.  * Side effects:
  3693.  *    Instructions are added to envPtr to evaluate the "continue" command
  3694.  *    at runtime.
  3695.  *
  3696.  *----------------------------------------------------------------------
  3697.  */
  3698.  
  3699. int
  3700. TclCompileContinueCmd(interp, string, lastChar, flags, envPtr)
  3701.     Tcl_Interp *interp;        /* Used for error reporting. */
  3702.     char *string;        /* The source string to compile. */
  3703.     char *lastChar;        /* Pointer to terminating character of
  3704.                  * string. */
  3705.     int flags;            /* Flags to control compilation (same as
  3706.                  * passed to Tcl_Eval). */
  3707.     CompileEnv *envPtr;        /* Holds resulting instructions. */
  3708. {
  3709.     register char *src = string;/* Points to current source char. */
  3710.     register int type;        /* Current char's CHAR_TYPE type. */
  3711.     int result = TCL_OK;
  3712.     
  3713.     /*
  3714.      * There should be no argument after the "continue".
  3715.      */
  3716.  
  3717.     type = CHAR_TYPE(src, lastChar);
  3718.     if (type != TCL_COMMAND_END) {
  3719.     AdvanceToNextWord(src, envPtr);
  3720.     src += envPtr->termOffset;
  3721.     type = CHAR_TYPE(src, lastChar);
  3722.     if (type != TCL_COMMAND_END) {
  3723.         Tcl_ResetResult(interp);
  3724.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  3725.                 "wrong # args: should be \"continue\"", -1);
  3726.         result = TCL_ERROR;
  3727.         goto done;
  3728.     }
  3729.     }
  3730.  
  3731.     /*
  3732.      * Emit a continue instruction.
  3733.      */
  3734.  
  3735.     TclEmitOpcode(INST_CONTINUE, envPtr);
  3736.  
  3737.     done:
  3738.     envPtr->termOffset = (src - string);
  3739.     envPtr->maxStackDepth = 0;
  3740.     return result;
  3741. }
  3742.  
  3743. /*
  3744.  *----------------------------------------------------------------------
  3745.  *
  3746.  * TclCompileExprCmd --
  3747.  *
  3748.  *    Procedure called to compile the "expr" command.
  3749.  *
  3750.  * Results:
  3751.  *    The return value is a standard Tcl result, which is TCL_OK
  3752.  *    unless there was an error while parsing string. If an error occurs
  3753.  *    then the interpreter's result contains a standard error message.
  3754.  *
  3755.  *    envPtr->termOffset is filled in with the offset of the character in
  3756.  *    "string" just after the last one successfully processed.
  3757.  *
  3758.  *    envPtr->maxStackDepth is updated with the maximum number of stack
  3759.  *    elements needed to execute the "expr" command.
  3760.  *
  3761.  * Side effects:
  3762.  *    Instructions are added to envPtr to evaluate the "expr" command
  3763.  *    at runtime.
  3764.  *
  3765.  *----------------------------------------------------------------------
  3766.  */
  3767.  
  3768. int
  3769. TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
  3770.     Tcl_Interp *interp;        /* Used for error reporting. */
  3771.     char *string;        /* The source string to compile. */
  3772.     char *lastChar;        /* Pointer to terminating character of
  3773.                  * string. */
  3774.     int flags;            /* Flags to control compilation (same as
  3775.                  * passed to Tcl_Eval). */
  3776.     CompileEnv *envPtr;        /* Holds resulting instructions. */
  3777. {
  3778.     int maxDepth = 0;        /* Maximum number of stack elements needed
  3779.                  * to execute cmd. */
  3780.     ArgInfo argInfo;        /* Structure holding information about the
  3781.                  * start and end of each argument word. */
  3782.     Tcl_DString buffer;        /* Holds the concatenated expr command
  3783.                  * argument words. */
  3784.     int firstWord;        /* 1 if processing the first word; 0 if
  3785.                  * processing subsequent words. */
  3786.     char *first, *last;        /* Points to the first and last significant
  3787.                  * chars of the concatenated expression. */
  3788.     int inlineCode;        /* 1 if inline "optimistic" code is
  3789.                  * emitted for the expression; else 0. */
  3790.     int range = -1;        /* If we inline compile the concatenated
  3791.                  * expression, the index for its catch range
  3792.                  * record in the ExceptionRange array.
  3793.                  * Initialized to avoid compile warning. */
  3794.     JumpFixup jumpFixup;    /* Used to emit the "success" jump after
  3795.                  * the inline concat. expression's code. */
  3796.     char savedChar;        /* Holds the character termporarily replaced
  3797.                  * by a null character during compilation
  3798.                  * of the concatenated expression. */
  3799.     int numWords, objIndex, i, result;
  3800.     char *wordStart, *wordEnd, *p;
  3801.     char c;
  3802.     int savePushSimpleWords = envPtr->pushSimpleWords;
  3803.     int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;
  3804.     int saveExprIsComparison = envPtr->exprIsComparison;
  3805.  
  3806.     /*
  3807.      * Scan the words of the command and record the start and finish of
  3808.      * each argument word.
  3809.      */
  3810.  
  3811.     InitArgInfo(&argInfo);
  3812.     result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
  3813.     numWords = argInfo.numArgs;      /* i.e., the # after the command name */
  3814.     if (result != TCL_OK) {
  3815.     goto done;
  3816.     }
  3817.     if (numWords == 0) {
  3818.     Tcl_ResetResult(interp);
  3819.     Tcl_AppendToObj(Tcl_GetObjResult(interp),
  3820.             "wrong # args: should be \"expr arg ?arg ...?\"", -1);
  3821.         result = TCL_ERROR;
  3822.     goto done;
  3823.     }
  3824.  
  3825.     /*
  3826.      * If there is a single argument word and it is enclosed in {}s, we may
  3827.      * strip them off and safely compile the expr command into an inline
  3828.      * sequence of instructions using TclCompileExpr. We know these
  3829.      * instructions will have the right Tcl7.x expression semantics.
  3830.      *
  3831.      * Otherwise, if the word is not enclosed in {}s, or there are multiple
  3832.      * words, we may need to call the expr command (Tcl_ExprObjCmd) at
  3833.      * runtime. This recompiles the expression each time (typically) and so
  3834.      * is slow. However, there are some circumstances where we can still
  3835.      * compile inline instructions "optimistically" and check, during their
  3836.      * execution, for double substitutions (these appear as nonnumeric
  3837.      * operands). We check for any backslash or command substitutions. If
  3838.      * none appear, and only variable substitutions are found, we generate
  3839.      * inline instructions. If there is a compilation error, we must emit
  3840.      * instructions that return the error at runtime, since this is when
  3841.      * scripts in Tcl7.x would "see" the error.
  3842.      *
  3843.      * For now, if there are multiple words, or the single argument word is
  3844.      * not in {}s, we concatenate the argument words and strip off any
  3845.      * enclosing {}s or ""s. We call the expr command at runtime if
  3846.      * either command or backslash substitutions appear (but not if
  3847.      * only variable substitutions appear).
  3848.      */
  3849.  
  3850.     if (numWords == 1) {
  3851.     wordStart = argInfo.startArray[0]; /* start of 1st arg word */
  3852.     wordEnd   = argInfo.endArray[0];   /* last char of 1st arg word */
  3853.     if ((*wordStart == '{') && (*wordEnd == '}')) {
  3854.         /*
  3855.          * Simple case: a single argument word in {}'s. 
  3856.          */
  3857.  
  3858.         *wordEnd = '\0';
  3859.         result = TclCompileExpr(interp, (wordStart + 1), wordEnd,
  3860.             flags, envPtr);
  3861.         *wordEnd = '}';
  3862.         
  3863.         envPtr->termOffset = (wordEnd + 1) - string;
  3864.         envPtr->pushSimpleWords = savePushSimpleWords;
  3865.         FreeArgInfo(&argInfo);
  3866.         return result;
  3867.     }
  3868.     }
  3869.     
  3870.     /*
  3871.      * There are multiple words or no braces around the single word.
  3872.      * Concatenate the expression's argument words while stripping off
  3873.      * any enclosing {}s or ""s.
  3874.      */
  3875.     
  3876.     Tcl_DStringInit(&buffer);
  3877.     firstWord = 1;
  3878.     for (i = 0;  i < numWords;  i++) {
  3879.     wordStart = argInfo.startArray[i];
  3880.     wordEnd   = argInfo.endArray[i];
  3881.     if (((*wordStart == '{') && (*wordEnd == '}'))
  3882.             || ((*wordStart == '"') && (*wordEnd == '"'))) {
  3883.         wordStart++;
  3884.         wordEnd--;
  3885.     }
  3886.     if (!firstWord) {
  3887.         Tcl_DStringAppend(&buffer, " ", 1);
  3888.     }
  3889.     firstWord = 0;
  3890.     if (wordEnd >= wordStart) {
  3891.         Tcl_DStringAppend(&buffer, wordStart, (wordEnd-wordStart+1));
  3892.     }
  3893.     }
  3894.  
  3895.     /*
  3896.      * Scan the concatenated expression's characters looking for any
  3897.      * '['s or (for now) '\'s. If any are found, just call the expr cmd
  3898.      * at runtime.
  3899.      */
  3900.     
  3901.     inlineCode = 1;
  3902.     first = Tcl_DStringValue(&buffer);
  3903.     last = first + (Tcl_DStringLength(&buffer) - 1);
  3904.     for (p = first;  p <= last;  p++) {
  3905.     c = *p;
  3906.     if ((c == '[') || (c == '\\')) {
  3907.         inlineCode = 0;
  3908.         break;
  3909.     }
  3910.     }
  3911.  
  3912.     if (inlineCode) {
  3913.     /*
  3914.      * Inline compile the concatenated expression inside a "catch"
  3915.      * so that a runtime error will back off to a (slow) call on expr.
  3916.      */
  3917.     
  3918.     int startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
  3919.     int startRangeNext = envPtr->excRangeArrayNext;
  3920.     
  3921.     /*
  3922.      * Create a ExceptionRange record to hold information about the
  3923.      * "catch" range for the expression's inline code. Also emit the
  3924.      * instruction to mark the start of the range.
  3925.      */
  3926.     
  3927.     envPtr->excRangeDepth++;
  3928.     envPtr->maxExcRangeDepth =
  3929.             TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
  3930.     range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr);
  3931.     TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr);
  3932.     
  3933.     /*
  3934.      * Inline compile the concatenated expression.
  3935.      */
  3936.     
  3937.     envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
  3938.     savedChar = *(last + 1);
  3939.     *(last + 1) = '\0';
  3940.     result = TclCompileExpr(interp, first, last + 1, flags, envPtr);
  3941.     *(last + 1) = savedChar;
  3942.     
  3943.     maxDepth = envPtr->maxStackDepth;
  3944.     envPtr->excRangeArrayPtr[range].numCodeBytes =
  3945.             TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
  3946.     
  3947.     if ((result != TCL_OK) || (envPtr->exprIsJustVarRef)
  3948.             || (envPtr->exprIsComparison)) {
  3949.         /*
  3950.          * We must call the expr command at runtime. Either there was a
  3951.          * compilation error or the inline code might fail to give the
  3952.          * correct 2 level substitution semantics.
  3953.          *
  3954.          * The latter can happen if the expression consisted of just a
  3955.          * single variable reference or if the top-level operator in the
  3956.          * expr is a comparison (which might operate on strings). In the
  3957.          * latter case, the expression's code might execute (apparently)
  3958.          * successfully but produce the wrong result. We depend on its
  3959.          * execution failing if a second level of substitutions is
  3960.          * required. This causes the "catch" code we generate around the
  3961.          * inline code to back off to a call on the expr command at
  3962.          * runtime, and this always gives the right 2 level substitution
  3963.          * semantics.
  3964.          *
  3965.          * We delete the inline code by backing up the code pc and catch
  3966.          * index. Note that if there was a compilation error, we can't
  3967.          * report the error yet since the expression might be valid
  3968.          * after the second round of substitutions.
  3969.          */
  3970.         
  3971.         envPtr->codeNext = (envPtr->codeStart + startCodeOffset);
  3972.         envPtr->excRangeArrayNext = startRangeNext;
  3973.         inlineCode = 0;
  3974.     } else {
  3975.         TclEmitOpcode(INST_END_CATCH, envPtr); /* for ok case */
  3976.         TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
  3977.         envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset();
  3978.         TclEmitOpcode(INST_END_CATCH, envPtr); /* for error case */
  3979.     }
  3980.     }
  3981.         
  3982.     /*
  3983.      * Emit code for the (slow) call on the expr command at runtime.
  3984.      * Generate code to concatenate the (already substituted once)
  3985.      * expression words with a space between each word.
  3986.      */
  3987.     
  3988.     for (i = 0;  i < numWords;  i++) {
  3989.     wordStart = argInfo.startArray[i];
  3990.     wordEnd   = argInfo.endArray[i];
  3991.     savedChar = *(wordEnd + 1);
  3992.     *(wordEnd + 1) = '\0';
  3993.     envPtr->pushSimpleWords = 1;
  3994.     result = CompileWord(interp, wordStart, wordEnd+1, flags, envPtr);
  3995.     *(wordEnd + 1) = savedChar;
  3996.     if (result != TCL_OK) {
  3997.         break;
  3998.     }
  3999.     if (i != (numWords - 1)) {
  4000.         objIndex = TclObjIndexForString(" ", 1, /*allocStrRep*/ 1,
  4001.                         /*inHeap*/ 0, envPtr);
  4002.         TclEmitPush(objIndex, envPtr);
  4003.         maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
  4004.     } else {
  4005.         maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
  4006.     }
  4007.     }
  4008.     if (result == TCL_OK) {
  4009.     int concatItems = 2*numWords - 1;
  4010.     while (concatItems > 255) {
  4011.         TclEmitInstUInt1(INST_CONCAT1, 255, envPtr);
  4012.         concatItems -= 254;  /* concat pushes 1 obj, the result */
  4013.     }
  4014.     if (concatItems > 1) {
  4015.         TclEmitInstUInt1(INST_CONCAT1, concatItems, envPtr);
  4016.     }
  4017.     TclEmitOpcode(INST_EXPR_STK, envPtr);
  4018.     }
  4019.     
  4020.     /*
  4021.      * If emitting inline code, update the target of the jump after
  4022.      * that inline code.
  4023.      */
  4024.     
  4025.     if (inlineCode) {
  4026.     int jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
  4027.     if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
  4028.         /*
  4029.          * Update the inline expression code's catch ExceptionRange
  4030.          * target since it, being after the jump, also moved down.
  4031.          */
  4032.         
  4033.         envPtr->excRangeArrayPtr[range].catchOffset += 3;
  4034.     }
  4035.     }
  4036.     Tcl_DStringFree(&buffer);
  4037.     
  4038.     done:
  4039.     if (numWords == 0) {
  4040.     envPtr->termOffset = 0;
  4041.     } else {
  4042.     envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
  4043.     }
  4044.     if (range != -1) {        /* we inline compiled the expr */
  4045.     envPtr->excRangeDepth--;
  4046.     }
  4047.     envPtr->pushSimpleWords = savePushSimpleWords;
  4048.     envPtr->exprIsJustVarRef = saveExprIsJustVarRef;
  4049.     envPtr->exprIsComparison = saveExprIsComparison;
  4050.     envPtr->maxStackDepth = maxDepth;
  4051.     FreeArgInfo(&argInfo);
  4052.     return result;
  4053. }
  4054.  
  4055. /*
  4056.  *----------------------------------------------------------------------
  4057.  *
  4058.  * TclCompileForCmd --
  4059.  *
  4060.  *    Procedure called to compile the "for" command.
  4061.  *
  4062.  * Results:
  4063.  *    The return value is a standard Tcl result, which is TCL_OK unless
  4064.  *    there was an error while parsing string. If an error occurs then
  4065.  *    the interpreter's result contains a standard error message.
  4066.  *
  4067.  *    envPtr->termOffset is filled in with the offset of the character in
  4068.  *    "string" just after the last one successfully processed.
  4069.  *
  4070.  *    envPtr->maxStackDepth is updated with the maximum number of stack
  4071.  *    elements needed to execute the command.
  4072.  *
  4073.  * Side effects:
  4074.  *    Instructions are added to envPtr to evaluate the "for" command
  4075.  *    at runtime.
  4076.  *
  4077.  *----------------------------------------------------------------------
  4078.  */
  4079.  
  4080. int
  4081. TclCompileForCmd(interp, string, lastChar, flags, envPtr)
  4082.     Tcl_Interp *interp;        /* Used for error reporting. */
  4083.     char *string;        /* The source string to compile. */
  4084.     char *lastChar;        /* Pointer to terminating character of
  4085.                  * string. */
  4086.     int flags;            /* Flags to control compilation (same as
  4087.                  * passed to Tcl_Eval). */
  4088.     CompileEnv *envPtr;        /* Holds resulting instructions. */
  4089. {
  4090.     int maxDepth = 0;        /* Maximum number of stack elements needed
  4091.                  * to execute cmd. */
  4092.     ArgInfo argInfo;        /* Structure holding information about the
  4093.                  * start and end of each argument word. */
  4094.     int range1, range2;        /* Indexes in the ExceptionRange array of
  4095.                  * the loop ranges for this loop: one for
  4096.                  * its body and one for its "next" cmd. */
  4097.     JumpFixup jumpFalseFixup;    /* Used to update or replace the ifFalse
  4098.                  * jump after the "for" test when its target
  4099.                  * PC is determined. */
  4100.     int jumpBackDist, jumpBackOffset, testCodeOffset, jumpDist, objIndex;
  4101.     unsigned char *jumpPc;
  4102.     int savePushSimpleWords = envPtr->pushSimpleWords;
  4103.     int numWords, result;
  4104.  
  4105.     /*
  4106.      * Scan the words of the command and record the start and finish of
  4107.      * each argument word.
  4108.      */
  4109.  
  4110.     InitArgInfo(&argInfo);
  4111.     result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
  4112.     numWords = argInfo.numArgs;      /* i.e., the # after the command name */
  4113.     if (result != TCL_OK) {
  4114.     goto done;
  4115.     }
  4116.     if (numWords != 4) {
  4117.     Tcl_ResetResult(interp);
  4118.     Tcl_AppendToObj(Tcl_GetObjResult(interp),
  4119.             "wrong # args: should be \"for start test next command\"", -1);
  4120.     result = TCL_ERROR;
  4121.     goto done;
  4122.     }
  4123.  
  4124.     /*
  4125.      * If the test expression is enclosed in quotes (""s), don't compile
  4126.      * the for inline. As a result of Tcl's two level substitution
  4127.      * semantics for expressions, the expression might have a constant
  4128.      * value that results in the loop never executing, or executing forever.
  4129.      * Consider "set x 0; for {} "$x > 5" {incr x} {}": the loop body 
  4130.      * should never be executed.
  4131.      */
  4132.  
  4133.     if (*(argInfo.startArray[1]) == '"') {
  4134.     result = TCL_OUT_LINE_COMPILE;
  4135.         goto done;
  4136.     }
  4137.  
  4138.     /*
  4139.      * Create a ExceptionRange record for the for loop's body. This is used
  4140.      * to implement break and continue commands inside the body.
  4141.      * Then create a second ExceptionRange record for the "next" command in 
  4142.      * order to implement break (but not continue) inside it. The second,
  4143.      * "next" ExceptionRange will always have a -1 continueOffset.
  4144.      */
  4145.  
  4146.     envPtr->excRangeDepth++;
  4147.     envPtr->maxExcRangeDepth =
  4148.     TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
  4149.     range1 = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
  4150.     range2 = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
  4151.  
  4152.     /*
  4153.      * Compile inline the next word: the initial command.
  4154.      */
  4155.  
  4156.     result = CompileCmdWordInline(interp, argInfo.startArray[0],
  4157.         (argInfo.endArray[0] + 1), flags, envPtr);
  4158.     if (result != TCL_OK) {
  4159.     if (result == TCL_ERROR) {
  4160.             Tcl_AddObjErrorInfo(interp, "\n    (\"for\" initial command)", -1);
  4161.         }
  4162.     goto done;
  4163.     }
  4164.     maxDepth = envPtr->maxStackDepth;
  4165.  
  4166.     /*
  4167.      * Discard the start command's result.
  4168.      */
  4169.  
  4170.     TclEmitOpcode(INST_POP, envPtr);
  4171.  
  4172.     /*
  4173.      * Compile the next word: the test expression.
  4174.      */
  4175.  
  4176.     testCodeOffset = TclCurrCodeOffset();
  4177.     envPtr->pushSimpleWords = 1;    /* process words normally */
  4178.     result = CompileExprWord(interp, argInfo.startArray[1],
  4179.         (argInfo.endArray[1] + 1), flags, envPtr);
  4180.     if (result != TCL_OK) {
  4181.     if (result == TCL_ERROR) {
  4182.             Tcl_AddObjErrorInfo(interp, "\n    (\"for\" test expression)", -1);
  4183.         }
  4184.     goto done;
  4185.     }
  4186.     maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
  4187.  
  4188.     /*
  4189.      * Emit the jump that terminates the for command if the test was
  4190.      * false. We emit a one byte (relative) jump here, and replace it later
  4191.      * with a four byte jump if the jump target is > 127 bytes away.
  4192.      */
  4193.  
  4194.     TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
  4195.  
  4196.     /*
  4197.      * Compile the loop body word inline. Also register the loop body's
  4198.      * starting PC offset and byte length in the its ExceptionRange record.
  4199.      */
  4200.  
  4201.     envPtr->excRangeArrayPtr[range1].codeOffset = TclCurrCodeOffset();
  4202.     result = CompileCmdWordInline(interp, argInfo.startArray[3],
  4203.         (argInfo.endArray[3] + 1), flags, envPtr);
  4204.     if (result != TCL_OK) {
  4205.     if (result == TCL_ERROR) {
  4206.         char msg[60];
  4207.         sprintf(msg, "\n    (\"for\" body line %d)", interp->errorLine);
  4208.             Tcl_AddObjErrorInfo(interp, msg, -1);
  4209.         }
  4210.     goto done;
  4211.     }
  4212.     maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
  4213.     envPtr->excRangeArrayPtr[range1].numCodeBytes =
  4214.     (TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range1].codeOffset);
  4215.  
  4216.     /*
  4217.      * Discard the loop body's result.
  4218.      */
  4219.  
  4220.     TclEmitOpcode(INST_POP, envPtr);
  4221.  
  4222.     /*
  4223.      * Finally, compile the "next" subcommand word inline.
  4224.      */
  4225.  
  4226.     envPtr->excRangeArrayPtr[range1].continueOffset = TclCurrCodeOffset();
  4227.     envPtr->excRangeArrayPtr[range2].codeOffset = TclCurrCodeOffset();
  4228.     result = CompileCmdWordInline(interp, argInfo.startArray[2],
  4229.         (argInfo.endArray[2] + 1), flags, envPtr);
  4230.     if (result != TCL_OK) {
  4231.     if (result == TCL_ERROR) {
  4232.         Tcl_AddObjErrorInfo(interp, "\n    (\"for\" loop-end command)", -1);
  4233.     }
  4234.     goto done;
  4235.     }
  4236.     maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
  4237.     envPtr->excRangeArrayPtr[range2].numCodeBytes =
  4238.     TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range2].codeOffset;
  4239.  
  4240.     /*
  4241.      * Discard the "next" subcommand's result.
  4242.      */
  4243.  
  4244.     TclEmitOpcode(INST_POP, envPtr);
  4245.     
  4246.     /*
  4247.      * Emit the unconditional jump back to the test at the top of the for
  4248.      * loop. We generate a four byte jump if the distance to the test is
  4249.      * greater than 120 bytes. This is conservative, and ensures that we
  4250.      * won't have to replace this unconditional jump if we later need to
  4251.      * replace the ifFalse jump with a four-byte jump.
  4252.      */
  4253.  
  4254.     jumpBackOffset = TclCurrCodeOffset();
  4255.     jumpBackDist = (jumpBackOffset - testCodeOffset);
  4256.     if (jumpBackDist > 120) {
  4257.     TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
  4258.     } else {
  4259.     TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr);
  4260.     }
  4261.  
  4262.     /*
  4263.      * Now that we know the target of the jumpFalse after the test, update
  4264.      * it with the correct distance. If the distance is too great (more
  4265.      * than 127 bytes), replace that jump with a four byte instruction and
  4266.      * move the instructions after the jump down.
  4267.      */
  4268.  
  4269.     jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset);
  4270.     if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
  4271.     /*
  4272.      * Update the loop body's ExceptionRange record since it moved down:
  4273.      * i.e., increment both its start and continue PC offsets. Also,
  4274.      * update the "next" command's start PC offset in its ExceptionRange
  4275.      * record since it also moved down.
  4276.      */
  4277.  
  4278.     envPtr->excRangeArrayPtr[range1].codeOffset += 3;
  4279.     envPtr->excRangeArrayPtr[range1].continueOffset += 3;
  4280.     envPtr->excRangeArrayPtr[range2].codeOffset += 3;
  4281.  
  4282.     /*
  4283.      * Update the distance for the unconditional jump back to the test
  4284.      * at the top of the loop since it moved down 3 bytes too.
  4285.      */
  4286.  
  4287.     jumpBackOffset += 3;
  4288.     jumpPc = (envPtr->codeStart + jumpBackOffset);
  4289.     if (jumpBackDist > 120) {
  4290.         jumpBackDist += 3;
  4291.         TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist,
  4292.                    jumpPc);
  4293.     } else {
  4294.         jumpBackDist += 3;
  4295.         TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist,
  4296.                    jumpPc);
  4297.     }
  4298.     }
  4299.     
  4300.     /*
  4301.      * The current PC offset (after the loop's body and "next" subcommand)
  4302.      * is the loop's break target.
  4303.      */
  4304.  
  4305.     envPtr->excRangeArrayPtr[range1].breakOffset =
  4306.     envPtr->excRangeArrayPtr[range2].breakOffset = TclCurrCodeOffset();
  4307.     
  4308.     /*
  4309.      * Push an empty string object as the for command's result.
  4310.      */
  4311.  
  4312.     objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0,
  4313.                     envPtr);
  4314.     TclEmitPush(objIndex, envPtr);
  4315.     if (maxDepth == 0) {
  4316.     maxDepth = 1;
  4317.     }
  4318.  
  4319.     done:
  4320.     if (numWords == 0) {
  4321.     envPtr->termOffset = 0;
  4322.     } else {
  4323.     envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
  4324.     }
  4325.     envPtr->pushSimpleWords = savePushSimpleWords;
  4326.     envPtr->maxStackDepth = maxDepth;
  4327.     envPtr->excRangeDepth--;
  4328.     FreeArgInfo(&argInfo);
  4329.     return result;
  4330. }
  4331.  
  4332. /*
  4333.  *----------------------------------------------------------------------
  4334.  *
  4335.  * TclCompileForeachCmd --
  4336.  *
  4337.  *    Procedure called to compile the "foreach" command.
  4338.  *
  4339.  * Results:
  4340.  *    The return value is a standard Tcl result, which is TCL_OK if
  4341.  *    compilation was successful. If an error occurs then the
  4342.  *    interpreter's result contains a standard error message and TCL_ERROR
  4343.  *    is returned. If complation failed because the command is too complex
  4344.  *    for TclCompileForeachCmd, TCL_OUT_LINE_COMPILE is returned
  4345.  *    indicating that the foreach command should be compiled "out of line"
  4346.  *    by emitting code to invoke its command procedure at runtime.
  4347.  *
  4348.  *    envPtr->termOffset is filled in with the offset of the character in
  4349.  *    "string" just after the last one successfully processed.
  4350.  *
  4351.  *    envPtr->maxStackDepth is updated with the maximum number of stack
  4352.  *    elements needed to execute the "while" command.
  4353.  *
  4354.  * Side effects:
  4355.  *    Instructions are added to envPtr to evaluate the "foreach" command
  4356.  *    at runtime.
  4357.  *
  4358.  *----------------------------------------------------------------------
  4359.  */
  4360.  
  4361. int
  4362. TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
  4363.     Tcl_Interp *interp;        /* Used for error reporting. */
  4364.     char *string;        /* The source string to compile. */
  4365.     char *lastChar;        /* Pointer to terminating character of
  4366.                  * string. */
  4367.     int flags;            /* Flags to control compilation (same as
  4368.                  * passed to Tcl_Eval). */
  4369.     CompileEnv *envPtr;        /* Holds resulting instructions. */
  4370. {
  4371.     Proc *procPtr = envPtr->procPtr;
  4372.                     /* Points to structure describing procedure
  4373.                  * containing foreach command, else NULL. */
  4374.     int maxDepth = 0;        /* Maximum number of stack elements needed
  4375.                  * to execute cmd. */
  4376.     ArgInfo argInfo;        /* Structure holding information about the
  4377.                  * start and end of each argument word. */
  4378.     int numLists = 0;        /* Count of variable (and value) lists. */
  4379.     int range;            /* Index in the ExceptionRange array of the
  4380.                  * ExceptionRange record for this loop. */
  4381.     ForeachInfo *infoPtr;    /* Points to the structure describing this
  4382.                  * foreach command. Stored in a AuxData
  4383.                  * record in the ByteCode. */
  4384.     JumpFixup jumpFalseFixup;    /* Used to update or replace the ifFalse
  4385.                  * jump after test when its target PC is
  4386.                  * determined. */
  4387.     char savedChar;        /* Holds the char from string termporarily
  4388.                  * replaced by a null character during
  4389.                  * processing of argument words. */
  4390.     int firstListTmp = -1;    /* If we decide to compile this foreach
  4391.                  * command, this is the index or "slot
  4392.                  * number" for the first temp var allocated
  4393.                  * in the proc frame that holds a pointer to
  4394.                  * a value list. Initialized to avoid a
  4395.                  * compiler warning. */
  4396.     int loopIterNumTmp;        /* If we decide to compile this foreach
  4397.                  * command, the index for the temp var that
  4398.                  * holds the current iteration count.  */
  4399.     char *varListStart, *varListEnd, *valueListStart, *bodyStart, *bodyEnd;
  4400.     unsigned char *jumpPc;
  4401.     int jumpDist, jumpBackDist, jumpBackOffset;
  4402.     int numWords, numVars, infoIndex, tmpIndex, objIndex, i, j, result;
  4403.     int savePushSimpleWords = envPtr->pushSimpleWords;
  4404.  
  4405.     /*
  4406.      * We parse the variable list argument words and create two arrays:
  4407.      *    varcList[i] gives the number of variables in the i-th var list
  4408.      *    varvList[i] points to an array of the names in the i-th var list
  4409.      * These are initially allocated on the stack, and are allocated on
  4410.      * the heap if necessary.
  4411.      */
  4412.  
  4413. #define STATIC_VAR_LIST_SIZE 4
  4414.     int varcListStaticSpace[STATIC_VAR_LIST_SIZE];
  4415.     char **varvListStaticSpace[STATIC_VAR_LIST_SIZE];
  4416.  
  4417.     int *varcList = varcListStaticSpace;
  4418.     char ***varvList = varvListStaticSpace;
  4419.  
  4420.     /*
  4421.      * If the foreach command is at global level (not in a procedure),
  4422.      * don't compile it inline: the payoff is too small.
  4423.      */
  4424.  
  4425.     if (procPtr == NULL) {
  4426.     return TCL_OUT_LINE_COMPILE;
  4427.     }
  4428.  
  4429.     /*
  4430.      * Scan the words of the command and record the start and finish of
  4431.      * each argument word.
  4432.      */
  4433.  
  4434.     InitArgInfo(&argInfo);
  4435.     result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
  4436.     numWords = argInfo.numArgs;
  4437.     if (result != TCL_OK) {
  4438.     goto done;
  4439.     }
  4440.     if ((numWords < 3) || (numWords%2 != 1)) {
  4441.     Tcl_ResetResult(interp);
  4442.     Tcl_AppendToObj(Tcl_GetObjResult(interp),
  4443.             "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1);
  4444.         result = TCL_ERROR;
  4445.     goto done;
  4446.     }
  4447.  
  4448.     /*
  4449.      * Initialize the varcList and varvList arrays; allocate heap storage,
  4450.      * if necessary, for them. Also make sure the variable names
  4451.      * have no substitutions: that they're just "var" or "var(elem)"
  4452.      */
  4453.  
  4454.     numLists = (numWords - 1)/2;
  4455.     if (numLists > STATIC_VAR_LIST_SIZE) {
  4456.         varcList = (int *) ckalloc(numLists * sizeof(int));
  4457.         varvList = (char ***) ckalloc(numLists * sizeof(char **));
  4458.     }
  4459.     for (i = 0;  i < numLists;  i++) {
  4460.         varcList[i] = 0;
  4461.         varvList[i] = (char **) NULL;
  4462.     }
  4463.     for (i = 0;  i < numLists;  i++) {
  4464.     /*
  4465.      * Break each variable list into its component variables. If the
  4466.      * lists is enclosed in {}s or ""s, strip them off first.
  4467.      */
  4468.  
  4469.     varListStart = argInfo.startArray[i*2];
  4470.     varListEnd   = argInfo.endArray[i*2];
  4471.     if ((*varListStart == '{') || (*varListStart == '"')) {
  4472.         if ((*varListEnd != '}') && (*varListEnd != '"')) {
  4473.         Tcl_ResetResult(interp);
  4474.         if (*varListStart == '"') {
  4475.             Tcl_AppendToObj(Tcl_GetObjResult(interp),
  4476.                 "extra characters after close-quote", -1);
  4477.         } else {
  4478.             Tcl_AppendToObj(Tcl_GetObjResult(interp),
  4479.                     "extra characters after close-brace", -1);
  4480.         }
  4481.         result = TCL_ERROR;
  4482.         goto done;
  4483.         }
  4484.         varListStart++;
  4485.         varListEnd--;
  4486.     }
  4487.         
  4488.     /*
  4489.      * NOTE: THIS NEEDS TO BE CONVERTED TO AN OBJECT LIST.
  4490.      */
  4491.  
  4492.     savedChar = *(varListEnd+1);
  4493.     *(varListEnd+1) = '\0';
  4494.     result = Tcl_SplitList(interp, varListStart,
  4495.                    &varcList[i], &varvList[i]);
  4496.     *(varListEnd+1) = savedChar;
  4497.         if (result != TCL_OK) {
  4498.             goto done;
  4499.         }
  4500.  
  4501.     /*
  4502.      * Check that each variable name has no substitutions and that
  4503.      * it is a scalar name.
  4504.      */
  4505.  
  4506.     numVars = varcList[i];
  4507.     for (j = 0;  j < numVars;  j++) {
  4508.         char *varName = varvList[i][j];
  4509.         char *p = varName;
  4510.         while (*p != '\0') {
  4511.         if (CHAR_TYPE(p, p+1) != TCL_NORMAL) {
  4512.             result = TCL_OUT_LINE_COMPILE;
  4513.             goto done;
  4514.         }
  4515.         if (*p == '(') {
  4516.             char *q = p;
  4517.             do {
  4518.             q++;
  4519.             } while (*q != '\0');
  4520.             q--;
  4521.             if (*q == ')') { /* we have an array element */
  4522.             result = TCL_OUT_LINE_COMPILE;
  4523.             goto done; 
  4524.             }
  4525.         }
  4526.         p++;
  4527.         }
  4528.     }
  4529.     }
  4530.  
  4531.     /*
  4532.      *==== At this point we believe we can compile the foreach command ====
  4533.      */
  4534.  
  4535.     /*
  4536.      * Create and initialize a ExceptionRange record to hold information
  4537.      * about this loop. This is used to implement break and continue.
  4538.      */
  4539.     
  4540.     envPtr->excRangeDepth++;
  4541.     envPtr->maxExcRangeDepth =
  4542.     TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
  4543.     range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
  4544.     
  4545.     /*
  4546.      * Reserve (numLists + 1) temporary variables:
  4547.      *    - numLists temps for each value list
  4548.      *    - a temp for the "next value" index into each value list
  4549.      * At this time we don't try to reuse temporaries; if there are two
  4550.      * nonoverlapping foreach loops, they don't share any temps.
  4551.      */
  4552.  
  4553.     for (i = 0;  i < numLists;  i++) {
  4554.     tmpIndex = LookupCompiledLocal(NULL, /*nameChars*/ 0,
  4555.         /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, procPtr);
  4556.     if (i == 0) {
  4557.         firstListTmp = tmpIndex;
  4558.     }
  4559.     }
  4560.     loopIterNumTmp = LookupCompiledLocal(NULL, /*nameChars*/ 0,
  4561.         /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, procPtr);
  4562.     
  4563.     /*
  4564.      * Create and initialize the ForeachInfo and ForeachVarList data
  4565.      * structures describing this command. Then create a AuxData record
  4566.      * pointing to the ForeachInfo structure in the compilation environment.
  4567.      */
  4568.  
  4569.     infoPtr = (ForeachInfo *) ckalloc((unsigned)
  4570.         (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
  4571.     infoPtr->numLists = numLists;
  4572.     infoPtr->firstListTmp = firstListTmp;
  4573.     infoPtr->loopIterNumTmp = loopIterNumTmp;
  4574.     for (i = 0;  i < numLists;  i++) {
  4575.     ForeachVarList *varListPtr;
  4576.     numVars = varcList[i];
  4577.     varListPtr = (ForeachVarList *) ckalloc((unsigned)
  4578.             sizeof(ForeachVarList) + numVars*sizeof(int));
  4579.     varListPtr->numVars = numVars;
  4580.     for (j = 0;  j < numVars;  j++) {
  4581.         char *varName = varvList[i][j];
  4582.         int nameChars = strlen(varName);
  4583.         varListPtr->varIndexes[j] = LookupCompiledLocal(varName,
  4584.             nameChars, /*createIfNew*/ 1,
  4585.                     /*flagsIfCreated*/ VAR_SCALAR, procPtr);
  4586.     }
  4587.     infoPtr->varLists[i] = varListPtr;
  4588.     }
  4589.     infoIndex = TclCreateAuxData((ClientData) infoPtr,
  4590.             DupForeachInfo, FreeForeachInfo, envPtr);
  4591.  
  4592.     /*
  4593.      * Emit code to store each value list into the associated temporary.
  4594.      */
  4595.  
  4596.     for (i = 0;  i < numLists;  i++) {
  4597.     valueListStart = argInfo.startArray[2*i + 1];
  4598.     envPtr->pushSimpleWords = 1;
  4599.     result = CompileWord(interp, valueListStart, lastChar, flags,
  4600.         envPtr);
  4601.     if (result != TCL_OK) {
  4602.         goto done;
  4603.     }
  4604.     maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
  4605.  
  4606.     tmpIndex = (firstListTmp + i);
  4607.     if (tmpIndex <= 255) {
  4608.         TclEmitInstUInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
  4609.     } else {
  4610.         TclEmitInstUInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
  4611.     }
  4612.     TclEmitOpcode(INST_POP, envPtr);
  4613.     }
  4614.  
  4615.     /*
  4616.      * Emit the instruction to initialize the foreach loop's index temp var.
  4617.      */
  4618.  
  4619.     TclEmitInstUInt4(INST_FOREACH_START4, infoIndex, envPtr);
  4620.     
  4621.     /*
  4622.      * Emit the top of loop code that assigns each loop variable and checks
  4623.      * whether to terminate the loop.
  4624.      */
  4625.  
  4626.     envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset();
  4627.     TclEmitInstUInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
  4628.  
  4629.     /*
  4630.      * Emit the ifFalse jump that terminates the foreach if all value lists
  4631.      * are exhausted. We emit a one byte (relative) jump here, and replace
  4632.      * it later with a four byte jump if the jump target is more than
  4633.      * 127 bytes away.
  4634.      */
  4635.  
  4636.     TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
  4637.     
  4638.     /*
  4639.      * Compile the loop body word inline. Also register the loop body's
  4640.      * starting PC offset and byte length in the ExceptionRange record.
  4641.      */
  4642.  
  4643.     bodyStart = argInfo.startArray[numWords - 1];
  4644.     bodyEnd   = argInfo.endArray[numWords - 1];
  4645.     savedChar = *(bodyEnd+1);
  4646.     *(bodyEnd+1) = '\0';
  4647.     envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
  4648.     result = CompileCmdWordInline(interp, bodyStart, bodyEnd+1, flags,
  4649.         envPtr);
  4650.     *(bodyEnd+1) = savedChar;
  4651.     if (result != TCL_OK) {
  4652.     if (result == TCL_ERROR) {
  4653.         char msg[60];
  4654.         sprintf(msg, "\n    (\"foreach\" body line %d)",
  4655.             interp->errorLine);
  4656.             Tcl_AddObjErrorInfo(interp, msg, -1);
  4657.         }
  4658.     goto done;
  4659.     }
  4660.     maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
  4661.     envPtr->excRangeArrayPtr[range].numCodeBytes =
  4662.     TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
  4663.  
  4664.     /*
  4665.      * Discard the loop body's result.
  4666.      */
  4667.  
  4668.     TclEmitOpcode(INST_POP, envPtr);
  4669.     
  4670.     /*
  4671.      * Emit the unconditional jump back to the test at the top of the
  4672.      * loop. We generate a four byte jump if the distance to the to of
  4673.      * the foreach is greater than 120 bytes. This is conservative and
  4674.      * ensures that we won't have to replace this unconditional jump if
  4675.      * we later need to replace the ifFalse jump with a four-byte jump.
  4676.      */
  4677.  
  4678.     jumpBackOffset = TclCurrCodeOffset();
  4679.     jumpBackDist =
  4680.     (jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset);
  4681.     if (jumpBackDist > 120) {
  4682.     TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
  4683.     } else {
  4684.     TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr);
  4685.     }
  4686.  
  4687.     /*
  4688.      * Now that we know the target of the jumpFalse after the foreach_step
  4689.      * test, update it with the correct distance. If the distance is too
  4690.      * great (more than 127 bytes), replace that jump with a four byte
  4691.      * instruction and move the instructions after the jump down.
  4692.      */
  4693.  
  4694.     jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset);
  4695.     if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
  4696.     /*
  4697.      * Update the loop body's starting PC offset since it moved down.
  4698.      */
  4699.  
  4700.     envPtr->excRangeArrayPtr[range].codeOffset += 3;
  4701.  
  4702.     /*
  4703.      * Update the distance for the unconditional jump back to the test
  4704.      * at the top of the loop since it moved down 3 bytes too.
  4705.      */
  4706.  
  4707.     jumpBackOffset += 3;
  4708.     jumpPc = (envPtr->codeStart + jumpBackOffset);
  4709.     if (jumpBackDist > 120) {
  4710.         jumpBackDist += 3;
  4711.         TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist,
  4712.                    jumpPc);
  4713.     } else {
  4714.         jumpBackDist += 3;
  4715.         TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist,
  4716.                    jumpPc);
  4717.     }
  4718.     }
  4719.  
  4720.     /*
  4721.      * The current PC offset (after the loop's body) is the loop's
  4722.      * break target.
  4723.      */
  4724.  
  4725.     envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset();
  4726.     
  4727.     /*
  4728.      * Push an empty string object as the foreach command's result.
  4729.      */
  4730.  
  4731.     objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0,
  4732.                     envPtr);
  4733.     TclEmitPush(objIndex, envPtr);
  4734.     if (maxDepth == 0) {
  4735.     maxDepth = 1;
  4736.     }
  4737.  
  4738.     done:
  4739.     for (i = 0;  i < numLists;  i++) {
  4740.         if (varvList[i] != (char **) NULL) {
  4741.             ckfree((char *) varvList[i]);
  4742.         }
  4743.     }
  4744.     if (varcList != varcListStaticSpace) {
  4745.     ckfree((char *) varcList);
  4746.         ckfree((char *) varvList);
  4747.     }
  4748.     envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
  4749.     envPtr->pushSimpleWords = savePushSimpleWords;
  4750.     envPtr->maxStackDepth = maxDepth;
  4751.     envPtr->excRangeDepth--;
  4752.     FreeArgInfo(&argInfo);
  4753.     return result;
  4754. }
  4755.  
  4756. /*
  4757.  *----------------------------------------------------------------------
  4758.  *
  4759.  * DupForeachInfo --
  4760.  *
  4761.  *    This procedure duplicates a ForeachInfo structure created as
  4762.  *    auxiliary data during the compilation of a foreach command.
  4763.  *
  4764.  * Results:
  4765.  *    A pointer to a newly allocated copy of the existing ForeachInfo
  4766.  *    structure is returned.
  4767.  *
  4768.  * Side effects:
  4769.  *    Storage for the copied ForeachInfo record is allocated. If the
  4770.  *    original ForeachInfo structure pointed to any ForeachVarList
  4771.  *    records, these structures are also copied and pointers to them
  4772.  *    are stored in the new ForeachInfo record.
  4773.  *
  4774.  *----------------------------------------------------------------------
  4775.  */
  4776.  
  4777. static ClientData
  4778. DupForeachInfo(clientData)
  4779.     ClientData clientData;    /* The foreach command's compilation
  4780.                  * auxiliary data to duplicate. */
  4781. {
  4782.     register ForeachInfo *srcPtr = (ForeachInfo *) clientData;
  4783.     ForeachInfo *dupPtr;
  4784.     register ForeachVarList *srcListPtr, *dupListPtr;
  4785.     int numLists = srcPtr->numLists;
  4786.     int numVars, i, j;
  4787.     
  4788.     dupPtr = (ForeachInfo *) ckalloc((unsigned)
  4789.         (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
  4790.     dupPtr->numLists = numLists;
  4791.     dupPtr->firstListTmp = srcPtr->firstListTmp;
  4792.     dupPtr->loopIterNumTmp = srcPtr->loopIterNumTmp;
  4793.     
  4794.     for (i = 0;  i < numLists;  i++) {
  4795.     srcListPtr = srcPtr->varLists[i];
  4796.     numVars = srcListPtr->numVars;
  4797.     dupListPtr = (ForeachVarList *) ckalloc((unsigned)
  4798.             sizeof(ForeachVarList) + numVars*sizeof(int));
  4799.     dupListPtr->numVars = numVars;
  4800.     for (j = 0;  j < numVars;  j++) {
  4801.         dupListPtr->varIndexes[j] =    srcListPtr->varIndexes[j];
  4802.     }
  4803.     dupPtr->varLists[i] = dupListPtr;
  4804.     }
  4805.     return (ClientData) dupPtr;
  4806. }
  4807.  
  4808. /*
  4809.  *----------------------------------------------------------------------
  4810.  *
  4811.  * FreeForeachInfo --
  4812.  *
  4813.  *    Procedure to free a ForeachInfo structure created as auxiliary data
  4814.  *    during the compilation of a foreach command.
  4815.  *
  4816.  * Results:
  4817.  *    None.
  4818.  *
  4819.  * Side effects:
  4820.  *    Storage for the ForeachInfo structure pointed to by the ClientData
  4821.  *    argument is freed as is any ForeachVarList record pointed to by the
  4822.  *    ForeachInfo structure.
  4823.  *
  4824.  *----------------------------------------------------------------------
  4825.  */
  4826.  
  4827. static void
  4828. FreeForeachInfo(clientData)
  4829.     ClientData clientData;    /* The foreach command's compilation
  4830.                  * auxiliary data to free. */
  4831. {
  4832.     register ForeachInfo *infoPtr = (ForeachInfo *) clientData;
  4833.     register ForeachVarList *listPtr;
  4834.     int numLists = infoPtr->numLists;
  4835.     register int i;
  4836.  
  4837.     for (i = 0;  i < numLists;  i++) {
  4838.     listPtr = infoPtr->varLists[i];
  4839.     ckfree((char *) listPtr);
  4840.     }
  4841.     ckfree((char *) infoPtr);
  4842. }
  4843.  
  4844. /*
  4845.  *----------------------------------------------------------------------
  4846.  *
  4847.  * TclCompileIfCmd --
  4848.  *
  4849.  *    Procedure called to compile the "if" command.
  4850.  *
  4851.  * Results:
  4852.  *    The return value is a standard Tcl result, which is TCL_OK unless
  4853.  *    there was an error while parsing string. If an error occurs then
  4854.  *    the interpreter's result contains a standard error message.
  4855.  *
  4856.  *    envPtr->termOffset is filled in with the offset of the character in
  4857.  *    "string" just after the last one successfully processed.
  4858.  *
  4859.  *    envPtr->maxStackDepth is updated with the maximum number of stack
  4860.  *    elements needed to execute the command.
  4861.  *
  4862.  * Side effects:
  4863.  *    Instructions are added to envPtr to evaluate the "if" command
  4864.  *    at runtime.
  4865.  *
  4866.  *----------------------------------------------------------------------
  4867.  */
  4868.  
  4869. int
  4870. TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
  4871.     Tcl_Interp *interp;        /* Used for error reporting. */
  4872.     char *string;        /* The source string to compile. */
  4873.     char *lastChar;        /* Pointer to terminating character of
  4874.                  * string. */
  4875.     int flags;            /* Flags to control compilation (same as
  4876.                  * passed to Tcl_Eval). */
  4877.     CompileEnv *envPtr;        /* Holds resulting instructions. */
  4878. {
  4879.     register char *src = string;/* Points to current source char. */
  4880.     register int type;        /* Current char's CHAR_TYPE type. */
  4881.     int maxDepth = 0;        /* Maximum number of stack elements needed
  4882.                  * to execute cmd. */
  4883.     JumpFixupArray jumpFalseFixupArray;
  4884.                     /* Used to fix up the ifFalse jump after
  4885.                  * each "if"/"elseif" test when its target
  4886.                  * PC is determined. */
  4887.     JumpFixupArray jumpEndFixupArray;
  4888.                 /* Used to fix up the unconditional jump
  4889.                  * after each "then" command to the end of
  4890.                  * the "if" when that PC is determined. */
  4891.     char *testSrcStart;
  4892.     int jumpDist, jumpFalseDist, jumpIndex, objIndex, j, result;
  4893.     unsigned char *ifFalsePc;
  4894.     unsigned char opCode;
  4895.     int savePushSimpleWords = envPtr->pushSimpleWords;
  4896.  
  4897.     /*
  4898.      * Loop compiling "expr then body" clauses after an "if" or "elseif".
  4899.      */
  4900.  
  4901.     TclInitJumpFixupArray(&jumpFalseFixupArray);
  4902.     TclInitJumpFixupArray(&jumpEndFixupArray);
  4903.     while (1) {    
  4904.     /*
  4905.      * At this point in the loop, we have an expression to test, either
  4906.      * the main expression or an expression following an "elseif".
  4907.      * The arguments after the expression must be "then" (optional) and
  4908.      * a script to execute if the expression is true.
  4909.      */
  4910.  
  4911.     AdvanceToNextWord(src, envPtr);
  4912.     src += envPtr->termOffset;
  4913.     type = CHAR_TYPE(src, lastChar);
  4914.     if (type == TCL_COMMAND_END) {
  4915.         Tcl_ResetResult(interp);
  4916.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  4917.             "wrong # args: no expression after \"if\" argument", -1);
  4918.         result = TCL_ERROR;
  4919.         goto done;
  4920.     }
  4921.  
  4922.     /*
  4923.      * Compile the "if"/"elseif" test expression.
  4924.      */
  4925.     
  4926.     testSrcStart = src;
  4927.     envPtr->pushSimpleWords = 1;
  4928.     result = CompileExprWord(interp, src, lastChar, flags, envPtr);
  4929.     if (result != TCL_OK) {
  4930.         if (result == TCL_ERROR) {
  4931.         Tcl_AddObjErrorInfo(interp,
  4932.                 "\n    (\"if\" test expression)", -1);
  4933.         }
  4934.         goto done;
  4935.     }
  4936.     maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
  4937.     src += envPtr->termOffset;
  4938.  
  4939.     /*
  4940.      * Emit the ifFalse jump around the "then" part if the test was
  4941.      * false. We emit a one byte (relative) jump here, and replace it
  4942.      * later with a four byte jump if the jump target is more than 127
  4943.      * bytes away. 
  4944.      */
  4945.  
  4946.     if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
  4947.         TclExpandJumpFixupArray(&jumpFalseFixupArray);
  4948.     }
  4949.     jumpIndex = jumpFalseFixupArray.next;
  4950.     jumpFalseFixupArray.next++;
  4951.     TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
  4952.         &(jumpFalseFixupArray.fixup[jumpIndex]));
  4953.     
  4954.     /*
  4955.      * Skip over the optional "then" before the then clause.
  4956.      */
  4957.  
  4958.     AdvanceToNextWord(src, envPtr);
  4959.     src += envPtr->termOffset;
  4960.     type = CHAR_TYPE(src, lastChar);
  4961.     if (type == TCL_COMMAND_END) {
  4962.         char buf[100];
  4963.         sprintf(buf, "wrong # args: no script following \"%.20s\" argument", testSrcStart);
  4964.         Tcl_ResetResult(interp);
  4965.         Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
  4966.         result = TCL_ERROR;
  4967.         goto done;
  4968.     }
  4969.     if ((*src == 't') && (strncmp(src, "then", 4) == 0)) {
  4970.         type = CHAR_TYPE(src+4, lastChar);
  4971.         if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
  4972.         src += 4;
  4973.         AdvanceToNextWord(src, envPtr); 
  4974.         src += envPtr->termOffset;
  4975.         type = CHAR_TYPE(src, lastChar);
  4976.         if (type == TCL_COMMAND_END) {
  4977.             Tcl_ResetResult(interp);
  4978.             Tcl_AppendToObj(Tcl_GetObjResult(interp),
  4979.                     "wrong # args: no script following \"then\" argument", -1);
  4980.             result = TCL_ERROR;
  4981.             goto done;
  4982.         }
  4983.         }
  4984.     }
  4985.  
  4986.     /*
  4987.      * Compile the "then" command word inline.
  4988.      */
  4989.  
  4990.     result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr);
  4991.     if (result != TCL_OK) {
  4992.         if (result == TCL_ERROR) {
  4993.         char msg[60];
  4994.         sprintf(msg, "\n    (\"if\" then script line %d)",
  4995.                 interp->errorLine);
  4996.         Tcl_AddObjErrorInfo(interp, msg, -1);
  4997.         }
  4998.         goto done;
  4999.     }
  5000.     maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
  5001.     src += envPtr->termOffset;
  5002.  
  5003.     /*
  5004.      * Emit an unconditional jump to the end of the "if" command. We
  5005.      * emit a one byte jump here, and replace it later with a four byte
  5006.      * jump if the jump target is more than 127 bytes away. Note that
  5007.      * both the jumpFalseFixupArray and the jumpEndFixupArray are
  5008.      * indexed by the same index, "jumpIndex".
  5009.      */
  5010.  
  5011.     if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
  5012.         TclExpandJumpFixupArray(&jumpEndFixupArray);
  5013.     }
  5014.     jumpEndFixupArray.next++;
  5015.     TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
  5016.         &(jumpEndFixupArray.fixup[jumpIndex]));
  5017.  
  5018.      /*
  5019.      * Now that we know the target of the jumpFalse after the if test,
  5020.          * update it with the correct distance. We generate a four byte
  5021.      * jump if the distance is greater than 120 bytes. This is
  5022.      * conservative, and ensures that we won't have to replace this
  5023.      * jump if we later also need to replace the preceeding
  5024.      * unconditional jump to the end of the "if" with a four-byte jump.
  5025.          */
  5026.  
  5027.     jumpDist = (TclCurrCodeOffset() - jumpFalseFixupArray.fixup[jumpIndex].codeOffset);
  5028.     if (TclFixupForwardJump(envPtr,
  5029.             &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) {
  5030.         /*
  5031.          * Adjust the code offset for the unconditional jump at the end
  5032.          * of the last "then" clause.
  5033.          */
  5034.  
  5035.         jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
  5036.     }
  5037.  
  5038.     /*
  5039.      * Check now for a "elseif" word. If we find one, keep looping.
  5040.      */
  5041.  
  5042.     AdvanceToNextWord(src, envPtr);
  5043.     src += envPtr->termOffset;
  5044.     type = CHAR_TYPE(src, lastChar);
  5045.     if ((type != TCL_COMMAND_END)
  5046.             && ((*src == 'e') && (strncmp(src, "elseif", 6) == 0))) {
  5047.         type = CHAR_TYPE(src+6, lastChar);
  5048.         if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
  5049.         src += 6;
  5050.         AdvanceToNextWord(src, envPtr); 
  5051.         src += envPtr->termOffset;
  5052.         type = CHAR_TYPE(src, lastChar);
  5053.         if (type == TCL_COMMAND_END) {
  5054.             Tcl_ResetResult(interp);
  5055.             Tcl_AppendToObj(Tcl_GetObjResult(interp),
  5056.                     "wrong # args: no expression after \"elseif\" argument", -1);
  5057.             result = TCL_ERROR;
  5058.             goto done;
  5059.         }
  5060.         continue;      /* continue the "expr then body" loop */
  5061.         }
  5062.     }
  5063.     break;
  5064.     } /* end of the "expr then body" loop */
  5065.  
  5066.     /*
  5067.      * No more "elseif expr then body" clauses. Check now for an "else"
  5068.      * clause. If there is another word, we are at its start.
  5069.      */
  5070.  
  5071.     if (type != TCL_COMMAND_END) {
  5072.     if ((*src == 'e') && (strncmp(src, "else", 4) == 0)) {
  5073.         type = CHAR_TYPE(src+4, lastChar);
  5074.         if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
  5075.         src += 4;
  5076.         AdvanceToNextWord(src, envPtr); 
  5077.         src += envPtr->termOffset;
  5078.         type = CHAR_TYPE(src, lastChar);
  5079.         if (type == TCL_COMMAND_END) {
  5080.             Tcl_ResetResult(interp);
  5081.             Tcl_AppendToObj(Tcl_GetObjResult(interp),
  5082.                     "wrong # args: no script following \"else\" argument", -1);
  5083.             result = TCL_ERROR;
  5084.             goto done;
  5085.         }
  5086.         }
  5087.     }
  5088.  
  5089.     /*
  5090.      * Compile the "else" command word inline.
  5091.      */
  5092.  
  5093.     result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr);
  5094.     if (result != TCL_OK) {
  5095.         if (result == TCL_ERROR) {
  5096.         char msg[60];
  5097.         sprintf(msg, "\n    (\"if\" else script line %d)",
  5098.                 interp->errorLine);
  5099.         Tcl_AddObjErrorInfo(interp, msg, -1);
  5100.         }
  5101.         goto done;
  5102.     }
  5103.     maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
  5104.     src += envPtr->termOffset;
  5105.     
  5106.     /*
  5107.      * Skip over white space until the end of the command.
  5108.      */
  5109.     
  5110.     type = CHAR_TYPE(src, lastChar);
  5111.     if (type != TCL_COMMAND_END) {
  5112.         AdvanceToNextWord(src, envPtr);
  5113.         src += envPtr->termOffset;
  5114.         type = CHAR_TYPE(src, lastChar);
  5115.         if (type != TCL_COMMAND_END) {
  5116.         Tcl_ResetResult(interp);
  5117.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  5118.                 "wrong # args: extra words after \"else\" clause in \"if\" command", -1);
  5119.         result = TCL_ERROR;
  5120.         goto done;
  5121.         }
  5122.     }
  5123.     } else {
  5124.     /*
  5125.      * The "if" command has no "else" clause: push an empty string
  5126.      * object as its result.
  5127.      */
  5128.  
  5129.     objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0,
  5130.         /*inHeap*/ 0, envPtr);
  5131.     TclEmitPush(objIndex, envPtr);
  5132.     maxDepth = TclMax(1, maxDepth);
  5133.     }
  5134.  
  5135.     /*
  5136.      * Now that we know the target of the unconditional jumps to the end of
  5137.      * the "if" command, update them with the correct distance. If the
  5138.      * distance is too great (> 127 bytes), replace the jump with a four
  5139.      * byte instruction and move instructions after the jump down.
  5140.      */
  5141.     
  5142.     for (j = jumpEndFixupArray.next;  j > 0;  j--) {
  5143.     jumpIndex = (j - 1);    /* i.e. process the closest jump first */
  5144.     jumpDist = (TclCurrCodeOffset() - jumpEndFixupArray.fixup[jumpIndex].codeOffset);
  5145.     if (TclFixupForwardJump(envPtr,
  5146.             &(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) {
  5147.         /*
  5148.          * Adjust the jump distance for the "ifFalse" jump that
  5149.          * immediately preceeds this jump. We've moved it's target
  5150.          * (just after this unconditional jump) three bytes down.
  5151.          */
  5152.  
  5153.         ifFalsePc = (envPtr->codeStart + jumpFalseFixupArray.fixup[jumpIndex].codeOffset);
  5154.         opCode = *ifFalsePc;
  5155.         if (opCode == INST_JUMP_FALSE1) {
  5156.         jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
  5157.         jumpFalseDist += 3;
  5158.         TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
  5159.         } else if (opCode == INST_JUMP_FALSE4) {
  5160.         jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
  5161.         jumpFalseDist += 3;
  5162.         TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
  5163.         } else {
  5164.         panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump");
  5165.         }
  5166.     }
  5167.     }
  5168.     
  5169.     /*
  5170.      * Free the jumpFixupArray array if malloc'ed storage was used.
  5171.      */
  5172.  
  5173.     done:
  5174.     TclFreeJumpFixupArray(&jumpFalseFixupArray);
  5175.     TclFreeJumpFixupArray(&jumpEndFixupArray);
  5176.     envPtr->termOffset = (src - string);
  5177.     envPtr->maxStackDepth = maxDepth;
  5178.     envPtr->pushSimpleWords = savePushSimpleWords;
  5179.     return result;
  5180. }
  5181.  
  5182. /*
  5183.  *----------------------------------------------------------------------
  5184.  *
  5185.  * TclCompileIncrCmd --
  5186.  *
  5187.  *    Procedure called to compile the "incr" command.
  5188.  *
  5189.  * Results:
  5190.  *    The return value is a standard Tcl result, which is TCL_OK unless
  5191.  *    there was an error while parsing string. If an error occurs then
  5192.  *    the interpreter's result contains a standard error message.
  5193.  *
  5194.  *    envPtr->termOffset is filled in with the offset of the character in
  5195.  *    "string" just after the last one successfully processed.
  5196.  *
  5197.  *    envPtr->maxStackDepth is updated with the maximum number of stack
  5198.  *    elements needed to execute the "incr" command.
  5199.  *
  5200.  * Side effects:
  5201.  *    Instructions are added to envPtr to evaluate the "incr" command
  5202.  *    at runtime.
  5203.  *
  5204.  *----------------------------------------------------------------------
  5205.  */
  5206.  
  5207. int
  5208. TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
  5209.     Tcl_Interp *interp;        /* Used for error reporting. */
  5210.     char *string;        /* The source string to compile. */
  5211.     char *lastChar;        /* Pointer to terminating character of
  5212.                  * string. */
  5213.     int flags;            /* Flags to control compilation (same as
  5214.                  * passed to Tcl_Eval). */
  5215.     CompileEnv *envPtr;        /* Holds resulting instructions. */
  5216. {
  5217.     Proc *procPtr = envPtr->procPtr;
  5218.                     /* Points to structure describing procedure
  5219.                  * containing incr command, else NULL. */
  5220.     register char *src = string;
  5221.                     /* Points to current source char. */
  5222.     register int type;        /* Current char's CHAR_TYPE type. */
  5223.     int simpleVarName;        /* 1 if name is just sequence of chars with
  5224.                                  * an optional element name in parens. */
  5225.     char *name = NULL;        /* If simpleVarName, points to first char of
  5226.                  * variable name and nameChars is length.
  5227.                  * Otherwise NULL. */
  5228.     char *elName = NULL;    /* If simpleVarName, points to first char of
  5229.                  * element name and elNameChars is length.
  5230.                  * Otherwise NULL. */
  5231.     int nameChars = 0;        /* Length of the var name. Initialized to
  5232.                  * avoid a compiler warning. */
  5233.     int elNameChars = 0;    /* Length of array's element name, if any.
  5234.                  * Initialized to avoid a compiler
  5235.                  * warning. */
  5236.     int incrementGiven;        /* 1 if an increment amount was given. */
  5237.     int isImmIncrValue = 0;    /* 1 if increment amount is a literal
  5238.                  * integer in [-127..127]. */
  5239.     int immIncrValue = 0;    /* if isImmIncrValue is 1, the immediate
  5240.                  * integer value. */
  5241.     int maxDepth = 0;        /* Maximum number of stack elements needed
  5242.                  * to execute cmd. */
  5243.     int localIndex = -1;    /* Index of the variable in the current
  5244.                  * procedure's array of local variables.
  5245.                  * Otherwise -1 if not in a procedure or
  5246.                  * the variable wasn't found. */
  5247.     char savedChar;        /* Holds the character from string
  5248.                  * termporarily replaced by a null char
  5249.                  * during name processing. */
  5250.     int objIndex;        /* The object array index for a pushed
  5251.                  * object holding a name part. */
  5252.     int savePushSimpleWords = envPtr->pushSimpleWords;
  5253.     char *p;
  5254.     int i, result;
  5255.  
  5256.     /*
  5257.      * Parse the next word: the variable name. If it is "simple" (requires
  5258.      * no substitutions at runtime), divide it up into a simple "name" plus
  5259.      * an optional "elName". Otherwise, if not simple, just push the name.
  5260.      */
  5261.  
  5262.     AdvanceToNextWord(src, envPtr);
  5263.     src += envPtr->termOffset;
  5264.     type = CHAR_TYPE(src, lastChar);
  5265.     if (type == TCL_COMMAND_END) {
  5266.     badArgs:
  5267.     Tcl_ResetResult(interp);
  5268.     Tcl_AppendToObj(Tcl_GetObjResult(interp),
  5269.             "wrong # args: should be \"incr varName ?increment?\"", -1);
  5270.     result = TCL_ERROR;
  5271.     goto done;
  5272.     }
  5273.     
  5274.     envPtr->pushSimpleWords = 0;
  5275.     result = CompileWord(interp, src, lastChar, flags, envPtr);
  5276.     if (result != TCL_OK) {
  5277.     goto done;
  5278.     }
  5279.     simpleVarName = envPtr->wordIsSimple;
  5280.     if (simpleVarName) {
  5281.     name = src;
  5282.     nameChars = envPtr->numSimpleWordChars;
  5283.     if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
  5284.         name++;
  5285.     }
  5286.     elName = NULL;
  5287.     elNameChars = 0;
  5288.     p = name;
  5289.     for (i = 0;  i < nameChars;  i++) {
  5290.         if (*p == '(') {
  5291.         char *openParen = p;
  5292.         p = (src + nameChars-1);    
  5293.         if (*p == ')') { /* last char is ')' => array reference */
  5294.             nameChars = (openParen - name);
  5295.             elName = openParen+1;
  5296.             elNameChars = (p - elName);
  5297.         }
  5298.         break;
  5299.         }
  5300.         p++;
  5301.     }
  5302.     } else {
  5303.         maxDepth = envPtr->maxStackDepth;
  5304.     }
  5305.     src += envPtr->termOffset;
  5306.  
  5307.     /*
  5308.      * See if there is a next word. If so, we are incrementing the variable
  5309.      * by that value (which must be an integer).
  5310.      */
  5311.  
  5312.     incrementGiven = 0;
  5313.     type = CHAR_TYPE(src, lastChar);
  5314.     if (type != TCL_COMMAND_END) {
  5315.     AdvanceToNextWord(src, envPtr);
  5316.     src += envPtr->termOffset;
  5317.     type = CHAR_TYPE(src, lastChar);
  5318.     incrementGiven = (type != TCL_COMMAND_END);
  5319.     }
  5320.  
  5321.     /*
  5322.      * Non-simple names have already been pushed. If this is a simple
  5323.      * variable, either push its name (if a global or an unknown local
  5324.      * variable) or look up the variable's local frame index. If a local is
  5325.      * not found, push its name and do the lookup at runtime. If this is an
  5326.      * array reference, also push the array element.
  5327.      */
  5328.  
  5329.     if (simpleVarName) {
  5330.     if (procPtr == NULL) {
  5331.         savedChar = name[nameChars];
  5332.         name[nameChars] = '\0';
  5333.         objIndex = TclObjIndexForString(name, nameChars,
  5334.             /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
  5335.         name[nameChars] = savedChar;
  5336.         TclEmitPush(objIndex, envPtr);
  5337.         maxDepth = 1;
  5338.     } else {
  5339.         localIndex = LookupCompiledLocal(name, nameChars,
  5340.                 /*createIfNew*/ 0, /*flagsIfCreated*/ 0,
  5341.             envPtr->procPtr);
  5342.         if ((localIndex < 0) || (localIndex > 255)) {
  5343.         if (localIndex > 255) {          /* we'll push the name */
  5344.             localIndex = -1;
  5345.         }
  5346.         savedChar = name[nameChars];
  5347.         name[nameChars] = '\0';
  5348.         objIndex = TclObjIndexForString(name, nameChars,
  5349.             /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
  5350.         name[nameChars] = savedChar;
  5351.         TclEmitPush(objIndex, envPtr);
  5352.         maxDepth = 1;
  5353.         } else {
  5354.         maxDepth = 0;
  5355.         }
  5356.     }
  5357.     
  5358.     if (elName != NULL) {
  5359.         /*
  5360.          * Parse and push the array element's name. Perform
  5361.          * substitutions on it, just as is done for quoted strings.
  5362.          */
  5363.  
  5364.         savedChar = elName[elNameChars];
  5365.         elName[elNameChars] = '\0';
  5366.         envPtr->pushSimpleWords = 1;
  5367.         result = TclCompileQuotes(interp, elName, elName+elNameChars,
  5368.             0, flags, envPtr);
  5369.         elName[elNameChars] = savedChar;
  5370.         if (result != TCL_OK) {
  5371.         char msg[200];
  5372.         sprintf(msg, "\n    (parsing index for array \"%.*s\")",
  5373.             TclMin(nameChars, 100), name);
  5374.         Tcl_AddObjErrorInfo(interp, msg, -1);
  5375.         goto done;
  5376.         }
  5377.         maxDepth += envPtr->maxStackDepth;
  5378.     }
  5379.     }
  5380.  
  5381.     /*
  5382.      * If an increment was given, push the new value.
  5383.      */
  5384.     
  5385.     if (incrementGiven) {
  5386.     type = CHAR_TYPE(src, lastChar);
  5387.     envPtr->pushSimpleWords = 0;
  5388.     result = CompileWord(interp, src, lastChar, flags, envPtr);
  5389.     if (result != TCL_OK) {
  5390.         if (result == TCL_ERROR) {
  5391.         Tcl_AddObjErrorInfo(interp,
  5392.                 "\n    (increment expression)", -1);
  5393.         }
  5394.         goto done;
  5395.     }
  5396.     if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
  5397.         src++;
  5398.     }
  5399.     if (envPtr->wordIsSimple) {
  5400.         /*
  5401.          * See if the word represents an integer whose formatted
  5402.          * representation is the same as the word (e.g., this is
  5403.          * true for 123 and -1 but not for 00005). If so, just
  5404.          * push an integer object.
  5405.          */
  5406.         
  5407.         int isCompilableInt = 0;
  5408.         int numChars = envPtr->numSimpleWordChars;
  5409.         char savedChar = src[numChars];
  5410.         char buf[40];
  5411.         Tcl_Obj *objPtr;
  5412.         long n;
  5413.  
  5414.         src[numChars] = '\0';
  5415.         if (TclLooksLikeInt(src)) {
  5416.         int code = TclGetLong(interp, src, &n);
  5417.         if (code == TCL_OK) {
  5418.             if ((-127 <= n) && (n <= 127)) {
  5419.             isCompilableInt = 1;
  5420.             isImmIncrValue = 1;
  5421.             immIncrValue = n;
  5422.             } else {
  5423.             TclFormatInt(buf, n);
  5424.             if (strcmp(src, buf) == 0) {
  5425.                 isCompilableInt = 1;
  5426.                 isImmIncrValue = 0;
  5427.                 objIndex = TclObjIndexForString(src, numChars,
  5428.                                 /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr);
  5429.                 objPtr = envPtr->objArrayPtr[objIndex];
  5430.  
  5431.                 Tcl_InvalidateStringRep(objPtr);
  5432.                 objPtr->internalRep.longValue = n;
  5433.                 objPtr->typePtr = &tclIntType;
  5434.                 
  5435.                 TclEmitPush(objIndex, envPtr);
  5436.                 maxDepth += 1;
  5437.             }
  5438.             }
  5439.         } else {
  5440.             Tcl_ResetResult(interp);
  5441.         }
  5442.         }
  5443.         if (!isCompilableInt) {
  5444.         objIndex = TclObjIndexForString(src, numChars,
  5445.             /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
  5446.         TclEmitPush(objIndex, envPtr);
  5447.         maxDepth += 1;
  5448.         }
  5449.         src[numChars] = savedChar;
  5450.     } else {
  5451.         maxDepth += envPtr->maxStackDepth;
  5452.     }
  5453.     if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
  5454.         src += (envPtr->termOffset - 1); /* already advanced 1 above */
  5455.     } else {
  5456.         src += envPtr->termOffset;
  5457.     }
  5458.     } else {            /* no incr amount given so use 1 */
  5459.     isImmIncrValue = 1;
  5460.     immIncrValue = 1;
  5461.     }
  5462.     
  5463.     /*
  5464.      * Now emit instructions to increment the variable.
  5465.      */
  5466.  
  5467.     if (simpleVarName) {
  5468.     if (elName == NULL) {  /* scalar */
  5469.         if (localIndex >= 0) {
  5470.         if (isImmIncrValue) {
  5471.             TclEmitInstUInt1(INST_INCR_SCALAR1_IMM, localIndex,
  5472.                     envPtr);
  5473.             TclEmitInt1(immIncrValue, envPtr);
  5474.         } else {
  5475.             TclEmitInstUInt1(INST_INCR_SCALAR1, localIndex, envPtr);
  5476.         }
  5477.         } else {
  5478.         if (isImmIncrValue) {
  5479.             TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immIncrValue,
  5480.                    envPtr);
  5481.         } else {
  5482.             TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr);
  5483.         }
  5484.         }
  5485.     } else {        /* array */
  5486.         if (localIndex >= 0) {
  5487.         if (isImmIncrValue) {
  5488.             TclEmitInstUInt1(INST_INCR_ARRAY1_IMM, localIndex,
  5489.                     envPtr);
  5490.             TclEmitInt1(immIncrValue, envPtr);
  5491.         } else {
  5492.             TclEmitInstUInt1(INST_INCR_ARRAY1, localIndex, envPtr);
  5493.         }
  5494.         } else {
  5495.         if (isImmIncrValue) {
  5496.             TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immIncrValue,
  5497.                    envPtr);
  5498.         } else {
  5499.             TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr);
  5500.         }
  5501.         }
  5502.     }
  5503.     } else {            /* non-simple variable name */
  5504.     if (isImmIncrValue) {
  5505.         TclEmitInstInt1(INST_INCR_STK_IMM, immIncrValue, envPtr);
  5506.     } else {
  5507.         TclEmitOpcode(INST_INCR_STK, envPtr);
  5508.     }
  5509.     }
  5510.     
  5511.     /*
  5512.      * Skip over white space until the end of the command.
  5513.      */
  5514.  
  5515.     type = CHAR_TYPE(src, lastChar);
  5516.     if (type != TCL_COMMAND_END) {
  5517.     AdvanceToNextWord(src, envPtr);
  5518.     src += envPtr->termOffset;
  5519.     type = CHAR_TYPE(src, lastChar);
  5520.     if (type != TCL_COMMAND_END) {
  5521.         goto badArgs;
  5522.     }
  5523.     }
  5524.  
  5525.     done:
  5526.     envPtr->termOffset = (src - string);
  5527.     envPtr->maxStackDepth = maxDepth;
  5528.     envPtr->pushSimpleWords = savePushSimpleWords;
  5529.     return result;
  5530. }
  5531.  
  5532. /*
  5533.  *----------------------------------------------------------------------
  5534.  *
  5535.  * TclCompileSetCmd --
  5536.  *
  5537.  *    Procedure called to compile the "set" command.
  5538.  *
  5539.  * Results:
  5540.  *    The return value is a standard Tcl result, which is normally TCL_OK
  5541.  *    unless there was an error while parsing string. If an error occurs
  5542.  *    then the interpreter's result contains a standard error message. If
  5543.  *    complation fails because the set command requires a second level of
  5544.  *    substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
  5545.  *    set command should be compiled "out of line" by emitting code to
  5546.  *    invoke its command procedure (Tcl_SetCmd) at runtime.
  5547.  *
  5548.  *    envPtr->termOffset is filled in with the offset of the character in
  5549.  *    "string" just after the last one successfully processed.
  5550.  *
  5551.  *    envPtr->maxStackDepth is updated with the maximum number of stack
  5552.  *    elements needed to execute the incr command.
  5553.  *
  5554.  * Side effects:
  5555.  *    Instructions are added to envPtr to evaluate the "set" command
  5556.  *    at runtime.
  5557.  *
  5558.  *----------------------------------------------------------------------
  5559.  */
  5560.  
  5561. int
  5562. TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
  5563.     Tcl_Interp *interp;        /* Used for error reporting. */
  5564.     char *string;        /* The source string to compile. */
  5565.     char *lastChar;        /* Pointer to terminating character of
  5566.                  * string. */
  5567.     int flags;            /* Flags to control compilation (same as
  5568.                  * passed to Tcl_Eval). */
  5569.     CompileEnv *envPtr;        /* Holds resulting instructions. */
  5570. {
  5571.     Proc *procPtr = envPtr->procPtr;
  5572.                 /* Points to structure describing procedure
  5573.                  * containing the set command, else NULL. */
  5574.     ArgInfo argInfo;        /* Structure holding information about the
  5575.                  * start and end of each argument word. */
  5576.     int simpleVarName;        /* 1 if name is just sequence of chars with
  5577.                                  * an optional element name in parens. */
  5578.     char *elName = NULL;    /* If simpleVarName, points to first char of
  5579.                  * element name and elNameChars is length.
  5580.                  * Otherwise NULL. */
  5581.     int isAssignment;        /* 1 if assigning value to var, else 0. */
  5582.     int maxDepth = 0;        /* Maximum number of stack elements needed
  5583.                  * to execute cmd. */
  5584.     int localIndex = -1;    /* Index of the variable in the current
  5585.                  * procedure's array of local variables.
  5586.                  * Otherwise -1 if not in a procedure, the
  5587.                  * name contains "::"s, or the variable
  5588.                  * wasn't found. */
  5589.     char savedChar;        /* Holds the character from string
  5590.                  * termporarily replaced by a null char
  5591.                  * during name processing. */
  5592.     int objIndex = -1;        /* The object array index for a pushed
  5593.                  * object holding a name part. Initialized
  5594.                  * to avoid a compiler warning. */
  5595.     char *wordStart, *p;
  5596.     int numWords, isCompilableInt, i, result;
  5597.     Tcl_Obj *objPtr;
  5598.     int savePushSimpleWords = envPtr->pushSimpleWords;
  5599.  
  5600.     /*
  5601.      * Scan the words of the command and record the start and finish of
  5602.      * each argument word.
  5603.      */
  5604.  
  5605.     InitArgInfo(&argInfo);
  5606.     result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
  5607.     numWords = argInfo.numArgs;      /* i.e., the # after the command name */
  5608.     if (result != TCL_OK) {
  5609.     goto done;
  5610.     }
  5611.     if ((numWords < 1) || (numWords > 2)) {
  5612.     Tcl_ResetResult(interp);
  5613.     Tcl_AppendToObj(Tcl_GetObjResult(interp),
  5614.             "wrong # args: should be \"set varName ?newValue?\"", -1);
  5615.         result = TCL_ERROR;
  5616.     goto done;
  5617.     }
  5618.     isAssignment = (numWords == 2);
  5619.  
  5620.     /*
  5621.      * Parse the next word: the variable name. If the name is enclosed in
  5622.      * quotes or braces, we return TCL_OUT_LINE_COMPILE and call the set
  5623.      * command procedure at runtime since this makes sure that a second
  5624.      * round of substitutions is done properly. 
  5625.      */
  5626.  
  5627.     wordStart = argInfo.startArray[0]; /* start of 1st arg word: varname */
  5628.     if ((*wordStart == '{') || (*wordStart == '"')) {
  5629.     result = TCL_OUT_LINE_COMPILE;
  5630.     goto done;
  5631.     }
  5632.  
  5633.     /*
  5634.      * Check whether the name is "simple": requires no substitutions at
  5635.      * runtime.
  5636.      */
  5637.     
  5638.     envPtr->pushSimpleWords = 0;
  5639.     result = CompileWord(interp, wordStart, argInfo.endArray[0] + 1,
  5640.         flags, envPtr);
  5641.     if (result != TCL_OK) {
  5642.     goto done;
  5643.     }
  5644.     simpleVarName = envPtr->wordIsSimple;
  5645.     
  5646.     if (!simpleVarName) {
  5647.     /*
  5648.      * The name isn't simple. CompileWord already pushed it.
  5649.      */
  5650.     
  5651.     maxDepth = envPtr->maxStackDepth;
  5652.     } else {
  5653.     char *name;        /* If simpleVarName, points to first char of
  5654.                  * variable name and nameChars is length.
  5655.                  * Otherwise NULL. */
  5656.     int nameChars;        /* Length of the var name. */
  5657.     int nameHasNsSeparators = 0;
  5658.                 /* Set 1 if name contains "::"s. */
  5659.     int elNameChars;    /* Length of array's element name if any. */
  5660.  
  5661.     /*
  5662.      * A simple name. First divide it up into "name" plus "elName"
  5663.      * for an array element name, if any.
  5664.      */
  5665.     
  5666.     name = wordStart;
  5667.     nameChars = envPtr->numSimpleWordChars;
  5668.     elName = NULL;
  5669.     elNameChars = 0;
  5670.     
  5671.     p = name;
  5672.     for (i = 0;  i < nameChars;  i++) {
  5673.         if (*p == '(') {
  5674.         char *openParen = p;
  5675.         p = (name + nameChars-1);    
  5676.         if (*p == ')') { /* last char is ')' => array reference */
  5677.             nameChars = (openParen - name);
  5678.             elName = openParen+1;
  5679.             elNameChars = (p - elName);
  5680.         }
  5681.         break;
  5682.         }
  5683.         p++;
  5684.     }
  5685.  
  5686.     /*
  5687.      * Determine if name has any namespace separators (::'s).
  5688.      */
  5689.  
  5690.     p = name;
  5691.     for (i = 0;  i < nameChars;  i++) {
  5692.         if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
  5693.         nameHasNsSeparators = 1;
  5694.         break;
  5695.         }
  5696.         p++;
  5697.     }
  5698.  
  5699.     /*
  5700.      * Now either push the name or determine its index in the array of
  5701.      * local variables in a procedure frame. Note that if we are
  5702.      * compiling a procedure the variable must be local unless its
  5703.      * name has namespace separators ("::"s). Note also that global
  5704.      * variables are implemented by a local variable that "points" to
  5705.      * the real global. There are two cases:
  5706.      *   1) We are not compiling a procedure body. Push the global
  5707.      *      variable's name and do the lookup at runtime.
  5708.      *   2) We are compiling a procedure and the name has "::"s.
  5709.      *    Push the namespace variable's name and do the lookup at
  5710.      *    runtime.
  5711.      *   3) We are compiling a procedure and the name has no "::"s.
  5712.      *    If the variable has already been allocated an local index,
  5713.      *    just look it up. If the variable is unknown and we are
  5714.      *    doing an assignment, allocate a new index. Otherwise,
  5715.      *    push the name and try to do the lookup at runtime.
  5716.      */
  5717.  
  5718.     if ((procPtr == NULL) || nameHasNsSeparators) {
  5719.         savedChar = name[nameChars];
  5720.         name[nameChars] = '\0';
  5721.         objIndex = TclObjIndexForString(name, nameChars,
  5722.             /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
  5723.         name[nameChars] = savedChar;
  5724.         TclEmitPush(objIndex, envPtr);
  5725.         maxDepth = 1;
  5726.     } else {
  5727.         localIndex = LookupCompiledLocal(name, nameChars,
  5728.                 /*createIfNew*/ isAssignment,
  5729.                     /*flagsIfCreated*/
  5730.             ((elName == NULL)? VAR_SCALAR : VAR_ARRAY),
  5731.             envPtr->procPtr);
  5732.         if (localIndex >= 0) {
  5733.         maxDepth = 0;
  5734.         } else {
  5735.         savedChar = name[nameChars];
  5736.         name[nameChars] = '\0';
  5737.         objIndex = TclObjIndexForString(name, nameChars,
  5738.             /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
  5739.         name[nameChars] = savedChar;
  5740.         TclEmitPush(objIndex, envPtr);
  5741.         maxDepth = 1;
  5742.         }
  5743.     }
  5744.  
  5745.     /*
  5746.      * If we are dealing with a reference to an array element, push the
  5747.      * array element. Perform substitutions on it, just as is done
  5748.      * for quoted strings.
  5749.      */
  5750.     
  5751.     if (elName != NULL) {
  5752.         savedChar = elName[elNameChars];
  5753.         elName[elNameChars] = '\0';
  5754.         envPtr->pushSimpleWords = 1;
  5755.         result = TclCompileQuotes(interp, elName, elName+elNameChars,
  5756.             0, flags, envPtr);
  5757.         elName[elNameChars] = savedChar;
  5758.         if (result != TCL_OK) {
  5759.         char msg[200];
  5760.         sprintf(msg, "\n    (parsing index for array \"%.*s\")",
  5761.             TclMin(nameChars, 100), name);
  5762.         Tcl_AddObjErrorInfo(interp, msg, -1);
  5763.         goto done;
  5764.         }
  5765.         maxDepth += envPtr->maxStackDepth;
  5766.     }
  5767.     }
  5768.  
  5769.     /*
  5770.      * If we are doing an assignment, push the new value.
  5771.      */
  5772.     
  5773.     if (isAssignment) {
  5774.     wordStart = argInfo.startArray[1]; /* start of 2nd arg word */
  5775.     envPtr->pushSimpleWords = 0;       /* we will handle simple words */
  5776.     result = CompileWord(interp, wordStart,    argInfo.endArray[1] + 1,
  5777.         flags, envPtr);
  5778.     if (result != TCL_OK) {
  5779.         goto done;
  5780.     }
  5781.     if (!envPtr->wordIsSimple) {
  5782.         /*
  5783.          * The value isn't simple. CompileWord already pushed it.
  5784.          */
  5785.  
  5786.         maxDepth += envPtr->maxStackDepth;
  5787.     } else {
  5788.         /*
  5789.          * The value is simple. See if the word represents an integer
  5790.          * whose formatted representation is the same as the word (e.g.,
  5791.          * this is true for 123 and -1 but not for 00005). If so, just
  5792.          * push an integer object.
  5793.          */
  5794.         
  5795.         char buf[40];
  5796.         long n;
  5797.  
  5798.         p = wordStart;
  5799.         if ((*wordStart == '"') || (*wordStart == '{')) {
  5800.         p++;
  5801.         }
  5802.         savedChar = p[envPtr->numSimpleWordChars];
  5803.         p[envPtr->numSimpleWordChars] = '\0';
  5804.         isCompilableInt = 0;
  5805.         if (TclLooksLikeInt(p)) {
  5806.         int code = TclGetLong(interp, p, &n);
  5807.         if (code == TCL_OK) {
  5808.             TclFormatInt(buf, n);
  5809.             if (strcmp(p, buf) == 0) {
  5810.             isCompilableInt = 1;
  5811.             objIndex = TclObjIndexForString(p,
  5812.                 envPtr->numSimpleWordChars,
  5813.                                 /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr);
  5814.             objPtr = envPtr->objArrayPtr[objIndex];
  5815.  
  5816.             Tcl_InvalidateStringRep(objPtr);
  5817.             objPtr->internalRep.longValue = n;
  5818.             objPtr->typePtr = &tclIntType;
  5819.             }
  5820.         } else {
  5821.             Tcl_ResetResult(interp);
  5822.         }
  5823.         }
  5824.         if (!isCompilableInt) {
  5825.         objIndex = TclObjIndexForString(p,
  5826.             envPtr->numSimpleWordChars, /*allocStrRep*/ 1,
  5827.             /*inHeap*/ 0, envPtr);
  5828.         }
  5829.         p[envPtr->numSimpleWordChars] = savedChar;
  5830.         TclEmitPush(objIndex, envPtr);
  5831.         maxDepth += 1;
  5832.     }
  5833.     }
  5834.     
  5835.     /*
  5836.      * Now emit instructions to set/retrieve the variable.
  5837.      */
  5838.  
  5839.     if (simpleVarName) {
  5840.     if (elName == NULL) {  /* scalar */
  5841.         if (localIndex >= 0) {
  5842.         if (localIndex <= 255) {
  5843.             TclEmitInstUInt1((isAssignment?
  5844.                  INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
  5845.             localIndex, envPtr);
  5846.         } else {
  5847.             TclEmitInstUInt4((isAssignment?
  5848.                  INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),
  5849.             localIndex, envPtr);
  5850.         }
  5851.         } else {
  5852.         TclEmitOpcode((isAssignment?
  5853.                  INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK),
  5854.                 envPtr);
  5855.         }
  5856.     } else {        /* array */
  5857.         if (localIndex >= 0) {
  5858.         if (localIndex <= 255) {
  5859.             TclEmitInstUInt1((isAssignment?
  5860.                  INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),
  5861.             localIndex, envPtr);
  5862.         } else {
  5863.             TclEmitInstUInt4((isAssignment?
  5864.                  INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),
  5865.             localIndex, envPtr);
  5866.         }
  5867.         } else {
  5868.         TclEmitOpcode((isAssignment?
  5869.                  INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK),
  5870.                 envPtr);
  5871.         }
  5872.     }
  5873.     } else {            /* non-simple variable name */
  5874.     TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
  5875.     }
  5876.     
  5877.     done:
  5878.     if (numWords == 0) {
  5879.     envPtr->termOffset = 0;
  5880.     } else {
  5881.     envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
  5882.     }
  5883.     envPtr->pushSimpleWords = savePushSimpleWords;
  5884.     envPtr->maxStackDepth = maxDepth;
  5885.     FreeArgInfo(&argInfo);
  5886.     return result;
  5887. }
  5888.  
  5889. /*
  5890.  *----------------------------------------------------------------------
  5891.  *
  5892.  * TclCompileWhileCmd --
  5893.  *
  5894.  *    Procedure called to compile the "while" command.
  5895.  *
  5896.  * Results:
  5897.  *    The return value is a standard Tcl result, which is TCL_OK if
  5898.  *    compilation was successful. If an error occurs then the
  5899.  *    interpreter's result contains a standard error message and TCL_ERROR
  5900.  *    is returned. If compilation failed because the command is too
  5901.  *    complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned
  5902.  *    indicating that the while command should be compiled "out of line"
  5903.  *    by emitting code to invoke its command procedure at runtime.
  5904.  *
  5905.  *    envPtr->termOffset is filled in with the offset of the character in
  5906.  *    "string" just after the last one successfully processed.
  5907.  *
  5908.  *    envPtr->maxStackDepth is updated with the maximum number of stack
  5909.  *    elements needed to execute the "while" command.
  5910.  *
  5911.  * Side effects:
  5912.  *    Instructions are added to envPtr to evaluate the "while" command
  5913.  *    at runtime.
  5914.  *
  5915.  *----------------------------------------------------------------------
  5916.  */
  5917.  
  5918. int
  5919. TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
  5920.     Tcl_Interp *interp;        /* Used for error reporting. */
  5921.     char *string;        /* The source string to compile. */
  5922.     char *lastChar;         /* Pointer to terminating character of
  5923.                   * string. */
  5924.     int flags;            /* Flags to control compilation (same as
  5925.                  * passed to Tcl_Eval). */
  5926.     CompileEnv *envPtr;        /* Holds resulting instructions. */
  5927. {
  5928.     register char *src = string;/* Points to current source char. */
  5929.     register int type;        /* Current char's CHAR_TYPE type. */
  5930.     int maxDepth = 0;        /* Maximum number of stack elements needed
  5931.                  * to execute cmd. */
  5932.     int range;            /* Index in the ExceptionRange array of the
  5933.                  * ExceptionRange record for this loop. */
  5934.     JumpFixup jumpFalseFixup;    /* Used to update or replace the ifFalse
  5935.                  * jump after test when its target PC is
  5936.                  * determined. */
  5937.     unsigned char *jumpPc;
  5938.     int jumpDist, jumpBackDist, jumpBackOffset, objIndex, result;
  5939.     int savePushSimpleWords = envPtr->pushSimpleWords;
  5940.  
  5941.     envPtr->excRangeDepth++;
  5942.     envPtr->maxExcRangeDepth =
  5943.     TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
  5944.  
  5945.     /*
  5946.      * Create and initialize a ExceptionRange record to hold information
  5947.      * about this loop. This is used to implement break and continue.
  5948.      */
  5949.  
  5950.     range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
  5951.     envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset();
  5952.  
  5953.     AdvanceToNextWord(src, envPtr);
  5954.     src += envPtr->termOffset;
  5955.     type = CHAR_TYPE(src, lastChar);
  5956.     if (type == TCL_COMMAND_END) {
  5957.     badArgs:
  5958.     Tcl_ResetResult(interp);
  5959.     Tcl_AppendToObj(Tcl_GetObjResult(interp),
  5960.             "wrong # args: should be \"while test command\"", -1);
  5961.     result = TCL_ERROR;
  5962.     goto done;
  5963.     }
  5964.  
  5965.     /*
  5966.      * If the test expression is enclosed in quotes (""s), don't compile
  5967.      * the while inline. As a result of Tcl's two level substitution
  5968.      * semantics for expressions, the expression might have a constant
  5969.      * value that results in the loop never executing, or executing forever.
  5970.      * Consider "set x 0; while "$x < 5" {incr x}": the loop body should
  5971.      * never be executed.
  5972.      */
  5973.  
  5974.     if (*src == '"') {
  5975.     result = TCL_OUT_LINE_COMPILE;
  5976.         goto done;
  5977.     }
  5978.  
  5979.     /*
  5980.      * Compile the next word: the test expression.
  5981.      */
  5982.  
  5983.     envPtr->pushSimpleWords = 1;
  5984.     result = CompileExprWord(interp, src, lastChar, flags, envPtr);
  5985.     if (result != TCL_OK) {
  5986.     if (result == TCL_ERROR) {
  5987.             Tcl_AddObjErrorInfo(interp, "\n    (\"while\" test expression)", -1);
  5988.         }
  5989.     goto done;
  5990.     }
  5991.     maxDepth = envPtr->maxStackDepth;
  5992.     src += envPtr->termOffset;
  5993.  
  5994.     /*
  5995.      * Emit the ifFalse jump that terminates the while if the test was
  5996.      * false. We emit a one byte (relative) jump here, and replace it
  5997.      * later with a four byte jump if the jump target is more than
  5998.      * 127 bytes away.
  5999.      */
  6000.  
  6001.     TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
  6002.     
  6003.     /*
  6004.      * Compile the loop body word inline. Also register the loop body's
  6005.      * starting PC offset and byte length in the its ExceptionRange record.
  6006.      */
  6007.  
  6008.     AdvanceToNextWord(src, envPtr);
  6009.     src += envPtr->termOffset;
  6010.     type = CHAR_TYPE(src, lastChar);
  6011.     if (type == TCL_COMMAND_END) {
  6012.     goto badArgs;
  6013.     }
  6014.  
  6015.     envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
  6016.     result = CompileCmdWordInline(interp, src, lastChar,
  6017.         flags, envPtr);
  6018.     if (result != TCL_OK) {
  6019.     if (result == TCL_ERROR) {
  6020.         char msg[60];
  6021.         sprintf(msg, "\n    (\"while\" body line %d)", interp->errorLine);
  6022.             Tcl_AddObjErrorInfo(interp, msg, -1);
  6023.         }
  6024.     goto done;
  6025.     }
  6026.     maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
  6027.     src += envPtr->termOffset;
  6028.     envPtr->excRangeArrayPtr[range].numCodeBytes =
  6029.     (TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset);
  6030.  
  6031.     /*
  6032.      * Discard the loop body's result.
  6033.      */
  6034.  
  6035.     TclEmitOpcode(INST_POP, envPtr);
  6036.     
  6037.     /*
  6038.      * Emit the unconditional jump back to the test at the top of the
  6039.      * loop. We generate a four byte jump if the distance to the while's
  6040.      * test is greater than 120 bytes. This is conservative, and ensures
  6041.      * that we won't have to replace this unconditional jump if we later
  6042.      * need to replace the ifFalse jump with a four-byte jump.
  6043.      */
  6044.  
  6045.     jumpBackOffset = TclCurrCodeOffset();
  6046.     jumpBackDist =
  6047.     (jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset);
  6048.     if (jumpBackDist > 120) {
  6049.     TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
  6050.     } else {
  6051.     TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr);
  6052.     }
  6053.  
  6054.     /*
  6055.      * Now that we know the target of the jumpFalse after the test, update
  6056.      * it with the correct distance. If the distance is too great (more
  6057.      * than 127 bytes), replace that jump with a four byte instruction and
  6058.      * move the instructions after the jump down. 
  6059.      */
  6060.  
  6061.     jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset);
  6062.     if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
  6063.     /*
  6064.      * Update the loop body's starting PC offset since it moved down.
  6065.      */
  6066.  
  6067.     envPtr->excRangeArrayPtr[range].codeOffset += 3;
  6068.  
  6069.     /*
  6070.      * Update the distance for the unconditional jump back to the test
  6071.      * at the top of the loop since it moved down 3 bytes too.
  6072.      */
  6073.  
  6074.     jumpBackOffset += 3;
  6075.     jumpPc = (envPtr->codeStart + jumpBackOffset);
  6076.     if (jumpBackDist > 120) {
  6077.         jumpBackDist += 3;
  6078.         TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist,
  6079.                    jumpPc);
  6080.     } else {
  6081.         jumpBackDist += 3;
  6082.         TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist,
  6083.                    jumpPc);
  6084.     }
  6085.     }
  6086.  
  6087.     /*
  6088.      * The current PC offset (after the loop's body) is the loop's
  6089.      * break target.
  6090.      */
  6091.  
  6092.     envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset();
  6093.     
  6094.     /*
  6095.      * Push an empty string object as the while command's result.
  6096.      */
  6097.  
  6098.     objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0,
  6099.                     envPtr);
  6100.     TclEmitPush(objIndex, envPtr);
  6101.     if (maxDepth == 0) {
  6102.     maxDepth = 1;
  6103.     }
  6104.  
  6105.     /*
  6106.      * Skip over white space until the end of the command.
  6107.      */
  6108.  
  6109.     type = CHAR_TYPE(src, lastChar);
  6110.     if (type != TCL_COMMAND_END) {
  6111.     AdvanceToNextWord(src, envPtr);
  6112.     src += envPtr->termOffset;
  6113.     type = CHAR_TYPE(src, lastChar);
  6114.     if (type != TCL_COMMAND_END) {
  6115.         goto badArgs;
  6116.     }
  6117.     }
  6118.  
  6119.     done:
  6120.     envPtr->termOffset = (src - string);
  6121.     envPtr->pushSimpleWords = savePushSimpleWords;
  6122.     envPtr->maxStackDepth = maxDepth;
  6123.     envPtr->excRangeDepth--;
  6124.     return result;
  6125. }
  6126.  
  6127. /*
  6128.  *----------------------------------------------------------------------
  6129.  *
  6130.  * CompileExprWord --
  6131.  *
  6132.  *    Procedure that compiles a Tcl expression in a command word.
  6133.  *
  6134.  * Results:
  6135.  *    The return value is a standard Tcl result, which is TCL_OK unless
  6136.  *    there was an error while compiling string. If an error occurs then
  6137.  *    the interpreter's result contains a standard error message.
  6138.  *
  6139.  *    envPtr->termOffset is filled in with the offset of the character in
  6140.  *    "string" just after the last one successfully processed.
  6141.  *
  6142.  *    envPtr->maxStackDepth is updated with the maximum number of stack
  6143.  *    elements needed to execute the "expr" word.
  6144.  *
  6145.  * Side effects:
  6146.  *    Instructions are added to envPtr to evaluate the expression word
  6147.  *    at runtime.
  6148.  *
  6149.  *----------------------------------------------------------------------
  6150.  */
  6151.  
  6152. static int
  6153. CompileExprWord(interp, string, lastChar, flags, envPtr)
  6154.     Tcl_Interp *interp;        /* Used for error reporting. */
  6155.     char *string;        /* The source string to compile. */
  6156.     char *lastChar;         /* Pointer to terminating character of
  6157.                   * string. */
  6158.     int flags;            /* Flags to control compilation (same as
  6159.                  * passed to Tcl_Eval). */
  6160.     CompileEnv *envPtr;        /* Holds resulting instructions. */
  6161. {
  6162.     register char *src = string;/* Points to current source char. */
  6163.     register int type;          /* Current char's CHAR_TYPE type. */
  6164.     int maxDepth = 0;        /* Maximum number of stack elements needed
  6165.                  * to execute the expression. */
  6166.     int nestedCmd = (flags & TCL_BRACKET_TERM);
  6167.                 /* 1 if script being compiled is a nested
  6168.                  * command and is terminated by a ']';
  6169.                  * otherwise 0. */
  6170.     char *first, *last;        /* Points to the first and last significant
  6171.                  * characters of the word. */
  6172.     char savedChar;        /* Holds the character termporarily replaced
  6173.                  * by a null character during compilation
  6174.                  * of the expression. */
  6175.     int inlineCode;        /* 1 if inline "optimistic" code is
  6176.                  * emitted for the expression; else 0. */
  6177.     int range = -1;        /* If we inline compile an un-{}'d
  6178.                  * expression, the index for its catch range
  6179.                  * record in the ExceptionRange array.
  6180.                  * Initialized to avoid compile warning. */
  6181.     JumpFixup jumpFixup;    /* Used to emit the "success" jump after
  6182.                  * the inline expression code. */
  6183.     char *p;
  6184.     char c;
  6185.     int savePushSimpleWords = envPtr->pushSimpleWords;
  6186.     int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;
  6187.     int saveExprIsComparison = envPtr->exprIsComparison;
  6188.     int numChars, result;
  6189.  
  6190.     /*
  6191.      * Skip over leading white space.
  6192.      */
  6193.  
  6194.     AdvanceToNextWord(src, envPtr);
  6195.     src += envPtr->termOffset;
  6196.     type = CHAR_TYPE(src, lastChar);
  6197.     if (type == TCL_COMMAND_END) {
  6198.     badArgs:
  6199.     Tcl_ResetResult(interp);
  6200.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  6201.             "malformed expression word", -1);
  6202.     result = TCL_ERROR;
  6203.     goto done;
  6204.     }
  6205.  
  6206.     /*
  6207.      * If the word is enclosed in {}s, we may strip them off and safely
  6208.      * compile the expression into an inline sequence of instructions using
  6209.      * TclCompileExpr. We know these instructions will have the right Tcl7.x
  6210.      * expression semantics.
  6211.      *
  6212.      * Otherwise, if the word is not enclosed in {}s, we may need to call
  6213.      * the expr command (Tcl_ExprObjCmd) at runtime. This recompiles the
  6214.      * expression each time (typically) and so is slow. However, there are
  6215.      * some circumstances where we can still compile inline instructions
  6216.      * "optimistically" and check, during their execution, for double
  6217.      * substitutions (these appear as nonnumeric operands). We check for any
  6218.      * backslash or command substitutions. If none appear, and only variable
  6219.      * substitutions are found, we generate inline instructions.
  6220.      *
  6221.      * For now, if the expression is not enclosed in {}s, we call the expr
  6222.      * command at runtime if either command or backslash substitutions
  6223.      * appear (but not if only variable substitutions appear).
  6224.      */
  6225.  
  6226.     if (*src == '{') {
  6227.     /*
  6228.      * Inline compile the expression inside {}s.
  6229.      */
  6230.     
  6231.     first = src+1;
  6232.     src = TclWordEnd(src, lastChar, nestedCmd, NULL);
  6233.     if (*src == 0) {
  6234.         goto badArgs;
  6235.     }
  6236.     if (*src != '}') {
  6237.         goto badArgs;
  6238.     }
  6239.     last = (src-1);
  6240.  
  6241.     numChars = (last - first + 1);
  6242.     savedChar = first[numChars];
  6243.     first[numChars] = '\0';
  6244.     result = TclCompileExpr(interp, first, first+numChars,
  6245.         flags, envPtr);
  6246.     first[numChars] = savedChar;
  6247.  
  6248.     src++;
  6249.     maxDepth = envPtr->maxStackDepth;
  6250.     } else {
  6251.     /*
  6252.      * No braces. If the expression is enclosed in '"'s, call the expr
  6253.      * cmd at runtime. Otherwise, scan the word's characters looking for
  6254.      * any '['s or (for now) '\'s. If any are found, just call expr cmd
  6255.      * at runtime.
  6256.      */
  6257.  
  6258.     first = src;
  6259.     last = TclWordEnd(first, lastChar, nestedCmd, NULL);
  6260.     if (*last == 0) {    /* word doesn't end properly. */
  6261.         src = last;
  6262.         goto badArgs;
  6263.     }
  6264.  
  6265.     inlineCode = 1;
  6266.     if ((*first == '"') && (*last == '"')) {
  6267.         inlineCode = 0;
  6268.     } else {
  6269.         for (p = first;  p <= last;  p++) {
  6270.         c = *p;
  6271.         if ((c == '[') || (c == '\\')) {
  6272.             inlineCode = 0;
  6273.             break;
  6274.         }
  6275.         }
  6276.     }
  6277.     
  6278.     if (inlineCode) {
  6279.         /*
  6280.          * Inline compile the expression inside a "catch" so that a
  6281.          * runtime error will back off to make a (slow) call on expr.
  6282.          */
  6283.  
  6284.         int startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
  6285.         int startRangeNext = envPtr->excRangeArrayNext;
  6286.  
  6287.         /*
  6288.          * Create a ExceptionRange record to hold information about
  6289.          * the "catch" range for the expression's inline code. Also
  6290.          * emit the instruction to mark the start of the range.
  6291.          */
  6292.  
  6293.         envPtr->excRangeDepth++;
  6294.         envPtr->maxExcRangeDepth =
  6295.         TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
  6296.         range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr);
  6297.         TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr);
  6298.  
  6299.         /*
  6300.          * Inline compile the expression.
  6301.          */
  6302.  
  6303.         envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
  6304.         numChars = (last - first + 1);
  6305.         savedChar = first[numChars];
  6306.         first[numChars] = '\0';
  6307.         result = TclCompileExpr(interp, first, first + numChars,
  6308.             flags, envPtr);
  6309.         first[numChars] = savedChar;
  6310.         
  6311.         envPtr->excRangeArrayPtr[range].numCodeBytes =
  6312.         TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
  6313.  
  6314.         if ((result != TCL_OK) || (envPtr->exprIsJustVarRef)
  6315.                 || (envPtr->exprIsComparison)) {
  6316.         /*
  6317.          * We must call the expr command at runtime. Either there
  6318.          * was a compilation error or the inline code might fail to
  6319.          * give the correct 2 level substitution semantics.
  6320.          *
  6321.          * The latter can happen if the expression consisted of just
  6322.          * a single variable reference or if the top-level operator
  6323.          * in the expr is a comparison (which might operate on
  6324.          * strings). In the latter case, the expression's code might
  6325.          * execute (apparently) successfully but produce the wrong
  6326.          * result. We depend on its execution failing if a second
  6327.          * level of substitutions is required. This causes the
  6328.          * "catch" code we generate around the inline code to back
  6329.          * off to a call on the expr command at runtime, and this
  6330.          * always gives the right 2 level substitution semantics.
  6331.          *
  6332.          * We delete the inline code by backing up the code pc and
  6333.          * catch index. Note that if there was a compilation error,
  6334.          * we can't report the error yet since the expression might
  6335.          * be valid after the second round of substitutions.
  6336.          */
  6337.         
  6338.         envPtr->codeNext = (envPtr->codeStart + startCodeOffset);
  6339.         envPtr->excRangeArrayNext = startRangeNext;
  6340.         inlineCode = 0;
  6341.         } else {
  6342.         TclEmitOpcode(INST_END_CATCH, envPtr);
  6343.         TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
  6344.         envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset();
  6345.         }
  6346.     }
  6347.         
  6348.     /*
  6349.      * Arrange to call expr at runtime with the (already substituted
  6350.      * once) expression word on the stack.
  6351.      */
  6352.  
  6353.     envPtr->pushSimpleWords = 1;
  6354.     result = CompileWord(interp, first, lastChar, flags, envPtr);
  6355.     src += envPtr->termOffset;
  6356.     maxDepth = envPtr->maxStackDepth;
  6357.     if (result == TCL_OK) {
  6358.         TclEmitOpcode(INST_EXPR_STK, envPtr);
  6359.     }
  6360.  
  6361.     /*
  6362.      * If emitting inline code for this non-{}'d expression, update
  6363.      * the target of the jump after that inline code.
  6364.      */
  6365.  
  6366.     if (inlineCode) {
  6367.         int jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
  6368.         if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
  6369.         /*
  6370.          * Update the inline expression code's catch ExceptionRange
  6371.          * target since it, being after the jump, also moved down.
  6372.          */
  6373.  
  6374.         envPtr->excRangeArrayPtr[range].catchOffset += 3;
  6375.         }
  6376.     }
  6377.     } /* if expression isn't in {}s */
  6378.     
  6379.     done:
  6380.     envPtr->termOffset = (src - string);
  6381.     envPtr->maxStackDepth = maxDepth;
  6382.     envPtr->pushSimpleWords = savePushSimpleWords;
  6383.     envPtr->exprIsJustVarRef = saveExprIsJustVarRef;
  6384.     envPtr->exprIsComparison = saveExprIsComparison;
  6385.     return result;
  6386. }
  6387.  
  6388. /*
  6389.  *----------------------------------------------------------------------
  6390.  *
  6391.  * CompileCmdWordInline --
  6392.  *
  6393.  *    Procedure that compiles a Tcl command word inline. If the word is
  6394.  *    enclosed in quotes or braces, we call TclCompileString to compile it
  6395.  *    after stripping them off. Otherwise, we normally push the word's
  6396.  *    value and call eval at runtime, but if the word is just a sequence
  6397.  *    of alphanumeric characters, we emit an invoke instruction
  6398.  *    directly. This procedure assumes that string points to the start of
  6399.  *    the word to compile.
  6400.  *
  6401.  * Results:
  6402.  *    The return value is a standard Tcl result, which is TCL_OK unless
  6403.  *    there was an error while compiling string. If an error occurs then
  6404.  *    the interpreter's result contains a standard error message.
  6405.  *
  6406.  *    envPtr->termOffset is filled in with the offset of the character in
  6407.  *    "string" just after the last one successfully processed.
  6408.  *
  6409.  *    envPtr->maxStackDepth is updated with the maximum number of stack
  6410.  *    elements needed to execute the command.
  6411.  *
  6412.  * Side effects:
  6413.  *    Instructions are added to envPtr to execute the command word
  6414.  *    at runtime.
  6415.  *
  6416.  *----------------------------------------------------------------------
  6417.  */
  6418.  
  6419. static int
  6420. CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
  6421.     Tcl_Interp *interp;        /* Used for error reporting. */
  6422.     char *string;        /* The source string to compile. */
  6423.     char *lastChar;        /* Pointer to terminating character of
  6424.                  * string. */
  6425.     int flags;            /* Flags to control compilation (same as
  6426.                  * passed to Tcl_Eval). */
  6427.     CompileEnv *envPtr;        /* Holds resulting instructions. */
  6428. {
  6429.     Interp *iPtr = (Interp *) interp;
  6430.     register char *src = string;/* Points to current source char. */
  6431.     register int type;          /* Current char's CHAR_TYPE type. */
  6432.     int maxDepth = 0;        /* Maximum number of stack elements needed
  6433.                  * to execute cmd. */
  6434.     char *termPtr;        /* Points to char that terminated braced
  6435.                  * string. */
  6436.     char savedChar;        /* Holds the character termporarily replaced
  6437.                  * by a null character during compilation
  6438.                  * of the command. */
  6439.     int savePushSimpleWords = envPtr->pushSimpleWords;
  6440.     int objIndex;
  6441.     int result = TCL_OK;
  6442.     register char c;
  6443.  
  6444.     type = CHAR_TYPE(src, lastChar);
  6445.     if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
  6446.     src++;
  6447.     envPtr->pushSimpleWords = 0;
  6448.     if (type == TCL_QUOTE) {
  6449.         result = TclCompileQuotes(interp, src, lastChar,
  6450.             '"', flags, envPtr);
  6451.     } else {
  6452.         result = CompileBraces(interp, src, lastChar, flags, envPtr);
  6453.     }
  6454.     if (result != TCL_OK) {
  6455.         goto done;
  6456.     }
  6457.     
  6458.     /*
  6459.      * Make sure the terminating character is the end of word.
  6460.      */
  6461.     
  6462.     termPtr = (src + envPtr->termOffset);
  6463.     c = *termPtr;
  6464.     if ((c == '\\') && (*(termPtr+1) == '\n')) {
  6465.         /*
  6466.          * Line is continued on next line; the backslash-newline turns
  6467.          * into space, which terminates the word.
  6468.          */
  6469.     } else {
  6470.         type = CHAR_TYPE(termPtr, lastChar);
  6471.         if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) {
  6472.         Tcl_ResetResult(interp);
  6473.         if (*(src-1) == '"') {
  6474.             Tcl_AppendToObj(Tcl_GetObjResult(interp),
  6475.                 "extra characters after close-quote", -1);
  6476.         } else {
  6477.             Tcl_AppendToObj(Tcl_GetObjResult(interp),
  6478.                     "extra characters after close-brace", -1);
  6479.         }
  6480.         result = TCL_ERROR;
  6481.         goto done;
  6482.         }
  6483.     }
  6484.     
  6485.     if (envPtr->wordIsSimple) {
  6486.         /*
  6487.          * A simple word enclosed in "" or {}s. Call TclCompileString to
  6488.          * compile it inline. Add a null character after the end of the
  6489.          * quoted or braced string: i.e., at the " or }. Turn the
  6490.          * flag bit TCL_BRACKET_TERM off since the recursively
  6491.          * compiled subcommand is now terminated by a null character.
  6492.          */
  6493.         char *closeCharPos = (termPtr - 1);
  6494.         
  6495.         savedChar = *closeCharPos;
  6496.         *closeCharPos = '\0';
  6497.         result = TclCompileString(interp, src, closeCharPos,
  6498.             (flags & ~TCL_BRACKET_TERM), envPtr);
  6499.         *closeCharPos = savedChar;
  6500.         if (result != TCL_OK) {
  6501.         goto done;
  6502.         }
  6503.     } else {
  6504.             /*
  6505.          * The braced string contained a backslash-newline. Call eval
  6506.          * at runtime.
  6507.          */
  6508.         TclEmitOpcode(INST_EVAL_STK, envPtr);
  6509.     }
  6510.     src = termPtr;
  6511.     maxDepth = envPtr->maxStackDepth;
  6512.     } else {
  6513.     /*
  6514.      * Not a braced or quoted string. We normally push the word's
  6515.      * value and call eval at runtime. However, if the word is just
  6516.      * a sequence of alphanumeric characters, we call its compile
  6517.      * procedure, if any, or otherwise just emit an invoke instruction.
  6518.      */
  6519.  
  6520.     char *p = src;
  6521.     c = *p;
  6522.     while (isalnum(UCHAR(c)) || (c == '_')) {
  6523.             p++;
  6524.             c = *p;
  6525.         }
  6526.     type = CHAR_TYPE(p, lastChar);
  6527.         if ((p > src) && (type == TCL_COMMAND_END)) {
  6528.             /*
  6529.          * Look for a compile procedure and call it. Otherwise emit an
  6530.          * invoke instruction to call the command at runtime.
  6531.          */
  6532.  
  6533.         Tcl_Command cmd;
  6534.         Command *cmdPtr = NULL;
  6535.         int wasCompiled = 0;
  6536.  
  6537.         savedChar = *p;
  6538.         *p = '\0';
  6539.  
  6540.         cmd = Tcl_FindCommand(interp, src, (Tcl_Namespace *) NULL,
  6541.             /*flags*/ 0);
  6542.         if (cmd != (Tcl_Command) NULL) {
  6543.                 cmdPtr = (Command *) cmd;
  6544.             }
  6545.         if (cmdPtr != NULL && cmdPtr->compileProc != NULL) {
  6546.         *p = savedChar;
  6547.         src = p;
  6548.         iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS
  6549.                  | ERROR_CODE_SET);
  6550.         result = (*(cmdPtr->compileProc))(interp, src, lastChar, flags, envPtr);
  6551.         if (result != TCL_OK) {
  6552.             goto done;
  6553.         }
  6554.         wasCompiled = 1;
  6555.         src += envPtr->termOffset;
  6556.         maxDepth = envPtr->maxStackDepth;
  6557.         }
  6558.         if (!wasCompiled) {
  6559.         objIndex = TclObjIndexForString(src, p-src,
  6560.             /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
  6561.         *p = savedChar;
  6562.         TclEmitPush(objIndex, envPtr);
  6563.         TclEmitInstUInt1(INST_INVOKE_STK1, 1, envPtr);
  6564.         src = p;
  6565.         maxDepth = 1;
  6566.         }
  6567.         } else {
  6568.         /*
  6569.          * Push the word and call eval at runtime.
  6570.          */
  6571.  
  6572.         envPtr->pushSimpleWords = 1;
  6573.         result = CompileWord(interp, src, lastChar, flags, envPtr);
  6574.         if (result != TCL_OK) {
  6575.         goto done;
  6576.         }
  6577.         TclEmitOpcode(INST_EVAL_STK, envPtr);
  6578.         src += envPtr->termOffset;
  6579.         maxDepth = envPtr->maxStackDepth;
  6580.     }
  6581.     }
  6582.  
  6583.     done:
  6584.     envPtr->termOffset = (src - string);
  6585.     envPtr->maxStackDepth = maxDepth;
  6586.     envPtr->pushSimpleWords = savePushSimpleWords;
  6587.     return result;
  6588. }
  6589.  
  6590. /*
  6591.  *----------------------------------------------------------------------
  6592.  *
  6593.  * LookupCompiledLocal --
  6594.  *
  6595.  *    This procedure is called at compile time to look up and optionally
  6596.  *    allocate an entry ("slot") for a variable in a procedure's array of
  6597.  *    local variables. If the variable's name is NULL, a new temporary
  6598.  *    variable is always created. (Such temporary variables can only be
  6599.  *    referenced using their slot index.)
  6600.  *
  6601.  * Results:
  6602.  *    If createIfNew is 0 (false) and the name is non-NULL, then if the
  6603.  *    variable is found, the index of its entry in the procedure's array
  6604.  *    of local variables is returned; otherwise -1 is returned.
  6605.  *    If name is NULL, the index of a new temporary variable is returned.
  6606.  *    Finally, if createIfNew is 1 and name is non-NULL, the index of a
  6607.  *    new entry is returned.
  6608.  *
  6609.  * Side effects:
  6610.  *    Creates and registers a new local variable if createIfNew is 1 and
  6611.  *    the variable is unknown, or if the name is NULL.
  6612.  *
  6613.  *----------------------------------------------------------------------
  6614.  */
  6615.  
  6616. static int
  6617. LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr)
  6618.     register char *name;    /* Points to first character of the name of
  6619.                  * a scalar or array variable. If NULL, a
  6620.                  * temporary var should be created. */
  6621.     int nameChars;        /* The length of the name excluding the
  6622.                  * terminating null character. */
  6623.     int createIfNew;        /* 1 to allocate a local frame entry for the
  6624.                  * variable if it is new. */
  6625.     int flagsIfCreated;        /* Flag bits for the compiled local if
  6626.                  * created. Only VAR_SCALAR, VAR_ARRAY, and
  6627.                  * VAR_LINK make sense. */
  6628.     register Proc *procPtr;    /* Points to structure describing procedure
  6629.                  * containing the variable reference. */
  6630. {
  6631.     register CompiledLocal *localPtr;
  6632.     int localIndex = -1;
  6633.     register int i;
  6634.  
  6635.     /*
  6636.      * If not creating a temporary, does a local variable of the specified
  6637.      * name already exist?
  6638.      */
  6639.  
  6640.     if (name != NULL) {    
  6641.     int localCt = procPtr->numCompiledLocals;
  6642.     localPtr = procPtr->firstLocalPtr;
  6643.     for (i = 0;  i < localCt;  i++) {
  6644.         if (!localPtr->isTemp) {
  6645.         char *localName = localPtr->name;
  6646.         if ((name[0] == localName[0])
  6647.                     && (nameChars == localPtr->nameLength)
  6648.                     && (strncmp(name, localName, (unsigned) nameChars) == 0)) {
  6649.             return i;
  6650.         }
  6651.         }
  6652.         localPtr = localPtr->nextPtr;
  6653.     }
  6654.     }
  6655.  
  6656.     /*
  6657.      * Create a new variable if appropriate.
  6658.      */
  6659.     
  6660.     if (createIfNew || (name == NULL)) {
  6661.     localIndex = procPtr->numCompiledLocals;
  6662.     localPtr = (CompiledLocal *) ckalloc((unsigned) 
  6663.             (sizeof(CompiledLocal) - sizeof(localPtr->name)
  6664.         + nameChars+1));
  6665.     if (procPtr->firstLocalPtr == NULL) {
  6666.         procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
  6667.     } else {
  6668.         procPtr->lastLocalPtr->nextPtr = localPtr;
  6669.         procPtr->lastLocalPtr = localPtr;
  6670.     }
  6671.     localPtr->nextPtr = NULL;
  6672.     localPtr->nameLength = nameChars;
  6673.     localPtr->frameIndex = localIndex;
  6674.     localPtr->isArg  = 0;
  6675.     localPtr->isTemp = (name == NULL);
  6676.     localPtr->flags = flagsIfCreated;
  6677.     localPtr->defValuePtr = NULL;
  6678.     if (name != NULL) {
  6679.         memcpy((VOID *) localPtr->name, (VOID *) name, (size_t) nameChars);
  6680.     }
  6681.     localPtr->name[nameChars] = '\0';
  6682.     procPtr->numCompiledLocals++;
  6683.     }
  6684.     return localIndex;
  6685. }
  6686.  
  6687. /*
  6688.  *----------------------------------------------------------------------
  6689.  *
  6690.  * AdvanceToNextWord --
  6691.  *
  6692.  *    This procedure is called to skip over any leading white space at the
  6693.  *    start of a word. Note that a backslash-newline is treated as a
  6694.  *    space.
  6695.  *
  6696.  * Results:
  6697.  *    None.
  6698.  *
  6699.  * Side effects:
  6700.  *    Updates envPtr->termOffset with the offset of the first
  6701.  *    character in "string" that was not white space or a
  6702.  *    backslash-newline. This might be the offset of the character that
  6703.  *    ends the command: a newline, null, semicolon, or close-bracket.
  6704.  *
  6705.  *----------------------------------------------------------------------
  6706.  */
  6707.  
  6708. static void
  6709. AdvanceToNextWord(string, envPtr)
  6710.     char *string;        /* The source string to compile. */
  6711.     CompileEnv *envPtr;        /* Holds resulting instructions. */
  6712. {
  6713.     register char *src;        /* Points to current source char. */
  6714.     register int type;        /* Current char's CHAR_TYPE type. */
  6715.     
  6716.     src = string;
  6717.     type = CHAR_TYPE(src, src+1);
  6718.     while (type & (TCL_SPACE | TCL_BACKSLASH)) {
  6719.     if (type == TCL_BACKSLASH) {
  6720.         if (src[1] == '\n') {
  6721.         src += 2;
  6722.         } else {
  6723.         break;        /* exit loop; no longer white space */
  6724.         }
  6725.     } else {
  6726.         src++;
  6727.     }
  6728.     type = CHAR_TYPE(src, src+1);
  6729.     }
  6730.     envPtr->termOffset = (src - string);
  6731. }
  6732.  
  6733. /*
  6734.  *----------------------------------------------------------------------
  6735.  *
  6736.  * Tcl_Backslash --
  6737.  *
  6738.  *    Figure out how to handle a backslash sequence.
  6739.  *
  6740.  * Results:
  6741.  *    The return value is the character that should be substituted
  6742.  *    in place of the backslash sequence that starts at src.  If
  6743.  *    readPtr isn't NULL then it is filled in with a count of the
  6744.  *    number of characters in the backslash sequence.
  6745.  *
  6746.  * Side effects:
  6747.  *    None.
  6748.  *
  6749.  *----------------------------------------------------------------------
  6750.  */
  6751.  
  6752. char
  6753. Tcl_Backslash(src, readPtr)
  6754.     CONST char *src;        /* Points to the backslash character of
  6755.                  * a backslash sequence. */
  6756.     int *readPtr;        /* Fill in with number of characters read
  6757.                  * from src, unless NULL. */
  6758. {
  6759.     CONST char *p = src + 1;
  6760.     char result;
  6761.     int count;
  6762.  
  6763.     count = 2;
  6764.  
  6765.     switch (*p) {
  6766.     /*
  6767.          * Note: in the conversions below, use absolute values (e.g.,
  6768.          * 0xa) rather than symbolic values (e.g. \n) that get converted
  6769.          * by the compiler.  It's possible that compilers on some
  6770.          * platforms will do the symbolic conversions differently, which
  6771.          * could result in non-portable Tcl scripts.
  6772.          */
  6773.  
  6774.         case 'a':
  6775.             result = 0x7;
  6776.             break;
  6777.         case 'b':
  6778.             result = 0x8;
  6779.             break;
  6780.         case 'f':
  6781.             result = 0xc;
  6782.             break;
  6783.         case 'n':
  6784.             result = 0xa;
  6785.             break;
  6786.         case 'r':
  6787.             result = 0xd;
  6788.             break;
  6789.         case 't':
  6790.             result = 0x9;
  6791.             break;
  6792.         case 'v':
  6793.             result = 0xb;
  6794.             break;
  6795.         case 'x':
  6796.             if (isxdigit(UCHAR(p[1]))) {
  6797.                 char *end;
  6798.  
  6799.                 result = (char) strtoul(p+1, &end, 16);
  6800.                 count = end - src;
  6801.             } else {
  6802.                 count = 2;
  6803.                 result = 'x';
  6804.             }
  6805.             break;
  6806.         case '\n':
  6807.             do {
  6808.                 p++;
  6809.             } while ((*p == ' ') || (*p == '\t'));
  6810.             result = ' ';
  6811.             count = p - src;
  6812.             break;
  6813.         case 0:
  6814.             result = '\\';
  6815.             count = 1;
  6816.             break;
  6817.     default:
  6818.         if (isdigit(UCHAR(*p))) {
  6819.         result = (char)(*p - '0');
  6820.         p++;
  6821.         if (!isdigit(UCHAR(*p))) {
  6822.             break;
  6823.         }
  6824.         count = 3;
  6825.         result = (char)((result << 3) + (*p - '0'));
  6826.         p++;
  6827.         if (!isdigit(UCHAR(*p))) {
  6828.             break;
  6829.         }
  6830.         count = 4;
  6831.         result = (char)((result << 3) + (*p - '0'));
  6832.         break;
  6833.         }
  6834.         result = *p;
  6835.         count = 2;
  6836.         break;
  6837.     }
  6838.  
  6839.     if (readPtr != NULL) {
  6840.     *readPtr = count;
  6841.     }
  6842.     return result;
  6843. }
  6844.  
  6845. /*
  6846.  *----------------------------------------------------------------------
  6847.  *
  6848.  * TclObjIndexForString --
  6849.  *
  6850.  *    Procedure to find, or if necessary create, an object in a
  6851.  *    CompileEnv's object array that has a string representation
  6852.  *    matching the argument string.
  6853.  *
  6854.  * Results:
  6855.  *    The index in the CompileEnv's object array of an object with a
  6856.  *    string representation matching the argument "string". The object is
  6857.  *    created if necessary. If inHeap is 1, then string is heap allocated
  6858.  *    and ownership of the string is passed to TclObjIndexForString;
  6859.  *    otherwise, the string is owned by the caller and must not be
  6860.  *    modified or freed by TclObjIndexForString. Typically, a caller sets
  6861.  *    inHeap 1 if string is an already heap-allocated buffer holding the
  6862.  *    result of backslash substitutions.
  6863.  *
  6864.  * Side effects:
  6865.  *    A new Tcl object will be created if no existing object matches the
  6866.  *    input string. If allocStrRep is 1 then if a new object is created,
  6867.  *    its string representation is allocated in the heap, else it is left
  6868.  *    NULL. If inHeap is 1, this procedure is given ownership of the
  6869.  *     string: if an object is created and allocStrRep is 1 then its
  6870.  *    string representation is set directly from string, otherwise
  6871.  *    the string is freed.
  6872.  *
  6873.  *----------------------------------------------------------------------
  6874.  */
  6875.  
  6876. int
  6877. TclObjIndexForString(string, length, allocStrRep, inHeap, envPtr)
  6878.     register char *string;    /* Points to string for which an object is
  6879.                  * found or created in CompileEnv's object
  6880.                  * array. */
  6881.     int length;            /* Length of string. */
  6882.     int allocStrRep;        /* If 1 then the object's string rep should
  6883.                  * be allocated in the heap. */
  6884.     int inHeap;            /* If 1 then string is heap allocated and
  6885.                  * its ownership is passed to
  6886.                  * TclObjIndexForString. */
  6887.     CompileEnv *envPtr;        /* Points to the CompileEnv in whose object
  6888.                  * array an object is found or created. */
  6889. {
  6890.     register Tcl_Obj *objPtr;    /* Points to the object created for
  6891.                  * the string, if one was created. */
  6892.     int objIndex;        /* Index of matching object. */
  6893.     Tcl_HashEntry *hPtr;
  6894.     int strLength, new;
  6895.     
  6896.     /*
  6897.      * Look up the string in the code's object hashtable. If found, just
  6898.      * return the associated object array index.  Note that if the string
  6899.      * has embedded nulls, we don't create a hash table entry.  This
  6900.      * should be fixed, but we need to update hash tables, first.
  6901.      */
  6902.  
  6903.     strLength = strlen(string);
  6904.     if (length == -1) {
  6905.     length = strLength;
  6906.     }
  6907.     if (strLength != length) {
  6908.     hPtr = NULL;
  6909.     } else {
  6910.     hPtr = Tcl_CreateHashEntry(&envPtr->objTable, string, &new);
  6911.     if (!new) {        /* already in object table and array */
  6912.         objIndex = (int) Tcl_GetHashValue(hPtr);
  6913.         if (inHeap) {
  6914.         ckfree(string);
  6915.         }
  6916.         return objIndex;
  6917.     }
  6918.     }    
  6919.  
  6920.     /*
  6921.      * Create a new object holding the string, add it to the object array,
  6922.      * and register its index in the object hashtable.
  6923.      */
  6924.  
  6925.     objPtr = Tcl_NewObj();
  6926.     if (allocStrRep) {
  6927.     if (inHeap) {        /* use input string for obj's string rep */
  6928.         objPtr->bytes = string;
  6929.     } else {
  6930.         if (length > 0) {
  6931.         objPtr->bytes = ckalloc((unsigned) length + 1);
  6932.         memcpy((VOID *) objPtr->bytes, (VOID *) string,
  6933.             (size_t) length);
  6934.         objPtr->bytes[length] = '\0';
  6935.         }
  6936.     }
  6937.     objPtr->length = length;
  6938.     } else {            /* leave the string rep NULL */
  6939.     if (inHeap) {
  6940.         ckfree(string);
  6941.     }
  6942.     }
  6943.  
  6944.     if (envPtr->objArrayNext >= envPtr->objArrayEnd) {
  6945.         ExpandObjectArray(envPtr);
  6946.     }
  6947.     objIndex = envPtr->objArrayNext;
  6948.     envPtr->objArrayPtr[objIndex] = objPtr;
  6949.     Tcl_IncrRefCount(objPtr);
  6950.     envPtr->objArrayNext++;
  6951.  
  6952.     if (hPtr) {
  6953.     Tcl_SetHashValue(hPtr, objIndex);
  6954.     }
  6955.     return objIndex;
  6956. }
  6957.  
  6958. /*
  6959.  *----------------------------------------------------------------------
  6960.  *
  6961.  * TclExpandCodeArray --
  6962.  *
  6963.  *    Procedure that uses malloc to allocate more storage for a
  6964.  *    CompileEnv's code array.
  6965.  *
  6966.  * Results:
  6967.  *    None. 
  6968.  *
  6969.  * Side effects:
  6970.  *    The byte code array in *envPtr is reallocated to a new array of
  6971.  *    double the size, and if envPtr->mallocedCodeArray is non-zero the
  6972.  *    old array is freed. Byte codes are copied from the old array to the
  6973.  *    new one.
  6974.  *
  6975.  *----------------------------------------------------------------------
  6976.  */
  6977.  
  6978. void
  6979. TclExpandCodeArray(envPtr)
  6980.     CompileEnv *envPtr;        /* Points to the CompileEnv whose code array
  6981.                  * must be enlarged. */
  6982. {
  6983.     /*
  6984.      * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined
  6985.      * code bytes are stored between envPtr->codeStart and
  6986.      * (envPtr->codeNext - 1) [inclusive].
  6987.      */
  6988.     
  6989.     size_t currBytes = TclCurrCodeOffset();
  6990.     size_t newBytes  = 2*(envPtr->codeEnd  - envPtr->codeStart);
  6991.     unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes);
  6992.  
  6993.     /*
  6994.      * Copy from old code array to new, free old code array if needed, and
  6995.      * mark new code array as malloced.
  6996.      */
  6997.  
  6998.     memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes);
  6999.     if (envPtr->mallocedCodeArray) {
  7000.         ckfree((char *) envPtr->codeStart);
  7001.     }
  7002.     envPtr->codeStart = newPtr;
  7003.     envPtr->codeNext = (newPtr + currBytes);
  7004.     envPtr->codeEnd  = (newPtr + newBytes);
  7005.     envPtr->mallocedCodeArray = 1;
  7006. }
  7007.  
  7008. /*
  7009.  *----------------------------------------------------------------------
  7010.  *
  7011.  * ExpandObjectArray --
  7012.  *
  7013.  *    Procedure that uses malloc to allocate more storage for a
  7014.  *    CompileEnv's object array.
  7015.  *
  7016.  * Results:
  7017.  *    None.
  7018.  *
  7019.  * Side effects:
  7020.  *    The object array in *envPtr is reallocated to a new array of
  7021.  *    double the size, and if envPtr->mallocedObjArray is non-zero the
  7022.  *    old array is freed. Tcl_Obj pointers are copied from the old array
  7023.  *    to the new one.
  7024.  *
  7025.  *----------------------------------------------------------------------
  7026.  */
  7027.  
  7028. static void
  7029. ExpandObjectArray(envPtr)
  7030.     CompileEnv *envPtr;        /* Points to the CompileEnv whose object
  7031.                  * array must be enlarged. */
  7032. {
  7033.     /*
  7034.      * envPtr->objArrayNext is equal to envPtr->objArrayEnd. The currently
  7035.      * allocated Tcl_Obj pointers are stored between elements
  7036.      * 0 and (envPtr->objArrayNext - 1) [inclusive] in the object array
  7037.      * pointed to by objArrayPtr.
  7038.      */
  7039.  
  7040.     size_t currBytes = envPtr->objArrayNext * sizeof(Tcl_Obj *);
  7041.     int newElems = 2*envPtr->objArrayEnd;
  7042.     size_t newBytes = newElems * sizeof(Tcl_Obj *);
  7043.     Tcl_Obj **newPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
  7044.  
  7045.     /*
  7046.      * Copy from old object array to new, free old object array if needed,
  7047.      * and mark new object array as malloced.
  7048.      */
  7049.  
  7050.     memcpy((VOID *) newPtr, (VOID *) envPtr->objArrayPtr, currBytes);
  7051.     if (envPtr->mallocedObjArray) {
  7052.     ckfree((char *) envPtr->objArrayPtr);
  7053.     }
  7054.     envPtr->objArrayPtr = (Tcl_Obj **) newPtr;
  7055.     envPtr->objArrayEnd = newElems;
  7056.     envPtr->mallocedObjArray = 1;
  7057. }
  7058.  
  7059. /*
  7060.  *----------------------------------------------------------------------
  7061.  *
  7062.  * EnterCmdStartData --
  7063.  *
  7064.  *    Registers the starting source and bytecode location of a
  7065.  *    command. This information is used at runtime to map between
  7066.  *    instruction pc and source locations.
  7067.  *
  7068.  * Results:
  7069.  *    None.
  7070.  *
  7071.  * Side effects:
  7072.  *    Inserts source and code location information into the compilation
  7073.  *    environment envPtr for the command at index cmdIndex. The
  7074.  *    compilation environment's CmdLocation array is grown if necessary.
  7075.  *
  7076.  *----------------------------------------------------------------------
  7077.  */
  7078.  
  7079. static void
  7080. EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
  7081.     CompileEnv *envPtr;        /* Points to the compilation environment
  7082.                  * structure in which to enter command
  7083.                  * location information. */
  7084.     int cmdIndex;        /* Index of the command whose start data
  7085.                  * is being set. */
  7086.     int srcOffset;        /* Offset of first char of the command. */
  7087.     int codeOffset;        /* Offset of first byte of command code. */
  7088. {
  7089.     CmdLocation *cmdLocPtr;
  7090.     
  7091.     if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
  7092.     panic("EnterCmdStartData: bad command index %d\n", cmdIndex);
  7093.     }
  7094.     
  7095.     if (cmdIndex >= envPtr->cmdMapEnd) {
  7096.     /*
  7097.      * Expand the command location array by allocating more storage from
  7098.      * the heap. The currently allocated CmdLocation entries are stored
  7099.      * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive).
  7100.      */
  7101.  
  7102.     size_t currElems = envPtr->cmdMapEnd;
  7103.     size_t newElems  = 2*currElems;
  7104.     size_t currBytes = currElems * sizeof(CmdLocation);
  7105.     size_t newBytes  = newElems  * sizeof(CmdLocation);
  7106.     CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes);
  7107.     
  7108.     /*
  7109.      * Copy from old command location array to new, free old command
  7110.      * location array if needed, and mark new array as malloced.
  7111.      */
  7112.     
  7113.     memcpy((VOID *) newPtr, (VOID *) envPtr->cmdMapPtr, currBytes);
  7114.     if (envPtr->mallocedCmdMap) {
  7115.         ckfree((char *) envPtr->cmdMapPtr);
  7116.     }
  7117.     envPtr->cmdMapPtr = (CmdLocation *) newPtr;
  7118.     envPtr->cmdMapEnd = newElems;
  7119.     envPtr->mallocedCmdMap = 1;
  7120.     }
  7121.  
  7122.     if (cmdIndex > 0) {
  7123.     if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) {
  7124.         panic("EnterCmdStartData: cmd map table not sorted by code offset");
  7125.     }
  7126.     }
  7127.  
  7128.     cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
  7129.     cmdLocPtr->codeOffset = codeOffset;
  7130.     cmdLocPtr->srcOffset = srcOffset;
  7131.     cmdLocPtr->numSrcChars = -1;
  7132.     cmdLocPtr->numCodeBytes = -1;
  7133. }
  7134.  
  7135. /*
  7136.  *----------------------------------------------------------------------
  7137.  *
  7138.  * EnterCmdExtentData --
  7139.  *
  7140.  *    Registers the source and bytecode length for a command. This
  7141.  *    information is used at runtime to map between instruction pc and
  7142.  *    source locations.
  7143.  *
  7144.  * Results:
  7145.  *    None.
  7146.  *
  7147.  * Side effects:
  7148.  *    Inserts source and code length information into the compilation
  7149.  *    environment envPtr for the command at index cmdIndex. Starting
  7150.  *    source and bytecode information for the command must already
  7151.  *    have been registered.
  7152.  *
  7153.  *----------------------------------------------------------------------
  7154.  */
  7155.  
  7156. static void
  7157. EnterCmdExtentData(envPtr, cmdIndex, numSrcChars, numCodeBytes)
  7158.     CompileEnv *envPtr;        /* Points to the compilation environment
  7159.                  * structure in which to enter command
  7160.                  * location information. */
  7161.     int cmdIndex;        /* Index of the command whose source and
  7162.                  * code length data is being set. */
  7163.     int numSrcChars;        /* Number of command source chars. */
  7164.     int numCodeBytes;        /* Offset of last byte of command code. */
  7165. {
  7166.     CmdLocation *cmdLocPtr;
  7167.  
  7168.     if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
  7169.     panic("EnterCmdStartData: bad command index %d\n", cmdIndex);
  7170.     }
  7171.     
  7172.     if (cmdIndex > envPtr->cmdMapEnd) {
  7173.     panic("EnterCmdStartData: no start data registered for command with index %d\n", cmdIndex);
  7174.     }
  7175.  
  7176.     cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
  7177.     cmdLocPtr->numSrcChars = numSrcChars;
  7178.     cmdLocPtr->numCodeBytes = numCodeBytes;
  7179. }
  7180.  
  7181. /*
  7182.  *----------------------------------------------------------------------
  7183.  *
  7184.  * InitArgInfo --
  7185.  *
  7186.  *    Initializes a ArgInfo structure to hold information about
  7187.  *    some number of argument words in a command.
  7188.  *
  7189.  * Results:
  7190.  *    None.
  7191.  *
  7192.  * Side effects:
  7193.  *    The ArgInfo structure is initialized.
  7194.  *
  7195.  *----------------------------------------------------------------------
  7196.  */
  7197.  
  7198. static void
  7199. InitArgInfo(argInfoPtr)
  7200.     register ArgInfo *argInfoPtr; /* Points to the ArgInfo structure
  7201.                    * to initialize. */
  7202. {
  7203.     argInfoPtr->numArgs = 0;
  7204.     argInfoPtr->startArray = argInfoPtr->staticStartSpace;
  7205.     argInfoPtr->endArray   = argInfoPtr->staticEndSpace;
  7206.     argInfoPtr->allocArgs = ARGINFO_INIT_ENTRIES;
  7207.     argInfoPtr->mallocedArrays = 0;
  7208. }
  7209.  
  7210. /*
  7211.  *----------------------------------------------------------------------
  7212.  *
  7213.  * CollectArgInfo --
  7214.  *
  7215.  *    Procedure to scan the argument words of a command and record the
  7216.  *    start and finish of each argument word in a ArgInfo structure.
  7217.  *
  7218.  * Results:
  7219.  *    The return value is a standard Tcl result, which is TCL_OK unless
  7220.  *    there was an error while scanning string. If an error occurs then
  7221.  *    the interpreter's result contains a standard error message.
  7222.  *
  7223.  * Side effects:
  7224.  *    If necessary, the argument start and end arrays in *argInfoPtr
  7225.  *    are grown and reallocated to a new arrays of double the size, and
  7226.  *    if argInfoPtr->mallocedArray is non-zero the old arrays are freed.
  7227.  *
  7228.  *----------------------------------------------------------------------
  7229.  */
  7230.  
  7231. static int
  7232. CollectArgInfo(interp, string, lastChar, flags, argInfoPtr)
  7233.     Tcl_Interp *interp;         /* Used for error reporting. */
  7234.     char *string;               /* The source command string to scan. */
  7235.     char *lastChar;         /* Pointer to terminating character of
  7236.                   * string. */
  7237.     int flags;                  /* Flags to control compilation (same as
  7238.                                  * passed to Tcl_Eval). */
  7239.     register ArgInfo *argInfoPtr;
  7240.                 /* Points to the ArgInfo structure in which
  7241.                  * to record the arg word information. */
  7242. {
  7243.     register char *src = string;/* Points to current source char. */
  7244.     register int type;        /* Current char's CHAR_TYPE type. */
  7245.     int nestedCmd = (flags & TCL_BRACKET_TERM);
  7246.                                 /* 1 if string being scanned is a nested
  7247.                  * command and is terminated by a ']';
  7248.                  * otherwise 0. */
  7249.     int scanningArgs;           /* 1 if still scanning argument words to
  7250.                  * determine their start and end. */
  7251.     char *wordStart, *wordEnd;  /* Points to the first and last significant
  7252.                  * characters of each word. */
  7253.     CompileEnv tempCompEnv;    /* Only used to hold the termOffset field
  7254.                  * updated by AdvanceToNextWord. */
  7255.     char *prev;
  7256.  
  7257.     argInfoPtr->numArgs = 0;
  7258.     scanningArgs = 1;
  7259.     while (scanningArgs) {
  7260.     AdvanceToNextWord(src, &tempCompEnv);
  7261.     src += tempCompEnv.termOffset;
  7262.     type = CHAR_TYPE(src, lastChar);
  7263.  
  7264.     if ((type == TCL_COMMAND_END) && ((*src != ']') || nestedCmd)) {
  7265.         break;            /* done collecting argument words */
  7266.     } else if (*src == '"') {
  7267.         wordStart = src;
  7268.         src = TclWordEnd(src, lastChar, nestedCmd, NULL);
  7269.         if (src == lastChar) {
  7270.             badStringTermination:
  7271.         Tcl_ResetResult(interp);
  7272.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  7273.                     "quoted string doesn't terminate properly", -1);
  7274.         return TCL_ERROR;
  7275.         }
  7276.         prev = (src-1);
  7277.         if (*src == '"') {
  7278.         wordEnd = src;
  7279.         src++;
  7280.         } else if ((*src == ';') && (*prev == '"')) {
  7281.         scanningArgs = 0;
  7282.         wordEnd = prev;
  7283.         } else {
  7284.         goto badStringTermination;
  7285.         }
  7286.     } else if (*src == '{') {
  7287.         wordStart = src;
  7288.         src = TclWordEnd(src, lastChar, nestedCmd, NULL);
  7289.         if (src == lastChar) {
  7290.         Tcl_ResetResult(interp);
  7291.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  7292.                 "missing close-brace", -1);
  7293.         return TCL_ERROR;
  7294.         }
  7295.         prev = (src-1);
  7296.         if (*src == '}') {
  7297.         wordEnd = src;
  7298.         src++;
  7299.         } else if ((*src == ';') && (*prev == '}')) {
  7300.         scanningArgs = 0;
  7301.         wordEnd = prev;
  7302.         } else {
  7303.         Tcl_ResetResult(interp);
  7304.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  7305.                     "argument word in braces doesn't terminate properly", -1);
  7306.         return TCL_ERROR;
  7307.         }
  7308.     } else {
  7309.         wordStart = src;
  7310.         src = TclWordEnd(src, lastChar, nestedCmd, NULL);
  7311.         prev = (src-1);
  7312.         if (src == lastChar) {
  7313.         Tcl_ResetResult(interp);
  7314.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  7315.                 "missing close-bracket or close-brace", -1);
  7316.         return TCL_ERROR;
  7317.         } else if (*src == ';') {
  7318.         scanningArgs = 0;
  7319.         wordEnd = prev;
  7320.         } else {
  7321.         wordEnd = src;
  7322.         src++;
  7323.         if ((src == lastChar) || (*src == '\n')
  7324.                     || ((*src == ']') && nestedCmd)) {
  7325.             scanningArgs = 0;
  7326.         }
  7327.         }
  7328.     } /* end of test on each kind of word */
  7329.  
  7330.     if (argInfoPtr->numArgs == argInfoPtr->allocArgs) {
  7331.         int newArgs = 2*argInfoPtr->numArgs;
  7332.         size_t currBytes = argInfoPtr->numArgs * sizeof(char *);
  7333.         size_t newBytes  = newArgs * sizeof(char *);
  7334.         char **newStartArrayPtr =
  7335.             (char **) ckalloc((unsigned) newBytes);
  7336.         char **newEndArrayPtr =
  7337.             (char **) ckalloc((unsigned) newBytes);
  7338.         
  7339.         /*
  7340.          * Copy from the old arrays to the new, free the old arrays if
  7341.          * needed, and mark the new arrays as malloc'ed.
  7342.          */
  7343.         
  7344.         memcpy((VOID *) newStartArrayPtr,
  7345.                 (VOID *) argInfoPtr->startArray, currBytes);
  7346.         memcpy((VOID *) newEndArrayPtr,
  7347.             (VOID *) argInfoPtr->endArray, currBytes);
  7348.         if (argInfoPtr->mallocedArrays) {
  7349.         ckfree((char *) argInfoPtr->startArray);
  7350.         ckfree((char *) argInfoPtr->endArray);
  7351.         }
  7352.         argInfoPtr->startArray = newStartArrayPtr;
  7353.         argInfoPtr->endArray   = newEndArrayPtr;
  7354.         argInfoPtr->allocArgs = newArgs;
  7355.         argInfoPtr->mallocedArrays = 1;
  7356.     }
  7357.     argInfoPtr->startArray[argInfoPtr->numArgs] = wordStart;
  7358.     argInfoPtr->endArray[argInfoPtr->numArgs]   = wordEnd;
  7359.     argInfoPtr->numArgs++;
  7360.     }
  7361.     return TCL_OK;
  7362. }
  7363.  
  7364. /*
  7365.  *----------------------------------------------------------------------
  7366.  *
  7367.  * FreeArgInfo --
  7368.  *
  7369.  *    Free any storage allocated in a ArgInfo structure.
  7370.  *
  7371.  * Results:
  7372.  *    None.
  7373.  *
  7374.  * Side effects:
  7375.  *    Allocated storage in the ArgInfo structure is freed.
  7376.  *
  7377.  *----------------------------------------------------------------------
  7378.  */
  7379.  
  7380. static void
  7381. FreeArgInfo(argInfoPtr)
  7382.     register ArgInfo *argInfoPtr; /* Points to the ArgInfo structure
  7383.                    * to free. */
  7384. {
  7385.     if (argInfoPtr->mallocedArrays) {
  7386.     ckfree((char *) argInfoPtr->startArray);
  7387.     ckfree((char *) argInfoPtr->endArray);
  7388.     }
  7389. }
  7390.  
  7391. /*
  7392.  *----------------------------------------------------------------------
  7393.  *
  7394.  * CreateLoopExceptionRange --
  7395.  *
  7396.  *    Procedure that allocates and initializes a new ExceptionRange
  7397.  *    structure of the specified kind in a CompileEnv's ExceptionRange
  7398.  *    array.
  7399.  *
  7400.  * Results:
  7401.  *    Returns the index for the newly created ExceptionRange.
  7402.  *
  7403.  * Side effects:
  7404.  *    If there is not enough room in the CompileEnv's ExceptionRange
  7405.  *    array, the array in expanded: a new array of double the size is
  7406.  *    allocated, if envPtr->mallocedExcRangeArray is non-zero the old
  7407.  *    array is freed, and ExceptionRange entries are copied from the old
  7408.  *    array to the new one.
  7409.  *
  7410.  *----------------------------------------------------------------------
  7411.  */
  7412.  
  7413. static int
  7414. CreateExceptionRange(type, envPtr)
  7415.     ExceptionRangeType type;    /* The kind of ExceptionRange desired. */
  7416.     register CompileEnv *envPtr;/* Points to the CompileEnv for which a new
  7417.                  * loop ExceptionRange structure is to be
  7418.                  * allocated. */
  7419. {
  7420.     int index;            /* Index for the newly-allocated
  7421.                  * ExceptionRange structure. */
  7422.     register ExceptionRange *rangePtr;
  7423.                     /* Points to the new ExceptionRange
  7424.                  * structure */
  7425.     
  7426.     index = envPtr->excRangeArrayNext;
  7427.     if (index >= envPtr->excRangeArrayEnd) {
  7428.         /*
  7429.      * Expand the ExceptionRange array. The currently allocated entries
  7430.      * are stored between elements 0 and (envPtr->excRangeArrayNext - 1)
  7431.      * [inclusive].
  7432.      */
  7433.     
  7434.     size_t currBytes =
  7435.             envPtr->excRangeArrayNext * sizeof(ExceptionRange);
  7436.     int newElems = 2*envPtr->excRangeArrayEnd;
  7437.     size_t newBytes = newElems * sizeof(ExceptionRange);
  7438.     ExceptionRange *newPtr = (ExceptionRange *)
  7439.             ckalloc((unsigned) newBytes);
  7440.     
  7441.     /*
  7442.      * Copy from old ExceptionRange array to new, free old
  7443.      * ExceptionRange array if needed, and mark the new ExceptionRange
  7444.      * array as malloced.
  7445.      */
  7446.     
  7447.     memcpy((VOID *) newPtr, (VOID *) envPtr->excRangeArrayPtr,
  7448.             currBytes);
  7449.     if (envPtr->mallocedExcRangeArray) {
  7450.         ckfree((char *) envPtr->excRangeArrayPtr);
  7451.     }
  7452.     envPtr->excRangeArrayPtr = (ExceptionRange *) newPtr;
  7453.     envPtr->excRangeArrayEnd = newElems;
  7454.     envPtr->mallocedExcRangeArray = 1;
  7455.     }
  7456.     envPtr->excRangeArrayNext++;
  7457.     
  7458.     rangePtr = &(envPtr->excRangeArrayPtr[index]);
  7459.     rangePtr->type = type;
  7460.     rangePtr->nestingLevel = envPtr->excRangeDepth;
  7461.     rangePtr->codeOffset = -1;
  7462.     rangePtr->numCodeBytes = -1;
  7463.     rangePtr->breakOffset = -1;
  7464.     rangePtr->continueOffset = -1;
  7465.     rangePtr->catchOffset = -1;
  7466.     return index;
  7467. }
  7468.  
  7469. /*
  7470.  *----------------------------------------------------------------------
  7471.  *
  7472.  * TclCreateAuxData --
  7473.  *
  7474.  *    Procedure that allocates and initializes a new AuxData structure in
  7475.  *    a CompileEnv's array of compilation auxiliary data records. These
  7476.  *    AuxData records hold information created during compilation by
  7477.  *    CompileProcs and used by instructions during execution.
  7478.  *
  7479.  * Results:
  7480.  *    Returns the index for the newly created AuxData structure.
  7481.  *
  7482.  * Side effects:
  7483.  *    If there is not enough room in the CompileEnv's AuxData array,
  7484.  *    the AuxData array in expanded: a new array of double the size
  7485.  *    is allocated, if envPtr->mallocedAuxDataArray is non-zero
  7486.  *    the old array is freed, and AuxData entries are copied from
  7487.  *    the old array to the new one.
  7488.  *
  7489.  *----------------------------------------------------------------------
  7490.  */
  7491.  
  7492. int
  7493. TclCreateAuxData(clientData, dupProc, freeProc, envPtr)
  7494.     ClientData clientData;    /* The compilation auxiliary data to store
  7495.                  * in the new aux data record. */
  7496.     AuxDataDupProc *dupProc;    /* Procedure to call to duplicate the
  7497.                  * compilation aux data when the containing
  7498.                  * ByteCode structure is duplicated. */
  7499.     AuxDataFreeProc *freeProc;    /* Procedure to call to free the
  7500.                  * compilation aux data when the containing
  7501.                  * ByteCode structure is freed.  */
  7502.     register CompileEnv *envPtr;/* Points to the CompileEnv for which a new
  7503.                  * aux data structure is to be allocated. */
  7504. {
  7505.     int index;            /* Index for the new AuxData structure. */
  7506.     register AuxData *auxDataPtr;
  7507.                     /* Points to the new AuxData structure */
  7508.     
  7509.     index = envPtr->auxDataArrayNext;
  7510.     if (index >= envPtr->auxDataArrayEnd) {
  7511.         /*
  7512.      * Expand the AuxData array. The currently allocated entries are
  7513.      * stored between elements 0 and (envPtr->auxDataArrayNext - 1)
  7514.      * [inclusive].
  7515.      */
  7516.     
  7517.     size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
  7518.     int newElems = 2*envPtr->auxDataArrayEnd;
  7519.     size_t newBytes = newElems * sizeof(AuxData);
  7520.     AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes);
  7521.     
  7522.     /*
  7523.      * Copy from old AuxData array to new, free old AuxData array if
  7524.      * needed, and mark the new AuxData array as malloced.
  7525.      */
  7526.     
  7527.     memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr,
  7528.             currBytes);
  7529.     if (envPtr->mallocedAuxDataArray) {
  7530.         ckfree((char *) envPtr->auxDataArrayPtr);
  7531.     }
  7532.     envPtr->auxDataArrayPtr = newPtr;
  7533.     envPtr->auxDataArrayEnd = newElems;
  7534.     envPtr->mallocedAuxDataArray = 1;
  7535.     }
  7536.     envPtr->auxDataArrayNext++;
  7537.     
  7538.     auxDataPtr = &(envPtr->auxDataArrayPtr[index]);
  7539.     auxDataPtr->clientData = clientData;
  7540.     auxDataPtr->dupProc  = dupProc;
  7541.     auxDataPtr->freeProc = freeProc;
  7542.     return index;
  7543. }
  7544.  
  7545. /*
  7546.  *----------------------------------------------------------------------
  7547.  *
  7548.  * TclInitJumpFixupArray --
  7549.  *
  7550.  *    Initializes a JumpFixupArray structure to hold some number of
  7551.  *    jump fixup entries.
  7552.  *
  7553.  * Results:
  7554.  *    None.
  7555.  *
  7556.  * Side effects:
  7557.  *    The JumpFixupArray structure is initialized.
  7558.  *
  7559.  *----------------------------------------------------------------------
  7560.  */
  7561.  
  7562. void
  7563. TclInitJumpFixupArray(fixupArrayPtr)
  7564.     register JumpFixupArray *fixupArrayPtr;
  7565.                  /* Points to the JumpFixupArray structure
  7566.                   * to initialize. */
  7567. {
  7568.     fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace;
  7569.     fixupArrayPtr->next = 0;
  7570.     fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1);
  7571.     fixupArrayPtr->mallocedArray = 0;
  7572. }
  7573.  
  7574. /*
  7575.  *----------------------------------------------------------------------
  7576.  *
  7577.  * TclExpandJumpFixupArray --
  7578.  *
  7579.  *    Procedure that uses malloc to allocate more storage for a
  7580.  *      jump fixup array.
  7581.  *
  7582.  * Results:
  7583.  *    None.
  7584.  *
  7585.  * Side effects:
  7586.  *    The jump fixup array in *fixupArrayPtr is reallocated to a new array
  7587.  *    of double the size, and if fixupArrayPtr->mallocedArray is non-zero
  7588.  *    the old array is freed. Jump fixup structures are copied from the
  7589.  *    old array to the new one.
  7590.  *
  7591.  *----------------------------------------------------------------------
  7592.  */
  7593.  
  7594. void
  7595. TclExpandJumpFixupArray(fixupArrayPtr)
  7596.     register JumpFixupArray *fixupArrayPtr;
  7597.                  /* Points to the JumpFixupArray structure
  7598.                   * to enlarge. */
  7599. {
  7600.     /*
  7601.      * The currently allocated jump fixup entries are stored from fixup[0]
  7602.      * up to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume
  7603.      * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd.
  7604.      */
  7605.  
  7606.     size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
  7607.     int newElems = 2*(fixupArrayPtr->end + 1);
  7608.     size_t newBytes = newElems * sizeof(JumpFixup);
  7609.     JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes);
  7610.  
  7611.     /*
  7612.      * Copy from the old array to new, free the old array if needed,
  7613.      * and mark the new array as malloced.
  7614.      */
  7615.  
  7616.     memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes);
  7617.     if (fixupArrayPtr->mallocedArray) {
  7618.     ckfree((char *) fixupArrayPtr->fixup);
  7619.     }
  7620.     fixupArrayPtr->fixup = (JumpFixup *) newPtr;
  7621.     fixupArrayPtr->end = newElems;
  7622.     fixupArrayPtr->mallocedArray = 1;
  7623. }
  7624.  
  7625. /*
  7626.  *----------------------------------------------------------------------
  7627.  *
  7628.  * TclFreeJumpFixupArray --
  7629.  *
  7630.  *    Free any storage allocated in a jump fixup array structure.
  7631.  *
  7632.  * Results:
  7633.  *    None.
  7634.  *
  7635.  * Side effects:
  7636.  *    Allocated storage in the JumpFixupArray structure is freed.
  7637.  *
  7638.  *----------------------------------------------------------------------
  7639.  */
  7640.  
  7641. void
  7642. TclFreeJumpFixupArray(fixupArrayPtr)
  7643.     register JumpFixupArray *fixupArrayPtr;
  7644.                  /* Points to the JumpFixupArray structure
  7645.                   * to free. */
  7646. {
  7647.     if (fixupArrayPtr->mallocedArray) {
  7648.     ckfree((char *) fixupArrayPtr->fixup);
  7649.     }
  7650. }
  7651.  
  7652. /*
  7653.  *----------------------------------------------------------------------
  7654.  *
  7655.  * TclEmitForwardJump --
  7656.  *
  7657.  *    Procedure to emit a two-byte forward jump of kind "jumpType". Since
  7658.  *    the jump may later have to be grown to five bytes if the jump target
  7659.  *    is more than, say, 127 bytes away, this procedure also initializes a
  7660.  *    JumpFixup record with information about the jump. 
  7661.  *
  7662.  * Results:
  7663.  *    None.
  7664.  *
  7665.  * Side effects:
  7666.  *    The JumpFixup record pointed to by "jumpFixupPtr" is initialized
  7667.  *    with information needed later if the jump is to be grown. Also,
  7668.  *    a two byte jump of the designated type is emitted at the current
  7669.  *    point in the bytecode stream.
  7670.  *
  7671.  *----------------------------------------------------------------------
  7672.  */
  7673.  
  7674. void
  7675. TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr)
  7676.     CompileEnv *envPtr;        /* Points to the CompileEnv structure that
  7677.                  * holds the resulting instruction. */
  7678.     TclJumpType jumpType;    /* Indicates the kind of jump: if true or
  7679.                  * false or unconditional. */
  7680.     JumpFixup *jumpFixupPtr;    /* Points to the JumpFixup structure to
  7681.                  * initialize with information about this
  7682.                  * forward jump. */
  7683. {
  7684.     /*
  7685.      * Initialize the JumpFixup structure:
  7686.      *    - codeOffset is offset of first byte of jump below
  7687.      *    - cmdIndex is index of the command after the current one
  7688.      *    - excRangeIndex is the index of the first ExceptionRange after
  7689.      *      the current one.
  7690.      */
  7691.     
  7692.     jumpFixupPtr->jumpType = jumpType;
  7693.     jumpFixupPtr->codeOffset = TclCurrCodeOffset();
  7694.     jumpFixupPtr->cmdIndex = envPtr->numCommands;
  7695.     jumpFixupPtr->excRangeIndex = envPtr->excRangeArrayNext;
  7696.     
  7697.     switch (jumpType) {
  7698.     case TCL_UNCONDITIONAL_JUMP:
  7699.     TclEmitInstInt1(INST_JUMP1, /*offset*/ 0, envPtr);
  7700.     break;
  7701.     case TCL_TRUE_JUMP:
  7702.     TclEmitInstInt1(INST_JUMP_TRUE1, /*offset*/ 0, envPtr);
  7703.     break;
  7704.     default:
  7705.     TclEmitInstInt1(INST_JUMP_FALSE1, /*offset*/ 0, envPtr);
  7706.     break;
  7707.     }
  7708. }
  7709.  
  7710. /*
  7711.  *----------------------------------------------------------------------
  7712.  *
  7713.  * TclFixupForwardJump --
  7714.  *
  7715.  *    Procedure that updates a previously-emitted forward jump to jump
  7716.  *    a specified number of bytes, "jumpDist". If necessary, the jump is
  7717.  *      grown from two to five bytes; this is done if the jump distance is
  7718.  *    greater than "distThreshold" (normally 127 bytes). The jump is
  7719.  *    described by a JumpFixup record previously initialized by
  7720.  *    TclEmitForwardJump.
  7721.  *
  7722.  * Results:
  7723.  *    1 if the jump was grown and subsequent instructions had to be moved;
  7724.  *    otherwise 0. This result is returned to allow callers to update
  7725.  *    any additional code offsets they may hold.
  7726.  *
  7727.  * Side effects:
  7728.  *    The jump may be grown and subsequent instructions moved. If this
  7729.  *    happens, the code offsets for any commands and any ExceptionRange
  7730.  *    records    between the jump and the current code address will be
  7731.  *    updated to reflect the moved code. Also, the bytecode instruction
  7732.  *    array in the CompileEnv structure may be grown and reallocated.
  7733.  *
  7734.  *----------------------------------------------------------------------
  7735.  */
  7736.  
  7737. int
  7738. TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
  7739.     CompileEnv *envPtr;        /* Points to the CompileEnv structure that
  7740.                  * holds the resulting instruction. */
  7741.     JumpFixup *jumpFixupPtr;    /* Points to the JumpFixup structure that
  7742.                  * describes the forward jump. */
  7743.     int jumpDist;        /* Jump distance to set in jump
  7744.                  * instruction. */
  7745.     int distThreshold;        /* Maximum distance before the two byte
  7746.                  * jump is grown to five bytes. */
  7747. {
  7748.     unsigned char *jumpPc, *p;
  7749.     int firstCmd, lastCmd, firstRange, lastRange, k;
  7750.     unsigned int numBytes;
  7751.     
  7752.     if (jumpDist <= distThreshold) {
  7753.     jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
  7754.     switch (jumpFixupPtr->jumpType) {
  7755.     case TCL_UNCONDITIONAL_JUMP:
  7756.         TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc);
  7757.         break;
  7758.     case TCL_TRUE_JUMP:
  7759.         TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc);
  7760.         break;
  7761.     default:
  7762.         TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc);
  7763.         break;
  7764.     }
  7765.     return 0;
  7766.     }
  7767.  
  7768.     /*
  7769.      * We must grow the jump then move subsequent instructions down.
  7770.      */
  7771.     
  7772.     TclEnsureCodeSpace(3, envPtr);  /* NB: might change code addresses! */
  7773.     jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
  7774.     for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1;
  7775.         numBytes > 0;  numBytes--, p--) {
  7776.     p[3] = p[0];
  7777.     }
  7778.     envPtr->codeNext += 3;
  7779.     jumpDist += 3;
  7780.     switch (jumpFixupPtr->jumpType) {
  7781.     case TCL_UNCONDITIONAL_JUMP:
  7782.     TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc);
  7783.     break;
  7784.     case TCL_TRUE_JUMP:
  7785.     TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc);
  7786.     break;
  7787.     default:
  7788.     TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc);
  7789.     break;
  7790.     }
  7791.     
  7792.     /*
  7793.      * Adjust the code offsets for any commands and any ExceptionRange
  7794.      * records between the jump and the current code address.
  7795.      */
  7796.     
  7797.     firstCmd = jumpFixupPtr->cmdIndex;
  7798.     lastCmd  = (envPtr->numCommands - 1);
  7799.     if (firstCmd < lastCmd) {
  7800.     for (k = firstCmd;  k <= lastCmd;  k++) {
  7801.         (envPtr->cmdMapPtr[k]).codeOffset += 3;
  7802.     }
  7803.     }
  7804.     
  7805.     firstRange = jumpFixupPtr->excRangeIndex;
  7806.     lastRange  = (envPtr->excRangeArrayNext - 1);
  7807.     for (k = firstRange;  k <= lastRange;  k++) {
  7808.     ExceptionRange *rangePtr = &(envPtr->excRangeArrayPtr[k]);
  7809.     rangePtr->codeOffset += 3;
  7810.     
  7811.     switch (rangePtr->type) {
  7812.     case LOOP_EXCEPTION_RANGE:
  7813.         rangePtr->breakOffset += 3;
  7814.         if (rangePtr->continueOffset != -1) {
  7815.         rangePtr->continueOffset += 3;
  7816.         }
  7817.         break;
  7818.     case CATCH_EXCEPTION_RANGE:
  7819.         rangePtr->catchOffset += 3;
  7820.         break;
  7821.     default:
  7822.         panic("TclFixupForwardJump: unrecognized ExceptionRange type %d\n", rangePtr->type);
  7823.     }
  7824.     }
  7825.     return 1;            /* the jump was grown */
  7826. }
  7827.  
  7828.  
  7829.