1 |
/* $Header$ */ |
2 |
/* |
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(); |
3853 |
} |
3854 |
|
3855 |
/* |
3856 |
* Set stackPtr and stackTop from eePtr. |
3857 |
*/ |
3858 |
|
3859 |
CACHE_STACK_INFO(); |
3860 |
|
3861 |
/* |
3862 |
* Generate the random number using the linear congruential |
3863 |
* generator defined by the following recurrence: |
3864 |
* seed = ( IA * seed ) mod IM |
3865 |
* where IA is 16807 and IM is (2^31) - 1. In order to avoid |
3866 |
* potential problems with integer overflow, the code uses |
3867 |
* additional constants IQ and IR such that |
3868 |
* IM = IA*IQ + IR |
3869 |
* For details on how this algorithm works, refer to the following |
3870 |
* papers: |
3871 |
* |
3872 |
* S.K. Park & K.W. Miller, "Random number generators: good ones |
3873 |
* are hard to find," Comm ACM 31(10):1192-1201, Oct 1988 |
3874 |
* |
3875 |
* W.H. Press & S.A. Teukolsky, "Portable random number |
3876 |
* generators," Computers in Physics 6(5):522-524, Sep/Oct 1992. |
3877 |
*/ |
3878 |
|
3879 |
#define RAND_IA 16807 |
3880 |
#define RAND_IM 2147483647 |
3881 |
#define RAND_IQ 127773 |
3882 |
#define RAND_IR 2836 |
3883 |
#define RAND_MASK 123459876 |
3884 |
|
3885 |
if (iPtr->randSeed == 0) { |
3886 |
/* |
3887 |
* Don't allow a 0 seed, since it breaks the generator. Shift |
3888 |
* it to some other value. |
3889 |
*/ |
3890 |
|
3891 |
iPtr->randSeed = 123459876; |
3892 |
} |
3893 |
tmp = iPtr->randSeed/RAND_IQ; |
3894 |
iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp; |
3895 |
if (iPtr->randSeed < 0) { |
3896 |
iPtr->randSeed += RAND_IM; |
3897 |
} |
3898 |
|
3899 |
/* |
3900 |
* On 64-bit architectures we need to mask off the upper bits to |
3901 |
* ensure we only have a 32-bit range. The constant has the |
3902 |
* bizarre form below in order to make sure that it doesn't |
3903 |
* get sign-extended (the rules for sign extension are very |
3904 |
* concat, particularly on 64-bit machines). |
3905 |
*/ |
3906 |
|
3907 |
iPtr->randSeed &= ((((unsigned long) 0xfffffff) << 4) | 0xf); |
3908 |
dResult = iPtr->randSeed * (1.0/RAND_IM); |
3909 |
|
3910 |
/* |
3911 |
* Push a Tcl object with the result. |
3912 |
*/ |
3913 |
|
3914 |
PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); |
3915 |
|
3916 |
/* |
3917 |
* Reflect the change to stackTop back in eePtr. |
3918 |
*/ |
3919 |
|
3920 |
DECACHE_STACK_INFO(); |
3921 |
return TCL_OK; |
3922 |
} |
3923 |
|
3924 |
static int |
3925 |
ExprRoundFunc(interp, eePtr, clientData) |
3926 |
Tcl_Interp *interp; /* The interpreter in which to execute the |
3927 |
* function. */ |
3928 |
ExecEnv *eePtr; /* Points to the environment for executing |
3929 |
* the function. */ |
3930 |
ClientData clientData; /* Ignored. */ |
3931 |
{ |
3932 |
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
3933 |
register int stackTop; /* Cached top index of evaluation stack. */ |
3934 |
Tcl_Obj *valuePtr; |
3935 |
long iResult; |
3936 |
double d, temp; |
3937 |
int result; |
3938 |
|
3939 |
/* |
3940 |
* Set stackPtr and stackTop from eePtr. |
3941 |
*/ |
3942 |
|
3943 |
result = TCL_OK; |
3944 |
CACHE_STACK_INFO(); |
3945 |
|
3946 |
/* |
3947 |
* Pop the argument from the evaluation stack. |
3948 |
*/ |
3949 |
|
3950 |
valuePtr = POP_OBJECT(); |
3951 |
|
3952 |
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { |
3953 |
result = TCL_ERROR; |
3954 |
goto done; |
3955 |
} |
3956 |
|
3957 |
if (valuePtr->typePtr == &tclIntType) { |
3958 |
iResult = valuePtr->internalRep.longValue; |
3959 |
} else { |
3960 |
d = valuePtr->internalRep.doubleValue; |
3961 |
if (d < 0.0) { |
3962 |
if (d <= (((double) (long) LONG_MIN) - 0.5)) { |
3963 |
tooLarge: |
3964 |
Tcl_ResetResult(interp); |
3965 |
Tcl_AppendToObj(Tcl_GetObjResult(interp), |
3966 |
"integer value too large to represent", -1); |
3967 |
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", |
3968 |
"integer value too large to represent", |
3969 |
(char *) NULL); |
3970 |
result = TCL_ERROR; |
3971 |
goto done; |
3972 |
} |
3973 |
temp = (long) (d - 0.5); |
3974 |
} else { |
3975 |
if (d >= (((double) LONG_MAX + 0.5))) { |
3976 |
goto tooLarge; |
3977 |
} |
3978 |
temp = (long) (d + 0.5); |
3979 |
} |
3980 |
if (IS_NAN(temp) || IS_INF(temp)) { |
3981 |
TclExprFloatError(interp, temp); |
3982 |
result = TCL_ERROR; |
3983 |
goto done; |
3984 |
} |
3985 |
iResult = (long) temp; |
3986 |
} |
3987 |
|
3988 |
/* |
3989 |
* Push a Tcl object with the result. |
3990 |
*/ |
3991 |
|
3992 |
PUSH_OBJECT(Tcl_NewLongObj(iResult)); |
3993 |
|
3994 |
/* |
3995 |
* Reflect the change to stackTop back in eePtr. |
3996 |
*/ |
3997 |
|
3998 |
done: |
3999 |
Tcl_DecrRefCount(valuePtr); |
4000 |
DECACHE_STACK_INFO(); |
4001 |
return result; |
4002 |
} |
4003 |
|
4004 |
static int |
4005 |
ExprSrandFunc(interp, eePtr, clientData) |
4006 |
Tcl_Interp *interp; /* The interpreter in which to execute the |
4007 |
* function. */ |
4008 |
ExecEnv *eePtr; /* Points to the environment for executing |
4009 |
* the function. */ |
4010 |
ClientData clientData; /* Ignored. */ |
4011 |
{ |
4012 |
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
4013 |
register int stackTop; /* Cached top index of evaluation stack. */ |
4014 |
Interp *iPtr = (Interp *) interp; |
4015 |
Tcl_Obj *valuePtr; |
4016 |
long i = 0; /* Initialized to avoid compiler warning. */ |
4017 |
int result; |
4018 |
|
4019 |
/* |
4020 |
* Set stackPtr and stackTop from eePtr. |
4021 |
*/ |
4022 |
|
4023 |
CACHE_STACK_INFO(); |
4024 |
|
4025 |
/* |
4026 |
* Pop the argument from the evaluation stack. Use the value |
4027 |
* to reset the random number seed. |
4028 |
*/ |
4029 |
|
4030 |
valuePtr = POP_OBJECT(); |
4031 |
|
4032 |
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { |
4033 |
result = TCL_ERROR; |
4034 |
goto badValue; |
4035 |
} |
4036 |
|
4037 |
if (valuePtr->typePtr == &tclIntType) { |
4038 |
i = valuePtr->internalRep.longValue; |
4039 |
} else { |
4040 |
/* |
4041 |
* At this point, the only other possible type is double |
4042 |
*/ |
4043 |
Tcl_ResetResult(interp); |
4044 |
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), |
4045 |
"can't use floating-point value as argument to srand", |
4046 |
(char *) NULL); |
4047 |
badValue: |
4048 |
Tcl_DecrRefCount(valuePtr); |
4049 |
DECACHE_STACK_INFO(); |
4050 |
return TCL_ERROR; |
4051 |
} |
4052 |
|
4053 |
/* |
4054 |
* Reset the seed. |
4055 |
*/ |
4056 |
|
4057 |
iPtr->flags |= RAND_SEED_INITIALIZED; |
4058 |
iPtr->randSeed = i; |
4059 |
|
4060 |
/* |
4061 |
* To avoid duplicating the random number generation code we simply |
4062 |
* clean up our state and call the real random number function. That |
4063 |
* function will always succeed. |
4064 |
*/ |
4065 |
|
4066 |
Tcl_DecrRefCount(valuePtr); |
4067 |
DECACHE_STACK_INFO(); |
4068 |
|
4069 |
ExprRandFunc(interp, eePtr, clientData); |
4070 |
return TCL_OK; |
4071 |
} |
4072 |
|
4073 |
/* |
4074 |
*---------------------------------------------------------------------- |
4075 |
* |
4076 |
* ExprCallMathFunc -- |
4077 |
* |
4078 |
* This procedure is invoked to call a non-builtin math function |
4079 |
* during the execution of an expression. |
4080 |
* |
4081 |
* Results: |
4082 |
* TCL_OK is returned if all went well and the function's value |
4083 |
* was computed successfully. If an error occurred, TCL_ERROR |
4084 |
* is returned and an error message is left in the interpreter's |
4085 |
* result. After a successful return this procedure pushes a Tcl object |
4086 |
* holding the result. |
4087 |
* |
4088 |
* Side effects: |
4089 |
* None, unless the called math function has side effects. |
4090 |
* |
4091 |
*---------------------------------------------------------------------- |
4092 |
*/ |
4093 |
|
4094 |
static int |
4095 |
ExprCallMathFunc(interp, eePtr, objc, objv) |
4096 |
Tcl_Interp *interp; /* The interpreter in which to execute the |
4097 |
* function. */ |
4098 |
ExecEnv *eePtr; /* Points to the environment for executing |
4099 |
* the function. */ |
4100 |
int objc; /* Number of arguments. The function name is |
4101 |
* the 0-th argument. */ |
4102 |
Tcl_Obj **objv; /* The array of arguments. The function name |
4103 |
* is objv[0]. */ |
4104 |
{ |
4105 |
Interp *iPtr = (Interp *) interp; |
4106 |
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
4107 |
register int stackTop; /* Cached top index of evaluation stack. */ |
4108 |
char *funcName; |
4109 |
Tcl_HashEntry *hPtr; |
4110 |
MathFunc *mathFuncPtr; /* Information about math function. */ |
4111 |
Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */ |
4112 |
Tcl_Value funcResult; /* Result of function call as Tcl_Value. */ |
4113 |
register Tcl_Obj *valuePtr; |
4114 |
long i; |
4115 |
double d; |
4116 |
int j, k, result; |
4117 |
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); |
4118 |
|
4119 |
Tcl_ResetResult(interp); |
4120 |
|
4121 |
/* |
4122 |
* Set stackPtr and stackTop from eePtr. |
4123 |
*/ |
4124 |
|
4125 |
CACHE_STACK_INFO(); |
4126 |
|
4127 |
/* |
4128 |
* Look up the MathFunc record for the function. |
4129 |
*/ |
4130 |
|
4131 |
funcName = Tcl_GetString(objv[0]); |
4132 |
hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); |
4133 |
if (hPtr == NULL) { |
4134 |
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), |
4135 |
"unknown math function \"", funcName, "\"", (char *) NULL); |
4136 |
result = TCL_ERROR; |
4137 |
goto done; |
4138 |
} |
4139 |
mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); |
4140 |
if (mathFuncPtr->numArgs != (objc-1)) { |
4141 |
panic("ExprCallMathFunc: expected number of args %d != actual number %d", |
4142 |
mathFuncPtr->numArgs, objc); |
4143 |
result = TCL_ERROR; |
4144 |
goto done; |
4145 |
} |
4146 |
|
4147 |
/* |
4148 |
* Collect the arguments for the function, if there are any, into the |
4149 |
* array "args". Note that args[0] will have the Tcl_Value that |
4150 |
* corresponds to objv[1]. |
4151 |
*/ |
4152 |
|
4153 |
for (j = 1, k = 0; j < objc; j++, k++) { |
4154 |
valuePtr = objv[j]; |
4155 |
|
4156 |
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { |
4157 |
result = TCL_ERROR; |
4158 |
goto done; |
4159 |
} |
4160 |
|
4161 |
/* |
4162 |
* Copy the object's numeric value to the argument record, |
4163 |
* converting it if necessary. |
4164 |
*/ |
4165 |
|
4166 |
if (valuePtr->typePtr == &tclIntType) { |
4167 |
i = valuePtr->internalRep.longValue; |
4168 |
if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) { |
4169 |
args[k].type = TCL_DOUBLE; |
4170 |
args[k].doubleValue = i; |
4171 |
} else { |
4172 |
args[k].type = TCL_INT; |
4173 |
args[k].intValue = i; |
4174 |
} |
4175 |
} else { |
4176 |
d = valuePtr->internalRep.doubleValue; |
4177 |
if (mathFuncPtr->argTypes[k] == TCL_INT) { |
4178 |
args[k].type = TCL_INT; |
4179 |
args[k].intValue = (long) d; |
4180 |
} else { |
4181 |
args[k].type = TCL_DOUBLE; |
4182 |
args[k].doubleValue = d; |
4183 |
} |
4184 |
} |
4185 |
} |
4186 |
|
4187 |
/* |
4188 |
* Invoke the function and copy its result back into valuePtr. |
4189 |
*/ |
4190 |
|
4191 |
tsdPtr->mathInProgress++; |
4192 |
result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args, |
4193 |
&funcResult); |
4194 |
tsdPtr->mathInProgress--; |
4195 |
if (result != TCL_OK) { |
4196 |
goto done; |
4197 |
} |
4198 |
|
4199 |
/* |
4200 |
* Pop the objc top stack elements and decrement their ref counts. |
4201 |
*/ |
4202 |
|
4203 |
i = (stackTop - (objc-1)); |
4204 |
while (i <= stackTop) { |
4205 |
valuePtr = stackPtr[i]; |
4206 |
Tcl_DecrRefCount(valuePtr); |
4207 |
i++; |
4208 |
} |
4209 |
stackTop -= objc; |
4210 |
|
4211 |
/* |
4212 |
* Push the call's object result. |
4213 |
*/ |
4214 |
|
4215 |
if (funcResult.type == TCL_INT) { |
4216 |
PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue)); |
4217 |
} else { |
4218 |
d = funcResult.doubleValue; |
4219 |
if (IS_NAN(d) || IS_INF(d)) { |
4220 |
TclExprFloatError(interp, d); |
4221 |
result = TCL_ERROR; |
4222 |
goto done; |
4223 |
} |
4224 |
PUSH_OBJECT(Tcl_NewDoubleObj(d)); |
4225 |
} |
4226 |
|
4227 |
/* |
4228 |
* Reflect the change to stackTop back in eePtr. |
4229 |
*/ |
4230 |
|
4231 |
done: |
4232 |
DECACHE_STACK_INFO(); |
4233 |
return result; |
4234 |
} |
4235 |
|
4236 |
/* |
4237 |
*---------------------------------------------------------------------- |
4238 |
* |
4239 |
* TclExprFloatError -- |
4240 |
* |
4241 |
* This procedure is called when an error occurs during a |
4242 |
* floating-point operation. It reads errno and sets |
4243 |
* interp->objResultPtr accordingly. |
4244 |
* |
4245 |
* Results: |
4246 |
* interp->objResultPtr is set to hold an error message. |
4247 |
* |
4248 |
* Side effects: |
4249 |
* None. |
4250 |
* |
4251 |
*---------------------------------------------------------------------- |
4252 |
*/ |
4253 |
|
4254 |
void |
4255 |
TclExprFloatError(interp, value) |
4256 |
Tcl_Interp *interp; /* Where to store error message. */ |
4257 |
double value; /* Value returned after error; used to |
4258 |
* distinguish underflows from overflows. */ |
4259 |
{ |
4260 |
char *s; |
4261 |
|
4262 |
Tcl_ResetResult(interp); |
4263 |
if ((errno == EDOM) || (value != value)) { |
4264 |
s = "domain error: argument not in valid range"; |
4265 |
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); |
4266 |
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL); |
4267 |
} else if ((errno == ERANGE) || IS_INF(value)) { |
4268 |
if (value == 0.0) { |
4269 |
s = "floating-point value too small to represent"; |
4270 |
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); |
4271 |
Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL); |
4272 |
} else { |
4273 |
s = "floating-point value too large to represent"; |
4274 |
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); |
4275 |
Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL); |
4276 |
} |
4277 |
} else { |
4278 |
char msg[64 + TCL_INTEGER_SPACE]; |
4279 |
|
4280 |
sprintf(msg, "unknown floating-point error, errno = %d", errno); |
4281 |
Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1); |
4282 |
Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL); |
4283 |
} |
4284 |
} |
4285 |
|
4286 |
/* |
4287 |
*---------------------------------------------------------------------- |
4288 |
* |
4289 |
* TclMathInProgress -- |
4290 |
* |
4291 |
* This procedure is called to find out if Tcl is doing math |
4292 |
* in this thread. |
4293 |
* |
4294 |
* Results: |
4295 |
* 0 or 1. |
4296 |
* |
4297 |
* Side effects: |
4298 |
* None. |
4299 |
* |
4300 |
*---------------------------------------------------------------------- |
4301 |
*/ |
4302 |
|
4303 |
int |
4304 |
TclMathInProgress() |
4305 |
{ |
4306 |
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); |
4307 |
return tsdPtr->mathInProgress; |
4308 |
} |
4309 |
|
4310 |
#ifdef TCL_COMPILE_STATS |
4311 |
/* |
4312 |
*---------------------------------------------------------------------- |
4313 |
* |
4314 |
* TclLog2 -- |
4315 |
* |
4316 |
* Procedure used while collecting compilation statistics to determine |
4317 |
* the log base 2 of an integer. |
4318 |
* |
4319 |
* Results: |
4320 |
* Returns the log base 2 of the operand. If the argument is less |
4321 |
* than or equal to zero, a zero is returned. |
4322 |
* |
4323 |
* Side effects: |
4324 |
* None. |
4325 |
* |
4326 |
*---------------------------------------------------------------------- |
4327 |
*/ |
4328 |
|
4329 |
int |
4330 |
TclLog2(value) |
4331 |
register int value; /* The integer for which to compute the |
4332 |
* log base 2. */ |
4333 |
{ |
4334 |
register int n = value; |
4335 |
register int result = 0; |
4336 |
|
4337 |
while (n > 1) { |
4338 |
n = n >> 1; |
4339 |
result++; |
4340 |
} |
4341 |
return result; |
4342 |
} |
4343 |
|
4344 |
/* |
4345 |
*---------------------------------------------------------------------- |
4346 |
* |
4347 |
* EvalStatsCmd -- |
4348 |
* |
4349 |
* Implements the "evalstats" command that prints instruction execution |
4350 |
* counts to stdout. |
4351 |
* |
4352 |
* Results: |
4353 |
* Standard Tcl results. |
4354 |
* |
4355 |
* Side effects: |
4356 |
* None. |
4357 |
* |
4358 |
*---------------------------------------------------------------------- |
4359 |
*/ |
4360 |
|
4361 |
static int |
4362 |
EvalStatsCmd(unused, interp, argc, argv) |
4363 |
ClientData unused; /* Unused. */ |
4364 |
Tcl_Interp *interp; /* The current interpreter. */ |
4365 |
int argc; /* The number of arguments. */ |
4366 |
char **argv; /* The argument strings. */ |
4367 |
{ |
4368 |
Interp *iPtr = (Interp *) interp; |
4369 |
LiteralTable *globalTablePtr = &(iPtr->literalTable); |
4370 |
ByteCodeStats *statsPtr = &(iPtr->stats); |
4371 |
double totalCodeBytes, currentCodeBytes; |
4372 |
double totalLiteralBytes, currentLiteralBytes; |
4373 |
double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved; |
4374 |
double strBytesSharedMultX, strBytesSharedOnce; |
4375 |
double numInstructions, currentHeaderBytes; |
4376 |
long numCurrentByteCodes, numByteCodeLits; |
4377 |
long refCountSum, literalMgmtBytes, sum; |
4378 |
int numSharedMultX, numSharedOnce; |
4379 |
int decadeHigh, minSizeDecade, maxSizeDecade, length, i; |
4380 |
char *litTableStats; |
4381 |
LiteralEntry *entryPtr; |
4382 |
|
4383 |
numInstructions = 0.0; |
4384 |
for (i = 0; i < 256; i++) { |
4385 |
if (statsPtr->instructionCount[i] != 0) { |
4386 |
numInstructions += statsPtr->instructionCount[i]; |
4387 |
} |
4388 |
} |
4389 |
|
4390 |
totalLiteralBytes = sizeof(LiteralTable) |
4391 |
+ iPtr->literalTable.numBuckets * sizeof(LiteralEntry *) |
4392 |
+ (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)) |
4393 |
+ (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)) |
4394 |
+ statsPtr->totalLitStringBytes; |
4395 |
totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes; |
4396 |
|
4397 |
numCurrentByteCodes = |
4398 |
statsPtr->numCompilations - statsPtr->numByteCodesFreed; |
4399 |
currentHeaderBytes = numCurrentByteCodes |
4400 |
* (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))); |
4401 |
literalMgmtBytes = sizeof(LiteralTable) |
4402 |
+ (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)) |
4403 |
+ (iPtr->literalTable.numEntries * sizeof(LiteralEntry)); |
4404 |
currentLiteralBytes = literalMgmtBytes |
4405 |
+ iPtr->literalTable.numEntries * sizeof(Tcl_Obj) |
4406 |
+ statsPtr->currentLitStringBytes; |
4407 |
currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes; |
4408 |
|
4409 |
/* |
4410 |
* Summary statistics, total and current source and ByteCode sizes. |
4411 |
*/ |
4412 |
|
4413 |
fprintf(stdout, "\n----------------------------------------------------------------\n"); |
4414 |
fprintf(stdout, |
4415 |
"Compilation and execution statistics for interpreter 0x%x\n", |
4416 |
(unsigned int) iPtr); |
4417 |
|
4418 |
fprintf(stdout, "\nNumber ByteCodes executed %ld\n", |
4419 |
statsPtr->numExecutions); |
4420 |
fprintf(stdout, "Number ByteCodes compiled %ld\n", |
4421 |
statsPtr->numCompilations); |
4422 |
fprintf(stdout, " Mean executions/compile %.1f\n", |
4423 |
((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations)); |
4424 |
|
4425 |
fprintf(stdout, "\nInstructions executed %.0f\n", |
4426 |
numInstructions); |
4427 |
fprintf(stdout, " Mean inst/compile %.0f\n", |
4428 |
numInstructions / statsPtr->numCompilations); |
4429 |
fprintf(stdout, " Mean inst/execution %.0f\n", |
4430 |
numInstructions / statsPtr->numExecutions); |
4431 |
|
4432 |
fprintf(stdout, "\nTotal ByteCodes %ld\n", |
4433 |
statsPtr->numCompilations); |
4434 |
fprintf(stdout, " Source bytes %.6g\n", |
4435 |
statsPtr->totalSrcBytes); |
4436 |
fprintf(stdout, " Code bytes %.6g\n", |
4437 |
totalCodeBytes); |
4438 |
fprintf(stdout, " ByteCode bytes %.6g\n", |
4439 |
statsPtr->totalByteCodeBytes); |
4440 |
fprintf(stdout, " Literal bytes %.6g\n", |
4441 |
totalLiteralBytes); |
4442 |
fprintf(stdout, " table %d + bkts %d + entries %ld + objects %ld + strings %.6g\n", |
4443 |
sizeof(LiteralTable), |
4444 |
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), |
4445 |
statsPtr->numLiteralsCreated * sizeof(LiteralEntry), |
4446 |
statsPtr->numLiteralsCreated * sizeof(Tcl_Obj), |
4447 |
statsPtr->totalLitStringBytes); |
4448 |
fprintf(stdout, " Mean code/compile %.1f\n", |
4449 |
totalCodeBytes / statsPtr->numCompilations); |
4450 |
fprintf(stdout, " Mean code/source %.1f\n", |
4451 |
totalCodeBytes / statsPtr->totalSrcBytes); |
4452 |
|
4453 |
fprintf(stdout, "\nCurrent ByteCodes %ld\n", |
4454 |
numCurrentByteCodes); |
4455 |
fprintf(stdout, " Source bytes %.6g\n", |
4456 |
statsPtr->currentSrcBytes); |
4457 |
fprintf(stdout, " Code bytes %.6g\n", |
4458 |
currentCodeBytes); |
4459 |
fprintf(stdout, " ByteCode bytes %.6g\n", |
4460 |
statsPtr->currentByteCodeBytes); |
4461 |
fprintf(stdout, " Literal bytes %.6g\n", |
4462 |
currentLiteralBytes); |
4463 |
fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n", |
4464 |
sizeof(LiteralTable), |
4465 |
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), |
4466 |
iPtr->literalTable.numEntries * sizeof(LiteralEntry), |
4467 |
iPtr->literalTable.numEntries * sizeof(Tcl_Obj), |
4468 |
statsPtr->currentLitStringBytes); |
4469 |
fprintf(stdout, " Mean code/source %.1f\n", |
4470 |
currentCodeBytes / statsPtr->currentSrcBytes); |
4471 |
fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n", |
4472 |
(currentCodeBytes + statsPtr->currentSrcBytes), |
4473 |
(currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); |
4474 |
|
4475 |
/* |
4476 |
* Literal table statistics. |
4477 |
*/ |
4478 |
|
4479 |
numByteCodeLits = 0; |
4480 |
refCountSum = 0; |
4481 |
numSharedMultX = 0; |
4482 |
numSharedOnce = 0; |
4483 |
objBytesIfUnshared = 0.0; |
4484 |
strBytesIfUnshared = 0.0; |
4485 |
strBytesSharedMultX = 0.0; |
4486 |
strBytesSharedOnce = 0.0; |
4487 |
for (i = 0; i < globalTablePtr->numBuckets; i++) { |
4488 |
for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; |
4489 |
entryPtr = entryPtr->nextPtr) { |
4490 |
if (entryPtr->objPtr->typePtr == &tclByteCodeType) { |
4491 |
numByteCodeLits++; |
4492 |
} |
4493 |
(void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); |
4494 |
refCountSum += entryPtr->refCount; |
4495 |
objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); |
4496 |
strBytesIfUnshared += (entryPtr->refCount * (length+1)); |
4497 |
if (entryPtr->refCount > 1) { |
4498 |
numSharedMultX++; |
4499 |
strBytesSharedMultX += (length+1); |
4500 |
} else { |
4501 |
numSharedOnce++; |
4502 |
strBytesSharedOnce += (length+1); |
4503 |
} |
4504 |
} |
4505 |
} |
4506 |
sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared) |
4507 |
- currentLiteralBytes; |
4508 |
|
4509 |
fprintf(stdout, "\nTotal objects (all interps) %ld\n", |
4510 |
tclObjsAlloced); |
4511 |
fprintf(stdout, "Current objects %ld\n", |
4512 |
(tclObjsAlloced - tclObjsFreed)); |
4513 |
fprintf(stdout, "Total literal objects %ld\n", |
4514 |
statsPtr->numLiteralsCreated); |
4515 |
|
4516 |
fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n", |
4517 |
globalTablePtr->numEntries, |
4518 |
(globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed)); |
4519 |
fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)\n", |
4520 |
numByteCodeLits, |
4521 |
(numByteCodeLits * 100.0) / globalTablePtr->numEntries); |
4522 |
fprintf(stdout, " Literals reused > 1x %d\n", |
4523 |
numSharedMultX); |
4524 |
fprintf(stdout, " Mean reference count %.2f\n", |
4525 |
((double) refCountSum) / globalTablePtr->numEntries); |
4526 |
fprintf(stdout, " Mean len, str reused >1x %.2f\n", |
4527 |
(numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0)); |
4528 |
fprintf(stdout, " Mean len, str used 1x %.2f\n", |
4529 |
(numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0)); |
4530 |
fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n", |
4531 |
sharingBytesSaved, |
4532 |
(sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared)); |
4533 |
fprintf(stdout, " Bytes with sharing %.6g\n", |
4534 |
currentLiteralBytes); |
4535 |
fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n", |
4536 |
sizeof(LiteralTable), |
4537 |
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), |
4538 |
iPtr->literalTable.numEntries * sizeof(LiteralEntry), |
4539 |
iPtr->literalTable.numEntries * sizeof(Tcl_Obj), |
4540 |
statsPtr->currentLitStringBytes); |
4541 |
fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n", |
4542 |
(objBytesIfUnshared + strBytesIfUnshared), |
4543 |
objBytesIfUnshared, strBytesIfUnshared); |
4544 |
fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6g\n", |
4545 |
(strBytesIfUnshared - statsPtr->currentLitStringBytes), |
4546 |
strBytesIfUnshared, statsPtr->currentLitStringBytes); |
4547 |
fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n", |
4548 |
literalMgmtBytes, |
4549 |
(literalMgmtBytes * 100.0) / currentLiteralBytes); |
4550 |
fprintf(stdout, " table %d + buckets %d + entries %d\n", |
4551 |
sizeof(LiteralTable), |
4552 |
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), |
4553 |
iPtr->literalTable.numEntries * sizeof(LiteralEntry)); |
4554 |
|
4555 |
/* |
4556 |
* Breakdown of current ByteCode space requirements. |
4557 |
*/ |
4558 |
|
4559 |
fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n"); |
4560 |
fprintf(stdout, " Bytes Pct of Avg per\n"); |
4561 |
fprintf(stdout, " total ByteCode\n"); |
4562 |
fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n", |
4563 |
statsPtr->currentByteCodeBytes, |
4564 |
statsPtr->currentByteCodeBytes / numCurrentByteCodes); |
4565 |
fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n", |
4566 |
currentHeaderBytes, |
4567 |
((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes), |
4568 |
currentHeaderBytes / numCurrentByteCodes); |
4569 |
fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n", |
4570 |
statsPtr->currentInstBytes, |
4571 |
((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes), |
4572 |
statsPtr->currentInstBytes / numCurrentByteCodes); |
4573 |
fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n", |
4574 |
statsPtr->currentLitBytes, |
4575 |
((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes), |
4576 |
statsPtr->currentLitBytes / numCurrentByteCodes); |
4577 |
fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n", |
4578 |
statsPtr->currentExceptBytes, |
4579 |
((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes), |
4580 |
statsPtr->currentExceptBytes / numCurrentByteCodes); |
4581 |
fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n", |
4582 |
statsPtr->currentAuxBytes, |
4583 |
((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes), |
4584 |
statsPtr->currentAuxBytes / numCurrentByteCodes); |
4585 |
fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n", |
4586 |
statsPtr->currentCmdMapBytes, |
4587 |
((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes), |
4588 |
statsPtr->currentCmdMapBytes / numCurrentByteCodes); |
4589 |
|
4590 |
/* |
4591 |
* Detailed literal statistics. |
4592 |
*/ |
4593 |
|
4594 |
fprintf(stdout, "\nLiteral string sizes:\n"); |
4595 |
fprintf(stdout, " Up to length Percentage\n"); |
4596 |
maxSizeDecade = 0; |
4597 |
for (i = 31; i >= 0; i--) { |
4598 |
if (statsPtr->literalCount[i] > 0) { |
4599 |
maxSizeDecade = i; |
4600 |
break; |
4601 |
} |
4602 |
} |
4603 |
sum = 0; |
4604 |
for (i = 0; i <= maxSizeDecade; i++) { |
4605 |
decadeHigh = (1 << (i+1)) - 1; |
4606 |
sum += statsPtr->literalCount[i]; |
4607 |
fprintf(stdout, " %10d %8.0f%%\n", |
4608 |
decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated); |
4609 |
} |
4610 |
|
4611 |
litTableStats = TclLiteralStats(globalTablePtr); |
4612 |
fprintf(stdout, "\nCurrent literal table statistics:\n%s\n", |
4613 |
litTableStats); |
4614 |
ckfree((char *) litTableStats); |
4615 |
|
4616 |
/* |
4617 |
* Source and ByteCode size distributions. |
4618 |
*/ |
4619 |
|
4620 |
fprintf(stdout, "\nSource sizes:\n"); |
4621 |
fprintf(stdout, " Up to size Percentage\n"); |
4622 |
minSizeDecade = maxSizeDecade = 0; |
4623 |
for (i = 0; i < 31; i++) { |
4624 |
if (statsPtr->srcCount[i] > 0) { |
4625 |
minSizeDecade = i; |
4626 |
break; |
4627 |
} |
4628 |
} |
4629 |
for (i = 31; i >= 0; i--) { |
4630 |
if (statsPtr->srcCount[i] > 0) { |
4631 |
maxSizeDecade = i; |
4632 |
break; |
4633 |
} |
4634 |
} |
4635 |
sum = 0; |
4636 |
for (i = minSizeDecade; i <= maxSizeDecade; i++) { |
4637 |
decadeHigh = (1 << (i+1)) - 1; |
4638 |
sum += statsPtr->srcCount[i]; |
4639 |
fprintf(stdout, " %10d %8.0f%%\n", |
4640 |
decadeHigh, (sum * 100.0) / statsPtr->numCompilations); |
4641 |
} |
4642 |
|
4643 |
fprintf(stdout, "\nByteCode sizes:\n"); |
4644 |
fprintf(stdout, " Up to size Percentage\n"); |
4645 |
minSizeDecade = maxSizeDecade = 0; |
4646 |
for (i = 0; i < 31; i++) { |
4647 |
if (statsPtr->byteCodeCount[i] > 0) { |
4648 |
minSizeDecade = i; |
4649 |
break; |
4650 |
} |
4651 |
} |
4652 |
for (i = 31; i >= 0; i--) { |
4653 |
if (statsPtr->byteCodeCount[i] > 0) { |
4654 |
maxSizeDecade = i; |
4655 |
break; |
4656 |
} |
4657 |
} |
4658 |
sum = 0; |
4659 |
for (i = minSizeDecade; i <= maxSizeDecade; i++) { |
4660 |
decadeHigh = (1 << (i+1)) - 1; |
4661 |
sum += statsPtr->byteCodeCount[i]; |
4662 |
fprintf(stdout, " %10d %8.0f%%\n", |
4663 |
decadeHigh, (sum * 100.0) / statsPtr->numCompilations); |
4664 |
} |
4665 |
|
4666 |
fprintf(stdout, "\nByteCode longevity (excludes current ByteCodes):\n"); |
4667 |
fprintf(stdout, " Up to ms Percentage\n"); |
4668 |
minSizeDecade = maxSizeDecade = 0; |
4669 |
for (i = 0; i < 31; i++) { |
4670 |
if (statsPtr->lifetimeCount[i] > 0) { |
4671 |
minSizeDecade = i; |
4672 |
break; |
4673 |
} |
4674 |
} |
4675 |
for (i = 31; i >= 0; i--) { |
4676 |
if (statsPtr->lifetimeCount[i] > 0) { |
4677 |
maxSizeDecade = i; |
4678 |
break; |
4679 |
} |
4680 |
} |
4681 |
sum = 0; |
4682 |
for (i = minSizeDecade; i <= maxSizeDecade; i++) { |
4683 |
decadeHigh = (1 << (i+1)) - 1; |
4684 |
sum += statsPtr->lifetimeCount[i]; |
4685 |
fprintf(stdout, " %12.3f %8.0f%%\n", |
4686 |
decadeHigh / 1000.0, |
4687 |
(sum * 100.0) / statsPtr->numByteCodesFreed); |
4688 |
} |
4689 |
|
4690 |
/* |
4691 |
* Instruction counts. |
4692 |
*/ |
4693 |
|
4694 |
fprintf(stdout, "\nInstruction counts:\n"); |
4695 |
for (i = 0; i <= LAST_INST_OPCODE; i++) { |
4696 |
if (statsPtr->instructionCount[i]) { |
4697 |
fprintf(stdout, "%20s %8ld %6.1f%%\n", |
4698 |
instructionTable[i].name, |
4699 |
statsPtr->instructionCount[i], |
4700 |
(statsPtr->instructionCount[i]*100.0) / numInstructions); |
4701 |
} |
4702 |
} |
4703 |
|
4704 |
fprintf(stdout, "\nInstructions NEVER executed:\n"); |
4705 |
for (i = 0; i <= LAST_INST_OPCODE; i++) { |
4706 |
if (statsPtr->instructionCount[i] == 0) { |
4707 |
fprintf(stdout, "%20s\n", |
4708 |
instructionTable[i].name); |
4709 |
} |
4710 |
} |
4711 |
|
4712 |
#ifdef TCL_MEM_DEBUG |
4713 |
fprintf(stdout, "\nHeap Statistics:\n"); |
4714 |
TclDumpMemoryInfo(stdout); |
4715 |
#endif |
4716 |
fprintf(stdout, "\n----------------------------------------------------------------\n"); |
4717 |
return TCL_OK; |
4718 |
} |
4719 |
#endif /* TCL_COMPILE_STATS */ |
4720 |
|
4721 |
/* |
4722 |
*---------------------------------------------------------------------- |
4723 |
* |
4724 |
* Tcl_GetCommandFromObj -- |
4725 |
* |
4726 |
* Returns the command specified by the name in a Tcl_Obj. |
4727 |
* |
4728 |
* Results: |
4729 |
* Returns a token for the command if it is found. Otherwise, if it |
4730 |
* can't be found or there is an error, returns NULL. |
4731 |
* |
4732 |
* Side effects: |
4733 |
* May update the internal representation for the object, caching |
4734 |
* the command reference so that the next time this procedure is |
4735 |
* called with the same object, the command can be found quickly. |
4736 |
* |
4737 |
*---------------------------------------------------------------------- |
4738 |
*/ |
4739 |
|
4740 |
Tcl_Command |
4741 |
Tcl_GetCommandFromObj(interp, objPtr) |
4742 |
Tcl_Interp *interp; /* The interpreter in which to resolve the |
4743 |
* command and to report errors. */ |
4744 |
register Tcl_Obj *objPtr; /* The object containing the command's |
4745 |
* name. If the name starts with "::", will |
4746 |
* be looked up in global namespace. Else, |
4747 |
* looked up first in the current namespace |
4748 |
* if contextNsPtr is NULL, then in global |
4749 |
* namespace. */ |
4750 |
{ |
4751 |
Interp *iPtr = (Interp *) interp; |
4752 |
register ResolvedCmdName *resPtr; |
4753 |
register Command *cmdPtr; |
4754 |
Namespace *currNsPtr; |
4755 |
int result; |
4756 |
|
4757 |
/* |
4758 |
* Get the internal representation, converting to a command type if |
4759 |
* needed. The internal representation is a ResolvedCmdName that points |
4760 |
* to the actual command. |
4761 |
*/ |
4762 |
|
4763 |
if (objPtr->typePtr != &tclCmdNameType) { |
4764 |
result = tclCmdNameType.setFromAnyProc(interp, objPtr); |
4765 |
if (result != TCL_OK) { |
4766 |
return (Tcl_Command) NULL; |
4767 |
} |
4768 |
} |
4769 |
resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; |
4770 |
|
4771 |
/* |
4772 |
* Get the current namespace. |
4773 |
*/ |
4774 |
|
4775 |
if (iPtr->varFramePtr != NULL) { |
4776 |
currNsPtr = iPtr->varFramePtr->nsPtr; |
4777 |
} else { |
4778 |
currNsPtr = iPtr->globalNsPtr; |
4779 |
} |
4780 |
|
4781 |
/* |
4782 |
* Check the context namespace and the namespace epoch of the resolved |
4783 |
* symbol to make sure that it is fresh. If not, then force another |
4784 |
* conversion to the command type, to discard the old rep and create a |
4785 |
* new one. Note that we verify that the namespace id of the context |
4786 |
* namespace is the same as the one we cached; this insures that the |
4787 |
* namespace wasn't deleted and a new one created at the same address |
4788 |
* with the same command epoch. |
4789 |
*/ |
4790 |
|
4791 |
cmdPtr = NULL; |
4792 |
if ((resPtr != NULL) |
4793 |
&& (resPtr->refNsPtr == currNsPtr) |
4794 |
&& (resPtr->refNsId == currNsPtr->nsId) |
4795 |
&& (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) { |
4796 |
cmdPtr = resPtr->cmdPtr; |
4797 |
if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) { |
4798 |
cmdPtr = NULL; |
4799 |
} |
4800 |
} |
4801 |
|
4802 |
if (cmdPtr == NULL) { |
4803 |
result = tclCmdNameType.setFromAnyProc(interp, objPtr); |
4804 |
if (result != TCL_OK) { |
4805 |
return (Tcl_Command) NULL; |
4806 |
} |
4807 |
resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; |
4808 |
if (resPtr != NULL) { |
4809 |
cmdPtr = resPtr->cmdPtr; |
4810 |
} |
4811 |
} |
4812 |
return (Tcl_Command) cmdPtr; |
4813 |
} |
4814 |
|
4815 |
/* |
4816 |
*---------------------------------------------------------------------- |
4817 |
* |
4818 |
* TclSetCmdNameObj -- |
4819 |
* |
4820 |
* Modify an object to be an CmdName object that refers to the argument |
4821 |
* Command structure. |
4822 |
* |
4823 |
* Results: |
4824 |
* None. |
4825 |
* |
4826 |
* Side effects: |
4827 |
* The object's old internal rep is freed. It's string rep is not |
4828 |
* changed. The refcount in the Command structure is incremented to |
4829 |
* keep it from being freed if the command is later deleted until |
4830 |
* TclExecuteByteCode has a chance to recognize that it was deleted. |
4831 |
* |
4832 |
*---------------------------------------------------------------------- |
4833 |
*/ |
4834 |
|
4835 |
void |
4836 |
TclSetCmdNameObj(interp, objPtr, cmdPtr) |
4837 |
Tcl_Interp *interp; /* Points to interpreter containing command |
4838 |
* that should be cached in objPtr. */ |
4839 |
register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to |
4840 |
* a CmdName object. */ |
4841 |
Command *cmdPtr; /* Points to Command structure that the |
4842 |
* CmdName object should refer to. */ |
4843 |
{ |
4844 |
Interp *iPtr = (Interp *) interp; |
4845 |
register ResolvedCmdName *resPtr; |
4846 |
Tcl_ObjType *oldTypePtr = objPtr->typePtr; |
4847 |
register Namespace *currNsPtr; |
4848 |
|
4849 |
if (oldTypePtr == &tclCmdNameType) { |
4850 |
return; |
4851 |
} |
4852 |
|
4853 |
/* |
4854 |
* Get the current namespace. |
4855 |
*/ |
4856 |
|
4857 |
if (iPtr->varFramePtr != NULL) { |
4858 |
currNsPtr = iPtr->varFramePtr->nsPtr; |
4859 |
} else { |
4860 |
currNsPtr = iPtr->globalNsPtr; |
4861 |
} |
4862 |
|
4863 |
cmdPtr->refCount++; |
4864 |
resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); |
4865 |
resPtr->cmdPtr = cmdPtr; |
4866 |
resPtr->refNsPtr = currNsPtr; |
4867 |
resPtr->refNsId = currNsPtr->nsId; |
4868 |
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; |
4869 |
resPtr->cmdEpoch = cmdPtr->cmdEpoch; |
4870 |
resPtr->refCount = 1; |
4871 |
|
4872 |
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { |
4873 |
oldTypePtr->freeIntRepProc(objPtr); |
4874 |
} |
4875 |
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; |
4876 |
objPtr->internalRep.twoPtrValue.ptr2 = NULL; |
4877 |
objPtr->typePtr = &tclCmdNameType; |
4878 |
} |
4879 |
|
4880 |
/* |
4881 |
*---------------------------------------------------------------------- |
4882 |
* |
4883 |
* FreeCmdNameInternalRep -- |
4884 |
* |
4885 |
* Frees the resources associated with a cmdName object's internal |
4886 |
* representation. |
4887 |
* |
4888 |
* Results: |
4889 |
* None. |
4890 |
* |
4891 |
* Side effects: |
4892 |
* Decrements the ref count of any cached ResolvedCmdName structure |
4893 |
* pointed to by the cmdName's internal representation. If this is |
4894 |
* the last use of the ResolvedCmdName, it is freed. This in turn |
4895 |
* decrements the ref count of the Command structure pointed to by |
4896 |
* the ResolvedSymbol, which may free the Command structure. |
4897 |
* |
4898 |
*---------------------------------------------------------------------- |
4899 |
*/ |
4900 |
|
4901 |
static void |
4902 |
FreeCmdNameInternalRep(objPtr) |
4903 |
register Tcl_Obj *objPtr; /* CmdName object with internal |
4904 |
* representation to free. */ |
4905 |
{ |
4906 |
register ResolvedCmdName *resPtr = |
4907 |
(ResolvedCmdName *) objPtr->internalRep.otherValuePtr; |
4908 |
|
4909 |
if (resPtr != NULL) { |
4910 |
/* |
4911 |
* Decrement the reference count of the ResolvedCmdName structure. |
4912 |
* If there are no more uses, free the ResolvedCmdName structure. |
4913 |
*/ |
4914 |
|
4915 |
resPtr->refCount--; |
4916 |
if (resPtr->refCount == 0) { |
4917 |
/* |
4918 |
* Now free the cached command, unless it is still in its |
4919 |
* hash table or if there are other references to it |
4920 |
* from other cmdName objects. |
4921 |
*/ |
4922 |
|
4923 |
Command *cmdPtr = resPtr->cmdPtr; |
4924 |
TclCleanupCommand(cmdPtr); |
4925 |
ckfree((char *) resPtr); |
4926 |
} |
4927 |
} |
4928 |
} |
4929 |
|
4930 |
/* |
4931 |
*---------------------------------------------------------------------- |
4932 |
* |
4933 |
* DupCmdNameInternalRep -- |
4934 |
* |
4935 |
* Initialize the internal representation of an cmdName Tcl_Obj to a |
4936 |
* copy of the internal representation of an existing cmdName object. |
4937 |
* |
4938 |
* Results: |
4939 |
* None. |
4940 |
* |
4941 |
* Side effects: |
4942 |
* "copyPtr"s internal rep is set to point to the ResolvedCmdName |
4943 |
* structure corresponding to "srcPtr"s internal rep. Increments the |
4944 |
* ref count of the ResolvedCmdName structure pointed to by the |
4945 |
* cmdName's internal representation. |
4946 |
* |
4947 |
*---------------------------------------------------------------------- |
4948 |
*/ |
4949 |
|
4950 |
static void |
4951 |
DupCmdNameInternalRep(srcPtr, copyPtr) |
4952 |
Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ |
4953 |
register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ |
4954 |
{ |
4955 |
register ResolvedCmdName *resPtr = |
4956 |
(ResolvedCmdName *) srcPtr->internalRep.otherValuePtr; |
4957 |
|
4958 |
copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; |
4959 |
copyPtr->internalRep.twoPtrValue.ptr2 = NULL; |
4960 |
if (resPtr != NULL) { |
4961 |
resPtr->refCount++; |
4962 |
} |
4963 |
copyPtr->typePtr = &tclCmdNameType; |
4964 |
} |
4965 |
|
4966 |
/* |
4967 |
*---------------------------------------------------------------------- |
4968 |
* |
4969 |
* SetCmdNameFromAny -- |
4970 |
* |
4971 |
* Generate an cmdName internal form for the Tcl object "objPtr". |
4972 |
* |
4973 |
* Results: |
4974 |
* The return value is a standard Tcl result. The conversion always |
4975 |
* succeeds and TCL_OK is returned. |
4976 |
* |
4977 |
* Side effects: |
4978 |
* A pointer to a ResolvedCmdName structure that holds a cached pointer |
4979 |
* to the command with a name that matches objPtr's string rep is |
4980 |
* stored as objPtr's internal representation. This ResolvedCmdName |
4981 |
* pointer will be NULL if no matching command was found. The ref count |
4982 |
* of the cached Command's structure (if any) is also incremented. |
4983 |
* |
4984 |
*---------------------------------------------------------------------- |
4985 |
*/ |
4986 |
|
4987 |
static int |
4988 |
SetCmdNameFromAny(interp, objPtr) |
4989 |
Tcl_Interp *interp; /* Used for error reporting if not NULL. */ |
4990 |
register Tcl_Obj *objPtr; /* The object to convert. */ |
4991 |
{ |
4992 |
Interp *iPtr = (Interp *) interp; |
4993 |
char *name; |
4994 |
Tcl_Command cmd; |
4995 |
register Command *cmdPtr; |
4996 |
Namespace *currNsPtr; |
4997 |
register ResolvedCmdName *resPtr; |
4998 |
|
4999 |
/* |
5000 |
* Get "objPtr"s string representation. Make it up-to-date if necessary. |
5001 |
*/ |
5002 |
|
5003 |
name = objPtr->bytes; |
5004 |
if (name == NULL) { |
5005 |
name = Tcl_GetString(objPtr); |
5006 |
} |
5007 |
|
5008 |
/* |
5009 |
* Find the Command structure, if any, that describes the command called |
5010 |
* "name". Build a ResolvedCmdName that holds a cached pointer to this |
5011 |
* Command, and bump the reference count in the referenced Command |
5012 |
* structure. A Command structure will not be deleted as long as it is |
5013 |
* referenced from a CmdName object. |
5014 |
*/ |
5015 |
|
5016 |
cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL, |
5017 |
/*flags*/ 0); |
5018 |
cmdPtr = (Command *) cmd; |
5019 |
if (cmdPtr != NULL) { |
5020 |
/* |
5021 |
* Get the current namespace. |
5022 |
*/ |
5023 |
|
5024 |
if (iPtr->varFramePtr != NULL) { |
5025 |
currNsPtr = iPtr->varFramePtr->nsPtr; |
5026 |
} else { |
5027 |
currNsPtr = iPtr->globalNsPtr; |
5028 |
} |
5029 |
|
5030 |
cmdPtr->refCount++; |
5031 |
resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); |
5032 |
resPtr->cmdPtr = cmdPtr; |
5033 |
resPtr->refNsPtr = currNsPtr; |
5034 |
resPtr->refNsId = currNsPtr->nsId; |
5035 |
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; |
5036 |
resPtr->cmdEpoch = cmdPtr->cmdEpoch; |
5037 |
resPtr->refCount = 1; |
5038 |
} else { |
5039 |
resPtr = NULL; /* no command named "name" was found */ |
5040 |
} |
5041 |
|
5042 |
/* |
5043 |
* Free the old internalRep before setting the new one. We do this as |
5044 |
* late as possible to allow the conversion code, in particular |
5045 |
* GetStringFromObj, to use that old internalRep. If no Command |
5046 |
* structure was found, leave NULL as the cached value. |
5047 |
*/ |
5048 |
|
5049 |
if ((objPtr->typePtr != NULL) |
5050 |
&& (objPtr->typePtr->freeIntRepProc != NULL)) { |
5051 |
objPtr->typePtr->freeIntRepProc(objPtr); |
5052 |
} |
5053 |
|
5054 |
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; |
5055 |
objPtr->internalRep.twoPtrValue.ptr2 = NULL; |
5056 |
objPtr->typePtr = &tclCmdNameType; |
5057 |
return TCL_OK; |
5058 |
} |
5059 |
|
5060 |
#ifdef TCL_COMPILE_DEBUG |
5061 |
/* |
5062 |
*---------------------------------------------------------------------- |
5063 |
* |
5064 |
* StringForResultCode -- |
5065 |
* |
5066 |
* Procedure that returns a human-readable string representing a |
5067 |
* Tcl result code such as TCL_ERROR. |
5068 |
* |
5069 |
* Results: |
5070 |
* If the result code is one of the standard Tcl return codes, the |
5071 |
* result is a string representing that code such as "TCL_ERROR". |
5072 |
* Otherwise, the result string is that code formatted as a |
5073 |
* sequence of decimal digit characters. Note that the resulting |
5074 |
* string must not be modified by the caller. |
5075 |
* |
5076 |
* Side effects: |
5077 |
* None. |
5078 |
* |
5079 |
*---------------------------------------------------------------------- |
5080 |
*/ |
5081 |
|
5082 |
static char * |
5083 |
StringForResultCode(result) |
5084 |
int result; /* The Tcl result code for which to |
5085 |
* generate a string. */ |
5086 |
{ |
5087 |
static char buf[TCL_INTEGER_SPACE]; |
5088 |
|
5089 |
if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) { |
5090 |
return resultStrings[result]; |
5091 |
} |
5092 |
TclFormatInt(buf, result); |
5093 |
return buf; |
5094 |
} |
5095 |
#endif /* TCL_COMPILE_DEBUG */ |
5096 |
|
5097 |
/* End of tclexecute.c */ |