]> cvs.zerfleddert.de Git - micropolis/blob - src/tcl/tclexpr.c
projects / micropolis / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
src/tclx/tkucbsrc/makefile: Micropolis build fixes for recent macOS
[micropolis] / src / tcl / tclexpr.c
1 /*
2 * tclExpr.c --
3 *
4 * This file contains the code to evaluate expressions for
5 * Tcl.
6 *
7 * This implementation of floating-point support was modelled
8 * after an initial implementation by Bill Carpenter.
9 *
10 * Copyright 1987-1991 Regents of the University of California
11 * Permission to use, copy, modify, and distribute this
12 * software and its documentation for any purpose and without
13 * fee is hereby granted, provided that the above copyright
14 * notice appear in all copies. The University of California
15 * makes no representations about the suitability of this
16 * software for any purpose. It is provided "as is" without
17 * express or implied warranty.
18 */
19
20 #ifndef lint
21 static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclExpr.c,v 1.35 92/03/23 09:53:46 ouster Exp $ SPRITE (Berkeley)";
22 #endif
23
24 #include "tclint.h"
25
26 /*
27 * The stuff below is a bit of a workaround so that this file can be used
28 * in environments that include no UNIX, i.e. no errno. Just define
29 * errno here.
30 */
31
32 #ifndef TCL_GENERIC_ONLY
33 #include "tclunix.h"
34 #else
35 int errno;
36 #define ERANGE 34
37 #endif
38
39 /*
40 * The data structure below is used to describe an expression value,
41 * which can be either an integer (the usual case), a double-precision
42 * floating-point value, or a string. A given number has only one
43 * value at a time.
44 */
45
46 #define STATIC_STRING_SPACE 150
47
48 typedef struct {
49 long intValue; /* Integer value, if any. */
50 double doubleValue; /* Floating-point value, if any. */
51 ParseValue pv; /* Used to hold a string value, if any. */
52 char staticSpace[STATIC_STRING_SPACE];
53 /* Storage for small strings; large ones
54 * are malloc-ed. */
55 int type; /* Type of value: TYPE_INT, TYPE_DOUBLE,
56 * or TYPE_STRING. */
57 } Value;
58
59 /*
60 * Valid values for type:
61 */
62
63 #define TYPE_INT 0
64 #define TYPE_DOUBLE 1
65 #define TYPE_STRING 2
66
67
68 /*
69 * The data structure below describes the state of parsing an expression.
70 * It's passed among the routines in this module.
71 */
72
73 typedef struct {
74 char *originalExpr; /* The entire expression, as originally
75 * passed to Tcl_Expr. */
76 char *expr; /* Position to the next character to be
77 * scanned from the expression string. */
78 int token; /* Type of the last token to be parsed from
79 * expr. See below for definitions.
80 * Corresponds to the characters just
81 * before expr. */
82 } ExprInfo;
83
84 /*
85 * The token types are defined below. In addition, there is a table
86 * associating a precedence with each operator. The order of types
87 * is important. Consult the code before changing it.
88 */
89
90 #define VALUE 0
91 #define OPEN_PAREN 1
92 #define CLOSE_PAREN 2
93 #define END 3
94 #define UNKNOWN 4
95
96 /*
97 * Binary operators:
98 */
99
100 #define MULT 8
101 #define DIVIDE 9
102 #define MOD 10
103 #define PLUS 11
104 #define MINUS 12
105 #define LEFT_SHIFT 13
106 #define RIGHT_SHIFT 14
107 #define LESS 15
108 #define GREATER 16
109 #define LEQ 17
110 #define GEQ 18
111 #define EQUAL 19
112 #define NEQ 20
113 #define BIT_AND 21
114 #define BIT_XOR 22
115 #define BIT_OR 23
116 #define AND 24
117 #define OR 25
118 #define QUESTY 26
119 #define COLON 27
120
121 /*
122 * Unary operators:
123 */
124
125 #define UNARY_MINUS 28
126 #define NOT 29
127 #define BIT_NOT 30
128
129 /*
130 * Precedence table. The values for non-operator token types are ignored.
131 */
132
133 int precTable[] = {
134 0, 0, 0, 0, 0, 0, 0, 0,
135 11, 11, 11, /* MULT, DIVIDE, MOD */
136 10, 10, /* PLUS, MINUS */
137 9, 9, /* LEFT_SHIFT, RIGHT_SHIFT */
138 8, 8, 8, 8, /* LESS, GREATER, LEQ, GEQ */
139 7, 7, /* EQUAL, NEQ */
140 6, /* BIT_AND */
141 5, /* BIT_XOR */
142 4, /* BIT_OR */
143 3, /* AND */
144 2, /* OR */
145 1, 1, /* QUESTY, COLON */
146 12, 12, 12 /* UNARY_MINUS, NOT, BIT_NOT */
147 };
148
149 /*
150 * Mapping from operator numbers to strings; used for error messages.
151 */
152
153 char *operatorStrings[] = {
154 "VALUE", "(", ")", "END", "UNKNOWN", "5", "6", "7",
155 "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=",
156 ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":",
157 "-", "!", "~"
158 };
159
160 /*
161 * Declarations for local procedures to this file:
162 */
163
164 static int ExprGetValue _ANSI_ARGS_((Tcl_Interp *interp,
165 ExprInfo *infoPtr, int prec, Value *valuePtr));
166 static int ExprLex _ANSI_ARGS_((Tcl_Interp *interp,
167 ExprInfo *infoPtr, Value *valuePtr));
168 static void ExprMakeString _ANSI_ARGS_((Value *valuePtr));
169 static int ExprParseString _ANSI_ARGS_((Tcl_Interp *interp,
170 char *string, Value *valuePtr));
171 static int ExprTopLevel _ANSI_ARGS_((Tcl_Interp *interp,
172 char *string, Value *valuePtr));
173 \f
174 /*
175 *--------------------------------------------------------------
176 *
177 * ExprParseString --
178 *
179 * Given a string (such as one coming from command or variable
180 * substitution), make a Value based on the string. The value
181 * will be a floating-point or integer, if possible, or else it
182 * will just be a copy of the string.
183 *
184 * Results:
185 * TCL_OK is returned under normal circumstances, and TCL_ERROR
186 * is returned if a floating-point overflow or underflow occurred
187 * while reading in a number. The value at *valuePtr is modified
188 * to hold a number, if possible.
189 *
190 * Side effects:
191 * None.
192 *
193 *--------------------------------------------------------------
194 */
195
196 static int
197 ExprParseString(interp, string, valuePtr)
198 Tcl_Interp *interp; /* Where to store error message. */
199 char *string; /* String to turn into value. */
200 Value *valuePtr; /* Where to store value information.
201 * Caller must have initialized pv field. */
202 {
203 register char c;
204
205 /*
206 * Try to convert the string to a number.
207 */
208
209 c = *string;
210 if (((c >= '0') && (c <= '9')) || (c == '-') || (c == '.')) {
211 char *term;
212
213 valuePtr->type = TYPE_INT;
214 errno = 0;
215 valuePtr->intValue = strtol(string, &term, 0);
216 c = *term;
217 if ((c == '\0') && (errno != ERANGE)) {
218 return TCL_OK;
219 }
220 if ((c == '.') || (c == 'e') || (c == 'E') || (errno == ERANGE)) {
221 errno = 0;
222 valuePtr->doubleValue = strtod(string, &term);
223 if (errno == ERANGE) {
224 Tcl_ResetResult(interp);
225 if (valuePtr->doubleValue == 0.0) {
226 Tcl_AppendResult(interp, "floating-point value \"",
227 string, "\" too small to represent",
228 (char *) NULL);
229 } else {
230 Tcl_AppendResult(interp, "floating-point value \"",
231 string, "\" too large to represent",
232 (char *) NULL);
233 }
234 return TCL_ERROR;
235 }
236 if (*term == '\0') {
237 valuePtr->type = TYPE_DOUBLE;
238 return TCL_OK;
239 }
240 }
241 }
242
243 /*
244 * Not a valid number. Save a string value (but don't do anything
245 * if it's already the value).
246 */
247
248 valuePtr->type = TYPE_STRING;
249 if (string != valuePtr->pv.buffer) {
250 int length, shortfall;
251
252 length = strlen(string);
253 valuePtr->pv.next = valuePtr->pv.buffer;
254 shortfall = length - (valuePtr->pv.end - valuePtr->pv.buffer);
255 if (shortfall > 0) {
256 (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall);
257 }
258 strcpy(valuePtr->pv.buffer, string);
259 }
260 return TCL_OK;
261 }
262 \f
263 /*
264 *----------------------------------------------------------------------
265 *
266 * ExprLex --
267 *
268 * Lexical analyzer for expression parser: parses a single value,
269 * operator, or other syntactic element from an expression string.
270 *
271 * Results:
272 * TCL_OK is returned unless an error occurred while doing lexical
273 * analysis or executing an embedded command. In that case a
274 * standard Tcl error is returned, using interp->result to hold
275 * an error message. In the event of a successful return, the token
276 * and field in infoPtr is updated to refer to the next symbol in
277 * the expression string, and the expr field is advanced past that
278 * token; if the token is a value, then the value is stored at
279 * valuePtr.
280 *
281 * Side effects:
282 * None.
283 *
284 *----------------------------------------------------------------------
285 */
286
287 static int
288 ExprLex(interp, infoPtr, valuePtr)
289 Tcl_Interp *interp; /* Interpreter to use for error
290 * reporting. */
291 register ExprInfo *infoPtr; /* Describes the state of the parse. */
292 register Value *valuePtr; /* Where to store value, if that is
293 * what's parsed from string. Caller
294 * must have initialized pv field
295 * correctly. */
296 {
297 register char *p, c;
298 char *var, *term;
299 int result;
300
301 p = infoPtr->expr;
302 c = *p;
303 while (isspace(c)) {
304 p++;
305 c = *p;
306 }
307 infoPtr->expr = p+1;
308 switch (c) {
309 case '0':
310 case '1':
311 case '2':
312 case '3':
313 case '4':
314 case '5':
315 case '6':
316 case '7':
317 case '8':
318 case '9':
319 case '.':
320
321 /*
322 * Number. First read an integer. Then if it looks like
323 * there's a floating-point number (or if it's too big a
324 * number to fit in an integer), parse it as a floating-point
325 * number.
326 */
327
328 infoPtr->token = VALUE;
329 valuePtr->type = TYPE_INT;
330 errno = 0;
331 valuePtr->intValue = strtoul(p, &term, 0);
332 c = *term;
333 if ((c == '.') || (c == 'e') || (c == 'E') || (errno == ERANGE)) {
334 char *term2;
335
336 errno = 0;
337 valuePtr->doubleValue = strtod(p, &term2);
338 if (errno == ERANGE) {
339 Tcl_ResetResult(interp);
340 if (valuePtr->doubleValue == 0.0) {
341 interp->result =
342 "floating-point value too small to represent";
343 } else {
344 interp->result =
345 "floating-point value too large to represent";
346 }
347 return TCL_ERROR;
348 }
349 if (term2 == infoPtr->expr) {
350 interp->result = "poorly-formed floating-point value";
351 return TCL_ERROR;
352 }
353 valuePtr->type = TYPE_DOUBLE;
354 infoPtr->expr = term2;
355 } else {
356 infoPtr->expr = term;
357 }
358 return TCL_OK;
359
360 case '$':
361
362 /*
363 * Variable. Fetch its value, then see if it makes sense
364 * as an integer or floating-point number.
365 */
366
367 infoPtr->token = VALUE;
368 var = Tcl_ParseVar(interp, p, &infoPtr->expr);
369 if (var == NULL) {
370 return TCL_ERROR;
371 }
372 if (((Interp *) interp)->noEval) {
373 valuePtr->type = TYPE_INT;
374 valuePtr->intValue = 0;
375 return TCL_OK;
376 }
377 return ExprParseString(interp, var, valuePtr);
378
379 case '[':
380 infoPtr->token = VALUE;
381 result = Tcl_Eval(interp, p+1, TCL_BRACKET_TERM,
382 &infoPtr->expr);
383 if (result != TCL_OK) {
384 return result;
385 }
386 infoPtr->expr++;
387 if (((Interp *) interp)->noEval) {
388 valuePtr->type = TYPE_INT;
389 valuePtr->intValue = 0;
390 Tcl_ResetResult(interp);
391 return TCL_OK;
392 }
393 result = ExprParseString(interp, interp->result, valuePtr);
394 if (result != TCL_OK) {
395 return result;
396 }
397 Tcl_ResetResult(interp);
398 return TCL_OK;
399
400 case '"':
401 infoPtr->token = VALUE;
402 result = TclParseQuotes(interp, infoPtr->expr, '"', 0,
403 &infoPtr->expr, &valuePtr->pv);
404 if (result != TCL_OK) {
405 return result;
406 }
407 return ExprParseString(interp, valuePtr->pv.buffer, valuePtr);
408
409 case '{':
410 infoPtr->token = VALUE;
411 result = TclParseBraces(interp, infoPtr->expr, &infoPtr->expr,
412 &valuePtr->pv);
413 if (result != TCL_OK) {
414 return result;
415 }
416 return ExprParseString(interp, valuePtr->pv.buffer, valuePtr);
417
418 case '(':
419 infoPtr->token = OPEN_PAREN;
420 return TCL_OK;
421
422 case ')':
423 infoPtr->token = CLOSE_PAREN;
424 return TCL_OK;
425
426 case '*':
427 infoPtr->token = MULT;
428 return TCL_OK;
429
430 case '/':
431 infoPtr->token = DIVIDE;
432 return TCL_OK;
433
434 case '%':
435 infoPtr->token = MOD;
436 return TCL_OK;
437
438 case '+':
439 infoPtr->token = PLUS;
440 return TCL_OK;
441
442 case '-':
443 infoPtr->token = MINUS;
444 return TCL_OK;
445
446 case '?':
447 infoPtr->token = QUESTY;
448 return TCL_OK;
449
450 case ':':
451 infoPtr->token = COLON;
452 return TCL_OK;
453
454 case '<':
455 switch (p[1]) {
456 case '<':
457 infoPtr->expr = p+2;
458 infoPtr->token = LEFT_SHIFT;
459 break;
460 case '=':
461 infoPtr->expr = p+2;
462 infoPtr->token = LEQ;
463 break;
464 default:
465 infoPtr->token = LESS;
466 break;
467 }
468 return TCL_OK;
469
470 case '>':
471 switch (p[1]) {
472 case '>':
473 infoPtr->expr = p+2;
474 infoPtr->token = RIGHT_SHIFT;
475 break;
476 case '=':
477 infoPtr->expr = p+2;
478 infoPtr->token = GEQ;
479 break;
480 default:
481 infoPtr->token = GREATER;
482 break;
483 }
484 return TCL_OK;
485
486 case '=':
487 if (p[1] == '=') {
488 infoPtr->expr = p+2;
489 infoPtr->token = EQUAL;
490 } else {
491 infoPtr->token = UNKNOWN;
492 }
493 return TCL_OK;
494
495 case '!':
496 if (p[1] == '=') {
497 infoPtr->expr = p+2;
498 infoPtr->token = NEQ;
499 } else {
500 infoPtr->token = NOT;
501 }
502 return TCL_OK;
503
504 case '&':
505 if (p[1] == '&') {
506 infoPtr->expr = p+2;
507 infoPtr->token = AND;
508 } else {
509 infoPtr->token = BIT_AND;
510 }
511 return TCL_OK;
512
513 case '^':
514 infoPtr->token = BIT_XOR;
515 return TCL_OK;
516
517 case '|':
518 if (p[1] == '|') {
519 infoPtr->expr = p+2;
520 infoPtr->token = OR;
521 } else {
522 infoPtr->token = BIT_OR;
523 }
524 return TCL_OK;
525
526 case '~':
527 infoPtr->token = BIT_NOT;
528 return TCL_OK;
529
530 case 0:
531 infoPtr->token = END;
532 infoPtr->expr = p;
533 return TCL_OK;
534
535 default:
536 infoPtr->expr = p+1;
537 infoPtr->token = UNKNOWN;
538 return TCL_OK;
539 }
540 }
541 \f
542 /*
543 *----------------------------------------------------------------------
544 *
545 * ExprGetValue --
546 *
547 * Parse a "value" from the remainder of the expression in infoPtr.
548 *
549 * Results:
550 * Normally TCL_OK is returned. The value of the expression is
551 * returned in *valuePtr. If an error occurred, then interp->result
552 * contains an error message and TCL_ERROR is returned.
553 * InfoPtr->token will be left pointing to the token AFTER the
554 * expression, and infoPtr->expr will point to the character just
555 * after the terminating token.
556 *
557 * Side effects:
558 * None.
559 *
560 *----------------------------------------------------------------------
561 */
562
563 static int
564 ExprGetValue(interp, infoPtr, prec, valuePtr)
565 Tcl_Interp *interp; /* Interpreter to use for error
566 * reporting. */
567 register ExprInfo *infoPtr; /* Describes the state of the parse
568 * just before the value (i.e. ExprLex
569 * will be called to get first token
570 * of value). */
571 int prec; /* Treat any un-parenthesized operator
572 * with precedence <= this as the end
573 * of the expression. */
574 Value *valuePtr; /* Where to store the value of the
575 * expression. Caller must have
576 * initialized pv field. */
577 {
578 Interp *iPtr = (Interp *) interp;
579 Value value2; /* Second operand for current
580 * operator. */
581 int operator; /* Current operator (either unary
582 * or binary). */
583 int badType; /* Type of offending argument; used
584 * for error messages. */
585 int gotOp; /* Non-zero means already lexed the
586 * operator (while picking up value
587 * for unary operator). Don't lex
588 * again. */
589 int result;
590
591 /*
592 * There are two phases to this procedure. First, pick off an initial
593 * value. Then, parse (binary operator, value) pairs until done.
594 */
595
596 gotOp = 0;
597 value2.pv.buffer = value2.pv.next = value2.staticSpace;
598 value2.pv.end = value2.pv.buffer + STATIC_STRING_SPACE - 1;
599 value2.pv.expandProc = TclExpandParseValue;
600 value2.pv.clientData = (ClientData) NULL;
601 result = ExprLex(interp, infoPtr, valuePtr);
602 if (result != TCL_OK) {
603 goto done;
604 }
605 if (infoPtr->token == OPEN_PAREN) {
606
607 /*
608 * Parenthesized sub-expression.
609 */
610
611 result = ExprGetValue(interp, infoPtr, -1, valuePtr);
612 if (result != TCL_OK) {
613 goto done;
614 }
615 if (infoPtr->token != CLOSE_PAREN) {
616 Tcl_ResetResult(interp);
617 sprintf(interp->result,
618 "unmatched parentheses in expression \"%.50s\"",
619 infoPtr->originalExpr);
620 result = TCL_ERROR;
621 goto done;
622 }
623 } else {
624 if (infoPtr->token == MINUS) {
625 infoPtr->token = UNARY_MINUS;
626 }
627 if (infoPtr->token >= UNARY_MINUS) {
628
629 /*
630 * Process unary operators.
631 */
632
633 operator = infoPtr->token;
634 result = ExprGetValue(interp, infoPtr, precTable[infoPtr->token],
635 valuePtr);
636 if (result != TCL_OK) {
637 goto done;
638 }
639 switch (operator) {
640 case UNARY_MINUS:
641 if (valuePtr->type == TYPE_INT) {
642 valuePtr->intValue = -valuePtr->intValue;
643 } else if (valuePtr->type == TYPE_DOUBLE){
644 valuePtr->doubleValue = -valuePtr->doubleValue;
645 } else {
646 badType = valuePtr->type;
647 goto illegalType;
648 }
649 break;
650 case NOT:
651 if (valuePtr->type == TYPE_INT) {
652 valuePtr->intValue = !valuePtr->intValue;
653 } else if (valuePtr->type == TYPE_DOUBLE) {
654 /*
655 * Theoretically, should be able to use
656 * "!valuePtr->intValue", but apparently some
657 * compilers can't handle it.
658 */
659 if (valuePtr->doubleValue == 0.0) {
660 valuePtr->intValue = 1;
661 } else {
662 valuePtr->intValue = 0;
663 }
664 valuePtr->type = TYPE_INT;
665 } else {
666 badType = valuePtr->type;
667 goto illegalType;
668 }
669 break;
670 case BIT_NOT:
671 if (valuePtr->type == TYPE_INT) {
672 valuePtr->intValue = ~valuePtr->intValue;
673 } else {
674 badType = valuePtr->type;
675 goto illegalType;
676 }
677 break;
678 }
679 gotOp = 1;
680 } else if (infoPtr->token != VALUE) {
681 goto syntaxError;
682 }
683 }
684
685 /*
686 * Got the first operand. Now fetch (operator, operand) pairs.
687 */
688
689 if (!gotOp) {
690 result = ExprLex(interp, infoPtr, &value2);
691 if (result != TCL_OK) {
692 goto done;
693 }
694 }
695 while (1) {
696 operator = infoPtr->token;
697 value2.pv.next = value2.pv.buffer;
698 if ((operator < MULT) || (operator >= UNARY_MINUS)) {
699 if ((operator == END) || (operator == CLOSE_PAREN)) {
700 result = TCL_OK;
701 goto done;
702 } else {
703 goto syntaxError;
704 }
705 }
706 if (precTable[operator] <= prec) {
707 result = TCL_OK;
708 goto done;
709 }
710
711 /*
712 * If we're doing an AND or OR and the first operand already
713 * determines the result, don't execute anything in the
714 * second operand: just parse. Same style for ?: pairs.
715 */
716
717 if ((operator == AND) || (operator == OR) || (operator == QUESTY)) {
718 if (valuePtr->type == TYPE_DOUBLE) {
719 valuePtr->intValue = valuePtr->doubleValue != 0;
720 valuePtr->type = TYPE_INT;
721 } else if (valuePtr->type == TYPE_STRING) {
722 badType = TYPE_STRING;
723 goto illegalType;
724 }
725 if (((operator == AND) && !valuePtr->intValue)
726 || ((operator == OR) && valuePtr->intValue)) {
727 iPtr->noEval++;
728 result = ExprGetValue(interp, infoPtr, precTable[operator],
729 &value2);
730 iPtr->noEval--;
731 } else if (operator == QUESTY) {
732 if (valuePtr->intValue != 0) {
733 valuePtr->pv.next = valuePtr->pv.buffer;
734 result = ExprGetValue(interp, infoPtr, precTable[operator],
735 valuePtr);
736 if (result != TCL_OK) {
737 goto done;
738 }
739 if (infoPtr->token != COLON) {
740 goto syntaxError;
741 }
742 value2.pv.next = value2.pv.buffer;
743 iPtr->noEval++;
744 result = ExprGetValue(interp, infoPtr, precTable[operator],
745 &value2);
746 iPtr->noEval--;
747 } else {
748 iPtr->noEval++;
749 result = ExprGetValue(interp, infoPtr, precTable[operator],
750 &value2);
751 iPtr->noEval--;
752 if (result != TCL_OK) {
753 goto done;
754 }
755 if (infoPtr->token != COLON) {
756 goto syntaxError;
757 }
758 valuePtr->pv.next = valuePtr->pv.buffer;
759 result = ExprGetValue(interp, infoPtr, precTable[operator],
760 valuePtr);
761 }
762 } else {
763 result = ExprGetValue(interp, infoPtr, precTable[operator],
764 &value2);
765 }
766 } else {
767 result = ExprGetValue(interp, infoPtr, precTable[operator],
768 &value2);
769 }
770 if (result != TCL_OK) {
771 goto done;
772 }
773 if ((infoPtr->token < MULT) && (infoPtr->token != VALUE)
774 && (infoPtr->token != END)
775 && (infoPtr->token != CLOSE_PAREN)) {
776 goto syntaxError;
777 }
778
779 /*
780 * At this point we've got two values and an operator. Check
781 * to make sure that the particular data types are appropriate
782 * for the particular operator, and perform type conversion
783 * if necessary.
784 */
785
786 switch (operator) {
787
788 /*
789 * For the operators below, no strings are allowed and
790 * ints get converted to floats if necessary.
791 */
792
793 case MULT: case DIVIDE: case PLUS: case MINUS:
794 if ((valuePtr->type == TYPE_STRING)
795 || (value2.type == TYPE_STRING)) {
796 badType = TYPE_STRING;
797 goto illegalType;
798 }
799 if (valuePtr->type == TYPE_DOUBLE) {
800 if (value2.type == TYPE_INT) {
801 value2.doubleValue = value2.intValue;
802 value2.type = TYPE_DOUBLE;
803 }
804 } else if (value2.type == TYPE_DOUBLE) {
805 if (valuePtr->type == TYPE_INT) {
806 valuePtr->doubleValue = valuePtr->intValue;
807 valuePtr->type = TYPE_DOUBLE;
808 }
809 }
810 break;
811
812 /*
813 * For the operators below, only integers are allowed.
814 */
815
816 case MOD: case LEFT_SHIFT: case RIGHT_SHIFT:
817 case BIT_AND: case BIT_XOR: case BIT_OR:
818 if (valuePtr->type != TYPE_INT) {
819 badType = valuePtr->type;
820 goto illegalType;
821 } else if (value2.type != TYPE_INT) {
822 badType = value2.type;
823 goto illegalType;
824 }
825 break;
826
827 /*
828 * For the operators below, any type is allowed but the
829 * two operands must have the same type. Convert integers
830 * to floats and either to strings, if necessary.
831 */
832
833 case LESS: case GREATER: case LEQ: case GEQ:
834 case EQUAL: case NEQ:
835 if (valuePtr->type == TYPE_STRING) {
836 if (value2.type != TYPE_STRING) {
837 ExprMakeString(&value2);
838 }
839 } else if (value2.type == TYPE_STRING) {
840 if (valuePtr->type != TYPE_STRING) {
841 ExprMakeString(valuePtr);
842 }
843 } else if (valuePtr->type == TYPE_DOUBLE) {
844 if (value2.type == TYPE_INT) {
845 value2.doubleValue = value2.intValue;
846 value2.type = TYPE_DOUBLE;
847 }
848 } else if (value2.type == TYPE_DOUBLE) {
849 if (valuePtr->type == TYPE_INT) {
850 valuePtr->doubleValue = valuePtr->intValue;
851 valuePtr->type = TYPE_DOUBLE;
852 }
853 }
854 break;
855
856 /*
857 * For the operators below, no strings are allowed, but
858 * no int->double conversions are performed.
859 */
860
861 case AND: case OR:
862 if (valuePtr->type == TYPE_STRING) {
863 badType = valuePtr->type;
864 goto illegalType;
865 }
866 if (value2.type == TYPE_STRING) {
867 badType = value2.type;
868 goto illegalType;
869 }
870 break;
871
872 /*
873 * For the operators below, type and conversions are
874 * irrelevant: they're handled elsewhere.
875 */
876
877 case QUESTY: case COLON:
878 break;
879
880 /*
881 * Any other operator is an error.
882 */
883
884 default:
885 interp->result = "unknown operator in expression";
886 result = TCL_ERROR;
887 goto done;
888 }
889
890 /*
891 * If necessary, convert one of the operands to the type
892 * of the other. If the operands are incompatible with
893 * the operator (e.g. "+" on strings) then return an
894 * error.
895 */
896
897 switch (operator) {
898 case MULT:
899 if (valuePtr->type == TYPE_INT) {
900 valuePtr->intValue *= value2.intValue;
901 } else {
902 valuePtr->doubleValue *= value2.doubleValue;
903 }
904 break;
905 case DIVIDE:
906 if (valuePtr->type == TYPE_INT) {
907 if (value2.intValue == 0) {
908 divideByZero:
909 interp->result = "divide by zero";
910 result = TCL_ERROR;
911 goto done;
912 }
913 valuePtr->intValue /= value2.intValue;
914 } else {
915 if (value2.doubleValue == 0.0) {
916 goto divideByZero;
917 }
918 valuePtr->doubleValue /= value2.doubleValue;
919 }
920 break;
921 case MOD:
922 if (value2.intValue == 0) {
923 goto divideByZero;
924 }
925 valuePtr->intValue %= value2.intValue;
926 break;
927 case PLUS:
928 if (valuePtr->type == TYPE_INT) {
929 valuePtr->intValue += value2.intValue;
930 } else {
931 valuePtr->doubleValue += value2.doubleValue;
932 }
933 break;
934 case MINUS:
935 if (valuePtr->type == TYPE_INT) {
936 valuePtr->intValue -= value2.intValue;
937 } else {
938 valuePtr->doubleValue -= value2.doubleValue;
939 }
940 break;
941 case LEFT_SHIFT:
942 valuePtr->intValue <<= value2.intValue;
943 break;
944 case RIGHT_SHIFT:
945 /*
946 * The following code is a bit tricky: it ensures that
947 * right shifts propagate the sign bit even on machines
948 * where ">>" won't do it by default.
949 */
950
951 if (valuePtr->intValue < 0) {
952 valuePtr->intValue =
953 ~((~valuePtr->intValue) >> value2.intValue);
954 } else {
955 valuePtr->intValue >>= value2.intValue;
956 }
957 break;
958 case LESS:
959 if (valuePtr->type == TYPE_INT) {
960 valuePtr->intValue =
961 valuePtr->intValue < value2.intValue;
962 } else if (valuePtr->type == TYPE_DOUBLE) {
963 valuePtr->intValue =
964 valuePtr->doubleValue < value2.doubleValue;
965 } else {
966 valuePtr->intValue =
967 strcmp(valuePtr->pv.buffer, value2.pv.buffer) < 0;
968 }
969 valuePtr->type = TYPE_INT;
970 break;
971 case GREATER:
972 if (valuePtr->type == TYPE_INT) {
973 valuePtr->intValue =
974 valuePtr->intValue > value2.intValue;
975 } else if (valuePtr->type == TYPE_DOUBLE) {
976 valuePtr->intValue =
977 valuePtr->doubleValue > value2.doubleValue;
978 } else {
979 valuePtr->intValue =
980 strcmp(valuePtr->pv.buffer, value2.pv.buffer) > 0;
981 }
982 valuePtr->type = TYPE_INT;
983 break;
984 case LEQ:
985 if (valuePtr->type == TYPE_INT) {
986 valuePtr->intValue =
987 valuePtr->intValue <= value2.intValue;
988 } else if (valuePtr->type == TYPE_DOUBLE) {
989 valuePtr->intValue =
990 valuePtr->doubleValue <= value2.doubleValue;
991 } else {
992 valuePtr->intValue =
993 strcmp(valuePtr->pv.buffer, value2.pv.buffer) <= 0;
994 }
995 valuePtr->type = TYPE_INT;
996 break;
997 case GEQ:
998 if (valuePtr->type == TYPE_INT) {
999 valuePtr->intValue =
1000 valuePtr->intValue >= value2.intValue;
1001 } else if (valuePtr->type == TYPE_DOUBLE) {
1002 valuePtr->intValue =
1003 valuePtr->doubleValue >= value2.doubleValue;
1004 } else {
1005 valuePtr->intValue =
1006 strcmp(valuePtr->pv.buffer, value2.pv.buffer) >= 0;
1007 }
1008 valuePtr->type = TYPE_INT;
1009 break;
1010 case EQUAL:
1011 if (valuePtr->type == TYPE_INT) {
1012 valuePtr->intValue =
1013 valuePtr->intValue == value2.intValue;
1014 } else if (valuePtr->type == TYPE_DOUBLE) {
1015 valuePtr->intValue =
1016 valuePtr->doubleValue == value2.doubleValue;
1017 } else {
1018 valuePtr->intValue =
1019 strcmp(valuePtr->pv.buffer, value2.pv.buffer) == 0;
1020 }
1021 valuePtr->type = TYPE_INT;
1022 break;
1023 case NEQ:
1024 if (valuePtr->type == TYPE_INT) {
1025 valuePtr->intValue =
1026 valuePtr->intValue != value2.intValue;
1027 } else if (valuePtr->type == TYPE_DOUBLE) {
1028 valuePtr->intValue =
1029 valuePtr->doubleValue != value2.doubleValue;
1030 } else {
1031 valuePtr->intValue =
1032 strcmp(valuePtr->pv.buffer, value2.pv.buffer) != 0;
1033 }
1034 valuePtr->type = TYPE_INT;
1035 break;
1036 case BIT_AND:
1037 valuePtr->intValue &= value2.intValue;
1038 break;
1039 case BIT_XOR:
1040 valuePtr->intValue ^= value2.intValue;
1041 break;
1042 case BIT_OR:
1043 valuePtr->intValue |= value2.intValue;
1044 break;
1045
1046 /*
1047 * For AND and OR, we know that the first value has already
1048 * been converted to an integer. Thus we need only consider
1049 * the possibility of int vs. double for the second value.
1050 */
1051
1052 case AND:
1053 if (value2.type == TYPE_DOUBLE) {
1054 value2.intValue = value2.doubleValue != 0;
1055 value2.type = TYPE_INT;
1056 }
1057 valuePtr->intValue = valuePtr->intValue && value2.intValue;
1058 break;
1059 case OR:
1060 if (value2.type == TYPE_DOUBLE) {
1061 value2.intValue = value2.doubleValue != 0;
1062 value2.type = TYPE_INT;
1063 }
1064 valuePtr->intValue = valuePtr->intValue || value2.intValue;
1065 break;
1066
1067 case COLON:
1068 interp->result = "can't have : operator without ? first";
1069 result = TCL_ERROR;
1070 goto done;
1071 }
1072 }
1073
1074 done:
1075 if (value2.pv.buffer != value2.staticSpace) {
1076 ckfree(value2.pv.buffer);
1077 }
1078 return result;
1079
1080 syntaxError:
1081 Tcl_ResetResult(interp);
1082 Tcl_AppendResult(interp, "syntax error in expression \"",
1083 infoPtr->originalExpr, "\"", (char *) NULL);
1084 result = TCL_ERROR;
1085 goto done;
1086
1087 illegalType:
1088 Tcl_AppendResult(interp, "can't use ", (badType == TYPE_DOUBLE) ?
1089 "floating-point value" : "non-numeric string",
1090 " as operand of \"", operatorStrings[operator], "\"",
1091 (char *) NULL);
1092 result = TCL_ERROR;
1093 goto done;
1094 }
1095 \f
1096 /*
1097 *--------------------------------------------------------------
1098 *
1099 * ExprMakeString --
1100 *
1101 * Convert a value from int or double representation to
1102 * a string.
1103 *
1104 * Results:
1105 * The information at *valuePtr gets converted to string
1106 * format, if it wasn't that way already.
1107 *
1108 * Side effects:
1109 * None.
1110 *
1111 *--------------------------------------------------------------
1112 */
1113
1114 static void
1115 ExprMakeString(valuePtr)
1116 register Value *valuePtr; /* Value to be converted. */
1117 {
1118 int shortfall;
1119
1120 shortfall = 150 - (valuePtr->pv.end - valuePtr->pv.buffer);
1121 if (shortfall > 0) {
1122 (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall);
1123 }
1124 if (valuePtr->type == TYPE_INT) {
1125 sprintf(valuePtr->pv.buffer, "%ld", valuePtr->intValue);
1126 } else if (valuePtr->type == TYPE_DOUBLE) {
1127 sprintf(valuePtr->pv.buffer, "%g", valuePtr->doubleValue);
1128 }
1129 valuePtr->type = TYPE_STRING;
1130 }
1131 \f
1132 /*
1133 *--------------------------------------------------------------
1134 *
1135 * ExprTopLevel --
1136 *
1137 * This procedure provides top-level functionality shared by
1138 * procedures like Tcl_ExprInt, Tcl_ExprDouble, etc.
1139 *
1140 * Results:
1141 * The result is a standard Tcl return value. If an error
1142 * occurs then an error message is left in interp->result.
1143 * The value of the expression is returned in *valuePtr, in
1144 * whatever form it ends up in (could be string or integer
1145 * or double). Caller may need to convert result. Caller
1146 * is also responsible for freeing string memory in *valuePtr,
1147 * if any was allocated.
1148 *
1149 * Side effects:
1150 * None.
1151 *
1152 *--------------------------------------------------------------
1153 */
1154
1155 static int
1156 ExprTopLevel(interp, string, valuePtr)
1157 Tcl_Interp *interp; /* Context in which to evaluate the
1158 * expression. */
1159 char *string; /* Expression to evaluate. */
1160 Value *valuePtr; /* Where to store result. Should
1161 * not be initialized by caller. */
1162 {
1163 ExprInfo info;
1164 int result;
1165
1166 info.originalExpr = string;
1167 info.expr = string;
1168 valuePtr->pv.buffer = valuePtr->pv.next = valuePtr->staticSpace;
1169 valuePtr->pv.end = valuePtr->pv.buffer + STATIC_STRING_SPACE - 1;
1170 valuePtr->pv.expandProc = TclExpandParseValue;
1171 valuePtr->pv.clientData = (ClientData) NULL;
1172
1173 result = ExprGetValue(interp, &info, -1, valuePtr);
1174 if (result != TCL_OK) {
1175 return result;
1176 }
1177 if (info.token != END) {
1178 Tcl_AppendResult(interp, "syntax error in expression \"",
1179 string, "\"", (char *) NULL);
1180 return TCL_ERROR;
1181 }
1182 return TCL_OK;
1183 }
1184 \f
1185 /*
1186 *--------------------------------------------------------------
1187 *
1188 * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
1189 *
1190 * Procedures to evaluate an expression and return its value
1191 * in a particular form.
1192 *
1193 * Results:
1194 * Each of the procedures below returns a standard Tcl result.
1195 * If an error occurs then an error message is left in
1196 * interp->result. Otherwise the value of the expression,
1197 * in the appropriate form, is stored at *resultPtr. If
1198 * the expression had a result that was incompatible with the
1199 * desired form then an error is returned.
1200 *
1201 * Side effects:
1202 * None.
1203 *
1204 *--------------------------------------------------------------
1205 */
1206
1207 int
1208 Tcl_ExprLong(interp, string, ptr)
1209 Tcl_Interp *interp; /* Context in which to evaluate the
1210 * expression. */
1211 char *string; /* Expression to evaluate. */
1212 long *ptr; /* Where to store result. */
1213 {
1214 Value value;
1215 int result;
1216
1217 result = ExprTopLevel(interp, string, &value);
1218 if (result == TCL_OK) {
1219 if (value.type == TYPE_INT) {
1220 *ptr = value.intValue;
1221 } else if (value.type == TYPE_DOUBLE) {
1222 *ptr = value.doubleValue;
1223 } else {
1224 interp->result = "expression didn't have numeric value";
1225 result = TCL_ERROR;
1226 }
1227 }
1228 if (value.pv.buffer != value.staticSpace) {
1229 ckfree(value.pv.buffer);
1230 }
1231 return result;
1232 }
1233
1234 int
1235 Tcl_ExprDouble(interp, string, ptr)
1236 Tcl_Interp *interp; /* Context in which to evaluate the
1237 * expression. */
1238 char *string; /* Expression to evaluate. */
1239 double *ptr; /* Where to store result. */
1240 {
1241 Value value;
1242 int result;
1243
1244 result = ExprTopLevel(interp, string, &value);
1245 if (result == TCL_OK) {
1246 if (value.type == TYPE_INT) {
1247 *ptr = value.intValue;
1248 } else if (value.type == TYPE_DOUBLE) {
1249 *ptr = value.doubleValue;
1250 } else {
1251 interp->result = "expression didn't have numeric value";
1252 result = TCL_ERROR;
1253 }
1254 }
1255 if (value.pv.buffer != value.staticSpace) {
1256 ckfree(value.pv.buffer);
1257 }
1258 return result;
1259 }
1260
1261 int
1262 Tcl_ExprBoolean(interp, string, ptr)
1263 Tcl_Interp *interp; /* Context in which to evaluate the
1264 * expression. */
1265 char *string; /* Expression to evaluate. */
1266 int *ptr; /* Where to store 0/1 result. */
1267 {
1268 Value value;
1269 int result;
1270
1271 result = ExprTopLevel(interp, string, &value);
1272 if (result == TCL_OK) {
1273 if (value.type == TYPE_INT) {
1274 *ptr = value.intValue != 0;
1275 } else if (value.type == TYPE_DOUBLE) {
1276 *ptr = value.doubleValue != 0.0;
1277 } else {
1278 interp->result = "expression didn't have numeric value";
1279 result = TCL_ERROR;
1280 }
1281 }
1282 if (value.pv.buffer != value.staticSpace) {
1283 ckfree(value.pv.buffer);
1284 }
1285 return result;
1286 }
1287 \f
1288 /*
1289 *--------------------------------------------------------------
1290 *
1291 * Tcl_ExprString --
1292 *
1293 * Evaluate an expression and return its value in string form.
1294 *
1295 * Results:
1296 * A standard Tcl result. If the result is TCL_OK, then the
1297 * interpreter's result is set to the string value of the
1298 * expression. If the result is TCL_OK, then interp->result
1299 * contains an error message.
1300 *
1301 * Side effects:
1302 * None.
1303 *
1304 *--------------------------------------------------------------
1305 */
1306
1307 int
1308 Tcl_ExprString(interp, string)
1309 Tcl_Interp *interp; /* Context in which to evaluate the
1310 * expression. */
1311 char *string; /* Expression to evaluate. */
1312 {
1313 Value value;
1314 int result;
1315
1316 result = ExprTopLevel(interp, string, &value);
1317 if (result == TCL_OK) {
1318 if (value.type == TYPE_INT) {
1319 sprintf(interp->result, "%ld", value.intValue);
1320 } else if (value.type == TYPE_DOUBLE) {
1321 sprintf(interp->result, "%g", value.doubleValue);
1322 } else {
1323 if (value.pv.buffer != value.staticSpace) {
1324 interp->result = value.pv.buffer;
1325 interp->freeProc = (Tcl_FreeProc *) free;
1326 value.pv.buffer = value.staticSpace;
1327 } else {
1328 Tcl_SetResult(interp, value.pv.buffer, TCL_VOLATILE);
1329 }
1330 }
1331 }
1332 if (value.pv.buffer != value.staticSpace) {
1333 ckfree(value.pv.buffer);
1334 }
1335 return result;
1336 }
Micropolis
Impressum, Datenschutz