Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCompile.c@bde4ae8d615e (annotated)

sl@0	1	/*
sl@0	2	* tclCompile.c --
sl@0	3	*
sl@0	4	* This file contains procedures that compile Tcl commands or parts
sl@0	5	* of commands (like quoted strings or nested sub-commands) into a
sl@0	6	* sequence of instructions ("bytecodes").
sl@0	7	*
sl@0	8	* Copyright (c) 1996-1998 Sun Microsystems, Inc.
sl@0	9	* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
sl@0	10	* Portions Copyright (c) 2007 Nokia Corporation and/or its subsidiaries. All rights reserved.
sl@0	11	*
sl@0	12	* See the file "license.terms" for information on usage and redistribution
sl@0	13	* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0	14	*
sl@0	15	* RCS: @(#) $Id: tclCompile.c,v 1.43.2.7 2006/11/28 22:20:00 andreas_kupries Exp $
sl@0	16	*/
sl@0	17
sl@0	18	#include "tclInt.h"
sl@0	19	#include "tclCompile.h"
sl@0	20	#if defined(__SYMBIAN32__) && defined(__WINSCW__)
sl@0	21	#include "tclSymbianGlobals.h"
sl@0	22	#define dataKey getdataKey(0)
sl@0	23	#endif
sl@0	24
sl@0	25	#if !defined(__SYMBIAN32__) \|\| !defined(__WINSCW__)
sl@0	26	/*
sl@0	27	* Table of all AuxData types.
sl@0	28	*/
sl@0	29
sl@0	30	static Tcl_HashTable auxDataTypeTable;
sl@0	31	static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */
sl@0	32	#endif
sl@0	33	TCL_DECLARE_MUTEX(tableMutex)
sl@0	34
sl@0	35	/*
sl@0	36	* Variable that controls whether compilation tracing is enabled and, if so,
sl@0	37	* what level of tracing is desired:
sl@0	38	* 0: no compilation tracing
sl@0	39	* 1: summarize compilation of top level cmds and proc bodies
sl@0	40	* 2: display all instructions of each ByteCode compiled
sl@0	41	* This variable is linked to the Tcl variable "tcl_traceCompile".
sl@0	42	*/
sl@0	43
sl@0	44	#ifdef TCL_COMPILE_DEBUG
sl@0	45	int tclTraceCompile = 0;
sl@0	46	static int traceInitialized = 0;
sl@0	47	#endif
sl@0	48
sl@0	49	/*
sl@0	50	* A table describing the Tcl bytecode instructions. Entries in this table
sl@0	51	* must correspond to the instruction opcode definitions in tclCompile.h.
sl@0	52	* The names "op1" and "op4" refer to an instruction's one or four byte
sl@0	53	* first operand. Similarly, "stktop" and "stknext" refer to the topmost
sl@0	54	* and next to topmost stack elements.
sl@0	55	*
sl@0	56	* Note that the load, store, and incr instructions do not distinguish local
sl@0	57	* from global variables; the bytecode interpreter at runtime uses the
sl@0	58	* existence of a procedure call frame to distinguish these.
sl@0	59	*/
sl@0	60
sl@0	61	InstructionDesc tclInstructionTable[] = {
sl@0	62	/* Name Bytes stackEffect #Opnds Operand types Stack top, next */
sl@0	63	{"done", 1, -1, 0, {OPERAND_NONE}},
sl@0	64	/* Finish ByteCode execution and return stktop (top stack item) */
sl@0	65	{"push1", 2, +1, 1, {OPERAND_UINT1}},
sl@0	66	/* Push object at ByteCode objArray[op1] */
sl@0	67	{"push4", 5, +1, 1, {OPERAND_UINT4}},
sl@0	68	/* Push object at ByteCode objArray[op4] */
sl@0	69	{"pop", 1, -1, 0, {OPERAND_NONE}},
sl@0	70	/* Pop the topmost stack object */
sl@0	71	{"dup", 1, +1, 0, {OPERAND_NONE}},
sl@0	72	/* Duplicate the topmost stack object and push the result */
sl@0	73	{"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}},
sl@0	74	/* Concatenate the top op1 items and push result */
sl@0	75	{"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}},
sl@0	76	/* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */
sl@0	77	{"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}},
sl@0	78	/* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
sl@0	79	{"evalStk", 1, 0, 0, {OPERAND_NONE}},
sl@0	80	/* Evaluate command in stktop using Tcl_EvalObj. */
sl@0	81	{"exprStk", 1, 0, 0, {OPERAND_NONE}},
sl@0	82	/* Execute expression in stktop using Tcl_ExprStringObj. */
sl@0	83
sl@0	84	{"loadScalar1", 2, 1, 1, {OPERAND_UINT1}},
sl@0	85	/* Load scalar variable at index op1 <= 255 in call frame */
sl@0	86	{"loadScalar4", 5, 1, 1, {OPERAND_UINT4}},
sl@0	87	/* Load scalar variable at index op1 >= 256 in call frame */
sl@0	88	{"loadScalarStk", 1, 0, 0, {OPERAND_NONE}},
sl@0	89	/* Load scalar variable; scalar's name is stktop */
sl@0	90	{"loadArray1", 2, 0, 1, {OPERAND_UINT1}},
sl@0	91	/* Load array element; array at slot op1<=255, element is stktop */
sl@0	92	{"loadArray4", 5, 0, 1, {OPERAND_UINT4}},
sl@0	93	/* Load array element; array at slot op1 > 255, element is stktop */
sl@0	94	{"loadArrayStk", 1, -1, 0, {OPERAND_NONE}},
sl@0	95	/* Load array element; element is stktop, array name is stknext */
sl@0	96	{"loadStk", 1, 0, 0, {OPERAND_NONE}},
sl@0	97	/* Load general variable; unparsed variable name is stktop */
sl@0	98	{"storeScalar1", 2, 0, 1, {OPERAND_UINT1}},
sl@0	99	/* Store scalar variable at op1<=255 in frame; value is stktop */
sl@0	100	{"storeScalar4", 5, 0, 1, {OPERAND_UINT4}},
sl@0	101	/* Store scalar variable at op1 > 255 in frame; value is stktop */
sl@0	102	{"storeScalarStk", 1, -1, 0, {OPERAND_NONE}},
sl@0	103	/* Store scalar; value is stktop, scalar name is stknext */
sl@0	104	{"storeArray1", 2, -1, 1, {OPERAND_UINT1}},
sl@0	105	/* Store array element; array at op1<=255, value is top then elem */
sl@0	106	{"storeArray4", 5, -1, 1, {OPERAND_UINT4}},
sl@0	107	/* Store array element; array at op1>=256, value is top then elem */
sl@0	108	{"storeArrayStk", 1, -2, 0, {OPERAND_NONE}},
sl@0	109	/* Store array element; value is stktop, then elem, array names */
sl@0	110	{"storeStk", 1, -1, 0, {OPERAND_NONE}},
sl@0	111	/* Store general variable; value is stktop, then unparsed name */
sl@0	112
sl@0	113	{"incrScalar1", 2, 0, 1, {OPERAND_UINT1}},
sl@0	114	/* Incr scalar at index op1<=255 in frame; incr amount is stktop */
sl@0	115	{"incrScalarStk", 1, -1, 0, {OPERAND_NONE}},
sl@0	116	/* Incr scalar; incr amount is stktop, scalar's name is stknext */
sl@0	117	{"incrArray1", 2, -1, 1, {OPERAND_UINT1}},
sl@0	118	/* Incr array elem; arr at slot op1<=255, amount is top then elem */
sl@0	119	{"incrArrayStk", 1, -2, 0, {OPERAND_NONE}},
sl@0	120	/* Incr array element; amount is top then elem then array names */
sl@0	121	{"incrStk", 1, -1, 0, {OPERAND_NONE}},
sl@0	122	/* Incr general variable; amount is stktop then unparsed var name */
sl@0	123	{"incrScalar1Imm", 3, +1, 2, {OPERAND_UINT1, OPERAND_INT1}},
sl@0	124	/* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */
sl@0	125	{"incrScalarStkImm", 2, 0, 1, {OPERAND_INT1}},
sl@0	126	/* Incr scalar; scalar name is stktop; incr amount is op1 */
sl@0	127	{"incrArray1Imm", 3, 0, 2, {OPERAND_UINT1, OPERAND_INT1}},
sl@0	128	/* Incr array elem; array at slot op1 <= 255, elem is stktop,
sl@0	129	* amount is 2nd operand byte */
sl@0	130	{"incrArrayStkImm", 2, -1, 1, {OPERAND_INT1}},
sl@0	131	/* Incr array element; elem is top then array name, amount is op1 */
sl@0	132	{"incrStkImm", 2, 0, 1, {OPERAND_INT1}},
sl@0	133	/* Incr general variable; unparsed name is top, amount is op1 */
sl@0	134
sl@0	135	{"jump1", 2, 0, 1, {OPERAND_INT1}},
sl@0	136	/* Jump relative to (pc + op1) */
sl@0	137	{"jump4", 5, 0, 1, {OPERAND_INT4}},
sl@0	138	/* Jump relative to (pc + op4) */
sl@0	139	{"jumpTrue1", 2, -1, 1, {OPERAND_INT1}},
sl@0	140	/* Jump relative to (pc + op1) if stktop expr object is true */
sl@0	141	{"jumpTrue4", 5, -1, 1, {OPERAND_INT4}},
sl@0	142	/* Jump relative to (pc + op4) if stktop expr object is true */
sl@0	143	{"jumpFalse1", 2, -1, 1, {OPERAND_INT1}},
sl@0	144	/* Jump relative to (pc + op1) if stktop expr object is false */
sl@0	145	{"jumpFalse4", 5, -1, 1, {OPERAND_INT4}},
sl@0	146	/* Jump relative to (pc + op4) if stktop expr object is false */
sl@0	147
sl@0	148	{"lor", 1, -1, 0, {OPERAND_NONE}},
sl@0	149	/* Logical or: push (stknext \|\| stktop) */
sl@0	150	{"land", 1, -1, 0, {OPERAND_NONE}},
sl@0	151	/* Logical and: push (stknext && stktop) */
sl@0	152	{"bitor", 1, -1, 0, {OPERAND_NONE}},
sl@0	153	/* Bitwise or: push (stknext \| stktop) */
sl@0	154	{"bitxor", 1, -1, 0, {OPERAND_NONE}},
sl@0	155	/* Bitwise xor push (stknext ^ stktop) */
sl@0	156	{"bitand", 1, -1, 0, {OPERAND_NONE}},
sl@0	157	/* Bitwise and: push (stknext & stktop) */
sl@0	158	{"eq", 1, -1, 0, {OPERAND_NONE}},
sl@0	159	/* Equal: push (stknext == stktop) */
sl@0	160	{"neq", 1, -1, 0, {OPERAND_NONE}},
sl@0	161	/* Not equal: push (stknext != stktop) */
sl@0	162	{"lt", 1, -1, 0, {OPERAND_NONE}},
sl@0	163	/* Less: push (stknext < stktop) */
sl@0	164	{"gt", 1, -1, 0, {OPERAND_NONE}},
sl@0	165	/* Greater: push (stknext \|\| stktop) */
sl@0	166	{"le", 1, -1, 0, {OPERAND_NONE}},
sl@0	167	/* Logical or: push (stknext \|\| stktop) */
sl@0	168	{"ge", 1, -1, 0, {OPERAND_NONE}},
sl@0	169	/* Logical or: push (stknext \|\| stktop) */
sl@0	170	{"lshift", 1, -1, 0, {OPERAND_NONE}},
sl@0	171	/* Left shift: push (stknext << stktop) */
sl@0	172	{"rshift", 1, -1, 0, {OPERAND_NONE}},
sl@0	173	/* Right shift: push (stknext >> stktop) */
sl@0	174	{"add", 1, -1, 0, {OPERAND_NONE}},
sl@0	175	/* Add: push (stknext + stktop) */
sl@0	176	{"sub", 1, -1, 0, {OPERAND_NONE}},
sl@0	177	/* Sub: push (stkext - stktop) */
sl@0	178	{"mult", 1, -1, 0, {OPERAND_NONE}},
sl@0	179	/* Multiply: push (stknext * stktop) */
sl@0	180	{"div", 1, -1, 0, {OPERAND_NONE}},
sl@0	181	/* Divide: push (stknext / stktop) */
sl@0	182	{"mod", 1, -1, 0, {OPERAND_NONE}},
sl@0	183	/* Mod: push (stknext % stktop) */
sl@0	184	{"uplus", 1, 0, 0, {OPERAND_NONE}},
sl@0	185	/* Unary plus: push +stktop */
sl@0	186	{"uminus", 1, 0, 0, {OPERAND_NONE}},
sl@0	187	/* Unary minus: push -stktop */
sl@0	188	{"bitnot", 1, 0, 0, {OPERAND_NONE}},
sl@0	189	/* Bitwise not: push ~stktop */
sl@0	190	{"not", 1, 0, 0, {OPERAND_NONE}},
sl@0	191	/* Logical not: push !stktop */
sl@0	192	{"callBuiltinFunc1", 2, 1, 1, {OPERAND_UINT1}},
sl@0	193	/* Call builtin math function with index op1; any args are on stk */
sl@0	194	{"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}},
sl@0	195	/* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */
sl@0	196	{"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}},
sl@0	197	/* Try converting stktop to first int then double if possible. */
sl@0	198
sl@0	199	{"break", 1, 0, 0, {OPERAND_NONE}},
sl@0	200	/* Abort closest enclosing loop; if none, return TCL_BREAK code. */
sl@0	201	{"continue", 1, 0, 0, {OPERAND_NONE}},
sl@0	202	/* Skip to next iteration of closest enclosing loop; if none,
sl@0	203	* return TCL_CONTINUE code. */
sl@0	204
sl@0	205	{"foreach_start4", 5, 0, 1, {OPERAND_UINT4}},
sl@0	206	/* Initialize execution of a foreach loop. Operand is aux data index
sl@0	207	* of the ForeachInfo structure for the foreach command. */
sl@0	208	{"foreach_step4", 5, +1, 1, {OPERAND_UINT4}},
sl@0	209	/* "Step" or begin next iteration of foreach loop. Push 0 if to
sl@0	210	* terminate loop, else push 1. */
sl@0	211
sl@0	212	{"beginCatch4", 5, 0, 1, {OPERAND_UINT4}},
sl@0	213	/* Record start of catch with the operand's exception index.
sl@0	214	* Push the current stack depth onto a special catch stack. */
sl@0	215	{"endCatch", 1, 0, 0, {OPERAND_NONE}},
sl@0	216	/* End of last catch. Pop the bytecode interpreter's catch stack. */
sl@0	217	{"pushResult", 1, +1, 0, {OPERAND_NONE}},
sl@0	218	/* Push the interpreter's object result onto the stack. */
sl@0	219	{"pushReturnCode", 1, +1, 0, {OPERAND_NONE}},
sl@0	220	/* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as
sl@0	221	* a new object onto the stack. */
sl@0	222	{"streq", 1, -1, 0, {OPERAND_NONE}},
sl@0	223	/* Str Equal: push (stknext eq stktop) */
sl@0	224	{"strneq", 1, -1, 0, {OPERAND_NONE}},
sl@0	225	/* Str !Equal: push (stknext neq stktop) */
sl@0	226	{"strcmp", 1, -1, 0, {OPERAND_NONE}},
sl@0	227	/* Str Compare: push (stknext cmp stktop) */
sl@0	228	{"strlen", 1, 0, 0, {OPERAND_NONE}},
sl@0	229	/* Str Length: push (strlen stktop) */
sl@0	230	{"strindex", 1, -1, 0, {OPERAND_NONE}},
sl@0	231	/* Str Index: push (strindex stknext stktop) */
sl@0	232	{"strmatch", 2, -1, 1, {OPERAND_INT1}},
sl@0	233	/* Str Match: push (strmatch stknext stktop) opnd == nocase */
sl@0	234	{"list", 5, INT_MIN, 1, {OPERAND_UINT4}},
sl@0	235	/* List: push (stk1 stk2 ... stktop) */
sl@0	236	{"listindex", 1, -1, 0, {OPERAND_NONE}},
sl@0	237	/* List Index: push (listindex stknext stktop) */
sl@0	238	{"listlength", 1, 0, 0, {OPERAND_NONE}},
sl@0	239	/* List Len: push (listlength stktop) */
sl@0	240	{"appendScalar1", 2, 0, 1, {OPERAND_UINT1}},
sl@0	241	/* Append scalar variable at op1<=255 in frame; value is stktop */
sl@0	242	{"appendScalar4", 5, 0, 1, {OPERAND_UINT4}},
sl@0	243	/* Append scalar variable at op1 > 255 in frame; value is stktop */
sl@0	244	{"appendArray1", 2, -1, 1, {OPERAND_UINT1}},
sl@0	245	/* Append array element; array at op1<=255, value is top then elem */
sl@0	246	{"appendArray4", 5, -1, 1, {OPERAND_UINT4}},
sl@0	247	/* Append array element; array at op1>=256, value is top then elem */
sl@0	248	{"appendArrayStk", 1, -2, 0, {OPERAND_NONE}},
sl@0	249	/* Append array element; value is stktop, then elem, array names */
sl@0	250	{"appendStk", 1, -1, 0, {OPERAND_NONE}},
sl@0	251	/* Append general variable; value is stktop, then unparsed name */
sl@0	252	{"lappendScalar1", 2, 0, 1, {OPERAND_UINT1}},
sl@0	253	/* Lappend scalar variable at op1<=255 in frame; value is stktop */
sl@0	254	{"lappendScalar4", 5, 0, 1, {OPERAND_UINT4}},
sl@0	255	/* Lappend scalar variable at op1 > 255 in frame; value is stktop */
sl@0	256	{"lappendArray1", 2, -1, 1, {OPERAND_UINT1}},
sl@0	257	/* Lappend array element; array at op1<=255, value is top then elem */
sl@0	258	{"lappendArray4", 5, -1, 1, {OPERAND_UINT4}},
sl@0	259	/* Lappend array element; array at op1>=256, value is top then elem */
sl@0	260	{"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}},
sl@0	261	/* Lappend array element; value is stktop, then elem, array names */
sl@0	262	{"lappendStk", 1, -1, 0, {OPERAND_NONE}},
sl@0	263	/* Lappend general variable; value is stktop, then unparsed name */
sl@0	264	{"lindexMulti", 5, INT_MIN, 1, {OPERAND_UINT4}},
sl@0	265	/* Lindex with generalized args, operand is number of stacked objs
sl@0	266	* used: (operand-1) entries from stktop are the indices; then list
sl@0	267	* to process. */
sl@0	268	{"over", 5, +1, 1, {OPERAND_UINT4}},
sl@0	269	/* Duplicate the arg-th element from top of stack (TOS=0) */
sl@0	270	{"lsetList", 1, -2, 0, {OPERAND_NONE}},
sl@0	271	/* Four-arg version of 'lset'. stktop is old value; next is
sl@0	272	* new element value, next is the index list; pushes new value */
sl@0	273	{"lsetFlat", 5, INT_MIN, 1, {OPERAND_UINT4}},
sl@0	274	/* Three- or >=5-arg version of 'lset', operand is number of
sl@0	275	* stacked objs: stktop is old value, next is new element value, next
sl@0	276	* come (operand-2) indices; pushes the new value.
sl@0	277	*/
sl@0	278	{0}
sl@0	279	};
sl@0	280
sl@0	281	/*
sl@0	282	* Prototypes for procedures defined later in this file:
sl@0	283	*/
sl@0	284
sl@0	285	static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
sl@0	286	Tcl_Obj *copyPtr));
sl@0	287	static unsigned char * EncodeCmdLocMap _ANSI_ARGS_((
sl@0	288	CompileEnv envPtr, ByteCode codePtr,
sl@0	289	unsigned char *startPtr));
sl@0	290	static void EnterCmdExtentData _ANSI_ARGS_((
sl@0	291	CompileEnv *envPtr, int cmdNumber,
sl@0	292	int numSrcBytes, int numCodeBytes));
sl@0	293	static void EnterCmdStartData _ANSI_ARGS_((
sl@0	294	CompileEnv *envPtr, int cmdNumber,
sl@0	295	int srcOffset, int codeOffset));
sl@0	296	static void FreeByteCodeInternalRep _ANSI_ARGS_((
sl@0	297	Tcl_Obj *objPtr));
sl@0	298	static int GetCmdLocEncodingSize _ANSI_ARGS_((
sl@0	299	CompileEnv *envPtr));
sl@0	300	static void LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	301	CONST char script, CONST char command,
sl@0	302	int length));
sl@0	303	#ifdef TCL_COMPILE_STATS
sl@0	304	static void RecordByteCodeStats _ANSI_ARGS_((
sl@0	305	ByteCode *codePtr));
sl@0	306	#endif /* TCL_COMPILE_STATS */
sl@0	307	static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	308	Tcl_Obj *objPtr));
sl@0	309
sl@0	310	#ifdef TCL_TIP280
sl@0	311	/* TIP #280 : Helper for building the per-word line information of all
sl@0	312	* compiled commands */
sl@0	313	static void EnterCmdWordData _ANSI_ARGS_((
sl@0	314	ExtCmdLoc eclPtr, int srcOffset, Tcl_Token tokenPtr,
sl@0	315	CONST char* cmd, int len, int numWords, int line,
sl@0	316	int** lines));
sl@0	317	#endif
sl@0	318
sl@0	319
sl@0	320	/*
sl@0	321	* The structure below defines the bytecode Tcl object type by
sl@0	322	* means of procedures that can be invoked by generic object code.
sl@0	323	*/
sl@0	324
sl@0	325	Tcl_ObjType tclByteCodeType = {
sl@0	326	"bytecode", /* name */
sl@0	327	FreeByteCodeInternalRep, /* freeIntRepProc */
sl@0	328	DupByteCodeInternalRep, /* dupIntRepProc */
sl@0	329	(Tcl_UpdateStringProc ) NULL, / updateStringProc */
sl@0	330	SetByteCodeFromAny /* setFromAnyProc */
sl@0	331	};
sl@0	332
sl@0	333	/*
sl@0	334	*----------------------------------------------------------------------
sl@0	335	*
sl@0	336	* TclSetByteCodeFromAny --
sl@0	337	*
sl@0	338	* Part of the bytecode Tcl object type implementation. Attempts to
sl@0	339	* generate an byte code internal form for the Tcl object "objPtr" by
sl@0	340	* compiling its string representation. This function also takes
sl@0	341	* a hook procedure that will be invoked to perform any needed post
sl@0	342	* processing on the compilation results before generating byte
sl@0	343	* codes.
sl@0	344	*
sl@0	345	* Results:
sl@0	346	* The return value is a standard Tcl object result. If an error occurs
sl@0	347	* during compilation, an error message is left in the interpreter's
sl@0	348	* result unless "interp" is NULL.
sl@0	349	*
sl@0	350	* Side effects:
sl@0	351	* Frees the old internal representation. If no error occurs, then the
sl@0	352	* compiled code is stored as "objPtr"s bytecode representation.
sl@0	353	* Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
sl@0	354	* used to trace compilations.
sl@0	355	*
sl@0	356	*----------------------------------------------------------------------
sl@0	357	*/
sl@0	358
sl@0	359	int
sl@0	360	TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData)
sl@0	361	Tcl_Interp interp; / The interpreter for which the code is
sl@0	362	* being compiled. Must not be NULL. */
sl@0	363	Tcl_Obj objPtr; / The object to make a ByteCode object. */
sl@0	364	CompileHookProc hookProc; / Procedure to invoke after compilation. */
sl@0	365	ClientData clientData; /* Hook procedure private data. */
sl@0	366	{
sl@0	367	Interp iPtr = (Interp ) interp;
sl@0	368	CompileEnv compEnv; /* Compilation environment structure
sl@0	369	* allocated in frame. */
sl@0	370	LiteralTable *localTablePtr = &(compEnv.localLitTable);
sl@0	371	register AuxData *auxDataPtr;
sl@0	372	LiteralEntry *entryPtr;
sl@0	373	register int i;
sl@0	374	int length, nested, result;
sl@0	375	char *string;
sl@0	376
sl@0	377	#ifdef TCL_COMPILE_DEBUG
sl@0	378	if (!traceInitialized) {
sl@0	379	if (Tcl_LinkVar(interp, "tcl_traceCompile",
sl@0	380	(char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
sl@0	381	panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
sl@0	382	}
sl@0	383	traceInitialized = 1;
sl@0	384	}
sl@0	385	#endif
sl@0	386
sl@0	387	if (iPtr->evalFlags & TCL_BRACKET_TERM) {
sl@0	388	nested = 1;
sl@0	389	} else {
sl@0	390	nested = 0;
sl@0	391	}
sl@0	392	string = Tcl_GetStringFromObj(objPtr, &length);
sl@0	393	#ifndef TCL_TIP280
sl@0	394	TclInitCompileEnv(interp, &compEnv, string, length);
sl@0	395	#else
sl@0	396	/*
sl@0	397	* TIP #280. Pick up the CmdFrame in which the BC compiler was invoked
sl@0	398	* and use to initialize the tracking in the compiler. This information
sl@0	399	* was stored by TclCompEvalObj (tclExecute.c), and ProcCompileProc
sl@0	400	* (tclProc.c).
sl@0	401	*/
sl@0	402
sl@0	403	TclInitCompileEnv(interp, &compEnv, string, length,
sl@0	404	iPtr->invokeCmdFramePtr, iPtr->invokeWord);
sl@0	405	#endif
sl@0	406	result = TclCompileScript(interp, string, length, nested, &compEnv);
sl@0	407
sl@0	408	if (result == TCL_OK) {
sl@0	409	/*
sl@0	410	* Successful compilation. Add a "done" instruction at the end.
sl@0	411	*/
sl@0	412
sl@0	413	compEnv.numSrcBytes = iPtr->termOffset;
sl@0	414	TclEmitOpcode(INST_DONE, &compEnv);
sl@0	415
sl@0	416	/*
sl@0	417	* Invoke the compilation hook procedure if one exists.
sl@0	418	*/
sl@0	419
sl@0	420	if (hookProc) {
sl@0	421	result = (*hookProc)(interp, &compEnv, clientData);
sl@0	422	}
sl@0	423
sl@0	424	/*
sl@0	425	* Change the object into a ByteCode object. Ownership of the literal
sl@0	426	* objects and aux data items is given to the ByteCode object.
sl@0	427	*/
sl@0	428
sl@0	429	#ifdef TCL_COMPILE_DEBUG
sl@0	430	TclVerifyLocalLiteralTable(&compEnv);
sl@0	431	#endif /TCL_COMPILE_DEBUG/
sl@0	432
sl@0	433	TclInitByteCodeObj(objPtr, &compEnv);
sl@0	434	#ifdef TCL_COMPILE_DEBUG
sl@0	435	if (tclTraceCompile >= 2) {
sl@0	436	TclPrintByteCodeObj(interp, objPtr);
sl@0	437	}
sl@0	438	#endif /* TCL_COMPILE_DEBUG */
sl@0	439	}
sl@0	440
sl@0	441	if (result != TCL_OK) {
sl@0	442	/*
sl@0	443	* Compilation errors.
sl@0	444	*/
sl@0	445
sl@0	446	entryPtr = compEnv.literalArrayPtr;
sl@0	447	for (i = 0; i < compEnv.literalArrayNext; i++) {
sl@0	448	TclReleaseLiteral(interp, entryPtr->objPtr);
sl@0	449	entryPtr++;
sl@0	450	}
sl@0	451	#ifdef TCL_COMPILE_DEBUG
sl@0	452	TclVerifyGlobalLiteralTable(iPtr);
sl@0	453	#endif /TCL_COMPILE_DEBUG/
sl@0	454
sl@0	455	auxDataPtr = compEnv.auxDataArrayPtr;
sl@0	456	for (i = 0; i < compEnv.auxDataArrayNext; i++) {
sl@0	457	if (auxDataPtr->type->freeProc != NULL) {
sl@0	458	auxDataPtr->type->freeProc(auxDataPtr->clientData);
sl@0	459	}
sl@0	460	auxDataPtr++;
sl@0	461	}
sl@0	462	}
sl@0	463
sl@0	464
sl@0	465	/*
sl@0	466	* Free storage allocated during compilation.
sl@0	467	*/
sl@0	468
sl@0	469	if (localTablePtr->buckets != localTablePtr->staticBuckets) {
sl@0	470	ckfree((char *) localTablePtr->buckets);
sl@0	471	}
sl@0	472	TclFreeCompileEnv(&compEnv);
sl@0	473	return result;
sl@0	474	}
sl@0	475
sl@0	476	/*
sl@0	477	*-----------------------------------------------------------------------
sl@0	478	*
sl@0	479	* SetByteCodeFromAny --
sl@0	480	*
sl@0	481	* Part of the bytecode Tcl object type implementation. Attempts to
sl@0	482	* generate an byte code internal form for the Tcl object "objPtr" by
sl@0	483	* compiling its string representation.
sl@0	484	*
sl@0	485	* Results:
sl@0	486	* The return value is a standard Tcl object result. If an error occurs
sl@0	487	* during compilation, an error message is left in the interpreter's
sl@0	488	* result unless "interp" is NULL.
sl@0	489	*
sl@0	490	* Side effects:
sl@0	491	* Frees the old internal representation. If no error occurs, then the
sl@0	492	* compiled code is stored as "objPtr"s bytecode representation.
sl@0	493	* Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
sl@0	494	* used to trace compilations.
sl@0	495	*
sl@0	496	*----------------------------------------------------------------------
sl@0	497	*/
sl@0	498
sl@0	499	static int
sl@0	500	SetByteCodeFromAny(interp, objPtr)
sl@0	501	Tcl_Interp interp; / The interpreter for which the code is
sl@0	502	* being compiled. Must not be NULL. */
sl@0	503	Tcl_Obj objPtr; / The object to make a ByteCode object. */
sl@0	504	{
sl@0	505	return TclSetByteCodeFromAny(interp, objPtr,
sl@0	506	(CompileHookProc *) NULL, (ClientData) NULL);
sl@0	507	}
sl@0	508
sl@0	509	/*
sl@0	510	*----------------------------------------------------------------------
sl@0	511	*
sl@0	512	* DupByteCodeInternalRep --
sl@0	513	*
sl@0	514	* Part of the bytecode Tcl object type implementation. However, it
sl@0	515	* does not copy the internal representation of a bytecode Tcl_Obj, but
sl@0	516	* instead leaves the new object untyped (with a NULL type pointer).
sl@0	517	* Code will be compiled for the new object only if necessary.
sl@0	518	*
sl@0	519	* Results:
sl@0	520	* None.
sl@0	521	*
sl@0	522	* Side effects:
sl@0	523	* None.
sl@0	524	*
sl@0	525	*----------------------------------------------------------------------
sl@0	526	*/
sl@0	527
sl@0	528	static void
sl@0	529	DupByteCodeInternalRep(srcPtr, copyPtr)
sl@0	530	Tcl_Obj srcPtr; / Object with internal rep to copy. */
sl@0	531	Tcl_Obj copyPtr; / Object with internal rep to set. */
sl@0	532	{
sl@0	533	return;
sl@0	534	}
sl@0	535
sl@0	536	/*
sl@0	537	*----------------------------------------------------------------------
sl@0	538	*
sl@0	539	* FreeByteCodeInternalRep --
sl@0	540	*
sl@0	541	* Part of the bytecode Tcl object type implementation. Frees the
sl@0	542	* storage associated with a bytecode object's internal representation
sl@0	543	* unless its code is actively being executed.
sl@0	544	*
sl@0	545	* Results:
sl@0	546	* None.
sl@0	547	*
sl@0	548	* Side effects:
sl@0	549	* The bytecode object's internal rep is marked invalid and its
sl@0	550	* code gets freed unless the code is actively being executed.
sl@0	551	* In that case the cleanup is delayed until the last execution
sl@0	552	* of the code completes.
sl@0	553	*
sl@0	554	*----------------------------------------------------------------------
sl@0	555	*/
sl@0	556
sl@0	557	static void
sl@0	558	FreeByteCodeInternalRep(objPtr)
sl@0	559	register Tcl_Obj objPtr; / Object whose internal rep to free. */
sl@0	560	{
sl@0	561	register ByteCode *codePtr =
sl@0	562	(ByteCode *) objPtr->internalRep.otherValuePtr;
sl@0	563
sl@0	564	codePtr->refCount--;
sl@0	565	if (codePtr->refCount <= 0) {
sl@0	566	TclCleanupByteCode(codePtr);
sl@0	567	}
sl@0	568	objPtr->typePtr = NULL;
sl@0	569	objPtr->internalRep.otherValuePtr = NULL;
sl@0	570	}
sl@0	571
sl@0	572	/*
sl@0	573	*----------------------------------------------------------------------
sl@0	574	*
sl@0	575	* TclCleanupByteCode --
sl@0	576	*
sl@0	577	* This procedure does all the real work of freeing up a bytecode
sl@0	578	* object's ByteCode structure. It's called only when the structure's
sl@0	579	* reference count becomes zero.
sl@0	580	*
sl@0	581	* Results:
sl@0	582	* None.
sl@0	583	*
sl@0	584	* Side effects:
sl@0	585	* Frees objPtr's bytecode internal representation and sets its type
sl@0	586	* and objPtr->internalRep.otherValuePtr NULL. Also releases its
sl@0	587	* literals and frees its auxiliary data items.
sl@0	588	*
sl@0	589	*----------------------------------------------------------------------
sl@0	590	*/
sl@0	591
sl@0	592	void
sl@0	593	TclCleanupByteCode(codePtr)
sl@0	594	register ByteCode codePtr; / Points to the ByteCode to free. */
sl@0	595	{
sl@0	596	Tcl_Interp interp = (Tcl_Interp ) *codePtr->interpHandle;
sl@0	597	#ifdef TCL_TIP280
sl@0	598	Interp* iPtr = (Interp*) interp;
sl@0	599	#endif
sl@0	600	int numLitObjects = codePtr->numLitObjects;
sl@0	601	int numAuxDataItems = codePtr->numAuxDataItems;
sl@0	602	register Tcl_Obj **objArrayPtr;
sl@0	603	register AuxData *auxDataPtr;
sl@0	604	int i;
sl@0	605	#ifdef TCL_COMPILE_STATS
sl@0	606
sl@0	607	if (interp != NULL) {
sl@0	608	ByteCodeStats *statsPtr;
sl@0	609	Tcl_Time destroyTime;
sl@0	610	int lifetimeSec, lifetimeMicroSec, log2;
sl@0	611
sl@0	612	statsPtr = &((Interp *) interp)->stats;
sl@0	613
sl@0	614	statsPtr->numByteCodesFreed++;
sl@0	615	statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes;
sl@0	616	statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize;
sl@0	617
sl@0	618	statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes;
sl@0	619	statsPtr->currentLitBytes -=
sl@0	620	(double) (codePtr->numLitObjects * sizeof(Tcl_Obj *));
sl@0	621	statsPtr->currentExceptBytes -=
sl@0	622	(double) (codePtr->numExceptRanges * sizeof(ExceptionRange));
sl@0	623	statsPtr->currentAuxBytes -=
sl@0	624	(double) (codePtr->numAuxDataItems * sizeof(AuxData));
sl@0	625	statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes;
sl@0	626
sl@0	627	Tcl_GetTime(&destroyTime);
sl@0	628	lifetimeSec = destroyTime.sec - codePtr->createTime.sec;
sl@0	629	if (lifetimeSec > 2000) { /* avoid overflow */
sl@0	630	lifetimeSec = 2000;
sl@0	631	}
sl@0	632	lifetimeMicroSec =
sl@0	633	1000000*lifetimeSec + (destroyTime.usec - codePtr->createTime.usec);
sl@0	634
sl@0	635	log2 = TclLog2(lifetimeMicroSec);
sl@0	636	if (log2 > 31) {
sl@0	637	log2 = 31;
sl@0	638	}
sl@0	639	statsPtr->lifetimeCount[log2]++;
sl@0	640	}
sl@0	641	#endif /* TCL_COMPILE_STATS */
sl@0	642
sl@0	643	/*
sl@0	644	* A single heap object holds the ByteCode structure and its code,
sl@0	645	* object, command location, and auxiliary data arrays. This means we
sl@0	646	* only need to 1) decrement the ref counts of the LiteralEntry's in
sl@0	647	* its literal array, 2) call the free procs for the auxiliary data
sl@0	648	* items, and 3) free the ByteCode structure's heap object.
sl@0	649	*
sl@0	650	* The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes,
sl@0	651	* like those generated from tbcload) is special, as they doesn't
sl@0	652	* make use of the global literal table. They instead maintain
sl@0	653	* private references to their literals which must be decremented.
sl@0	654	*/
sl@0	655
sl@0	656	if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
sl@0	657	register Tcl_Obj *objPtr;
sl@0	658
sl@0	659	objArrayPtr = codePtr->objArrayPtr;
sl@0	660	for (i = 0; i < numLitObjects; i++) {
sl@0	661	objPtr = *objArrayPtr;
sl@0	662	if (objPtr) {
sl@0	663	Tcl_DecrRefCount(objPtr);
sl@0	664	}
sl@0	665	objArrayPtr++;
sl@0	666	}
sl@0	667	codePtr->numLitObjects = 0;
sl@0	668	} else if (interp != NULL) {
sl@0	669	/*
sl@0	670	* If the interp has already been freed, then Tcl will have already
sl@0	671	* forcefully released all the literals used by ByteCodes compiled
sl@0	672	* with respect to that interp.
sl@0	673	*/
sl@0	674
sl@0	675	objArrayPtr = codePtr->objArrayPtr;
sl@0	676	for (i = 0; i < numLitObjects; i++) {
sl@0	677	/*
sl@0	678	* TclReleaseLiteral sets a ByteCode's object array entry NULL to
sl@0	679	* indicate that it has already freed the literal.
sl@0	680	*/
sl@0	681
sl@0	682	if (*objArrayPtr != NULL) {
sl@0	683	TclReleaseLiteral(interp, *objArrayPtr);
sl@0	684	}
sl@0	685	objArrayPtr++;
sl@0	686	}
sl@0	687	}
sl@0	688
sl@0	689	auxDataPtr = codePtr->auxDataArrayPtr;
sl@0	690	for (i = 0; i < numAuxDataItems; i++) {
sl@0	691	if (auxDataPtr->type->freeProc != NULL) {
sl@0	692	(*auxDataPtr->type->freeProc)(auxDataPtr->clientData);
sl@0	693	}
sl@0	694	auxDataPtr++;
sl@0	695	}
sl@0	696
sl@0	697	#ifdef TCL_TIP280
sl@0	698	/*
sl@0	699	* TIP #280. Release the location data associated with this byte code
sl@0	700	* structure, if any. NOTE: The interp we belong to may be gone already,
sl@0	701	* and the data with it.
sl@0	702	*
sl@0	703	* See also tclBasic.c, DeleteInterpProc
sl@0	704	*/
sl@0	705
sl@0	706	if (iPtr) {
sl@0	707	Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);
sl@0	708	if (hePtr) {
sl@0	709	ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
sl@0	710	int i;
sl@0	711
sl@0	712	if (eclPtr->type == TCL_LOCATION_SOURCE) {
sl@0	713	Tcl_DecrRefCount (eclPtr->path);
sl@0	714	}
sl@0	715	for (i=0; i< eclPtr->nuloc; i++) {
sl@0	716	ckfree ((char*) eclPtr->loc[i].line);
sl@0	717	}
sl@0	718
sl@0	719	if (eclPtr->loc != NULL) {
sl@0	720	ckfree ((char*) eclPtr->loc);
sl@0	721	}
sl@0	722
sl@0	723	ckfree ((char*) eclPtr);
sl@0	724	Tcl_DeleteHashEntry (hePtr);
sl@0	725	}
sl@0	726	}
sl@0	727	#endif
sl@0	728
sl@0	729	TclHandleRelease(codePtr->interpHandle);
sl@0	730	ckfree((char *) codePtr);
sl@0	731	}
sl@0	732
sl@0	733	/*
sl@0	734	*----------------------------------------------------------------------
sl@0	735	*
sl@0	736	* TclInitCompileEnv --
sl@0	737	*
sl@0	738	* Initializes a CompileEnv compilation environment structure for the
sl@0	739	* compilation of a string in an interpreter.
sl@0	740	*
sl@0	741	* Results:
sl@0	742	* None.
sl@0	743	*
sl@0	744	* Side effects:
sl@0	745	* The CompileEnv structure is initialized.
sl@0	746	*
sl@0	747	*----------------------------------------------------------------------
sl@0	748	*/
sl@0	749
sl@0	750	void
sl@0	751	#ifndef TCL_TIP280
sl@0	752	TclInitCompileEnv(interp, envPtr, string, numBytes)
sl@0	753	#else
sl@0	754	TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word)
sl@0	755	#endif
sl@0	756	Tcl_Interp interp; / The interpreter for which a CompileEnv
sl@0	757	* structure is initialized. */
sl@0	758	register CompileEnv envPtr; / Points to the CompileEnv structure to
sl@0	759	* initialize. */
sl@0	760	char string; / The source string to be compiled. */
sl@0	761	int numBytes; /* Number of bytes in source string. */
sl@0	762	#ifdef TCL_TIP280
sl@0	763	CONST CmdFrame* invoker; /* Location context invoking the bcc */
sl@0	764	int word; /* Index of the word in that context
sl@0	765	* getting compiled */
sl@0	766	#endif
sl@0	767	{
sl@0	768	Interp iPtr = (Interp ) interp;
sl@0	769
sl@0	770	envPtr->iPtr = iPtr;
sl@0	771	envPtr->source = string;
sl@0	772	envPtr->numSrcBytes = numBytes;
sl@0	773	envPtr->procPtr = iPtr->compiledProcPtr;
sl@0	774	envPtr->numCommands = 0;
sl@0	775	envPtr->exceptDepth = 0;
sl@0	776	envPtr->maxExceptDepth = 0;
sl@0	777	envPtr->maxStackDepth = 0;
sl@0	778	envPtr->currStackDepth = 0;
sl@0	779	TclInitLiteralTable(&(envPtr->localLitTable));
sl@0	780
sl@0	781	envPtr->codeStart = envPtr->staticCodeSpace;
sl@0	782	envPtr->codeNext = envPtr->codeStart;
sl@0	783	envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES);
sl@0	784	envPtr->mallocedCodeArray = 0;
sl@0	785
sl@0	786	envPtr->literalArrayPtr = envPtr->staticLiteralSpace;
sl@0	787	envPtr->literalArrayNext = 0;
sl@0	788	envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS;
sl@0	789	envPtr->mallocedLiteralArray = 0;
sl@0	790
sl@0	791	envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace;
sl@0	792	envPtr->exceptArrayNext = 0;
sl@0	793	envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
sl@0	794	envPtr->mallocedExceptArray = 0;
sl@0	795
sl@0	796	envPtr->cmdMapPtr = envPtr->staticCmdMapSpace;
sl@0	797	envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
sl@0	798	envPtr->mallocedCmdMap = 0;
sl@0	799
sl@0	800	#ifdef TCL_TIP280
sl@0	801	/*
sl@0	802	* TIP #280: Set up the extended command location information, based on
sl@0	803	* the context invoking the byte code compiler. This structure is used to
sl@0	804	* keep the per-word line information for all compiled commands.
sl@0	805	*
sl@0	806	* See also tclBasic.c, TclEvalObjEx, for the equivalent code in the
sl@0	807	* non-compiling evaluator
sl@0	808	*/
sl@0	809
sl@0	810	envPtr->extCmdMapPtr = (ExtCmdLoc*) ckalloc (sizeof (ExtCmdLoc));
sl@0	811	envPtr->extCmdMapPtr->loc = NULL;
sl@0	812	envPtr->extCmdMapPtr->nloc = 0;
sl@0	813	envPtr->extCmdMapPtr->nuloc = 0;
sl@0	814	envPtr->extCmdMapPtr->path = NULL;
sl@0	815
sl@0	816	if (invoker == NULL) {
sl@0	817	/* Initialize the compiler for relative counting */
sl@0	818
sl@0	819	envPtr->line = 1;
sl@0	820	envPtr->extCmdMapPtr->type = (envPtr->procPtr
sl@0	821	? TCL_LOCATION_PROC
sl@0	822	: TCL_LOCATION_BC);
sl@0	823	} else {
sl@0	824	/* Initialize the compiler using the context, making counting absolute
sl@0	825	* to that context. Note that the context can be byte code
sl@0	826	* execution. In that case we have to fill out the missing pieces
sl@0	827	* (line, path, ...). Which may make change the type as well.
sl@0	828	*/
sl@0	829
sl@0	830	if ((invoker->nline <= word) \|\| (invoker->line[word] < 0)) {
sl@0	831	/* Word is not a literal, relative counting */
sl@0	832
sl@0	833	envPtr->line = 1;
sl@0	834	envPtr->extCmdMapPtr->type = (envPtr->procPtr
sl@0	835	? TCL_LOCATION_PROC
sl@0	836	: TCL_LOCATION_BC);
sl@0	837	} else {
sl@0	838	CmdFrame ctx = *invoker;
sl@0	839	int pc = 0;
sl@0	840
sl@0	841	if (invoker->type == TCL_LOCATION_BC) {
sl@0	842	/* Note: Type BC => ctx.data.eval.path is not used.
sl@0	843	* ctx.data.tebc.codePtr is used instead.
sl@0	844	*/
sl@0	845	TclGetSrcInfoForPc (&ctx);
sl@0	846	pc = 1;
sl@0	847	}
sl@0	848
sl@0	849	envPtr->line = ctx.line [word];
sl@0	850	envPtr->extCmdMapPtr->type = ctx.type;
sl@0	851
sl@0	852	if (ctx.type == TCL_LOCATION_SOURCE) {
sl@0	853	if (pc) {
sl@0	854	/* The reference 'TclGetSrcInfoForPc' made is transfered */
sl@0	855	envPtr->extCmdMapPtr->path = ctx.data.eval.path;
sl@0	856	ctx.data.eval.path = NULL;
sl@0	857	} else {
sl@0	858	/* We have a new reference here */
sl@0	859	envPtr->extCmdMapPtr->path = ctx.data.eval.path;
sl@0	860	Tcl_IncrRefCount (envPtr->extCmdMapPtr->path);
sl@0	861	}
sl@0	862	}
sl@0	863	}
sl@0	864	}
sl@0	865	#endif
sl@0	866
sl@0	867	envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
sl@0	868	envPtr->auxDataArrayNext = 0;
sl@0	869	envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE;
sl@0	870	envPtr->mallocedAuxDataArray = 0;
sl@0	871	}
sl@0	872
sl@0	873	/*
sl@0	874	*----------------------------------------------------------------------
sl@0	875	*
sl@0	876	* TclFreeCompileEnv --
sl@0	877	*
sl@0	878	* Free the storage allocated in a CompileEnv compilation environment
sl@0	879	* structure.
sl@0	880	*
sl@0	881	* Results:
sl@0	882	* None.
sl@0	883	*
sl@0	884	* Side effects:
sl@0	885	* Allocated storage in the CompileEnv structure is freed. Note that
sl@0	886	* its local literal table is not deleted and its literal objects are
sl@0	887	* not released. In addition, storage referenced by its auxiliary data
sl@0	888	* items is not freed. This is done so that, when compilation is
sl@0	889	* successful, "ownership" of these objects and aux data items is
sl@0	890	* handed over to the corresponding ByteCode structure.
sl@0	891	*
sl@0	892	*----------------------------------------------------------------------
sl@0	893	*/
sl@0	894
sl@0	895	void
sl@0	896	TclFreeCompileEnv(envPtr)
sl@0	897	register CompileEnv envPtr; / Points to the CompileEnv structure. */
sl@0	898	{
sl@0	899	if (envPtr->mallocedCodeArray) {
sl@0	900	ckfree((char *) envPtr->codeStart);
sl@0	901	}
sl@0	902	if (envPtr->mallocedLiteralArray) {
sl@0	903	ckfree((char *) envPtr->literalArrayPtr);
sl@0	904	}
sl@0	905	if (envPtr->mallocedExceptArray) {
sl@0	906	ckfree((char *) envPtr->exceptArrayPtr);
sl@0	907	}
sl@0	908	if (envPtr->mallocedCmdMap) {
sl@0	909	ckfree((char *) envPtr->cmdMapPtr);
sl@0	910	}
sl@0	911	if (envPtr->mallocedAuxDataArray) {
sl@0	912	ckfree((char *) envPtr->auxDataArrayPtr);
sl@0	913	}
sl@0	914	}
sl@0	915
sl@0	916	#ifdef TCL_TIP280
sl@0	917	/*
sl@0	918	*----------------------------------------------------------------------
sl@0	919	*
sl@0	920	* TclWordKnownAtCompileTime --
sl@0	921	*
sl@0	922	* Test whether the value of a token is completely known at compile time.
sl@0	923	*
sl@0	924	* Results:
sl@0	925	* Returns true if the tokenPtr argument points to a word value that is
sl@0	926	* completely known at compile time. Generally, values that are known at
sl@0	927	* compile time can be compiled to their values, while values that cannot
sl@0	928	* be known until substitution at runtime must be compiled to bytecode
sl@0	929	* instructions that perform that substitution. For several commands,
sl@0	930	* whether or not arguments are known at compile time determine whether
sl@0	931	* it is worthwhile to compile at all.
sl@0	932	*
sl@0	933	* Side effects:
sl@0	934	* None.
sl@0	935	*
sl@0	936	* TIP #280
sl@0	937	*----------------------------------------------------------------------
sl@0	938	*/
sl@0	939
sl@0	940	int
sl@0	941	TclWordKnownAtCompileTime (tokenPtr)
sl@0	942	Tcl_Token* tokenPtr;
sl@0	943	{
sl@0	944	int i;
sl@0	945	Tcl_Token* sub;
sl@0	946
sl@0	947	if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {return 1;};
sl@0	948	if (tokenPtr->type != TCL_TOKEN_WORD) {return 0;};
sl@0	949
sl@0	950	/* Check the sub tokens of the word. It is a literal if we find
sl@0	951	* only BS and TEXT tokens */
sl@0	952
sl@0	953	for (i=0, sub = tokenPtr + 1;
sl@0	954	i < tokenPtr->numComponents;
sl@0	955	i++, sub ++) {
sl@0	956	if (sub->type == TCL_TOKEN_TEXT) continue;
sl@0	957	if (sub->type == TCL_TOKEN_BS) continue;
sl@0	958	return 0;
sl@0	959	}
sl@0	960	return 1;
sl@0	961	}
sl@0	962	#endif
sl@0	963
sl@0	964	/*
sl@0	965	*----------------------------------------------------------------------
sl@0	966	*
sl@0	967	* TclCompileScript --
sl@0	968	*
sl@0	969	* Compile a Tcl script in a string.
sl@0	970	*
sl@0	971	* Results:
sl@0	972	* The return value is TCL_OK on a successful compilation and TCL_ERROR
sl@0	973	* on failure. If TCL_ERROR is returned, then the interpreter's result
sl@0	974	* contains an error message.
sl@0	975	*
sl@0	976	* interp->termOffset is set to the offset of the character in the
sl@0	977	* script just after the last one successfully processed; this will be
sl@0	978	* the offset of the ']' if (flags & TCL_BRACKET_TERM).
sl@0	979	*
sl@0	980	* Side effects:
sl@0	981	* Adds instructions to envPtr to evaluate the script at runtime.
sl@0	982	*
sl@0	983	*----------------------------------------------------------------------
sl@0	984	*/
sl@0	985
sl@0	986	int
sl@0	987	TclCompileScript(interp, script, numBytes, nested, envPtr)
sl@0	988	Tcl_Interp interp; / Used for error and status reporting.
sl@0	989	* Also serves as context for finding and
sl@0	990	* compiling commands. May not be NULL. */
sl@0	991	CONST char script; / The source script to compile. */
sl@0	992	int numBytes; /* Number of bytes in script. If < 0, the
sl@0	993	* script consists of all bytes up to the
sl@0	994	* first null character. */
sl@0	995	int nested; /* Non-zero means this is a nested command:
sl@0	996	* close bracket ']' should be considered a
sl@0	997	* command terminator. If zero, close
sl@0	998	* bracket has no special meaning. */
sl@0	999	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	1000	{
sl@0	1001	Interp iPtr = (Interp ) interp;
sl@0	1002	Tcl_Parse parse;
sl@0	1003	int lastTopLevelCmdIndex = -1;
sl@0	1004	/* Index of most recent toplevel command in
sl@0	1005	* the command location table. Initialized
sl@0	1006	* to avoid compiler warning. */
sl@0	1007	int startCodeOffset = -1; /* Offset of first byte of current command's
sl@0	1008	* code. Init. to avoid compiler warning. */
sl@0	1009	unsigned char *entryCodeNext = envPtr->codeNext;
sl@0	1010	CONST char p, next;
sl@0	1011	Namespace *cmdNsPtr;
sl@0	1012	Command *cmdPtr;
sl@0	1013	Tcl_Token *tokenPtr;
sl@0	1014	int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex;
sl@0	1015	int commandLength, objIndex, code;
sl@0	1016	Tcl_DString ds;
sl@0	1017
sl@0	1018	#ifdef TCL_TIP280
sl@0	1019	/* TIP #280 */
sl@0	1020	ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr;
sl@0	1021	int* wlines;
sl@0	1022	int wlineat, cmdLine;
sl@0	1023	#endif
sl@0	1024
sl@0	1025	Tcl_DStringInit(&ds);
sl@0	1026
sl@0	1027	if (numBytes < 0) {
sl@0	1028	numBytes = strlen(script);
sl@0	1029	}
sl@0	1030	Tcl_ResetResult(interp);
sl@0	1031	isFirstCmd = 1;
sl@0	1032
sl@0	1033	/*
sl@0	1034	* Each iteration through the following loop compiles the next
sl@0	1035	* command from the script.
sl@0	1036	*/
sl@0	1037
sl@0	1038	p = script;
sl@0	1039	bytesLeft = numBytes;
sl@0	1040	gotParse = 0;
sl@0	1041	#ifdef TCL_TIP280
sl@0	1042	cmdLine = envPtr->line;
sl@0	1043	#endif
sl@0	1044
sl@0	1045	do {
sl@0	1046	if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) {
sl@0	1047	code = TCL_ERROR;
sl@0	1048	goto error;
sl@0	1049	}
sl@0	1050	gotParse = 1;
sl@0	1051	if (nested) {
sl@0	1052	/*
sl@0	1053	* This is an unusual situation where the caller has passed us
sl@0	1054	* a non-zero value for "nested". How unusual? Well, this
sl@0	1055	* procedure, TclCompileScript, is internal to Tcl, so all
sl@0	1056	* callers should be within Tcl itself. All but one of those
sl@0	1057	* callers explicitly pass in (nested = 0). The exceptional
sl@0	1058	* caller is TclSetByteCodeFromAny, which will pass in
sl@0	1059	* (nested = 1) if and only if the flag TCL_BRACKET_TERM
sl@0	1060	* is set in the evalFlags field of interp.
sl@0	1061	*
sl@0	1062	* It appears that the TCL_BRACKET_TERM flag is only ever set
sl@0	1063	* by Tcl_SubstObj, and it immediately calls Tcl_EvalEx
sl@0	1064	* which clears the flag before passing the interp along.
sl@0	1065	* So, I don't think this procedure, TclCompileScript, is
sl@0	1066	* ever called with (nested != 0).
sl@0	1067	* (The testsuite indeed doesn't exercise this code. MS)
sl@0	1068	*
sl@0	1069	* This means that the branches in this procedure that are
sl@0	1070	* only active when (nested != 0) are probably never exercised.
sl@0	1071	* This means that any bugs in them go unnoticed, and any bug
sl@0	1072	* fixes in them have a semi-theoretical nature.
sl@0	1073	*
sl@0	1074	* All that said, the spec for this procedure says it should
sl@0	1075	* handle the (nested != 0) case, so here's an attempt to fix
sl@0	1076	* bugs (Tcl Bug 681841) in that case. Just in case some
sl@0	1077	* callers eventually come along and expect it to work...
sl@0	1078	*/
sl@0	1079
sl@0	1080	if (parse.term == (script + numBytes)) {
sl@0	1081	/*
sl@0	1082	* The (nested != 0) case is meant to indicate that the
sl@0	1083	* caller found an open bracket ([) and asked us to
sl@0	1084	* parse and compile Tcl commands up to the matching
sl@0	1085	* close bracket (]). We have to detect and handle
sl@0	1086	* the case where the close bracket is missing.
sl@0	1087	*/
sl@0	1088
sl@0	1089	Tcl_SetObjResult(interp,
sl@0	1090	Tcl_NewStringObj("missing close-bracket", -1));
sl@0	1091	code = TCL_ERROR;
sl@0	1092	goto error;
sl@0	1093	}
sl@0	1094	}
sl@0	1095	if (parse.numWords > 0) {
sl@0	1096	/*
sl@0	1097	* If not the first command, pop the previous command's result
sl@0	1098	* and, if we're compiling a top level command, update the last
sl@0	1099	* command's code size to account for the pop instruction.
sl@0	1100	*/
sl@0	1101
sl@0	1102	if (!isFirstCmd) {
sl@0	1103	TclEmitOpcode(INST_POP, envPtr);
sl@0	1104	if (!nested) {
sl@0	1105	envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes =
sl@0	1106	(envPtr->codeNext - envPtr->codeStart)
sl@0	1107	- startCodeOffset;
sl@0	1108	}
sl@0	1109	}
sl@0	1110
sl@0	1111	/*
sl@0	1112	* Determine the actual length of the command.
sl@0	1113	*/
sl@0	1114
sl@0	1115	commandLength = parse.commandSize;
sl@0	1116	if (parse.term == parse.commandStart + commandLength - 1) {
sl@0	1117	/*
sl@0	1118	* The command terminator character (such as ; or ]) is
sl@0	1119	* the last character in the parsed command. Reduce the
sl@0	1120	* length by one so that the trace message doesn't include
sl@0	1121	* the terminator character.
sl@0	1122	*/
sl@0	1123
sl@0	1124	commandLength -= 1;
sl@0	1125	}
sl@0	1126
sl@0	1127	#ifdef TCL_COMPILE_DEBUG
sl@0	1128	/*
sl@0	1129	* If tracing, print a line for each top level command compiled.
sl@0	1130	*/
sl@0	1131
sl@0	1132	if ((tclTraceCompile >= 1)
sl@0	1133	&& !nested && (envPtr->procPtr == NULL)) {
sl@0	1134	fprintf(stdout, " Compiling: ");
sl@0	1135	TclPrintSource(stdout, parse.commandStart,
sl@0	1136	TclMin(commandLength, 55));
sl@0	1137	fprintf(stdout, "\n");
sl@0	1138	}
sl@0	1139	#endif
sl@0	1140	/*
sl@0	1141	* Each iteration of the following loop compiles one word
sl@0	1142	* from the command.
sl@0	1143	*/
sl@0	1144
sl@0	1145	envPtr->numCommands++;
sl@0	1146	currCmdIndex = (envPtr->numCommands - 1);
sl@0	1147	if (!nested) {
sl@0	1148	lastTopLevelCmdIndex = currCmdIndex;
sl@0	1149	}
sl@0	1150	startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0	1151	EnterCmdStartData(envPtr, currCmdIndex,
sl@0	1152	(parse.commandStart - envPtr->source), startCodeOffset);
sl@0	1153
sl@0	1154	#ifdef TCL_TIP280
sl@0	1155	/* TIP #280. Scan the words and compute the extended location
sl@0	1156	* information. The map first contain full per-word line
sl@0	1157	* information for use by the compiler. This is later replaced by
sl@0	1158	* a reduced form which signals non-literal words, stored in
sl@0	1159	* 'wlines'.
sl@0	1160	*/
sl@0	1161
sl@0	1162	TclAdvanceLines (&cmdLine, p, parse.commandStart);
sl@0	1163	EnterCmdWordData (eclPtr, (parse.commandStart - envPtr->source),
sl@0	1164	parse.tokenPtr, parse.commandStart, parse.commandSize,
sl@0	1165	parse.numWords, cmdLine, &wlines);
sl@0	1166	wlineat = eclPtr->nuloc - 1;
sl@0	1167	#endif
sl@0	1168
sl@0	1169	for (wordIdx = 0, tokenPtr = parse.tokenPtr;
sl@0	1170	wordIdx < parse.numWords;
sl@0	1171	wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
sl@0	1172	#ifdef TCL_TIP280
sl@0	1173	envPtr->line = eclPtr->loc [wlineat].line [wordIdx];
sl@0	1174	#endif
sl@0	1175	if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	1176	/*
sl@0	1177	* If this is the first word and the command has a
sl@0	1178	* compile procedure, let it compile the command.
sl@0	1179	*/
sl@0	1180
sl@0	1181	if (wordIdx == 0) {
sl@0	1182	if (envPtr->procPtr != NULL) {
sl@0	1183	cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
sl@0	1184	} else {
sl@0	1185	cmdNsPtr = NULL; /* use current NS */
sl@0	1186	}
sl@0	1187
sl@0	1188	/*
sl@0	1189	* We copy the string before trying to find the command
sl@0	1190	* by name. We used to modify the string in place, but
sl@0	1191	* this is not safe because the name resolution
sl@0	1192	* handlers could have side effects that rely on the
sl@0	1193	* unmodified string.
sl@0	1194	*/
sl@0	1195
sl@0	1196	Tcl_DStringSetLength(&ds, 0);
sl@0	1197	Tcl_DStringAppend(&ds, tokenPtr[1].start,
sl@0	1198	tokenPtr[1].size);
sl@0	1199
sl@0	1200	cmdPtr = (Command *) Tcl_FindCommand(interp,
sl@0	1201	Tcl_DStringValue(&ds),
sl@0	1202	(Tcl_Namespace ) cmdNsPtr, /flags*/ 0);
sl@0	1203
sl@0	1204	if ((cmdPtr != NULL)
sl@0	1205	&& (cmdPtr->compileProc != NULL)
sl@0	1206	&& !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
sl@0	1207	&& !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
sl@0	1208	int savedNumCmds = envPtr->numCommands;
sl@0	1209	unsigned int savedCodeNext =
sl@0	1210	envPtr->codeNext - envPtr->codeStart;
sl@0	1211
sl@0	1212	code = (*(cmdPtr->compileProc))(interp, &parse,
sl@0	1213	envPtr);
sl@0	1214	if (code == TCL_OK) {
sl@0	1215	goto finishCommand;
sl@0	1216	} else if (code == TCL_OUT_LINE_COMPILE) {
sl@0	1217	/*
sl@0	1218	* Restore numCommands and codeNext to their correct
sl@0	1219	* values, removing any commands compiled before
sl@0	1220	* TCL_OUT_LINE_COMPILE [Bugs 705406 and 735055]
sl@0	1221	*/
sl@0	1222	envPtr->numCommands = savedNumCmds;
sl@0	1223	envPtr->codeNext = envPtr->codeStart + savedCodeNext;
sl@0	1224	} else { /* an error */
sl@0	1225	/*
sl@0	1226	* There was a compilation error, the last
sl@0	1227	* command did not get compiled into (*envPtr).
sl@0	1228	* Decrement the number of commands
sl@0	1229	* claimed to be in (*envPtr).
sl@0	1230	*/
sl@0	1231	envPtr->numCommands--;
sl@0	1232	goto log;
sl@0	1233	}
sl@0	1234	}
sl@0	1235
sl@0	1236	/*
sl@0	1237	* No compile procedure so push the word. If the
sl@0	1238	* command was found, push a CmdName object to
sl@0	1239	* reduce runtime lookups.
sl@0	1240	*/
sl@0	1241
sl@0	1242	objIndex = TclRegisterNewLiteral(envPtr,
sl@0	1243	tokenPtr[1].start, tokenPtr[1].size);
sl@0	1244	if (cmdPtr != NULL) {
sl@0	1245	TclSetCmdNameObj(interp,
sl@0	1246	envPtr->literalArrayPtr[objIndex].objPtr,
sl@0	1247	cmdPtr);
sl@0	1248	}
sl@0	1249	} else {
sl@0	1250	objIndex = TclRegisterNewLiteral(envPtr,
sl@0	1251	tokenPtr[1].start, tokenPtr[1].size);
sl@0	1252	}
sl@0	1253	TclEmitPush(objIndex, envPtr);
sl@0	1254	} else {
sl@0	1255	/*
sl@0	1256	* The word is not a simple string of characters.
sl@0	1257	*/
sl@0	1258	code = TclCompileTokens(interp, tokenPtr+1,
sl@0	1259	tokenPtr->numComponents, envPtr);
sl@0	1260	if (code != TCL_OK) {
sl@0	1261	goto log;
sl@0	1262	}
sl@0	1263	}
sl@0	1264	}
sl@0	1265
sl@0	1266	/*
sl@0	1267	* Emit an invoke instruction for the command. We skip this
sl@0	1268	* if a compile procedure was found for the command.
sl@0	1269	*/
sl@0	1270
sl@0	1271	if (wordIdx > 0) {
sl@0	1272	if (wordIdx <= 255) {
sl@0	1273	TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
sl@0	1274	} else {
sl@0	1275	TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr);
sl@0	1276	}
sl@0	1277	}
sl@0	1278
sl@0	1279	/*
sl@0	1280	* Update the compilation environment structure and record the
sl@0	1281	* offsets of the source and code for the command.
sl@0	1282	*/
sl@0	1283
sl@0	1284	finishCommand:
sl@0	1285	EnterCmdExtentData(envPtr, currCmdIndex, commandLength,
sl@0	1286	(envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
sl@0	1287	isFirstCmd = 0;
sl@0	1288
sl@0	1289	#ifdef TCL_TIP280
sl@0	1290	/* TIP #280: Free full form of per-word line data and insert
sl@0	1291	* the reduced form now
sl@0	1292	*/
sl@0	1293	ckfree ((char*) eclPtr->loc [wlineat].line);
sl@0	1294	eclPtr->loc [wlineat].line = wlines;
sl@0	1295	#endif
sl@0	1296	} /* end if parse.numWords > 0 */
sl@0	1297
sl@0	1298	/*
sl@0	1299	* Advance to the next command in the script.
sl@0	1300	*/
sl@0	1301
sl@0	1302	next = parse.commandStart + parse.commandSize;
sl@0	1303	bytesLeft -= (next - p);
sl@0	1304	p = next;
sl@0	1305	#ifdef TCL_TIP280
sl@0	1306	/* TIP #280 : Track lines in the just compiled command */
sl@0	1307	TclAdvanceLines (&cmdLine, parse.commandStart, p);
sl@0	1308	#endif
sl@0	1309	Tcl_FreeParse(&parse);
sl@0	1310	gotParse = 0;
sl@0	1311	if (nested && (*parse.term == ']')) {
sl@0	1312	/*
sl@0	1313	* We get here in the special case where TCL_BRACKET_TERM was
sl@0	1314	* set in the interpreter and the latest parsed command was
sl@0	1315	* terminated by the matching close-bracket we were looking for.
sl@0	1316	* Stop compilation.
sl@0	1317	*/
sl@0	1318
sl@0	1319	break;
sl@0	1320	}
sl@0	1321	} while (bytesLeft > 0);
sl@0	1322
sl@0	1323	/*
sl@0	1324	* If the source script yielded no instructions (e.g., if it was empty),
sl@0	1325	* push an empty string as the command's result.
sl@0	1326	*/
sl@0	1327
sl@0	1328	if (envPtr->codeNext == entryCodeNext) {
sl@0	1329	TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /onHeap/ 0),
sl@0	1330	envPtr);
sl@0	1331	}
sl@0	1332
sl@0	1333	if (nested) {
sl@0	1334	/*
sl@0	1335	* When (nested != 0) back up 1 character to have
sl@0	1336	* iPtr->termOffset indicate the offset to the matching
sl@0	1337	* close-bracket.
sl@0	1338	*/
sl@0	1339
sl@0	1340	iPtr->termOffset = (p - 1) - script;
sl@0	1341	} else {
sl@0	1342	iPtr->termOffset = (p - script);
sl@0	1343	}
sl@0	1344	Tcl_DStringFree(&ds);
sl@0	1345	return TCL_OK;
sl@0	1346
sl@0	1347	error:
sl@0	1348	/*
sl@0	1349	* Generate various pieces of error information, such as the line
sl@0	1350	* number where the error occurred and information to add to the
sl@0	1351	* errorInfo variable. Then free resources that had been allocated
sl@0	1352	* to the command.
sl@0	1353	*/
sl@0	1354
sl@0	1355	commandLength = parse.commandSize;
sl@0	1356	if (parse.term == parse.commandStart + commandLength - 1) {
sl@0	1357	/*
sl@0	1358	* The terminator character (such as ; or ]) of the command where
sl@0	1359	* the error occurred is the last character in the parsed command.
sl@0	1360	* Reduce the length by one so that the error message doesn't
sl@0	1361	* include the terminator character.
sl@0	1362	*/
sl@0	1363
sl@0	1364	commandLength -= 1;
sl@0	1365	}
sl@0	1366
sl@0	1367	log:
sl@0	1368	LogCompilationInfo(interp, script, parse.commandStart, commandLength);
sl@0	1369	if (gotParse) {
sl@0	1370	Tcl_FreeParse(&parse);
sl@0	1371	}
sl@0	1372	iPtr->termOffset = (p - script);
sl@0	1373	Tcl_DStringFree(&ds);
sl@0	1374	return code;
sl@0	1375	}
sl@0	1376
sl@0	1377	/*
sl@0	1378	*----------------------------------------------------------------------
sl@0	1379	*
sl@0	1380	* TclCompileTokens --
sl@0	1381	*
sl@0	1382	* Given an array of tokens parsed from a Tcl command (e.g., the tokens
sl@0	1383	* that make up a word) this procedure emits instructions to evaluate
sl@0	1384	* the tokens and concatenate their values to form a single result
sl@0	1385	* value on the interpreter's runtime evaluation stack.
sl@0	1386	*
sl@0	1387	* Results:
sl@0	1388	* The return value is a standard Tcl result. If an error occurs, an
sl@0	1389	* error message is left in the interpreter's result.
sl@0	1390	*
sl@0	1391	* Side effects:
sl@0	1392	* Instructions are added to envPtr to push and evaluate the tokens
sl@0	1393	* at runtime.
sl@0	1394	*
sl@0	1395	*----------------------------------------------------------------------
sl@0	1396	*/
sl@0	1397
sl@0	1398	int
sl@0	1399	TclCompileTokens(interp, tokenPtr, count, envPtr)
sl@0	1400	Tcl_Interp interp; / Used for error and status reporting. */
sl@0	1401	Tcl_Token tokenPtr; / Pointer to first in an array of tokens
sl@0	1402	* to compile. */
sl@0	1403	int count; /* Number of tokens to consider at tokenPtr.
sl@0	1404	* Must be at least 1. */
sl@0	1405	CompileEnv envPtr; / Holds the resulting instructions. */
sl@0	1406	{
sl@0	1407	Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
sl@0	1408	* TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
sl@0	1409	char buffer[TCL_UTF_MAX];
sl@0	1410	CONST char name, p;
sl@0	1411	int numObjsToConcat, nameBytes, localVarName, localVar;
sl@0	1412	int length, i, code;
sl@0	1413	unsigned char *entryCodeNext = envPtr->codeNext;
sl@0	1414
sl@0	1415	Tcl_DStringInit(&textBuffer);
sl@0	1416	numObjsToConcat = 0;
sl@0	1417	for ( ; count > 0; count--, tokenPtr++) {
sl@0	1418	switch (tokenPtr->type) {
sl@0	1419	case TCL_TOKEN_TEXT:
sl@0	1420	Tcl_DStringAppend(&textBuffer, tokenPtr->start,
sl@0	1421	tokenPtr->size);
sl@0	1422	break;
sl@0	1423
sl@0	1424	case TCL_TOKEN_BS:
sl@0	1425	length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
sl@0	1426	buffer);
sl@0	1427	Tcl_DStringAppend(&textBuffer, buffer, length);
sl@0	1428	break;
sl@0	1429
sl@0	1430	case TCL_TOKEN_COMMAND:
sl@0	1431	/*
sl@0	1432	* Push any accumulated chars appearing before the command.
sl@0	1433	*/
sl@0	1434
sl@0	1435	if (Tcl_DStringLength(&textBuffer) > 0) {
sl@0	1436	int literal;
sl@0	1437
sl@0	1438	literal = TclRegisterLiteral(envPtr,
sl@0	1439	Tcl_DStringValue(&textBuffer),
sl@0	1440	Tcl_DStringLength(&textBuffer), /onHeap/ 0);
sl@0	1441	TclEmitPush(literal, envPtr);
sl@0	1442	numObjsToConcat++;
sl@0	1443	Tcl_DStringFree(&textBuffer);
sl@0	1444	}
sl@0	1445
sl@0	1446	code = TclCompileScript(interp, tokenPtr->start+1,
sl@0	1447	tokenPtr->size-2, /nested/ 0, envPtr);
sl@0	1448	if (code != TCL_OK) {
sl@0	1449	goto error;
sl@0	1450	}
sl@0	1451	numObjsToConcat++;
sl@0	1452	break;
sl@0	1453
sl@0	1454	case TCL_TOKEN_VARIABLE:
sl@0	1455	/*
sl@0	1456	* Push any accumulated chars appearing before the $<var>.
sl@0	1457	*/
sl@0	1458
sl@0	1459	if (Tcl_DStringLength(&textBuffer) > 0) {
sl@0	1460	int literal;
sl@0	1461
sl@0	1462	literal = TclRegisterLiteral(envPtr,
sl@0	1463	Tcl_DStringValue(&textBuffer),
sl@0	1464	Tcl_DStringLength(&textBuffer), /onHeap/ 0);
sl@0	1465	TclEmitPush(literal, envPtr);
sl@0	1466	numObjsToConcat++;
sl@0	1467	Tcl_DStringFree(&textBuffer);
sl@0	1468	}
sl@0	1469
sl@0	1470	/*
sl@0	1471	* Determine how the variable name should be handled: if it contains
sl@0	1472	* any namespace qualifiers it is not a local variable (localVarName=-1);
sl@0	1473	* if it looks like an array element and the token has a single component,
sl@0	1474	* it should not be created here [Bug 569438] (localVarName=0); otherwise,
sl@0	1475	* the local variable can safely be created (localVarName=1).
sl@0	1476	*/
sl@0	1477
sl@0	1478	name = tokenPtr[1].start;
sl@0	1479	nameBytes = tokenPtr[1].size;
sl@0	1480	localVarName = -1;
sl@0	1481	if (envPtr->procPtr != NULL) {
sl@0	1482	localVarName = 1;
sl@0	1483	for (i = 0, p = name; i < nameBytes; i++, p++) {
sl@0	1484	if ((*p == ':') && (i < (nameBytes-1))
sl@0	1485	&& (*(p+1) == ':')) {
sl@0	1486	localVarName = -1;
sl@0	1487	break;
sl@0	1488	} else if ((*p == '(')
sl@0	1489	&& (tokenPtr->numComponents == 1)
sl@0	1490	&& (*(name + nameBytes - 1) == ')')) {
sl@0	1491	localVarName = 0;
sl@0	1492	break;
sl@0	1493	}
sl@0	1494	}
sl@0	1495	}
sl@0	1496
sl@0	1497	/*
sl@0	1498	* Either push the variable's name, or find its index in
sl@0	1499	* the array of local variables in a procedure frame.
sl@0	1500	*/
sl@0	1501
sl@0	1502	localVar = -1;
sl@0	1503	if (localVarName != -1) {
sl@0	1504	localVar = TclFindCompiledLocal(name, nameBytes,
sl@0	1505	localVarName, /flags/ 0, envPtr->procPtr);
sl@0	1506	}
sl@0	1507	if (localVar < 0) {
sl@0	1508	TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes),
sl@0	1509	envPtr);
sl@0	1510	}
sl@0	1511
sl@0	1512	/*
sl@0	1513	* Emit instructions to load the variable.
sl@0	1514	*/
sl@0	1515
sl@0	1516	if (tokenPtr->numComponents == 1) {
sl@0	1517	if (localVar < 0) {
sl@0	1518	TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
sl@0	1519	} else if (localVar <= 255) {
sl@0	1520	TclEmitInstInt1(INST_LOAD_SCALAR1, localVar,
sl@0	1521	envPtr);
sl@0	1522	} else {
sl@0	1523	TclEmitInstInt4(INST_LOAD_SCALAR4, localVar,
sl@0	1524	envPtr);
sl@0	1525	}
sl@0	1526	} else {
sl@0	1527	code = TclCompileTokens(interp, tokenPtr+2,
sl@0	1528	tokenPtr->numComponents-1, envPtr);
sl@0	1529	if (code != TCL_OK) {
sl@0	1530	char errorBuffer[150];
sl@0	1531	sprintf(errorBuffer,
sl@0	1532	"\n (parsing index for array \"%.*s\")",
sl@0	1533	((nameBytes > 100)? 100 : nameBytes), name);
sl@0	1534	Tcl_AddObjErrorInfo(interp, errorBuffer, -1);
sl@0	1535	goto error;
sl@0	1536	}
sl@0	1537	if (localVar < 0) {
sl@0	1538	TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
sl@0	1539	} else if (localVar <= 255) {
sl@0	1540	TclEmitInstInt1(INST_LOAD_ARRAY1, localVar,
sl@0	1541	envPtr);
sl@0	1542	} else {
sl@0	1543	TclEmitInstInt4(INST_LOAD_ARRAY4, localVar,
sl@0	1544	envPtr);
sl@0	1545	}
sl@0	1546	}
sl@0	1547	numObjsToConcat++;
sl@0	1548	count -= tokenPtr->numComponents;
sl@0	1549	tokenPtr += tokenPtr->numComponents;
sl@0	1550	break;
sl@0	1551
sl@0	1552	default:
sl@0	1553	panic("Unexpected token type in TclCompileTokens");
sl@0	1554	}
sl@0	1555	}
sl@0	1556
sl@0	1557	/*
sl@0	1558	* Push any accumulated characters appearing at the end.
sl@0	1559	*/
sl@0	1560
sl@0	1561	if (Tcl_DStringLength(&textBuffer) > 0) {
sl@0	1562	int literal;
sl@0	1563
sl@0	1564	literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer),
sl@0	1565	Tcl_DStringLength(&textBuffer), /onHeap/ 0);
sl@0	1566	TclEmitPush(literal, envPtr);
sl@0	1567	numObjsToConcat++;
sl@0	1568	}
sl@0	1569
sl@0	1570	/*
sl@0	1571	* If necessary, concatenate the parts of the word.
sl@0	1572	*/
sl@0	1573
sl@0	1574	while (numObjsToConcat > 255) {
sl@0	1575	TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
sl@0	1576	numObjsToConcat -= 254; /* concat pushes 1 obj, the result */
sl@0	1577	}
sl@0	1578	if (numObjsToConcat > 1) {
sl@0	1579	TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr);
sl@0	1580	}
sl@0	1581
sl@0	1582	/*
sl@0	1583	* If the tokens yielded no instructions, push an empty string.
sl@0	1584	*/
sl@0	1585
sl@0	1586	if (envPtr->codeNext == entryCodeNext) {
sl@0	1587	TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /onHeap/ 0),
sl@0	1588	envPtr);
sl@0	1589	}
sl@0	1590	Tcl_DStringFree(&textBuffer);
sl@0	1591	return TCL_OK;
sl@0	1592
sl@0	1593	error:
sl@0	1594	Tcl_DStringFree(&textBuffer);
sl@0	1595	return code;
sl@0	1596	}
sl@0	1597
sl@0	1598	/*
sl@0	1599	*----------------------------------------------------------------------
sl@0	1600	*
sl@0	1601	* TclCompileCmdWord --
sl@0	1602	*
sl@0	1603	* Given an array of parse tokens for a word containing one or more Tcl
sl@0	1604	* commands, emit inline instructions to execute them. This procedure
sl@0	1605	* differs from TclCompileTokens in that a simple word such as a loop
sl@0	1606	* body enclosed in braces is not just pushed as a string, but is
sl@0	1607	* itself parsed into tokens and compiled.
sl@0	1608	*
sl@0	1609	* Results:
sl@0	1610	* The return value is a standard Tcl result. If an error occurs, an
sl@0	1611	* error message is left in the interpreter's result.
sl@0	1612	*
sl@0	1613	* Side effects:
sl@0	1614	* Instructions are added to envPtr to execute the tokens at runtime.
sl@0	1615	*
sl@0	1616	*----------------------------------------------------------------------
sl@0	1617	*/
sl@0	1618
sl@0	1619	int
sl@0	1620	TclCompileCmdWord(interp, tokenPtr, count, envPtr)
sl@0	1621	Tcl_Interp interp; / Used for error and status reporting. */
sl@0	1622	Tcl_Token tokenPtr; / Pointer to first in an array of tokens
sl@0	1623	* for a command word to compile inline. */
sl@0	1624	int count; /* Number of tokens to consider at tokenPtr.
sl@0	1625	* Must be at least 1. */
sl@0	1626	CompileEnv envPtr; / Holds the resulting instructions. */
sl@0	1627	{
sl@0	1628	int code;
sl@0	1629
sl@0	1630	/*
sl@0	1631	* Handle the common case: if there is a single text token, compile it
sl@0	1632	* into an inline sequence of instructions.
sl@0	1633	*/
sl@0	1634
sl@0	1635	if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
sl@0	1636	code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size,
sl@0	1637	/nested/ 0, envPtr);
sl@0	1638	return code;
sl@0	1639	}
sl@0	1640
sl@0	1641	/*
sl@0	1642	* Multiple tokens or the single token involves substitutions. Emit
sl@0	1643	* instructions to invoke the eval command procedure at runtime on the
sl@0	1644	* result of evaluating the tokens.
sl@0	1645	*/
sl@0	1646
sl@0	1647	code = TclCompileTokens(interp, tokenPtr, count, envPtr);
sl@0	1648	if (code != TCL_OK) {
sl@0	1649	return code;
sl@0	1650	}
sl@0	1651	TclEmitOpcode(INST_EVAL_STK, envPtr);
sl@0	1652	return TCL_OK;
sl@0	1653	}
sl@0	1654
sl@0	1655	/*
sl@0	1656	*----------------------------------------------------------------------
sl@0	1657	*
sl@0	1658	* TclCompileExprWords --
sl@0	1659	*
sl@0	1660	* Given an array of parse tokens representing one or more words that
sl@0	1661	* contain a Tcl expression, emit inline instructions to execute the
sl@0	1662	* expression. This procedure differs from TclCompileExpr in that it
sl@0	1663	* supports Tcl's two-level substitution semantics for expressions that
sl@0	1664	* appear as command words.
sl@0	1665	*
sl@0	1666	* Results:
sl@0	1667	* The return value is a standard Tcl result. If an error occurs, an
sl@0	1668	* error message is left in the interpreter's result.
sl@0	1669	*
sl@0	1670	* Side effects:
sl@0	1671	* Instructions are added to envPtr to execute the expression.
sl@0	1672	*
sl@0	1673	*----------------------------------------------------------------------
sl@0	1674	*/
sl@0	1675
sl@0	1676	int
sl@0	1677	TclCompileExprWords(interp, tokenPtr, numWords, envPtr)
sl@0	1678	Tcl_Interp interp; / Used for error and status reporting. */
sl@0	1679	Tcl_Token tokenPtr; / Points to first in an array of word
sl@0	1680	* tokens tokens for the expression to
sl@0	1681	* compile inline. */
sl@0	1682	int numWords; /* Number of word tokens starting at
sl@0	1683	* tokenPtr. Must be at least 1. Each word
sl@0	1684	* token contains one or more subtokens. */
sl@0	1685	CompileEnv envPtr; / Holds the resulting instructions. */
sl@0	1686	{
sl@0	1687	Tcl_Token *wordPtr;
sl@0	1688	int numBytes, i, code;
sl@0	1689	CONST char *script;
sl@0	1690
sl@0	1691	code = TCL_OK;
sl@0	1692
sl@0	1693	/*
sl@0	1694	* If the expression is a single word that doesn't require
sl@0	1695	* substitutions, just compile its string into inline instructions.
sl@0	1696	*/
sl@0	1697
sl@0	1698	if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
sl@0	1699	script = tokenPtr[1].start;
sl@0	1700	numBytes = tokenPtr[1].size;
sl@0	1701	code = TclCompileExpr(interp, script, numBytes, envPtr);
sl@0	1702	return code;
sl@0	1703	}
sl@0	1704
sl@0	1705	/*
sl@0	1706	* Emit code to call the expr command proc at runtime. Concatenate the
sl@0	1707	* (already substituted once) expr tokens with a space between each.
sl@0	1708	*/
sl@0	1709
sl@0	1710	wordPtr = tokenPtr;
sl@0	1711	for (i = 0; i < numWords; i++) {
sl@0	1712	code = TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents,
sl@0	1713	envPtr);
sl@0	1714	if (code != TCL_OK) {
sl@0	1715	break;
sl@0	1716	}
sl@0	1717	if (i < (numWords - 1)) {
sl@0	1718	TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /onHeap/ 0),
sl@0	1719	envPtr);
sl@0	1720	}
sl@0	1721	wordPtr += (wordPtr->numComponents + 1);
sl@0	1722	}
sl@0	1723	if (code == TCL_OK) {
sl@0	1724	int concatItems = 2*numWords - 1;
sl@0	1725	while (concatItems > 255) {
sl@0	1726	TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
sl@0	1727	concatItems -= 254;
sl@0	1728	}
sl@0	1729	if (concatItems > 1) {
sl@0	1730	TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr);
sl@0	1731	}
sl@0	1732	TclEmitOpcode(INST_EXPR_STK, envPtr);
sl@0	1733	}
sl@0	1734
sl@0	1735	return code;
sl@0	1736	}
sl@0	1737
sl@0	1738	/*
sl@0	1739	*----------------------------------------------------------------------
sl@0	1740	*
sl@0	1741	* TclInitByteCodeObj --
sl@0	1742	*
sl@0	1743	* Create a ByteCode structure and initialize it from a CompileEnv
sl@0	1744	* compilation environment structure. The ByteCode structure is
sl@0	1745	* smaller and contains just that information needed to execute
sl@0	1746	* the bytecode instructions resulting from compiling a Tcl script.
sl@0	1747	* The resulting structure is placed in the specified object.
sl@0	1748	*
sl@0	1749	* Results:
sl@0	1750	* A newly constructed ByteCode object is stored in the internal
sl@0	1751	* representation of the objPtr.
sl@0	1752	*
sl@0	1753	* Side effects:
sl@0	1754	* A single heap object is allocated to hold the new ByteCode structure
sl@0	1755	* and its code, object, command location, and aux data arrays. Note
sl@0	1756	* that "ownership" (i.e., the pointers to) the Tcl objects and aux
sl@0	1757	* data items will be handed over to the new ByteCode structure from
sl@0	1758	* the CompileEnv structure.
sl@0	1759	*
sl@0	1760	*----------------------------------------------------------------------
sl@0	1761	*/
sl@0	1762
sl@0	1763	void
sl@0	1764	TclInitByteCodeObj(objPtr, envPtr)
sl@0	1765	Tcl_Obj objPtr; / Points object that should be
sl@0	1766	* initialized, and whose string rep
sl@0	1767	* contains the source code. */
sl@0	1768	register CompileEnv envPtr; / Points to the CompileEnv structure from
sl@0	1769	* which to create a ByteCode structure. */
sl@0	1770	{
sl@0	1771	register ByteCode *codePtr;
sl@0	1772	size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
sl@0	1773	size_t auxDataArrayBytes, structureSize;
sl@0	1774	register unsigned char *p;
sl@0	1775	#ifdef TCL_COMPILE_DEBUG
sl@0	1776	unsigned char *nextPtr;
sl@0	1777	#endif
sl@0	1778	int numLitObjects = envPtr->literalArrayNext;
sl@0	1779	Namespace *namespacePtr;
sl@0	1780	int i;
sl@0	1781	#ifdef TCL_TIP280
sl@0	1782	int new;
sl@0	1783	#endif
sl@0	1784	Interp *iPtr;
sl@0	1785
sl@0	1786	iPtr = envPtr->iPtr;
sl@0	1787
sl@0	1788	codeBytes = (envPtr->codeNext - envPtr->codeStart);
sl@0	1789	objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *));
sl@0	1790	exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange));
sl@0	1791	auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData));
sl@0	1792	cmdLocBytes = GetCmdLocEncodingSize(envPtr);
sl@0	1793
sl@0	1794	/*
sl@0	1795	* Compute the total number of bytes needed for this bytecode.
sl@0	1796	*/
sl@0	1797
sl@0	1798	structureSize = sizeof(ByteCode);
sl@0	1799	structureSize += TCL_ALIGN(codeBytes); /* align object array */
sl@0	1800	structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */
sl@0	1801	structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
sl@0	1802	structureSize += auxDataArrayBytes;
sl@0	1803	structureSize += cmdLocBytes;
sl@0	1804
sl@0	1805	if (envPtr->iPtr->varFramePtr != NULL) {
sl@0	1806	namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
sl@0	1807	} else {
sl@0	1808	namespacePtr = envPtr->iPtr->globalNsPtr;
sl@0	1809	}
sl@0	1810
sl@0	1811	p = (unsigned char *) ckalloc((size_t) structureSize);
sl@0	1812	codePtr = (ByteCode *) p;
sl@0	1813	codePtr->interpHandle = TclHandlePreserve(iPtr->handle);
sl@0	1814	codePtr->compileEpoch = iPtr->compileEpoch;
sl@0	1815	codePtr->nsPtr = namespacePtr;
sl@0	1816	codePtr->nsEpoch = namespacePtr->resolverEpoch;
sl@0	1817	codePtr->refCount = 1;
sl@0	1818	codePtr->flags = 0;
sl@0	1819	codePtr->source = envPtr->source;
sl@0	1820	codePtr->procPtr = envPtr->procPtr;
sl@0	1821
sl@0	1822	codePtr->numCommands = envPtr->numCommands;
sl@0	1823	codePtr->numSrcBytes = envPtr->numSrcBytes;
sl@0	1824	codePtr->numCodeBytes = codeBytes;
sl@0	1825	codePtr->numLitObjects = numLitObjects;
sl@0	1826	codePtr->numExceptRanges = envPtr->exceptArrayNext;
sl@0	1827	codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
sl@0	1828	codePtr->numCmdLocBytes = cmdLocBytes;
sl@0	1829	codePtr->maxExceptDepth = envPtr->maxExceptDepth;
sl@0	1830	codePtr->maxStackDepth = envPtr->maxStackDepth;
sl@0	1831
sl@0	1832	p += sizeof(ByteCode);
sl@0	1833	codePtr->codeStart = p;
sl@0	1834	memcpy((VOID ) p, (VOID ) envPtr->codeStart, (size_t) codeBytes);
sl@0	1835
sl@0	1836	p += TCL_ALIGN(codeBytes); /* align object array */
sl@0	1837	codePtr->objArrayPtr = (Tcl_Obj **) p;
sl@0	1838	for (i = 0; i < numLitObjects; i++) {
sl@0	1839	codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr;
sl@0	1840	}
sl@0	1841
sl@0	1842	p += TCL_ALIGN(objArrayBytes); /* align exception range array */
sl@0	1843	if (exceptArrayBytes > 0) {
sl@0	1844	codePtr->exceptArrayPtr = (ExceptionRange *) p;
sl@0	1845	memcpy((VOID ) p, (VOID ) envPtr->exceptArrayPtr,
sl@0	1846	(size_t) exceptArrayBytes);
sl@0	1847	} else {
sl@0	1848	codePtr->exceptArrayPtr = NULL;
sl@0	1849	}
sl@0	1850
sl@0	1851	p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
sl@0	1852	if (auxDataArrayBytes > 0) {
sl@0	1853	codePtr->auxDataArrayPtr = (AuxData *) p;
sl@0	1854	memcpy((VOID ) p, (VOID ) envPtr->auxDataArrayPtr,
sl@0	1855	(size_t) auxDataArrayBytes);
sl@0	1856	} else {
sl@0	1857	codePtr->auxDataArrayPtr = NULL;
sl@0	1858	}
sl@0	1859
sl@0	1860	p += auxDataArrayBytes;
sl@0	1861	#ifndef TCL_COMPILE_DEBUG
sl@0	1862	EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
sl@0	1863	#else
sl@0	1864	nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
sl@0	1865	if (((size_t)(nextPtr - p)) != cmdLocBytes) {
sl@0	1866	panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes);
sl@0	1867	}
sl@0	1868	#endif
sl@0	1869
sl@0	1870	/*
sl@0	1871	* Record various compilation-related statistics about the new ByteCode
sl@0	1872	* structure. Don't include overhead for statistics-related fields.
sl@0	1873	*/
sl@0	1874
sl@0	1875	#ifdef TCL_COMPILE_STATS
sl@0	1876	codePtr->structureSize = structureSize
sl@0	1877	- (sizeof(size_t) + sizeof(Tcl_Time));
sl@0	1878	Tcl_GetTime(&(codePtr->createTime));
sl@0	1879
sl@0	1880	RecordByteCodeStats(codePtr);
sl@0	1881	#endif /* TCL_COMPILE_STATS */
sl@0	1882
sl@0	1883	/*
sl@0	1884	* Free the old internal rep then convert the object to a
sl@0	1885	* bytecode object by making its internal rep point to the just
sl@0	1886	* compiled ByteCode.
sl@0	1887	*/
sl@0	1888
sl@0	1889	if ((objPtr->typePtr != NULL) &&
sl@0	1890	(objPtr->typePtr->freeIntRepProc != NULL)) {
sl@0	1891	(*objPtr->typePtr->freeIntRepProc)(objPtr);
sl@0	1892	}
sl@0	1893	objPtr->internalRep.otherValuePtr = (VOID *) codePtr;
sl@0	1894	objPtr->typePtr = &tclByteCodeType;
sl@0	1895
sl@0	1896	#ifdef TCL_TIP280
sl@0	1897	/* TIP #280. Associate the extended per-word line information with the
sl@0	1898	* byte code object (internal rep), for use with the bc compiler.
sl@0	1899	*/
sl@0	1900
sl@0	1901	Tcl_SetHashValue (Tcl_CreateHashEntry (iPtr->lineBCPtr, (char*) codePtr, &new),
sl@0	1902	envPtr->extCmdMapPtr);
sl@0	1903	envPtr->extCmdMapPtr = NULL;
sl@0	1904	#endif
sl@0	1905	}
sl@0	1906
sl@0	1907	/*
sl@0	1908	*----------------------------------------------------------------------
sl@0	1909	*
sl@0	1910	* LogCompilationInfo --
sl@0	1911	*
sl@0	1912	* This procedure is invoked after an error occurs during compilation.
sl@0	1913	* It adds information to the "errorInfo" variable to describe the
sl@0	1914	* command that was being compiled when the error occurred.
sl@0	1915	*
sl@0	1916	* Results:
sl@0	1917	* None.
sl@0	1918	*
sl@0	1919	* Side effects:
sl@0	1920	* Information about the command is added to errorInfo and the
sl@0	1921	* line number stored internally in the interpreter is set. If this
sl@0	1922	* is the first call to this procedure or Tcl_AddObjErrorInfo since
sl@0	1923	* an error occurred, then old information in errorInfo is
sl@0	1924	* deleted.
sl@0	1925	*
sl@0	1926	*----------------------------------------------------------------------
sl@0	1927	*/
sl@0	1928
sl@0	1929	static void
sl@0	1930	LogCompilationInfo(interp, script, command, length)
sl@0	1931	Tcl_Interp interp; / Interpreter in which to log the
sl@0	1932	* information. */
sl@0	1933	CONST char script; / First character in script containing
sl@0	1934	* command (must be <= command). */
sl@0	1935	CONST char command; / First character in command that
sl@0	1936	* generated the error. */
sl@0	1937	int length; /* Number of bytes in command (-1 means
sl@0	1938	* use all bytes up to first null byte). */
sl@0	1939	{
sl@0	1940	char buffer[200];
sl@0	1941	register CONST char *p;
sl@0	1942	char *ellipsis = "";
sl@0	1943	Interp iPtr = (Interp ) interp;
sl@0	1944
sl@0	1945	if (iPtr->flags & ERR_ALREADY_LOGGED) {
sl@0	1946	/*
sl@0	1947	* Someone else has already logged error information for this
sl@0	1948	* command; we shouldn't add anything more.
sl@0	1949	*/
sl@0	1950
sl@0	1951	return;
sl@0	1952	}
sl@0	1953
sl@0	1954	/*
sl@0	1955	* Compute the line number where the error occurred.
sl@0	1956	*/
sl@0	1957
sl@0	1958	iPtr->errorLine = 1;
sl@0	1959	for (p = script; p != command; p++) {
sl@0	1960	if (*p == '\n') {
sl@0	1961	iPtr->errorLine++;
sl@0	1962	}
sl@0	1963	}
sl@0	1964
sl@0	1965	/*
sl@0	1966	* Create an error message to add to errorInfo, including up to a
sl@0	1967	* maximum number of characters of the command.
sl@0	1968	*/
sl@0	1969
sl@0	1970	if (length < 0) {
sl@0	1971	length = strlen(command);
sl@0	1972	}
sl@0	1973	if (length > 150) {
sl@0	1974	length = 150;
sl@0	1975	ellipsis = "...";
sl@0	1976	}
sl@0	1977	while ( (command[length] & 0xC0) == 0x80 ) {
sl@0	1978	/*
sl@0	1979	* Back up truncation point so that we don't truncate in the
sl@0	1980	* middle of a multi-byte character (in UTF-8)
sl@0	1981	*/
sl@0	1982	length--;
sl@0	1983	ellipsis = "...";
sl@0	1984	}
sl@0	1985	sprintf(buffer, "\n while compiling\n\"%.*s%s\"",
sl@0	1986	length, command, ellipsis);
sl@0	1987	Tcl_AddObjErrorInfo(interp, buffer, -1);
sl@0	1988	}
sl@0	1989
sl@0	1990	/*
sl@0	1991	*----------------------------------------------------------------------
sl@0	1992	*
sl@0	1993	* TclFindCompiledLocal --
sl@0	1994	*
sl@0	1995	* This procedure is called at compile time to look up and optionally
sl@0	1996	* allocate an entry ("slot") for a variable in a procedure's array of
sl@0	1997	* local variables. If the variable's name is NULL, a new temporary
sl@0	1998	* variable is always created. (Such temporary variables can only be
sl@0	1999	* referenced using their slot index.)
sl@0	2000	*
sl@0	2001	* Results:
sl@0	2002	* If create is 0 and the name is non-NULL, then if the variable is
sl@0	2003	* found, the index of its entry in the procedure's array of local
sl@0	2004	* variables is returned; otherwise -1 is returned. If name is NULL,
sl@0	2005	* the index of a new temporary variable is returned. Finally, if
sl@0	2006	* create is 1 and name is non-NULL, the index of a new entry is
sl@0	2007	* returned.
sl@0	2008	*
sl@0	2009	* Side effects:
sl@0	2010	* Creates and registers a new local variable if create is 1 and
sl@0	2011	* the variable is unknown, or if the name is NULL.
sl@0	2012	*
sl@0	2013	*----------------------------------------------------------------------
sl@0	2014	*/
sl@0	2015
sl@0	2016	int
sl@0	2017	TclFindCompiledLocal(name, nameBytes, create, flags, procPtr)
sl@0	2018	register CONST char name; / Points to first character of the name of
sl@0	2019	* a scalar or array variable. If NULL, a
sl@0	2020	* temporary var should be created. */
sl@0	2021	int nameBytes; /* Number of bytes in the name. */
sl@0	2022	int create; /* If 1, allocate a local frame entry for
sl@0	2023	* the variable if it is new. */
sl@0	2024	int flags; /* Flag bits for the compiled local if
sl@0	2025	* created. Only VAR_SCALAR, VAR_ARRAY, and
sl@0	2026	* VAR_LINK make sense. */
sl@0	2027	register Proc procPtr; / Points to structure describing procedure
sl@0	2028	* containing the variable reference. */
sl@0	2029	{
sl@0	2030	register CompiledLocal *localPtr;
sl@0	2031	int localVar = -1;
sl@0	2032	register int i;
sl@0	2033
sl@0	2034	/*
sl@0	2035	* If not creating a temporary, does a local variable of the specified
sl@0	2036	* name already exist?
sl@0	2037	*/
sl@0	2038
sl@0	2039	if (name != NULL) {
sl@0	2040	int localCt = procPtr->numCompiledLocals;
sl@0	2041	localPtr = procPtr->firstLocalPtr;
sl@0	2042	for (i = 0; i < localCt; i++) {
sl@0	2043	if (!TclIsVarTemporary(localPtr)) {
sl@0	2044	char *localName = localPtr->name;
sl@0	2045	if ((nameBytes == localPtr->nameLength)
sl@0	2046	&& (strncmp(name, localName, (unsigned) nameBytes) == 0)) {
sl@0	2047	return i;
sl@0	2048	}
sl@0	2049	}
sl@0	2050	localPtr = localPtr->nextPtr;
sl@0	2051	}
sl@0	2052	}
sl@0	2053
sl@0	2054	/*
sl@0	2055	* Create a new variable if appropriate.
sl@0	2056	*/
sl@0	2057
sl@0	2058	if (create \|\| (name == NULL)) {
sl@0	2059	localVar = procPtr->numCompiledLocals;
sl@0	2060	localPtr = (CompiledLocal *) ckalloc((unsigned)
sl@0	2061	(sizeof(CompiledLocal) - sizeof(localPtr->name)
sl@0	2062	+ nameBytes+1));
sl@0	2063	if (procPtr->firstLocalPtr == NULL) {
sl@0	2064	procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
sl@0	2065	} else {
sl@0	2066	procPtr->lastLocalPtr->nextPtr = localPtr;
sl@0	2067	procPtr->lastLocalPtr = localPtr;
sl@0	2068	}
sl@0	2069	localPtr->nextPtr = NULL;
sl@0	2070	localPtr->nameLength = nameBytes;
sl@0	2071	localPtr->frameIndex = localVar;
sl@0	2072	localPtr->flags = flags \| VAR_UNDEFINED;
sl@0	2073	if (name == NULL) {
sl@0	2074	localPtr->flags \|= VAR_TEMPORARY;
sl@0	2075	}
sl@0	2076	localPtr->defValuePtr = NULL;
sl@0	2077	localPtr->resolveInfo = NULL;
sl@0	2078
sl@0	2079	if (name != NULL) {
sl@0	2080	memcpy((VOID ) localPtr->name, (VOID ) name,
sl@0	2081	(size_t) nameBytes);
sl@0	2082	}
sl@0	2083	localPtr->name[nameBytes] = '\0';
sl@0	2084	procPtr->numCompiledLocals++;
sl@0	2085	}
sl@0	2086	return localVar;
sl@0	2087	}
sl@0	2088
sl@0	2089	/*
sl@0	2090	*----------------------------------------------------------------------
sl@0	2091	*
sl@0	2092	* TclInitCompiledLocals --
sl@0	2093	*
sl@0	2094	* This routine is invoked in order to initialize the compiled
sl@0	2095	* locals table for a new call frame.
sl@0	2096	*
sl@0	2097	* Results:
sl@0	2098	* None.
sl@0	2099	*
sl@0	2100	* Side effects:
sl@0	2101	* May invoke various name resolvers in order to determine which
sl@0	2102	* variables are being referenced at runtime.
sl@0	2103	*
sl@0	2104	*----------------------------------------------------------------------
sl@0	2105	*/
sl@0	2106
sl@0	2107	void
sl@0	2108	TclInitCompiledLocals(interp, framePtr, nsPtr)
sl@0	2109	Tcl_Interp interp; / Current interpreter. */
sl@0	2110	CallFrame framePtr; / Call frame to initialize. */
sl@0	2111	Namespace nsPtr; / Pointer to current namespace. */
sl@0	2112	{
sl@0	2113	register CompiledLocal *localPtr;
sl@0	2114	Interp iPtr = (Interp) interp;
sl@0	2115	Tcl_ResolvedVarInfo vinfo, resVarInfo;
sl@0	2116	Var *varPtr = framePtr->compiledLocals;
sl@0	2117	Var *resolvedVarPtr;
sl@0	2118	ResolverScheme *resPtr;
sl@0	2119	int result;
sl@0	2120
sl@0	2121	/*
sl@0	2122	* Initialize the array of local variables stored in the call frame.
sl@0	2123	* Some variables may have special resolution rules. In that case,
sl@0	2124	* we call their "resolver" procs to get our hands on the variable,
sl@0	2125	* and we make the compiled local a link to the real variable.
sl@0	2126	*/
sl@0	2127
sl@0	2128	for (localPtr = framePtr->procPtr->firstLocalPtr;
sl@0	2129	localPtr != NULL;
sl@0	2130	localPtr = localPtr->nextPtr) {
sl@0	2131
sl@0	2132	/*
sl@0	2133	* Check to see if this local is affected by namespace or
sl@0	2134	* interp resolvers. The resolver to use is cached for the
sl@0	2135	* next invocation of the procedure.
sl@0	2136	*/
sl@0	2137
sl@0	2138	if (!(localPtr->flags & (VAR_ARGUMENT\|VAR_TEMPORARY\|VAR_RESOLVED))
sl@0	2139	&& (nsPtr->compiledVarResProc \|\| iPtr->resolverPtr)) {
sl@0	2140	resPtr = iPtr->resolverPtr;
sl@0	2141
sl@0	2142	if (nsPtr->compiledVarResProc) {
sl@0	2143	result = (*nsPtr->compiledVarResProc)(nsPtr->interp,
sl@0	2144	localPtr->name, localPtr->nameLength,
sl@0	2145	(Tcl_Namespace *) nsPtr, &vinfo);
sl@0	2146	} else {
sl@0	2147	result = TCL_CONTINUE;
sl@0	2148	}
sl@0	2149
sl@0	2150	while ((result == TCL_CONTINUE) && resPtr) {
sl@0	2151	if (resPtr->compiledVarResProc) {
sl@0	2152	result = (*resPtr->compiledVarResProc)(nsPtr->interp,
sl@0	2153	localPtr->name, localPtr->nameLength,
sl@0	2154	(Tcl_Namespace *) nsPtr, &vinfo);
sl@0	2155	}
sl@0	2156	resPtr = resPtr->nextPtr;
sl@0	2157	}
sl@0	2158	if (result == TCL_OK) {
sl@0	2159	localPtr->resolveInfo = vinfo;
sl@0	2160	localPtr->flags \|= VAR_RESOLVED;
sl@0	2161	}
sl@0	2162	}
sl@0	2163
sl@0	2164	/*
sl@0	2165	* Now invoke the resolvers to determine the exact variables that
sl@0	2166	* should be used.
sl@0	2167	*/
sl@0	2168
sl@0	2169	resVarInfo = localPtr->resolveInfo;
sl@0	2170	resolvedVarPtr = NULL;
sl@0	2171
sl@0	2172	if (resVarInfo && resVarInfo->fetchProc) {
sl@0	2173	resolvedVarPtr = (Var) (resVarInfo->fetchProc)(interp,
sl@0	2174	resVarInfo);
sl@0	2175	}
sl@0	2176
sl@0	2177	if (resolvedVarPtr) {
sl@0	2178	varPtr->name = localPtr->name; /* will be just '\0' if temp var */
sl@0	2179	varPtr->nsPtr = NULL;
sl@0	2180	varPtr->hPtr = NULL;
sl@0	2181	varPtr->refCount = 0;
sl@0	2182	varPtr->tracePtr = NULL;
sl@0	2183	varPtr->searchPtr = NULL;
sl@0	2184	varPtr->flags = 0;
sl@0	2185	TclSetVarLink(varPtr);
sl@0	2186	varPtr->value.linkPtr = resolvedVarPtr;
sl@0	2187	resolvedVarPtr->refCount++;
sl@0	2188	} else {
sl@0	2189	varPtr->value.objPtr = NULL;
sl@0	2190	varPtr->name = localPtr->name; /* will be just '\0' if temp var */
sl@0	2191	varPtr->nsPtr = NULL;
sl@0	2192	varPtr->hPtr = NULL;
sl@0	2193	varPtr->refCount = 0;
sl@0	2194	varPtr->tracePtr = NULL;
sl@0	2195	varPtr->searchPtr = NULL;
sl@0	2196	varPtr->flags = localPtr->flags;
sl@0	2197	}
sl@0	2198	varPtr++;
sl@0	2199	}
sl@0	2200	}
sl@0	2201
sl@0	2202	/*
sl@0	2203	*----------------------------------------------------------------------
sl@0	2204	*
sl@0	2205	* TclExpandCodeArray --
sl@0	2206	*
sl@0	2207	* Procedure that uses malloc to allocate more storage for a
sl@0	2208	* CompileEnv's code array.
sl@0	2209	*
sl@0	2210	* Results:
sl@0	2211	* None.
sl@0	2212	*
sl@0	2213	* Side effects:
sl@0	2214	* The byte code array in *envPtr is reallocated to a new array of
sl@0	2215	* double the size, and if envPtr->mallocedCodeArray is non-zero the
sl@0	2216	* old array is freed. Byte codes are copied from the old array to the
sl@0	2217	* new one.
sl@0	2218	*
sl@0	2219	*----------------------------------------------------------------------
sl@0	2220	*/
sl@0	2221
sl@0	2222	void
sl@0	2223	TclExpandCodeArray(envArgPtr)
sl@0	2224	void envArgPtr; / Points to the CompileEnv whose code array
sl@0	2225	* must be enlarged. */
sl@0	2226	{
sl@0	2227	CompileEnv envPtr = (CompileEnv) envArgPtr; /* Points to the CompileEnv whose code array
sl@0	2228	* must be enlarged. */
sl@0	2229
sl@0	2230	/*
sl@0	2231	* envPtr->codeNext is equal to envPtr->codeEnd. The currently defined
sl@0	2232	* code bytes are stored between envPtr->codeStart and
sl@0	2233	* (envPtr->codeNext - 1) [inclusive].
sl@0	2234	*/
sl@0	2235
sl@0	2236	size_t currBytes = (envPtr->codeNext - envPtr->codeStart);
sl@0	2237	size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart);
sl@0	2238	unsigned char newPtr = (unsigned char ) ckalloc((unsigned) newBytes);
sl@0	2239
sl@0	2240	/*
sl@0	2241	* Copy from old code array to new, free old code array if needed, and
sl@0	2242	* mark new code array as malloced.
sl@0	2243	*/
sl@0	2244
sl@0	2245	memcpy((VOID ) newPtr, (VOID ) envPtr->codeStart, currBytes);
sl@0	2246	if (envPtr->mallocedCodeArray) {
sl@0	2247	ckfree((char *) envPtr->codeStart);
sl@0	2248	}
sl@0	2249	envPtr->codeStart = newPtr;
sl@0	2250	envPtr->codeNext = (newPtr + currBytes);
sl@0	2251	envPtr->codeEnd = (newPtr + newBytes);
sl@0	2252	envPtr->mallocedCodeArray = 1;
sl@0	2253	}
sl@0	2254
sl@0	2255	/*
sl@0	2256	*----------------------------------------------------------------------
sl@0	2257	*
sl@0	2258	* EnterCmdStartData --
sl@0	2259	*
sl@0	2260	* Registers the starting source and bytecode location of a
sl@0	2261	* command. This information is used at runtime to map between
sl@0	2262	* instruction pc and source locations.
sl@0	2263	*
sl@0	2264	* Results:
sl@0	2265	* None.
sl@0	2266	*
sl@0	2267	* Side effects:
sl@0	2268	* Inserts source and code location information into the compilation
sl@0	2269	* environment envPtr for the command at index cmdIndex. The
sl@0	2270	* compilation environment's CmdLocation array is grown if necessary.
sl@0	2271	*
sl@0	2272	*----------------------------------------------------------------------
sl@0	2273	*/
sl@0	2274
sl@0	2275	static void
sl@0	2276	EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
sl@0	2277	CompileEnv envPtr; / Points to the compilation environment
sl@0	2278	* structure in which to enter command
sl@0	2279	* location information. */
sl@0	2280	int cmdIndex; /* Index of the command whose start data
sl@0	2281	* is being set. */
sl@0	2282	int srcOffset; /* Offset of first char of the command. */
sl@0	2283	int codeOffset; /* Offset of first byte of command code. */
sl@0	2284	{
sl@0	2285	CmdLocation *cmdLocPtr;
sl@0	2286
sl@0	2287	if ((cmdIndex < 0) \|\| (cmdIndex >= envPtr->numCommands)) {
sl@0	2288	panic("EnterCmdStartData: bad command index %d\n", cmdIndex);
sl@0	2289	}
sl@0	2290
sl@0	2291	if (cmdIndex >= envPtr->cmdMapEnd) {
sl@0	2292	/*
sl@0	2293	* Expand the command location array by allocating more storage from
sl@0	2294	* the heap. The currently allocated CmdLocation entries are stored
sl@0	2295	* from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive).
sl@0	2296	*/
sl@0	2297
sl@0	2298	size_t currElems = envPtr->cmdMapEnd;
sl@0	2299	size_t newElems = 2*currElems;
sl@0	2300	size_t currBytes = currElems * sizeof(CmdLocation);
sl@0	2301	size_t newBytes = newElems * sizeof(CmdLocation);
sl@0	2302	CmdLocation newPtr = (CmdLocation ) ckalloc((unsigned) newBytes);
sl@0	2303
sl@0	2304	/*
sl@0	2305	* Copy from old command location array to new, free old command
sl@0	2306	* location array if needed, and mark new array as malloced.
sl@0	2307	*/
sl@0	2308
sl@0	2309	memcpy((VOID ) newPtr, (VOID ) envPtr->cmdMapPtr, currBytes);
sl@0	2310	if (envPtr->mallocedCmdMap) {
sl@0	2311	ckfree((char *) envPtr->cmdMapPtr);
sl@0	2312	}
sl@0	2313	envPtr->cmdMapPtr = (CmdLocation *) newPtr;
sl@0	2314	envPtr->cmdMapEnd = newElems;
sl@0	2315	envPtr->mallocedCmdMap = 1;
sl@0	2316	}
sl@0	2317
sl@0	2318	if (cmdIndex > 0) {
sl@0	2319	if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) {
sl@0	2320	panic("EnterCmdStartData: cmd map not sorted by code offset");
sl@0	2321	}
sl@0	2322	}
sl@0	2323
sl@0	2324	cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
sl@0	2325	cmdLocPtr->codeOffset = codeOffset;
sl@0	2326	cmdLocPtr->srcOffset = srcOffset;
sl@0	2327	cmdLocPtr->numSrcBytes = -1;
sl@0	2328	cmdLocPtr->numCodeBytes = -1;
sl@0	2329	}
sl@0	2330
sl@0	2331	/*
sl@0	2332	*----------------------------------------------------------------------
sl@0	2333	*
sl@0	2334	* EnterCmdExtentData --
sl@0	2335	*
sl@0	2336	* Registers the source and bytecode length for a command. This
sl@0	2337	* information is used at runtime to map between instruction pc and
sl@0	2338	* source locations.
sl@0	2339	*
sl@0	2340	* Results:
sl@0	2341	* None.
sl@0	2342	*
sl@0	2343	* Side effects:
sl@0	2344	* Inserts source and code length information into the compilation
sl@0	2345	* environment envPtr for the command at index cmdIndex. Starting
sl@0	2346	* source and bytecode information for the command must already
sl@0	2347	* have been registered.
sl@0	2348	*
sl@0	2349	*----------------------------------------------------------------------
sl@0	2350	*/
sl@0	2351
sl@0	2352	static void
sl@0	2353	EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes)
sl@0	2354	CompileEnv envPtr; / Points to the compilation environment
sl@0	2355	* structure in which to enter command
sl@0	2356	* location information. */
sl@0	2357	int cmdIndex; /* Index of the command whose source and
sl@0	2358	* code length data is being set. */
sl@0	2359	int numSrcBytes; /* Number of command source chars. */
sl@0	2360	int numCodeBytes; /* Offset of last byte of command code. */
sl@0	2361	{
sl@0	2362	CmdLocation *cmdLocPtr;
sl@0	2363
sl@0	2364	if ((cmdIndex < 0) \|\| (cmdIndex >= envPtr->numCommands)) {
sl@0	2365	panic("EnterCmdExtentData: bad command index %d\n", cmdIndex);
sl@0	2366	}
sl@0	2367
sl@0	2368	if (cmdIndex > envPtr->cmdMapEnd) {
sl@0	2369	panic("EnterCmdExtentData: missing start data for command %d\n",
sl@0	2370	cmdIndex);
sl@0	2371	}
sl@0	2372
sl@0	2373	cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
sl@0	2374	cmdLocPtr->numSrcBytes = numSrcBytes;
sl@0	2375	cmdLocPtr->numCodeBytes = numCodeBytes;
sl@0	2376	}
sl@0	2377
sl@0	2378	#ifdef TCL_TIP280
sl@0	2379	/*
sl@0	2380	*----------------------------------------------------------------------
sl@0	2381	* TIP #280
sl@0	2382	*
sl@0	2383	* EnterCmdWordData --
sl@0	2384	*
sl@0	2385	* Registers the lines for the words of a command. This information
sl@0	2386	* is used at runtime by 'info frame'.
sl@0	2387	*
sl@0	2388	* Results:
sl@0	2389	* None.
sl@0	2390	*
sl@0	2391	* Side effects:
sl@0	2392	* Inserts word location information into the compilation
sl@0	2393	* environment envPtr for the command at index cmdIndex. The
sl@0	2394	* compilation environment's ExtCmdLoc.ECL array is grown if necessary.
sl@0	2395	*
sl@0	2396	*----------------------------------------------------------------------
sl@0	2397	*/
sl@0	2398
sl@0	2399	static void
sl@0	2400	EnterCmdWordData(eclPtr, srcOffset, tokenPtr, cmd, len, numWords, line, wlines)
sl@0	2401	ExtCmdLoc eclPtr; / Points to the map environment
sl@0	2402	* structure in which to enter command
sl@0	2403	* location information. */
sl@0	2404	int srcOffset; /* Offset of first char of the command. */
sl@0	2405	Tcl_Token* tokenPtr;
sl@0	2406	CONST char* cmd;
sl@0	2407	int len;
sl@0	2408	int numWords;
sl@0	2409	int line;
sl@0	2410	int** wlines;
sl@0	2411	{
sl@0	2412	ECL* ePtr;
sl@0	2413	int wordIdx;
sl@0	2414	CONST char* last;
sl@0	2415	int wordLine;
sl@0	2416	int* wwlines;
sl@0	2417
sl@0	2418	if (eclPtr->nuloc >= eclPtr->nloc) {
sl@0	2419	/*
sl@0	2420	* Expand the ECL array by allocating more storage from the
sl@0	2421	* heap. The currently allocated ECL entries are stored from
sl@0	2422	* eclPtr->loc[0] up to eclPtr->loc[eclPtr->nuloc-1] (inclusive).
sl@0	2423	*/
sl@0	2424
sl@0	2425	size_t currElems = eclPtr->nloc;
sl@0	2426	size_t newElems = (currElems ? 2*currElems : 1);
sl@0	2427	size_t currBytes = currElems * sizeof(ECL);
sl@0	2428	size_t newBytes = newElems * sizeof(ECL);
sl@0	2429	ECL * newPtr = (ECL *) ckalloc((unsigned) newBytes);
sl@0	2430
sl@0	2431	/*
sl@0	2432	* Copy from old ECL array to new, free old ECL array if
sl@0	2433	* needed.
sl@0	2434	*/
sl@0	2435
sl@0	2436	if (currBytes) {
sl@0	2437	memcpy((VOID ) newPtr, (VOID ) eclPtr->loc, currBytes);
sl@0	2438	}
sl@0	2439	if (eclPtr->loc != NULL) {
sl@0	2440	ckfree((char *) eclPtr->loc);
sl@0	2441	}
sl@0	2442	eclPtr->loc = (ECL *) newPtr;
sl@0	2443	eclPtr->nloc = newElems;
sl@0	2444	}
sl@0	2445
sl@0	2446	ePtr = &eclPtr->loc [eclPtr->nuloc];
sl@0	2447	ePtr->srcOffset = srcOffset;
sl@0	2448	ePtr->line = (int) ckalloc (numWords sizeof (int));
sl@0	2449	ePtr->nline = numWords;
sl@0	2450	wwlines = (int) ckalloc (numWords sizeof (int));
sl@0	2451
sl@0	2452	last = cmd;
sl@0	2453	wordLine = line;
sl@0	2454	for (wordIdx = 0;
sl@0	2455	wordIdx < numWords;
sl@0	2456	wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
sl@0	2457	TclAdvanceLines (&wordLine, last, tokenPtr->start);
sl@0	2458	wwlines [wordIdx] = (TclWordKnownAtCompileTime (tokenPtr)
sl@0	2459	? wordLine
sl@0	2460	: -1);
sl@0	2461	ePtr->line [wordIdx] = wordLine;
sl@0	2462	last = tokenPtr->start;
sl@0	2463	}
sl@0	2464
sl@0	2465	*wlines = wwlines;
sl@0	2466	eclPtr->nuloc ++;
sl@0	2467	}
sl@0	2468	#endif
sl@0	2469
sl@0	2470	/*
sl@0	2471	*----------------------------------------------------------------------
sl@0	2472	*
sl@0	2473	* TclCreateExceptRange --
sl@0	2474	*
sl@0	2475	* Procedure that allocates and initializes a new ExceptionRange
sl@0	2476	* structure of the specified kind in a CompileEnv.
sl@0	2477	*
sl@0	2478	* Results:
sl@0	2479	* Returns the index for the newly created ExceptionRange.
sl@0	2480	*
sl@0	2481	* Side effects:
sl@0	2482	* If there is not enough room in the CompileEnv's ExceptionRange
sl@0	2483	* array, the array in expanded: a new array of double the size is
sl@0	2484	* allocated, if envPtr->mallocedExceptArray is non-zero the old
sl@0	2485	* array is freed, and ExceptionRange entries are copied from the old
sl@0	2486	* array to the new one.
sl@0	2487	*
sl@0	2488	*----------------------------------------------------------------------
sl@0	2489	*/
sl@0	2490
sl@0	2491	int
sl@0	2492	TclCreateExceptRange(type, envPtr)
sl@0	2493	ExceptionRangeType type; /* The kind of ExceptionRange desired. */
sl@0	2494	register CompileEnv envPtr;/ Points to CompileEnv for which to
sl@0	2495	* create a new ExceptionRange structure. */
sl@0	2496	{
sl@0	2497	register ExceptionRange *rangePtr;
sl@0	2498	int index = envPtr->exceptArrayNext;
sl@0	2499
sl@0	2500	if (index >= envPtr->exceptArrayEnd) {
sl@0	2501	/*
sl@0	2502	* Expand the ExceptionRange array. The currently allocated entries
sl@0	2503	* are stored between elements 0 and (envPtr->exceptArrayNext - 1)
sl@0	2504	* [inclusive].
sl@0	2505	*/
sl@0	2506
sl@0	2507	size_t currBytes =
sl@0	2508	envPtr->exceptArrayNext * sizeof(ExceptionRange);
sl@0	2509	int newElems = 2*envPtr->exceptArrayEnd;
sl@0	2510	size_t newBytes = newElems * sizeof(ExceptionRange);
sl@0	2511	ExceptionRange newPtr = (ExceptionRange )
sl@0	2512	ckalloc((unsigned) newBytes);
sl@0	2513
sl@0	2514	/*
sl@0	2515	* Copy from old ExceptionRange array to new, free old
sl@0	2516	* ExceptionRange array if needed, and mark the new ExceptionRange
sl@0	2517	* array as malloced.
sl@0	2518	*/
sl@0	2519
sl@0	2520	memcpy((VOID ) newPtr, (VOID ) envPtr->exceptArrayPtr,
sl@0	2521	currBytes);
sl@0	2522	if (envPtr->mallocedExceptArray) {
sl@0	2523	ckfree((char *) envPtr->exceptArrayPtr);
sl@0	2524	}
sl@0	2525	envPtr->exceptArrayPtr = (ExceptionRange *) newPtr;
sl@0	2526	envPtr->exceptArrayEnd = newElems;
sl@0	2527	envPtr->mallocedExceptArray = 1;
sl@0	2528	}
sl@0	2529	envPtr->exceptArrayNext++;
sl@0	2530
sl@0	2531	rangePtr = &(envPtr->exceptArrayPtr[index]);
sl@0	2532	rangePtr->type = type;
sl@0	2533	rangePtr->nestingLevel = envPtr->exceptDepth;
sl@0	2534	rangePtr->codeOffset = -1;
sl@0	2535	rangePtr->numCodeBytes = -1;
sl@0	2536	rangePtr->breakOffset = -1;
sl@0	2537	rangePtr->continueOffset = -1;
sl@0	2538	rangePtr->catchOffset = -1;
sl@0	2539	return index;
sl@0	2540	}
sl@0	2541
sl@0	2542	/*
sl@0	2543	*----------------------------------------------------------------------
sl@0	2544	*
sl@0	2545	* TclCreateAuxData --
sl@0	2546	*
sl@0	2547	* Procedure that allocates and initializes a new AuxData structure in
sl@0	2548	* a CompileEnv's array of compilation auxiliary data records. These
sl@0	2549	* AuxData records hold information created during compilation by
sl@0	2550	* CompileProcs and used by instructions during execution.
sl@0	2551	*
sl@0	2552	* Results:
sl@0	2553	* Returns the index for the newly created AuxData structure.
sl@0	2554	*
sl@0	2555	* Side effects:
sl@0	2556	* If there is not enough room in the CompileEnv's AuxData array,
sl@0	2557	* the AuxData array in expanded: a new array of double the size
sl@0	2558	* is allocated, if envPtr->mallocedAuxDataArray is non-zero
sl@0	2559	* the old array is freed, and AuxData entries are copied from
sl@0	2560	* the old array to the new one.
sl@0	2561	*
sl@0	2562	*----------------------------------------------------------------------
sl@0	2563	*/
sl@0	2564
sl@0	2565	int
sl@0	2566	TclCreateAuxData(clientData, typePtr, envPtr)
sl@0	2567	ClientData clientData; /* The compilation auxiliary data to store
sl@0	2568	* in the new aux data record. */
sl@0	2569	AuxDataType typePtr; / Pointer to the type to attach to this AuxData */
sl@0	2570	register CompileEnv envPtr;/ Points to the CompileEnv for which a new
sl@0	2571	* aux data structure is to be allocated. */
sl@0	2572	{
sl@0	2573	int index; /* Index for the new AuxData structure. */
sl@0	2574	register AuxData *auxDataPtr;
sl@0	2575	/* Points to the new AuxData structure */
sl@0	2576
sl@0	2577	index = envPtr->auxDataArrayNext;
sl@0	2578	if (index >= envPtr->auxDataArrayEnd) {
sl@0	2579	/*
sl@0	2580	* Expand the AuxData array. The currently allocated entries are
sl@0	2581	* stored between elements 0 and (envPtr->auxDataArrayNext - 1)
sl@0	2582	* [inclusive].
sl@0	2583	*/
sl@0	2584
sl@0	2585	size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
sl@0	2586	int newElems = 2*envPtr->auxDataArrayEnd;
sl@0	2587	size_t newBytes = newElems * sizeof(AuxData);
sl@0	2588	AuxData newPtr = (AuxData ) ckalloc((unsigned) newBytes);
sl@0	2589
sl@0	2590	/*
sl@0	2591	* Copy from old AuxData array to new, free old AuxData array if
sl@0	2592	* needed, and mark the new AuxData array as malloced.
sl@0	2593	*/
sl@0	2594
sl@0	2595	memcpy((VOID ) newPtr, (VOID ) envPtr->auxDataArrayPtr,
sl@0	2596	currBytes);
sl@0	2597	if (envPtr->mallocedAuxDataArray) {
sl@0	2598	ckfree((char *) envPtr->auxDataArrayPtr);
sl@0	2599	}
sl@0	2600	envPtr->auxDataArrayPtr = newPtr;
sl@0	2601	envPtr->auxDataArrayEnd = newElems;
sl@0	2602	envPtr->mallocedAuxDataArray = 1;
sl@0	2603	}
sl@0	2604	envPtr->auxDataArrayNext++;
sl@0	2605
sl@0	2606	auxDataPtr = &(envPtr->auxDataArrayPtr[index]);
sl@0	2607	auxDataPtr->clientData = clientData;
sl@0	2608	auxDataPtr->type = typePtr;
sl@0	2609	return index;
sl@0	2610	}
sl@0	2611
sl@0	2612	/*
sl@0	2613	*----------------------------------------------------------------------
sl@0	2614	*
sl@0	2615	* TclInitJumpFixupArray --
sl@0	2616	*
sl@0	2617	* Initializes a JumpFixupArray structure to hold some number of
sl@0	2618	* jump fixup entries.
sl@0	2619	*
sl@0	2620	* Results:
sl@0	2621	* None.
sl@0	2622	*
sl@0	2623	* Side effects:
sl@0	2624	* The JumpFixupArray structure is initialized.
sl@0	2625	*
sl@0	2626	*----------------------------------------------------------------------
sl@0	2627	*/
sl@0	2628
sl@0	2629	void
sl@0	2630	TclInitJumpFixupArray(fixupArrayPtr)
sl@0	2631	register JumpFixupArray *fixupArrayPtr;
sl@0	2632	/* Points to the JumpFixupArray structure
sl@0	2633	* to initialize. */
sl@0	2634	{
sl@0	2635	fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace;
sl@0	2636	fixupArrayPtr->next = 0;
sl@0	2637	fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1);
sl@0	2638	fixupArrayPtr->mallocedArray = 0;
sl@0	2639	}
sl@0	2640
sl@0	2641	/*
sl@0	2642	*----------------------------------------------------------------------
sl@0	2643	*
sl@0	2644	* TclExpandJumpFixupArray --
sl@0	2645	*
sl@0	2646	* Procedure that uses malloc to allocate more storage for a
sl@0	2647	* jump fixup array.
sl@0	2648	*
sl@0	2649	* Results:
sl@0	2650	* None.
sl@0	2651	*
sl@0	2652	* Side effects:
sl@0	2653	* The jump fixup array in *fixupArrayPtr is reallocated to a new array
sl@0	2654	* of double the size, and if fixupArrayPtr->mallocedArray is non-zero
sl@0	2655	* the old array is freed. Jump fixup structures are copied from the
sl@0	2656	* old array to the new one.
sl@0	2657	*
sl@0	2658	*----------------------------------------------------------------------
sl@0	2659	*/
sl@0	2660
sl@0	2661	void
sl@0	2662	TclExpandJumpFixupArray(fixupArrayPtr)
sl@0	2663	register JumpFixupArray *fixupArrayPtr;
sl@0	2664	/* Points to the JumpFixupArray structure
sl@0	2665	* to enlarge. */
sl@0	2666	{
sl@0	2667	/*
sl@0	2668	* The currently allocated jump fixup entries are stored from fixup[0]
sl@0	2669	* up to fixup[fixupArrayPtr->fixupNext] (not inclusive). We assume
sl@0	2670	* fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd.
sl@0	2671	*/
sl@0	2672
sl@0	2673	size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
sl@0	2674	int newElems = 2*(fixupArrayPtr->end + 1);
sl@0	2675	size_t newBytes = newElems * sizeof(JumpFixup);
sl@0	2676	JumpFixup newPtr = (JumpFixup ) ckalloc((unsigned) newBytes);
sl@0	2677
sl@0	2678	/*
sl@0	2679	* Copy from the old array to new, free the old array if needed,
sl@0	2680	* and mark the new array as malloced.
sl@0	2681	*/
sl@0	2682
sl@0	2683	memcpy((VOID ) newPtr, (VOID ) fixupArrayPtr->fixup, currBytes);
sl@0	2684	if (fixupArrayPtr->mallocedArray) {
sl@0	2685	ckfree((char *) fixupArrayPtr->fixup);
sl@0	2686	}
sl@0	2687	fixupArrayPtr->fixup = (JumpFixup *) newPtr;
sl@0	2688	fixupArrayPtr->end = newElems;
sl@0	2689	fixupArrayPtr->mallocedArray = 1;
sl@0	2690	}
sl@0	2691
sl@0	2692	/*
sl@0	2693	*----------------------------------------------------------------------
sl@0	2694	*
sl@0	2695	* TclFreeJumpFixupArray --
sl@0	2696	*
sl@0	2697	* Free any storage allocated in a jump fixup array structure.
sl@0	2698	*
sl@0	2699	* Results:
sl@0	2700	* None.
sl@0	2701	*
sl@0	2702	* Side effects:
sl@0	2703	* Allocated storage in the JumpFixupArray structure is freed.
sl@0	2704	*
sl@0	2705	*----------------------------------------------------------------------
sl@0	2706	*/
sl@0	2707
sl@0	2708	void
sl@0	2709	TclFreeJumpFixupArray(fixupArrayPtr)
sl@0	2710	register JumpFixupArray *fixupArrayPtr;
sl@0	2711	/* Points to the JumpFixupArray structure
sl@0	2712	* to free. */
sl@0	2713	{
sl@0	2714	if (fixupArrayPtr->mallocedArray) {
sl@0	2715	ckfree((char *) fixupArrayPtr->fixup);
sl@0	2716	}
sl@0	2717	}
sl@0	2718
sl@0	2719	/*
sl@0	2720	*----------------------------------------------------------------------
sl@0	2721	*
sl@0	2722	* TclEmitForwardJump --
sl@0	2723	*
sl@0	2724	* Procedure to emit a two-byte forward jump of kind "jumpType". Since
sl@0	2725	* the jump may later have to be grown to five bytes if the jump target
sl@0	2726	* is more than, say, 127 bytes away, this procedure also initializes a
sl@0	2727	* JumpFixup record with information about the jump.
sl@0	2728	*
sl@0	2729	* Results:
sl@0	2730	* None.
sl@0	2731	*
sl@0	2732	* Side effects:
sl@0	2733	* The JumpFixup record pointed to by "jumpFixupPtr" is initialized
sl@0	2734	* with information needed later if the jump is to be grown. Also,
sl@0	2735	* a two byte jump of the designated type is emitted at the current
sl@0	2736	* point in the bytecode stream.
sl@0	2737	*
sl@0	2738	*----------------------------------------------------------------------
sl@0	2739	*/
sl@0	2740
sl@0	2741	void
sl@0	2742	TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr)
sl@0	2743	CompileEnv envPtr; / Points to the CompileEnv structure that
sl@0	2744	* holds the resulting instruction. */
sl@0	2745	TclJumpType jumpType; /* Indicates the kind of jump: if true or
sl@0	2746	* false or unconditional. */
sl@0	2747	JumpFixup jumpFixupPtr; / Points to the JumpFixup structure to
sl@0	2748	* initialize with information about this
sl@0	2749	* forward jump. */
sl@0	2750	{
sl@0	2751	/*
sl@0	2752	* Initialize the JumpFixup structure:
sl@0	2753	* - codeOffset is offset of first byte of jump below
sl@0	2754	* - cmdIndex is index of the command after the current one
sl@0	2755	* - exceptIndex is the index of the first ExceptionRange after
sl@0	2756	* the current one.
sl@0	2757	*/
sl@0	2758
sl@0	2759	jumpFixupPtr->jumpType = jumpType;
sl@0	2760	jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0	2761	jumpFixupPtr->cmdIndex = envPtr->numCommands;
sl@0	2762	jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext;
sl@0	2763
sl@0	2764	switch (jumpType) {
sl@0	2765	case TCL_UNCONDITIONAL_JUMP:
sl@0	2766	TclEmitInstInt1(INST_JUMP1, 0, envPtr);
sl@0	2767	break;
sl@0	2768	case TCL_TRUE_JUMP:
sl@0	2769	TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr);
sl@0	2770	break;
sl@0	2771	default:
sl@0	2772	TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
sl@0	2773	break;
sl@0	2774	}
sl@0	2775	}
sl@0	2776
sl@0	2777	/*
sl@0	2778	*----------------------------------------------------------------------
sl@0	2779	*
sl@0	2780	* TclFixupForwardJump --
sl@0	2781	*
sl@0	2782	* Procedure that updates a previously-emitted forward jump to jump
sl@0	2783	* a specified number of bytes, "jumpDist". If necessary, the jump is
sl@0	2784	* grown from two to five bytes; this is done if the jump distance is
sl@0	2785	* greater than "distThreshold" (normally 127 bytes). The jump is
sl@0	2786	* described by a JumpFixup record previously initialized by
sl@0	2787	* TclEmitForwardJump.
sl@0	2788	*
sl@0	2789	* Results:
sl@0	2790	* 1 if the jump was grown and subsequent instructions had to be moved;
sl@0	2791	* otherwise 0. This result is returned to allow callers to update
sl@0	2792	* any additional code offsets they may hold.
sl@0	2793	*
sl@0	2794	* Side effects:
sl@0	2795	* The jump may be grown and subsequent instructions moved. If this
sl@0	2796	* happens, the code offsets for any commands and any ExceptionRange
sl@0	2797	* records between the jump and the current code address will be
sl@0	2798	* updated to reflect the moved code. Also, the bytecode instruction
sl@0	2799	* array in the CompileEnv structure may be grown and reallocated.
sl@0	2800	*
sl@0	2801	*----------------------------------------------------------------------
sl@0	2802	*/
sl@0	2803
sl@0	2804	int
sl@0	2805	TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
sl@0	2806	CompileEnv envPtr; / Points to the CompileEnv structure that
sl@0	2807	* holds the resulting instruction. */
sl@0	2808	JumpFixup jumpFixupPtr; / Points to the JumpFixup structure that
sl@0	2809	* describes the forward jump. */
sl@0	2810	int jumpDist; /* Jump distance to set in jump
sl@0	2811	* instruction. */
sl@0	2812	int distThreshold; /* Maximum distance before the two byte
sl@0	2813	* jump is grown to five bytes. */
sl@0	2814	{
sl@0	2815	unsigned char jumpPc, p;
sl@0	2816	int firstCmd, lastCmd, firstRange, lastRange, k;
sl@0	2817	unsigned int numBytes;
sl@0	2818
sl@0	2819	if (jumpDist <= distThreshold) {
sl@0	2820	jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
sl@0	2821	switch (jumpFixupPtr->jumpType) {
sl@0	2822	case TCL_UNCONDITIONAL_JUMP:
sl@0	2823	TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc);
sl@0	2824	break;
sl@0	2825	case TCL_TRUE_JUMP:
sl@0	2826	TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc);
sl@0	2827	break;
sl@0	2828	default:
sl@0	2829	TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc);
sl@0	2830	break;
sl@0	2831	}
sl@0	2832	return 0;
sl@0	2833	}
sl@0	2834
sl@0	2835	/*
sl@0	2836	* We must grow the jump then move subsequent instructions down.
sl@0	2837	* Note that if we expand the space for generated instructions,
sl@0	2838	* code addresses might change; be careful about updating any of
sl@0	2839	* these addresses held in variables.
sl@0	2840	*/
sl@0	2841
sl@0	2842	if ((envPtr->codeNext + 3) > envPtr->codeEnd) {
sl@0	2843	TclExpandCodeArray(envPtr);
sl@0	2844	}
sl@0	2845	jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
sl@0	2846	for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1;
sl@0	2847	numBytes > 0; numBytes--, p--) {
sl@0	2848	p[3] = p[0];
sl@0	2849	}
sl@0	2850	envPtr->codeNext += 3;
sl@0	2851	jumpDist += 3;
sl@0	2852	switch (jumpFixupPtr->jumpType) {
sl@0	2853	case TCL_UNCONDITIONAL_JUMP:
sl@0	2854	TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc);
sl@0	2855	break;
sl@0	2856	case TCL_TRUE_JUMP:
sl@0	2857	TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc);
sl@0	2858	break;
sl@0	2859	default:
sl@0	2860	TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc);
sl@0	2861	break;
sl@0	2862	}
sl@0	2863
sl@0	2864	/*
sl@0	2865	* Adjust the code offsets for any commands and any ExceptionRange
sl@0	2866	* records between the jump and the current code address.
sl@0	2867	*/
sl@0	2868
sl@0	2869	firstCmd = jumpFixupPtr->cmdIndex;
sl@0	2870	lastCmd = (envPtr->numCommands - 1);
sl@0	2871	if (firstCmd < lastCmd) {
sl@0	2872	for (k = firstCmd; k <= lastCmd; k++) {
sl@0	2873	(envPtr->cmdMapPtr[k]).codeOffset += 3;
sl@0	2874	}
sl@0	2875	}
sl@0	2876
sl@0	2877	firstRange = jumpFixupPtr->exceptIndex;
sl@0	2878	lastRange = (envPtr->exceptArrayNext - 1);
sl@0	2879	for (k = firstRange; k <= lastRange; k++) {
sl@0	2880	ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]);
sl@0	2881	rangePtr->codeOffset += 3;
sl@0	2882
sl@0	2883	switch (rangePtr->type) {
sl@0	2884	case LOOP_EXCEPTION_RANGE:
sl@0	2885	rangePtr->breakOffset += 3;
sl@0	2886	if (rangePtr->continueOffset != -1) {
sl@0	2887	rangePtr->continueOffset += 3;
sl@0	2888	}
sl@0	2889	break;
sl@0	2890	case CATCH_EXCEPTION_RANGE:
sl@0	2891	rangePtr->catchOffset += 3;
sl@0	2892	break;
sl@0	2893	default:
sl@0	2894	panic("TclFixupForwardJump: bad ExceptionRange type %d\n",
sl@0	2895	rangePtr->type);
sl@0	2896	}
sl@0	2897	}
sl@0	2898	return 1; /* the jump was grown */
sl@0	2899	}
sl@0	2900
sl@0	2901	/*
sl@0	2902	*----------------------------------------------------------------------
sl@0	2903	*
sl@0	2904	* TclGetInstructionTable --
sl@0	2905	*
sl@0	2906	* Returns a pointer to the table describing Tcl bytecode instructions.
sl@0	2907	* This procedure is defined so that clients can access the pointer from
sl@0	2908	* outside the TCL DLLs.
sl@0	2909	*
sl@0	2910	* Results:
sl@0	2911	* Returns a pointer to the global instruction table, same as the
sl@0	2912	* expression (&tclInstructionTable[0]).
sl@0	2913	*
sl@0	2914	* Side effects:
sl@0	2915	* None.
sl@0	2916	*
sl@0	2917	*----------------------------------------------------------------------
sl@0	2918	*/
sl@0	2919
sl@0	2920	void * /* == InstructionDesc* == */
sl@0	2921	TclGetInstructionTable()
sl@0	2922	{
sl@0	2923	return &tclInstructionTable[0];
sl@0	2924	}
sl@0	2925
sl@0	2926	/*
sl@0	2927	*--------------------------------------------------------------
sl@0	2928	*
sl@0	2929	* TclRegisterAuxDataType --
sl@0	2930	*
sl@0	2931	* This procedure is called to register a new AuxData type
sl@0	2932	* in the table of all AuxData types supported by Tcl.
sl@0	2933	*
sl@0	2934	* Results:
sl@0	2935	* None.
sl@0	2936	*
sl@0	2937	* Side effects:
sl@0	2938	* The type is registered in the AuxData type table. If there was already
sl@0	2939	* a type with the same name as in typePtr, it is replaced with the
sl@0	2940	* new type.
sl@0	2941	*
sl@0	2942	*--------------------------------------------------------------
sl@0	2943	*/
sl@0	2944
sl@0	2945	void
sl@0	2946	TclRegisterAuxDataType(typePtr)
sl@0	2947	AuxDataType typePtr; / Information about object type;
sl@0	2948	* storage must be statically
sl@0	2949	* allocated (must live forever). */
sl@0	2950	{
sl@0	2951	register Tcl_HashEntry *hPtr;
sl@0	2952	int new;
sl@0	2953
sl@0	2954	Tcl_MutexLock(&tableMutex);
sl@0	2955	if (!auxDataTypeTableInitialized) {
sl@0	2956	TclInitAuxDataTypeTable();
sl@0	2957	}
sl@0	2958
sl@0	2959	/*
sl@0	2960	* If there's already a type with the given name, remove it.
sl@0	2961	*/
sl@0	2962
sl@0	2963	hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name);
sl@0	2964	if (hPtr != (Tcl_HashEntry *) NULL) {
sl@0	2965	Tcl_DeleteHashEntry(hPtr);
sl@0	2966	}
sl@0	2967
sl@0	2968	/*
sl@0	2969	* Now insert the new object type.
sl@0	2970	*/
sl@0	2971
sl@0	2972	hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new);
sl@0	2973	if (new) {
sl@0	2974	Tcl_SetHashValue(hPtr, typePtr);
sl@0	2975	}
sl@0	2976	Tcl_MutexUnlock(&tableMutex);
sl@0	2977	}
sl@0	2978
sl@0	2979	/*
sl@0	2980	*----------------------------------------------------------------------
sl@0	2981	*
sl@0	2982	* TclGetAuxDataType --
sl@0	2983	*
sl@0	2984	* This procedure looks up an Auxdata type by name.
sl@0	2985	*
sl@0	2986	* Results:
sl@0	2987	* If an AuxData type with name matching "typeName" is found, a pointer
sl@0	2988	* to its AuxDataType structure is returned; otherwise, NULL is returned.
sl@0	2989	*
sl@0	2990	* Side effects:
sl@0	2991	* None.
sl@0	2992	*
sl@0	2993	*----------------------------------------------------------------------
sl@0	2994	*/
sl@0	2995
sl@0	2996	AuxDataType *
sl@0	2997	TclGetAuxDataType(typeName)
sl@0	2998	char typeName; / Name of AuxData type to look up. */
sl@0	2999	{
sl@0	3000	register Tcl_HashEntry *hPtr;
sl@0	3001	AuxDataType *typePtr = NULL;
sl@0	3002
sl@0	3003	Tcl_MutexLock(&tableMutex);
sl@0	3004	if (!auxDataTypeTableInitialized) {
sl@0	3005	TclInitAuxDataTypeTable();
sl@0	3006	}
sl@0	3007
sl@0	3008	hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName);
sl@0	3009	if (hPtr != (Tcl_HashEntry *) NULL) {
sl@0	3010	typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr);
sl@0	3011	}
sl@0	3012	Tcl_MutexUnlock(&tableMutex);
sl@0	3013
sl@0	3014	return typePtr;
sl@0	3015	}
sl@0	3016
sl@0	3017	/*
sl@0	3018	*--------------------------------------------------------------
sl@0	3019	*
sl@0	3020	* TclInitAuxDataTypeTable --
sl@0	3021	*
sl@0	3022	* This procedure is invoked to perform once-only initialization of
sl@0	3023	* the AuxData type table. It also registers the AuxData types defined in
sl@0	3024	* this file.
sl@0	3025	*
sl@0	3026	* Results:
sl@0	3027	* None.
sl@0	3028	*
sl@0	3029	* Side effects:
sl@0	3030	* Initializes the table of defined AuxData types "auxDataTypeTable" with
sl@0	3031	* builtin AuxData types defined in this file.
sl@0	3032	*
sl@0	3033	*--------------------------------------------------------------
sl@0	3034	*/
sl@0	3035
sl@0	3036	void
sl@0	3037	TclInitAuxDataTypeTable()
sl@0	3038	{
sl@0	3039	/*
sl@0	3040	* The table mutex must already be held before this routine is invoked.
sl@0	3041	*/
sl@0	3042
sl@0	3043	auxDataTypeTableInitialized = 1;
sl@0	3044	Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS);
sl@0	3045
sl@0	3046	/*
sl@0	3047	* There is only one AuxData type at this time, so register it here.
sl@0	3048	*/
sl@0	3049
sl@0	3050	TclRegisterAuxDataType(&tclForeachInfoType);
sl@0	3051	}
sl@0	3052
sl@0	3053	/*
sl@0	3054	*----------------------------------------------------------------------
sl@0	3055	*
sl@0	3056	* TclFinalizeAuxDataTypeTable --
sl@0	3057	*
sl@0	3058	* This procedure is called by Tcl_Finalize after all exit handlers
sl@0	3059	* have been run to free up storage associated with the table of AuxData
sl@0	3060	* types. This procedure is called by TclFinalizeExecution() which
sl@0	3061	* is called by Tcl_Finalize().
sl@0	3062	*
sl@0	3063	* Results:
sl@0	3064	* None.
sl@0	3065	*
sl@0	3066	* Side effects:
sl@0	3067	* Deletes all entries in the hash table of AuxData types.
sl@0	3068	*
sl@0	3069	*----------------------------------------------------------------------
sl@0	3070	*/
sl@0	3071
sl@0	3072	void
sl@0	3073	TclFinalizeAuxDataTypeTable()
sl@0	3074	{
sl@0	3075	Tcl_MutexLock(&tableMutex);
sl@0	3076	if (auxDataTypeTableInitialized) {
sl@0	3077	Tcl_DeleteHashTable(&auxDataTypeTable);
sl@0	3078	auxDataTypeTableInitialized = 0;
sl@0	3079	}
sl@0	3080	Tcl_MutexUnlock(&tableMutex);
sl@0	3081	}
sl@0	3082
sl@0	3083	/*
sl@0	3084	*----------------------------------------------------------------------
sl@0	3085	*
sl@0	3086	* GetCmdLocEncodingSize --
sl@0	3087	*
sl@0	3088	* Computes the total number of bytes needed to encode the command
sl@0	3089	* location information for some compiled code.
sl@0	3090	*
sl@0	3091	* Results:
sl@0	3092	* The byte count needed to encode the compiled location information.
sl@0	3093	*
sl@0	3094	* Side effects:
sl@0	3095	* None.
sl@0	3096	*
sl@0	3097	*----------------------------------------------------------------------
sl@0	3098	*/
sl@0	3099
sl@0	3100	static int
sl@0	3101	GetCmdLocEncodingSize(envPtr)
sl@0	3102	CompileEnv envPtr; / Points to compilation environment
sl@0	3103	* structure containing the CmdLocation
sl@0	3104	* structure to encode. */
sl@0	3105	{
sl@0	3106	register CmdLocation *mapPtr = envPtr->cmdMapPtr;
sl@0	3107	int numCmds = envPtr->numCommands;
sl@0	3108	int codeDelta, codeLen, srcDelta, srcLen;
sl@0	3109	int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext;
sl@0	3110	/* The offsets in their respective byte
sl@0	3111	* sequences where the next encoded offset
sl@0	3112	* or length should go. */
sl@0	3113	int prevCodeOffset, prevSrcOffset, i;
sl@0	3114
sl@0	3115	codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0;
sl@0	3116	prevCodeOffset = prevSrcOffset = 0;
sl@0	3117	for (i = 0; i < numCmds; i++) {
sl@0	3118	codeDelta = (mapPtr[i].codeOffset - prevCodeOffset);
sl@0	3119	if (codeDelta < 0) {
sl@0	3120	panic("GetCmdLocEncodingSize: bad code offset");
sl@0	3121	} else if (codeDelta <= 127) {
sl@0	3122	codeDeltaNext++;
sl@0	3123	} else {
sl@0	3124	codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */
sl@0	3125	}
sl@0	3126	prevCodeOffset = mapPtr[i].codeOffset;
sl@0	3127
sl@0	3128	codeLen = mapPtr[i].numCodeBytes;
sl@0	3129	if (codeLen < 0) {
sl@0	3130	panic("GetCmdLocEncodingSize: bad code length");
sl@0	3131	} else if (codeLen <= 127) {
sl@0	3132	codeLengthNext++;
sl@0	3133	} else {
sl@0	3134	codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
sl@0	3135	}
sl@0	3136
sl@0	3137	srcDelta = (mapPtr[i].srcOffset - prevSrcOffset);
sl@0	3138	if ((-127 <= srcDelta) && (srcDelta <= 127)) {
sl@0	3139	srcDeltaNext++;
sl@0	3140	} else {
sl@0	3141	srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */
sl@0	3142	}
sl@0	3143	prevSrcOffset = mapPtr[i].srcOffset;
sl@0	3144
sl@0	3145	srcLen = mapPtr[i].numSrcBytes;
sl@0	3146	if (srcLen < 0) {
sl@0	3147	panic("GetCmdLocEncodingSize: bad source length");
sl@0	3148	} else if (srcLen <= 127) {
sl@0	3149	srcLengthNext++;
sl@0	3150	} else {
sl@0	3151	srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
sl@0	3152	}
sl@0	3153	}
sl@0	3154
sl@0	3155	return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext);
sl@0	3156	}
sl@0	3157
sl@0	3158	/*
sl@0	3159	*----------------------------------------------------------------------
sl@0	3160	*
sl@0	3161	* EncodeCmdLocMap --
sl@0	3162	*
sl@0	3163	* Encode the command location information for some compiled code into
sl@0	3164	* a ByteCode structure. The encoded command location map is stored as
sl@0	3165	* three adjacent byte sequences.
sl@0	3166	*
sl@0	3167	* Results:
sl@0	3168	* Pointer to the first byte after the encoded command location
sl@0	3169	* information.
sl@0	3170	*
sl@0	3171	* Side effects:
sl@0	3172	* The encoded information is stored into the block of memory headed
sl@0	3173	* by codePtr. Also records pointers to the start of the four byte
sl@0	3174	* sequences in fields in codePtr's ByteCode header structure.
sl@0	3175	*
sl@0	3176	*----------------------------------------------------------------------
sl@0	3177	*/
sl@0	3178
sl@0	3179	static unsigned char *
sl@0	3180	EncodeCmdLocMap(envPtr, codePtr, startPtr)
sl@0	3181	CompileEnv envPtr; / Points to compilation environment
sl@0	3182	* structure containing the CmdLocation
sl@0	3183	* structure to encode. */
sl@0	3184	ByteCode codePtr; / ByteCode in which to encode envPtr's
sl@0	3185	* command location information. */
sl@0	3186	unsigned char startPtr; / Points to the first byte in codePtr's
sl@0	3187	* memory block where the location
sl@0	3188	* information is to be stored. */
sl@0	3189	{
sl@0	3190	register CmdLocation *mapPtr = envPtr->cmdMapPtr;
sl@0	3191	int numCmds = envPtr->numCommands;
sl@0	3192	register unsigned char *p = startPtr;
sl@0	3193	int codeDelta, codeLen, srcDelta, srcLen, prevOffset;
sl@0	3194	register int i;
sl@0	3195
sl@0	3196	/*
sl@0	3197	* Encode the code offset for each command as a sequence of deltas.
sl@0	3198	*/
sl@0	3199
sl@0	3200	codePtr->codeDeltaStart = p;
sl@0	3201	prevOffset = 0;
sl@0	3202	for (i = 0; i < numCmds; i++) {
sl@0	3203	codeDelta = (mapPtr[i].codeOffset - prevOffset);
sl@0	3204	if (codeDelta < 0) {
sl@0	3205	panic("EncodeCmdLocMap: bad code offset");
sl@0	3206	} else if (codeDelta <= 127) {
sl@0	3207	TclStoreInt1AtPtr(codeDelta, p);
sl@0	3208	p++;
sl@0	3209	} else {
sl@0	3210	TclStoreInt1AtPtr(0xFF, p);
sl@0	3211	p++;
sl@0	3212	TclStoreInt4AtPtr(codeDelta, p);
sl@0	3213	p += 4;
sl@0	3214	}
sl@0	3215	prevOffset = mapPtr[i].codeOffset;
sl@0	3216	}
sl@0	3217
sl@0	3218	/*
sl@0	3219	* Encode the code length for each command.
sl@0	3220	*/
sl@0	3221
sl@0	3222	codePtr->codeLengthStart = p;
sl@0	3223	for (i = 0; i < numCmds; i++) {
sl@0	3224	codeLen = mapPtr[i].numCodeBytes;
sl@0	3225	if (codeLen < 0) {
sl@0	3226	panic("EncodeCmdLocMap: bad code length");
sl@0	3227	} else if (codeLen <= 127) {
sl@0	3228	TclStoreInt1AtPtr(codeLen, p);
sl@0	3229	p++;
sl@0	3230	} else {
sl@0	3231	TclStoreInt1AtPtr(0xFF, p);
sl@0	3232	p++;
sl@0	3233	TclStoreInt4AtPtr(codeLen, p);
sl@0	3234	p += 4;
sl@0	3235	}
sl@0	3236	}
sl@0	3237
sl@0	3238	/*
sl@0	3239	* Encode the source offset for each command as a sequence of deltas.
sl@0	3240	*/
sl@0	3241
sl@0	3242	codePtr->srcDeltaStart = p;
sl@0	3243	prevOffset = 0;
sl@0	3244	for (i = 0; i < numCmds; i++) {
sl@0	3245	srcDelta = (mapPtr[i].srcOffset - prevOffset);
sl@0	3246	if ((-127 <= srcDelta) && (srcDelta <= 127)) {
sl@0	3247	TclStoreInt1AtPtr(srcDelta, p);
sl@0	3248	p++;
sl@0	3249	} else {
sl@0	3250	TclStoreInt1AtPtr(0xFF, p);
sl@0	3251	p++;
sl@0	3252	TclStoreInt4AtPtr(srcDelta, p);
sl@0	3253	p += 4;
sl@0	3254	}
sl@0	3255	prevOffset = mapPtr[i].srcOffset;
sl@0	3256	}
sl@0	3257
sl@0	3258	/*
sl@0	3259	* Encode the source length for each command.
sl@0	3260	*/
sl@0	3261
sl@0	3262	codePtr->srcLengthStart = p;
sl@0	3263	for (i = 0; i < numCmds; i++) {
sl@0	3264	srcLen = mapPtr[i].numSrcBytes;
sl@0	3265	if (srcLen < 0) {
sl@0	3266	panic("EncodeCmdLocMap: bad source length");
sl@0	3267	} else if (srcLen <= 127) {
sl@0	3268	TclStoreInt1AtPtr(srcLen, p);
sl@0	3269	p++;
sl@0	3270	} else {
sl@0	3271	TclStoreInt1AtPtr(0xFF, p);
sl@0	3272	p++;
sl@0	3273	TclStoreInt4AtPtr(srcLen, p);
sl@0	3274	p += 4;
sl@0	3275	}
sl@0	3276	}
sl@0	3277
sl@0	3278	return p;
sl@0	3279	}
sl@0	3280
sl@0	3281	#ifdef TCL_COMPILE_DEBUG
sl@0	3282	/*
sl@0	3283	*----------------------------------------------------------------------
sl@0	3284	*
sl@0	3285	* TclPrintByteCodeObj --
sl@0	3286	*
sl@0	3287	* This procedure prints ("disassembles") the instructions of a
sl@0	3288	* bytecode object to stdout.
sl@0	3289	*
sl@0	3290	* Results:
sl@0	3291	* None.
sl@0	3292	*
sl@0	3293	* Side effects:
sl@0	3294	* None.
sl@0	3295	*
sl@0	3296	*----------------------------------------------------------------------
sl@0	3297	*/
sl@0	3298
sl@0	3299	void
sl@0	3300	TclPrintByteCodeObj(interp, objPtr)
sl@0	3301	Tcl_Interp interp; / Used only for Tcl_GetStringFromObj. */
sl@0	3302	Tcl_Obj objPtr; / The bytecode object to disassemble. */
sl@0	3303	{
sl@0	3304	ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
sl@0	3305	unsigned char codeStart, codeLimit, *pc;
sl@0	3306	unsigned char codeDeltaNext, codeLengthNext;
sl@0	3307	unsigned char srcDeltaNext, srcLengthNext;
sl@0	3308	int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i;
sl@0	3309	Interp iPtr = (Interp ) *codePtr->interpHandle;
sl@0	3310
sl@0	3311	if (codePtr->refCount <= 0) {
sl@0	3312	return; /* already freed */
sl@0	3313	}
sl@0	3314
sl@0	3315	codeStart = codePtr->codeStart;
sl@0	3316	codeLimit = (codeStart + codePtr->numCodeBytes);
sl@0	3317	numCmds = codePtr->numCommands;
sl@0	3318
sl@0	3319	/*
sl@0	3320	* Print header lines describing the ByteCode.
sl@0	3321	*/
sl@0	3322
sl@0	3323	fprintf(stdout, "\nByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
sl@0	3324	(unsigned int) codePtr, codePtr->refCount,
sl@0	3325	codePtr->compileEpoch, (unsigned int) iPtr,
sl@0	3326	iPtr->compileEpoch);
sl@0	3327	fprintf(stdout, " Source ");
sl@0	3328	TclPrintSource(stdout, codePtr->source,
sl@0	3329	TclMin(codePtr->numSrcBytes, 55));
sl@0	3330	fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
sl@0	3331	numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes,
sl@0	3332	codePtr->numLitObjects, codePtr->numAuxDataItems,
sl@0	3333	codePtr->maxStackDepth,
sl@0	3334	#ifdef TCL_COMPILE_STATS
sl@0	3335	(codePtr->numSrcBytes?
sl@0	3336	((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
sl@0	3337	#else
sl@0	3338	0.0);
sl@0	3339	#endif
sl@0	3340	#ifdef TCL_COMPILE_STATS
sl@0	3341	fprintf(stdout,
sl@0	3342	" Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
sl@0	3343	codePtr->structureSize,
sl@0	3344	(sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
sl@0	3345	codePtr->numCodeBytes,
sl@0	3346	(codePtr->numLitObjects * sizeof(Tcl_Obj *)),
sl@0	3347	(codePtr->numExceptRanges * sizeof(ExceptionRange)),
sl@0	3348	(codePtr->numAuxDataItems * sizeof(AuxData)),
sl@0	3349	codePtr->numCmdLocBytes);
sl@0	3350	#endif /* TCL_COMPILE_STATS */
sl@0	3351
sl@0	3352	/*
sl@0	3353	* If the ByteCode is the compiled body of a Tcl procedure, print
sl@0	3354	* information about that procedure. Note that we don't know the
sl@0	3355	* procedure's name since ByteCode's can be shared among procedures.
sl@0	3356	*/
sl@0	3357
sl@0	3358	if (codePtr->procPtr != NULL) {
sl@0	3359	Proc *procPtr = codePtr->procPtr;
sl@0	3360	int numCompiledLocals = procPtr->numCompiledLocals;
sl@0	3361	fprintf(stdout,
sl@0	3362	" Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
sl@0	3363	(unsigned int) procPtr, procPtr->refCount, procPtr->numArgs,
sl@0	3364	numCompiledLocals);
sl@0	3365	if (numCompiledLocals > 0) {
sl@0	3366	CompiledLocal *localPtr = procPtr->firstLocalPtr;
sl@0	3367	for (i = 0; i < numCompiledLocals; i++) {
sl@0	3368	fprintf(stdout, " slot %d%s%s%s%s%s%s", i,
sl@0	3369	((localPtr->flags & VAR_SCALAR)? ", scalar" : ""),
sl@0	3370	((localPtr->flags & VAR_ARRAY)? ", array" : ""),
sl@0	3371	((localPtr->flags & VAR_LINK)? ", link" : ""),
sl@0	3372	((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""),
sl@0	3373	((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""),
sl@0	3374	((localPtr->flags & VAR_RESOLVED)? ", resolved" : ""));
sl@0	3375	if (TclIsVarTemporary(localPtr)) {
sl@0	3376	fprintf(stdout, "\n");
sl@0	3377	} else {
sl@0	3378	fprintf(stdout, ", \"%s\"\n", localPtr->name);
sl@0	3379	}
sl@0	3380	localPtr = localPtr->nextPtr;
sl@0	3381	}
sl@0	3382	}
sl@0	3383	}
sl@0	3384
sl@0	3385	/*
sl@0	3386	* Print the ExceptionRange array.
sl@0	3387	*/
sl@0	3388
sl@0	3389	if (codePtr->numExceptRanges > 0) {
sl@0	3390	fprintf(stdout, " Exception ranges %d, depth %d:\n",
sl@0	3391	codePtr->numExceptRanges, codePtr->maxExceptDepth);
sl@0	3392	for (i = 0; i < codePtr->numExceptRanges; i++) {
sl@0	3393	ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]);
sl@0	3394	fprintf(stdout, " %d: level %d, %s, pc %d-%d, ",
sl@0	3395	i, rangePtr->nestingLevel,
sl@0	3396	((rangePtr->type == LOOP_EXCEPTION_RANGE)
sl@0	3397	? "loop" : "catch"),
sl@0	3398	rangePtr->codeOffset,
sl@0	3399	(rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
sl@0	3400	switch (rangePtr->type) {
sl@0	3401	case LOOP_EXCEPTION_RANGE:
sl@0	3402	fprintf(stdout, "continue %d, break %d\n",
sl@0	3403	rangePtr->continueOffset, rangePtr->breakOffset);
sl@0	3404	break;
sl@0	3405	case CATCH_EXCEPTION_RANGE:
sl@0	3406	fprintf(stdout, "catch %d\n", rangePtr->catchOffset);
sl@0	3407	break;
sl@0	3408	default:
sl@0	3409	panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n",
sl@0	3410	rangePtr->type);
sl@0	3411	}
sl@0	3412	}
sl@0	3413	}
sl@0	3414
sl@0	3415	/*
sl@0	3416	* If there were no commands (e.g., an expression or an empty string
sl@0	3417	* was compiled), just print all instructions and return.
sl@0	3418	*/
sl@0	3419
sl@0	3420	if (numCmds == 0) {
sl@0	3421	pc = codeStart;
sl@0	3422	while (pc < codeLimit) {
sl@0	3423	fprintf(stdout, " ");
sl@0	3424	pc += TclPrintInstruction(codePtr, pc);
sl@0	3425	}
sl@0	3426	return;
sl@0	3427	}
sl@0	3428
sl@0	3429	/*
sl@0	3430	* Print table showing the code offset, source offset, and source
sl@0	3431	* length for each command. These are encoded as a sequence of bytes.
sl@0	3432	*/
sl@0	3433
sl@0	3434	fprintf(stdout, " Commands %d:", numCmds);
sl@0	3435	codeDeltaNext = codePtr->codeDeltaStart;
sl@0	3436	codeLengthNext = codePtr->codeLengthStart;
sl@0	3437	srcDeltaNext = codePtr->srcDeltaStart;
sl@0	3438	srcLengthNext = codePtr->srcLengthStart;
sl@0	3439	codeOffset = srcOffset = 0;
sl@0	3440	for (i = 0; i < numCmds; i++) {
sl@0	3441	if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
sl@0	3442	codeDeltaNext++;
sl@0	3443	delta = TclGetInt4AtPtr(codeDeltaNext);
sl@0	3444	codeDeltaNext += 4;
sl@0	3445	} else {
sl@0	3446	delta = TclGetInt1AtPtr(codeDeltaNext);
sl@0	3447	codeDeltaNext++;
sl@0	3448	}
sl@0	3449	codeOffset += delta;
sl@0	3450
sl@0	3451	if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
sl@0	3452	codeLengthNext++;
sl@0	3453	codeLen = TclGetInt4AtPtr(codeLengthNext);
sl@0	3454	codeLengthNext += 4;
sl@0	3455	} else {
sl@0	3456	codeLen = TclGetInt1AtPtr(codeLengthNext);
sl@0	3457	codeLengthNext++;
sl@0	3458	}
sl@0	3459
sl@0	3460	if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
sl@0	3461	srcDeltaNext++;
sl@0	3462	delta = TclGetInt4AtPtr(srcDeltaNext);
sl@0	3463	srcDeltaNext += 4;
sl@0	3464	} else {
sl@0	3465	delta = TclGetInt1AtPtr(srcDeltaNext);
sl@0	3466	srcDeltaNext++;
sl@0	3467	}
sl@0	3468	srcOffset += delta;
sl@0	3469
sl@0	3470	if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
sl@0	3471	srcLengthNext++;
sl@0	3472	srcLen = TclGetInt4AtPtr(srcLengthNext);
sl@0	3473	srcLengthNext += 4;
sl@0	3474	} else {
sl@0	3475	srcLen = TclGetInt1AtPtr(srcLengthNext);
sl@0	3476	srcLengthNext++;
sl@0	3477	}
sl@0	3478
sl@0	3479	fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d",
sl@0	3480	((i % 2)? " " : "\n "),
sl@0	3481	(i+1), codeOffset, (codeOffset + codeLen - 1),
sl@0	3482	srcOffset, (srcOffset + srcLen - 1));
sl@0	3483	}
sl@0	3484	if (numCmds > 0) {
sl@0	3485	fprintf(stdout, "\n");
sl@0	3486	}
sl@0	3487
sl@0	3488	/*
sl@0	3489	* Print each instruction. If the instruction corresponds to the start
sl@0	3490	* of a command, print the command's source. Note that we don't need
sl@0	3491	* the code length here.
sl@0	3492	*/
sl@0	3493
sl@0	3494	codeDeltaNext = codePtr->codeDeltaStart;
sl@0	3495	srcDeltaNext = codePtr->srcDeltaStart;
sl@0	3496	srcLengthNext = codePtr->srcLengthStart;
sl@0	3497	codeOffset = srcOffset = 0;
sl@0	3498	pc = codeStart;
sl@0	3499	for (i = 0; i < numCmds; i++) {
sl@0	3500	if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
sl@0	3501	codeDeltaNext++;
sl@0	3502	delta = TclGetInt4AtPtr(codeDeltaNext);
sl@0	3503	codeDeltaNext += 4;
sl@0	3504	} else {
sl@0	3505	delta = TclGetInt1AtPtr(codeDeltaNext);
sl@0	3506	codeDeltaNext++;
sl@0	3507	}
sl@0	3508	codeOffset += delta;
sl@0	3509
sl@0	3510	if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
sl@0	3511	srcDeltaNext++;
sl@0	3512	delta = TclGetInt4AtPtr(srcDeltaNext);
sl@0	3513	srcDeltaNext += 4;
sl@0	3514	} else {
sl@0	3515	delta = TclGetInt1AtPtr(srcDeltaNext);
sl@0	3516	srcDeltaNext++;
sl@0	3517	}
sl@0	3518	srcOffset += delta;
sl@0	3519
sl@0	3520	if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
sl@0	3521	srcLengthNext++;
sl@0	3522	srcLen = TclGetInt4AtPtr(srcLengthNext);
sl@0	3523	srcLengthNext += 4;
sl@0	3524	} else {
sl@0	3525	srcLen = TclGetInt1AtPtr(srcLengthNext);
sl@0	3526	srcLengthNext++;
sl@0	3527	}
sl@0	3528
sl@0	3529	/*
sl@0	3530	* Print instructions before command i.
sl@0	3531	*/
sl@0	3532
sl@0	3533	while ((pc-codeStart) < codeOffset) {
sl@0	3534	fprintf(stdout, " ");
sl@0	3535	pc += TclPrintInstruction(codePtr, pc);
sl@0	3536	}
sl@0	3537
sl@0	3538	fprintf(stdout, " Command %d: ", (i+1));
sl@0	3539	TclPrintSource(stdout, (codePtr->source + srcOffset),
sl@0	3540	TclMin(srcLen, 55));
sl@0	3541	fprintf(stdout, "\n");
sl@0	3542	}
sl@0	3543	if (pc < codeLimit) {
sl@0	3544	/*
sl@0	3545	* Print instructions after the last command.
sl@0	3546	*/
sl@0	3547
sl@0	3548	while (pc < codeLimit) {
sl@0	3549	fprintf(stdout, " ");
sl@0	3550	pc += TclPrintInstruction(codePtr, pc);
sl@0	3551	}
sl@0	3552	}
sl@0	3553	}
sl@0	3554	#endif /* TCL_COMPILE_DEBUG */
sl@0	3555
sl@0	3556	/*
sl@0	3557	*----------------------------------------------------------------------
sl@0	3558	*
sl@0	3559	* TclPrintInstruction --
sl@0	3560	*
sl@0	3561	* This procedure prints ("disassembles") one instruction from a
sl@0	3562	* bytecode object to stdout.
sl@0	3563	*
sl@0	3564	* Results:
sl@0	3565	* Returns the length in bytes of the current instruiction.
sl@0	3566	*
sl@0	3567	* Side effects:
sl@0	3568	* None.
sl@0	3569	*
sl@0	3570	*----------------------------------------------------------------------
sl@0	3571	*/
sl@0	3572
sl@0	3573	int
sl@0	3574	TclPrintInstruction(codePtr, pc)
sl@0	3575	ByteCode* codePtr; /* Bytecode containing the instruction. */
sl@0	3576	unsigned char pc; / Points to first byte of instruction. */
sl@0	3577	{
sl@0	3578	Proc *procPtr = codePtr->procPtr;
sl@0	3579	unsigned char opCode = *pc;
sl@0	3580	register InstructionDesc *instDesc = &tclInstructionTable[opCode];
sl@0	3581	unsigned char *codeStart = codePtr->codeStart;
sl@0	3582	unsigned int pcOffset = (pc - codeStart);
sl@0	3583	int opnd, i, j;
sl@0	3584
sl@0	3585	fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
sl@0	3586	for (i = 0; i < instDesc->numOperands; i++) {
sl@0	3587	switch (instDesc->opTypes[i]) {
sl@0	3588	case OPERAND_INT1:
sl@0	3589	opnd = TclGetInt1AtPtr(pc+1+i);
sl@0	3590	if ((i == 0) && ((opCode == INST_JUMP1)
sl@0	3591	\|\| (opCode == INST_JUMP_TRUE1)
sl@0	3592	\|\| (opCode == INST_JUMP_FALSE1))) {
sl@0	3593	fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
sl@0	3594	} else {
sl@0	3595	fprintf(stdout, "%d", opnd);
sl@0	3596	}
sl@0	3597	break;
sl@0	3598	case OPERAND_INT4:
sl@0	3599	opnd = TclGetInt4AtPtr(pc+1+i);
sl@0	3600	if ((i == 0) && ((opCode == INST_JUMP4)
sl@0	3601	\|\| (opCode == INST_JUMP_TRUE4)
sl@0	3602	\|\| (opCode == INST_JUMP_FALSE4))) {
sl@0	3603	fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
sl@0	3604	} else {
sl@0	3605	fprintf(stdout, "%d", opnd);
sl@0	3606	}
sl@0	3607	break;
sl@0	3608	case OPERAND_UINT1:
sl@0	3609	opnd = TclGetUInt1AtPtr(pc+1+i);
sl@0	3610	if ((i == 0) && (opCode == INST_PUSH1)) {
sl@0	3611	fprintf(stdout, "%u # ", (unsigned int) opnd);
sl@0	3612	TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
sl@0	3613	} else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1)
sl@0	3614	\|\| (opCode == INST_LOAD_ARRAY1)
sl@0	3615	\|\| (opCode == INST_STORE_SCALAR1)
sl@0	3616	\|\| (opCode == INST_STORE_ARRAY1))) {
sl@0	3617	int localCt = procPtr->numCompiledLocals;
sl@0	3618	CompiledLocal *localPtr = procPtr->firstLocalPtr;
sl@0	3619	if (opnd >= localCt) {
sl@0	3620	panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
sl@0	3621	(unsigned int) opnd, localCt);
sl@0	3622	return instDesc->numBytes;
sl@0	3623	}
sl@0	3624	for (j = 0; j < opnd; j++) {
sl@0	3625	localPtr = localPtr->nextPtr;
sl@0	3626	}
sl@0	3627	if (TclIsVarTemporary(localPtr)) {
sl@0	3628	fprintf(stdout, "%u # temp var %u",
sl@0	3629	(unsigned int) opnd, (unsigned int) opnd);
sl@0	3630	} else {
sl@0	3631	fprintf(stdout, "%u # var ", (unsigned int) opnd);
sl@0	3632	TclPrintSource(stdout, localPtr->name, 40);
sl@0	3633	}
sl@0	3634	} else {
sl@0	3635	fprintf(stdout, "%u ", (unsigned int) opnd);
sl@0	3636	}
sl@0	3637	break;
sl@0	3638	case OPERAND_UINT4:
sl@0	3639	opnd = TclGetUInt4AtPtr(pc+1+i);
sl@0	3640	if (opCode == INST_PUSH4) {
sl@0	3641	fprintf(stdout, "%u # ", opnd);
sl@0	3642	TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
sl@0	3643	} else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4)
sl@0	3644	\|\| (opCode == INST_LOAD_ARRAY4)
sl@0	3645	\|\| (opCode == INST_STORE_SCALAR4)
sl@0	3646	\|\| (opCode == INST_STORE_ARRAY4))) {
sl@0	3647	int localCt = procPtr->numCompiledLocals;
sl@0	3648	CompiledLocal *localPtr = procPtr->firstLocalPtr;
sl@0	3649	if (opnd >= localCt) {
sl@0	3650	panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
sl@0	3651	(unsigned int) opnd, localCt);
sl@0	3652	return instDesc->numBytes;
sl@0	3653	}
sl@0	3654	for (j = 0; j < opnd; j++) {
sl@0	3655	localPtr = localPtr->nextPtr;
sl@0	3656	}
sl@0	3657	if (TclIsVarTemporary(localPtr)) {
sl@0	3658	fprintf(stdout, "%u # temp var %u",
sl@0	3659	(unsigned int) opnd, (unsigned int) opnd);
sl@0	3660	} else {
sl@0	3661	fprintf(stdout, "%u # var ", (unsigned int) opnd);
sl@0	3662	TclPrintSource(stdout, localPtr->name, 40);
sl@0	3663	}
sl@0	3664	} else {
sl@0	3665	fprintf(stdout, "%u ", (unsigned int) opnd);
sl@0	3666	}
sl@0	3667	break;
sl@0	3668	case OPERAND_NONE:
sl@0	3669	default:
sl@0	3670	break;
sl@0	3671	}
sl@0	3672	}
sl@0	3673	fprintf(stdout, "\n");
sl@0	3674	return instDesc->numBytes;
sl@0	3675	}
sl@0	3676
sl@0	3677	/*
sl@0	3678	*----------------------------------------------------------------------
sl@0	3679	*
sl@0	3680	* TclPrintObject --
sl@0	3681	*
sl@0	3682	* This procedure prints up to a specified number of characters from
sl@0	3683	* the argument Tcl object's string representation to a specified file.
sl@0	3684	*
sl@0	3685	* Results:
sl@0	3686	* None.
sl@0	3687	*
sl@0	3688	* Side effects:
sl@0	3689	* Outputs characters to the specified file.
sl@0	3690	*
sl@0	3691	*----------------------------------------------------------------------
sl@0	3692	*/
sl@0	3693
sl@0	3694	void
sl@0	3695	TclPrintObject(outFile, objPtr, maxChars)
sl@0	3696	FILE outFile; / The file to print the source to. */
sl@0	3697	Tcl_Obj objPtr; / Points to the Tcl object whose string
sl@0	3698	* representation should be printed. */
sl@0	3699	int maxChars; /* Maximum number of chars to print. */
sl@0	3700	{
sl@0	3701	char *bytes;
sl@0	3702	int length;
sl@0	3703
sl@0	3704	bytes = Tcl_GetStringFromObj(objPtr, &length);
sl@0	3705	TclPrintSource(outFile, bytes, TclMin(length, maxChars));
sl@0	3706	}
sl@0	3707
sl@0	3708	/*
sl@0	3709	*----------------------------------------------------------------------
sl@0	3710	*
sl@0	3711	* TclPrintSource --
sl@0	3712	*
sl@0	3713	* This procedure prints up to a specified number of characters from
sl@0	3714	* the argument string to a specified file. It tries to produce legible
sl@0	3715	* output by adding backslashes as necessary.
sl@0	3716	*
sl@0	3717	* Results:
sl@0	3718	* None.
sl@0	3719	*
sl@0	3720	* Side effects:
sl@0	3721	* Outputs characters to the specified file.
sl@0	3722	*
sl@0	3723	*----------------------------------------------------------------------
sl@0	3724	*/
sl@0	3725
sl@0	3726	void
sl@0	3727	TclPrintSource(outFile, string, maxChars)
sl@0	3728	FILE outFile; / The file to print the source to. */
sl@0	3729	CONST char string; / The string to print. */
sl@0	3730	int maxChars; /* Maximum number of chars to print. */
sl@0	3731	{
sl@0	3732	register CONST char *p;
sl@0	3733	register int i = 0;
sl@0	3734
sl@0	3735	if (string == NULL) {
sl@0	3736	fprintf(outFile, "\"\"");
sl@0	3737	return;
sl@0	3738	}
sl@0	3739
sl@0	3740	fprintf(outFile, "\"");
sl@0	3741	p = string;
sl@0	3742	for (; (*p != '\0') && (i < maxChars); p++, i++) {
sl@0	3743	switch (*p) {
sl@0	3744	case '"':
sl@0	3745	fprintf(outFile, "\\\"");
sl@0	3746	continue;
sl@0	3747	case '\f':
sl@0	3748	fprintf(outFile, "\\f");
sl@0	3749	continue;
sl@0	3750	case '\n':
sl@0	3751	fprintf(outFile, "\\n");
sl@0	3752	continue;
sl@0	3753	case '\r':
sl@0	3754	fprintf(outFile, "\\r");
sl@0	3755	continue;
sl@0	3756	case '\t':
sl@0	3757	fprintf(outFile, "\\t");
sl@0	3758	continue;
sl@0	3759	case '\v':
sl@0	3760	fprintf(outFile, "\\v");
sl@0	3761	continue;
sl@0	3762	default:
sl@0	3763	fprintf(outFile, "%c", *p);
sl@0	3764	continue;
sl@0	3765	}
sl@0	3766	}
sl@0	3767	fprintf(outFile, "\"");
sl@0	3768	}
sl@0	3769
sl@0	3770	#ifdef TCL_COMPILE_STATS
sl@0	3771	/*
sl@0	3772	*----------------------------------------------------------------------
sl@0	3773	*
sl@0	3774	* RecordByteCodeStats --
sl@0	3775	*
sl@0	3776	* Accumulates various compilation-related statistics for each newly
sl@0	3777	* compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is
sl@0	3778	* compiled with the -DTCL_COMPILE_STATS flag
sl@0	3779	*
sl@0	3780	* Results:
sl@0	3781	* None.
sl@0	3782	*
sl@0	3783	* Side effects:
sl@0	3784	* Accumulates aggregate code-related statistics in the interpreter's
sl@0	3785	* ByteCodeStats structure. Records statistics specific to a ByteCode
sl@0	3786	* in its ByteCode structure.
sl@0	3787	*
sl@0	3788	*----------------------------------------------------------------------
sl@0	3789	*/
sl@0	3790
sl@0	3791	void
sl@0	3792	RecordByteCodeStats(codePtr)
sl@0	3793	ByteCode codePtr; / Points to ByteCode structure with info
sl@0	3794	* to add to accumulated statistics. */
sl@0	3795	{
sl@0	3796	Interp iPtr = (Interp ) *codePtr->interpHandle;
sl@0	3797	register ByteCodeStats *statsPtr = &(iPtr->stats);
sl@0	3798
sl@0	3799	statsPtr->numCompilations++;
sl@0	3800	statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes;
sl@0	3801	statsPtr->totalByteCodeBytes += (double) codePtr->structureSize;
sl@0	3802	statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes;
sl@0	3803	statsPtr->currentByteCodeBytes += (double) codePtr->structureSize;
sl@0	3804
sl@0	3805	statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++;
sl@0	3806	statsPtr->byteCodeCount[TclLog2((int)(codePtr->structureSize))]++;
sl@0	3807
sl@0	3808	statsPtr->currentInstBytes += (double) codePtr->numCodeBytes;
sl@0	3809	statsPtr->currentLitBytes +=
sl@0	3810	(double) (codePtr->numLitObjects * sizeof(Tcl_Obj *));
sl@0	3811	statsPtr->currentExceptBytes +=
sl@0	3812	(double) (codePtr->numExceptRanges * sizeof(ExceptionRange));
sl@0	3813	statsPtr->currentAuxBytes +=
sl@0	3814	(double) (codePtr->numAuxDataItems * sizeof(AuxData));
sl@0	3815	statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes;
sl@0	3816	}
sl@0	3817	#endif /* TCL_COMPILE_STATS */
sl@0	3818
sl@0	3819	/*
sl@0	3820	* Local Variables:
sl@0	3821	* mode: c
sl@0	3822	* c-basic-offset: 4
sl@0	3823	* fill-column: 78
sl@0	3824	* End:
sl@0	3825	*/
sl@0	3826

author	sl@SLION-WIN7.fritz.box
	Fri, 15 Jun 2012 03:10:57 +0200
changeset 0	bde4ae8d615e
permissions	-rw-r--r--