1
2 /*
3 * bltVecMath.c --
4 *
5 * This module implements mathematical expressions with vector
6 * data objects.
7 *
8 * Copyright 1995-1998 Lucent Technologies, Inc.
9 *
10 * Permission to use, copy, modify, and distribute this software and
11 * its documentation for any purpose and without fee is hereby
12 * granted, provided that the above copyright notice appear in all
13 * copies and that both that the copyright notice and warranty
14 * disclaimer appear in supporting documentation, and that the names
15 * of Lucent Technologies any of their entities not be used in
16 * advertising or publicity pertaining to distribution of the software
17 * without specific, written prior permission.
18 *
19 * Lucent Technologies disclaims all warranties with regard to this
20 * software, including all implied warranties of merchantability and
21 * fitness. In no event shall Lucent Technologies be liable for any
22 * special, indirect or consequential damages or any damages
23 * whatsoever resulting from loss of use, data or profits, whether in
24 * an action of contract, negligence or other tortuous action, arising
25 * out of or in connection with the use or performance of this
26 * software.
27 */
28
29 #include "bltVecInt.h"
30
31 /*
32 * Three types of math functions:
33 *
34 * ComponentProc Function is applied in multiple calls to
35 * each component of the vector.
36 * VectorProc Entire vector is passed, each component is
37 * modified.
38 * ScalarProc Entire vector is passed, single scalar value
39 * is returned.
40 */
41
42 typedef double (ComponentProc) _ANSI_ARGS_((double value));
43 typedef int (VectorProc) _ANSI_ARGS_((VectorObject *vPtr));
44 typedef double (ScalarProc) _ANSI_ARGS_((VectorObject *vPtr));
45 typedef double (Opt1Proc) _ANSI_ARGS_((VectorObject *vPtr, VectorObject *optPtr));
46
47 /*
48 * Built-in math functions:
49 */
50 typedef int (GenericMathProc) _ANSI_ARGS_(ANYARGS);
51
52 /*
53 * MathFunction --
54 *
55 * Contains information about math functions that can be called
56 * for vectors. The table of math functions is global within the
57 * application. So you can't define two different "sqrt"
58 * functions.
59 */
60 typedef struct {
61 char *name; /* Name of built-in math function. If
62 * NULL, indicates that the function
63 * was user-defined and dynamically
64 * allocated. Function names are
65 * global across all interpreters. */
66
67 GenericMathProc *proc; /* Procedure that implements this math
68 * function. */
69
70 ClientData clientData; /* Argument to pass when invoking the
71 * function. */
72 int hasArg;
73
74 } MathFunction;
75
76
77 /*
78 * Macros for testing floating-point values for certain special cases:
79 *
80 * IS_NAN Test for not-a-number by comparing a value against itself
81 * IF_INF Test for infinity by comparing against the largest floating
82 * point value.
83 */
84
85 #define IS_NAN(v) ((v) != (v))
86
87 #ifdef DBL_MAX
88 # define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
89 #else
90 # define IS_INF(v) 0
91 #endif
92
93 /* The data structure below is used to describe an expression value,
94 * which can be either a double-precision floating-point value, or a
95 * string. A given number has only one value at a time. */
96
97 #define STATIC_STRING_SPACE 150
98
99 /*
100 * Tokens --
101 *
102 * The token types are defined below. In addition, there is a
103 * table associating a precedence with each operator. The order
104 * of types is important. Consult the code before changing it.
105 */
106 enum Tokens {
107 VALUE, OPEN_PAREN, CLOSE_PAREN, COMMA, END, UNKNOWN,
108 MULT = 8, DIVIDE, MOD, PLUS, MINUS,
109 LEFT_SHIFT, RIGHT_SHIFT,
110 LESS, GREATER, LEQ, GEQ, EQUAL, NEQ,
111 OLD_BIT_AND, EXPONENT, OLD_BIT_OR, OLD_QUESTY, OLD_COLON,
112 AND, OR, UNARY_MINUS, OLD_UNARY_PLUS, NOT, OLD_BIT_NOT
113 };
114
115 /*
116 * ParseValue --
117 *
118 * The following data structure is used by various parsing
119 * procedures to hold information about where to store the
120 * results of parsing (e.g. the substituted contents of a quoted
121 * argument, or the result of a nested command). At any given
122 * time, the space available for output is fixed, but a procedure
123 * may be called to expand the space available if the current
124 * space runs out.
125 */
126
127 typedef struct ParseValueStruct ParseValue;
128
129 struct ParseValueStruct {
130 char *buffer; /* Address of first character in
131 * output buffer. */
132 char *next; /* Place to store next character in
133 * output buffer. */
134 char *end; /* Address of the last usable character
135 * in the buffer. */
136 void (*expandProc) _ANSI_ARGS_((ParseValue * pvPtr, int needed));
137 /* Procedure to call when space runs out;
138 * it will make more space. */
139 ClientData clientData; /* Arbitrary information for use of
140 * expandProc. */
141 };
142
143 typedef struct {
144 VectorObject *vPtr;
145 char staticSpace[STATIC_STRING_SPACE];
146 ParseValue pv; /* Used to hold a string value, if any. */
147 int funcArg; /* This value is to be a function argument. */
148 int isLast;
149 } Value;
150
151 /*
152 * ParseInfo --
153 *
154 * The data structure below describes the state of parsing an
155 * expression. It's passed among the routines in this module.
156 */
157 typedef struct {
158 char *expr; /* The entire right-hand side of the
159 * expression, as originally passed to
160 * Blt_ExprVector. */
161
162 char *nextPtr; /* Position of the next character to
163 * be scanned from the expression
164 * string. */
165
166 enum Tokens token; /* Type of the last token to be parsed
167 * from nextPtr. See below for
168 * definitions. Corresponds to the
169 * characters just before nextPtr. */
170 VectorObject *vPtr; /* Allow functions to use no arguments for self. */
171 } ParseInfo;
172
173 /*
174 * Precedence table. The values for non-operator token types are ignored.
175 */
176 static int precTable[] =
177 {
178 0, 0, 0, 0, 0, 0, 0, 0,
179 12, 12, 12, /* MULT, DIVIDE, MOD */
180 11, 11, /* PLUS, MINUS */
181 10, 10, /* LEFT_SHIFT, RIGHT_SHIFT */
182 9, 9, 9, 9, /* LESS, GREATER, LEQ, GEQ */
183 8, 8, /* EQUAL, NEQ */
184 7, /* OLD_BIT_AND */
185 13, /* EXPONENTIATION */
186 5, /* OLD_BIT_OR */
187 4, /* AND */
188 3, /* OR */
189 2, /* OLD_QUESTY */
190 1, /* OLD_COLON */
191 14, 14, 14, 14 /* UNARY_MINUS, OLD_UNARY_PLUS, NOT,
192 * OLD_BIT_NOT */
193 };
194
195
196 /*
197 * Forward declarations.
198 */
199
200 static int NextValue _ANSI_ARGS_((Tcl_Interp *interp, ParseInfo *parsePtr,
201 int prec, Value * valuePtr, Value * optValPtr));
202
203 #if (TCL_VERSION_NUMBER >= _VERSION(8,1,0))
204 #define TclParseBraces Blt_ParseBraces
205 #define TclParseNestedCmd Blt_ParseNestedCmd
206 #define TclParseQuotes Blt_ParseQuotes
207 #define TclExpandParseValue Blt_ExpandParseValue
208 #endif /* TCL_VERSION_NUMBER >= _VERSION(8,1,0) */
209
210 extern int TclParseBraces _ANSI_ARGS_((Tcl_Interp *interp, char *string,
211 char **termPtr, ParseValue * pvPtr));
212
213 extern int TclParseNestedCmd _ANSI_ARGS_((Tcl_Interp *interp, char *string,
214 int flags, char **termPtr, ParseValue * pvPtr));
215
216 extern int TclParseQuotes _ANSI_ARGS_((Tcl_Interp *interp, char *string,
217 int termChar, int flags, char **termPtr, ParseValue * pvPtr));
218
219 extern void TclExpandParseValue _ANSI_ARGS_((ParseValue * pvPtr, int needed));
220
221 #if defined(HAVE_DRAND48) && defined(NO_DECL_DRAND48)
222 extern double drand48 _ANSI_ARGS_((void));
223 #endif
224
225 #include <bltMath.h>
226
227 /*
228 *--------------------------------------------------------------
229 *
230 * First --
231 *
232 * Gets the first index of the designated interval. The interval
233 * is between vPtr->first and vPtr->last. But the range may
234 * NaN or Inf values that should be ignored.
235 *
236 * Results:
237 * Returns the index of the first finite value in the designated
238 * interval. If no finite values exists in the range, then -1 is
239 * returned.
240 *
241 *--------------------------------------------------------------
242 */
243 static int
First(vPtr)244 First(vPtr)
245 VectorObject *vPtr;
246 {
247 register int i;
248
249 for(i = vPtr->first; i <= vPtr->last; i++) {
250 if (FINITE(vPtr->valueArr[i])) {
251 return i;
252 }
253 }
254 return -1;
255 }
256
257 /*
258 *--------------------------------------------------------------
259 *
260 * Next --
261 *
262 * Gets the next index of the designated interval. The interval
263 * is between vPtr->first and vPtr->last. Ignore NaN or Inf
264 * values.
265 *
266 * Results:
267 * Returns the index of the next finite value in the designated
268 * interval. If no more finite values exists in the range,
269 * then -1 is returned.
270 *
271 *--------------------------------------------------------------
272 */
273 static int
Next(vPtr,current)274 Next(vPtr, current)
275 VectorObject *vPtr;
276 int current;
277 {
278 register int i;
279
280 for(i = current + 1; i <= vPtr->last; i++) {
281 if (FINITE(vPtr->valueArr[i])) {
282 return i;
283 }
284 }
285 return -1;
286 }
287
288 /*
289 *--------------------------------------------------------------
290 *
291 * Sort --
292 *
293 * A vector math function. Sorts the values of the given
294 * vector.
295 *
296 * Results:
297 * Always TCL_OK.
298 *
299 * Side Effects:
300 * The vector is sorted.
301 *
302 *--------------------------------------------------------------
303 */
304 static int
Sort(vPtr)305 Sort(vPtr)
306 VectorObject *vPtr;
307 {
308 int *indexArr;
309 double *tempArr;
310 register int i;
311
312 indexArr = Blt_VectorSortIndex(&vPtr, 1);
313 tempArr = Blt_Malloc(sizeof(double) * vPtr->length);
314 assert(tempArr);
315 for(i = vPtr->first; i <= vPtr->last; i++) {
316 tempArr[i] = vPtr->valueArr[indexArr[i]];
317 }
318 Blt_Free(indexArr);
319 for(i = vPtr->first; i <= vPtr->last; i++) {
320 vPtr->valueArr[i] = tempArr[i];
321 }
322 Blt_Free(tempArr);
323 return TCL_OK;
324 }
325
326 static int
Invert(vPtr)327 Invert(vPtr)
328 VectorObject *vPtr;
329 {
330 double *v, t;
331 register int i, j;
332
333 v = vPtr->valueArr;
334 for(i = vPtr->first, j = vPtr->last ; i < j; i++, j--) {
335 t = v[i];
336 v[i] = v[j];
337 v[j] = t;
338 }
339 return TCL_OK;
340 }
341
342 static double
Length(vecPtr)343 Length(vecPtr)
344 Blt_Vector *vecPtr;
345 {
346 VectorObject *vPtr = (VectorObject *)vecPtr;
347 int count;
348 register int i;
349
350 count = 0;
351 for(i = First(vPtr); i >= 0; i = Next(vPtr, i)) {
352 count++;
353 }
354 return (double) count;
355 }
356
357 /* ARGSUSED */
358 double
Blt_VecMin(vecPtr)359 Blt_VecMin(vecPtr)
360 Blt_Vector *vecPtr;
361 {
362 VectorObject *vPtr = (VectorObject *)vecPtr;
363
364 if (!FINITE(vPtr->min)) {
365 double min;
366 register int i;
367
368 min = bltNaN;
369 for (i = 0; i < vPtr->length; i++) {
370 if (FINITE(vPtr->valueArr[i])) {
371 min = vPtr->valueArr[i];
372 break;
373 }
374 }
375 for (/* empty */; i < vPtr->length; i++) {
376 if (FINITE(vPtr->valueArr[i])) {
377 if (min > vPtr->valueArr[i]) {
378 min = vPtr->valueArr[i];
379 }
380 }
381 }
382 vPtr->min = min;
383 }
384 return vPtr->min;
385 }
386
387 double
Blt_VecMax(vecPtr)388 Blt_VecMax(vecPtr)
389 Blt_Vector *vecPtr;
390 {
391 VectorObject *vPtr = (VectorObject *)vecPtr;
392
393 if (!FINITE(vPtr->max)) {
394 double max;
395 register int i;
396
397 max = bltNaN;
398 for (i = 0; i < vPtr->length; i++) {
399 if (FINITE(vPtr->valueArr[i])) {
400 max = vPtr->valueArr[i];
401 break;
402 }
403 }
404 for (/* empty */; i < vPtr->length; i++) {
405 if (FINITE(vPtr->valueArr[i])) {
406 if (max < vPtr->valueArr[i]) {
407 max = vPtr->valueArr[i];
408 }
409 }
410 }
411 vPtr->max = max;
412 }
413 return vPtr->max;
414 }
415
416 static double
Mean(vecPtr)417 Mean(vecPtr)
418 Blt_Vector *vecPtr;
419 {
420 VectorObject *vPtr = (VectorObject *)vecPtr;
421 register int i;
422 int count;
423 double sum;
424
425 sum = 0.0;
426 count = 0;
427 for(i = First(vPtr); i >= 0; i = Next(vPtr, i)) {
428 sum += vPtr->valueArr[i];
429 count++;
430 }
431 return sum / (double)count;
432 }
433
434 /*
435 * var = 1/N Sum( (x[i] - mean)^2 )
436 */
437 static double
Variance(vecPtr)438 Variance(vecPtr)
439 Blt_Vector *vecPtr;
440 {
441 VectorObject *vPtr = (VectorObject *)vecPtr;
442 register double dx, var, mean;
443 register int i;
444 int count;
445
446 mean = Mean(vecPtr);
447 var = 0.0;
448 count = 0;
449 for(i = First(vPtr); i >= 0; i = Next(vPtr, i)) {
450 dx = vPtr->valueArr[i] - mean;
451 var += dx * dx;
452 count++;
453 }
454 if (count < 2) {
455 return 0.0;
456 }
457 var /= (double)(count - 1);
458 return var;
459 }
460
461 /*
462 * skew = Sum( (x[i] - mean)^3 ) / (var^3/2)
463 */
464 static double
Skew(vecPtr)465 Skew(vecPtr)
466 Blt_Vector *vecPtr;
467 {
468 VectorObject *vPtr = (VectorObject *)vecPtr;
469 register double diff, var, skew, mean, diffsq;
470 register int i;
471 int count;
472
473 mean = Mean(vecPtr);
474 var = skew = 0.0;
475 count = 0;
476 for(i = First(vPtr); i >= 0; i = Next(vPtr, i)) {
477 diff = vPtr->valueArr[i] - mean;
478 diff = FABS(diff);
479 diffsq = diff * diff;
480 var += diffsq;
481 skew += diffsq * diff;
482 count++;
483 }
484 if (count < 2) {
485 return 0.0;
486 }
487 var /= (double)(count - 1);
488 skew /= count * var * sqrt(var);
489 return skew;
490 }
491
492 static double
StdDeviation(vecPtr)493 StdDeviation(vecPtr)
494 Blt_Vector *vecPtr;
495 {
496 double var;
497
498 var = Variance(vecPtr);
499 if (var > 0.0) {
500 return sqrt(var);
501 }
502 return 0.0;
503 }
504
505
506 static double
AvgDeviation(vecPtr)507 AvgDeviation(vecPtr)
508 Blt_Vector *vecPtr;
509 {
510 VectorObject *vPtr = (VectorObject *)vecPtr;
511 register double diff, avg, mean;
512 register int i;
513 int count;
514
515 mean = Mean(vecPtr);
516 avg = 0.0;
517 count = 0;
518 for(i = First(vPtr); i >= 0; i = Next(vPtr, i)) {
519 diff = vPtr->valueArr[i] - mean;
520 avg += FABS(diff);
521 count++;
522 }
523 if (count < 2) {
524 return 0.0;
525 }
526 avg /= (double)count;
527 return avg;
528 }
529
530
531 static double
Kurtosis(vecPtr)532 Kurtosis(vecPtr)
533 Blt_Vector *vecPtr;
534 {
535 VectorObject *vPtr = (VectorObject *)vecPtr;
536 register double diff, diffsq, kurt, var, mean;
537 register int i;
538 int count;
539
540 mean = Mean(vecPtr);
541 var = kurt = 0.0;
542 count = 0;
543 for(i = First(vPtr); i >= 0; i = Next(vPtr, i)) {
544 diff = vPtr->valueArr[i] - mean;
545 diffsq = diff * diff;
546 var += diffsq;
547 kurt += diffsq * diffsq;
548 count++;
549 }
550 if (count < 2) {
551 return 0.0;
552 }
553 var /= (double)(count - 1);
554 if (var == 0.0) {
555 return 0.0;
556 }
557 kurt /= (count * var * var);
558 return kurt - 3.0; /* Fisher Kurtosis */
559 }
560
561 static double
Shift(vecPtr,optPtr)562 Shift(vecPtr, optPtr)
563 Blt_Vector *vecPtr;
564 Blt_Vector *optPtr;
565 {
566 VectorObject *vPtr = (VectorObject *)vecPtr;
567 VectorObject *oPtr = (VectorObject *)optPtr;
568 double *v, def = 0;
569 int i, offs, ni;
570 v = vPtr->valueArr;
571 if (oPtr==NULL || oPtr->length<1 || !v) { return 0; }
572 offs = oPtr->valueArr[0];
573 if (offs == 0) return 0;
574 if (oPtr->length>1) {
575 def = oPtr->valueArr[1];
576 }
577 if (offs>0) {
578 for (i=vPtr->length-1; i>=0; i--) {
579 ni = i-offs;
580 if (ni<0 || ni>=vPtr->length) {
581 v[i] = def;
582 } else {
583 v[i] = v[ni];
584 }
585 }
586 } else {
587 for (i=0; i<vPtr->length; i++) {
588 ni = i-offs;
589 if (ni<0 || ni>=vPtr->length) {
590 v[i] = def;
591 } else {
592 v[i] = v[ni];
593 }
594 }
595 }
596 return 0;
597 }
598
599 static double
Median(vecPtr)600 Median(vecPtr)
601 Blt_Vector *vecPtr;
602 {
603 VectorObject *vPtr = (VectorObject *)vecPtr;
604 int *iArr;
605 double q2;
606 int mid;
607
608 if (vPtr->length == 0) {
609 return -DBL_MAX;
610 }
611 iArr = Blt_VectorSortIndex(&vPtr, 1);
612 mid = (vPtr->length - 1) / 2;
613
614 /*
615 * Determine Q2 by checking if the number of elements [0..n-1] is
616 * odd or even. If even, we must take the average of the two
617 * middle values.
618 */
619 if (vPtr->length & 1) { /* Odd */
620 q2 = vPtr->valueArr[iArr[mid]];
621 } else { /* Even */
622 q2 = (vPtr->valueArr[iArr[mid]] + vPtr->valueArr[iArr[mid + 1]]) * 0.5;
623 }
624 Blt_Free(iArr);
625 return q2;
626 }
627
628 static double
Q1(vecPtr)629 Q1(vecPtr)
630 Blt_Vector *vecPtr;
631 {
632 VectorObject *vPtr = (VectorObject *)vecPtr;
633 double q1;
634 int *iArr;
635
636 if (vPtr->length == 0) {
637 return -DBL_MAX;
638 }
639 iArr = Blt_VectorSortIndex(&vPtr, 1);
640
641 if (vPtr->length < 4) {
642 q1 = vPtr->valueArr[iArr[0]];
643 } else {
644 int mid, q;
645
646 mid = (vPtr->length - 1) / 2;
647 q = mid / 2;
648
649 /*
650 * Determine Q1 by checking if the number of elements in the
651 * bottom half [0..mid) is odd or even. If even, we must
652 * take the average of the two middle values.
653 */
654 if (mid & 1) { /* Odd */
655 q1 = vPtr->valueArr[iArr[q]];
656 } else { /* Even */
657 q1 = (vPtr->valueArr[iArr[q]] + vPtr->valueArr[iArr[q + 1]]) * 0.5;
658 }
659 }
660 Blt_Free(iArr);
661 return q1;
662 }
663
664 static double
Q3(vecPtr)665 Q3(vecPtr)
666 Blt_Vector *vecPtr;
667 {
668 VectorObject *vPtr = (VectorObject *)vecPtr;
669 double q3;
670 int *iArr;
671
672 if (vPtr->length == 0) {
673 return -DBL_MAX;
674 }
675
676 iArr = Blt_VectorSortIndex(&vPtr, 1);
677
678 if (vPtr->length < 4) {
679 q3 = vPtr->valueArr[iArr[vPtr->length - 1]];
680 } else {
681 int mid, q;
682
683 mid = (vPtr->length - 1) / 2;
684 q = (vPtr->length + mid) / 2;
685
686 /*
687 * Determine Q3 by checking if the number of elements in the
688 * upper half (mid..n-1] is odd or even. If even, we must
689 * take the average of the two middle values.
690 */
691 if (mid & 1) { /* Odd */
692 q3 = vPtr->valueArr[iArr[q]];
693 } else { /* Even */
694 q3 = (vPtr->valueArr[iArr[q]] + vPtr->valueArr[iArr[q + 1]]) * 0.5;
695 }
696 }
697 Blt_Free(iArr);
698 return q3;
699 }
700
701
702 static int
Norm(vecPtr)703 Norm(vecPtr)
704 Blt_Vector *vecPtr;
705 {
706 VectorObject *vPtr = (VectorObject *)vecPtr;
707 double norm, range, min, max;
708 register int i;
709
710 min = Blt_VecMin(vecPtr);
711 max = Blt_VecMax(vecPtr);
712 range = max - min;
713 for(i = 0; i < vPtr->length; i++) {
714 norm = (vPtr->valueArr[i] - min) / range;
715 vPtr->valueArr[i] = norm;
716 }
717 return TCL_OK;
718 }
719
720 static int
Row(vecPtr)721 Row(vecPtr)
722 Blt_Vector *vecPtr;
723 {
724 VectorObject *vPtr = (VectorObject *)vecPtr;
725 register int i;
726
727 for(i = 0; i < vPtr->length; i++) {
728 vPtr->valueArr[i] = i;
729 }
730 return TCL_OK;
731 }
732
733 static double
Product(vecPtr)734 Product(vecPtr)
735 Blt_Vector *vecPtr;
736 {
737 VectorObject *vPtr = (VectorObject *)vecPtr;
738 register int i;
739 register double prod;
740
741 prod = 1.0;
742 for(i = First(vPtr); i >= 0; i = Next(vPtr, i)) {
743 prod *= vPtr->valueArr[i];
744 }
745 return prod;
746 }
747
748 static double
Sum(vecPtr)749 Sum(vecPtr)
750 Blt_Vector *vecPtr;
751 {
752 VectorObject *vPtr = (VectorObject *)vecPtr;
753 register int i;
754 double sum;
755
756 sum = 0.0;
757 for(i = First(vPtr); i >= 0; i = Next(vPtr, i)) {
758 sum += vPtr->valueArr[i];
759 }
760 return sum;
761 }
762
763 static double
Nonzeros(vecPtr)764 Nonzeros(vecPtr)
765 Blt_Vector *vecPtr;
766 {
767 VectorObject *vPtr = (VectorObject *)vecPtr;
768 register int i;
769 int count;
770
771 count = 0;
772 for(i = First(vPtr); i >= 0; i = Next(vPtr, i)) {
773 if (vPtr->valueArr[i] == 0.0) {
774 count++;
775 }
776 }
777 return (double) count;
778 }
779
780 static double
Fabs(value)781 Fabs(value)
782 double value;
783 {
784 if (value < 0.0) {
785 return -value;
786 }
787 return value;
788 }
789
790 static double
Round(value)791 Round(value)
792 double value;
793 {
794 if (value < 0.0) {
795 return ceil(value - 0.5);
796 } else {
797 return floor(value + 0.5);
798 }
799 }
800
801 static double
Fmod(x,y)802 Fmod(x, y)
803 double x, y;
804 {
805 if (y == 0.0) {
806 return 0.0;
807 }
808 return x - (floor(x / y) * y);
809 }
810
811 /*
812 *----------------------------------------------------------------------
813 *
814 * MathError --
815 *
816 * This procedure is called when an error occurs during a
817 * floating-point operation. It reads errno and sets
818 * interp->result accordingly.
819 *
820 * Results:
821 * Interp->result is set to hold an error message.
822 *
823 * Side effects:
824 * None.
825 *
826 *----------------------------------------------------------------------
827 */
828 static void
MathError(interp,value)829 MathError(interp, value)
830 Tcl_Interp *interp; /* Where to store error message. */
831 double value; /* Value returned after error; used to
832 * distinguish underflows from overflows. */
833 {
834 if ((errno == EDOM) || (value != value)) {
835 Tcl_AppendResult(interp, "domain error: argument not in valid range",
836 (char *)NULL);
837 Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", Tcl_GetStringResult(interp),
838 (char *)NULL);
839 } else if ((errno == ERANGE) || IS_INF(value)) {
840 if (value == 0.0) {
841 Tcl_AppendResult(interp,
842 "floating-point value too small to represent",
843 (char *)NULL);
844 Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", Tcl_GetStringResult(interp),
845 (char *)NULL);
846 } else {
847 Tcl_AppendResult(interp,
848 "floating-point value too large to represent",
849 (char *)NULL);
850 Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", Tcl_GetStringResult(interp),
851 (char *)NULL);
852 }
853 } else {
854 char buf[20];
855
856 sprintf(buf, "%d", errno);
857 Tcl_AppendResult(interp, "unknown floating-point error, ",
858 "errno = ", buf, (char *)NULL);
859 Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", Tcl_GetStringResult(interp),
860 (char *)NULL);
861 }
862 }
863
864 /*
865 *--------------------------------------------------------------
866 *
867 * ParseString --
868 *
869 * Given a string (such as one coming from command or variable
870 * substitution), make a Value based on the string. The value
871 * will be a floating-point or integer, if possible, or else it
872 * will just be a copy of the string.
873 *
874 * Results:
875 * TCL_OK is returned under normal circumstances, and TCL_ERROR
876 * is returned if a floating-point overflow or underflow occurred
877 * while reading in a number. The value at *valuePtr is modified
878 * to hold a number, if possible.
879 *
880 * Side effects:
881 * None.
882 *
883 *--------------------------------------------------------------
884 */
885
886 static int
ParseString(interp,string,valuePtr)887 ParseString(interp, string, valuePtr)
888 Tcl_Interp *interp; /* Where to store error message. */
889 CONST char *string; /* String to turn into value. */
890 Value *valuePtr; /* Where to store value information.
891 * Caller must have initialized pv field. */
892 {
893 char *endPtr;
894 double value;
895
896 errno = 0;
897
898 /*
899 * The string can be either a number or a vector. First try to
900 * convert the string to a number. If that fails then see if
901 * we can find a vector by that name.
902 */
903
904 value = strtod(string, &endPtr);
905 if ((endPtr != string) && (*endPtr == '\0')) {
906 if (errno != 0) {
907 Tcl_ResetResult(interp);
908 MathError(interp, value);
909 return TCL_ERROR;
910 }
911 /* Numbers are stored as single element vectors. */
912 if (Blt_VectorChangeLength(valuePtr->vPtr, 1) != TCL_OK) {
913 return TCL_ERROR;
914 }
915 valuePtr->vPtr->valueArr[0] = value;
916 return TCL_OK;
917 } else {
918 VectorObject *vPtr;
919
920 while (isspace(UCHAR(*string))) {
921 string++; /* Skip spaces leading the vector name. */
922 }
923 vPtr = Blt_VectorParseElement(interp, valuePtr->vPtr->dataPtr, string,
924 &endPtr, NS_SEARCH_BOTH);
925 if (vPtr == NULL) {
926 return TCL_ERROR;
927 }
928 if (*endPtr != '\0') {
929 Tcl_AppendResult(interp, "extra characters after vector",
930 (char *)NULL);
931 return TCL_ERROR;
932 }
933 /* Copy the designated vector to our temporary. */
934 Blt_VectorDuplicate(valuePtr->vPtr, vPtr);
935 }
936 return TCL_OK;
937 }
938
939 /*
940 *----------------------------------------------------------------------
941 *
942 * ParseMathFunction --
943 *
944 * This procedure is invoked to parse a math function from an
945 * expression string, carry out the function, and return the
946 * value computed.
947 *
948 * Results:
949 * TCL_OK is returned if all went well and the function's value
950 * was computed successfully. If the name doesn't match any
951 * known math function, returns TCL_RETURN. And if a format error
952 * was found, TCL_ERROR is returned and an error message is left
953 * in interp->result.
954 *
955 * After a successful return parsePtr will be updated to point to
956 * the character just after the function call, the token is set
957 * to VALUE, and the value is stored in valuePtr.
958 *
959 * Side effects:
960 * Embedded commands could have arbitrary side-effects.
961 *
962 *----------------------------------------------------------------------
963 */
964 static int
ParseMathFunction(interp,start,parsePtr,valuePtr)965 ParseMathFunction(interp, start, parsePtr, valuePtr)
966 Tcl_Interp *interp; /* Interpreter to use for error reporting. */
967 char *start; /* Start of string to parse */
968 ParseInfo *parsePtr; /* Describes the state of the parse.
969 * parsePtr->nextPtr must point to the
970 * first character of the function's
971 * name. */
972 Value *valuePtr; /* Where to store value, if that is
973 * what's parsed from string. Caller
974 * must have initialized pv field
975 * correctly. */
976 {
977 Blt_HashEntry *hPtr;
978 MathFunction *mathPtr; /* Info about math function. */
979 register char *p;
980 VectorInterpData *dataPtr; /* Interpreter-specific data. */
981 VectorObject *vPtr;
982 Value optVal;
983 int result = TCL_OK;
984
985 /*
986 * Find the end of the math function's name and lookup the
987 * record for the function.
988 */
989 p = start;
990 while (isspace(UCHAR(*p))) {
991 p++;
992 }
993 parsePtr->nextPtr = p;
994 while (isalnum(UCHAR(*p)) || (*p == '_')) {
995 p++;
996 }
997 if (*p != '(') {
998 return TCL_RETURN; /* Must start with open parenthesis */
999 }
1000 dataPtr = valuePtr->vPtr->dataPtr;
1001 *p = '\0';
1002 hPtr = Blt_FindHashEntry(&(dataPtr->mathProcTable), parsePtr->nextPtr);
1003 *p = '(';
1004 if (hPtr == NULL) {
1005 return TCL_RETURN; /* Name doesn't match any known function */
1006 }
1007 /* Pick up the single value as the argument to the function */
1008 mathPtr = (MathFunction *) Blt_GetHashValue(hPtr);
1009 parsePtr->token = OPEN_PAREN;
1010 parsePtr->nextPtr = p + 1;
1011 valuePtr->pv.next = valuePtr->pv.buffer;
1012 optVal.funcArg = mathPtr->hasArg;
1013 if (NextValue(interp, parsePtr, -1, valuePtr, mathPtr->hasArg?&optVal:NULL) != TCL_OK) {
1014 /* Ok to skip argument and use self. */
1015 if (valuePtr->funcArg == -1 && parsePtr->vPtr && !mathPtr->hasArg) {
1016 Blt_VectorDuplicate(vPtr=valuePtr->vPtr, parsePtr->vPtr);
1017 Tcl_ResetResult(interp);
1018 goto callfunc;
1019 }
1020 return TCL_ERROR; /* Parse error */
1021 }
1022 vPtr = valuePtr->vPtr;
1023
1024 if (parsePtr->token != CLOSE_PAREN) {
1025 Tcl_AppendResult(interp, "unmatched parentheses in expression \"",
1026 parsePtr->expr, "\"", (char *)NULL);
1027 result = TCL_ERROR; /* Missing right parenthesis */
1028 goto cleanup;
1029 }
1030 callfunc:
1031 if ((*mathPtr->proc) (mathPtr->clientData, interp, vPtr, optVal.vPtr)
1032 != TCL_OK) {
1033 result = TCL_ERROR; /* Function invocation error */
1034 } else {
1035 parsePtr->token = VALUE;
1036 }
1037 cleanup:
1038 if (mathPtr->hasArg) {
1039 if (optVal.vPtr) {
1040 Blt_VectorFree(optVal.vPtr);
1041 }
1042 }
1043 return result;
1044 }
1045
1046 /*
1047 *----------------------------------------------------------------------
1048 *
1049 * NextToken --
1050 *
1051 * Lexical analyzer for expression parser: parses a single value,
1052 * operator, or other syntactic element from an expression string.
1053 *
1054 * Results:
1055 * TCL_OK is returned unless an error occurred while doing lexical
1056 * analysis or executing an embedded command. In that case a
1057 * standard Tcl error is returned, using interp->result to hold
1058 * an error message. In the event of a successful return, the token
1059 * and field in parsePtr is updated to refer to the next symbol in
1060 * the expression string, and the expr field is advanced past that
1061 * token; if the token is a value, then the value is stored at
1062 * valuePtr.
1063 *
1064 * Side effects:
1065 * None.
1066 *
1067 *----------------------------------------------------------------------
1068 */
1069 static int
NextToken(interp,parsePtr,valuePtr)1070 NextToken(interp, parsePtr, valuePtr)
1071 Tcl_Interp *interp; /* Interpreter to use for error reporting. */
1072 ParseInfo *parsePtr; /* Describes the state of the parse. */
1073 Value *valuePtr; /* Where to store value, if that is
1074 * what's parsed from string. Caller
1075 * must have initialized pv field
1076 * correctly. */
1077 {
1078 register char *p;
1079 char *endPtr;
1080 CONST char *var;
1081 int result;
1082
1083 p = parsePtr->nextPtr;
1084 while (isspace(UCHAR(*p))) {
1085 p++;
1086 }
1087 if (*p == '\0') {
1088 parsePtr->token = END;
1089 parsePtr->nextPtr = p;
1090 return TCL_OK;
1091 }
1092 /*
1093 * Try to parse the token as a floating-point number. But check
1094 * that the first character isn't a "-" or "+", which "strtod"
1095 * will happily accept as an unary operator. Otherwise, we might
1096 * accidently treat a binary operator as unary by mistake, which
1097 * will eventually cause a syntax error.
1098 */
1099 if (((*p != '-') || valuePtr->funcArg) && (*p != '+')) {
1100 double value;
1101
1102 errno = 0;
1103 value = strtod(p, &endPtr);
1104 if (endPtr != p) {
1105 if (errno != 0) {
1106 MathError(interp, value);
1107 return TCL_ERROR;
1108 }
1109 parsePtr->token = VALUE;
1110 parsePtr->nextPtr = endPtr;
1111
1112 /*
1113 * Save the single floating-point value as an 1-component vector.
1114 */
1115 if (Blt_VectorChangeLength(valuePtr->vPtr, 1) != TCL_OK) {
1116 return TCL_ERROR;
1117 }
1118 valuePtr->vPtr->valueArr[0] = value;
1119 return TCL_OK;
1120 }
1121 }
1122 if ((*p == 'l') && (p[1] == 'a') && (p[2] == 's') && (p[3] == 't') && (p[4] == 0)) {
1123
1124 parsePtr->token = VALUE;
1125 parsePtr->nextPtr = p+4;
1126 if (Blt_VectorChangeLength(valuePtr->vPtr, 1) != TCL_OK) {
1127 return TCL_ERROR;
1128 }
1129 valuePtr->vPtr->valueArr[0] = 0;
1130 valuePtr->isLast = 1;
1131 return TCL_OK;
1132 }
1133 parsePtr->nextPtr = p + 1;
1134 switch (*p) {
1135 case '$':
1136 parsePtr->token = VALUE;
1137 var = Tcl_ParseVar(interp, p, &endPtr);
1138 if (var == NULL) {
1139 return TCL_ERROR;
1140 }
1141 parsePtr->nextPtr = endPtr;
1142 Tcl_ResetResult(interp);
1143 result = ParseString(interp, var, valuePtr);
1144 return result;
1145
1146 case '[':
1147 parsePtr->token = VALUE;
1148 result = TclParseNestedCmd(interp, p + 1, 0, &endPtr, &(valuePtr->pv));
1149 if (result != TCL_OK) {
1150 return result;
1151 }
1152 parsePtr->nextPtr = endPtr;
1153 Tcl_ResetResult(interp);
1154 result = ParseString(interp, valuePtr->pv.buffer, valuePtr);
1155 return result;
1156
1157 case '"':
1158 parsePtr->token = VALUE;
1159 result = TclParseQuotes(interp, p + 1, '"', 0, &endPtr,
1160 &(valuePtr->pv));
1161 if (result != TCL_OK) {
1162 return result;
1163 }
1164 parsePtr->nextPtr = endPtr;
1165 Tcl_ResetResult(interp);
1166 result = ParseString(interp, valuePtr->pv.buffer, valuePtr);
1167 return result;
1168
1169 case '{':
1170 parsePtr->token = VALUE;
1171 result = TclParseBraces(interp, p + 1, &endPtr, &valuePtr->pv);
1172 if (result != TCL_OK) {
1173 return result;
1174 }
1175 parsePtr->nextPtr = endPtr;
1176 Tcl_ResetResult(interp);
1177 result = ParseString(interp, valuePtr->pv.buffer, valuePtr);
1178 return result;
1179
1180 case '(':
1181 parsePtr->token = OPEN_PAREN;
1182 break;
1183
1184 case ')':
1185 parsePtr->token = CLOSE_PAREN;
1186 break;
1187
1188 case ',':
1189 parsePtr->token = COMMA;
1190 break;
1191
1192 case '*':
1193 parsePtr->token = MULT;
1194 break;
1195
1196 case '/':
1197 parsePtr->token = DIVIDE;
1198 break;
1199
1200 case '%':
1201 parsePtr->token = MOD;
1202 break;
1203
1204 case '+':
1205 parsePtr->token = PLUS;
1206 break;
1207
1208 case '-':
1209 parsePtr->token = MINUS;
1210 break;
1211
1212 case '^':
1213 parsePtr->token = EXPONENT;
1214 break;
1215
1216 case '<':
1217 switch (*(p + 1)) {
1218 case '<':
1219 parsePtr->nextPtr = p + 2;
1220 parsePtr->token = LEFT_SHIFT;
1221 break;
1222 case '=':
1223 parsePtr->nextPtr = p + 2;
1224 parsePtr->token = LEQ;
1225 break;
1226 default:
1227 parsePtr->token = LESS;
1228 break;
1229 }
1230 break;
1231
1232 case '>':
1233 switch (*(p + 1)) {
1234 case '>':
1235 parsePtr->nextPtr = p + 2;
1236 parsePtr->token = RIGHT_SHIFT;
1237 break;
1238 case '=':
1239 parsePtr->nextPtr = p + 2;
1240 parsePtr->token = GEQ;
1241 break;
1242 default:
1243 parsePtr->token = GREATER;
1244 break;
1245 }
1246 break;
1247
1248 case '=':
1249 if (*(p + 1) == '=') {
1250 parsePtr->nextPtr = p + 2;
1251 parsePtr->token = EQUAL;
1252 } else {
1253 parsePtr->token = UNKNOWN;
1254 }
1255 break;
1256
1257 case '&':
1258 if (*(p + 1) == '&') {
1259 parsePtr->nextPtr = p + 2;
1260 parsePtr->token = AND;
1261 } else {
1262 parsePtr->token = UNKNOWN;
1263 }
1264 break;
1265
1266 case '|':
1267 if (*(p + 1) == '|') {
1268 parsePtr->nextPtr = p + 2;
1269 parsePtr->token = OR;
1270 } else {
1271 parsePtr->token = UNKNOWN;
1272 }
1273 break;
1274
1275 case '!':
1276 if (*(p + 1) == '=') {
1277 parsePtr->nextPtr = p + 2;
1278 parsePtr->token = NEQ;
1279 } else {
1280 parsePtr->token = NOT;
1281 }
1282 break;
1283
1284 default:
1285 parsePtr->token = VALUE;
1286 result = ParseMathFunction(interp, p, parsePtr, valuePtr);
1287 if ((result == TCL_OK) || (result == TCL_ERROR)) {
1288 return result;
1289 } else {
1290 VectorObject *vPtr;
1291
1292 while (isspace(UCHAR(*p))) {
1293 p++; /* Skip spaces leading the vector name. */
1294 }
1295 vPtr = Blt_VectorParseElement(interp, valuePtr->vPtr->dataPtr, p,
1296 &endPtr, NS_SEARCH_BOTH);
1297 if (vPtr == NULL) {
1298 return TCL_ERROR;
1299 }
1300 Blt_VectorDuplicate(valuePtr->vPtr, vPtr);
1301 parsePtr->nextPtr = endPtr;
1302 }
1303 }
1304 return TCL_OK;
1305 }
1306
1307 /*
1308 *----------------------------------------------------------------------
1309 *
1310 * NextValue --
1311 *
1312 * Parse a "value" from the remainder of the expression in parsePtr.
1313 *
1314 * Results:
1315 * Normally TCL_OK is returned. The value of the expression is
1316 * returned in *valuePtr. If an error occurred, then interp->result
1317 * contains an error message and TCL_ERROR is returned.
1318 * InfoPtr->token will be left pointing to the token AFTER the
1319 * expression, and parsePtr->nextPtr will point to the character just
1320 * after the terminating token.
1321 *
1322 * Side effects:
1323 * None.
1324 *
1325 *----------------------------------------------------------------------
1326 */
1327 static int
NextValue(interp,parsePtr,prec,valuePtr,optValPtr)1328 NextValue(interp, parsePtr, prec, valuePtr, optValPtr)
1329 Tcl_Interp *interp; /* Interpreter to use for error reporting. */
1330 ParseInfo *parsePtr; /* Describes the state of the parse
1331 * just before the value (i.e. NextToken will
1332 * be called to get first token of value). */
1333 int prec; /* Treat any un-parenthesized operator
1334 * with precedence <= this as the end
1335 * of the expression. */
1336 Value *valuePtr; /* Where to store the value of the expression.
1337 * Caller must have initialized pv field. */
1338 Value *optValPtr;
1339 {
1340 Value value2; /* Second operand for current operator. */
1341 int operator; /* Current operator (either unary or binary). */
1342 int gotOp; /* Non-zero means already lexed the operator
1343 * (while picking up value for unary operator).
1344 * Don't lex again. */
1345 int result;
1346 VectorObject *vPtr, *v2Ptr;
1347 register int i;
1348
1349 /*
1350 * There are two phases to this procedure. First, pick off an initial
1351 * value. Then, parse (binary operator, value) pairs until done.
1352 */
1353
1354 vPtr = valuePtr->vPtr;
1355 v2Ptr = Blt_VectorNew(vPtr->dataPtr);
1356 gotOp = FALSE;
1357 memset( &value2, 0, sizeof(value2));
1358 value2.funcArg = 0;
1359 value2.vPtr = v2Ptr;
1360 value2.pv.buffer = value2.pv.next = value2.staticSpace;
1361 value2.pv.end = value2.pv.buffer + STATIC_STRING_SPACE - 1;
1362 value2.pv.expandProc = TclExpandParseValue;
1363 value2.pv.clientData = NULL;
1364 if (optValPtr) {
1365 *optValPtr = value2;
1366 optValPtr->funcArg = 1;
1367 optValPtr->vPtr = Blt_VectorNew(vPtr->dataPtr);
1368
1369 }
1370
1371 result = NextToken(interp, parsePtr, valuePtr);
1372 if (result != TCL_OK) {
1373 goto done;
1374 }
1375 if (parsePtr->token == OPEN_PAREN) {
1376
1377 /* Parenthesized sub-expression. */
1378
1379 result = NextValue(interp, parsePtr, -1, valuePtr, 0);
1380 if (result != TCL_OK) {
1381 goto done;
1382 }
1383 if (parsePtr->token != CLOSE_PAREN) {
1384 Tcl_AppendResult(interp, "unmatched parentheses in expression \"",
1385 parsePtr->expr, "\"", (char *)NULL);
1386 result = TCL_ERROR;
1387 goto done;
1388 }
1389 } else {
1390 if (parsePtr->token == MINUS) {
1391 parsePtr->token = UNARY_MINUS;
1392 }
1393 if (parsePtr->token >= UNARY_MINUS) {
1394 operator = parsePtr->token;
1395 result = NextValue(interp, parsePtr, precTable[operator], valuePtr, 0);
1396 if (result != TCL_OK) {
1397 goto done;
1398 }
1399 gotOp = TRUE;
1400 /* Process unary operators. */
1401 switch (operator) {
1402 case UNARY_MINUS:
1403 for(i = 0; i < vPtr->length; i++) {
1404 vPtr->valueArr[i] = -(vPtr->valueArr[i]);
1405 }
1406 break;
1407
1408 case NOT:
1409 for(i = 0; i < vPtr->length; i++) {
1410 vPtr->valueArr[i] = (double)(!vPtr->valueArr[i]);
1411 }
1412 break;
1413 default:
1414 Tcl_AppendResult(interp, "unknown operator", (char *)NULL);
1415 goto error;
1416 }
1417 } else if (parsePtr->token != VALUE) {
1418 Tcl_AppendResult(interp, "missing operand", (char *)NULL);
1419 valuePtr->funcArg = -1;
1420 goto error;
1421 }
1422 }
1423 if (!gotOp) {
1424 result = NextToken(interp, parsePtr, &value2);
1425 if (result != TCL_OK) {
1426 goto done;
1427 }
1428 if (optValPtr) {
1429 if (parsePtr->token != COMMA) {
1430 goto error;
1431 }
1432 result = NextToken(interp, parsePtr, optValPtr);
1433 if (result != TCL_OK) {
1434 goto error;
1435 }
1436 result = NextToken(interp, parsePtr, optValPtr);
1437 if (result != TCL_OK) {
1438 goto error;
1439 }
1440 goto done;
1441 }
1442 }
1443 /*
1444 * Got the first operand. Now fetch (operator, operand) pairs.
1445 */
1446 for (;;) {
1447 operator = parsePtr->token;
1448
1449 value2.pv.next = value2.pv.buffer;
1450 if ((operator < MULT) || (operator >= UNARY_MINUS)) {
1451 if ((operator == END) || (operator == CLOSE_PAREN) ||
1452 (operator == COMMA)) {
1453 result = TCL_OK;
1454 goto done;
1455 } else {
1456 Tcl_AppendResult(interp, "bad operator", (char *)NULL);
1457 goto error;
1458 }
1459 }
1460 if (precTable[operator] <= prec) {
1461 result = TCL_OK;
1462 goto done;
1463 }
1464 result = NextValue(interp, parsePtr, precTable[operator], &value2, 0);
1465 if (result != TCL_OK) {
1466 goto done;
1467 }
1468 if ((parsePtr->token < MULT) && (parsePtr->token != VALUE) &&
1469 (parsePtr->token != END) && (parsePtr->token != CLOSE_PAREN) &&
1470 (parsePtr->token != COMMA)) {
1471 Tcl_AppendResult(interp, "unexpected token in expression",
1472 (char *)NULL);
1473 goto error;
1474 }
1475 /*
1476 * At this point we have two vectors and an operator.
1477 */
1478
1479 if (v2Ptr->length == 1) {
1480 register double *opnd;
1481 register double scalar;
1482
1483 /*
1484 * 2nd operand is a scalar.
1485 */
1486 scalar = v2Ptr->valueArr[0];
1487 opnd = vPtr->valueArr;
1488 #define DOLAST if (value2.isLast == 1) scalar = opnd[i];
1489 switch (operator) {
1490 case MULT:
1491 for(i = 0; i < vPtr->length; i++) {
1492 opnd[i] *= scalar;
1493 DOLAST
1494 }
1495 break;
1496
1497 case DIVIDE:
1498 if (scalar == 0.0) {
1499 Tcl_AppendResult(interp, "divide by zero", (char *)NULL);
1500 goto error;
1501 }
1502 for(i = 0; i < vPtr->length; i++) {
1503 opnd[i] /= scalar;
1504 DOLAST
1505 }
1506 break;
1507
1508 case PLUS:
1509 for(i = 0; i < vPtr->length; i++) {
1510 opnd[i] += scalar;
1511 DOLAST
1512 }
1513 break;
1514
1515 case MINUS:
1516 for(i = 0; i < vPtr->length; i++) {
1517 opnd[i] -= scalar;
1518 }
1519 break;
1520
1521 case EXPONENT:
1522 for(i = 0; i < vPtr->length; i++) {
1523 opnd[i] = pow(opnd[i], scalar);
1524 DOLAST
1525 }
1526 break;
1527
1528 case MOD:
1529 for(i = 0; i < vPtr->length; i++) {
1530 opnd[i] = Fmod(opnd[i], scalar);
1531 DOLAST
1532 }
1533 break;
1534
1535 case LESS:
1536 for(i = 0; i < vPtr->length; i++) {
1537 opnd[i] = (double)(opnd[i] < scalar);
1538 DOLAST
1539 }
1540 break;
1541
1542 case GREATER:
1543 for(i = 0; i < vPtr->length; i++) {
1544 opnd[i] = (double)(opnd[i] > scalar);
1545 DOLAST
1546 }
1547 break;
1548
1549 case LEQ:
1550 for(i = 0; i < vPtr->length; i++) {
1551 opnd[i] = (double)(opnd[i] <= scalar);
1552 DOLAST
1553 }
1554 break;
1555
1556 case GEQ:
1557 for(i = 0; i < vPtr->length; i++) {
1558 opnd[i] = (double)(opnd[i] >= scalar);
1559 DOLAST
1560 }
1561 break;
1562
1563 case EQUAL:
1564 for(i = 0; i < vPtr->length; i++) {
1565 opnd[i] = (double)(opnd[i] == scalar);
1566 DOLAST
1567 }
1568 break;
1569
1570 case NEQ:
1571 for(i = 0; i < vPtr->length; i++) {
1572 opnd[i] = (double)(opnd[i] != scalar);
1573 DOLAST
1574 }
1575 break;
1576
1577 case AND:
1578 for(i = 0; i < vPtr->length; i++) {
1579 opnd[i] = (double)(opnd[i] && scalar);
1580 DOLAST
1581 }
1582 break;
1583
1584 case OR:
1585 for(i = 0; i < vPtr->length; i++) {
1586 opnd[i] = (double)(opnd[i] || scalar);
1587 DOLAST
1588 }
1589 break;
1590
1591 case LEFT_SHIFT:
1592 {
1593 int offset;
1594
1595 offset = (int)scalar % vPtr->length;
1596 if (offset > 0) {
1597 double *hold;
1598 register int j;
1599
1600 hold = Blt_Malloc(sizeof(double) * offset);
1601 for (i = 0; i < offset; i++) {
1602 hold[i] = opnd[i];
1603 }
1604 for (i = offset, j = 0; i < vPtr->length; i++, j++) {
1605 opnd[j] = opnd[i];
1606 }
1607 for (i = 0, j = vPtr->length - offset;
1608 j < vPtr->length; i++, j++) {
1609 opnd[j] = hold[i];
1610 }
1611 Blt_Free(hold);
1612 }
1613 }
1614 break;
1615
1616 case RIGHT_SHIFT:
1617 {
1618 int offset;
1619
1620 offset = (int)scalar % vPtr->length;
1621 if (offset > 0) {
1622 double *hold;
1623 register int j;
1624
1625 hold = Blt_Malloc(sizeof(double) * offset);
1626 for (i = vPtr->length - offset, j = 0;
1627 i < vPtr->length; i++, j++) {
1628 hold[j] = opnd[i];
1629 }
1630 for (i = vPtr->length - offset - 1,
1631 j = vPtr->length - 1; i >= 0; i--, j--) {
1632 opnd[j] = opnd[i];
1633 }
1634 for (i = 0; i < offset; i++) {
1635 opnd[i] = hold[i];
1636 }
1637 Blt_Free(hold);
1638 }
1639 }
1640 break;
1641
1642 default:
1643 Tcl_AppendResult(interp, "unknown operator in expression",
1644 (char *)NULL);
1645 goto error;
1646 }
1647
1648 } else if (vPtr->length == 1) {
1649 register double *opnd;
1650 register double scalar;
1651 /*
1652 * 1st operand is a scalar.
1653 */
1654 scalar = vPtr->valueArr[0];
1655 Blt_VectorDuplicate(vPtr, v2Ptr);
1656 opnd = vPtr->valueArr;
1657 switch (operator) {
1658 case MULT:
1659 for(i = 0; i < vPtr->length; i++) {
1660 opnd[i] *= scalar;
1661 }
1662 break;
1663
1664 case PLUS:
1665 for(i = 0; i < vPtr->length; i++) {
1666 opnd[i] += scalar;
1667 }
1668 break;
1669
1670 case DIVIDE:
1671 for(i = 0; i < vPtr->length; i++) {
1672 if (opnd[i] == 0.0) {
1673 Tcl_AppendResult(interp, "divide by zero",
1674 (char *)NULL);
1675 goto error;
1676 }
1677 opnd[i] = (scalar / opnd[i]);
1678 }
1679 break;
1680
1681 case MINUS:
1682 for(i = 0; i < vPtr->length; i++) {
1683 opnd[i] = scalar - opnd[i];
1684 }
1685 break;
1686
1687 case EXPONENT:
1688 for(i = 0; i < vPtr->length; i++) {
1689 opnd[i] = pow(scalar, opnd[i]);
1690 }
1691 break;
1692
1693 case MOD:
1694 for(i = 0; i < vPtr->length; i++) {
1695 opnd[i] = Fmod(scalar, opnd[i]);
1696 }
1697 break;
1698
1699 case LESS:
1700 for(i = 0; i < vPtr->length; i++) {
1701 opnd[i] = (double)(scalar < opnd[i]);
1702 }
1703 break;
1704
1705 case GREATER:
1706 for(i = 0; i < vPtr->length; i++) {
1707 opnd[i] = (double)(scalar > opnd[i]);
1708 }
1709 break;
1710
1711 case LEQ:
1712 for(i = 0; i < vPtr->length; i++) {
1713 opnd[i] = (double)(scalar >= opnd[i]);
1714 }
1715 break;
1716
1717 case GEQ:
1718 for(i = 0; i < vPtr->length; i++) {
1719 opnd[i] = (double)(scalar <= opnd[i]);
1720 }
1721 break;
1722
1723 case EQUAL:
1724 for(i = 0; i < vPtr->length; i++) {
1725 opnd[i] = (double)(opnd[i] == scalar);
1726 }
1727 break;
1728
1729 case NEQ:
1730 for(i = 0; i < vPtr->length; i++) {
1731 opnd[i] = (double)(opnd[i] != scalar);
1732 }
1733 break;
1734
1735 case AND:
1736 for(i = 0; i < vPtr->length; i++) {
1737 opnd[i] = (double)(opnd[i] && scalar);
1738 }
1739 break;
1740
1741 case OR:
1742 for(i = 0; i < vPtr->length; i++) {
1743 opnd[i] = (double)(opnd[i] || scalar);
1744 }
1745 break;
1746
1747 case LEFT_SHIFT:
1748 case RIGHT_SHIFT:
1749 Tcl_AppendResult(interp, "second shift operand must be scalar",
1750 (char *)NULL);
1751 goto error;
1752
1753 default:
1754 Tcl_AppendResult(interp, "unknown operator in expression",
1755 (char *)NULL);
1756 goto error;
1757 }
1758 } else {
1759 register double *opnd1, *opnd2;
1760 /*
1761 * Carry out the function of the specified operator.
1762 */
1763 if (vPtr->length != v2Ptr->length) {
1764 Tcl_AppendResult(interp, "vectors are different lengths",
1765 (char *)NULL);
1766 goto error;
1767 }
1768 opnd1 = vPtr->valueArr, opnd2 = v2Ptr->valueArr;
1769 switch (operator) {
1770 case MULT:
1771 for (i = 0; i < vPtr->length; i++) {
1772 opnd1[i] *= opnd2[i];
1773 }
1774 break;
1775
1776 case DIVIDE:
1777 for (i = 0; i < vPtr->length; i++) {
1778 if (opnd2[i] == 0.0) {
1779 Tcl_AppendResult(interp,
1780 "can't divide by 0.0 vector component",
1781 (char *)NULL);
1782 goto error;
1783 }
1784 opnd1[i] /= opnd2[i];
1785 }
1786 break;
1787
1788 case PLUS:
1789 for (i = 0; i < vPtr->length; i++) {
1790 opnd1[i] += opnd2[i];
1791 }
1792 break;
1793
1794 case MINUS:
1795 for (i = 0; i < vPtr->length; i++) {
1796 opnd1[i] -= opnd2[i];
1797 }
1798 break;
1799
1800 case MOD:
1801 for (i = 0; i < vPtr->length; i++) {
1802 opnd1[i] = Fmod(opnd1[i], opnd2[i]);
1803 }
1804 break;
1805
1806 case EXPONENT:
1807 for (i = 0; i < vPtr->length; i++) {
1808 opnd1[i] = pow(opnd1[i], opnd2[i]);
1809 }
1810 break;
1811
1812 case LESS:
1813 for (i = 0; i < vPtr->length; i++) {
1814 opnd1[i] = (double)(opnd1[i] < opnd2[i]);
1815 }
1816 break;
1817
1818 case GREATER:
1819 for (i = 0; i < vPtr->length; i++) {
1820 opnd1[i] = (double)(opnd1[i] > opnd2[i]);
1821 }
1822 break;
1823
1824 case LEQ:
1825 for (i = 0; i < vPtr->length; i++) {
1826 opnd1[i] = (double)(opnd1[i] <= opnd2[i]);
1827 }
1828 break;
1829
1830 case GEQ:
1831 for (i = 0; i < vPtr->length; i++) {
1832 opnd1[i] = (double)(opnd1[i] >= opnd2[i]);
1833 }
1834 break;
1835
1836 case EQUAL:
1837 for (i = 0; i < vPtr->length; i++) {
1838 opnd1[i] = (double)(opnd1[i] == opnd2[i]);
1839 }
1840 break;
1841
1842 case NEQ:
1843 for (i = 0; i < vPtr->length; i++) {
1844 opnd1[i] = (double)(opnd1[i] != opnd2[i]);
1845 }
1846 break;
1847
1848 case AND:
1849 for (i = 0; i < vPtr->length; i++) {
1850 opnd1[i] = (double)(opnd1[i] && opnd2[i]);
1851 }
1852 break;
1853
1854 case OR:
1855 for (i = 0; i < vPtr->length; i++) {
1856 opnd1[i] = (double)(opnd1[i] || opnd2[i]);
1857 }
1858 break;
1859
1860 case LEFT_SHIFT:
1861 case RIGHT_SHIFT:
1862 Tcl_AppendResult(interp, "second shift operand must be scalar",
1863 (char *)NULL);
1864 goto error;
1865
1866 default:
1867 Tcl_AppendResult(interp, "unknown operator in expression",
1868 (char *)NULL);
1869 goto error;
1870 }
1871 }
1872 }
1873 done:
1874 if (value2.pv.buffer != value2.staticSpace) {
1875 Blt_Free(value2.pv.buffer);
1876 }
1877 Blt_VectorFree(v2Ptr);
1878 return result;
1879
1880 error:
1881 if (value2.pv.buffer != value2.staticSpace) {
1882 Blt_Free(value2.pv.buffer);
1883 }
1884 Blt_VectorFree(v2Ptr);
1885 return TCL_ERROR;
1886 }
1887
1888 /*
1889 *--------------------------------------------------------------
1890 *
1891 * EvaluateExpression --
1892 *
1893 * This procedure provides top-level functionality shared by
1894 * procedures like Tcl_ExprInt, Tcl_ExprDouble, etc.
1895 *
1896 * Results:
1897 * The result is a standard Tcl return value. If an error
1898 * occurs then an error message is left in interp->result.
1899 * The value of the expression is returned in *valuePtr, in
1900 * whatever form it ends up in (could be string or integer
1901 * or double). Caller may need to convert result. Caller
1902 * is also responsible for freeing string memory in *valuePtr,
1903 * if any was allocated.
1904 *
1905 * Side effects:
1906 * None.
1907 *
1908 *--------------------------------------------------------------
1909 */
1910 static int
EvaluateExpression(interp,string,valuePtr,cvPtr)1911 EvaluateExpression(interp, string, valuePtr, cvPtr)
1912 Tcl_Interp *interp; /* Context in which to evaluate the
1913 * expression. */
1914 char *string; /* Expression to evaluate. */
1915 Value *valuePtr; /* Where to store result. Should
1916 * not be initialized by caller. */
1917 VectorObject *cvPtr;
1918 {
1919 ParseInfo info;
1920 int result;
1921 VectorObject *vPtr;
1922 register int i;
1923
1924 info.expr = info.nextPtr = string;
1925 info.vPtr = cvPtr;
1926 valuePtr->pv.buffer = valuePtr->pv.next = valuePtr->staticSpace;
1927 valuePtr->pv.end = valuePtr->pv.buffer + STATIC_STRING_SPACE - 1;
1928 valuePtr->pv.expandProc = TclExpandParseValue;
1929 valuePtr->pv.clientData = NULL;
1930
1931 result = NextValue(interp, &info, -1, valuePtr, 0);
1932 if (result != TCL_OK) {
1933 return result;
1934 }
1935 if (info.token != END) {
1936 Tcl_AppendResult(interp, ": syntax error in expression \"",
1937 string, "\"", (char *)NULL);
1938 return TCL_ERROR;
1939 }
1940 vPtr = valuePtr->vPtr;
1941
1942 /* Check for NaN's and overflows. */
1943 for (i = 0; i < vPtr->length; i++) {
1944 if (!FINITE(vPtr->valueArr[i])) {
1945 /*
1946 * IEEE floating-point error.
1947 */
1948 MathError(interp, vPtr->valueArr[i]);
1949 return TCL_ERROR;
1950 }
1951 }
1952 return TCL_OK;
1953 }
1954
1955 /*
1956 *----------------------------------------------------------------------
1957 *
1958 * Math Functions --
1959 *
1960 * This page contains the procedures that implement all of the
1961 * built-in math functions for expressions.
1962 *
1963 * Results:
1964 * Each procedure returns TCL_OK if it succeeds and places result
1965 * information at *resultPtr. If it fails it returns TCL_ERROR
1966 * and leaves an error message in interp->result.
1967 *
1968 * Side effects:
1969 * None.
1970 *
1971 *----------------------------------------------------------------------
1972 */
1973 static int
ComponentFunc(clientData,interp,vPtr)1974 ComponentFunc(clientData, interp, vPtr)
1975 ClientData clientData; /* Contains address of procedure that
1976 * takes one double argument and
1977 * returns a double result. */
1978 Tcl_Interp *interp;
1979 VectorObject *vPtr;
1980 {
1981 ComponentProc *procPtr = (ComponentProc *) clientData;
1982 register int i;
1983
1984 errno = 0;
1985 for(i = First(vPtr); i >= 0; i = Next(vPtr, i)) {
1986 vPtr->valueArr[i] = (*procPtr) (vPtr->valueArr[i]);
1987 if (errno != 0) {
1988 MathError(interp, vPtr->valueArr[i]);
1989 return TCL_ERROR;
1990 }
1991 if (!FINITE(vPtr->valueArr[i])) {
1992 /*
1993 * IEEE floating-point error.
1994 */
1995 MathError(interp, vPtr->valueArr[i]);
1996 return TCL_ERROR;
1997 }
1998 }
1999 return TCL_OK;
2000 }
2001
2002 static int
ScalarFunc(clientData,interp,vPtr)2003 ScalarFunc(clientData, interp, vPtr)
2004 ClientData clientData;
2005 Tcl_Interp *interp;
2006 VectorObject *vPtr;
2007 {
2008 double value;
2009 ScalarProc *procPtr = (ScalarProc *) clientData;
2010
2011 errno = 0;
2012 value = (*procPtr) (vPtr);
2013 if (errno != 0) {
2014 MathError(interp, value);
2015 return TCL_ERROR;
2016 }
2017 if (Blt_VectorChangeLength(vPtr, 1) != TCL_OK) {
2018 return TCL_ERROR;
2019 }
2020 vPtr->valueArr[0] = value;
2021 return TCL_OK;
2022 }
2023
2024 /*ARGSUSED*/
2025 static int
VectorFunc(clientData,interp,vPtr)2026 VectorFunc(clientData, interp, vPtr)
2027 ClientData clientData;
2028 Tcl_Interp *interp; /* Not used. */
2029 VectorObject *vPtr;
2030 {
2031 VectorProc *procPtr = (VectorProc *) clientData;
2032
2033 return (*procPtr) (vPtr);
2034 }
2035
2036 static int
Opt1Func(clientData,interp,vPtr,optPtr)2037 Opt1Func(clientData, interp, vPtr, optPtr)
2038 ClientData clientData;
2039 Tcl_Interp *interp; /* Not used. */
2040 VectorObject *vPtr;
2041 VectorObject *optPtr;
2042 {
2043 Opt1Proc *procPtr = (Opt1Proc *) clientData;
2044
2045 return (*procPtr) (vPtr, optPtr);
2046 }
2047
2048
2049 static MathFunction mathFunctions[] =
2050 {
2051 {"abs", (GenericMathProc *) ComponentFunc, (ClientData)Fabs},
2052 {"acos", (GenericMathProc *) ComponentFunc, (ClientData)acos},
2053 {"asin", (GenericMathProc *) ComponentFunc, (ClientData)asin},
2054 {"atan", (GenericMathProc *) ComponentFunc, (ClientData)atan},
2055 {"adev", (GenericMathProc *) ScalarFunc, (ClientData)AvgDeviation},
2056 {"ceil", (GenericMathProc *) ComponentFunc, (ClientData)ceil},
2057 {"cos", (GenericMathProc *) ComponentFunc, (ClientData)cos},
2058 {"cosh", (GenericMathProc *) ComponentFunc, (ClientData)cosh},
2059 {"exp", (GenericMathProc *) ComponentFunc, (ClientData)exp},
2060 {"floor", (GenericMathProc *) ComponentFunc, (ClientData)floor},
2061 {"invert", (GenericMathProc *) VectorFunc, (ClientData)Invert},
2062 {"kurtosis", (GenericMathProc *) ScalarFunc, (ClientData)Kurtosis},
2063 {"length", (GenericMathProc *) ScalarFunc, (ClientData)Length},
2064 {"log", (GenericMathProc *) ComponentFunc, (ClientData)log},
2065 {"log10", (GenericMathProc *) ComponentFunc, (ClientData)log10},
2066 {"max", (GenericMathProc *) ScalarFunc, (ClientData)Blt_VecMax},
2067 {"mean", (GenericMathProc *) ScalarFunc, (ClientData)Mean},
2068 {"median", (GenericMathProc *) ScalarFunc, (ClientData)Median},
2069 {"min", (GenericMathProc *) ScalarFunc, (ClientData)Blt_VecMin},
2070 {"norm", (GenericMathProc *) VectorFunc, (ClientData)Norm},
2071 {"nz", (GenericMathProc *) ScalarFunc, (ClientData)Nonzeros},
2072 {"q1", (GenericMathProc *) ScalarFunc, (ClientData)Q1},
2073 {"q3", (GenericMathProc *) ScalarFunc, (ClientData)Q3},
2074 {"prod", (GenericMathProc *) ScalarFunc, (ClientData)Product},
2075 #ifdef HAVE_DRAND48
2076 {"random", (GenericMathProc *) ComponentFunc, (ClientData)drand48},
2077 #endif
2078 {"round", (GenericMathProc *) ComponentFunc, (ClientData)Round},
2079 {"row", (GenericMathProc *) VectorFunc, (ClientData)Row},
2080 {"sdev", (GenericMathProc *) ScalarFunc, (ClientData)StdDeviation},
2081 {"shift", (GenericMathProc *) Opt1Func, (ClientData)Shift, 1 },
2082 {"sin", (GenericMathProc *) ComponentFunc, (ClientData)sin},
2083 {"sinh", (GenericMathProc *) ComponentFunc, (ClientData)sinh},
2084 {"skew", (GenericMathProc *) ScalarFunc, (ClientData)Skew},
2085 {"sort", (GenericMathProc *) VectorFunc, (ClientData)Sort},
2086 {"sqrt", (GenericMathProc *) ComponentFunc, (ClientData)sqrt},
2087 {"sum", (GenericMathProc *) ScalarFunc, (ClientData)Sum},
2088 {"tan", (GenericMathProc *) ComponentFunc, (ClientData)tan},
2089 {"tanh", (GenericMathProc *) ComponentFunc, (ClientData)tanh},
2090 {"var", (GenericMathProc *) ScalarFunc, (ClientData)Variance},
2091 {(char *)NULL,},
2092 };
2093
2094 void
Blt_VectorInstallMathFunctions(tablePtr)2095 Blt_VectorInstallMathFunctions(tablePtr)
2096 Blt_HashTable *tablePtr;
2097 {
2098 Blt_HashEntry *hPtr;
2099 register MathFunction *mathPtr;
2100 int isNew;
2101
2102 for (mathPtr = mathFunctions; mathPtr->name != NULL; mathPtr++) {
2103 hPtr = Blt_CreateHashEntry(tablePtr, mathPtr->name, &isNew);
2104 Blt_SetHashValue(hPtr, (ClientData)mathPtr);
2105 }
2106 }
2107
2108 void
Blt_VectorUninstallMathFunctions(tablePtr)2109 Blt_VectorUninstallMathFunctions(tablePtr)
2110 Blt_HashTable *tablePtr;
2111 {
2112 MathFunction *mathPtr;
2113 Blt_HashEntry *hPtr;
2114 Blt_HashSearch cursor;
2115
2116 for (hPtr = Blt_FirstHashEntry(tablePtr, &cursor); hPtr != NULL;
2117 hPtr = Blt_NextHashEntry(&cursor)) {
2118 mathPtr = (MathFunction *) Blt_GetHashValue(hPtr);
2119 if (mathPtr->name == NULL) {
2120 Blt_Free(mathPtr);
2121 }
2122 }
2123 }
2124
2125
2126 static void
InstallIndexProc(tablePtr,string,procPtr)2127 InstallIndexProc(tablePtr, string, procPtr)
2128 Blt_HashTable *tablePtr;
2129 char *string;
2130 Blt_VectorIndexProc *procPtr; /* Pointer to function to be called
2131 * when the vector finds the named index.
2132 * If NULL, this indicates to remove
2133 * the index from the table.
2134 */
2135 {
2136 Blt_HashEntry *hPtr;
2137 int dummy;
2138
2139 hPtr = Blt_CreateHashEntry(tablePtr, string, &dummy);
2140 if (procPtr == NULL) {
2141 Blt_DeleteHashEntry(tablePtr, hPtr);
2142 } else {
2143 Blt_SetHashValue(hPtr, (ClientData)procPtr);
2144 }
2145 }
2146
2147 void
Blt_VectorInstallSpecialIndices(tablePtr)2148 Blt_VectorInstallSpecialIndices(tablePtr)
2149 Blt_HashTable *tablePtr;
2150 {
2151 InstallIndexProc(tablePtr, "min", Blt_VecMin);
2152 InstallIndexProc(tablePtr, "max", Blt_VecMax);
2153 InstallIndexProc(tablePtr, "mean", Mean);
2154 InstallIndexProc(tablePtr, "sum", Sum);
2155 InstallIndexProc(tablePtr, "prod", Product);
2156 }
2157
2158 /* Evaluate expression and handle ? : conditional. */
2159 /* TODO: evaluate/compile all expressions to detect syntax error. */
2160 static VectorObject*
EvalVectorExpr(interp,string,dataPtr,vPtr)2161 EvalVectorExpr(interp, string, dataPtr, vPtr)
2162 Tcl_Interp *interp; /* Context in which to evaluate the
2163 * expression. */
2164 char *string; /* Expression to evaluate. */
2165 VectorInterpData *dataPtr; /* Interpreter-specific data. */
2166 VectorObject *vPtr;
2167 {
2168 VectorObject *result = NULL;
2169 Value value;
2170 char *quest, *colon, *cp;
2171 char zStatic[201], *s[3];
2172 int i, sz, vm[3], vmax, vmi, isconst, lvl;
2173 Value values[3];
2174 double *v[3];
2175
2176 memset( &value, 0, sizeof(value));
2177 value.funcArg = 0;
2178 quest = strchr(string, '?');
2179 if (quest && ((colon = strchr(string, ':')))) {
2180 /* Handling conditional "X ? Y : Z" */
2181 } else {
2182 value.vPtr = Blt_VectorNew(dataPtr);
2183 if (EvaluateExpression(interp, string, &value, vPtr) != TCL_OK) {
2184 Blt_VectorFree(value.vPtr);
2185 return NULL;
2186 }
2187 return value.vPtr;
2188 }
2189
2190 /* Make a static copy of index. */
2191 sz = strlen(string);
2192 if (sz>=200) {
2193 char *zBuf = Blt_Malloc(sz+1);
2194 strcpy(zBuf, string);
2195 string = zBuf;
2196 } else {
2197 strcpy(zStatic, string);
2198 string = zStatic;
2199 }
2200 quest = strchr(string, '?');
2201 cp = quest+1;
2202 lvl = 0;
2203 while ( *cp && (*cp != ':' || lvl > 0)) {
2204 if (*cp == '?') lvl++;
2205 if (*cp == ':') lvl--;
2206 cp++;
2207 }
2208 if (lvl || *cp != ':') {
2209 Tcl_AppendResult(interp, "'?' conditional missing ':'", 0);
2210 return NULL;
2211 }
2212 colon = cp;
2213 *quest = 0;
2214 *colon = 0;
2215 s[0] = string;
2216 s[1] = quest+1;
2217 s[2] = colon+1;
2218 for (i=0; i<3; i++) {
2219 while (*s[i] != 0 && isspace(*s[i])) {
2220 s[i] = s[i]+1;
2221 }
2222 if (!*s[i]) {
2223 Tcl_AppendResult(interp, "null expression in conditional", 0);
2224 return NULL;
2225 }
2226 }
2227 values[0].vPtr = values[1].vPtr = values[2].vPtr = NULL;
2228 vmax =0;
2229 vmi = -1;
2230 isconst = 1;
2231 for (i=0; i<3; i++) {
2232 if ((result = EvalVectorExpr(interp, s[i], dataPtr, vPtr)) == NULL) {
2233 goto cleanup;
2234 }
2235 values[i].vPtr = result;
2236 v[i] = values[i].vPtr->valueArr;
2237 vm[i] = values[i].vPtr->length;
2238 if (vm[i]>vmax) { vmax = vm[vmi=i]; }
2239 if (i==0) {
2240 if (values[0].vPtr->length == 1) {
2241 isconst = 1;
2242 if (!v[0][0]) { isconst++; i++; }
2243 }
2244 } else if (isconst && i==1) break;
2245 }
2246 if (isconst==1) {
2247 result = values[1].vPtr;
2248 values[1].vPtr = NULL;
2249 } else if (isconst==2) {
2250 result = values[2].vPtr;
2251 values[2].vPtr = NULL;
2252 } else {
2253 #define VM(n,i) v[n][vm[n]>i?i:vm[n]]
2254 values[vmi].vPtr = NULL;
2255 for (i=0; i<result->length; i++) {
2256 result->valueArr[i] = (VM(0,i) ? VM(1,i) : VM(2,i) );
2257 }
2258 result = values[vmi].vPtr;
2259 }
2260
2261 cleanup:
2262 for (i=0; i<3; i++) {
2263 if (values[i].vPtr) {
2264 Blt_VectorFree(values[i].vPtr);
2265 }
2266 }
2267 if (string != zStatic) {
2268 Blt_Free(string);
2269 }
2270 return result;
2271
2272 }
2273
2274
2275 /*
2276 *--------------------------------------------------------------
2277 *
2278 * Blt_ExprVector --
2279 *
2280 * Evaluates an vector expression and returns its value(s).
2281 *
2282 * Results:
2283 * Each of the procedures below returns a standard Tcl result.
2284 * If an error occurs then an error message is left in
2285 * interp->result. Otherwise the value of the expression,
2286 * in the appropriate form, is stored at *resultPtr. If
2287 * the expression had a result that was incompatible with the
2288 * desired form then an error is returned.
2289 *
2290 * Side effects:
2291 * None.
2292 *
2293 *--------------------------------------------------------------
2294 */
2295 int
Blt_ExprVector(interp,string,vecPtr)2296 Blt_ExprVector(interp, string, vecPtr)
2297 Tcl_Interp *interp; /* Context in which to evaluate the
2298 * expression. */
2299 char *string; /* Expression to evaluate. */
2300 Blt_Vector *vecPtr; /* Where to store result. */
2301 {
2302 VectorInterpData *dataPtr; /* Interpreter-specific data. */
2303 VectorObject *nvPtr, *vPtr = (VectorObject *)vecPtr;
2304 int result = TCL_OK;
2305
2306 dataPtr = (vecPtr != NULL)
2307 ? vPtr->dataPtr : Blt_VectorGetInterpData(interp);
2308
2309 if ((nvPtr = EvalVectorExpr(interp, string, dataPtr, vPtr)) == NULL) {
2310 result = TCL_ERROR;
2311 goto cleanup;
2312 }
2313
2314 //printf("VMAX: %d, vmi=%d, %d,%d,%d\n", vmax, vmi, vm[0], vm[1],vm[2]);
2315 #define VM(n,i) v[n][vm[n]>i?i:vm[n]]
2316
2317 if (vPtr != NULL) {
2318 Blt_VectorDuplicate(vPtr, nvPtr);
2319 } else {
2320 register int i;
2321 /* No result vector. Put values in interp->result. */
2322 for (i = 0; i < nvPtr->length; i++) {
2323 string = Blt_Dtoa(interp, nvPtr->valueArr[i]);
2324 Tcl_AppendElement(interp, string);
2325 }
2326 }
2327 cleanup:
2328 if (nvPtr) {
2329 Blt_VectorFree(nvPtr);
2330 }
2331 return result;
2332 }
2333