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