1 |
/* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclexecute.c,v 1.1.1.1 2001/06/13 04:38:49 dtashley Exp $ */
|
2 |
|
3 |
/*
|
4 |
* tclExecute.c --
|
5 |
*
|
6 |
* This file contains procedures that execute byte-compiled Tcl
|
7 |
* commands.
|
8 |
*
|
9 |
* Copyright (c) 1996-1997 Sun Microsystems, Inc.
|
10 |
*
|
11 |
* See the file "license.terms" for information on usage and redistribution
|
12 |
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
13 |
*
|
14 |
* RCS: @(#) $Id: tclexecute.c,v 1.1.1.1 2001/06/13 04:38:49 dtashley Exp $
|
15 |
*/
|
16 |
|
17 |
#include "tclInt.h"
|
18 |
#include "tclCompile.h"
|
19 |
|
20 |
#ifdef NO_FLOAT_H
|
21 |
# include "../compat/float.h"
|
22 |
#else
|
23 |
# include <float.h>
|
24 |
#endif
|
25 |
#ifndef TCL_NO_MATH
|
26 |
#include "tclMath.h"
|
27 |
#endif
|
28 |
|
29 |
/*
|
30 |
* The stuff below is a bit of a hack so that this file can be used
|
31 |
* in environments that include no UNIX, i.e. no errno. Just define
|
32 |
* errno here.
|
33 |
*/
|
34 |
|
35 |
#ifndef TCL_GENERIC_ONLY
|
36 |
#include "tclPort.h"
|
37 |
#else
|
38 |
#define NO_ERRNO_H
|
39 |
#endif
|
40 |
|
41 |
#ifdef NO_ERRNO_H
|
42 |
int errno;
|
43 |
#define EDOM 33
|
44 |
#define ERANGE 34
|
45 |
#endif
|
46 |
|
47 |
/*
|
48 |
* Boolean flag indicating whether the Tcl bytecode interpreter has been
|
49 |
* initialized.
|
50 |
*/
|
51 |
|
52 |
static int execInitialized = 0;
|
53 |
TCL_DECLARE_MUTEX(execMutex)
|
54 |
|
55 |
/*
|
56 |
* Variable that controls whether execution tracing is enabled and, if so,
|
57 |
* what level of tracing is desired:
|
58 |
* 0: no execution tracing
|
59 |
* 1: trace invocations of Tcl procs only
|
60 |
* 2: trace invocations of all (not compiled away) commands
|
61 |
* 3: display each instruction executed
|
62 |
* This variable is linked to the Tcl variable "tcl_traceExec".
|
63 |
*/
|
64 |
|
65 |
int tclTraceExec = 0;
|
66 |
|
67 |
typedef struct ThreadSpecificData {
|
68 |
/*
|
69 |
* The following global variable is use to signal matherr that Tcl
|
70 |
* is responsible for the arithmetic, so errors can be handled in a
|
71 |
* fashion appropriate for Tcl. Zero means no Tcl math is in
|
72 |
* progress; non-zero means Tcl is doing math.
|
73 |
*/
|
74 |
|
75 |
int mathInProgress;
|
76 |
|
77 |
} ThreadSpecificData;
|
78 |
|
79 |
static Tcl_ThreadDataKey dataKey;
|
80 |
|
81 |
/*
|
82 |
* The variable below serves no useful purpose except to generate
|
83 |
* a reference to matherr, so that the Tcl version of matherr is
|
84 |
* linked in rather than the system version. Without this reference
|
85 |
* the need for matherr won't be discovered during linking until after
|
86 |
* libtcl.a has been processed, so Tcl's version won't be used.
|
87 |
*/
|
88 |
|
89 |
#ifdef NEED_MATHERR
|
90 |
extern int matherr();
|
91 |
int (*tclMatherrPtr)() = matherr;
|
92 |
#endif
|
93 |
|
94 |
/*
|
95 |
* Mapping from expression instruction opcodes to strings; used for error
|
96 |
* messages. Note that these entries must match the order and number of the
|
97 |
* expression opcodes (e.g., INST_LOR) in tclCompile.h.
|
98 |
*/
|
99 |
|
100 |
static char *operatorStrings[] = {
|
101 |
"||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
|
102 |
"+", "-", "*", "/", "%", "+", "-", "~", "!",
|
103 |
"BUILTIN FUNCTION", "FUNCTION"
|
104 |
};
|
105 |
|
106 |
/*
|
107 |
* Mapping from Tcl result codes to strings; used for error and debugging
|
108 |
* messages.
|
109 |
*/
|
110 |
|
111 |
#ifdef TCL_COMPILE_DEBUG
|
112 |
static char *resultStrings[] = {
|
113 |
"TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
|
114 |
};
|
115 |
#endif
|
116 |
|
117 |
/*
|
118 |
* Macros for testing floating-point values for certain special cases. Test
|
119 |
* for not-a-number by comparing a value against itself; test for infinity
|
120 |
* by comparing against the largest floating-point value.
|
121 |
*/
|
122 |
|
123 |
#define IS_NAN(v) ((v) != (v))
|
124 |
#ifdef DBL_MAX
|
125 |
# define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
|
126 |
#else
|
127 |
# define IS_INF(v) 0
|
128 |
#endif
|
129 |
|
130 |
/*
|
131 |
* Macro to adjust the program counter and restart the instruction execution
|
132 |
* loop after each instruction is executed.
|
133 |
*/
|
134 |
|
135 |
#define ADJUST_PC(instBytes) \
|
136 |
pc += (instBytes); \
|
137 |
continue
|
138 |
|
139 |
/*
|
140 |
* Macros used to cache often-referenced Tcl evaluation stack information
|
141 |
* in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
|
142 |
* pair must surround any call inside TclExecuteByteCode (and a few other
|
143 |
* procedures that use this scheme) that could result in a recursive call
|
144 |
* to TclExecuteByteCode.
|
145 |
*/
|
146 |
|
147 |
#define CACHE_STACK_INFO() \
|
148 |
stackPtr = eePtr->stackPtr; \
|
149 |
stackTop = eePtr->stackTop
|
150 |
|
151 |
#define DECACHE_STACK_INFO() \
|
152 |
eePtr->stackTop = stackTop
|
153 |
|
154 |
/*
|
155 |
* Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
|
156 |
* increments the object's ref count since it makes the stack have another
|
157 |
* reference pointing to the object. However, POP_OBJECT does not decrement
|
158 |
* the ref count. This is because the stack may hold the only reference to
|
159 |
* the object, so the object would be destroyed if its ref count were
|
160 |
* decremented before the caller had a chance to, e.g., store it in a
|
161 |
* variable. It is the caller's responsibility to decrement the ref count
|
162 |
* when it is finished with an object.
|
163 |
*
|
164 |
* WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT
|
165 |
* macro. The actual parameter might be an expression with side effects,
|
166 |
* and this ensures that it will be executed only once.
|
167 |
*/
|
168 |
|
169 |
#define PUSH_OBJECT(objPtr) \
|
170 |
Tcl_IncrRefCount(stackPtr[++stackTop] = (objPtr))
|
171 |
|
172 |
#define POP_OBJECT() \
|
173 |
(stackPtr[stackTop--])
|
174 |
|
175 |
/*
|
176 |
* Macros used to trace instruction execution. The macros TRACE,
|
177 |
* TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode.
|
178 |
* O2S is only used in TRACE* calls to get a string from an object.
|
179 |
*/
|
180 |
|
181 |
#ifdef TCL_COMPILE_DEBUG
|
182 |
#define TRACE(a) \
|
183 |
if (traceInstructions) { \
|
184 |
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
|
185 |
(unsigned int)(pc - codePtr->codeStart), \
|
186 |
GetOpcodeName(pc)); \
|
187 |
printf a; \
|
188 |
}
|
189 |
#define TRACE_WITH_OBJ(a, objPtr) \
|
190 |
if (traceInstructions) { \
|
191 |
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
|
192 |
(unsigned int)(pc - codePtr->codeStart), \
|
193 |
GetOpcodeName(pc)); \
|
194 |
printf a; \
|
195 |
TclPrintObject(stdout, (objPtr), 30); \
|
196 |
fprintf(stdout, "\n"); \
|
197 |
}
|
198 |
#define O2S(objPtr) \
|
199 |
Tcl_GetString(objPtr)
|
200 |
#else
|
201 |
#define TRACE(a)
|
202 |
#define TRACE_WITH_OBJ(a, objPtr)
|
203 |
#define O2S(objPtr)
|
204 |
#endif /* TCL_COMPILE_DEBUG */
|
205 |
|
206 |
/*
|
207 |
* Declarations for local procedures to this file:
|
208 |
*/
|
209 |
|
210 |
static void CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp,
|
211 |
Trace *tracePtr, Command *cmdPtr,
|
212 |
char *command, int numChars,
|
213 |
int objc, Tcl_Obj *objv[]));
|
214 |
static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
|
215 |
Tcl_Obj *copyPtr));
|
216 |
static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp,
|
217 |
ExecEnv *eePtr, ClientData clientData));
|
218 |
static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
|
219 |
ExecEnv *eePtr, ClientData clientData));
|
220 |
static int ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
|
221 |
ExecEnv *eePtr, int objc, Tcl_Obj **objv));
|
222 |
static int ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp,
|
223 |
ExecEnv *eePtr, ClientData clientData));
|
224 |
static int ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp,
|
225 |
ExecEnv *eePtr, ClientData clientData));
|
226 |
static int ExprRandFunc _ANSI_ARGS_((Tcl_Interp *interp,
|
227 |
ExecEnv *eePtr, ClientData clientData));
|
228 |
static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp,
|
229 |
ExecEnv *eePtr, ClientData clientData));
|
230 |
static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp,
|
231 |
ExecEnv *eePtr, ClientData clientData));
|
232 |
static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
|
233 |
ExecEnv *eePtr, ClientData clientData));
|
234 |
#ifdef TCL_COMPILE_STATS
|
235 |
static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
|
236 |
Tcl_Interp *interp, int argc, char **argv));
|
237 |
#endif
|
238 |
static void FreeCmdNameInternalRep _ANSI_ARGS_((
|
239 |
Tcl_Obj *objPtr));
|
240 |
#ifdef TCL_COMPILE_DEBUG
|
241 |
static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc));
|
242 |
#endif
|
243 |
static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc,
|
244 |
int catchOnly, ByteCode* codePtr));
|
245 |
static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
|
246 |
ByteCode* codePtr, int *lengthPtr));
|
247 |
static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr));
|
248 |
static void IllegalExprOperandType _ANSI_ARGS_((
|
249 |
Tcl_Interp *interp, unsigned char *pc,
|
250 |
Tcl_Obj *opndPtr));
|
251 |
static void InitByteCodeExecution _ANSI_ARGS_((
|
252 |
Tcl_Interp *interp));
|
253 |
#ifdef TCL_COMPILE_DEBUG
|
254 |
static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
|
255 |
#endif
|
256 |
static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
|
257 |
Tcl_Obj *objPtr));
|
258 |
#ifdef TCL_COMPILE_DEBUG
|
259 |
static char * StringForResultCode _ANSI_ARGS_((int result));
|
260 |
static void ValidatePcAndStackTop _ANSI_ARGS_((
|
261 |
ByteCode *codePtr, unsigned char *pc,
|
262 |
int stackTop, int stackLowerBound,
|
263 |
int stackUpperBound));
|
264 |
#endif
|
265 |
static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp,
|
266 |
Tcl_Obj *objPtr));
|
267 |
|
268 |
/*
|
269 |
* Table describing the built-in math functions. Entries in this table are
|
270 |
* indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
|
271 |
* operand byte.
|
272 |
*/
|
273 |
|
274 |
BuiltinFunc builtinFuncTable[] = {
|
275 |
#ifndef TCL_NO_MATH
|
276 |
{"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
|
277 |
{"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
|
278 |
{"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
|
279 |
{"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
|
280 |
{"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
|
281 |
{"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},
|
282 |
{"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh},
|
283 |
{"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp},
|
284 |
{"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor},
|
285 |
{"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod},
|
286 |
{"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot},
|
287 |
{"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log},
|
288 |
{"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10},
|
289 |
{"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow},
|
290 |
{"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin},
|
291 |
{"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh},
|
292 |
{"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt},
|
293 |
{"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan},
|
294 |
{"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh},
|
295 |
#endif
|
296 |
{"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
|
297 |
{"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
|
298 |
{"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
|
299 |
{"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */
|
300 |
{"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
|
301 |
{"srand", 1, {TCL_INT}, ExprSrandFunc, 0},
|
302 |
{0},
|
303 |
};
|
304 |
|
305 |
/*
|
306 |
* The structure below defines the command name Tcl object type by means of
|
307 |
* procedures that can be invoked by generic object code. Objects of this
|
308 |
* type cache the Command pointer that results from looking up command names
|
309 |
* in the command hashtable. Such objects appear as the zeroth ("command
|
310 |
* name") argument in a Tcl command.
|
311 |
*/
|
312 |
|
313 |
Tcl_ObjType tclCmdNameType = {
|
314 |
"cmdName", /* name */
|
315 |
FreeCmdNameInternalRep, /* freeIntRepProc */
|
316 |
DupCmdNameInternalRep, /* dupIntRepProc */
|
317 |
(Tcl_UpdateStringProc *) NULL, /* updateStringProc */
|
318 |
SetCmdNameFromAny /* setFromAnyProc */
|
319 |
};
|
320 |
|
321 |
/*
|
322 |
*----------------------------------------------------------------------
|
323 |
*
|
324 |
* InitByteCodeExecution --
|
325 |
*
|
326 |
* This procedure is called once to initialize the Tcl bytecode
|
327 |
* interpreter.
|
328 |
*
|
329 |
* Results:
|
330 |
* None.
|
331 |
*
|
332 |
* Side effects:
|
333 |
* This procedure initializes the array of instruction names. If
|
334 |
* compiling with the TCL_COMPILE_STATS flag, it initializes the
|
335 |
* array that counts the executions of each instruction and it
|
336 |
* creates the "evalstats" command. It also registers the command name
|
337 |
* Tcl_ObjType. It also establishes the link between the Tcl
|
338 |
* "tcl_traceExec" and C "tclTraceExec" variables.
|
339 |
*
|
340 |
*----------------------------------------------------------------------
|
341 |
*/
|
342 |
|
343 |
static void
|
344 |
InitByteCodeExecution(interp)
|
345 |
Tcl_Interp *interp; /* Interpreter for which the Tcl variable
|
346 |
* "tcl_traceExec" is linked to control
|
347 |
* instruction tracing. */
|
348 |
{
|
349 |
Tcl_RegisterObjType(&tclCmdNameType);
|
350 |
if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
|
351 |
TCL_LINK_INT) != TCL_OK) {
|
352 |
panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
|
353 |
}
|
354 |
|
355 |
#ifdef TCL_COMPILE_STATS
|
356 |
Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd,
|
357 |
(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
|
358 |
#endif /* TCL_COMPILE_STATS */
|
359 |
}
|
360 |
|
361 |
/*
|
362 |
*----------------------------------------------------------------------
|
363 |
*
|
364 |
* TclCreateExecEnv --
|
365 |
*
|
366 |
* This procedure creates a new execution environment for Tcl bytecode
|
367 |
* execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv
|
368 |
* is typically created once for each Tcl interpreter (Interp
|
369 |
* structure) and recursively passed to TclExecuteByteCode to execute
|
370 |
* ByteCode sequences for nested commands.
|
371 |
*
|
372 |
* Results:
|
373 |
* A newly allocated ExecEnv is returned. This points to an empty
|
374 |
* evaluation stack of the standard initial size.
|
375 |
*
|
376 |
* Side effects:
|
377 |
* The bytecode interpreter is also initialized here, as this
|
378 |
* procedure will be called before any call to TclExecuteByteCode.
|
379 |
*
|
380 |
*----------------------------------------------------------------------
|
381 |
*/
|
382 |
|
383 |
#define TCL_STACK_INITIAL_SIZE 2000
|
384 |
|
385 |
ExecEnv *
|
386 |
TclCreateExecEnv(interp)
|
387 |
Tcl_Interp *interp; /* Interpreter for which the execution
|
388 |
* environment is being created. */
|
389 |
{
|
390 |
ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
|
391 |
|
392 |
eePtr->stackPtr = (Tcl_Obj **)
|
393 |
ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));
|
394 |
eePtr->stackTop = -1;
|
395 |
eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1);
|
396 |
|
397 |
Tcl_MutexLock(&execMutex);
|
398 |
if (!execInitialized) {
|
399 |
TclInitAuxDataTypeTable();
|
400 |
InitByteCodeExecution(interp);
|
401 |
execInitialized = 1;
|
402 |
}
|
403 |
Tcl_MutexUnlock(&execMutex);
|
404 |
|
405 |
return eePtr;
|
406 |
}
|
407 |
#undef TCL_STACK_INITIAL_SIZE
|
408 |
|
409 |
/*
|
410 |
*----------------------------------------------------------------------
|
411 |
*
|
412 |
* TclDeleteExecEnv --
|
413 |
*
|
414 |
* Frees the storage for an ExecEnv.
|
415 |
*
|
416 |
* Results:
|
417 |
* None.
|
418 |
*
|
419 |
* Side effects:
|
420 |
* Storage for an ExecEnv and its contained storage (e.g. the
|
421 |
* evaluation stack) is freed.
|
422 |
*
|
423 |
*----------------------------------------------------------------------
|
424 |
*/
|
425 |
|
426 |
void
|
427 |
TclDeleteExecEnv(eePtr)
|
428 |
ExecEnv *eePtr; /* Execution environment to free. */
|
429 |
{
|
430 |
ckfree((char *) eePtr->stackPtr);
|
431 |
ckfree((char *) eePtr);
|
432 |
}
|
433 |
|
434 |
/*
|
435 |
*----------------------------------------------------------------------
|
436 |
*
|
437 |
* TclFinalizeExecution --
|
438 |
*
|
439 |
* Finalizes the execution environment setup so that it can be
|
440 |
* later reinitialized.
|
441 |
*
|
442 |
* Results:
|
443 |
* None.
|
444 |
*
|
445 |
* Side effects:
|
446 |
* After this call, the next time TclCreateExecEnv will be called
|
447 |
* it will call InitByteCodeExecution.
|
448 |
*
|
449 |
*----------------------------------------------------------------------
|
450 |
*/
|
451 |
|
452 |
void
|
453 |
TclFinalizeExecution()
|
454 |
{
|
455 |
Tcl_MutexLock(&execMutex);
|
456 |
execInitialized = 0;
|
457 |
Tcl_MutexUnlock(&execMutex);
|
458 |
TclFinalizeAuxDataTypeTable();
|
459 |
}
|
460 |
|
461 |
/*
|
462 |
*----------------------------------------------------------------------
|
463 |
*
|
464 |
* GrowEvaluationStack --
|
465 |
*
|
466 |
* This procedure grows a Tcl evaluation stack stored in an ExecEnv.
|
467 |
*
|
468 |
* Results:
|
469 |
* None.
|
470 |
*
|
471 |
* Side effects:
|
472 |
* The size of the evaluation stack is doubled.
|
473 |
*
|
474 |
*----------------------------------------------------------------------
|
475 |
*/
|
476 |
|
477 |
static void
|
478 |
GrowEvaluationStack(eePtr)
|
479 |
register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation
|
480 |
* stack to enlarge. */
|
481 |
{
|
482 |
/*
|
483 |
* The current Tcl stack elements are stored from eePtr->stackPtr[0]
|
484 |
* to eePtr->stackPtr[eePtr->stackEnd] (inclusive).
|
485 |
*/
|
486 |
|
487 |
int currElems = (eePtr->stackEnd + 1);
|
488 |
int newElems = 2*currElems;
|
489 |
int currBytes = currElems * sizeof(Tcl_Obj *);
|
490 |
int newBytes = 2*currBytes;
|
491 |
Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
|
492 |
|
493 |
/*
|
494 |
* Copy the existing stack items to the new stack space, free the old
|
495 |
* storage if appropriate, and mark new space as malloc'ed.
|
496 |
*/
|
497 |
|
498 |
memcpy((VOID *) newStackPtr, (VOID *) eePtr->stackPtr,
|
499 |
(size_t) currBytes);
|
500 |
ckfree((char *) eePtr->stackPtr);
|
501 |
eePtr->stackPtr = newStackPtr;
|
502 |
eePtr->stackEnd = (newElems - 1); /* i.e. index of last usable item */
|
503 |
}
|
504 |
|
505 |
/*
|
506 |
*----------------------------------------------------------------------
|
507 |
*
|
508 |
* TclExecuteByteCode --
|
509 |
*
|
510 |
* This procedure executes the instructions of a ByteCode structure.
|
511 |
* It returns when a "done" instruction is executed or an error occurs.
|
512 |
*
|
513 |
* Results:
|
514 |
* The return value is one of the return codes defined in tcl.h
|
515 |
* (such as TCL_OK), and interp->objResultPtr refers to a Tcl object
|
516 |
* that either contains the result of executing the code or an
|
517 |
* error message.
|
518 |
*
|
519 |
* Side effects:
|
520 |
* Almost certainly, depending on the ByteCode's instructions.
|
521 |
*
|
522 |
*----------------------------------------------------------------------
|
523 |
*/
|
524 |
|
525 |
int
|
526 |
TclExecuteByteCode(interp, codePtr)
|
527 |
Tcl_Interp *interp; /* Token for command interpreter. */
|
528 |
ByteCode *codePtr; /* The bytecode sequence to interpret. */
|
529 |
{
|
530 |
Interp *iPtr = (Interp *) interp;
|
531 |
ExecEnv *eePtr = iPtr->execEnvPtr;
|
532 |
/* Points to the execution environment. */
|
533 |
register Tcl_Obj **stackPtr = eePtr->stackPtr;
|
534 |
/* Cached evaluation stack base pointer. */
|
535 |
register int stackTop = eePtr->stackTop;
|
536 |
/* Cached top index of evaluation stack. */
|
537 |
register unsigned char *pc = codePtr->codeStart;
|
538 |
/* The current program counter. */
|
539 |
int opnd; /* Current instruction's operand byte. */
|
540 |
int pcAdjustment; /* Hold pc adjustment after instruction. */
|
541 |
int initStackTop = stackTop;/* Stack top at start of execution. */
|
542 |
ExceptionRange *rangePtr; /* Points to closest loop or catch exception
|
543 |
* range enclosing the pc. Used by various
|
544 |
* instructions and processCatch to
|
545 |
* process break, continue, and errors. */
|
546 |
int result = TCL_OK; /* Return code returned after execution. */
|
547 |
int traceInstructions = (tclTraceExec == 3);
|
548 |
Tcl_Obj *valuePtr, *value2Ptr, *objPtr;
|
549 |
char *bytes;
|
550 |
int length;
|
551 |
long i;
|
552 |
|
553 |
/*
|
554 |
* This procedure uses a stack to hold information about catch commands.
|
555 |
* This information is the current operand stack top when starting to
|
556 |
* execute the code for each catch command. It starts out with stack-
|
557 |
* allocated space but uses dynamically-allocated storage if needed.
|
558 |
*/
|
559 |
|
560 |
#define STATIC_CATCH_STACK_SIZE 4
|
561 |
int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
|
562 |
int *catchStackPtr = catchStackStorage;
|
563 |
int catchTop = -1;
|
564 |
|
565 |
#ifdef TCL_COMPILE_DEBUG
|
566 |
if (tclTraceExec >= 2) {
|
567 |
PrintByteCodeInfo(codePtr);
|
568 |
fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop);
|
569 |
fflush(stdout);
|
570 |
}
|
571 |
#endif
|
572 |
|
573 |
#ifdef TCL_COMPILE_STATS
|
574 |
iPtr->stats.numExecutions++;
|
575 |
#endif
|
576 |
|
577 |
/*
|
578 |
* Make sure the catch stack is large enough to hold the maximum number
|
579 |
* of catch commands that could ever be executing at the same time. This
|
580 |
* will be no more than the exception range array's depth.
|
581 |
*/
|
582 |
|
583 |
if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) {
|
584 |
catchStackPtr = (int *)
|
585 |
ckalloc(codePtr->maxExceptDepth * sizeof(int));
|
586 |
}
|
587 |
|
588 |
/*
|
589 |
* Make sure the stack has enough room to execute this ByteCode.
|
590 |
*/
|
591 |
|
592 |
while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
|
593 |
GrowEvaluationStack(eePtr);
|
594 |
stackPtr = eePtr->stackPtr;
|
595 |
}
|
596 |
|
597 |
/*
|
598 |
* Loop executing instructions until a "done" instruction, a TCL_RETURN,
|
599 |
* or some error.
|
600 |
*/
|
601 |
|
602 |
for (;;) {
|
603 |
#ifdef TCL_COMPILE_DEBUG
|
604 |
ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop,
|
605 |
eePtr->stackEnd);
|
606 |
#else /* not TCL_COMPILE_DEBUG */
|
607 |
if (traceInstructions) {
|
608 |
fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop);
|
609 |
TclPrintInstruction(codePtr, pc);
|
610 |
fflush(stdout);
|
611 |
}
|
612 |
#endif /* TCL_COMPILE_DEBUG */
|
613 |
|
614 |
#ifdef TCL_COMPILE_STATS
|
615 |
iPtr->stats.instructionCount[*pc]++;
|
616 |
#endif
|
617 |
switch (*pc) {
|
618 |
case INST_DONE:
|
619 |
/*
|
620 |
* Pop the topmost object from the stack, set the interpreter's
|
621 |
* object result to point to it, and return.
|
622 |
*/
|
623 |
valuePtr = POP_OBJECT();
|
624 |
Tcl_SetObjResult(interp, valuePtr);
|
625 |
TclDecrRefCount(valuePtr);
|
626 |
if (stackTop != initStackTop) {
|
627 |
fprintf(stderr, "\nTclExecuteByteCode: done instruction at pc %u: stack top %d != entry stack top %d\n",
|
628 |
(unsigned int)(pc - codePtr->codeStart),
|
629 |
(unsigned int) stackTop,
|
630 |
(unsigned int) initStackTop);
|
631 |
panic("TclExecuteByteCode execution failure: end stack top != start stack top");
|
632 |
}
|
633 |
TRACE_WITH_OBJ(("=> return code=%d, result=", result),
|
634 |
iPtr->objResultPtr);
|
635 |
#ifdef TCL_COMPILE_DEBUG
|
636 |
if (traceInstructions) {
|
637 |
fprintf(stdout, "\n");
|
638 |
}
|
639 |
#endif
|
640 |
goto done;
|
641 |
|
642 |
case INST_PUSH1:
|
643 |
#ifdef TCL_COMPILE_DEBUG
|
644 |
valuePtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];
|
645 |
PUSH_OBJECT(valuePtr);
|
646 |
TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), valuePtr);
|
647 |
#else
|
648 |
PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
|
649 |
#endif /* TCL_COMPILE_DEBUG */
|
650 |
ADJUST_PC(2);
|
651 |
|
652 |
case INST_PUSH4:
|
653 |
valuePtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
|
654 |
PUSH_OBJECT(valuePtr);
|
655 |
TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), valuePtr);
|
656 |
ADJUST_PC(5);
|
657 |
|
658 |
case INST_POP:
|
659 |
valuePtr = POP_OBJECT();
|
660 |
TRACE_WITH_OBJ(("=> discarding "), valuePtr);
|
661 |
TclDecrRefCount(valuePtr); /* finished with pop'ed object. */
|
662 |
ADJUST_PC(1);
|
663 |
|
664 |
case INST_DUP:
|
665 |
valuePtr = stackPtr[stackTop];
|
666 |
PUSH_OBJECT(Tcl_DuplicateObj(valuePtr));
|
667 |
TRACE_WITH_OBJ(("=> "), valuePtr);
|
668 |
ADJUST_PC(1);
|
669 |
|
670 |
case INST_CONCAT1:
|
671 |
opnd = TclGetUInt1AtPtr(pc+1);
|
672 |
{
|
673 |
Tcl_Obj *concatObjPtr;
|
674 |
int totalLen = 0;
|
675 |
|
676 |
/*
|
677 |
* Concatenate strings (with no separators) from the top
|
678 |
* opnd items on the stack starting with the deepest item.
|
679 |
* First, determine how many characters are needed.
|
680 |
*/
|
681 |
|
682 |
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
|
683 |
bytes = Tcl_GetStringFromObj(stackPtr[i], &length);
|
684 |
if (bytes != NULL) {
|
685 |
totalLen += length;
|
686 |
}
|
687 |
}
|
688 |
|
689 |
/*
|
690 |
* Initialize the new append string object by appending the
|
691 |
* strings of the opnd stack objects. Also pop the objects.
|
692 |
*/
|
693 |
|
694 |
TclNewObj(concatObjPtr);
|
695 |
if (totalLen > 0) {
|
696 |
char *p = (char *) ckalloc((unsigned) (totalLen + 1));
|
697 |
concatObjPtr->bytes = p;
|
698 |
concatObjPtr->length = totalLen;
|
699 |
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
|
700 |
valuePtr = stackPtr[i];
|
701 |
bytes = Tcl_GetStringFromObj(valuePtr, &length);
|
702 |
if (bytes != NULL) {
|
703 |
memcpy((VOID *) p, (VOID *) bytes,
|
704 |
(size_t) length);
|
705 |
p += length;
|
706 |
}
|
707 |
TclDecrRefCount(valuePtr);
|
708 |
}
|
709 |
*p = '\0';
|
710 |
} else {
|
711 |
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
|
712 |
Tcl_DecrRefCount(stackPtr[i]);
|
713 |
}
|
714 |
}
|
715 |
stackTop -= opnd;
|
716 |
|
717 |
PUSH_OBJECT(concatObjPtr);
|
718 |
TRACE_WITH_OBJ(("%u => ", opnd), concatObjPtr);
|
719 |
ADJUST_PC(2);
|
720 |
}
|
721 |
|
722 |
case INST_INVOKE_STK4:
|
723 |
opnd = TclGetUInt4AtPtr(pc+1);
|
724 |
pcAdjustment = 5;
|
725 |
goto doInvocation;
|
726 |
|
727 |
case INST_INVOKE_STK1:
|
728 |
opnd = TclGetUInt1AtPtr(pc+1);
|
729 |
pcAdjustment = 2;
|
730 |
|
731 |
doInvocation:
|
732 |
{
|
733 |
int objc = opnd; /* The number of arguments. */
|
734 |
Tcl_Obj **objv; /* The array of argument objects. */
|
735 |
Command *cmdPtr; /* Points to command's Command struct. */
|
736 |
int newPcOffset; /* New inst offset for break, continue. */
|
737 |
#ifdef TCL_COMPILE_DEBUG
|
738 |
int isUnknownCmd = 0;
|
739 |
char cmdNameBuf[21];
|
740 |
#endif /* TCL_COMPILE_DEBUG */
|
741 |
|
742 |
/*
|
743 |
* If the interpreter was deleted, return an error.
|
744 |
*/
|
745 |
|
746 |
if (iPtr->flags & DELETED) {
|
747 |
Tcl_ResetResult(interp);
|
748 |
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
749 |
"attempt to call eval in deleted interpreter", -1);
|
750 |
Tcl_SetErrorCode(interp, "CORE", "IDELETE",
|
751 |
"attempt to call eval in deleted interpreter",
|
752 |
(char *) NULL);
|
753 |
result = TCL_ERROR;
|
754 |
goto checkForCatch;
|
755 |
}
|
756 |
|
757 |
/*
|
758 |
* Find the procedure to execute this command. If the
|
759 |
* command is not found, handle it with the "unknown" proc.
|
760 |
*/
|
761 |
|
762 |
objv = &(stackPtr[stackTop - (objc-1)]);
|
763 |
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
|
764 |
if (cmdPtr == NULL) {
|
765 |
cmdPtr = (Command *) Tcl_FindCommand(interp, "unknown",
|
766 |
(Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY);
|
767 |
if (cmdPtr == NULL) {
|
768 |
Tcl_ResetResult(interp);
|
769 |
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
770 |
"invalid command name \"",
|
771 |
Tcl_GetString(objv[0]), "\"",
|
772 |
(char *) NULL);
|
773 |
TRACE(("%u => unknown proc not found: ", objc));
|
774 |
result = TCL_ERROR;
|
775 |
goto checkForCatch;
|
776 |
}
|
777 |
#ifdef TCL_COMPILE_DEBUG
|
778 |
isUnknownCmd = 1;
|
779 |
#endif /*TCL_COMPILE_DEBUG*/
|
780 |
stackTop++; /* need room for new inserted objv[0] */
|
781 |
for (i = objc-1; i >= 0; i--) {
|
782 |
objv[i+1] = objv[i];
|
783 |
}
|
784 |
objc++;
|
785 |
objv[0] = Tcl_NewStringObj("unknown", -1);
|
786 |
Tcl_IncrRefCount(objv[0]);
|
787 |
}
|
788 |
|
789 |
/*
|
790 |
* Call any trace procedures.
|
791 |
*/
|
792 |
|
793 |
if (iPtr->tracePtr != NULL) {
|
794 |
Trace *tracePtr, *nextTracePtr;
|
795 |
|
796 |
for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
|
797 |
tracePtr = nextTracePtr) {
|
798 |
nextTracePtr = tracePtr->nextPtr;
|
799 |
if (iPtr->numLevels <= tracePtr->level) {
|
800 |
int numChars;
|
801 |
char *cmd = GetSrcInfoForPc(pc, codePtr,
|
802 |
&numChars);
|
803 |
if (cmd != NULL) {
|
804 |
DECACHE_STACK_INFO();
|
805 |
CallTraceProcedure(interp, tracePtr, cmdPtr,
|
806 |
cmd, numChars, objc, objv);
|
807 |
CACHE_STACK_INFO();
|
808 |
}
|
809 |
}
|
810 |
}
|
811 |
}
|
812 |
|
813 |
/*
|
814 |
* Finally, invoke the command's Tcl_ObjCmdProc. First reset
|
815 |
* the interpreter's string and object results to their
|
816 |
* default empty values since they could have gotten changed
|
817 |
* by earlier invocations.
|
818 |
*/
|
819 |
|
820 |
Tcl_ResetResult(interp);
|
821 |
if (tclTraceExec >= 2) {
|
822 |
#ifdef TCL_COMPILE_DEBUG
|
823 |
if (traceInstructions) {
|
824 |
strncpy(cmdNameBuf, Tcl_GetString(objv[0]), 20);
|
825 |
TRACE(("%u => call ", (isUnknownCmd? objc-1:objc)));
|
826 |
} else {
|
827 |
fprintf(stdout, "%d: (%u) invoking ",
|
828 |
iPtr->numLevels,
|
829 |
(unsigned int)(pc - codePtr->codeStart));
|
830 |
}
|
831 |
for (i = 0; i < objc; i++) {
|
832 |
TclPrintObject(stdout, objv[i], 15);
|
833 |
fprintf(stdout, " ");
|
834 |
}
|
835 |
fprintf(stdout, "\n");
|
836 |
fflush(stdout);
|
837 |
#else /* TCL_COMPILE_DEBUG */
|
838 |
fprintf(stdout, "%d: (%u) invoking %s\n",
|
839 |
iPtr->numLevels,
|
840 |
(unsigned int)(pc - codePtr->codeStart),
|
841 |
Tcl_GetString(objv[0]));
|
842 |
#endif /*TCL_COMPILE_DEBUG*/
|
843 |
}
|
844 |
|
845 |
iPtr->cmdCount++;
|
846 |
DECACHE_STACK_INFO();
|
847 |
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
|
848 |
objc, objv);
|
849 |
if (Tcl_AsyncReady()) {
|
850 |
result = Tcl_AsyncInvoke(interp, result);
|
851 |
}
|
852 |
CACHE_STACK_INFO();
|
853 |
|
854 |
/*
|
855 |
* If the interpreter has a non-empty string result, the
|
856 |
* result object is either empty or stale because some
|
857 |
* procedure set interp->result directly. If so, move the
|
858 |
* string result to the result object, then reset the
|
859 |
* string result.
|
860 |
*/
|
861 |
|
862 |
if (*(iPtr->result) != 0) {
|
863 |
(void) Tcl_GetObjResult(interp);
|
864 |
}
|
865 |
|
866 |
/*
|
867 |
* Pop the objc top stack elements and decrement their ref
|
868 |
* counts.
|
869 |
*/
|
870 |
|
871 |
for (i = 0; i < objc; i++) {
|
872 |
valuePtr = stackPtr[stackTop];
|
873 |
TclDecrRefCount(valuePtr);
|
874 |
stackTop--;
|
875 |
}
|
876 |
|
877 |
/*
|
878 |
* Process the result of the Tcl_ObjCmdProc call.
|
879 |
*/
|
880 |
|
881 |
switch (result) {
|
882 |
case TCL_OK:
|
883 |
/*
|
884 |
* Push the call's object result and continue execution
|
885 |
* with the next instruction.
|
886 |
*/
|
887 |
PUSH_OBJECT(Tcl_GetObjResult(interp));
|
888 |
TRACE_WITH_OBJ(("%u => ...after \"%.20s\", result=",
|
889 |
objc, cmdNameBuf), Tcl_GetObjResult(interp));
|
890 |
ADJUST_PC(pcAdjustment);
|
891 |
|
892 |
case TCL_BREAK:
|
893 |
case TCL_CONTINUE:
|
894 |
/*
|
895 |
* The invoked command requested a break or continue.
|
896 |
* Find the closest enclosing loop or catch exception
|
897 |
* range, if any. If a loop is found, terminate its
|
898 |
* execution or skip to its next iteration. If the
|
899 |
* closest is a catch exception range, jump to its
|
900 |
* catchOffset. If no enclosing range is found, stop
|
901 |
* execution and return the TCL_BREAK or TCL_CONTINUE.
|
902 |
*/
|
903 |
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0,
|
904 |
codePtr);
|
905 |
if (rangePtr == NULL) {
|
906 |
TRACE(("%u => ... after \"%.20s\", no encl. loop or catch, returning %s\n",
|
907 |
objc, cmdNameBuf,
|
908 |
StringForResultCode(result)));
|
909 |
goto abnormalReturn; /* no catch exists to check */
|
910 |
}
|
911 |
newPcOffset = 0;
|
912 |
switch (rangePtr->type) {
|
913 |
case LOOP_EXCEPTION_RANGE:
|
914 |
if (result == TCL_BREAK) {
|
915 |
newPcOffset = rangePtr->breakOffset;
|
916 |
} else if (rangePtr->continueOffset == -1) {
|
917 |
TRACE(("%u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n",
|
918 |
objc, cmdNameBuf,
|
919 |
StringForResultCode(result)));
|
920 |
goto checkForCatch;
|
921 |
} else {
|
922 |
newPcOffset = rangePtr->continueOffset;
|
923 |
}
|
924 |
TRACE(("%u => ... after \"%.20s\", %s, range at %d, new pc %d\n",
|
925 |
objc, cmdNameBuf,
|
926 |
StringForResultCode(result),
|
927 |
rangePtr->codeOffset, newPcOffset));
|
928 |
break;
|
929 |
case CATCH_EXCEPTION_RANGE:
|
930 |
TRACE(("%u => ... after \"%.20s\", %s...\n",
|
931 |
objc, cmdNameBuf,
|
932 |
StringForResultCode(result)));
|
933 |
goto processCatch; /* it will use rangePtr */
|
934 |
default:
|
935 |
panic("TclExecuteByteCode: bad ExceptionRange type\n");
|
936 |
}
|
937 |
result = TCL_OK;
|
938 |
pc = (codePtr->codeStart + newPcOffset);
|
939 |
continue; /* restart outer instruction loop at pc */
|
940 |
|
941 |
case TCL_ERROR:
|
942 |
/*
|
943 |
* The invoked command returned an error. Look for an
|
944 |
* enclosing catch exception range, if any.
|
945 |
*/
|
946 |
TRACE_WITH_OBJ(("%u => ... after \"%.20s\", TCL_ERROR ",
|
947 |
objc, cmdNameBuf), Tcl_GetObjResult(interp));
|
948 |
goto checkForCatch;
|
949 |
|
950 |
case TCL_RETURN:
|
951 |
/*
|
952 |
* The invoked command requested that the current
|
953 |
* procedure stop execution and return. First check
|
954 |
* for an enclosing catch exception range, if any.
|
955 |
*/
|
956 |
TRACE(("%u => ... after \"%.20s\", TCL_RETURN\n",
|
957 |
objc, cmdNameBuf));
|
958 |
goto checkForCatch;
|
959 |
|
960 |
default:
|
961 |
TRACE_WITH_OBJ(("%u => ... after \"%.20s\", OTHER RETURN CODE %d ",
|
962 |
objc, cmdNameBuf, result),
|
963 |
Tcl_GetObjResult(interp));
|
964 |
goto checkForCatch;
|
965 |
}
|
966 |
}
|
967 |
|
968 |
case INST_EVAL_STK:
|
969 |
objPtr = POP_OBJECT();
|
970 |
DECACHE_STACK_INFO();
|
971 |
result = Tcl_EvalObjEx(interp, objPtr, 0);
|
972 |
CACHE_STACK_INFO();
|
973 |
if (result == TCL_OK) {
|
974 |
/*
|
975 |
* Normal return; push the eval's object result.
|
976 |
*/
|
977 |
PUSH_OBJECT(Tcl_GetObjResult(interp));
|
978 |
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
|
979 |
Tcl_GetObjResult(interp));
|
980 |
TclDecrRefCount(objPtr);
|
981 |
ADJUST_PC(1);
|
982 |
} else if ((result == TCL_BREAK) || (result == TCL_CONTINUE)) {
|
983 |
/*
|
984 |
* Find the closest enclosing loop or catch exception range,
|
985 |
* if any. If a loop is found, terminate its execution or
|
986 |
* skip to its next iteration. If the closest is a catch
|
987 |
* exception range, jump to its catchOffset. If no enclosing
|
988 |
* range is found, stop execution and return that same
|
989 |
* TCL_BREAK or TCL_CONTINUE.
|
990 |
*/
|
991 |
|
992 |
int newPcOffset = 0; /* Pc offset computed during break,
|
993 |
* continue, error processing. Init.
|
994 |
* to avoid compiler warning. */
|
995 |
|
996 |
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0,
|
997 |
codePtr);
|
998 |
if (rangePtr == NULL) {
|
999 |
TRACE(("\"%.30s\" => no encl. loop or catch, returning %s\n",
|
1000 |
O2S(objPtr), StringForResultCode(result)));
|
1001 |
Tcl_DecrRefCount(objPtr);
|
1002 |
goto abnormalReturn; /* no catch exists to check */
|
1003 |
}
|
1004 |
switch (rangePtr->type) {
|
1005 |
case LOOP_EXCEPTION_RANGE:
|
1006 |
if (result == TCL_BREAK) {
|
1007 |
newPcOffset = rangePtr->breakOffset;
|
1008 |
} else if (rangePtr->continueOffset == -1) {
|
1009 |
TRACE(("\"%.30s\" => %s, loop w/o continue, checking for catch\n",
|
1010 |
O2S(objPtr), StringForResultCode(result)));
|
1011 |
Tcl_DecrRefCount(objPtr);
|
1012 |
goto checkForCatch;
|
1013 |
} else {
|
1014 |
newPcOffset = rangePtr->continueOffset;
|
1015 |
}
|
1016 |
result = TCL_OK;
|
1017 |
TRACE_WITH_OBJ(("\"%.30s\" => %s, range at %d, new pc %d ",
|
1018 |
O2S(objPtr), StringForResultCode(result),
|
1019 |
rangePtr->codeOffset, newPcOffset), valuePtr);
|
1020 |
break;
|
1021 |
case CATCH_EXCEPTION_RANGE:
|
1022 |
TRACE_WITH_OBJ(("\"%.30s\" => %s ",
|
1023 |
O2S(objPtr), StringForResultCode(result)),
|
1024 |
valuePtr);
|
1025 |
Tcl_DecrRefCount(objPtr);
|
1026 |
goto processCatch; /* it will use rangePtr */
|
1027 |
default:
|
1028 |
panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
|
1029 |
}
|
1030 |
Tcl_DecrRefCount(objPtr);
|
1031 |
pc = (codePtr->codeStart + newPcOffset);
|
1032 |
continue; /* restart outer instruction loop at pc */
|
1033 |
} else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */
|
1034 |
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
|
1035 |
Tcl_GetObjResult(interp));
|
1036 |
Tcl_DecrRefCount(objPtr);
|
1037 |
goto checkForCatch;
|
1038 |
}
|
1039 |
|
1040 |
case INST_EXPR_STK:
|
1041 |
objPtr = POP_OBJECT();
|
1042 |
Tcl_ResetResult(interp);
|
1043 |
DECACHE_STACK_INFO();
|
1044 |
result = Tcl_ExprObj(interp, objPtr, &valuePtr);
|
1045 |
CACHE_STACK_INFO();
|
1046 |
if (result != TCL_OK) {
|
1047 |
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
|
1048 |
O2S(objPtr)), Tcl_GetObjResult(interp));
|
1049 |
Tcl_DecrRefCount(objPtr);
|
1050 |
goto checkForCatch;
|
1051 |
}
|
1052 |
stackPtr[++stackTop] = valuePtr; /* already has right refct */
|
1053 |
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
|
1054 |
TclDecrRefCount(objPtr);
|
1055 |
ADJUST_PC(1);
|
1056 |
|
1057 |
case INST_LOAD_SCALAR1:
|
1058 |
#ifdef TCL_COMPILE_DEBUG
|
1059 |
opnd = TclGetUInt1AtPtr(pc+1);
|
1060 |
DECACHE_STACK_INFO();
|
1061 |
valuePtr = TclGetIndexedScalar(interp, opnd,
|
1062 |
/*leaveErrorMsg*/ 1);
|
1063 |
CACHE_STACK_INFO();
|
1064 |
if (valuePtr == NULL) {
|
1065 |
TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
|
1066 |
Tcl_GetObjResult(interp));
|
1067 |
result = TCL_ERROR;
|
1068 |
goto checkForCatch;
|
1069 |
}
|
1070 |
PUSH_OBJECT(valuePtr);
|
1071 |
TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
|
1072 |
#else /* TCL_COMPILE_DEBUG */
|
1073 |
DECACHE_STACK_INFO();
|
1074 |
opnd = TclGetUInt1AtPtr(pc+1);
|
1075 |
valuePtr = TclGetIndexedScalar(interp, opnd, /*leaveErrorMsg*/ 1);
|
1076 |
CACHE_STACK_INFO();
|
1077 |
if (valuePtr == NULL) {
|
1078 |
result = TCL_ERROR;
|
1079 |
goto checkForCatch;
|
1080 |
}
|
1081 |
PUSH_OBJECT(valuePtr);
|
1082 |
#endif /* TCL_COMPILE_DEBUG */
|
1083 |
ADJUST_PC(2);
|
1084 |
|
1085 |
case INST_LOAD_SCALAR4:
|
1086 |
opnd = TclGetUInt4AtPtr(pc+1);
|
1087 |
DECACHE_STACK_INFO();
|
1088 |
valuePtr = TclGetIndexedScalar(interp, opnd,
|
1089 |
/*leaveErrorMsg*/ 1);
|
1090 |
CACHE_STACK_INFO();
|
1091 |
if (valuePtr == NULL) {
|
1092 |
TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
|
1093 |
Tcl_GetObjResult(interp));
|
1094 |
result = TCL_ERROR;
|
1095 |
goto checkForCatch;
|
1096 |
}
|
1097 |
PUSH_OBJECT(valuePtr);
|
1098 |
TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
|
1099 |
ADJUST_PC(5);
|
1100 |
|
1101 |
case INST_LOAD_SCALAR_STK:
|
1102 |
objPtr = POP_OBJECT(); /* scalar name */
|
1103 |
DECACHE_STACK_INFO();
|
1104 |
valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);
|
1105 |
CACHE_STACK_INFO();
|
1106 |
if (valuePtr == NULL) {
|
1107 |
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
|
1108 |
Tcl_GetObjResult(interp));
|
1109 |
Tcl_DecrRefCount(objPtr);
|
1110 |
result = TCL_ERROR;
|
1111 |
goto checkForCatch;
|
1112 |
}
|
1113 |
PUSH_OBJECT(valuePtr);
|
1114 |
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
|
1115 |
TclDecrRefCount(objPtr);
|
1116 |
ADJUST_PC(1);
|
1117 |
|
1118 |
case INST_LOAD_ARRAY4:
|
1119 |
opnd = TclGetUInt4AtPtr(pc+1);
|
1120 |
pcAdjustment = 5;
|
1121 |
goto doLoadArray;
|
1122 |
|
1123 |
case INST_LOAD_ARRAY1:
|
1124 |
opnd = TclGetUInt1AtPtr(pc+1);
|
1125 |
pcAdjustment = 2;
|
1126 |
|
1127 |
doLoadArray:
|
1128 |
{
|
1129 |
Tcl_Obj *elemPtr = POP_OBJECT();
|
1130 |
|
1131 |
DECACHE_STACK_INFO();
|
1132 |
valuePtr = TclGetElementOfIndexedArray(interp, opnd,
|
1133 |
elemPtr, /*leaveErrorMsg*/ 1);
|
1134 |
CACHE_STACK_INFO();
|
1135 |
if (valuePtr == NULL) {
|
1136 |
TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ",
|
1137 |
opnd, O2S(elemPtr)), Tcl_GetObjResult(interp));
|
1138 |
Tcl_DecrRefCount(elemPtr);
|
1139 |
result = TCL_ERROR;
|
1140 |
goto checkForCatch;
|
1141 |
}
|
1142 |
PUSH_OBJECT(valuePtr);
|
1143 |
TRACE_WITH_OBJ(("%u \"%.30s\" => ",
|
1144 |
opnd, O2S(elemPtr)),valuePtr);
|
1145 |
TclDecrRefCount(elemPtr);
|
1146 |
}
|
1147 |
ADJUST_PC(pcAdjustment);
|
1148 |
|
1149 |
case INST_LOAD_ARRAY_STK:
|
1150 |
{
|
1151 |
Tcl_Obj *elemPtr = POP_OBJECT();
|
1152 |
|
1153 |
objPtr = POP_OBJECT(); /* array name */
|
1154 |
DECACHE_STACK_INFO();
|
1155 |
valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr,
|
1156 |
TCL_LEAVE_ERR_MSG);
|
1157 |
CACHE_STACK_INFO();
|
1158 |
if (valuePtr == NULL) {
|
1159 |
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ",
|
1160 |
O2S(objPtr), O2S(elemPtr)),
|
1161 |
Tcl_GetObjResult(interp));
|
1162 |
Tcl_DecrRefCount(objPtr);
|
1163 |
Tcl_DecrRefCount(elemPtr);
|
1164 |
result = TCL_ERROR;
|
1165 |
goto checkForCatch;
|
1166 |
}
|
1167 |
PUSH_OBJECT(valuePtr);
|
1168 |
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ",
|
1169 |
O2S(objPtr), O2S(elemPtr)), valuePtr);
|
1170 |
TclDecrRefCount(objPtr);
|
1171 |
TclDecrRefCount(elemPtr);
|
1172 |
}
|
1173 |
ADJUST_PC(1);
|
1174 |
|
1175 |
case INST_LOAD_STK:
|
1176 |
objPtr = POP_OBJECT(); /* variable name */
|
1177 |
DECACHE_STACK_INFO();
|
1178 |
valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);
|
1179 |
CACHE_STACK_INFO();
|
1180 |
if (valuePtr == NULL) {
|
1181 |
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
|
1182 |
O2S(objPtr)), Tcl_GetObjResult(interp));
|
1183 |
Tcl_DecrRefCount(objPtr);
|
1184 |
result = TCL_ERROR;
|
1185 |
goto checkForCatch;
|
1186 |
}
|
1187 |
PUSH_OBJECT(valuePtr);
|
1188 |
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
|
1189 |
TclDecrRefCount(objPtr);
|
1190 |
ADJUST_PC(1);
|
1191 |
|
1192 |
case INST_STORE_SCALAR4:
|
1193 |
opnd = TclGetUInt4AtPtr(pc+1);
|
1194 |
pcAdjustment = 5;
|
1195 |
goto doStoreScalar;
|
1196 |
|
1197 |
case INST_STORE_SCALAR1:
|
1198 |
opnd = TclGetUInt1AtPtr(pc+1);
|
1199 |
pcAdjustment = 2;
|
1200 |
|
1201 |
doStoreScalar:
|
1202 |
valuePtr = POP_OBJECT();
|
1203 |
DECACHE_STACK_INFO();
|
1204 |
value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr,
|
1205 |
/*leaveErrorMsg*/ 1);
|
1206 |
CACHE_STACK_INFO();
|
1207 |
if (value2Ptr == NULL) {
|
1208 |
TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ",
|
1209 |
opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
|
1210 |
Tcl_DecrRefCount(valuePtr);
|
1211 |
result = TCL_ERROR;
|
1212 |
goto checkForCatch;
|
1213 |
}
|
1214 |
PUSH_OBJECT(value2Ptr);
|
1215 |
TRACE_WITH_OBJ(("%u <- \"%.30s\" => ",
|
1216 |
opnd, O2S(valuePtr)), value2Ptr);
|
1217 |
TclDecrRefCount(valuePtr);
|
1218 |
ADJUST_PC(pcAdjustment);
|
1219 |
|
1220 |
case INST_STORE_SCALAR_STK:
|
1221 |
valuePtr = POP_OBJECT();
|
1222 |
objPtr = POP_OBJECT(); /* scalar name */
|
1223 |
DECACHE_STACK_INFO();
|
1224 |
value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
|
1225 |
TCL_LEAVE_ERR_MSG);
|
1226 |
CACHE_STACK_INFO();
|
1227 |
if (value2Ptr == NULL) {
|
1228 |
TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ",
|
1229 |
O2S(objPtr), O2S(valuePtr)),
|
1230 |
Tcl_GetObjResult(interp));
|
1231 |
Tcl_DecrRefCount(objPtr);
|
1232 |
Tcl_DecrRefCount(valuePtr);
|
1233 |
result = TCL_ERROR;
|
1234 |
goto checkForCatch;
|
1235 |
}
|
1236 |
PUSH_OBJECT(value2Ptr);
|
1237 |
TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ",
|
1238 |
O2S(objPtr), O2S(valuePtr)), value2Ptr);
|
1239 |
TclDecrRefCount(objPtr);
|
1240 |
TclDecrRefCount(valuePtr);
|
1241 |
ADJUST_PC(1);
|
1242 |
|
1243 |
case INST_STORE_ARRAY4:
|
1244 |
opnd = TclGetUInt4AtPtr(pc+1);
|
1245 |
pcAdjustment = 5;
|
1246 |
goto doStoreArray;
|
1247 |
|
1248 |
case INST_STORE_ARRAY1:
|
1249 |
opnd = TclGetUInt1AtPtr(pc+1);
|
1250 |
pcAdjustment = 2;
|
1251 |
|
1252 |
doStoreArray:
|
1253 |
{
|
1254 |
Tcl_Obj *elemPtr;
|
1255 |
|
1256 |
valuePtr = POP_OBJECT();
|
1257 |
elemPtr = POP_OBJECT();
|
1258 |
DECACHE_STACK_INFO();
|
1259 |
value2Ptr = TclSetElementOfIndexedArray(interp, opnd,
|
1260 |
elemPtr, valuePtr, TCL_LEAVE_ERR_MSG);
|
1261 |
CACHE_STACK_INFO();
|
1262 |
if (value2Ptr == NULL) {
|
1263 |
TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ",
|
1264 |
opnd, O2S(elemPtr), O2S(valuePtr)),
|
1265 |
Tcl_GetObjResult(interp));
|
1266 |
Tcl_DecrRefCount(elemPtr);
|
1267 |
Tcl_DecrRefCount(valuePtr);
|
1268 |
result = TCL_ERROR;
|
1269 |
goto checkForCatch;
|
1270 |
}
|
1271 |
PUSH_OBJECT(value2Ptr);
|
1272 |
TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ",
|
1273 |
opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr);
|
1274 |
TclDecrRefCount(elemPtr);
|
1275 |
TclDecrRefCount(valuePtr);
|
1276 |
}
|
1277 |
ADJUST_PC(pcAdjustment);
|
1278 |
|
1279 |
case INST_STORE_ARRAY_STK:
|
1280 |
{
|
1281 |
Tcl_Obj *elemPtr;
|
1282 |
|
1283 |
valuePtr = POP_OBJECT();
|
1284 |
elemPtr = POP_OBJECT();
|
1285 |
objPtr = POP_OBJECT(); /* array name */
|
1286 |
DECACHE_STACK_INFO();
|
1287 |
value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr,
|
1288 |
TCL_LEAVE_ERR_MSG);
|
1289 |
CACHE_STACK_INFO();
|
1290 |
if (value2Ptr == NULL) {
|
1291 |
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
|
1292 |
O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
|
1293 |
Tcl_GetObjResult(interp));
|
1294 |
Tcl_DecrRefCount(objPtr);
|
1295 |
Tcl_DecrRefCount(elemPtr);
|
1296 |
Tcl_DecrRefCount(valuePtr);
|
1297 |
result = TCL_ERROR;
|
1298 |
goto checkForCatch;
|
1299 |
}
|
1300 |
PUSH_OBJECT(value2Ptr);
|
1301 |
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
|
1302 |
O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
|
1303 |
value2Ptr);
|
1304 |
TclDecrRefCount(objPtr);
|
1305 |
TclDecrRefCount(elemPtr);
|
1306 |
TclDecrRefCount(valuePtr);
|
1307 |
}
|
1308 |
ADJUST_PC(1);
|
1309 |
|
1310 |
case INST_STORE_STK:
|
1311 |
valuePtr = POP_OBJECT();
|
1312 |
objPtr = POP_OBJECT(); /* variable name */
|
1313 |
DECACHE_STACK_INFO();
|
1314 |
value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
|
1315 |
TCL_LEAVE_ERR_MSG);
|
1316 |
CACHE_STACK_INFO();
|
1317 |
if (value2Ptr == NULL) {
|
1318 |
TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ",
|
1319 |
O2S(objPtr), O2S(valuePtr)),
|
1320 |
Tcl_GetObjResult(interp));
|
1321 |
Tcl_DecrRefCount(objPtr);
|
1322 |
Tcl_DecrRefCount(valuePtr);
|
1323 |
result = TCL_ERROR;
|
1324 |
goto checkForCatch;
|
1325 |
}
|
1326 |
PUSH_OBJECT(value2Ptr);
|
1327 |
TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ",
|
1328 |
O2S(objPtr), O2S(valuePtr)), value2Ptr);
|
1329 |
TclDecrRefCount(objPtr);
|
1330 |
TclDecrRefCount(valuePtr);
|
1331 |
ADJUST_PC(1);
|
1332 |
|
1333 |
case INST_INCR_SCALAR1:
|
1334 |
opnd = TclGetUInt1AtPtr(pc+1);
|
1335 |
valuePtr = POP_OBJECT();
|
1336 |
if (valuePtr->typePtr != &tclIntType) {
|
1337 |
result = tclIntType.setFromAnyProc(interp, valuePtr);
|
1338 |
if (result != TCL_OK) {
|
1339 |
TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
|
1340 |
opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
|
1341 |
Tcl_DecrRefCount(valuePtr);
|
1342 |
goto checkForCatch;
|
1343 |
}
|
1344 |
}
|
1345 |
i = valuePtr->internalRep.longValue;
|
1346 |
DECACHE_STACK_INFO();
|
1347 |
value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
|
1348 |
CACHE_STACK_INFO();
|
1349 |
if (value2Ptr == NULL) {
|
1350 |
TRACE_WITH_OBJ(("%u (by %ld) => ERROR: ", opnd, i),
|
1351 |
Tcl_GetObjResult(interp));
|
1352 |
Tcl_DecrRefCount(valuePtr);
|
1353 |
result = TCL_ERROR;
|
1354 |
goto checkForCatch;
|
1355 |
}
|
1356 |
PUSH_OBJECT(value2Ptr);
|
1357 |
TRACE_WITH_OBJ(("%u (by %ld) => ", opnd, i), value2Ptr);
|
1358 |
TclDecrRefCount(valuePtr);
|
1359 |
ADJUST_PC(2);
|
1360 |
|
1361 |
case INST_INCR_SCALAR_STK:
|
1362 |
case INST_INCR_STK:
|
1363 |
valuePtr = POP_OBJECT();
|
1364 |
objPtr = POP_OBJECT(); /* scalar name */
|
1365 |
if (valuePtr->typePtr != &tclIntType) {
|
1366 |
result = tclIntType.setFromAnyProc(interp, valuePtr);
|
1367 |
if (result != TCL_OK) {
|
1368 |
TRACE_WITH_OBJ(("\"%.30s\" (by %s) => ERROR converting increment amount to int: ",
|
1369 |
O2S(objPtr), O2S(valuePtr)),
|
1370 |
Tcl_GetObjResult(interp));
|
1371 |
Tcl_DecrRefCount(objPtr);
|
1372 |
Tcl_DecrRefCount(valuePtr);
|
1373 |
goto checkForCatch;
|
1374 |
}
|
1375 |
}
|
1376 |
i = valuePtr->internalRep.longValue;
|
1377 |
DECACHE_STACK_INFO();
|
1378 |
value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i,
|
1379 |
TCL_LEAVE_ERR_MSG);
|
1380 |
CACHE_STACK_INFO();
|
1381 |
if (value2Ptr == NULL) {
|
1382 |
TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ERROR: ",
|
1383 |
O2S(objPtr), i), Tcl_GetObjResult(interp));
|
1384 |
Tcl_DecrRefCount(objPtr);
|
1385 |
Tcl_DecrRefCount(valuePtr);
|
1386 |
result = TCL_ERROR;
|
1387 |
goto checkForCatch;
|
1388 |
}
|
1389 |
PUSH_OBJECT(value2Ptr);
|
1390 |
TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ", O2S(objPtr), i),
|
1391 |
value2Ptr);
|
1392 |
Tcl_DecrRefCount(objPtr);
|
1393 |
Tcl_DecrRefCount(valuePtr);
|
1394 |
ADJUST_PC(1);
|
1395 |
|
1396 |
case INST_INCR_ARRAY1:
|
1397 |
{
|
1398 |
Tcl_Obj *elemPtr;
|
1399 |
|
1400 |
opnd = TclGetUInt1AtPtr(pc+1);
|
1401 |
valuePtr = POP_OBJECT();
|
1402 |
elemPtr = POP_OBJECT();
|
1403 |
if (valuePtr->typePtr != &tclIntType) {
|
1404 |
result = tclIntType.setFromAnyProc(interp, valuePtr);
|
1405 |
if (result != TCL_OK) {
|
1406 |
TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
|
1407 |
opnd, O2S(elemPtr), O2S(valuePtr)),
|
1408 |
Tcl_GetObjResult(interp));
|
1409 |
Tcl_DecrRefCount(elemPtr);
|
1410 |
Tcl_DecrRefCount(valuePtr);
|
1411 |
goto checkForCatch;
|
1412 |
}
|
1413 |
}
|
1414 |
i = valuePtr->internalRep.longValue;
|
1415 |
DECACHE_STACK_INFO();
|
1416 |
value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
|
1417 |
elemPtr, i);
|
1418 |
CACHE_STACK_INFO();
|
1419 |
if (value2Ptr == NULL) {
|
1420 |
TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
|
1421 |
opnd, O2S(elemPtr), i),
|
1422 |
Tcl_GetObjResult(interp));
|
1423 |
Tcl_DecrRefCount(elemPtr);
|
1424 |
Tcl_DecrRefCount(valuePtr);
|
1425 |
result = TCL_ERROR;
|
1426 |
goto checkForCatch;
|
1427 |
}
|
1428 |
PUSH_OBJECT(value2Ptr);
|
1429 |
TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
|
1430 |
opnd, O2S(elemPtr), i), value2Ptr);
|
1431 |
Tcl_DecrRefCount(elemPtr);
|
1432 |
Tcl_DecrRefCount(valuePtr);
|
1433 |
}
|
1434 |
ADJUST_PC(2);
|
1435 |
|
1436 |
case INST_INCR_ARRAY_STK:
|
1437 |
{
|
1438 |
Tcl_Obj *elemPtr;
|
1439 |
|
1440 |
valuePtr = POP_OBJECT();
|
1441 |
elemPtr = POP_OBJECT();
|
1442 |
objPtr = POP_OBJECT(); /* array name */
|
1443 |
if (valuePtr->typePtr != &tclIntType) {
|
1444 |
result = tclIntType.setFromAnyProc(interp, valuePtr);
|
1445 |
if (result != TCL_OK) {
|
1446 |
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ",
|
1447 |
O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
|
1448 |
Tcl_GetObjResult(interp));
|
1449 |
Tcl_DecrRefCount(objPtr);
|
1450 |
Tcl_DecrRefCount(elemPtr);
|
1451 |
Tcl_DecrRefCount(valuePtr);
|
1452 |
goto checkForCatch;
|
1453 |
}
|
1454 |
}
|
1455 |
i = valuePtr->internalRep.longValue;
|
1456 |
DECACHE_STACK_INFO();
|
1457 |
value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
|
1458 |
TCL_LEAVE_ERR_MSG);
|
1459 |
CACHE_STACK_INFO();
|
1460 |
if (value2Ptr == NULL) {
|
1461 |
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
|
1462 |
O2S(objPtr), O2S(elemPtr), i),
|
1463 |
Tcl_GetObjResult(interp));
|
1464 |
Tcl_DecrRefCount(objPtr);
|
1465 |
Tcl_DecrRefCount(elemPtr);
|
1466 |
Tcl_DecrRefCount(valuePtr);
|
1467 |
result = TCL_ERROR;
|
1468 |
goto checkForCatch;
|
1469 |
}
|
1470 |
PUSH_OBJECT(value2Ptr);
|
1471 |
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
|
1472 |
O2S(objPtr), O2S(elemPtr), i), value2Ptr);
|
1473 |
Tcl_DecrRefCount(objPtr);
|
1474 |
Tcl_DecrRefCount(elemPtr);
|
1475 |
Tcl_DecrRefCount(valuePtr);
|
1476 |
}
|
1477 |
ADJUST_PC(1);
|
1478 |
|
1479 |
case INST_INCR_SCALAR1_IMM:
|
1480 |
opnd = TclGetUInt1AtPtr(pc+1);
|
1481 |
i = TclGetInt1AtPtr(pc+2);
|
1482 |
DECACHE_STACK_INFO();
|
1483 |
value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
|
1484 |
CACHE_STACK_INFO();
|
1485 |
if (value2Ptr == NULL) {
|
1486 |
TRACE_WITH_OBJ(("%u %ld => ERROR: ", opnd, i),
|
1487 |
Tcl_GetObjResult(interp));
|
1488 |
result = TCL_ERROR;
|
1489 |
goto checkForCatch;
|
1490 |
}
|
1491 |
PUSH_OBJECT(value2Ptr);
|
1492 |
TRACE_WITH_OBJ(("%u %ld => ", opnd, i), value2Ptr);
|
1493 |
ADJUST_PC(3);
|
1494 |
|
1495 |
case INST_INCR_SCALAR_STK_IMM:
|
1496 |
case INST_INCR_STK_IMM:
|
1497 |
objPtr = POP_OBJECT(); /* variable name */
|
1498 |
i = TclGetInt1AtPtr(pc+1);
|
1499 |
DECACHE_STACK_INFO();
|
1500 |
value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i,
|
1501 |
TCL_LEAVE_ERR_MSG);
|
1502 |
CACHE_STACK_INFO();
|
1503 |
if (value2Ptr == NULL) {
|
1504 |
TRACE_WITH_OBJ(("\"%.30s\" %ld => ERROR: ",
|
1505 |
O2S(objPtr), i), Tcl_GetObjResult(interp));
|
1506 |
result = TCL_ERROR;
|
1507 |
Tcl_DecrRefCount(objPtr);
|
1508 |
goto checkForCatch;
|
1509 |
}
|
1510 |
PUSH_OBJECT(value2Ptr);
|
1511 |
TRACE_WITH_OBJ(("\"%.30s\" %ld => ", O2S(objPtr), i),
|
1512 |
value2Ptr);
|
1513 |
TclDecrRefCount(objPtr);
|
1514 |
ADJUST_PC(2);
|
1515 |
|
1516 |
case INST_INCR_ARRAY1_IMM:
|
1517 |
{
|
1518 |
Tcl_Obj *elemPtr;
|
1519 |
|
1520 |
opnd = TclGetUInt1AtPtr(pc+1);
|
1521 |
i = TclGetInt1AtPtr(pc+2);
|
1522 |
elemPtr = POP_OBJECT();
|
1523 |
DECACHE_STACK_INFO();
|
1524 |
value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
|
1525 |
elemPtr, i);
|
1526 |
CACHE_STACK_INFO();
|
1527 |
if (value2Ptr == NULL) {
|
1528 |
TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
|
1529 |
opnd, O2S(elemPtr), i),
|
1530 |
Tcl_GetObjResult(interp));
|
1531 |
Tcl_DecrRefCount(elemPtr);
|
1532 |
result = TCL_ERROR;
|
1533 |
goto checkForCatch;
|
1534 |
}
|
1535 |
PUSH_OBJECT(value2Ptr);
|
1536 |
TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
|
1537 |
opnd, O2S(elemPtr), i), value2Ptr);
|
1538 |
Tcl_DecrRefCount(elemPtr);
|
1539 |
}
|
1540 |
ADJUST_PC(3);
|
1541 |
|
1542 |
case INST_INCR_ARRAY_STK_IMM:
|
1543 |
{
|
1544 |
Tcl_Obj *elemPtr;
|
1545 |
|
1546 |
i = TclGetInt1AtPtr(pc+1);
|
1547 |
elemPtr = POP_OBJECT();
|
1548 |
objPtr = POP_OBJECT(); /* array name */
|
1549 |
DECACHE_STACK_INFO();
|
1550 |
value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
|
1551 |
TCL_LEAVE_ERR_MSG);
|
1552 |
CACHE_STACK_INFO();
|
1553 |
if (value2Ptr == NULL) {
|
1554 |
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
|
1555 |
O2S(objPtr), O2S(elemPtr), i),
|
1556 |
Tcl_GetObjResult(interp));
|
1557 |
Tcl_DecrRefCount(objPtr);
|
1558 |
Tcl_DecrRefCount(elemPtr);
|
1559 |
result = TCL_ERROR;
|
1560 |
goto checkForCatch;
|
1561 |
}
|
1562 |
PUSH_OBJECT(value2Ptr);
|
1563 |
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
|
1564 |
O2S(objPtr), O2S(elemPtr), i), value2Ptr);
|
1565 |
Tcl_DecrRefCount(objPtr);
|
1566 |
Tcl_DecrRefCount(elemPtr);
|
1567 |
}
|
1568 |
ADJUST_PC(2);
|
1569 |
|
1570 |
case INST_JUMP1:
|
1571 |
#ifdef TCL_COMPILE_DEBUG
|
1572 |
opnd = TclGetInt1AtPtr(pc+1);
|
1573 |
TRACE(("%d => new pc %u\n", opnd,
|
1574 |
(unsigned int)(pc + opnd - codePtr->codeStart)));
|
1575 |
pc += opnd;
|
1576 |
#else
|
1577 |
pc += TclGetInt1AtPtr(pc+1);
|
1578 |
#endif /* TCL_COMPILE_DEBUG */
|
1579 |
continue;
|
1580 |
|
1581 |
case INST_JUMP4:
|
1582 |
opnd = TclGetInt4AtPtr(pc+1);
|
1583 |
TRACE(("%d => new pc %u\n", opnd,
|
1584 |
(unsigned int)(pc + opnd - codePtr->codeStart)));
|
1585 |
ADJUST_PC(opnd);
|
1586 |
|
1587 |
case INST_JUMP_TRUE4:
|
1588 |
opnd = TclGetInt4AtPtr(pc+1);
|
1589 |
pcAdjustment = 5;
|
1590 |
goto doJumpTrue;
|
1591 |
|
1592 |
case INST_JUMP_TRUE1:
|
1593 |
opnd = TclGetInt1AtPtr(pc+1);
|
1594 |
pcAdjustment = 2;
|
1595 |
|
1596 |
doJumpTrue:
|
1597 |
{
|
1598 |
int b;
|
1599 |
|
1600 |
valuePtr = POP_OBJECT();
|
1601 |
if (valuePtr->typePtr == &tclIntType) {
|
1602 |
b = (valuePtr->internalRep.longValue != 0);
|
1603 |
} else if (valuePtr->typePtr == &tclDoubleType) {
|
1604 |
b = (valuePtr->internalRep.doubleValue != 0.0);
|
1605 |
} else {
|
1606 |
result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
|
1607 |
if (result != TCL_OK) {
|
1608 |
TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
|
1609 |
Tcl_GetObjResult(interp));
|
1610 |
Tcl_DecrRefCount(valuePtr);
|
1611 |
goto checkForCatch;
|
1612 |
}
|
1613 |
}
|
1614 |
if (b) {
|
1615 |
TRACE(("%d => %.20s true, new pc %u\n",
|
1616 |
opnd, O2S(valuePtr),
|
1617 |
(unsigned int)(pc+opnd - codePtr->codeStart)));
|
1618 |
TclDecrRefCount(valuePtr);
|
1619 |
ADJUST_PC(opnd);
|
1620 |
} else {
|
1621 |
TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr)));
|
1622 |
TclDecrRefCount(valuePtr);
|
1623 |
ADJUST_PC(pcAdjustment);
|
1624 |
}
|
1625 |
}
|
1626 |
|
1627 |
case INST_JUMP_FALSE4:
|
1628 |
opnd = TclGetInt4AtPtr(pc+1);
|
1629 |
pcAdjustment = 5;
|
1630 |
goto doJumpFalse;
|
1631 |
|
1632 |
case INST_JUMP_FALSE1:
|
1633 |
opnd = TclGetInt1AtPtr(pc+1);
|
1634 |
pcAdjustment = 2;
|
1635 |
|
1636 |
doJumpFalse:
|
1637 |
{
|
1638 |
int b;
|
1639 |
|
1640 |
valuePtr = POP_OBJECT();
|
1641 |
if (valuePtr->typePtr == &tclIntType) {
|
1642 |
b = (valuePtr->internalRep.longValue != 0);
|
1643 |
} else if (valuePtr->typePtr == &tclDoubleType) {
|
1644 |
b = (valuePtr->internalRep.doubleValue != 0.0);
|
1645 |
} else {
|
1646 |
result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
|
1647 |
if (result != TCL_OK) {
|
1648 |
TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
|
1649 |
Tcl_GetObjResult(interp));
|
1650 |
Tcl_DecrRefCount(valuePtr);
|
1651 |
goto checkForCatch;
|
1652 |
}
|
1653 |
}
|
1654 |
if (b) {
|
1655 |
TRACE(("%d => %.20s true\n", opnd, O2S(valuePtr)));
|
1656 |
TclDecrRefCount(valuePtr);
|
1657 |
ADJUST_PC(pcAdjustment);
|
1658 |
} else {
|
1659 |
TRACE(("%d => %.20s false, new pc %u\n",
|
1660 |
opnd, O2S(valuePtr),
|
1661 |
(unsigned int)(pc + opnd - codePtr->codeStart)));
|
1662 |
TclDecrRefCount(valuePtr);
|
1663 |
ADJUST_PC(opnd);
|
1664 |
}
|
1665 |
}
|
1666 |
|
1667 |
case INST_LOR:
|
1668 |
case INST_LAND:
|
1669 |
{
|
1670 |
/*
|
1671 |
* Operands must be boolean or numeric. No int->double
|
1672 |
* conversions are performed.
|
1673 |
*/
|
1674 |
|
1675 |
int i1, i2;
|
1676 |
int iResult;
|
1677 |
char *s;
|
1678 |
Tcl_ObjType *t1Ptr, *t2Ptr;
|
1679 |
|
1680 |
value2Ptr = POP_OBJECT();
|
1681 |
valuePtr = POP_OBJECT();
|
1682 |
t1Ptr = valuePtr->typePtr;
|
1683 |
t2Ptr = value2Ptr->typePtr;
|
1684 |
|
1685 |
if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
|
1686 |
i1 = (valuePtr->internalRep.longValue != 0);
|
1687 |
} else if (t1Ptr == &tclDoubleType) {
|
1688 |
i1 = (valuePtr->internalRep.doubleValue != 0.0);
|
1689 |
} else {
|
1690 |
s = Tcl_GetStringFromObj(valuePtr, &length);
|
1691 |
if (TclLooksLikeInt(s, length)) {
|
1692 |
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
|
1693 |
valuePtr, &i);
|
1694 |
i1 = (i != 0);
|
1695 |
} else {
|
1696 |
result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
|
1697 |
valuePtr, &i1);
|
1698 |
i1 = (i1 != 0);
|
1699 |
}
|
1700 |
if (result != TCL_OK) {
|
1701 |
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
|
1702 |
O2S(valuePtr),
|
1703 |
(t1Ptr? t1Ptr->name : "null")));
|
1704 |
IllegalExprOperandType(interp, pc, valuePtr);
|
1705 |
Tcl_DecrRefCount(valuePtr);
|
1706 |
Tcl_DecrRefCount(value2Ptr);
|
1707 |
goto checkForCatch;
|
1708 |
}
|
1709 |
}
|
1710 |
|
1711 |
if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
|
1712 |
i2 = (value2Ptr->internalRep.longValue != 0);
|
1713 |
} else if (t2Ptr == &tclDoubleType) {
|
1714 |
i2 = (value2Ptr->internalRep.doubleValue != 0.0);
|
1715 |
} else {
|
1716 |
s = Tcl_GetStringFromObj(value2Ptr, &length);
|
1717 |
if (TclLooksLikeInt(s, length)) {
|
1718 |
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
|
1719 |
value2Ptr, &i);
|
1720 |
i2 = (i != 0);
|
1721 |
} else {
|
1722 |
result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
|
1723 |
value2Ptr, &i2);
|
1724 |
}
|
1725 |
if (result != TCL_OK) {
|
1726 |
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
|
1727 |
O2S(value2Ptr),
|
1728 |
(t2Ptr? t2Ptr->name : "null")));
|
1729 |
IllegalExprOperandType(interp, pc, value2Ptr);
|
1730 |
Tcl_DecrRefCount(valuePtr);
|
1731 |
Tcl_DecrRefCount(value2Ptr);
|
1732 |
goto checkForCatch;
|
1733 |
}
|
1734 |
}
|
1735 |
|
1736 |
/*
|
1737 |
* Reuse the valuePtr object already on stack if possible.
|
1738 |
*/
|
1739 |
|
1740 |
if (*pc == INST_LOR) {
|
1741 |
iResult = (i1 || i2);
|
1742 |
} else {
|
1743 |
iResult = (i1 && i2);
|
1744 |
}
|
1745 |
if (Tcl_IsShared(valuePtr)) {
|
1746 |
PUSH_OBJECT(Tcl_NewLongObj(iResult));
|
1747 |
TRACE(("%.20s %.20s => %d\n",
|
1748 |
O2S(valuePtr), O2S(value2Ptr), iResult));
|
1749 |
TclDecrRefCount(valuePtr);
|
1750 |
} else { /* reuse the valuePtr object */
|
1751 |
TRACE(("%.20s %.20s => %d\n",
|
1752 |
O2S(valuePtr), O2S(value2Ptr), iResult));
|
1753 |
Tcl_SetLongObj(valuePtr, iResult);
|
1754 |
++stackTop; /* valuePtr now on stk top has right r.c. */
|
1755 |
}
|
1756 |
TclDecrRefCount(value2Ptr);
|
1757 |
}
|
1758 |
ADJUST_PC(1);
|
1759 |
|
1760 |
case INST_EQ:
|
1761 |
case INST_NEQ:
|
1762 |
case INST_LT:
|
1763 |
case INST_GT:
|
1764 |
case INST_LE:
|
1765 |
case INST_GE:
|
1766 |
{
|
1767 |
/*
|
1768 |
* Any type is allowed but the two operands must have the
|
1769 |
* same type. We will compute value op value2.
|
1770 |
*/
|
1771 |
|
1772 |
Tcl_ObjType *t1Ptr, *t2Ptr;
|
1773 |
char *s1 = NULL; /* Init. avoids compiler warning. */
|
1774 |
char *s2 = NULL; /* Init. avoids compiler warning. */
|
1775 |
long i2 = 0; /* Init. avoids compiler warning. */
|
1776 |
double d1 = 0.0; /* Init. avoids compiler warning. */
|
1777 |
double d2 = 0.0; /* Init. avoids compiler warning. */
|
1778 |
long iResult = 0; /* Init. avoids compiler warning. */
|
1779 |
|
1780 |
value2Ptr = POP_OBJECT();
|
1781 |
valuePtr = POP_OBJECT();
|
1782 |
t1Ptr = valuePtr->typePtr;
|
1783 |
t2Ptr = value2Ptr->typePtr;
|
1784 |
|
1785 |
/*
|
1786 |
* We only want to coerce numeric validation if
|
1787 |
* neither type is NULL. A NULL type means the arg is
|
1788 |
* essentially an empty object ("", {} or [list]).
|
1789 |
*/
|
1790 |
if (!((((t1Ptr == NULL) && (valuePtr->bytes == NULL))
|
1791 |
|| (valuePtr->bytes && (valuePtr->length == 0)))
|
1792 |
|| (((t2Ptr == NULL) && (value2Ptr->bytes == NULL))
|
1793 |
|| (value2Ptr->bytes && (value2Ptr->length == 0))))) {
|
1794 |
if ((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) {
|
1795 |
s1 = Tcl_GetStringFromObj(valuePtr, &length);
|
1796 |
if (TclLooksLikeInt(s1, length)) {
|
1797 |
(void) Tcl_GetLongFromObj((Tcl_Interp *) NULL,
|
1798 |
valuePtr, &i);
|
1799 |
} else {
|
1800 |
(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
|
1801 |
valuePtr, &d1);
|
1802 |
}
|
1803 |
t1Ptr = valuePtr->typePtr;
|
1804 |
}
|
1805 |
if ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType)) {
|
1806 |
s2 = Tcl_GetStringFromObj(value2Ptr, &length);
|
1807 |
if (TclLooksLikeInt(s2, length)) {
|
1808 |
(void) Tcl_GetLongFromObj((Tcl_Interp *) NULL,
|
1809 |
value2Ptr, &i2);
|
1810 |
} else {
|
1811 |
(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
|
1812 |
value2Ptr, &d2);
|
1813 |
}
|
1814 |
t2Ptr = value2Ptr->typePtr;
|
1815 |
}
|
1816 |
}
|
1817 |
if (((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType))
|
1818 |
|| ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType))) {
|
1819 |
/*
|
1820 |
* One operand is not numeric. Compare as strings.
|
1821 |
*/
|
1822 |
int cmpValue;
|
1823 |
s1 = Tcl_GetString(valuePtr);
|
1824 |
s2 = Tcl_GetString(value2Ptr);
|
1825 |
cmpValue = strcmp(s1, s2);
|
1826 |
switch (*pc) {
|
1827 |
case INST_EQ:
|
1828 |
iResult = (cmpValue == 0);
|
1829 |
break;
|
1830 |
case INST_NEQ:
|
1831 |
iResult = (cmpValue != 0);
|
1832 |
break;
|
1833 |
case INST_LT:
|
1834 |
iResult = (cmpValue < 0);
|
1835 |
break;
|
1836 |
case INST_GT:
|
1837 |
iResult = (cmpValue > 0);
|
1838 |
break;
|
1839 |
case INST_LE:
|
1840 |
iResult = (cmpValue <= 0);
|
1841 |
break;
|
1842 |
case INST_GE:
|
1843 |
iResult = (cmpValue >= 0);
|
1844 |
break;
|
1845 |
}
|
1846 |
} else if ((t1Ptr == &tclDoubleType)
|
1847 |
|| (t2Ptr == &tclDoubleType)) {
|
1848 |
/*
|
1849 |
* Compare as doubles.
|
1850 |
*/
|
1851 |
if (t1Ptr == &tclDoubleType) {
|
1852 |
d1 = valuePtr->internalRep.doubleValue;
|
1853 |
if (t2Ptr == &tclIntType) {
|
1854 |
d2 = value2Ptr->internalRep.longValue;
|
1855 |
} else {
|
1856 |
d2 = value2Ptr->internalRep.doubleValue;
|
1857 |
}
|
1858 |
} else { /* t1Ptr is int, t2Ptr is double */
|
1859 |
d1 = valuePtr->internalRep.longValue;
|
1860 |
d2 = value2Ptr->internalRep.doubleValue;
|
1861 |
}
|
1862 |
switch (*pc) {
|
1863 |
case INST_EQ:
|
1864 |
iResult = d1 == d2;
|
1865 |
break;
|
1866 |
case INST_NEQ:
|
1867 |
iResult = d1 != d2;
|
1868 |
break;
|
1869 |
case INST_LT:
|
1870 |
iResult = d1 < d2;
|
1871 |
break;
|
1872 |
case INST_GT:
|
1873 |
iResult = d1 > d2;
|
1874 |
break;
|
1875 |
case INST_LE:
|
1876 |
iResult = d1 <= d2;
|
1877 |
break;
|
1878 |
case INST_GE:
|
1879 |
iResult = d1 >= d2;
|
1880 |
break;
|
1881 |
}
|
1882 |
} else {
|
1883 |
/*
|
1884 |
* Compare as ints.
|
1885 |
*/
|
1886 |
i = valuePtr->internalRep.longValue;
|
1887 |
i2 = value2Ptr->internalRep.longValue;
|
1888 |
switch (*pc) {
|
1889 |
case INST_EQ:
|
1890 |
iResult = i == i2;
|
1891 |
break;
|
1892 |
case INST_NEQ:
|
1893 |
iResult = i != i2;
|
1894 |
break;
|
1895 |
case INST_LT:
|
1896 |
iResult = i < i2;
|
1897 |
break;
|
1898 |
case INST_GT:
|
1899 |
iResult = i > i2;
|
1900 |
break;
|
1901 |
case INST_LE:
|
1902 |
iResult = i <= i2;
|
1903 |
break;
|
1904 |
case INST_GE:
|
1905 |
iResult = i >= i2;
|
1906 |
break;
|
1907 |
}
|
1908 |
}
|
1909 |
|
1910 |
/*
|
1911 |
* Reuse the valuePtr object already on stack if possible.
|
1912 |
*/
|
1913 |
|
1914 |
if (Tcl_IsShared(valuePtr)) {
|
1915 |
PUSH_OBJECT(Tcl_NewLongObj(iResult));
|
1916 |
TRACE(("%.20s %.20s => %ld\n",
|
1917 |
O2S(valuePtr), O2S(value2Ptr), iResult));
|
1918 |
TclDecrRefCount(valuePtr);
|
1919 |
} else { /* reuse the valuePtr object */
|
1920 |
TRACE(("%.20s %.20s => %ld\n",
|
1921 |
O2S(valuePtr), O2S(value2Ptr), iResult));
|
1922 |
Tcl_SetLongObj(valuePtr, iResult);
|
1923 |
++stackTop; /* valuePtr now on stk top has right r.c. */
|
1924 |
}
|
1925 |
TclDecrRefCount(value2Ptr);
|
1926 |
}
|
1927 |
ADJUST_PC(1);
|
1928 |
|
1929 |
case INST_MOD:
|
1930 |
case INST_LSHIFT:
|
1931 |
case INST_RSHIFT:
|
1932 |
case INST_BITOR:
|
1933 |
case INST_BITXOR:
|
1934 |
case INST_BITAND:
|
1935 |
{
|
1936 |
/*
|
1937 |
* Only integers are allowed. We compute value op value2.
|
1938 |
*/
|
1939 |
|
1940 |
long i2, rem, negative;
|
1941 |
long iResult = 0; /* Init. avoids compiler warning. */
|
1942 |
|
1943 |
value2Ptr = POP_OBJECT();
|
1944 |
valuePtr = POP_OBJECT();
|
1945 |
if (valuePtr->typePtr == &tclIntType) {
|
1946 |
i = valuePtr->internalRep.longValue;
|
1947 |
} else { /* try to convert to int */
|
1948 |
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
|
1949 |
valuePtr, &i);
|
1950 |
if (result != TCL_OK) {
|
1951 |
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
|
1952 |
O2S(valuePtr), O2S(value2Ptr),
|
1953 |
(valuePtr->typePtr?
|
1954 |
valuePtr->typePtr->name : "null")));
|
1955 |
IllegalExprOperandType(interp, pc, valuePtr);
|
1956 |
Tcl_DecrRefCount(valuePtr);
|
1957 |
Tcl_DecrRefCount(value2Ptr);
|
1958 |
goto checkForCatch;
|
1959 |
}
|
1960 |
}
|
1961 |
if (value2Ptr->typePtr == &tclIntType) {
|
1962 |
i2 = value2Ptr->internalRep.longValue;
|
1963 |
} else {
|
1964 |
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
|
1965 |
value2Ptr, &i2);
|
1966 |
if (result != TCL_OK) {
|
1967 |
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
|
1968 |
O2S(valuePtr), O2S(value2Ptr),
|
1969 |
(value2Ptr->typePtr?
|
1970 |
value2Ptr->typePtr->name : "null")));
|
1971 |
IllegalExprOperandType(interp, pc, value2Ptr);
|
1972 |
Tcl_DecrRefCount(valuePtr);
|
1973 |
Tcl_DecrRefCount(value2Ptr);
|
1974 |
goto checkForCatch;
|
1975 |
}
|
1976 |
}
|
1977 |
|
1978 |
switch (*pc) {
|
1979 |
case INST_MOD:
|
1980 |
/*
|
1981 |
* This code is tricky: C doesn't guarantee much about
|
1982 |
* the quotient or remainder, but Tcl does. The
|
1983 |
* remainder always has the same sign as the divisor and
|
1984 |
* a smaller absolute value.
|
1985 |
*/
|
1986 |
if (i2 == 0) {
|
1987 |
TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
|
1988 |
Tcl_DecrRefCount(valuePtr);
|
1989 |
Tcl_DecrRefCount(value2Ptr);
|
1990 |
goto divideByZero;
|
1991 |
}
|
1992 |
negative = 0;
|
1993 |
if (i2 < 0) {
|
1994 |
i2 = -i2;
|
1995 |
i = -i;
|
1996 |
negative = 1;
|
1997 |
}
|
1998 |
rem = i % i2;
|
1999 |
if (rem < 0) {
|
2000 |
rem += i2;
|
2001 |
}
|
2002 |
if (negative) {
|
2003 |
rem = -rem;
|
2004 |
}
|
2005 |
iResult = rem;
|
2006 |
break;
|
2007 |
case INST_LSHIFT:
|
2008 |
iResult = i << i2;
|
2009 |
break;
|
2010 |
case INST_RSHIFT:
|
2011 |
/*
|
2012 |
* The following code is a bit tricky: it ensures that
|
2013 |
* right shifts propagate the sign bit even on machines
|
2014 |
* where ">>" won't do it by default.
|
2015 |
*/
|
2016 |
if (i < 0) {
|
2017 |
iResult = ~((~i) >> i2);
|
2018 |
} else {
|
2019 |
iResult = i >> i2;
|
2020 |
}
|
2021 |
break;
|
2022 |
case INST_BITOR:
|
2023 |
iResult = i | i2;
|
2024 |
break;
|
2025 |
case INST_BITXOR:
|
2026 |
iResult = i ^ i2;
|
2027 |
break;
|
2028 |
case INST_BITAND:
|
2029 |
iResult = i & i2;
|
2030 |
break;
|
2031 |
}
|
2032 |
|
2033 |
/*
|
2034 |
* Reuse the valuePtr object already on stack if possible.
|
2035 |
*/
|
2036 |
|
2037 |
if (Tcl_IsShared(valuePtr)) {
|
2038 |
PUSH_OBJECT(Tcl_NewLongObj(iResult));
|
2039 |
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
|
2040 |
TclDecrRefCount(valuePtr);
|
2041 |
} else { /* reuse the valuePtr object */
|
2042 |
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
|
2043 |
Tcl_SetLongObj(valuePtr, iResult);
|
2044 |
++stackTop; /* valuePtr now on stk top has right r.c. */
|
2045 |
}
|
2046 |
TclDecrRefCount(value2Ptr);
|
2047 |
}
|
2048 |
ADJUST_PC(1);
|
2049 |
|
2050 |
case INST_ADD:
|
2051 |
case INST_SUB:
|
2052 |
case INST_MULT:
|
2053 |
case INST_DIV:
|
2054 |
{
|
2055 |
/*
|
2056 |
* Operands must be numeric and ints get converted to floats
|
2057 |
* if necessary. We compute value op value2.
|
2058 |
*/
|
2059 |
|
2060 |
Tcl_ObjType *t1Ptr, *t2Ptr;
|
2061 |
long i2, quot, rem;
|
2062 |
double d1, d2;
|
2063 |
long iResult = 0; /* Init. avoids compiler warning. */
|
2064 |
double dResult = 0.0; /* Init. avoids compiler warning. */
|
2065 |
int doDouble = 0; /* 1 if doing floating arithmetic */
|
2066 |
|
2067 |
value2Ptr = POP_OBJECT();
|
2068 |
valuePtr = POP_OBJECT();
|
2069 |
t1Ptr = valuePtr->typePtr;
|
2070 |
t2Ptr = value2Ptr->typePtr;
|
2071 |
|
2072 |
if (t1Ptr == &tclIntType) {
|
2073 |
i = valuePtr->internalRep.longValue;
|
2074 |
} else if ((t1Ptr == &tclDoubleType)
|
2075 |
&& (valuePtr->bytes == NULL)) {
|
2076 |
/*
|
2077 |
* We can only use the internal rep directly if there is
|
2078 |
* no string rep. Otherwise the string rep might actually
|
2079 |
* look like an integer, which is preferred.
|
2080 |
*/
|
2081 |
|
2082 |
d1 = valuePtr->internalRep.doubleValue;
|
2083 |
} else {
|
2084 |
char *s = Tcl_GetStringFromObj(valuePtr, &length);
|
2085 |
if (TclLooksLikeInt(s, length)) {
|
2086 |
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
|
2087 |
valuePtr, &i);
|
2088 |
} else {
|
2089 |
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
|
2090 |
valuePtr, &d1);
|
2091 |
}
|
2092 |
if (result != TCL_OK) {
|
2093 |
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
|
2094 |
s, O2S(valuePtr),
|
2095 |
(valuePtr->typePtr?
|
2096 |
valuePtr->typePtr->name : "null")));
|
2097 |
IllegalExprOperandType(interp, pc, valuePtr);
|
2098 |
Tcl_DecrRefCount(valuePtr);
|
2099 |
Tcl_DecrRefCount(value2Ptr);
|
2100 |
goto checkForCatch;
|
2101 |
}
|
2102 |
t1Ptr = valuePtr->typePtr;
|
2103 |
}
|
2104 |
|
2105 |
if (t2Ptr == &tclIntType) {
|
2106 |
i2 = value2Ptr->internalRep.longValue;
|
2107 |
} else if ((t2Ptr == &tclDoubleType)
|
2108 |
&& (value2Ptr->bytes == NULL)) {
|
2109 |
/*
|
2110 |
* We can only use the internal rep directly if there is
|
2111 |
* no string rep. Otherwise the string rep might actually
|
2112 |
* look like an integer, which is preferred.
|
2113 |
*/
|
2114 |
|
2115 |
d2 = value2Ptr->internalRep.doubleValue;
|
2116 |
} else {
|
2117 |
char *s = Tcl_GetStringFromObj(value2Ptr, &length);
|
2118 |
if (TclLooksLikeInt(s, length)) {
|
2119 |
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
|
2120 |
value2Ptr, &i2);
|
2121 |
} else {
|
2122 |
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
|
2123 |
value2Ptr, &d2);
|
2124 |
}
|
2125 |
if (result != TCL_OK) {
|
2126 |
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
|
2127 |
O2S(value2Ptr), s,
|
2128 |
(value2Ptr->typePtr?
|
2129 |
value2Ptr->typePtr->name : "null")));
|
2130 |
IllegalExprOperandType(interp, pc, value2Ptr);
|
2131 |
Tcl_DecrRefCount(valuePtr);
|
2132 |
Tcl_DecrRefCount(value2Ptr);
|
2133 |
goto checkForCatch;
|
2134 |
}
|
2135 |
t2Ptr = value2Ptr->typePtr;
|
2136 |
}
|
2137 |
|
2138 |
if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
|
2139 |
/*
|
2140 |
* Do double arithmetic.
|
2141 |
*/
|
2142 |
doDouble = 1;
|
2143 |
if (t1Ptr == &tclIntType) {
|
2144 |
d1 = i; /* promote value 1 to double */
|
2145 |
} else if (t2Ptr == &tclIntType) {
|
2146 |
d2 = i2; /* promote value 2 to double */
|
2147 |
}
|
2148 |
switch (*pc) {
|
2149 |
case INST_ADD:
|
2150 |
dResult = d1 + d2;
|
2151 |
break;
|
2152 |
case INST_SUB:
|
2153 |
dResult = d1 - d2;
|
2154 |
break;
|
2155 |
case INST_MULT:
|
2156 |
dResult = d1 * d2;
|
2157 |
break;
|
2158 |
case INST_DIV:
|
2159 |
if (d2 == 0.0) {
|
2160 |
TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
|
2161 |
Tcl_DecrRefCount(valuePtr);
|
2162 |
Tcl_DecrRefCount(value2Ptr);
|
2163 |
goto divideByZero;
|
2164 |
}
|
2165 |
dResult = d1 / d2;
|
2166 |
break;
|
2167 |
}
|
2168 |
|
2169 |
/*
|
2170 |
* Check now for IEEE floating-point error.
|
2171 |
*/
|
2172 |
|
2173 |
if (IS_NAN(dResult) || IS_INF(dResult)) {
|
2174 |
TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
|
2175 |
O2S(valuePtr), O2S(value2Ptr)));
|
2176 |
TclExprFloatError(interp, dResult);
|
2177 |
result = TCL_ERROR;
|
2178 |
Tcl_DecrRefCount(valuePtr);
|
2179 |
Tcl_DecrRefCount(value2Ptr);
|
2180 |
goto checkForCatch;
|
2181 |
}
|
2182 |
} else {
|
2183 |
/*
|
2184 |
* Do integer arithmetic.
|
2185 |
*/
|
2186 |
switch (*pc) {
|
2187 |
case INST_ADD:
|
2188 |
iResult = i + i2;
|
2189 |
break;
|
2190 |
case INST_SUB:
|
2191 |
iResult = i - i2;
|
2192 |
break;
|
2193 |
case INST_MULT:
|
2194 |
iResult = i * i2;
|
2195 |
break;
|
2196 |
case INST_DIV:
|
2197 |
/*
|
2198 |
* This code is tricky: C doesn't guarantee much
|
2199 |
* about the quotient or remainder, but Tcl does.
|
2200 |
* The remainder always has the same sign as the
|
2201 |
* divisor and a smaller absolute value.
|
2202 |
*/
|
2203 |
if (i2 == 0) {
|
2204 |
TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
|
2205 |
Tcl_DecrRefCount(valuePtr);
|
2206 |
Tcl_DecrRefCount(value2Ptr);
|
2207 |
goto divideByZero;
|
2208 |
}
|
2209 |
if (i2 < 0) {
|
2210 |
i2 = -i2;
|
2211 |
i = -i;
|
2212 |
}
|
2213 |
quot = i / i2;
|
2214 |
rem = i % i2;
|
2215 |
if (rem < 0) {
|
2216 |
quot -= 1;
|
2217 |
}
|
2218 |
iResult = quot;
|
2219 |
break;
|
2220 |
}
|
2221 |
}
|
2222 |
|
2223 |
/*
|
2224 |
* Reuse the valuePtr object already on stack if possible.
|
2225 |
*/
|
2226 |
|
2227 |
if (Tcl_IsShared(valuePtr)) {
|
2228 |
if (doDouble) {
|
2229 |
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
|
2230 |
TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
|
2231 |
} else {
|
2232 |
PUSH_OBJECT(Tcl_NewLongObj(iResult));
|
2233 |
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
|
2234 |
}
|
2235 |
TclDecrRefCount(valuePtr);
|
2236 |
} else { /* reuse the valuePtr object */
|
2237 |
if (doDouble) { /* NB: stack top is off by 1 */
|
2238 |
TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
|
2239 |
Tcl_SetDoubleObj(valuePtr, dResult);
|
2240 |
} else {
|
2241 |
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
|
2242 |
Tcl_SetLongObj(valuePtr, iResult);
|
2243 |
}
|
2244 |
++stackTop; /* valuePtr now on stk top has right r.c. */
|
2245 |
}
|
2246 |
TclDecrRefCount(value2Ptr);
|
2247 |
}
|
2248 |
ADJUST_PC(1);
|
2249 |
|
2250 |
case INST_UPLUS:
|
2251 |
{
|
2252 |
/*
|
2253 |
* Operand must be numeric.
|
2254 |
*/
|
2255 |
|
2256 |
double d;
|
2257 |
Tcl_ObjType *tPtr;
|
2258 |
|
2259 |
valuePtr = stackPtr[stackTop];
|
2260 |
tPtr = valuePtr->typePtr;
|
2261 |
if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
|
2262 |
|| (valuePtr->bytes != NULL))) {
|
2263 |
char *s = Tcl_GetStringFromObj(valuePtr, &length);
|
2264 |
if (TclLooksLikeInt(s, length)) {
|
2265 |
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
|
2266 |
valuePtr, &i);
|
2267 |
} else {
|
2268 |
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
|
2269 |
valuePtr, &d);
|
2270 |
}
|
2271 |
if (result != TCL_OK) {
|
2272 |
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
|
2273 |
s, (tPtr? tPtr->name : "null")));
|
2274 |
IllegalExprOperandType(interp, pc, valuePtr);
|
2275 |
goto checkForCatch;
|
2276 |
}
|
2277 |
tPtr = valuePtr->typePtr;
|
2278 |
}
|
2279 |
|
2280 |
/*
|
2281 |
* Ensure that the operand's string rep is the same as the
|
2282 |
* formatted version of its internal rep. This makes sure
|
2283 |
* that "expr +000123" yields "83", not "000123". We
|
2284 |
* implement this by _discarding_ the string rep since we
|
2285 |
* know it will be regenerated, if needed later, by
|
2286 |
* formatting the internal rep's value.
|
2287 |
*/
|
2288 |
|
2289 |
if (Tcl_IsShared(valuePtr)) {
|
2290 |
if (tPtr == &tclIntType) {
|
2291 |
i = valuePtr->internalRep.longValue;
|
2292 |
objPtr = Tcl_NewLongObj(i);
|
2293 |
} else {
|
2294 |
d = valuePtr->internalRep.doubleValue;
|
2295 |
objPtr = Tcl_NewDoubleObj(d);
|
2296 |
}
|
2297 |
Tcl_IncrRefCount(objPtr);
|
2298 |
Tcl_DecrRefCount(valuePtr);
|
2299 |
valuePtr = objPtr;
|
2300 |
stackPtr[stackTop] = valuePtr;
|
2301 |
} else {
|
2302 |
Tcl_InvalidateStringRep(valuePtr);
|
2303 |
}
|
2304 |
TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);
|
2305 |
}
|
2306 |
ADJUST_PC(1);
|
2307 |
|
2308 |
case INST_UMINUS:
|
2309 |
case INST_LNOT:
|
2310 |
{
|
2311 |
/*
|
2312 |
* The operand must be numeric. If the operand object is
|
2313 |
* unshared modify it directly, otherwise create a copy to
|
2314 |
* modify: this is "copy on write". free any old string
|
2315 |
* representation since it is now invalid.
|
2316 |
*/
|
2317 |
|
2318 |
double d;
|
2319 |
Tcl_ObjType *tPtr;
|
2320 |
|
2321 |
valuePtr = POP_OBJECT();
|
2322 |
tPtr = valuePtr->typePtr;
|
2323 |
if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
|
2324 |
|| (valuePtr->bytes != NULL))) {
|
2325 |
if ((tPtr == &tclBooleanType)
|
2326 |
&& (valuePtr->bytes == NULL)) {
|
2327 |
valuePtr->typePtr = &tclIntType;
|
2328 |
} else {
|
2329 |
char *s = Tcl_GetStringFromObj(valuePtr, &length);
|
2330 |
if (TclLooksLikeInt(s, length)) {
|
2331 |
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
|
2332 |
valuePtr, &i);
|
2333 |
} else {
|
2334 |
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
|
2335 |
valuePtr, &d);
|
2336 |
}
|
2337 |
if (result != TCL_OK) {
|
2338 |
TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
|
2339 |
s, (tPtr? tPtr->name : "null")));
|
2340 |
IllegalExprOperandType(interp, pc, valuePtr);
|
2341 |
Tcl_DecrRefCount(valuePtr);
|
2342 |
goto checkForCatch;
|
2343 |
}
|
2344 |
}
|
2345 |
tPtr = valuePtr->typePtr;
|
2346 |
}
|
2347 |
|
2348 |
if (Tcl_IsShared(valuePtr)) {
|
2349 |
/*
|
2350 |
* Create a new object.
|
2351 |
*/
|
2352 |
if (tPtr == &tclIntType) {
|
2353 |
i = valuePtr->internalRep.longValue;
|
2354 |
objPtr = Tcl_NewLongObj(
|
2355 |
(*pc == INST_UMINUS)? -i : !i);
|
2356 |
TRACE_WITH_OBJ(("%ld => ", i), objPtr);
|
2357 |
} else {
|
2358 |
d = valuePtr->internalRep.doubleValue;
|
2359 |
if (*pc == INST_UMINUS) {
|
2360 |
objPtr = Tcl_NewDoubleObj(-d);
|
2361 |
} else {
|
2362 |
/*
|
2363 |
* Should be able to use "!d", but apparently
|
2364 |
* some compilers can't handle it.
|
2365 |
*/
|
2366 |
objPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
|
2367 |
}
|
2368 |
TRACE_WITH_OBJ(("%.6g => ", d), objPtr);
|
2369 |
}
|
2370 |
PUSH_OBJECT(objPtr);
|
2371 |
TclDecrRefCount(valuePtr);
|
2372 |
} else {
|
2373 |
/*
|
2374 |
* valuePtr is unshared. Modify it directly.
|
2375 |
*/
|
2376 |
if (tPtr == &tclIntType) {
|
2377 |
i = valuePtr->internalRep.longValue;
|
2378 |
Tcl_SetLongObj(valuePtr,
|
2379 |
(*pc == INST_UMINUS)? -i : !i);
|
2380 |
TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
|
2381 |
} else {
|
2382 |
d = valuePtr->internalRep.doubleValue;
|
2383 |
if (*pc == INST_UMINUS) {
|
2384 |
Tcl_SetDoubleObj(valuePtr, -d);
|
2385 |
} else {
|
2386 |
/*
|
2387 |
* Should be able to use "!d", but apparently
|
2388 |
* some compilers can't handle it.
|
2389 |
*/
|
2390 |
Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
|
2391 |
}
|
2392 |
TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
|
2393 |
}
|
2394 |
++stackTop; /* valuePtr now on stk top has right r.c. */
|
2395 |
}
|
2396 |
}
|
2397 |
ADJUST_PC(1);
|
2398 |
|
2399 |
case INST_BITNOT:
|
2400 |
{
|
2401 |
/*
|
2402 |
* The operand must be an integer. If the operand object is
|
2403 |
* unshared modify it directly, otherwise modify a copy.
|
2404 |
* Free any old string representation since it is now
|
2405 |
* invalid.
|
2406 |
*/
|
2407 |
|
2408 |
Tcl_ObjType *tPtr;
|
2409 |
|
2410 |
valuePtr = POP_OBJECT();
|
2411 |
tPtr = valuePtr->typePtr;
|
2412 |
if (tPtr != &tclIntType) {
|
2413 |
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
|
2414 |
valuePtr, &i);
|
2415 |
if (result != TCL_OK) { /* try to convert to double */
|
2416 |
TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
|
2417 |
O2S(valuePtr), (tPtr? tPtr->name : "null")));
|
2418 |
IllegalExprOperandType(interp, pc, valuePtr);
|
2419 |
Tcl_DecrRefCount(valuePtr);
|
2420 |
goto checkForCatch;
|
2421 |
}
|
2422 |
}
|
2423 |
|
2424 |
i = valuePtr->internalRep.longValue;
|
2425 |
if (Tcl_IsShared(valuePtr)) {
|
2426 |
PUSH_OBJECT(Tcl_NewLongObj(~i));
|
2427 |
TRACE(("0x%lx => (%lu)\n", i, ~i));
|
2428 |
TclDecrRefCount(valuePtr);
|
2429 |
} else {
|
2430 |
/*
|
2431 |
* valuePtr is unshared. Modify it directly.
|
2432 |
*/
|
2433 |
Tcl_SetLongObj(valuePtr, ~i);
|
2434 |
++stackTop; /* valuePtr now on stk top has right r.c. */
|
2435 |
TRACE(("0x%lx => (%lu)\n", i, ~i));
|
2436 |
}
|
2437 |
}
|
2438 |
ADJUST_PC(1);
|
2439 |
|
2440 |
case INST_CALL_BUILTIN_FUNC1:
|
2441 |
opnd = TclGetUInt1AtPtr(pc+1);
|
2442 |
{
|
2443 |
/*
|
2444 |
* Call one of the built-in Tcl math functions.
|
2445 |
*/
|
2446 |
|
2447 |
BuiltinFunc *mathFuncPtr;
|
2448 |
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
2449 |
|
2450 |
if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
|
2451 |
TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
|
2452 |
panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
|
2453 |
}
|
2454 |
mathFuncPtr = &(builtinFuncTable[opnd]);
|
2455 |
DECACHE_STACK_INFO();
|
2456 |
tsdPtr->mathInProgress++;
|
2457 |
result = (*mathFuncPtr->proc)(interp, eePtr,
|
2458 |
mathFuncPtr->clientData);
|
2459 |
tsdPtr->mathInProgress--;
|
2460 |
CACHE_STACK_INFO();
|
2461 |
if (result != TCL_OK) {
|
2462 |
goto checkForCatch;
|
2463 |
}
|
2464 |
TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]);
|
2465 |
}
|
2466 |
ADJUST_PC(2);
|
2467 |
|
2468 |
case INST_CALL_FUNC1:
|
2469 |
opnd = TclGetUInt1AtPtr(pc+1);
|
2470 |
{
|
2471 |
/*
|
2472 |
* Call a non-builtin Tcl math function previously
|
2473 |
* registered by a call to Tcl_CreateMathFunc.
|
2474 |
*/
|
2475 |
|
2476 |
int objc = opnd; /* Number of arguments. The function name
|
2477 |
* is the 0-th argument. */
|
2478 |
Tcl_Obj **objv; /* The array of arguments. The function
|
2479 |
* name is objv[0]. */
|
2480 |
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
2481 |
|
2482 |
objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */
|
2483 |
DECACHE_STACK_INFO();
|
2484 |
tsdPtr->mathInProgress++;
|
2485 |
result = ExprCallMathFunc(interp, eePtr, objc, objv);
|
2486 |
tsdPtr->mathInProgress--;
|
2487 |
CACHE_STACK_INFO();
|
2488 |
if (result != TCL_OK) {
|
2489 |
goto checkForCatch;
|
2490 |
}
|
2491 |
TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]);
|
2492 |
ADJUST_PC(2);
|
2493 |
}
|
2494 |
|
2495 |
case INST_TRY_CVT_TO_NUMERIC:
|
2496 |
{
|
2497 |
/*
|
2498 |
* Try to convert the topmost stack object to an int or
|
2499 |
* double object. This is done in order to support Tcl's
|
2500 |
* policy of interpreting operands if at all possible as
|
2501 |
* first integers, else floating-point numbers.
|
2502 |
*/
|
2503 |
|
2504 |
double d;
|
2505 |
char *s;
|
2506 |
Tcl_ObjType *tPtr;
|
2507 |
int converted, shared;
|
2508 |
|
2509 |
valuePtr = stackPtr[stackTop];
|
2510 |
tPtr = valuePtr->typePtr;
|
2511 |
converted = 0;
|
2512 |
if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
|
2513 |
|| (valuePtr->bytes != NULL))) {
|
2514 |
if ((tPtr == &tclBooleanType)
|
2515 |
&& (valuePtr->bytes == NULL)) {
|
2516 |
valuePtr->typePtr = &tclIntType;
|
2517 |
converted = 1;
|
2518 |
} else {
|
2519 |
s = Tcl_GetStringFromObj(valuePtr, &length);
|
2520 |
if (TclLooksLikeInt(s, length)) {
|
2521 |
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
|
2522 |
valuePtr, &i);
|
2523 |
} else {
|
2524 |
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
|
2525 |
valuePtr, &d);
|
2526 |
}
|
2527 |
if (result == TCL_OK) {
|
2528 |
converted = 1;
|
2529 |
}
|
2530 |
result = TCL_OK; /* reset the result variable */
|
2531 |
}
|
2532 |
tPtr = valuePtr->typePtr;
|
2533 |
}
|
2534 |
|
2535 |
/*
|
2536 |
* Ensure that the topmost stack object, if numeric, has a
|
2537 |
* string rep the same as the formatted version of its
|
2538 |
* internal rep. This is used, e.g., to make sure that "expr
|
2539 |
* {0001}" yields "1", not "0001". We implement this by
|
2540 |
* _discarding_ the string rep since we know it will be
|
2541 |
* regenerated, if needed later, by formatting the internal
|
2542 |
* rep's value. Also check if there has been an IEEE
|
2543 |
* floating point error.
|
2544 |
*/
|
2545 |
|
2546 |
if ((tPtr == &tclIntType) || (tPtr == &tclDoubleType)) {
|
2547 |
shared = 0;
|
2548 |
if (Tcl_IsShared(valuePtr)) {
|
2549 |
shared = 1;
|
2550 |
if (valuePtr->bytes != NULL) {
|
2551 |
/*
|
2552 |
* We only need to make a copy of the object
|
2553 |
* when it already had a string rep
|
2554 |
*/
|
2555 |
if (tPtr == &tclIntType) {
|
2556 |
i = valuePtr->internalRep.longValue;
|
2557 |
objPtr = Tcl_NewLongObj(i);
|
2558 |
} else {
|
2559 |
d = valuePtr->internalRep.doubleValue;
|
2560 |
objPtr = Tcl_NewDoubleObj(d);
|
2561 |
}
|
2562 |
Tcl_IncrRefCount(objPtr);
|
2563 |
TclDecrRefCount(valuePtr);
|
2564 |
valuePtr = objPtr;
|
2565 |
stackPtr[stackTop] = valuePtr;
|
2566 |
tPtr = valuePtr->typePtr;
|
2567 |
}
|
2568 |
} else {
|
2569 |
Tcl_InvalidateStringRep(valuePtr);
|
2570 |
}
|
2571 |
|
2572 |
if (tPtr == &tclDoubleType) {
|
2573 |
d = valuePtr->internalRep.doubleValue;
|
2574 |
if (IS_NAN(d) || IS_INF(d)) {
|
2575 |
TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
|
2576 |
O2S(valuePtr)));
|
2577 |
TclExprFloatError(interp, d);
|
2578 |
result = TCL_ERROR;
|
2579 |
goto checkForCatch;
|
2580 |
}
|
2581 |
}
|
2582 |
shared = shared; /* lint, shared not used. */
|
2583 |
converted = converted; /* lint, converted not used. */
|
2584 |
TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr),
|
2585 |
(converted? "converted" : "not converted"),
|
2586 |
(shared? "shared" : "not shared")));
|
2587 |
} else {
|
2588 |
TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
|
2589 |
}
|
2590 |
}
|
2591 |
ADJUST_PC(1);
|
2592 |
|
2593 |
case INST_BREAK:
|
2594 |
/*
|
2595 |
* First reset the interpreter's result. Then find the closest
|
2596 |
* enclosing loop or catch exception range, if any. If a loop is
|
2597 |
* found, terminate its execution. If the closest is a catch
|
2598 |
* exception range, jump to its catchOffset. If no enclosing
|
2599 |
* range is found, stop execution and return TCL_BREAK.
|
2600 |
*/
|
2601 |
|
2602 |
Tcl_ResetResult(interp);
|
2603 |
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
|
2604 |
if (rangePtr == NULL) {
|
2605 |
TRACE(("=> no encl. loop or catch, returning TCL_BREAK\n"));
|
2606 |
result = TCL_BREAK;
|
2607 |
goto abnormalReturn; /* no catch exists to check */
|
2608 |
}
|
2609 |
switch (rangePtr->type) {
|
2610 |
case LOOP_EXCEPTION_RANGE:
|
2611 |
result = TCL_OK;
|
2612 |
TRACE(("=> range at %d, new pc %d\n",
|
2613 |
rangePtr->codeOffset, rangePtr->breakOffset));
|
2614 |
break;
|
2615 |
case CATCH_EXCEPTION_RANGE:
|
2616 |
result = TCL_BREAK;
|
2617 |
TRACE(("=> ...\n"));
|
2618 |
goto processCatch; /* it will use rangePtr */
|
2619 |
default:
|
2620 |
panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
|
2621 |
}
|
2622 |
pc = (codePtr->codeStart + rangePtr->breakOffset);
|
2623 |
continue; /* restart outer instruction loop at pc */
|
2624 |
|
2625 |
case INST_CONTINUE:
|
2626 |
/*
|
2627 |
* Find the closest enclosing loop or catch exception range,
|
2628 |
* if any. If a loop is found, skip to its next iteration.
|
2629 |
* If the closest is a catch exception range, jump to its
|
2630 |
* catchOffset. If no enclosing range is found, stop
|
2631 |
* execution and return TCL_CONTINUE.
|
2632 |
*/
|
2633 |
|
2634 |
Tcl_ResetResult(interp);
|
2635 |
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
|
2636 |
if (rangePtr == NULL) {
|
2637 |
TRACE(("=> no encl. loop or catch, returning TCL_CONTINUE\n"));
|
2638 |
result = TCL_CONTINUE;
|
2639 |
goto abnormalReturn;
|
2640 |
}
|
2641 |
switch (rangePtr->type) {
|
2642 |
case LOOP_EXCEPTION_RANGE:
|
2643 |
if (rangePtr->continueOffset == -1) {
|
2644 |
TRACE(("=> loop w/o continue, checking for catch\n"));
|
2645 |
goto checkForCatch;
|
2646 |
} else {
|
2647 |
result = TCL_OK;
|
2648 |
TRACE(("=> range at %d, new pc %d\n",
|
2649 |
rangePtr->codeOffset, rangePtr->continueOffset));
|
2650 |
}
|
2651 |
break;
|
2652 |
case CATCH_EXCEPTION_RANGE:
|
2653 |
result = TCL_CONTINUE;
|
2654 |
TRACE(("=> ...\n"));
|
2655 |
goto processCatch; /* it will use rangePtr */
|
2656 |
default:
|
2657 |
panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
|
2658 |
}
|
2659 |
pc = (codePtr->codeStart + rangePtr->continueOffset);
|
2660 |
continue; /* restart outer instruction loop at pc */
|
2661 |
|
2662 |
case INST_FOREACH_START4:
|
2663 |
opnd = TclGetUInt4AtPtr(pc+1);
|
2664 |
{
|
2665 |
/*
|
2666 |
* Initialize the temporary local var that holds the count
|
2667 |
* of the number of iterations of the loop body to -1.
|
2668 |
*/
|
2669 |
|
2670 |
ForeachInfo *infoPtr = (ForeachInfo *)
|
2671 |
codePtr->auxDataArrayPtr[opnd].clientData;
|
2672 |
int iterTmpIndex = infoPtr->loopCtTemp;
|
2673 |
Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
|
2674 |
Var *iterVarPtr = &(compiledLocals[iterTmpIndex]);
|
2675 |
Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr;
|
2676 |
|
2677 |
if (oldValuePtr == NULL) {
|
2678 |
iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
|
2679 |
Tcl_IncrRefCount(iterVarPtr->value.objPtr);
|
2680 |
} else {
|
2681 |
Tcl_SetLongObj(oldValuePtr, -1);
|
2682 |
}
|
2683 |
TclSetVarScalar(iterVarPtr);
|
2684 |
TclClearVarUndefined(iterVarPtr);
|
2685 |
TRACE(("%u => loop iter count temp %d\n",
|
2686 |
opnd, iterTmpIndex));
|
2687 |
}
|
2688 |
ADJUST_PC(5);
|
2689 |
|
2690 |
case INST_FOREACH_STEP4:
|
2691 |
opnd = TclGetUInt4AtPtr(pc+1);
|
2692 |
{
|
2693 |
/*
|
2694 |
* "Step" a foreach loop (i.e., begin its next iteration) by
|
2695 |
* assigning the next value list element to each loop var.
|
2696 |
*/
|
2697 |
|
2698 |
ForeachInfo *infoPtr = (ForeachInfo *)
|
2699 |
codePtr->auxDataArrayPtr[opnd].clientData;
|
2700 |
ForeachVarList *varListPtr;
|
2701 |
int numLists = infoPtr->numLists;
|
2702 |
Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
|
2703 |
Tcl_Obj *listPtr;
|
2704 |
List *listRepPtr;
|
2705 |
Var *iterVarPtr, *listVarPtr;
|
2706 |
int iterNum, listTmpIndex, listLen, numVars;
|
2707 |
int varIndex, valIndex, continueLoop, j;
|
2708 |
|
2709 |
/*
|
2710 |
* Increment the temp holding the loop iteration number.
|
2711 |
*/
|
2712 |
|
2713 |
iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
|
2714 |
valuePtr = iterVarPtr->value.objPtr;
|
2715 |
iterNum = (valuePtr->internalRep.longValue + 1);
|
2716 |
Tcl_SetLongObj(valuePtr, iterNum);
|
2717 |
|
2718 |
/*
|
2719 |
* Check whether all value lists are exhausted and we should
|
2720 |
* stop the loop.
|
2721 |
*/
|
2722 |
|
2723 |
continueLoop = 0;
|
2724 |
listTmpIndex = infoPtr->firstValueTemp;
|
2725 |
for (i = 0; i < numLists; i++) {
|
2726 |
varListPtr = infoPtr->varLists[i];
|
2727 |
numVars = varListPtr->numVars;
|
2728 |
|
2729 |
listVarPtr = &(compiledLocals[listTmpIndex]);
|
2730 |
listPtr = listVarPtr->value.objPtr;
|
2731 |
result = Tcl_ListObjLength(interp, listPtr, &listLen);
|
2732 |
if (result != TCL_OK) {
|
2733 |
TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
|
2734 |
opnd, i, O2S(listPtr)),
|
2735 |
Tcl_GetObjResult(interp));
|
2736 |
goto checkForCatch;
|
2737 |
}
|
2738 |
if (listLen > (iterNum * numVars)) {
|
2739 |
continueLoop = 1;
|
2740 |
}
|
2741 |
listTmpIndex++;
|
2742 |
}
|
2743 |
|
2744 |
/*
|
2745 |
* If some var in some var list still has a remaining list
|
2746 |
* element iterate one more time. Assign to var the next
|
2747 |
* element from its value list. We already checked above
|
2748 |
* that each list temp holds a valid list object.
|
2749 |
*/
|
2750 |
|
2751 |
if (continueLoop) {
|
2752 |
listTmpIndex = infoPtr->firstValueTemp;
|
2753 |
for (i = 0; i < numLists; i++) {
|
2754 |
varListPtr = infoPtr->varLists[i];
|
2755 |
numVars = varListPtr->numVars;
|
2756 |
|
2757 |
listVarPtr = &(compiledLocals[listTmpIndex]);
|
2758 |
listPtr = listVarPtr->value.objPtr;
|
2759 |
listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
|
2760 |
listLen = listRepPtr->elemCount;
|
2761 |
|
2762 |
valIndex = (iterNum * numVars);
|
2763 |
for (j = 0; j < numVars; j++) {
|
2764 |
int setEmptyStr = 0;
|
2765 |
if (valIndex >= listLen) {
|
2766 |
setEmptyStr = 1;
|
2767 |
valuePtr = Tcl_NewObj();
|
2768 |
} else {
|
2769 |
valuePtr = listRepPtr->elements[valIndex];
|
2770 |
}
|
2771 |
|
2772 |
varIndex = varListPtr->varIndexes[j];
|
2773 |
DECACHE_STACK_INFO();
|
2774 |
value2Ptr = TclSetIndexedScalar(interp,
|
2775 |
varIndex, valuePtr, /*leaveErrorMsg*/ 1);
|
2776 |
CACHE_STACK_INFO();
|
2777 |
if (value2Ptr == NULL) {
|
2778 |
TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
|
2779 |
opnd, varIndex),
|
2780 |
Tcl_GetObjResult(interp));
|
2781 |
if (setEmptyStr) {
|
2782 |
Tcl_DecrRefCount(valuePtr);
|
2783 |
}
|
2784 |
result = TCL_ERROR;
|
2785 |
goto checkForCatch;
|
2786 |
}
|
2787 |
valIndex++;
|
2788 |
}
|
2789 |
listTmpIndex++;
|
2790 |
}
|
2791 |
}
|
2792 |
|
2793 |
/*
|
2794 |
* Push 1 if at least one value list had a remaining element
|
2795 |
* and the loop should continue. Otherwise push 0.
|
2796 |
*/
|
2797 |
|
2798 |
PUSH_OBJECT(Tcl_NewLongObj(continueLoop));
|
2799 |
TRACE(("%u => %d lists, iter %d, %s loop\n",
|
2800 |
opnd, numLists, iterNum,
|
2801 |
(continueLoop? "continue" : "exit")));
|
2802 |
}
|
2803 |
ADJUST_PC(5);
|
2804 |
|
2805 |
case INST_BEGIN_CATCH4:
|
2806 |
/*
|
2807 |
* Record start of the catch command with exception range index
|
2808 |
* equal to the operand. Push the current stack depth onto the
|
2809 |
* special catch stack.
|
2810 |
*/
|
2811 |
catchStackPtr[++catchTop] = stackTop;
|
2812 |
TRACE(("%u => catchTop=%d, stackTop=%d\n",
|
2813 |
TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
|
2814 |
ADJUST_PC(5);
|
2815 |
|
2816 |
case INST_END_CATCH:
|
2817 |
catchTop--;
|
2818 |
result = TCL_OK;
|
2819 |
TRACE(("=> catchTop=%d\n", catchTop));
|
2820 |
ADJUST_PC(1);
|
2821 |
|
2822 |
case INST_PUSH_RESULT:
|
2823 |
PUSH_OBJECT(Tcl_GetObjResult(interp));
|
2824 |
TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
|
2825 |
ADJUST_PC(1);
|
2826 |
|
2827 |
case INST_PUSH_RETURN_CODE:
|
2828 |
PUSH_OBJECT(Tcl_NewLongObj(result));
|
2829 |
TRACE(("=> %u\n", result));
|
2830 |
ADJUST_PC(1);
|
2831 |
|
2832 |
default:
|
2833 |
panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
|
2834 |
} /* end of switch on opCode */
|
2835 |
|
2836 |
/*
|
2837 |
* Division by zero in an expression. Control only reaches this
|
2838 |
* point by "goto divideByZero".
|
2839 |
*/
|
2840 |
|
2841 |
divideByZero:
|
2842 |
Tcl_ResetResult(interp);
|
2843 |
Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
|
2844 |
Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
|
2845 |
(char *) NULL);
|
2846 |
result = TCL_ERROR;
|
2847 |
|
2848 |
/*
|
2849 |
* Execution has generated an "exception" such as TCL_ERROR. If the
|
2850 |
* exception is an error, record information about what was being
|
2851 |
* executed when the error occurred. Find the closest enclosing
|
2852 |
* catch range, if any. If no enclosing catch range is found, stop
|
2853 |
* execution and return the "exception" code.
|
2854 |
*/
|
2855 |
|
2856 |
checkForCatch:
|
2857 |
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
|
2858 |
bytes = GetSrcInfoForPc(pc, codePtr, &length);
|
2859 |
if (bytes != NULL) {
|
2860 |
Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
|
2861 |
iPtr->flags |= ERR_ALREADY_LOGGED;
|
2862 |
}
|
2863 |
}
|
2864 |
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
|
2865 |
if (rangePtr == NULL) {
|
2866 |
#ifdef TCL_COMPILE_DEBUG
|
2867 |
if (traceInstructions) {
|
2868 |
fprintf(stdout, " ... no enclosing catch, returning %s\n",
|
2869 |
StringForResultCode(result));
|
2870 |
}
|
2871 |
#endif
|
2872 |
goto abnormalReturn;
|
2873 |
}
|
2874 |
|
2875 |
/*
|
2876 |
* A catch exception range (rangePtr) was found to handle an
|
2877 |
* "exception". It was found either by checkForCatch just above or
|
2878 |
* by an instruction during break, continue, or error processing.
|
2879 |
* Jump to its catchOffset after unwinding the operand stack to
|
2880 |
* the depth it had when starting to execute the range's catch
|
2881 |
* command.
|
2882 |
*/
|
2883 |
|
2884 |
processCatch:
|
2885 |
while (stackTop > catchStackPtr[catchTop]) {
|
2886 |
valuePtr = POP_OBJECT();
|
2887 |
TclDecrRefCount(valuePtr);
|
2888 |
}
|
2889 |
#ifdef TCL_COMPILE_DEBUG
|
2890 |
if (traceInstructions) {
|
2891 |
fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
|
2892 |
rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],
|
2893 |
(unsigned int)(rangePtr->catchOffset));
|
2894 |
}
|
2895 |
#endif
|
2896 |
pc = (codePtr->codeStart + rangePtr->catchOffset);
|
2897 |
continue; /* restart the execution loop at pc */
|
2898 |
} /* end of infinite loop dispatching on instructions */
|
2899 |
|
2900 |
/*
|
2901 |
* Abnormal return code. Restore the stack to state it had when starting
|
2902 |
* to execute the ByteCode.
|
2903 |
*/
|
2904 |
|
2905 |
abnormalReturn:
|
2906 |
while (stackTop > initStackTop) {
|
2907 |
valuePtr = POP_OBJECT();
|
2908 |
Tcl_DecrRefCount(valuePtr);
|
2909 |
}
|
2910 |
|
2911 |
/*
|
2912 |
* Free the catch stack array if malloc'ed storage was used.
|
2913 |
*/
|
2914 |
|
2915 |
done:
|
2916 |
if (catchStackPtr != catchStackStorage) {
|
2917 |
ckfree((char *) catchStackPtr);
|
2918 |
}
|
2919 |
eePtr->stackTop = initStackTop;
|
2920 |
return result;
|
2921 |
#undef STATIC_CATCH_STACK_SIZE
|
2922 |
}
|
2923 |
|
2924 |
#ifdef TCL_COMPILE_DEBUG
|
2925 |
/*
|
2926 |
*----------------------------------------------------------------------
|
2927 |
*
|
2928 |
* PrintByteCodeInfo --
|
2929 |
*
|
2930 |
* This procedure prints a summary about a bytecode object to stdout.
|
2931 |
* It is called by TclExecuteByteCode when starting to execute the
|
2932 |
* bytecode object if tclTraceExec has the value 2 or more.
|
2933 |
*
|
2934 |
* Results:
|
2935 |
* None.
|
2936 |
*
|
2937 |
* Side effects:
|
2938 |
* None.
|
2939 |
*
|
2940 |
*----------------------------------------------------------------------
|
2941 |
*/
|
2942 |
|
2943 |
static void
|
2944 |
PrintByteCodeInfo(codePtr)
|
2945 |
register ByteCode *codePtr; /* The bytecode whose summary is printed
|
2946 |
* to stdout. */
|
2947 |
{
|
2948 |
Proc *procPtr = codePtr->procPtr;
|
2949 |
Interp *iPtr = (Interp *) *codePtr->interpHandle;
|
2950 |
|
2951 |
fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
|
2952 |
(unsigned int) codePtr, codePtr->refCount,
|
2953 |
codePtr->compileEpoch, (unsigned int) iPtr,
|
2954 |
iPtr->compileEpoch);
|
2955 |
|
2956 |
fprintf(stdout, " Source: ");
|
2957 |
TclPrintSource(stdout, codePtr->source, 60);
|
2958 |
|
2959 |
fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
|
2960 |
codePtr->numCommands, codePtr->numSrcBytes,
|
2961 |
codePtr->numCodeBytes, codePtr->numLitObjects,
|
2962 |
codePtr->numAuxDataItems, codePtr->maxStackDepth,
|
2963 |
#ifdef TCL_COMPILE_STATS
|
2964 |
(codePtr->numSrcBytes?
|
2965 |
((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
|
2966 |
#else
|
2967 |
0.0);
|
2968 |
#endif
|
2969 |
#ifdef TCL_COMPILE_STATS
|
2970 |
fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
|
2971 |
codePtr->structureSize,
|
2972 |
(sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
|
2973 |
codePtr->numCodeBytes,
|
2974 |
(codePtr->numLitObjects * sizeof(Tcl_Obj *)),
|
2975 |
(codePtr->numExceptRanges * sizeof(ExceptionRange)),
|
2976 |
(codePtr->numAuxDataItems * sizeof(AuxData)),
|
2977 |
codePtr->numCmdLocBytes);
|
2978 |
#endif /* TCL_COMPILE_STATS */
|
2979 |
if (procPtr != NULL) {
|
2980 |
fprintf(stdout,
|
2981 |
" Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
|
2982 |
(unsigned int) procPtr, procPtr->refCount,
|
2983 |
procPtr->numArgs, procPtr->numCompiledLocals);
|
2984 |
}
|
2985 |
}
|
2986 |
#endif /* TCL_COMPILE_DEBUG */
|
2987 |
|
2988 |
/*
|
2989 |
*----------------------------------------------------------------------
|
2990 |
*
|
2991 |
* ValidatePcAndStackTop --
|
2992 |
*
|
2993 |
* This procedure is called by TclExecuteByteCode when debugging to
|
2994 |
* verify that the program counter and stack top are valid during
|
2995 |
* execution.
|
2996 |
*
|
2997 |
* Results:
|
2998 |
* None.
|
2999 |
*
|
3000 |
* Side effects:
|
3001 |
* Prints a message to stderr and panics if either the pc or stack
|
3002 |
* top are invalid.
|
3003 |
*
|
3004 |
*----------------------------------------------------------------------
|
3005 |
*/
|
3006 |
|
3007 |
#ifdef TCL_COMPILE_DEBUG
|
3008 |
static void
|
3009 |
ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound,
|
3010 |
stackUpperBound)
|
3011 |
register ByteCode *codePtr; /* The bytecode whose summary is printed
|
3012 |
* to stdout. */
|
3013 |
unsigned char *pc; /* Points to first byte of a bytecode
|
3014 |
* instruction. The program counter. */
|
3015 |
int stackTop; /* Current stack top. Must be between
|
3016 |
* stackLowerBound and stackUpperBound
|
3017 |
* (inclusive). */
|
3018 |
int stackLowerBound; /* Smallest legal value for stackTop. */
|
3019 |
int stackUpperBound; /* Greatest legal value for stackTop. */
|
3020 |
{
|
3021 |
unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart);
|
3022 |
unsigned int codeStart = (unsigned int) codePtr->codeStart;
|
3023 |
unsigned int codeEnd = (unsigned int)
|
3024 |
(codePtr->codeStart + codePtr->numCodeBytes);
|
3025 |
unsigned char opCode = *pc;
|
3026 |
|
3027 |
if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) {
|
3028 |
fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n",
|
3029 |
(unsigned int) pc);
|
3030 |
panic("TclExecuteByteCode execution failure: bad pc");
|
3031 |
}
|
3032 |
if ((unsigned int) opCode > LAST_INST_OPCODE) {
|
3033 |
fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
|
3034 |
(unsigned int) opCode, relativePc);
|
3035 |
panic("TclExecuteByteCode execution failure: bad opcode");
|
3036 |
}
|
3037 |
if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) {
|
3038 |
int numChars;
|
3039 |
char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
|
3040 |
char *ellipsis = "";
|
3041 |
|
3042 |
fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode",
|
3043 |
stackTop, relativePc);
|
3044 |
if (cmd != NULL) {
|
3045 |
if (numChars > 100) {
|
3046 |
numChars = 100;
|
3047 |
ellipsis = "...";
|
3048 |
}
|
3049 |
fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd,
|
3050 |
ellipsis);
|
3051 |
} else {
|
3052 |
fprintf(stderr, "\n");
|
3053 |
}
|
3054 |
panic("TclExecuteByteCode execution failure: bad stack top");
|
3055 |
}
|
3056 |
}
|
3057 |
#endif /* TCL_COMPILE_DEBUG */
|
3058 |
|
3059 |
/*
|
3060 |
*----------------------------------------------------------------------
|
3061 |
*
|
3062 |
* IllegalExprOperandType --
|
3063 |
*
|
3064 |
* Used by TclExecuteByteCode to add an error message to errorInfo
|
3065 |
* when an illegal operand type is detected by an expression
|
3066 |
* instruction. The argument opndPtr holds the operand object in error.
|
3067 |
*
|
3068 |
* Results:
|
3069 |
* None.
|
3070 |
*
|
3071 |
* Side effects:
|
3072 |
* An error message is appended to errorInfo.
|
3073 |
*
|
3074 |
*----------------------------------------------------------------------
|
3075 |
*/
|
3076 |
|
3077 |
static void
|
3078 |
IllegalExprOperandType(interp, pc, opndPtr)
|
3079 |
Tcl_Interp *interp; /* Interpreter to which error information
|
3080 |
* pertains. */
|
3081 |
unsigned char *pc; /* Points to the instruction being executed
|
3082 |
* when the illegal type was found. */
|
3083 |
Tcl_Obj *opndPtr; /* Points to the operand holding the value
|
3084 |
* with the illegal type. */
|
3085 |
{
|
3086 |
unsigned char opCode = *pc;
|
3087 |
|
3088 |
Tcl_ResetResult(interp);
|
3089 |
if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
|
3090 |
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
3091 |
"can't use empty string as operand of \"",
|
3092 |
operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
|
3093 |
} else {
|
3094 |
char *msg = "non-numeric string";
|
3095 |
if (opndPtr->typePtr != &tclDoubleType) {
|
3096 |
/*
|
3097 |
* See if the operand can be interpreted as a double in order to
|
3098 |
* improve the error message.
|
3099 |
*/
|
3100 |
|
3101 |
char *s = Tcl_GetString(opndPtr);
|
3102 |
double d;
|
3103 |
|
3104 |
if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) {
|
3105 |
/*
|
3106 |
* Make sure that what appears to be a double
|
3107 |
* (ie 08) isn't really a bad octal
|
3108 |
*/
|
3109 |
if (TclCheckBadOctal(NULL, Tcl_GetString(opndPtr))) {
|
3110 |
msg = "invalid octal number";
|
3111 |
} else {
|
3112 |
msg = "floating-point value";
|
3113 |
}
|
3114 |
}
|
3115 |
}
|
3116 |
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
|
3117 |
msg, " as operand of \"", operatorStrings[opCode - INST_LOR],
|
3118 |
"\"", (char *) NULL);
|
3119 |
}
|
3120 |
}
|
3121 |
|
3122 |
/*
|
3123 |
*----------------------------------------------------------------------
|
3124 |
*
|
3125 |
* CallTraceProcedure --
|
3126 |
*
|
3127 |
* Invokes a trace procedure registered with an interpreter. These
|
3128 |
* procedures trace command execution. Currently this trace procedure
|
3129 |
* is called with the address of the string-based Tcl_CmdProc for the
|
3130 |
* command, not the Tcl_ObjCmdProc.
|
3131 |
*
|
3132 |
* Results:
|
3133 |
* None.
|
3134 |
*
|
3135 |
* Side effects:
|
3136 |
* Those side effects made by the trace procedure.
|
3137 |
*
|
3138 |
*----------------------------------------------------------------------
|
3139 |
*/
|
3140 |
|
3141 |
static void
|
3142 |
CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
|
3143 |
Tcl_Interp *interp; /* The current interpreter. */
|
3144 |
register Trace *tracePtr; /* Describes the trace procedure to call. */
|
3145 |
Command *cmdPtr; /* Points to command's Command struct. */
|
3146 |
char *command; /* Points to the first character of the
|
3147 |
* command's source before substitutions. */
|
3148 |
int numChars; /* The number of characters in the
|
3149 |
* command's source. */
|
3150 |
register int objc; /* Number of arguments for the command. */
|
3151 |
Tcl_Obj *objv[]; /* Pointers to Tcl_Obj of each argument. */
|
3152 |
{
|
3153 |
Interp *iPtr = (Interp *) interp;
|
3154 |
register char **argv;
|
3155 |
register int i;
|
3156 |
int length;
|
3157 |
char *p;
|
3158 |
|
3159 |
/*
|
3160 |
* Get the string rep from the objv argument objects and place their
|
3161 |
* pointers in argv. First make sure argv is large enough to hold the
|
3162 |
* objc args plus 1 extra word for the zero end-of-argv word.
|
3163 |
*/
|
3164 |
|
3165 |
argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
|
3166 |
for (i = 0; i < objc; i++) {
|
3167 |
argv[i] = Tcl_GetStringFromObj(objv[i], &length);
|
3168 |
}
|
3169 |
argv[objc] = 0;
|
3170 |
|
3171 |
/*
|
3172 |
* Copy the command characters into a new string.
|
3173 |
*/
|
3174 |
|
3175 |
p = (char *) ckalloc((unsigned) (numChars + 1));
|
3176 |
memcpy((VOID *) p, (VOID *) command, (size_t) numChars);
|
3177 |
p[numChars] = '\0';
|
3178 |
|
3179 |
/*
|
3180 |
* Call the trace procedure then free allocated storage.
|
3181 |
*/
|
3182 |
|
3183 |
(*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
|
3184 |
p, cmdPtr->proc, cmdPtr->clientData, objc, argv);
|
3185 |
|
3186 |
ckfree((char *) argv);
|
3187 |
ckfree((char *) p);
|
3188 |
}
|
3189 |
|
3190 |
/*
|
3191 |
*----------------------------------------------------------------------
|
3192 |
*
|
3193 |
* GetSrcInfoForPc --
|
3194 |
*
|
3195 |
* Given a program counter value, finds the closest command in the
|
3196 |
* bytecode code unit's CmdLocation array and returns information about
|
3197 |
* that command's source: a pointer to its first byte and the number of
|
3198 |
* characters.
|
3199 |
*
|
3200 |
* Results:
|
3201 |
* If a command is found that encloses the program counter value, a
|
3202 |
* pointer to the command's source is returned and the length of the
|
3203 |
* source is stored at *lengthPtr. If multiple commands resulted in
|
3204 |
* code at pc, information about the closest enclosing command is
|
3205 |
* returned. If no matching command is found, NULL is returned and
|
3206 |
* *lengthPtr is unchanged.
|
3207 |
*
|
3208 |
* Side effects:
|
3209 |
* None.
|
3210 |
*
|
3211 |
*----------------------------------------------------------------------
|
3212 |
*/
|
3213 |
|
3214 |
static char *
|
3215 |
GetSrcInfoForPc(pc, codePtr, lengthPtr)
|
3216 |
unsigned char *pc; /* The program counter value for which to
|
3217 |
* return the closest command's source info.
|
3218 |
* This points to a bytecode instruction
|
3219 |
* in codePtr's code. */
|
3220 |
ByteCode *codePtr; /* The bytecode sequence in which to look
|
3221 |
* up the command source for the pc. */
|
3222 |
int *lengthPtr; /* If non-NULL, the location where the
|
3223 |
* length of the command's source should be
|
3224 |
* stored. If NULL, no length is stored. */
|
3225 |
{
|
3226 |
register int pcOffset = (pc - codePtr->codeStart);
|
3227 |
int numCmds = codePtr->numCommands;
|
3228 |
unsigned char *codeDeltaNext, *codeLengthNext;
|
3229 |
unsigned char *srcDeltaNext, *srcLengthNext;
|
3230 |
int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
|
3231 |
int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
|
3232 |
int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
|
3233 |
int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
|
3234 |
|
3235 |
if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) {
|
3236 |
return NULL;
|
3237 |
}
|
3238 |
|
3239 |
/*
|
3240 |
* Decode the code and source offset and length for each command. The
|
3241 |
* closest enclosing command is the last one whose code started before
|
3242 |
* pcOffset.
|
3243 |
*/
|
3244 |
|
3245 |
codeDeltaNext = codePtr->codeDeltaStart;
|
3246 |
codeLengthNext = codePtr->codeLengthStart;
|
3247 |
srcDeltaNext = codePtr->srcDeltaStart;
|
3248 |
srcLengthNext = codePtr->srcLengthStart;
|
3249 |
codeOffset = srcOffset = 0;
|
3250 |
for (i = 0; i < numCmds; i++) {
|
3251 |
if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
|
3252 |
codeDeltaNext++;
|
3253 |
delta = TclGetInt4AtPtr(codeDeltaNext);
|
3254 |
codeDeltaNext += 4;
|
3255 |
} else {
|
3256 |
delta = TclGetInt1AtPtr(codeDeltaNext);
|
3257 |
codeDeltaNext++;
|
3258 |
}
|
3259 |
codeOffset += delta;
|
3260 |
|
3261 |
if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
|
3262 |
codeLengthNext++;
|
3263 |
codeLen = TclGetInt4AtPtr(codeLengthNext);
|
3264 |
codeLengthNext += 4;
|
3265 |
} else {
|
3266 |
codeLen = TclGetInt1AtPtr(codeLengthNext);
|
3267 |
codeLengthNext++;
|
3268 |
}
|
3269 |
codeEnd = (codeOffset + codeLen - 1);
|
3270 |
|
3271 |
if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
|
3272 |
srcDeltaNext++;
|
3273 |
delta = TclGetInt4AtPtr(srcDeltaNext);
|
3274 |
srcDeltaNext += 4;
|
3275 |
} else {
|
3276 |
delta = TclGetInt1AtPtr(srcDeltaNext);
|
3277 |
srcDeltaNext++;
|
3278 |
}
|
3279 |
srcOffset += delta;
|
3280 |
|
3281 |
if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
|
3282 |
srcLengthNext++;
|
3283 |
srcLen = TclGetInt4AtPtr(srcLengthNext);
|
3284 |
srcLengthNext += 4;
|
3285 |
} else {
|
3286 |
srcLen = TclGetInt1AtPtr(srcLengthNext);
|
3287 |
srcLengthNext++;
|
3288 |
}
|
3289 |
|
3290 |
if (codeOffset > pcOffset) { /* best cmd already found */
|
3291 |
break;
|
3292 |
} else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */
|
3293 |
int dist = (pcOffset - codeOffset);
|
3294 |
if (dist <= bestDist) {
|
3295 |
bestDist = dist;
|
3296 |
bestSrcOffset = srcOffset;
|
3297 |
bestSrcLength = srcLen;
|
3298 |
}
|
3299 |
}
|
3300 |
}
|
3301 |
|
3302 |
if (bestDist == INT_MAX) {
|
3303 |
return NULL;
|
3304 |
}
|
3305 |
|
3306 |
if (lengthPtr != NULL) {
|
3307 |
*lengthPtr = bestSrcLength;
|
3308 |
}
|
3309 |
return (codePtr->source + bestSrcOffset);
|
3310 |
}
|
3311 |
|
3312 |
/*
|
3313 |
*----------------------------------------------------------------------
|
3314 |
*
|
3315 |
* GetExceptRangeForPc --
|
3316 |
*
|
3317 |
* Given a program counter value, return the closest enclosing
|
3318 |
* ExceptionRange.
|
3319 |
*
|
3320 |
* Results:
|
3321 |
* In the normal case, catchOnly is 0 (false) and this procedure
|
3322 |
* returns a pointer to the most closely enclosing ExceptionRange
|
3323 |
* structure regardless of whether it is a loop or catch exception
|
3324 |
* range. This is appropriate when processing a TCL_BREAK or
|
3325 |
* TCL_CONTINUE, which will be "handled" either by a loop exception
|
3326 |
* range or a closer catch range. If catchOnly is nonzero, this
|
3327 |
* procedure ignores loop exception ranges and returns a pointer to the
|
3328 |
* closest catch range. If no matching ExceptionRange is found that
|
3329 |
* encloses pc, a NULL is returned.
|
3330 |
*
|
3331 |
* Side effects:
|
3332 |
* None.
|
3333 |
*
|
3334 |
*----------------------------------------------------------------------
|
3335 |
*/
|
3336 |
|
3337 |
static ExceptionRange *
|
3338 |
GetExceptRangeForPc(pc, catchOnly, codePtr)
|
3339 |
unsigned char *pc; /* The program counter value for which to
|
3340 |
* search for a closest enclosing exception
|
3341 |
* range. This points to a bytecode
|
3342 |
* instruction in codePtr's code. */
|
3343 |
int catchOnly; /* If 0, consider either loop or catch
|
3344 |
* ExceptionRanges in search. If nonzero
|
3345 |
* consider only catch ranges (and ignore
|
3346 |
* any closer loop ranges). */
|
3347 |
ByteCode* codePtr; /* Points to the ByteCode in which to search
|
3348 |
* for the enclosing ExceptionRange. */
|
3349 |
{
|
3350 |
ExceptionRange *rangeArrayPtr;
|
3351 |
int numRanges = codePtr->numExceptRanges;
|
3352 |
register ExceptionRange *rangePtr;
|
3353 |
int pcOffset = (pc - codePtr->codeStart);
|
3354 |
register int i, level;
|
3355 |
|
3356 |
if (numRanges == 0) {
|
3357 |
return NULL;
|
3358 |
}
|
3359 |
rangeArrayPtr = codePtr->exceptArrayPtr;
|
3360 |
|
3361 |
for (level = codePtr->maxExceptDepth; level >= 0; level--) {
|
3362 |
for (i = 0; i < numRanges; i++) {
|
3363 |
rangePtr = &(rangeArrayPtr[i]);
|
3364 |
if (rangePtr->nestingLevel == level) {
|
3365 |
int start = rangePtr->codeOffset;
|
3366 |
int end = (start + rangePtr->numCodeBytes);
|
3367 |
if ((start <= pcOffset) && (pcOffset < end)) {
|
3368 |
if ((!catchOnly)
|
3369 |
|| (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
|
3370 |
return rangePtr;
|
3371 |
}
|
3372 |
}
|
3373 |
}
|
3374 |
}
|
3375 |
}
|
3376 |
return NULL;
|
3377 |
}
|
3378 |
|
3379 |
/*
|
3380 |
*----------------------------------------------------------------------
|
3381 |
*
|
3382 |
* GetOpcodeName --
|
3383 |
*
|
3384 |
* This procedure is called by the TRACE and TRACE_WITH_OBJ macros
|
3385 |
* used in TclExecuteByteCode when debugging. It returns the name of
|
3386 |
* the bytecode instruction at a specified instruction pc.
|
3387 |
*
|
3388 |
* Results:
|
3389 |
* A character string for the instruction.
|
3390 |
*
|
3391 |
* Side effects:
|
3392 |
* None.
|
3393 |
*
|
3394 |
*----------------------------------------------------------------------
|
3395 |
*/
|
3396 |
|
3397 |
#ifdef TCL_COMPILE_DEBUG
|
3398 |
static char *
|
3399 |
GetOpcodeName(pc)
|
3400 |
unsigned char *pc; /* Points to the instruction whose name
|
3401 |
* should be returned. */
|
3402 |
{
|
3403 |
unsigned char opCode = *pc;
|
3404 |
|
3405 |
return instructionTable[opCode].name;
|
3406 |
}
|
3407 |
#endif /* TCL_COMPILE_DEBUG */
|
3408 |
|
3409 |
/*
|
3410 |
*----------------------------------------------------------------------
|
3411 |
*
|
3412 |
* VerifyExprObjType --
|
3413 |
*
|
3414 |
* This procedure is called by the math functions to verify that
|
3415 |
* the object is either an int or double, coercing it if necessary.
|
3416 |
* If an error occurs during conversion, an error message is left
|
3417 |
* in the interpreter's result unless "interp" is NULL.
|
3418 |
*
|
3419 |
* Results:
|
3420 |
* TCL_OK if it was int or double, TCL_ERROR otherwise
|
3421 |
*
|
3422 |
* Side effects:
|
3423 |
* objPtr is ensured to be either tclIntType of tclDoubleType.
|
3424 |
*
|
3425 |
*----------------------------------------------------------------------
|
3426 |
*/
|
3427 |
|
3428 |
static int
|
3429 |
VerifyExprObjType(interp, objPtr)
|
3430 |
Tcl_Interp *interp; /* The interpreter in which to execute the
|
3431 |
* function. */
|
3432 |
Tcl_Obj *objPtr; /* Points to the object to type check. */
|
3433 |
{
|
3434 |
if ((objPtr->typePtr == &tclIntType) ||
|
3435 |
(objPtr->typePtr == &tclDoubleType)) {
|
3436 |
return TCL_OK;
|
3437 |
} else {
|
3438 |
int length, result = TCL_OK;
|
3439 |
char *s = Tcl_GetStringFromObj(objPtr, &length);
|
3440 |
|
3441 |
if (TclLooksLikeInt(s, length)) {
|
3442 |
long i;
|
3443 |
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, objPtr, &i);
|
3444 |
} else {
|
3445 |
double d;
|
3446 |
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d);
|
3447 |
}
|
3448 |
if ((result != TCL_OK) && (interp != NULL)) {
|
3449 |
Tcl_ResetResult(interp);
|
3450 |
if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) {
|
3451 |
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
3452 |
"argument to math function was an invalid octal number",
|
3453 |
-1);
|
3454 |
} else {
|
3455 |
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
3456 |
"argument to math function didn't have numeric value",
|
3457 |
-1);
|
3458 |
}
|
3459 |
}
|
3460 |
return result;
|
3461 |
}
|
3462 |
}
|
3463 |
|
3464 |
/*
|
3465 |
*----------------------------------------------------------------------
|
3466 |
*
|
3467 |
* Math Functions --
|
3468 |
*
|
3469 |
* This page contains the procedures that implement all of the
|
3470 |
* built-in math functions for expressions.
|
3471 |
*
|
3472 |
* Results:
|
3473 |
* Each procedure returns TCL_OK if it succeeds and pushes an
|
3474 |
* Tcl object holding the result. If it fails it returns TCL_ERROR
|
3475 |
* and leaves an error message in the interpreter's result.
|
3476 |
*
|
3477 |
* Side effects:
|
3478 |
* None.
|
3479 |
*
|
3480 |
*----------------------------------------------------------------------
|
3481 |
*/
|
3482 |
|
3483 |
static int
|
3484 |
ExprUnaryFunc(interp, eePtr, clientData)
|
3485 |
Tcl_Interp *interp; /* The interpreter in which to execute the
|
3486 |
* function. */
|
3487 |
ExecEnv *eePtr; /* Points to the environment for executing
|
3488 |
* the function. */
|
3489 |
ClientData clientData; /* Contains the address of a procedure that
|
3490 |
* takes one double argument and returns a
|
3491 |
* double result. */
|
3492 |
{
|
3493 |
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
|
3494 |
register int stackTop; /* Cached top index of evaluation stack. */
|
3495 |
register Tcl_Obj *valuePtr;
|
3496 |
double d, dResult;
|
3497 |
int result;
|
3498 |
|
3499 |
double (*func) _ANSI_ARGS_((double)) =
|
3500 |
(double (*)_ANSI_ARGS_((double))) clientData;
|
3501 |
|
3502 |
/*
|
3503 |
* Set stackPtr and stackTop from eePtr.
|
3504 |
*/
|
3505 |
|
3506 |
result = TCL_OK;
|
3507 |
CACHE_STACK_INFO();
|
3508 |
|
3509 |
/*
|
3510 |
* Pop the function's argument from the evaluation stack. Convert it
|
3511 |
* to a double if necessary.
|
3512 |
*/
|
3513 |
|
3514 |
valuePtr = POP_OBJECT();
|
3515 |
|
3516 |
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
|
3517 |
result = TCL_ERROR;
|
3518 |
goto done;
|
3519 |
}
|
3520 |
|
3521 |
if (valuePtr->typePtr == &tclIntType) {
|
3522 |
d = (double) valuePtr->internalRep.longValue;
|
3523 |
} else {
|
3524 |
d = valuePtr->internalRep.doubleValue;
|
3525 |
}
|
3526 |
|
3527 |
errno = 0;
|
3528 |
dResult = (*func)(d);
|
3529 |
if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
|
3530 |
TclExprFloatError(interp, dResult);
|
3531 |
result = TCL_ERROR;
|
3532 |
goto done;
|
3533 |
}
|
3534 |
|
3535 |
/*
|
3536 |
* Push a Tcl object holding the result.
|
3537 |
*/
|
3538 |
|
3539 |
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
|
3540 |
|
3541 |
/*
|
3542 |
* Reflect the change to stackTop back in eePtr.
|
3543 |
*/
|
3544 |
|
3545 |
done:
|
3546 |
Tcl_DecrRefCount(valuePtr);
|
3547 |
DECACHE_STACK_INFO();
|
3548 |
return result;
|
3549 |
}
|
3550 |
|
3551 |
static int
|
3552 |
ExprBinaryFunc(interp, eePtr, clientData)
|
3553 |
Tcl_Interp *interp; /* The interpreter in which to execute the
|
3554 |
* function. */
|
3555 |
ExecEnv *eePtr; /* Points to the environment for executing
|
3556 |
* the function. */
|
3557 |
ClientData clientData; /* Contains the address of a procedure that
|
3558 |
* takes two double arguments and
|
3559 |
* returns a double result. */
|
3560 |
{
|
3561 |
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
|
3562 |
register int stackTop; /* Cached top index of evaluation stack. */
|
3563 |
register Tcl_Obj *valuePtr, *value2Ptr;
|
3564 |
double d1, d2, dResult;
|
3565 |
int result;
|
3566 |
|
3567 |
double (*func) _ANSI_ARGS_((double, double))
|
3568 |
= (double (*)_ANSI_ARGS_((double, double))) clientData;
|
3569 |
|
3570 |
/*
|
3571 |
* Set stackPtr and stackTop from eePtr.
|
3572 |
*/
|
3573 |
|
3574 |
result = TCL_OK;
|
3575 |
CACHE_STACK_INFO();
|
3576 |
|
3577 |
/*
|
3578 |
* Pop the function's two arguments from the evaluation stack. Convert
|
3579 |
* them to doubles if necessary.
|
3580 |
*/
|
3581 |
|
3582 |
value2Ptr = POP_OBJECT();
|
3583 |
valuePtr = POP_OBJECT();
|
3584 |
|
3585 |
if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) ||
|
3586 |
(VerifyExprObjType(interp, value2Ptr) != TCL_OK)) {
|
3587 |
result = TCL_ERROR;
|
3588 |
goto done;
|
3589 |
}
|
3590 |
|
3591 |
if (valuePtr->typePtr == &tclIntType) {
|
3592 |
d1 = (double) valuePtr->internalRep.longValue;
|
3593 |
} else {
|
3594 |
d1 = valuePtr->internalRep.doubleValue;
|
3595 |
}
|
3596 |
|
3597 |
if (value2Ptr->typePtr == &tclIntType) {
|
3598 |
d2 = (double) value2Ptr->internalRep.longValue;
|
3599 |
} else {
|
3600 |
d2 = value2Ptr->internalRep.doubleValue;
|
3601 |
}
|
3602 |
|
3603 |
errno = 0;
|
3604 |
dResult = (*func)(d1, d2);
|
3605 |
if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
|
3606 |
TclExprFloatError(interp, dResult);
|
3607 |
result = TCL_ERROR;
|
3608 |
goto done;
|
3609 |
}
|
3610 |
|
3611 |
/*
|
3612 |
* Push a Tcl object holding the result.
|
3613 |
*/
|
3614 |
|
3615 |
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
|
3616 |
|
3617 |
/*
|
3618 |
* Reflect the change to stackTop back in eePtr.
|
3619 |
*/
|
3620 |
|
3621 |
done:
|
3622 |
Tcl_DecrRefCount(valuePtr);
|
3623 |
Tcl_DecrRefCount(value2Ptr);
|
3624 |
DECACHE_STACK_INFO();
|
3625 |
return result;
|
3626 |
}
|
3627 |
|
3628 |
static int
|
3629 |
ExprAbsFunc(interp, eePtr, clientData)
|
3630 |
Tcl_Interp *interp; /* The interpreter in which to execute the
|
3631 |
* function. */
|
3632 |
ExecEnv *eePtr; /* Points to the environment for executing
|
3633 |
* the function. */
|
3634 |
ClientData clientData; /* Ignored. */
|
3635 |
{
|
3636 |
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
|
3637 |
register int stackTop; /* Cached top index of evaluation stack. */
|
3638 |
register Tcl_Obj *valuePtr;
|
3639 |
long i, iResult;
|
3640 |
double d, dResult;
|
3641 |
int result;
|
3642 |
|
3643 |
/*
|
3644 |
* Set stackPtr and stackTop from eePtr.
|
3645 |
*/
|
3646 |
|
3647 |
result = TCL_OK;
|
3648 |
CACHE_STACK_INFO();
|
3649 |
|
3650 |
/*
|
3651 |
* Pop the argument from the evaluation stack.
|
3652 |
*/
|
3653 |
|
3654 |
valuePtr = POP_OBJECT();
|
3655 |
|
3656 |
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
|
3657 |
result = TCL_ERROR;
|
3658 |
goto done;
|
3659 |
}
|
3660 |
|
3661 |
/*
|
3662 |
* Push a Tcl object with the result.
|
3663 |
*/
|
3664 |
if (valuePtr->typePtr == &tclIntType) {
|
3665 |
i = valuePtr->internalRep.longValue;
|
3666 |
if (i < 0) {
|
3667 |
iResult = -i;
|
3668 |
if (iResult < 0) {
|
3669 |
Tcl_ResetResult(interp);
|
3670 |
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
3671 |
"integer value too large to represent", -1);
|
3672 |
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
|
3673 |
"integer value too large to represent", (char *) NULL);
|
3674 |
result = TCL_ERROR;
|
3675 |
goto done;
|
3676 |
}
|
3677 |
} else {
|
3678 |
iResult = i;
|
3679 |
}
|
3680 |
PUSH_OBJECT(Tcl_NewLongObj(iResult));
|
3681 |
} else {
|
3682 |
d = valuePtr->internalRep.doubleValue;
|
3683 |
if (d < 0.0) {
|
3684 |
dResult = -d;
|
3685 |
} else {
|
3686 |
dResult = d;
|
3687 |
}
|
3688 |
if (IS_NAN(dResult) || IS_INF(dResult)) {
|
3689 |
TclExprFloatError(interp, dResult);
|
3690 |
result = TCL_ERROR;
|
3691 |
goto done;
|
3692 |
}
|
3693 |
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
|
3694 |
}
|
3695 |
|
3696 |
/*
|
3697 |
* Reflect the change to stackTop back in eePtr.
|
3698 |
*/
|
3699 |
|
3700 |
done:
|
3701 |
Tcl_DecrRefCount(valuePtr);
|
3702 |
DECACHE_STACK_INFO();
|
3703 |
return result;
|
3704 |
}
|
3705 |
|
3706 |
static int
|
3707 |
ExprDoubleFunc(interp, eePtr, clientData)
|
3708 |
Tcl_Interp *interp; /* The interpreter in which to execute the
|
3709 |
* function. */
|
3710 |
ExecEnv *eePtr; /* Points to the environment for executing
|
3711 |
* the function. */
|
3712 |
ClientData clientData; /* Ignored. */
|
3713 |
{
|
3714 |
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
|
3715 |
register int stackTop; /* Cached top index of evaluation stack. */
|
3716 |
register Tcl_Obj *valuePtr;
|
3717 |
double dResult;
|
3718 |
int result;
|
3719 |
|
3720 |
/*
|
3721 |
* Set stackPtr and stackTop from eePtr.
|
3722 |
*/
|
3723 |
|
3724 |
result = TCL_OK;
|
3725 |
CACHE_STACK_INFO();
|
3726 |
|
3727 |
/*
|
3728 |
* Pop the argument from the evaluation stack.
|
3729 |
*/
|
3730 |
|
3731 |
valuePtr = POP_OBJECT();
|
3732 |
|
3733 |
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
|
3734 |
result = TCL_ERROR;
|
3735 |
goto done;
|
3736 |
}
|
3737 |
|
3738 |
if (valuePtr->typePtr == &tclIntType) {
|
3739 |
dResult = (double) valuePtr->internalRep.longValue;
|
3740 |
} else {
|
3741 |
dResult = valuePtr->internalRep.doubleValue;
|
3742 |
}
|
3743 |
|
3744 |
/*
|
3745 |
* Push a Tcl object with the result.
|
3746 |
*/
|
3747 |
|
3748 |
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
|
3749 |
|
3750 |
/*
|
3751 |
* Reflect the change to stackTop back in eePtr.
|
3752 |
*/
|
3753 |
|
3754 |
done:
|
3755 |
Tcl_DecrRefCount(valuePtr);
|
3756 |
DECACHE_STACK_INFO();
|
3757 |
return result;
|
3758 |
}
|
3759 |
|
3760 |
static int
|
3761 |
ExprIntFunc(interp, eePtr, clientData)
|
3762 |
Tcl_Interp *interp; /* The interpreter in which to execute the
|
3763 |
* function. */
|
3764 |
ExecEnv *eePtr; /* Points to the environment for executing
|
3765 |
* the function. */
|
3766 |
ClientData clientData; /* Ignored. */
|
3767 |
{
|
3768 |
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
|
3769 |
register int stackTop; /* Cached top index of evaluation stack. */
|
3770 |
register Tcl_Obj *valuePtr;
|
3771 |
long iResult;
|
3772 |
double d;
|
3773 |
int result;
|
3774 |
|
3775 |
/*
|
3776 |
* Set stackPtr and stackTop from eePtr.
|
3777 |
*/
|
3778 |
|
3779 |
result = TCL_OK;
|
3780 |
CACHE_STACK_INFO();
|
3781 |
|
3782 |
/*
|
3783 |
* Pop the argument from the evaluation stack.
|
3784 |
*/
|
3785 |
|
3786 |
valuePtr = POP_OBJECT();
|
3787 |
|
3788 |
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
|
3789 |
result = TCL_ERROR;
|
3790 |
goto done;
|
3791 |
}
|
3792 |
|
3793 |
if (valuePtr->typePtr == &tclIntType) {
|
3794 |
iResult = valuePtr->internalRep.longValue;
|
3795 |
} else {
|
3796 |
d = valuePtr->internalRep.doubleValue;
|
3797 |
if (d < 0.0) {
|
3798 |
if (d < (double) (long) LONG_MIN) {
|
3799 |
tooLarge:
|
3800 |
Tcl_ResetResult(interp);
|
3801 |
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
3802 |
"integer value too large to represent", -1);
|
3803 |
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
|
3804 |
"integer value too large to represent", (char *) NULL);
|
3805 |
result = TCL_ERROR;
|
3806 |
goto done;
|
3807 |
}
|
3808 |
} else {
|
3809 |
if (d > (double) LONG_MAX) {
|
3810 |
goto tooLarge;
|
3811 |
}
|
3812 |
}
|
3813 |
if (IS_NAN(d) || IS_INF(d)) {
|
3814 |
TclExprFloatError(interp, d);
|
3815 |
result = TCL_ERROR;
|
3816 |
goto done;
|
3817 |
}
|
3818 |
iResult = (long) d;
|
3819 |
}
|
3820 |
|
3821 |
/*
|
3822 |
* Push a Tcl object with the result.
|
3823 |
*/
|
3824 |
|
3825 |
PUSH_OBJECT(Tcl_NewLongObj(iResult));
|
3826 |
|
3827 |
/*
|
3828 |
* Reflect the change to stackTop back in eePtr.
|
3829 |
*/
|
3830 |
|
3831 |
done:
|
3832 |
Tcl_DecrRefCount(valuePtr);
|
3833 |
DECACHE_STACK_INFO();
|
3834 |
return result;
|
3835 |
}
|
3836 |
|
3837 |
static int
|
3838 |
ExprRandFunc(interp, eePtr, clientData)
|
3839 |
Tcl_Interp *interp; /* The interpreter in which to execute the
|
3840 |
* function. */
|
3841 |
ExecEnv *eePtr; /* Points to the environment for executing
|
3842 |
* the function. */
|
3843 |
ClientData clientData; /* Ignored. */
|
3844 |
{
|
3845 |
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
|
3846 |
register int stackTop; /* Cached top index of evaluation stack. */
|
3847 |
Interp *iPtr = (Interp *) interp;
|
3848 |
double dResult;
|
3849 |
int tmp;
|
3850 |
|
3851 |
if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
|
3852 |
iPtr->flags |= RAND_SEED_INITIALIZED;
|
3853 |
iPtr->randSeed = TclpGetClicks();
|
3854 |
}
|
3855 |
|
3856 |
/*
|
3857 |
* Set stackPtr and stackTop from eePtr.
|
3858 |
*/
|
3859 |
|
3860 |
CACHE_STACK_INFO();
|
3861 |
|
3862 |
/*
|
3863 |
* Generate the random number using the linear congruential
|
3864 |
* generator defined by the following recurrence:
|
3865 |
* seed = ( IA * seed ) mod IM
|
3866 |
* where IA is 16807 and IM is (2^31) - 1. In order to avoid
|
3867 |
* potential problems with integer overflow, the code uses
|
3868 |
* additional constants IQ and IR such that
|
3869 |
* IM = IA*IQ + IR
|
3870 |
* For details on how this algorithm works, refer to the following
|
3871 |
* papers:
|
3872 |
*
|
3873 |
* S.K. Park & K.W. Miller, "Random number generators: good ones
|
3874 |
* are hard to find," Comm ACM 31(10):1192-1201, Oct 1988
|
3875 |
*
|
3876 |
* W.H. Press & S.A. Teukolsky, "Portable random number
|
3877 |
* generators," Computers in Physics 6(5):522-524, Sep/Oct 1992.
|
3878 |
*/
|
3879 |
|
3880 |
#define RAND_IA 16807
|
3881 |
#define RAND_IM 2147483647
|
3882 |
#define RAND_IQ 127773
|
3883 |
#define RAND_IR 2836
|
3884 |
#define RAND_MASK 123459876
|
3885 |
|
3886 |
if (iPtr->randSeed == 0) {
|
3887 |
/*
|
3888 |
* Don't allow a 0 seed, since it breaks the generator. Shift
|
3889 |
* it to some other value.
|
3890 |
*/
|
3891 |
|
3892 |
iPtr->randSeed = 123459876;
|
3893 |
}
|
3894 |
tmp = iPtr->randSeed/RAND_IQ;
|
3895 |
iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp;
|
3896 |
if (iPtr->randSeed < 0) {
|
3897 |
iPtr->randSeed += RAND_IM;
|
3898 |
}
|
3899 |
|
3900 |
/*
|
3901 |
* On 64-bit architectures we need to mask off the upper bits to
|
3902 |
* ensure we only have a 32-bit range. The constant has the
|
3903 |
* bizarre form below in order to make sure that it doesn't
|
3904 |
* get sign-extended (the rules for sign extension are very
|
3905 |
* concat, particularly on 64-bit machines).
|
3906 |
*/
|
3907 |
|
3908 |
iPtr->randSeed &= ((((unsigned long) 0xfffffff) << 4) | 0xf);
|
3909 |
dResult = iPtr->randSeed * (1.0/RAND_IM);
|
3910 |
|
3911 |
/*
|
3912 |
* Push a Tcl object with the result.
|
3913 |
*/
|
3914 |
|
3915 |
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
|
3916 |
|
3917 |
/*
|
3918 |
* Reflect the change to stackTop back in eePtr.
|
3919 |
*/
|
3920 |
|
3921 |
DECACHE_STACK_INFO();
|
3922 |
return TCL_OK;
|
3923 |
}
|
3924 |
|
3925 |
static int
|
3926 |
ExprRoundFunc(interp, eePtr, clientData)
|
3927 |
Tcl_Interp *interp; /* The interpreter in which to execute the
|
3928 |
* function. */
|
3929 |
ExecEnv *eePtr; /* Points to the environment for executing
|
3930 |
* the function. */
|
3931 |
ClientData clientData; /* Ignored. */
|
3932 |
{
|
3933 |
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
|
3934 |
register int stackTop; /* Cached top index of evaluation stack. */
|
3935 |
Tcl_Obj *valuePtr;
|
3936 |
long iResult;
|
3937 |
double d, temp;
|
3938 |
int result;
|
3939 |
|
3940 |
/*
|
3941 |
* Set stackPtr and stackTop from eePtr.
|
3942 |
*/
|
3943 |
|
3944 |
result = TCL_OK;
|
3945 |
CACHE_STACK_INFO();
|
3946 |
|
3947 |
/*
|
3948 |
* Pop the argument from the evaluation stack.
|
3949 |
*/
|
3950 |
|
3951 |
valuePtr = POP_OBJECT();
|
3952 |
|
3953 |
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
|
3954 |
result = TCL_ERROR;
|
3955 |
goto done;
|
3956 |
}
|
3957 |
|
3958 |
if (valuePtr->typePtr == &tclIntType) {
|
3959 |
iResult = valuePtr->internalRep.longValue;
|
3960 |
} else {
|
3961 |
d = valuePtr->internalRep.doubleValue;
|
3962 |
if (d < 0.0) {
|
3963 |
if (d <= (((double) (long) LONG_MIN) - 0.5)) {
|
3964 |
tooLarge:
|
3965 |
Tcl_ResetResult(interp);
|
3966 |
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
3967 |
"integer value too large to represent", -1);
|
3968 |
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
|
3969 |
"integer value too large to represent",
|
3970 |
(char *) NULL);
|
3971 |
result = TCL_ERROR;
|
3972 |
goto done;
|
3973 |
}
|
3974 |
temp = (long) (d - 0.5);
|
3975 |
} else {
|
3976 |
if (d >= (((double) LONG_MAX + 0.5))) {
|
3977 |
goto tooLarge;
|
3978 |
}
|
3979 |
temp = (long) (d + 0.5);
|
3980 |
}
|
3981 |
if (IS_NAN(temp) || IS_INF(temp)) {
|
3982 |
TclExprFloatError(interp, temp);
|
3983 |
result = TCL_ERROR;
|
3984 |
goto done;
|
3985 |
}
|
3986 |
iResult = (long) temp;
|
3987 |
}
|
3988 |
|
3989 |
/*
|
3990 |
* Push a Tcl object with the result.
|
3991 |
*/
|
3992 |
|
3993 |
PUSH_OBJECT(Tcl_NewLongObj(iResult));
|
3994 |
|
3995 |
/*
|
3996 |
* Reflect the change to stackTop back in eePtr.
|
3997 |
*/
|
3998 |
|
3999 |
done:
|
4000 |
Tcl_DecrRefCount(valuePtr);
|
4001 |
DECACHE_STACK_INFO();
|
4002 |
return result;
|
4003 |
}
|
4004 |
|
4005 |
static int
|
4006 |
ExprSrandFunc(interp, eePtr, clientData)
|
4007 |
Tcl_Interp *interp; /* The interpreter in which to execute the
|
4008 |
* function. */
|
4009 |
ExecEnv *eePtr; /* Points to the environment for executing
|
4010 |
* the function. */
|
4011 |
ClientData clientData; /* Ignored. */
|
4012 |
{
|
4013 |
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
|
4014 |
register int stackTop; /* Cached top index of evaluation stack. */
|
4015 |
Interp *iPtr = (Interp *) interp;
|
4016 |
Tcl_Obj *valuePtr;
|
4017 |
long i = 0; /* Initialized to avoid compiler warning. */
|
4018 |
int result;
|
4019 |
|
4020 |
/*
|
4021 |
* Set stackPtr and stackTop from eePtr.
|
4022 |
*/
|
4023 |
|
4024 |
CACHE_STACK_INFO();
|
4025 |
|
4026 |
/*
|
4027 |
* Pop the argument from the evaluation stack. Use the value
|
4028 |
* to reset the random number seed.
|
4029 |
*/
|
4030 |
|
4031 |
valuePtr = POP_OBJECT();
|
4032 |
|
4033 |
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
|
4034 |
result = TCL_ERROR;
|
4035 |
goto badValue;
|
4036 |
}
|
4037 |
|
4038 |
if (valuePtr->typePtr == &tclIntType) {
|
4039 |
i = valuePtr->internalRep.longValue;
|
4040 |
} else {
|
4041 |
/*
|
4042 |
* At this point, the only other possible type is double
|
4043 |
*/
|
4044 |
Tcl_ResetResult(interp);
|
4045 |
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
4046 |
"can't use floating-point value as argument to srand",
|
4047 |
(char *) NULL);
|
4048 |
badValue:
|
4049 |
Tcl_DecrRefCount(valuePtr);
|
4050 |
DECACHE_STACK_INFO();
|
4051 |
return TCL_ERROR;
|
4052 |
}
|
4053 |
|
4054 |
/*
|
4055 |
* Reset the seed.
|
4056 |
*/
|
4057 |
|
4058 |
iPtr->flags |= RAND_SEED_INITIALIZED;
|
4059 |
iPtr->randSeed = i;
|
4060 |
|
4061 |
/*
|
4062 |
* To avoid duplicating the random number generation code we simply
|
4063 |
* clean up our state and call the real random number function. That
|
4064 |
* function will always succeed.
|
4065 |
*/
|
4066 |
|
4067 |
Tcl_DecrRefCount(valuePtr);
|
4068 |
DECACHE_STACK_INFO();
|
4069 |
|
4070 |
ExprRandFunc(interp, eePtr, clientData);
|
4071 |
return TCL_OK;
|
4072 |
}
|
4073 |
|
4074 |
/*
|
4075 |
*----------------------------------------------------------------------
|
4076 |
*
|
4077 |
* ExprCallMathFunc --
|
4078 |
*
|
4079 |
* This procedure is invoked to call a non-builtin math function
|
4080 |
* during the execution of an expression.
|
4081 |
*
|
4082 |
* Results:
|
4083 |
* TCL_OK is returned if all went well and the function's value
|
4084 |
* was computed successfully. If an error occurred, TCL_ERROR
|
4085 |
* is returned and an error message is left in the interpreter's
|
4086 |
* result. After a successful return this procedure pushes a Tcl object
|
4087 |
* holding the result.
|
4088 |
*
|
4089 |
* Side effects:
|
4090 |
* None, unless the called math function has side effects.
|
4091 |
*
|
4092 |
*----------------------------------------------------------------------
|
4093 |
*/
|
4094 |
|
4095 |
static int
|
4096 |
ExprCallMathFunc(interp, eePtr, objc, objv)
|
4097 |
Tcl_Interp *interp; /* The interpreter in which to execute the
|
4098 |
* function. */
|
4099 |
ExecEnv *eePtr; /* Points to the environment for executing
|
4100 |
* the function. */
|
4101 |
int objc; /* Number of arguments. The function name is
|
4102 |
* the 0-th argument. */
|
4103 |
Tcl_Obj **objv; /* The array of arguments. The function name
|
4104 |
* is objv[0]. */
|
4105 |
{
|
4106 |
Interp *iPtr = (Interp *) interp;
|
4107 |
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
|
4108 |
register int stackTop; /* Cached top index of evaluation stack. */
|
4109 |
char *funcName;
|
4110 |
Tcl_HashEntry *hPtr;
|
4111 |
MathFunc *mathFuncPtr; /* Information about math function. */
|
4112 |
Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */
|
4113 |
Tcl_Value funcResult; /* Result of function call as Tcl_Value. */
|
4114 |
register Tcl_Obj *valuePtr;
|
4115 |
long i;
|
4116 |
double d;
|
4117 |
int j, k, result;
|
4118 |
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
4119 |
|
4120 |
Tcl_ResetResult(interp);
|
4121 |
|
4122 |
/*
|
4123 |
* Set stackPtr and stackTop from eePtr.
|
4124 |
*/
|
4125 |
|
4126 |
CACHE_STACK_INFO();
|
4127 |
|
4128 |
/*
|
4129 |
* Look up the MathFunc record for the function.
|
4130 |
*/
|
4131 |
|
4132 |
funcName = Tcl_GetString(objv[0]);
|
4133 |
hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
|
4134 |
if (hPtr == NULL) {
|
4135 |
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
4136 |
"unknown math function \"", funcName, "\"", (char *) NULL);
|
4137 |
result = TCL_ERROR;
|
4138 |
goto done;
|
4139 |
}
|
4140 |
mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
|
4141 |
if (mathFuncPtr->numArgs != (objc-1)) {
|
4142 |
panic("ExprCallMathFunc: expected number of args %d != actual number %d",
|
4143 |
mathFuncPtr->numArgs, objc);
|
4144 |
result = TCL_ERROR;
|
4145 |
goto done;
|
4146 |
}
|
4147 |
|
4148 |
/*
|
4149 |
* Collect the arguments for the function, if there are any, into the
|
4150 |
* array "args". Note that args[0] will have the Tcl_Value that
|
4151 |
* corresponds to objv[1].
|
4152 |
*/
|
4153 |
|
4154 |
for (j = 1, k = 0; j < objc; j++, k++) {
|
4155 |
valuePtr = objv[j];
|
4156 |
|
4157 |
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
|
4158 |
result = TCL_ERROR;
|
4159 |
goto done;
|
4160 |
}
|
4161 |
|
4162 |
/*
|
4163 |
* Copy the object's numeric value to the argument record,
|
4164 |
* converting it if necessary.
|
4165 |
*/
|
4166 |
|
4167 |
if (valuePtr->typePtr == &tclIntType) {
|
4168 |
i = valuePtr->internalRep.longValue;
|
4169 |
if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
|
4170 |
args[k].type = TCL_DOUBLE;
|
4171 |
args[k].doubleValue = i;
|
4172 |
} else {
|
4173 |
args[k].type = TCL_INT;
|
4174 |
args[k].intValue = i;
|
4175 |
}
|
4176 |
} else {
|
4177 |
d = valuePtr->internalRep.doubleValue;
|
4178 |
if (mathFuncPtr->argTypes[k] == TCL_INT) {
|
4179 |
args[k].type = TCL_INT;
|
4180 |
args[k].intValue = (long) d;
|
4181 |
} else {
|
4182 |
args[k].type = TCL_DOUBLE;
|
4183 |
args[k].doubleValue = d;
|
4184 |
}
|
4185 |
}
|
4186 |
}
|
4187 |
|
4188 |
/*
|
4189 |
* Invoke the function and copy its result back into valuePtr.
|
4190 |
*/
|
4191 |
|
4192 |
tsdPtr->mathInProgress++;
|
4193 |
result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
|
4194 |
&funcResult);
|
4195 |
tsdPtr->mathInProgress--;
|
4196 |
if (result != TCL_OK) {
|
4197 |
goto done;
|
4198 |
}
|
4199 |
|
4200 |
/*
|
4201 |
* Pop the objc top stack elements and decrement their ref counts.
|
4202 |
*/
|
4203 |
|
4204 |
i = (stackTop - (objc-1));
|
4205 |
while (i <= stackTop) {
|
4206 |
valuePtr = stackPtr[i];
|
4207 |
Tcl_DecrRefCount(valuePtr);
|
4208 |
i++;
|
4209 |
}
|
4210 |
stackTop -= objc;
|
4211 |
|
4212 |
/*
|
4213 |
* Push the call's object result.
|
4214 |
*/
|
4215 |
|
4216 |
if (funcResult.type == TCL_INT) {
|
4217 |
PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue));
|
4218 |
} else {
|
4219 |
d = funcResult.doubleValue;
|
4220 |
if (IS_NAN(d) || IS_INF(d)) {
|
4221 |
TclExprFloatError(interp, d);
|
4222 |
result = TCL_ERROR;
|
4223 |
goto done;
|
4224 |
}
|
4225 |
PUSH_OBJECT(Tcl_NewDoubleObj(d));
|
4226 |
}
|
4227 |
|
4228 |
/*
|
4229 |
* Reflect the change to stackTop back in eePtr.
|
4230 |
*/
|
4231 |
|
4232 |
done:
|
4233 |
DECACHE_STACK_INFO();
|
4234 |
return result;
|
4235 |
}
|
4236 |
|
4237 |
/*
|
4238 |
*----------------------------------------------------------------------
|
4239 |
*
|
4240 |
* TclExprFloatError --
|
4241 |
*
|
4242 |
* This procedure is called when an error occurs during a
|
4243 |
* floating-point operation. It reads errno and sets
|
4244 |
* interp->objResultPtr accordingly.
|
4245 |
*
|
4246 |
* Results:
|
4247 |
* interp->objResultPtr is set to hold an error message.
|
4248 |
*
|
4249 |
* Side effects:
|
4250 |
* None.
|
4251 |
*
|
4252 |
*----------------------------------------------------------------------
|
4253 |
*/
|
4254 |
|
4255 |
void
|
4256 |
TclExprFloatError(interp, value)
|
4257 |
Tcl_Interp *interp; /* Where to store error message. */
|
4258 |
double value; /* Value returned after error; used to
|
4259 |
* distinguish underflows from overflows. */
|
4260 |
{
|
4261 |
char *s;
|
4262 |
|
4263 |
Tcl_ResetResult(interp);
|
4264 |
if ((errno == EDOM) || (value != value)) {
|
4265 |
s = "domain error: argument not in valid range";
|
4266 |
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
|
4267 |
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL);
|
4268 |
} else if ((errno == ERANGE) || IS_INF(value)) {
|
4269 |
if (value == 0.0) {
|
4270 |
s = "floating-point value too small to represent";
|
4271 |
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
|
4272 |
Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL);
|
4273 |
} else {
|
4274 |
s = "floating-point value too large to represent";
|
4275 |
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
|
4276 |
Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL);
|
4277 |
}
|
4278 |
} else {
|
4279 |
char msg[64 + TCL_INTEGER_SPACE];
|
4280 |
|
4281 |
sprintf(msg, "unknown floating-point error, errno = %d", errno);
|
4282 |
Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1);
|
4283 |
Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL);
|
4284 |
}
|
4285 |
}
|
4286 |
|
4287 |
/*
|
4288 |
*----------------------------------------------------------------------
|
4289 |
*
|
4290 |
* TclMathInProgress --
|
4291 |
*
|
4292 |
* This procedure is called to find out if Tcl is doing math
|
4293 |
* in this thread.
|
4294 |
*
|
4295 |
* Results:
|
4296 |
* 0 or 1.
|
4297 |
*
|
4298 |
* Side effects:
|
4299 |
* None.
|
4300 |
*
|
4301 |
*----------------------------------------------------------------------
|
4302 |
*/
|
4303 |
|
4304 |
int
|
4305 |
TclMathInProgress()
|
4306 |
{
|
4307 |
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
4308 |
return tsdPtr->mathInProgress;
|
4309 |
}
|
4310 |
|
4311 |
#ifdef TCL_COMPILE_STATS
|
4312 |
/*
|
4313 |
*----------------------------------------------------------------------
|
4314 |
*
|
4315 |
* TclLog2 --
|
4316 |
*
|
4317 |
* Procedure used while collecting compilation statistics to determine
|
4318 |
* the log base 2 of an integer.
|
4319 |
*
|
4320 |
* Results:
|
4321 |
* Returns the log base 2 of the operand. If the argument is less
|
4322 |
* than or equal to zero, a zero is returned.
|
4323 |
*
|
4324 |
* Side effects:
|
4325 |
* None.
|
4326 |
*
|
4327 |
*----------------------------------------------------------------------
|
4328 |
*/
|
4329 |
|
4330 |
int
|
4331 |
TclLog2(value)
|
4332 |
register int value; /* The integer for which to compute the
|
4333 |
* log base 2. */
|
4334 |
{
|
4335 |
register int n = value;
|
4336 |
register int result = 0;
|
4337 |
|
4338 |
while (n > 1) {
|
4339 |
n = n >> 1;
|
4340 |
result++;
|
4341 |
}
|
4342 |
return result;
|
4343 |
}
|
4344 |
|
4345 |
/*
|
4346 |
*----------------------------------------------------------------------
|
4347 |
*
|
4348 |
* EvalStatsCmd --
|
4349 |
*
|
4350 |
* Implements the "evalstats" command that prints instruction execution
|
4351 |
* counts to stdout.
|
4352 |
*
|
4353 |
* Results:
|
4354 |
* Standard Tcl results.
|
4355 |
*
|
4356 |
* Side effects:
|
4357 |
* None.
|
4358 |
*
|
4359 |
*----------------------------------------------------------------------
|
4360 |
*/
|
4361 |
|
4362 |
static int
|
4363 |
EvalStatsCmd(unused, interp, argc, argv)
|
4364 |
ClientData unused; /* Unused. */
|
4365 |
Tcl_Interp *interp; /* The current interpreter. */
|
4366 |
int argc; /* The number of arguments. */
|
4367 |
char **argv; /* The argument strings. */
|
4368 |
{
|
4369 |
Interp *iPtr = (Interp *) interp;
|
4370 |
LiteralTable *globalTablePtr = &(iPtr->literalTable);
|
4371 |
ByteCodeStats *statsPtr = &(iPtr->stats);
|
4372 |
double totalCodeBytes, currentCodeBytes;
|
4373 |
double totalLiteralBytes, currentLiteralBytes;
|
4374 |
double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
|
4375 |
double strBytesSharedMultX, strBytesSharedOnce;
|
4376 |
double numInstructions, currentHeaderBytes;
|
4377 |
long numCurrentByteCodes, numByteCodeLits;
|
4378 |
long refCountSum, literalMgmtBytes, sum;
|
4379 |
int numSharedMultX, numSharedOnce;
|
4380 |
int decadeHigh, minSizeDecade, maxSizeDecade, length, i;
|
4381 |
char *litTableStats;
|
4382 |
LiteralEntry *entryPtr;
|
4383 |
|
4384 |
numInstructions = 0.0;
|
4385 |
for (i = 0; i < 256; i++) {
|
4386 |
if (statsPtr->instructionCount[i] != 0) {
|
4387 |
numInstructions += statsPtr->instructionCount[i];
|
4388 |
}
|
4389 |
}
|
4390 |
|
4391 |
totalLiteralBytes = sizeof(LiteralTable)
|
4392 |
+ iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)
|
4393 |
+ (statsPtr->numLiteralsCreated * sizeof(LiteralEntry))
|
4394 |
+ (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj))
|
4395 |
+ statsPtr->totalLitStringBytes;
|
4396 |
totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes;
|
4397 |
|
4398 |
numCurrentByteCodes =
|
4399 |
statsPtr->numCompilations - statsPtr->numByteCodesFreed;
|
4400 |
currentHeaderBytes = numCurrentByteCodes
|
4401 |
* (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time)));
|
4402 |
literalMgmtBytes = sizeof(LiteralTable)
|
4403 |
+ (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *))
|
4404 |
+ (iPtr->literalTable.numEntries * sizeof(LiteralEntry));
|
4405 |
currentLiteralBytes = literalMgmtBytes
|
4406 |
+ iPtr->literalTable.numEntries * sizeof(Tcl_Obj)
|
4407 |
+ statsPtr->currentLitStringBytes;
|
4408 |
currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes;
|
4409 |
|
4410 |
/*
|
4411 |
* Summary statistics, total and current source and ByteCode sizes.
|
4412 |
*/
|
4413 |
|
4414 |
fprintf(stdout, "\n----------------------------------------------------------------\n");
|
4415 |
fprintf(stdout,
|
4416 |
"Compilation and execution statistics for interpreter 0x%x\n",
|
4417 |
(unsigned int) iPtr);
|
4418 |
|
4419 |
fprintf(stdout, "\nNumber ByteCodes executed %ld\n",
|
4420 |
statsPtr->numExecutions);
|
4421 |
fprintf(stdout, "Number ByteCodes compiled %ld\n",
|
4422 |
statsPtr->numCompilations);
|
4423 |
fprintf(stdout, " Mean executions/compile %.1f\n",
|
4424 |
((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations));
|
4425 |
|
4426 |
fprintf(stdout, "\nInstructions executed %.0f\n",
|
4427 |
numInstructions);
|
4428 |
fprintf(stdout, " Mean inst/compile %.0f\n",
|
4429 |
numInstructions / statsPtr->numCompilations);
|
4430 |
fprintf(stdout, " Mean inst/execution %.0f\n",
|
4431 |
numInstructions / statsPtr->numExecutions);
|
4432 |
|
4433 |
fprintf(stdout, "\nTotal ByteCodes %ld\n",
|
4434 |
statsPtr->numCompilations);
|
4435 |
fprintf(stdout, " Source bytes %.6g\n",
|
4436 |
statsPtr->totalSrcBytes);
|
4437 |
fprintf(stdout, " Code bytes %.6g\n",
|
4438 |
totalCodeBytes);
|
4439 |
fprintf(stdout, " ByteCode bytes %.6g\n",
|
4440 |
statsPtr->totalByteCodeBytes);
|
4441 |
fprintf(stdout, " Literal bytes %.6g\n",
|
4442 |
totalLiteralBytes);
|
4443 |
fprintf(stdout, " table %d + bkts %d + entries %ld + objects %ld + strings %.6g\n",
|
4444 |
sizeof(LiteralTable),
|
4445 |
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
|
4446 |
statsPtr->numLiteralsCreated * sizeof(LiteralEntry),
|
4447 |
statsPtr->numLiteralsCreated * sizeof(Tcl_Obj),
|
4448 |
statsPtr->totalLitStringBytes);
|
4449 |
fprintf(stdout, " Mean code/compile %.1f\n",
|
4450 |
totalCodeBytes / statsPtr->numCompilations);
|
4451 |
fprintf(stdout, " Mean code/source %.1f\n",
|
4452 |
totalCodeBytes / statsPtr->totalSrcBytes);
|
4453 |
|
4454 |
fprintf(stdout, "\nCurrent ByteCodes %ld\n",
|
4455 |
numCurrentByteCodes);
|
4456 |
fprintf(stdout, " Source bytes %.6g\n",
|
4457 |
statsPtr->currentSrcBytes);
|
4458 |
fprintf(stdout, " Code bytes %.6g\n",
|
4459 |
currentCodeBytes);
|
4460 |
fprintf(stdout, " ByteCode bytes %.6g\n",
|
4461 |
statsPtr->currentByteCodeBytes);
|
4462 |
fprintf(stdout, " Literal bytes %.6g\n",
|
4463 |
currentLiteralBytes);
|
4464 |
fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n",
|
4465 |
sizeof(LiteralTable),
|
4466 |
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
|
4467 |
iPtr->literalTable.numEntries * sizeof(LiteralEntry),
|
4468 |
iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
|
4469 |
statsPtr->currentLitStringBytes);
|
4470 |
fprintf(stdout, " Mean code/source %.1f\n",
|
4471 |
currentCodeBytes / statsPtr->currentSrcBytes);
|
4472 |
fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n",
|
4473 |
(currentCodeBytes + statsPtr->currentSrcBytes),
|
4474 |
(currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
|
4475 |
|
4476 |
/*
|
4477 |
* Literal table statistics.
|
4478 |
*/
|
4479 |
|
4480 |
numByteCodeLits = 0;
|
4481 |
refCountSum = 0;
|
4482 |
numSharedMultX = 0;
|
4483 |
numSharedOnce = 0;
|
4484 |
objBytesIfUnshared = 0.0;
|
4485 |
strBytesIfUnshared = 0.0;
|
4486 |
strBytesSharedMultX = 0.0;
|
4487 |
strBytesSharedOnce = 0.0;
|
4488 |
for (i = 0; i < globalTablePtr->numBuckets; i++) {
|
4489 |
for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
|
4490 |
entryPtr = entryPtr->nextPtr) {
|
4491 |
if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
|
4492 |
numByteCodeLits++;
|
4493 |
}
|
4494 |
(void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
|
4495 |
refCountSum += entryPtr->refCount;
|
4496 |
objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
|
4497 |
strBytesIfUnshared += (entryPtr->refCount * (length+1));
|
4498 |
if (entryPtr->refCount > 1) {
|
4499 |
numSharedMultX++;
|
4500 |
strBytesSharedMultX += (length+1);
|
4501 |
} else {
|
4502 |
numSharedOnce++;
|
4503 |
strBytesSharedOnce += (length+1);
|
4504 |
}
|
4505 |
}
|
4506 |
}
|
4507 |
sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
|
4508 |
- currentLiteralBytes;
|
4509 |
|
4510 |
fprintf(stdout, "\nTotal objects (all interps) %ld\n",
|
4511 |
tclObjsAlloced);
|
4512 |
fprintf(stdout, "Current objects %ld\n",
|
4513 |
(tclObjsAlloced - tclObjsFreed));
|
4514 |
fprintf(stdout, "Total literal objects %ld\n",
|
4515 |
statsPtr->numLiteralsCreated);
|
4516 |
|
4517 |
fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n",
|
4518 |
globalTablePtr->numEntries,
|
4519 |
(globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed));
|
4520 |
fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)\n",
|
4521 |
numByteCodeLits,
|
4522 |
(numByteCodeLits * 100.0) / globalTablePtr->numEntries);
|
4523 |
fprintf(stdout, " Literals reused > 1x %d\n",
|
4524 |
numSharedMultX);
|
4525 |
fprintf(stdout, " Mean reference count %.2f\n",
|
4526 |
((double) refCountSum) / globalTablePtr->numEntries);
|
4527 |
fprintf(stdout, " Mean len, str reused >1x %.2f\n",
|
4528 |
(numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0));
|
4529 |
fprintf(stdout, " Mean len, str used 1x %.2f\n",
|
4530 |
(numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0));
|
4531 |
fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n",
|
4532 |
sharingBytesSaved,
|
4533 |
(sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared));
|
4534 |
fprintf(stdout, " Bytes with sharing %.6g\n",
|
4535 |
currentLiteralBytes);
|
4536 |
fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n",
|
4537 |
sizeof(LiteralTable),
|
4538 |
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
|
4539 |
iPtr->literalTable.numEntries * sizeof(LiteralEntry),
|
4540 |
iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
|
4541 |
statsPtr->currentLitStringBytes);
|
4542 |
fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n",
|
4543 |
(objBytesIfUnshared + strBytesIfUnshared),
|
4544 |
objBytesIfUnshared, strBytesIfUnshared);
|
4545 |
fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6g\n",
|
4546 |
(strBytesIfUnshared - statsPtr->currentLitStringBytes),
|
4547 |
strBytesIfUnshared, statsPtr->currentLitStringBytes);
|
4548 |
fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n",
|
4549 |
literalMgmtBytes,
|
4550 |
(literalMgmtBytes * 100.0) / currentLiteralBytes);
|
4551 |
fprintf(stdout, " table %d + buckets %d + entries %d\n",
|
4552 |
sizeof(LiteralTable),
|
4553 |
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
|
4554 |
iPtr->literalTable.numEntries * sizeof(LiteralEntry));
|
4555 |
|
4556 |
/*
|
4557 |
* Breakdown of current ByteCode space requirements.
|
4558 |
*/
|
4559 |
|
4560 |
fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n");
|
4561 |
fprintf(stdout, " Bytes Pct of Avg per\n");
|
4562 |
fprintf(stdout, " total ByteCode\n");
|
4563 |
fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n",
|
4564 |
statsPtr->currentByteCodeBytes,
|
4565 |
statsPtr->currentByteCodeBytes / numCurrentByteCodes);
|
4566 |
fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n",
|
4567 |
currentHeaderBytes,
|
4568 |
((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes),
|
4569 |
currentHeaderBytes / numCurrentByteCodes);
|
4570 |
fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n",
|
4571 |
statsPtr->currentInstBytes,
|
4572 |
((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes),
|
4573 |
statsPtr->currentInstBytes / numCurrentByteCodes);
|
4574 |
fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n",
|
4575 |
statsPtr->currentLitBytes,
|
4576 |
((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes),
|
4577 |
statsPtr->currentLitBytes / numCurrentByteCodes);
|
4578 |
fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n",
|
4579 |
statsPtr->currentExceptBytes,
|
4580 |
((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes),
|
4581 |
statsPtr->currentExceptBytes / numCurrentByteCodes);
|
4582 |
fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n",
|
4583 |
statsPtr->currentAuxBytes,
|
4584 |
((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes),
|
4585 |
statsPtr->currentAuxBytes / numCurrentByteCodes);
|
4586 |
fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n",
|
4587 |
statsPtr->currentCmdMapBytes,
|
4588 |
((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes),
|
4589 |
statsPtr->currentCmdMapBytes / numCurrentByteCodes);
|
4590 |
|
4591 |
/*
|
4592 |
* Detailed literal statistics.
|
4593 |
*/
|
4594 |
|
4595 |
fprintf(stdout, "\nLiteral string sizes:\n");
|
4596 |
fprintf(stdout, " Up to length Percentage\n");
|
4597 |
maxSizeDecade = 0;
|
4598 |
for (i = 31; i >= 0; i--) {
|
4599 |
if (statsPtr->literalCount[i] > 0) {
|
4600 |
maxSizeDecade = i;
|
4601 |
break;
|
4602 |
}
|
4603 |
}
|
4604 |
sum = 0;
|
4605 |
for (i = 0; i <= maxSizeDecade; i++) {
|
4606 |
decadeHigh = (1 << (i+1)) - 1;
|
4607 |
sum += statsPtr->literalCount[i];
|
4608 |
fprintf(stdout, " %10d %8.0f%%\n",
|
4609 |
decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated);
|
4610 |
}
|
4611 |
|
4612 |
litTableStats = TclLiteralStats(globalTablePtr);
|
4613 |
fprintf(stdout, "\nCurrent literal table statistics:\n%s\n",
|
4614 |
litTableStats);
|
4615 |
ckfree((char *) litTableStats);
|
4616 |
|
4617 |
/*
|
4618 |
* Source and ByteCode size distributions.
|
4619 |
*/
|
4620 |
|
4621 |
fprintf(stdout, "\nSource sizes:\n");
|
4622 |
fprintf(stdout, " Up to size Percentage\n");
|
4623 |
minSizeDecade = maxSizeDecade = 0;
|
4624 |
for (i = 0; i < 31; i++) {
|
4625 |
if (statsPtr->srcCount[i] > 0) {
|
4626 |
minSizeDecade = i;
|
4627 |
break;
|
4628 |
}
|
4629 |
}
|
4630 |
for (i = 31; i >= 0; i--) {
|
4631 |
if (statsPtr->srcCount[i] > 0) {
|
4632 |
maxSizeDecade = i;
|
4633 |
break;
|
4634 |
}
|
4635 |
}
|
4636 |
sum = 0;
|
4637 |
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
|
4638 |
decadeHigh = (1 << (i+1)) - 1;
|
4639 |
sum += statsPtr->srcCount[i];
|
4640 |
fprintf(stdout, " %10d %8.0f%%\n",
|
4641 |
decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
|
4642 |
}
|
4643 |
|
4644 |
fprintf(stdout, "\nByteCode sizes:\n");
|
4645 |
fprintf(stdout, " Up to size Percentage\n");
|
4646 |
minSizeDecade = maxSizeDecade = 0;
|
4647 |
for (i = 0; i < 31; i++) {
|
4648 |
if (statsPtr->byteCodeCount[i] > 0) {
|
4649 |
minSizeDecade = i;
|
4650 |
break;
|
4651 |
}
|
4652 |
}
|
4653 |
for (i = 31; i >= 0; i--) {
|
4654 |
if (statsPtr->byteCodeCount[i] > 0) {
|
4655 |
maxSizeDecade = i;
|
4656 |
break;
|
4657 |
}
|
4658 |
}
|
4659 |
sum = 0;
|
4660 |
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
|
4661 |
decadeHigh = (1 << (i+1)) - 1;
|
4662 |
sum += statsPtr->byteCodeCount[i];
|
4663 |
fprintf(stdout, " %10d %8.0f%%\n",
|
4664 |
decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
|
4665 |
}
|
4666 |
|
4667 |
fprintf(stdout, "\nByteCode longevity (excludes current ByteCodes):\n");
|
4668 |
fprintf(stdout, " Up to ms Percentage\n");
|
4669 |
minSizeDecade = maxSizeDecade = 0;
|
4670 |
for (i = 0; i < 31; i++) {
|
4671 |
if (statsPtr->lifetimeCount[i] > 0) {
|
4672 |
minSizeDecade = i;
|
4673 |
break;
|
4674 |
}
|
4675 |
}
|
4676 |
for (i = 31; i >= 0; i--) {
|
4677 |
if (statsPtr->lifetimeCount[i] > 0) {
|
4678 |
maxSizeDecade = i;
|
4679 |
break;
|
4680 |
}
|
4681 |
}
|
4682 |
sum = 0;
|
4683 |
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
|
4684 |
decadeHigh = (1 << (i+1)) - 1;
|
4685 |
sum += statsPtr->lifetimeCount[i];
|
4686 |
fprintf(stdout, " %12.3f %8.0f%%\n",
|
4687 |
decadeHigh / 1000.0,
|
4688 |
(sum * 100.0) / statsPtr->numByteCodesFreed);
|
4689 |
}
|
4690 |
|
4691 |
/*
|
4692 |
* Instruction counts.
|
4693 |
*/
|
4694 |
|
4695 |
fprintf(stdout, "\nInstruction counts:\n");
|
4696 |
for (i = 0; i <= LAST_INST_OPCODE; i++) {
|
4697 |
if (statsPtr->instructionCount[i]) {
|
4698 |
fprintf(stdout, "%20s %8ld %6.1f%%\n",
|
4699 |
instructionTable[i].name,
|
4700 |
statsPtr->instructionCount[i],
|
4701 |
(statsPtr->instructionCount[i]*100.0) / numInstructions);
|
4702 |
}
|
4703 |
}
|
4704 |
|
4705 |
fprintf(stdout, "\nInstructions NEVER executed:\n");
|
4706 |
for (i = 0; i <= LAST_INST_OPCODE; i++) {
|
4707 |
if (statsPtr->instructionCount[i] == 0) {
|
4708 |
fprintf(stdout, "%20s\n",
|
4709 |
instructionTable[i].name);
|
4710 |
}
|
4711 |
}
|
4712 |
|
4713 |
#ifdef TCL_MEM_DEBUG
|
4714 |
fprintf(stdout, "\nHeap Statistics:\n");
|
4715 |
TclDumpMemoryInfo(stdout);
|
4716 |
#endif
|
4717 |
fprintf(stdout, "\n----------------------------------------------------------------\n");
|
4718 |
return TCL_OK;
|
4719 |
}
|
4720 |
#endif /* TCL_COMPILE_STATS */
|
4721 |
|
4722 |
/*
|
4723 |
*----------------------------------------------------------------------
|
4724 |
*
|
4725 |
* Tcl_GetCommandFromObj --
|
4726 |
*
|
4727 |
* Returns the command specified by the name in a Tcl_Obj.
|
4728 |
*
|
4729 |
* Results:
|
4730 |
* Returns a token for the command if it is found. Otherwise, if it
|
4731 |
* can't be found or there is an error, returns NULL.
|
4732 |
*
|
4733 |
* Side effects:
|
4734 |
* May update the internal representation for the object, caching
|
4735 |
* the command reference so that the next time this procedure is
|
4736 |
* called with the same object, the command can be found quickly.
|
4737 |
*
|
4738 |
*----------------------------------------------------------------------
|
4739 |
*/
|
4740 |
|
4741 |
Tcl_Command
|
4742 |
Tcl_GetCommandFromObj(interp, objPtr)
|
4743 |
Tcl_Interp *interp; /* The interpreter in which to resolve the
|
4744 |
* command and to report errors. */
|
4745 |
register Tcl_Obj *objPtr; /* The object containing the command's
|
4746 |
* name. If the name starts with "::", will
|
4747 |
* be looked up in global namespace. Else,
|
4748 |
* looked up first in the current namespace
|
4749 |
* if contextNsPtr is NULL, then in global
|
4750 |
* namespace. */
|
4751 |
{
|
4752 |
Interp *iPtr = (Interp *) interp;
|
4753 |
register ResolvedCmdName *resPtr;
|
4754 |
register Command *cmdPtr;
|
4755 |
Namespace *currNsPtr;
|
4756 |
int result;
|
4757 |
|
4758 |
/*
|
4759 |
* Get the internal representation, converting to a command type if
|
4760 |
* needed. The internal representation is a ResolvedCmdName that points
|
4761 |
* to the actual command.
|
4762 |
*/
|
4763 |
|
4764 |
if (objPtr->typePtr != &tclCmdNameType) {
|
4765 |
result = tclCmdNameType.setFromAnyProc(interp, objPtr);
|
4766 |
if (result != TCL_OK) {
|
4767 |
return (Tcl_Command) NULL;
|
4768 |
}
|
4769 |
}
|
4770 |
resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
|
4771 |
|
4772 |
/*
|
4773 |
* Get the current namespace.
|
4774 |
*/
|
4775 |
|
4776 |
if (iPtr->varFramePtr != NULL) {
|
4777 |
currNsPtr = iPtr->varFramePtr->nsPtr;
|
4778 |
} else {
|
4779 |
currNsPtr = iPtr->globalNsPtr;
|
4780 |
}
|
4781 |
|
4782 |
/*
|
4783 |
* Check the context namespace and the namespace epoch of the resolved
|
4784 |
* symbol to make sure that it is fresh. If not, then force another
|
4785 |
* conversion to the command type, to discard the old rep and create a
|
4786 |
* new one. Note that we verify that the namespace id of the context
|
4787 |
* namespace is the same as the one we cached; this insures that the
|
4788 |
* namespace wasn't deleted and a new one created at the same address
|
4789 |
* with the same command epoch.
|
4790 |
*/
|
4791 |
|
4792 |
cmdPtr = NULL;
|
4793 |
if ((resPtr != NULL)
|
4794 |
&& (resPtr->refNsPtr == currNsPtr)
|
4795 |
&& (resPtr->refNsId == currNsPtr->nsId)
|
4796 |
&& (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) {
|
4797 |
cmdPtr = resPtr->cmdPtr;
|
4798 |
if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) {
|
4799 |
cmdPtr = NULL;
|
4800 |
}
|
4801 |
}
|
4802 |
|
4803 |
if (cmdPtr == NULL) {
|
4804 |
result = tclCmdNameType.setFromAnyProc(interp, objPtr);
|
4805 |
if (result != TCL_OK) {
|
4806 |
return (Tcl_Command) NULL;
|
4807 |
}
|
4808 |
resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
|
4809 |
if (resPtr != NULL) {
|
4810 |
cmdPtr = resPtr->cmdPtr;
|
4811 |
}
|
4812 |
}
|
4813 |
return (Tcl_Command) cmdPtr;
|
4814 |
}
|
4815 |
|
4816 |
/*
|
4817 |
*----------------------------------------------------------------------
|
4818 |
*
|
4819 |
* TclSetCmdNameObj --
|
4820 |
*
|
4821 |
* Modify an object to be an CmdName object that refers to the argument
|
4822 |
* Command structure.
|
4823 |
*
|
4824 |
* Results:
|
4825 |
* None.
|
4826 |
*
|
4827 |
* Side effects:
|
4828 |
* The object's old internal rep is freed. It's string rep is not
|
4829 |
* changed. The refcount in the Command structure is incremented to
|
4830 |
* keep it from being freed if the command is later deleted until
|
4831 |
* TclExecuteByteCode has a chance to recognize that it was deleted.
|
4832 |
*
|
4833 |
*----------------------------------------------------------------------
|
4834 |
*/
|
4835 |
|
4836 |
void
|
4837 |
TclSetCmdNameObj(interp, objPtr, cmdPtr)
|
4838 |
Tcl_Interp *interp; /* Points to interpreter containing command
|
4839 |
* that should be cached in objPtr. */
|
4840 |
register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to
|
4841 |
* a CmdName object. */
|
4842 |
Command *cmdPtr; /* Points to Command structure that the
|
4843 |
* CmdName object should refer to. */
|
4844 |
{
|
4845 |
Interp *iPtr = (Interp *) interp;
|
4846 |
register ResolvedCmdName *resPtr;
|
4847 |
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
4848 |
register Namespace *currNsPtr;
|
4849 |
|
4850 |
if (oldTypePtr == &tclCmdNameType) {
|
4851 |
return;
|
4852 |
}
|
4853 |
|
4854 |
/*
|
4855 |
* Get the current namespace.
|
4856 |
*/
|
4857 |
|
4858 |
if (iPtr->varFramePtr != NULL) {
|
4859 |
currNsPtr = iPtr->varFramePtr->nsPtr;
|
4860 |
} else {
|
4861 |
currNsPtr = iPtr->globalNsPtr;
|
4862 |
}
|
4863 |
|
4864 |
cmdPtr->refCount++;
|
4865 |
resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
|
4866 |
resPtr->cmdPtr = cmdPtr;
|
4867 |
resPtr->refNsPtr = currNsPtr;
|
4868 |
resPtr->refNsId = currNsPtr->nsId;
|
4869 |
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
|
4870 |
resPtr->cmdEpoch = cmdPtr->cmdEpoch;
|
4871 |
resPtr->refCount = 1;
|
4872 |
|
4873 |
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
4874 |
oldTypePtr->freeIntRepProc(objPtr);
|
4875 |
}
|
4876 |
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
|
4877 |
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
|
4878 |
objPtr->typePtr = &tclCmdNameType;
|
4879 |
}
|
4880 |
|
4881 |
/*
|
4882 |
*----------------------------------------------------------------------
|
4883 |
*
|
4884 |
* FreeCmdNameInternalRep --
|
4885 |
*
|
4886 |
* Frees the resources associated with a cmdName object's internal
|
4887 |
* representation.
|
4888 |
*
|
4889 |
* Results:
|
4890 |
* None.
|
4891 |
*
|
4892 |
* Side effects:
|
4893 |
* Decrements the ref count of any cached ResolvedCmdName structure
|
4894 |
* pointed to by the cmdName's internal representation. If this is
|
4895 |
* the last use of the ResolvedCmdName, it is freed. This in turn
|
4896 |
* decrements the ref count of the Command structure pointed to by
|
4897 |
* the ResolvedSymbol, which may free the Command structure.
|
4898 |
*
|
4899 |
*----------------------------------------------------------------------
|
4900 |
*/
|
4901 |
|
4902 |
static void
|
4903 |
FreeCmdNameInternalRep(objPtr)
|
4904 |
register Tcl_Obj *objPtr; /* CmdName object with internal
|
4905 |
* representation to free. */
|
4906 |
{
|
4907 |
register ResolvedCmdName *resPtr =
|
4908 |
(ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
|
4909 |
|
4910 |
if (resPtr != NULL) {
|
4911 |
/*
|
4912 |
* Decrement the reference count of the ResolvedCmdName structure.
|
4913 |
* If there are no more uses, free the ResolvedCmdName structure.
|
4914 |
*/
|
4915 |
|
4916 |
resPtr->refCount--;
|
4917 |
if (resPtr->refCount == 0) {
|
4918 |
/*
|
4919 |
* Now free the cached command, unless it is still in its
|
4920 |
* hash table or if there are other references to it
|
4921 |
* from other cmdName objects.
|
4922 |
*/
|
4923 |
|
4924 |
Command *cmdPtr = resPtr->cmdPtr;
|
4925 |
TclCleanupCommand(cmdPtr);
|
4926 |
ckfree((char *) resPtr);
|
4927 |
}
|
4928 |
}
|
4929 |
}
|
4930 |
|
4931 |
/*
|
4932 |
*----------------------------------------------------------------------
|
4933 |
*
|
4934 |
* DupCmdNameInternalRep --
|
4935 |
*
|
4936 |
* Initialize the internal representation of an cmdName Tcl_Obj to a
|
4937 |
* copy of the internal representation of an existing cmdName object.
|
4938 |
*
|
4939 |
* Results:
|
4940 |
* None.
|
4941 |
*
|
4942 |
* Side effects:
|
4943 |
* "copyPtr"s internal rep is set to point to the ResolvedCmdName
|
4944 |
* structure corresponding to "srcPtr"s internal rep. Increments the
|
4945 |
* ref count of the ResolvedCmdName structure pointed to by the
|
4946 |
* cmdName's internal representation.
|
4947 |
*
|
4948 |
*----------------------------------------------------------------------
|
4949 |
*/
|
4950 |
|
4951 |
static void
|
4952 |
DupCmdNameInternalRep(srcPtr, copyPtr)
|
4953 |
Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
|
4954 |
register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
|
4955 |
{
|
4956 |
register ResolvedCmdName *resPtr =
|
4957 |
(ResolvedCmdName *) srcPtr->internalRep.otherValuePtr;
|
4958 |
|
4959 |
copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
|
4960 |
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
|
4961 |
if (resPtr != NULL) {
|
4962 |
resPtr->refCount++;
|
4963 |
}
|
4964 |
copyPtr->typePtr = &tclCmdNameType;
|
4965 |
}
|
4966 |
|
4967 |
/*
|
4968 |
*----------------------------------------------------------------------
|
4969 |
*
|
4970 |
* SetCmdNameFromAny --
|
4971 |
*
|
4972 |
* Generate an cmdName internal form for the Tcl object "objPtr".
|
4973 |
*
|
4974 |
* Results:
|
4975 |
* The return value is a standard Tcl result. The conversion always
|
4976 |
* succeeds and TCL_OK is returned.
|
4977 |
*
|
4978 |
* Side effects:
|
4979 |
* A pointer to a ResolvedCmdName structure that holds a cached pointer
|
4980 |
* to the command with a name that matches objPtr's string rep is
|
4981 |
* stored as objPtr's internal representation. This ResolvedCmdName
|
4982 |
* pointer will be NULL if no matching command was found. The ref count
|
4983 |
* of the cached Command's structure (if any) is also incremented.
|
4984 |
*
|
4985 |
*----------------------------------------------------------------------
|
4986 |
*/
|
4987 |
|
4988 |
static int
|
4989 |
SetCmdNameFromAny(interp, objPtr)
|
4990 |
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
4991 |
register Tcl_Obj *objPtr; /* The object to convert. */
|
4992 |
{
|
4993 |
Interp *iPtr = (Interp *) interp;
|
4994 |
char *name;
|
4995 |
Tcl_Command cmd;
|
4996 |
register Command *cmdPtr;
|
4997 |
Namespace *currNsPtr;
|
4998 |
register ResolvedCmdName *resPtr;
|
4999 |
|
5000 |
/*
|
5001 |
* Get "objPtr"s string representation. Make it up-to-date if necessary.
|
5002 |
*/
|
5003 |
|
5004 |
name = objPtr->bytes;
|
5005 |
if (name == NULL) {
|
5006 |
name = Tcl_GetString(objPtr);
|
5007 |
}
|
5008 |
|
5009 |
/*
|
5010 |
* Find the Command structure, if any, that describes the command called
|
5011 |
* "name". Build a ResolvedCmdName that holds a cached pointer to this
|
5012 |
* Command, and bump the reference count in the referenced Command
|
5013 |
* structure. A Command structure will not be deleted as long as it is
|
5014 |
* referenced from a CmdName object.
|
5015 |
*/
|
5016 |
|
5017 |
cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL,
|
5018 |
/*flags*/ 0);
|
5019 |
cmdPtr = (Command *) cmd;
|
5020 |
if (cmdPtr != NULL) {
|
5021 |
/*
|
5022 |
* Get the current namespace.
|
5023 |
*/
|
5024 |
|
5025 |
if (iPtr->varFramePtr != NULL) {
|
5026 |
currNsPtr = iPtr->varFramePtr->nsPtr;
|
5027 |
} else {
|
5028 |
currNsPtr = iPtr->globalNsPtr;
|
5029 |
}
|
5030 |
|
5031 |
cmdPtr->refCount++;
|
5032 |
resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
|
5033 |
resPtr->cmdPtr = cmdPtr;
|
5034 |
resPtr->refNsPtr = currNsPtr;
|
5035 |
resPtr->refNsId = currNsPtr->nsId;
|
5036 |
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
|
5037 |
resPtr->cmdEpoch = cmdPtr->cmdEpoch;
|
5038 |
resPtr->refCount = 1;
|
5039 |
} else {
|
5040 |
resPtr = NULL; /* no command named "name" was found */
|
5041 |
}
|
5042 |
|
5043 |
/*
|
5044 |
* Free the old internalRep before setting the new one. We do this as
|
5045 |
* late as possible to allow the conversion code, in particular
|
5046 |
* GetStringFromObj, to use that old internalRep. If no Command
|
5047 |
* structure was found, leave NULL as the cached value.
|
5048 |
*/
|
5049 |
|
5050 |
if ((objPtr->typePtr != NULL)
|
5051 |
&& (objPtr->typePtr->freeIntRepProc != NULL)) {
|
5052 |
objPtr->typePtr->freeIntRepProc(objPtr);
|
5053 |
}
|
5054 |
|
5055 |
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
|
5056 |
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
|
5057 |
objPtr->typePtr = &tclCmdNameType;
|
5058 |
return TCL_OK;
|
5059 |
}
|
5060 |
|
5061 |
#ifdef TCL_COMPILE_DEBUG
|
5062 |
/*
|
5063 |
*----------------------------------------------------------------------
|
5064 |
*
|
5065 |
* StringForResultCode --
|
5066 |
*
|
5067 |
* Procedure that returns a human-readable string representing a
|
5068 |
* Tcl result code such as TCL_ERROR.
|
5069 |
*
|
5070 |
* Results:
|
5071 |
* If the result code is one of the standard Tcl return codes, the
|
5072 |
* result is a string representing that code such as "TCL_ERROR".
|
5073 |
* Otherwise, the result string is that code formatted as a
|
5074 |
* sequence of decimal digit characters. Note that the resulting
|
5075 |
* string must not be modified by the caller.
|
5076 |
*
|
5077 |
* Side effects:
|
5078 |
* None.
|
5079 |
*
|
5080 |
*----------------------------------------------------------------------
|
5081 |
*/
|
5082 |
|
5083 |
static char *
|
5084 |
StringForResultCode(result)
|
5085 |
int result; /* The Tcl result code for which to
|
5086 |
* generate a string. */
|
5087 |
{
|
5088 |
static char buf[TCL_INTEGER_SPACE];
|
5089 |
|
5090 |
if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
|
5091 |
return resultStrings[result];
|
5092 |
}
|
5093 |
TclFormatInt(buf, result);
|
5094 |
return buf;
|
5095 |
}
|
5096 |
#endif /* TCL_COMPILE_DEBUG */
|
5097 |
|
5098 |
|
5099 |
/* $History: tclexecute.c $
|
5100 |
*
|
5101 |
* ***************** Version 1 *****************
|
5102 |
* User: Dtashley Date: 1/02/01 Time: 1:31a
|
5103 |
* Created in $/IjuScripter, IjuConsole/Source/Tcl Base
|
5104 |
* Initial check-in.
|
5105 |
*/
|
5106 |
|
5107 |
/* End of TCLEXECUTE.C */ |