Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

tclExecute.c @ 5

Last change on this file since 5 was 5, checked in by zerwas, 11 years ago
update to Delphes-3.0.9
File size: 139.3 KB

Line
1	/*
2	* tclExecute.c --
3	*
4	* This file contains procedures that execute byte-compiled Tcl
5	* commands.
6	*
7	* Copyright (c) 1996-1997 Sun Microsystems, Inc.
8	*
9	* See the file "license.terms" for information on usage and redistribution
10	* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
11	*
12	* RCS: @(#) $Id: tclExecute.c,v 1.1 2008-06-04 13:58:06 demin Exp $
13	*/
14
15	#include "tclInt.h"
16	#include "tclCompile.h"
17
18	#ifdef NO_FLOAT_H
19	# include "../compat/float.h"
20	#else
21	# include <float.h>
22	#endif
23	#ifndef TCL_NO_MATH
24	#include "tclMath.h"
25	#endif
26
27	/*
28	* The stuff below is a bit of a hack so that this file can be used
29	* in environments that include no UNIX, i.e. no errno. Just define
30	* errno here.
31	*/
32
33	#ifndef TCL_GENERIC_ONLY
34	#include "tclPort.h"
35	#else
36	#define NO_ERRNO_H
37	#endif
38
39	#ifdef NO_ERRNO_H
40	int errno;
41	#define EDOM 33
42	#define ERANGE 34
43	#endif
44
45	/*
46	* Boolean flag indicating whether the Tcl bytecode interpreter has been
47	* initialized.
48	*/
49
50	static int execInitialized = 0;
51
52	/*
53	* Variable that controls whether execution tracing is enabled and, if so,
54	* what level of tracing is desired:
55	* 0: no execution tracing
56	* 1: trace invocations of Tcl procs only
57	* 2: trace invocations of all (not compiled away) commands
58	* 3: display each instruction executed
59	* This variable is linked to the Tcl variable "tcl_traceExec".
60	*/
61
62	int tclTraceExec = 0;
63
64	/*
65	* The following global variable is use to signal matherr that Tcl
66	* is responsible for the arithmetic, so errors can be handled in a
67	* fashion appropriate for Tcl. Zero means no Tcl math is in
68	* progress; non-zero means Tcl is doing math.
69	*/
70
71	int tcl_MathInProgress = 0;
72
73	/*
74	* The variable below serves no useful purpose except to generate
75	* a reference to matherr, so that the Tcl version of matherr is
76	* linked in rather than the system version. Without this reference
77	* the need for matherr won't be discovered during linking until after
78	* libtcl.a has been processed, so Tcl's version won't be used.
79	*/
80
81	#ifdef NEED_MATHERR
82	extern int matherr();
83	int (*tclMatherrPtr)() = matherr;
84	#endif
85
86	/*
87	* Array of instruction names.
88	*/
89
90	static char *opName[256];
91
92	/*
93	* Mapping from expression instruction opcodes to strings; used for error
94	* messages. Note that these entries must match the order and number of the
95	* expression opcodes (e.g., INST_LOR) in tclCompile.h.
96	*/
97
98	static char *operatorStrings[] = {
99	"\|\|", "&&", "\|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
100	"+", "-", "*", "/", "%", "+", "-", "~", "!",
101	"BUILTIN FUNCTION", "FUNCTION"
102	};
103
104	/*
105	* Mapping from Tcl result codes to strings; used for error and debugging
106	* messages.
107	*/
108
109	#ifdef TCL_COMPILE_DEBUG
110	static char *resultStrings[] = {
111	"TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
112	};
113	#endif /* TCL_COMPILE_DEBUG */
114
115	/*
116	* The following are statistics-related variables that record information
117	* about the bytecode compiler and interpreter's operation. This includes
118	* an array that records for each instruction how often it is executed.
119	*/
120
121	#ifdef TCL_COMPILE_STATS
122	static long numExecutions = 0;
123	static int instructionCount[256];
124	#endif /* TCL_COMPILE_STATS */
125
126	/*
127	* Macros for testing floating-point values for certain special cases. Test
128	* for not-a-number by comparing a value against itself; test for infinity
129	* by comparing against the largest floating-point value.
130	*/
131
132	#define IS_NAN(v) ((v) != (v))
133	#ifdef DBL_MAX
134	# define IS_INF(v) (((v) > DBL_MAX) \|\| ((v) < -DBL_MAX))
135	#else
136	# define IS_INF(v) 0
137	#endif
138
139	/*
140	* Macro to adjust the program counter and restart the instruction execution
141	* loop after each instruction is executed.
142	*/
143
144	#define ADJUST_PC(instBytes) \
145	pc += instBytes; continue
146
147	/*
148	* Macros used to cache often-referenced Tcl evaluation stack information
149	* in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
150	* pair must surround any call inside TclExecuteByteCode (and a few other
151	* procedures that use this scheme) that could result in a recursive call
152	* to TclExecuteByteCode.
153	*/
154
155	#define CACHE_STACK_INFO() \
156	stackPtr = eePtr->stackPtr; \
157	stackTop = eePtr->stackTop
158
159	#define DECACHE_STACK_INFO() \
160	eePtr->stackTop = stackTop
161
162	/*
163	* Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
164	* increments the object's ref count since it makes the stack have another
165	* reference pointing to the object. However, POP_OBJECT does not decrement
166	* the ref count. This is because the stack may hold the only reference to
167	* the object, so the object would be destroyed if its ref count were
168	* decremented before the caller had a chance to, e.g., store it in a
169	* variable. It is the caller's responsibility to decrement the ref count
170	* when it is finished with an object.
171	*/
172
173	#define STK_ITEM(offset) (stackPtr[stackTop + (offset)])
174	#define STK_OBJECT(offset) (STK_ITEM(offset).o)
175	#define STK_INT(offset) (STK_ITEM(offset).i)
176	#define STK_POINTER(offset) (STK_ITEM(offset).p)
177
178	/*
179	* WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT
180	* macro. The actual parameter might be an expression with side effects,
181	* and this ensures that it will be executed only once.
182	*/
183
184	#define PUSH_OBJECT(objPtr) \
185	Tcl_IncrRefCount(stackPtr[++stackTop].o = (objPtr))
186
187	#define POP_OBJECT() \
188	(stackPtr[stackTop--].o)
189
190	/*
191	* Macros used to trace instruction execution. The macros TRACE,
192	* TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode.
193	* O2S is only used in TRACE* calls to get a string from an object.
194	*
195	* NOTE THAT CLIENTS OF O2S ARE LIKELY TO FAIL IF THE OBJECT'S
196	* STRING REP CONTAINS NULLS.
197	*/
198
199	#ifdef TCL_COMPILE_DEBUG
200
201	#define O2S(objPtr) \
202	Tcl_GetStringFromObj((objPtr), &length)
203
204	#ifdef TCL_COMPILE_STATS
205	#define TRACE(a) \
206	if (traceInstructions) { \
207	fprintf(stdout, "%d: %d,%ld (%u) ", iPtr->numLevels, \
208	stackTop, (tclObjsAlloced - tclObjsFreed), \
209	(unsigned int)(pc - codePtr->codeStart)); \
210	printf a; \
211	fflush(stdout); \
212	}
213	#define TRACE_WITH_OBJ(a, objPtr) \
214	if (traceInstructions) { \
215	fprintf(stdout, "%d: %d,%ld (%u) ", iPtr->numLevels, \
216	stackTop, (tclObjsAlloced - tclObjsFreed), \
217	(unsigned int)(pc - codePtr->codeStart)); \
218	printf a; \
219	bytes = Tcl_GetStringFromObj((objPtr), &length); \
220	TclPrintSource(stdout, bytes, TclMin(length, 30)); \
221	fprintf(stdout, "\n"); \
222	fflush(stdout); \
223	}
224	#else /* not TCL_COMPILE_STATS */
225	#define TRACE(a) \
226	if (traceInstructions) { \
227	fprintf(stdout, "%d: %d (%u) ", iPtr->numLevels, stackTop, \
228	(unsigned int)(pc - codePtr->codeStart)); \
229	printf a; \
230	fflush(stdout); \
231	}
232	#define TRACE_WITH_OBJ(a, objPtr) \
233	if (traceInstructions) { \
234	fprintf(stdout, "%d: %d (%u) ", iPtr->numLevels, stackTop, \
235	(unsigned int)(pc - codePtr->codeStart)); \
236	printf a; \
237	bytes = Tcl_GetStringFromObj((objPtr), &length); \
238	TclPrintSource(stdout, bytes, TclMin(length, 30)); \
239	fprintf(stdout, "\n"); \
240	fflush(stdout); \
241	}
242	#endif /* TCL_COMPILE_STATS */
243
244	#else /* not TCL_COMPILE_DEBUG */
245
246	#define TRACE(a)
247	#define TRACE_WITH_OBJ(a, objPtr)
248	#define O2S(objPtr)
249
250	#endif /* TCL_COMPILE_DEBUG */
251
252	/*
253	* Declarations for local procedures to this file:
254	*/
255
256	static void CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp,
257	Trace tracePtr, Command cmdPtr,
258	char *command, int numChars,
259	int objc, Tcl_Obj *objv[]));
260	static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
261	Tcl_Obj *copyPtr));
262	static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp,
263	ExecEnv *eePtr, ClientData clientData));
264	static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
265	ExecEnv *eePtr, ClientData clientData));
266	static int ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
267	ExecEnv eePtr, int objc, Tcl_Obj *objv));
268	static int ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp,
269	ExecEnv *eePtr, ClientData clientData));
270	static int ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp,
271	ExecEnv *eePtr, ClientData clientData));
272	static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp,
273	ExecEnv *eePtr, ClientData clientData));
274	static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
275	ExecEnv *eePtr, ClientData clientData));
276	#ifdef TCL_COMPILE_STATS
277	static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
278	Tcl_Interp interp, int argc, char *argv));
279	#endif /* TCL_COMPILE_STATS */
280	static void FreeCmdNameInternalRep _ANSI_ARGS_((
281	Tcl_Obj *objPtr));
282	static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
283	ByteCode* codePtr, int *lengthPtr));
284	static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr));
285	static void IllegalExprOperandType _ANSI_ARGS_((
286	Tcl_Interp *interp, unsigned int opCode,
287	Tcl_Obj *opndPtr));
288	static void InitByteCodeExecution _ANSI_ARGS_((
289	Tcl_Interp *interp));
290	static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
291	static void RecordTracebackInfo _ANSI_ARGS_((Tcl_Interp *interp,
292	unsigned char pc, ByteCode codePtr));
293	static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
294	Tcl_Obj *objPtr));
295	#ifdef TCL_COMPILE_DEBUG
296	static char * StringForResultCode _ANSI_ARGS_((int result));
297	#endif /* TCL_COMPILE_DEBUG */
298	static void UpdateStringOfCmdName _ANSI_ARGS_((Tcl_Obj *objPtr));
299	#ifdef TCL_COMPILE_DEBUG
300	static void ValidatePcAndStackTop _ANSI_ARGS_((
301	ByteCode codePtr, unsigned char pc,
302	int stackTop, int stackLowerBound,
303	int stackUpperBound));
304	#endif /* TCL_COMPILE_DEBUG */
305
306	/*
307	* Table describing the built-in math functions. Entries in this table are
308	* indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
309	* operand byte.
310	*/
311
312	BuiltinFunc builtinFuncTable[] = {
313	#ifndef TCL_NO_MATH
314	{"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
315	{"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
316	{"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
317	{"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
318	{"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
319	{"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},
320	{"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh},
321	{"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp},
322	{"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor},
323	{"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod},
324	{"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot},
325	{"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log},
326	{"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10},
327	{"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow},
328	{"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin},
329	{"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh},
330	{"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt},
331	{"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan},
332	{"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh},
333	#endif
334	{"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
335	{"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
336	{"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
337	{"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
338	{0},
339	};
340
341	/*
342	* The structure below defines the command name Tcl object type by means of
343	* procedures that can be invoked by generic object code. Objects of this
344	* type cache the Command pointer that results from looking up command names
345	* in the command hashtable. Such objects appear as the zeroth ("command
346	* name") argument in a Tcl command.
347	*/
348
349	Tcl_ObjType tclCmdNameType = {
350	"cmdName", /* name */
351	FreeCmdNameInternalRep, /* freeIntRepProc */
352	DupCmdNameInternalRep, /* dupIntRepProc */
353	UpdateStringOfCmdName, /* updateStringProc */
354	SetCmdNameFromAny /* setFromAnyProc */
355	};
356
357	/*
358	*----------------------------------------------------------------------
359	*
360	* InitByteCodeExecution --
361	*
362	* This procedure is called once to initialize the Tcl bytecode
363	* interpreter.
364	*
365	* Results:
366	* None.
367	*
368	* Side effects:
369	* This procedure initializes the array of instruction names. If
370	* compiling with the TCL_COMPILE_STATS flag, it initializes the
371	* array that counts the executions of each instruction and it
372	* creates the "evalstats" command. It also registers the command name
373	* Tcl_ObjType. It also establishes the link between the Tcl
374	* "tcl_traceExec" and C "tclTraceExec" variables.
375	*
376	*----------------------------------------------------------------------
377	*/
378
379	static void
380	InitByteCodeExecution(interp)
381	Tcl_Interp interp; / Interpreter for which the Tcl variable
382	* "tcl_traceExec" is linked to control
383	* instruction tracing. */
384	{
385	int i;
386
387	Tcl_RegisterObjType(&tclCmdNameType);
388
389	(VOID *) memset(opName, 0, sizeof(opName));
390	for (i = 0; instructionTable[i].name != NULL; i++) {
391	opName[i] = instructionTable[i].name;
392	}
393
394	#ifdef TCL_COMPILE_STATS
395	(VOID *) memset(instructionCount, 0, sizeof(instructionCount));
396	(VOID *) memset(tclByteCodeCount, 0, sizeof(tclByteCodeCount));
397	(VOID *) memset(tclSourceCount, 0, sizeof(tclSourceCount));
398
399	Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd,
400	(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
401	#endif /* TCL_COMPILE_STATS */
402
403	if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
404	TCL_LINK_INT) != TCL_OK) {
405	panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
406	}
407	}
408
409	/*
410	*----------------------------------------------------------------------
411	*
412	* TclCreateExecEnv --
413	*
414	* This procedure creates a new execution environment for Tcl bytecode
415	* execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv
416	* is typically created once for each Tcl interpreter (Interp
417	* structure) and recursively passed to TclExecuteByteCode to execute
418	* ByteCode sequences for nested commands.
419	*
420	* Results:
421	* A newly allocated ExecEnv is returned. This points to an empty
422	* evaluation stack of the standard initial size.
423	*
424	* Side effects:
425	* The bytecode interpreter is also initialized here, as this
426	* procedure will be called before any call to TclExecuteByteCode.
427	*
428	*----------------------------------------------------------------------
429	*/
430
431	#define TCL_STACK_INITIAL_SIZE 2000
432
433	ExecEnv *
434	TclCreateExecEnv(interp)
435	Tcl_Interp interp; / Interpreter for which the execution
436	* environment is being created. */
437	{
438	ExecEnv eePtr = (ExecEnv ) ckalloc(sizeof(ExecEnv));
439
440	eePtr->stackPtr = (StackItem *)
441	ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(StackItem)));
442	eePtr->stackTop = -1;
443	eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1);
444
445	if (!execInitialized) {
446	TclInitAuxDataTypeTable();
447	InitByteCodeExecution(interp);
448	execInitialized = 1;
449	}
450
451	return eePtr;
452	}
453	#undef TCL_STACK_INITIAL_SIZE
454
455	/*
456	*----------------------------------------------------------------------
457	*
458	* TclDeleteExecEnv --
459	*
460	* Frees the storage for an ExecEnv.
461	*
462	* Results:
463	* None.
464	*
465	* Side effects:
466	* Storage for an ExecEnv and its contained storage (e.g. the
467	* evaluation stack) is freed.
468	*
469	*----------------------------------------------------------------------
470	*/
471
472	void
473	TclDeleteExecEnv(eePtr)
474	ExecEnv eePtr; / Execution environment to free. */
475	{
476	ckfree((char *) eePtr->stackPtr);
477	ckfree((char *) eePtr);
478	}
479
480	/*
481	*----------------------------------------------------------------------
482	*
483	* TclFinalizeExecEnv --
484	*
485	* Finalizes the execution environment setup so that it can be
486	* later reinitialized.
487	*
488	* Results:
489	* None.
490	*
491	* Side effects:
492	* After this call, the next time TclCreateExecEnv will be called
493	* it will call InitByteCodeExecution.
494	*
495	*----------------------------------------------------------------------
496	*/
497
498	void
499	TclFinalizeExecEnv()
500	{
501	execInitialized = 0;
502	TclFinalizeAuxDataTypeTable();
503	}
504
505	/*
506	*----------------------------------------------------------------------
507	*
508	* GrowEvaluationStack --
509	*
510	* This procedure grows a Tcl evaluation stack stored in an ExecEnv.
511	*
512	* Results:
513	* None.
514	*
515	* Side effects:
516	* The size of the evaluation stack is doubled.
517	*
518	*----------------------------------------------------------------------
519	*/
520
521	static void
522	GrowEvaluationStack(eePtr)
523	register ExecEnv eePtr; / Points to the ExecEnv with an evaluation
524	* stack to enlarge. */
525	{
526	/*
527	* The current Tcl stack elements are stored from eePtr->stackPtr[0]
528	* to eePtr->stackPtr[eePtr->stackEnd] (inclusive).
529	*/
530
531	int currElems = (eePtr->stackEnd + 1);
532	int newElems = 2*currElems;
533	int currBytes = currElems * sizeof(StackItem);
534	int newBytes = 2*currBytes;
535	StackItem newStackPtr = (StackItem ) ckalloc((unsigned) newBytes);
536
537	/*
538	* Copy the existing stack items to the new stack space, free the old
539	* storage if appropriate, and mark new space as malloc'ed.
540	*/
541
542	memcpy((VOID ) newStackPtr, (VOID ) eePtr->stackPtr,
543	(size_t) currBytes);
544	ckfree((char *) eePtr->stackPtr);
545	eePtr->stackPtr = newStackPtr;
546	eePtr->stackEnd = (newElems - 1); /* i.e. index of last usable item */
547	}
548
549	/*
550	*----------------------------------------------------------------------
551	*
552	* TclExecuteByteCode --
553	*
554	* This procedure executes the instructions of a ByteCode structure.
555	* It returns when a "done" instruction is executed or an error occurs.
556	*
557	* Results:
558	* The return value is one of the return codes defined in tcl.h
559	* (such as TCL_OK), and interp->objResultPtr refers to a Tcl object
560	* that either contains the result of executing the code or an
561	* error message.
562	*
563	* Side effects:
564	* Almost certainly, depending on the ByteCode's instructions.
565	*
566	*----------------------------------------------------------------------
567	*/
568
569	int
570	TclExecuteByteCode(interp, codePtr)
571	Tcl_Interp interp; / Token for command interpreter. */
572	ByteCode codePtr; / The bytecode sequence to interpret. */
573	{
574	Interp iPtr = (Interp ) interp;
575	ExecEnv *eePtr = iPtr->execEnvPtr;
576	/* Points to the execution environment. */
577	register StackItem *stackPtr = eePtr->stackPtr;
578	/* Cached evaluation stack base pointer. */
579	register int stackTop = eePtr->stackTop;
580	/* Cached top index of evaluation stack. */
581	Tcl_Obj **objArrayPtr = codePtr->objArrayPtr;
582	/* Points to the ByteCode's object array. */
583	unsigned char *pc = codePtr->codeStart;
584	/* The current program counter. */
585	unsigned char opCode; /* The current instruction code. */
586	int opnd; /* Current instruction's operand byte. */
587	int pcAdjustment; /* Hold pc adjustment after instruction. */
588	int initStackTop = stackTop;/* Stack top at start of execution. */
589	ExceptionRange rangePtr; / Points to closest loop or catch exception
590	* range enclosing the pc. Used by various
591	* instructions and processCatch to
592	* process break, continue, and errors. */
593	int result = TCL_OK; /* Return code returned after execution. */
594	int traceInstructions = (tclTraceExec == 3);
595	Tcl_Obj valuePtr, value2Ptr, namePtr, objPtr;
596	char *bytes;
597	int length;
598	long i;
599	Tcl_DString command; /* Used for debugging. If tclTraceExec >= 2
600	* holds a string representing the last
601	* command invoked. */
602
603	/*
604	* This procedure uses a stack to hold information about catch commands.
605	* This information is the current operand stack top when starting to
606	* execute the code for each catch command. It starts out with stack-
607	* allocated space but uses dynamically-allocated storage if needed.
608	*/
609
610	#define STATIC_CATCH_STACK_SIZE 5
611	int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
612	int *catchStackPtr = catchStackStorage;
613	int catchTop = -1;
614
615	/*
616	* THIS PROC FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
617	*/
618
619	if (tclTraceExec >= 2) {
620	PrintByteCodeInfo(codePtr);
621	#ifdef TCL_COMPILE_STATS
622	fprintf(stdout, " Starting stack top=%d, system objects=%ld\n",
623	eePtr->stackTop, (tclObjsAlloced - tclObjsFreed));
624	#else
625	fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop);
626	#endif /* TCL_COMPILE_STATS */
627	fflush(stdout);
628	}
629
630	#ifdef TCL_COMPILE_STATS
631	numExecutions++;
632	#endif /* TCL_COMPILE_STATS */
633
634	/*
635	* Make sure the catch stack is large enough to hold the maximum number
636	* of catch commands that could ever be executing at the same time. This
637	* will be no more than the exception range array's depth.
638	*/
639
640	if (codePtr->maxExcRangeDepth > STATIC_CATCH_STACK_SIZE) {
641	catchStackPtr = (int *)
642	ckalloc(codePtr->maxExcRangeDepth * sizeof(int));
643	}
644
645	/*
646	* Make sure the stack has enough room to execute this ByteCode.
647	*/
648
649	while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
650	GrowEvaluationStack(eePtr);
651	stackPtr = eePtr->stackPtr;
652	}
653
654	/*
655	* Initialize the buffer that holds a string containing the name and
656	* arguments for the last invoked command.
657	*/
658
659	Tcl_DStringInit(&command);
660
661	/*
662	* Loop executing instructions until a "done" instruction, a TCL_RETURN,
663	* or some error.
664	*/
665
666	for (;;) {
667	#ifdef TCL_COMPILE_DEBUG
668	ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop,
669	eePtr->stackEnd);
670	#else /* not TCL_COMPILE_DEBUG */
671	if (traceInstructions) {
672	#ifdef TCL_COMPILE_STATS
673	fprintf(stdout, "%d: %d,%ld ", iPtr->numLevels, stackTop,
674	(tclObjsAlloced - tclObjsFreed));
675	#else /* TCL_COMPILE_STATS */
676	fprintf(stdout, "%d: %d ", iPtr->numLevels, stackTop);
677	#endif /* TCL_COMPILE_STATS */
678	TclPrintInstruction(codePtr, pc);
679	fflush(stdout);
680	}
681	#endif /* TCL_COMPILE_DEBUG */
682
683	opCode = *pc;
684	#ifdef TCL_COMPILE_STATS
685	instructionCount[opCode]++;
686	#endif /* TCL_COMPILE_STATS */
687
688	switch (opCode) {
689	case INST_DONE:
690	/*
691	* Pop the topmost object from the stack, set the interpreter's
692	* object result to point to it, and return.
693	*/
694	valuePtr = POP_OBJECT();
695	Tcl_SetObjResult(interp, valuePtr);
696	TclDecrRefCount(valuePtr);
697	if (stackTop != initStackTop) {
698	fprintf(stderr, "\nTclExecuteByteCode: done instruction at pc %u: stack top %d != entry stack top %d\n",
699	(unsigned int)(pc - codePtr->codeStart),
700	(unsigned int) stackTop,
701	(unsigned int) initStackTop);
702	fprintf(stderr, " Source: ");
703	TclPrintSource(stderr, codePtr->source, 150);
704	panic("TclExecuteByteCode execution failure: end stack top != start stack top");
705	}
706	TRACE_WITH_OBJ(("done => return code=%d, result is ", result),
707	iPtr->objResultPtr);
708	goto done;
709
710	case INST_PUSH1:
711	valuePtr = objArrayPtr[TclGetUInt1AtPtr(pc+1)];
712	PUSH_OBJECT(valuePtr);
713	TRACE_WITH_OBJ(("push1 %u => ", TclGetUInt1AtPtr(pc+1)),
714	valuePtr);
715	ADJUST_PC(2);
716
717	case INST_PUSH4:
718	valuePtr = objArrayPtr[TclGetUInt4AtPtr(pc+1)];
719	PUSH_OBJECT(valuePtr);
720	TRACE_WITH_OBJ(("push4 %u => ", TclGetUInt4AtPtr(pc+1)),
721	valuePtr);
722	ADJUST_PC(5);
723
724	case INST_POP:
725	valuePtr = POP_OBJECT();
726	TRACE_WITH_OBJ(("pop => discarding "), valuePtr);
727	TclDecrRefCount(valuePtr); /* finished with pop'ed object. */
728	ADJUST_PC(1);
729
730	case INST_DUP:
731	valuePtr = stackPtr[stackTop].o;
732	PUSH_OBJECT(Tcl_DuplicateObj(valuePtr));
733	TRACE_WITH_OBJ(("dup => "), valuePtr);
734	ADJUST_PC(1);
735
736	case INST_CONCAT1:
737	opnd = TclGetUInt1AtPtr(pc+1);
738	{
739	Tcl_Obj *concatObjPtr;
740	int totalLen = 0;
741
742	/*
743	* Concatenate strings (with no separators) from the top
744	* opnd items on the stack starting with the deepest item.
745	* First, determine how many characters are needed.
746	*/
747
748	for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
749	valuePtr = stackPtr[i].o;
750	bytes = TclGetStringFromObj(valuePtr, &length);
751	if (bytes != NULL) {
752	totalLen += length;
753	}
754	}
755
756	/*
757	* Initialize the new append string object by appending the
758	* strings of the opnd stack objects. Also pop the objects.
759	*/
760
761	TclNewObj(concatObjPtr);
762	if (totalLen > 0) {
763	char p = (char ) ckalloc((unsigned) (totalLen + 1));
764	concatObjPtr->bytes = p;
765	concatObjPtr->length = totalLen;
766	for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
767	valuePtr = stackPtr[i].o;
768	bytes = TclGetStringFromObj(valuePtr, &length);
769	if (bytes != NULL) {
770	memcpy((VOID ) p, (VOID ) bytes,
771	(size_t) length);
772	p += length;
773	}
774	TclDecrRefCount(valuePtr);
775	}
776	*p = '\0';
777	} else {
778	for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
779	valuePtr = stackPtr[i].o;
780	Tcl_DecrRefCount(valuePtr);
781	}
782	}
783	stackTop -= opnd;
784
785	PUSH_OBJECT(concatObjPtr);
786	TRACE_WITH_OBJ(("concat %u => ", opnd), concatObjPtr);
787	ADJUST_PC(2);
788	}
789
790	case INST_INVOKE_STK4:
791	opnd = TclGetUInt4AtPtr(pc+1);
792	pcAdjustment = 5;
793	goto doInvocation;
794
795	case INST_INVOKE_STK1:
796	opnd = TclGetUInt1AtPtr(pc+1);
797	pcAdjustment = 2;
798
799	doInvocation:
800	{
801	char *cmdName;
802	Command cmdPtr; / Points to command's Command struct. */
803	int objc = opnd; /* The number of arguments. */
804	Tcl_Obj *objv; / The array of argument objects. */
805	Tcl_Obj objv0Ptr; / Holds objv[0], the command name. */
806	int newPcOffset = 0;
807	/* Instruction offset computed during
808	* break, continue, error processing.
809	* Init. to avoid compiler warning. */
810	Tcl_Command cmd;
811	#ifdef TCL_COMPILE_DEBUG
812	int isUnknownCmd = 0;
813	char cmdNameBuf[30];
814	#endif /* TCL_COMPILE_DEBUG */
815
816	/*
817	* If the interpreter was deleted, return an error.
818	*/
819
820	if (iPtr->flags & DELETED) {
821	Tcl_ResetResult(interp);
822	Tcl_AppendToObj(Tcl_GetObjResult(interp),
823	"attempt to call eval in deleted interpreter", -1);
824	Tcl_SetErrorCode(interp, "CORE", "IDELETE",
825	"attempt to call eval in deleted interpreter",
826	(char *) NULL);
827	result = TCL_ERROR;
828	goto checkForCatch;
829	}
830
831	objv = &(stackPtr[stackTop - (objc-1)].o);
832	objv0Ptr = objv[0];
833	cmdName = TclGetStringFromObj(objv0Ptr, (int *) NULL);
834
835	/*
836	* Find the procedure to execute this command. If there
837	* isn't one, then see if there is a command "unknown". If
838	* so, invoke it, passing it the original command words as
839	* arguments.
840	*
841	* We convert the objv[0] object to be a CmdName object.
842	* This caches a pointer to the Command structure for the
843	* command; this pointer is held in a ResolvedCmdName
844	* structure the object's internal rep. points to.
845	*/
846
847	cmd = Tcl_GetCommandFromObj(interp, objv0Ptr);
848	cmdPtr = (Command *) cmd;
849
850	/*
851	* If the command is still not found, handle it with the
852	* "unknown" proc.
853	*/
854
855	if (cmdPtr == NULL) {
856	cmd = Tcl_FindCommand(interp, "unknown",
857	(Tcl_Namespace ) NULL, /flags*/ TCL_GLOBAL_ONLY);
858	if (cmd == (Tcl_Command) NULL) {
859	Tcl_ResetResult(interp);
860	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
861	"invalid command name \"", cmdName, "\"",
862	(char *) NULL);
863	TRACE(("%s %u => unknown proc not found: ",
864	opName[opCode], objc));
865	result = TCL_ERROR;
866	goto checkForCatch;
867	}
868	cmdPtr = (Command *) cmd;
869	#ifdef TCL_COMPILE_DEBUG
870	isUnknownCmd = 1;
871	#endif /TCL_COMPILE_DEBUG/
872	stackTop++; /* need room for new inserted objv[0] */
873	for (i = objc; i >= 0; i--) {
874	objv[i+1] = objv[i];
875	}
876	objc++;
877	objv[0] = Tcl_NewStringObj("unknown", -1);
878	Tcl_IncrRefCount(objv[0]);
879	}
880
881	/*
882	* Call any trace procedures.
883	*/
884
885	if (iPtr->tracePtr != NULL) {
886	Trace tracePtr, nextTracePtr;
887
888	for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
889	tracePtr = nextTracePtr) {
890	nextTracePtr = tracePtr->nextPtr;
891	if (iPtr->numLevels <= tracePtr->level) {
892	int numChars;
893	char *cmd = GetSrcInfoForPc(pc, codePtr,
894	&numChars);
895	if (cmd != NULL) {
896	DECACHE_STACK_INFO();
897	CallTraceProcedure(interp, tracePtr, cmdPtr,
898	cmd, numChars, objc, objv);
899	CACHE_STACK_INFO();
900	}
901	}
902	}
903	}
904
905	/*
906	* Finally, invoke the command's Tcl_ObjCmdProc. First reset
907	* the interpreter's string and object results to their
908	* default empty values since they could have gotten changed
909	* by earlier invocations.
910	*/
911
912	Tcl_ResetResult(interp);
913
914	if (tclTraceExec >= 2) {
915	char buffer[50];
916
917	sprintf(buffer, "%d: (%u) invoking ", iPtr->numLevels,
918	(unsigned int)(pc - codePtr->codeStart));
919	Tcl_DStringAppend(&command, buffer, -1);
920
921	#ifdef TCL_COMPILE_DEBUG
922	if (traceInstructions) { /* tclTraceExec == 3 */
923	strncpy(cmdNameBuf, cmdName, 20);
924	TRACE(("%s %u => call ", opName[opCode],
925	(isUnknownCmd? objc-1 : objc)));
926	} else {
927	fprintf(stdout, "%s", buffer);
928	}
929	#else /* TCL_COMPILE_DEBUG */
930	fprintf(stdout, "%s", buffer);
931	#endif /TCL_COMPILE_DEBUG/
932
933	for (i = 0; i < objc; i++) {
934	bytes = TclGetStringFromObj(objv[i], &length);
935	TclPrintSource(stdout, bytes, TclMin(length, 15));
936	fprintf(stdout, " ");
937
938	sprintf(buffer, "\"%.*s\" ", TclMin(length, 15), bytes);
939	Tcl_DStringAppend(&command, buffer, -1);
940	}
941	fprintf(stdout, "\n");
942	fflush(stdout);
943
944	Tcl_DStringFree(&command);
945	}
946
947	iPtr->cmdCount++;
948	DECACHE_STACK_INFO();
949	result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
950	objc, objv);
951	if (Tcl_AsyncReady()) {
952	result = Tcl_AsyncInvoke(interp, result);
953	}
954	CACHE_STACK_INFO();
955
956	/*
957	* If the interpreter has a non-empty string result, the
958	* result object is either empty or stale because some
959	* procedure set interp->result directly. If so, move the
960	* string result to the result object, then reset the
961	* string result.
962	*/
963
964	if (*(iPtr->result) != 0) {
965	(void) Tcl_GetObjResult(interp);
966	}
967
968	/*
969	* Pop the objc top stack elements and decrement their ref
970	* counts.
971	*/
972
973	i = (stackTop - (objc-1));
974	while (i <= stackTop) {
975	valuePtr = stackPtr[i].o;
976	TclDecrRefCount(valuePtr);
977	i++;
978	}
979	stackTop -= objc;
980
981	/*
982	* Process the result of the Tcl_ObjCmdProc call.
983	*/
984
985	switch (result) {
986	case TCL_OK:
987	/*
988	* Push the call's object result and continue execution
989	* with the next instruction.
990	*/
991	PUSH_OBJECT(Tcl_GetObjResult(interp));
992	TRACE_WITH_OBJ(("%s %u => ...after \"%.20s\", result=",
993	opName[opCode], objc, cmdNameBuf),
994	Tcl_GetObjResult(interp));
995	ADJUST_PC(pcAdjustment);
996
997	case TCL_BREAK:
998	case TCL_CONTINUE:
999	/*
1000	* The invoked command requested a break or continue.
1001	* Find the closest enclosing loop or catch exception
1002	* range, if any. If a loop is found, terminate its
1003	* execution or skip to its next iteration. If the
1004	* closest is a catch exception range, jump to its
1005	* catchOffset. If no enclosing range is found, stop
1006	* execution and return the TCL_BREAK or TCL_CONTINUE.
1007	*/
1008	rangePtr = TclGetExceptionRangeForPc(pc,
1009	/catchOnly/ 0, codePtr);
1010	if (rangePtr == NULL) {
1011	TRACE(("%s %u => ... after \"%.20s\", no encl. loop or catch, returning %s\n",
1012	opName[opCode], objc, cmdNameBuf,
1013	StringForResultCode(result)));
1014	goto abnormalReturn; /* no catch exists to check */
1015	}
1016	switch (rangePtr->type) {
1017	case LOOP_EXCEPTION_RANGE:
1018	if (result == TCL_BREAK) {
1019	newPcOffset = rangePtr->breakOffset;
1020	} else if (rangePtr->continueOffset == -1) {
1021	TRACE(("%s %u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n",
1022	opName[opCode], objc, cmdNameBuf,
1023	StringForResultCode(result)));
1024	goto checkForCatch;
1025	} else {
1026	newPcOffset = rangePtr->continueOffset;
1027	}
1028	TRACE(("%s %u => ... after \"%.20s\", %s, range at %d, new pc %d\n",
1029	opName[opCode], objc, cmdNameBuf,
1030	StringForResultCode(result),
1031	rangePtr->codeOffset, newPcOffset));
1032	break;
1033	case CATCH_EXCEPTION_RANGE:
1034	TRACE(("%s %u => ... after \"%.20s\", %s...\n",
1035	opName[opCode], objc, cmdNameBuf,
1036	StringForResultCode(result)));
1037	goto processCatch; /* it will use rangePtr */
1038	default:
1039	panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
1040	}
1041	result = TCL_OK;
1042	pc = (codePtr->codeStart + newPcOffset);
1043	continue; /* restart outer instruction loop at pc */
1044
1045	case TCL_ERROR:
1046	/*
1047	* The invoked command returned an error. Look for an
1048	* enclosing catch exception range, if any.
1049	*/
1050	TRACE_WITH_OBJ(("%s %u => ... after \"%.20s\", TCL_ERROR ",
1051	opName[opCode], objc, cmdNameBuf),
1052	Tcl_GetObjResult(interp));
1053	goto checkForCatch;
1054
1055	case TCL_RETURN:
1056	/*
1057	* The invoked command requested that the current
1058	* procedure stop execution and return. First check
1059	* for an enclosing catch exception range, if any.
1060	*/
1061	TRACE(("%s %u => ... after \"%.20s\", TCL_RETURN\n",
1062	opName[opCode], objc, cmdNameBuf));
1063	goto checkForCatch;
1064
1065	default:
1066	TRACE_WITH_OBJ(("%s %u => ... after \"%.20s\", OTHER RETURN CODE %d ",
1067	opName[opCode], objc, cmdNameBuf, result),
1068	Tcl_GetObjResult(interp));
1069	goto checkForCatch;
1070	} /* end of switch on result from invoke instruction */
1071	}
1072
1073	case INST_EVAL_STK:
1074	objPtr = POP_OBJECT();
1075	DECACHE_STACK_INFO();
1076	result = Tcl_EvalObj(interp, objPtr);
1077	CACHE_STACK_INFO();
1078	if (result == TCL_OK) {
1079	/*
1080	* Normal return; push the eval's object result.
1081	*/
1082
1083	PUSH_OBJECT(Tcl_GetObjResult(interp));
1084	TRACE_WITH_OBJ(("evalStk \"%.30s\" => ", O2S(objPtr)),
1085	Tcl_GetObjResult(interp));
1086	TclDecrRefCount(objPtr);
1087	ADJUST_PC(1);
1088	} else if ((result == TCL_BREAK) \|\| (result == TCL_CONTINUE)) {
1089	/*
1090	* Find the closest enclosing loop or catch exception range,
1091	* if any. If a loop is found, terminate its execution or
1092	* skip to its next iteration. If the closest is a catch
1093	* exception range, jump to its catchOffset. If no enclosing
1094	* range is found, stop execution and return that same
1095	* TCL_BREAK or TCL_CONTINUE.
1096	*/
1097
1098	int newPcOffset = 0; /* Pc offset computed during break,
1099	* continue, error processing. Init.
1100	* to avoid compiler warning. */
1101
1102	rangePtr = TclGetExceptionRangeForPc(pc, /catchOnly/ 0,
1103	codePtr);
1104	if (rangePtr == NULL) {
1105	TRACE(("evalStk \"%.30s\" => no encl. loop or catch, returning %s\n",
1106	O2S(objPtr), StringForResultCode(result)));
1107	Tcl_DecrRefCount(objPtr);
1108	goto abnormalReturn; /* no catch exists to check */
1109	}
1110	switch (rangePtr->type) {
1111	case LOOP_EXCEPTION_RANGE:
1112	if (result == TCL_BREAK) {
1113	newPcOffset = rangePtr->breakOffset;
1114	} else if (rangePtr->continueOffset == -1) {
1115	TRACE(("evalStk \"%.30s\" => %s, loop w/o continue, checking for catch\n",
1116	O2S(objPtr), StringForResultCode(result)));
1117	Tcl_DecrRefCount(objPtr);
1118	goto checkForCatch;
1119	} else {
1120	newPcOffset = rangePtr->continueOffset;
1121	}
1122	result = TCL_OK;
1123	TRACE_WITH_OBJ(("evalStk \"%.30s\" => %s, range at %d, new pc %d ",
1124	O2S(objPtr), StringForResultCode(result),
1125	rangePtr->codeOffset, newPcOffset), valuePtr);
1126	break;
1127	case CATCH_EXCEPTION_RANGE:
1128	TRACE_WITH_OBJ(("evalStk \"%.30s\" => %s ",
1129	O2S(objPtr), StringForResultCode(result)),
1130	valuePtr);
1131	Tcl_DecrRefCount(objPtr);
1132	goto processCatch; /* it will use rangePtr */
1133	default:
1134	panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
1135	}
1136	Tcl_DecrRefCount(objPtr);
1137	pc = (codePtr->codeStart + newPcOffset);
1138	continue; /* restart outer instruction loop at pc */
1139	} else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */
1140	TRACE_WITH_OBJ(("evalStk \"%.30s\" => ERROR: ", O2S(objPtr)),
1141	Tcl_GetObjResult(interp));
1142	Tcl_DecrRefCount(objPtr);
1143	goto checkForCatch;
1144	}
1145
1146	case INST_EXPR_STK:
1147	objPtr = POP_OBJECT();
1148	Tcl_ResetResult(interp);
1149	DECACHE_STACK_INFO();
1150	result = Tcl_ExprObj(interp, objPtr, &valuePtr);
1151	CACHE_STACK_INFO();
1152	if (result != TCL_OK) {
1153	TRACE_WITH_OBJ(("exprStk \"%.30s\" => ERROR: ",
1154	O2S(objPtr)), Tcl_GetObjResult(interp));
1155	Tcl_DecrRefCount(objPtr);
1156	goto checkForCatch;
1157	}
1158	stackPtr[++stackTop].o = valuePtr; /* already has right refct */
1159	TRACE_WITH_OBJ(("exprStk \"%.30s\" => ", O2S(objPtr)), valuePtr);
1160	TclDecrRefCount(objPtr);
1161	ADJUST_PC(1);
1162
1163	case INST_LOAD_SCALAR4:
1164	opnd = TclGetInt4AtPtr(pc+1);
1165	pcAdjustment = 5;
1166	goto doLoadScalar;
1167
1168	case INST_LOAD_SCALAR1:
1169	opnd = TclGetUInt1AtPtr(pc+1);
1170	pcAdjustment = 2;
1171
1172	doLoadScalar:
1173	DECACHE_STACK_INFO();
1174	valuePtr = TclGetIndexedScalar(interp, opnd,
1175	/leaveErrorMsg/ 1);
1176	CACHE_STACK_INFO();
1177	if (valuePtr == NULL) {
1178	TRACE_WITH_OBJ(("%s %u => ERROR: ", opName[opCode], opnd),
1179	Tcl_GetObjResult(interp));
1180	result = TCL_ERROR;
1181	goto checkForCatch;
1182	}
1183	PUSH_OBJECT(valuePtr);
1184	TRACE_WITH_OBJ(("%s %u => ", opName[opCode], opnd), valuePtr);
1185	ADJUST_PC(pcAdjustment);
1186
1187	case INST_LOAD_SCALAR_STK:
1188	namePtr = POP_OBJECT();
1189	DECACHE_STACK_INFO();
1190	valuePtr = Tcl_ObjGetVar2(interp, namePtr, (Tcl_Obj *) NULL,
1191	TCL_LEAVE_ERR_MSG);
1192	CACHE_STACK_INFO();
1193	if (valuePtr == NULL) {
1194	TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ERROR: ",
1195	O2S(namePtr)), Tcl_GetObjResult(interp));
1196	Tcl_DecrRefCount(namePtr);
1197	result = TCL_ERROR;
1198	goto checkForCatch;
1199	}
1200	PUSH_OBJECT(valuePtr);
1201	TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ",
1202	O2S(namePtr)), valuePtr);
1203	TclDecrRefCount(namePtr);
1204	ADJUST_PC(1);
1205
1206	case INST_LOAD_ARRAY4:
1207	opnd = TclGetUInt4AtPtr(pc+1);
1208	pcAdjustment = 5;
1209	goto doLoadArray;
1210
1211	case INST_LOAD_ARRAY1:
1212	opnd = TclGetUInt1AtPtr(pc+1);
1213	pcAdjustment = 2;
1214
1215	doLoadArray:
1216	{
1217	Tcl_Obj *elemPtr = POP_OBJECT();
1218
1219	DECACHE_STACK_INFO();
1220	valuePtr = TclGetElementOfIndexedArray(interp, opnd,
1221	elemPtr, /leaveErrorMsg/ 1);
1222	CACHE_STACK_INFO();
1223	if (valuePtr == NULL) {
1224	TRACE_WITH_OBJ(("%s %u \"%.30s\" => ERROR: ",
1225	opName[opCode], opnd, O2S(elemPtr)),
1226	Tcl_GetObjResult(interp));
1227	Tcl_DecrRefCount(elemPtr);
1228	result = TCL_ERROR;
1229	goto checkForCatch;
1230	}
1231	PUSH_OBJECT(valuePtr);
1232	TRACE_WITH_OBJ(("%s %u \"%.30s\" => ",
1233	opName[opCode], opnd, O2S(elemPtr)), valuePtr);
1234	TclDecrRefCount(elemPtr);
1235	}
1236	ADJUST_PC(pcAdjustment);
1237
1238	case INST_LOAD_ARRAY_STK:
1239	{
1240	Tcl_Obj *elemPtr = POP_OBJECT();
1241
1242	namePtr = POP_OBJECT();
1243	DECACHE_STACK_INFO();
1244	valuePtr = Tcl_ObjGetVar2(interp, namePtr, elemPtr,
1245	TCL_LEAVE_ERR_MSG);
1246	CACHE_STACK_INFO();
1247	if (valuePtr == NULL) {
1248	TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ERROR: ",
1249	O2S(namePtr), O2S(elemPtr)),
1250	Tcl_GetObjResult(interp));
1251	Tcl_DecrRefCount(namePtr);
1252	Tcl_DecrRefCount(elemPtr);
1253	result = TCL_ERROR;
1254	goto checkForCatch;
1255	}
1256	PUSH_OBJECT(valuePtr);
1257	TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ",
1258	O2S(namePtr), O2S(elemPtr)), valuePtr);
1259	TclDecrRefCount(namePtr);
1260	TclDecrRefCount(elemPtr);
1261	}
1262	ADJUST_PC(1);
1263
1264	case INST_LOAD_STK:
1265	namePtr = POP_OBJECT();
1266	DECACHE_STACK_INFO();
1267	valuePtr = Tcl_ObjGetVar2(interp, namePtr, NULL,
1268	TCL_PARSE_PART1\|TCL_LEAVE_ERR_MSG);
1269	CACHE_STACK_INFO();
1270	if (valuePtr == NULL) {
1271	TRACE_WITH_OBJ(("loadStk \"%.30s\" => ERROR: ",
1272	O2S(namePtr)), Tcl_GetObjResult(interp));
1273	Tcl_DecrRefCount(namePtr);
1274	result = TCL_ERROR;
1275	goto checkForCatch;
1276	}
1277	PUSH_OBJECT(valuePtr);
1278	TRACE_WITH_OBJ(("loadStk \"%.30s\" => ", O2S(namePtr)),
1279	valuePtr);
1280	TclDecrRefCount(namePtr);
1281	ADJUST_PC(1);
1282
1283	case INST_STORE_SCALAR4:
1284	opnd = TclGetUInt4AtPtr(pc+1);
1285	pcAdjustment = 5;
1286	goto doStoreScalar;
1287
1288	case INST_STORE_SCALAR1:
1289	opnd = TclGetUInt1AtPtr(pc+1);
1290	pcAdjustment = 2;
1291
1292	doStoreScalar:
1293	valuePtr = POP_OBJECT();
1294	DECACHE_STACK_INFO();
1295	value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr,
1296	/leaveErrorMsg/ 1);
1297	CACHE_STACK_INFO();
1298	if (value2Ptr == NULL) {
1299	TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ERROR: ",
1300	opName[opCode], opnd, O2S(valuePtr)),
1301	Tcl_GetObjResult(interp));
1302	Tcl_DecrRefCount(valuePtr);
1303	result = TCL_ERROR;
1304	goto checkForCatch;
1305	}
1306	PUSH_OBJECT(value2Ptr);
1307	TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ",
1308	opName[opCode], opnd, O2S(valuePtr)), value2Ptr);
1309	TclDecrRefCount(valuePtr);
1310	ADJUST_PC(pcAdjustment);
1311
1312	case INST_STORE_SCALAR_STK:
1313	valuePtr = POP_OBJECT();
1314	namePtr = POP_OBJECT();
1315	DECACHE_STACK_INFO();
1316	value2Ptr = Tcl_ObjSetVar2(interp, namePtr, NULL, valuePtr,
1317	TCL_LEAVE_ERR_MSG);
1318	CACHE_STACK_INFO();
1319	if (value2Ptr == NULL) {
1320	TRACE_WITH_OBJ(
1321	("storeScalarStk \"%.30s\" <- \"%.30s\" => ERROR: ",
1322	O2S(namePtr), O2S(valuePtr)),
1323	Tcl_GetObjResult(interp));
1324	Tcl_DecrRefCount(namePtr);
1325	Tcl_DecrRefCount(valuePtr);
1326	result = TCL_ERROR;
1327	goto checkForCatch;
1328	}
1329	PUSH_OBJECT(value2Ptr);
1330	TRACE_WITH_OBJ(
1331	("storeScalarStk \"%.30s\" <- \"%.30s\" => ",
1332	O2S(namePtr),
1333	O2S(valuePtr)),
1334	value2Ptr);
1335	TclDecrRefCount(namePtr);
1336	TclDecrRefCount(valuePtr);
1337	ADJUST_PC(1);
1338
1339	case INST_STORE_ARRAY4:
1340	opnd = TclGetUInt4AtPtr(pc+1);
1341	pcAdjustment = 5;
1342	goto doStoreArray;
1343
1344	case INST_STORE_ARRAY1:
1345	opnd = TclGetUInt1AtPtr(pc+1);
1346	pcAdjustment = 2;
1347
1348	doStoreArray:
1349	{
1350	Tcl_Obj *elemPtr;
1351
1352	valuePtr = POP_OBJECT();
1353	elemPtr = POP_OBJECT();
1354	DECACHE_STACK_INFO();
1355	value2Ptr = TclSetElementOfIndexedArray(interp, opnd,
1356	elemPtr, valuePtr, TCL_LEAVE_ERR_MSG);
1357	CACHE_STACK_INFO();
1358	if (value2Ptr == NULL) {
1359	TRACE_WITH_OBJ(
1360	("%s %u \"%.30s\" <- \"%.30s\" => ERROR: ",
1361	opName[opCode], opnd, O2S(elemPtr),
1362	O2S(valuePtr)), Tcl_GetObjResult(interp));
1363	Tcl_DecrRefCount(elemPtr);
1364	Tcl_DecrRefCount(valuePtr);
1365	result = TCL_ERROR;
1366	goto checkForCatch;
1367	}
1368	PUSH_OBJECT(value2Ptr);
1369	TRACE_WITH_OBJ(("%s %u \"%.30s\" <- \"%.30s\" => ",
1370	opName[opCode], opnd, O2S(elemPtr), O2S(valuePtr)),
1371	value2Ptr);
1372	TclDecrRefCount(elemPtr);
1373	TclDecrRefCount(valuePtr);
1374	}
1375	ADJUST_PC(pcAdjustment);
1376
1377	case INST_STORE_ARRAY_STK:
1378	{
1379	Tcl_Obj *elemPtr;
1380
1381	valuePtr = POP_OBJECT();
1382	elemPtr = POP_OBJECT();
1383	namePtr = POP_OBJECT();
1384	DECACHE_STACK_INFO();
1385	value2Ptr = Tcl_ObjSetVar2(interp, namePtr, elemPtr,
1386	valuePtr, TCL_LEAVE_ERR_MSG);
1387	CACHE_STACK_INFO();
1388	if (value2Ptr == NULL) {
1389	TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
1390	O2S(namePtr), O2S(elemPtr), O2S(valuePtr)),
1391	Tcl_GetObjResult(interp));
1392	Tcl_DecrRefCount(namePtr);
1393	Tcl_DecrRefCount(elemPtr);
1394	Tcl_DecrRefCount(valuePtr);
1395	result = TCL_ERROR;
1396	goto checkForCatch;
1397	}
1398	PUSH_OBJECT(value2Ptr);
1399	TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ",
1400	O2S(namePtr), O2S(elemPtr), O2S(valuePtr)),
1401	value2Ptr);
1402	TclDecrRefCount(namePtr);
1403	TclDecrRefCount(elemPtr);
1404	TclDecrRefCount(valuePtr);
1405	}
1406	ADJUST_PC(1);
1407
1408	case INST_STORE_STK:
1409	valuePtr = POP_OBJECT();
1410	namePtr = POP_OBJECT();
1411	DECACHE_STACK_INFO();
1412	value2Ptr = Tcl_ObjSetVar2(interp, namePtr, NULL, valuePtr,
1413	TCL_PARSE_PART1\|TCL_LEAVE_ERR_MSG);
1414	CACHE_STACK_INFO();
1415	if (value2Ptr == NULL) {
1416	TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ERROR: ",
1417	O2S(namePtr), O2S(valuePtr)),
1418	Tcl_GetObjResult(interp));
1419	Tcl_DecrRefCount(namePtr);
1420	Tcl_DecrRefCount(valuePtr);
1421	result = TCL_ERROR;
1422	goto checkForCatch;
1423	}
1424	PUSH_OBJECT(value2Ptr);
1425	TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ",
1426	O2S(namePtr), O2S(valuePtr)), value2Ptr);
1427	TclDecrRefCount(namePtr);
1428	TclDecrRefCount(valuePtr);
1429	ADJUST_PC(1);
1430
1431	case INST_INCR_SCALAR1:
1432	opnd = TclGetUInt1AtPtr(pc+1);
1433	valuePtr = POP_OBJECT();
1434	if (valuePtr->typePtr != &tclIntType) {
1435	result = tclIntType.setFromAnyProc(interp, valuePtr);
1436	if (result != TCL_OK) {
1437	TRACE_WITH_OBJ(("incrScalar1 %u (by %s) => ERROR converting increment amount to int: ",
1438	opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
1439	Tcl_DecrRefCount(valuePtr);
1440	goto checkForCatch;
1441	}
1442	}
1443	i = valuePtr->internalRep.longValue;
1444	DECACHE_STACK_INFO();
1445	value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
1446	CACHE_STACK_INFO();
1447	if (value2Ptr == NULL) {
1448	TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ERROR: ",
1449	opnd, i), Tcl_GetObjResult(interp));
1450	Tcl_DecrRefCount(valuePtr);
1451	result = TCL_ERROR;
1452	goto checkForCatch;
1453	}
1454	PUSH_OBJECT(value2Ptr);
1455	TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ", opnd, i),
1456	value2Ptr);
1457	TclDecrRefCount(valuePtr);
1458	ADJUST_PC(2);
1459
1460	case INST_INCR_SCALAR_STK:
1461	case INST_INCR_STK:
1462	valuePtr = POP_OBJECT();
1463	namePtr = POP_OBJECT();
1464	if (valuePtr->typePtr != &tclIntType) {
1465	result = tclIntType.setFromAnyProc(interp, valuePtr);
1466	if (result != TCL_OK) {
1467	TRACE_WITH_OBJ(("%s \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
1468	opName[opCode], O2S(namePtr), O2S(valuePtr)),
1469	Tcl_GetObjResult(interp));
1470	Tcl_DecrRefCount(namePtr);
1471	Tcl_DecrRefCount(valuePtr);
1472	goto checkForCatch;
1473	}
1474	}
1475	i = valuePtr->internalRep.longValue;
1476	DECACHE_STACK_INFO();
1477	value2Ptr = TclIncrVar2(interp, namePtr, (Tcl_Obj *) NULL, i,
1478	/part1NotParsed/ (opCode == INST_INCR_STK));
1479	CACHE_STACK_INFO();
1480	if (value2Ptr == NULL) {
1481	TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ERROR: ",
1482	opName[opCode], O2S(namePtr), i),
1483	Tcl_GetObjResult(interp));
1484	Tcl_DecrRefCount(namePtr);
1485	Tcl_DecrRefCount(valuePtr);
1486	result = TCL_ERROR;
1487	goto checkForCatch;
1488	}
1489	PUSH_OBJECT(value2Ptr);
1490	TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ",
1491	opName[opCode], O2S(namePtr), i), value2Ptr);
1492	Tcl_DecrRefCount(namePtr);
1493	Tcl_DecrRefCount(valuePtr);
1494	ADJUST_PC(1);
1495
1496	case INST_INCR_ARRAY1:
1497	{
1498	Tcl_Obj *elemPtr;
1499
1500	opnd = TclGetUInt1AtPtr(pc+1);
1501	valuePtr = POP_OBJECT();
1502	elemPtr = POP_OBJECT();
1503	if (valuePtr->typePtr != &tclIntType) {
1504	result = tclIntType.setFromAnyProc(interp, valuePtr);
1505	if (result != TCL_OK) {
1506	TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
1507	opnd, O2S(elemPtr), O2S(valuePtr)),
1508	Tcl_GetObjResult(interp));
1509	Tcl_DecrRefCount(elemPtr);
1510	Tcl_DecrRefCount(valuePtr);
1511	goto checkForCatch;
1512	}
1513	}
1514	i = valuePtr->internalRep.longValue;
1515	DECACHE_STACK_INFO();
1516	value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
1517	elemPtr, i);
1518	CACHE_STACK_INFO();
1519	if (value2Ptr == NULL) {
1520	TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ERROR: ",
1521	opnd, O2S(elemPtr), i),
1522	Tcl_GetObjResult(interp));
1523	Tcl_DecrRefCount(elemPtr);
1524	Tcl_DecrRefCount(valuePtr);
1525	result = TCL_ERROR;
1526	goto checkForCatch;
1527	}
1528	PUSH_OBJECT(value2Ptr);
1529	TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ",
1530	opnd, O2S(elemPtr), i), value2Ptr);
1531	Tcl_DecrRefCount(elemPtr);
1532	Tcl_DecrRefCount(valuePtr);
1533	}
1534	ADJUST_PC(2);
1535
1536	case INST_INCR_ARRAY_STK:
1537	{
1538	Tcl_Obj *elemPtr;
1539
1540	valuePtr = POP_OBJECT();
1541	elemPtr = POP_OBJECT();
1542	namePtr = POP_OBJECT();
1543	if (valuePtr->typePtr != &tclIntType) {
1544	result = tclIntType.setFromAnyProc(interp, valuePtr);
1545	if (result != TCL_OK) {
1546	TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ",
1547	O2S(namePtr), O2S(elemPtr), O2S(valuePtr)),
1548	Tcl_GetObjResult(interp));
1549	Tcl_DecrRefCount(namePtr);
1550	Tcl_DecrRefCount(elemPtr);
1551	Tcl_DecrRefCount(valuePtr);
1552	goto checkForCatch;
1553	}
1554	}
1555	i = valuePtr->internalRep.longValue;
1556	DECACHE_STACK_INFO();
1557	value2Ptr = TclIncrVar2(interp, namePtr, elemPtr, i,
1558	/part1NotParsed/ 0);
1559	CACHE_STACK_INFO();
1560	if (value2Ptr == NULL) {
1561	TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ERROR: ",
1562	O2S(namePtr), O2S(elemPtr), i),
1563	Tcl_GetObjResult(interp));
1564	Tcl_DecrRefCount(namePtr);
1565	Tcl_DecrRefCount(elemPtr);
1566	Tcl_DecrRefCount(valuePtr);
1567	result = TCL_ERROR;
1568	goto checkForCatch;
1569	}
1570	PUSH_OBJECT(value2Ptr);
1571	TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ",
1572	O2S(namePtr), O2S(elemPtr), i), value2Ptr);
1573	Tcl_DecrRefCount(namePtr);
1574	Tcl_DecrRefCount(elemPtr);
1575	Tcl_DecrRefCount(valuePtr);
1576	}
1577	ADJUST_PC(1);
1578
1579	case INST_INCR_SCALAR1_IMM:
1580	opnd = TclGetUInt1AtPtr(pc+1);
1581	i = TclGetInt1AtPtr(pc+2);
1582	DECACHE_STACK_INFO();
1583	value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
1584	CACHE_STACK_INFO();
1585	if (value2Ptr == NULL) {
1586	TRACE_WITH_OBJ(("incrScalar1Imm %u %ld => ERROR: ",
1587	opnd, i), Tcl_GetObjResult(interp));
1588	result = TCL_ERROR;
1589	goto checkForCatch;
1590	}
1591	PUSH_OBJECT(value2Ptr);
1592	TRACE_WITH_OBJ(("incrScalar1Imm %u %ld => ", opnd, i),
1593	value2Ptr);
1594	ADJUST_PC(3);
1595
1596	case INST_INCR_SCALAR_STK_IMM:
1597	case INST_INCR_STK_IMM:
1598	namePtr = POP_OBJECT();
1599	i = TclGetInt1AtPtr(pc+1);
1600	DECACHE_STACK_INFO();
1601	value2Ptr = TclIncrVar2(interp, namePtr, (Tcl_Obj *) NULL, i,
1602	/part1NotParsed/ (opCode == INST_INCR_STK_IMM));
1603	CACHE_STACK_INFO();
1604	if (value2Ptr == NULL) {
1605	TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ERROR: ",
1606	opName[opCode], O2S(namePtr), i),
1607	Tcl_GetObjResult(interp));
1608	result = TCL_ERROR;
1609	Tcl_DecrRefCount(namePtr);
1610	goto checkForCatch;
1611	}
1612	PUSH_OBJECT(value2Ptr);
1613	TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ",
1614	opName[opCode], O2S(namePtr), i), value2Ptr);
1615	TclDecrRefCount(namePtr);
1616	ADJUST_PC(2);
1617
1618	case INST_INCR_ARRAY1_IMM:
1619	{
1620	Tcl_Obj *elemPtr;
1621
1622	opnd = TclGetUInt1AtPtr(pc+1);
1623	i = TclGetInt1AtPtr(pc+2);
1624	elemPtr = POP_OBJECT();
1625	DECACHE_STACK_INFO();
1626	value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
1627	elemPtr, i);
1628	CACHE_STACK_INFO();
1629	if (value2Ptr == NULL) {
1630	TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ERROR: ",
1631	opnd, O2S(elemPtr), i),
1632	Tcl_GetObjResult(interp));
1633	Tcl_DecrRefCount(elemPtr);
1634	result = TCL_ERROR;
1635	goto checkForCatch;
1636	}
1637	PUSH_OBJECT(value2Ptr);
1638	TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ",
1639	opnd, O2S(elemPtr), i), value2Ptr);
1640	Tcl_DecrRefCount(elemPtr);
1641	}
1642	ADJUST_PC(3);
1643
1644	case INST_INCR_ARRAY_STK_IMM:
1645	{
1646	Tcl_Obj *elemPtr;
1647
1648	i = TclGetInt1AtPtr(pc+1);
1649	elemPtr = POP_OBJECT();
1650	namePtr = POP_OBJECT();
1651	DECACHE_STACK_INFO();
1652	value2Ptr = TclIncrVar2(interp, namePtr, elemPtr, i,
1653	/part1NotParsed/ 0);
1654	CACHE_STACK_INFO();
1655	if (value2Ptr == NULL) {
1656	TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ERROR: ",
1657	O2S(namePtr), O2S(elemPtr), i),
1658	Tcl_GetObjResult(interp));
1659	Tcl_DecrRefCount(namePtr);
1660	Tcl_DecrRefCount(elemPtr);
1661	result = TCL_ERROR;
1662	goto checkForCatch;
1663	}
1664	PUSH_OBJECT(value2Ptr);
1665	TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ",
1666	O2S(namePtr), O2S(elemPtr), i), value2Ptr);
1667	Tcl_DecrRefCount(namePtr);
1668	Tcl_DecrRefCount(elemPtr);
1669	}
1670	ADJUST_PC(2);
1671
1672	case INST_JUMP1:
1673	opnd = TclGetInt1AtPtr(pc+1);
1674	TRACE(("jump1 %d => new pc %u\n", opnd,
1675	(unsigned int)(pc + opnd - codePtr->codeStart)));
1676	ADJUST_PC(opnd);
1677
1678	case INST_JUMP4:
1679	opnd = TclGetInt4AtPtr(pc+1);
1680	TRACE(("jump4 %d => new pc %u\n", opnd,
1681	(unsigned int)(pc + opnd - codePtr->codeStart)));
1682	ADJUST_PC(opnd);
1683
1684	case INST_JUMP_TRUE4:
1685	opnd = TclGetInt4AtPtr(pc+1);
1686	pcAdjustment = 5;
1687	goto doJumpTrue;
1688
1689	case INST_JUMP_TRUE1:
1690	opnd = TclGetInt1AtPtr(pc+1);
1691	pcAdjustment = 2;
1692
1693	doJumpTrue:
1694	{
1695	int b;
1696
1697	valuePtr = POP_OBJECT();
1698	if (valuePtr->typePtr == &tclIntType) {
1699	b = (valuePtr->internalRep.longValue != 0);
1700	} else if (valuePtr->typePtr == &tclDoubleType) {
1701	b = (valuePtr->internalRep.doubleValue != 0.0);
1702	} else {
1703	result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
1704	if (result != TCL_OK) {
1705	TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode],
1706	opnd), Tcl_GetObjResult(interp));
1707	Tcl_DecrRefCount(valuePtr);
1708	goto checkForCatch;
1709	}
1710	}
1711	if (b) {
1712	TRACE(("%s %d => %.20s true, new pc %u\n",
1713	opName[opCode], opnd, O2S(valuePtr),
1714	(unsigned int)(pc+opnd - codePtr->codeStart)));
1715	TclDecrRefCount(valuePtr);
1716	ADJUST_PC(opnd);
1717	} else {
1718	TRACE(("%s %d => %.20s false\n", opName[opCode], opnd,
1719	O2S(valuePtr)));
1720	TclDecrRefCount(valuePtr);
1721	ADJUST_PC(pcAdjustment);
1722	}
1723	}
1724
1725	case INST_JUMP_FALSE4:
1726	opnd = TclGetInt4AtPtr(pc+1);
1727	pcAdjustment = 5;
1728	goto doJumpFalse;
1729
1730	case INST_JUMP_FALSE1:
1731	opnd = TclGetInt1AtPtr(pc+1);
1732	pcAdjustment = 2;
1733
1734	doJumpFalse:
1735	{
1736	int b;
1737
1738	valuePtr = POP_OBJECT();
1739	if (valuePtr->typePtr == &tclIntType) {
1740	b = (valuePtr->internalRep.longValue != 0);
1741	} else if (valuePtr->typePtr == &tclDoubleType) {
1742	b = (valuePtr->internalRep.doubleValue != 0.0);
1743	} else {
1744	result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
1745	if (result != TCL_OK) {
1746	TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode],
1747	opnd), Tcl_GetObjResult(interp));
1748	Tcl_DecrRefCount(valuePtr);
1749	goto checkForCatch;
1750	}
1751	}
1752	if (b) {
1753	TRACE(("%s %d => %.20s true\n", opName[opCode], opnd,
1754	O2S(valuePtr)));
1755	TclDecrRefCount(valuePtr);
1756	ADJUST_PC(pcAdjustment);
1757	} else {
1758	TRACE(("%s %d => %.20s false, new pc %u\n",
1759	opName[opCode], opnd, O2S(valuePtr),
1760	(unsigned int)(pc + opnd - codePtr->codeStart)));
1761	TclDecrRefCount(valuePtr);
1762	ADJUST_PC(opnd);
1763	}
1764	}
1765
1766	case INST_LOR:
1767	case INST_LAND:
1768	{
1769	/*
1770	* Operands must be boolean or numeric. No int->double
1771	* conversions are performed.
1772	*/
1773
1774	int i1, i2;
1775	int iResult;
1776	char *s;
1777	Tcl_ObjType t1Ptr, t2Ptr;
1778
1779	value2Ptr = POP_OBJECT();
1780	valuePtr = POP_OBJECT();
1781	t1Ptr = valuePtr->typePtr;
1782	t2Ptr = value2Ptr->typePtr;
1783
1784	if ((t1Ptr == &tclIntType) \|\| (t1Ptr == &tclBooleanType)) {
1785	i1 = (valuePtr->internalRep.longValue != 0);
1786	} else if (t1Ptr == &tclDoubleType) {
1787	i1 = (valuePtr->internalRep.doubleValue != 0.0);
1788	} else { /* FAILS IF NULL STRING REP */
1789	s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
1790	if (TclLooksLikeInt(s)) {
1791	result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1792	valuePtr, &i);
1793	i1 = (i != 0);
1794	} else {
1795	result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
1796	valuePtr, &i1);
1797	i1 = (i1 != 0);
1798	}
1799	if (result != TCL_OK) {
1800	TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",
1801	opName[opCode], O2S(valuePtr),
1802	(t1Ptr? t1Ptr->name : "null")));
1803	IllegalExprOperandType(interp, opCode, valuePtr);
1804	Tcl_DecrRefCount(valuePtr);
1805	Tcl_DecrRefCount(value2Ptr);
1806	goto checkForCatch;
1807	}
1808	}
1809
1810	if ((t2Ptr == &tclIntType) \|\| (t2Ptr == &tclBooleanType)) {
1811	i2 = (value2Ptr->internalRep.longValue != 0);
1812	} else if (t2Ptr == &tclDoubleType) {
1813	i2 = (value2Ptr->internalRep.doubleValue != 0.0);
1814	} else { /* FAILS IF NULL STRING REP */
1815	s = Tcl_GetStringFromObj(value2Ptr, (int *) NULL);
1816	if (TclLooksLikeInt(s)) {
1817	result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1818	value2Ptr, &i);
1819	i2 = (i != 0);
1820	} else {
1821	result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
1822	value2Ptr, &i2);
1823	i2 = (i2 != 0);
1824	}
1825	if (result != TCL_OK) {
1826	TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",
1827	opName[opCode], O2S(value2Ptr),
1828	(t2Ptr? t2Ptr->name : "null")));
1829	IllegalExprOperandType(interp, opCode, value2Ptr);
1830	Tcl_DecrRefCount(valuePtr);
1831	Tcl_DecrRefCount(value2Ptr);
1832	goto checkForCatch;
1833	}
1834	}
1835
1836	/*
1837	* Reuse the valuePtr object already on stack if possible.
1838	*/
1839
1840	if (opCode == INST_LOR) {
1841	iResult = (i1 \|\| i2);
1842	} else {
1843	iResult = (i1 && i2);
1844	}
1845	if (Tcl_IsShared(valuePtr)) {
1846	PUSH_OBJECT(Tcl_NewLongObj(iResult));
1847	TRACE(("%s %.20s %.20s => %d\n", opName[opCode],
1848	O2S(valuePtr), O2S(value2Ptr), iResult));
1849	TclDecrRefCount(valuePtr);
1850	} else { /* reuse the valuePtr object */
1851	TRACE(("%s %.20s %.20s => %d\n",
1852	opName[opCode], /* NB: stack top is off by 1 */
1853	O2S(valuePtr), O2S(value2Ptr), iResult));
1854	Tcl_SetLongObj(valuePtr, iResult);
1855	++stackTop; /* valuePtr now on stk top has right r.c. */
1856	}
1857	TclDecrRefCount(value2Ptr);
1858	}
1859	ADJUST_PC(1);
1860
1861	case INST_EQ:
1862	case INST_NEQ:
1863	case INST_LT:
1864	case INST_GT:
1865	case INST_LE:
1866	case INST_GE:
1867	{
1868	/*
1869	* Any type is allowed but the two operands must have the
1870	* same type. We will compute value op value2.
1871	*/
1872
1873	Tcl_ObjType t1Ptr, t2Ptr;
1874	char s1 = NULL; / Init. avoids compiler warning. */
1875	char s2 = NULL; / Init. avoids compiler warning. */
1876	long i2 = 0; /* Init. avoids compiler warning. */
1877	double d1 = 0.0; /* Init. avoids compiler warning. */
1878	double d2 = 0.0; /* Init. avoids compiler warning. */
1879	long iResult = 0; /* Init. avoids compiler warning. */
1880
1881	value2Ptr = POP_OBJECT();
1882	valuePtr = POP_OBJECT();
1883	t1Ptr = valuePtr->typePtr;
1884	t2Ptr = value2Ptr->typePtr;
1885
1886	if ((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) {
1887	s1 = Tcl_GetStringFromObj(valuePtr, &length);
1888	if (TclLooksLikeInt(s1)) { /* FAILS IF NULLS */
1889	(void) Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1890	valuePtr, &i);
1891	} else {
1892	(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
1893	valuePtr, &d1);
1894	}
1895	t1Ptr = valuePtr->typePtr;
1896	}
1897	if ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType)) {
1898	s2 = Tcl_GetStringFromObj(value2Ptr, &length);
1899	if (TclLooksLikeInt(s2)) { /* FAILS IF NULLS */
1900	(void) Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1901	value2Ptr, &i2);
1902	} else {
1903	(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
1904	value2Ptr, &d2);
1905	}
1906	t2Ptr = value2Ptr->typePtr;
1907	}
1908
1909	if (((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType))
1910	\|\| ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType))) {
1911	/*
1912	* One operand is not numeric. Compare as strings.
1913	* THIS FAILS IF AN OBJECT'S STRING REP CONTAINS NULLS.
1914	*/
1915	int cmpValue;
1916	s1 = TclGetStringFromObj(valuePtr, &length);
1917	s2 = TclGetStringFromObj(value2Ptr, &length);
1918	cmpValue = strcmp(s1, s2);
1919	switch (opCode) {
1920	case INST_EQ:
1921	iResult = (cmpValue == 0);
1922	break;
1923	case INST_NEQ:
1924	iResult = (cmpValue != 0);
1925	break;
1926	case INST_LT:
1927	iResult = (cmpValue < 0);
1928	break;
1929	case INST_GT:
1930	iResult = (cmpValue > 0);
1931	break;
1932	case INST_LE:
1933	iResult = (cmpValue <= 0);
1934	break;
1935	case INST_GE:
1936	iResult = (cmpValue >= 0);
1937	break;
1938	}
1939	} else if ((t1Ptr == &tclDoubleType)
1940	\|\| (t2Ptr == &tclDoubleType)) {
1941	/*
1942	* Compare as doubles.
1943	*/
1944	if (t1Ptr == &tclDoubleType) {
1945	d1 = valuePtr->internalRep.doubleValue;
1946	if (t2Ptr == &tclIntType) {
1947	d2 = value2Ptr->internalRep.longValue;
1948	} else {
1949	d2 = value2Ptr->internalRep.doubleValue;
1950	}
1951	} else { /* t1Ptr is int, t2Ptr is double */
1952	d1 = valuePtr->internalRep.longValue;
1953	d2 = value2Ptr->internalRep.doubleValue;
1954	}
1955	switch (opCode) {
1956	case INST_EQ:
1957	iResult = d1 == d2;
1958	break;
1959	case INST_NEQ:
1960	iResult = d1 != d2;
1961	break;
1962	case INST_LT:
1963	iResult = d1 < d2;
1964	break;
1965	case INST_GT:
1966	iResult = d1 > d2;
1967	break;
1968	case INST_LE:
1969	iResult = d1 <= d2;
1970	break;
1971	case INST_GE:
1972	iResult = d1 >= d2;
1973	break;
1974	}
1975	} else {
1976	/*
1977	* Compare as ints.
1978	*/
1979	i = valuePtr->internalRep.longValue;
1980	i2 = value2Ptr->internalRep.longValue;
1981	switch (opCode) {
1982	case INST_EQ:
1983	iResult = i == i2;
1984	break;
1985	case INST_NEQ:
1986	iResult = i != i2;
1987	break;
1988	case INST_LT:
1989	iResult = i < i2;
1990	break;
1991	case INST_GT:
1992	iResult = i > i2;
1993	break;
1994	case INST_LE:
1995	iResult = i <= i2;
1996	break;
1997	case INST_GE:
1998	iResult = i >= i2;
1999	break;
2000	}
2001	}
2002
2003	/*
2004	* Reuse the valuePtr object already on stack if possible.
2005	*/
2006
2007	if (Tcl_IsShared(valuePtr)) {
2008	PUSH_OBJECT(Tcl_NewLongObj(iResult));
2009	TRACE(("%s %.20s %.20s => %ld\n", opName[opCode],
2010	O2S(valuePtr), O2S(value2Ptr), iResult));
2011	TclDecrRefCount(valuePtr);
2012	} else { /* reuse the valuePtr object */
2013	TRACE(("%s %.20s %.20s => %ld\n",
2014	opName[opCode], /* NB: stack top is off by 1 */
2015	O2S(valuePtr), O2S(value2Ptr), iResult));
2016	Tcl_SetLongObj(valuePtr, iResult);
2017	++stackTop; /* valuePtr now on stk top has right r.c. */
2018	}
2019	TclDecrRefCount(value2Ptr);
2020	}
2021	ADJUST_PC(1);
2022
2023	case INST_MOD:
2024	case INST_LSHIFT:
2025	case INST_RSHIFT:
2026	case INST_BITOR:
2027	case INST_BITXOR:
2028	case INST_BITAND:
2029	{
2030	/*
2031	* Only integers are allowed. We compute value op value2.
2032	*/
2033
2034	long i2, rem, negative;
2035	long iResult = 0; /* Init. avoids compiler warning. */
2036
2037	value2Ptr = POP_OBJECT();
2038	valuePtr = POP_OBJECT();
2039	if (valuePtr->typePtr == &tclIntType) {
2040	i = valuePtr->internalRep.longValue;
2041	} else { /* try to convert to int */
2042	result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2043	valuePtr, &i);
2044	if (result != TCL_OK) {
2045	TRACE(("%s %.20s %.20s => ILLEGAL 1st TYPE %s\n",
2046	opName[opCode], O2S(valuePtr), O2S(value2Ptr),
2047	(valuePtr->typePtr?
2048	valuePtr->typePtr->name : "null")));
2049	IllegalExprOperandType(interp, opCode, valuePtr);
2050	Tcl_DecrRefCount(valuePtr);
2051	Tcl_DecrRefCount(value2Ptr);
2052	goto checkForCatch;
2053	}
2054	}
2055	if (value2Ptr->typePtr == &tclIntType) {
2056	i2 = value2Ptr->internalRep.longValue;
2057	} else {
2058	result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2059	value2Ptr, &i2);
2060	if (result != TCL_OK) {
2061	TRACE(("%s %.20s %.20s => ILLEGAL 2nd TYPE %s\n",
2062	opName[opCode], O2S(valuePtr), O2S(value2Ptr),
2063	(value2Ptr->typePtr?
2064	value2Ptr->typePtr->name : "null")));
2065	IllegalExprOperandType(interp, opCode, value2Ptr);
2066	Tcl_DecrRefCount(valuePtr);
2067	Tcl_DecrRefCount(value2Ptr);
2068	goto checkForCatch;
2069	}
2070	}
2071
2072	switch (opCode) {
2073	case INST_MOD:
2074	/*
2075	* This code is tricky: C doesn't guarantee much about
2076	* the quotient or remainder, but Tcl does. The
2077	* remainder always has the same sign as the divisor and
2078	* a smaller absolute value.
2079	*/
2080	if (i2 == 0) {
2081	TRACE(("mod %ld %ld => DIVIDE BY ZERO\n", i, i2));
2082	Tcl_DecrRefCount(valuePtr);
2083	Tcl_DecrRefCount(value2Ptr);
2084	goto divideByZero;
2085	}
2086	negative = 0;
2087	if (i2 < 0) {
2088	i2 = -i2;
2089	i = -i;
2090	negative = 1;
2091	}
2092	rem = i % i2;
2093	if (rem < 0) {
2094	rem += i2;
2095	}
2096	if (negative) {
2097	rem = -rem;
2098	}
2099	iResult = rem;
2100	break;
2101	case INST_LSHIFT:
2102	iResult = i << i2;
2103	break;
2104	case INST_RSHIFT:
2105	/*
2106	* The following code is a bit tricky: it ensures that
2107	* right shifts propagate the sign bit even on machines
2108	* where ">>" won't do it by default.
2109	*/
2110	if (i < 0) {
2111	iResult = ~((~i) >> i2);
2112	} else {
2113	iResult = i >> i2;
2114	}
2115	break;
2116	case INST_BITOR:
2117	iResult = i \| i2;
2118	break;
2119	case INST_BITXOR:
2120	iResult = i ^ i2;
2121	break;
2122	case INST_BITAND:
2123	iResult = i & i2;
2124	break;
2125	}
2126
2127	/*
2128	* Reuse the valuePtr object already on stack if possible.
2129	*/
2130
2131	if (Tcl_IsShared(valuePtr)) {
2132	PUSH_OBJECT(Tcl_NewLongObj(iResult));
2133	TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2,
2134	iResult));
2135	TclDecrRefCount(valuePtr);
2136	} else { /* reuse the valuePtr object */
2137	TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2,
2138	iResult)); /* NB: stack top is off by 1 */
2139	Tcl_SetLongObj(valuePtr, iResult);
2140	++stackTop; /* valuePtr now on stk top has right r.c. */
2141	}
2142	TclDecrRefCount(value2Ptr);
2143	}
2144	ADJUST_PC(1);
2145
2146	case INST_ADD:
2147	case INST_SUB:
2148	case INST_MULT:
2149	case INST_DIV:
2150	{
2151	/*
2152	* Operands must be numeric and ints get converted to floats
2153	* if necessary. We compute value op value2.
2154	*/
2155
2156	Tcl_ObjType t1Ptr, t2Ptr;
2157	long i2, quot, rem;
2158	double d1, d2;
2159	long iResult = 0; /* Init. avoids compiler warning. */
2160	double dResult = 0.0; /* Init. avoids compiler warning. */
2161	int doDouble = 0; /* 1 if doing floating arithmetic */
2162
2163	value2Ptr = POP_OBJECT();
2164	valuePtr = POP_OBJECT();
2165	t1Ptr = valuePtr->typePtr;
2166	t2Ptr = value2Ptr->typePtr;
2167
2168	if (t1Ptr == &tclIntType) {
2169	i = valuePtr->internalRep.longValue;
2170	} else if (t1Ptr == &tclDoubleType) {
2171	d1 = valuePtr->internalRep.doubleValue;
2172	} else { /* try to convert; FAILS IF NULLS */
2173	char *s = Tcl_GetStringFromObj(valuePtr, &length);
2174	if (TclLooksLikeInt(s)) {
2175	result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2176	valuePtr, &i);
2177	} else {
2178	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2179	valuePtr, &d1);
2180	}
2181	if (result != TCL_OK) {
2182	TRACE(("%s %.20s %.20s => ILLEGAL 1st TYPE %s\n",
2183	opName[opCode], s, O2S(value2Ptr),
2184	(valuePtr->typePtr?
2185	valuePtr->typePtr->name : "null")));
2186	IllegalExprOperandType(interp, opCode, valuePtr);
2187	Tcl_DecrRefCount(valuePtr);
2188	Tcl_DecrRefCount(value2Ptr);
2189	goto checkForCatch;
2190	}
2191	t1Ptr = valuePtr->typePtr;
2192	}
2193
2194	if (t2Ptr == &tclIntType) {
2195	i2 = value2Ptr->internalRep.longValue;
2196	} else if (t2Ptr == &tclDoubleType) {
2197	d2 = value2Ptr->internalRep.doubleValue;
2198	} else { /* try to convert; FAILS IF NULLS */
2199	char *s = Tcl_GetStringFromObj(value2Ptr, &length);
2200	if (TclLooksLikeInt(s)) {
2201	result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2202	value2Ptr, &i2);
2203	} else {
2204	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2205	value2Ptr, &d2);
2206	}
2207	if (result != TCL_OK) {
2208	TRACE(("%s %.20s %.20s => ILLEGAL 2nd TYPE %s\n",
2209	opName[opCode], O2S(valuePtr), s,
2210	(value2Ptr->typePtr?
2211	value2Ptr->typePtr->name : "null")));
2212	IllegalExprOperandType(interp, opCode, value2Ptr);
2213	Tcl_DecrRefCount(valuePtr);
2214	Tcl_DecrRefCount(value2Ptr);
2215	goto checkForCatch;
2216	}
2217	t2Ptr = value2Ptr->typePtr;
2218	}
2219
2220	if ((t1Ptr == &tclDoubleType) \|\| (t2Ptr == &tclDoubleType)) {
2221	/*
2222	* Do double arithmetic.
2223	*/
2224	doDouble = 1;
2225	if (t1Ptr == &tclIntType) {
2226	d1 = i; /* promote value 1 to double */
2227	} else if (t2Ptr == &tclIntType) {
2228	d2 = i2; /* promote value 2 to double */
2229	}
2230	switch (opCode) {
2231	case INST_ADD:
2232	dResult = d1 + d2;
2233	break;
2234	case INST_SUB:
2235	dResult = d1 - d2;
2236	break;
2237	case INST_MULT:
2238	dResult = d1 * d2;
2239	break;
2240	case INST_DIV:
2241	if (d2 == 0.0) {
2242	TRACE(("div %.6g %.6g => DIVIDE BY ZERO\n",
2243	d1, d2));
2244	Tcl_DecrRefCount(valuePtr);
2245	Tcl_DecrRefCount(value2Ptr);
2246	goto divideByZero;
2247	}
2248	dResult = d1 / d2;
2249	break;
2250	}
2251
2252	/*
2253	* Check now for IEEE floating-point error.
2254	*/
2255
2256	if (IS_NAN(dResult) \|\| IS_INF(dResult)) {
2257	TRACE(("%s %.20s %.20s => IEEE FLOATING PT ERROR\n",
2258	opName[opCode], O2S(valuePtr), O2S(value2Ptr)));
2259	TclExprFloatError(interp, dResult);
2260	result = TCL_ERROR;
2261	Tcl_DecrRefCount(valuePtr);
2262	Tcl_DecrRefCount(value2Ptr);
2263	goto checkForCatch;
2264	}
2265	} else {
2266	/*
2267	* Do integer arithmetic.
2268	*/
2269	switch (opCode) {
2270	case INST_ADD:
2271	iResult = i + i2;
2272	break;
2273	case INST_SUB:
2274	iResult = i - i2;
2275	break;
2276	case INST_MULT:
2277	iResult = i * i2;
2278	break;
2279	case INST_DIV:
2280	/*
2281	* This code is tricky: C doesn't guarantee much
2282	* about the quotient or remainder, but Tcl does.
2283	* The remainder always has the same sign as the
2284	* divisor and a smaller absolute value.
2285	*/
2286	if (i2 == 0) {
2287	TRACE(("div %ld %ld => DIVIDE BY ZERO\n",
2288	i, i2));
2289	Tcl_DecrRefCount(valuePtr);
2290	Tcl_DecrRefCount(value2Ptr);
2291	goto divideByZero;
2292	}
2293	if (i2 < 0) {
2294	i2 = -i2;
2295	i = -i;
2296	}
2297	quot = i / i2;
2298	rem = i % i2;
2299	if (rem < 0) {
2300	quot -= 1;
2301	}
2302	iResult = quot;
2303	break;
2304	}
2305	}
2306
2307	/*
2308	* Reuse the valuePtr object already on stack if possible.
2309	*/
2310
2311	if (Tcl_IsShared(valuePtr)) {
2312	if (doDouble) {
2313	PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
2314	TRACE(("%s %.6g %.6g => %.6g\n", opName[opCode],
2315	d1, d2, dResult));
2316	} else {
2317	PUSH_OBJECT(Tcl_NewLongObj(iResult));
2318	TRACE(("%s %ld %ld => %ld\n", opName[opCode],
2319	i, i2, iResult));
2320	}
2321	TclDecrRefCount(valuePtr);
2322	} else { /* reuse the valuePtr object */
2323	if (doDouble) { /* NB: stack top is off by 1 */
2324	TRACE(("%s %.6g %.6g => %.6g\n", opName[opCode],
2325	d1, d2, dResult));
2326	Tcl_SetDoubleObj(valuePtr, dResult);
2327	} else {
2328	TRACE(("%s %ld %ld => %ld\n", opName[opCode],
2329	i, i2, iResult));
2330	Tcl_SetLongObj(valuePtr, iResult);
2331	}
2332	++stackTop; /* valuePtr now on stk top has right r.c. */
2333	}
2334	TclDecrRefCount(value2Ptr);
2335	}
2336	ADJUST_PC(1);
2337
2338	case INST_UPLUS:
2339	{
2340	/*
2341	* Operand must be numeric.
2342	*/
2343
2344	double d;
2345	Tcl_ObjType *tPtr;
2346
2347	valuePtr = stackPtr[stackTop].o;
2348	tPtr = valuePtr->typePtr;
2349	if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) {
2350	char s = Tcl_GetStringFromObj(valuePtr, (int ) NULL);
2351	if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */
2352	result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2353	valuePtr, &i);
2354	} else {
2355	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2356	valuePtr, &d);
2357	}
2358	if (result != TCL_OK) {
2359	TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",
2360	opName[opCode], s,
2361	(tPtr? tPtr->name : "null")));
2362	IllegalExprOperandType(interp, opCode, valuePtr);
2363	goto checkForCatch;
2364	}
2365	}
2366	TRACE_WITH_OBJ(("uplus %s => ", O2S(valuePtr)), valuePtr);
2367	}
2368	ADJUST_PC(1);
2369
2370	case INST_UMINUS:
2371	case INST_LNOT:
2372	{
2373	/*
2374	* The operand must be numeric. If the operand object is
2375	* unshared modify it directly, otherwise create a copy to
2376	* modify: this is "copy on write". free any old string
2377	* representation since it is now invalid.
2378	*/
2379
2380	double d;
2381	Tcl_ObjType *tPtr;
2382
2383	valuePtr = POP_OBJECT();
2384	tPtr = valuePtr->typePtr;
2385	if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) {
2386	char s = Tcl_GetStringFromObj(valuePtr, (int ) NULL);
2387	if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */
2388	result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2389	valuePtr, &i);
2390	} else {
2391	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2392	valuePtr, &d);
2393	}
2394	if (result != TCL_OK) {
2395	TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s\n",
2396	opName[opCode], s,
2397	(tPtr? tPtr->name : "null")));
2398	IllegalExprOperandType(interp, opCode, valuePtr);
2399	Tcl_DecrRefCount(valuePtr);
2400	goto checkForCatch;
2401	}
2402	tPtr = valuePtr->typePtr;
2403	}
2404
2405	if (Tcl_IsShared(valuePtr)) {
2406	/*
2407	* Create a new object.
2408	*/
2409	if (tPtr == &tclIntType) {
2410	i = valuePtr->internalRep.longValue;
2411	objPtr = Tcl_NewLongObj(
2412	(opCode == INST_UMINUS)? -i : !i);
2413	TRACE_WITH_OBJ(("%s %ld => ", opName[opCode], i),
2414	objPtr); /* NB: stack top is off by 1 */
2415	} else {
2416	d = valuePtr->internalRep.doubleValue;
2417	if (opCode == INST_UMINUS) {
2418	objPtr = Tcl_NewDoubleObj(-d);
2419	} else {
2420	/*
2421	* Should be able to use "!d", but apparently
2422	* some compilers can't handle it.
2423	*/
2424	objPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
2425	}
2426	TRACE_WITH_OBJ(("%s %.6g => ", opName[opCode], d),
2427	objPtr); /* NB: stack top is off by 1 */
2428	}
2429	PUSH_OBJECT(objPtr);
2430	TclDecrRefCount(valuePtr);
2431	} else {
2432	/*
2433	* valuePtr is unshared. Modify it directly.
2434	*/
2435	if (tPtr == &tclIntType) {
2436	i = valuePtr->internalRep.longValue;
2437	Tcl_SetLongObj(valuePtr,
2438	(opCode == INST_UMINUS)? -i : !i);
2439	TRACE_WITH_OBJ(("%s %ld => ", opName[opCode], i),
2440	valuePtr); /* NB: stack top is off by 1 */
2441	} else {
2442	d = valuePtr->internalRep.doubleValue;
2443	if (opCode == INST_UMINUS) {
2444	Tcl_SetDoubleObj(valuePtr, -d);
2445	} else {
2446	/*
2447	* Should be able to use "!d", but apparently
2448	* some compilers can't handle it.
2449	*/
2450	Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
2451	}
2452	TRACE_WITH_OBJ(("%s %.6g => ", opName[opCode], d),
2453	valuePtr); /* NB: stack top is off by 1 */
2454	}
2455	++stackTop; /* valuePtr now on stk top has right r.c. */
2456	}
2457	}
2458	ADJUST_PC(1);
2459
2460	case INST_BITNOT:
2461	{
2462	/*
2463	* The operand must be an integer. If the operand object is
2464	* unshared modify it directly, otherwise modify a copy.
2465	* Free any old string representation since it is now
2466	* invalid.
2467	*/
2468
2469	Tcl_ObjType *tPtr;
2470
2471	valuePtr = POP_OBJECT();
2472	tPtr = valuePtr->typePtr;
2473	if (tPtr != &tclIntType) {
2474	result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2475	valuePtr, &i);
2476	if (result != TCL_OK) { /* try to convert to double */
2477	TRACE(("bitnot \"%.20s\" => ILLEGAL TYPE %s\n",
2478	O2S(valuePtr), (tPtr? tPtr->name : "null")));
2479	IllegalExprOperandType(interp, opCode, valuePtr);
2480	Tcl_DecrRefCount(valuePtr);
2481	goto checkForCatch;
2482	}
2483	}
2484
2485	i = valuePtr->internalRep.longValue;
2486	if (Tcl_IsShared(valuePtr)) {
2487	PUSH_OBJECT(Tcl_NewLongObj(~i));
2488	TRACE(("bitnot 0x%lx => (%lu)\n", i, ~i));
2489	TclDecrRefCount(valuePtr);
2490	} else {
2491	/*
2492	* valuePtr is unshared. Modify it directly.
2493	*/
2494	Tcl_SetLongObj(valuePtr, ~i);
2495	++stackTop; /* valuePtr now on stk top has right r.c. */
2496	TRACE(("bitnot 0x%lx => (%lu)\n", i, ~i));
2497	}
2498	}
2499	ADJUST_PC(1);
2500
2501	case INST_CALL_BUILTIN_FUNC1:
2502	opnd = TclGetUInt1AtPtr(pc+1);
2503	{
2504	/*
2505	* Call one of the built-in Tcl math functions.
2506	*/
2507
2508	BuiltinFunc *mathFuncPtr;
2509
2510	if ((opnd < 0) \|\| (opnd > LAST_BUILTIN_FUNC)) {
2511	TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
2512	panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
2513	}
2514	mathFuncPtr = &(builtinFuncTable[opnd]);
2515	DECACHE_STACK_INFO();
2516	tcl_MathInProgress++;
2517	result = (*mathFuncPtr->proc)(interp, eePtr,
2518	mathFuncPtr->clientData);
2519	tcl_MathInProgress--;
2520	CACHE_STACK_INFO();
2521	if (result != TCL_OK) {
2522	goto checkForCatch;
2523	}
2524	TRACE_WITH_OBJ(("callBuiltinFunc1 %d => ", opnd),
2525	stackPtr[stackTop].o);
2526	}
2527	ADJUST_PC(2);
2528
2529	case INST_CALL_FUNC1:
2530	opnd = TclGetUInt1AtPtr(pc+1);
2531	{
2532	/*
2533	* Call a non-builtin Tcl math function previously
2534	* registered by a call to Tcl_CreateMathFunc.
2535	*/
2536
2537	int objc = opnd; /* Number of arguments. The function name
2538	* is the 0-th argument. */
2539	Tcl_Obj *objv; / The array of arguments. The function
2540	* name is objv[0]. */
2541
2542	objv = &(stackPtr[stackTop - (objc-1)].o); /* "objv[0]" */
2543	DECACHE_STACK_INFO();
2544	tcl_MathInProgress++;
2545	result = ExprCallMathFunc(interp, eePtr, objc, objv);
2546	tcl_MathInProgress--;
2547	CACHE_STACK_INFO();
2548	if (result != TCL_OK) {
2549	goto checkForCatch;
2550	}
2551	TRACE_WITH_OBJ(("callFunc1 %d => ", objc),
2552	stackPtr[stackTop].o);
2553	ADJUST_PC(2);
2554	}
2555
2556	case INST_TRY_CVT_TO_NUMERIC:
2557	{
2558	/*
2559	* Try to convert the topmost stack object to an int or
2560	* double object. This is done in order to support Tcl's
2561	* policy of interpreting operands if at all possible as
2562	* first integers, else floating-point numbers.
2563	*/
2564
2565	double d;
2566	char *s;
2567	Tcl_ObjType *tPtr;
2568	int converted, shared;
2569
2570	valuePtr = stackPtr[stackTop].o;
2571	tPtr = valuePtr->typePtr;
2572	converted = 0;
2573	if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) {
2574	s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
2575	if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */
2576	result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2577	valuePtr, &i);
2578	} else {
2579	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2580	valuePtr, &d);
2581	}
2582	if (result == TCL_OK) {
2583	converted = 1;
2584	}
2585	result = TCL_OK; /* reset the result variable */
2586	tPtr = valuePtr->typePtr;
2587	}
2588
2589	/*
2590	* Ensure that the topmost stack object, if numeric, has a
2591	* string rep the same as the formatted version of its
2592	* internal rep. This is used, e.g., to make sure that "expr
2593	* {0001}" yields "1", not "0001". We implement this by
2594	* _discarding_ the string rep since we know it will be
2595	* regenerated, if needed later, by formatting the internal
2596	* rep's value. Also check if there has been an IEEE
2597	* floating point error.
2598	*/
2599
2600	if ((tPtr == &tclIntType) \|\| (tPtr == &tclDoubleType)) {
2601	shared = 0;
2602	if (Tcl_IsShared(valuePtr)) {
2603	shared = 1;
2604	if (tPtr == &tclIntType) {
2605	i = valuePtr->internalRep.longValue;
2606	objPtr = Tcl_NewLongObj(i);
2607	} else {
2608	d = valuePtr->internalRep.doubleValue;
2609	objPtr = Tcl_NewDoubleObj(d);
2610	}
2611	Tcl_IncrRefCount(objPtr);
2612	TclDecrRefCount(valuePtr);
2613	valuePtr = objPtr;
2614	tPtr = valuePtr->typePtr;
2615	} else {
2616	Tcl_InvalidateStringRep(valuePtr);
2617	}
2618	stackPtr[stackTop].o = valuePtr;
2619
2620	if (tPtr == &tclDoubleType) {
2621	d = valuePtr->internalRep.doubleValue;
2622	if (IS_NAN(d) \|\| IS_INF(d)) {
2623	TRACE(("tryCvtToNumeric \"%.20s\" => IEEE FLOATING PT ERROR\n",
2624	O2S(valuePtr)));
2625	TclExprFloatError(interp, d);
2626	result = TCL_ERROR;
2627	goto checkForCatch;
2628	}
2629	}
2630	shared = shared; /* lint, shared not used. */
2631	converted = converted; /* lint, converted not used. */
2632	TRACE(("tryCvtToNumeric \"%.20s\" => numeric, %s, %s\n",
2633	O2S(valuePtr),
2634	(converted? "converted" : "not converted"),
2635	(shared? "shared" : "not shared")));
2636	} else {
2637	TRACE(("tryCvtToNumeric \"%.20s\" => not numeric\n",
2638	O2S(valuePtr)));
2639	}
2640	}
2641	ADJUST_PC(1);
2642
2643	case INST_BREAK:
2644	/*
2645	* First reset the interpreter's result. Then find the closest
2646	* enclosing loop or catch exception range, if any. If a loop is
2647	* found, terminate its execution. If the closest is a catch
2648	* exception range, jump to its catchOffset. If no enclosing
2649	* range is found, stop execution and return TCL_BREAK.
2650	*/
2651
2652	Tcl_ResetResult(interp);
2653	rangePtr = TclGetExceptionRangeForPc(pc, /catchOnly/ 0,
2654	codePtr);
2655	if (rangePtr == NULL) {
2656	TRACE(("break => no encl. loop or catch, returning TCL_BREAK\n"));
2657	result = TCL_BREAK;
2658	goto abnormalReturn; /* no catch exists to check */
2659	}
2660	switch (rangePtr->type) {
2661	case LOOP_EXCEPTION_RANGE:
2662	result = TCL_OK;
2663	TRACE(("break => range at %d, new pc %d\n",
2664	rangePtr->codeOffset, rangePtr->breakOffset));
2665	break;
2666	case CATCH_EXCEPTION_RANGE:
2667	result = TCL_BREAK;
2668	TRACE(("break => ...\n"));
2669	goto processCatch; /* it will use rangePtr */
2670	default:
2671	panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
2672	}
2673	pc = (codePtr->codeStart + rangePtr->breakOffset);
2674	continue; /* restart outer instruction loop at pc */
2675
2676	case INST_CONTINUE:
2677	/*
2678	* Find the closest enclosing loop or catch exception range,
2679	* if any. If a loop is found, skip to its next iteration.
2680	* If the closest is a catch exception range, jump to its
2681	* catchOffset. If no enclosing range is found, stop
2682	* execution and return TCL_CONTINUE.
2683	*/
2684
2685	Tcl_ResetResult(interp);
2686	rangePtr = TclGetExceptionRangeForPc(pc, /catchOnly/ 0,
2687	codePtr);
2688	if (rangePtr == NULL) {
2689	TRACE(("continue => no encl. loop or catch, returning TCL_CONTINUE\n"));
2690	result = TCL_CONTINUE;
2691	goto abnormalReturn;
2692	}
2693	switch (rangePtr->type) {
2694	case LOOP_EXCEPTION_RANGE:
2695	if (rangePtr->continueOffset == -1) {
2696	TRACE(("continue => loop w/o continue, checking for catch\n"));
2697	goto checkForCatch;
2698	} else {
2699	result = TCL_OK;
2700	TRACE(("continue => range at %d, new pc %d\n",
2701	rangePtr->codeOffset, rangePtr->continueOffset));
2702	}
2703	break;
2704	case CATCH_EXCEPTION_RANGE:
2705	result = TCL_CONTINUE;
2706	TRACE(("continue => ...\n"));
2707	goto processCatch; /* it will use rangePtr */
2708	default:
2709	panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
2710	}
2711	pc = (codePtr->codeStart + rangePtr->continueOffset);
2712	continue; /* restart outer instruction loop at pc */
2713
2714	case INST_FOREACH_START4:
2715	opnd = TclGetUInt4AtPtr(pc+1);
2716	{
2717	/*
2718	* Initialize the temporary local var that holds the count
2719	* of the number of iterations of the loop body to -1.
2720	*/
2721
2722	ForeachInfo infoPtr = (ForeachInfo )
2723	codePtr->auxDataArrayPtr[opnd].clientData;
2724	int iterTmpIndex = infoPtr->loopIterNumTmp;
2725	CallFrame *varFramePtr = iPtr->varFramePtr;
2726	Var *compiledLocals = varFramePtr->compiledLocals;
2727	Var *iterVarPtr;
2728	Tcl_Obj *oldValuePtr;
2729
2730	iterVarPtr = &(compiledLocals[iterTmpIndex]);
2731	oldValuePtr = iterVarPtr->value.objPtr;
2732	if (oldValuePtr == NULL) {
2733	iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
2734	Tcl_IncrRefCount(iterVarPtr->value.objPtr);
2735	} else {
2736	Tcl_SetLongObj(oldValuePtr, -1);
2737	}
2738	TclSetVarScalar(iterVarPtr);
2739	TclClearVarUndefined(iterVarPtr);
2740	TRACE(("foreach_start4 %u => loop iter count temp %d\n",
2741	opnd, iterTmpIndex));
2742	}
2743	ADJUST_PC(5);
2744
2745	case INST_FOREACH_STEP4:
2746	opnd = TclGetUInt4AtPtr(pc+1);
2747	{
2748	/*
2749	* "Step" a foreach loop (i.e., begin its next iteration) by
2750	* assigning the next value list element to each loop var.
2751	*/
2752
2753	ForeachInfo infoPtr = (ForeachInfo )
2754	codePtr->auxDataArrayPtr[opnd].clientData;
2755	ForeachVarList *varListPtr;
2756	int numLists = infoPtr->numLists;
2757	int iterTmpIndex = infoPtr->loopIterNumTmp;
2758	CallFrame *varFramePtr = iPtr->varFramePtr;
2759	Var *compiledLocals = varFramePtr->compiledLocals;
2760	int iterNum, listTmpIndex, listLen, numVars;
2761	int varIndex, valIndex, j;
2762	Tcl_Obj listPtr, elemPtr, *oldValuePtr;
2763	List *listRepPtr;
2764	Var iterVarPtr, listVarPtr;
2765	int continueLoop = 0;
2766
2767	/*
2768	* Increment the temp holding the loop iteration number.
2769	*/
2770
2771	iterVarPtr = &(compiledLocals[iterTmpIndex]);
2772	oldValuePtr = iterVarPtr->value.objPtr;
2773	iterNum = (oldValuePtr->internalRep.longValue + 1);
2774	Tcl_SetLongObj(oldValuePtr, iterNum);
2775
2776	/*
2777	* Check whether all value lists are exhausted and we should
2778	* stop the loop.
2779	*/
2780
2781	listTmpIndex = infoPtr->firstListTmp;
2782	for (i = 0; i < numLists; i++) {
2783	varListPtr = infoPtr->varLists[i];
2784	numVars = varListPtr->numVars;
2785
2786	listVarPtr = &(compiledLocals[listTmpIndex]);
2787	listPtr = listVarPtr->value.objPtr;
2788	result = Tcl_ListObjLength(interp, listPtr, &listLen);
2789	if (result != TCL_OK) {
2790	TRACE_WITH_OBJ(("foreach_step4 %u => ERROR converting list %ld, \"%s\": ",
2791	opnd, i, O2S(listPtr)),
2792	Tcl_GetObjResult(interp));
2793	goto checkForCatch;
2794	}
2795	if (listLen > (iterNum * numVars)) {
2796	continueLoop = 1;
2797	}
2798	listTmpIndex++;
2799	}
2800
2801	/*
2802	* If some var in some var list still has a remaining list
2803	* element iterate one more time. Assign to var the next
2804	* element from its value list. We already checked above
2805	* that each list temp holds a valid list object.
2806	*/
2807
2808	if (continueLoop) {
2809	listTmpIndex = infoPtr->firstListTmp;
2810	for (i = 0; i < numLists; i++) {
2811	varListPtr = infoPtr->varLists[i];
2812	numVars = varListPtr->numVars;
2813
2814	listVarPtr = &(compiledLocals[listTmpIndex]);
2815	listPtr = listVarPtr->value.objPtr;
2816	listRepPtr = (List *)
2817	listPtr->internalRep.otherValuePtr;
2818	listLen = listRepPtr->elemCount;
2819
2820	valIndex = (iterNum * numVars);
2821	for (j = 0; j < numVars; j++) {
2822	int setEmptyStr = 0;
2823	if (valIndex >= listLen) {
2824	setEmptyStr = 1;
2825	elemPtr = Tcl_NewObj();
2826	} else {
2827	elemPtr = listRepPtr->elements[valIndex];
2828	}
2829
2830	varIndex = varListPtr->varIndexes[j];
2831	DECACHE_STACK_INFO();
2832	value2Ptr = TclSetIndexedScalar(interp,
2833	varIndex, elemPtr, /leaveErrorMsg/ 1);
2834	CACHE_STACK_INFO();
2835	if (value2Ptr == NULL) {
2836	TRACE_WITH_OBJ(("foreach_step4 %u => ERROR init. index temp %d: ",
2837	opnd, varIndex),
2838	Tcl_GetObjResult(interp));
2839	if (setEmptyStr) {
2840	Tcl_DecrRefCount(elemPtr); /* unneeded */
2841	}
2842	result = TCL_ERROR;
2843	goto checkForCatch;
2844	}
2845	valIndex++;
2846	}
2847	listTmpIndex++;
2848	}
2849	}
2850
2851	/*
2852	* Now push a "1" object if at least one value list had a
2853	* remaining element and the loop should continue.
2854	* Otherwise push "0".
2855	*/
2856
2857	PUSH_OBJECT(Tcl_NewLongObj(continueLoop));
2858	TRACE(("foreach_step4 %u => %d lists, iter %d, %s loop\n",
2859	opnd, numLists, iterNum,
2860	(continueLoop? "continue" : "exit")));
2861	}
2862	ADJUST_PC(5);
2863
2864	case INST_BEGIN_CATCH4:
2865	/*
2866	* Record start of the catch command with exception range index
2867	* equal to the operand. Push the current stack depth onto the
2868	* special catch stack.
2869	*/
2870	catchStackPtr[++catchTop] = stackTop;
2871	TRACE(("beginCatch4 %u => catchTop=%d, stackTop=%d\n",
2872	TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
2873	ADJUST_PC(5);
2874
2875	case INST_END_CATCH:
2876	catchTop--;
2877	result = TCL_OK;
2878	TRACE(("endCatch => catchTop=%d\n", catchTop));
2879	ADJUST_PC(1);
2880
2881	case INST_PUSH_RESULT:
2882	PUSH_OBJECT(Tcl_GetObjResult(interp));
2883	TRACE_WITH_OBJ(("pushResult => "), Tcl_GetObjResult(interp));
2884	ADJUST_PC(1);
2885
2886	case INST_PUSH_RETURN_CODE:
2887	PUSH_OBJECT(Tcl_NewLongObj(result));
2888	TRACE(("pushReturnCode => %u\n", result));
2889	ADJUST_PC(1);
2890
2891	default:
2892	TRACE(("UNRECOGNIZED INSTRUCTION %u\n", opCode));
2893	panic("TclExecuteByteCode: unrecognized opCode %u", opCode);
2894	} /* end of switch on opCode */
2895
2896	/*
2897	* Division by zero in an expression. Control only reaches this
2898	* point by "goto divideByZero".
2899	*/
2900
2901	divideByZero:
2902	Tcl_ResetResult(interp);
2903	Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
2904	Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
2905	(char *) NULL);
2906	result = TCL_ERROR;
2907
2908	/*
2909	* Execution has generated an "exception" such as TCL_ERROR. If the
2910	* exception is an error, record information about what was being
2911	* executed when the error occurred. Find the closest enclosing
2912	* catch range, if any. If no enclosing catch range is found, stop
2913	* execution and return the "exception" code.
2914	*/
2915
2916	checkForCatch:
2917	if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
2918	RecordTracebackInfo(interp, pc, codePtr);
2919	}
2920	rangePtr = TclGetExceptionRangeForPc(pc, /catchOnly/ 1, codePtr);
2921	if (rangePtr == NULL) {
2922	TRACE((" ... no enclosing catch, returning %s\n",
2923	StringForResultCode(result)));
2924	goto abnormalReturn;
2925	}
2926
2927	/*
2928	* A catch exception range (rangePtr) was found to handle an
2929	* "exception". It was found either by checkForCatch just above or
2930	* by an instruction during break, continue, or error processing.
2931	* Jump to its catchOffset after unwinding the operand stack to
2932	* the depth it had when starting to execute the range's catch
2933	* command.
2934	*/
2935
2936	processCatch:
2937	while (stackTop > catchStackPtr[catchTop]) {
2938	valuePtr = POP_OBJECT();
2939	TclDecrRefCount(valuePtr);
2940	}
2941	TRACE((" ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
2942	rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],
2943	(unsigned int)(rangePtr->catchOffset)));
2944	pc = (codePtr->codeStart + rangePtr->catchOffset);
2945	continue; /* restart the execution loop at pc */
2946	} /* end of infinite loop dispatching on instructions */
2947
2948	/*
2949	* Abnormal return code. Restore the stack to state it had when starting
2950	* to execute the ByteCode.
2951	*/
2952
2953	abnormalReturn:
2954	while (stackTop > initStackTop) {
2955	valuePtr = POP_OBJECT();
2956	Tcl_DecrRefCount(valuePtr);
2957	}
2958
2959	/*
2960	* Free the catch stack array if malloc'ed storage was used.
2961	*/
2962
2963	done:
2964	if (catchStackPtr != catchStackStorage) {
2965	ckfree((char *) catchStackPtr);
2966	}
2967	eePtr->stackTop = initStackTop;
2968	return result;
2969	#undef STATIC_CATCH_STACK_SIZE
2970	}
2971
2972	/*
2973	*----------------------------------------------------------------------
2974	*
2975	* PrintByteCodeInfo --
2976	*
2977	* This procedure prints a summary about a bytecode object to stdout.
2978	* It is called by TclExecuteByteCode when starting to execute the
2979	* bytecode object if tclTraceExec has the value 2 or more.
2980	*
2981	* Results:
2982	* None.
2983	*
2984	* Side effects:
2985	* None.
2986	*
2987	*----------------------------------------------------------------------
2988	*/
2989
2990	static void
2991	PrintByteCodeInfo(codePtr)
2992	register ByteCode codePtr; / The bytecode whose summary is printed
2993	* to stdout. */
2994	{
2995	Proc *procPtr = codePtr->procPtr;
2996	int numCmds = codePtr->numCommands;
2997	int numObjs = codePtr->numObjects;
2998	int objBytes, i;
2999
3000	objBytes = (numObjs * sizeof(Tcl_Obj));
3001	for (i = 0; i < numObjs; i++) {
3002	Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i];
3003	if (litObjPtr->bytes != NULL) {
3004	objBytes += litObjPtr->length;
3005	}
3006	}
3007
3008	fprintf(stdout, "\nExecuting ByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n",
3009	(unsigned int) codePtr, codePtr->refCount,
3010	codePtr->compileEpoch, (unsigned int) codePtr->iPtr,
3011	codePtr->iPtr->compileEpoch);
3012
3013	fprintf(stdout, " Source: ");
3014	TclPrintSource(stdout, codePtr->source, 70);
3015
3016	fprintf(stdout, "\n Cmds %d, chars %d, inst %u, objs %u, aux %d, stk depth %u, code/src %.2fn",
3017	numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs,
3018	codePtr->numAuxDataItems, codePtr->maxStackDepth,
3019	(codePtr->numSrcChars?
3020	((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0));
3021
3022	fprintf(stdout, " Code %zu = %u(header)+%d(inst)+%d(objs)+%u(exc)+%u(aux)+%d(cmd map)\n",
3023	codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes,
3024	objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)),
3025	(codePtr->numAuxDataItems * sizeof(AuxData)),
3026	codePtr->numCmdLocBytes);
3027
3028	if (procPtr != NULL) {
3029	fprintf(stdout,
3030	" Proc 0x%x, ref ct %d, args %d, compiled locals %d\n",
3031	(unsigned int) procPtr, procPtr->refCount,
3032	procPtr->numArgs, procPtr->numCompiledLocals);
3033	}
3034	}
3035
3036	/*
3037	*----------------------------------------------------------------------
3038	*
3039	* ValidatePcAndStackTop --
3040	*
3041	* This procedure is called by TclExecuteByteCode when debugging to
3042	* verify that the program counter and stack top are valid during
3043	* execution.
3044	*
3045	* Results:
3046	* None.
3047	*
3048	* Side effects:
3049	* Prints a message to stderr and panics if either the pc or stack
3050	* top are invalid.
3051	*
3052	*----------------------------------------------------------------------
3053	*/
3054
3055	#ifdef TCL_COMPILE_DEBUG
3056	static void
3057	ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, stackUpperBound)
3058	register ByteCode codePtr; / The bytecode whose summary is printed
3059	* to stdout. */
3060	unsigned char pc; / Points to first byte of a bytecode
3061	* instruction. The program counter. */
3062	int stackTop; /* Current stack top. Must be between
3063	* stackLowerBound and stackUpperBound
3064	* (inclusive). */
3065	int stackLowerBound; /* Smallest legal value for stackTop. */
3066	int stackUpperBound; /* Greatest legal value for stackTop. */
3067	{
3068	unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart);
3069	unsigned int codeStart = (unsigned int) codePtr->codeStart;
3070	unsigned int codeEnd = (unsigned int)
3071	(codePtr->codeStart + codePtr->numCodeBytes);
3072	unsigned char opCode = *pc;
3073
3074	if (((unsigned int) pc < codeStart) \|\| ((unsigned int) pc > codeEnd)) {
3075	fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n",
3076	(unsigned int) pc);
3077	panic("TclExecuteByteCode execution failure: bad pc");
3078	}
3079	if ((unsigned int) opCode > LAST_INST_OPCODE) {
3080	fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
3081	(unsigned int) opCode, relativePc);
3082	panic("TclExecuteByteCode execution failure: bad opcode");
3083	}
3084	if ((stackTop < stackLowerBound) \|\| (stackTop > stackUpperBound)) {
3085	int numChars;
3086	char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
3087	char *ellipsis = "";
3088
3089	fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode",
3090	stackTop, relativePc);
3091	if (cmd != NULL) {
3092	if (numChars > 100) {
3093	numChars = 100;
3094	ellipsis = "...";
3095	}
3096	fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd,
3097	ellipsis);
3098	} else {
3099	fprintf(stderr, "\n");
3100	}
3101	panic("TclExecuteByteCode execution failure: bad stack top");
3102	}
3103	}
3104	#endif /* TCL_COMPILE_DEBUG */
3105
3106	/*
3107	*----------------------------------------------------------------------
3108	*
3109	* IllegalExprOperandType --
3110	*
3111	* Used by TclExecuteByteCode to add an error message to errorInfo
3112	* when an illegal operand type is detected by an expression
3113	* instruction. The argument opCode holds the failing instruction's
3114	* opcode and opndPtr holds the operand object in error.
3115	*
3116	* Results:
3117	* None.
3118	*
3119	* Side effects:
3120	* An error message is appended to errorInfo.
3121	*
3122	*----------------------------------------------------------------------
3123	*/
3124
3125	static void
3126	IllegalExprOperandType(interp, opCode, opndPtr)
3127	Tcl_Interp interp; / Interpreter to which error information
3128	* pertains. */
3129	unsigned int opCode; /* The instruction opcode being executed
3130	* when the illegal type was found. */
3131	Tcl_Obj opndPtr; / Points to the operand holding the value
3132	* with the illegal type. */
3133	{
3134	Tcl_ResetResult(interp);
3135	if ((opndPtr->bytes == NULL) \|\| (opndPtr->length == 0)) {
3136	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
3137	"can't use empty string as operand of \"",
3138	operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
3139	} else {
3140	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
3141	((opndPtr->typePtr == &tclDoubleType) ?
3142	"floating-point value" : "non-numeric string"),
3143	" as operand of \"", operatorStrings[opCode - INST_LOR],
3144	"\"", (char *) NULL);
3145	}
3146	}
3147
3148	/*
3149	*----------------------------------------------------------------------
3150	*
3151	* CallTraceProcedure --
3152	*
3153	* Invokes a trace procedure registered with an interpreter. These
3154	* procedures trace command execution. Currently this trace procedure
3155	* is called with the address of the string-based Tcl_CmdProc for the
3156	* command, not the Tcl_ObjCmdProc.
3157	*
3158	* Results:
3159	* None.
3160	*
3161	* Side effects:
3162	* Those side effects made by the trace procedure.
3163	*
3164	*----------------------------------------------------------------------
3165	*/
3166
3167	static void
3168	CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
3169	Tcl_Interp interp; / The current interpreter. */
3170	register Trace tracePtr; / Describes the trace procedure to call. */
3171	Command cmdPtr; / Points to command's Command struct. */
3172	char command; / Points to the first character of the
3173	* command's source before substitutions. */
3174	int numChars; /* The number of characters in the
3175	* command's source. */
3176	register int objc; /* Number of arguments for the command. */
3177	Tcl_Obj objv[]; / Pointers to Tcl_Obj of each argument. */
3178	{
3179	Interp iPtr = (Interp ) interp;
3180	register char **argv;
3181	register int i;
3182	int length;
3183	char *p;
3184
3185	/*
3186	* Get the string rep from the objv argument objects and place their
3187	* pointers in argv. First make sure argv is large enough to hold the
3188	* objc args plus 1 extra word for the zero end-of-argv word.
3189	* THIS FAILS IF AN OBJECT'S STRING REP CONTAINS NULLS.
3190	*/
3191
3192	argv = (char *) ckalloc((unsigned)(objc + 1) sizeof(char *));
3193	for (i = 0; i < objc; i++) {
3194	argv[i] = Tcl_GetStringFromObj(objv[i], &length);
3195	}
3196	argv[objc] = 0;
3197
3198	/*
3199	* Copy the command characters into a new string.
3200	*/
3201
3202	p = (char *) ckalloc((unsigned) (numChars + 1));
3203	memcpy((VOID ) p, (VOID ) command, (size_t) numChars);
3204	p[numChars] = '\0';
3205
3206	/*
3207	* Call the trace procedure then free allocated storage.
3208	*/
3209
3210	(*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
3211	p, cmdPtr->proc, cmdPtr->clientData, objc, argv);
3212
3213	ckfree((char *) argv);
3214	ckfree((char *) p);
3215	}
3216
3217	/*
3218	*----------------------------------------------------------------------
3219	*
3220	* RecordTracebackInfo --
3221	*
3222	* Procedure called by TclExecuteByteCode to record information
3223	* about what was being executed when the error occurred.
3224	*
3225	* Results:
3226	* None.
3227	*
3228	* Side effects:
3229	* Appends information about the command being executed to the
3230	* "errorInfo" variable. Sets the errorLine field in the interpreter
3231	* to the line number of that command. Sets the ERR_ALREADY_LOGGED
3232	* bit in the interpreter's execution flags.
3233	*
3234	*----------------------------------------------------------------------
3235	*/
3236
3237	static void
3238	RecordTracebackInfo(interp, pc, codePtr)
3239	Tcl_Interp interp; / The interpreter in which the error
3240	* occurred. */
3241	unsigned char pc; / The program counter value where the error * occurred. This points to a bytecode
3242	* instruction in codePtr's code. */
3243	ByteCode codePtr; / The bytecode sequence being executed. */
3244	{
3245	register Interp iPtr = (Interp ) interp;
3246	char cmd, ellipsis;
3247	char buf[200];
3248	register char *p;
3249	int numChars;
3250
3251	/*
3252	* Record the command in errorInfo (up to a certain number of
3253	* characters, or up to the first newline).
3254	*/
3255
3256	iPtr->errorLine = 1;
3257	cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
3258	if (cmd != NULL) {
3259	for (p = codePtr->source; p != cmd; p++) {
3260	if (*p == '\n') {
3261	iPtr->errorLine++;
3262	}
3263	}
3264	for ( ; (isspace(UCHAR(p)) \|\| (p == ';')); p++) {
3265	if (*p == '\n') {
3266	iPtr->errorLine++;
3267	}
3268	}
3269
3270	ellipsis = "";
3271	if (numChars > 150) {
3272	numChars = 150;
3273	ellipsis = "...";
3274	}
3275	if (!(iPtr->flags & ERR_IN_PROGRESS)) {
3276	sprintf(buf, "\n while executing\n\"%.*s%s\"",
3277	numChars, cmd, ellipsis);
3278	} else {
3279	sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
3280	numChars, cmd, ellipsis);
3281	}
3282	Tcl_AddObjErrorInfo(interp, buf, -1);
3283	iPtr->flags \|= ERR_ALREADY_LOGGED;
3284	}
3285	}
3286
3287	/*
3288	*----------------------------------------------------------------------
3289	*
3290	* GetSrcInfoForPc --
3291	*
3292	* Given a program counter value, finds the closest command in the
3293	* bytecode code unit's CmdLocation array and returns information about
3294	* that command's source: a pointer to its first byte and the number of
3295	* characters.
3296	*
3297	* Results:
3298	* If a command is found that encloses the program counter value, a
3299	* pointer to the command's source is returned and the length of the
3300	* source is stored at *lengthPtr. If multiple commands resulted in
3301	* code at pc, information about the closest enclosing command is
3302	* returned. If no matching command is found, NULL is returned and
3303	* *lengthPtr is unchanged.
3304	*
3305	* Side effects:
3306	* None.
3307	*
3308	*----------------------------------------------------------------------
3309	*/
3310
3311	static char *
3312	GetSrcInfoForPc(pc, codePtr, lengthPtr)
3313	unsigned char pc; / The program counter value for which to
3314	* return the closest command's source info.
3315	* This points to a bytecode instruction
3316	* in codePtr's code. */
3317	ByteCode codePtr; / The bytecode sequence in which to look
3318	* up the command source for the pc. */
3319	int lengthPtr; / If non-NULL, the location where the
3320	* length of the command's source should be
3321	* stored. If NULL, no length is stored. */
3322	{
3323	register int pcOffset = (pc - codePtr->codeStart);
3324	int numCmds = codePtr->numCommands;
3325	unsigned char codeDeltaNext, codeLengthNext;
3326	unsigned char srcDeltaNext, srcLengthNext;
3327	int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
3328	int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
3329	int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
3330	int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
3331
3332	if ((pcOffset < 0) \|\| (pcOffset >= codePtr->numCodeBytes)) {
3333	return NULL;
3334	}
3335
3336	/*
3337	* Decode the code and source offset and length for each command. The
3338	* closest enclosing command is the last one whose code started before
3339	* pcOffset.
3340	*/
3341
3342	codeDeltaNext = codePtr->codeDeltaStart;
3343	codeLengthNext = codePtr->codeLengthStart;
3344	srcDeltaNext = codePtr->srcDeltaStart;
3345	srcLengthNext = codePtr->srcLengthStart;
3346	codeOffset = srcOffset = 0;
3347	for (i = 0; i < numCmds; i++) {
3348	if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
3349	codeDeltaNext++;
3350	delta = TclGetInt4AtPtr(codeDeltaNext);
3351	codeDeltaNext += 4;
3352	} else {
3353	delta = TclGetInt1AtPtr(codeDeltaNext);
3354	codeDeltaNext++;
3355	}
3356	codeOffset += delta;
3357
3358	if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
3359	codeLengthNext++;
3360	codeLen = TclGetInt4AtPtr(codeLengthNext);
3361	codeLengthNext += 4;
3362	} else {
3363	codeLen = TclGetInt1AtPtr(codeLengthNext);
3364	codeLengthNext++;
3365	}
3366	codeEnd = (codeOffset + codeLen - 1);
3367
3368	if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
3369	srcDeltaNext++;
3370	delta = TclGetInt4AtPtr(srcDeltaNext);
3371	srcDeltaNext += 4;
3372	} else {
3373	delta = TclGetInt1AtPtr(srcDeltaNext);
3374	srcDeltaNext++;
3375	}
3376	srcOffset += delta;
3377
3378	if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
3379	srcLengthNext++;
3380	srcLen = TclGetInt4AtPtr(srcLengthNext);
3381	srcLengthNext += 4;
3382	} else {
3383	srcLen = TclGetInt1AtPtr(srcLengthNext);
3384	srcLengthNext++;
3385	}
3386
3387	if (codeOffset > pcOffset) { /* best cmd already found */
3388	break;
3389	} else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */
3390	int dist = (pcOffset - codeOffset);
3391	if (dist <= bestDist) {
3392	bestDist = dist;
3393	bestSrcOffset = srcOffset;
3394	bestSrcLength = srcLen;
3395	}
3396	}
3397	}
3398
3399	if (bestDist == INT_MAX) {
3400	return NULL;
3401	}
3402
3403	if (lengthPtr != NULL) {
3404	*lengthPtr = bestSrcLength;
3405	}
3406	return (codePtr->source + bestSrcOffset);
3407	}
3408
3409	/*
3410	*----------------------------------------------------------------------
3411	*
3412	* TclGetExceptionRangeForPc --
3413	*
3414	* Procedure that given a program counter value, returns the closest
3415	* enclosing ExceptionRange that matches the kind requested.
3416	*
3417	* Results:
3418	* In the normal case, catchOnly is 0 (false) and this procedure
3419	* returns a pointer to the most closely enclosing ExceptionRange
3420	* structure regardless of whether it is a loop or catch exception
3421	* range. This is appropriate when processing a TCL_BREAK or
3422	* TCL_CONTINUE, which will be "handled" either by a loop exception
3423	* range or a closer catch range. If catchOnly is nonzero (true), this
3424	* procedure ignores loop exception ranges and returns a pointer to the
3425	* closest catch range. If no matching ExceptionRange is found that
3426	* encloses pc, a NULL is returned.
3427	*
3428	* Side effects:
3429	* None.
3430	*
3431	*----------------------------------------------------------------------
3432	*/
3433
3434	ExceptionRange *
3435	TclGetExceptionRangeForPc(pc, catchOnly, codePtr)
3436	unsigned char pc; / The program counter value for which to
3437	* search for a closest enclosing exception
3438	* range. This points to a bytecode
3439	* instruction in codePtr's code. */
3440	int catchOnly; /* If 0, consider either loop or catch
3441	* ExceptionRanges in search. Otherwise
3442	* consider only catch ranges (and ignore
3443	* any closer loop ranges). */
3444	ByteCode* codePtr; /* Points to the ByteCode in which to search
3445	* for the enclosing ExceptionRange. */
3446	{
3447	ExceptionRange *rangeArrayPtr;
3448	int numRanges = codePtr->numExcRanges;
3449	register ExceptionRange *rangePtr;
3450	int codeOffset = (pc - codePtr->codeStart);
3451	register int i, level;
3452
3453	if (numRanges == 0) {
3454	return NULL;
3455	}
3456	rangeArrayPtr = codePtr->excRangeArrayPtr;
3457
3458	for (level = codePtr->maxExcRangeDepth; level >= 0; level--) {
3459	for (i = 0; i < numRanges; i++) {
3460	rangePtr = &(rangeArrayPtr[i]);
3461	if (rangePtr->nestingLevel == level) {
3462	int start = rangePtr->codeOffset;
3463	int end = (start + rangePtr->numCodeBytes);
3464	if ((start <= codeOffset) && (codeOffset < end)) {
3465	if ((!catchOnly)
3466	\|\| (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
3467	return rangePtr;
3468	}
3469	}
3470	}
3471	}
3472	}
3473	return NULL;
3474	}
3475
3476	/*
3477	*----------------------------------------------------------------------
3478	*
3479	* Math Functions --
3480	*
3481	* This page contains the procedures that implement all of the
3482	* built-in math functions for expressions.
3483	*
3484	* Results:
3485	* Each procedure returns TCL_OK if it succeeds and pushes an
3486	* Tcl object holding the result. If it fails it returns TCL_ERROR
3487	* and leaves an error message in the interpreter's result.
3488	*
3489	* Side effects:
3490	* None.
3491	*
3492	*----------------------------------------------------------------------
3493	*/
3494
3495	static int
3496	ExprUnaryFunc(interp, eePtr, clientData)
3497	Tcl_Interp interp; / The interpreter in which to execute the
3498	* function. */
3499	ExecEnv eePtr; / Points to the environment for executing
3500	* the function. */
3501	ClientData clientData; /* Contains the address of a procedure that
3502	* takes one double argument and returns a
3503	* double result. */
3504	{
3505	StackItem stackPtr; / Cached evaluation stack base pointer. */
3506	register int stackTop; /* Cached top index of evaluation stack. */
3507	register Tcl_Obj *valuePtr;
3508	Tcl_ObjType *tPtr;
3509	double d, dResult;
3510	long i;
3511	int result = TCL_OK;
3512
3513	double (*func) _ANSI_ARGS_((double)) =
3514	(double (*)_ANSI_ARGS_((double))) clientData;
3515
3516	/*
3517	* Set stackPtr and stackTop from eePtr.
3518	*/
3519
3520	CACHE_STACK_INFO();
3521
3522	/*
3523	* Pop the function's argument from the evaluation stack. Convert it
3524	* to a double if necessary.
3525	*/
3526
3527	valuePtr = POP_OBJECT();
3528	tPtr = valuePtr->typePtr;
3529
3530	if (tPtr == &tclIntType) {
3531	d = (double) valuePtr->internalRep.longValue;
3532	} else if (tPtr == &tclDoubleType) {
3533	d = valuePtr->internalRep.doubleValue;
3534	} else { /* FAILS IF STRING REP HAS NULLS */
3535	char s = Tcl_GetStringFromObj(valuePtr, (int ) NULL);
3536
3537	if (TclLooksLikeInt(s)) {
3538	result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
3539	d = (double) valuePtr->internalRep.longValue;
3540	} else {
3541	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
3542	}
3543	if (result != TCL_OK) {
3544	Tcl_ResetResult(interp);
3545	Tcl_AppendToObj(Tcl_GetObjResult(interp),
3546	"argument to math function didn't have numeric value", -1);
3547	goto done;
3548	}
3549	}
3550
3551	errno = 0;
3552	dResult = (*func)(d);
3553	if ((errno != 0) \|\| IS_NAN(dResult) \|\| IS_INF(dResult)) {
3554	TclExprFloatError(interp, dResult);
3555	result = TCL_ERROR;
3556	goto done;
3557	}
3558
3559	/*
3560	* Push a Tcl object holding the result.
3561	*/
3562
3563	PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3564
3565	/*
3566	* Reflect the change to stackTop back in eePtr.
3567	*/
3568
3569	done:
3570	Tcl_DecrRefCount(valuePtr);
3571	DECACHE_STACK_INFO();
3572	return result;
3573	}
3574
3575	static int
3576	ExprBinaryFunc(interp, eePtr, clientData)
3577	Tcl_Interp interp; / The interpreter in which to execute the
3578	* function. */
3579	ExecEnv eePtr; / Points to the environment for executing
3580	* the function. */
3581	ClientData clientData; /* Contains the address of a procedure that
3582	* takes two double arguments and
3583	* returns a double result. */
3584	{
3585	StackItem stackPtr; / Cached evaluation stack base pointer. */
3586	register int stackTop; /* Cached top index of evaluation stack. */
3587	register Tcl_Obj valuePtr, value2Ptr;
3588	Tcl_ObjType *tPtr;
3589	double d1, d2, dResult;
3590	long i;
3591	char *s;
3592	int result = TCL_OK;
3593
3594	double (*func) _ANSI_ARGS_((double, double))
3595	= (double (*)_ANSI_ARGS_((double, double))) clientData;
3596
3597	/*
3598	* Set stackPtr and stackTop from eePtr.
3599	*/
3600
3601	CACHE_STACK_INFO();
3602
3603	/*
3604	* Pop the function's two arguments from the evaluation stack. Convert
3605	* them to doubles if necessary.
3606	*/
3607
3608	value2Ptr = POP_OBJECT();
3609	valuePtr = POP_OBJECT();
3610
3611	tPtr = valuePtr->typePtr;
3612	if (tPtr == &tclIntType) {
3613	d1 = (double) valuePtr->internalRep.longValue;
3614	} else if (tPtr == &tclDoubleType) {
3615	d1 = valuePtr->internalRep.doubleValue;
3616	} else { /* FAILS IF STRING REP HAS NULLS */
3617	s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
3618	if (TclLooksLikeInt(s)) {
3619	result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
3620	d1 = (double) valuePtr->internalRep.longValue;
3621	} else {
3622	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d1);
3623	}
3624	if (result != TCL_OK) {
3625	badArg:
3626	Tcl_ResetResult(interp);
3627	Tcl_AppendToObj(Tcl_GetObjResult(interp),
3628	"argument to math function didn't have numeric value", -1);
3629	goto done;
3630	}
3631	}
3632
3633	tPtr = value2Ptr->typePtr;
3634	if (tPtr == &tclIntType) {
3635	d2 = value2Ptr->internalRep.longValue;
3636	} else if (tPtr == &tclDoubleType) {
3637	d2 = value2Ptr->internalRep.doubleValue;
3638	} else { /* FAILS IF STRING REP HAS NULLS */
3639	s = Tcl_GetStringFromObj(value2Ptr, (int *) NULL);
3640	if (TclLooksLikeInt(s)) {
3641	result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, value2Ptr, &i);
3642	d2 = (double) value2Ptr->internalRep.longValue;
3643	} else {
3644	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, value2Ptr, &d2);
3645	}
3646	if (result != TCL_OK) {
3647	goto badArg;
3648	}
3649	}
3650
3651	errno = 0;
3652	dResult = (*func)(d1, d2);
3653	if ((errno != 0) \|\| IS_NAN(dResult) \|\| IS_INF(dResult)) {
3654	TclExprFloatError(interp, dResult);
3655	result = TCL_ERROR;
3656	goto done;
3657	}
3658
3659	/*
3660	* Push a Tcl object holding the result.
3661	*/
3662
3663	PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3664
3665	/*
3666	* Reflect the change to stackTop back in eePtr.
3667	*/
3668
3669	done:
3670	Tcl_DecrRefCount(valuePtr);
3671	Tcl_DecrRefCount(value2Ptr);
3672	DECACHE_STACK_INFO();
3673	return result;
3674	}
3675
3676	static int
3677	ExprAbsFunc(interp, eePtr, clientData)
3678	Tcl_Interp interp; / The interpreter in which to execute the
3679	* function. */
3680	ExecEnv eePtr; / Points to the environment for executing
3681	* the function. */
3682	ClientData clientData; /* Ignored. */
3683	{
3684	StackItem stackPtr; / Cached evaluation stack base pointer. */
3685	register int stackTop; /* Cached top index of evaluation stack. */
3686	register Tcl_Obj *valuePtr;
3687	Tcl_ObjType *tPtr;
3688	long i, iResult;
3689	double d, dResult;
3690	int result = TCL_OK;
3691
3692	/*
3693	* Set stackPtr and stackTop from eePtr.
3694	*/
3695
3696	CACHE_STACK_INFO();
3697
3698	/*
3699	* Pop the argument from the evaluation stack.
3700	*/
3701
3702	valuePtr = POP_OBJECT();
3703	tPtr = valuePtr->typePtr;
3704
3705	if (tPtr == &tclIntType) {
3706	i = valuePtr->internalRep.longValue;
3707	} else if (tPtr == &tclDoubleType) {
3708	d = valuePtr->internalRep.doubleValue;
3709	} else { /* FAILS IF STRING REP HAS NULLS */
3710	char s = Tcl_GetStringFromObj(valuePtr, (int ) NULL);
3711
3712	if (TclLooksLikeInt(s)) {
3713	result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
3714	} else {
3715	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
3716	}
3717	if (result != TCL_OK) {
3718	Tcl_ResetResult(interp);
3719	Tcl_AppendToObj(Tcl_GetObjResult(interp),
3720	"argument to math function didn't have numeric value", -1);
3721	goto done;
3722	}
3723	tPtr = valuePtr->typePtr;
3724	}
3725
3726	/*
3727	* Push a Tcl object with the result.
3728	*/
3729
3730	if (tPtr == &tclIntType) {
3731	if (i < 0) {
3732	iResult = -i;
3733	if (iResult < 0) {
3734	Tcl_ResetResult(interp);
3735	Tcl_AppendToObj(Tcl_GetObjResult(interp),
3736	"integer value too large to represent", -1);
3737	Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
3738	"integer value too large to represent", (char *) NULL);
3739	result = TCL_ERROR;
3740	goto done;
3741	}
3742	} else {
3743	iResult = i;
3744	}
3745	PUSH_OBJECT(Tcl_NewLongObj(iResult));
3746	} else {
3747	if (d < 0.0) {
3748	dResult = -d;
3749	} else {
3750	dResult = d;
3751	}
3752	if (IS_NAN(dResult) \|\| IS_INF(dResult)) {
3753	TclExprFloatError(interp, dResult);
3754	result = TCL_ERROR;
3755	goto done;
3756	}
3757	PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3758	}
3759
3760	/*
3761	* Reflect the change to stackTop back in eePtr.
3762	*/
3763
3764	done:
3765	Tcl_DecrRefCount(valuePtr);
3766	DECACHE_STACK_INFO();
3767	return result;
3768	}
3769
3770	static int
3771	ExprDoubleFunc(interp, eePtr, clientData)
3772	Tcl_Interp interp; / The interpreter in which to execute the
3773	* function. */
3774	ExecEnv eePtr; / Points to the environment for executing
3775	* the function. */
3776	ClientData clientData; /* Ignored. */
3777	{
3778	StackItem stackPtr; / Cached evaluation stack base pointer. */
3779	register int stackTop; /* Cached top index of evaluation stack. */
3780	register Tcl_Obj *valuePtr;
3781	double dResult;
3782	long i;
3783	int result = TCL_OK;
3784
3785	/*
3786	* Set stackPtr and stackTop from eePtr.
3787	*/
3788
3789	CACHE_STACK_INFO();
3790
3791	/*
3792	* Pop the argument from the evaluation stack.
3793	*/
3794
3795	valuePtr = POP_OBJECT();
3796	if (valuePtr->typePtr == &tclIntType) {
3797	dResult = (double) valuePtr->internalRep.longValue;
3798	} else if (valuePtr->typePtr == &tclDoubleType) {
3799	dResult = valuePtr->internalRep.doubleValue;
3800	} else { /* FAILS IF STRING REP HAS NULLS */
3801	char s = Tcl_GetStringFromObj(valuePtr, (int ) NULL);
3802
3803	if (TclLooksLikeInt(s)) {
3804	result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
3805	dResult = (double) valuePtr->internalRep.longValue;
3806	} else {
3807	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr,
3808	&dResult);
3809	}
3810	if (result != TCL_OK) {
3811	Tcl_ResetResult(interp);
3812	Tcl_AppendToObj(Tcl_GetObjResult(interp),
3813	"argument to math function didn't have numeric value", -1);
3814	goto done;
3815	}
3816	}
3817
3818	/*
3819	* Push a Tcl object with the result.
3820	*/
3821
3822	PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3823
3824	/*
3825	* Reflect the change to stackTop back in eePtr.
3826	*/
3827
3828	done:
3829	Tcl_DecrRefCount(valuePtr);
3830	DECACHE_STACK_INFO();
3831	return result;
3832	}
3833
3834	static int
3835	ExprIntFunc(interp, eePtr, clientData)
3836	Tcl_Interp interp; / The interpreter in which to execute the
3837	* function. */
3838	ExecEnv eePtr; / Points to the environment for executing
3839	* the function. */
3840	ClientData clientData; /* Ignored. */
3841	{
3842	StackItem stackPtr; / Cached evaluation stack base pointer. */
3843	register int stackTop; /* Cached top index of evaluation stack. */
3844	register Tcl_Obj *valuePtr;
3845	Tcl_ObjType *tPtr;
3846	long i = 0; /* Initialized to avoid compiler warning. */
3847	long iResult;
3848	double d;
3849	int result = TCL_OK;
3850
3851	/*
3852	* Set stackPtr and stackTop from eePtr.
3853	*/
3854
3855	CACHE_STACK_INFO();
3856
3857	/*
3858	* Pop the argument from the evaluation stack.
3859	*/
3860
3861	valuePtr = POP_OBJECT();
3862	tPtr = valuePtr->typePtr;
3863
3864	if (tPtr == &tclIntType) {
3865	i = valuePtr->internalRep.longValue;
3866	} else if (tPtr == &tclDoubleType) {
3867	d = valuePtr->internalRep.doubleValue;
3868	} else { /* FAILS IF STRING REP HAS NULLS */
3869	char s = Tcl_GetStringFromObj(valuePtr, (int ) NULL);
3870
3871	if (TclLooksLikeInt(s)) {
3872	result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
3873	} else {
3874	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
3875	}
3876	if (result != TCL_OK) {
3877	Tcl_ResetResult(interp);
3878	Tcl_AppendToObj(Tcl_GetObjResult(interp),
3879	"argument to math function didn't have numeric value", -1);
3880	goto done;
3881	}
3882	tPtr = valuePtr->typePtr;
3883	}
3884
3885	/*
3886	* Push a Tcl object with the result.
3887	*/
3888
3889	if (tPtr == &tclIntType) {
3890	iResult = i;
3891	} else {
3892	if (d < 0.0) {
3893	if (d < (double) (long) LONG_MIN) {
3894	tooLarge:
3895	Tcl_ResetResult(interp);
3896	Tcl_AppendToObj(Tcl_GetObjResult(interp),
3897	"integer value too large to represent", -1);
3898	Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
3899	"integer value too large to represent", (char *) NULL);
3900	result = TCL_ERROR;
3901	goto done;
3902	}
3903	} else {
3904	if (d > (double) LONG_MAX) {
3905	goto tooLarge;
3906	}
3907	}
3908	if (IS_NAN(d) \|\| IS_INF(d)) {
3909	TclExprFloatError(interp, d);
3910	result = TCL_ERROR;
3911	goto done;
3912	}
3913	iResult = (long) d;
3914	}
3915	PUSH_OBJECT(Tcl_NewLongObj(iResult));
3916
3917	/*
3918	* Reflect the change to stackTop back in eePtr.
3919	*/
3920
3921	done:
3922	Tcl_DecrRefCount(valuePtr);
3923	DECACHE_STACK_INFO();
3924	return result;
3925	}
3926
3927	static int
3928	ExprRoundFunc(interp, eePtr, clientData)
3929	Tcl_Interp interp; / The interpreter in which to execute the
3930	* function. */
3931	ExecEnv eePtr; / Points to the environment for executing
3932	* the function. */
3933	ClientData clientData; /* Ignored. */
3934	{
3935	StackItem stackPtr; / Cached evaluation stack base pointer. */
3936	register int stackTop; /* Cached top index of evaluation stack. */
3937	Tcl_Obj *valuePtr;
3938	Tcl_ObjType *tPtr;
3939	long i = 0; /* Initialized to avoid compiler warning. */
3940	long iResult;
3941	double d, temp;
3942	int result = TCL_OK;
3943
3944	/*
3945	* Set stackPtr and stackTop from eePtr.
3946	*/
3947
3948	CACHE_STACK_INFO();
3949
3950	/*
3951	* Pop the argument from the evaluation stack.
3952	*/
3953
3954	valuePtr = POP_OBJECT();
3955	tPtr = valuePtr->typePtr;
3956
3957	if (tPtr == &tclIntType) {
3958	i = valuePtr->internalRep.longValue;
3959	} else if (tPtr == &tclDoubleType) {
3960	d = valuePtr->internalRep.doubleValue;
3961	} else { /* FAILS IF STRING REP HAS NULLS */
3962	char s = Tcl_GetStringFromObj(valuePtr, (int ) NULL);
3963
3964	if (TclLooksLikeInt(s)) {
3965	result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
3966	} else {
3967	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
3968	}
3969	if (result != TCL_OK) {
3970	Tcl_ResetResult(interp);
3971	Tcl_AppendToObj(Tcl_GetObjResult(interp),
3972	"argument to math function didn't have numeric value", -1);
3973	goto done;
3974	}
3975	tPtr = valuePtr->typePtr;
3976	}
3977
3978	/*
3979	* Push a Tcl object with the result.
3980	*/
3981
3982	if (tPtr == &tclIntType) {
3983	iResult = i;
3984	} else {
3985	if (d < 0.0) {
3986	if (d <= (((double) (long) LONG_MIN) - 0.5)) {
3987	tooLarge:
3988	Tcl_ResetResult(interp);
3989	Tcl_AppendToObj(Tcl_GetObjResult(interp),
3990	"integer value too large to represent", -1);
3991	Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
3992	"integer value too large to represent",
3993	(char *) NULL);
3994	result = TCL_ERROR;
3995	goto done;
3996	}
3997	temp = (long) (d - 0.5);
3998	} else {
3999	if (d >= (((double) LONG_MAX + 0.5))) {
4000	goto tooLarge;
4001	}
4002	temp = (long) (d + 0.5);
4003	}
4004	if (IS_NAN(temp) \|\| IS_INF(temp)) {
4005	TclExprFloatError(interp, temp);
4006	result = TCL_ERROR;
4007	goto done;
4008	}
4009	iResult = (long) temp;
4010	}
4011	PUSH_OBJECT(Tcl_NewLongObj(iResult));
4012
4013	/*
4014	* Reflect the change to stackTop back in eePtr.
4015	*/
4016
4017	done:
4018	Tcl_DecrRefCount(valuePtr);
4019	DECACHE_STACK_INFO();
4020	return result;
4021	}
4022
4023	/*
4024	*----------------------------------------------------------------------
4025	*
4026	* ExprCallMathFunc --
4027	*
4028	* This procedure is invoked to call a non-builtin math function
4029	* during the execution of an expression.
4030	*
4031	* Results:
4032	* TCL_OK is returned if all went well and the function's value
4033	* was computed successfully. If an error occurred, TCL_ERROR
4034	* is returned and an error message is left in the interpreter's
4035	* result. After a successful return this procedure pushes a Tcl object
4036	* holding the result.
4037	*
4038	* Side effects:
4039	* None, unless the called math function has side effects.
4040	*
4041	*----------------------------------------------------------------------
4042	*/
4043
4044	static int
4045	ExprCallMathFunc(interp, eePtr, objc, objv)
4046	Tcl_Interp interp; / The interpreter in which to execute the
4047	* function. */
4048	ExecEnv eePtr; / Points to the environment for executing
4049	* the function. */
4050	int objc; /* Number of arguments. The function name is
4051	* the 0-th argument. */
4052	Tcl_Obj *objv; / The array of arguments. The function name
4053	* is objv[0]. */
4054	{
4055	Interp iPtr = (Interp ) interp;
4056	StackItem stackPtr; / Cached evaluation stack base pointer. */
4057	register int stackTop; /* Cached top index of evaluation stack. */
4058	char *funcName;
4059	Tcl_HashEntry *hPtr;
4060	MathFunc mathFuncPtr; / Information about math function. */
4061	Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */
4062	Tcl_Value funcResult; /* Result of function call as Tcl_Value. */
4063	register Tcl_Obj *valuePtr;
4064	Tcl_ObjType *tPtr;
4065	long i;
4066	double d;
4067	int j, k, result;
4068
4069	Tcl_ResetResult(interp);
4070
4071	/*
4072	* Set stackPtr and stackTop from eePtr.
4073	*/
4074
4075	CACHE_STACK_INFO();
4076
4077	/*
4078	* Look up the MathFunc record for the function.
4079	* THIS FAILS IF THE OBJECT'S STRING REP CONTAINS NULLS.
4080	*/
4081
4082	funcName = Tcl_GetStringFromObj(objv[0], (int *) NULL);
4083	hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
4084	if (hPtr == NULL) {
4085	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
4086	"unknown math function \"", funcName, "\"", (char *) NULL);
4087	result = TCL_ERROR;
4088	goto done;
4089	}
4090	mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
4091	if (mathFuncPtr->numArgs != (objc-1)) {
4092	panic("ExprCallMathFunc: expected number of args %d != actual number %d",
4093	mathFuncPtr->numArgs, objc);
4094	result = TCL_ERROR;
4095	goto done;
4096	}
4097
4098	/*
4099	* Collect the arguments for the function, if there are any, into the
4100	* array "args". Note that args[0] will have the Tcl_Value that
4101	* corresponds to objv[1].
4102	*/
4103
4104	for (j = 1, k = 0; j < objc; j++, k++) {
4105	valuePtr = objv[j];
4106	tPtr = valuePtr->typePtr;
4107
4108	if (tPtr == &tclIntType) {
4109	i = valuePtr->internalRep.longValue;
4110	} else if (tPtr == &tclDoubleType) {
4111	d = valuePtr->internalRep.doubleValue;
4112	} else {
4113	/*
4114	* Try to convert to int first then double.
4115	* FAILS IF STRING REP HAS NULLS.
4116	*/
4117
4118	char s = Tcl_GetStringFromObj(valuePtr, (int ) NULL);
4119
4120	if (TclLooksLikeInt(s)) {
4121	result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
4122	} else {
4123	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
4124	valuePtr, &d);
4125	}
4126	if (result != TCL_OK) {
4127	Tcl_AppendToObj(Tcl_GetObjResult(interp),
4128	"argument to math function didn't have numeric value", -1);
4129	goto done;
4130	}
4131	tPtr = valuePtr->typePtr;
4132	}
4133
4134	/*
4135	* Copy the object's numeric value to the argument record,
4136	* converting it if necessary.
4137	*/
4138
4139	if (tPtr == &tclIntType) {
4140	if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
4141	args[k].type = TCL_DOUBLE;
4142	args[k].doubleValue = i;
4143	} else {
4144	args[k].type = TCL_INT;
4145	args[k].intValue = i;
4146	}
4147	} else {
4148	if (mathFuncPtr->argTypes[k] == TCL_INT) {
4149	args[k].type = TCL_INT;
4150	args[k].intValue = (long) d;
4151	} else {
4152	args[k].type = TCL_DOUBLE;
4153	args[k].doubleValue = d;
4154	}
4155	}
4156	}
4157
4158	/*
4159	* Invoke the function and copy its result back into valuePtr.
4160	*/
4161
4162	tcl_MathInProgress++;
4163	result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
4164	&funcResult);
4165	tcl_MathInProgress--;
4166	if (result != TCL_OK) {
4167	goto done;
4168	}
4169
4170	/*
4171	* Pop the objc top stack elements and decrement their ref counts.
4172	*/
4173
4174	i = (stackTop - (objc-1));
4175	while (i <= stackTop) {
4176	valuePtr = stackPtr[i].o;
4177	Tcl_DecrRefCount(valuePtr);
4178	i++;
4179	}
4180	stackTop -= objc;
4181
4182	/*
4183	* Push the call's object result.
4184	*/
4185
4186	if (funcResult.type == TCL_INT) {
4187	PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue));
4188	} else {
4189	d = funcResult.doubleValue;
4190	if (IS_NAN(d) \|\| IS_INF(d)) {
4191	TclExprFloatError(interp, d);
4192	result = TCL_ERROR;
4193	goto done;
4194	}
4195	PUSH_OBJECT(Tcl_NewDoubleObj(d));
4196	}
4197
4198	/*
4199	* Reflect the change to stackTop back in eePtr.
4200	*/
4201
4202	done:
4203	DECACHE_STACK_INFO();
4204	return result;
4205	}
4206
4207	/*
4208	*----------------------------------------------------------------------
4209	*
4210	* TclExprFloatError --
4211	*
4212	* This procedure is called when an error occurs during a
4213	* floating-point operation. It reads errno and sets
4214	* interp->objResultPtr accordingly.
4215	*
4216	* Results:
4217	* interp->objResultPtr is set to hold an error message.
4218	*
4219	* Side effects:
4220	* None.
4221	*
4222	*----------------------------------------------------------------------
4223	*/
4224
4225	void
4226	TclExprFloatError(interp, value)
4227	Tcl_Interp interp; / Where to store error message. */
4228	double value; /* Value returned after error; used to
4229	* distinguish underflows from overflows. */
4230	{
4231	char *s;
4232
4233	Tcl_ResetResult(interp);
4234	if ((errno == EDOM) \|\| (value != value)) {
4235	s = "domain error: argument not in valid range";
4236	Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
4237	Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL);
4238	} else if ((errno == ERANGE) \|\| IS_INF(value)) {
4239	if (value == 0.0) {
4240	s = "floating-point value too small to represent";
4241	Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
4242	Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL);
4243	} else {
4244	s = "floating-point value too large to represent";
4245	Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
4246	Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL);
4247	}
4248	} else { /* FAILS IF STRING REP CONTAINS NULLS */
4249	char msg[100];
4250
4251	sprintf(msg, "unknown floating-point error, errno = %d", errno);
4252	Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1);
4253	Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL);
4254	}
4255	}
4256
4257	#ifdef TCL_COMPILE_STATS
4258	/*
4259	*----------------------------------------------------------------------
4260	*
4261	* TclLog2 --
4262	*
4263	* Procedure used while collecting compilation statistics to determine
4264	* the log base 2 of an integer.
4265	*
4266	* Results:
4267	* Returns the log base 2 of the operand. If the argument is less
4268	* than or equal to zero, a zero is returned.
4269	*
4270	* Side effects:
4271	* None.
4272	*
4273	*----------------------------------------------------------------------
4274	*/
4275
4276	int
4277	TclLog2(value)
4278	register int value; /* The integer for which to compute the
4279	* log base 2. */
4280	{
4281	register int n = value;
4282	register int result = 0;
4283
4284	while (n > 1) {
4285	n = n >> 1;
4286	result++;
4287	}
4288	return result;
4289	}
4290
4291	/*
4292	*----------------------------------------------------------------------
4293	*
4294	* EvalStatsCmd --
4295	*
4296	* Implements the "evalstats" command that prints instruction execution
4297	* counts to stdout.
4298	*
4299	* Results:
4300	* Standard Tcl results.
4301	*
4302	* Side effects:
4303	* None.
4304	*
4305	*----------------------------------------------------------------------
4306	*/
4307
4308	static int
4309	EvalStatsCmd(unused, interp, argc, argv)
4310	ClientData unused; /* Unused. */
4311	Tcl_Interp interp; / The current interpreter. */
4312	int argc; /* The number of arguments. */
4313	char *argv; / The argument strings. */
4314	{
4315	register double total = 0.0;
4316	register int i;
4317	int maxSizeDecade = 0;
4318	double totalHeaderBytes = (tclNumCompilations * sizeof(ByteCode));
4319
4320	for (i = 0; i < 256; i++) {
4321	if (instructionCount[i] != 0) {
4322	total += instructionCount[i];
4323	}
4324	}
4325
4326	for (i = 31; i >= 0; i--) {
4327	if ((tclSourceCount[i] > 0) && (tclByteCodeCount[i] > 0)) {
4328	maxSizeDecade = i;
4329	break;
4330	}
4331	}
4332
4333	fprintf(stdout, "\nNumber of compilations %ld\n",
4334	tclNumCompilations);
4335	fprintf(stdout, "Number of executions %ld\n",
4336	numExecutions);
4337	fprintf(stdout, "Average executions/compilation %.0f\n",
4338	((float) numExecutions/tclNumCompilations));
4339
4340	fprintf(stdout, "\nInstructions executed %.0f\n",
4341	total);
4342	fprintf(stdout, "Average instructions/compile %.0f\n",
4343	total/tclNumCompilations);
4344	fprintf(stdout, "Average instructions/execution %.0f\n",
4345	total/numExecutions);
4346
4347	fprintf(stdout, "\nTotal source bytes %.6g\n",
4348	tclTotalSourceBytes);
4349	fprintf(stdout, "Total code bytes %.6g\n",
4350	tclTotalCodeBytes);
4351	fprintf(stdout, "Average code/compilation %.0f\n",
4352	tclTotalCodeBytes/tclNumCompilations);
4353	fprintf(stdout, "Average code/source %.2f\n",
4354	tclTotalCodeBytes/tclTotalSourceBytes);
4355	fprintf(stdout, "Current source bytes %.6g\n",
4356	tclCurrentSourceBytes);
4357	fprintf(stdout, "Current code bytes %.6g\n",
4358	tclCurrentCodeBytes);
4359	fprintf(stdout, "Current code/source %.2f\n",
4360	tclCurrentCodeBytes/tclCurrentSourceBytes);
4361
4362	fprintf(stdout, "\nTotal objects allocated %ld\n",
4363	tclObjsAlloced);
4364	fprintf(stdout, "Total objects freed %ld\n",
4365	tclObjsFreed);
4366	fprintf(stdout, "Current objects: %ld\n",
4367	(tclObjsAlloced - tclObjsFreed));
4368
4369	fprintf(stdout, "\nBreakdown of code byte requirements:\n");
4370	fprintf(stdout, " Total bytes Pct of Avg per\n");
4371	fprintf(stdout, " all code compile\n");
4372	fprintf(stdout, "Total code %12.6g 100%% %8.2f\n",
4373	tclTotalCodeBytes, tclTotalCodeBytes/tclNumCompilations);
4374	fprintf(stdout, "Header %12.6g %8.2f%% %8.2f\n",
4375	totalHeaderBytes,
4376	((totalHeaderBytes * 100.0) / tclTotalCodeBytes),
4377	totalHeaderBytes/tclNumCompilations);
4378	fprintf(stdout, "Instructions %12.6g %8.2f%% %8.2f\n",
4379	tclTotalInstBytes,
4380	((tclTotalInstBytes * 100.0) / tclTotalCodeBytes),
4381	tclTotalInstBytes/tclNumCompilations);
4382	fprintf(stdout, "Objects %12.6g %8.2f%% %8.2f\n",
4383	tclTotalObjBytes,
4384	((tclTotalObjBytes * 100.0) / tclTotalCodeBytes),
4385	tclTotalObjBytes/tclNumCompilations);
4386	fprintf(stdout, "Exception table %12.6g %8.2f%% %8.2f\n",
4387	tclTotalExceptBytes,
4388	((tclTotalExceptBytes * 100.0) / tclTotalCodeBytes),
4389	tclTotalExceptBytes/tclNumCompilations);
4390	fprintf(stdout, "Auxiliary data %12.6g %8.2f%% %8.2f\n",
4391	tclTotalAuxBytes,
4392	((tclTotalAuxBytes * 100.0) / tclTotalCodeBytes),
4393	tclTotalAuxBytes/tclNumCompilations);
4394	fprintf(stdout, "Command map %12.6g %8.2f%% %8.2f\n",
4395	tclTotalCmdMapBytes,
4396	((tclTotalCmdMapBytes * 100.0) / tclTotalCodeBytes),
4397	tclTotalCmdMapBytes/tclNumCompilations);
4398
4399	fprintf(stdout, "\nSource and ByteCode size distributions:\n");
4400	fprintf(stdout, " binary decade source code\n");
4401	for (i = 0; i <= maxSizeDecade; i++) {
4402	int decadeLow, decadeHigh;
4403
4404	if (i == 0) {
4405	decadeLow = 0;
4406	} else {
4407	decadeLow = 1 << i;
4408	}
4409	decadeHigh = (1 << (i+1)) - 1;
4410	fprintf(stdout, " %6d -%6d %6d %6d\n",
4411	decadeLow, decadeHigh,
4412	tclSourceCount[i], tclByteCodeCount[i]);
4413	}
4414
4415	fprintf(stdout, "\nInstruction counts:\n");
4416	for (i = 0; i < 256; i++) {
4417	if (instructionCount[i]) {
4418	fprintf(stdout, "%20s %8d %6.2f%%\n",
4419	opName[i], instructionCount[i],
4420	(instructionCount[i] * 100.0)/total);
4421	}
4422	}
4423
4424	#ifdef TCL_MEM_DEBUG
4425	fprintf(stdout, "\nHeap Statistics:\n");
4426	TclDumpMemoryInfo(stdout);
4427	#endif /* TCL_MEM_DEBUG */
4428
4429	return TCL_OK;
4430	}
4431	#endif /* TCL_COMPILE_STATS */
4432
4433	/*
4434	*----------------------------------------------------------------------
4435	*
4436	* Tcl_GetCommandFromObj --
4437	*
4438	* Returns the command specified by the name in a Tcl_Obj.
4439	*
4440	* Results:
4441	* Returns a token for the command if it is found. Otherwise, if it
4442	* can't be found or there is an error, returns NULL.
4443	*
4444	* Side effects:
4445	* May update the internal representation for the object, caching
4446	* the command reference so that the next time this procedure is
4447	* called with the same object, the command can be found quickly.
4448	*
4449	*----------------------------------------------------------------------
4450	*/
4451
4452	Tcl_Command
4453	Tcl_GetCommandFromObj(interp, objPtr)
4454	Tcl_Interp interp; / The interpreter in which to resolve the
4455	* command and to report errors. */
4456	register Tcl_Obj objPtr; / The object containing the command's
4457	* name. If the name starts with "::", will
4458	* be looked up in global namespace. Else,
4459	* looked up first in the current namespace
4460	* if contextNsPtr is NULL, then in global
4461	* namespace. */
4462	{
4463	Interp iPtr = (Interp ) interp;
4464	register ResolvedCmdName *resPtr;
4465	register Command *cmdPtr;
4466	Namespace *currNsPtr;
4467	int result;
4468
4469	/*
4470	* Get the internal representation, converting to a command type if
4471	* needed. The internal representation is a ResolvedCmdName that points
4472	* to the actual command.
4473	*/
4474
4475	if (objPtr->typePtr != &tclCmdNameType) {
4476	result = tclCmdNameType.setFromAnyProc(interp, objPtr);
4477	if (result != TCL_OK) {
4478	return (Tcl_Command) NULL;
4479	}
4480	}
4481	resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
4482
4483	/*
4484	* Get the current namespace.
4485	*/
4486
4487	if (iPtr->varFramePtr != NULL) {
4488	currNsPtr = iPtr->varFramePtr->nsPtr;
4489	} else {
4490	currNsPtr = iPtr->globalNsPtr;
4491	}
4492
4493	/*
4494	* Check the context namespace and the namespace epoch of the resolved
4495	* symbol to make sure that it is fresh. If not, then force another
4496	* conversion to the command type, to discard the old rep and create a
4497	* new one. Note that we verify that the namespace id of the context
4498	* namespace is the same as the one we cached; this insures that the
4499	* namespace wasn't deleted and a new one created at the same address
4500	* with the same command epoch.
4501	*/
4502
4503	cmdPtr = NULL;
4504	if ((resPtr != NULL)
4505	&& (resPtr->refNsPtr == currNsPtr)
4506	&& (resPtr->refNsId == currNsPtr->nsId)
4507	&& (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) {
4508	cmdPtr = resPtr->cmdPtr;
4509	if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) {
4510	cmdPtr = NULL;
4511	}
4512	}
4513
4514	if (cmdPtr == NULL) {
4515	result = tclCmdNameType.setFromAnyProc(interp, objPtr);
4516	if (result != TCL_OK) {
4517	return (Tcl_Command) NULL;
4518	}
4519	resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
4520	if (resPtr != NULL) {
4521	cmdPtr = resPtr->cmdPtr;
4522	}
4523	}
4524
4525	if (cmdPtr == NULL) {
4526	return (Tcl_Command) NULL;
4527	}
4528	return (Tcl_Command) cmdPtr;
4529	}
4530
4531	/*
4532	*----------------------------------------------------------------------
4533	*
4534	* FreeCmdNameInternalRep --
4535	*
4536	* Frees the resources associated with a cmdName object's internal
4537	* representation.
4538	*
4539	* Results:
4540	* None.
4541	*
4542	* Side effects:
4543	* Decrements the ref count of any cached ResolvedCmdName structure
4544	* pointed to by the cmdName's internal representation. If this is
4545	* the last use of the ResolvedCmdName, it is freed. This in turn
4546	* decrements the ref count of the Command structure pointed to by
4547	* the ResolvedSymbol, which may free the Command structure.
4548	*
4549	*----------------------------------------------------------------------
4550	*/
4551
4552	static void
4553	FreeCmdNameInternalRep(objPtr)
4554	register Tcl_Obj objPtr; / CmdName object with internal
4555	* representation to free. */
4556	{
4557	register ResolvedCmdName *resPtr =
4558	(ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
4559
4560	if (resPtr != NULL) {
4561	/*
4562	* Decrement the reference count of the ResolvedCmdName structure.
4563	* If there are no more uses, free the ResolvedCmdName structure.
4564	*/
4565
4566	resPtr->refCount--;
4567	if (resPtr->refCount == 0) {
4568	/*
4569	* Now free the cached command, unless it is still in its
4570	* hash table or if there are other references to it
4571	* from other cmdName objects.
4572	*/
4573
4574	Command *cmdPtr = resPtr->cmdPtr;
4575	TclCleanupCommand(cmdPtr);
4576	ckfree((char *) resPtr);
4577	}
4578	}
4579	}
4580
4581	/*
4582	*----------------------------------------------------------------------
4583	*
4584	* DupCmdNameInternalRep --
4585	*
4586	* Initialize the internal representation of an cmdName Tcl_Obj to a
4587	* copy of the internal representation of an existing cmdName object.
4588	*
4589	* Results:
4590	* None.
4591	*
4592	* Side effects:
4593	* "copyPtr"s internal rep is set to point to the ResolvedCmdName
4594	* structure corresponding to "srcPtr"s internal rep. Increments the
4595	* ref count of the ResolvedCmdName structure pointed to by the
4596	* cmdName's internal representation.
4597	*
4598	*----------------------------------------------------------------------
4599	*/
4600
4601	static void
4602	DupCmdNameInternalRep(srcPtr, copyPtr)
4603	Tcl_Obj srcPtr; / Object with internal rep to copy. */
4604	register Tcl_Obj copyPtr; / Object with internal rep to set. */
4605	{
4606	register ResolvedCmdName *resPtr =
4607	(ResolvedCmdName *) srcPtr->internalRep.otherValuePtr;
4608
4609	copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
4610	copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
4611	if (resPtr != NULL) {
4612	resPtr->refCount++;
4613	}
4614	copyPtr->typePtr = &tclCmdNameType;
4615	}
4616
4617	/*
4618	*----------------------------------------------------------------------
4619	*
4620	* SetCmdNameFromAny --
4621	*
4622	* Generate an cmdName internal form for the Tcl object "objPtr".
4623	*
4624	* Results:
4625	* The return value is a standard Tcl result. The conversion always
4626	* succeeds and TCL_OK is returned.
4627	*
4628	* Side effects:
4629	* A pointer to a ResolvedCmdName structure that holds a cached pointer
4630	* to the command with a name that matches objPtr's string rep is
4631	* stored as objPtr's internal representation. This ResolvedCmdName
4632	* pointer will be NULL if no matching command was found. The ref count
4633	* of the cached Command's structure (if any) is also incremented.
4634	*
4635	*----------------------------------------------------------------------
4636	*/
4637
4638	static int
4639	SetCmdNameFromAny(interp, objPtr)
4640	Tcl_Interp interp; / Used for error reporting if not NULL. */
4641	register Tcl_Obj objPtr; / The object to convert. */
4642	{
4643	Interp iPtr = (Interp ) interp;
4644	char *name;
4645	Tcl_Command cmd;
4646	register Command *cmdPtr;
4647	Namespace *currNsPtr;
4648	register ResolvedCmdName *resPtr;
4649
4650	/*
4651	* Get "objPtr"s string representation. Make it up-to-date if necessary.
4652	*/
4653
4654	name = objPtr->bytes;
4655	if (name == NULL) {
4656	name = Tcl_GetStringFromObj(objPtr, (int *) NULL);
4657	}
4658
4659	/*
4660	* Find the Command structure, if any, that describes the command called
4661	* "name". Build a ResolvedCmdName that holds a cached pointer to this
4662	* Command, and bump the reference count in the referenced Command
4663	* structure. A Command structure will not be deleted as long as it is
4664	* referenced from a CmdName object.
4665	*/
4666
4667	cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL,
4668	/flags/ 0);
4669	cmdPtr = (Command *) cmd;
4670	if (cmdPtr != NULL) {
4671	/*
4672	* Get the current namespace.
4673	*/
4674
4675	if (iPtr->varFramePtr != NULL) {
4676	currNsPtr = iPtr->varFramePtr->nsPtr;
4677	} else {
4678	currNsPtr = iPtr->globalNsPtr;
4679	}
4680
4681	cmdPtr->refCount++;
4682	resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
4683	resPtr->cmdPtr = cmdPtr;
4684	resPtr->refNsPtr = currNsPtr;
4685	resPtr->refNsId = currNsPtr->nsId;
4686	resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
4687	resPtr->cmdEpoch = cmdPtr->cmdEpoch;
4688	resPtr->refCount = 1;
4689	} else {
4690	resPtr = NULL; /* no command named "name" was found */
4691	}
4692
4693	/*
4694	* Free the old internalRep before setting the new one. We do this as
4695	* late as possible to allow the conversion code, in particular
4696	* GetStringFromObj, to use that old internalRep. If no Command
4697	* structure was found, leave NULL as the cached value.
4698	*/
4699
4700	if ((objPtr->typePtr != NULL)
4701	&& (objPtr->typePtr->freeIntRepProc != NULL)) {
4702	objPtr->typePtr->freeIntRepProc(objPtr);
4703	}
4704
4705	objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
4706	objPtr->internalRep.twoPtrValue.ptr2 = NULL;
4707	objPtr->typePtr = &tclCmdNameType;
4708	return TCL_OK;
4709	}
4710
4711	/*
4712	*----------------------------------------------------------------------
4713	*
4714	* UpdateStringOfCmdName --
4715	*
4716	* Update the string representation for an cmdName object.
4717	*
4718	* Results:
4719	* None.
4720	*
4721	* Side effects:
4722	* Generates a panic.
4723	*
4724	*----------------------------------------------------------------------
4725	*/
4726
4727	static void
4728	UpdateStringOfCmdName(objPtr)
4729	Tcl_Obj objPtr; / CmdName obj to update string rep. */
4730	{
4731	/*
4732	* This procedure is never invoked since the internal representation of
4733	* a cmdName object is never modified.
4734	*/
4735
4736	panic("UpdateStringOfCmdName should never be invoked");
4737	}
4738
4739	#ifdef TCL_COMPILE_DEBUG
4740	/*
4741	*----------------------------------------------------------------------
4742	*
4743	* StringForResultCode --
4744	*
4745	* Procedure that returns a human-readable string representing a
4746	* Tcl result code such as TCL_ERROR.
4747	*
4748	* Results:
4749	* If the result code is one of the standard Tcl return codes, the
4750	* result is a string representing that code such as "TCL_ERROR".
4751	* Otherwise, the result string is that code formatted as a
4752	* sequence of decimal digit characters. Note that the resulting
4753	* string must not be modified by the caller.
4754	*
4755	* Side effects:
4756	* None.
4757	*
4758	*----------------------------------------------------------------------
4759	*/
4760
4761	static char *
4762	StringForResultCode(result)
4763	int result; /* The Tcl result code for which to
4764	* generate a string. */
4765	{
4766	static char buf[20];
4767
4768	if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
4769	return resultStrings[result];
4770	}
4771	TclFormatInt(buf, result);
4772	return buf;
4773	}
4774	#endif /* TCL_COMPILE_DEBUG */

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: HiSusy/trunk/Delphes/Delphes-3.0.9/external/tcl/tclExecute.c @ 5

Download in other formats: