Fork me on GitHub

source: git/external/tcl/tclCompExpr.c@ 8abab33

ImprovedOutputFile Timing dual_readout llp
Last change on this file since 8abab33 was d7d2da3, checked in by pavel <pavel@…>, 12 years ago

move branches/ModularDelphes to trunk

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