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