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