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

sl@0	1	/*
sl@0	2	* tclExecute.c --
sl@0	3	*
sl@0	4	* This file contains procedures that execute byte-compiled Tcl
sl@0	5	* commands.
sl@0	6	*
sl@0	7	* Copyright (c) 1996-1997 Sun Microsystems, Inc.
sl@0	8	* Copyright (c) 1998-2000 by Scriptics Corporation.
sl@0	9	* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
sl@0	10	* Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
sl@0	11	*
sl@0	12	* See the file "license.terms" for information on usage and redistribution
sl@0	13	* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0	14	*
sl@0	15	* RCS: @(#) $Id: tclExecute.c,v 1.94.2.21 2007/03/13 16:26:32 dgp Exp $
sl@0	16	*/
sl@0	17
sl@0	18	#include "tclInt.h"
sl@0	19	#include "tclCompile.h"
sl@0	20	#include "tclMath.h"
sl@0	21
sl@0	22	/*
sl@0	23	* The stuff below is a bit of a hack so that this file can be used
sl@0	24	* in environments that include no UNIX, i.e. no errno. Just define
sl@0	25	* errno here.
sl@0	26	*/
sl@0	27
sl@0	28	#ifndef TCL_GENERIC_ONLY
sl@0	29	# include "tclPort.h"
sl@0	30	#else /* TCL_GENERIC_ONLY */
sl@0	31	# ifndef NO_FLOAT_H
sl@0	32	# include <float.h>
sl@0	33	# else /* NO_FLOAT_H */
sl@0	34	# ifndef NO_VALUES_H
sl@0	35	# include <values.h>
sl@0	36	# endif /* !NO_VALUES_H */
sl@0	37	# endif /* !NO_FLOAT_H */
sl@0	38	# define NO_ERRNO_H
sl@0	39	#endif /* !TCL_GENERIC_ONLY */
sl@0	40
sl@0	41	#ifdef NO_ERRNO_H
sl@0	42	int errno;
sl@0	43	# define EDOM 33
sl@0	44	# define ERANGE 34
sl@0	45	#endif
sl@0	46
sl@0	47	/*
sl@0	48	* Need DBL_MAX for IS_INF() macro...
sl@0	49	*/
sl@0	50	#ifndef DBL_MAX
sl@0	51	# ifdef MAXDOUBLE
sl@0	52	# define DBL_MAX MAXDOUBLE
sl@0	53	# else /* !MAXDOUBLE */
sl@0	54	/*
sl@0	55	* This value is from the Solaris headers, but doubles seem to be the
sl@0	56	* same size everywhere. Long doubles aren't, but we don't use those.
sl@0	57	*/
sl@0	58	# define DBL_MAX 1.79769313486231570e+308
sl@0	59	# endif /* MAXDOUBLE */
sl@0	60	#endif /* !DBL_MAX */
sl@0	61
sl@0	62	/*
sl@0	63	* Boolean flag indicating whether the Tcl bytecode interpreter has been
sl@0	64	* initialized.
sl@0	65	*/
sl@0	66
sl@0	67	static int execInitialized = 0;
sl@0	68	TCL_DECLARE_MUTEX(execMutex)
sl@0	69
sl@0	70	#ifdef TCL_COMPILE_DEBUG
sl@0	71	/*
sl@0	72	* Variable that controls whether execution tracing is enabled and, if so,
sl@0	73	* what level of tracing is desired:
sl@0	74	* 0: no execution tracing
sl@0	75	* 1: trace invocations of Tcl procs only
sl@0	76	* 2: trace invocations of all (not compiled away) commands
sl@0	77	* 3: display each instruction executed
sl@0	78	* This variable is linked to the Tcl variable "tcl_traceExec".
sl@0	79	*/
sl@0	80
sl@0	81	int tclTraceExec = 0;
sl@0	82	#endif
sl@0	83
sl@0	84	/*
sl@0	85	* Mapping from expression instruction opcodes to strings; used for error
sl@0	86	* messages. Note that these entries must match the order and number of the
sl@0	87	* expression opcodes (e.g., INST_LOR) in tclCompile.h.
sl@0	88	*/
sl@0	89
sl@0	90	static char *operatorStrings[] = {
sl@0	91	"\|\|", "&&", "\|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
sl@0	92	"+", "-", "*", "/", "%", "+", "-", "~", "!",
sl@0	93	"BUILTIN FUNCTION", "FUNCTION",
sl@0	94	"", "", "", "", "", "", "", "", "eq", "ne",
sl@0	95	};
sl@0	96
sl@0	97	/*
sl@0	98	* Mapping from Tcl result codes to strings; used for error and debugging
sl@0	99	* messages.
sl@0	100	*/
sl@0	101
sl@0	102	#ifdef TCL_COMPILE_DEBUG
sl@0	103	static char *resultStrings[] = {
sl@0	104	"TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
sl@0	105	};
sl@0	106	#endif
sl@0	107
sl@0	108	/*
sl@0	109	* These are used by evalstats to monitor object usage in Tcl.
sl@0	110	*/
sl@0	111
sl@0	112	#ifdef TCL_COMPILE_STATS
sl@0	113	long tclObjsAlloced = 0;
sl@0	114	long tclObjsFreed = 0;
sl@0	115	#define TCL_MAX_SHARED_OBJ_STATS 5
sl@0	116	long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
sl@0	117	#endif /* TCL_COMPILE_STATS */
sl@0	118
sl@0	119	/*
sl@0	120	* Macros for testing floating-point values for certain special cases. Test
sl@0	121	* for not-a-number by comparing a value against itself; test for infinity
sl@0	122	* by comparing against the largest floating-point value.
sl@0	123	*/
sl@0	124
sl@0	125	#define IS_NAN(v) ((v) != (v))
sl@0	126	#define IS_INF(v) (((v) > DBL_MAX) \|\| ((v) < -DBL_MAX))
sl@0	127
sl@0	128	/*
sl@0	129	* The new macro for ending an instruction; note that a
sl@0	130	* reasonable C-optimiser will resolve all branches
sl@0	131	* at compile time. (result) is always a constant; the macro
sl@0	132	* NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is
sl@0	133	* resolved at runtime for variable (nCleanup).
sl@0	134	*
sl@0	135	* ARGUMENTS:
sl@0	136	* pcAdjustment: how much to increment pc
sl@0	137	* nCleanup: how many objects to remove from the stack
sl@0	138	* result: 0 indicates no object should be pushed on the
sl@0	139	* stack; otherwise, push objResultPtr. If (result < 0),
sl@0	140	* objResultPtr already has the correct reference count.
sl@0	141	*/
sl@0	142
sl@0	143	#define NEXT_INST_F(pcAdjustment, nCleanup, result) \
sl@0	144	if (nCleanup == 0) {\
sl@0	145	if (result != 0) {\
sl@0	146	if ((result) > 0) {\
sl@0	147	PUSH_OBJECT(objResultPtr);\
sl@0	148	} else {\
sl@0	149	stackPtr[++stackTop] = objResultPtr;\
sl@0	150	}\
sl@0	151	} \
sl@0	152	pc += (pcAdjustment);\
sl@0	153	goto cleanup0;\
sl@0	154	} else if (result != 0) {\
sl@0	155	if ((result) > 0) {\
sl@0	156	Tcl_IncrRefCount(objResultPtr);\
sl@0	157	}\
sl@0	158	pc += (pcAdjustment);\
sl@0	159	switch (nCleanup) {\
sl@0	160	case 1: goto cleanup1_pushObjResultPtr;\
sl@0	161	case 2: goto cleanup2_pushObjResultPtr;\
sl@0	162	default: panic("ERROR: bad usage of macro NEXT_INST_F");\
sl@0	163	}\
sl@0	164	} else {\
sl@0	165	pc += (pcAdjustment);\
sl@0	166	switch (nCleanup) {\
sl@0	167	case 1: goto cleanup1;\
sl@0	168	case 2: goto cleanup2;\
sl@0	169	default: panic("ERROR: bad usage of macro NEXT_INST_F");\
sl@0	170	}\
sl@0	171	}
sl@0	172
sl@0	173	#define NEXT_INST_V(pcAdjustment, nCleanup, result) \
sl@0	174	pc += (pcAdjustment);\
sl@0	175	cleanup = (nCleanup);\
sl@0	176	if (result) {\
sl@0	177	if ((result) > 0) {\
sl@0	178	Tcl_IncrRefCount(objResultPtr);\
sl@0	179	}\
sl@0	180	goto cleanupV_pushObjResultPtr;\
sl@0	181	} else {\
sl@0	182	goto cleanupV;\
sl@0	183	}
sl@0	184
sl@0	185
sl@0	186	/*
sl@0	187	* Macros used to cache often-referenced Tcl evaluation stack information
sl@0	188	* in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
sl@0	189	* pair must surround any call inside TclExecuteByteCode (and a few other
sl@0	190	* procedures that use this scheme) that could result in a recursive call
sl@0	191	* to TclExecuteByteCode.
sl@0	192	*/
sl@0	193
sl@0	194	#define CACHE_STACK_INFO() \
sl@0	195	stackPtr = eePtr->stackPtr; \
sl@0	196	stackTop = eePtr->stackTop
sl@0	197
sl@0	198	#define DECACHE_STACK_INFO() \
sl@0	199	eePtr->stackTop = stackTop
sl@0	200
sl@0	201
sl@0	202	/*
sl@0	203	* Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
sl@0	204	* increments the object's ref count since it makes the stack have another
sl@0	205	* reference pointing to the object. However, POP_OBJECT does not decrement
sl@0	206	* the ref count. This is because the stack may hold the only reference to
sl@0	207	* the object, so the object would be destroyed if its ref count were
sl@0	208	* decremented before the caller had a chance to, e.g., store it in a
sl@0	209	* variable. It is the caller's responsibility to decrement the ref count
sl@0	210	* when it is finished with an object.
sl@0	211	*
sl@0	212	* WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT
sl@0	213	* macro. The actual parameter might be an expression with side effects,
sl@0	214	* and this ensures that it will be executed only once.
sl@0	215	*/
sl@0	216
sl@0	217	#define PUSH_OBJECT(objPtr) \
sl@0	218	Tcl_IncrRefCount(stackPtr[++stackTop] = (objPtr))
sl@0	219
sl@0	220	#define POP_OBJECT() \
sl@0	221	(stackPtr[stackTop--])
sl@0	222
sl@0	223	/*
sl@0	224	* Macros used to trace instruction execution. The macros TRACE,
sl@0	225	* TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode.
sl@0	226	* O2S is only used in TRACE* calls to get a string from an object.
sl@0	227	*/
sl@0	228
sl@0	229	#ifdef TCL_COMPILE_DEBUG
sl@0	230	# define TRACE(a) \
sl@0	231	if (traceInstructions) { \
sl@0	232	fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
sl@0	233	(unsigned int)(pc - codePtr->codeStart), \
sl@0	234	GetOpcodeName(pc)); \
sl@0	235	printf a; \
sl@0	236	}
sl@0	237	# define TRACE_APPEND(a) \
sl@0	238	if (traceInstructions) { \
sl@0	239	printf a; \
sl@0	240	}
sl@0	241	# define TRACE_WITH_OBJ(a, objPtr) \
sl@0	242	if (traceInstructions) { \
sl@0	243	fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
sl@0	244	(unsigned int)(pc - codePtr->codeStart), \
sl@0	245	GetOpcodeName(pc)); \
sl@0	246	printf a; \
sl@0	247	TclPrintObject(stdout, objPtr, 30); \
sl@0	248	fprintf(stdout, "\n"); \
sl@0	249	}
sl@0	250	# define O2S(objPtr) \
sl@0	251	(objPtr ? TclGetString(objPtr) : "")
sl@0	252	#else /* !TCL_COMPILE_DEBUG */
sl@0	253	# define TRACE(a)
sl@0	254	# define TRACE_APPEND(a)
sl@0	255	# define TRACE_WITH_OBJ(a, objPtr)
sl@0	256	# define O2S(objPtr)
sl@0	257	#endif /* TCL_COMPILE_DEBUG */
sl@0	258
sl@0	259	/*
sl@0	260	* Macro to read a string containing either a wide or an int and
sl@0	261	* decide which it is while decoding it at the same time. This
sl@0	262	* enforces the policy that integer constants between LONG_MIN and
sl@0	263	* LONG_MAX (inclusive) are represented by normal longs, and integer
sl@0	264	* constants outside that range are represented by wide ints.
sl@0	265	*
sl@0	266	* GET_WIDE_OR_INT is the same as REQUIRE_WIDE_OR_INT except it never
sl@0	267	* generates an error message.
sl@0	268	*/
sl@0	269	#define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \
sl@0	270	(resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar)); \
sl@0	271	if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \
sl@0	272	&& (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \
sl@0	273	(objPtr)->typePtr = &tclIntType; \
sl@0	274	(objPtr)->internalRep.longValue = (longVar) \
sl@0	275	= Tcl_WideAsLong(wideVar); \
sl@0	276	}
sl@0	277	#define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \
sl@0	278	(resultVar) = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, (objPtr), \
sl@0	279	&(wideVar)); \
sl@0	280	if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \
sl@0	281	&& (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \
sl@0	282	(objPtr)->typePtr = &tclIntType; \
sl@0	283	(objPtr)->internalRep.longValue = (longVar) \
sl@0	284	= Tcl_WideAsLong(wideVar); \
sl@0	285	}
sl@0	286	/*
sl@0	287	* Combined with REQUIRE_WIDE_OR_INT, this gets a long value from
sl@0	288	* an obj.
sl@0	289	*/
sl@0	290	#define FORCE_LONG(objPtr, longVar, wideVar) \
sl@0	291	if ((objPtr)->typePtr == &tclWideIntType) { \
sl@0	292	(longVar) = Tcl_WideAsLong(wideVar); \
sl@0	293	}
sl@0	294	#define IS_INTEGER_TYPE(typePtr) \
sl@0	295	((typePtr) == &tclIntType \|\| (typePtr) == &tclWideIntType)
sl@0	296	#define IS_NUMERIC_TYPE(typePtr) \
sl@0	297	(IS_INTEGER_TYPE(typePtr) \|\| (typePtr) == &tclDoubleType)
sl@0	298
sl@0	299	#define W0 Tcl_LongAsWide(0)
sl@0	300	/*
sl@0	301	* For tracing that uses wide values.
sl@0	302	*/
sl@0	303	#define LLD "%" TCL_LL_MODIFIER "d"
sl@0	304
sl@0	305	#ifndef TCL_WIDE_INT_IS_LONG
sl@0	306	/*
sl@0	307	* Extract a double value from a general numeric object.
sl@0	308	*/
sl@0	309	#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \
sl@0	310	if ((typePtr) == &tclIntType) { \
sl@0	311	(doubleVar) = (double) (objPtr)->internalRep.longValue; \
sl@0	312	} else if ((typePtr) == &tclWideIntType) { \
sl@0	313	(doubleVar) = Tcl_WideAsDouble((objPtr)->internalRep.wideValue);\
sl@0	314	} else { \
sl@0	315	(doubleVar) = (objPtr)->internalRep.doubleValue; \
sl@0	316	}
sl@0	317	#else /* TCL_WIDE_INT_IS_LONG */
sl@0	318	#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \
sl@0	319	if (((typePtr) == &tclIntType) \|\| ((typePtr) == &tclWideIntType)) { \
sl@0	320	(doubleVar) = (double) (objPtr)->internalRep.longValue; \
sl@0	321	} else { \
sl@0	322	(doubleVar) = (objPtr)->internalRep.doubleValue; \
sl@0	323	}
sl@0	324	#endif /* TCL_WIDE_INT_IS_LONG */
sl@0	325
sl@0	326	/*
sl@0	327	* Declarations for local procedures to this file:
sl@0	328	*/
sl@0	329
sl@0	330	static int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	331	ByteCode *codePtr));
sl@0	332	static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	333	ExecEnv *eePtr, ClientData clientData));
sl@0	334	static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	335	ExecEnv *eePtr, ClientData clientData));
sl@0	336	static int ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	337	ExecEnv eePtr, int objc, Tcl_Obj *objv));
sl@0	338	static int ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	339	ExecEnv *eePtr, ClientData clientData));
sl@0	340	static int ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	341	ExecEnv *eePtr, ClientData clientData));
sl@0	342	static int ExprRandFunc _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	343	ExecEnv *eePtr, ClientData clientData));
sl@0	344	static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	345	ExecEnv *eePtr, ClientData clientData));
sl@0	346	static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	347	ExecEnv *eePtr, ClientData clientData));
sl@0	348	static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	349	ExecEnv *eePtr, ClientData clientData));
sl@0	350	static int ExprWideFunc _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	351	ExecEnv *eePtr, ClientData clientData));
sl@0	352	#ifdef TCL_COMPILE_STATS
sl@0	353	static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
sl@0	354	Tcl_Interp *interp, int objc,
sl@0	355	Tcl_Obj *CONST objv[]));
sl@0	356	#endif /* TCL_COMPILE_STATS */
sl@0	357	#ifdef TCL_COMPILE_DEBUG
sl@0	358	static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc));
sl@0	359	#endif /* TCL_COMPILE_DEBUG */
sl@0	360	static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc,
sl@0	361	int catchOnly, ByteCode* codePtr));
sl@0	362	static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
sl@0	363	ByteCode* codePtr, int *lengthPtr));
sl@0	364	static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr));
sl@0	365	static void IllegalExprOperandType _ANSI_ARGS_((
sl@0	366	Tcl_Interp interp, unsigned char pc,
sl@0	367	Tcl_Obj *opndPtr));
sl@0	368	static void InitByteCodeExecution _ANSI_ARGS_((
sl@0	369	Tcl_Interp *interp));
sl@0	370	#ifdef TCL_COMPILE_DEBUG
sl@0	371	static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
sl@0	372	static char * StringForResultCode _ANSI_ARGS_((int result));
sl@0	373	static void ValidatePcAndStackTop _ANSI_ARGS_((
sl@0	374	ByteCode codePtr, unsigned char pc,
sl@0	375	int stackTop, int stackLowerBound));
sl@0	376	#endif /* TCL_COMPILE_DEBUG */
sl@0	377	static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	378	Tcl_Obj *objPtr));
sl@0	379
sl@0	380	/*
sl@0	381	========== Begin of math function wrappers =============
sl@0	382	The math function wrappers bellow are need to avoid the "Import relocation does not refer to code segment" error
sl@0	383	message reported from ELF2E32 tool.
sl@0	384	*/
sl@0	385
sl@0	386	static double Tcl_acos(double x)
sl@0	387	{
sl@0	388	return acos(x);
sl@0	389	}
sl@0	390
sl@0	391	static double Tcl_asin(double x)
sl@0	392	{
sl@0	393	return asin(x);
sl@0	394	}
sl@0	395
sl@0	396	static double Tcl_atan(double x)
sl@0	397	{
sl@0	398	return atan(x);
sl@0	399	}
sl@0	400
sl@0	401	static double Tcl_atan2(double x, double y)
sl@0	402	{
sl@0	403	return atan2(x, y);
sl@0	404	}
sl@0	405
sl@0	406	static double Tcl_ceil(double num)
sl@0	407	{
sl@0	408	return ceil(num);
sl@0	409	}
sl@0	410
sl@0	411	static double Tcl_cos(double x)
sl@0	412	{
sl@0	413	return cos(x);
sl@0	414	}
sl@0	415
sl@0	416	static double Tcl_cosh(double x)
sl@0	417	{
sl@0	418	return cosh(x);
sl@0	419	}
sl@0	420
sl@0	421	static double Tcl_exp(double x)
sl@0	422	{
sl@0	423	return exp(x);
sl@0	424	}
sl@0	425
sl@0	426	static double Tcl_floor(double x)
sl@0	427	{
sl@0	428	return floor(x);
sl@0	429	}
sl@0	430
sl@0	431	static double Tcl_fmod(double numerator, double denominator)
sl@0	432	{
sl@0	433	return fmod(numerator, denominator);
sl@0	434	}
sl@0	435
sl@0	436	static double Tcl_hypot(double x, double y)
sl@0	437	{
sl@0	438	return hypot(x, y);
sl@0	439	}
sl@0	440
sl@0	441	static double Tcl_log(double x)
sl@0	442	{
sl@0	443	return log(x);
sl@0	444	}
sl@0	445
sl@0	446	static double Tcl_log10(double x)
sl@0	447	{
sl@0	448	return log10(x);
sl@0	449	}
sl@0	450
sl@0	451	static double Tcl_pow(double base, double exponent)
sl@0	452	{
sl@0	453	return pow(base, exponent);
sl@0	454	}
sl@0	455
sl@0	456	static double Tcl_sin(double x)
sl@0	457	{
sl@0	458	return sin(x);
sl@0	459	}
sl@0	460
sl@0	461	static double Tcl_sinh(double x)
sl@0	462	{
sl@0	463	return sinh(x);
sl@0	464	}
sl@0	465
sl@0	466	static double Tcl_sqrt(double x)
sl@0	467	{
sl@0	468	return sqrt(x);
sl@0	469	}
sl@0	470
sl@0	471	static double Tcl_tan(double x)
sl@0	472	{
sl@0	473	return tan(x);
sl@0	474	}
sl@0	475
sl@0	476	static double Tcl_tanh(double x)
sl@0	477	{
sl@0	478	return tanh(x);
sl@0	479	}
sl@0	480
sl@0	481	/*
sl@0	482	========== End of math function wrappers ===============
sl@0	483	*/
sl@0	484
sl@0	485	/*
sl@0	486	* Table describing the built-in math functions. Entries in this table are
sl@0	487	* indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
sl@0	488	* operand byte.
sl@0	489	*/
sl@0	490
sl@0	491	BuiltinFunc tclBuiltinFuncTable[] = {
sl@0	492	#ifndef TCL_NO_MATH
sl@0	493	{"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_acos},
sl@0	494	{"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_asin},
sl@0	495	{"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_atan},
sl@0	496	{"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) Tcl_atan2},
sl@0	497	{"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_ceil},
sl@0	498	{"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_cos},
sl@0	499	{"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_cosh},
sl@0	500	{"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_exp},
sl@0	501	{"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_floor},
sl@0	502	{"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) Tcl_fmod},
sl@0	503	{"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) Tcl_hypot},
sl@0	504	{"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_log},
sl@0	505	{"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_log10},
sl@0	506	{"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) Tcl_pow},
sl@0	507	{"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_sin},
sl@0	508	{"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_sinh},
sl@0	509	{"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_sqrt},
sl@0	510	{"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_tan},
sl@0	511	{"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_tanh},
sl@0	512	#endif
sl@0	513	{"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
sl@0	514	{"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
sl@0	515	{"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
sl@0	516	{"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */
sl@0	517	{"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
sl@0	518	{"srand", 1, {TCL_INT}, ExprSrandFunc, 0},
sl@0	519	{"wide", 1, {TCL_EITHER}, ExprWideFunc, 0},
sl@0	520	{0},
sl@0	521	};
sl@0	522
sl@0	523	/*
sl@0	524	*----------------------------------------------------------------------
sl@0	525	*
sl@0	526	* InitByteCodeExecution --
sl@0	527	*
sl@0	528	* This procedure is called once to initialize the Tcl bytecode
sl@0	529	* interpreter.
sl@0	530	*
sl@0	531	* Results:
sl@0	532	* None.
sl@0	533	*
sl@0	534	* Side effects:
sl@0	535	* This procedure initializes the array of instruction names. If
sl@0	536	* compiling with the TCL_COMPILE_STATS flag, it initializes the
sl@0	537	* array that counts the executions of each instruction and it
sl@0	538	* creates the "evalstats" command. It also establishes the link
sl@0	539	* between the Tcl "tcl_traceExec" and C "tclTraceExec" variables.
sl@0	540	*
sl@0	541	*----------------------------------------------------------------------
sl@0	542	*/
sl@0	543
sl@0	544	static void
sl@0	545	InitByteCodeExecution(interp)
sl@0	546	Tcl_Interp interp; / Interpreter for which the Tcl variable
sl@0	547	* "tcl_traceExec" is linked to control
sl@0	548	* instruction tracing. */
sl@0	549	{
sl@0	550	#ifdef TCL_COMPILE_DEBUG
sl@0	551	if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
sl@0	552	TCL_LINK_INT) != TCL_OK) {
sl@0	553	panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
sl@0	554	}
sl@0	555	#endif
sl@0	556	#ifdef TCL_COMPILE_STATS
sl@0	557	Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd,
sl@0	558	(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
sl@0	559	#endif /* TCL_COMPILE_STATS */
sl@0	560	}
sl@0	561
sl@0	562	/*
sl@0	563	*----------------------------------------------------------------------
sl@0	564	*
sl@0	565	* TclCreateExecEnv --
sl@0	566	*
sl@0	567	* This procedure creates a new execution environment for Tcl bytecode
sl@0	568	* execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv
sl@0	569	* is typically created once for each Tcl interpreter (Interp
sl@0	570	* structure) and recursively passed to TclExecuteByteCode to execute
sl@0	571	* ByteCode sequences for nested commands.
sl@0	572	*
sl@0	573	* Results:
sl@0	574	* A newly allocated ExecEnv is returned. This points to an empty
sl@0	575	* evaluation stack of the standard initial size.
sl@0	576	*
sl@0	577	* Side effects:
sl@0	578	* The bytecode interpreter is also initialized here, as this
sl@0	579	* procedure will be called before any call to TclExecuteByteCode.
sl@0	580	*
sl@0	581	*----------------------------------------------------------------------
sl@0	582	*/
sl@0	583
sl@0	584	#define TCL_STACK_INITIAL_SIZE 2000
sl@0	585
sl@0	586	ExecEnv *
sl@0	587	TclCreateExecEnv(interp)
sl@0	588	Tcl_Interp interp; / Interpreter for which the execution
sl@0	589	* environment is being created. */
sl@0	590	{
sl@0	591	ExecEnv eePtr = (ExecEnv ) ckalloc(sizeof(ExecEnv));
sl@0	592	Tcl_Obj **stackPtr;
sl@0	593
sl@0	594	stackPtr = (Tcl_Obj **)
sl@0	595	ckalloc((size_t) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));
sl@0	596
sl@0	597	/*
sl@0	598	* Use the bottom pointer to keep a reference count; the
sl@0	599	* execution environment holds a reference.
sl@0	600	*/
sl@0	601
sl@0	602	stackPtr++;
sl@0	603	eePtr->stackPtr = stackPtr;
sl@0	604	stackPtr[-1] = (Tcl_Obj ) ((char ) 1);
sl@0	605
sl@0	606	eePtr->stackTop = -1;
sl@0	607	eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 2);
sl@0	608
sl@0	609	eePtr->errorInfo = Tcl_NewStringObj("::errorInfo", -1);
sl@0	610	Tcl_IncrRefCount(eePtr->errorInfo);
sl@0	611
sl@0	612	eePtr->errorCode = Tcl_NewStringObj("::errorCode", -1);
sl@0	613	Tcl_IncrRefCount(eePtr->errorCode);
sl@0	614
sl@0	615	Tcl_MutexLock(&execMutex);
sl@0	616	if (!execInitialized) {
sl@0	617	TclInitAuxDataTypeTable();
sl@0	618	InitByteCodeExecution(interp);
sl@0	619	execInitialized = 1;
sl@0	620	}
sl@0	621	Tcl_MutexUnlock(&execMutex);
sl@0	622
sl@0	623	return eePtr;
sl@0	624	}
sl@0	625	#undef TCL_STACK_INITIAL_SIZE
sl@0	626
sl@0	627	/*
sl@0	628	*----------------------------------------------------------------------
sl@0	629	*
sl@0	630	* TclDeleteExecEnv --
sl@0	631	*
sl@0	632	* Frees the storage for an ExecEnv.
sl@0	633	*
sl@0	634	* Results:
sl@0	635	* None.
sl@0	636	*
sl@0	637	* Side effects:
sl@0	638	* Storage for an ExecEnv and its contained storage (e.g. the
sl@0	639	* evaluation stack) is freed.
sl@0	640	*
sl@0	641	*----------------------------------------------------------------------
sl@0	642	*/
sl@0	643
sl@0	644	void
sl@0	645	TclDeleteExecEnv(eePtr)
sl@0	646	ExecEnv eePtr; / Execution environment to free. */
sl@0	647	{
sl@0	648	if (eePtr->stackPtr[-1] == (Tcl_Obj ) ((char ) 1)) {
sl@0	649	ckfree((char *) (eePtr->stackPtr-1));
sl@0	650	} else {
sl@0	651	panic("ERROR: freeing an execEnv whose stack is still in use.\n");
sl@0	652	}
sl@0	653	TclDecrRefCount(eePtr->errorInfo);
sl@0	654	TclDecrRefCount(eePtr->errorCode);
sl@0	655	ckfree((char *) eePtr);
sl@0	656	}
sl@0	657
sl@0	658	/*
sl@0	659	*----------------------------------------------------------------------
sl@0	660	*
sl@0	661	* TclFinalizeExecution --
sl@0	662	*
sl@0	663	* Finalizes the execution environment setup so that it can be
sl@0	664	* later reinitialized.
sl@0	665	*
sl@0	666	* Results:
sl@0	667	* None.
sl@0	668	*
sl@0	669	* Side effects:
sl@0	670	* After this call, the next time TclCreateExecEnv will be called
sl@0	671	* it will call InitByteCodeExecution.
sl@0	672	*
sl@0	673	*----------------------------------------------------------------------
sl@0	674	*/
sl@0	675
sl@0	676	void
sl@0	677	TclFinalizeExecution()
sl@0	678	{
sl@0	679	Tcl_MutexLock(&execMutex);
sl@0	680	execInitialized = 0;
sl@0	681	Tcl_MutexUnlock(&execMutex);
sl@0	682	TclFinalizeAuxDataTypeTable();
sl@0	683	}
sl@0	684
sl@0	685	/*
sl@0	686	*----------------------------------------------------------------------
sl@0	687	*
sl@0	688	* GrowEvaluationStack --
sl@0	689	*
sl@0	690	* This procedure grows a Tcl evaluation stack stored in an ExecEnv.
sl@0	691	*
sl@0	692	* Results:
sl@0	693	* None.
sl@0	694	*
sl@0	695	* Side effects:
sl@0	696	* The size of the evaluation stack is doubled.
sl@0	697	*
sl@0	698	*----------------------------------------------------------------------
sl@0	699	*/
sl@0	700
sl@0	701	static void
sl@0	702	GrowEvaluationStack(eePtr)
sl@0	703	register ExecEnv eePtr; / Points to the ExecEnv with an evaluation
sl@0	704	* stack to enlarge. */
sl@0	705	{
sl@0	706	/*
sl@0	707	* The current Tcl stack elements are stored from eePtr->stackPtr[0]
sl@0	708	* to eePtr->stackPtr[eePtr->stackEnd] (inclusive).
sl@0	709	*/
sl@0	710
sl@0	711	int currElems = (eePtr->stackEnd + 1);
sl@0	712	int newElems = 2*currElems;
sl@0	713	int currBytes = currElems * sizeof(Tcl_Obj *);
sl@0	714	int newBytes = 2*currBytes;
sl@0	715	Tcl_Obj newStackPtr = (Tcl_Obj ) ckalloc((unsigned) newBytes);
sl@0	716	Tcl_Obj **oldStackPtr = eePtr->stackPtr;
sl@0	717
sl@0	718	/*
sl@0	719	* We keep the stack reference count as a (char *), as that
sl@0	720	* works nicely as a portable pointer-sized counter.
sl@0	721	*/
sl@0	722
sl@0	723	char refCount = (char ) oldStackPtr[-1];
sl@0	724
sl@0	725	/*
sl@0	726	* Copy the existing stack items to the new stack space, free the old
sl@0	727	* storage if appropriate, and record the refCount of the new stack
sl@0	728	* held by the environment.
sl@0	729	*/
sl@0	730
sl@0	731	newStackPtr++;
sl@0	732	memcpy((VOID ) newStackPtr, (VOID ) oldStackPtr,
sl@0	733	(size_t) currBytes);
sl@0	734
sl@0	735	if (refCount == (char *) 1) {
sl@0	736	ckfree((VOID *) (oldStackPtr-1));
sl@0	737	} else {
sl@0	738	/*
sl@0	739	* Remove the reference corresponding to the
sl@0	740	* environment pointer.
sl@0	741	*/
sl@0	742
sl@0	743	oldStackPtr[-1] = (Tcl_Obj *) (refCount-1);
sl@0	744	}
sl@0	745
sl@0	746	eePtr->stackPtr = newStackPtr;
sl@0	747	eePtr->stackEnd = (newElems - 2); /* index of last usable item */
sl@0	748	newStackPtr[-1] = (Tcl_Obj ) ((char ) 1);
sl@0	749	}
sl@0	750
sl@0	751	/*
sl@0	752	*--------------------------------------------------------------
sl@0	753	*
sl@0	754	* Tcl_ExprObj --
sl@0	755	*
sl@0	756	* Evaluate an expression in a Tcl_Obj.
sl@0	757	*
sl@0	758	* Results:
sl@0	759	* A standard Tcl object result. If the result is other than TCL_OK,
sl@0	760	* then the interpreter's result contains an error message. If the
sl@0	761	* result is TCL_OK, then a pointer to the expression's result value
sl@0	762	* object is stored in resultPtrPtr. In that case, the object's ref
sl@0	763	* count is incremented to reflect the reference returned to the
sl@0	764	* caller; the caller is then responsible for the resulting object
sl@0	765	* and must, for example, decrement the ref count when it is finished
sl@0	766	* with the object.
sl@0	767	*
sl@0	768	* Side effects:
sl@0	769	* Any side effects caused by subcommands in the expression, if any.
sl@0	770	* The interpreter result is not modified unless there is an error.
sl@0	771	*
sl@0	772	*--------------------------------------------------------------
sl@0	773	*/
sl@0	774
sl@0	775	EXPORT_C int
sl@0	776	Tcl_ExprObj(interp, objPtr, resultPtrPtr)
sl@0	777	Tcl_Interp interp; / Context in which to evaluate the
sl@0	778	* expression. */
sl@0	779	register Tcl_Obj objPtr; / Points to Tcl object containing
sl@0	780	* expression to evaluate. */
sl@0	781	Tcl_Obj *resultPtrPtr; / Where the Tcl_Obj* that is the expression
sl@0	782	* result is stored if no errors occur. */
sl@0	783	{
sl@0	784	Interp iPtr = (Interp ) interp;
sl@0	785	CompileEnv compEnv; /* Compilation environment structure
sl@0	786	* allocated in frame. */
sl@0	787	LiteralTable *localTablePtr = &(compEnv.localLitTable);
sl@0	788	register ByteCode *codePtr = NULL;
sl@0	789	/* Tcl Internal type of bytecode.
sl@0	790	* Initialized to avoid compiler warning. */
sl@0	791	AuxData *auxDataPtr;
sl@0	792	LiteralEntry *entryPtr;
sl@0	793	Tcl_Obj *saveObjPtr;
sl@0	794	char *string;
sl@0	795	int length, i, result;
sl@0	796
sl@0	797	/*
sl@0	798	* First handle some common expressions specially.
sl@0	799	*/
sl@0	800
sl@0	801	string = Tcl_GetStringFromObj(objPtr, &length);
sl@0	802	if (length == 1) {
sl@0	803	if (*string == '0') {
sl@0	804	*resultPtrPtr = Tcl_NewLongObj(0);
sl@0	805	Tcl_IncrRefCount(*resultPtrPtr);
sl@0	806	return TCL_OK;
sl@0	807	} else if (*string == '1') {
sl@0	808	*resultPtrPtr = Tcl_NewLongObj(1);
sl@0	809	Tcl_IncrRefCount(*resultPtrPtr);
sl@0	810	return TCL_OK;
sl@0	811	}
sl@0	812	} else if ((length == 2) && (*string == '!')) {
sl@0	813	if (*(string+1) == '0') {
sl@0	814	*resultPtrPtr = Tcl_NewLongObj(1);
sl@0	815	Tcl_IncrRefCount(*resultPtrPtr);
sl@0	816	return TCL_OK;
sl@0	817	} else if (*(string+1) == '1') {
sl@0	818	*resultPtrPtr = Tcl_NewLongObj(0);
sl@0	819	Tcl_IncrRefCount(*resultPtrPtr);
sl@0	820	return TCL_OK;
sl@0	821	}
sl@0	822	}
sl@0	823
sl@0	824	/*
sl@0	825	* Get the ByteCode from the object. If it exists, make sure it hasn't
sl@0	826	* been invalidated by, e.g., someone redefining a command with a
sl@0	827	* compile procedure (this might make the compiled code wrong). If
sl@0	828	* necessary, convert the object to be a ByteCode object and compile it.
sl@0	829	* Also, if the code was compiled in/for a different interpreter, we
sl@0	830	* recompile it.
sl@0	831	*
sl@0	832	* Precompiled expressions, however, are immutable and therefore
sl@0	833	* they are not recompiled, even if the epoch has changed.
sl@0	834	*
sl@0	835	*/
sl@0	836
sl@0	837	if (objPtr->typePtr == &tclByteCodeType) {
sl@0	838	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
sl@0	839	if (((Interp ) codePtr->interpHandle != iPtr)
sl@0	840	\|\| (codePtr->compileEpoch != iPtr->compileEpoch)) {
sl@0	841	if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
sl@0	842	if ((Interp ) codePtr->interpHandle != iPtr) {
sl@0	843	panic("Tcl_ExprObj: compiled expression jumped interps");
sl@0	844	}
sl@0	845	codePtr->compileEpoch = iPtr->compileEpoch;
sl@0	846	} else {
sl@0	847	(*tclByteCodeType.freeIntRepProc)(objPtr);
sl@0	848	objPtr->typePtr = (Tcl_ObjType *) NULL;
sl@0	849	}
sl@0	850	}
sl@0	851	}
sl@0	852	if (objPtr->typePtr != &tclByteCodeType) {
sl@0	853	#ifndef TCL_TIP280
sl@0	854	TclInitCompileEnv(interp, &compEnv, string, length);
sl@0	855	#else
sl@0	856	/* TIP #280 : No invoker (yet) - Expression compilation */
sl@0	857	TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
sl@0	858	#endif
sl@0	859	result = TclCompileExpr(interp, string, length, &compEnv);
sl@0	860
sl@0	861	/*
sl@0	862	* Free the compilation environment's literal table bucket array if
sl@0	863	* it was dynamically allocated.
sl@0	864	*/
sl@0	865
sl@0	866	if (localTablePtr->buckets != localTablePtr->staticBuckets) {
sl@0	867	ckfree((char *) localTablePtr->buckets);
sl@0	868	}
sl@0	869
sl@0	870	if (result != TCL_OK) {
sl@0	871	/*
sl@0	872	* Compilation errors. Free storage allocated for compilation.
sl@0	873	*/
sl@0	874
sl@0	875	#ifdef TCL_COMPILE_DEBUG
sl@0	876	TclVerifyLocalLiteralTable(&compEnv);
sl@0	877	#endif /TCL_COMPILE_DEBUG/
sl@0	878	entryPtr = compEnv.literalArrayPtr;
sl@0	879	for (i = 0; i < compEnv.literalArrayNext; i++) {
sl@0	880	TclReleaseLiteral(interp, entryPtr->objPtr);
sl@0	881	entryPtr++;
sl@0	882	}
sl@0	883	#ifdef TCL_COMPILE_DEBUG
sl@0	884	TclVerifyGlobalLiteralTable(iPtr);
sl@0	885	#endif /TCL_COMPILE_DEBUG/
sl@0	886
sl@0	887	auxDataPtr = compEnv.auxDataArrayPtr;
sl@0	888	for (i = 0; i < compEnv.auxDataArrayNext; i++) {
sl@0	889	if (auxDataPtr->type->freeProc != NULL) {
sl@0	890	auxDataPtr->type->freeProc(auxDataPtr->clientData);
sl@0	891	}
sl@0	892	auxDataPtr++;
sl@0	893	}
sl@0	894	TclFreeCompileEnv(&compEnv);
sl@0	895	return result;
sl@0	896	}
sl@0	897
sl@0	898	/*
sl@0	899	* Successful compilation. If the expression yielded no
sl@0	900	* instructions, push an zero object as the expression's result.
sl@0	901	*/
sl@0	902
sl@0	903	if (compEnv.codeNext == compEnv.codeStart) {
sl@0	904	TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /onHeap/ 0),
sl@0	905	&compEnv);
sl@0	906	}
sl@0	907
sl@0	908	/*
sl@0	909	* Add a "done" instruction as the last instruction and change the
sl@0	910	* object into a ByteCode object. Ownership of the literal objects
sl@0	911	* and aux data items is given to the ByteCode object.
sl@0	912	*/
sl@0	913
sl@0	914	compEnv.numSrcBytes = iPtr->termOffset;
sl@0	915	TclEmitOpcode(INST_DONE, &compEnv);
sl@0	916	TclInitByteCodeObj(objPtr, &compEnv);
sl@0	917	TclFreeCompileEnv(&compEnv);
sl@0	918	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
sl@0	919	#ifdef TCL_COMPILE_DEBUG
sl@0	920	if (tclTraceCompile == 2) {
sl@0	921	TclPrintByteCodeObj(interp, objPtr);
sl@0	922	}
sl@0	923	#endif /* TCL_COMPILE_DEBUG */
sl@0	924	}
sl@0	925
sl@0	926	/*
sl@0	927	* Execute the expression after first saving the interpreter's result.
sl@0	928	*/
sl@0	929
sl@0	930	saveObjPtr = Tcl_GetObjResult(interp);
sl@0	931	Tcl_IncrRefCount(saveObjPtr);
sl@0	932	Tcl_ResetResult(interp);
sl@0	933
sl@0	934	/*
sl@0	935	* Increment the code's ref count while it is being executed. If
sl@0	936	* afterwards no references to it remain, free the code.
sl@0	937	*/
sl@0	938
sl@0	939	codePtr->refCount++;
sl@0	940	result = TclExecuteByteCode(interp, codePtr);
sl@0	941	codePtr->refCount--;
sl@0	942	if (codePtr->refCount <= 0) {
sl@0	943	TclCleanupByteCode(codePtr);
sl@0	944	objPtr->typePtr = NULL;
sl@0	945	objPtr->internalRep.otherValuePtr = NULL;
sl@0	946	}
sl@0	947
sl@0	948	/*
sl@0	949	* If the expression evaluated successfully, store a pointer to its
sl@0	950	* value object in resultPtrPtr then restore the old interpreter result.
sl@0	951	* We increment the object's ref count to reflect the reference that we
sl@0	952	* are returning to the caller. We also decrement the ref count of the
sl@0	953	* interpreter's result object after calling Tcl_SetResult since we
sl@0	954	* next store into that field directly.
sl@0	955	*/
sl@0	956
sl@0	957	if (result == TCL_OK) {
sl@0	958	*resultPtrPtr = iPtr->objResultPtr;
sl@0	959	Tcl_IncrRefCount(iPtr->objResultPtr);
sl@0	960
sl@0	961	Tcl_SetObjResult(interp, saveObjPtr);
sl@0	962	}
sl@0	963	TclDecrRefCount(saveObjPtr);
sl@0	964	return result;
sl@0	965	}
sl@0	966
sl@0	967	/*
sl@0	968	*----------------------------------------------------------------------
sl@0	969	*
sl@0	970	* TclCompEvalObj --
sl@0	971	*
sl@0	972	* This procedure evaluates the script contained in a Tcl_Obj by
sl@0	973	* first compiling it and then passing it to TclExecuteByteCode.
sl@0	974	*
sl@0	975	* Results:
sl@0	976	* The return value is one of the return codes defined in tcl.h
sl@0	977	* (such as TCL_OK), and interp->objResultPtr refers to a Tcl object
sl@0	978	* that either contains the result of executing the code or an
sl@0	979	* error message.
sl@0	980	*
sl@0	981	* Side effects:
sl@0	982	* Almost certainly, depending on the ByteCode's instructions.
sl@0	983	*
sl@0	984	*----------------------------------------------------------------------
sl@0	985	*/
sl@0	986
sl@0	987	int
sl@0	988	#ifndef TCL_TIP280
sl@0	989	TclCompEvalObj(interp, objPtr)
sl@0	990	#else
sl@0	991	TclCompEvalObj(interp, objPtr, invoker, word)
sl@0	992	#endif
sl@0	993	Tcl_Interp *interp;
sl@0	994	Tcl_Obj *objPtr;
sl@0	995	#ifdef TCL_TIP280
sl@0	996	CONST CmdFrame* invoker; /* Frame of the command doing the eval */
sl@0	997	int word; /* Index of the word which is in objPtr */
sl@0	998	#endif
sl@0	999	{
sl@0	1000	register Interp iPtr = (Interp ) interp;
sl@0	1001	register ByteCode* codePtr; /* Tcl Internal type of bytecode. */
sl@0	1002	int oldCount = iPtr->cmdCount; /* Used to tell whether any commands
sl@0	1003	* at all were executed. */
sl@0	1004	char *script;
sl@0	1005	int numSrcBytes;
sl@0	1006	int result;
sl@0	1007	Namespace *namespacePtr;
sl@0	1008
sl@0	1009
sl@0	1010	/*
sl@0	1011	* Check that the interpreter is ready to execute scripts
sl@0	1012	*/
sl@0	1013
sl@0	1014	iPtr->numLevels++;
sl@0	1015	if (TclInterpReady(interp) == TCL_ERROR) {
sl@0	1016	iPtr->numLevels--;
sl@0	1017	return TCL_ERROR;
sl@0	1018	}
sl@0	1019
sl@0	1020	if (iPtr->varFramePtr != NULL) {
sl@0	1021	namespacePtr = iPtr->varFramePtr->nsPtr;
sl@0	1022	} else {
sl@0	1023	namespacePtr = iPtr->globalNsPtr;
sl@0	1024	}
sl@0	1025
sl@0	1026	/*
sl@0	1027	* If the object is not already of tclByteCodeType, compile it (and
sl@0	1028	* reset the compilation flags in the interpreter; this should be
sl@0	1029	* done after any compilation).
sl@0	1030	* Otherwise, check that it is "fresh" enough.
sl@0	1031	*/
sl@0	1032
sl@0	1033	if (objPtr->typePtr != &tclByteCodeType) {
sl@0	1034	recompileObj:
sl@0	1035	iPtr->errorLine = 1;
sl@0	1036
sl@0	1037	#ifdef TCL_TIP280
sl@0	1038	/* TIP #280. Remember the invoker for a moment in the interpreter
sl@0	1039	* structures so that the byte code compiler can pick it up when
sl@0	1040	* initializing the compilation environment, i.e. the extended
sl@0	1041	* location information.
sl@0	1042	*/
sl@0	1043
sl@0	1044	iPtr->invokeCmdFramePtr = invoker;
sl@0	1045	iPtr->invokeWord = word;
sl@0	1046	#endif
sl@0	1047	result = tclByteCodeType.setFromAnyProc(interp, objPtr);
sl@0	1048	#ifdef TCL_TIP280
sl@0	1049	iPtr->invokeCmdFramePtr = NULL;
sl@0	1050	#endif
sl@0	1051
sl@0	1052	if (result != TCL_OK) {
sl@0	1053	iPtr->numLevels--;
sl@0	1054	return result;
sl@0	1055	}
sl@0	1056	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
sl@0	1057	} else {
sl@0	1058	/*
sl@0	1059	* Make sure the Bytecode hasn't been invalidated by, e.g., someone
sl@0	1060	* redefining a command with a compile procedure (this might make the
sl@0	1061	* compiled code wrong).
sl@0	1062	* The object needs to be recompiled if it was compiled in/for a
sl@0	1063	* different interpreter, or for a different namespace, or for the
sl@0	1064	* same namespace but with different name resolution rules.
sl@0	1065	* Precompiled objects, however, are immutable and therefore
sl@0	1066	* they are not recompiled, even if the epoch has changed.
sl@0	1067	*
sl@0	1068	* To be pedantically correct, we should also check that the
sl@0	1069	* originating procPtr is the same as the current context procPtr
sl@0	1070	* (assuming one exists at all - none for global level). This
sl@0	1071	* code is #def'ed out because [info body] was changed to never
sl@0	1072	* return a bytecode type object, which should obviate us from
sl@0	1073	* the extra checks here.
sl@0	1074	*/
sl@0	1075	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
sl@0	1076	if (((Interp ) codePtr->interpHandle != iPtr)
sl@0	1077	\|\| (codePtr->compileEpoch != iPtr->compileEpoch)
sl@0	1078	#ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */
sl@0	1079	\|\| (codePtr->procPtr != NULL && !(iPtr->varFramePtr &&
sl@0	1080	iPtr->varFramePtr->procPtr == codePtr->procPtr))
sl@0	1081	#endif
sl@0	1082	\|\| (codePtr->nsPtr != namespacePtr)
sl@0	1083	\|\| (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
sl@0	1084	if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
sl@0	1085	if ((Interp ) codePtr->interpHandle != iPtr) {
sl@0	1086	panic("Tcl_EvalObj: compiled script jumped interps");
sl@0	1087	}
sl@0	1088	codePtr->compileEpoch = iPtr->compileEpoch;
sl@0	1089	} else {
sl@0	1090	/*
sl@0	1091	* This byteCode is invalid: free it and recompile
sl@0	1092	*/
sl@0	1093	tclByteCodeType.freeIntRepProc(objPtr);
sl@0	1094	goto recompileObj;
sl@0	1095	}
sl@0	1096	}
sl@0	1097	}
sl@0	1098
sl@0	1099	/*
sl@0	1100	* Execute the commands. If the code was compiled from an empty string,
sl@0	1101	* don't bother executing the code.
sl@0	1102	*/
sl@0	1103
sl@0	1104	numSrcBytes = codePtr->numSrcBytes;
sl@0	1105	if ((numSrcBytes > 0) \|\| (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
sl@0	1106	/*
sl@0	1107	* Increment the code's ref count while it is being executed. If
sl@0	1108	* afterwards no references to it remain, free the code.
sl@0	1109	*/
sl@0	1110
sl@0	1111	codePtr->refCount++;
sl@0	1112	result = TclExecuteByteCode(interp, codePtr);
sl@0	1113	codePtr->refCount--;
sl@0	1114	if (codePtr->refCount <= 0) {
sl@0	1115	TclCleanupByteCode(codePtr);
sl@0	1116	}
sl@0	1117	} else {
sl@0	1118	result = TCL_OK;
sl@0	1119	}
sl@0	1120	iPtr->numLevels--;
sl@0	1121
sl@0	1122
sl@0	1123	/*
sl@0	1124	* If no commands at all were executed, check for asynchronous
sl@0	1125	* handlers so that they at least get one change to execute.
sl@0	1126	* This is needed to handle event loops written in Tcl with
sl@0	1127	* empty bodies.
sl@0	1128	*/
sl@0	1129
sl@0	1130	if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) {
sl@0	1131	result = Tcl_AsyncInvoke(interp, result);
sl@0	1132
sl@0	1133
sl@0	1134	/*
sl@0	1135	* If an error occurred, record information about what was being
sl@0	1136	* executed when the error occurred.
sl@0	1137	*/
sl@0	1138
sl@0	1139	if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
sl@0	1140	script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
sl@0	1141	Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
sl@0	1142	}
sl@0	1143	}
sl@0	1144
sl@0	1145	/*
sl@0	1146	* Set the interpreter's termOffset member to the offset of the
sl@0	1147	* character just after the last one executed. We approximate the offset
sl@0	1148	* of the last character executed by using the number of characters
sl@0	1149	* compiled.
sl@0	1150	*/
sl@0	1151
sl@0	1152	iPtr->termOffset = numSrcBytes;
sl@0	1153	iPtr->flags &= ~ERR_ALREADY_LOGGED;
sl@0	1154
sl@0	1155	return result;
sl@0	1156	}
sl@0	1157
sl@0	1158	/*
sl@0	1159	*----------------------------------------------------------------------
sl@0	1160	*
sl@0	1161	* TclExecuteByteCode --
sl@0	1162	*
sl@0	1163	* This procedure executes the instructions of a ByteCode structure.
sl@0	1164	* It returns when a "done" instruction is executed or an error occurs.
sl@0	1165	*
sl@0	1166	* Results:
sl@0	1167	* The return value is one of the return codes defined in tcl.h
sl@0	1168	* (such as TCL_OK), and interp->objResultPtr refers to a Tcl object
sl@0	1169	* that either contains the result of executing the code or an
sl@0	1170	* error message.
sl@0	1171	*
sl@0	1172	* Side effects:
sl@0	1173	* Almost certainly, depending on the ByteCode's instructions.
sl@0	1174	*
sl@0	1175	*----------------------------------------------------------------------
sl@0	1176	*/
sl@0	1177
sl@0	1178	static int
sl@0	1179	TclExecuteByteCode(interp, codePtr)
sl@0	1180	Tcl_Interp interp; / Token for command interpreter. */
sl@0	1181	ByteCode codePtr; / The bytecode sequence to interpret. */
sl@0	1182	{
sl@0	1183	Interp iPtr = (Interp ) interp;
sl@0	1184	ExecEnv *eePtr = iPtr->execEnvPtr;
sl@0	1185	/* Points to the execution environment. */
sl@0	1186	register Tcl_Obj **stackPtr = eePtr->stackPtr;
sl@0	1187	/* Cached evaluation stack base pointer. */
sl@0	1188	register int stackTop = eePtr->stackTop;
sl@0	1189	/* Cached top index of evaluation stack. */
sl@0	1190	register unsigned char *pc = codePtr->codeStart;
sl@0	1191	/* The current program counter. */
sl@0	1192	int opnd; /* Current instruction's operand byte(s). */
sl@0	1193	int pcAdjustment; /* Hold pc adjustment after instruction. */
sl@0	1194	int initStackTop = stackTop;/* Stack top at start of execution. */
sl@0	1195	ExceptionRange rangePtr; / Points to closest loop or catch exception
sl@0	1196	* range enclosing the pc. Used by various
sl@0	1197	* instructions and processCatch to
sl@0	1198	* process break, continue, and errors. */
sl@0	1199	int result = TCL_OK; /* Return code returned after execution. */
sl@0	1200	int storeFlags;
sl@0	1201	Tcl_Obj valuePtr, value2Ptr, *objPtr;
sl@0	1202	char *bytes;
sl@0	1203	int length;
sl@0	1204	long i = 0; /* Init. avoids compiler warning. */
sl@0	1205	Tcl_WideInt w;
sl@0	1206	register int cleanup;
sl@0	1207	Tcl_Obj *objResultPtr;
sl@0	1208	char part1, part2;
sl@0	1209	Var varPtr, arrayPtr;
sl@0	1210	CallFrame *varFramePtr = iPtr->varFramePtr;
sl@0	1211
sl@0	1212	#ifdef TCL_TIP280
sl@0	1213	/* TIP #280 : Structures for tracking lines */
sl@0	1214	CmdFrame bcFrame;
sl@0	1215	#endif
sl@0	1216
sl@0	1217	#ifdef TCL_COMPILE_DEBUG
sl@0	1218	int traceInstructions = (tclTraceExec == 3);
sl@0	1219	char cmdNameBuf[21];
sl@0	1220	#endif
sl@0	1221
sl@0	1222	/*
sl@0	1223	* This procedure uses a stack to hold information about catch commands.
sl@0	1224	* This information is the current operand stack top when starting to
sl@0	1225	* execute the code for each catch command. It starts out with stack-
sl@0	1226	* allocated space but uses dynamically-allocated storage if needed.
sl@0	1227	*/
sl@0	1228
sl@0	1229	#define STATIC_CATCH_STACK_SIZE 4
sl@0	1230	int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
sl@0	1231	int *catchStackPtr = catchStackStorage;
sl@0	1232	int catchTop = -1;
sl@0	1233
sl@0	1234	#ifdef TCL_TIP280
sl@0	1235	/* TIP #280 : Initialize the frame. Do not push it yet. */
sl@0	1236
sl@0	1237	bcFrame.type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
sl@0	1238	? TCL_LOCATION_PREBC
sl@0	1239	: TCL_LOCATION_BC);
sl@0	1240	bcFrame.level = (iPtr->cmdFramePtr == NULL ?
sl@0	1241	1 :
sl@0	1242	iPtr->cmdFramePtr->level + 1);
sl@0	1243	bcFrame.framePtr = iPtr->framePtr;
sl@0	1244	bcFrame.nextPtr = iPtr->cmdFramePtr;
sl@0	1245	bcFrame.nline = 0;
sl@0	1246	bcFrame.line = NULL;
sl@0	1247
sl@0	1248	bcFrame.data.tebc.codePtr = codePtr;
sl@0	1249	bcFrame.data.tebc.pc = NULL;
sl@0	1250	bcFrame.cmd.str.cmd = NULL;
sl@0	1251	bcFrame.cmd.str.len = 0;
sl@0	1252	#endif
sl@0	1253
sl@0	1254	#ifdef TCL_COMPILE_DEBUG
sl@0	1255	if (tclTraceExec >= 2) {
sl@0	1256	PrintByteCodeInfo(codePtr);
sl@0	1257	fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop);
sl@0	1258	fflush(stdout);
sl@0	1259	}
sl@0	1260	opnd = 0; /* Init. avoids compiler warning. */
sl@0	1261	#endif
sl@0	1262
sl@0	1263	#ifdef TCL_COMPILE_STATS
sl@0	1264	iPtr->stats.numExecutions++;
sl@0	1265	#endif
sl@0	1266
sl@0	1267	/*
sl@0	1268	* Make sure the catch stack is large enough to hold the maximum number
sl@0	1269	* of catch commands that could ever be executing at the same time. This
sl@0	1270	* will be no more than the exception range array's depth.
sl@0	1271	*/
sl@0	1272
sl@0	1273	if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) {
sl@0	1274	catchStackPtr = (int *)
sl@0	1275	ckalloc(codePtr->maxExceptDepth * sizeof(int));
sl@0	1276	}
sl@0	1277
sl@0	1278	/*
sl@0	1279	* Make sure the stack has enough room to execute this ByteCode.
sl@0	1280	*/
sl@0	1281
sl@0	1282	while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
sl@0	1283	GrowEvaluationStack(eePtr);
sl@0	1284	stackPtr = eePtr->stackPtr;
sl@0	1285	}
sl@0	1286
sl@0	1287	/*
sl@0	1288	* Loop executing instructions until a "done" instruction, a
sl@0	1289	* TCL_RETURN, or some error.
sl@0	1290	*/
sl@0	1291
sl@0	1292	goto cleanup0;
sl@0	1293
sl@0	1294
sl@0	1295	/*
sl@0	1296	* Targets for standard instruction endings; unrolled
sl@0	1297	* for speed in the most frequent cases (instructions that
sl@0	1298	* consume up to two stack elements).
sl@0	1299	*
sl@0	1300	* This used to be a "for(;;)" loop, with each instruction doing
sl@0	1301	* its own cleanup.
sl@0	1302	*/
sl@0	1303
sl@0	1304	cleanupV_pushObjResultPtr:
sl@0	1305	switch (cleanup) {
sl@0	1306	case 0:
sl@0	1307	stackPtr[++stackTop] = (objResultPtr);
sl@0	1308	goto cleanup0;
sl@0	1309	default:
sl@0	1310	cleanup -= 2;
sl@0	1311	while (cleanup--) {
sl@0	1312	valuePtr = POP_OBJECT();
sl@0	1313	TclDecrRefCount(valuePtr);
sl@0	1314	}
sl@0	1315	case 2:
sl@0	1316	cleanup2_pushObjResultPtr:
sl@0	1317	valuePtr = POP_OBJECT();
sl@0	1318	TclDecrRefCount(valuePtr);
sl@0	1319	case 1:
sl@0	1320	cleanup1_pushObjResultPtr:
sl@0	1321	valuePtr = stackPtr[stackTop];
sl@0	1322	TclDecrRefCount(valuePtr);
sl@0	1323	}
sl@0	1324	stackPtr[stackTop] = objResultPtr;
sl@0	1325	goto cleanup0;
sl@0	1326
sl@0	1327	cleanupV:
sl@0	1328	switch (cleanup) {
sl@0	1329	default:
sl@0	1330	cleanup -= 2;
sl@0	1331	while (cleanup--) {
sl@0	1332	valuePtr = POP_OBJECT();
sl@0	1333	TclDecrRefCount(valuePtr);
sl@0	1334	}
sl@0	1335	case 2:
sl@0	1336	cleanup2:
sl@0	1337	valuePtr = POP_OBJECT();
sl@0	1338	TclDecrRefCount(valuePtr);
sl@0	1339	case 1:
sl@0	1340	cleanup1:
sl@0	1341	valuePtr = POP_OBJECT();
sl@0	1342	TclDecrRefCount(valuePtr);
sl@0	1343	case 0:
sl@0	1344	/*
sl@0	1345	* We really want to do nothing now, but this is needed
sl@0	1346	* for some compilers (SunPro CC)
sl@0	1347	*/
sl@0	1348	break;
sl@0	1349	}
sl@0	1350
sl@0	1351	cleanup0:
sl@0	1352
sl@0	1353	#ifdef TCL_COMPILE_DEBUG
sl@0	1354	ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop);
sl@0	1355	if (traceInstructions) {
sl@0	1356	fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop);
sl@0	1357	TclPrintInstruction(codePtr, pc);
sl@0	1358	fflush(stdout);
sl@0	1359	}
sl@0	1360	#endif /* TCL_COMPILE_DEBUG */
sl@0	1361
sl@0	1362	#ifdef TCL_COMPILE_STATS
sl@0	1363	iPtr->stats.instructionCount[*pc]++;
sl@0	1364	#endif
sl@0	1365	switch (*pc) {
sl@0	1366	case INST_DONE:
sl@0	1367	if (stackTop <= initStackTop) {
sl@0	1368	stackTop--;
sl@0	1369	goto abnormalReturn;
sl@0	1370	}
sl@0	1371
sl@0	1372	/*
sl@0	1373	* Set the interpreter's object result to point to the
sl@0	1374	* topmost object from the stack, and check for a possible
sl@0	1375	* [catch]. The stackTop's level and refCount will be handled
sl@0	1376	* by "processCatch" or "abnormalReturn".
sl@0	1377	*/
sl@0	1378
sl@0	1379	valuePtr = stackPtr[stackTop];
sl@0	1380	Tcl_SetObjResult(interp, valuePtr);
sl@0	1381	#ifdef TCL_COMPILE_DEBUG
sl@0	1382	TRACE_WITH_OBJ(("=> return code=%d, result=", result),
sl@0	1383	iPtr->objResultPtr);
sl@0	1384	if (traceInstructions) {
sl@0	1385	fprintf(stdout, "\n");
sl@0	1386	}
sl@0	1387	#endif
sl@0	1388	goto checkForCatch;
sl@0	1389
sl@0	1390	case INST_PUSH1:
sl@0	1391	objResultPtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];
sl@0	1392	TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), objResultPtr);
sl@0	1393	NEXT_INST_F(2, 0, 1);
sl@0	1394
sl@0	1395	case INST_PUSH4:
sl@0	1396	objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
sl@0	1397	TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
sl@0	1398	NEXT_INST_F(5, 0, 1);
sl@0	1399
sl@0	1400	case INST_POP:
sl@0	1401	TRACE_WITH_OBJ(("=> discarding "), stackPtr[stackTop]);
sl@0	1402	valuePtr = POP_OBJECT();
sl@0	1403	TclDecrRefCount(valuePtr);
sl@0	1404	NEXT_INST_F(1, 0, 0);
sl@0	1405
sl@0	1406	case INST_DUP:
sl@0	1407	objResultPtr = stackPtr[stackTop];
sl@0	1408	TRACE_WITH_OBJ(("=> "), objResultPtr);
sl@0	1409	NEXT_INST_F(1, 0, 1);
sl@0	1410
sl@0	1411	case INST_OVER:
sl@0	1412	opnd = TclGetUInt4AtPtr( pc+1 );
sl@0	1413	objResultPtr = stackPtr[ stackTop - opnd ];
sl@0	1414	TRACE_WITH_OBJ(("=> "), objResultPtr);
sl@0	1415	NEXT_INST_F(5, 0, 1);
sl@0	1416
sl@0	1417	case INST_CONCAT1:
sl@0	1418	opnd = TclGetUInt1AtPtr(pc+1);
sl@0	1419	{
sl@0	1420	int totalLen = 0;
sl@0	1421
sl@0	1422	/*
sl@0	1423	* Peephole optimisation for appending an empty string.
sl@0	1424	* This enables replacing 'K $x [set x{}]' by '$x[set x{}]'
sl@0	1425	* for fastest execution. Avoid doing the optimisation for wide
sl@0	1426	* ints - a case where equal strings may refer to different values
sl@0	1427	* (see [Bug 1251791]).
sl@0	1428	*/
sl@0	1429
sl@0	1430	if ((opnd == 2) && (stackPtr[stackTop-1]->typePtr != &tclWideIntType)) {
sl@0	1431	Tcl_GetStringFromObj(stackPtr[stackTop], &length);
sl@0	1432	if (length == 0) {
sl@0	1433	/* Just drop the top item from the stack */
sl@0	1434	NEXT_INST_F(2, 1, 0);
sl@0	1435	}
sl@0	1436	}
sl@0	1437
sl@0	1438	/*
sl@0	1439	* Concatenate strings (with no separators) from the top
sl@0	1440	* opnd items on the stack starting with the deepest item.
sl@0	1441	* First, determine how many characters are needed.
sl@0	1442	*/
sl@0	1443
sl@0	1444	for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
sl@0	1445	bytes = Tcl_GetStringFromObj(stackPtr[i], &length);
sl@0	1446	if (bytes != NULL) {
sl@0	1447	totalLen += length;
sl@0	1448	}
sl@0	1449	}
sl@0	1450
sl@0	1451	/*
sl@0	1452	* Initialize the new append string object by appending the
sl@0	1453	* strings of the opnd stack objects. Also pop the objects.
sl@0	1454	*/
sl@0	1455
sl@0	1456	TclNewObj(objResultPtr);
sl@0	1457	if (totalLen > 0) {
sl@0	1458	char p = (char ) ckalloc((unsigned) (totalLen + 1));
sl@0	1459	objResultPtr->bytes = p;
sl@0	1460	objResultPtr->length = totalLen;
sl@0	1461	for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
sl@0	1462	valuePtr = stackPtr[i];
sl@0	1463	bytes = Tcl_GetStringFromObj(valuePtr, &length);
sl@0	1464	if (bytes != NULL) {
sl@0	1465	memcpy((VOID ) p, (VOID ) bytes,
sl@0	1466	(size_t) length);
sl@0	1467	p += length;
sl@0	1468	}
sl@0	1469	}
sl@0	1470	*p = '\0';
sl@0	1471	}
sl@0	1472
sl@0	1473	TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
sl@0	1474	NEXT_INST_V(2, opnd, 1);
sl@0	1475	}
sl@0	1476
sl@0	1477	case INST_INVOKE_STK4:
sl@0	1478	opnd = TclGetUInt4AtPtr(pc+1);
sl@0	1479	pcAdjustment = 5;
sl@0	1480	goto doInvocation;
sl@0	1481
sl@0	1482	case INST_INVOKE_STK1:
sl@0	1483	opnd = TclGetUInt1AtPtr(pc+1);
sl@0	1484	pcAdjustment = 2;
sl@0	1485
sl@0	1486	doInvocation:
sl@0	1487	{
sl@0	1488	int objc = opnd; /* The number of arguments. */
sl@0	1489	Tcl_Obj *objv; / The array of argument objects. */
sl@0	1490
sl@0	1491	/*
sl@0	1492	* We keep the stack reference count as a (char *), as that
sl@0	1493	* works nicely as a portable pointer-sized counter.
sl@0	1494	*/
sl@0	1495
sl@0	1496	char **preservedStackRefCountPtr;
sl@0	1497
sl@0	1498	/*
sl@0	1499	* Reference to memory block containing
sl@0	1500	* objv array (must be kept live throughout
sl@0	1501	* trace and command invokations.)
sl@0	1502	*/
sl@0	1503
sl@0	1504	objv = &(stackPtr[stackTop - (objc-1)]);
sl@0	1505
sl@0	1506	#ifdef TCL_COMPILE_DEBUG
sl@0	1507	if (tclTraceExec >= 2) {
sl@0	1508	if (traceInstructions) {
sl@0	1509	strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
sl@0	1510	TRACE(("%u => call ", objc));
sl@0	1511	} else {
sl@0	1512	fprintf(stdout, "%d: (%u) invoking ",
sl@0	1513	iPtr->numLevels,
sl@0	1514	(unsigned int)(pc - codePtr->codeStart));
sl@0	1515	}
sl@0	1516	for (i = 0; i < objc; i++) {
sl@0	1517	TclPrintObject(stdout, objv[i], 15);
sl@0	1518	fprintf(stdout, " ");
sl@0	1519	}
sl@0	1520	fprintf(stdout, "\n");
sl@0	1521	fflush(stdout);
sl@0	1522	}
sl@0	1523	#endif /TCL_COMPILE_DEBUG/
sl@0	1524
sl@0	1525	/*
sl@0	1526	* If trace procedures will be called, we need a
sl@0	1527	* command string to pass to TclEvalObjvInternal; note
sl@0	1528	* that a copy of the string will be made there to
sl@0	1529	* include the ending \0.
sl@0	1530	*/
sl@0	1531
sl@0	1532	bytes = NULL;
sl@0	1533	length = 0;
sl@0	1534	if (iPtr->tracePtr != NULL) {
sl@0	1535	Trace tracePtr, nextTracePtr;
sl@0	1536
sl@0	1537	for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
sl@0	1538	tracePtr = nextTracePtr) {
sl@0	1539	nextTracePtr = tracePtr->nextPtr;
sl@0	1540	if (tracePtr->level == 0 \|\|
sl@0	1541	iPtr->numLevels <= tracePtr->level) {
sl@0	1542	/*
sl@0	1543	* Traces will be called: get command string
sl@0	1544	*/
sl@0	1545
sl@0	1546	bytes = GetSrcInfoForPc(pc, codePtr, &length);
sl@0	1547	break;
sl@0	1548	}
sl@0	1549	}
sl@0	1550	} else {
sl@0	1551	Command *cmdPtr;
sl@0	1552	cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
sl@0	1553	if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
sl@0	1554	bytes = GetSrcInfoForPc(pc, codePtr, &length);
sl@0	1555	}
sl@0	1556	}
sl@0	1557
sl@0	1558	/*
sl@0	1559	* A reference to part of the stack vector itself
sl@0	1560	* escapes our control: increase its refCount
sl@0	1561	* to stop it from being deallocated by a recursive
sl@0	1562	* call to ourselves. The extra variable is needed
sl@0	1563	* because all others are liable to change due to the
sl@0	1564	* trace procedures.
sl@0	1565	*/
sl@0	1566
sl@0	1567	preservedStackRefCountPtr = (char **) (stackPtr-1);
sl@0	1568	++*preservedStackRefCountPtr;
sl@0	1569
sl@0	1570	/*
sl@0	1571	* Finally, let TclEvalObjvInternal handle the command.
sl@0	1572	*
sl@0	1573	* TIP #280 : Record the last piece of info needed by
sl@0	1574	* 'TclGetSrcInfoForPc', and push the frame.
sl@0	1575	*/
sl@0	1576
sl@0	1577	#ifdef TCL_TIP280
sl@0	1578	bcFrame.data.tebc.pc = pc;
sl@0	1579	iPtr->cmdFramePtr = &bcFrame;
sl@0	1580	#endif
sl@0	1581	DECACHE_STACK_INFO();
sl@0	1582	Tcl_ResetResult(interp);
sl@0	1583	result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0);
sl@0	1584	CACHE_STACK_INFO();
sl@0	1585	#ifdef TCL_TIP280
sl@0	1586	iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
sl@0	1587	#endif
sl@0	1588
sl@0	1589	/*
sl@0	1590	* If the old stack is going to be released, it is
sl@0	1591	* safe to do so now, since no references to objv are
sl@0	1592	* going to be used from now on.
sl@0	1593	*/
sl@0	1594
sl@0	1595	--*preservedStackRefCountPtr;
sl@0	1596	if (preservedStackRefCountPtr == (char ) 0) {
sl@0	1597	ckfree((VOID *) preservedStackRefCountPtr);
sl@0	1598	}
sl@0	1599
sl@0	1600	if (result == TCL_OK) {
sl@0	1601	/*
sl@0	1602	* Push the call's object result and continue execution
sl@0	1603	* with the next instruction.
sl@0	1604	*/
sl@0	1605
sl@0	1606	TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
sl@0	1607	objc, cmdNameBuf), Tcl_GetObjResult(interp));
sl@0	1608
sl@0	1609	objResultPtr = Tcl_GetObjResult(interp);
sl@0	1610
sl@0	1611	/*
sl@0	1612	* Reset the interp's result to avoid possible duplications
sl@0	1613	* of large objects [Bug 781585]. We do not call
sl@0	1614	* Tcl_ResetResult() to avoid any side effects caused by
sl@0	1615	* the resetting of errorInfo and errorCode [Bug 804681],
sl@0	1616	* which are not needed here. We chose instead to manipulate
sl@0	1617	* the interp's object result directly.
sl@0	1618	*
sl@0	1619	* Note that the result object is now in objResultPtr, it
sl@0	1620	* keeps the refCount it had in its role of iPtr->objResultPtr.
sl@0	1621	*/
sl@0	1622	{
sl@0	1623	Tcl_Obj *newObjResultPtr;
sl@0	1624	TclNewObj(newObjResultPtr);
sl@0	1625	Tcl_IncrRefCount(newObjResultPtr);
sl@0	1626	iPtr->objResultPtr = newObjResultPtr;
sl@0	1627	}
sl@0	1628
sl@0	1629	NEXT_INST_V(pcAdjustment, opnd, -1);
sl@0	1630	} else {
sl@0	1631	cleanup = opnd;
sl@0	1632	goto processExceptionReturn;
sl@0	1633	}
sl@0	1634	}
sl@0	1635
sl@0	1636	case INST_EVAL_STK:
sl@0	1637	/*
sl@0	1638	* Note to maintainers: it is important that INST_EVAL_STK
sl@0	1639	* pop its argument from the stack before jumping to
sl@0	1640	* checkForCatch! DO NOT OPTIMISE!
sl@0	1641	*/
sl@0	1642
sl@0	1643	objPtr = stackPtr[stackTop];
sl@0	1644	DECACHE_STACK_INFO();
sl@0	1645	#ifndef TCL_TIP280
sl@0	1646	result = TclCompEvalObj(interp, objPtr);
sl@0	1647	#else
sl@0	1648	/* TIP #280: The invoking context is left NULL for a dynamically
sl@0	1649	* constructed command. We cannot match its lines to the outer
sl@0	1650	* context.
sl@0	1651	*/
sl@0	1652
sl@0	1653	result = TclCompEvalObj(interp, objPtr, NULL,0);
sl@0	1654	#endif
sl@0	1655	CACHE_STACK_INFO();
sl@0	1656	if (result == TCL_OK) {
sl@0	1657	/*
sl@0	1658	* Normal return; push the eval's object result.
sl@0	1659	*/
sl@0	1660
sl@0	1661	objResultPtr = Tcl_GetObjResult(interp);
sl@0	1662	TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
sl@0	1663	Tcl_GetObjResult(interp));
sl@0	1664
sl@0	1665	/*
sl@0	1666	* Reset the interp's result to avoid possible duplications
sl@0	1667	* of large objects [Bug 781585]. We do not call
sl@0	1668	* Tcl_ResetResult() to avoid any side effects caused by
sl@0	1669	* the resetting of errorInfo and errorCode [Bug 804681],
sl@0	1670	* which are not needed here. We chose instead to manipulate
sl@0	1671	* the interp's object result directly.
sl@0	1672	*
sl@0	1673	* Note that the result object is now in objResultPtr, it
sl@0	1674	* keeps the refCount it had in its role of iPtr->objResultPtr.
sl@0	1675	*/
sl@0	1676	{
sl@0	1677	Tcl_Obj *newObjResultPtr;
sl@0	1678	TclNewObj(newObjResultPtr);
sl@0	1679	Tcl_IncrRefCount(newObjResultPtr);
sl@0	1680	iPtr->objResultPtr = newObjResultPtr;
sl@0	1681	}
sl@0	1682
sl@0	1683	NEXT_INST_F(1, 1, -1);
sl@0	1684	} else {
sl@0	1685	cleanup = 1;
sl@0	1686	goto processExceptionReturn;
sl@0	1687	}
sl@0	1688
sl@0	1689	case INST_EXPR_STK:
sl@0	1690	objPtr = stackPtr[stackTop];
sl@0	1691	DECACHE_STACK_INFO();
sl@0	1692	Tcl_ResetResult(interp);
sl@0	1693	result = Tcl_ExprObj(interp, objPtr, &valuePtr);
sl@0	1694	CACHE_STACK_INFO();
sl@0	1695	if (result != TCL_OK) {
sl@0	1696	TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
sl@0	1697	O2S(objPtr)), Tcl_GetObjResult(interp));
sl@0	1698	goto checkForCatch;
sl@0	1699	}
sl@0	1700	objResultPtr = valuePtr;
sl@0	1701	TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
sl@0	1702	NEXT_INST_F(1, 1, -1); /* already has right refct */
sl@0	1703
sl@0	1704	/*
sl@0	1705	* ---------------------------------------------------------
sl@0	1706	* Start of INST_LOAD instructions.
sl@0	1707	*
sl@0	1708	* WARNING: more 'goto' here than your doctor recommended!
sl@0	1709	* The different instructions set the value of some variables
sl@0	1710	* and then jump to somme common execution code.
sl@0	1711	*/
sl@0	1712
sl@0	1713	case INST_LOAD_SCALAR1:
sl@0	1714	opnd = TclGetUInt1AtPtr(pc+1);
sl@0	1715	varPtr = &(varFramePtr->compiledLocals[opnd]);
sl@0	1716	part1 = varPtr->name;
sl@0	1717	while (TclIsVarLink(varPtr)) {
sl@0	1718	varPtr = varPtr->value.linkPtr;
sl@0	1719	}
sl@0	1720	TRACE(("%u => ", opnd));
sl@0	1721	if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
sl@0	1722	&& (varPtr->tracePtr == NULL)) {
sl@0	1723	/*
sl@0	1724	* No errors, no traces: just get the value.
sl@0	1725	*/
sl@0	1726	objResultPtr = varPtr->value.objPtr;
sl@0	1727	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
sl@0	1728	NEXT_INST_F(2, 0, 1);
sl@0	1729	}
sl@0	1730	pcAdjustment = 2;
sl@0	1731	cleanup = 0;
sl@0	1732	arrayPtr = NULL;
sl@0	1733	part2 = NULL;
sl@0	1734	goto doCallPtrGetVar;
sl@0	1735
sl@0	1736	case INST_LOAD_SCALAR4:
sl@0	1737	opnd = TclGetUInt4AtPtr(pc+1);
sl@0	1738	varPtr = &(varFramePtr->compiledLocals[opnd]);
sl@0	1739	part1 = varPtr->name;
sl@0	1740	while (TclIsVarLink(varPtr)) {
sl@0	1741	varPtr = varPtr->value.linkPtr;
sl@0	1742	}
sl@0	1743	TRACE(("%u => ", opnd));
sl@0	1744	if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
sl@0	1745	&& (varPtr->tracePtr == NULL)) {
sl@0	1746	/*
sl@0	1747	* No errors, no traces: just get the value.
sl@0	1748	*/
sl@0	1749	objResultPtr = varPtr->value.objPtr;
sl@0	1750	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
sl@0	1751	NEXT_INST_F(5, 0, 1);
sl@0	1752	}
sl@0	1753	pcAdjustment = 5;
sl@0	1754	cleanup = 0;
sl@0	1755	arrayPtr = NULL;
sl@0	1756	part2 = NULL;
sl@0	1757	goto doCallPtrGetVar;
sl@0	1758
sl@0	1759	case INST_LOAD_ARRAY_STK:
sl@0	1760	cleanup = 2;
sl@0	1761	part2 = Tcl_GetString(stackPtr[stackTop]); /* element name */
sl@0	1762	objPtr = stackPtr[stackTop-1]; /* array name */
sl@0	1763	TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), part2));
sl@0	1764	goto doLoadStk;
sl@0	1765
sl@0	1766	case INST_LOAD_STK:
sl@0	1767	case INST_LOAD_SCALAR_STK:
sl@0	1768	cleanup = 1;
sl@0	1769	part2 = NULL;
sl@0	1770	objPtr = stackPtr[stackTop]; /* variable name */
sl@0	1771	TRACE(("\"%.30s\" => ", O2S(objPtr)));
sl@0	1772
sl@0	1773	doLoadStk:
sl@0	1774	part1 = TclGetString(objPtr);
sl@0	1775	varPtr = TclObjLookupVar(interp, objPtr, part2,
sl@0	1776	TCL_LEAVE_ERR_MSG, "read",
sl@0	1777	/createPart1/ 0,
sl@0	1778	/createPart2/ 1, &arrayPtr);
sl@0	1779	if (varPtr == NULL) {
sl@0	1780	TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
sl@0	1781	result = TCL_ERROR;
sl@0	1782	goto checkForCatch;
sl@0	1783	}
sl@0	1784	if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
sl@0	1785	&& (varPtr->tracePtr == NULL)
sl@0	1786	&& ((arrayPtr == NULL)
sl@0	1787	\|\| (arrayPtr->tracePtr == NULL))) {
sl@0	1788	/*
sl@0	1789	* No errors, no traces: just get the value.
sl@0	1790	*/
sl@0	1791	objResultPtr = varPtr->value.objPtr;
sl@0	1792	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
sl@0	1793	NEXT_INST_V(1, cleanup, 1);
sl@0	1794	}
sl@0	1795	pcAdjustment = 1;
sl@0	1796	goto doCallPtrGetVar;
sl@0	1797
sl@0	1798	case INST_LOAD_ARRAY4:
sl@0	1799	opnd = TclGetUInt4AtPtr(pc+1);
sl@0	1800	pcAdjustment = 5;
sl@0	1801	goto doLoadArray;
sl@0	1802
sl@0	1803	case INST_LOAD_ARRAY1:
sl@0	1804	opnd = TclGetUInt1AtPtr(pc+1);
sl@0	1805	pcAdjustment = 2;
sl@0	1806
sl@0	1807	doLoadArray:
sl@0	1808	part2 = TclGetString(stackPtr[stackTop]);
sl@0	1809	arrayPtr = &(varFramePtr->compiledLocals[opnd]);
sl@0	1810	part1 = arrayPtr->name;
sl@0	1811	while (TclIsVarLink(arrayPtr)) {
sl@0	1812	arrayPtr = arrayPtr->value.linkPtr;
sl@0	1813	}
sl@0	1814	TRACE(("%u \"%.30s\" => ", opnd, part2));
sl@0	1815	varPtr = TclLookupArrayElement(interp, part1, part2,
sl@0	1816	TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
sl@0	1817	if (varPtr == NULL) {
sl@0	1818	TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
sl@0	1819	result = TCL_ERROR;
sl@0	1820	goto checkForCatch;
sl@0	1821	}
sl@0	1822	if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
sl@0	1823	&& (varPtr->tracePtr == NULL)
sl@0	1824	&& ((arrayPtr == NULL)
sl@0	1825	\|\| (arrayPtr->tracePtr == NULL))) {
sl@0	1826	/*
sl@0	1827	* No errors, no traces: just get the value.
sl@0	1828	*/
sl@0	1829	objResultPtr = varPtr->value.objPtr;
sl@0	1830	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
sl@0	1831	NEXT_INST_F(pcAdjustment, 1, 1);
sl@0	1832	}
sl@0	1833	cleanup = 1;
sl@0	1834	goto doCallPtrGetVar;
sl@0	1835
sl@0	1836	doCallPtrGetVar:
sl@0	1837	/*
sl@0	1838	* There are either errors or the variable is traced:
sl@0	1839	* call TclPtrGetVar to process fully.
sl@0	1840	*/
sl@0	1841
sl@0	1842	DECACHE_STACK_INFO();
sl@0	1843	objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1,
sl@0	1844	part2, TCL_LEAVE_ERR_MSG);
sl@0	1845	CACHE_STACK_INFO();
sl@0	1846	if (objResultPtr == NULL) {
sl@0	1847	TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
sl@0	1848	result = TCL_ERROR;
sl@0	1849	goto checkForCatch;
sl@0	1850	}
sl@0	1851	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
sl@0	1852	NEXT_INST_V(pcAdjustment, cleanup, 1);
sl@0	1853
sl@0	1854	/*
sl@0	1855	* End of INST_LOAD instructions.
sl@0	1856	* ---------------------------------------------------------
sl@0	1857	*/
sl@0	1858
sl@0	1859	/*
sl@0	1860	* ---------------------------------------------------------
sl@0	1861	* Start of INST_STORE and related instructions.
sl@0	1862	*
sl@0	1863	* WARNING: more 'goto' here than your doctor recommended!
sl@0	1864	* The different instructions set the value of some variables
sl@0	1865	* and then jump to somme common execution code.
sl@0	1866	*/
sl@0	1867
sl@0	1868	case INST_LAPPEND_STK:
sl@0	1869	valuePtr = stackPtr[stackTop]; /* value to append */
sl@0	1870	part2 = NULL;
sl@0	1871	storeFlags = (TCL_LEAVE_ERR_MSG \| TCL_APPEND_VALUE
sl@0	1872	\| TCL_LIST_ELEMENT \| TCL_TRACE_READS);
sl@0	1873	goto doStoreStk;
sl@0	1874
sl@0	1875	case INST_LAPPEND_ARRAY_STK:
sl@0	1876	valuePtr = stackPtr[stackTop]; /* value to append */
sl@0	1877	part2 = TclGetString(stackPtr[stackTop - 1]);
sl@0	1878	storeFlags = (TCL_LEAVE_ERR_MSG \| TCL_APPEND_VALUE
sl@0	1879	\| TCL_LIST_ELEMENT \| TCL_TRACE_READS);
sl@0	1880	goto doStoreStk;
sl@0	1881
sl@0	1882	case INST_APPEND_STK:
sl@0	1883	valuePtr = stackPtr[stackTop]; /* value to append */
sl@0	1884	part2 = NULL;
sl@0	1885	storeFlags = (TCL_LEAVE_ERR_MSG \| TCL_APPEND_VALUE);
sl@0	1886	goto doStoreStk;
sl@0	1887
sl@0	1888	case INST_APPEND_ARRAY_STK:
sl@0	1889	valuePtr = stackPtr[stackTop]; /* value to append */
sl@0	1890	part2 = TclGetString(stackPtr[stackTop - 1]);
sl@0	1891	storeFlags = (TCL_LEAVE_ERR_MSG \| TCL_APPEND_VALUE);
sl@0	1892	goto doStoreStk;
sl@0	1893
sl@0	1894	case INST_STORE_ARRAY_STK:
sl@0	1895	valuePtr = stackPtr[stackTop];
sl@0	1896	part2 = TclGetString(stackPtr[stackTop - 1]);
sl@0	1897	storeFlags = TCL_LEAVE_ERR_MSG;
sl@0	1898	goto doStoreStk;
sl@0	1899
sl@0	1900	case INST_STORE_STK:
sl@0	1901	case INST_STORE_SCALAR_STK:
sl@0	1902	valuePtr = stackPtr[stackTop];
sl@0	1903	part2 = NULL;
sl@0	1904	storeFlags = TCL_LEAVE_ERR_MSG;
sl@0	1905
sl@0	1906	doStoreStk:
sl@0	1907	objPtr = stackPtr[stackTop - 1 - (part2 != NULL)]; /* variable name */
sl@0	1908	part1 = TclGetString(objPtr);
sl@0	1909	#ifdef TCL_COMPILE_DEBUG
sl@0	1910	if (part2 == NULL) {
sl@0	1911	TRACE(("\"%.30s\" <- \"%.30s\" =>",
sl@0	1912	part1, O2S(valuePtr)));
sl@0	1913	} else {
sl@0	1914	TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
sl@0	1915	part1, part2, O2S(valuePtr)));
sl@0	1916	}
sl@0	1917	#endif
sl@0	1918	varPtr = TclObjLookupVar(interp, objPtr, part2,
sl@0	1919	TCL_LEAVE_ERR_MSG, "set",
sl@0	1920	/createPart1/ 1,
sl@0	1921	/createPart2/ 1, &arrayPtr);
sl@0	1922	if (varPtr == NULL) {
sl@0	1923	TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
sl@0	1924	result = TCL_ERROR;
sl@0	1925	goto checkForCatch;
sl@0	1926	}
sl@0	1927	cleanup = ((part2 == NULL)? 2 : 3);
sl@0	1928	pcAdjustment = 1;
sl@0	1929	goto doCallPtrSetVar;
sl@0	1930
sl@0	1931	case INST_LAPPEND_ARRAY4:
sl@0	1932	opnd = TclGetUInt4AtPtr(pc+1);
sl@0	1933	pcAdjustment = 5;
sl@0	1934	storeFlags = (TCL_LEAVE_ERR_MSG \| TCL_APPEND_VALUE
sl@0	1935	\| TCL_LIST_ELEMENT \| TCL_TRACE_READS);
sl@0	1936	goto doStoreArray;
sl@0	1937
sl@0	1938	case INST_LAPPEND_ARRAY1:
sl@0	1939	opnd = TclGetUInt1AtPtr(pc+1);
sl@0	1940	pcAdjustment = 2;
sl@0	1941	storeFlags = (TCL_LEAVE_ERR_MSG \| TCL_APPEND_VALUE
sl@0	1942	\| TCL_LIST_ELEMENT \| TCL_TRACE_READS);
sl@0	1943	goto doStoreArray;
sl@0	1944
sl@0	1945	case INST_APPEND_ARRAY4:
sl@0	1946	opnd = TclGetUInt4AtPtr(pc+1);
sl@0	1947	pcAdjustment = 5;
sl@0	1948	storeFlags = (TCL_LEAVE_ERR_MSG \| TCL_APPEND_VALUE);
sl@0	1949	goto doStoreArray;
sl@0	1950
sl@0	1951	case INST_APPEND_ARRAY1:
sl@0	1952	opnd = TclGetUInt1AtPtr(pc+1);
sl@0	1953	pcAdjustment = 2;
sl@0	1954	storeFlags = (TCL_LEAVE_ERR_MSG \| TCL_APPEND_VALUE);
sl@0	1955	goto doStoreArray;
sl@0	1956
sl@0	1957	case INST_STORE_ARRAY4:
sl@0	1958	opnd = TclGetUInt4AtPtr(pc+1);
sl@0	1959	pcAdjustment = 5;
sl@0	1960	storeFlags = TCL_LEAVE_ERR_MSG;
sl@0	1961	goto doStoreArray;
sl@0	1962
sl@0	1963	case INST_STORE_ARRAY1:
sl@0	1964	opnd = TclGetUInt1AtPtr(pc+1);
sl@0	1965	pcAdjustment = 2;
sl@0	1966	storeFlags = TCL_LEAVE_ERR_MSG;
sl@0	1967
sl@0	1968	doStoreArray:
sl@0	1969	valuePtr = stackPtr[stackTop];
sl@0	1970	part2 = TclGetString(stackPtr[stackTop - 1]);
sl@0	1971	arrayPtr = &(varFramePtr->compiledLocals[opnd]);
sl@0	1972	part1 = arrayPtr->name;
sl@0	1973	TRACE(("%u \"%.30s\" <- \"%.30s\" => ",
sl@0	1974	opnd, part2, O2S(valuePtr)));
sl@0	1975	while (TclIsVarLink(arrayPtr)) {
sl@0	1976	arrayPtr = arrayPtr->value.linkPtr;
sl@0	1977	}
sl@0	1978	varPtr = TclLookupArrayElement(interp, part1, part2,
sl@0	1979	TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr);
sl@0	1980	if (varPtr == NULL) {
sl@0	1981	TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
sl@0	1982	result = TCL_ERROR;
sl@0	1983	goto checkForCatch;
sl@0	1984	}
sl@0	1985	cleanup = 2;
sl@0	1986	goto doCallPtrSetVar;
sl@0	1987
sl@0	1988	case INST_LAPPEND_SCALAR4:
sl@0	1989	opnd = TclGetUInt4AtPtr(pc+1);
sl@0	1990	pcAdjustment = 5;
sl@0	1991	storeFlags = (TCL_LEAVE_ERR_MSG \| TCL_APPEND_VALUE
sl@0	1992	\| TCL_LIST_ELEMENT \| TCL_TRACE_READS);
sl@0	1993	goto doStoreScalar;
sl@0	1994
sl@0	1995	case INST_LAPPEND_SCALAR1:
sl@0	1996	opnd = TclGetUInt1AtPtr(pc+1);
sl@0	1997	pcAdjustment = 2;
sl@0	1998	storeFlags = (TCL_LEAVE_ERR_MSG \| TCL_APPEND_VALUE
sl@0	1999	\| TCL_LIST_ELEMENT \| TCL_TRACE_READS);
sl@0	2000	goto doStoreScalar;
sl@0	2001
sl@0	2002	case INST_APPEND_SCALAR4:
sl@0	2003	opnd = TclGetUInt4AtPtr(pc+1);
sl@0	2004	pcAdjustment = 5;
sl@0	2005	storeFlags = (TCL_LEAVE_ERR_MSG \| TCL_APPEND_VALUE);
sl@0	2006	goto doStoreScalar;
sl@0	2007
sl@0	2008	case INST_APPEND_SCALAR1:
sl@0	2009	opnd = TclGetUInt1AtPtr(pc+1);
sl@0	2010	pcAdjustment = 2;
sl@0	2011	storeFlags = (TCL_LEAVE_ERR_MSG \| TCL_APPEND_VALUE);
sl@0	2012	goto doStoreScalar;
sl@0	2013
sl@0	2014	case INST_STORE_SCALAR4:
sl@0	2015	opnd = TclGetUInt4AtPtr(pc+1);
sl@0	2016	pcAdjustment = 5;
sl@0	2017	storeFlags = TCL_LEAVE_ERR_MSG;
sl@0	2018	goto doStoreScalar;
sl@0	2019
sl@0	2020	case INST_STORE_SCALAR1:
sl@0	2021	opnd = TclGetUInt1AtPtr(pc+1);
sl@0	2022	pcAdjustment = 2;
sl@0	2023	storeFlags = TCL_LEAVE_ERR_MSG;
sl@0	2024
sl@0	2025	doStoreScalar:
sl@0	2026	valuePtr = stackPtr[stackTop];
sl@0	2027	varPtr = &(varFramePtr->compiledLocals[opnd]);
sl@0	2028	part1 = varPtr->name;
sl@0	2029	TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
sl@0	2030	while (TclIsVarLink(varPtr)) {
sl@0	2031	varPtr = varPtr->value.linkPtr;
sl@0	2032	}
sl@0	2033	cleanup = 1;
sl@0	2034	arrayPtr = NULL;
sl@0	2035	part2 = NULL;
sl@0	2036
sl@0	2037	doCallPtrSetVar:
sl@0	2038	if ((storeFlags == TCL_LEAVE_ERR_MSG)
sl@0	2039	&& !((varPtr->flags & VAR_IN_HASHTABLE)
sl@0	2040	&& (varPtr->hPtr == NULL))
sl@0	2041	&& (varPtr->tracePtr == NULL)
sl@0	2042	&& (TclIsVarScalar(varPtr)
sl@0	2043	\|\| TclIsVarUndefined(varPtr))
sl@0	2044	&& ((arrayPtr == NULL)
sl@0	2045	\|\| (arrayPtr->tracePtr == NULL))) {
sl@0	2046	/*
sl@0	2047	* No traces, no errors, plain 'set': we can safely inline.
sl@0	2048	* The value will be set to what's requested, so that
sl@0	2049	* the stack top remains pointing to the same Tcl_Obj.
sl@0	2050	*/
sl@0	2051	valuePtr = varPtr->value.objPtr;
sl@0	2052	objResultPtr = stackPtr[stackTop];
sl@0	2053	if (valuePtr != objResultPtr) {
sl@0	2054	if (valuePtr != NULL) {
sl@0	2055	TclDecrRefCount(valuePtr);
sl@0	2056	} else {
sl@0	2057	TclSetVarScalar(varPtr);
sl@0	2058	TclClearVarUndefined(varPtr);
sl@0	2059	}
sl@0	2060	varPtr->value.objPtr = objResultPtr;
sl@0	2061	Tcl_IncrRefCount(objResultPtr);
sl@0	2062	}
sl@0	2063	#ifndef TCL_COMPILE_DEBUG
sl@0	2064	if (*(pc+pcAdjustment) == INST_POP) {
sl@0	2065	NEXT_INST_V((pcAdjustment+1), cleanup, 0);
sl@0	2066	}
sl@0	2067	#else
sl@0	2068	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
sl@0	2069	#endif
sl@0	2070	NEXT_INST_V(pcAdjustment, cleanup, 1);
sl@0	2071	} else {
sl@0	2072	DECACHE_STACK_INFO();
sl@0	2073	objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr,
sl@0	2074	part1, part2, valuePtr, storeFlags);
sl@0	2075	CACHE_STACK_INFO();
sl@0	2076	if (objResultPtr == NULL) {
sl@0	2077	TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
sl@0	2078	result = TCL_ERROR;
sl@0	2079	goto checkForCatch;
sl@0	2080	}
sl@0	2081	}
sl@0	2082	#ifndef TCL_COMPILE_DEBUG
sl@0	2083	if (*(pc+pcAdjustment) == INST_POP) {
sl@0	2084	NEXT_INST_V((pcAdjustment+1), cleanup, 0);
sl@0	2085	}
sl@0	2086	#endif
sl@0	2087	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
sl@0	2088	NEXT_INST_V(pcAdjustment, cleanup, 1);
sl@0	2089
sl@0	2090
sl@0	2091	/*
sl@0	2092	* End of INST_STORE and related instructions.
sl@0	2093	* ---------------------------------------------------------
sl@0	2094	*/
sl@0	2095
sl@0	2096	/*
sl@0	2097	* ---------------------------------------------------------
sl@0	2098	* Start of INST_INCR instructions.
sl@0	2099	*
sl@0	2100	* WARNING: more 'goto' here than your doctor recommended!
sl@0	2101	* The different instructions set the value of some variables
sl@0	2102	* and then jump to somme common execution code.
sl@0	2103	*/
sl@0	2104
sl@0	2105	case INST_INCR_SCALAR1:
sl@0	2106	case INST_INCR_ARRAY1:
sl@0	2107	case INST_INCR_ARRAY_STK:
sl@0	2108	case INST_INCR_SCALAR_STK:
sl@0	2109	case INST_INCR_STK:
sl@0	2110	opnd = TclGetUInt1AtPtr(pc+1);
sl@0	2111	valuePtr = stackPtr[stackTop];
sl@0	2112	if (valuePtr->typePtr == &tclIntType) {
sl@0	2113	i = valuePtr->internalRep.longValue;
sl@0	2114	} else if (valuePtr->typePtr == &tclWideIntType) {
sl@0	2115	TclGetLongFromWide(i,valuePtr);
sl@0	2116	} else {
sl@0	2117	REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
sl@0	2118	if (result != TCL_OK) {
sl@0	2119	TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
sl@0	2120	opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
sl@0	2121	DECACHE_STACK_INFO();
sl@0	2122	Tcl_AddErrorInfo(interp, "\n (reading increment)");
sl@0	2123	CACHE_STACK_INFO();
sl@0	2124	goto checkForCatch;
sl@0	2125	}
sl@0	2126	FORCE_LONG(valuePtr, i, w);
sl@0	2127	}
sl@0	2128	stackTop--;
sl@0	2129	TclDecrRefCount(valuePtr);
sl@0	2130	switch (*pc) {
sl@0	2131	case INST_INCR_SCALAR1:
sl@0	2132	pcAdjustment = 2;
sl@0	2133	goto doIncrScalar;
sl@0	2134	case INST_INCR_ARRAY1:
sl@0	2135	pcAdjustment = 2;
sl@0	2136	goto doIncrArray;
sl@0	2137	default:
sl@0	2138	pcAdjustment = 1;
sl@0	2139	goto doIncrStk;
sl@0	2140	}
sl@0	2141
sl@0	2142	case INST_INCR_ARRAY_STK_IMM:
sl@0	2143	case INST_INCR_SCALAR_STK_IMM:
sl@0	2144	case INST_INCR_STK_IMM:
sl@0	2145	i = TclGetInt1AtPtr(pc+1);
sl@0	2146	pcAdjustment = 2;
sl@0	2147
sl@0	2148	doIncrStk:
sl@0	2149	if ((*pc == INST_INCR_ARRAY_STK_IMM)
sl@0	2150	\|\| (*pc == INST_INCR_ARRAY_STK)) {
sl@0	2151	part2 = TclGetString(stackPtr[stackTop]);
sl@0	2152	objPtr = stackPtr[stackTop - 1];
sl@0	2153	TRACE(("\"%.30s(%.30s)\" (by %ld) => ",
sl@0	2154	O2S(objPtr), part2, i));
sl@0	2155	} else {
sl@0	2156	part2 = NULL;
sl@0	2157	objPtr = stackPtr[stackTop];
sl@0	2158	TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i));
sl@0	2159	}
sl@0	2160	part1 = TclGetString(objPtr);
sl@0	2161
sl@0	2162	varPtr = TclObjLookupVar(interp, objPtr, part2,
sl@0	2163	TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr);
sl@0	2164	if (varPtr == NULL) {
sl@0	2165	DECACHE_STACK_INFO();
sl@0	2166	Tcl_AddObjErrorInfo(interp,
sl@0	2167	"\n (reading value of variable to increment)", -1);
sl@0	2168	CACHE_STACK_INFO();
sl@0	2169	TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
sl@0	2170	result = TCL_ERROR;
sl@0	2171	goto checkForCatch;
sl@0	2172	}
sl@0	2173	cleanup = ((part2 == NULL)? 1 : 2);
sl@0	2174	goto doIncrVar;
sl@0	2175
sl@0	2176	case INST_INCR_ARRAY1_IMM:
sl@0	2177	opnd = TclGetUInt1AtPtr(pc+1);
sl@0	2178	i = TclGetInt1AtPtr(pc+2);
sl@0	2179	pcAdjustment = 3;
sl@0	2180
sl@0	2181	doIncrArray:
sl@0	2182	part2 = TclGetString(stackPtr[stackTop]);
sl@0	2183	arrayPtr = &(varFramePtr->compiledLocals[opnd]);
sl@0	2184	part1 = arrayPtr->name;
sl@0	2185	while (TclIsVarLink(arrayPtr)) {
sl@0	2186	arrayPtr = arrayPtr->value.linkPtr;
sl@0	2187	}
sl@0	2188	TRACE(("%u \"%.30s\" (by %ld) => ",
sl@0	2189	opnd, part2, i));
sl@0	2190	varPtr = TclLookupArrayElement(interp, part1, part2,
sl@0	2191	TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
sl@0	2192	if (varPtr == NULL) {
sl@0	2193	TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
sl@0	2194	result = TCL_ERROR;
sl@0	2195	goto checkForCatch;
sl@0	2196	}
sl@0	2197	cleanup = 1;
sl@0	2198	goto doIncrVar;
sl@0	2199
sl@0	2200	case INST_INCR_SCALAR1_IMM:
sl@0	2201	opnd = TclGetUInt1AtPtr(pc+1);
sl@0	2202	i = TclGetInt1AtPtr(pc+2);
sl@0	2203	pcAdjustment = 3;
sl@0	2204
sl@0	2205	doIncrScalar:
sl@0	2206	varPtr = &(varFramePtr->compiledLocals[opnd]);
sl@0	2207	part1 = varPtr->name;
sl@0	2208	while (TclIsVarLink(varPtr)) {
sl@0	2209	varPtr = varPtr->value.linkPtr;
sl@0	2210	}
sl@0	2211	arrayPtr = NULL;
sl@0	2212	part2 = NULL;
sl@0	2213	cleanup = 0;
sl@0	2214	TRACE(("%u %ld => ", opnd, i));
sl@0	2215
sl@0	2216
sl@0	2217	doIncrVar:
sl@0	2218	objPtr = varPtr->value.objPtr;
sl@0	2219	if (TclIsVarScalar(varPtr)
sl@0	2220	&& !TclIsVarUndefined(varPtr)
sl@0	2221	&& (varPtr->tracePtr == NULL)
sl@0	2222	&& ((arrayPtr == NULL)
sl@0	2223	\|\| (arrayPtr->tracePtr == NULL))
sl@0	2224	&& (objPtr->typePtr == &tclIntType)) {
sl@0	2225	/*
sl@0	2226	* No errors, no traces, the variable already has an
sl@0	2227	* integer value: inline processing.
sl@0	2228	*/
sl@0	2229
sl@0	2230	i += objPtr->internalRep.longValue;
sl@0	2231	if (Tcl_IsShared(objPtr)) {
sl@0	2232	objResultPtr = Tcl_NewLongObj(i);
sl@0	2233	TclDecrRefCount(objPtr);
sl@0	2234	Tcl_IncrRefCount(objResultPtr);
sl@0	2235	varPtr->value.objPtr = objResultPtr;
sl@0	2236	} else {
sl@0	2237	Tcl_SetLongObj(objPtr, i);
sl@0	2238	objResultPtr = objPtr;
sl@0	2239	}
sl@0	2240	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
sl@0	2241	} else {
sl@0	2242	DECACHE_STACK_INFO();
sl@0	2243	objResultPtr = TclPtrIncrVar(interp, varPtr, arrayPtr, part1,
sl@0	2244	part2, i, TCL_LEAVE_ERR_MSG);
sl@0	2245	CACHE_STACK_INFO();
sl@0	2246	if (objResultPtr == NULL) {
sl@0	2247	TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
sl@0	2248	result = TCL_ERROR;
sl@0	2249	goto checkForCatch;
sl@0	2250	}
sl@0	2251	}
sl@0	2252	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
sl@0	2253	#ifndef TCL_COMPILE_DEBUG
sl@0	2254	if (*(pc+pcAdjustment) == INST_POP) {
sl@0	2255	NEXT_INST_V((pcAdjustment+1), cleanup, 0);
sl@0	2256	}
sl@0	2257	#endif
sl@0	2258	NEXT_INST_V(pcAdjustment, cleanup, 1);
sl@0	2259
sl@0	2260	/*
sl@0	2261	* End of INST_INCR instructions.
sl@0	2262	* ---------------------------------------------------------
sl@0	2263	*/
sl@0	2264
sl@0	2265
sl@0	2266	case INST_JUMP1:
sl@0	2267	opnd = TclGetInt1AtPtr(pc+1);
sl@0	2268	TRACE(("%d => new pc %u\n", opnd,
sl@0	2269	(unsigned int)(pc + opnd - codePtr->codeStart)));
sl@0	2270	NEXT_INST_F(opnd, 0, 0);
sl@0	2271
sl@0	2272	case INST_JUMP4:
sl@0	2273	opnd = TclGetInt4AtPtr(pc+1);
sl@0	2274	TRACE(("%d => new pc %u\n", opnd,
sl@0	2275	(unsigned int)(pc + opnd - codePtr->codeStart)));
sl@0	2276	NEXT_INST_F(opnd, 0, 0);
sl@0	2277
sl@0	2278	case INST_JUMP_FALSE4:
sl@0	2279	opnd = 5; /* TRUE */
sl@0	2280	pcAdjustment = TclGetInt4AtPtr(pc+1); /* FALSE */
sl@0	2281	goto doJumpTrue;
sl@0	2282
sl@0	2283	case INST_JUMP_TRUE4:
sl@0	2284	opnd = TclGetInt4AtPtr(pc+1); /* TRUE */
sl@0	2285	pcAdjustment = 5; /* FALSE */
sl@0	2286	goto doJumpTrue;
sl@0	2287
sl@0	2288	case INST_JUMP_FALSE1:
sl@0	2289	opnd = 2; /* TRUE */
sl@0	2290	pcAdjustment = TclGetInt1AtPtr(pc+1); /* FALSE */
sl@0	2291	goto doJumpTrue;
sl@0	2292
sl@0	2293	case INST_JUMP_TRUE1:
sl@0	2294	opnd = TclGetInt1AtPtr(pc+1); /* TRUE */
sl@0	2295	pcAdjustment = 2; /* FALSE */
sl@0	2296
sl@0	2297	doJumpTrue:
sl@0	2298	{
sl@0	2299	int b;
sl@0	2300
sl@0	2301	valuePtr = stackPtr[stackTop];
sl@0	2302	if (valuePtr->typePtr == &tclIntType) {
sl@0	2303	b = (valuePtr->internalRep.longValue != 0);
sl@0	2304	} else if (valuePtr->typePtr == &tclDoubleType) {
sl@0	2305	b = (valuePtr->internalRep.doubleValue != 0.0);
sl@0	2306	} else if (valuePtr->typePtr == &tclWideIntType) {
sl@0	2307	TclGetWide(w,valuePtr);
sl@0	2308	b = (w != W0);
sl@0	2309	} else {
sl@0	2310	result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
sl@0	2311	if (result != TCL_OK) {
sl@0	2312	TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
sl@0	2313	goto checkForCatch;
sl@0	2314	}
sl@0	2315	}
sl@0	2316	#ifndef TCL_COMPILE_DEBUG
sl@0	2317	NEXT_INST_F((b? opnd : pcAdjustment), 1, 0);
sl@0	2318	#else
sl@0	2319	if (b) {
sl@0	2320	if ((pc == INST_JUMP_TRUE1) \|\| (pc == INST_JUMP_TRUE1)) {
sl@0	2321	TRACE(("%d => %.20s true, new pc %u\n", opnd, O2S(valuePtr),
sl@0	2322	(unsigned int)(pc+opnd - codePtr->codeStart)));
sl@0	2323	} else {
sl@0	2324	TRACE(("%d => %.20s true\n", pcAdjustment, O2S(valuePtr)));
sl@0	2325	}
sl@0	2326	NEXT_INST_F(opnd, 1, 0);
sl@0	2327	} else {
sl@0	2328	if ((pc == INST_JUMP_TRUE1) \|\| (pc == INST_JUMP_TRUE1)) {
sl@0	2329	TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr)));
sl@0	2330	} else {
sl@0	2331	opnd = pcAdjustment;
sl@0	2332	TRACE(("%d => %.20s false, new pc %u\n", opnd, O2S(valuePtr),
sl@0	2333	(unsigned int)(pc + opnd - codePtr->codeStart)));
sl@0	2334	}
sl@0	2335	NEXT_INST_F(pcAdjustment, 1, 0);
sl@0	2336	}
sl@0	2337	#endif
sl@0	2338	}
sl@0	2339
sl@0	2340	case INST_LOR:
sl@0	2341	case INST_LAND:
sl@0	2342	{
sl@0	2343	/*
sl@0	2344	* Operands must be boolean or numeric. No int->double
sl@0	2345	* conversions are performed.
sl@0	2346	*/
sl@0	2347
sl@0	2348	int i1, i2;
sl@0	2349	int iResult;
sl@0	2350	char *s;
sl@0	2351	Tcl_ObjType t1Ptr, t2Ptr;
sl@0	2352
sl@0	2353	value2Ptr = stackPtr[stackTop];
sl@0	2354	valuePtr = stackPtr[stackTop - 1];;
sl@0	2355	t1Ptr = valuePtr->typePtr;
sl@0	2356	t2Ptr = value2Ptr->typePtr;
sl@0	2357
sl@0	2358	if ((t1Ptr == &tclIntType) \|\| (t1Ptr == &tclBooleanType)) {
sl@0	2359	i1 = (valuePtr->internalRep.longValue != 0);
sl@0	2360	} else if (t1Ptr == &tclWideIntType) {
sl@0	2361	TclGetWide(w,valuePtr);
sl@0	2362	i1 = (w != W0);
sl@0	2363	} else if (t1Ptr == &tclDoubleType) {
sl@0	2364	i1 = (valuePtr->internalRep.doubleValue != 0.0);
sl@0	2365	} else {
sl@0	2366	s = Tcl_GetStringFromObj(valuePtr, &length);
sl@0	2367	if (TclLooksLikeInt(s, length)) {
sl@0	2368	GET_WIDE_OR_INT(result, valuePtr, i, w);
sl@0	2369	if (valuePtr->typePtr == &tclIntType) {
sl@0	2370	i1 = (i != 0);
sl@0	2371	} else {
sl@0	2372	i1 = (w != W0);
sl@0	2373	}
sl@0	2374	} else {
sl@0	2375	result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
sl@0	2376	valuePtr, &i1);
sl@0	2377	i1 = (i1 != 0);
sl@0	2378	}
sl@0	2379	if (result != TCL_OK) {
sl@0	2380	TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
sl@0	2381	(t1Ptr? t1Ptr->name : "null")));
sl@0	2382	DECACHE_STACK_INFO();
sl@0	2383	IllegalExprOperandType(interp, pc, valuePtr);
sl@0	2384	CACHE_STACK_INFO();
sl@0	2385	goto checkForCatch;
sl@0	2386	}
sl@0	2387	}
sl@0	2388
sl@0	2389	if ((t2Ptr == &tclIntType) \|\| (t2Ptr == &tclBooleanType)) {
sl@0	2390	i2 = (value2Ptr->internalRep.longValue != 0);
sl@0	2391	} else if (t2Ptr == &tclWideIntType) {
sl@0	2392	TclGetWide(w,value2Ptr);
sl@0	2393	i2 = (w != W0);
sl@0	2394	} else if (t2Ptr == &tclDoubleType) {
sl@0	2395	i2 = (value2Ptr->internalRep.doubleValue != 0.0);
sl@0	2396	} else {
sl@0	2397	s = Tcl_GetStringFromObj(value2Ptr, &length);
sl@0	2398	if (TclLooksLikeInt(s, length)) {
sl@0	2399	GET_WIDE_OR_INT(result, value2Ptr, i, w);
sl@0	2400	if (value2Ptr->typePtr == &tclIntType) {
sl@0	2401	i2 = (i != 0);
sl@0	2402	} else {
sl@0	2403	i2 = (w != W0);
sl@0	2404	}
sl@0	2405	} else {
sl@0	2406	result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, value2Ptr, &i2);
sl@0	2407	}
sl@0	2408	if (result != TCL_OK) {
sl@0	2409	TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
sl@0	2410	(t2Ptr? t2Ptr->name : "null")));
sl@0	2411	DECACHE_STACK_INFO();
sl@0	2412	IllegalExprOperandType(interp, pc, value2Ptr);
sl@0	2413	CACHE_STACK_INFO();
sl@0	2414	goto checkForCatch;
sl@0	2415	}
sl@0	2416	}
sl@0	2417
sl@0	2418	/*
sl@0	2419	* Reuse the valuePtr object already on stack if possible.
sl@0	2420	*/
sl@0	2421
sl@0	2422	if (*pc == INST_LOR) {
sl@0	2423	iResult = (i1 \|\| i2);
sl@0	2424	} else {
sl@0	2425	iResult = (i1 && i2);
sl@0	2426	}
sl@0	2427	if (Tcl_IsShared(valuePtr)) {
sl@0	2428	objResultPtr = Tcl_NewLongObj(iResult);
sl@0	2429	TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
sl@0	2430	NEXT_INST_F(1, 2, 1);
sl@0	2431	} else { /* reuse the valuePtr object */
sl@0	2432	TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
sl@0	2433	Tcl_SetLongObj(valuePtr, iResult);
sl@0	2434	NEXT_INST_F(1, 1, 0);
sl@0	2435	}
sl@0	2436	}
sl@0	2437
sl@0	2438	/*
sl@0	2439	* ---------------------------------------------------------
sl@0	2440	* Start of INST_LIST and related instructions.
sl@0	2441	*/
sl@0	2442
sl@0	2443	case INST_LIST:
sl@0	2444	/*
sl@0	2445	* Pop the opnd (objc) top stack elements into a new list obj
sl@0	2446	* and then decrement their ref counts.
sl@0	2447	*/
sl@0	2448
sl@0	2449	opnd = TclGetUInt4AtPtr(pc+1);
sl@0	2450	objResultPtr = Tcl_NewListObj(opnd, &(stackPtr[stackTop - (opnd-1)]));
sl@0	2451	TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
sl@0	2452	NEXT_INST_V(5, opnd, 1);
sl@0	2453
sl@0	2454	case INST_LIST_LENGTH:
sl@0	2455	valuePtr = stackPtr[stackTop];
sl@0	2456
sl@0	2457	result = Tcl_ListObjLength(interp, valuePtr, &length);
sl@0	2458	if (result != TCL_OK) {
sl@0	2459	TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
sl@0	2460	Tcl_GetObjResult(interp));
sl@0	2461	goto checkForCatch;
sl@0	2462	}
sl@0	2463	objResultPtr = Tcl_NewIntObj(length);
sl@0	2464	TRACE(("%.20s => %d\n", O2S(valuePtr), length));
sl@0	2465	NEXT_INST_F(1, 1, 1);
sl@0	2466
sl@0	2467	case INST_LIST_INDEX:
sl@0	2468	/* lindex with objc == 3 */
sl@0	2469
sl@0	2470	/*
sl@0	2471	* Pop the two operands
sl@0	2472	*/
sl@0	2473	value2Ptr = stackPtr[stackTop];
sl@0	2474	valuePtr = stackPtr[stackTop- 1];
sl@0	2475
sl@0	2476	/*
sl@0	2477	* Extract the desired list element
sl@0	2478	*/
sl@0	2479	objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
sl@0	2480	if (objResultPtr == NULL) {
sl@0	2481	TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), O2S(value2Ptr)),
sl@0	2482	Tcl_GetObjResult(interp));
sl@0	2483	result = TCL_ERROR;
sl@0	2484	goto checkForCatch;
sl@0	2485	}
sl@0	2486
sl@0	2487	/*
sl@0	2488	* Stash the list element on the stack
sl@0	2489	*/
sl@0	2490	TRACE(("%.20s %.20s => %s\n",
sl@0	2491	O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr)));
sl@0	2492	NEXT_INST_F(1, 2, -1); /* already has the correct refCount */
sl@0	2493
sl@0	2494	case INST_LIST_INDEX_MULTI:
sl@0	2495	{
sl@0	2496	/*
sl@0	2497	* 'lindex' with multiple index args:
sl@0	2498	*
sl@0	2499	* Determine the count of index args.
sl@0	2500	*/
sl@0	2501
sl@0	2502	int numIdx;
sl@0	2503
sl@0	2504	opnd = TclGetUInt4AtPtr(pc+1);
sl@0	2505	numIdx = opnd-1;
sl@0	2506
sl@0	2507	/*
sl@0	2508	* Do the 'lindex' operation.
sl@0	2509	*/
sl@0	2510	objResultPtr = TclLindexFlat(interp, stackPtr[stackTop - numIdx],
sl@0	2511	numIdx, stackPtr + stackTop - numIdx + 1);
sl@0	2512
sl@0	2513	/*
sl@0	2514	* Check for errors
sl@0	2515	*/
sl@0	2516	if (objResultPtr == NULL) {
sl@0	2517	TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
sl@0	2518	result = TCL_ERROR;
sl@0	2519	goto checkForCatch;
sl@0	2520	}
sl@0	2521
sl@0	2522	/*
sl@0	2523	* Set result
sl@0	2524	*/
sl@0	2525	TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
sl@0	2526	NEXT_INST_V(5, opnd, -1);
sl@0	2527	}
sl@0	2528
sl@0	2529	case INST_LSET_FLAT:
sl@0	2530	{
sl@0	2531	/*
sl@0	2532	* Lset with 3, 5, or more args. Get the number
sl@0	2533	* of index args.
sl@0	2534	*/
sl@0	2535	int numIdx;
sl@0	2536
sl@0	2537	opnd = TclGetUInt4AtPtr( pc + 1 );
sl@0	2538	numIdx = opnd - 2;
sl@0	2539
sl@0	2540	/*
sl@0	2541	* Get the old value of variable, and remove the stack ref.
sl@0	2542	* This is safe because the variable still references the
sl@0	2543	* object; the ref count will never go zero here.
sl@0	2544	*/
sl@0	2545	value2Ptr = POP_OBJECT();
sl@0	2546	TclDecrRefCount(value2Ptr); /* This one should be done here */
sl@0	2547
sl@0	2548	/*
sl@0	2549	* Get the new element value.
sl@0	2550	*/
sl@0	2551	valuePtr = stackPtr[stackTop];
sl@0	2552
sl@0	2553	/*
sl@0	2554	* Compute the new variable value
sl@0	2555	*/
sl@0	2556	objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx,
sl@0	2557	stackPtr + stackTop - numIdx, valuePtr);
sl@0	2558
sl@0	2559
sl@0	2560	/*
sl@0	2561	* Check for errors
sl@0	2562	*/
sl@0	2563	if (objResultPtr == NULL) {
sl@0	2564	TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
sl@0	2565	result = TCL_ERROR;
sl@0	2566	goto checkForCatch;
sl@0	2567	}
sl@0	2568
sl@0	2569	/*
sl@0	2570	* Set result
sl@0	2571	*/
sl@0	2572	TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
sl@0	2573	NEXT_INST_V(5, (numIdx+1), -1);
sl@0	2574	}
sl@0	2575
sl@0	2576	case INST_LSET_LIST:
sl@0	2577	/*
sl@0	2578	* 'lset' with 4 args.
sl@0	2579	*
sl@0	2580	* Get the old value of variable, and remove the stack ref.
sl@0	2581	* This is safe because the variable still references the
sl@0	2582	* object; the ref count will never go zero here.
sl@0	2583	*/
sl@0	2584	objPtr = POP_OBJECT();
sl@0	2585	TclDecrRefCount(objPtr); /* This one should be done here */
sl@0	2586
sl@0	2587	/*
sl@0	2588	* Get the new element value, and the index list
sl@0	2589	*/
sl@0	2590	valuePtr = stackPtr[stackTop];
sl@0	2591	value2Ptr = stackPtr[stackTop - 1];
sl@0	2592
sl@0	2593	/*
sl@0	2594	* Compute the new variable value
sl@0	2595	*/
sl@0	2596	objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr);
sl@0	2597
sl@0	2598	/*
sl@0	2599	* Check for errors
sl@0	2600	*/
sl@0	2601	if (objResultPtr == NULL) {
sl@0	2602	TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)),
sl@0	2603	Tcl_GetObjResult(interp));
sl@0	2604	result = TCL_ERROR;
sl@0	2605	goto checkForCatch;
sl@0	2606	}
sl@0	2607
sl@0	2608	/*
sl@0	2609	* Set result
sl@0	2610	*/
sl@0	2611	TRACE(("=> %s\n", O2S(objResultPtr)));
sl@0	2612	NEXT_INST_F(1, 2, -1);
sl@0	2613
sl@0	2614	/*
sl@0	2615	* End of INST_LIST and related instructions.
sl@0	2616	* ---------------------------------------------------------
sl@0	2617	*/
sl@0	2618
sl@0	2619	case INST_STR_EQ:
sl@0	2620	case INST_STR_NEQ:
sl@0	2621	{
sl@0	2622	/*
sl@0	2623	* String (in)equality check
sl@0	2624	*/
sl@0	2625	int iResult;
sl@0	2626
sl@0	2627	value2Ptr = stackPtr[stackTop];
sl@0	2628	valuePtr = stackPtr[stackTop - 1];
sl@0	2629
sl@0	2630	if (valuePtr == value2Ptr) {
sl@0	2631	/*
sl@0	2632	* On the off-chance that the objects are the same,
sl@0	2633	* we don't really have to think hard about equality.
sl@0	2634	*/
sl@0	2635	iResult = (*pc == INST_STR_EQ);
sl@0	2636	} else {
sl@0	2637	char s1, s2;
sl@0	2638	int s1len, s2len;
sl@0	2639
sl@0	2640	s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
sl@0	2641	s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
sl@0	2642	if (s1len == s2len) {
sl@0	2643	/*
sl@0	2644	* We only need to check (in)equality when
sl@0	2645	* we have equal length strings.
sl@0	2646	*/
sl@0	2647	if (*pc == INST_STR_NEQ) {
sl@0	2648	iResult = (strcmp(s1, s2) != 0);
sl@0	2649	} else {
sl@0	2650	/* INST_STR_EQ */
sl@0	2651	iResult = (strcmp(s1, s2) == 0);
sl@0	2652	}
sl@0	2653	} else {
sl@0	2654	iResult = (*pc == INST_STR_NEQ);
sl@0	2655	}
sl@0	2656	}
sl@0	2657
sl@0	2658	TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
sl@0	2659
sl@0	2660	/*
sl@0	2661	* Peep-hole optimisation: if you're about to jump, do jump
sl@0	2662	* from here.
sl@0	2663	*/
sl@0	2664
sl@0	2665	pc++;
sl@0	2666	#ifndef TCL_COMPILE_DEBUG
sl@0	2667	switch (*pc) {
sl@0	2668	case INST_JUMP_FALSE1:
sl@0	2669	NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
sl@0	2670	case INST_JUMP_TRUE1:
sl@0	2671	NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
sl@0	2672	case INST_JUMP_FALSE4:
sl@0	2673	NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
sl@0	2674	case INST_JUMP_TRUE4:
sl@0	2675	NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
sl@0	2676	}
sl@0	2677	#endif
sl@0	2678	objResultPtr = Tcl_NewIntObj(iResult);
sl@0	2679	NEXT_INST_F(0, 2, 1);
sl@0	2680	}
sl@0	2681
sl@0	2682	case INST_STR_CMP:
sl@0	2683	{
sl@0	2684	/*
sl@0	2685	* String compare
sl@0	2686	*/
sl@0	2687	CONST char s1, s2;
sl@0	2688	int s1len, s2len, iResult;
sl@0	2689
sl@0	2690	value2Ptr = stackPtr[stackTop];
sl@0	2691	valuePtr = stackPtr[stackTop - 1];
sl@0	2692
sl@0	2693	/*
sl@0	2694	* The comparison function should compare up to the
sl@0	2695	* minimum byte length only.
sl@0	2696	*/
sl@0	2697	if (valuePtr == value2Ptr) {
sl@0	2698	/*
sl@0	2699	* In the pure equality case, set lengths too for
sl@0	2700	* the checks below (or we could goto beyond it).
sl@0	2701	*/
sl@0	2702	iResult = s1len = s2len = 0;
sl@0	2703	} else if ((valuePtr->typePtr == &tclByteArrayType)
sl@0	2704	&& (value2Ptr->typePtr == &tclByteArrayType)) {
sl@0	2705	s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len);
sl@0	2706	s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
sl@0	2707	iResult = memcmp(s1, s2,
sl@0	2708	(size_t) ((s1len < s2len) ? s1len : s2len));
sl@0	2709	} else if (((valuePtr->typePtr == &tclStringType)
sl@0	2710	&& (value2Ptr->typePtr == &tclStringType))) {
sl@0	2711	/*
sl@0	2712	* Do a unicode-specific comparison if both of the args are of
sl@0	2713	* String type. If the char length == byte length, we can do a
sl@0	2714	* memcmp. In benchmark testing this proved the most efficient
sl@0	2715	* check between the unicode and string comparison operations.
sl@0	2716	*/
sl@0	2717
sl@0	2718	s1len = Tcl_GetCharLength(valuePtr);
sl@0	2719	s2len = Tcl_GetCharLength(value2Ptr);
sl@0	2720	if ((s1len == valuePtr->length) && (s2len == value2Ptr->length)) {
sl@0	2721	iResult = memcmp(valuePtr->bytes, value2Ptr->bytes,
sl@0	2722	(unsigned) ((s1len < s2len) ? s1len : s2len));
sl@0	2723	} else {
sl@0	2724	iResult = TclUniCharNcmp(Tcl_GetUnicode(valuePtr),
sl@0	2725	Tcl_GetUnicode(value2Ptr),
sl@0	2726	(unsigned) ((s1len < s2len) ? s1len : s2len));
sl@0	2727	}
sl@0	2728	} else {
sl@0	2729	/*
sl@0	2730	* We can't do a simple memcmp in order to handle the
sl@0	2731	* special Tcl \xC0\x80 null encoding for utf-8.
sl@0	2732	*/
sl@0	2733	s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
sl@0	2734	s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
sl@0	2735	iResult = TclpUtfNcmp2(s1, s2,
sl@0	2736	(size_t) ((s1len < s2len) ? s1len : s2len));
sl@0	2737	}
sl@0	2738
sl@0	2739	/*
sl@0	2740	* Make sure only -1,0,1 is returned
sl@0	2741	*/
sl@0	2742	if (iResult == 0) {
sl@0	2743	iResult = s1len - s2len;
sl@0	2744	}
sl@0	2745	if (iResult < 0) {
sl@0	2746	iResult = -1;
sl@0	2747	} else if (iResult > 0) {
sl@0	2748	iResult = 1;
sl@0	2749	}
sl@0	2750
sl@0	2751	objResultPtr = Tcl_NewIntObj(iResult);
sl@0	2752	TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
sl@0	2753	NEXT_INST_F(1, 2, 1);
sl@0	2754	}
sl@0	2755
sl@0	2756	case INST_STR_LEN:
sl@0	2757	{
sl@0	2758	int length1;
sl@0	2759
sl@0	2760	valuePtr = stackPtr[stackTop];
sl@0	2761
sl@0	2762	if (valuePtr->typePtr == &tclByteArrayType) {
sl@0	2763	(void) Tcl_GetByteArrayFromObj(valuePtr, &length1);
sl@0	2764	} else {
sl@0	2765	length1 = Tcl_GetCharLength(valuePtr);
sl@0	2766	}
sl@0	2767	objResultPtr = Tcl_NewIntObj(length1);
sl@0	2768	TRACE(("%.20s => %d\n", O2S(valuePtr), length1));
sl@0	2769	NEXT_INST_F(1, 1, 1);
sl@0	2770	}
sl@0	2771
sl@0	2772	case INST_STR_INDEX:
sl@0	2773	{
sl@0	2774	/*
sl@0	2775	* String compare
sl@0	2776	*/
sl@0	2777	int index;
sl@0	2778	bytes = NULL; /* lint */
sl@0	2779
sl@0	2780	value2Ptr = stackPtr[stackTop];
sl@0	2781	valuePtr = stackPtr[stackTop - 1];
sl@0	2782
sl@0	2783	/*
sl@0	2784	* If we have a ByteArray object, avoid indexing in the
sl@0	2785	* Utf string since the byte array contains one byte per
sl@0	2786	* character. Otherwise, use the Unicode string rep to
sl@0	2787	* get the index'th char.
sl@0	2788	*/
sl@0	2789
sl@0	2790	if (valuePtr->typePtr == &tclByteArrayType) {
sl@0	2791	bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length);
sl@0	2792	} else {
sl@0	2793	/*
sl@0	2794	* Get Unicode char length to calulate what 'end' means.
sl@0	2795	*/
sl@0	2796	length = Tcl_GetCharLength(valuePtr);
sl@0	2797	}
sl@0	2798
sl@0	2799	result = TclGetIntForIndex(interp, value2Ptr, length - 1, &index);
sl@0	2800	if (result != TCL_OK) {
sl@0	2801	goto checkForCatch;
sl@0	2802	}
sl@0	2803
sl@0	2804	if ((index >= 0) && (index < length)) {
sl@0	2805	if (valuePtr->typePtr == &tclByteArrayType) {
sl@0	2806	objResultPtr = Tcl_NewByteArrayObj((unsigned char *)
sl@0	2807	(&bytes[index]), 1);
sl@0	2808	} else if (valuePtr->bytes && length == valuePtr->length) {
sl@0	2809	objResultPtr = Tcl_NewStringObj((CONST char *)
sl@0	2810	(&valuePtr->bytes[index]), 1);
sl@0	2811	} else {
sl@0	2812	char buf[TCL_UTF_MAX];
sl@0	2813	Tcl_UniChar ch;
sl@0	2814
sl@0	2815	ch = Tcl_GetUniChar(valuePtr, index);
sl@0	2816	/*
sl@0	2817	* This could be:
sl@0	2818	* Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch, 1)
sl@0	2819	* but creating the object as a string seems to be
sl@0	2820	* faster in practical use.
sl@0	2821	*/
sl@0	2822	length = Tcl_UniCharToUtf(ch, buf);
sl@0	2823	objResultPtr = Tcl_NewStringObj(buf, length);
sl@0	2824	}
sl@0	2825	} else {
sl@0	2826	TclNewObj(objResultPtr);
sl@0	2827	}
sl@0	2828
sl@0	2829	TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr),
sl@0	2830	O2S(objResultPtr)));
sl@0	2831	NEXT_INST_F(1, 2, 1);
sl@0	2832	}
sl@0	2833
sl@0	2834	case INST_STR_MATCH:
sl@0	2835	{
sl@0	2836	int nocase, match;
sl@0	2837
sl@0	2838	nocase = TclGetInt1AtPtr(pc+1);
sl@0	2839	valuePtr = stackPtr[stackTop]; /* String */
sl@0	2840	value2Ptr = stackPtr[stackTop - 1]; /* Pattern */
sl@0	2841
sl@0	2842	/*
sl@0	2843	* Check that at least one of the objects is Unicode before
sl@0	2844	* promoting both.
sl@0	2845	*/
sl@0	2846
sl@0	2847	if ((valuePtr->typePtr == &tclStringType)
sl@0	2848	\|\| (value2Ptr->typePtr == &tclStringType)) {
sl@0	2849	Tcl_UniChar ustring1, ustring2;
sl@0	2850	int length1, length2;
sl@0	2851
sl@0	2852	ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length1);
sl@0	2853	ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
sl@0	2854	match = TclUniCharMatch(ustring1, length1, ustring2, length2,
sl@0	2855	nocase);
sl@0	2856	} else {
sl@0	2857	match = Tcl_StringCaseMatch(TclGetString(valuePtr),
sl@0	2858	TclGetString(value2Ptr), nocase);
sl@0	2859	}
sl@0	2860
sl@0	2861	/*
sl@0	2862	* Reuse value2Ptr object already on stack if possible.
sl@0	2863	* Adjustment is 2 due to the nocase byte
sl@0	2864	*/
sl@0	2865
sl@0	2866	TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
sl@0	2867	if (Tcl_IsShared(value2Ptr)) {
sl@0	2868	objResultPtr = Tcl_NewIntObj(match);
sl@0	2869	NEXT_INST_F(2, 2, 1);
sl@0	2870	} else { /* reuse the valuePtr object */
sl@0	2871	Tcl_SetIntObj(value2Ptr, match);
sl@0	2872	NEXT_INST_F(2, 1, 0);
sl@0	2873	}
sl@0	2874	}
sl@0	2875
sl@0	2876	case INST_EQ:
sl@0	2877	case INST_NEQ:
sl@0	2878	case INST_LT:
sl@0	2879	case INST_GT:
sl@0	2880	case INST_LE:
sl@0	2881	case INST_GE:
sl@0	2882	{
sl@0	2883	/*
sl@0	2884	* Any type is allowed but the two operands must have the
sl@0	2885	* same type. We will compute value op value2.
sl@0	2886	*/
sl@0	2887
sl@0	2888	Tcl_ObjType t1Ptr, t2Ptr;
sl@0	2889	char s1 = NULL; / Init. avoids compiler warning. */
sl@0	2890	char s2 = NULL; / Init. avoids compiler warning. */
sl@0	2891	long i2 = 0; /* Init. avoids compiler warning. */
sl@0	2892	double d1 = 0.0; /* Init. avoids compiler warning. */
sl@0	2893	double d2 = 0.0; /* Init. avoids compiler warning. */
sl@0	2894	long iResult = 0; /* Init. avoids compiler warning. */
sl@0	2895
sl@0	2896	value2Ptr = stackPtr[stackTop];
sl@0	2897	valuePtr = stackPtr[stackTop - 1];
sl@0	2898
sl@0	2899	/*
sl@0	2900	* Be careful in the equal-object case; 'NaN' isn't supposed
sl@0	2901	* to be equal to even itself. [Bug 761471]
sl@0	2902	*/
sl@0	2903
sl@0	2904	t1Ptr = valuePtr->typePtr;
sl@0	2905	if (valuePtr == value2Ptr) {
sl@0	2906	/*
sl@0	2907	* If we are numeric already, we can proceed to the main
sl@0	2908	* equality check right now. Otherwise, we need to try to
sl@0	2909	* coerce to a numeric type so we can see if we've got a
sl@0	2910	* NaN but haven't parsed it as numeric.
sl@0	2911	*/
sl@0	2912	if (!IS_NUMERIC_TYPE(t1Ptr)) {
sl@0	2913	if (t1Ptr == &tclListType) {
sl@0	2914	int length;
sl@0	2915	/*
sl@0	2916	* Only a list of length 1 can be NaN or such
sl@0	2917	* things.
sl@0	2918	*/
sl@0	2919	(void) Tcl_ListObjLength(NULL, valuePtr, &length);
sl@0	2920	if (length == 1) {
sl@0	2921	goto mustConvertForNaNCheck;
sl@0	2922	}
sl@0	2923	} else {
sl@0	2924	/*
sl@0	2925	* Too bad, we'll have to compute the string and
sl@0	2926	* try the conversion
sl@0	2927	*/
sl@0	2928
sl@0	2929	mustConvertForNaNCheck:
sl@0	2930	s1 = Tcl_GetStringFromObj(valuePtr, &length);
sl@0	2931	if (TclLooksLikeInt(s1, length)) {
sl@0	2932	GET_WIDE_OR_INT(iResult, valuePtr, i, w);
sl@0	2933	} else {
sl@0	2934	(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
sl@0	2935	valuePtr, &d1);
sl@0	2936	}
sl@0	2937	t1Ptr = valuePtr->typePtr;
sl@0	2938	}
sl@0	2939	}
sl@0	2940
sl@0	2941	switch (*pc) {
sl@0	2942	case INST_EQ:
sl@0	2943	case INST_LE:
sl@0	2944	case INST_GE:
sl@0	2945	iResult = !((t1Ptr == &tclDoubleType)
sl@0	2946	&& IS_NAN(valuePtr->internalRep.doubleValue));
sl@0	2947	break;
sl@0	2948	case INST_LT:
sl@0	2949	case INST_GT:
sl@0	2950	iResult = 0;
sl@0	2951	break;
sl@0	2952	case INST_NEQ:
sl@0	2953	iResult = ((t1Ptr == &tclDoubleType)
sl@0	2954	&& IS_NAN(valuePtr->internalRep.doubleValue));
sl@0	2955	break;
sl@0	2956	}
sl@0	2957	goto foundResult;
sl@0	2958	}
sl@0	2959
sl@0	2960	t2Ptr = value2Ptr->typePtr;
sl@0	2961
sl@0	2962	/*
sl@0	2963	* We only want to coerce numeric validation if neither type
sl@0	2964	* is NULL. A NULL type means the arg is essentially an empty
sl@0	2965	* object ("", {} or [list]).
sl@0	2966	*/
sl@0	2967	if (!( (!t1Ptr && !valuePtr->bytes)
sl@0	2968	\|\| (valuePtr->bytes && !valuePtr->length)
sl@0	2969	\|\| (!t2Ptr && !value2Ptr->bytes)
sl@0	2970	\|\| (value2Ptr->bytes && !value2Ptr->length))) {
sl@0	2971	if (!IS_NUMERIC_TYPE(t1Ptr)) {
sl@0	2972	s1 = Tcl_GetStringFromObj(valuePtr, &length);
sl@0	2973	if (TclLooksLikeInt(s1, length)) {
sl@0	2974	GET_WIDE_OR_INT(iResult, valuePtr, i, w);
sl@0	2975	} else {
sl@0	2976	(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
sl@0	2977	valuePtr, &d1);
sl@0	2978	}
sl@0	2979	t1Ptr = valuePtr->typePtr;
sl@0	2980	}
sl@0	2981	if (!IS_NUMERIC_TYPE(t2Ptr)) {
sl@0	2982	s2 = Tcl_GetStringFromObj(value2Ptr, &length);
sl@0	2983	if (TclLooksLikeInt(s2, length)) {
sl@0	2984	GET_WIDE_OR_INT(iResult, value2Ptr, i2, w);
sl@0	2985	} else {
sl@0	2986	(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
sl@0	2987	value2Ptr, &d2);
sl@0	2988	}
sl@0	2989	t2Ptr = value2Ptr->typePtr;
sl@0	2990	}
sl@0	2991	}
sl@0	2992	if (!IS_NUMERIC_TYPE(t1Ptr) \|\| !IS_NUMERIC_TYPE(t2Ptr)) {
sl@0	2993	/*
sl@0	2994	* One operand is not numeric. Compare as strings. NOTE:
sl@0	2995	* strcmp is not correct for \x00 < \x01, but that is
sl@0	2996	* unlikely to occur here. We could use the TclUtfNCmp2
sl@0	2997	* to handle this.
sl@0	2998	*/
sl@0	2999	int s1len, s2len;
sl@0	3000	s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
sl@0	3001	s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
sl@0	3002	switch (*pc) {
sl@0	3003	case INST_EQ:
sl@0	3004	if (s1len == s2len) {
sl@0	3005	iResult = (strcmp(s1, s2) == 0);
sl@0	3006	} else {
sl@0	3007	iResult = 0;
sl@0	3008	}
sl@0	3009	break;
sl@0	3010	case INST_NEQ:
sl@0	3011	if (s1len == s2len) {
sl@0	3012	iResult = (strcmp(s1, s2) != 0);
sl@0	3013	} else {
sl@0	3014	iResult = 1;
sl@0	3015	}
sl@0	3016	break;
sl@0	3017	case INST_LT:
sl@0	3018	iResult = (strcmp(s1, s2) < 0);
sl@0	3019	break;
sl@0	3020	case INST_GT:
sl@0	3021	iResult = (strcmp(s1, s2) > 0);
sl@0	3022	break;
sl@0	3023	case INST_LE:
sl@0	3024	iResult = (strcmp(s1, s2) <= 0);
sl@0	3025	break;
sl@0	3026	case INST_GE:
sl@0	3027	iResult = (strcmp(s1, s2) >= 0);
sl@0	3028	break;
sl@0	3029	}
sl@0	3030	} else if ((t1Ptr == &tclDoubleType)
sl@0	3031	\|\| (t2Ptr == &tclDoubleType)) {
sl@0	3032	/*
sl@0	3033	* Compare as doubles.
sl@0	3034	*/
sl@0	3035	if (t1Ptr == &tclDoubleType) {
sl@0	3036	d1 = valuePtr->internalRep.doubleValue;
sl@0	3037	GET_DOUBLE_VALUE(d2, value2Ptr, t2Ptr);
sl@0	3038	} else { /* t1Ptr is integer, t2Ptr is double */
sl@0	3039	GET_DOUBLE_VALUE(d1, valuePtr, t1Ptr);
sl@0	3040	d2 = value2Ptr->internalRep.doubleValue;
sl@0	3041	}
sl@0	3042	switch (*pc) {
sl@0	3043	case INST_EQ:
sl@0	3044	iResult = d1 == d2;
sl@0	3045	break;
sl@0	3046	case INST_NEQ:
sl@0	3047	iResult = d1 != d2;
sl@0	3048	break;
sl@0	3049	case INST_LT:
sl@0	3050	iResult = d1 < d2;
sl@0	3051	break;
sl@0	3052	case INST_GT:
sl@0	3053	iResult = d1 > d2;
sl@0	3054	break;
sl@0	3055	case INST_LE:
sl@0	3056	iResult = d1 <= d2;
sl@0	3057	break;
sl@0	3058	case INST_GE:
sl@0	3059	iResult = d1 >= d2;
sl@0	3060	break;
sl@0	3061	}
sl@0	3062	} else if ((t1Ptr == &tclWideIntType)
sl@0	3063	\|\| (t2Ptr == &tclWideIntType)) {
sl@0	3064	Tcl_WideInt w2;
sl@0	3065	/*
sl@0	3066	* Compare as wide ints (neither are doubles)
sl@0	3067	*/
sl@0	3068	if (t1Ptr == &tclIntType) {
sl@0	3069	w = Tcl_LongAsWide(valuePtr->internalRep.longValue);
sl@0	3070	TclGetWide(w2,value2Ptr);
sl@0	3071	} else if (t2Ptr == &tclIntType) {
sl@0	3072	TclGetWide(w,valuePtr);
sl@0	3073	w2 = Tcl_LongAsWide(value2Ptr->internalRep.longValue);
sl@0	3074	} else {
sl@0	3075	TclGetWide(w,valuePtr);
sl@0	3076	TclGetWide(w2,value2Ptr);
sl@0	3077	}
sl@0	3078	switch (*pc) {
sl@0	3079	case INST_EQ:
sl@0	3080	iResult = w == w2;
sl@0	3081	break;
sl@0	3082	case INST_NEQ:
sl@0	3083	iResult = w != w2;
sl@0	3084	break;
sl@0	3085	case INST_LT:
sl@0	3086	iResult = w < w2;
sl@0	3087	break;
sl@0	3088	case INST_GT:
sl@0	3089	iResult = w > w2;
sl@0	3090	break;
sl@0	3091	case INST_LE:
sl@0	3092	iResult = w <= w2;
sl@0	3093	break;
sl@0	3094	case INST_GE:
sl@0	3095	iResult = w >= w2;
sl@0	3096	break;
sl@0	3097	}
sl@0	3098	} else {
sl@0	3099	/*
sl@0	3100	* Compare as ints.
sl@0	3101	*/
sl@0	3102	i = valuePtr->internalRep.longValue;
sl@0	3103	i2 = value2Ptr->internalRep.longValue;
sl@0	3104	switch (*pc) {
sl@0	3105	case INST_EQ:
sl@0	3106	iResult = i == i2;
sl@0	3107	break;
sl@0	3108	case INST_NEQ:
sl@0	3109	iResult = i != i2;
sl@0	3110	break;
sl@0	3111	case INST_LT:
sl@0	3112	iResult = i < i2;
sl@0	3113	break;
sl@0	3114	case INST_GT:
sl@0	3115	iResult = i > i2;
sl@0	3116	break;
sl@0	3117	case INST_LE:
sl@0	3118	iResult = i <= i2;
sl@0	3119	break;
sl@0	3120	case INST_GE:
sl@0	3121	iResult = i >= i2;
sl@0	3122	break;
sl@0	3123	}
sl@0	3124	}
sl@0	3125
sl@0	3126	foundResult:
sl@0	3127	TRACE(("%.20s %.20s => %ld\n", O2S(valuePtr), O2S(value2Ptr), iResult));
sl@0	3128
sl@0	3129	/*
sl@0	3130	* Peep-hole optimisation: if you're about to jump, do jump
sl@0	3131	* from here.
sl@0	3132	*/
sl@0	3133
sl@0	3134	pc++;
sl@0	3135	#ifndef TCL_COMPILE_DEBUG
sl@0	3136	switch (*pc) {
sl@0	3137	case INST_JUMP_FALSE1:
sl@0	3138	NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
sl@0	3139	case INST_JUMP_TRUE1:
sl@0	3140	NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
sl@0	3141	case INST_JUMP_FALSE4:
sl@0	3142	NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
sl@0	3143	case INST_JUMP_TRUE4:
sl@0	3144	NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
sl@0	3145	}
sl@0	3146	#endif
sl@0	3147	objResultPtr = Tcl_NewIntObj(iResult);
sl@0	3148	NEXT_INST_F(0, 2, 1);
sl@0	3149	}
sl@0	3150
sl@0	3151	case INST_MOD:
sl@0	3152	case INST_LSHIFT:
sl@0	3153	case INST_RSHIFT:
sl@0	3154	case INST_BITOR:
sl@0	3155	case INST_BITXOR:
sl@0	3156	case INST_BITAND:
sl@0	3157	{
sl@0	3158	/*
sl@0	3159	* Only integers are allowed. We compute value op value2.
sl@0	3160	*/
sl@0	3161
sl@0	3162	long i2 = 0, rem, negative;
sl@0	3163	long iResult = 0; /* Init. avoids compiler warning. */
sl@0	3164	Tcl_WideInt w2, wResult = W0;
sl@0	3165	int doWide = 0;
sl@0	3166
sl@0	3167	value2Ptr = stackPtr[stackTop];
sl@0	3168	valuePtr = stackPtr[stackTop - 1];
sl@0	3169	if (valuePtr->typePtr == &tclIntType) {
sl@0	3170	i = valuePtr->internalRep.longValue;
sl@0	3171	} else if (valuePtr->typePtr == &tclWideIntType) {
sl@0	3172	TclGetWide(w,valuePtr);
sl@0	3173	} else { /* try to convert to int */
sl@0	3174	REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
sl@0	3175	if (result != TCL_OK) {
sl@0	3176	TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
sl@0	3177	O2S(valuePtr), O2S(value2Ptr),
sl@0	3178	(valuePtr->typePtr?
sl@0	3179	valuePtr->typePtr->name : "null")));
sl@0	3180	DECACHE_STACK_INFO();
sl@0	3181	IllegalExprOperandType(interp, pc, valuePtr);
sl@0	3182	CACHE_STACK_INFO();
sl@0	3183	goto checkForCatch;
sl@0	3184	}
sl@0	3185	}
sl@0	3186	if (value2Ptr->typePtr == &tclIntType) {
sl@0	3187	i2 = value2Ptr->internalRep.longValue;
sl@0	3188	} else if (value2Ptr->typePtr == &tclWideIntType) {
sl@0	3189	TclGetWide(w2,value2Ptr);
sl@0	3190	} else {
sl@0	3191	REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2);
sl@0	3192	if (result != TCL_OK) {
sl@0	3193	TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
sl@0	3194	O2S(valuePtr), O2S(value2Ptr),
sl@0	3195	(value2Ptr->typePtr?
sl@0	3196	value2Ptr->typePtr->name : "null")));
sl@0	3197	DECACHE_STACK_INFO();
sl@0	3198	IllegalExprOperandType(interp, pc, value2Ptr);
sl@0	3199	CACHE_STACK_INFO();
sl@0	3200	goto checkForCatch;
sl@0	3201	}
sl@0	3202	}
sl@0	3203
sl@0	3204	switch (*pc) {
sl@0	3205	case INST_MOD:
sl@0	3206	/*
sl@0	3207	* This code is tricky: C doesn't guarantee much about
sl@0	3208	* the quotient or remainder, but Tcl does. The
sl@0	3209	* remainder always has the same sign as the divisor and
sl@0	3210	* a smaller absolute value.
sl@0	3211	*/
sl@0	3212	if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) {
sl@0	3213	if (valuePtr->typePtr == &tclIntType) {
sl@0	3214	TRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2));
sl@0	3215	} else {
sl@0	3216	TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
sl@0	3217	}
sl@0	3218	goto divideByZero;
sl@0	3219	}
sl@0	3220	if (value2Ptr->typePtr == &tclIntType && i2 == 0) {
sl@0	3221	if (valuePtr->typePtr == &tclIntType) {
sl@0	3222	TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
sl@0	3223	} else {
sl@0	3224	TRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2));
sl@0	3225	}
sl@0	3226	goto divideByZero;
sl@0	3227	}
sl@0	3228	negative = 0;
sl@0	3229	if (valuePtr->typePtr == &tclWideIntType
sl@0	3230	\|\| value2Ptr->typePtr == &tclWideIntType) {
sl@0	3231	Tcl_WideInt wRemainder;
sl@0	3232	/*
sl@0	3233	* Promote to wide
sl@0	3234	*/
sl@0	3235	if (valuePtr->typePtr == &tclIntType) {
sl@0	3236	w = Tcl_LongAsWide(i);
sl@0	3237	} else if (value2Ptr->typePtr == &tclIntType) {
sl@0	3238	w2 = Tcl_LongAsWide(i2);
sl@0	3239	}
sl@0	3240	if (w2 < 0) {
sl@0	3241	w2 = -w2;
sl@0	3242	w = -w;
sl@0	3243	negative = 1;
sl@0	3244	}
sl@0	3245	wRemainder = w % w2;
sl@0	3246	if (wRemainder < 0) {
sl@0	3247	wRemainder += w2;
sl@0	3248	}
sl@0	3249	if (negative) {
sl@0	3250	wRemainder = -wRemainder;
sl@0	3251	}
sl@0	3252	wResult = wRemainder;
sl@0	3253	doWide = 1;
sl@0	3254	break;
sl@0	3255	}
sl@0	3256	if (i2 < 0) {
sl@0	3257	i2 = -i2;
sl@0	3258	i = -i;
sl@0	3259	negative = 1;
sl@0	3260	}
sl@0	3261	rem = i % i2;
sl@0	3262	if (rem < 0) {
sl@0	3263	rem += i2;
sl@0	3264	}
sl@0	3265	if (negative) {
sl@0	3266	rem = -rem;
sl@0	3267	}
sl@0	3268	iResult = rem;
sl@0	3269	break;
sl@0	3270	case INST_LSHIFT:
sl@0	3271	/*
sl@0	3272	* Shifts are never usefully 64-bits wide!
sl@0	3273	*/
sl@0	3274	FORCE_LONG(value2Ptr, i2, w2);
sl@0	3275	if (valuePtr->typePtr == &tclWideIntType) {
sl@0	3276	#ifdef TCL_COMPILE_DEBUG
sl@0	3277	w2 = Tcl_LongAsWide(i2);
sl@0	3278	#endif /* TCL_COMPILE_DEBUG */
sl@0	3279	wResult = w;
sl@0	3280	/*
sl@0	3281	* Shift in steps when the shift gets large to prevent
sl@0	3282	* annoying compiler/processor bugs. [Bug 868467]
sl@0	3283	*/
sl@0	3284	if (i2 >= 64) {
sl@0	3285	wResult = Tcl_LongAsWide(0);
sl@0	3286	} else if (i2 > 60) {
sl@0	3287	wResult = w << 30;
sl@0	3288	wResult <<= 30;
sl@0	3289	wResult <<= i2-60;
sl@0	3290	} else if (i2 > 30) {
sl@0	3291	wResult = w << 30;
sl@0	3292	wResult <<= i2-30;
sl@0	3293	} else {
sl@0	3294	wResult = w << i2;
sl@0	3295	}
sl@0	3296	doWide = 1;
sl@0	3297	break;
sl@0	3298	}
sl@0	3299	/*
sl@0	3300	* Shift in steps when the shift gets large to prevent
sl@0	3301	* annoying compiler/processor bugs. [Bug 868467]
sl@0	3302	*/
sl@0	3303	if (i2 >= 64) {
sl@0	3304	iResult = 0;
sl@0	3305	} else if (i2 > 60) {
sl@0	3306	iResult = i << 30;
sl@0	3307	iResult <<= 30;
sl@0	3308	iResult <<= i2-60;
sl@0	3309	} else if (i2 > 30) {
sl@0	3310	iResult = i << 30;
sl@0	3311	iResult <<= i2-30;
sl@0	3312	} else {
sl@0	3313	iResult = i << i2;
sl@0	3314	}
sl@0	3315	break;
sl@0	3316	case INST_RSHIFT:
sl@0	3317	/*
sl@0	3318	* The following code is a bit tricky: it ensures that
sl@0	3319	* right shifts propagate the sign bit even on machines
sl@0	3320	* where ">>" won't do it by default.
sl@0	3321	*/
sl@0	3322	/*
sl@0	3323	* Shifts are never usefully 64-bits wide!
sl@0	3324	*/
sl@0	3325	FORCE_LONG(value2Ptr, i2, w2);
sl@0	3326	if (valuePtr->typePtr == &tclWideIntType) {
sl@0	3327	#ifdef TCL_COMPILE_DEBUG
sl@0	3328	w2 = Tcl_LongAsWide(i2);
sl@0	3329	#endif /* TCL_COMPILE_DEBUG */
sl@0	3330	if (w < 0) {
sl@0	3331	wResult = ~w;
sl@0	3332	} else {
sl@0	3333	wResult = w;
sl@0	3334	}
sl@0	3335	/*
sl@0	3336	* Shift in steps when the shift gets large to prevent
sl@0	3337	* annoying compiler/processor bugs. [Bug 868467]
sl@0	3338	*/
sl@0	3339	if (i2 >= 64) {
sl@0	3340	wResult = Tcl_LongAsWide(0);
sl@0	3341	} else if (i2 > 60) {
sl@0	3342	wResult >>= 30;
sl@0	3343	wResult >>= 30;
sl@0	3344	wResult >>= i2-60;
sl@0	3345	} else if (i2 > 30) {
sl@0	3346	wResult >>= 30;
sl@0	3347	wResult >>= i2-30;
sl@0	3348	} else {
sl@0	3349	wResult >>= i2;
sl@0	3350	}
sl@0	3351	if (w < 0) {
sl@0	3352	wResult = ~wResult;
sl@0	3353	}
sl@0	3354	doWide = 1;
sl@0	3355	break;
sl@0	3356	}
sl@0	3357	if (i < 0) {
sl@0	3358	iResult = ~i;
sl@0	3359	} else {
sl@0	3360	iResult = i;
sl@0	3361	}
sl@0	3362	/*
sl@0	3363	* Shift in steps when the shift gets large to prevent
sl@0	3364	* annoying compiler/processor bugs. [Bug 868467]
sl@0	3365	*/
sl@0	3366	if (i2 >= 64) {
sl@0	3367	iResult = 0;
sl@0	3368	} else if (i2 > 60) {
sl@0	3369	iResult >>= 30;
sl@0	3370	iResult >>= 30;
sl@0	3371	iResult >>= i2-60;
sl@0	3372	} else if (i2 > 30) {
sl@0	3373	iResult >>= 30;
sl@0	3374	iResult >>= i2-30;
sl@0	3375	} else {
sl@0	3376	iResult >>= i2;
sl@0	3377	}
sl@0	3378	if (i < 0) {
sl@0	3379	iResult = ~iResult;
sl@0	3380	}
sl@0	3381	break;
sl@0	3382	case INST_BITOR:
sl@0	3383	if (valuePtr->typePtr == &tclWideIntType
sl@0	3384	\|\| value2Ptr->typePtr == &tclWideIntType) {
sl@0	3385	/*
sl@0	3386	* Promote to wide
sl@0	3387	*/
sl@0	3388	if (valuePtr->typePtr == &tclIntType) {
sl@0	3389	w = Tcl_LongAsWide(i);
sl@0	3390	} else if (value2Ptr->typePtr == &tclIntType) {
sl@0	3391	w2 = Tcl_LongAsWide(i2);
sl@0	3392	}
sl@0	3393	wResult = w \| w2;
sl@0	3394	doWide = 1;
sl@0	3395	break;
sl@0	3396	}
sl@0	3397	iResult = i \| i2;
sl@0	3398	break;
sl@0	3399	case INST_BITXOR:
sl@0	3400	if (valuePtr->typePtr == &tclWideIntType
sl@0	3401	\|\| value2Ptr->typePtr == &tclWideIntType) {
sl@0	3402	/*
sl@0	3403	* Promote to wide
sl@0	3404	*/
sl@0	3405	if (valuePtr->typePtr == &tclIntType) {
sl@0	3406	w = Tcl_LongAsWide(i);
sl@0	3407	} else if (value2Ptr->typePtr == &tclIntType) {
sl@0	3408	w2 = Tcl_LongAsWide(i2);
sl@0	3409	}
sl@0	3410	wResult = w ^ w2;
sl@0	3411	doWide = 1;
sl@0	3412	break;
sl@0	3413	}
sl@0	3414	iResult = i ^ i2;
sl@0	3415	break;
sl@0	3416	case INST_BITAND:
sl@0	3417	if (valuePtr->typePtr == &tclWideIntType
sl@0	3418	\|\| value2Ptr->typePtr == &tclWideIntType) {
sl@0	3419	/*
sl@0	3420	* Promote to wide
sl@0	3421	*/
sl@0	3422	if (valuePtr->typePtr == &tclIntType) {
sl@0	3423	w = Tcl_LongAsWide(i);
sl@0	3424	} else if (value2Ptr->typePtr == &tclIntType) {
sl@0	3425	w2 = Tcl_LongAsWide(i2);
sl@0	3426	}
sl@0	3427	wResult = w & w2;
sl@0	3428	doWide = 1;
sl@0	3429	break;
sl@0	3430	}
sl@0	3431	iResult = i & i2;
sl@0	3432	break;
sl@0	3433	}
sl@0	3434
sl@0	3435	/*
sl@0	3436	* Reuse the valuePtr object already on stack if possible.
sl@0	3437	*/
sl@0	3438
sl@0	3439	if (Tcl_IsShared(valuePtr)) {
sl@0	3440	if (doWide) {
sl@0	3441	objResultPtr = Tcl_NewWideIntObj(wResult);
sl@0	3442	TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
sl@0	3443	} else {
sl@0	3444	objResultPtr = Tcl_NewLongObj(iResult);
sl@0	3445	TRACE(("%ld %ld => %ld\n", i, i2, iResult));
sl@0	3446	}
sl@0	3447	NEXT_INST_F(1, 2, 1);
sl@0	3448	} else { /* reuse the valuePtr object */
sl@0	3449	if (doWide) {
sl@0	3450	TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
sl@0	3451	Tcl_SetWideIntObj(valuePtr, wResult);
sl@0	3452	} else {
sl@0	3453	TRACE(("%ld %ld => %ld\n", i, i2, iResult));
sl@0	3454	Tcl_SetLongObj(valuePtr, iResult);
sl@0	3455	}
sl@0	3456	NEXT_INST_F(1, 1, 0);
sl@0	3457	}
sl@0	3458	}
sl@0	3459
sl@0	3460	case INST_ADD:
sl@0	3461	case INST_SUB:
sl@0	3462	case INST_MULT:
sl@0	3463	case INST_DIV:
sl@0	3464	{
sl@0	3465	/*
sl@0	3466	* Operands must be numeric and ints get converted to floats
sl@0	3467	* if necessary. We compute value op value2.
sl@0	3468	*/
sl@0	3469
sl@0	3470	Tcl_ObjType t1Ptr, t2Ptr;
sl@0	3471	long i2 = 0, quot, rem; /* Init. avoids compiler warning. */
sl@0	3472	double d1, d2;
sl@0	3473	long iResult = 0; /* Init. avoids compiler warning. */
sl@0	3474	double dResult = 0.0; /* Init. avoids compiler warning. */
sl@0	3475	int doDouble = 0; /* 1 if doing floating arithmetic */
sl@0	3476	Tcl_WideInt w2, wquot, wrem;
sl@0	3477	Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */
sl@0	3478	int doWide = 0; /* 1 if doing wide arithmetic. */
sl@0	3479
sl@0	3480	value2Ptr = stackPtr[stackTop];
sl@0	3481	valuePtr = stackPtr[stackTop - 1];
sl@0	3482	t1Ptr = valuePtr->typePtr;
sl@0	3483	t2Ptr = value2Ptr->typePtr;
sl@0	3484
sl@0	3485	if (t1Ptr == &tclIntType) {
sl@0	3486	i = valuePtr->internalRep.longValue;
sl@0	3487	} else if (t1Ptr == &tclWideIntType) {
sl@0	3488	TclGetWide(w,valuePtr);
sl@0	3489	} else if ((t1Ptr == &tclDoubleType)
sl@0	3490	&& (valuePtr->bytes == NULL)) {
sl@0	3491	/*
sl@0	3492	* We can only use the internal rep directly if there is
sl@0	3493	* no string rep. Otherwise the string rep might actually
sl@0	3494	* look like an integer, which is preferred.
sl@0	3495	*/
sl@0	3496
sl@0	3497	d1 = valuePtr->internalRep.doubleValue;
sl@0	3498	} else {
sl@0	3499	char *s = Tcl_GetStringFromObj(valuePtr, &length);
sl@0	3500	if (TclLooksLikeInt(s, length)) {
sl@0	3501	GET_WIDE_OR_INT(result, valuePtr, i, w);
sl@0	3502	} else {
sl@0	3503	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
sl@0	3504	valuePtr, &d1);
sl@0	3505	}
sl@0	3506	if (result != TCL_OK) {
sl@0	3507	TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
sl@0	3508	s, O2S(valuePtr),
sl@0	3509	(valuePtr->typePtr?
sl@0	3510	valuePtr->typePtr->name : "null")));
sl@0	3511	DECACHE_STACK_INFO();
sl@0	3512	IllegalExprOperandType(interp, pc, valuePtr);
sl@0	3513	CACHE_STACK_INFO();
sl@0	3514	goto checkForCatch;
sl@0	3515	}
sl@0	3516	t1Ptr = valuePtr->typePtr;
sl@0	3517	}
sl@0	3518
sl@0	3519	if (t2Ptr == &tclIntType) {
sl@0	3520	i2 = value2Ptr->internalRep.longValue;
sl@0	3521	} else if (t2Ptr == &tclWideIntType) {
sl@0	3522	TclGetWide(w2,value2Ptr);
sl@0	3523	} else if ((t2Ptr == &tclDoubleType)
sl@0	3524	&& (value2Ptr->bytes == NULL)) {
sl@0	3525	/*
sl@0	3526	* We can only use the internal rep directly if there is
sl@0	3527	* no string rep. Otherwise the string rep might actually
sl@0	3528	* look like an integer, which is preferred.
sl@0	3529	*/
sl@0	3530
sl@0	3531	d2 = value2Ptr->internalRep.doubleValue;
sl@0	3532	} else {
sl@0	3533	char *s = Tcl_GetStringFromObj(value2Ptr, &length);
sl@0	3534	if (TclLooksLikeInt(s, length)) {
sl@0	3535	GET_WIDE_OR_INT(result, value2Ptr, i2, w2);
sl@0	3536	} else {
sl@0	3537	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
sl@0	3538	value2Ptr, &d2);
sl@0	3539	}
sl@0	3540	if (result != TCL_OK) {
sl@0	3541	TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
sl@0	3542	O2S(value2Ptr), s,
sl@0	3543	(value2Ptr->typePtr?
sl@0	3544	value2Ptr->typePtr->name : "null")));
sl@0	3545	DECACHE_STACK_INFO();
sl@0	3546	IllegalExprOperandType(interp, pc, value2Ptr);
sl@0	3547	CACHE_STACK_INFO();
sl@0	3548	goto checkForCatch;
sl@0	3549	}
sl@0	3550	t2Ptr = value2Ptr->typePtr;
sl@0	3551	}
sl@0	3552
sl@0	3553	if ((t1Ptr == &tclDoubleType) \|\| (t2Ptr == &tclDoubleType)) {
sl@0	3554	/*
sl@0	3555	* Do double arithmetic.
sl@0	3556	*/
sl@0	3557	doDouble = 1;
sl@0	3558	if (t1Ptr == &tclIntType) {
sl@0	3559	d1 = i; /* promote value 1 to double */
sl@0	3560	} else if (t2Ptr == &tclIntType) {
sl@0	3561	d2 = i2; /* promote value 2 to double */
sl@0	3562	} else if (t1Ptr == &tclWideIntType) {
sl@0	3563	d1 = Tcl_WideAsDouble(w);
sl@0	3564	} else if (t2Ptr == &tclWideIntType) {
sl@0	3565	d2 = Tcl_WideAsDouble(w2);
sl@0	3566	}
sl@0	3567	switch (*pc) {
sl@0	3568	case INST_ADD:
sl@0	3569	dResult = d1 + d2;
sl@0	3570	break;
sl@0	3571	case INST_SUB:
sl@0	3572	dResult = d1 - d2;
sl@0	3573	break;
sl@0	3574	case INST_MULT:
sl@0	3575	dResult = d1 * d2;
sl@0	3576	break;
sl@0	3577	case INST_DIV:
sl@0	3578	if (d2 == 0.0) {
sl@0	3579	TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
sl@0	3580	goto divideByZero;
sl@0	3581	}
sl@0	3582	dResult = d1 / d2;
sl@0	3583	break;
sl@0	3584	}
sl@0	3585
sl@0	3586	/*
sl@0	3587	* Check now for IEEE floating-point error.
sl@0	3588	*/
sl@0	3589
sl@0	3590	if (IS_NAN(dResult) \|\| IS_INF(dResult)) {
sl@0	3591	TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
sl@0	3592	O2S(valuePtr), O2S(value2Ptr)));
sl@0	3593	DECACHE_STACK_INFO();
sl@0	3594	TclExprFloatError(interp, dResult);
sl@0	3595	CACHE_STACK_INFO();
sl@0	3596	result = TCL_ERROR;
sl@0	3597	goto checkForCatch;
sl@0	3598	}
sl@0	3599	} else if ((t1Ptr == &tclWideIntType)
sl@0	3600	\|\| (t2Ptr == &tclWideIntType)) {
sl@0	3601	/*
sl@0	3602	* Do wide integer arithmetic.
sl@0	3603	*/
sl@0	3604	doWide = 1;
sl@0	3605	if (t1Ptr == &tclIntType) {
sl@0	3606	w = Tcl_LongAsWide(i);
sl@0	3607	} else if (t2Ptr == &tclIntType) {
sl@0	3608	w2 = Tcl_LongAsWide(i2);
sl@0	3609	}
sl@0	3610	switch (*pc) {
sl@0	3611	case INST_ADD:
sl@0	3612	wResult = w + w2;
sl@0	3613	break;
sl@0	3614	case INST_SUB:
sl@0	3615	wResult = w - w2;
sl@0	3616	break;
sl@0	3617	case INST_MULT:
sl@0	3618	wResult = w * w2;
sl@0	3619	break;
sl@0	3620	case INST_DIV:
sl@0	3621	/*
sl@0	3622	* This code is tricky: C doesn't guarantee much
sl@0	3623	* about the quotient or remainder, but Tcl does.
sl@0	3624	* The remainder always has the same sign as the
sl@0	3625	* divisor and a smaller absolute value.
sl@0	3626	*/
sl@0	3627	if (w2 == W0) {
sl@0	3628	TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
sl@0	3629	goto divideByZero;
sl@0	3630	}
sl@0	3631	if (w2 < 0) {
sl@0	3632	w2 = -w2;
sl@0	3633	w = -w;
sl@0	3634	}
sl@0	3635	wquot = w / w2;
sl@0	3636	wrem = w % w2;
sl@0	3637	if (wrem < W0) {
sl@0	3638	wquot -= 1;
sl@0	3639	}
sl@0	3640	wResult = wquot;
sl@0	3641	break;
sl@0	3642	}
sl@0	3643	} else {
sl@0	3644	/*
sl@0	3645	* Do integer arithmetic.
sl@0	3646	*/
sl@0	3647	switch (*pc) {
sl@0	3648	case INST_ADD:
sl@0	3649	iResult = i + i2;
sl@0	3650	break;
sl@0	3651	case INST_SUB:
sl@0	3652	iResult = i - i2;
sl@0	3653	break;
sl@0	3654	case INST_MULT:
sl@0	3655	iResult = i * i2;
sl@0	3656	break;
sl@0	3657	case INST_DIV:
sl@0	3658	/*
sl@0	3659	* This code is tricky: C doesn't guarantee much
sl@0	3660	* about the quotient or remainder, but Tcl does.
sl@0	3661	* The remainder always has the same sign as the
sl@0	3662	* divisor and a smaller absolute value.
sl@0	3663	*/
sl@0	3664	if (i2 == 0) {
sl@0	3665	TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
sl@0	3666	goto divideByZero;
sl@0	3667	}
sl@0	3668	if (i2 < 0) {
sl@0	3669	i2 = -i2;
sl@0	3670	i = -i;
sl@0	3671	}
sl@0	3672	quot = i / i2;
sl@0	3673	rem = i % i2;
sl@0	3674	if (rem < 0) {
sl@0	3675	quot -= 1;
sl@0	3676	}
sl@0	3677	iResult = quot;
sl@0	3678	break;
sl@0	3679	}
sl@0	3680	}
sl@0	3681
sl@0	3682	/*
sl@0	3683	* Reuse the valuePtr object already on stack if possible.
sl@0	3684	*/
sl@0	3685
sl@0	3686	if (Tcl_IsShared(valuePtr)) {
sl@0	3687	if (doDouble) {
sl@0	3688	objResultPtr = Tcl_NewDoubleObj(dResult);
sl@0	3689	TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
sl@0	3690	} else if (doWide) {
sl@0	3691	objResultPtr = Tcl_NewWideIntObj(wResult);
sl@0	3692	TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
sl@0	3693	} else {
sl@0	3694	objResultPtr = Tcl_NewLongObj(iResult);
sl@0	3695	TRACE(("%ld %ld => %ld\n", i, i2, iResult));
sl@0	3696	}
sl@0	3697	NEXT_INST_F(1, 2, 1);
sl@0	3698	} else { /* reuse the valuePtr object */
sl@0	3699	if (doDouble) { /* NB: stack top is off by 1 */
sl@0	3700	TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
sl@0	3701	Tcl_SetDoubleObj(valuePtr, dResult);
sl@0	3702	} else if (doWide) {
sl@0	3703	TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
sl@0	3704	Tcl_SetWideIntObj(valuePtr, wResult);
sl@0	3705	} else {
sl@0	3706	TRACE(("%ld %ld => %ld\n", i, i2, iResult));
sl@0	3707	Tcl_SetLongObj(valuePtr, iResult);
sl@0	3708	}
sl@0	3709	NEXT_INST_F(1, 1, 0);
sl@0	3710	}
sl@0	3711	}
sl@0	3712
sl@0	3713	case INST_UPLUS:
sl@0	3714	{
sl@0	3715	/*
sl@0	3716	* Operand must be numeric.
sl@0	3717	*/
sl@0	3718
sl@0	3719	double d;
sl@0	3720	Tcl_ObjType *tPtr;
sl@0	3721
sl@0	3722	valuePtr = stackPtr[stackTop];
sl@0	3723	tPtr = valuePtr->typePtr;
sl@0	3724	if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
sl@0	3725	\|\| (valuePtr->bytes != NULL))) {
sl@0	3726	char *s = Tcl_GetStringFromObj(valuePtr, &length);
sl@0	3727	if (TclLooksLikeInt(s, length)) {
sl@0	3728	GET_WIDE_OR_INT(result, valuePtr, i, w);
sl@0	3729	} else {
sl@0	3730	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
sl@0	3731	}
sl@0	3732	if (result != TCL_OK) {
sl@0	3733	TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
sl@0	3734	s, (tPtr? tPtr->name : "null")));
sl@0	3735	DECACHE_STACK_INFO();
sl@0	3736	IllegalExprOperandType(interp, pc, valuePtr);
sl@0	3737	CACHE_STACK_INFO();
sl@0	3738	goto checkForCatch;
sl@0	3739	}
sl@0	3740	tPtr = valuePtr->typePtr;
sl@0	3741	}
sl@0	3742
sl@0	3743	/*
sl@0	3744	* Ensure that the operand's string rep is the same as the
sl@0	3745	* formatted version of its internal rep. This makes sure
sl@0	3746	* that "expr +000123" yields "83", not "000123". We
sl@0	3747	* implement this by _discarding_ the string rep since we
sl@0	3748	* know it will be regenerated, if needed later, by
sl@0	3749	* formatting the internal rep's value.
sl@0	3750	*/
sl@0	3751
sl@0	3752	if (Tcl_IsShared(valuePtr)) {
sl@0	3753	if (tPtr == &tclIntType) {
sl@0	3754	i = valuePtr->internalRep.longValue;
sl@0	3755	objResultPtr = Tcl_NewLongObj(i);
sl@0	3756	} else if (tPtr == &tclWideIntType) {
sl@0	3757	TclGetWide(w,valuePtr);
sl@0	3758	objResultPtr = Tcl_NewWideIntObj(w);
sl@0	3759	} else {
sl@0	3760	d = valuePtr->internalRep.doubleValue;
sl@0	3761	objResultPtr = Tcl_NewDoubleObj(d);
sl@0	3762	}
sl@0	3763	TRACE_WITH_OBJ(("%s => ", O2S(objResultPtr)), objResultPtr);
sl@0	3764	NEXT_INST_F(1, 1, 1);
sl@0	3765	} else {
sl@0	3766	Tcl_InvalidateStringRep(valuePtr);
sl@0	3767	TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);
sl@0	3768	NEXT_INST_F(1, 0, 0);
sl@0	3769	}
sl@0	3770	}
sl@0	3771
sl@0	3772	case INST_UMINUS:
sl@0	3773	case INST_LNOT:
sl@0	3774	{
sl@0	3775	/*
sl@0	3776	* The operand must be numeric or a boolean string as
sl@0	3777	* accepted by Tcl_GetBooleanFromObj(). If the operand
sl@0	3778	* object is unshared modify it directly, otherwise
sl@0	3779	* create a copy to modify: this is "copy on write".
sl@0	3780	* Free any old string representation since it is now
sl@0	3781	* invalid.
sl@0	3782	*/
sl@0	3783
sl@0	3784	double d;
sl@0	3785	int boolvar;
sl@0	3786	Tcl_ObjType *tPtr;
sl@0	3787
sl@0	3788	valuePtr = stackPtr[stackTop];
sl@0	3789	tPtr = valuePtr->typePtr;
sl@0	3790	if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
sl@0	3791	\|\| (valuePtr->bytes != NULL))) {
sl@0	3792	if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) {
sl@0	3793	valuePtr->typePtr = &tclIntType;
sl@0	3794	} else {
sl@0	3795	char *s = Tcl_GetStringFromObj(valuePtr, &length);
sl@0	3796	if (TclLooksLikeInt(s, length)) {
sl@0	3797	GET_WIDE_OR_INT(result, valuePtr, i, w);
sl@0	3798	} else {
sl@0	3799	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
sl@0	3800	valuePtr, &d);
sl@0	3801	}
sl@0	3802	if (result == TCL_ERROR && *pc == INST_LNOT) {
sl@0	3803	result = Tcl_GetBooleanFromObj((Tcl_Interp *)NULL,
sl@0	3804	valuePtr, &boolvar);
sl@0	3805	i = (long)boolvar; /* i is long, not int! */
sl@0	3806	}
sl@0	3807	if (result != TCL_OK) {
sl@0	3808	TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
sl@0	3809	s, (tPtr? tPtr->name : "null")));
sl@0	3810	DECACHE_STACK_INFO();
sl@0	3811	IllegalExprOperandType(interp, pc, valuePtr);
sl@0	3812	CACHE_STACK_INFO();
sl@0	3813	goto checkForCatch;
sl@0	3814	}
sl@0	3815	}
sl@0	3816	tPtr = valuePtr->typePtr;
sl@0	3817	}
sl@0	3818
sl@0	3819	if (Tcl_IsShared(valuePtr)) {
sl@0	3820	/*
sl@0	3821	* Create a new object.
sl@0	3822	*/
sl@0	3823	if ((tPtr == &tclIntType) \|\| (tPtr == &tclBooleanType)) {
sl@0	3824	i = valuePtr->internalRep.longValue;
sl@0	3825	objResultPtr = Tcl_NewLongObj(
sl@0	3826	(*pc == INST_UMINUS)? -i : !i);
sl@0	3827	TRACE_WITH_OBJ(("%ld => ", i), objResultPtr);
sl@0	3828	} else if (tPtr == &tclWideIntType) {
sl@0	3829	TclGetWide(w,valuePtr);
sl@0	3830	if (*pc == INST_UMINUS) {
sl@0	3831	objResultPtr = Tcl_NewWideIntObj(-w);
sl@0	3832	} else {
sl@0	3833	objResultPtr = Tcl_NewLongObj(w == W0);
sl@0	3834	}
sl@0	3835	TRACE_WITH_OBJ((LLD" => ", w), objResultPtr);
sl@0	3836	} else {
sl@0	3837	d = valuePtr->internalRep.doubleValue;
sl@0	3838	if (*pc == INST_UMINUS) {
sl@0	3839	objResultPtr = Tcl_NewDoubleObj(-d);
sl@0	3840	} else {
sl@0	3841	/*
sl@0	3842	* Should be able to use "!d", but apparently
sl@0	3843	* some compilers can't handle it.
sl@0	3844	*/
sl@0	3845	objResultPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
sl@0	3846	}
sl@0	3847	TRACE_WITH_OBJ(("%.6g => ", d), objResultPtr);
sl@0	3848	}
sl@0	3849	NEXT_INST_F(1, 1, 1);
sl@0	3850	} else {
sl@0	3851	/*
sl@0	3852	* valuePtr is unshared. Modify it directly.
sl@0	3853	*/
sl@0	3854	if ((tPtr == &tclIntType) \|\| (tPtr == &tclBooleanType)) {
sl@0	3855	i = valuePtr->internalRep.longValue;
sl@0	3856	Tcl_SetLongObj(valuePtr,
sl@0	3857	(*pc == INST_UMINUS)? -i : !i);
sl@0	3858	TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
sl@0	3859	} else if (tPtr == &tclWideIntType) {
sl@0	3860	TclGetWide(w,valuePtr);
sl@0	3861	if (*pc == INST_UMINUS) {
sl@0	3862	Tcl_SetWideIntObj(valuePtr, -w);
sl@0	3863	} else {
sl@0	3864	Tcl_SetLongObj(valuePtr, w == W0);
sl@0	3865	}
sl@0	3866	TRACE_WITH_OBJ((LLD" => ", w), valuePtr);
sl@0	3867	} else {
sl@0	3868	d = valuePtr->internalRep.doubleValue;
sl@0	3869	if (*pc == INST_UMINUS) {
sl@0	3870	Tcl_SetDoubleObj(valuePtr, -d);
sl@0	3871	} else {
sl@0	3872	/*
sl@0	3873	* Should be able to use "!d", but apparently
sl@0	3874	* some compilers can't handle it.
sl@0	3875	*/
sl@0	3876	Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
sl@0	3877	}
sl@0	3878	TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
sl@0	3879	}
sl@0	3880	NEXT_INST_F(1, 0, 0);
sl@0	3881	}
sl@0	3882	}
sl@0	3883
sl@0	3884	case INST_BITNOT:
sl@0	3885	{
sl@0	3886	/*
sl@0	3887	* The operand must be an integer. If the operand object is
sl@0	3888	* unshared modify it directly, otherwise modify a copy.
sl@0	3889	* Free any old string representation since it is now
sl@0	3890	* invalid.
sl@0	3891	*/
sl@0	3892
sl@0	3893	Tcl_ObjType *tPtr;
sl@0	3894
sl@0	3895	valuePtr = stackPtr[stackTop];
sl@0	3896	tPtr = valuePtr->typePtr;
sl@0	3897	if (!IS_INTEGER_TYPE(tPtr)) {
sl@0	3898	REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
sl@0	3899	if (result != TCL_OK) { /* try to convert to double */
sl@0	3900	TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
sl@0	3901	O2S(valuePtr), (tPtr? tPtr->name : "null")));
sl@0	3902	DECACHE_STACK_INFO();
sl@0	3903	IllegalExprOperandType(interp, pc, valuePtr);
sl@0	3904	CACHE_STACK_INFO();
sl@0	3905	goto checkForCatch;
sl@0	3906	}
sl@0	3907	}
sl@0	3908
sl@0	3909	if (valuePtr->typePtr == &tclWideIntType) {
sl@0	3910	TclGetWide(w,valuePtr);
sl@0	3911	if (Tcl_IsShared(valuePtr)) {
sl@0	3912	objResultPtr = Tcl_NewWideIntObj(~w);
sl@0	3913	TRACE(("0x%llx => (%llu)\n", w, ~w));
sl@0	3914	NEXT_INST_F(1, 1, 1);
sl@0	3915	} else {
sl@0	3916	/*
sl@0	3917	* valuePtr is unshared. Modify it directly.
sl@0	3918	*/
sl@0	3919	Tcl_SetWideIntObj(valuePtr, ~w);
sl@0	3920	TRACE(("0x%llx => (%llu)\n", w, ~w));
sl@0	3921	NEXT_INST_F(1, 0, 0);
sl@0	3922	}
sl@0	3923	} else {
sl@0	3924	i = valuePtr->internalRep.longValue;
sl@0	3925	if (Tcl_IsShared(valuePtr)) {
sl@0	3926	objResultPtr = Tcl_NewLongObj(~i);
sl@0	3927	TRACE(("0x%lx => (%lu)\n", i, ~i));
sl@0	3928	NEXT_INST_F(1, 1, 1);
sl@0	3929	} else {
sl@0	3930	/*
sl@0	3931	* valuePtr is unshared. Modify it directly.
sl@0	3932	*/
sl@0	3933	Tcl_SetLongObj(valuePtr, ~i);
sl@0	3934	TRACE(("0x%lx => (%lu)\n", i, ~i));
sl@0	3935	NEXT_INST_F(1, 0, 0);
sl@0	3936	}
sl@0	3937	}
sl@0	3938	}
sl@0	3939
sl@0	3940	case INST_CALL_BUILTIN_FUNC1:
sl@0	3941	opnd = TclGetUInt1AtPtr(pc+1);
sl@0	3942	{
sl@0	3943	/*
sl@0	3944	* Call one of the built-in Tcl math functions.
sl@0	3945	*/
sl@0	3946
sl@0	3947	BuiltinFunc *mathFuncPtr;
sl@0	3948
sl@0	3949	if ((opnd < 0) \|\| (opnd > LAST_BUILTIN_FUNC)) {
sl@0	3950	TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
sl@0	3951	panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
sl@0	3952	}
sl@0	3953	mathFuncPtr = &(tclBuiltinFuncTable[opnd]);
sl@0	3954	DECACHE_STACK_INFO();
sl@0	3955	result = (*mathFuncPtr->proc)(interp, eePtr,
sl@0	3956	mathFuncPtr->clientData);
sl@0	3957	CACHE_STACK_INFO();
sl@0	3958	if (result != TCL_OK) {
sl@0	3959	goto checkForCatch;
sl@0	3960	}
sl@0	3961	TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]);
sl@0	3962	}
sl@0	3963	NEXT_INST_F(2, 0, 0);
sl@0	3964
sl@0	3965	case INST_CALL_FUNC1:
sl@0	3966	opnd = TclGetUInt1AtPtr(pc+1);
sl@0	3967	{
sl@0	3968	/*
sl@0	3969	* Call a non-builtin Tcl math function previously
sl@0	3970	* registered by a call to Tcl_CreateMathFunc.
sl@0	3971	*/
sl@0	3972
sl@0	3973	int objc = opnd; /* Number of arguments. The function name
sl@0	3974	* is the 0-th argument. */
sl@0	3975	Tcl_Obj *objv; / The array of arguments. The function
sl@0	3976	* name is objv[0]. */
sl@0	3977
sl@0	3978	objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */
sl@0	3979	DECACHE_STACK_INFO();
sl@0	3980	result = ExprCallMathFunc(interp, eePtr, objc, objv);
sl@0	3981	CACHE_STACK_INFO();
sl@0	3982	if (result != TCL_OK) {
sl@0	3983	goto checkForCatch;
sl@0	3984	}
sl@0	3985	TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]);
sl@0	3986	}
sl@0	3987	NEXT_INST_F(2, 0, 0);
sl@0	3988
sl@0	3989	case INST_TRY_CVT_TO_NUMERIC:
sl@0	3990	{
sl@0	3991	/*
sl@0	3992	* Try to convert the topmost stack object to an int or
sl@0	3993	* double object. This is done in order to support Tcl's
sl@0	3994	* policy of interpreting operands if at all possible as
sl@0	3995	* first integers, else floating-point numbers.
sl@0	3996	*/
sl@0	3997
sl@0	3998	double d;
sl@0	3999	char *s;
sl@0	4000	Tcl_ObjType *tPtr;
sl@0	4001	int converted, needNew;
sl@0	4002
sl@0	4003	valuePtr = stackPtr[stackTop];
sl@0	4004	tPtr = valuePtr->typePtr;
sl@0	4005	converted = 0;
sl@0	4006	if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
sl@0	4007	\|\| (valuePtr->bytes != NULL))) {
sl@0	4008	if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) {
sl@0	4009	valuePtr->typePtr = &tclIntType;
sl@0	4010	converted = 1;
sl@0	4011	} else {
sl@0	4012	s = Tcl_GetStringFromObj(valuePtr, &length);
sl@0	4013	if (TclLooksLikeInt(s, length)) {
sl@0	4014	GET_WIDE_OR_INT(result, valuePtr, i, w);
sl@0	4015	} else {
sl@0	4016	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
sl@0	4017	valuePtr, &d);
sl@0	4018	}
sl@0	4019	if (result == TCL_OK) {
sl@0	4020	converted = 1;
sl@0	4021	}
sl@0	4022	result = TCL_OK; /* reset the result variable */
sl@0	4023	}
sl@0	4024	tPtr = valuePtr->typePtr;
sl@0	4025	}
sl@0	4026
sl@0	4027	/*
sl@0	4028	* Ensure that the topmost stack object, if numeric, has a
sl@0	4029	* string rep the same as the formatted version of its
sl@0	4030	* internal rep. This is used, e.g., to make sure that "expr
sl@0	4031	* {0001}" yields "1", not "0001". We implement this by
sl@0	4032	* _discarding_ the string rep since we know it will be
sl@0	4033	* regenerated, if needed later, by formatting the internal
sl@0	4034	* rep's value. Also check if there has been an IEEE
sl@0	4035	* floating point error.
sl@0	4036	*/
sl@0	4037
sl@0	4038	objResultPtr = valuePtr;
sl@0	4039	needNew = 0;
sl@0	4040	if (IS_NUMERIC_TYPE(tPtr)) {
sl@0	4041	if (Tcl_IsShared(valuePtr)) {
sl@0	4042	if (valuePtr->bytes != NULL) {
sl@0	4043	/*
sl@0	4044	* We only need to make a copy of the object
sl@0	4045	* when it already had a string rep
sl@0	4046	*/
sl@0	4047	needNew = 1;
sl@0	4048	if (tPtr == &tclIntType) {
sl@0	4049	i = valuePtr->internalRep.longValue;
sl@0	4050	objResultPtr = Tcl_NewLongObj(i);
sl@0	4051	} else if (tPtr == &tclWideIntType) {
sl@0	4052	TclGetWide(w,valuePtr);
sl@0	4053	objResultPtr = Tcl_NewWideIntObj(w);
sl@0	4054	} else {
sl@0	4055	d = valuePtr->internalRep.doubleValue;
sl@0	4056	objResultPtr = Tcl_NewDoubleObj(d);
sl@0	4057	}
sl@0	4058	tPtr = objResultPtr->typePtr;
sl@0	4059	}
sl@0	4060	} else {
sl@0	4061	Tcl_InvalidateStringRep(valuePtr);
sl@0	4062	}
sl@0	4063
sl@0	4064	if (tPtr == &tclDoubleType) {
sl@0	4065	d = objResultPtr->internalRep.doubleValue;
sl@0	4066	if (IS_NAN(d) \|\| IS_INF(d)) {
sl@0	4067	TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
sl@0	4068	O2S(objResultPtr)));
sl@0	4069	DECACHE_STACK_INFO();
sl@0	4070	TclExprFloatError(interp, d);
sl@0	4071	CACHE_STACK_INFO();
sl@0	4072	result = TCL_ERROR;
sl@0	4073	goto checkForCatch;
sl@0	4074	}
sl@0	4075	}
sl@0	4076	converted = converted; /* lint, converted not used. */
sl@0	4077	TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr),
sl@0	4078	(converted? "converted" : "not converted"),
sl@0	4079	(needNew? "new Tcl_Obj" : "same Tcl_Obj")));
sl@0	4080	} else {
sl@0	4081	TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
sl@0	4082	}
sl@0	4083	if (needNew) {
sl@0	4084	NEXT_INST_F(1, 1, 1);
sl@0	4085	} else {
sl@0	4086	NEXT_INST_F(1, 0, 0);
sl@0	4087	}
sl@0	4088	}
sl@0	4089
sl@0	4090	case INST_BREAK:
sl@0	4091	DECACHE_STACK_INFO();
sl@0	4092	Tcl_ResetResult(interp);
sl@0	4093	CACHE_STACK_INFO();
sl@0	4094	result = TCL_BREAK;
sl@0	4095	cleanup = 0;
sl@0	4096	goto processExceptionReturn;
sl@0	4097
sl@0	4098	case INST_CONTINUE:
sl@0	4099	DECACHE_STACK_INFO();
sl@0	4100	Tcl_ResetResult(interp);
sl@0	4101	CACHE_STACK_INFO();
sl@0	4102	result = TCL_CONTINUE;
sl@0	4103	cleanup = 0;
sl@0	4104	goto processExceptionReturn;
sl@0	4105
sl@0	4106	case INST_FOREACH_START4:
sl@0	4107	opnd = TclGetUInt4AtPtr(pc+1);
sl@0	4108	{
sl@0	4109	/*
sl@0	4110	* Initialize the temporary local var that holds the count
sl@0	4111	* of the number of iterations of the loop body to -1.
sl@0	4112	*/
sl@0	4113
sl@0	4114	ForeachInfo infoPtr = (ForeachInfo )
sl@0	4115	codePtr->auxDataArrayPtr[opnd].clientData;
sl@0	4116	int iterTmpIndex = infoPtr->loopCtTemp;
sl@0	4117	Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
sl@0	4118	Var *iterVarPtr = &(compiledLocals[iterTmpIndex]);
sl@0	4119	Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr;
sl@0	4120
sl@0	4121	if (oldValuePtr == NULL) {
sl@0	4122	iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
sl@0	4123	Tcl_IncrRefCount(iterVarPtr->value.objPtr);
sl@0	4124	} else {
sl@0	4125	Tcl_SetLongObj(oldValuePtr, -1);
sl@0	4126	}
sl@0	4127	TclSetVarScalar(iterVarPtr);
sl@0	4128	TclClearVarUndefined(iterVarPtr);
sl@0	4129	TRACE(("%u => loop iter count temp %d\n",
sl@0	4130	opnd, iterTmpIndex));
sl@0	4131	}
sl@0	4132
sl@0	4133	#ifndef TCL_COMPILE_DEBUG
sl@0	4134	/*
sl@0	4135	* Remark that the compiler ALWAYS sets INST_FOREACH_STEP4
sl@0	4136	* immediately after INST_FOREACH_START4 - let us just fall
sl@0	4137	* through instead of jumping back to the top.
sl@0	4138	*/
sl@0	4139
sl@0	4140	pc += 5;
sl@0	4141	#else
sl@0	4142	NEXT_INST_F(5, 0, 0);
sl@0	4143	#endif
sl@0	4144	case INST_FOREACH_STEP4:
sl@0	4145	opnd = TclGetUInt4AtPtr(pc+1);
sl@0	4146	{
sl@0	4147	/*
sl@0	4148	* "Step" a foreach loop (i.e., begin its next iteration) by
sl@0	4149	* assigning the next value list element to each loop var.
sl@0	4150	*/
sl@0	4151
sl@0	4152	ForeachInfo infoPtr = (ForeachInfo )
sl@0	4153	codePtr->auxDataArrayPtr[opnd].clientData;
sl@0	4154	ForeachVarList *varListPtr;
sl@0	4155	int numLists = infoPtr->numLists;
sl@0	4156	Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
sl@0	4157	Tcl_Obj *listPtr;
sl@0	4158	Var iterVarPtr, listVarPtr;
sl@0	4159	int iterNum, listTmpIndex, listLen, numVars;
sl@0	4160	int varIndex, valIndex, continueLoop, j;
sl@0	4161
sl@0	4162	/*
sl@0	4163	* Increment the temp holding the loop iteration number.
sl@0	4164	*/
sl@0	4165
sl@0	4166	iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
sl@0	4167	valuePtr = iterVarPtr->value.objPtr;
sl@0	4168	iterNum = (valuePtr->internalRep.longValue + 1);
sl@0	4169	Tcl_SetLongObj(valuePtr, iterNum);
sl@0	4170
sl@0	4171	/*
sl@0	4172	* Check whether all value lists are exhausted and we should
sl@0	4173	* stop the loop.
sl@0	4174	*/
sl@0	4175
sl@0	4176	continueLoop = 0;
sl@0	4177	listTmpIndex = infoPtr->firstValueTemp;
sl@0	4178	for (i = 0; i < numLists; i++) {
sl@0	4179	varListPtr = infoPtr->varLists[i];
sl@0	4180	numVars = varListPtr->numVars;
sl@0	4181
sl@0	4182	listVarPtr = &(compiledLocals[listTmpIndex]);
sl@0	4183	listPtr = listVarPtr->value.objPtr;
sl@0	4184	result = Tcl_ListObjLength(interp, listPtr, &listLen);
sl@0	4185	if (result != TCL_OK) {
sl@0	4186	TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
sl@0	4187	opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));
sl@0	4188	goto checkForCatch;
sl@0	4189	}
sl@0	4190	if (listLen > (iterNum * numVars)) {
sl@0	4191	continueLoop = 1;
sl@0	4192	}
sl@0	4193	listTmpIndex++;
sl@0	4194	}
sl@0	4195
sl@0	4196	/*
sl@0	4197	* If some var in some var list still has a remaining list
sl@0	4198	* element iterate one more time. Assign to var the next
sl@0	4199	* element from its value list. We already checked above
sl@0	4200	* that each list temp holds a valid list object.
sl@0	4201	*/
sl@0	4202
sl@0	4203	if (continueLoop) {
sl@0	4204	listTmpIndex = infoPtr->firstValueTemp;
sl@0	4205	for (i = 0; i < numLists; i++) {
sl@0	4206	varListPtr = infoPtr->varLists[i];
sl@0	4207	numVars = varListPtr->numVars;
sl@0	4208
sl@0	4209	listVarPtr = &(compiledLocals[listTmpIndex]);
sl@0	4210	listPtr = listVarPtr->value.objPtr;
sl@0	4211
sl@0	4212	valIndex = (iterNum * numVars);
sl@0	4213	for (j = 0; j < numVars; j++) {
sl@0	4214	Tcl_Obj **elements;
sl@0	4215
sl@0	4216	/*
sl@0	4217	* The call to TclPtrSetVar might shimmer listPtr,
sl@0	4218	* so re-fetch pointers every iteration for safety.
sl@0	4219	* See test foreach-10.1.
sl@0	4220	*/
sl@0	4221
sl@0	4222	Tcl_ListObjGetElements(NULL, listPtr,
sl@0	4223	&listLen, &elements);
sl@0	4224	if (valIndex >= listLen) {
sl@0	4225	TclNewObj(valuePtr);
sl@0	4226	} else {
sl@0	4227	valuePtr = elements[valIndex];
sl@0	4228	}
sl@0	4229
sl@0	4230	varIndex = varListPtr->varIndexes[j];
sl@0	4231	varPtr = &(varFramePtr->compiledLocals[varIndex]);
sl@0	4232	part1 = varPtr->name;
sl@0	4233	while (TclIsVarLink(varPtr)) {
sl@0	4234	varPtr = varPtr->value.linkPtr;
sl@0	4235	}
sl@0	4236	if (!((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL))
sl@0	4237	&& (varPtr->tracePtr == NULL)
sl@0	4238	&& (TclIsVarScalar(varPtr) \|\| TclIsVarUndefined(varPtr))) {
sl@0	4239	value2Ptr = varPtr->value.objPtr;
sl@0	4240	if (valuePtr != value2Ptr) {
sl@0	4241	if (value2Ptr != NULL) {
sl@0	4242	TclDecrRefCount(value2Ptr);
sl@0	4243	} else {
sl@0	4244	TclSetVarScalar(varPtr);
sl@0	4245	TclClearVarUndefined(varPtr);
sl@0	4246	}
sl@0	4247	varPtr->value.objPtr = valuePtr;
sl@0	4248	Tcl_IncrRefCount(valuePtr);
sl@0	4249	}
sl@0	4250	} else {
sl@0	4251	DECACHE_STACK_INFO();
sl@0	4252	Tcl_IncrRefCount(valuePtr);
sl@0	4253	value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1,
sl@0	4254	NULL, valuePtr, TCL_LEAVE_ERR_MSG);
sl@0	4255	TclDecrRefCount(valuePtr);
sl@0	4256	CACHE_STACK_INFO();
sl@0	4257	if (value2Ptr == NULL) {
sl@0	4258	TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
sl@0	4259	opnd, varIndex),
sl@0	4260	Tcl_GetObjResult(interp));
sl@0	4261	result = TCL_ERROR;
sl@0	4262	goto checkForCatch;
sl@0	4263	}
sl@0	4264	}
sl@0	4265	valIndex++;
sl@0	4266	}
sl@0	4267	listTmpIndex++;
sl@0	4268	}
sl@0	4269	}
sl@0	4270	TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists,
sl@0	4271	iterNum, (continueLoop? "continue" : "exit")));
sl@0	4272
sl@0	4273	/*
sl@0	4274	* Run-time peep-hole optimisation: the compiler ALWAYS follows
sl@0	4275	* INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that
sl@0	4276	* instruction and jump direct from here.
sl@0	4277	*/
sl@0	4278
sl@0	4279	pc += 5;
sl@0	4280	if (*pc == INST_JUMP_FALSE1) {
sl@0	4281	NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0);
sl@0	4282	} else {
sl@0	4283	NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
sl@0	4284	}
sl@0	4285	}
sl@0	4286
sl@0	4287	case INST_BEGIN_CATCH4:
sl@0	4288	/*
sl@0	4289	* Record start of the catch command with exception range index
sl@0	4290	* equal to the operand. Push the current stack depth onto the
sl@0	4291	* special catch stack.
sl@0	4292	*/
sl@0	4293	catchStackPtr[++catchTop] = stackTop;
sl@0	4294	TRACE(("%u => catchTop=%d, stackTop=%d\n",
sl@0	4295	TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
sl@0	4296	NEXT_INST_F(5, 0, 0);
sl@0	4297
sl@0	4298	case INST_END_CATCH:
sl@0	4299	catchTop--;
sl@0	4300	result = TCL_OK;
sl@0	4301	TRACE(("=> catchTop=%d\n", catchTop));
sl@0	4302	NEXT_INST_F(1, 0, 0);
sl@0	4303
sl@0	4304	case INST_PUSH_RESULT:
sl@0	4305	objResultPtr = Tcl_GetObjResult(interp);
sl@0	4306	TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
sl@0	4307
sl@0	4308	/*
sl@0	4309	* See the comments at INST_INVOKE_STK
sl@0	4310	*/
sl@0	4311	{
sl@0	4312	Tcl_Obj *newObjResultPtr;
sl@0	4313	TclNewObj(newObjResultPtr);
sl@0	4314	Tcl_IncrRefCount(newObjResultPtr);
sl@0	4315	iPtr->objResultPtr = newObjResultPtr;
sl@0	4316	}
sl@0	4317
sl@0	4318	NEXT_INST_F(1, 0, -1);
sl@0	4319
sl@0	4320	case INST_PUSH_RETURN_CODE:
sl@0	4321	objResultPtr = Tcl_NewLongObj(result);
sl@0	4322	TRACE(("=> %u\n", result));
sl@0	4323	NEXT_INST_F(1, 0, 1);
sl@0	4324
sl@0	4325	default:
sl@0	4326	panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
sl@0	4327	} /* end of switch on opCode */
sl@0	4328
sl@0	4329	/*
sl@0	4330	* Division by zero in an expression. Control only reaches this
sl@0	4331	* point by "goto divideByZero".
sl@0	4332	*/
sl@0	4333
sl@0	4334	divideByZero:
sl@0	4335	DECACHE_STACK_INFO();
sl@0	4336	Tcl_ResetResult(interp);
sl@0	4337	Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
sl@0	4338	Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
sl@0	4339	(char *) NULL);
sl@0	4340	CACHE_STACK_INFO();
sl@0	4341
sl@0	4342	result = TCL_ERROR;
sl@0	4343	goto checkForCatch;
sl@0	4344
sl@0	4345	/*
sl@0	4346	* An external evaluation (INST_INVOKE or INST_EVAL) returned
sl@0	4347	* something different from TCL_OK, or else INST_BREAK or
sl@0	4348	* INST_CONTINUE were called.
sl@0	4349	*/
sl@0	4350
sl@0	4351	processExceptionReturn:
sl@0	4352	#if TCL_COMPILE_DEBUG
sl@0	4353	switch (*pc) {
sl@0	4354	case INST_INVOKE_STK1:
sl@0	4355	case INST_INVOKE_STK4:
sl@0	4356	TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf));
sl@0	4357	break;
sl@0	4358	case INST_EVAL_STK:
sl@0	4359	/*
sl@0	4360	* Note that the object at stacktop has to be used
sl@0	4361	* before doing the cleanup.
sl@0	4362	*/
sl@0	4363
sl@0	4364	TRACE(("\"%.30s\" => ", O2S(stackPtr[stackTop])));
sl@0	4365	break;
sl@0	4366	default:
sl@0	4367	TRACE(("=> "));
sl@0	4368	}
sl@0	4369	#endif
sl@0	4370	if ((result == TCL_CONTINUE) \|\| (result == TCL_BREAK)) {
sl@0	4371	rangePtr = GetExceptRangeForPc(pc, /catchOnly/ 0, codePtr);
sl@0	4372	if (rangePtr == NULL) {
sl@0	4373	TRACE_APPEND(("no encl. loop or catch, returning %s\n",
sl@0	4374	StringForResultCode(result)));
sl@0	4375	goto abnormalReturn;
sl@0	4376	}
sl@0	4377	if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
sl@0	4378	TRACE_APPEND(("%s ...\n", StringForResultCode(result)));
sl@0	4379	goto processCatch;
sl@0	4380	}
sl@0	4381	while (cleanup--) {
sl@0	4382	valuePtr = POP_OBJECT();
sl@0	4383	TclDecrRefCount(valuePtr);
sl@0	4384	}
sl@0	4385	if (result == TCL_BREAK) {
sl@0	4386	result = TCL_OK;
sl@0	4387	pc = (codePtr->codeStart + rangePtr->breakOffset);
sl@0	4388	TRACE_APPEND(("%s, range at %d, new pc %d\n",
sl@0	4389	StringForResultCode(result),
sl@0	4390	rangePtr->codeOffset, rangePtr->breakOffset));
sl@0	4391	NEXT_INST_F(0, 0, 0);
sl@0	4392	} else {
sl@0	4393	if (rangePtr->continueOffset == -1) {
sl@0	4394	TRACE_APPEND(("%s, loop w/o continue, checking for catch\n",
sl@0	4395	StringForResultCode(result)));
sl@0	4396	goto checkForCatch;
sl@0	4397	}
sl@0	4398	result = TCL_OK;
sl@0	4399	pc = (codePtr->codeStart + rangePtr->continueOffset);
sl@0	4400	TRACE_APPEND(("%s, range at %d, new pc %d\n",
sl@0	4401	StringForResultCode(result),
sl@0	4402	rangePtr->codeOffset, rangePtr->continueOffset));
sl@0	4403	NEXT_INST_F(0, 0, 0);
sl@0	4404	}
sl@0	4405	#if TCL_COMPILE_DEBUG
sl@0	4406	} else if (traceInstructions) {
sl@0	4407	if ((result != TCL_ERROR) && (result != TCL_RETURN)) {
sl@0	4408	objPtr = Tcl_GetObjResult(interp);
sl@0	4409	TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ",
sl@0	4410	result, O2S(objPtr)));
sl@0	4411	} else {
sl@0	4412	objPtr = Tcl_GetObjResult(interp);
sl@0	4413	TRACE_APPEND(("%s, result= \"%s\"\n",
sl@0	4414	StringForResultCode(result), O2S(objPtr)));
sl@0	4415	}
sl@0	4416	#endif
sl@0	4417	}
sl@0	4418
sl@0	4419	/*
sl@0	4420	* Execution has generated an "exception" such as TCL_ERROR. If the
sl@0	4421	* exception is an error, record information about what was being
sl@0	4422	* executed when the error occurred. Find the closest enclosing
sl@0	4423	* catch range, if any. If no enclosing catch range is found, stop
sl@0	4424	* execution and return the "exception" code.
sl@0	4425	*/
sl@0	4426
sl@0	4427	checkForCatch:
sl@0	4428	if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
sl@0	4429	bytes = GetSrcInfoForPc(pc, codePtr, &length);
sl@0	4430	if (bytes != NULL) {
sl@0	4431	DECACHE_STACK_INFO();
sl@0	4432	Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
sl@0	4433	CACHE_STACK_INFO();
sl@0	4434	iPtr->flags \|= ERR_ALREADY_LOGGED;
sl@0	4435	}
sl@0	4436	}
sl@0	4437	if (catchTop == -1) {
sl@0	4438	#ifdef TCL_COMPILE_DEBUG
sl@0	4439	if (traceInstructions) {
sl@0	4440	fprintf(stdout, " ... no enclosing catch, returning %s\n",
sl@0	4441	StringForResultCode(result));
sl@0	4442	}
sl@0	4443	#endif
sl@0	4444	goto abnormalReturn;
sl@0	4445	}
sl@0	4446	rangePtr = GetExceptRangeForPc(pc, /catchOnly/ 1, codePtr);
sl@0	4447	if (rangePtr == NULL) {
sl@0	4448	/*
sl@0	4449	* This is only possible when compiling a [catch] that sends its
sl@0	4450	* script to INST_EVAL. Cannot correct the compiler without
sl@0	4451	* breakingcompat with previous .tbc compiled scripts.
sl@0	4452	*/
sl@0	4453	#ifdef TCL_COMPILE_DEBUG
sl@0	4454	if (traceInstructions) {
sl@0	4455	fprintf(stdout, " ... no enclosing catch, returning %s\n",
sl@0	4456	StringForResultCode(result));
sl@0	4457	}
sl@0	4458	#endif
sl@0	4459	goto abnormalReturn;
sl@0	4460	}
sl@0	4461
sl@0	4462	/*
sl@0	4463	* A catch exception range (rangePtr) was found to handle an
sl@0	4464	* "exception". It was found either by checkForCatch just above or
sl@0	4465	* by an instruction during break, continue, or error processing.
sl@0	4466	* Jump to its catchOffset after unwinding the operand stack to
sl@0	4467	* the depth it had when starting to execute the range's catch
sl@0	4468	* command.
sl@0	4469	*/
sl@0	4470
sl@0	4471	processCatch:
sl@0	4472	while (stackTop > catchStackPtr[catchTop]) {
sl@0	4473	valuePtr = POP_OBJECT();
sl@0	4474	TclDecrRefCount(valuePtr);
sl@0	4475	}
sl@0	4476	#ifdef TCL_COMPILE_DEBUG
sl@0	4477	if (traceInstructions) {
sl@0	4478	fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
sl@0	4479	rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],
sl@0	4480	(unsigned int)(rangePtr->catchOffset));
sl@0	4481	}
sl@0	4482	#endif
sl@0	4483	pc = (codePtr->codeStart + rangePtr->catchOffset);
sl@0	4484	NEXT_INST_F(0, 0, 0); /* restart the execution loop at pc */
sl@0	4485
sl@0	4486	/*
sl@0	4487	* end of infinite loop dispatching on instructions.
sl@0	4488	*/
sl@0	4489
sl@0	4490	/*
sl@0	4491	* Abnormal return code. Restore the stack to state it had when starting
sl@0	4492	* to execute the ByteCode. Panic if the stack is below the initial level.
sl@0	4493	*/
sl@0	4494
sl@0	4495	abnormalReturn:
sl@0	4496	while (stackTop > initStackTop) {
sl@0	4497	valuePtr = POP_OBJECT();
sl@0	4498	TclDecrRefCount(valuePtr);
sl@0	4499	}
sl@0	4500	if (stackTop < initStackTop) {
sl@0	4501	fprintf(stderr, "\nTclExecuteByteCode: abnormal return at pc %u: stack top %d < entry stack top %d\n",
sl@0	4502	(unsigned int)(pc - codePtr->codeStart),
sl@0	4503	(unsigned int) stackTop,
sl@0	4504	(unsigned int) initStackTop);
sl@0	4505	panic("TclExecuteByteCode execution failure: end stack top < start stack top");
sl@0	4506	}
sl@0	4507
sl@0	4508	/*
sl@0	4509	* Free the catch stack array if malloc'ed storage was used.
sl@0	4510	*/
sl@0	4511
sl@0	4512	if (catchStackPtr != catchStackStorage) {
sl@0	4513	ckfree((char *) catchStackPtr);
sl@0	4514	}
sl@0	4515	eePtr->stackTop = initStackTop;
sl@0	4516	return result;
sl@0	4517	#undef STATIC_CATCH_STACK_SIZE
sl@0	4518	}
sl@0	4519
sl@0	4520	#ifdef TCL_COMPILE_DEBUG
sl@0	4521	/*
sl@0	4522	*----------------------------------------------------------------------
sl@0	4523	*
sl@0	4524	* PrintByteCodeInfo --
sl@0	4525	*
sl@0	4526	* This procedure prints a summary about a bytecode object to stdout.
sl@0	4527	* It is called by TclExecuteByteCode when starting to execute the
sl@0	4528	* bytecode object if tclTraceExec has the value 2 or more.
sl@0	4529	*
sl@0	4530	* Results:
sl@0	4531	* None.
sl@0	4532	*
sl@0	4533	* Side effects:
sl@0	4534	* None.
sl@0	4535	*
sl@0	4536	*----------------------------------------------------------------------
sl@0	4537	*/
sl@0	4538
sl@0	4539	static void
sl@0	4540	PrintByteCodeInfo(codePtr)
sl@0	4541	register ByteCode codePtr; / The bytecode whose summary is printed
sl@0	4542	* to stdout. */
sl@0	4543	{
sl@0	4544	Proc *procPtr = codePtr->procPtr;
sl@0	4545	Interp iPtr = (Interp ) *codePtr->interpHandle;
sl@0	4546
sl@0	4547	fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
sl@0	4548	(unsigned int) codePtr, codePtr->refCount,
sl@0	4549	codePtr->compileEpoch, (unsigned int) iPtr,
sl@0	4550	iPtr->compileEpoch);
sl@0	4551
sl@0	4552	fprintf(stdout, " Source: ");
sl@0	4553	TclPrintSource(stdout, codePtr->source, 60);
sl@0	4554
sl@0	4555	fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
sl@0	4556	codePtr->numCommands, codePtr->numSrcBytes,
sl@0	4557	codePtr->numCodeBytes, codePtr->numLitObjects,
sl@0	4558	codePtr->numAuxDataItems, codePtr->maxStackDepth,
sl@0	4559	#ifdef TCL_COMPILE_STATS
sl@0	4560	(codePtr->numSrcBytes?
sl@0	4561	((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
sl@0	4562	#else
sl@0	4563	0.0);
sl@0	4564	#endif
sl@0	4565	#ifdef TCL_COMPILE_STATS
sl@0	4566	fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
sl@0	4567	codePtr->structureSize,
sl@0	4568	(sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
sl@0	4569	codePtr->numCodeBytes,
sl@0	4570	(codePtr->numLitObjects * sizeof(Tcl_Obj *)),
sl@0	4571	(codePtr->numExceptRanges * sizeof(ExceptionRange)),
sl@0	4572	(codePtr->numAuxDataItems * sizeof(AuxData)),
sl@0	4573	codePtr->numCmdLocBytes);
sl@0	4574	#endif /* TCL_COMPILE_STATS */
sl@0	4575	if (procPtr != NULL) {
sl@0	4576	fprintf(stdout,
sl@0	4577	" Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
sl@0	4578	(unsigned int) procPtr, procPtr->refCount,
sl@0	4579	procPtr->numArgs, procPtr->numCompiledLocals);
sl@0	4580	}
sl@0	4581	}
sl@0	4582	#endif /* TCL_COMPILE_DEBUG */
sl@0	4583
sl@0	4584	/*
sl@0	4585	*----------------------------------------------------------------------
sl@0	4586	*
sl@0	4587	* ValidatePcAndStackTop --
sl@0	4588	*
sl@0	4589	* This procedure is called by TclExecuteByteCode when debugging to
sl@0	4590	* verify that the program counter and stack top are valid during
sl@0	4591	* execution.
sl@0	4592	*
sl@0	4593	* Results:
sl@0	4594	* None.
sl@0	4595	*
sl@0	4596	* Side effects:
sl@0	4597	* Prints a message to stderr and panics if either the pc or stack
sl@0	4598	* top are invalid.
sl@0	4599	*
sl@0	4600	*----------------------------------------------------------------------
sl@0	4601	*/
sl@0	4602
sl@0	4603	#ifdef TCL_COMPILE_DEBUG
sl@0	4604	static void
sl@0	4605	ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound)
sl@0	4606	register ByteCode codePtr; / The bytecode whose summary is printed
sl@0	4607	* to stdout. */
sl@0	4608	unsigned char pc; / Points to first byte of a bytecode
sl@0	4609	* instruction. The program counter. */
sl@0	4610	int stackTop; /* Current stack top. Must be between
sl@0	4611	* stackLowerBound and stackUpperBound
sl@0	4612	* (inclusive). */
sl@0	4613	int stackLowerBound; /* Smallest legal value for stackTop. */
sl@0	4614	{
sl@0	4615	int stackUpperBound = stackLowerBound + codePtr->maxStackDepth;
sl@0	4616	/* Greatest legal value for stackTop. */
sl@0	4617	unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart);
sl@0	4618	unsigned int codeStart = (unsigned int) codePtr->codeStart;
sl@0	4619	unsigned int codeEnd = (unsigned int)
sl@0	4620	(codePtr->codeStart + codePtr->numCodeBytes);
sl@0	4621	unsigned char opCode = *pc;
sl@0	4622
sl@0	4623	if (((unsigned int) pc < codeStart) \|\| ((unsigned int) pc > codeEnd)) {
sl@0	4624	fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n",
sl@0	4625	(unsigned int) pc);
sl@0	4626	panic("TclExecuteByteCode execution failure: bad pc");
sl@0	4627	}
sl@0	4628	if ((unsigned int) opCode > LAST_INST_OPCODE) {
sl@0	4629	fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
sl@0	4630	(unsigned int) opCode, relativePc);
sl@0	4631	panic("TclExecuteByteCode execution failure: bad opcode");
sl@0	4632	}
sl@0	4633	if ((stackTop < stackLowerBound) \|\| (stackTop > stackUpperBound)) {
sl@0	4634	int numChars;
sl@0	4635	char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
sl@0	4636	char *ellipsis = "";
sl@0	4637
sl@0	4638	fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)",
sl@0	4639	stackTop, relativePc, stackLowerBound, stackUpperBound);
sl@0	4640	if (cmd != NULL) {
sl@0	4641	if (numChars > 100) {
sl@0	4642	numChars = 100;
sl@0	4643	ellipsis = "...";
sl@0	4644	}
sl@0	4645	fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd,
sl@0	4646	ellipsis);
sl@0	4647	} else {
sl@0	4648	fprintf(stderr, "\n");
sl@0	4649	}
sl@0	4650	panic("TclExecuteByteCode execution failure: bad stack top");
sl@0	4651	}
sl@0	4652	}
sl@0	4653	#endif /* TCL_COMPILE_DEBUG */
sl@0	4654
sl@0	4655	/*
sl@0	4656	*----------------------------------------------------------------------
sl@0	4657	*
sl@0	4658	* IllegalExprOperandType --
sl@0	4659	*
sl@0	4660	* Used by TclExecuteByteCode to add an error message to errorInfo
sl@0	4661	* when an illegal operand type is detected by an expression
sl@0	4662	* instruction. The argument opndPtr holds the operand object in error.
sl@0	4663	*
sl@0	4664	* Results:
sl@0	4665	* None.
sl@0	4666	*
sl@0	4667	* Side effects:
sl@0	4668	* An error message is appended to errorInfo.
sl@0	4669	*
sl@0	4670	*----------------------------------------------------------------------
sl@0	4671	*/
sl@0	4672
sl@0	4673	static void
sl@0	4674	IllegalExprOperandType(interp, pc, opndPtr)
sl@0	4675	Tcl_Interp interp; / Interpreter to which error information
sl@0	4676	* pertains. */
sl@0	4677	unsigned char pc; / Points to the instruction being executed
sl@0	4678	* when the illegal type was found. */
sl@0	4679	Tcl_Obj opndPtr; / Points to the operand holding the value
sl@0	4680	* with the illegal type. */
sl@0	4681	{
sl@0	4682	unsigned char opCode = *pc;
sl@0	4683
sl@0	4684	Tcl_ResetResult(interp);
sl@0	4685	if ((opndPtr->bytes == NULL) \|\| (opndPtr->length == 0)) {
sl@0	4686	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	4687	"can't use empty string as operand of \"",
sl@0	4688	operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
sl@0	4689	} else {
sl@0	4690	char *msg = "non-numeric string";
sl@0	4691	char s, p;
sl@0	4692	int length;
sl@0	4693	int looksLikeInt = 0;
sl@0	4694
sl@0	4695	s = Tcl_GetStringFromObj(opndPtr, &length);
sl@0	4696	p = s;
sl@0	4697	/*
sl@0	4698	* strtod() isn't at all consistent about detecting Inf and
sl@0	4699	* NaN between platforms.
sl@0	4700	*/
sl@0	4701	if (length == 3) {
sl@0	4702	if ((s[0]=='n' \|\| s[0]=='N') && (s[1]=='a' \|\| s[1]=='A') &&
sl@0	4703	(s[2]=='n' \|\| s[2]=='N')) {
sl@0	4704	msg = "non-numeric floating-point value";
sl@0	4705	goto makeErrorMessage;
sl@0	4706	}
sl@0	4707	if ((s[0]=='i' \|\| s[0]=='I') && (s[1]=='n' \|\| s[1]=='N') &&
sl@0	4708	(s[2]=='f' \|\| s[2]=='F')) {
sl@0	4709	msg = "infinite floating-point value";
sl@0	4710	goto makeErrorMessage;
sl@0	4711	}
sl@0	4712	}
sl@0	4713
sl@0	4714	/*
sl@0	4715	* We cannot use TclLooksLikeInt here because it passes strings
sl@0	4716	* like "10;" [Bug 587140]. We'll accept as "looking like ints"
sl@0	4717	* for the present purposes any string that looks formally like
sl@0	4718	* a (decimal\|octal\|hex) integer.
sl@0	4719	*/
sl@0	4720
sl@0	4721	while (length && isspace(UCHAR(*p))) {
sl@0	4722	length--;
sl@0	4723	p++;
sl@0	4724	}
sl@0	4725	if (length && ((p == '+') \|\| (p == '-'))) {
sl@0	4726	length--;
sl@0	4727	p++;
sl@0	4728	}
sl@0	4729	if (length) {
sl@0	4730	if ((p == '0') && (((p+1) == 'x') \|\| (*(p+1) == 'X'))) {
sl@0	4731	p += 2;
sl@0	4732	length -= 2;
sl@0	4733	looksLikeInt = ((length > 0) && isxdigit(UCHAR(*p)));
sl@0	4734	if (looksLikeInt) {
sl@0	4735	length--;
sl@0	4736	p++;
sl@0	4737	while (length && isxdigit(UCHAR(*p))) {
sl@0	4738	length--;
sl@0	4739	p++;
sl@0	4740	}
sl@0	4741	}
sl@0	4742	} else {
sl@0	4743	looksLikeInt = (length && isdigit(UCHAR(*p)));
sl@0	4744	if (looksLikeInt) {
sl@0	4745	length--;
sl@0	4746	p++;
sl@0	4747	while (length && isdigit(UCHAR(*p))) {
sl@0	4748	length--;
sl@0	4749	p++;
sl@0	4750	}
sl@0	4751	}
sl@0	4752	}
sl@0	4753	while (length && isspace(UCHAR(*p))) {
sl@0	4754	length--;
sl@0	4755	p++;
sl@0	4756	}
sl@0	4757	looksLikeInt = !length;
sl@0	4758	}
sl@0	4759	if (looksLikeInt) {
sl@0	4760	/*
sl@0	4761	* If something that looks like an integer could not be
sl@0	4762	* converted, then it must be a bad octal or too large
sl@0	4763	* to represent [Bug 542588].
sl@0	4764	*/
sl@0	4765
sl@0	4766	if (TclCheckBadOctal(NULL, s)) {
sl@0	4767	msg = "invalid octal number";
sl@0	4768	} else {
sl@0	4769	msg = "integer value too large to represent";
sl@0	4770	Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
sl@0	4771	"integer value too large to represent", (char *) NULL);
sl@0	4772	}
sl@0	4773	} else {
sl@0	4774	/*
sl@0	4775	* See if the operand can be interpreted as a double in
sl@0	4776	* order to improve the error message.
sl@0	4777	*/
sl@0	4778
sl@0	4779	double d;
sl@0	4780
sl@0	4781	if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) {
sl@0	4782	msg = "floating-point value";
sl@0	4783	}
sl@0	4784	}
sl@0	4785	makeErrorMessage:
sl@0	4786	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
sl@0	4787	msg, " as operand of \"", operatorStrings[opCode - INST_LOR],
sl@0	4788	"\"", (char *) NULL);
sl@0	4789	}
sl@0	4790	}
sl@0	4791
sl@0	4792	/*
sl@0	4793	*----------------------------------------------------------------------
sl@0	4794	*
sl@0	4795	* TclGetSrcInfoForPc, GetSrcInfoForPc --
sl@0	4796	*
sl@0	4797	* Given a program counter value, finds the closest command in the
sl@0	4798	* bytecode code unit's CmdLocation array and returns information about
sl@0	4799	* that command's source: a pointer to its first byte and the number of
sl@0	4800	* characters.
sl@0	4801	*
sl@0	4802	* Results:
sl@0	4803	* If a command is found that encloses the program counter value, a
sl@0	4804	* pointer to the command's source is returned and the length of the
sl@0	4805	* source is stored at *lengthPtr. If multiple commands resulted in
sl@0	4806	* code at pc, information about the closest enclosing command is
sl@0	4807	* returned. If no matching command is found, NULL is returned and
sl@0	4808	* *lengthPtr is unchanged.
sl@0	4809	*
sl@0	4810	* Side effects:
sl@0	4811	* None.
sl@0	4812	*
sl@0	4813	*----------------------------------------------------------------------
sl@0	4814	*/
sl@0	4815
sl@0	4816	#ifdef TCL_TIP280
sl@0	4817	void
sl@0	4818	TclGetSrcInfoForPc (cfPtr)
sl@0	4819	CmdFrame* cfPtr;
sl@0	4820	{
sl@0	4821	ByteCode* codePtr = (ByteCode*) cfPtr->data.tebc.codePtr;
sl@0	4822
sl@0	4823	if (cfPtr->cmd.str.cmd == NULL) {
sl@0	4824	cfPtr->cmd.str.cmd = GetSrcInfoForPc((char*) cfPtr->data.tebc.pc,
sl@0	4825	codePtr,
sl@0	4826	&cfPtr->cmd.str.len);
sl@0	4827	}
sl@0	4828
sl@0	4829	if (cfPtr->cmd.str.cmd != NULL) {
sl@0	4830	/* We now have the command. We can get the srcOffset back and
sl@0	4831	* from there find the list of word locations for this command
sl@0	4832	*/
sl@0	4833
sl@0	4834	ExtCmdLoc* eclPtr;
sl@0	4835	ECL* locPtr = NULL;
sl@0	4836	int srcOffset;
sl@0	4837
sl@0	4838	Interp* iPtr = (Interp) codePtr->interpHandle;
sl@0	4839	Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);
sl@0	4840
sl@0	4841	if (!hePtr) return;
sl@0	4842
sl@0	4843	srcOffset = cfPtr->cmd.str.cmd - codePtr->source;
sl@0	4844	eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
sl@0	4845
sl@0	4846	{
sl@0	4847	int i;
sl@0	4848	for (i=0; i < eclPtr->nuloc; i++) {
sl@0	4849	if (eclPtr->loc [i].srcOffset == srcOffset) {
sl@0	4850	locPtr = &(eclPtr->loc [i]);
sl@0	4851	break;
sl@0	4852	}
sl@0	4853	}
sl@0	4854	}
sl@0	4855
sl@0	4856	if (locPtr == NULL) {Tcl_Panic ("LocSearch failure");}
sl@0	4857
sl@0	4858	cfPtr->line = locPtr->line;
sl@0	4859	cfPtr->nline = locPtr->nline;
sl@0	4860	cfPtr->type = eclPtr->type;
sl@0	4861
sl@0	4862	if (eclPtr->type == TCL_LOCATION_SOURCE) {
sl@0	4863	cfPtr->data.eval.path = eclPtr->path;
sl@0	4864	Tcl_IncrRefCount (cfPtr->data.eval.path);
sl@0	4865	}
sl@0	4866	/* Do not set cfPtr->data.eval.path NULL for non-SOURCE
sl@0	4867	* Needed for cfPtr->data.tebc.codePtr.
sl@0	4868	*/
sl@0	4869	}
sl@0	4870	}
sl@0	4871	#endif
sl@0	4872
sl@0	4873	static char *
sl@0	4874	GetSrcInfoForPc(pc, codePtr, lengthPtr)
sl@0	4875	unsigned char pc; / The program counter value for which to
sl@0	4876	* return the closest command's source info.
sl@0	4877	* This points to a bytecode instruction
sl@0	4878	* in codePtr's code. */
sl@0	4879	ByteCode codePtr; / The bytecode sequence in which to look
sl@0	4880	* up the command source for the pc. */
sl@0	4881	int lengthPtr; / If non-NULL, the location where the
sl@0	4882	* length of the command's source should be
sl@0	4883	* stored. If NULL, no length is stored. */
sl@0	4884	{
sl@0	4885	register int pcOffset = (pc - codePtr->codeStart);
sl@0	4886	int numCmds = codePtr->numCommands;
sl@0	4887	unsigned char codeDeltaNext, codeLengthNext;
sl@0	4888	unsigned char srcDeltaNext, srcLengthNext;
sl@0	4889	int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
sl@0	4890	int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
sl@0	4891	int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
sl@0	4892	int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
sl@0	4893
sl@0	4894	if ((pcOffset < 0) \|\| (pcOffset >= codePtr->numCodeBytes)) {
sl@0	4895	return NULL;
sl@0	4896	}
sl@0	4897
sl@0	4898	/*
sl@0	4899	* Decode the code and source offset and length for each command. The
sl@0	4900	* closest enclosing command is the last one whose code started before
sl@0	4901	* pcOffset.
sl@0	4902	*/
sl@0	4903
sl@0	4904	codeDeltaNext = codePtr->codeDeltaStart;
sl@0	4905	codeLengthNext = codePtr->codeLengthStart;
sl@0	4906	srcDeltaNext = codePtr->srcDeltaStart;
sl@0	4907	srcLengthNext = codePtr->srcLengthStart;
sl@0	4908	codeOffset = srcOffset = 0;
sl@0	4909	for (i = 0; i < numCmds; i++) {
sl@0	4910	if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
sl@0	4911	codeDeltaNext++;
sl@0	4912	delta = TclGetInt4AtPtr(codeDeltaNext);
sl@0	4913	codeDeltaNext += 4;
sl@0	4914	} else {
sl@0	4915	delta = TclGetInt1AtPtr(codeDeltaNext);
sl@0	4916	codeDeltaNext++;
sl@0	4917	}
sl@0	4918	codeOffset += delta;
sl@0	4919
sl@0	4920	if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
sl@0	4921	codeLengthNext++;
sl@0	4922	codeLen = TclGetInt4AtPtr(codeLengthNext);
sl@0	4923	codeLengthNext += 4;
sl@0	4924	} else {
sl@0	4925	codeLen = TclGetInt1AtPtr(codeLengthNext);
sl@0	4926	codeLengthNext++;
sl@0	4927	}
sl@0	4928	codeEnd = (codeOffset + codeLen - 1);
sl@0	4929
sl@0	4930	if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
sl@0	4931	srcDeltaNext++;
sl@0	4932	delta = TclGetInt4AtPtr(srcDeltaNext);
sl@0	4933	srcDeltaNext += 4;
sl@0	4934	} else {
sl@0	4935	delta = TclGetInt1AtPtr(srcDeltaNext);
sl@0	4936	srcDeltaNext++;
sl@0	4937	}
sl@0	4938	srcOffset += delta;
sl@0	4939
sl@0	4940	if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
sl@0	4941	srcLengthNext++;
sl@0	4942	srcLen = TclGetInt4AtPtr(srcLengthNext);
sl@0	4943	srcLengthNext += 4;
sl@0	4944	} else {
sl@0	4945	srcLen = TclGetInt1AtPtr(srcLengthNext);
sl@0	4946	srcLengthNext++;
sl@0	4947	}
sl@0	4948
sl@0	4949	if (codeOffset > pcOffset) { /* best cmd already found */
sl@0	4950	break;
sl@0	4951	} else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */
sl@0	4952	int dist = (pcOffset - codeOffset);
sl@0	4953	if (dist <= bestDist) {
sl@0	4954	bestDist = dist;
sl@0	4955	bestSrcOffset = srcOffset;
sl@0	4956	bestSrcLength = srcLen;
sl@0	4957	}
sl@0	4958	}
sl@0	4959	}
sl@0	4960
sl@0	4961	if (bestDist == INT_MAX) {
sl@0	4962	return NULL;
sl@0	4963	}
sl@0	4964
sl@0	4965	if (lengthPtr != NULL) {
sl@0	4966	*lengthPtr = bestSrcLength;
sl@0	4967	}
sl@0	4968	return (codePtr->source + bestSrcOffset);
sl@0	4969	}
sl@0	4970
sl@0	4971	/*
sl@0	4972	*----------------------------------------------------------------------
sl@0	4973	*
sl@0	4974	* GetExceptRangeForPc --
sl@0	4975	*
sl@0	4976	* Given a program counter value, return the closest enclosing
sl@0	4977	* ExceptionRange.
sl@0	4978	*
sl@0	4979	* Results:
sl@0	4980	* In the normal case, catchOnly is 0 (false) and this procedure
sl@0	4981	* returns a pointer to the most closely enclosing ExceptionRange
sl@0	4982	* structure regardless of whether it is a loop or catch exception
sl@0	4983	* range. This is appropriate when processing a TCL_BREAK or
sl@0	4984	* TCL_CONTINUE, which will be "handled" either by a loop exception
sl@0	4985	* range or a closer catch range. If catchOnly is nonzero, this
sl@0	4986	* procedure ignores loop exception ranges and returns a pointer to the
sl@0	4987	* closest catch range. If no matching ExceptionRange is found that
sl@0	4988	* encloses pc, a NULL is returned.
sl@0	4989	*
sl@0	4990	* Side effects:
sl@0	4991	* None.
sl@0	4992	*
sl@0	4993	*----------------------------------------------------------------------
sl@0	4994	*/
sl@0	4995
sl@0	4996	static ExceptionRange *
sl@0	4997	GetExceptRangeForPc(pc, catchOnly, codePtr)
sl@0	4998	unsigned char pc; / The program counter value for which to
sl@0	4999	* search for a closest enclosing exception
sl@0	5000	* range. This points to a bytecode
sl@0	5001	* instruction in codePtr's code. */
sl@0	5002	int catchOnly; /* If 0, consider either loop or catch
sl@0	5003	* ExceptionRanges in search. If nonzero
sl@0	5004	* consider only catch ranges (and ignore
sl@0	5005	* any closer loop ranges). */
sl@0	5006	ByteCode* codePtr; /* Points to the ByteCode in which to search
sl@0	5007	* for the enclosing ExceptionRange. */
sl@0	5008	{
sl@0	5009	ExceptionRange *rangeArrayPtr;
sl@0	5010	int numRanges = codePtr->numExceptRanges;
sl@0	5011	register ExceptionRange *rangePtr;
sl@0	5012	int pcOffset = (pc - codePtr->codeStart);
sl@0	5013	register int start;
sl@0	5014
sl@0	5015	if (numRanges == 0) {
sl@0	5016	return NULL;
sl@0	5017	}
sl@0	5018
sl@0	5019	/*
sl@0	5020	* This exploits peculiarities of our compiler: nested ranges
sl@0	5021	* are always after their containing ranges, so that by scanning
sl@0	5022	* backwards we are sure that the first matching range is indeed
sl@0	5023	* the deepest.
sl@0	5024	*/
sl@0	5025
sl@0	5026	rangeArrayPtr = codePtr->exceptArrayPtr;
sl@0	5027	rangePtr = rangeArrayPtr + numRanges;
sl@0	5028	while (--rangePtr >= rangeArrayPtr) {
sl@0	5029	start = rangePtr->codeOffset;
sl@0	5030	if ((start <= pcOffset) &&
sl@0	5031	(pcOffset < (start + rangePtr->numCodeBytes))) {
sl@0	5032	if ((!catchOnly)
sl@0	5033	\|\| (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
sl@0	5034	return rangePtr;
sl@0	5035	}
sl@0	5036	}
sl@0	5037	}
sl@0	5038	return NULL;
sl@0	5039	}
sl@0	5040
sl@0	5041	/*
sl@0	5042	*----------------------------------------------------------------------
sl@0	5043	*
sl@0	5044	* GetOpcodeName --
sl@0	5045	*
sl@0	5046	* This procedure is called by the TRACE and TRACE_WITH_OBJ macros
sl@0	5047	* used in TclExecuteByteCode when debugging. It returns the name of
sl@0	5048	* the bytecode instruction at a specified instruction pc.
sl@0	5049	*
sl@0	5050	* Results:
sl@0	5051	* A character string for the instruction.
sl@0	5052	*
sl@0	5053	* Side effects:
sl@0	5054	* None.
sl@0	5055	*
sl@0	5056	*----------------------------------------------------------------------
sl@0	5057	*/
sl@0	5058
sl@0	5059	#ifdef TCL_COMPILE_DEBUG
sl@0	5060	static char *
sl@0	5061	GetOpcodeName(pc)
sl@0	5062	unsigned char pc; / Points to the instruction whose name
sl@0	5063	* should be returned. */
sl@0	5064	{
sl@0	5065	unsigned char opCode = *pc;
sl@0	5066
sl@0	5067	return tclInstructionTable[opCode].name;
sl@0	5068	}
sl@0	5069	#endif /* TCL_COMPILE_DEBUG */
sl@0	5070
sl@0	5071	/*
sl@0	5072	*----------------------------------------------------------------------
sl@0	5073	*
sl@0	5074	* VerifyExprObjType --
sl@0	5075	*
sl@0	5076	* This procedure is called by the math functions to verify that
sl@0	5077	* the object is either an int or double, coercing it if necessary.
sl@0	5078	* If an error occurs during conversion, an error message is left
sl@0	5079	* in the interpreter's result unless "interp" is NULL.
sl@0	5080	*
sl@0	5081	* Results:
sl@0	5082	* TCL_OK if it was int or double, TCL_ERROR otherwise
sl@0	5083	*
sl@0	5084	* Side effects:
sl@0	5085	* objPtr is ensured to be of tclIntType, tclWideIntType or
sl@0	5086	* tclDoubleType.
sl@0	5087	*
sl@0	5088	*----------------------------------------------------------------------
sl@0	5089	*/
sl@0	5090
sl@0	5091	static int
sl@0	5092	VerifyExprObjType(interp, objPtr)
sl@0	5093	Tcl_Interp interp; / The interpreter in which to execute the
sl@0	5094	* function. */
sl@0	5095	Tcl_Obj objPtr; / Points to the object to type check. */
sl@0	5096	{
sl@0	5097	if (IS_NUMERIC_TYPE(objPtr->typePtr)) {
sl@0	5098	return TCL_OK;
sl@0	5099	} else {
sl@0	5100	int length, result = TCL_OK;
sl@0	5101	char *s = Tcl_GetStringFromObj(objPtr, &length);
sl@0	5102
sl@0	5103	if (TclLooksLikeInt(s, length)) {
sl@0	5104	long i;
sl@0	5105	Tcl_WideInt w;
sl@0	5106	GET_WIDE_OR_INT(result, objPtr, i, w);
sl@0	5107	} else {
sl@0	5108	double d;
sl@0	5109	result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d);
sl@0	5110	}
sl@0	5111	if ((result != TCL_OK) && (interp != NULL)) {
sl@0	5112	Tcl_ResetResult(interp);
sl@0	5113	if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) {
sl@0	5114	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	5115	"argument to math function was an invalid octal number",
sl@0	5116	-1);
sl@0	5117	} else {
sl@0	5118	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	5119	"argument to math function didn't have numeric value",
sl@0	5120	-1);
sl@0	5121	}
sl@0	5122	}
sl@0	5123	return result;
sl@0	5124	}
sl@0	5125	}
sl@0	5126
sl@0	5127	/*
sl@0	5128	*----------------------------------------------------------------------
sl@0	5129	*
sl@0	5130	* Math Functions --
sl@0	5131	*
sl@0	5132	* This page contains the procedures that implement all of the
sl@0	5133	* built-in math functions for expressions.
sl@0	5134	*
sl@0	5135	* Results:
sl@0	5136	* Each procedure returns TCL_OK if it succeeds and pushes an
sl@0	5137	* Tcl object holding the result. If it fails it returns TCL_ERROR
sl@0	5138	* and leaves an error message in the interpreter's result.
sl@0	5139	*
sl@0	5140	* Side effects:
sl@0	5141	* None.
sl@0	5142	*
sl@0	5143	*----------------------------------------------------------------------
sl@0	5144	*/
sl@0	5145
sl@0	5146	static int
sl@0	5147	ExprUnaryFunc(interp, eePtr, clientData)
sl@0	5148	Tcl_Interp interp; / The interpreter in which to execute the
sl@0	5149	* function. */
sl@0	5150	ExecEnv eePtr; / Points to the environment for executing
sl@0	5151	* the function. */
sl@0	5152	ClientData clientData; /* Contains the address of a procedure that
sl@0	5153	* takes one double argument and returns a
sl@0	5154	* double result. */
sl@0	5155	{
sl@0	5156	Tcl_Obj *stackPtr; / Cached evaluation stack base pointer. */
sl@0	5157	register int stackTop; /* Cached top index of evaluation stack. */
sl@0	5158	register Tcl_Obj *valuePtr;
sl@0	5159	double d, dResult;
sl@0	5160	int result;
sl@0	5161
sl@0	5162	double (*func) _ANSI_ARGS_((double)) =
sl@0	5163	(double (*)_ANSI_ARGS_((double))) clientData;
sl@0	5164
sl@0	5165	/*
sl@0	5166	* Set stackPtr and stackTop from eePtr.
sl@0	5167	*/
sl@0	5168
sl@0	5169	result = TCL_OK;
sl@0	5170	CACHE_STACK_INFO();
sl@0	5171
sl@0	5172	/*
sl@0	5173	* Pop the function's argument from the evaluation stack. Convert it
sl@0	5174	* to a double if necessary.
sl@0	5175	*/
sl@0	5176
sl@0	5177	valuePtr = POP_OBJECT();
sl@0	5178
sl@0	5179	if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
sl@0	5180	result = TCL_ERROR;
sl@0	5181	goto done;
sl@0	5182	}
sl@0	5183
sl@0	5184	GET_DOUBLE_VALUE(d, valuePtr, valuePtr->typePtr);
sl@0	5185
sl@0	5186	errno = 0;
sl@0	5187	dResult = (*func)(d);
sl@0	5188	if ((errno != 0) \|\| IS_NAN(dResult) \|\| IS_INF(dResult)) {
sl@0	5189	TclExprFloatError(interp, dResult);
sl@0	5190	result = TCL_ERROR;
sl@0	5191	goto done;
sl@0	5192	}
sl@0	5193
sl@0	5194	/*
sl@0	5195	* Push a Tcl object holding the result.
sl@0	5196	*/
sl@0	5197
sl@0	5198	PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
sl@0	5199
sl@0	5200	/*
sl@0	5201	* Reflect the change to stackTop back in eePtr.
sl@0	5202	*/
sl@0	5203
sl@0	5204	done:
sl@0	5205	TclDecrRefCount(valuePtr);
sl@0	5206	DECACHE_STACK_INFO();
sl@0	5207	return result;
sl@0	5208	}
sl@0	5209
sl@0	5210	static int
sl@0	5211	ExprBinaryFunc(interp, eePtr, clientData)
sl@0	5212	Tcl_Interp interp; / The interpreter in which to execute the
sl@0	5213	* function. */
sl@0	5214	ExecEnv eePtr; / Points to the environment for executing
sl@0	5215	* the function. */
sl@0	5216	ClientData clientData; /* Contains the address of a procedure that
sl@0	5217	* takes two double arguments and
sl@0	5218	* returns a double result. */
sl@0	5219	{
sl@0	5220	Tcl_Obj *stackPtr; / Cached evaluation stack base pointer. */
sl@0	5221	register int stackTop; /* Cached top index of evaluation stack. */
sl@0	5222	register Tcl_Obj valuePtr, value2Ptr;
sl@0	5223	double d1, d2, dResult;
sl@0	5224	int result;
sl@0	5225
sl@0	5226	double (*func) _ANSI_ARGS_((double, double))
sl@0	5227	= (double (*)_ANSI_ARGS_((double, double))) clientData;
sl@0	5228
sl@0	5229	/*
sl@0	5230	* Set stackPtr and stackTop from eePtr.
sl@0	5231	*/
sl@0	5232
sl@0	5233	result = TCL_OK;
sl@0	5234	CACHE_STACK_INFO();
sl@0	5235
sl@0	5236	/*
sl@0	5237	* Pop the function's two arguments from the evaluation stack. Convert
sl@0	5238	* them to doubles if necessary.
sl@0	5239	*/
sl@0	5240
sl@0	5241	value2Ptr = POP_OBJECT();
sl@0	5242	valuePtr = POP_OBJECT();
sl@0	5243
sl@0	5244	if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) \|\|
sl@0	5245	(VerifyExprObjType(interp, value2Ptr) != TCL_OK)) {
sl@0	5246	result = TCL_ERROR;
sl@0	5247	goto done;
sl@0	5248	}
sl@0	5249
sl@0	5250	GET_DOUBLE_VALUE(d1, valuePtr, valuePtr->typePtr);
sl@0	5251	GET_DOUBLE_VALUE(d2, value2Ptr, value2Ptr->typePtr);
sl@0	5252
sl@0	5253	errno = 0;
sl@0	5254	dResult = (*func)(d1, d2);
sl@0	5255	if ((errno != 0) \|\| IS_NAN(dResult) \|\| IS_INF(dResult)) {
sl@0	5256	TclExprFloatError(interp, dResult);
sl@0	5257	result = TCL_ERROR;
sl@0	5258	goto done;
sl@0	5259	}
sl@0	5260
sl@0	5261	/*
sl@0	5262	* Push a Tcl object holding the result.
sl@0	5263	*/
sl@0	5264
sl@0	5265	PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
sl@0	5266
sl@0	5267	/*
sl@0	5268	* Reflect the change to stackTop back in eePtr.
sl@0	5269	*/
sl@0	5270
sl@0	5271	done:
sl@0	5272	TclDecrRefCount(valuePtr);
sl@0	5273	TclDecrRefCount(value2Ptr);
sl@0	5274	DECACHE_STACK_INFO();
sl@0	5275	return result;
sl@0	5276	}
sl@0	5277
sl@0	5278	static int
sl@0	5279	ExprAbsFunc(interp, eePtr, clientData)
sl@0	5280	Tcl_Interp interp; / The interpreter in which to execute the
sl@0	5281	* function. */
sl@0	5282	ExecEnv eePtr; / Points to the environment for executing
sl@0	5283	* the function. */
sl@0	5284	ClientData clientData; /* Ignored. */
sl@0	5285	{
sl@0	5286	Tcl_Obj *stackPtr; / Cached evaluation stack base pointer. */
sl@0	5287	register int stackTop; /* Cached top index of evaluation stack. */
sl@0	5288	register Tcl_Obj *valuePtr;
sl@0	5289	long i, iResult;
sl@0	5290	double d, dResult;
sl@0	5291	int result;
sl@0	5292
sl@0	5293	/*
sl@0	5294	* Set stackPtr and stackTop from eePtr.
sl@0	5295	*/
sl@0	5296
sl@0	5297	result = TCL_OK;
sl@0	5298	CACHE_STACK_INFO();
sl@0	5299
sl@0	5300	/*
sl@0	5301	* Pop the argument from the evaluation stack.
sl@0	5302	*/
sl@0	5303
sl@0	5304	valuePtr = POP_OBJECT();
sl@0	5305
sl@0	5306	if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
sl@0	5307	result = TCL_ERROR;
sl@0	5308	goto done;
sl@0	5309	}
sl@0	5310
sl@0	5311	/*
sl@0	5312	* Push a Tcl object with the result.
sl@0	5313	*/
sl@0	5314	if (valuePtr->typePtr == &tclIntType) {
sl@0	5315	i = valuePtr->internalRep.longValue;
sl@0	5316	if (i < 0) {
sl@0	5317	if (i == LONG_MIN) {
sl@0	5318	#ifdef TCL_WIDE_INT_IS_LONG
sl@0	5319	Tcl_SetObjResult(interp, Tcl_NewStringObj(
sl@0	5320	"integer value too large to represent", -1));
sl@0	5321	Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
sl@0	5322	"integer value too large to represent", (char *) NULL);
sl@0	5323	result = TCL_ERROR;
sl@0	5324	goto done;
sl@0	5325	#else
sl@0	5326	/*
sl@0	5327	* Special case: abs(MIN_INT) must promote to wide.
sl@0	5328	*/
sl@0	5329
sl@0	5330	PUSH_OBJECT( Tcl_NewWideIntObj(-(Tcl_WideInt) i) );
sl@0	5331	result = TCL_OK;
sl@0	5332	goto done;
sl@0	5333	#endif
sl@0	5334
sl@0	5335	}
sl@0	5336	iResult = -i;
sl@0	5337	} else {
sl@0	5338	iResult = i;
sl@0	5339	}
sl@0	5340	PUSH_OBJECT(Tcl_NewLongObj(iResult));
sl@0	5341	} else if (valuePtr->typePtr == &tclWideIntType) {
sl@0	5342	Tcl_WideInt wResult, w;
sl@0	5343	TclGetWide(w,valuePtr);
sl@0	5344	if (w < W0) {
sl@0	5345	wResult = -w;
sl@0	5346	if (wResult < 0) {
sl@0	5347	Tcl_ResetResult(interp);
sl@0	5348	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	5349	"integer value too large to represent", -1);
sl@0	5350	Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
sl@0	5351	"integer value too large to represent", (char *) NULL);
sl@0	5352	result = TCL_ERROR;
sl@0	5353	goto done;
sl@0	5354	}
sl@0	5355	} else {
sl@0	5356	wResult = w;
sl@0	5357	}
sl@0	5358	PUSH_OBJECT(Tcl_NewWideIntObj(wResult));
sl@0	5359	} else {
sl@0	5360	d = valuePtr->internalRep.doubleValue;
sl@0	5361	if (d < 0.0) {
sl@0	5362	dResult = -d;
sl@0	5363	} else {
sl@0	5364	dResult = d;
sl@0	5365	}
sl@0	5366	if (IS_NAN(dResult) \|\| IS_INF(dResult)) {
sl@0	5367	TclExprFloatError(interp, dResult);
sl@0	5368	result = TCL_ERROR;
sl@0	5369	goto done;
sl@0	5370	}
sl@0	5371	PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
sl@0	5372	}
sl@0	5373
sl@0	5374	/*
sl@0	5375	* Reflect the change to stackTop back in eePtr.
sl@0	5376	*/
sl@0	5377
sl@0	5378	done:
sl@0	5379	TclDecrRefCount(valuePtr);
sl@0	5380	DECACHE_STACK_INFO();
sl@0	5381	return result;
sl@0	5382	}
sl@0	5383
sl@0	5384	static int
sl@0	5385	ExprDoubleFunc(interp, eePtr, clientData)
sl@0	5386	Tcl_Interp interp; / The interpreter in which to execute the
sl@0	5387	* function. */
sl@0	5388	ExecEnv eePtr; / Points to the environment for executing
sl@0	5389	* the function. */
sl@0	5390	ClientData clientData; /* Ignored. */
sl@0	5391	{
sl@0	5392	Tcl_Obj *stackPtr; / Cached evaluation stack base pointer. */
sl@0	5393	register int stackTop; /* Cached top index of evaluation stack. */
sl@0	5394	register Tcl_Obj *valuePtr;
sl@0	5395	double dResult;
sl@0	5396	int result;
sl@0	5397
sl@0	5398	/*
sl@0	5399	* Set stackPtr and stackTop from eePtr.
sl@0	5400	*/
sl@0	5401
sl@0	5402	result = TCL_OK;
sl@0	5403	CACHE_STACK_INFO();
sl@0	5404
sl@0	5405	/*
sl@0	5406	* Pop the argument from the evaluation stack.
sl@0	5407	*/
sl@0	5408
sl@0	5409	valuePtr = POP_OBJECT();
sl@0	5410
sl@0	5411	if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
sl@0	5412	result = TCL_ERROR;
sl@0	5413	goto done;
sl@0	5414	}
sl@0	5415
sl@0	5416	GET_DOUBLE_VALUE(dResult, valuePtr, valuePtr->typePtr);
sl@0	5417
sl@0	5418	/*
sl@0	5419	* Push a Tcl object with the result.
sl@0	5420	*/
sl@0	5421
sl@0	5422	PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
sl@0	5423
sl@0	5424	/*
sl@0	5425	* Reflect the change to stackTop back in eePtr.
sl@0	5426	*/
sl@0	5427
sl@0	5428	done:
sl@0	5429	TclDecrRefCount(valuePtr);
sl@0	5430	DECACHE_STACK_INFO();
sl@0	5431	return result;
sl@0	5432	}
sl@0	5433
sl@0	5434	static int
sl@0	5435	ExprIntFunc(interp, eePtr, clientData)
sl@0	5436	Tcl_Interp interp; / The interpreter in which to execute the
sl@0	5437	* function. */
sl@0	5438	ExecEnv eePtr; / Points to the environment for executing
sl@0	5439	* the function. */
sl@0	5440	ClientData clientData; /* Ignored. */
sl@0	5441	{
sl@0	5442	Tcl_Obj *stackPtr; / Cached evaluation stack base pointer. */
sl@0	5443	register int stackTop; /* Cached top index of evaluation stack. */
sl@0	5444	register Tcl_Obj *valuePtr;
sl@0	5445	long iResult;
sl@0	5446	double d;
sl@0	5447	int result;
sl@0	5448
sl@0	5449	/*
sl@0	5450	* Set stackPtr and stackTop from eePtr.
sl@0	5451	*/
sl@0	5452
sl@0	5453	result = TCL_OK;
sl@0	5454	CACHE_STACK_INFO();
sl@0	5455
sl@0	5456	/*
sl@0	5457	* Pop the argument from the evaluation stack.
sl@0	5458	*/
sl@0	5459
sl@0	5460	valuePtr = POP_OBJECT();
sl@0	5461
sl@0	5462	if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
sl@0	5463	result = TCL_ERROR;
sl@0	5464	goto done;
sl@0	5465	}
sl@0	5466
sl@0	5467	if (valuePtr->typePtr == &tclIntType) {
sl@0	5468	iResult = valuePtr->internalRep.longValue;
sl@0	5469	} else if (valuePtr->typePtr == &tclWideIntType) {
sl@0	5470	TclGetLongFromWide(iResult,valuePtr);
sl@0	5471	} else {
sl@0	5472	d = valuePtr->internalRep.doubleValue;
sl@0	5473	if (d < 0.0) {
sl@0	5474	if (d < (double) (long) LONG_MIN) {
sl@0	5475	tooLarge:
sl@0	5476	Tcl_ResetResult(interp);
sl@0	5477	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	5478	"integer value too large to represent", -1);
sl@0	5479	Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
sl@0	5480	"integer value too large to represent", (char *) NULL);
sl@0	5481	result = TCL_ERROR;
sl@0	5482	goto done;
sl@0	5483	}
sl@0	5484	} else {
sl@0	5485	if (d > (double) LONG_MAX) {
sl@0	5486	goto tooLarge;
sl@0	5487	}
sl@0	5488	}
sl@0	5489	if (IS_NAN(d) \|\| IS_INF(d)) {
sl@0	5490	TclExprFloatError(interp, d);
sl@0	5491	result = TCL_ERROR;
sl@0	5492	goto done;
sl@0	5493	}
sl@0	5494	iResult = (long) d;
sl@0	5495	}
sl@0	5496
sl@0	5497	/*
sl@0	5498	* Push a Tcl object with the result.
sl@0	5499	*/
sl@0	5500
sl@0	5501	PUSH_OBJECT(Tcl_NewLongObj(iResult));
sl@0	5502
sl@0	5503	/*
sl@0	5504	* Reflect the change to stackTop back in eePtr.
sl@0	5505	*/
sl@0	5506
sl@0	5507	done:
sl@0	5508	TclDecrRefCount(valuePtr);
sl@0	5509	DECACHE_STACK_INFO();
sl@0	5510	return result;
sl@0	5511	}
sl@0	5512
sl@0	5513	static int
sl@0	5514	ExprWideFunc(interp, eePtr, clientData)
sl@0	5515	Tcl_Interp interp; / The interpreter in which to execute the
sl@0	5516	* function. */
sl@0	5517	ExecEnv eePtr; / Points to the environment for executing
sl@0	5518	* the function. */
sl@0	5519	ClientData clientData; /* Ignored. */
sl@0	5520	{
sl@0	5521	Tcl_Obj *stackPtr; / Cached evaluation stack base pointer. */
sl@0	5522	register int stackTop; /* Cached top index of evaluation stack. */
sl@0	5523	register Tcl_Obj *valuePtr;
sl@0	5524	Tcl_WideInt wResult;
sl@0	5525	double d;
sl@0	5526	int result;
sl@0	5527
sl@0	5528	/*
sl@0	5529	* Set stackPtr and stackTop from eePtr.
sl@0	5530	*/
sl@0	5531
sl@0	5532	result = TCL_OK;
sl@0	5533	CACHE_STACK_INFO();
sl@0	5534
sl@0	5535	/*
sl@0	5536	* Pop the argument from the evaluation stack.
sl@0	5537	*/
sl@0	5538
sl@0	5539	valuePtr = POP_OBJECT();
sl@0	5540
sl@0	5541	if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
sl@0	5542	result = TCL_ERROR;
sl@0	5543	goto done;
sl@0	5544	}
sl@0	5545
sl@0	5546	if (valuePtr->typePtr == &tclWideIntType) {
sl@0	5547	TclGetWide(wResult,valuePtr);
sl@0	5548	} else if (valuePtr->typePtr == &tclIntType) {
sl@0	5549	wResult = Tcl_LongAsWide(valuePtr->internalRep.longValue);
sl@0	5550	} else {
sl@0	5551	d = valuePtr->internalRep.doubleValue;
sl@0	5552	if (d < 0.0) {
sl@0	5553	if (d < Tcl_WideAsDouble(LLONG_MIN)) {
sl@0	5554	tooLarge:
sl@0	5555	Tcl_ResetResult(interp);
sl@0	5556	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	5557	"integer value too large to represent", -1);
sl@0	5558	Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
sl@0	5559	"integer value too large to represent", (char *) NULL);
sl@0	5560	result = TCL_ERROR;
sl@0	5561	goto done;
sl@0	5562	}
sl@0	5563	} else {
sl@0	5564	if (d > Tcl_WideAsDouble(LLONG_MAX)) {
sl@0	5565	goto tooLarge;
sl@0	5566	}
sl@0	5567	}
sl@0	5568	if (IS_NAN(d) \|\| IS_INF(d)) {
sl@0	5569	TclExprFloatError(interp, d);
sl@0	5570	result = TCL_ERROR;
sl@0	5571	goto done;
sl@0	5572	}
sl@0	5573	wResult = Tcl_DoubleAsWide(d);
sl@0	5574	}
sl@0	5575
sl@0	5576	/*
sl@0	5577	* Push a Tcl object with the result.
sl@0	5578	*/
sl@0	5579
sl@0	5580	PUSH_OBJECT(Tcl_NewWideIntObj(wResult));
sl@0	5581
sl@0	5582	/*
sl@0	5583	* Reflect the change to stackTop back in eePtr.
sl@0	5584	*/
sl@0	5585
sl@0	5586	done:
sl@0	5587	TclDecrRefCount(valuePtr);
sl@0	5588	DECACHE_STACK_INFO();
sl@0	5589	return result;
sl@0	5590	}
sl@0	5591
sl@0	5592	static int
sl@0	5593	ExprRandFunc(interp, eePtr, clientData)
sl@0	5594	Tcl_Interp interp; / The interpreter in which to execute the
sl@0	5595	* function. */
sl@0	5596	ExecEnv eePtr; / Points to the environment for executing
sl@0	5597	* the function. */
sl@0	5598	ClientData clientData; /* Ignored. */
sl@0	5599	{
sl@0	5600	Tcl_Obj *stackPtr; / Cached evaluation stack base pointer. */
sl@0	5601	register int stackTop; /* Cached top index of evaluation stack. */
sl@0	5602	Interp iPtr = (Interp ) interp;
sl@0	5603	double dResult;
sl@0	5604	long tmp; /* Algorithm assumes at least 32 bits.
sl@0	5605	* Only long guarantees that. See below. */
sl@0	5606
sl@0	5607	if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
sl@0	5608	iPtr->flags \|= RAND_SEED_INITIALIZED;
sl@0	5609
sl@0	5610	/*
sl@0	5611	* Take into consideration the thread this interp is running in order
sl@0	5612	* to insure different seeds in different threads (bug #416643)
sl@0	5613	*/
sl@0	5614
sl@0	5615	iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12);
sl@0	5616
sl@0	5617	/*
sl@0	5618	* Make sure 1 <= randSeed <= (2^31) - 2. See below.
sl@0	5619	*/
sl@0	5620
sl@0	5621	iPtr->randSeed &= (unsigned long) 0x7fffffff;
sl@0	5622	if ((iPtr->randSeed == 0) \|\| (iPtr->randSeed == 0x7fffffff)) {
sl@0	5623	iPtr->randSeed ^= 123459876;
sl@0	5624	}
sl@0	5625	}
sl@0	5626
sl@0	5627	/*
sl@0	5628	* Set stackPtr and stackTop from eePtr.
sl@0	5629	*/
sl@0	5630
sl@0	5631	CACHE_STACK_INFO();
sl@0	5632
sl@0	5633	/*
sl@0	5634	* Generate the random number using the linear congruential
sl@0	5635	* generator defined by the following recurrence:
sl@0	5636	* seed = ( IA * seed ) mod IM
sl@0	5637	* where IA is 16807 and IM is (2^31) - 1. The recurrence maps
sl@0	5638	* a seed in the range [1, IM - 1] to a new seed in that same range.
sl@0	5639	* The recurrence maps IM to 0, and maps 0 back to 0, so those two
sl@0	5640	* values must not be allowed as initial values of seed.
sl@0	5641	*
sl@0	5642	* In order to avoid potential problems with integer overflow, the
sl@0	5643	* recurrence is implemented in terms of additional constants
sl@0	5644	* IQ and IR such that
sl@0	5645	* IM = IA*IQ + IR
sl@0	5646	* None of the operations in the implementation overflows a 32-bit
sl@0	5647	* signed integer, and the C type long is guaranteed to be at least
sl@0	5648	* 32 bits wide.
sl@0	5649	*
sl@0	5650	* For more details on how this algorithm works, refer to the following
sl@0	5651	* papers:
sl@0	5652	*
sl@0	5653	* S.K. Park & K.W. Miller, "Random number generators: good ones
sl@0	5654	* are hard to find," Comm ACM 31(10):1192-1201, Oct 1988
sl@0	5655	*
sl@0	5656	* W.H. Press & S.A. Teukolsky, "Portable random number
sl@0	5657	* generators," Computers in Physics 6(5):522-524, Sep/Oct 1992.
sl@0	5658	*/
sl@0	5659
sl@0	5660	#define RAND_IA 16807
sl@0	5661	#define RAND_IM 2147483647
sl@0	5662	#define RAND_IQ 127773
sl@0	5663	#define RAND_IR 2836
sl@0	5664	#define RAND_MASK 123459876
sl@0	5665
sl@0	5666	tmp = iPtr->randSeed/RAND_IQ;
sl@0	5667	iPtr->randSeed = RAND_IA(iPtr->randSeed - tmpRAND_IQ) - RAND_IR*tmp;
sl@0	5668	if (iPtr->randSeed < 0) {
sl@0	5669	iPtr->randSeed += RAND_IM;
sl@0	5670	}
sl@0	5671
sl@0	5672	/*
sl@0	5673	* Since the recurrence keeps seed values in the range [1, RAND_IM - 1],
sl@0	5674	* dividing by RAND_IM yields a double in the range (0, 1).
sl@0	5675	*/
sl@0	5676
sl@0	5677	dResult = iPtr->randSeed * (1.0/RAND_IM);
sl@0	5678
sl@0	5679	/*
sl@0	5680	* Push a Tcl object with the result.
sl@0	5681	*/
sl@0	5682
sl@0	5683	PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
sl@0	5684
sl@0	5685	/*
sl@0	5686	* Reflect the change to stackTop back in eePtr.
sl@0	5687	*/
sl@0	5688
sl@0	5689	DECACHE_STACK_INFO();
sl@0	5690	return TCL_OK;
sl@0	5691	}
sl@0	5692
sl@0	5693	static int
sl@0	5694	ExprRoundFunc(interp, eePtr, clientData)
sl@0	5695	Tcl_Interp interp; / The interpreter in which to execute the
sl@0	5696	* function. */
sl@0	5697	ExecEnv eePtr; / Points to the environment for executing
sl@0	5698	* the function. */
sl@0	5699	ClientData clientData; /* Ignored. */
sl@0	5700	{
sl@0	5701	Tcl_Obj *stackPtr; / Cached evaluation stack base pointer. */
sl@0	5702	register int stackTop; /* Cached top index of evaluation stack. */
sl@0	5703	Tcl_Obj valuePtr, resPtr;
sl@0	5704	double d, f, i;
sl@0	5705	int result;
sl@0	5706
sl@0	5707	/*
sl@0	5708	* Set stackPtr and stackTop from eePtr.
sl@0	5709	*/
sl@0	5710
sl@0	5711	result = TCL_OK;
sl@0	5712	CACHE_STACK_INFO();
sl@0	5713
sl@0	5714	/*
sl@0	5715	* Pop the argument from the evaluation stack.
sl@0	5716	*/
sl@0	5717
sl@0	5718	valuePtr = POP_OBJECT();
sl@0	5719
sl@0	5720	if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
sl@0	5721	result = TCL_ERROR;
sl@0	5722	goto done;
sl@0	5723	}
sl@0	5724
sl@0	5725	if ((valuePtr->typePtr == &tclIntType) \|\|
sl@0	5726	(valuePtr->typePtr == &tclWideIntType)) {
sl@0	5727	result = TCL_OK;
sl@0	5728	resPtr = valuePtr;
sl@0	5729	} else {
sl@0	5730
sl@0	5731	/*
sl@0	5732	* Round the number to the nearest integer. I'd like to use round(),
sl@0	5733	* but it's C99 (or BSD), and not yet universal.
sl@0	5734	*/
sl@0	5735
sl@0	5736	d = valuePtr->internalRep.doubleValue;
sl@0	5737	f = modf(d, &i);
sl@0	5738	if (d < 0.0) {
sl@0	5739	if (f <= -0.5) {
sl@0	5740	i += -1.0;
sl@0	5741	}
sl@0	5742	if (i <= Tcl_WideAsDouble(LLONG_MIN)) {
sl@0	5743	goto tooLarge;
sl@0	5744	} else if (i <= (double) LONG_MIN) {
sl@0	5745	resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i));
sl@0	5746	} else {
sl@0	5747	resPtr = Tcl_NewLongObj((long) i);
sl@0	5748	}
sl@0	5749	} else {
sl@0	5750	if (f >= 0.5) {
sl@0	5751	i += 1.0;
sl@0	5752	}
sl@0	5753	if (i >= Tcl_WideAsDouble(LLONG_MAX)) {
sl@0	5754	goto tooLarge;
sl@0	5755	} else if (i >= (double) LONG_MAX) {
sl@0	5756	resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i));
sl@0	5757	} else {
sl@0	5758	resPtr = Tcl_NewLongObj((long) i);
sl@0	5759	}
sl@0	5760	}
sl@0	5761	}
sl@0	5762
sl@0	5763	/*
sl@0	5764	* Push the result object and free the argument Tcl_Obj.
sl@0	5765	*/
sl@0	5766
sl@0	5767	PUSH_OBJECT(resPtr);
sl@0	5768
sl@0	5769	done:
sl@0	5770	TclDecrRefCount(valuePtr);
sl@0	5771	DECACHE_STACK_INFO();
sl@0	5772	return result;
sl@0	5773
sl@0	5774	/*
sl@0	5775	* Error return: result cannot be represented as an integer.
sl@0	5776	*/
sl@0	5777
sl@0	5778	tooLarge:
sl@0	5779	Tcl_ResetResult(interp);
sl@0	5780	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	5781	"integer value too large to represent", -1);
sl@0	5782	Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
sl@0	5783	"integer value too large to represent",
sl@0	5784	(char *) NULL);
sl@0	5785	result = TCL_ERROR;
sl@0	5786	goto done;
sl@0	5787	}
sl@0	5788
sl@0	5789	static int
sl@0	5790	ExprSrandFunc(interp, eePtr, clientData)
sl@0	5791	Tcl_Interp interp; / The interpreter in which to execute the
sl@0	5792	* function. */
sl@0	5793	ExecEnv eePtr; / Points to the environment for executing
sl@0	5794	* the function. */
sl@0	5795	ClientData clientData; /* Ignored. */
sl@0	5796	{
sl@0	5797	Tcl_Obj *stackPtr; / Cached evaluation stack base pointer. */
sl@0	5798	register int stackTop; /* Cached top index of evaluation stack. */
sl@0	5799	Interp iPtr = (Interp ) interp;
sl@0	5800	Tcl_Obj *valuePtr;
sl@0	5801	long i = 0; /* Initialized to avoid compiler warning. */
sl@0	5802
sl@0	5803	/*
sl@0	5804	* Set stackPtr and stackTop from eePtr.
sl@0	5805	*/
sl@0	5806
sl@0	5807	CACHE_STACK_INFO();
sl@0	5808
sl@0	5809	/*
sl@0	5810	* Pop the argument from the evaluation stack. Use the value
sl@0	5811	* to reset the random number seed.
sl@0	5812	*/
sl@0	5813
sl@0	5814	valuePtr = POP_OBJECT();
sl@0	5815
sl@0	5816	if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
sl@0	5817	goto badValue;
sl@0	5818	}
sl@0	5819
sl@0	5820	if (Tcl_GetLongFromObj(NULL, valuePtr, &i) != TCL_OK) {
sl@0	5821	Tcl_WideInt w;
sl@0	5822
sl@0	5823	if (Tcl_GetWideIntFromObj(interp, valuePtr, &w) != TCL_OK) {
sl@0	5824	badValue:
sl@0	5825	Tcl_AddErrorInfo(interp, "\n (argument to \"srand()\")");
sl@0	5826	TclDecrRefCount(valuePtr);
sl@0	5827	DECACHE_STACK_INFO();
sl@0	5828	return TCL_ERROR;
sl@0	5829	}
sl@0	5830
sl@0	5831	i = Tcl_WideAsLong(w);
sl@0	5832	}
sl@0	5833
sl@0	5834	/*
sl@0	5835	* Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2.
sl@0	5836	* See comments in ExprRandFunc() for more details.
sl@0	5837	*/
sl@0	5838
sl@0	5839	iPtr->flags \|= RAND_SEED_INITIALIZED;
sl@0	5840	iPtr->randSeed = i;
sl@0	5841	iPtr->randSeed &= (unsigned long) 0x7fffffff;
sl@0	5842	if ((iPtr->randSeed == 0) \|\| (iPtr->randSeed == 0x7fffffff)) {
sl@0	5843	iPtr->randSeed ^= 123459876;
sl@0	5844	}
sl@0	5845
sl@0	5846	/*
sl@0	5847	* To avoid duplicating the random number generation code we simply
sl@0	5848	* clean up our state and call the real random number function. That
sl@0	5849	* function will always succeed.
sl@0	5850	*/
sl@0	5851
sl@0	5852	TclDecrRefCount(valuePtr);
sl@0	5853	DECACHE_STACK_INFO();
sl@0	5854
sl@0	5855	ExprRandFunc(interp, eePtr, clientData);
sl@0	5856	return TCL_OK;
sl@0	5857	}
sl@0	5858
sl@0	5859	/*
sl@0	5860	*----------------------------------------------------------------------
sl@0	5861	*
sl@0	5862	* ExprCallMathFunc --
sl@0	5863	*
sl@0	5864	* This procedure is invoked to call a non-builtin math function
sl@0	5865	* during the execution of an expression.
sl@0	5866	*
sl@0	5867	* Results:
sl@0	5868	* TCL_OK is returned if all went well and the function's value
sl@0	5869	* was computed successfully. If an error occurred, TCL_ERROR
sl@0	5870	* is returned and an error message is left in the interpreter's
sl@0	5871	* result. After a successful return this procedure pushes a Tcl object
sl@0	5872	* holding the result.
sl@0	5873	*
sl@0	5874	* Side effects:
sl@0	5875	* None, unless the called math function has side effects.
sl@0	5876	*
sl@0	5877	*----------------------------------------------------------------------
sl@0	5878	*/
sl@0	5879
sl@0	5880	static int
sl@0	5881	ExprCallMathFunc(interp, eePtr, objc, objv)
sl@0	5882	Tcl_Interp interp; / The interpreter in which to execute the
sl@0	5883	* function. */
sl@0	5884	ExecEnv eePtr; / Points to the environment for executing
sl@0	5885	* the function. */
sl@0	5886	int objc; /* Number of arguments. The function name is
sl@0	5887	* the 0-th argument. */
sl@0	5888	Tcl_Obj *objv; / The array of arguments. The function name
sl@0	5889	* is objv[0]. */
sl@0	5890	{
sl@0	5891	Interp iPtr = (Interp ) interp;
sl@0	5892	Tcl_Obj *stackPtr; / Cached evaluation stack base pointer. */
sl@0	5893	register int stackTop; /* Cached top index of evaluation stack. */
sl@0	5894	char *funcName;
sl@0	5895	Tcl_HashEntry *hPtr;
sl@0	5896	MathFunc mathFuncPtr; / Information about math function. */
sl@0	5897	Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */
sl@0	5898	Tcl_Value funcResult; /* Result of function call as Tcl_Value. */
sl@0	5899	register Tcl_Obj *valuePtr;
sl@0	5900	long i;
sl@0	5901	double d;
sl@0	5902	int j, k, result;
sl@0	5903
sl@0	5904	Tcl_ResetResult(interp);
sl@0	5905
sl@0	5906	/*
sl@0	5907	* Set stackPtr and stackTop from eePtr.
sl@0	5908	*/
sl@0	5909
sl@0	5910	CACHE_STACK_INFO();
sl@0	5911
sl@0	5912	/*
sl@0	5913	* Look up the MathFunc record for the function.
sl@0	5914	*/
sl@0	5915
sl@0	5916	funcName = TclGetString(objv[0]);
sl@0	5917	hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
sl@0	5918	if (hPtr == NULL) {
sl@0	5919	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	5920	"unknown math function \"", funcName, "\"", (char *) NULL);
sl@0	5921	result = TCL_ERROR;
sl@0	5922	goto done;
sl@0	5923	}
sl@0	5924	mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
sl@0	5925	if (mathFuncPtr->numArgs != (objc-1)) {
sl@0	5926	panic("ExprCallMathFunc: expected number of args %d != actual number %d",
sl@0	5927	mathFuncPtr->numArgs, objc);
sl@0	5928	result = TCL_ERROR;
sl@0	5929	goto done;
sl@0	5930	}
sl@0	5931
sl@0	5932	/*
sl@0	5933	* Collect the arguments for the function, if there are any, into the
sl@0	5934	* array "args". Note that args[0] will have the Tcl_Value that
sl@0	5935	* corresponds to objv[1].
sl@0	5936	*/
sl@0	5937
sl@0	5938	for (j = 1, k = 0; j < objc; j++, k++) {
sl@0	5939	valuePtr = objv[j];
sl@0	5940
sl@0	5941	if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
sl@0	5942	result = TCL_ERROR;
sl@0	5943	goto done;
sl@0	5944	}
sl@0	5945
sl@0	5946	/*
sl@0	5947	* Copy the object's numeric value to the argument record,
sl@0	5948	* converting it if necessary.
sl@0	5949	*/
sl@0	5950
sl@0	5951	if (valuePtr->typePtr == &tclIntType) {
sl@0	5952	i = valuePtr->internalRep.longValue;
sl@0	5953	if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
sl@0	5954	args[k].type = TCL_DOUBLE;
sl@0	5955	args[k].doubleValue = i;
sl@0	5956	} else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
sl@0	5957	args[k].type = TCL_WIDE_INT;
sl@0	5958	args[k].wideValue = Tcl_LongAsWide(i);
sl@0	5959	} else {
sl@0	5960	args[k].type = TCL_INT;
sl@0	5961	args[k].intValue = i;
sl@0	5962	}
sl@0	5963	} else if (valuePtr->typePtr == &tclWideIntType) {
sl@0	5964	Tcl_WideInt w;
sl@0	5965	TclGetWide(w,valuePtr);
sl@0	5966	if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
sl@0	5967	args[k].type = TCL_DOUBLE;
sl@0	5968	args[k].doubleValue = Tcl_WideAsDouble(w);
sl@0	5969	} else if (mathFuncPtr->argTypes[k] == TCL_INT) {
sl@0	5970	args[k].type = TCL_INT;
sl@0	5971	args[k].intValue = Tcl_WideAsLong(w);
sl@0	5972	} else {
sl@0	5973	args[k].type = TCL_WIDE_INT;
sl@0	5974	args[k].wideValue = w;
sl@0	5975	}
sl@0	5976	} else {
sl@0	5977	d = valuePtr->internalRep.doubleValue;
sl@0	5978	if (mathFuncPtr->argTypes[k] == TCL_INT) {
sl@0	5979	args[k].type = TCL_INT;
sl@0	5980	args[k].intValue = (long) d;
sl@0	5981	} else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
sl@0	5982	args[k].type = TCL_WIDE_INT;
sl@0	5983	args[k].wideValue = Tcl_DoubleAsWide(d);
sl@0	5984	} else {
sl@0	5985	args[k].type = TCL_DOUBLE;
sl@0	5986	args[k].doubleValue = d;
sl@0	5987	}
sl@0	5988	}
sl@0	5989	}
sl@0	5990
sl@0	5991	/*
sl@0	5992	* Invoke the function and copy its result back into valuePtr.
sl@0	5993	*/
sl@0	5994
sl@0	5995	result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
sl@0	5996	&funcResult);
sl@0	5997	if (result != TCL_OK) {
sl@0	5998	goto done;
sl@0	5999	}
sl@0	6000
sl@0	6001	/*
sl@0	6002	* Pop the objc top stack elements and decrement their ref counts.
sl@0	6003	*/
sl@0	6004
sl@0	6005	k = (stackTop - (objc-1));
sl@0	6006	while (stackTop >= k) {
sl@0	6007	valuePtr = POP_OBJECT();
sl@0	6008	TclDecrRefCount(valuePtr);
sl@0	6009	}
sl@0	6010
sl@0	6011	/*
sl@0	6012	* Push the call's object result.
sl@0	6013	*/
sl@0	6014
sl@0	6015	if (funcResult.type == TCL_INT) {
sl@0	6016	PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue));
sl@0	6017	} else if (funcResult.type == TCL_WIDE_INT) {
sl@0	6018	PUSH_OBJECT(Tcl_NewWideIntObj(funcResult.wideValue));
sl@0	6019	} else {
sl@0	6020	d = funcResult.doubleValue;
sl@0	6021	if (IS_NAN(d) \|\| IS_INF(d)) {
sl@0	6022	TclExprFloatError(interp, d);
sl@0	6023	result = TCL_ERROR;
sl@0	6024	goto done;
sl@0	6025	}
sl@0	6026	PUSH_OBJECT(Tcl_NewDoubleObj(d));
sl@0	6027	}
sl@0	6028
sl@0	6029	/*
sl@0	6030	* Reflect the change to stackTop back in eePtr.
sl@0	6031	*/
sl@0	6032
sl@0	6033	done:
sl@0	6034	DECACHE_STACK_INFO();
sl@0	6035	return result;
sl@0	6036	}
sl@0	6037
sl@0	6038	/*
sl@0	6039	*----------------------------------------------------------------------
sl@0	6040	*
sl@0	6041	* TclExprFloatError --
sl@0	6042	*
sl@0	6043	* This procedure is called when an error occurs during a
sl@0	6044	* floating-point operation. It reads errno and sets
sl@0	6045	* interp->objResultPtr accordingly.
sl@0	6046	*
sl@0	6047	* Results:
sl@0	6048	* interp->objResultPtr is set to hold an error message.
sl@0	6049	*
sl@0	6050	* Side effects:
sl@0	6051	* None.
sl@0	6052	*
sl@0	6053	*----------------------------------------------------------------------
sl@0	6054	*/
sl@0	6055
sl@0	6056	void
sl@0	6057	TclExprFloatError(interp, value)
sl@0	6058	Tcl_Interp interp; / Where to store error message. */
sl@0	6059	double value; /* Value returned after error; used to
sl@0	6060	* distinguish underflows from overflows. */
sl@0	6061	{
sl@0	6062	char *s;
sl@0	6063
sl@0	6064	Tcl_ResetResult(interp);
sl@0	6065	if ((errno == EDOM) \|\| IS_NAN(value)) {
sl@0	6066	s = "domain error: argument not in valid range";
sl@0	6067	Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
sl@0	6068	Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL);
sl@0	6069	} else if ((errno == ERANGE) \|\| IS_INF(value)) {
sl@0	6070	if (value == 0.0) {
sl@0	6071	s = "floating-point value too small to represent";
sl@0	6072	Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
sl@0	6073	Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL);
sl@0	6074	} else {
sl@0	6075	s = "floating-point value too large to represent";
sl@0	6076	Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
sl@0	6077	Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL);
sl@0	6078	}
sl@0	6079	} else {
sl@0	6080	char msg[64 + TCL_INTEGER_SPACE];
sl@0	6081
sl@0	6082	sprintf(msg, "unknown floating-point error, errno = %d", errno);
sl@0	6083	Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1);
sl@0	6084	Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL);
sl@0	6085	}
sl@0	6086	}
sl@0	6087
sl@0	6088	#ifdef TCL_COMPILE_STATS
sl@0	6089	/*
sl@0	6090	*----------------------------------------------------------------------
sl@0	6091	*
sl@0	6092	* TclLog2 --
sl@0	6093	*
sl@0	6094	* Procedure used while collecting compilation statistics to determine
sl@0	6095	* the log base 2 of an integer.
sl@0	6096	*
sl@0	6097	* Results:
sl@0	6098	* Returns the log base 2 of the operand. If the argument is less
sl@0	6099	* than or equal to zero, a zero is returned.
sl@0	6100	*
sl@0	6101	* Side effects:
sl@0	6102	* None.
sl@0	6103	*
sl@0	6104	*----------------------------------------------------------------------
sl@0	6105	*/
sl@0	6106
sl@0	6107	int
sl@0	6108	TclLog2(value)
sl@0	6109	register int value; /* The integer for which to compute the
sl@0	6110	* log base 2. */
sl@0	6111	{
sl@0	6112	register int n = value;
sl@0	6113	register int result = 0;
sl@0	6114
sl@0	6115	while (n > 1) {
sl@0	6116	n = n >> 1;
sl@0	6117	result++;
sl@0	6118	}
sl@0	6119	return result;
sl@0	6120	}
sl@0	6121
sl@0	6122	/*
sl@0	6123	*----------------------------------------------------------------------
sl@0	6124	*
sl@0	6125	* EvalStatsCmd --
sl@0	6126	*
sl@0	6127	* Implements the "evalstats" command that prints instruction execution
sl@0	6128	* counts to stdout.
sl@0	6129	*
sl@0	6130	* Results:
sl@0	6131	* Standard Tcl results.
sl@0	6132	*
sl@0	6133	* Side effects:
sl@0	6134	* None.
sl@0	6135	*
sl@0	6136	*----------------------------------------------------------------------
sl@0	6137	*/
sl@0	6138
sl@0	6139	static int
sl@0	6140	EvalStatsCmd(unused, interp, objc, objv)
sl@0	6141	ClientData unused; /* Unused. */
sl@0	6142	Tcl_Interp interp; / The current interpreter. */
sl@0	6143	int objc; /* The number of arguments. */
sl@0	6144	Tcl_Obj CONST objv[]; / The argument strings. */
sl@0	6145	{
sl@0	6146	Interp iPtr = (Interp ) interp;
sl@0	6147	LiteralTable *globalTablePtr = &(iPtr->literalTable);
sl@0	6148	ByteCodeStats *statsPtr = &(iPtr->stats);
sl@0	6149	double totalCodeBytes, currentCodeBytes;
sl@0	6150	double totalLiteralBytes, currentLiteralBytes;
sl@0	6151	double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
sl@0	6152	double strBytesSharedMultX, strBytesSharedOnce;
sl@0	6153	double numInstructions, currentHeaderBytes;
sl@0	6154	long numCurrentByteCodes, numByteCodeLits;
sl@0	6155	long refCountSum, literalMgmtBytes, sum;
sl@0	6156	int numSharedMultX, numSharedOnce;
sl@0	6157	int decadeHigh, minSizeDecade, maxSizeDecade, length, i;
sl@0	6158	char *litTableStats;
sl@0	6159	LiteralEntry *entryPtr;
sl@0	6160
sl@0	6161	numInstructions = 0.0;
sl@0	6162	for (i = 0; i < 256; i++) {
sl@0	6163	if (statsPtr->instructionCount[i] != 0) {
sl@0	6164	numInstructions += statsPtr->instructionCount[i];
sl@0	6165	}
sl@0	6166	}
sl@0	6167
sl@0	6168	totalLiteralBytes = sizeof(LiteralTable)
sl@0	6169	+ iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)
sl@0	6170	+ (statsPtr->numLiteralsCreated * sizeof(LiteralEntry))
sl@0	6171	+ (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj))
sl@0	6172	+ statsPtr->totalLitStringBytes;
sl@0	6173	totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes;
sl@0	6174
sl@0	6175	numCurrentByteCodes =
sl@0	6176	statsPtr->numCompilations - statsPtr->numByteCodesFreed;
sl@0	6177	currentHeaderBytes = numCurrentByteCodes
sl@0	6178	* (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time)));
sl@0	6179	literalMgmtBytes = sizeof(LiteralTable)
sl@0	6180	+ (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *))
sl@0	6181	+ (iPtr->literalTable.numEntries * sizeof(LiteralEntry));
sl@0	6182	currentLiteralBytes = literalMgmtBytes
sl@0	6183	+ iPtr->literalTable.numEntries * sizeof(Tcl_Obj)
sl@0	6184	+ statsPtr->currentLitStringBytes;
sl@0	6185	currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes;
sl@0	6186
sl@0	6187	/*
sl@0	6188	* Summary statistics, total and current source and ByteCode sizes.
sl@0	6189	*/
sl@0	6190
sl@0	6191	fprintf(stdout, "\n----------------------------------------------------------------\n");
sl@0	6192	fprintf(stdout,
sl@0	6193	"Compilation and execution statistics for interpreter 0x%x\n",
sl@0	6194	(unsigned int) iPtr);
sl@0	6195
sl@0	6196	fprintf(stdout, "\nNumber ByteCodes executed %ld\n",
sl@0	6197	statsPtr->numExecutions);
sl@0	6198	fprintf(stdout, "Number ByteCodes compiled %ld\n",
sl@0	6199	statsPtr->numCompilations);
sl@0	6200	fprintf(stdout, " Mean executions/compile %.1f\n",
sl@0	6201	((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations));
sl@0	6202
sl@0	6203	fprintf(stdout, "\nInstructions executed %.0f\n",
sl@0	6204	numInstructions);
sl@0	6205	fprintf(stdout, " Mean inst/compile %.0f\n",
sl@0	6206	numInstructions / statsPtr->numCompilations);
sl@0	6207	fprintf(stdout, " Mean inst/execution %.0f\n",
sl@0	6208	numInstructions / statsPtr->numExecutions);
sl@0	6209
sl@0	6210	fprintf(stdout, "\nTotal ByteCodes %ld\n",
sl@0	6211	statsPtr->numCompilations);
sl@0	6212	fprintf(stdout, " Source bytes %.6g\n",
sl@0	6213	statsPtr->totalSrcBytes);
sl@0	6214	fprintf(stdout, " Code bytes %.6g\n",
sl@0	6215	totalCodeBytes);
sl@0	6216	fprintf(stdout, " ByteCode bytes %.6g\n",
sl@0	6217	statsPtr->totalByteCodeBytes);
sl@0	6218	fprintf(stdout, " Literal bytes %.6g\n",
sl@0	6219	totalLiteralBytes);
sl@0	6220	fprintf(stdout, " table %d + bkts %d + entries %ld + objects %ld + strings %.6g\n",
sl@0	6221	sizeof(LiteralTable),
sl@0	6222	iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
sl@0	6223	statsPtr->numLiteralsCreated * sizeof(LiteralEntry),
sl@0	6224	statsPtr->numLiteralsCreated * sizeof(Tcl_Obj),
sl@0	6225	statsPtr->totalLitStringBytes);
sl@0	6226	fprintf(stdout, " Mean code/compile %.1f\n",
sl@0	6227	totalCodeBytes / statsPtr->numCompilations);
sl@0	6228	fprintf(stdout, " Mean code/source %.1f\n",
sl@0	6229	totalCodeBytes / statsPtr->totalSrcBytes);
sl@0	6230
sl@0	6231	fprintf(stdout, "\nCurrent (active) ByteCodes %ld\n",
sl@0	6232	numCurrentByteCodes);
sl@0	6233	fprintf(stdout, " Source bytes %.6g\n",
sl@0	6234	statsPtr->currentSrcBytes);
sl@0	6235	fprintf(stdout, " Code bytes %.6g\n",
sl@0	6236	currentCodeBytes);
sl@0	6237	fprintf(stdout, " ByteCode bytes %.6g\n",
sl@0	6238	statsPtr->currentByteCodeBytes);
sl@0	6239	fprintf(stdout, " Literal bytes %.6g\n",
sl@0	6240	currentLiteralBytes);
sl@0	6241	fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n",
sl@0	6242	sizeof(LiteralTable),
sl@0	6243	iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
sl@0	6244	iPtr->literalTable.numEntries * sizeof(LiteralEntry),
sl@0	6245	iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
sl@0	6246	statsPtr->currentLitStringBytes);
sl@0	6247	fprintf(stdout, " Mean code/source %.1f\n",
sl@0	6248	currentCodeBytes / statsPtr->currentSrcBytes);
sl@0	6249	fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n",
sl@0	6250	(currentCodeBytes + statsPtr->currentSrcBytes),
sl@0	6251	(currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
sl@0	6252
sl@0	6253	/*
sl@0	6254	* Tcl_IsShared statistics check
sl@0	6255	*
sl@0	6256	* This gives the refcount of each obj as Tcl_IsShared was called
sl@0	6257	* for it. Shared objects must be duplicated before they can be
sl@0	6258	* modified.
sl@0	6259	*/
sl@0	6260
sl@0	6261	numSharedMultX = 0;
sl@0	6262	fprintf(stdout, "\nTcl_IsShared object check (all objects):\n");
sl@0	6263	fprintf(stdout, " Object had refcount <=1 (not shared) %ld\n",
sl@0	6264	tclObjsShared[1]);
sl@0	6265	for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) {
sl@0	6266	fprintf(stdout, " refcount ==%d %ld\n",
sl@0	6267	i, tclObjsShared[i]);
sl@0	6268	numSharedMultX += tclObjsShared[i];
sl@0	6269	}
sl@0	6270	fprintf(stdout, " refcount >=%d %ld\n",
sl@0	6271	i, tclObjsShared[0]);
sl@0	6272	numSharedMultX += tclObjsShared[0];
sl@0	6273	fprintf(stdout, " Total shared objects %d\n",
sl@0	6274	numSharedMultX);
sl@0	6275
sl@0	6276	/*
sl@0	6277	* Literal table statistics.
sl@0	6278	*/
sl@0	6279
sl@0	6280	numByteCodeLits = 0;
sl@0	6281	refCountSum = 0;
sl@0	6282	numSharedMultX = 0;
sl@0	6283	numSharedOnce = 0;
sl@0	6284	objBytesIfUnshared = 0.0;
sl@0	6285	strBytesIfUnshared = 0.0;
sl@0	6286	strBytesSharedMultX = 0.0;
sl@0	6287	strBytesSharedOnce = 0.0;
sl@0	6288	for (i = 0; i < globalTablePtr->numBuckets; i++) {
sl@0	6289	for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
sl@0	6290	entryPtr = entryPtr->nextPtr) {
sl@0	6291	if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
sl@0	6292	numByteCodeLits++;
sl@0	6293	}
sl@0	6294	(void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
sl@0	6295	refCountSum += entryPtr->refCount;
sl@0	6296	objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
sl@0	6297	strBytesIfUnshared += (entryPtr->refCount * (length+1));
sl@0	6298	if (entryPtr->refCount > 1) {
sl@0	6299	numSharedMultX++;
sl@0	6300	strBytesSharedMultX += (length+1);
sl@0	6301	} else {
sl@0	6302	numSharedOnce++;
sl@0	6303	strBytesSharedOnce += (length+1);
sl@0	6304	}
sl@0	6305	}
sl@0	6306	}
sl@0	6307	sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
sl@0	6308	- currentLiteralBytes;
sl@0	6309
sl@0	6310	fprintf(stdout, "\nTotal objects (all interps) %ld\n",
sl@0	6311	tclObjsAlloced);
sl@0	6312	fprintf(stdout, "Current objects %ld\n",
sl@0	6313	(tclObjsAlloced - tclObjsFreed));
sl@0	6314	fprintf(stdout, "Total literal objects %ld\n",
sl@0	6315	statsPtr->numLiteralsCreated);
sl@0	6316
sl@0	6317	fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n",
sl@0	6318	globalTablePtr->numEntries,
sl@0	6319	(globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed));
sl@0	6320	fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)\n",
sl@0	6321	numByteCodeLits,
sl@0	6322	(numByteCodeLits * 100.0) / globalTablePtr->numEntries);
sl@0	6323	fprintf(stdout, " Literals reused > 1x %d\n",
sl@0	6324	numSharedMultX);
sl@0	6325	fprintf(stdout, " Mean reference count %.2f\n",
sl@0	6326	((double) refCountSum) / globalTablePtr->numEntries);
sl@0	6327	fprintf(stdout, " Mean len, str reused >1x %.2f\n",
sl@0	6328	(numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0));
sl@0	6329	fprintf(stdout, " Mean len, str used 1x %.2f\n",
sl@0	6330	(numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0));
sl@0	6331	fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n",
sl@0	6332	sharingBytesSaved,
sl@0	6333	(sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared));
sl@0	6334	fprintf(stdout, " Bytes with sharing %.6g\n",
sl@0	6335	currentLiteralBytes);
sl@0	6336	fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n",
sl@0	6337	sizeof(LiteralTable),
sl@0	6338	iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
sl@0	6339	iPtr->literalTable.numEntries * sizeof(LiteralEntry),
sl@0	6340	iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
sl@0	6341	statsPtr->currentLitStringBytes);
sl@0	6342	fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n",
sl@0	6343	(objBytesIfUnshared + strBytesIfUnshared),
sl@0	6344	objBytesIfUnshared, strBytesIfUnshared);
sl@0	6345	fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6g\n",
sl@0	6346	(strBytesIfUnshared - statsPtr->currentLitStringBytes),
sl@0	6347	strBytesIfUnshared, statsPtr->currentLitStringBytes);
sl@0	6348	fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n",
sl@0	6349	literalMgmtBytes,
sl@0	6350	(literalMgmtBytes * 100.0) / currentLiteralBytes);
sl@0	6351	fprintf(stdout, " table %d + buckets %d + entries %d\n",
sl@0	6352	sizeof(LiteralTable),
sl@0	6353	iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
sl@0	6354	iPtr->literalTable.numEntries * sizeof(LiteralEntry));
sl@0	6355
sl@0	6356	/*
sl@0	6357	* Breakdown of current ByteCode space requirements.
sl@0	6358	*/
sl@0	6359
sl@0	6360	fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n");
sl@0	6361	fprintf(stdout, " Bytes Pct of Avg per\n");
sl@0	6362	fprintf(stdout, " total ByteCode\n");
sl@0	6363	fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n",
sl@0	6364	statsPtr->currentByteCodeBytes,
sl@0	6365	statsPtr->currentByteCodeBytes / numCurrentByteCodes);
sl@0	6366	fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n",
sl@0	6367	currentHeaderBytes,
sl@0	6368	((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes),
sl@0	6369	currentHeaderBytes / numCurrentByteCodes);
sl@0	6370	fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n",
sl@0	6371	statsPtr->currentInstBytes,
sl@0	6372	((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes),
sl@0	6373	statsPtr->currentInstBytes / numCurrentByteCodes);
sl@0	6374	fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n",
sl@0	6375	statsPtr->currentLitBytes,
sl@0	6376	((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes),
sl@0	6377	statsPtr->currentLitBytes / numCurrentByteCodes);
sl@0	6378	fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n",
sl@0	6379	statsPtr->currentExceptBytes,
sl@0	6380	((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes),
sl@0	6381	statsPtr->currentExceptBytes / numCurrentByteCodes);
sl@0	6382	fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n",
sl@0	6383	statsPtr->currentAuxBytes,
sl@0	6384	((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes),
sl@0	6385	statsPtr->currentAuxBytes / numCurrentByteCodes);
sl@0	6386	fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n",
sl@0	6387	statsPtr->currentCmdMapBytes,
sl@0	6388	((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes),
sl@0	6389	statsPtr->currentCmdMapBytes / numCurrentByteCodes);
sl@0	6390
sl@0	6391	/*
sl@0	6392	* Detailed literal statistics.
sl@0	6393	*/
sl@0	6394
sl@0	6395	fprintf(stdout, "\nLiteral string sizes:\n");
sl@0	6396	fprintf(stdout, " Up to length Percentage\n");
sl@0	6397	maxSizeDecade = 0;
sl@0	6398	for (i = 31; i >= 0; i--) {
sl@0	6399	if (statsPtr->literalCount[i] > 0) {
sl@0	6400	maxSizeDecade = i;
sl@0	6401	break;
sl@0	6402	}
sl@0	6403	}
sl@0	6404	sum = 0;
sl@0	6405	for (i = 0; i <= maxSizeDecade; i++) {
sl@0	6406	decadeHigh = (1 << (i+1)) - 1;
sl@0	6407	sum += statsPtr->literalCount[i];
sl@0	6408	fprintf(stdout, " %10d %8.0f%%\n",
sl@0	6409	decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated);
sl@0	6410	}
sl@0	6411
sl@0	6412	litTableStats = TclLiteralStats(globalTablePtr);
sl@0	6413	fprintf(stdout, "\nCurrent literal table statistics:\n%s\n",
sl@0	6414	litTableStats);
sl@0	6415	ckfree((char *) litTableStats);
sl@0	6416
sl@0	6417	/*
sl@0	6418	* Source and ByteCode size distributions.
sl@0	6419	*/
sl@0	6420
sl@0	6421	fprintf(stdout, "\nSource sizes:\n");
sl@0	6422	fprintf(stdout, " Up to size Percentage\n");
sl@0	6423	minSizeDecade = maxSizeDecade = 0;
sl@0	6424	for (i = 0; i < 31; i++) {
sl@0	6425	if (statsPtr->srcCount[i] > 0) {
sl@0	6426	minSizeDecade = i;
sl@0	6427	break;
sl@0	6428	}
sl@0	6429	}
sl@0	6430	for (i = 31; i >= 0; i--) {
sl@0	6431	if (statsPtr->srcCount[i] > 0) {
sl@0	6432	maxSizeDecade = i;
sl@0	6433	break;
sl@0	6434	}
sl@0	6435	}
sl@0	6436	sum = 0;
sl@0	6437	for (i = minSizeDecade; i <= maxSizeDecade; i++) {
sl@0	6438	decadeHigh = (1 << (i+1)) - 1;
sl@0	6439	sum += statsPtr->srcCount[i];
sl@0	6440	fprintf(stdout, " %10d %8.0f%%\n",
sl@0	6441	decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
sl@0	6442	}
sl@0	6443
sl@0	6444	fprintf(stdout, "\nByteCode sizes:\n");
sl@0	6445	fprintf(stdout, " Up to size Percentage\n");
sl@0	6446	minSizeDecade = maxSizeDecade = 0;
sl@0	6447	for (i = 0; i < 31; i++) {
sl@0	6448	if (statsPtr->byteCodeCount[i] > 0) {
sl@0	6449	minSizeDecade = i;
sl@0	6450	break;
sl@0	6451	}
sl@0	6452	}
sl@0	6453	for (i = 31; i >= 0; i--) {
sl@0	6454	if (statsPtr->byteCodeCount[i] > 0) {
sl@0	6455	maxSizeDecade = i;
sl@0	6456	break;
sl@0	6457	}
sl@0	6458	}
sl@0	6459	sum = 0;
sl@0	6460	for (i = minSizeDecade; i <= maxSizeDecade; i++) {
sl@0	6461	decadeHigh = (1 << (i+1)) - 1;
sl@0	6462	sum += statsPtr->byteCodeCount[i];
sl@0	6463	fprintf(stdout, " %10d %8.0f%%\n",
sl@0	6464	decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
sl@0	6465	}
sl@0	6466
sl@0	6467	fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n");
sl@0	6468	fprintf(stdout, " Up to ms Percentage\n");
sl@0	6469	minSizeDecade = maxSizeDecade = 0;
sl@0	6470	for (i = 0; i < 31; i++) {
sl@0	6471	if (statsPtr->lifetimeCount[i] > 0) {
sl@0	6472	minSizeDecade = i;
sl@0	6473	break;
sl@0	6474	}
sl@0	6475	}
sl@0	6476	for (i = 31; i >= 0; i--) {
sl@0	6477	if (statsPtr->lifetimeCount[i] > 0) {
sl@0	6478	maxSizeDecade = i;
sl@0	6479	break;
sl@0	6480	}
sl@0	6481	}
sl@0	6482	sum = 0;
sl@0	6483	for (i = minSizeDecade; i <= maxSizeDecade; i++) {
sl@0	6484	decadeHigh = (1 << (i+1)) - 1;
sl@0	6485	sum += statsPtr->lifetimeCount[i];
sl@0	6486	fprintf(stdout, " %12.3f %8.0f%%\n",
sl@0	6487	decadeHigh / 1000.0,
sl@0	6488	(sum * 100.0) / statsPtr->numByteCodesFreed);
sl@0	6489	}
sl@0	6490
sl@0	6491	/*
sl@0	6492	* Instruction counts.
sl@0	6493	*/
sl@0	6494
sl@0	6495	fprintf(stdout, "\nInstruction counts:\n");
sl@0	6496	for (i = 0; i <= LAST_INST_OPCODE; i++) {
sl@0	6497	if (statsPtr->instructionCount[i]) {
sl@0	6498	fprintf(stdout, "%20s %8ld %6.1f%%\n",
sl@0	6499	tclInstructionTable[i].name,
sl@0	6500	statsPtr->instructionCount[i],
sl@0	6501	(statsPtr->instructionCount[i]*100.0) / numInstructions);
sl@0	6502	}
sl@0	6503	}
sl@0	6504
sl@0	6505	fprintf(stdout, "\nInstructions NEVER executed:\n");
sl@0	6506	for (i = 0; i <= LAST_INST_OPCODE; i++) {
sl@0	6507	if (statsPtr->instructionCount[i] == 0) {
sl@0	6508	fprintf(stdout, "%20s\n", tclInstructionTable[i].name);
sl@0	6509	}
sl@0	6510	}
sl@0	6511
sl@0	6512	#ifdef TCL_MEM_DEBUG
sl@0	6513	fprintf(stdout, "\nHeap Statistics:\n");
sl@0	6514	TclDumpMemoryInfo(stdout);
sl@0	6515	#endif
sl@0	6516	fprintf(stdout, "\n----------------------------------------------------------------\n");
sl@0	6517	return TCL_OK;
sl@0	6518	}
sl@0	6519	#endif /* TCL_COMPILE_STATS */
sl@0	6520
sl@0	6521	#ifdef TCL_COMPILE_DEBUG
sl@0	6522	/*
sl@0	6523	*----------------------------------------------------------------------
sl@0	6524	*
sl@0	6525	* StringForResultCode --
sl@0	6526	*
sl@0	6527	* Procedure that returns a human-readable string representing a
sl@0	6528	* Tcl result code such as TCL_ERROR.
sl@0	6529	*
sl@0	6530	* Results:
sl@0	6531	* If the result code is one of the standard Tcl return codes, the
sl@0	6532	* result is a string representing that code such as "TCL_ERROR".
sl@0	6533	* Otherwise, the result string is that code formatted as a
sl@0	6534	* sequence of decimal digit characters. Note that the resulting
sl@0	6535	* string must not be modified by the caller.
sl@0	6536	*
sl@0	6537	* Side effects:
sl@0	6538	* None.
sl@0	6539	*
sl@0	6540	*----------------------------------------------------------------------
sl@0	6541	*/
sl@0	6542
sl@0	6543	static char *
sl@0	6544	StringForResultCode(result)
sl@0	6545	int result; /* The Tcl result code for which to
sl@0	6546	* generate a string. */
sl@0	6547	{
sl@0	6548	static char buf[TCL_INTEGER_SPACE];
sl@0	6549
sl@0	6550	if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
sl@0	6551	return resultStrings[result];
sl@0	6552	}
sl@0	6553	TclFormatInt(buf, result);
sl@0	6554	return buf;
sl@0	6555	}
sl@0	6556	#endif /* TCL_COMPILE_DEBUG */
sl@0	6557
sl@0	6558	/*
sl@0	6559	* Local Variables:
sl@0	6560	* mode: c
sl@0	6561	* c-basic-offset: 4
sl@0	6562	* fill-column: 78
sl@0	6563	* End:
sl@0	6564	*/
sl@0	6565

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