Fork me on GitHub

source: git/external/tcl/tclCompExpr.c@ d3165fa

Last change on this file since d3165fa was adeddd8, checked in by Pavel Demin <pavel-demin@…>, 5 years ago

remove debug code from Tcl

  • Property mode set to 100644
File size: 66.3 KB
Line 
1/*
2 * tclCompExpr.c --
3 *
4 * This file contains the code to compile Tcl expressions.
5 *
6 * Copyright (c) 1996-1997 Sun Microsystems, Inc.
7 *
8 * See the file "license.terms" for information on usage and redistribution
9 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
10 *
11 * RCS: @(#) $Id: tclCompExpr.c,v 1.1 2008-06-04 13:58:05 demin Exp $
12 */
13
14#include "tclInt.h"
15#include "tclCompile.h"
16
17/*
18 * The stuff below is a bit of a hack so that this file can be used in
19 * environments that include no UNIX, i.e. no errno: just arrange to use
20 * the errno from tclExecute.c here.
21 */
22
23#ifndef TCL_GENERIC_ONLY
24#include "tclPort.h"
25#else
26#define NO_ERRNO_H
27#endif
28
29#ifdef NO_ERRNO_H
30extern int errno; /* Use errno from tclExecute.c. */
31#define ERANGE 34
32#endif
33
34/*
35 * The ExprInfo structure describes the state of compiling an expression.
36 * A pointer to an ExprInfo record is passed among the routines in
37 * this module.
38 */
39
40typedef struct ExprInfo {
41 int token; /* Type of the last token parsed in expr.
42 * See below for definitions. Corresponds
43 * to the characters just before next. */
44 int objIndex; /* If token is a literal value, the index of
45 * an object holding the value in the code's
46 * object table; otherwise is NULL. */
47 char *funcName; /* If the token is FUNC_NAME, points to the
48 * first character of the math function's
49 * name; otherwise is NULL. */
50 char *next; /* Position of the next character to be
51 * scanned in the expression string. */
52 char *originalExpr; /* The entire expression that was originally
53 * passed to Tcl_ExprString et al. */
54 char *lastChar; /* Pointer to terminating null in
55 * originalExpr. */
56 int hasOperators; /* Set 1 if the expr has operators; 0 if
57 * expr is only a primary. If 1 after
58 * compiling an expr, a tryCvtToNumeric
59 * instruction is emitted to convert the
60 * primary to a number if possible. */
61 int exprIsJustVarRef; /* Set 1 if the expr consists of just a
62 * variable reference as in the expression
63 * of "if $b then...". Otherwise 0. If 1 the
64 * expr is compiled out-of-line in order to
65 * implement expr's 2 level substitution
66 * semantics properly. */
67 int exprIsComparison; /* Set 1 if the top-level operator in the
68 * expr is a comparison. Otherwise 0. If 1,
69 * because the operands might be strings,
70 * the expr is compiled out-of-line in order
71 * to implement expr's 2 level substitution
72 * semantics properly. */
73} ExprInfo;
74
75/*
76 * Definitions of the different tokens that appear in expressions. The order
77 * of these must match the corresponding entries in the operatorStrings
78 * array below.
79 */
80
81#define LITERAL 0
82#define FUNC_NAME (LITERAL + 1)
83#define OPEN_BRACKET (LITERAL + 2)
84#define CLOSE_BRACKET (LITERAL + 3)
85#define OPEN_PAREN (LITERAL + 4)
86#define CLOSE_PAREN (LITERAL + 5)
87#define DOLLAR (LITERAL + 6)
88#define QUOTE (LITERAL + 7)
89#define COMMA (LITERAL + 8)
90#define END (LITERAL + 9)
91#define UNKNOWN (LITERAL + 10)
92
93/*
94 * Binary operators:
95 */
96
97#define MULT (UNKNOWN + 1)
98#define DIVIDE (MULT + 1)
99#define MOD (MULT + 2)
100#define PLUS (MULT + 3)
101#define MINUS (MULT + 4)
102#define LEFT_SHIFT (MULT + 5)
103#define RIGHT_SHIFT (MULT + 6)
104#define LESS (MULT + 7)
105#define GREATER (MULT + 8)
106#define LEQ (MULT + 9)
107#define GEQ (MULT + 10)
108#define EQUAL (MULT + 11)
109#define NEQ (MULT + 12)
110#define BIT_AND (MULT + 13)
111#define BIT_XOR (MULT + 14)
112#define BIT_OR (MULT + 15)
113#define AND (MULT + 16)
114#define OR (MULT + 17)
115#define QUESTY (MULT + 18)
116#define COLON (MULT + 19)
117
118/*
119 * Unary operators. Unary minus and plus are represented by the (binary)
120 * tokens MINUS and PLUS.
121 */
122
123#define NOT (COLON + 1)
124#define BIT_NOT (NOT + 1)
125
126/*
127 * Declarations for local procedures to this file:
128 */
129
130static int CompileAddExpr _ANSI_ARGS_((Tcl_Interp *interp,
131 ExprInfo *infoPtr, int flags,
132 CompileEnv *envPtr));
133static int CompileBitAndExpr _ANSI_ARGS_((Tcl_Interp *interp,
134 ExprInfo *infoPtr, int flags,
135 CompileEnv *envPtr));
136static int CompileBitOrExpr _ANSI_ARGS_((Tcl_Interp *interp,
137 ExprInfo *infoPtr, int flags,
138 CompileEnv *envPtr));
139static int CompileBitXorExpr _ANSI_ARGS_((Tcl_Interp *interp,
140 ExprInfo *infoPtr, int flags,
141 CompileEnv *envPtr));
142static int CompileCondExpr _ANSI_ARGS_((Tcl_Interp *interp,
143 ExprInfo *infoPtr, int flags,
144 CompileEnv *envPtr));
145static int CompileEqualityExpr _ANSI_ARGS_((Tcl_Interp *interp,
146 ExprInfo *infoPtr, int flags,
147 CompileEnv *envPtr));
148static int CompileLandExpr _ANSI_ARGS_((Tcl_Interp *interp,
149 ExprInfo *infoPtr, int flags,
150 CompileEnv *envPtr));
151static int CompileLorExpr _ANSI_ARGS_((Tcl_Interp *interp,
152 ExprInfo *infoPtr, int flags,
153 CompileEnv *envPtr));
154static int CompileMathFuncCall _ANSI_ARGS_((Tcl_Interp *interp,
155 ExprInfo *infoPtr, int flags,
156 CompileEnv *envPtr));
157static int CompileMultiplyExpr _ANSI_ARGS_((Tcl_Interp *interp,
158 ExprInfo *infoPtr, int flags,
159 CompileEnv *envPtr));
160static int CompilePrimaryExpr _ANSI_ARGS_((Tcl_Interp *interp,
161 ExprInfo *infoPtr, int flags,
162 CompileEnv *envPtr));
163static int CompileRelationalExpr _ANSI_ARGS_((
164 Tcl_Interp *interp, ExprInfo *infoPtr,
165 int flags, CompileEnv *envPtr));
166static int CompileShiftExpr _ANSI_ARGS_((Tcl_Interp *interp,
167 ExprInfo *infoPtr, int flags,
168 CompileEnv *envPtr));
169static int CompileUnaryExpr _ANSI_ARGS_((Tcl_Interp *interp,
170 ExprInfo *infoPtr, int flags,
171 CompileEnv *envPtr));
172static int GetToken _ANSI_ARGS_((Tcl_Interp *interp,
173 ExprInfo *infoPtr, CompileEnv *envPtr));
174
175
176
177/*
178 *----------------------------------------------------------------------
179 *
180 * TclCompileExpr --
181 *
182 * This procedure compiles a string containing a Tcl expression into
183 * Tcl bytecodes. This procedure is the top-level interface to the
184 * the expression compilation module, and is used by such public
185 * procedures as Tcl_ExprString, Tcl_ExprStringObj, Tcl_ExprLong,
186 * Tcl_ExprDouble, Tcl_ExprBoolean, and Tcl_ExprBooleanObj.
187 *
188 * Note that the topmost recursive-descent parsing routine used by
189 * TclCompileExpr to compile expressions is called "CompileCondExpr"
190 * and not, e.g., "CompileExpr". This is done to avoid an extra
191 * procedure call since such a procedure would only return the result
192 * of calling CompileCondExpr. Other recursive-descent procedures
193 * that need to parse expressions also call CompileCondExpr.
194 *
195 * Results:
196 * The return value is TCL_OK on a successful compilation and TCL_ERROR
197 * on failure. If TCL_ERROR is returned, then the interpreter's result
198 * contains an error message.
199 *
200 * envPtr->termOffset is filled in with the offset of the character in
201 * "string" just after the last one successfully processed; this might
202 * be the offset of the ']' (if flags & TCL_BRACKET_TERM), or the
203 * offset of the '\0' at the end of the string.
204 *
205 * envPtr->maxStackDepth is updated with the maximum number of stack
206 * elements needed to execute the expression.
207 *
208 * envPtr->exprIsJustVarRef is set 1 if the expression consisted of
209 * a single variable reference as in the expression of "if $b then...".
210 * Otherwise it is set 0. This is used to implement Tcl's two level
211 * expression substitution semantics properly.
212 *
213 * envPtr->exprIsComparison is set 1 if the top-level operator in the
214 * expr is a comparison. Otherwise it is set 0. If 1, because the
215 * operands might be strings, the expr is compiled out-of-line in order
216 * to implement expr's 2 level substitution semantics properly.
217 *
218 * Side effects:
219 * Adds instructions to envPtr to evaluate the expression at runtime.
220 *
221 *----------------------------------------------------------------------
222 */
223
224int
225TclCompileExpr(interp, string, lastChar, flags, envPtr)
226 Tcl_Interp *interp; /* Used for error reporting. */
227 char *string; /* The source string to compile. */
228 char *lastChar; /* Pointer to terminating character of
229 * string. */
230 int flags; /* Flags to control compilation (same as
231 * passed to Tcl_Eval). */
232 CompileEnv *envPtr; /* Holds resulting instructions. */
233{
234 Interp *iPtr = (Interp *) interp;
235 ExprInfo info;
236 int maxDepth = 0; /* Maximum number of stack elements needed
237 * to execute the expression. */
238 int result;
239
240 /*
241 * Register the builtin math functions the first time an expression is
242 * compiled.
243 */
244
245 if (!(iPtr->flags & EXPR_INITIALIZED)) {
246 BuiltinFunc *funcPtr;
247 Tcl_HashEntry *hPtr;
248 MathFunc *mathFuncPtr;
249 int i;
250
251 iPtr->flags |= EXPR_INITIALIZED;
252 i = 0;
253 for (funcPtr = builtinFuncTable; funcPtr->name != NULL; funcPtr++) {
254 Tcl_CreateMathFunc(interp, funcPtr->name,
255 funcPtr->numArgs, funcPtr->argTypes,
256 (Tcl_MathProc *) NULL, (ClientData) 0);
257
258 hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcPtr->name);
259 if (hPtr == NULL) {
260 panic("TclCompileExpr: Tcl_CreateMathFunc incorrectly registered '%s'", funcPtr->name);
261 return TCL_ERROR;
262 }
263 mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
264 mathFuncPtr->builtinFuncIndex = i;
265 i++;
266 }
267 }
268
269 info.token = UNKNOWN;
270 info.objIndex = -1;
271 info.funcName = NULL;
272 info.next = string;
273 info.originalExpr = string;
274 info.lastChar = lastChar;
275 info.hasOperators = 0;
276 info.exprIsJustVarRef = 1; /* will be set 0 if anything else is seen */
277 info.exprIsComparison = 0; /* set 1 if topmost operator is <,==,etc. */
278
279 /*
280 * Get the first token then compile an expression.
281 */
282
283 result = GetToken(interp, &info, envPtr);
284 if (result != TCL_OK) {
285 goto done;
286 }
287
288 result = CompileCondExpr(interp, &info, flags, envPtr);
289 if (result != TCL_OK) {
290 goto done;
291 }
292 if (info.token != END) {
293 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
294 "syntax error in expression \"", string, "\"", (char *) NULL);
295 result = TCL_ERROR;
296 goto done;
297 }
298 if (!info.hasOperators) {
299 /*
300 * Attempt to convert the primary's object to an int or double.
301 * This is done in order to support Tcl's policy of interpreting
302 * operands if at all possible as first integers, else
303 * floating-point numbers.
304 */
305
306 TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
307 }
308 maxDepth = envPtr->maxStackDepth;
309
310 done:
311 envPtr->termOffset = (info.next - string);
312 envPtr->maxStackDepth = maxDepth;
313 envPtr->exprIsJustVarRef = info.exprIsJustVarRef;
314 envPtr->exprIsComparison = info.exprIsComparison;
315 return result;
316}
317
318
319/*
320 *----------------------------------------------------------------------
321 *
322 * CompileCondExpr --
323 *
324 * This procedure compiles a Tcl conditional expression:
325 * condExpr ::= lorExpr ['?' condExpr ':' condExpr]
326 *
327 * Note that this is the topmost recursive-descent parsing routine used
328 * by TclCompileExpr to compile expressions. It does not call an
329 * separate, higher-level "CompileExpr" procedure. This avoids an extra
330 * procedure call since such a procedure would only return the result
331 * of calling CompileCondExpr. Other recursive-descent procedures that
332 * need to parse expressions also call CompileCondExpr.
333 *
334 * Results:
335 * The return value is TCL_OK on a successful compilation and TCL_ERROR
336 * on failure. If TCL_ERROR is returned, then the interpreter's result
337 * contains an error message.
338 *
339 * envPtr->maxStackDepth is updated with the maximum number of stack
340 * elements needed to execute the expression.
341 *
342 * Side effects:
343 * Adds instructions to envPtr to evaluate the expression at runtime.
344 *
345 *----------------------------------------------------------------------
346 */
347
348static int
349CompileCondExpr(interp, infoPtr, flags, envPtr)
350 Tcl_Interp *interp; /* Used for error reporting. */
351 ExprInfo *infoPtr; /* Describes the compilation state for the
352 * expression being compiled. */
353 int flags; /* Flags to control compilation (same as
354 * passed to Tcl_Eval). */
355 CompileEnv *envPtr; /* Holds resulting instructions. */
356{
357 int maxDepth = 0; /* Maximum number of stack elements needed
358 * to execute the expression. */
359 JumpFixup jumpAroundThenFixup, jumpAroundElseFixup;
360 /* Used to update or replace one-byte jumps
361 * around the then and else expressions when
362 * their target PCs are determined. */
363 int elseCodeOffset, currCodeOffset, jumpDist, result;
364
365 result = CompileLorExpr(interp, infoPtr, flags, envPtr);
366 if (result != TCL_OK) {
367 goto done;
368 }
369 maxDepth = envPtr->maxStackDepth;
370
371 if (infoPtr->token == QUESTY) {
372 result = GetToken(interp, infoPtr, envPtr); /* skip over the '?' */
373 if (result != TCL_OK) {
374 goto done;
375 }
376
377 /*
378 * Emit the jump around the "then" clause to the "else" condExpr if
379 * the test was false. We emit a one byte (relative) jump here, and
380 * replace it later with a four byte jump if the jump target is more
381 * than 127 bytes away.
382 */
383
384 TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup);
385
386 /*
387 * Compile the "then" expression. Note that if a subexpression
388 * is only a primary, we need to try to convert it to numeric.
389 * This is done in order to support Tcl's policy of interpreting
390 * operands if at all possible as first integers, else
391 * floating-point numbers.
392 */
393
394 infoPtr->hasOperators = 0;
395 infoPtr->exprIsJustVarRef = 0;
396 infoPtr->exprIsComparison = 0;
397 result = CompileCondExpr(interp, infoPtr, flags, envPtr);
398 if (result != TCL_OK) {
399 goto done;
400 }
401 maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
402 if (infoPtr->token != COLON) {
403 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
404 "syntax error in expression \"", infoPtr->originalExpr,
405 "\"", (char *) NULL);
406 result = TCL_ERROR;
407 goto done;
408 }
409 if (!infoPtr->hasOperators) {
410 TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
411 }
412 result = GetToken(interp, infoPtr, envPtr); /* skip over the ':' */
413 if (result != TCL_OK) {
414 goto done;
415 }
416
417 /*
418 * Emit an unconditional jump around the "else" condExpr.
419 */
420
421 TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
422 &jumpAroundElseFixup);
423
424 /*
425 * Compile the "else" expression.
426 */
427
428 infoPtr->hasOperators = 0;
429 elseCodeOffset = TclCurrCodeOffset();
430 result = CompileCondExpr(interp, infoPtr, flags, envPtr);
431 if (result != TCL_OK) {
432 goto done;
433 }
434 maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
435 if (!infoPtr->hasOperators) {
436 TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
437 }
438
439 /*
440 * Fix up the second jump: the unconditional jump around the "else"
441 * expression. If the distance is too great (> 127 bytes), replace
442 * it with a four byte instruction and move the instructions after
443 * the jump down.
444 */
445
446 currCodeOffset = TclCurrCodeOffset();
447 jumpDist = (currCodeOffset - jumpAroundElseFixup.codeOffset);
448 if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, jumpDist, 127)) {
449 /*
450 * Update the else expression's starting code offset since it
451 * moved down 3 bytes too.
452 */
453
454 elseCodeOffset += 3;
455 }
456
457 /*
458 * Now fix up the first branch: the jumpFalse after the test. If the
459 * distance is too great, replace it with a four byte instruction
460 * and update the code offsets for the commands in both the "then"
461 * and "else" expressions.
462 */
463
464 jumpDist = (elseCodeOffset - jumpAroundThenFixup.codeOffset);
465 TclFixupForwardJump(envPtr, &jumpAroundThenFixup, jumpDist, 127);
466
467 infoPtr->hasOperators = 1;
468
469 /*
470 * A comparison is not the top-level operator in this expression.
471 */
472
473 infoPtr->exprIsComparison = 0;
474 }
475
476 done:
477 envPtr->maxStackDepth = maxDepth;
478 return result;
479}
480
481
482/*
483 *----------------------------------------------------------------------
484 *
485 * CompileLorExpr --
486 *
487 * This procedure compiles a Tcl logical or expression:
488 * lorExpr ::= landExpr {'||' landExpr}
489 *
490 * Results:
491 * The return value is TCL_OK on a successful compilation and TCL_ERROR
492 * on failure. If TCL_ERROR is returned, then the interpreter's result
493 * contains an error message.
494 *
495 * envPtr->maxStackDepth is updated with the maximum number of stack
496 * elements needed to execute the expression.
497 *
498 * Side effects:
499 * Adds instructions to envPtr to evaluate the expression at runtime.
500 *
501 *----------------------------------------------------------------------
502 */
503
504static int
505CompileLorExpr(interp, infoPtr, flags, envPtr)
506 Tcl_Interp *interp; /* Used for error reporting. */
507 ExprInfo *infoPtr; /* Describes the compilation state for the
508 * expression being compiled. */
509 int flags; /* Flags to control compilation (same as
510 * passed to Tcl_Eval). */
511 CompileEnv *envPtr; /* Holds resulting instructions. */
512{
513 int maxDepth; /* Maximum number of stack elements needed
514 * to execute the expression. */
515 JumpFixupArray jumpFixupArray;
516 /* Used to fix up the forward "short
517 * circuit" jump after each or-ed
518 * subexpression to just after the last
519 * subexpression. */
520 JumpFixup jumpTrueFixup, jumpFixup;
521 /* Used to emit the jumps in the code to
522 * convert the first operand to a 0 or 1. */
523 int fixupIndex, jumpDist, currCodeOffset, objIndex, j, result;
524 Tcl_Obj *objPtr;
525
526 result = CompileLandExpr(interp, infoPtr, flags, envPtr);
527 if ((result != TCL_OK) || (infoPtr->token != OR)) {
528 return result; /* envPtr->maxStackDepth is already set */
529 }
530
531 infoPtr->hasOperators = 1;
532 infoPtr->exprIsJustVarRef = 0;
533 maxDepth = envPtr->maxStackDepth;
534 TclInitJumpFixupArray(&jumpFixupArray);
535 while (infoPtr->token == OR) {
536 result = GetToken(interp, infoPtr, envPtr); /* skip over the '||' */
537 if (result != TCL_OK) {
538 goto done;
539 }
540
541 if (jumpFixupArray.next == 0) {
542 /*
543 * Just the first "lor" operand is on the stack. The following
544 * is slightly ugly: we need to convert that first "lor" operand
545 * to a "0" or "1" to get the correct result if it is nonzero.
546 * Eventually we'll use a new instruction for this.
547 */
548
549 TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpTrueFixup);
550
551 objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0,
552 /*inHeap*/ 0, envPtr);
553 objPtr = envPtr->objArrayPtr[objIndex];
554
555 Tcl_InvalidateStringRep(objPtr);
556 objPtr->internalRep.longValue = 0;
557 objPtr->typePtr = &tclIntType;
558
559 TclEmitPush(objIndex, envPtr);
560 TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
561
562 jumpDist = (TclCurrCodeOffset() - jumpTrueFixup.codeOffset);
563 if (TclFixupForwardJump(envPtr, &jumpTrueFixup, jumpDist, 127)) {
564 panic("CompileLorExpr: bad jump distance %d\n", jumpDist);
565 }
566 objIndex = TclObjIndexForString("1", 1, /*allocStrRep*/ 0,
567 /*inHeap*/ 0, envPtr);
568 objPtr = envPtr->objArrayPtr[objIndex];
569
570 Tcl_InvalidateStringRep(objPtr);
571 objPtr->internalRep.longValue = 1;
572 objPtr->typePtr = &tclIntType;
573
574 TclEmitPush(objIndex, envPtr);
575
576 jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
577 if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
578 panic("CompileLorExpr: bad jump distance %d\n", jumpDist);
579 }
580 }
581
582 /*
583 * Duplicate the value on top of the stack to prevent the jump from
584 * consuming it.
585 */
586
587 TclEmitOpcode(INST_DUP, envPtr);
588
589 /*
590 * Emit the "short circuit" jump around the rest of the lorExp if
591 * the previous expression was true. We emit a one byte (relative)
592 * jump here, and replace it later with a four byte jump if the jump
593 * target is more than 127 bytes away.
594 */
595
596 if (jumpFixupArray.next == jumpFixupArray.end) {
597 TclExpandJumpFixupArray(&jumpFixupArray);
598 }
599 fixupIndex = jumpFixupArray.next;
600 jumpFixupArray.next++;
601 TclEmitForwardJump(envPtr, TCL_TRUE_JUMP,
602 &(jumpFixupArray.fixup[fixupIndex]));
603
604 /*
605 * Compile the subexpression.
606 */
607
608 result = CompileLandExpr(interp, infoPtr, flags, envPtr);
609 if (result != TCL_OK) {
610 goto done;
611 }
612 maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
613
614 /*
615 * Emit a "logical or" instruction. This does not try to "short-
616 * circuit" the evaluation of both operands of a Tcl "||" operator,
617 * but instead ensures that we either have a "1" or a "0" result.
618 */
619
620 TclEmitOpcode(INST_LOR, envPtr);
621 }
622
623 /*
624 * Now that we know the target of the forward jumps, update the jumps
625 * with the correct distance. Also, if the distance is too great (> 127
626 * bytes), replace the jump with a four byte instruction and move the
627 * instructions after the jump down.
628 */
629
630 for (j = jumpFixupArray.next; j > 0; j--) {
631 fixupIndex = (j - 1); /* process closest jump first */
632 currCodeOffset = TclCurrCodeOffset();
633 jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset);
634 TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), jumpDist, 127);
635 }
636
637 /*
638 * We get here only if one or more ||'s appear as top-level operators.
639 */
640
641 done:
642 infoPtr->exprIsComparison = 0;
643 TclFreeJumpFixupArray(&jumpFixupArray);
644 envPtr->maxStackDepth = maxDepth;
645 return result;
646}
647
648
649/*
650 *----------------------------------------------------------------------
651 *
652 * CompileLandExpr --
653 *
654 * This procedure compiles a Tcl logical and expression:
655 * landExpr ::= bitOrExpr {'&&' bitOrExpr}
656 *
657 * Results:
658 * The return value is TCL_OK on a successful compilation and TCL_ERROR
659 * on failure. If TCL_ERROR is returned, then the interpreter's result
660 * contains an error message.
661 *
662 * envPtr->maxStackDepth is updated with the maximum number of stack
663 * elements needed to execute the expression.
664 *
665 * Side effects:
666 * Adds instructions to envPtr to evaluate the expression at runtime.
667 *
668 *----------------------------------------------------------------------
669 */
670
671static int
672CompileLandExpr(interp, infoPtr, flags, envPtr)
673 Tcl_Interp *interp; /* Used for error reporting. */
674 ExprInfo *infoPtr; /* Describes the compilation state for the
675 * expression being compiled. */
676 int flags; /* Flags to control compilation (same as
677 * passed to Tcl_Eval). */
678 CompileEnv *envPtr; /* Holds resulting instructions. */
679{
680 int maxDepth; /* Maximum number of stack elements needed
681 * to execute the expression. */
682 JumpFixupArray jumpFixupArray;
683 /* Used to fix up the forward "short
684 * circuit" jump after each and-ed
685 * subexpression to just after the last
686 * subexpression. */
687 JumpFixup jumpTrueFixup, jumpFixup;
688 /* Used to emit the jumps in the code to
689 * convert the first operand to a 0 or 1. */
690 int fixupIndex, jumpDist, currCodeOffset, objIndex, j, result;
691 Tcl_Obj *objPtr;
692
693 result = CompileBitOrExpr(interp, infoPtr, flags, envPtr);
694 if ((result != TCL_OK) || (infoPtr->token != AND)) {
695 return result; /* envPtr->maxStackDepth is already set */
696 }
697
698 infoPtr->hasOperators = 1;
699 infoPtr->exprIsJustVarRef = 0;
700 maxDepth = envPtr->maxStackDepth;
701 TclInitJumpFixupArray(&jumpFixupArray);
702 while (infoPtr->token == AND) {
703 result = GetToken(interp, infoPtr, envPtr); /* skip over the '&&' */
704 if (result != TCL_OK) {
705 goto done;
706 }
707
708 if (jumpFixupArray.next == 0) {
709 /*
710 * Just the first "land" operand is on the stack. The following
711 * is slightly ugly: we need to convert the first "land" operand
712 * to a "0" or "1" to get the correct result if it is
713 * nonzero. Eventually we'll use a new instruction.
714 */
715
716 TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpTrueFixup);
717
718 objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0,
719 /*inHeap*/ 0, envPtr);
720 objPtr = envPtr->objArrayPtr[objIndex];
721
722 Tcl_InvalidateStringRep(objPtr);
723 objPtr->internalRep.longValue = 0;
724 objPtr->typePtr = &tclIntType;
725
726 TclEmitPush(objIndex, envPtr);
727 TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
728
729 jumpDist = (TclCurrCodeOffset() - jumpTrueFixup.codeOffset);
730 if (TclFixupForwardJump(envPtr, &jumpTrueFixup, jumpDist, 127)) {
731 panic("CompileLandExpr: bad jump distance %d\n", jumpDist);
732 }
733 objIndex = TclObjIndexForString("1", 1, /*allocStrRep*/ 0,
734 /*inHeap*/ 0, envPtr);
735 objPtr = envPtr->objArrayPtr[objIndex];
736
737 Tcl_InvalidateStringRep(objPtr);
738 objPtr->internalRep.longValue = 1;
739 objPtr->typePtr = &tclIntType;
740
741 TclEmitPush(objIndex, envPtr);
742
743 jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
744 if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
745 panic("CompileLandExpr: bad jump distance %d\n", jumpDist);
746 }
747 }
748
749 /*
750 * Duplicate the value on top of the stack to prevent the jump from
751 * consuming it.
752 */
753
754 TclEmitOpcode(INST_DUP, envPtr);
755
756 /*
757 * Emit the "short circuit" jump around the rest of the landExp if
758 * the previous expression was false. We emit a one byte (relative)
759 * jump here, and replace it later with a four byte jump if the jump
760 * target is more than 127 bytes away.
761 */
762
763 if (jumpFixupArray.next == jumpFixupArray.end) {
764 TclExpandJumpFixupArray(&jumpFixupArray);
765 }
766 fixupIndex = jumpFixupArray.next;
767 jumpFixupArray.next++;
768 TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
769 &(jumpFixupArray.fixup[fixupIndex]));
770
771 /*
772 * Compile the subexpression.
773 */
774
775 result = CompileBitOrExpr(interp, infoPtr, flags, envPtr);
776 if (result != TCL_OK) {
777 goto done;
778 }
779 maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
780
781 /*
782 * Emit a "logical and" instruction. This does not try to "short-
783 * circuit" the evaluation of both operands of a Tcl "&&" operator,
784 * but instead ensures that we either have a "1" or a "0" result.
785 */
786
787 TclEmitOpcode(INST_LAND, envPtr);
788 }
789
790 /*
791 * Now that we know the target of the forward jumps, update the jumps
792 * with the correct distance. Also, if the distance is too great (> 127
793 * bytes), replace the jump with a four byte instruction and move the
794 * instructions after the jump down.
795 */
796
797 for (j = jumpFixupArray.next; j > 0; j--) {
798 fixupIndex = (j - 1); /* process closest jump first */
799 currCodeOffset = TclCurrCodeOffset();
800 jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset);
801 TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]),
802 jumpDist, 127);
803 }
804
805 /*
806 * We get here only if one or more &&'s appear as top-level operators.
807 */
808
809 done:
810 infoPtr->exprIsComparison = 0;
811 TclFreeJumpFixupArray(&jumpFixupArray);
812 envPtr->maxStackDepth = maxDepth;
813 return result;
814}
815
816
817/*
818 *----------------------------------------------------------------------
819 *
820 * CompileBitOrExpr --
821 *
822 * This procedure compiles a Tcl bitwise or expression:
823 * bitOrExpr ::= bitXorExpr {'|' bitXorExpr}
824 *
825 * Results:
826 * The return value is TCL_OK on a successful compilation and TCL_ERROR
827 * on failure. If TCL_ERROR is returned, then the interpreter's result
828 * contains an error message.
829 *
830 * envPtr->maxStackDepth is updated with the maximum number of stack
831 * elements needed to execute the expression.
832 *
833 * Side effects:
834 * Adds instructions to envPtr to evaluate the expression at runtime.
835 *
836 *----------------------------------------------------------------------
837 */
838
839static int
840CompileBitOrExpr(interp, infoPtr, flags, envPtr)
841 Tcl_Interp *interp; /* Used for error reporting. */
842 ExprInfo *infoPtr; /* Describes the compilation state for the
843 * expression being compiled. */
844 int flags; /* Flags to control compilation (same as
845 * passed to Tcl_Eval). */
846 CompileEnv *envPtr; /* Holds resulting instructions. */
847{
848 int maxDepth = 0; /* Maximum number of stack elements needed
849 * to execute the expression. */
850 int result;
851
852 result = CompileBitXorExpr(interp, infoPtr, flags, envPtr);
853 if (result != TCL_OK) {
854 goto done;
855 }
856 maxDepth = envPtr->maxStackDepth;
857
858 while (infoPtr->token == BIT_OR) {
859 infoPtr->hasOperators = 1;
860 infoPtr->exprIsJustVarRef = 0;
861 result = GetToken(interp, infoPtr, envPtr); /* skip over the '|' */
862 if (result != TCL_OK) {
863 goto done;
864 }
865
866 result = CompileBitXorExpr(interp, infoPtr, flags, envPtr);
867 if (result != TCL_OK) {
868 goto done;
869 }
870 maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
871
872 TclEmitOpcode(INST_BITOR, envPtr);
873
874 /*
875 * A comparison is not the top-level operator in this expression.
876 */
877
878 infoPtr->exprIsComparison = 0;
879 }
880
881 done:
882 envPtr->maxStackDepth = maxDepth;
883 return result;
884}
885
886
887/*
888 *----------------------------------------------------------------------
889 *
890 * CompileBitXorExpr --
891 *
892 * This procedure compiles a Tcl bitwise exclusive or expression:
893 * bitXorExpr ::= bitAndExpr {'^' bitAndExpr}
894 *
895 * Results:
896 * The return value is TCL_OK on a successful compilation and TCL_ERROR
897 * on failure. If TCL_ERROR is returned, then the interpreter's result
898 * contains an error message.
899 *
900 * envPtr->maxStackDepth is updated with the maximum number of stack
901 * elements needed to execute the expression.
902 *
903 * Side effects:
904 * Adds instructions to envPtr to evaluate the expression at runtime.
905 *
906 *----------------------------------------------------------------------
907 */
908
909static int
910CompileBitXorExpr(interp, infoPtr, flags, envPtr)
911 Tcl_Interp *interp; /* Used for error reporting. */
912 ExprInfo *infoPtr; /* Describes the compilation state for the
913 * expression being compiled. */
914 int flags; /* Flags to control compilation (same as
915 * passed to Tcl_Eval). */
916 CompileEnv *envPtr; /* Holds resulting instructions. */
917{
918 int maxDepth = 0; /* Maximum number of stack elements needed
919 * to execute the expression. */
920 int result;
921
922 result = CompileBitAndExpr(interp, infoPtr, flags, envPtr);
923 if (result != TCL_OK) {
924 goto done;
925 }
926 maxDepth = envPtr->maxStackDepth;
927
928 while (infoPtr->token == BIT_XOR) {
929 infoPtr->hasOperators = 1;
930 infoPtr->exprIsJustVarRef = 0;
931 result = GetToken(interp, infoPtr, envPtr); /* skip over the '^' */
932 if (result != TCL_OK) {
933 goto done;
934 }
935
936 result = CompileBitAndExpr(interp, infoPtr, flags, envPtr);
937 if (result != TCL_OK) {
938 goto done;
939 }
940 maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
941
942 TclEmitOpcode(INST_BITXOR, envPtr);
943
944 /*
945 * A comparison is not the top-level operator in this expression.
946 */
947
948 infoPtr->exprIsComparison = 0;
949 }
950
951 done:
952 envPtr->maxStackDepth = maxDepth;
953 return result;
954}
955
956
957/*
958 *----------------------------------------------------------------------
959 *
960 * CompileBitAndExpr --
961 *
962 * This procedure compiles a Tcl bitwise and expression:
963 * bitAndExpr ::= equalityExpr {'&' equalityExpr}
964 *
965 * Results:
966 * The return value is TCL_OK on a successful compilation and TCL_ERROR
967 * on failure. If TCL_ERROR is returned, then the interpreter's result
968 * contains an error message.
969 *
970 * envPtr->maxStackDepth is updated with the maximum number of stack
971 * elements needed to execute the expression.
972 *
973 * Side effects:
974 * Adds instructions to envPtr to evaluate the expression at runtime.
975 *
976 *----------------------------------------------------------------------
977 */
978
979static int
980CompileBitAndExpr(interp, infoPtr, flags, envPtr)
981 Tcl_Interp *interp; /* Used for error reporting. */
982 ExprInfo *infoPtr; /* Describes the compilation state for the
983 * expression being compiled. */
984 int flags; /* Flags to control compilation (same as
985 * passed to Tcl_Eval). */
986 CompileEnv *envPtr; /* Holds resulting instructions. */
987{
988 int maxDepth = 0; /* Maximum number of stack elements needed
989 * to execute the expression. */
990 int result;
991
992 result = CompileEqualityExpr(interp, infoPtr, flags, envPtr);
993 if (result != TCL_OK) {
994 goto done;
995 }
996 maxDepth = envPtr->maxStackDepth;
997
998 while (infoPtr->token == BIT_AND) {
999 infoPtr->hasOperators = 1;
1000 infoPtr->exprIsJustVarRef = 0;
1001 result = GetToken(interp, infoPtr, envPtr); /* skip over the '&' */
1002 if (result != TCL_OK) {
1003 goto done;
1004 }
1005
1006 result = CompileEqualityExpr(interp, infoPtr, flags, envPtr);
1007 if (result != TCL_OK) {
1008 goto done;
1009 }
1010 maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
1011
1012 TclEmitOpcode(INST_BITAND, envPtr);
1013
1014 /*
1015 * A comparison is not the top-level operator in this expression.
1016 */
1017
1018 infoPtr->exprIsComparison = 0;
1019 }
1020
1021 done:
1022 envPtr->maxStackDepth = maxDepth;
1023 return result;
1024}
1025
1026
1027/*
1028 *----------------------------------------------------------------------
1029 *
1030 * CompileEqualityExpr --
1031 *
1032 * This procedure compiles a Tcl equality (inequality) expression:
1033 * equalityExpr ::= relationalExpr {('==' | '!=') relationalExpr}
1034 *
1035 * Results:
1036 * The return value is TCL_OK on a successful compilation and TCL_ERROR
1037 * on failure. If TCL_ERROR is returned, then the interpreter's result
1038 * contains an error message.
1039 *
1040 * envPtr->maxStackDepth is updated with the maximum number of stack
1041 * elements needed to execute the expression.
1042 *
1043 * Side effects:
1044 * Adds instructions to envPtr to evaluate the expression at runtime.
1045 *
1046 *----------------------------------------------------------------------
1047 */
1048
1049static int
1050CompileEqualityExpr(interp, infoPtr, flags, envPtr)
1051 Tcl_Interp *interp; /* Used for error reporting. */
1052 ExprInfo *infoPtr; /* Describes the compilation state for the
1053 * expression being compiled. */
1054 int flags; /* Flags to control compilation (same as
1055 * passed to Tcl_Eval). */
1056 CompileEnv *envPtr; /* Holds resulting instructions. */
1057{
1058 int maxDepth = 0; /* Maximum number of stack elements needed
1059 * to execute the expression. */
1060 int op, result;
1061
1062 result = CompileRelationalExpr(interp, infoPtr, flags, envPtr);
1063 if (result != TCL_OK) {
1064 goto done;
1065 }
1066 maxDepth = envPtr->maxStackDepth;
1067
1068 op = infoPtr->token;
1069 while ((op == EQUAL) || (op == NEQ)) {
1070 infoPtr->hasOperators = 1;
1071 infoPtr->exprIsJustVarRef = 0;
1072 result = GetToken(interp, infoPtr, envPtr); /* skip over == or != */
1073 if (result != TCL_OK) {
1074 goto done;
1075 }
1076
1077 result = CompileRelationalExpr(interp, infoPtr, flags, envPtr);
1078 if (result != TCL_OK) {
1079 goto done;
1080 }
1081 maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
1082
1083 if (op == EQUAL) {
1084 TclEmitOpcode(INST_EQ, envPtr);
1085 } else {
1086 TclEmitOpcode(INST_NEQ, envPtr);
1087 }
1088
1089 op = infoPtr->token;
1090
1091 /*
1092 * A comparison _is_ the top-level operator in this expression.
1093 */
1094
1095 infoPtr->exprIsComparison = 1;
1096 }
1097
1098 done:
1099 envPtr->maxStackDepth = maxDepth;
1100 return result;
1101}
1102
1103
1104/*
1105 *----------------------------------------------------------------------
1106 *
1107 * CompileRelationalExpr --
1108 *
1109 * This procedure compiles a Tcl relational expression:
1110 * relationalExpr ::= shiftExpr {('<' | '>' | '<=' | '>=') shiftExpr}
1111 *
1112 * Results:
1113 * The return value is TCL_OK on a successful compilation and TCL_ERROR
1114 * on failure. If TCL_ERROR is returned, then the interpreter's result
1115 * contains an error message.
1116 *
1117 * envPtr->maxStackDepth is updated with the maximum number of stack
1118 * elements needed to execute the expression.
1119 *
1120 * Side effects:
1121 * Adds instructions to envPtr to evaluate the expression at runtime.
1122 *
1123 *----------------------------------------------------------------------
1124 */
1125
1126static int
1127CompileRelationalExpr(interp, infoPtr, flags, envPtr)
1128 Tcl_Interp *interp; /* Used for error reporting. */
1129 ExprInfo *infoPtr; /* Describes the compilation state for the
1130 * expression being compiled. */
1131 int flags; /* Flags to control compilation (same as
1132 * passed to Tcl_Eval). */
1133 CompileEnv *envPtr; /* Holds resulting instructions. */
1134{
1135 int maxDepth = 0; /* Maximum number of stack elements needed
1136 * to execute the expression. */
1137 int op, result;
1138
1139 result = CompileShiftExpr(interp, infoPtr, flags, envPtr);
1140 if (result != TCL_OK) {
1141 goto done;
1142 }
1143 maxDepth = envPtr->maxStackDepth;
1144
1145 op = infoPtr->token;
1146 while ((op == LESS) || (op == GREATER) || (op == LEQ) || (op == GEQ)) {
1147 infoPtr->hasOperators = 1;
1148 infoPtr->exprIsJustVarRef = 0;
1149 result = GetToken(interp, infoPtr, envPtr); /* skip over the op */
1150 if (result != TCL_OK) {
1151 goto done;
1152 }
1153
1154 result = CompileShiftExpr(interp, infoPtr, flags, envPtr);
1155 if (result != TCL_OK) {
1156 goto done;
1157 }
1158 maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
1159
1160 switch (op) {
1161 case LESS:
1162 TclEmitOpcode(INST_LT, envPtr);
1163 break;
1164 case GREATER:
1165 TclEmitOpcode(INST_GT, envPtr);
1166 break;
1167 case LEQ:
1168 TclEmitOpcode(INST_LE, envPtr);
1169 break;
1170 case GEQ:
1171 TclEmitOpcode(INST_GE, envPtr);
1172 break;
1173 }
1174
1175 op = infoPtr->token;
1176
1177 /*
1178 * A comparison _is_ the top-level operator in this expression.
1179 */
1180
1181 infoPtr->exprIsComparison = 1;
1182 }
1183
1184 done:
1185 envPtr->maxStackDepth = maxDepth;
1186 return result;
1187}
1188
1189
1190/*
1191 *----------------------------------------------------------------------
1192 *
1193 * CompileShiftExpr --
1194 *
1195 * This procedure compiles a Tcl shift expression:
1196 * shiftExpr ::= addExpr {('<<' | '>>') addExpr}
1197 *
1198 * Results:
1199 * The return value is TCL_OK on a successful compilation and TCL_ERROR
1200 * on failure. If TCL_ERROR is returned, then the interpreter's result
1201 * contains an error message.
1202 *
1203 * envPtr->maxStackDepth is updated with the maximum number of stack
1204 * elements needed to execute the expression.
1205 *
1206 * Side effects:
1207 * Adds instructions to envPtr to evaluate the expression at runtime.
1208 *
1209 *----------------------------------------------------------------------
1210 */
1211
1212static int
1213CompileShiftExpr(interp, infoPtr, flags, envPtr)
1214 Tcl_Interp *interp; /* Used for error reporting. */
1215 ExprInfo *infoPtr; /* Describes the compilation state for the
1216 * expression being compiled. */
1217 int flags; /* Flags to control compilation (same as
1218 * passed to Tcl_Eval). */
1219 CompileEnv *envPtr; /* Holds resulting instructions. */
1220{
1221 int maxDepth = 0; /* Maximum number of stack elements needed
1222 * to execute the expression. */
1223 int op, result;
1224
1225 result = CompileAddExpr(interp, infoPtr, flags, envPtr);
1226 if (result != TCL_OK) {
1227 goto done;
1228 }
1229 maxDepth = envPtr->maxStackDepth;
1230
1231 op = infoPtr->token;
1232 while ((op == LEFT_SHIFT) || (op == RIGHT_SHIFT)) {
1233 infoPtr->hasOperators = 1;
1234 infoPtr->exprIsJustVarRef = 0;
1235 result = GetToken(interp, infoPtr, envPtr); /* skip over << or >> */
1236 if (result != TCL_OK) {
1237 goto done;
1238 }
1239
1240 result = CompileAddExpr(interp, infoPtr, flags, envPtr);
1241 if (result != TCL_OK) {
1242 goto done;
1243 }
1244 maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
1245
1246 if (op == LEFT_SHIFT) {
1247 TclEmitOpcode(INST_LSHIFT, envPtr);
1248 } else {
1249 TclEmitOpcode(INST_RSHIFT, envPtr);
1250 }
1251
1252 op = infoPtr->token;
1253
1254 /*
1255 * A comparison is not the top-level operator in this expression.
1256 */
1257
1258 infoPtr->exprIsComparison = 0;
1259 }
1260
1261 done:
1262 envPtr->maxStackDepth = maxDepth;
1263 return result;
1264}
1265
1266
1267/*
1268 *----------------------------------------------------------------------
1269 *
1270 * CompileAddExpr --
1271 *
1272 * This procedure compiles a Tcl addition expression:
1273 * addExpr ::= multiplyExpr {('+' | '-') multiplyExpr}
1274 *
1275 * Results:
1276 * The return value is TCL_OK on a successful compilation and TCL_ERROR
1277 * on failure. If TCL_ERROR is returned, then the interpreter's result
1278 * contains an error message.
1279 *
1280 * envPtr->maxStackDepth is updated with the maximum number of stack
1281 * elements needed to execute the expression.
1282 *
1283 * Side effects:
1284 * Adds instructions to envPtr to evaluate the expression at runtime.
1285 *
1286 *----------------------------------------------------------------------
1287 */
1288
1289static int
1290CompileAddExpr(interp, infoPtr, flags, envPtr)
1291 Tcl_Interp *interp; /* Used for error reporting. */
1292 ExprInfo *infoPtr; /* Describes the compilation state for the
1293 * expression being compiled. */
1294 int flags; /* Flags to control compilation (same as
1295 * passed to Tcl_Eval). */
1296 CompileEnv *envPtr; /* Holds resulting instructions. */
1297{
1298 int maxDepth = 0; /* Maximum number of stack elements needed
1299 * to execute the expression. */
1300 int op, result;
1301
1302 result = CompileMultiplyExpr(interp, infoPtr, flags, envPtr);
1303 if (result != TCL_OK) {
1304 goto done;
1305 }
1306 maxDepth = envPtr->maxStackDepth;
1307
1308 op = infoPtr->token;
1309 while ((op == PLUS) || (op == MINUS)) {
1310 infoPtr->hasOperators = 1;
1311 infoPtr->exprIsJustVarRef = 0;
1312 result = GetToken(interp, infoPtr, envPtr); /* skip over + or - */
1313 if (result != TCL_OK) {
1314 goto done;
1315 }
1316
1317 result = CompileMultiplyExpr(interp, infoPtr, flags, envPtr);
1318 if (result != TCL_OK) {
1319 goto done;
1320 }
1321 maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
1322
1323 if (op == PLUS) {
1324 TclEmitOpcode(INST_ADD, envPtr);
1325 } else {
1326 TclEmitOpcode(INST_SUB, envPtr);
1327 }
1328
1329 op = infoPtr->token;
1330
1331 /*
1332 * A comparison is not the top-level operator in this expression.
1333 */
1334
1335 infoPtr->exprIsComparison = 0;
1336 }
1337
1338 done:
1339 envPtr->maxStackDepth = maxDepth;
1340 return result;
1341}
1342
1343
1344/*
1345 *----------------------------------------------------------------------
1346 *
1347 * CompileMultiplyExpr --
1348 *
1349 * This procedure compiles a Tcl multiply expression:
1350 * multiplyExpr ::= unaryExpr {('*' | '/' | '%') unaryExpr}
1351 *
1352 * Results:
1353 * The return value is TCL_OK on a successful compilation and TCL_ERROR
1354 * on failure. If TCL_ERROR is returned, then the interpreter's result
1355 * contains an error message.
1356 *
1357 * envPtr->maxStackDepth is updated with the maximum number of stack
1358 * elements needed to execute the expression.
1359 *
1360 * Side effects:
1361 * Adds instructions to envPtr to evaluate the expression at runtime.
1362 *
1363 *----------------------------------------------------------------------
1364 */
1365
1366static int
1367CompileMultiplyExpr(interp, infoPtr, flags, envPtr)
1368 Tcl_Interp *interp; /* Used for error reporting. */
1369 ExprInfo *infoPtr; /* Describes the compilation state for the
1370 * expression being compiled. */
1371 int flags; /* Flags to control compilation (same as
1372 * passed to Tcl_Eval). */
1373 CompileEnv *envPtr; /* Holds resulting instructions. */
1374{
1375 int maxDepth = 0; /* Maximum number of stack elements needed
1376 * to execute the expression. */
1377 int op, result;
1378
1379 result = CompileUnaryExpr(interp, infoPtr, flags, envPtr);
1380 if (result != TCL_OK) {
1381 goto done;
1382 }
1383 maxDepth = envPtr->maxStackDepth;
1384
1385 op = infoPtr->token;
1386 while ((op == MULT) || (op == DIVIDE) || (op == MOD)) {
1387 infoPtr->hasOperators = 1;
1388 infoPtr->exprIsJustVarRef = 0;
1389 result = GetToken(interp, infoPtr, envPtr); /* skip over * or / */
1390 if (result != TCL_OK) {
1391 goto done;
1392 }
1393
1394 result = CompileUnaryExpr(interp, infoPtr, flags, envPtr);
1395 if (result != TCL_OK) {
1396 goto done;
1397 }
1398 maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
1399
1400 if (op == MULT) {
1401 TclEmitOpcode(INST_MULT, envPtr);
1402 } else if (op == DIVIDE) {
1403 TclEmitOpcode(INST_DIV, envPtr);
1404 } else {
1405 TclEmitOpcode(INST_MOD, envPtr);
1406 }
1407
1408 op = infoPtr->token;
1409
1410 /*
1411 * A comparison is not the top-level operator in this expression.
1412 */
1413
1414 infoPtr->exprIsComparison = 0;
1415 }
1416
1417 done:
1418 envPtr->maxStackDepth = maxDepth;
1419 return result;
1420}
1421
1422
1423/*
1424 *----------------------------------------------------------------------
1425 *
1426 * CompileUnaryExpr --
1427 *
1428 * This procedure compiles a Tcl unary expression:
1429 * unaryExpr ::= ('+' | '-' | '~' | '!') unaryExpr | primaryExpr
1430 *
1431 * Results:
1432 * The return value is TCL_OK on a successful compilation and TCL_ERROR
1433 * on failure. If TCL_ERROR is returned, then the interpreter's result
1434 * contains an error message.
1435 *
1436 * envPtr->maxStackDepth is updated with the maximum number of stack
1437 * elements needed to execute the expression.
1438 *
1439 * Side effects:
1440 * Adds instructions to envPtr to evaluate the expression at runtime.
1441 *
1442 *----------------------------------------------------------------------
1443 */
1444
1445static int
1446CompileUnaryExpr(interp, infoPtr, flags, envPtr)
1447 Tcl_Interp *interp; /* Used for error reporting. */
1448 ExprInfo *infoPtr; /* Describes the compilation state for the
1449 * expression being compiled. */
1450 int flags; /* Flags to control compilation (same as
1451 * passed to Tcl_Eval). */
1452 CompileEnv *envPtr; /* Holds resulting instructions. */
1453{
1454 int maxDepth = 0; /* Maximum number of stack elements needed
1455 * to execute the expression. */
1456 int op, result;
1457
1458 op = infoPtr->token;
1459 if ((op == PLUS) || (op == MINUS) || (op == BIT_NOT) || (op == NOT)) {
1460 infoPtr->hasOperators = 1;
1461 infoPtr->exprIsJustVarRef = 0;
1462 result = GetToken(interp, infoPtr, envPtr); /* skip over the op */
1463 if (result != TCL_OK) {
1464 goto done;
1465 }
1466
1467 result = CompileUnaryExpr(interp, infoPtr, flags, envPtr);
1468 if (result != TCL_OK) {
1469 goto done;
1470 }
1471 maxDepth = envPtr->maxStackDepth;
1472
1473 switch (op) {
1474 case PLUS:
1475 TclEmitOpcode(INST_UPLUS, envPtr);
1476 break;
1477 case MINUS:
1478 TclEmitOpcode(INST_UMINUS, envPtr);
1479 break;
1480 case BIT_NOT:
1481 TclEmitOpcode(INST_BITNOT, envPtr);
1482 break;
1483 case NOT:
1484 TclEmitOpcode(INST_LNOT, envPtr);
1485 break;
1486 }
1487
1488 /*
1489 * A comparison is not the top-level operator in this expression.
1490 */
1491
1492 infoPtr->exprIsComparison = 0;
1493 } else { /* must be a primaryExpr */
1494 result = CompilePrimaryExpr(interp, infoPtr, flags, envPtr);
1495 if (result != TCL_OK) {
1496 goto done;
1497 }
1498 maxDepth = envPtr->maxStackDepth;
1499 }
1500
1501 done:
1502 envPtr->maxStackDepth = maxDepth;
1503 return result;
1504}
1505
1506
1507/*
1508 *----------------------------------------------------------------------
1509 *
1510 * CompilePrimaryExpr --
1511 *
1512 * This procedure compiles a Tcl primary expression:
1513 * primaryExpr ::= literal | varReference | quotedString |
1514 * '[' command ']' | mathFuncCall | '(' condExpr ')'
1515 *
1516 * Results:
1517 * The return value is TCL_OK on a successful compilation and TCL_ERROR
1518 * on failure. If TCL_ERROR is returned, then the interpreter's result
1519 * contains an error message.
1520 *
1521 * envPtr->maxStackDepth is updated with the maximum number of stack
1522 * elements needed to execute the expression.
1523 *
1524 * Side effects:
1525 * Adds instructions to envPtr to evaluate the expression at runtime.
1526 *
1527 *----------------------------------------------------------------------
1528 */
1529
1530static int
1531CompilePrimaryExpr(interp, infoPtr, flags, envPtr)
1532 Tcl_Interp *interp; /* Used for error reporting. */
1533 ExprInfo *infoPtr; /* Describes the compilation state for the
1534 * expression being compiled. */
1535 int flags; /* Flags to control compilation (same as
1536 * passed to Tcl_Eval). */
1537 CompileEnv *envPtr; /* Holds resulting instructions. */
1538{
1539 int maxDepth = 0; /* Maximum number of stack elements needed
1540 * to execute the expression. */
1541 int theToken;
1542 char *dollarPtr, *quotePtr, *cmdPtr, *termPtr;
1543 int result = TCL_OK;
1544
1545 /*
1546 * We emit tryCvtToNumeric instructions after most of these primary
1547 * expressions in order to support Tcl's policy of interpreting operands
1548 * as first integers if possible, otherwise floating-point numbers if
1549 * possible.
1550 */
1551
1552 theToken = infoPtr->token;
1553
1554 if ((theToken != DOLLAR) && (theToken != OPEN_PAREN)) {
1555 infoPtr->exprIsJustVarRef = 0;
1556 }
1557 switch (theToken) {
1558 case LITERAL: /* int, double, or string in braces */
1559 TclEmitPush(infoPtr->objIndex, envPtr);
1560 maxDepth = 1;
1561 break;
1562
1563 case DOLLAR: /* $var variable reference */
1564 dollarPtr = (infoPtr->next - 1);
1565 envPtr->pushSimpleWords = 1;
1566 result = TclCompileDollarVar(interp, dollarPtr,
1567 infoPtr->lastChar, flags, envPtr);
1568 if (result != TCL_OK) {
1569 goto done;
1570 }
1571 maxDepth = envPtr->maxStackDepth;
1572 infoPtr->next = (dollarPtr + envPtr->termOffset);
1573 break;
1574
1575 case QUOTE: /* quotedString */
1576 quotePtr = infoPtr->next;
1577 envPtr->pushSimpleWords = 1;
1578 result = TclCompileQuotes(interp, quotePtr,
1579 infoPtr->lastChar, '"', flags, envPtr);
1580 if (result != TCL_OK) {
1581 goto done;
1582 }
1583 maxDepth = envPtr->maxStackDepth;
1584 infoPtr->next = (quotePtr + envPtr->termOffset);
1585 break;
1586
1587 case OPEN_BRACKET: /* '[' command ']' */
1588 cmdPtr = infoPtr->next;
1589 envPtr->pushSimpleWords = 1;
1590 result = TclCompileString(interp, cmdPtr,
1591 infoPtr->lastChar, (flags | TCL_BRACKET_TERM), envPtr);
1592 if (result != TCL_OK) {
1593 goto done;
1594 }
1595 termPtr = (cmdPtr + envPtr->termOffset);
1596 if (*termPtr == ']') {
1597 infoPtr->next = (termPtr + 1); /* advance over the ']'. */
1598 } else if (termPtr == infoPtr->lastChar) {
1599 /*
1600 * Missing ] at end of nested command.
1601 */
1602
1603 Tcl_ResetResult(interp);
1604 Tcl_AppendToObj(Tcl_GetObjResult(interp),
1605 "missing close-bracket", -1);
1606 result = TCL_ERROR;
1607 goto done;
1608 } else {
1609 panic("CompilePrimaryExpr: unexpected termination char '%c' for nested command\n", *termPtr);
1610 }
1611 maxDepth = envPtr->maxStackDepth;
1612 break;
1613
1614 case FUNC_NAME:
1615 result = CompileMathFuncCall(interp, infoPtr, flags, envPtr);
1616 if (result != TCL_OK) {
1617 goto done;
1618 }
1619 maxDepth = envPtr->maxStackDepth;
1620 break;
1621
1622 case OPEN_PAREN:
1623 result = GetToken(interp, infoPtr, envPtr); /* skip over the '(' */
1624 if (result != TCL_OK) {
1625 goto done;
1626 }
1627 infoPtr->exprIsComparison = 0;
1628 result = CompileCondExpr(interp, infoPtr, flags, envPtr);
1629 if (result != TCL_OK) {
1630 goto done;
1631 }
1632 maxDepth = envPtr->maxStackDepth;
1633 if (infoPtr->token != CLOSE_PAREN) {
1634 goto syntaxError;
1635 }
1636 break;
1637
1638 default:
1639 goto syntaxError;
1640 }
1641
1642 if (theToken != FUNC_NAME) {
1643 /*
1644 * Advance to the next token before returning.
1645 */
1646
1647 result = GetToken(interp, infoPtr, envPtr);
1648 if (result != TCL_OK) {
1649 goto done;
1650 }
1651 }
1652
1653 done:
1654 envPtr->maxStackDepth = maxDepth;
1655 return result;
1656
1657 syntaxError:
1658 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1659 "syntax error in expression \"", infoPtr->originalExpr,
1660 "\"", (char *) NULL);
1661 return TCL_ERROR;
1662}
1663
1664
1665/*
1666 *----------------------------------------------------------------------
1667 *
1668 * CompileMathFuncCall --
1669 *
1670 * This procedure compiles a call on a math function in an expression:
1671 * mathFuncCall ::= funcName '(' [condExpr {',' condExpr}] ')'
1672 *
1673 * Results:
1674 * The return value is TCL_OK on a successful compilation and TCL_ERROR
1675 * on failure. If TCL_ERROR is returned, then the interpreter's result
1676 * contains an error message.
1677 *
1678 * envPtr->maxStackDepth is updated with the maximum number of stack
1679 * elements needed to execute the function.
1680 *
1681 * Side effects:
1682 * Adds instructions to envPtr to evaluate the math function at
1683 * runtime.
1684 *
1685 *----------------------------------------------------------------------
1686 */
1687
1688static int
1689CompileMathFuncCall(interp, infoPtr, flags, envPtr)
1690 Tcl_Interp *interp; /* Used for error reporting. */
1691 ExprInfo *infoPtr; /* Describes the compilation state for the
1692 * expression being compiled. */
1693 int flags; /* Flags to control compilation (same as
1694 * passed to Tcl_Eval). */
1695 CompileEnv *envPtr; /* Holds resulting instructions. */
1696{
1697 Interp *iPtr = (Interp *) interp;
1698 int maxDepth = 0; /* Maximum number of stack elements needed
1699 * to execute the expression. */
1700 MathFunc *mathFuncPtr; /* Info about math function. */
1701 int objIndex; /* The object array index for an object
1702 * holding the function name if it is not
1703 * builtin. */
1704 Tcl_HashEntry *hPtr;
1705 char *p, *funcName;
1706 char savedChar;
1707 int result, i;
1708
1709 /*
1710 * infoPtr->funcName points to the first character of the math
1711 * function's name. Look for the end of its name and look up the
1712 * MathFunc record for the function.
1713 */
1714
1715 funcName = p = infoPtr->funcName;
1716 while (isalnum(UCHAR(*p)) || (*p == '_')) {
1717 p++;
1718 }
1719 infoPtr->next = p;
1720
1721 result = GetToken(interp, infoPtr, envPtr); /* skip over func name */
1722 if (result != TCL_OK) {
1723 goto done;
1724 }
1725 if (infoPtr->token != OPEN_PAREN) {
1726 goto syntaxError;
1727 }
1728 result = GetToken(interp, infoPtr, envPtr); /* skip over '(' */
1729 if (result != TCL_OK) {
1730 goto done;
1731 }
1732
1733 savedChar = *p;
1734 *p = 0;
1735 hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
1736 if (hPtr == NULL) {
1737 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1738 "unknown math function \"", funcName, "\"", (char *) NULL);
1739 result = TCL_ERROR;
1740 *p = savedChar;
1741 goto done;
1742 }
1743 mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
1744
1745 /*
1746 * If not a builtin function, push an object with the function's name.
1747 */
1748
1749 if (mathFuncPtr->builtinFuncIndex < 0) { /* not builtin */
1750 objIndex = TclObjIndexForString(funcName, -1, /*allocStrRep*/ 1,
1751 /*inHeap*/ 0, envPtr);
1752 TclEmitPush(objIndex, envPtr);
1753 maxDepth = 1;
1754 }
1755
1756 /*
1757 * Restore the saved character after the function name.
1758 */
1759
1760 *p = savedChar;
1761
1762 /*
1763 * Compile the arguments for the function, if there are any.
1764 */
1765
1766 if (mathFuncPtr->numArgs > 0) {
1767 for (i = 0; ; i++) {
1768 infoPtr->exprIsComparison = 0;
1769 result = CompileCondExpr(interp, infoPtr, flags, envPtr);
1770 if (result != TCL_OK) {
1771 goto done;
1772 }
1773
1774 /*
1775 * Check for a ',' between arguments or a ')' ending the
1776 * argument list.
1777 */
1778
1779 if (i == (mathFuncPtr->numArgs-1)) {
1780 if (infoPtr->token == CLOSE_PAREN) {
1781 break; /* exit the argument parsing loop */
1782 } else if (infoPtr->token == COMMA) {
1783 Tcl_ResetResult(interp);
1784 Tcl_AppendToObj(Tcl_GetObjResult(interp),
1785 "too many arguments for math function", -1);
1786 result = TCL_ERROR;
1787 goto done;
1788 } else {
1789 goto syntaxError;
1790 }
1791 }
1792 if (infoPtr->token != COMMA) {
1793 if (infoPtr->token == CLOSE_PAREN) {
1794 Tcl_ResetResult(interp);
1795 Tcl_AppendToObj(Tcl_GetObjResult(interp),
1796 "too few arguments for math function", -1);
1797 result = TCL_ERROR;
1798 goto done;
1799 } else {
1800 goto syntaxError;
1801 }
1802 }
1803 result = GetToken(interp, infoPtr, envPtr); /* skip over , */
1804 if (result != TCL_OK) {
1805 goto done;
1806 }
1807 maxDepth++;
1808 }
1809 }
1810
1811 if (infoPtr->token != CLOSE_PAREN) {
1812 goto syntaxError;
1813 }
1814 result = GetToken(interp, infoPtr, envPtr); /* skip over ')' */
1815 if (result != TCL_OK) {
1816 goto done;
1817 }
1818
1819 /*
1820 * Compile the call on the math function. Note that the "objc" argument
1821 * count for non-builtin functions is incremented by 1 to include the
1822 * the function name itself.
1823 */
1824
1825 if (mathFuncPtr->builtinFuncIndex >= 0) { /* a builtin function */
1826 TclEmitInstUInt1(INST_CALL_BUILTIN_FUNC1,
1827 mathFuncPtr->builtinFuncIndex, envPtr);
1828 } else {
1829 TclEmitInstUInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr);
1830 }
1831
1832 /*
1833 * A comparison is not the top-level operator in this expression.
1834 */
1835
1836 done:
1837 infoPtr->exprIsComparison = 0;
1838 envPtr->maxStackDepth = maxDepth;
1839 return result;
1840
1841 syntaxError:
1842 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1843 "syntax error in expression \"", infoPtr->originalExpr,
1844 "\"", (char *) NULL);
1845 return TCL_ERROR;
1846}
1847
1848
1849/*
1850 *----------------------------------------------------------------------
1851 *
1852 * GetToken --
1853 *
1854 * Lexical scanner used to compile expressions: parses a single
1855 * operator or other syntactic element from an expression string.
1856 *
1857 * Results:
1858 * TCL_OK is returned unless an error occurred. In that case a standard
1859 * Tcl error is returned, using the interpreter's result to hold an
1860 * error message. TCL_ERROR is returned if an integer overflow, or a
1861 * floating-point overflow or underflow occurred while reading in a
1862 * number. If the lexical analysis is successful, infoPtr->token refers
1863 * to the next symbol in the expression string, and infoPtr->next is
1864 * advanced past the token. Also, if the token is a integer, double, or
1865 * string literal, then infoPtr->objIndex the index of an object
1866 * holding the value in the code's object table; otherwise is NULL.
1867 *
1868 * Side effects:
1869 * Object are added to envPtr to hold the values of scanned literal
1870 * integers, doubles, or strings.
1871 *
1872 *----------------------------------------------------------------------
1873 */
1874
1875static int
1876GetToken(interp, infoPtr, envPtr)
1877 Tcl_Interp *interp; /* Interpreter to use for error
1878 * reporting. */
1879 register ExprInfo *infoPtr; /* Describes the state of the
1880 * compiling the expression,
1881 * including the resulting token. */
1882 CompileEnv *envPtr; /* Holds objects that store literal
1883 * values that are scanned. */
1884{
1885 register char *src; /* Points to current source char. */
1886 register char c; /* The current char. */
1887 register int type; /* Current char's CHAR_TYPE type. */
1888 char *termPtr; /* Points to char terminating a literal. */
1889 char savedChar; /* Holds the character termporarily replaced
1890 * by a null character during processing of
1891 * literal tokens. */
1892 int objIndex; /* The object array index for an object
1893 * holding a scanned literal. */
1894 long longValue; /* Value of a scanned integer literal. */
1895 double doubleValue; /* Value of a scanned double literal. */
1896 Tcl_Obj *objPtr;
1897
1898 /*
1899 * First initialize the scanner's "result" fields to default values.
1900 */
1901
1902 infoPtr->token = UNKNOWN;
1903 infoPtr->objIndex = -1;
1904 infoPtr->funcName = NULL;
1905
1906 /*
1907 * Scan over leading white space at the start of a token. Note that a
1908 * backslash-newline is treated as a space.
1909 */
1910
1911 src = infoPtr->next;
1912 c = *src;
1913 type = CHAR_TYPE(src, infoPtr->lastChar);
1914 while ((type & (TCL_SPACE | TCL_BACKSLASH)) || (c == '\n')) {
1915 if (type == TCL_BACKSLASH) {
1916 if (src[1] == '\n') {
1917 src += 2;
1918 } else {
1919 break; /* no longer white space */
1920 }
1921 } else {
1922 src++;
1923 }
1924 c = *src;
1925 type = CHAR_TYPE(src, infoPtr->lastChar);
1926 }
1927 if (src == infoPtr->lastChar) {
1928 infoPtr->token = END;
1929 infoPtr->next = src;
1930 return TCL_OK;
1931 }
1932
1933 /*
1934 * Try to parse the token first as an integer or floating-point
1935 * number. Don't check for a number if the first character is "+" or
1936 * "-". If we did, we might treat a binary operator as unary by mistake,
1937 * which would eventually cause a syntax error.
1938 */
1939
1940 if ((*src != '+') && (*src != '-')) {
1941 int startsWithDigit = isdigit(UCHAR(*src));
1942
1943 if (startsWithDigit && TclLooksLikeInt(src)) {
1944 errno = 0;
1945 longValue = strtoul(src, &termPtr, 0);
1946 if (errno == ERANGE) {
1947 char *s = "integer value too large to represent";
1948
1949 Tcl_ResetResult(interp);
1950 Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
1951 Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s,
1952 (char *) NULL);
1953 return TCL_ERROR;
1954 }
1955 if (termPtr != src) {
1956 /*
1957 * src was the start of a valid integer. Find/create an
1958 * object in envPtr's object array to contain the integer.
1959 */
1960
1961 savedChar = *termPtr;
1962 *termPtr = '\0';
1963 objIndex = TclObjIndexForString(src, termPtr - src,
1964 /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr);
1965 *termPtr = savedChar; /* restore the saved char */
1966
1967 objPtr = envPtr->objArrayPtr[objIndex];
1968 Tcl_InvalidateStringRep(objPtr);
1969 objPtr->internalRep.longValue = longValue;
1970 objPtr->typePtr = &tclIntType;
1971
1972 infoPtr->token = LITERAL;
1973 infoPtr->objIndex = objIndex;
1974 infoPtr->next = termPtr;
1975 return TCL_OK;
1976 }
1977 } else if (startsWithDigit || (*src == '.')
1978 || (*src == 'n') || (*src == 'N')) {
1979 errno = 0;
1980 doubleValue = strtod(src, &termPtr);
1981 if (termPtr != src) {
1982 if (errno != 0) {
1983 TclExprFloatError(interp, doubleValue);
1984 return TCL_ERROR;
1985 }
1986
1987 /*
1988 * Find/create an object in the object array containing the
1989 * double.
1990 */
1991
1992 savedChar = *termPtr;
1993 *termPtr = '\0';
1994 objIndex = TclObjIndexForString(src, termPtr - src,
1995 /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
1996 *termPtr = savedChar; /* restore the saved char */
1997
1998 objPtr = envPtr->objArrayPtr[objIndex];
1999 objPtr->internalRep.doubleValue = doubleValue;
2000 objPtr->typePtr = &tclDoubleType;
2001
2002 infoPtr->token = LITERAL;
2003 infoPtr->objIndex = objIndex;
2004 infoPtr->next = termPtr;
2005 return TCL_OK;
2006 }
2007 }
2008 }
2009
2010 /*
2011 * Not an integer or double literal. Check next for a string literal
2012 * in braces.
2013 */
2014
2015 if (*src == '{') {
2016 int level = 0; /* The {} nesting level. */
2017 int hasBackslashNL = 0; /* Nonzero if '\newline' was found. */
2018 char *string = src; /* Set below to point just after the
2019 * starting '{'. */
2020 char *last; /* Points just before terminating '}'. */
2021 int numChars; /* Number of chars in braced string. */
2022 char savedChar; /* Holds the character from string
2023 * termporarily replaced by a null char
2024 * during braced string processing. */
2025 int numRead;
2026
2027 /*
2028 * Check first for any backslash-newlines, since we must treat
2029 * backslash-newlines specially (they must be replaced by spaces).
2030 */
2031
2032 while (1) {
2033 if (src == infoPtr->lastChar) {
2034 Tcl_ResetResult(interp);
2035 Tcl_AppendToObj(Tcl_GetObjResult(interp),
2036 "missing close-brace", -1);
2037 return TCL_ERROR;
2038 } else if (CHAR_TYPE(src, infoPtr->lastChar) == TCL_NORMAL) {
2039 src++;
2040 continue;
2041 }
2042 c = *src++;
2043 if (c == '{') {
2044 level++;
2045 } else if (c == '}') {
2046 --level;
2047 if (level == 0) {
2048 last = (src - 2); /* i.e. just before terminating } */
2049 break;
2050 }
2051 } else if (c == '\\') {
2052 if (*src == '\n') {
2053 hasBackslashNL = 1;
2054 }
2055 (void) Tcl_Backslash(src-1, &numRead);
2056 src += numRead - 1;
2057 }
2058 }
2059
2060 /*
2061 * Create a string object for the braced string. This will start at
2062 * "string" and ends just after "last" (which points to the final
2063 * character before the terminating '}'). If backslash-newlines were
2064 * found, we copy characters one at a time into a heap-allocated
2065 * buffer and do backslash-newline substitutions.
2066 */
2067
2068 string++;
2069 numChars = (last - string + 1);
2070 savedChar = string[numChars];
2071 string[numChars] = '\0';
2072 if (hasBackslashNL && (numChars > 0)) {
2073 char *buffer = ckalloc((unsigned) numChars + 1);
2074 register char *dst = buffer;
2075 register char *p = string;
2076 while (p <= last) {
2077 c = *dst++ = *p++;
2078 if (c == '\\') {
2079 if (*p == '\n') {
2080 dst[-1] = Tcl_Backslash(p-1, &numRead);
2081 p += numRead - 1;
2082 } else {
2083 (void) Tcl_Backslash(p-1, &numRead);
2084 while (numRead > 1) {
2085 *dst++ = *p++;
2086 numRead--;
2087 }
2088 }
2089 }
2090 }
2091 *dst = '\0';
2092 objIndex = TclObjIndexForString(buffer, dst - buffer,
2093 /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr);
2094 } else {
2095 objIndex = TclObjIndexForString(string, numChars,
2096 /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
2097 }
2098 string[numChars] = savedChar; /* restore the saved char */
2099
2100 infoPtr->token = LITERAL;
2101 infoPtr->objIndex = objIndex;
2102 infoPtr->next = src;
2103 return TCL_OK;
2104 }
2105
2106 /*
2107 * Not an literal value.
2108 */
2109
2110 infoPtr->next = src+1; /* assume a 1 char token and advance over it */
2111 switch (*src) {
2112 case '[':
2113 infoPtr->token = OPEN_BRACKET;
2114 return TCL_OK;
2115
2116 case ']':
2117 infoPtr->token = CLOSE_BRACKET;
2118 return TCL_OK;
2119
2120 case '(':
2121 infoPtr->token = OPEN_PAREN;
2122 return TCL_OK;
2123
2124 case ')':
2125 infoPtr->token = CLOSE_PAREN;
2126 return TCL_OK;
2127
2128 case '$':
2129 infoPtr->token = DOLLAR;
2130 return TCL_OK;
2131
2132 case '"':
2133 infoPtr->token = QUOTE;
2134 return TCL_OK;
2135
2136 case ',':
2137 infoPtr->token = COMMA;
2138 return TCL_OK;
2139
2140 case '*':
2141 infoPtr->token = MULT;
2142 return TCL_OK;
2143
2144 case '/':
2145 infoPtr->token = DIVIDE;
2146 return TCL_OK;
2147
2148 case '%':
2149 infoPtr->token = MOD;
2150 return TCL_OK;
2151
2152 case '+':
2153 infoPtr->token = PLUS;
2154 return TCL_OK;
2155
2156 case '-':
2157 infoPtr->token = MINUS;
2158 return TCL_OK;
2159
2160 case '?':
2161 infoPtr->token = QUESTY;
2162 return TCL_OK;
2163
2164 case ':':
2165 infoPtr->token = COLON;
2166 return TCL_OK;
2167
2168 case '<':
2169 switch (src[1]) {
2170 case '<':
2171 infoPtr->next = src+2;
2172 infoPtr->token = LEFT_SHIFT;
2173 break;
2174 case '=':
2175 infoPtr->next = src+2;
2176 infoPtr->token = LEQ;
2177 break;
2178 default:
2179 infoPtr->token = LESS;
2180 break;
2181 }
2182 return TCL_OK;
2183
2184 case '>':
2185 switch (src[1]) {
2186 case '>':
2187 infoPtr->next = src+2;
2188 infoPtr->token = RIGHT_SHIFT;
2189 break;
2190 case '=':
2191 infoPtr->next = src+2;
2192 infoPtr->token = GEQ;
2193 break;
2194 default:
2195 infoPtr->token = GREATER;
2196 break;
2197 }
2198 return TCL_OK;
2199
2200 case '=':
2201 if (src[1] == '=') {
2202 infoPtr->next = src+2;
2203 infoPtr->token = EQUAL;
2204 } else {
2205 infoPtr->token = UNKNOWN;
2206 }
2207 return TCL_OK;
2208
2209 case '!':
2210 if (src[1] == '=') {
2211 infoPtr->next = src+2;
2212 infoPtr->token = NEQ;
2213 } else {
2214 infoPtr->token = NOT;
2215 }
2216 return TCL_OK;
2217
2218 case '&':
2219 if (src[1] == '&') {
2220 infoPtr->next = src+2;
2221 infoPtr->token = AND;
2222 } else {
2223 infoPtr->token = BIT_AND;
2224 }
2225 return TCL_OK;
2226
2227 case '^':
2228 infoPtr->token = BIT_XOR;
2229 return TCL_OK;
2230
2231 case '|':
2232 if (src[1] == '|') {
2233 infoPtr->next = src+2;
2234 infoPtr->token = OR;
2235 } else {
2236 infoPtr->token = BIT_OR;
2237 }
2238 return TCL_OK;
2239
2240 case '~':
2241 infoPtr->token = BIT_NOT;
2242 return TCL_OK;
2243
2244 default:
2245 if (isalpha(UCHAR(*src))) {
2246 infoPtr->token = FUNC_NAME;
2247 infoPtr->funcName = src;
2248 while (isalnum(UCHAR(*src)) || (*src == '_')) {
2249 src++;
2250 }
2251 infoPtr->next = src;
2252 return TCL_OK;
2253 }
2254 infoPtr->next = src+1;
2255 infoPtr->token = UNKNOWN;
2256 return TCL_OK;
2257 }
2258}
2259
2260
2261/*
2262 *----------------------------------------------------------------------
2263 *
2264 * Tcl_CreateMathFunc --
2265 *
2266 * Creates a new math function for expressions in a given
2267 * interpreter.
2268 *
2269 * Results:
2270 * None.
2271 *
2272 * Side effects:
2273 * The function defined by "name" is created or redefined. If the
2274 * function already exists then its definition is replaced; this
2275 * includes the builtin functions. Redefining a builtin function forces
2276 * all existing code to be invalidated since that code may be compiled
2277 * using an instruction specific to the replaced function. In addition,
2278 * redefioning a non-builtin function will force existing code to be
2279 * invalidated if the number of arguments has changed.
2280 *
2281 *----------------------------------------------------------------------
2282 */
2283
2284void
2285Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
2286 Tcl_Interp *interp; /* Interpreter in which function is
2287 * to be available. */
2288 char *name; /* Name of function (e.g. "sin"). */
2289 int numArgs; /* Nnumber of arguments required by
2290 * function. */
2291 Tcl_ValueType *argTypes; /* Array of types acceptable for
2292 * each argument. */
2293 Tcl_MathProc *proc; /* Procedure that implements the
2294 * math function. */
2295 ClientData clientData; /* Additional value to pass to the
2296 * function. */
2297{
2298 Interp *iPtr = (Interp *) interp;
2299 Tcl_HashEntry *hPtr;
2300 MathFunc *mathFuncPtr;
2301 int new, i;
2302
2303 hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new);
2304 if (new) {
2305 Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc)));
2306 }
2307 mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
2308
2309 if (!new) {
2310 if (mathFuncPtr->builtinFuncIndex >= 0) {
2311 /*
2312 * We are redefining a builtin math function. Invalidate the
2313 * interpreter's existing code by incrementing its
2314 * compileEpoch member. This field is checked in Tcl_EvalObj
2315 * and ObjInterpProc, and code whose compilation epoch doesn't
2316 * match is recompiled. Newly compiled code will no longer
2317 * treat the function as builtin.
2318 */
2319
2320 iPtr->compileEpoch++;
2321 } else {
2322 /*
2323 * A non-builtin function is being redefined. We must invalidate
2324 * existing code if the number of arguments has changed. This
2325 * is because existing code was compiled assuming that number.
2326 */
2327
2328 if (numArgs != mathFuncPtr->numArgs) {
2329 iPtr->compileEpoch++;
2330 }
2331 }
2332 }
2333
2334 mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */
2335 if (numArgs > MAX_MATH_ARGS) {
2336 numArgs = MAX_MATH_ARGS;
2337 }
2338 mathFuncPtr->numArgs = numArgs;
2339 for (i = 0; i < numArgs; i++) {
2340 mathFuncPtr->argTypes[i] = argTypes[i];
2341 }
2342 mathFuncPtr->proc = proc;
2343 mathFuncPtr->clientData = clientData;
2344}
Note: See TracBrowser for help on using the repository browser.