Fork me on GitHub

Context Navigation

source: git/external/tcl/tclExecute.c@ a0f5d71

Visit:

3.4.3pre03

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

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

Download in other formats: