/[ascend]/trunk/base/generic/compiler/relation.c
ViewVC logotype

Contents of /trunk/base/generic/compiler/relation.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 222 - (show annotations) (download) (as text)
Fri Jan 27 04:23:20 2006 UTC (14 years, 10 months ago) by johnpye
File MIME type: text/x-csrc
File size: 131613 byte(s)
Updating for Jerry's new error_reporter syntax, bug #179
1 /*
2 * Relation construction routines
3 * by Tom Epperly
4 * Created: 1/30/90
5 * Version: $Revision: 1.32 $
6 * Version control file: $RCSfile: relation.c,v $
7 * Date last modified: $Date: 1998/03/17 22:09:24 $
8 * Last modified by: $Author: ballan $
9 *
10 * This file is part of the Ascend Language Interpreter.
11 *
12 * Copyright (C) 1990, 1993, 1994 Thomas Guthrie Epperly
13 * Copyright (C) 1993, 1994, 1995 Kirk Andre' Abbott
14 * Copyright (C) 1996 Benjamin Andrew Allan
15 *
16 * The Ascend Language Interpreter is free software; you can redistribute
17 * it and/or modify it under the terms of the GNU General Public License as
18 * published by the Free Software Foundation; either version 2 of the
19 * License, or (at your option) any later version.
20 *
21 * The Ascend Language Interpreter is distributed in hope that it will be
22 * useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
23 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
24 * General Public License for more details.
25 *
26 * You should have received a copy of the GNU General Public License
27 * along with the program; if not, write to the Free Software Foundation,
28 * Inc., 675 Mass Ave, Cambridge, MA 02139 USA. Check the file named
29 * COPYING.
30 *
31 */
32
33 #include <math.h>
34 #include <stdarg.h>
35 #include "utilities/ascConfig.h"
36 #include "utilities/ascMalloc.h"
37 #include "utilities/ascPanic.h"
38 #include "general/pool.h"
39 #include "general/list.h"
40 #include "general/stack.h"
41 #include "general/dstring.h"
42 #include "compiler/compiler.h"
43 #include "compiler/fractions.h"
44 #include "compiler/dimen.h"
45 #include "compiler/functype.h"
46 #include "compiler/func.h"
47 #include "compiler/types.h"
48 #include "compiler/name.h"
49 #include "compiler/nameio.h"
50 #include "compiler/instance_enum.h"
51 #include "compiler/bintoken.h"
52 #include "compiler/exprs.h"
53 #include "compiler/exprio.h"
54 #include "compiler/value_type.h"
55 #include "compiler/evaluate.h"
56 #include "compiler/forvars.h"
57 #include "compiler/find.h"
58 #include "compiler/sets.h"
59 #include "compiler/setinstval.h"
60 #include "compiler/instance_io.h"
61 #include "compiler/extcall.h"
62 #include "compiler/relation_type.h"
63 #include "compiler/relation_util.h"
64 #include "compiler/rel_common.h"
65 #include "compiler/temp.h"
66 #include "compiler/atomvalue.h"
67 #include "compiler/mathinst.h"
68 #include "compiler/instquery.h"
69 #include "compiler/tmpnum.h"
70 #include "compiler/relation.h"
71
72 #ifndef lint
73 static CONST char RelationModRCSid[] =
74 "$Id: relation.c,v 1.32 1998/03/17 22:09:24 ballan Exp $";
75 #endif
76
77 /*
78 * internal form of RelationRelop for lval or rval use.
79 */
80 #define RelRelop(r) ((r)->share->s.relop)
81
82 #define SUM 1
83 #define PROD 0
84 #ifndef abs
85 #define abs(a) ( ((a)>0) ? (a) : (-(a)) )
86 #endif
87
88 /*
89 * Some global and exported variables.
90 */
91 struct gl_list_t *g_relation_var_list = NULL;
92
93 int g_simplify_relations = 1;
94
95 int g_ExternalNodeStamps=0; /* incremented each time an new external
96 * statement is seen */
97
98 /* fwd declaration */
99 static union RelationTermUnion
100 *CopyRelationSide(union RelationTermUnion *, unsigned long);
101
102 #ifdef THIS_IS_AN_UNUSED_FUNCTION
103 static
104 unsigned long ExprLength(register CONST struct Expr *start,
105 register CONST struct Expr *stop)
106 {
107 register unsigned long result=0;
108 while(start!=stop){
109 start = NextExpr(start);
110 result++;
111 }
112 return result;
113 }
114 #endif /* THIS_IS_AN_UNUSED_FUNCTION */
115
116
117 static
118 void FigureOutError(struct value_t value,
119 enum relation_errors *err,
120 enum find_errors *ferr)
121 {
122 assert(ValueKind(value)==error_value);
123 *err = find_error;
124 switch(ErrorValue(value)){
125 case type_conflict:
126 case dimension_conflict:
127 case incorrect_name:
128 case incorrect_such_that:
129 case empty_choice:
130 case empty_intersection:
131 case temporary_variable_reused:
132 *ferr = impossible_instance;
133 break;
134 case undefined_value:
135 *ferr = undefined_instance;
136 break;
137 case name_unfound:
138 *ferr = unmade_instance;
139 break;
140 default:
141 Asc_Panic(2, NULL, "Unknown error type in FigureOutError.\n");
142 break;
143 }
144 }
145
146
147 /*********************************************************************\
148 Section for creation and management of relation terms.
149 It is cheaper to create relation terms in arrays the size of
150 the union than individually because of operating system overhead.
151
152 Lookout, the tokens have unionized: next they'll want a raise.
153 \*********************************************************************/
154 /*
155 * The define POOL_ALLOCTERM is for people who are pulling terms out
156 * of a pool and promise to return them immediately.
157 */
158
159 static pool_store_t g_term_pool = NULL;
160 /* A pool_store for 1 expression.
161 * It is expected that objective functions will cause the
162 * largest expressions.
163 * Each time an expression is completed, it will be copied
164 * into an array which can be created already knowing
165 * its proper size. The array will be naturally in postfix.
166 */
167
168 #define POOL_ALLOCTERM A_TERM(pool_get_element(g_term_pool))
169 /* get a token. Token is the size of the RelationTermUnion. */
170 #ifdef NDEBUG
171 #define PTINIT(x)
172 #else
173 #define PTINIT(x) TermUnionInit(x)
174 #endif
175 #define POOL_RESET pool_clear_store(g_term_pool)
176 /* reset the pool for next expression */
177
178 #ifndef NDEBUG
179 /*
180 * this function zeros a termunion ptr contents. tu must not be NULL.
181 */
182 static void TermUnionInit(struct relation_term *tu)
183 {
184 memset((char *)tu,0,sizeof(union RelationTermUnion));
185 }
186 #endif
187
188 static struct {
189 long startcheck;
190 size_t len;
191 size_t cap;
192 struct relation_term **buf;
193 unsigned long *termstack;
194 unsigned long termstackcap;
195 long endcheck;
196 } g_term_ptrs = {1234567890,0,0,NULL,NULL,0,987654321};
197
198 #define TPBUF_RESET (g_term_ptrs.len=0)
199 /* forget about all the terms in the buffer */
200
201
202 /*
203 * Now one can ask why a pool and a buffer both? Couldn't one just
204 * run a big buffer? Well, yes, but how big? Growing a buffer of
205 * complete tokens can cause some system allocators to behave very
206 * poorly. Growing a vector of pointers to tokens is much less
207 * likely to cause the allocator headaches.
208 *
209 * The pool has a good growth mechanism and can handle tokens.
210 * Tradeoff: it is slower to copy the final token data into a
211 * fixed array from pool pointers than from a buffer monolith.
212 */
213 #define TPBUF_INITSIZE 1000
214 /* initial token buffer capacity */
215 #define TPBUF_GROW 1000
216 /* token buffer growth rate */
217
218 #define RP_LEN 5
219 #if (SIZEOF_VOID_P == 8)
220 #define RP_WID 41
221 #else
222 #define RP_WID 63
223 #endif
224 /* retune rpwid if the size of tokens changes dramatically */
225 #define RP_ELT_SIZE (sizeof(union RelationTermUnion))
226 #define RP_MORE_ELTS 5
227 /* Number of slots filled if more elements needed.
228 So if the pool grows, it grows by RP_MORE_ELTS*RP_WID elements at a time. */
229 #define RP_MORE_BARS 508
230 /* This is the number of pool bar slots to add during expansion.
231 not all the slots will be filled immediately. */
232
233 /* This function is called at compiler startup time and destroy at shutdown.
234 One could also recall these every time there is a delete all types. */
235 void InitRelInstantiator(void) {
236 if (g_term_pool != NULL || g_term_ptrs.buf != NULL) {
237 Asc_Panic(2, NULL, "ERROR: InitRelInstantiator called twice.\n");
238 }
239 g_term_pool =
240 pool_create_store(RP_LEN, RP_WID, RP_ELT_SIZE, RP_MORE_ELTS, RP_MORE_BARS);
241 if (g_term_pool == NULL) {
242 Asc_Panic(2, "InitRelInstantiator",
243 "ERROR: InitRelInstantiator unable to allocate pool.\n");
244 }
245 g_term_ptrs.buf = (struct relation_term **)
246 asccalloc(TPBUF_INITSIZE,sizeof(union RelationTermUnion *));
247 /* don't let the above cast fool you about what's in the array */
248 if (g_term_ptrs.buf == NULL) {
249 Asc_Panic(2, "InitRelInstantiator",
250 "ERROR: InitRelInstantiator unable to allocate memory.\n");
251 }
252 g_term_ptrs.len = 0;
253 g_term_ptrs.cap = TPBUF_INITSIZE;
254 g_term_ptrs.termstackcap = 200;
255 g_term_ptrs.termstack =
256 (unsigned long *)ascmalloc((sizeof(unsigned long)*200));
257 if (g_term_ptrs.termstack == NULL) {
258 Asc_Panic(2, "InitRelInstantiator",
259 "ERROR: InitRelInstantiator unable to allocate memory.\n");
260 }
261 }
262
263 /* this function returns NULL when newcap is 0 or when
264 * it is unable to allocate the space requested.
265 */
266 static unsigned long *realloc_term_stack(unsigned long newcap){
267 if (!newcap) {
268 if (g_term_ptrs.termstackcap !=0) {
269 ascfree(g_term_ptrs.termstack);
270 g_term_ptrs.termstack = NULL;
271 g_term_ptrs.termstackcap = 0;
272 }
273 } else {
274 if (newcap >= g_term_ptrs.termstackcap) { /*less than means currently ok */
275 unsigned long *newbuf;
276 newbuf = (unsigned long *)
277 ascrealloc(g_term_ptrs.termstack,(sizeof(unsigned long)*newcap));
278 if (newbuf!=NULL) {
279 g_term_ptrs.termstack = newbuf;
280 g_term_ptrs.termstackcap = newcap;
281 } else {
282 FPRINTF(ASCERR,"Insufficient memory in relation processor\n");
283 return NULL;
284 }
285 }
286 }
287 return g_term_ptrs.termstack;
288 }
289
290 void DestroyRelInstantiator(void) {
291 assert(g_term_ptrs.buf!=NULL);
292 assert(g_term_pool!=NULL);
293 ascfree(g_term_ptrs.buf);
294 g_term_ptrs.buf = NULL;
295 g_term_ptrs.cap = g_term_ptrs.len = (size_t)0;
296 if (g_term_ptrs.termstackcap != 0) {
297 ascfree(g_term_ptrs.termstack);
298 g_term_ptrs.termstack = NULL;
299 g_term_ptrs.termstackcap = 0;
300 }
301 pool_destroy_store(g_term_pool);
302 g_term_pool = NULL;
303 }
304
305 void ReportRelInstantiator(FILE *f)
306 {
307 assert(g_term_pool!=NULL);
308 FPRINTF(f,"RelInstantiator ");
309 pool_print_store(f,g_term_pool,0);
310 FPRINTF(f,"RelInstantiator buffer capacity: %lu\n",
311 (unsigned long)g_term_ptrs.cap);
312 }
313
314 /* The slower expansion process. */
315 static void ExpandTermBuf(struct relation_term *t) {
316 struct relation_term **newbuf;
317 newbuf = (struct relation_term **)ascrealloc(g_term_ptrs.buf,
318 (sizeof(struct relation_term *)*(g_term_ptrs.cap+TPBUF_GROW)));
319 if (newbuf!=NULL) {
320 g_term_ptrs.buf = newbuf;
321 g_term_ptrs.cap += TPBUF_GROW;
322 g_term_ptrs.buf[g_term_ptrs.len] = t;
323 g_term_ptrs.len++;
324 } else {
325 FPRINTF(ASCERR,
326 "ERROR: Relation Instantiator unable to allocate memory.\n");
327 /* we have ignored the term pointer, but somebody else still has it: pool*/
328 }
329 return;
330 }
331
332 /* Appends term to buffer. if buffer full and can't expand, forgets term.*/
333 static void AppendTermBuf(struct relation_term *t) {
334 if (g_term_ptrs.len < g_term_ptrs.cap) {
335 g_term_ptrs.buf[g_term_ptrs.len++] = t;
336 } else {
337 ExpandTermBuf(t);
338 }
339 return;
340 }
341
342 /************************************************************************\
343 functions to simplify the postfix token list before final creation
344 of the token relation array.
345 \************************************************************************/
346
347 /* returns 1 if term is e_zero, e_real=0.0, or e_int=0 */
348 static int SimplifyTBIsZero(struct relation_term *arg)
349 {
350 if (RelationTermType(arg)==e_real && R_TERM(arg)->value == 0.0) return 1;
351 if (RelationTermType(arg)==e_int && I_TERM(arg)->ivalue == 0) return 1;
352 if (RelationTermType(arg)==e_zero) return 1;
353 return 0;
354 }
355
356 #ifdef THIS_IS_AN_UNUSED_FUNCTION
357 /* check a termtype, t, for scalarness. return 1 if so, 0 otherwise. */
358 static int SimplifyTBIsScalar(enum Expr_enum t)
359 {
360 return (t <= TOK_SCALAR_HIGH && t >= TOK_SCALAR_LOW);
361 }
362 #endif /* THIS_IS_AN_UNUSED_FUNCTION */
363
364
365 /* check a termtype, t, for constantness, return 1 if so, 0 otherwise. */
366 static int SimplifyTBIsConstant(enum Expr_enum t)
367 {
368 return (t <= TOK_CONSTANT_HIGH && t >= TOK_CONSTANT_LOW);
369 }
370
371 #define ZEROTERM(rtp) SimplifyTBIsZero(rtp)
372 /* check a term pointer, rtp, for scalarness */
373 #define SCALARTERM(t) SimplifyTBIsScalar(t)
374 /* check a termtype, t, for scalarness */
375 #define CONSTANTTERM(t) SimplifyTBIsConstant(t)
376 /* check a termtype, t, for constantness */
377
378 /*
379 * Attempt to simplify unary functions.
380 * Returns 1 if arg is not constant.
381 * Returns 0 if succeeded, in which case *fn is now morphed to a constant term.
382 * Returns -1 if arg value/dimens are inconsistent with function fn.
383 * Constant arg with numeric value 0 and wild/no dim are coerced quietly
384 * where applicable.
385 *
386 * Cost: O(1).
387 */
388 static int SimplifyTermBuf_Func(struct relation_term *arg,
389 struct relation_term *fn)
390 {
391 CONST dim_type *newdim=NULL;
392 double rval;
393 /* zero constants */
394 if (ZEROTERM(arg)) {
395 switch(FuncId(F_TERM(fn)->fptr)) {
396 case F_LN:
397 case F_LOG10:
398 case F_ARCCOSH:
399 /* illegal argument. caller will whine. */
400 return -1;
401 case F_EXP:
402 case F_COSH:
403 if (IsWild(TermDimensions(arg)) ||
404 SameDimen(TermDimensions(arg),Dimensionless())) {
405 arg->t = e_nop;
406 fn->t = e_int;
407 I_TERM(fn)->ivalue = 1;
408 return 0;
409 } else {
410 return -1; /* dimensional incompatibility */
411 }
412 case F_COS:
413 if (IsWild(TermDimensions(arg)) ||
414 SameDimen(TermDimensions(arg),TrigDimension())) {
415 arg->t = e_nop;
416 fn->t = e_int;
417 I_TERM(fn)->ivalue = 1;
418 return 0;
419 } else {
420 return -1; /* dimensional incompatibility */
421 }
422 case F_SIN:
423 case F_TAN:
424 if (IsWild(TermDimensions(arg)) ||
425 SameDimen(TermDimensions(arg),TrigDimension())) {
426 arg->t = e_nop;
427 fn->t = e_int;
428 I_TERM(fn)->ivalue = 0;
429 return 0;
430 } else {
431 return -1; /* dimensional incompatibility */
432 }
433 #ifdef HAVE_ERF
434 case F_ERF:
435 #endif
436 case F_SINH:
437 case F_ARCSINH:
438 case F_TANH:
439 case F_ARCTANH:
440 if (IsWild(TermDimensions(arg)) ||
441 SameDimen(TermDimensions(arg),Dimensionless())) {
442 arg->t = e_nop;
443 fn->t = e_int;
444 I_TERM(fn)->ivalue = 0; /* dimensionless integer 0 */
445 return 0;
446 } else {
447 return -1; /* dimensional incompatibility */
448 }
449 case F_CUBE:
450 {
451 newdim = CubeDimension(TermDimensions(arg),1);
452 if (newdim != NULL) {
453 arg->t = e_nop;
454 fn->t = e_real;
455 R_TERM(fn)->value = 0.0;
456 R_TERM(fn)->dimensions = newdim;
457 return 0;
458 } else {
459 return -1; /* dimensional incompatibility */
460 }
461 }
462 case F_CBRT:
463 {
464 newdim = ThirdDimension(TermDimensions(arg),1);
465 if (newdim != NULL) {
466 arg->t = e_nop;
467 fn->t = e_real;
468 R_TERM(fn)->value = 0.0;
469 R_TERM(fn)->dimensions = newdim;
470 return 0;
471 } else {
472 return -1; /* dimensional incompatibility */
473 }
474 }
475 case F_SQR:
476 {
477 newdim = SquareDimension(TermDimensions(arg),1);
478 if (newdim != NULL) {
479 arg->t = e_nop;
480 fn->t = e_real;
481 R_TERM(fn)->value = 0.0;
482 R_TERM(fn)->dimensions = newdim;
483 return 0;
484 } else {
485 return -1; /* dimensional incompatibility */
486 }
487 }
488 case F_SQRT:
489 {
490 newdim = HalfDimension(TermDimensions(arg),1);
491 if (newdim != NULL) {
492 arg->t = e_nop;
493 fn->t = e_real;
494 R_TERM(fn)->value = 0.0;
495 R_TERM(fn)->dimensions = newdim;
496 return 0;
497 } else {
498 return -1; /* dimensional incompatibility */
499 }
500 }
501 case F_ARCSIN:
502 case F_ARCTAN:
503 if (IsWild(TermDimensions(arg)) ||
504 SameDimen(TermDimensions(arg),Dimensionless())) {
505 arg->t = e_nop;
506 fn->t = e_real;
507 R_TERM(fn)->value = 0.0;
508 R_TERM(fn)->dimensions = TrigDimension();
509 return 0;
510 } else {
511 return -1; /* dimensional incompatibility */
512 }
513 case F_ARCCOS:
514 if (IsWild(TermDimensions(arg)) ||
515 SameDimen(TermDimensions(arg),Dimensionless())) {
516 arg->t = e_nop;
517 fn->t = e_real;
518 R_TERM(fn)->value = F_PI_HALF;
519 R_TERM(fn)->dimensions = TrigDimension();
520 return 0;
521 } else {
522 return -1; /* dimensional incompatibility */
523 }
524 case F_ABS:
525 case F_HOLD:
526 {
527 newdim = TermDimensions(arg);
528 if (newdim != NULL) {
529 arg->t = e_nop;
530 fn->t = e_real;
531 R_TERM(fn)->value = 0.0;
532 R_TERM(fn)->dimensions = newdim;
533 return 0;
534 } else {
535 return -1; /* dimensional insanity */
536 }
537 }
538 case F_LNM:
539 return 1; /* user could change lnm epsilon. can't simplify. */
540 default:
541 FPRINTF(ASCERR,"Unrecognized function in relation.\n");
542 return 1;
543 }
544 }
545 /* nonzero int or real */
546 if( (arg->t == e_int) || (arg->t == e_real) ) {
547 newdim = NULL;
548 if (arg->t == e_int) {
549 rval = (double)I_TERM(arg)->ivalue;
550 } else {
551 rval = R_TERM(arg)->value;
552 }
553 switch(FuncId(F_TERM(fn)->fptr)) {
554 /* things that take any trig arg, return dimensionless */
555 case F_SIN:
556 case F_COS:
557 case F_TAN:
558 if (IsWild(TermDimensions(arg)) ||
559 SameDimen(TermDimensions(arg),TrigDimension())) {
560 newdim = Dimensionless();
561 } else {
562 return -1; /* dimensional incompatibility */
563 }
564 break; /* go to fixup */
565 /* things that require arg >= 1, return dimless */
566 case F_ARCCOSH:
567 if( rval < 1.0 ) return -1;
568 /* fall through */
569 case F_LN:
570 case F_LOG10:
571 if( rval < 0.0 ) return -1;
572 if (IsWild(TermDimensions(arg)) ||
573 SameDimen(TermDimensions(arg),Dimensionless())) {
574 newdim = Dimensionless();
575 } else {
576 return -1; /* dimensional incompatibility */
577 }
578 break; /* go to fixup */
579 /* things that take any exponentiable arg, return dimensionless */
580 case F_EXP:
581 case F_SINH:
582 case F_COSH:
583 if (fabs(rval) > F_LIM_EXP) return -1;
584 /* fall through */
585 /* things that take any arg, return dimensionless */
586 case F_ARCSINH:
587 case F_TANH:
588 #ifdef HAVE_ERG
589 case F_ERF:
590 #endif
591 if (IsWild(TermDimensions(arg)) ||
592 SameDimen(TermDimensions(arg),Dimensionless())) {
593 newdim = Dimensionless();
594 } else {
595 return -1; /* dimensional incompatibility */
596 }
597 break;
598 case F_ARCTANH:
599 /* things that take any arg abs <1, return dimensionless */
600 if (fabs(rval) < 1.0 && (IsWild(TermDimensions(arg)) ||
601 SameDimen(TermDimensions(arg),Dimensionless()))) {
602 newdim = Dimensionless();
603 } else {
604 return -1; /* dimensional incompatibility or range */
605 }
606 break;
607 case F_CUBE:
608 {
609 newdim = CubeDimension(TermDimensions(arg),1);
610 if (newdim == NULL || fabs(rval) > F_LIM_CUBE) {
611 return -1; /* dimensional incompatibility */
612 }
613 }
614 break;
615 case F_CBRT:
616 {
617 newdim = ThirdDimension(TermDimensions(arg),1);
618 if (newdim == NULL) {
619 return -1; /* dimensional incompatibility , range*/
620 }
621 break;
622 }
623 case F_SQR:
624 {
625 newdim = SquareDimension(TermDimensions(arg),1);
626 if (newdim == NULL || fabs(rval) > F_LIM_SQR) {
627 return -1; /* dimensional incompatibility , range*/
628 }
629 break;
630 }
631 case F_SQRT:
632 {
633 newdim = HalfDimension(TermDimensions(arg),1);
634 if (newdim == NULL || rval < 0.0) {
635 return -1; /* dimensional incompatibility or range */
636 }
637 break;
638 }
639 /* things that take any trig arg, return dimensionless */
640 case F_ARCSIN:
641 case F_ARCCOS:
642 if ( fabs(rval) <= 1.0 && (IsWild(TermDimensions(arg)) ||
643 SameDimen(TermDimensions(arg),Dimensionless()))) {
644 newdim = TrigDimension();
645 break;
646 } else {
647 return -1; /* dimensional incompatibility */
648 }
649 case F_ARCTAN:
650 if (IsWild(TermDimensions(arg)) ||
651 SameDimen(TermDimensions(arg),Dimensionless())) {
652 newdim = TrigDimension();
653 break;
654 } else {
655 return -1; /* dimensional incompatibility */
656 }
657 case F_ABS:
658 case F_HOLD:
659 newdim = TermDimensions(arg);
660 break;
661 case F_LNM:
662 return 1; /* user could change lnm epsilon. can't simplify. */
663 default:
664 FPRINTF(ASCERR,"Unrecognized function in relation.\n");
665 return 1;
666 }
667 rval = FuncEval(TermFunc(A_TERM(fn)),rval);
668 if (floor(rval)==ceil(rval) && SameDimen(newdim,Dimensionless()) &&
669 fabs(rval) < MAXINTREAL) {
670 fn->t = e_int;
671 I_TERM(fn)->ivalue = (long)floor(rval);
672 } else {
673 fn->t = e_real;
674 R_TERM(fn)->value = rval;
675 R_TERM(fn)->dimensions = newdim;
676 }
677 return 0;
678 }
679 return 1;
680 }
681
682 static int ArgsForToken(enum Expr_enum t) {
683 switch (t) {
684 case e_nop:
685 case e_undefined:
686 case e_glassbox:
687 case e_blackbox:
688 case e_opcode:
689 case e_token:
690 case e_zero:
691 case e_real:
692 case e_int:
693 case e_var:
694 return 0;
695 case e_uminus:
696 case e_func:
697 return 1;
698 case e_plus:
699 case e_minus:
700 case e_times:
701 case e_divide:
702 case e_power:
703 case e_ipower:
704 case e_notequal:
705 case e_equal:
706 case e_less:
707 case e_greater:
708 case e_lesseq:
709 case e_greatereq:
710 return 2;
711 case e_maximize:
712 case e_minimize:
713 return 1;
714 default:
715 FPRINTF(ASCERR,"ArgsForToken called with illegal token type.\n");
716 return -1;
717 }
718 }
719
720 /*
721 * first = SimplifyTermBuf_SubExprLimit(ts,b,start,tt)
722 * unsigned long CONST *ts; current term stack
723 * struct relation_term ** CONST b; global term ptr array
724 * unsigned long start; starting index IN STACK ts to find needed args
725 * enum Expr_enum tt; term type of operator you want the subexpr for
726 * long int first; term stack position of rightmost arg outside subexpr
727 *
728 * A little function to find the extent of a postfix subexpression for
729 * the args of an operator term in the termstack/termbuf processing.
730 * Returns -2 if insanity detected. handles nonoperator tt gracefully (-2).
731 *
732 * e.g. cos(v1+v2) * v3
733 * tt = e_times, ts =>
734 * | V1 | V2 | + | cos | V3 | * |
735 * ^--------start = 3
736 * ^--------first = -1
737 *
738 * e.g. v1 * (v2 + v3)
739 * tt = e_plus, ts =>
740 * | V1 | V2 | V3 | + | * |
741 * ^--------start = 2
742 * ^--------first = 0
743 *
744 * O(n) n= subexpr length.
745 */
746 static long
747 SimplifyTermBuf_SubExprLimit(unsigned long CONST *ts,
748 struct relation_term ** CONST buf,
749 unsigned long start,
750 enum Expr_enum tt)
751 {
752 long int first, req_args;
753
754 first = start;
755 req_args = ArgsForToken(tt);
756 if (first < 0) {
757 FPRINTF(ASCERR,"SimplifyTermBuf_SubExpr given malformed subexpression.\n");
758 }
759
760 while (first >= 0 && req_args >0) {
761 switch(buf[ts[first]]->t) {
762 case e_zero:
763 case e_real:
764 case e_int:
765 case e_var:
766 req_args--;
767 break;
768 case e_plus:
769 case e_minus:
770 case e_times:
771 case e_divide:
772 case e_power:
773 case e_ipower:
774 req_args++;
775 break;
776 case e_func:
777 case e_uminus:
778 break;
779 default:
780 FPRINTF(ASCERR,
781 "SimplifyTermBuf_SubExpr found illegal argument type (%d).\n",
782 buf[ts[first]]->t);
783 return -2;
784 }
785 first--;
786 }
787 if (first < -1) {
788 FPRINTF(ASCERR,"SimplifyTermBuf_SubExpr found malformed subexpression.\n");
789 }
790 return first;
791 }
792
793 #ifndef NDEBUG
794 /* some functions to keep assert happy when simplification is in debug */
795 static int check_gt0(unsigned long i) {
796 assert(i);
797 return 1;
798 }
799 static int check_gt1(unsigned long i) {
800 assert(i>1);
801 return 1;
802 }
803 #endif
804
805 /*
806 * A function to simplify the term buffer before copying it into a
807 * postfix array. Only mandatory dim checking is performed.
808 * Cost: O(n) where n = blen.
809 *
810 * This function is rather large, but simply structured, because speed
811 * is important.
812 * This is postfix simplification on the cheap. It could be more aggressive,
813 * but only at potentially quadratic expense.
814 *
815 * int level;
816 * struct relation_term ** CONST b;
817 * CONST unsigned long blen;
818 * They are the original term buffer array and its starting length.
819 * b stays constant, not the data in it!
820 *
821 * (the following level definitions are mostly vapor. see relation.h for true.
822 * level is how far to go in simplification. it is cumulative.
823 * level 0 = do nothing.
824 * level 1 = constant folding
825 * level 2 = zero reductions. A*0 = 0/A =0. A^0=1;
826 * level 3 = converting division by constants into multiplication
827 * level 4 = distributing constants over simple mult. (V*C2)*C1 --> V*C3
828 *
829 * As a side effect, any e_power term that can be resolved to having
830 * an integer exponent is converted to an e_ipower.
831 *
832 * This function is designed to simplifications wrt constants that
833 * are easy to do in postfix. If you want something more clever, you
834 * need to dress up things in infix, simplify, and put back to postfix.
835 * Better you than me, bud.
836 *
837 * At present level > 1 is ignored; we always do 1-3, never 4.
838 *
839 * All this goes on in the termbuf array leaving null pointers behind.
840 * We will compact the array and adjust the length before leaving this
841 * function, so you don't have to care about len changing.
842 * The termbuf pointers are from the pool, so we do not free them
843 * as terms are eliminated.
844 *
845 * Internal doc:
846 * Because C optimizers are pretty damned good, we aren't going to
847 * play pointer games, we will just play subscript of b games.
848 * Note that in flight we create null pointers in the already
849 * visited buffer, but we always have an argument immediately
850 * to the left (b[i-1]) of operator b[i]. If b[i] binary, its
851 * right arg is b[i-1] and its left arg is the first nonnull
852 * entry b[j] to the left of b[i-1] (j<i-1).
853 *
854 * The buffer is in postfix. We have no infix to maintain yet.
855 * Abbreviations in comments:
856 * U - unary operator
857 * B - binary operator
858 * P - any operator
859 * V - e_var arg
860 * A - any arg
861 * C - any constant arg (e_int, e_real)
862 * R - e_real arg
863 * I - e_int arg
864 * N - null pointer
865 * While in flight:
866 | A | A | A | A | A | A | A | termbuf
867 * ^------- top = rightmost we've considered (current).
868 | S | S | S | 0 |
869 * ^----next = next free location to put an index in termstack
870 */
871 static unsigned long SimplifyTermBuf(int level,
872 register struct relation_term ** CONST b,
873 CONST unsigned long blen)
874 {
875 register unsigned long next;
876 register unsigned long *ts; /* term stack, should we need it */
877 unsigned long top;
878 long last;
879 unsigned long right;
880 int early = 0, err;
881 CONST dim_type *newdim;
882 long ival;
883 double rval;
884
885 if ( level < 1 || !blen ) {
886 realloc_term_stack(0);
887 return blen;
888 }
889 ts = realloc_term_stack(blen);
890 /* stack gets used a lot, so make him locally managed, reusable mem */
891 if (ts==NULL) return blen;
892 /* at any trip through this loop we must be able to guarantee
893 * some simple change, or that the buffer is suitable for
894 * cleanup and return, so that we can handle the rogue operators,
895 * args cleanly.
896 */
897 /* check that stack doesn't start with operator */
898 /* should check that stack doesn't start pos 1 with binary operator */
899 switch (b[0]->t) {
900 case e_var:
901 case e_int:
902 case e_real:
903 case e_zero:
904 break;
905 default:
906 FPRINTF(ASCERR,"Compiler cannot simplify malformed expression\n");
907 return blen;
908 }
909
910 #ifdef NDEBUG
911 # define TS_TOP (ts[next-1]) /* term address last pushed */
912 # define TS_LEFT (ts[next-2])
913 /* left hand term address IFF current term is binary and the term at TS_TOP is scalar (not operator) */
914 # define TS_SHIFTPOP ts[next-2] = ts[next-1]; next-- /* overwrite ts_left with ts_top and pop */
915 #else
916 # define TS_TOP (check_gt0(next),ts[next-1]) /* term address last pushed */
917 # define TS_LEFT (check_gt1(next),ts[next-2]) /* left hand term address IFF current term is binary and the term at TS_TOP is scalar (not operator) */
918 # define TS_SHIFTPOP assert(next>1); ts[next-2] = ts[next-1]; next-- /* overwrite ts_left with ts_top and pop */
919 #endif
920 /* keep the above definitions in sync. only difference should be assert. */
921
922 #define TS_PUSH(index) ts[next]=(index); next++ /* add a term to the stack */
923 #define TS_POP next-- /* backup the stack */
924 #define TS_POP2 next -= 2 /* backup the stack 2 spots */
925
926 for (next=top=0; top < blen; top++) {
927 /* pass through the tokens pointers array */
928 if (b[top]==NULL) continue; /* so we can go through again if we like */
929 /* each case and nested case should be complete in itself for
930 readability. do not use fall throughs */
931 switch (b[top]->t) {
932 case e_var:
933 case e_int:
934 case e_real:
935 case e_zero:
936 TS_PUSH(top);
937 break;
938 case e_nop:
939 b[top] = NULL; /* forget nop */
940 break;
941 case e_func:
942 if ( CONSTANTTERM(b[TS_TOP]->t) ) {
943 /* C U -> C' */
944 if ( (err = SimplifyTermBuf_Func(b[TS_TOP],b[top]) ) != 0 ) {
945 /* not simplified. just push later. whine if needed. */
946 if (err < 0) {
947 FPRINTF(ASCERR,
948 "Can't simplify inconsistent argument to unary function.\n");
949 }
950 } else {
951 b[TS_TOP] = NULL; /* kill old arg, func term was morphed. */
952 TS_POP; /* set up to push morphed func in place of arg */
953 }
954 }
955 TS_PUSH(top); /* for all cases in the ifs */
956 break;
957 case e_uminus:
958 switch (b[TS_TOP]->t) {
959 case e_int:
960 I_TERM(b[TS_TOP])->ivalue = -(I_TERM(b[TS_TOP])->ivalue);
961 b[top] = b[TS_TOP]; /* I - => -I */
962 b[TS_TOP] = NULL;
963 TS_POP;
964 TS_PUSH(top);
965 break;
966 case e_real:
967 R_TERM(b[TS_TOP])->value = -(R_TERM(b[TS_TOP])->value);
968 b[top] = b[TS_TOP]; /* R - => -R */
969 b[TS_TOP] = NULL;
970 TS_POP;
971 TS_PUSH(top);
972 break;
973 case e_zero:
974 b[top] = b[TS_TOP]; /* -0 = 0 */
975 b[TS_TOP] = NULL;
976 TS_POP;
977 TS_PUSH(top);
978 break;
979 default: /* aren't going to distribute or do other funky things */
980 TS_PUSH(top);
981 break;
982 }
983 break;
984
985 case e_plus:
986 /* A 0 + => NULL NULL A */
987 if ( ZEROTERM(b[TS_TOP]) ) {
988 /*
989 * Note: we really should be checking the dimens of A to match
990 * with dimens of 0 if e_real, but we are can't yet.
991 */
992 b[top] = b[TS_LEFT]; /* overwrite the + with the A */
993 b[TS_LEFT] = NULL; /* null the A old location */
994 b[TS_TOP] = NULL; /* null old location of 0 */
995 TS_POP2;
996 TS_PUSH(top);
997 break;
998 }
999 switch (b[TS_TOP]->t) {
1000 case e_var:
1001 if ( ZEROTERM(b[TS_LEFT]) ) {
1002 /* 0 V + => NULL NULL V */
1003 /*
1004 * Note: we really should be checking the dimens of V to match
1005 * with dimens of 0 if e_real, but we are don't yet.
1006 */
1007 b[TS_LEFT] = NULL; /* null the zero term */
1008 b[top] = b[TS_TOP]; /* overwrite the + with the V */
1009 b[TS_TOP] = NULL; /* null old location of V */
1010 TS_POP2;
1011 TS_PUSH(top);
1012 } else {
1013 TS_PUSH(top);
1014 }
1015 break;
1016 /* 2 constant args? mangle C1 C2 + => C3 of appropriate type,if ok. */
1017 case e_int: /* 0 I +, R I +, I I + */
1018 if ( CONSTANTTERM(b[TS_LEFT]->t) ) {
1019 /* 2 constant args. mangle C2 I1 + => C3 of appropriate type,if ok.*/
1020 if (b[TS_LEFT]->t==e_zero) { /* 0 I + */
1021 b[top] = b[TS_TOP]; /* overwrite the + with the I */
1022 b[TS_LEFT] = NULL; /* null the 0 old location */
1023 b[TS_TOP] = NULL; /* null old location of I */
1024 TS_POP2;
1025 TS_PUSH(top);
1026 break;
1027 }
1028 if (b[TS_LEFT]->t == e_int) { /* I2 I1 + */
1029 I_TERM(b[TS_TOP])->ivalue += I_TERM(b[TS_LEFT])->ivalue;
1030 b[top] = b[TS_TOP]; /* overwrite the + with the I1' */
1031 b[TS_LEFT] = NULL; /* null the I2 old location */
1032 b[TS_TOP] = NULL; /* null old location of I1 */
1033 TS_POP2;
1034 TS_PUSH(top);
1035 break;
1036 }
1037 if ( b[TS_LEFT]->t==e_real &&
1038 ( SameDimen(R_TERM(b[TS_LEFT])->dimensions,Dimensionless()) ||
1039 (IsWild(R_TERM(b[TS_LEFT])->dimensions) &&
1040 R_TERM(b[TS_LEFT])->value == 0.0)
1041 )
1042 ) { /* Ri2(possibly wild 0.0) I1 + => I1' */
1043 if (floor(R_TERM(b[TS_LEFT])->value) ==
1044 ceil(R_TERM(b[TS_LEFT])->value) &&
1045 fabs(R_TERM(b[TS_LEFT])->value) < MAXINTREAL) {
1046 I_TERM(b[TS_TOP])->ivalue +=
1047 (long)floor(R_TERM(b[TS_LEFT])->value);
1048 b[top] = b[TS_TOP]; /* overwrite the + with the I1' */
1049 b[TS_LEFT] = NULL; /* null the R2 old location */
1050 b[TS_TOP] = NULL; /* null old location of I1 */
1051 TS_POP2;
1052 TS_PUSH(top);
1053 break;
1054 } else { /* morph + to R' */
1055 b[top]->t = e_real;
1056 R_TERM(b[top])->dimensions = Dimensionless();
1057 R_TERM(b[top])->value =
1058 R_TERM(b[TS_LEFT])->value + (double)I_TERM(b[TS_TOP])->ivalue;
1059 b[TS_LEFT] = NULL; /* null the R2 old location */
1060 b[TS_TOP] = NULL; /* null old location of I1 */
1061 TS_POP2;
1062 TS_PUSH(top);
1063 break;
1064 }
1065 } else { /* dimensional conflict can't be fixed */
1066 FPRINTF(ASCERR,
1067 "Can't simplify dimensionally inconsistent arguments to +.\n");
1068 TS_PUSH(top);
1069 }
1070 break;
1071 } else { /* non C TS_LEFT */
1072 TS_PUSH(top);
1073 }
1074 break;
1075 case e_real: /* 0 R +, R R +, I R + */
1076 if ( CONSTANTTERM(b[TS_LEFT]->t) ) {
1077 /* 2 constant args. mangle C2 R1 + => C3 of appropriate type,if ok.*/
1078 newdim = CheckDimensionsMatch(TermDimensions(b[TS_TOP]),
1079 TermDimensions(b[TS_LEFT]));
1080 if (newdim == NULL) {
1081 FPRINTF(ASCERR,
1082 "Can't simplify dimensionally inconsistent arguments to +.\n");
1083 TS_PUSH(top);
1084 break;
1085 }
1086 if (b[TS_LEFT]->t==e_zero) { /* 0 R + */
1087 b[top] = b[TS_TOP]; /* overwrite the + with the R */
1088 b[TS_LEFT] = NULL; /* null the 0 old location */
1089 b[TS_TOP] = NULL; /* null old location of R */
1090 TS_POP2;
1091 TS_PUSH(top);
1092 /* if R was wild, it stays wild */
1093 break;
1094 }
1095 if (b[TS_LEFT]->t == e_int) { /* I2 R1 + */
1096 R_TERM(b[TS_TOP])->value += (double)I_TERM(b[TS_LEFT])->ivalue;
1097 R_TERM(b[TS_TOP])->dimensions = newdim;
1098 b[top] = b[TS_TOP]; /* overwrite the + with the R1' */
1099 b[TS_LEFT] = NULL; /* null the I2 old location */
1100 b[TS_TOP] = NULL; /* null old location of R1 */
1101 TS_POP2;
1102 TS_PUSH(top);
1103 /* if R wild, R becomes dimensionless */
1104 break;
1105 }
1106 if ( b[TS_LEFT]->t==e_real ) { /* R2 R1 + => R1', if R1' whole->I1'*/
1107 b[top]->t = e_real;
1108 R_TERM(b[top])->dimensions = newdim;
1109 R_TERM(b[top])->value =
1110 R_TERM(b[TS_LEFT])->value + R_TERM(b[TS_TOP])->value;
1111 b[TS_LEFT] = NULL; /* null the R2 old location */
1112 b[TS_TOP] = NULL; /* null old location of R1 */
1113 TS_POP2;
1114 TS_PUSH(top);
1115 /* if integer valued dimless real, convert to int */
1116 if (floor(R_TERM(b[top])->value) == ceil(R_TERM(b[top])->value)
1117 && SameDimen(R_TERM(b[top])->dimensions,Dimensionless()) &&
1118 fabs(R_TERM(b[top])->value) < MAXINTREAL) {
1119 I_TERM(b[top])->ivalue = (long)R_TERM(b[top])->value;
1120 b[top]->t = e_int;
1121 }
1122 break;
1123 } else { /* dimensional conflict can't be fixed */
1124 FPRINTF(ASCERR,
1125 "Can't simplify dimensionally inconsistent arguments to +.\n");
1126 TS_PUSH(top);
1127 }
1128 break;
1129 } else { /* non C TS_LEFT */
1130 TS_PUSH(top);
1131 }
1132 break; /* end eplus, right arg is e_real */
1133 default: /* tstop is not 0, R, I, V */
1134 TS_PUSH(top);
1135 break;
1136 } /* end argtype switch of e_plus */
1137 break;
1138
1139 case e_minus:
1140 /* A 0 - => NULL NULL A */
1141 if ( ZEROTERM(b[TS_TOP]) ) {
1142 /*
1143 * Note: we really should be checking the dimens of A to match
1144 * with dimens of 0 if e_real, but we are can't yet.
1145 */
1146 b[top] = b[TS_LEFT]; /* overwrite the - with the A */
1147 b[TS_LEFT] = NULL; /* null the A old location */
1148 b[TS_TOP] = NULL; /* null old location of 0 */
1149 TS_POP2;
1150 TS_PUSH(top);
1151 break;
1152 }
1153 switch (b[TS_TOP]->t) {
1154 case e_var:
1155 if ( ZEROTERM(b[TS_LEFT]) ) {
1156 /* 0 V - => NULL V uminus */
1157 /*
1158 * Note: we really should be checking the dimens of V to match
1159 * with dimens of 0 if e_real, but we are don't yet.
1160 */
1161 b[TS_LEFT] = NULL; /* null the zero term */
1162 b[top]->t = e_uminus; /* morph - to uminus */
1163 TS_SHIFTPOP; /* reduce 0 V => V */
1164 TS_PUSH(top);
1165 } else {
1166 TS_PUSH(top);
1167 }
1168 break;
1169 /* 2 constant args? mangle C1 C2 - => C3 of appropriate type,if ok. */
1170 case e_int: /* 0 I -, R I -, I I - */
1171 if ( CONSTANTTERM(b[TS_LEFT]->t) ) {
1172 /* 2 constant args. mangle C2 I1 - => C3 of appropriate type,if ok.*/
1173 if (b[TS_LEFT]->t==e_zero) { /* 0 I - */
1174 b[top] = b[TS_TOP]; /* overwrite the - with -I */
1175 I_TERM(b[top])->ivalue = -(I_TERM(b[top])->ivalue);
1176 b[TS_LEFT] = NULL; /* null the 0 old location */
1177 b[TS_TOP] = NULL; /* null old location of I */
1178 TS_POP2;
1179 TS_PUSH(top);
1180 break;
1181 }
1182 if (b[TS_LEFT]->t == e_int) { /* I2 I1 - */
1183 I_TERM(b[TS_TOP])->ivalue =
1184 I_TERM(b[TS_LEFT])->ivalue - I_TERM(b[TS_TOP])->ivalue;
1185 b[top] = b[TS_TOP]; /* overwrite the - with the I1' */
1186 b[TS_LEFT] = NULL; /* null the I2 old location */
1187 b[TS_TOP] = NULL; /* null old location of I1 */
1188 TS_POP2;
1189 TS_PUSH(top);
1190 break;
1191 }
1192 if ( b[TS_LEFT]->t==e_real &&
1193 ( SameDimen(R_TERM(b[TS_LEFT])->dimensions,Dimensionless()) ||
1194 (IsWild(R_TERM(b[TS_LEFT])->dimensions) &&
1195 R_TERM(b[TS_LEFT])->value == 0.0)
1196 )
1197 ) { /* Ri2(possibly wild 0.0) I1 - => I1' */
1198 if (floor(R_TERM(b[TS_LEFT])->value) ==
1199 ceil(R_TERM(b[TS_LEFT])->value) &&
1200 fabs(R_TERM(b[TS_LEFT])->value) < MAXINTREAL) {
1201 I_TERM(b[TS_TOP])->ivalue =
1202 (long)floor(R_TERM(b[TS_LEFT])->value)
1203 - I_TERM(b[TS_TOP])->ivalue;
1204 b[top] = b[TS_TOP]; /* overwrite the + with the I1' */
1205 b[TS_LEFT] = NULL; /* null the R2 old location */
1206 b[TS_TOP] = NULL; /* null old location of I1 */
1207 TS_POP2;
1208 TS_PUSH(top);
1209 break;
1210 } else { /* morph - to R' */
1211 b[top]->t = e_real;
1212 R_TERM(b[top])->dimensions = Dimensionless();
1213 R_TERM(b[top])->value =
1214 R_TERM(b[TS_LEFT])->value - (double)I_TERM(b[TS_TOP])->ivalue;
1215 b[TS_LEFT] = NULL; /* null the R2 old location */
1216 b[TS_TOP] = NULL; /* null old location of I1 */
1217 TS_POP2;
1218 TS_PUSH(top);
1219 break;
1220 }
1221 } else { /* dimensional conflict can't be fixed */
1222 FPRINTF(ASCERR,
1223 "Can't simplify dimensionally inconsistent arguments to -.\n");
1224 TS_PUSH(top);
1225 }
1226 break;
1227 } else { /* non C TS_LEFT */
1228 TS_PUSH(top);
1229 }
1230 break;
1231
1232 case e_real: /* 0 R -, R R -, I R - */
1233 if ( CONSTANTTERM(b[TS_LEFT]->t) ) {
1234 /* 2 constant args. mangle C2 R1 - => C3 of appropriate type,if ok.*/
1235 newdim = CheckDimensionsMatch(TermDimensions(b[TS_TOP]),
1236 TermDimensions(b[TS_LEFT]));
1237 if (newdim == NULL) {
1238 FPRINTF(ASCERR,
1239 "Can't simplify dimensionally inconsistent arguments to -.\n");
1240 TS_PUSH(top);
1241 break;
1242 }
1243 if (b[TS_LEFT]->t==e_zero) { /* 0 R - */
1244 b[top] = b[TS_TOP]; /* overwrite the - with the R */
1245 R_TERM(b[top])->value = -(R_TERM(b[top])->value);
1246 b[TS_LEFT] = NULL; /* null the 0 old location */
1247 b[TS_TOP] = NULL; /* null old location of R */
1248 TS_POP2;
1249 TS_PUSH(top);
1250 /* if R was wild, it stays wild */
1251 break;
1252 }
1253 if (b[TS_LEFT]->t == e_int) { /* I2 R1 - */
1254 R_TERM(b[TS_TOP])->value =
1255 (double)I_TERM(b[TS_LEFT])->ivalue - R_TERM(b[TS_TOP])->value;
1256 R_TERM(b[TS_TOP])->dimensions = newdim;
1257 b[top] = b[TS_TOP]; /* overwrite the - with the R1' */
1258 b[TS_LEFT] = NULL; /* null the I2 old location */
1259 b[TS_TOP] = NULL; /* null old location of R1 */
1260 TS_POP2;
1261 TS_PUSH(top);
1262 /* if R wild, R becomes dimensionless */
1263 break;
1264 }
1265 if ( b[TS_LEFT]->t==e_real ) { /* R2 R1 - => R1', if R1' whole->I1'*/
1266 b[top]->t = e_real; /* morph - to R */
1267 R_TERM(b[top])->dimensions = newdim;
1268 R_TERM(b[top])->value =
1269 R_TERM(b[TS_LEFT])->value - R_TERM(b[TS_TOP])->value;
1270 b[TS_LEFT] = NULL; /* null the R2 old location */
1271 b[TS_TOP] = NULL; /* null old location of R1 */
1272 TS_POP2;
1273 TS_PUSH(top);
1274 /* if integer valued dimless real, convert to int */
1275 if (floor(R_TERM(b[top])->value) == ceil(R_TERM(b[top])->value)
1276 && SameDimen(R_TERM(b[top])->dimensions,Dimensionless())
1277 && fabs(R_TERM(b[top])->value) < MAXINTREAL) {
1278 I_TERM(b[top])->ivalue = (long)R_TERM(b[top])->value;
1279 b[top]->t = e_int;
1280 }
1281 break;
1282 } else { /* dimensional conflict can't be fixed */
1283 FPRINTF(ASCERR,
1284 "Can't simplify dimensionally inconsistent arguments to -.\n");
1285 TS_PUSH(top);
1286 }
1287 break;
1288 } else { /* non C TS_LEFT */
1289 TS_PUSH(top);
1290 }
1291 break; /* end eminus, right arg is e_real */
1292 default: /* tstop is not 0, R, I, V */
1293 TS_PUSH(top);
1294 break;
1295 } /* end argtype switch of e_minus */
1296 break;
1297
1298 case e_times:
1299 /* needs completing. only C*C done at present. need A*0 reductions */
1300 if ( !CONSTANTTERM(b[TS_LEFT]->t) && !CONSTANTTERM(b[TS_TOP]->t) ) {
1301 /* no constants in sight, go on fast. */
1302 TS_PUSH(top);
1303 break;
1304 } else {
1305 /* some constants in sight, try things. */
1306 if (b[TS_LEFT]->t == e_zero || b[TS_TOP]->t == e_zero) {
1307 /* end of A 0 * and 0 A * => 0 */
1308 ival = SimplifyTermBuf_SubExprLimit(ts,b,next-1,e_times);
1309 if ( ival > -2 ) {
1310 for (last = next-1; last > ival; last--) {
1311 b[ts[last]] = NULL; /* kill the subexpression tokens */
1312 }
1313 next = ival + 1; /* big stack pop */
1314 b[top]->t = e_zero;
1315 R_TERM(b[top])->dimensions = WildDimension();
1316 R_TERM(b[top])->value = 0.0;
1317 TS_PUSH(top);
1318 break;
1319 } else {
1320 /* we had an error in subexpression limit search */
1321 TS_PUSH(top);
1322 break;
1323 }
1324 } /* end of A 0 * and 0 A * */
1325 /* NOTE: here we should be watching for 0.0 e_real and 0 e_int,
1326 * but as yet we don't have the dimen derivation utility to
1327 * check these cases and derive a properly dimensioned e_real 0.
1328 * We are not going to do a dimensionally incorrect shortcut
1329 * implementation. BAA 3/96
1330 */
1331 if ( CONSTANTTERM(b[TS_LEFT]->t) ) { /* C A * =?=> ?*/
1332 /* LEFT is now ereal or e_int because it passed the 0 and C tests */
1333 if ( b[TS_TOP]->t == e_real) { /* C R * => C */
1334 if ( b[TS_LEFT]->t == e_real ) { /* R R * => R */
1335 newdim = SumDimensions(R_TERM(b[TS_TOP])->dimensions,
1336 R_TERM(b[TS_LEFT])->dimensions,1);
1337 if ( newdim == NULL || IsWild(newdim) ) { /* bad dim */
1338 FPRINTF(ASCERR,
1339 "Mult. by wild or fractional dimension constant not folded.\n");
1340 TS_PUSH(top);
1341 break;
1342 } else { /* dim ok. morph etimes to be result. */
1343 rval = R_TERM(b[TS_TOP])->value * R_TERM(b[TS_LEFT])->value;
1344 /* god help us if this overflows... */
1345 b[top]->t = e_real;
1346 R_TERM(b[top])->dimensions = newdim;
1347 R_TERM(b[top])->value = rval;
1348 b[TS_TOP] = NULL;
1349 b[TS_LEFT] = NULL;
1350 TS_POP2;
1351 TS_PUSH(top);
1352 break;
1353 }
1354 } else { /* I R * => R */
1355 rval =
1356 R_TERM(b[TS_TOP])->value * (double)I_TERM(b[TS_LEFT])->ivalue;
1357 /* god help us if this overflows... */
1358 b[top]->t = e_real;
1359 R_TERM(b[top])->dimensions = R_TERM(b[TS_TOP])->dimensions;
1360 R_TERM(b[top])->value = rval;
1361 b[TS_TOP] = NULL;
1362 b[TS_LEFT] = NULL;
1363 TS_POP2;
1364 TS_PUSH(top);
1365 break;
1366 }
1367 #ifndef NDEBUG
1368 FPRINTF(ASCERR,"Unexpected error in Simplification (1).\n");
1369 /* NOT REACHED */
1370 break;
1371 #endif
1372 }
1373 if ( b[TS_TOP]->t == e_int) { /* C I * => C */
1374 if ( b[TS_LEFT]->t == e_real ) { /* R I * => R */
1375 rval =
1376 R_TERM(b[TS_LEFT])->value * (double)I_TERM(b[TS_TOP])->ivalue;
1377 /* god help us if this overflows... */
1378 b[top]->t = e_real;
1379 R_TERM(b[top])->dimensions = R_TERM(b[TS_LEFT])->dimensions;
1380 R_TERM(b[top])->value = rval;
1381 b[TS_TOP] = NULL;
1382 b[TS_LEFT] = NULL;
1383 TS_POP2;
1384 TS_PUSH(top);
1385 break;
1386 } else { /* I I * => I */
1387 rval = (double)I_TERM(b[TS_TOP])->ivalue *
1388 (double)I_TERM(b[TS_LEFT])->ivalue;
1389 if (fabs(rval) < (double)(LONG_MAX/2)) {/*result safely integer*/
1390 b[top]->t = e_int;
1391 I_TERM(b[top])->ivalue =
1392 I_TERM(b[TS_TOP])->ivalue * I_TERM(b[TS_LEFT])->ivalue;
1393 b[TS_TOP] = NULL;
1394 b[TS_LEFT] = NULL;
1395 TS_POP2;
1396 TS_PUSH(top);
1397 break;
1398 } else {
1399 b[top]->t = e_real;
1400 R_TERM(b[top])->dimensions = Dimensionless();
1401 R_TERM(b[top])->value = rval;
1402 b[TS_TOP] = NULL;
1403 b[TS_LEFT] = NULL;
1404 TS_POP2;
1405 TS_PUSH(top);
1406 break;
1407 }
1408 }
1409 #ifndef NDEBUG
1410 FPRINTF(ASCERR,"Unexpected error in Simplification (2).\n");
1411 /* NOT REACHED */
1412 break;
1413 #endif
1414 }
1415 } /* end all C A * alternatives */
1416 /* if here, no simplifications worked,
1417 * though constants exist.
1418 */
1419 TS_PUSH(top);
1420 break;
1421 } /* end of case e_times outermost if */
1422 #ifndef NDEBUG
1423 FPRINTF(ASCERR,"Unexpected error in Simplification (3).\n");
1424 /* NOT REACHED */
1425 break;
1426 #endif
1427
1428 case e_divide: /* note: A1 A2 / postfix => A1/A2 infix */
1429 /* needs completing only does C/C at present. needs to do 0/A. */
1430 if ( !CONSTANTTERM(b[TS_LEFT]->t) && !CONSTANTTERM(b[TS_TOP]->t) ) {
1431 /* no constants in sight, go on fast. */
1432 TS_PUSH(top);
1433 break;
1434 } else {
1435 /* some constants in sight, try things. */
1436 if (b[TS_LEFT]->t == e_zero && b[TS_TOP]->t != e_zero) {
1437 /* 0 A / => 0 */
1438 ival = SimplifyTermBuf_SubExprLimit(ts,b,next-1,e_divide);
1439 if ( ival > -2 ) {
1440 for (last = next-1; last > ival; last--) {
1441 b[ts[last]] = NULL; /* kill the subexpression tokens */
1442 }
1443 next = ival + 1; /* big stack pop, could be pop2 */
1444 b[top]->t = e_zero;
1445 R_TERM(b[top])->dimensions = WildDimension();
1446 R_TERM(b[top])->value = 0.0;
1447 TS_PUSH(top);
1448 break;
1449 } else {
1450 /* we had an error in subexpression limit search */
1451 TS_PUSH(top);
1452 break;
1453 }
1454 } /* end of 0 A / */
1455 /* NOTE: here we should be watching for 0.0 e_real and 0 e_int,
1456 * but as yet we don't
1457 * check these cases and derive a properly dimensioned e_real 0.
1458 * We are not going to do a dimensionally incorrect shortcut
1459 * implementation. BAA 3/96
1460 */
1461 if ( ZEROTERM(b[TS_TOP]) ) {
1462 /* trap A/0 out */
1463 FPRINTF(ASCERR,"Division by constant 0 not simplified.\n");
1464 top = blen;
1465 early = 1; /* set flag that we punted. */
1466 TS_PUSH(top);
1467 break;
1468 } /* end of A/0 out */
1469 if ( CONSTANTTERM(b[TS_LEFT]->t) ) { /* C A / =?=> ?*/
1470 /* LEFT is now R or I because it passed the 0 and C tests */
1471 if ( b[TS_TOP]->t == e_real) { /* C R / => C */
1472 if ( b[TS_LEFT]->t == e_real ) { /* R R / => R */
1473 newdim = DiffDimensions(R_TERM(b[TS_LEFT])->dimensions,
1474 R_TERM(b[TS_TOP])->dimensions,1);
1475 if ( newdim == NULL || IsWild(newdim) ) { /* bad dim */
1476 FPRINTF(ASCERR,
1477 "Div. by wild or fractional dimension constant not folded.\n");
1478 TS_PUSH(top);
1479 break;
1480 } else { /* dim ok. morph edivide to be result. */
1481 rval = R_TERM(b[TS_LEFT])->value / R_TERM(b[TS_TOP])->value;
1482 /* god help us if this overflows/underflows... */
1483 b[top]->t = e_real;
1484 R_TERM(b[top])->dimensions = newdim;
1485 R_TERM(b[top])->value = rval;
1486 b[TS_TOP] = NULL;
1487 b[TS_LEFT] = NULL;
1488 TS_POP2;
1489 TS_PUSH(top);
1490 break;
1491 }
1492 } else { /* I R / => R */
1493 rval =
1494 ((double)I_TERM(b[TS_LEFT])->ivalue) /R_TERM(b[TS_TOP])->value;
1495 /* god help us if this overflows... */
1496 b[top]->t = e_real;
1497 R_TERM(b[top])->dimensions =
1498 DiffDimensions(Dimensionless(),
1499 R_TERM(b[TS_TOP])->dimensions,0);
1500 /* diff dimens not checked here because top is dimensionless */
1501 R_TERM(b[top])->value = rval;
1502 b[TS_TOP] = NULL;
1503 b[TS_LEFT] = NULL;
1504 TS_POP2;
1505 TS_PUSH(top);
1506 break;
1507 }
1508 #ifndef NDEBUG
1509 FPRINTF(ASCERR,"Unexpected error in Simplification (4).\n");
1510 /* NOT REACHED */
1511 break;
1512 #endif
1513 }
1514 if ( b[TS_TOP]->t == e_int) { /* C I / => C */
1515 if ( b[TS_LEFT]->t == e_real ) { /* R I / => R */
1516 rval =
1517 R_TERM(b[TS_LEFT])->value / (double)I_TERM(b[TS_TOP])->ivalue;
1518 /* god help us if this overflows... */
1519 b[top]->t = e_real;
1520 R_TERM(b[top])->dimensions = R_TERM(b[TS_LEFT])->dimensions;
1521 R_TERM(b[top])->value = rval;
1522 b[TS_TOP] = NULL;
1523 b[TS_LEFT] = NULL;
1524 TS_POP2;
1525 TS_PUSH(top);
1526 break;
1527 } else { /* I I / => R! Integer division is NOT allowed */
1528 rval = (double)I_TERM(b[TS_LEFT])->ivalue;
1529 rval /= (double)I_TERM(b[TS_TOP])->ivalue;
1530 b[top]->t = e_real;
1531 R_TERM(b[top])->dimensions = Dimensionless();
1532 R_TERM(b[top])->value = rval;
1533 b[TS_TOP] = NULL;
1534 b[TS_LEFT] = NULL;
1535 TS_POP2;
1536 TS_PUSH(top);
1537 break;
1538 }
1539 #ifndef NDEBUG
1540 FPRINTF(ASCERR,"Unexpected error in Simplification (5).\n");
1541 /* NOT REACHED */
1542 break;
1543 #endif
1544 }
1545 } /* end all C A / alternatives */
1546 if ( CONSTANTTERM(b[TS_TOP]->t) ) { /* A C / => A (1/C) * */
1547 /* we screened out 0 above, so its int or real */
1548 if (b[TS_TOP]->t == e_real) { /* A R / => A R * */
1549 rval = 1/R_TERM(b[TS_TOP])->value;
1550 /* god help us if this overflows... */
1551 b[top]->t = e_times; /* morph / to * */
1552 /* flip dimens */
1553 R_TERM(b[TS_TOP])->dimensions =
1554 DiffDimensions(Dimensionless(),R_TERM(b[TS_TOP])->dimensions,0);
1555 /* diff dimens not checked here because top is dimensionless */
1556 R_TERM(b[TS_TOP])->value = rval; /* flip value */
1557 TS_PUSH(top);
1558 break;
1559 }
1560 if (b[TS_TOP]->t == e_int) { /* A I / => A I * */
1561 rval = 1.0/(double)I_TERM(b[TS_TOP])->ivalue;
1562 /* god help us if this overflows... */
1563 b[top]->t = e_times; /* morph / to * */
1564 /* flip dimens */
1565 b[TS_TOP]->t = e_real; /* morph int to real */
1566 R_TERM(b[TS_TOP])->value = rval; /* flip value */
1567 R_TERM(b[TS_TOP])->dimensions = Dimensionless();
1568 TS_PUSH(top);
1569 break;
1570 }
1571 } /* end of morphing A/C => A*c' */
1572 /* if here, no simplifications worked,
1573 * though constants exist.
1574 */
1575 TS_PUSH(top);
1576 break;
1577 } /* end of case e_divide outermost if */
1578 /* NOT REACHED */
1579 #ifndef NDEBUG
1580 FPRINTF(ASCERR,"Unexpected error in Simplification (6).\n");
1581 break;
1582 #endif
1583 case e_power: /* DANGER! WILL ROBINSON, DANGER! possible fall through */
1584 /* exponents must be dimensionless to make any sense */
1585 if (b[TS_TOP]->t == e_zero || b[TS_TOP]->t == e_int ||
1586 (b[TS_TOP]->t == e_real &&
1587 ( SameDimen(R_TERM(b[TS_TOP])->dimensions,Dimensionless()) ||
1588 IsWild(R_TERM(b[TS_TOP])->dimensions) ) &&
1589 floor(R_TERM(b[TS_TOP])->value)==ceil(R_TERM(b[TS_TOP])->value) &&
1590 fabs(R_TERM(b[TS_TOP])->value) < MAXINTREAL)
1591 ) { /* big if ipowerable */
1592 if (b[TS_TOP]->t == e_real) { /* morph real to int */
1593 b[TS_TOP]->t = e_int;
1594 I_TERM(b[TS_TOP])->ivalue = (long)R_TERM(b[TS_TOP])->value;
1595 }
1596 /* e_zero and e_int are appropriate to ipower and need no morph */
1597 b[top]->t = e_ipower; /* morph to ipower and fall through */
1598 /* FALL THROUGH! FALL THROUGH! FALL THROUGH! FALL THROUGH! */
1599 /* we aren't supposed to allow fall, but this is really the
1600 most perfect place to do power=>ipower conversion.
1601 Note that very large exponent values may be impossible later. */
1602 } else {
1603 /* still need to code C^R case. A^0 promoted to ipow, not here */
1604 if ( CONSTANTTERM(b[TS_LEFT]->t) && CONSTANTTERM(b[TS_TOP]->t) ) {
1605 /* C is either 0, int, or real. R is nonintegral (or damn big) real.
1606 Because R is not integer, C must be positive and dimensionless,
1607 and also small enough not to overflow: C > 1 =>
1608 check for pow(DBL_MAX,1/R) > R */
1609 if ( !SameDimen(R_TERM(b[TS_TOP])->dimensions,Dimensionless()) &&
1610 !IsWild(R_TERM(b[TS_TOP])->dimensions) ) {
1611 FPRINTF(ASCERR,"Illegal dimensioned exponent found in power.\n");
1612 top=blen;
1613 early = 1; /* set flag that we punted. */
1614 break;
1615 }
1616 if (b[TS_LEFT]->t == e_zero) { /* 0^R, R!=0 => 1 */
1617 b[top]->t = e_int;
1618 I_TERM(b[top])->ivalue = 1;
1619 b[TS_TOP] = NULL;
1620 b[TS_LEFT] = NULL;
1621 TS_POP2;
1622 TS_PUSH(top);
1623 break;
1624 /* end of 0^R */
1625 } else {
1626 if (b[TS_LEFT]->t == e_real) { /* R^R */
1627 if ( !SameDimen(R_TERM(b[TS_LEFT])->dimensions,Dimensionless())
1628 && !IsWild(R_TERM(b[TS_LEFT])->dimensions) ) {
1629 /* can happen on very large exponents */
1630 FPRINTF(ASCERR,
1631 "Illegal dimensioned base raised to nonintegral power.\n");
1632 top = blen;
1633 early = 1; /* set flag that we punted. */
1634 break;
1635 } else { /* R(dimless)^R , err if R ln(C) > ln(DBL_MAX) */
1636 if (R_TERM(b[TS_LEFT])->value < 0) {
1637 /* can happen on very large exponents */
1638 FPRINTF(ASCERR,
1639 "Illegal negative base raised to nonintegral power.\n");
1640 top = blen;
1641 early = 1; /* set flag that we punted. */
1642 break;
1643 }
1644 if (R_TERM(b[TS_LEFT])->value == 0.0) {
1645 /* R!=0, 0^R = 1 */
1646 b[top]->t = e_int;
1647 I_TERM(b[top])->ivalue = 0;
1648 b[TS_TOP] = NULL;
1649 b[TS_LEFT] = NULL;
1650 TS_POP2;
1651 TS_PUSH(top);
1652 break;
1653 }
1654 if ( R_TERM(b[TS_TOP])->value*log(R_TERM(b[TS_LEFT])->value) >
1655 F_LIM_EXP) { /* overflow in result. let solver do it */
1656 TS_PUSH(top);
1657 break;
1658 } else {
1659 b[top]->t = e_real;
1660 R_TERM(b[top])->dimensions = Dimensionless();
1661 R_TERM(b[top])->value =
1662 pow(R_TERM(b[TS_LEFT])->value,R_TERM(b[TS_TOP])->value);
1663 b[TS_TOP] = NULL;
1664 b[TS_LEFT] = NULL;
1665 TS_POP2;
1666 TS_PUSH(top);
1667 break;
1668 }
1669 }
1670 /* end of R^R */
1671 } else { /* I^R */
1672 if (I_TERM(b[TS_LEFT])->ivalue < 0) {
1673 /* can happen on very large exponents */
1674 FPRINTF(ASCERR,
1675 "Illegal negative base raised to nonintegral power.\n");
1676 top = blen;
1677 early = 1; /* set flag that we punted. */
1678 break;
1679 }
1680 if (I_TERM(b[TS_LEFT])->ivalue == 0) {
1681 /* R!=0, 0^R = 1 */
1682 b[top]->t = e_int;
1683 I_TERM(b[top])->ivalue = 0;
1684 b[TS_TOP] = NULL;
1685 b[TS_LEFT] = NULL;
1686 TS_POP2;
1687 TS_PUSH(top);
1688 break;
1689 }
1690 if ( R_TERM(b[TS_TOP])->value *
1691 log((double)I_TERM(b[TS_LEFT])->ivalue) > F_LIM_EXP) {
1692 /* overflow in result. let solver do it */
1693 TS_PUSH(top);
1694 break;
1695 } else {
1696 b[top]->t = e_real;
1697 R_TERM(b[top])->dimensions = Dimensionless();
1698 R_TERM(b[top])->value =
1699 pow((double)I_TERM(b[TS_LEFT])->ivalue,
1700 R_TERM(b[TS_TOP])->value);
1701 b[TS_TOP] = NULL;
1702 b[TS_LEFT] = NULL;
1703 TS_POP2;
1704 TS_PUSH(top);
1705 break;
1706 }
1707 /* end of I^R */
1708 }
1709 /* end of I,R ^R */
1710 }
1711 /* end of 0,I,R ^R */
1712 } else {
1713 TS_PUSH(top);
1714 /* remaining A^A2 where A2 => R or V or expr */
1715 }
1716 /* end of not morphing to ipower */
1717 break;
1718 }
1719 /* FALL THROUGH if morphing to ipower test succeeded */
1720
1721 case e_ipower:
1722 if ( ZEROTERM(b[TS_TOP]) ) {
1723 /* A^0 */
1724 if ( ZEROTERM(b[TS_LEFT]) ) {
1725 /* 0^0 */
1726 FPRINTF(ASCERR,"0 raised to 0 power is undefined.\n");
1727 top=blen;
1728 early = 1; /* set flag that we punted. */
1729 break;
1730 } else {
1731 /* A^0 => 1 */
1732 ival = SimplifyTermBuf_SubExprLimit(ts,b,next-1,e_ipower);
1733 if ( ival > -2 ) {
1734 for (last = next-1; last > ival; last--) {
1735 b[ts[last]] = NULL; /* kill the subexpression tokens */
1736 }
1737 next = ival + 1; /* big stack pop */
1738 b[top]->t = e_int;
1739 I_TERM(b[top])->ivalue = 1;
1740 TS_PUSH(top);
1741 break;
1742 } else {
1743 /* we had an error */
1744 TS_PUSH(top);
1745 break;
1746 }
1747 }
1748 } else { /* A^I, I!=0, A!=0 => R or I as needed */
1749 if (CONSTANTTERM(b[TS_LEFT]->t)) { /* C^I */
1750 if (b[TS_LEFT]->t == e_real) { /* R^I */
1751 /* err if I*ln(R) > ln(DBL_MAX) */
1752 if ( I_TERM(b[TS_TOP])->ivalue*log(fabs(R_TERM(b[TS_LEFT])->value))
1753 > F_LIM_EXP) { /* overflow in result. let solver do it */
1754 TS_PUSH(top);
1755 break;
1756 } else {
1757 ival = I_TERM(b[TS_TOP])->ivalue;
1758 newdim = PowDimension(ival,R_TERM(b[TS_LEFT])->dimensions,1);
1759 if (newdim==NULL) {
1760 FPRINTF(ASCERR,
1761 "Dimensional overflow in exponentiation of constant.\n");
1762 TS_PUSH(top);
1763 break;
1764 }
1765 b[top]->t = e_real;
1766 R_TERM(b[top])->dimensions = newdim;
1767 R_TERM(b[top])->value =
1768 asc_ipow(R_TERM(b[TS_LEFT])->value,(int)ival);
1769 /* cast of ival is accurate if newdim was ok */
1770 b[TS_TOP] = NULL;
1771 b[TS_LEFT] = NULL;
1772 TS_POP2;
1773 TS_PUSH(top);
1774 break;
1775 }
1776 /* end of R^I */
1777 } else { /* I^I */
1778 ival = I_TERM(b[TS_TOP])->ivalue;
1779 if ( ival * log((double)abs(I_TERM(b[TS_LEFT])->ivalue))
1780 > F_LIM_EXP) {
1781 /* overflow in result. let solver do it */
1782 TS_PUSH(top);
1783 break;
1784 }
1785 if (abs(ival) < INT_MAX) { /* this could be a little better */
1786 rval = asc_ipow((double)I_TERM(b[TS_LEFT])->ivalue,
1787 (int)I_TERM(b[TS_LEFT])->ivalue);
1788 if (fabs(rval) > MAXINTREAL || floor(rval)!=ceil(rval) ) {
1789 b[top]->t = e_real;
1790 R_TERM(b[top])->dimensions = Dimensionless();
1791 R_TERM(b[top])->value = rval;
1792 } else { /* can be an int safely */
1793 b[top]->t = e_int;
1794 I_TERM(b[top])->ivalue = (long)rval;
1795 }
1796 b[TS_TOP] = NULL;
1797 b[TS_LEFT] = NULL;
1798 TS_POP2;
1799 TS_PUSH(top);
1800 break;
1801 } else {
1802 /* exponent to damn big */
1803 TS_PUSH(top);
1804 break;
1805 }
1806 /* end of I^I */
1807 } /* end of C^I */
1808 } else {
1809 TS_PUSH(top);
1810 break;
1811 }
1812 #ifndef NDEBUG
1813 FPRINTF(ASCERR,"Unexpected error in Simplification (7).\n");
1814 break; /* NOT REACHED */
1815 #endif
1816 }
1817 #ifndef NDEBUG
1818 FPRINTF(ASCERR,"Unexpected error in Simplification (8).\n");
1819 break; /* NOT REACHED */
1820 #endif
1821 /* end e_ipower */
1822
1823 /* all the following are bogus in instantiated tokens at this time. (2/96)
1824 * e_subexpr,e_const,e_par,
1825 * e_card,e_choice,e_sum,e_prod,e_union,e_inter,e_in,e_st,
1826 * e_glassbox,e_blackbox,e_opcode,e_token,
1827 * e_or,e_and,e_boolean,e_set,e_symbol,
1828 * e_equal,e_notequal,e_less,e_greater,e_lesseq,e_greatereq,e_not,
1829 * e_qstring,
1830 * e_maximize,e_minimize,
1831 * e_undefined
1832 */
1833 default:
1834 FPRINTF(ASCERR,"Unexpected token in relation simplification.\n");
1835 FPRINTF(ASCERR,"Returning early.\n");
1836 top=blen;
1837 early = 1; /* flag that we punted. */
1838 break;
1839 }
1840 }
1841 /*
1842 * cleanup reduced expression, if needed.
1843 * after the for loop, next is now the length of the postfix expression,
1844 * or garbage if early is true.
1845 */
1846 if (blen <= next) return blen; /* no simplification, oh well. */
1847 right = 0;
1848 while (right < blen && b[right] != NULL) right++; /* find first null */
1849 for(last = right; right < blen; right++) { /* shift nonnulls left */
1850 if (b[right] != NULL) {
1851 b[last] = b[right];
1852 last++;
1853 }
1854 }
1855 if (!early && last != (long)next) {
1856 FPRINTF(ASCERR,"Confusing token counts in Simplify\n");
1857 }
1858 right = last;
1859 while (last<(long)blen) { /* null remainder, if any, of pointers */
1860 b[last] = NULL;
1861 last++;
1862 }
1863 return right;
1864 }
1865 /* END SimplifyTermBuf */
1866
1867 struct relation_side_temp {
1868 unsigned long length;
1869 union RelationTermUnion *side;
1870 };
1871
1872 static struct relation_term
1873 *InfixArr_MakeSide(CONST struct relation_side_temp *, int *);
1874 /* forward declaration */
1875
1876 /* returns 1 if converting buf is successful
1877 * returns 0 if buf empty or insufficient memory.
1878 * The structure tmp given is filled with an array of terms
1879 * and its length. You must free the array if you decide you
1880 * don't want it. We don't care how the structure is initialized.
1881 */
1882 static int ConvertTermBuf(struct relation_side_temp *tmp)
1883 {
1884 union RelationTermUnion *arr = NULL;
1885 unsigned long len,c;
1886
1887 len = SimplifyTermBuf(g_simplify_relations,g_term_ptrs.buf,g_term_ptrs.len);
1888 if (len < 1) return 0;
1889 arr = (union RelationTermUnion *)
1890 ascmalloc(len*sizeof(union RelationTermUnion));
1891 if (arr==NULL) {
1892 FPRINTF(ASCERR,"Create Token Relation: Insufficient memory :-(.\n");
1893 return 0;
1894 }
1895 for (c=0; c<len; c++) {
1896 arr[c] = *(UNION_TERM(g_term_ptrs.buf[c]));
1897 }
1898 tmp->side = arr;
1899 tmp->length = len;
1900 return 1;
1901 }
1902
1903 /*
1904 * usually we want to reset both simultaneously. reset our
1905 * pooling and buffering data.
1906 */
1907 static
1908 void DestroyTermList(void) {
1909 POOL_RESET;
1910 TPBUF_RESET;
1911 }
1912
1913 /* create a term from the pool */
1914 static struct relation_term *CreateOpTerm(enum Expr_enum t)
1915 {
1916 struct relation_term *term;
1917 term = POOL_ALLOCTERM;
1918 assert(term!=NULL);
1919 PTINIT(term);
1920 term->t = t;
1921 if (t==e_uminus) {
1922 U_TERM(term)->left = NULL;
1923 } else {
1924 B_TERM(term)->left = NULL;
1925 B_TERM(term)->right = NULL;
1926 }
1927 return term;
1928 }
1929
1930 /* create a term from the pool, inserting it
1931 * in pointer sorted order on g_relation_var_list.
1932 * Note that this and ModifyTokenRelationPointers are the
1933 * only places where the sort
1934 * order of the var list matters.
1935 * In fact, in most cases we could equally afford
1936 * linear search and that would give us repeatability
1937 * across platforms and runs since the vars will be
1938 * then encountered in a constant order determined
1939 * by how the user wrote the equation.
1940 * Needs consideration, especially in light of
1941 * potential to improve relation sharing.
1942 * In particular, we could then easily share
1943 * in a fine-grained manner those relations with
1944 * only a single index involved and no internal sums/products,
1945 * such as f[i] = x[i]*Ftot; in[i].f = out[i].f;
1946 * x = hold(x);
1947 * which could be pretty darn common forms.
1948 */
1949 static struct relation_term *CreateVarTerm(CONST struct Instance *i)
1950 {
1951 struct relation_term *term;
1952 unsigned long pos;
1953 if (0 != (pos = gl_search(g_relation_var_list,i,(CmpFunc)CmpP))) {
1954 /* find var if already on relations var list */
1955 term = POOL_ALLOCTERM;
1956 assert(term!=NULL);
1957 PTINIT(term);
1958 term->t = e_var;
1959 V_TERM(term) -> varnum = pos;
1960 } else {
1961 /* or add it to the var list */
1962 gl_append_ptr(g_relation_var_list,(VOIDPTR)i);
1963 term = POOL_ALLOCTERM;
1964 assert(term!=NULL);
1965 PTINIT(term);
1966 term->t = e_var;
1967 V_TERM(term) -> varnum = gl_length(g_relation_var_list);
1968 }
1969 return term;
1970 }
1971
1972 /* create a term from the pool */
1973 static struct relation_term *CreateIntegerTerm(long int v)
1974 {
1975 struct relation_term *term;
1976 term = POOL_ALLOCTERM;
1977 assert(term!=NULL);
1978 PTINIT(term);
1979 term->t = e_int;
1980 I_TERM(term) -> ivalue = v;
1981 return term;
1982 }
1983
1984 /* create a term from the pool */
1985 static struct relation_term *CreateRealTerm(double v, CONST dim_type *dim)
1986 {
1987 struct relation_term *term;
1988 term = POOL_ALLOCTERM;
1989 assert(term!=NULL);
1990 PTINIT(term);
1991 term->t = e_real;
1992 R_TERM(term) -> value = v;
1993 R_TERM(term) -> dimensions = dim;
1994 return term;
1995 }
1996
1997 /* create a term from the pool. Zero terms look like real, wild zeros */
1998 static struct relation_term *CreateZeroTerm(void)
1999 {
2000 struct relation_term *term;
2001 term = POOL_ALLOCTERM;
2002 assert(term!=NULL);
2003 PTINIT(term);
2004 term->t = e_zero;
2005 R_TERM(term)->value = 0.0;
2006 R_TERM(term)->dimensions = WildDimension();
2007 return term;
2008 }
2009
2010 /* create a term from the pool */
2011 static struct relation_term *CreateFuncTerm(CONST struct Func *f)
2012 {
2013 struct relation_term *term;
2014 term = POOL_ALLOCTERM;
2015 assert(term!=NULL);
2016 PTINIT(term);
2017 term->t = e_func;
2018 F_TERM(term) -> fptr = f;
2019 F_TERM(term) -> left = NULL;
2020 return term;
2021 }
2022
2023
2024 #ifdef THIS_IS_AN_UNUSED_FUNCTION
2025 /* create a term from the pool */
2026 static struct relation_term *CreateNaryTerm(CONST struct Func *f)
2027 {
2028 struct relation_term *term;
2029 term = POOL_ALLOCTERM;
2030 assert(term!=NULL);
2031 PTINIT(term);
2032 term->t = e_func;
2033 N_TERM(term) -> fptr = f;
2034 N_TERM(term) -> args = NULL;
2035 return term;
2036 }
2037 #endif /* THIS_IS_AN_UNUSED_FUNCTION */
2038
2039
2040 /*
2041 * This function create and *must* create the memory
2042 * for the structure and for the union that the structure
2043 * points to. Too much code depends on the pre-existent
2044 * of a properly initialized union.
2045 * If copyunion is crs_NOUNION, the share ptr is init to NULL and user
2046 * must set refcount,relop after the allocate a UNION or whatever.
2047 * If copyunion is crs_NEWUNION, share ptr is allocated and configured.
2048 *
2049 */
2050 struct relation *CreateRelationStructure(enum Expr_enum relop,int copyunion)
2051 {
2052 struct relation *newrelation;
2053
2054 newrelation = (struct relation *)ascmalloc(sizeof(struct relation));
2055 assert(newrelation!=NULL);
2056
2057 newrelation->residual = DBL_MAX;
2058 newrelation->multiplier = DBL_MAX;
2059 newrelation->nominal = 1.0;
2060 newrelation->iscond = 0;
2061 newrelation->vars = NULL;
2062 newrelation->d =(dim_type *)WildDimension();
2063
2064 if (copyunion) {
2065 newrelation->share =
2066 (union RelationUnion *)ascmalloc(sizeof(union RelationUnion));
2067 assert(newrelation->share!=NULL);
2068 RelationRefCount(newrelation) = 0;
2069 RelRelop(newrelation) = relop;
2070 #if TOKENDOMINANT
2071 RTOKEN(newrelation).lhs_term = NULL;
2072 RTOKEN(newrelation).rhs_term = NULL;
2073 RTOKEN(newrelation).lhs = NULL;
2074 RTOKEN(newrelation).rhs = NULL;
2075 RTOKEN(newrelation).lhs_len = 0;
2076 RTOKEN(newrelation).rhs_len = 0;
2077 RTOKEN(newrelation).btable = 0;
2078 RTOKEN(newrelation).bindex = 0;
2079 #else
2080 memset((char *)(newrelation->share),0,sizeof(union RelationUnion));
2081 #endif
2082 } else {
2083 newrelation->share = NULL;
2084 }
2085 return newrelation;
2086 }
2087
2088
2089 /*
2090 **************************************************************************
2091 * External Procedures Processing.
2092 *
2093 * A special note on external relations.
2094 * External relations behave like relations but they also behave like
2095 * procedures. As such when they are constructed and invoked they expect
2096 * a particular ordering of their variables.
2097 * However there are some operations that can mess up (reduce) the number
2098 * of incident variables on the incident varlist -- ATSing 2 variables in the
2099 * *same* relation will do this. BUT we still need to maintain the number
2100 * of variables in the call to the evaluation routine.
2101 * Consider the following example:
2102 * An glassbox relation is constructed as: test1(x[46,2,8,9] ; 2);
2103 * It *requires* 4 arguements, but its incident var count could be anything
2104 * from 1 <= n <= 4, depending on how many ATS are done. Unfortunately
2105 * the ATS could have been done even before we have constructed the relation,
2106 * so we have to make sure that we check for aliasing.
2107 **************************************************************************
2108 */
2109
2110
2111
2112 struct relation *CreateBlackBoxRelation(struct Instance *relinst,
2113 struct ExternalFunc *efunc,
2114 struct gl_list_t *arglist,
2115 struct Instance *subject,
2116 struct gl_list_t *inputs,
2117 struct Instance *data)
2118 {
2119 struct relation *result;
2120 struct gl_list_t *newarglist;
2121 struct gl_list_t *newlist;
2122 struct ExtCallNode *ext;
2123 struct Instance *var = NULL;
2124 int *args;
2125 unsigned long c,len,pos;
2126 unsigned long n_inputs;
2127
2128 CONSOLE_DEBUG("CREATING BLACK BOX RELATION");
2129
2130 n_inputs = gl_length(inputs);
2131 len = n_inputs + 1; /* an extra for the output variable. */
2132
2133 /*
2134 * Add the input vars, making sure that their incidence
2135 * is unique, and adjusting the indexing appropriately
2136 * on the integer args array.
2137 */
2138
2139 args = (int *)asccalloc((int)(len+1), sizeof(int));
2140 newlist = gl_create(len);
2141
2142 for (c=1;c<=n_inputs;c++) {
2143 var = (struct Instance *)gl_fetch(inputs,c);
2144 pos = gl_search(newlist,var,(CmpFunc)CmpP);
2145 if (pos) {
2146 FPRINTF(ASCERR,"Incidence for external relation will be inaccurate\n");
2147 *args++ = (int)pos;
2148 }
2149 else{
2150 gl_append_ptr(newlist,(VOIDPTR)var);
2151 *args++ = (int)gl_length(newlist);
2152 AddRelation(subject,relinst);
2153 }
2154 }
2155
2156 /*
2157 * Add the subject.
2158 */
2159 pos = gl_search(newlist,subject,(CmpFunc)CmpP);
2160 if (pos) {
2161 FPRINTF(ASCERR,"An input and output variable are the same !!\n");
2162 *args++ = (int)pos;
2163 }
2164 else{
2165 gl_append_ptr(newlist,(VOIDPTR)subject); /* add the subject */
2166 *args++ = (int)gl_length(newlist);
2167 AddRelation(var,relinst);
2168 }
2169 *args = 0; /* terminate */
2170
2171 /*
2172 * Create the BlackBox relation structure. This requires
2173 * creating a ExtCallNode node.
2174 */
2175 newarglist = CopySpecialList(arglist);
2176 ext = CreateExtCall(efunc,newarglist,subject,data);
2177 SetExternalCallNodeStamp(ext,g_ExternalNodeStamps);
2178
2179 /*
2180 * Now make the main relation structure and put it all
2181 * together. Then append the necessary lists.
2182 */
2183 result = CreateRelationStructure(e_equal,crs_NEWUNION);
2184 RelationRefCount(result) = 1;
2185 RBBOX(result).args = args;
2186 RBBOX(result).ext = ext;
2187 result->vars = newlist;
2188 return result;
2189 }
2190
2191
2192 struct relation *CreateGlassBoxRelation(struct Instance *relinst,
2193 struct ExternalFunc *efunc,
2194 struct gl_list_t *varlist,
2195 int index,
2196 enum Expr_enum relop)
2197 {
2198 struct relation *result;
2199 struct Instance *var;
2200 struct gl_list_t *newlist = NULL;
2201 int *tmp = NULL, *args = NULL;
2202 unsigned long len,c,pos;
2203
2204 len = gl_length(varlist);
2205 /*
2206 * Make the variables aware that they are incident
2207 * in this relation instance. At the same time set up
2208 * the args list indexing.
2209 */
2210 if (len) {
2211 tmp = args = (int *)asccalloc((int)(len+1), sizeof(int));
2212 newlist = gl_create(len);
2213
2214 for (c=1;c<=len;c++) {
2215 var = (struct Instance *)gl_fetch(varlist,c);
2216 pos = gl_search(newlist,var,(CmpFunc)CmpP);
2217 if (pos) {
2218 FPRINTF(ASCERR,"Incidence for external relation will be inaccurate\n");
2219 *tmp++ = (int)pos;
2220 }
2221 else{
2222 gl_append_ptr(newlist,(VOIDPTR)var);
2223 *tmp++ = (int)gl_length(newlist);
2224 AddRelation(var,relinst);
2225 }
2226 }
2227 }
2228 *tmp = 0; /* terminate */
2229
2230 /*
2231 * Create the relation data structure and append the
2232 * varlist.
2233 */
2234 result = CreateRelationStructure(relop,crs_NEWUNION);
2235 RelationRefCount(result) = 1;
2236 RGBOX(result).efunc = efunc;
2237 RGBOX(result).args = args;
2238 RGBOX(result).nargs = (int)len;
2239 RGBOX(result).index = index;
2240 result->vars = newlist;
2241 return result;
2242 }
2243
2244
2245 /**************************************************************************\
2246 TokenRelation processing and general expr -> relation check routines.
2247 \**************************************************************************/
2248
2249
2250 static
2251 struct value_t CheckIntegerCoercion(struct value_t v)
2252 {
2253 if ((ValueKind(v)==real_value) && (RealValue(v)==0.0) &&
2254 IsWild(RealValueDimensions(v)) ){
2255 DestroyValue(&v);
2256 return CreateIntegerValue(0,1); /* assume this is a constant then */
2257 }
2258 else return v;
2259 }
2260
2261 static
2262 int ProcessListRange(CONST struct Instance *ref,
2263 CONST struct Expr *low,
2264 CONST struct Expr *up,
2265 int *added,
2266 int i,
2267 enum relation_errors *err,
2268 enum find_errors *ferr)
2269 {
2270 struct value_t lower,upper;
2271 struct relation_term *term;
2272 long lv,uv;
2273 assert(GetEvaluationContext()==NULL);
2274 SetEvaluationContext(ref);
2275 lower = EvaluateExpr(low,NULL,InstanceEvaluateName);
2276 upper = EvaluateExpr(up,NULL,InstanceEvaluateName);
2277 SetEvaluationContext(NULL);
2278 lower = CheckIntegerCoercion(lower);
2279 upper = CheckIntegerCoercion(upper);
2280 if ((ValueKind(lower)==integer_value)&&(ValueKind(upper)==integer_value)){
2281 lv = IntegerValue(lower);
2282 uv = IntegerValue(upper);
2283 while(lv<=uv){
2284 term = CreateIntegerTerm(lv);
2285 AppendTermBuf(term);
2286 if ((*added)++) {
2287 switch(i){
2288 case SUM:
2289 term = CreateOpTerm(e_plus);
2290 break;
2291 case PROD:
2292 term = CreateOpTerm(e_times);
2293 break;
2294 }
2295 AppendTermBuf(term);
2296 }
2297 lv++;
2298 }
2299 return 0;
2300 }
2301 else{
2302 if(ValueKind(lower)==error_value) {
2303 FigureOutError(lower,err,ferr);
2304 return 1;
2305 }
2306 if(ValueKind(upper)==error_value){
2307 FigureOutError(upper,err,ferr);
2308 return 1;
2309 }
2310 *err = incorrect_structure;
2311 FPRINTF(ASCERR,"incorrect_structure in ProcessListRange\n");
2312 return 1;
2313 }
2314 }
2315
2316 static
2317 CONST struct Expr *ExprContainsSuchThat(register CONST struct Expr *ex)
2318 {
2319 while(ex!=NULL){
2320 if (ExprType(ex)==e_st) return ex;
2321 ex = NextExpr(ex);
2322 }
2323 return ex;
2324 }
2325
2326 /*
2327 * Here we give up if vars are not well defined.
2328 * At present e_var acceptable ARE:
2329 * REAL_ATOM_INSTANCE
2330 * Well defined Real and Integer constants.
2331 * Everything else is trash.
2332 * CreateTermFromInst() and CheckExpr() must have matching semantics.
2333 */
2334 static
2335 struct relation_term *CreateTermFromInst(struct Instance *inst,
2336 struct Instance *rel,
2337 enum relation_errors *err)
2338 {
2339 struct relation_term *term;
2340 switch(InstanceKind(inst)){
2341 case REAL_ATOM_INST:
2342 term = CreateVarTerm(inst);
2343 AddRelation(inst,rel);
2344 return term;
2345 case REAL_CONSTANT_INST:
2346 if ( AtomAssigned(inst) && !IsWild(RealAtomDims(inst)) ){
2347 term = CreateRealTerm(RealAtomValue(inst),RealAtomDims(inst));
2348 return term;
2349 }
2350 else{
2351 if ( IsWild(RealAtomDims(inst)) && AtomAssigned(inst) ) {
2352 *err = real_value_wild;
2353 } else {
2354 *err = real_value_undefined;
2355 }
2356 return NULL;
2357 }
2358 case INTEGER_CONSTANT_INST:
2359 if (AtomAssigned(inst)){
2360 term = CreateIntegerTerm(GetIntegerAtomValue(inst));
2361 return term;
2362 }
2363 else{
2364 *err = integer_value_undefined;
2365 return NULL;
2366 }
2367 case REAL_INST:
2368 *err = incorrect_real_inst_type;
2369 return NULL;
2370 case INTEGER_ATOM_INST:
2371 case INTEGER_INST:
2372 *err = incorrect_integer_inst_type;
2373 return NULL;
2374 case SYMBOL_ATOM_INST:
2375 case SYMBOL_CONSTANT_INST:
2376 case SYMBOL_INST:
2377 *err = incorrect_symbol_inst_type;
2378 return NULL;
2379 case BOOLEAN_ATOM_INST:
2380 case BOOLEAN_CONSTANT_INST:
2381 case BOOLEAN_INST:
2382 *err = incorrect_boolean_inst_type;
2383 return NULL;
2384 default:
2385 *err = incorrect_inst_type;
2386 return NULL;
2387 }
2388 }
2389
2390 /* forward declaration */
2391 static int AppendList( CONST struct Instance *,
2392 struct Instance *,
2393 CONST struct Set *,
2394 int ,
2395 enum relation_errors *,
2396 enum find_errors *);
2397
2398 static
2399 int ConvertSubExpr(CONST struct Expr *ptr,
2400 CONST struct Expr *stop,
2401 CONST struct Instance *ref,
2402 struct Instance *rel,
2403 int *added,
2404 int i,
2405 enum relation_errors *err,
2406 enum find_errors *ferr)
2407 {
2408 struct relation_term *term = NULL;
2409 struct gl_list_t *instances;
2410 unsigned c,len;
2411 struct Instance *inst;
2412 struct value_t svalue,cvalue;
2413 int my_added=0;
2414 symchar *str;
2415 CONST struct for_var_t *fvp; /* for var pointer */
2416 while (ptr!=stop){
2417 switch(ExprType(ptr)){
2418 case e_plus:
2419 case e_minus:
2420 case e_times:
2421 case e_divide:
2422 case e_power:
2423 case e_ipower:
2424 case e_uminus:
2425 term = CreateOpTerm(ExprType(ptr));
2426 my_added++;
2427 AppendTermBuf(term);
2428 break;
2429 case e_var:
2430 str = SimpleNameIdPtr(ExprName(ptr));
2431 if (str&&TempExists(str)){
2432 cvalue = TempValue(str);
2433 switch(ValueKind(cvalue)){
2434 case integer_value:
2435 term = CreateIntegerTerm(IntegerValue(cvalue));
2436 my_added++;
2437 AppendTermBuf(term);
2438 break;
2439 default:
2440 FPRINTF(ASCERR,"Non-integer temporary variable used in expression.\n");
2441 *err = incorrect_inst_type;
2442 term = NULL;
2443 return 1;
2444 }
2445 }else if (GetEvaluationForTable() != NULL && str !=NULL &&
2446 (fvp=FindForVar(GetEvaluationForTable(),str)) !=NULL ){
2447 if (GetForKind(fvp)==f_integer){
2448 term = CreateIntegerTerm(GetForInteger(fvp));
2449 my_added++;
2450 AppendTermBuf(term);
2451 }
2452 else{
2453 FPRINTF(ASCERR,
2454 "Non-integer FOR variable used in expression.\n");
2455 *err = incorrect_inst_type;
2456 return 1;
2457 }
2458 }
2459 else{
2460 instances = FindInstances(ref,ExprName(ptr),ferr);
2461 if (instances!=NULL){
2462 if (NextExpr(ptr)==stop){ /* possibly multiple instances */
2463 len = gl_length(instances);
2464 for(c=1;c<=len;c++){
2465 inst = (struct Instance *)gl_fetch(instances,c);
2466 if ((term=CreateTermFromInst(inst,rel,err))!=NULL){
2467 AppendTermBuf(term);
2468 if (my_added++){
2469 switch(i){
2470 case SUM:
2471 term = CreateOpTerm(e_plus);
2472 break;
2473 case PROD:
2474 term = CreateOpTerm(e_times);
2475 break;
2476 }
2477 AppendTermBuf(term);
2478 }
2479 }
2480 else{
2481 gl_destroy(instances);
2482 return 1;
2483 }
2484 }
2485 gl_destroy(instances);
2486 }
2487 else{ /* single instance */
2488 if (gl_length(instances)==1){
2489 inst = (struct Instance *)gl_fetch(instances,1);
2490 gl_destroy(instances);
2491 if ((term=CreateTermFromInst(inst,rel,err))!=NULL){
2492 my_added++;
2493 AppendTermBuf(term);
2494 }
2495 else
2496 return 1;
2497 }
2498 else{
2499 gl_destroy(instances);
2500 *err = incorrect_structure;
2501 FPRINTF(ASCERR,"incorrect_structure in ConvertSubExpr 1\n");
2502 return 1;
2503 }
2504 }
2505 } else{
2506 *err = find_error;
2507 return 1;
2508 }
2509 }
2510 break;
2511 case e_int:
2512 term = CreateIntegerTerm(ExprIValue(ptr));
2513 my_added++;
2514 AppendTermBuf(term);
2515 break;
2516 case e_zero:
2517 /* this should never happen here */
2518 term = CreateZeroTerm();
2519 my_added++;
2520 AppendTermBuf(term);
2521 break;
2522 case e_real:
2523 term = CreateRealTerm(ExprRValue(ptr),ExprRDimensions(ptr));
2524 my_added++;
2525 AppendTermBuf(term);
2526 break;
2527 case e_card:
2528 assert(GetEvaluationContext() == NULL);
2529 SetEvaluationContext(ref);
2530 svalue = EvaluateSet(ExprBuiltinSet(ptr),InstanceEvaluateName);
2531 SetEvaluationContext(NULL);
2532 cvalue = CardValues(svalue);
2533 DestroyValue(&svalue);
2534 switch(ValueKind(cvalue)){
2535 case integer_value:
2536 term = CreateIntegerTerm(IntegerValue(cvalue));
2537 my_added++;
2538 AppendTermBuf(term);
2539 break;
2540 case error_value:
2541 FigureOutError(cvalue,err,ferr);
2542 DestroyValue(&cvalue);
2543 return 1;
2544 default:
2545 FPRINTF(ASCERR,"This message should never occur.\n");
2546 FPRINTF(ASCERR,"If it does tell %s\n",ASC_BIG_BUGMAIL);
2547 DestroyValue(&cvalue);
2548 *err = incorrect_structure;
2549 return 1;
2550 }
2551 DestroyValue(&cvalue);
2552 break;
2553 case e_sum:
2554 my_added++;
2555 if (AppendList(ref,rel,ExprBuiltinSet(ptr),SUM,err,ferr))
2556 return 1;
2557 break;
2558 case e_prod:
2559 my_added++;
2560 if (AppendList(ref,rel,ExprBuiltinSet(ptr),PROD,err,ferr))
2561 return 1;
2562 break;
2563 case e_func:
2564 term = CreateFuncTerm(ExprFunc(ptr));
2565 my_added++;
2566 AppendTermBuf(term);
2567 break;
2568 default:
2569 *err = incorrect_structure;
2570 FPRINTF(ASCERR,"incorrect_structure in ConvertSubExpr 2\n");
2571 return 1;
2572
2573 }
2574 ptr = NextExpr(ptr);
2575 }
2576 if (my_added) {
2577 if ((*added)++){
2578 switch(i){
2579 case SUM:
2580 term = CreateOpTerm(e_plus);
2581 break;
2582 case PROD:
2583 term = CreateOpTerm(e_times);
2584 break;
2585 }
2586 AppendTermBuf(term);
2587 }
2588 }
2589 return 0;
2590 }
2591
2592 static
2593 int CorrectSuchThat(CONST struct Expr *ex,
2594 CONST struct Expr **depth_one,
2595 CONST struct Expr **node)
2596 {
2597 unsigned depth=0;
2598 CONST struct Expr *previous=NULL;
2599 while(ex!=NULL){
2600 switch(ExprType(ex)){
2601 case e_zero:
2602 case e_var:
2603 case e_int:
2604 case e_real:
2605 case e_boolean:
2606 case e_set:
2607 case e_symbol:
2608 case e_card:
2609 case e_choice:
2610 case e_sum:
2611 case e_prod:
2612 case e_union:
2613 case e_inter:
2614 if ((++depth)==1) *depth_one = ex;
2615 break;
2616 /* binary operators */
2617 case e_plus:
2618 case e_minus:
2619 case e_times:
2620 case e_divide:
2621 case e_power:
2622 case e_ipower:
2623 case e_or:
2624 case e_and:
2625 case e_in:
2626 case e_equal:
2627 case e_notequal:
2628 case e_less:
2629 case e_greater:
2630 case e_lesseq:
2631 case e_greatereq:
2632 if ((--depth)==1) *depth_one = ex;
2633 break;
2634 case e_func:
2635 case e_uminus:
2636 case e_not:
2637 if (depth==1) *depth_one = ex;
2638 break;
2639 case e_st:
2640 if (previous==NULL) return 0; /* error */
2641 if (NextExpr(ex)!=NULL) return 0; /* error */
2642 if (ExprType(previous)!=e_in) return 0; /* error */
2643 *node = previous;
2644 return 1;
2645 case e_minimize:
2646 case e_maximize:
2647 Asc_Panic(2, NULL,
2648 "Maximize and minimize are not allowed in expression.\n"
2649 "They are only allowed in relations.\n");
2650 break;
2651 default:
2652 Asc_Panic(2, NULL, "Unknown expression node type.\n");
2653 break;
2654 }
2655 previous = ex;
2656 ex = NextExpr(ex);
2657 }
2658 return 0;
2659 }
2660
2661 /* if problem, returns 1. if ok, returns 0 */
2662 static
2663 int DoNameAndSet(CONST struct Expr *ex,
2664 CONST struct Expr *stop,
2665 CONST struct Instance *ref,
2666 symchar **name,
2667 struct value_t *value)
2668 {
2669 if (ExprType(ex)==e_var){
2670 if ((*name = SimpleNameIdPtr(ExprName(ex)))!=NULL){
2671 assert(GetEvaluationContext()==NULL);
2672 SetEvaluationContext(ref);
2673 *value = EvaluateExpr(NextExpr(ex),stop,InstanceEvaluateName);
2674 SetEvaluationContext(NULL);
2675 if (ValueKind(*value)==set_value) return 0;
2676 DestroyValue(value);
2677 return 1;
2678 }
2679 else return 1;
2680 }
2681 else return 1;
2682 }
2683
2684 static
2685 int ConvertSuchThat(CONST struct Expr *ex,
2686 CONST struct Instance *ref,
2687 struct Instance *rel,
2688 int *added,
2689 int i,
2690 enum relation_errors *err,
2691 enum find_errors *ferr)
2692 {
2693 symchar *tmp_name;
2694 unsigned long c,len;
2695 int my_added=0;
2696 struct value_t iteration_set,tmp_value;
2697 struct relation_term *term = NULL;
2698 struct set_t *sptr;
2699 CONST struct Expr *depth_one,*node;
2700 if (CorrectSuchThat(ex,&depth_one,&node)){
2701 if (DoNameAndSet(NextExpr(depth_one),node,ref,&tmp_name,&iteration_set)){
2702 *err = incorrect_structure;
2703 FPRINTF(ASCERR,"incorrect_structure in ConvertSuchThat 1\n");
2704 if (depth_one!=NULL && NextExpr(depth_one)!=NULL) {
2705 FPRINTF(ASCERR,"such that expression (RPN):\n\t");
2706 WriteExpr(ASCERR,NextExpr(depth_one));
2707 FPRINTF(ASCERR,"\n");
2708 }
2709 return 1;
2710 }
2711 node = NextExpr(depth_one);
2712 sptr = SetValue(iteration_set);
2713 switch(SetKind(sptr)){
2714 case empty_set:
2715 DestroyValue(&iteration_set);
2716 return 0;
2717 case integer_set:
2718 case string_set:
2719 if (TempExists(tmp_name)){
2720 FPRINTF(ASCERR,"Reused temporary variable %s.\n",SCP(tmp_name));
2721 DestroyValue(&iteration_set);
2722 *err = incorrect_structure;
2723 return 1;
2724 }
2725 AddTemp(tmp_name);
2726 len = Cardinality(sptr);
2727 for(c=1;c<=len;c++) {
2728 if (SetKind(sptr)==string_set)
2729 tmp_value = CreateSymbolValue(FetchStrMember(sptr,c),1);
2730 else
2731 tmp_value = CreateIntegerValue(FetchIntMember(sptr,c),1);
2732 SetTemp(tmp_name,tmp_value);
2733 if (ConvertSubExpr(ex,node,ref,rel,&my_added,i,err,ferr)){
2734 RemoveTemp(tmp_name);
2735 DestroyValue(&tmp_value);
2736 DestroyValue(&iteration_set);
2737 return 1;
2738 }
2739 DestroyValue(&tmp_value);
2740 }
2741 if (my_added){
2742 my_added++;
2743 if ((*added)++){
2744 switch(i){
2745 case SUM:
2746 term = CreateOpTerm(e_plus);
2747 break;
2748 case PROD:
2749 term = CreateOpTerm(e_times);
2750 break;
2751 }
2752 AppendTermBuf(term);
2753 }
2754 }
2755 RemoveTemp(tmp_name);
2756 DestroyValue(&iteration_set);
2757 return 0;
2758 }
2759 /*NOTREACHED*/
2760 }
2761 else{
2762 *err = incorrect_structure;
2763 FPRINTF(ASCERR,"incorrect_structure in ConvertSuchThat 2\n");
2764 return 1;
2765 }
2766 /*NOTREACHED we hope*/
2767 return 1;
2768 }
2769
2770 static
2771 int ProcessListExpr(CONST struct Instance *ref,
2772 struct Instance *rel,
2773 CONST struct Expr *ex,
2774 int *added,
2775 int i,
2776 enum relation_errors *err,
2777 enum find_errors *ferr)
2778 {
2779 if (ExprContainsSuchThat(ex)!=NULL){
2780 return ConvertSuchThat(ex,ref,rel,added,i,err,ferr);
2781 } else {
2782 return ConvertSubExpr(ex,NULL,ref,rel,added,i,err,ferr);
2783 }
2784 }
2785
2786 static int AppendList(CONST struct Instance *ref,
2787 struct Instance *rel,
2788 CONST struct Set *set,
2789 int i,
2790 enum relation_errors *err,
2791 enum find_errors *ferr)
2792 {
2793 int added_one=0; /* becomes true when a term is added */
2794 struct relation_term *term = NULL;
2795 while (set!=NULL){
2796 if (SetType(set)){ /* range of values */
2797 if (ProcessListRange(ref,GetLowerExpr(set),
2798 GetUpperExpr(set),&added_one,i,err,ferr))
2799 return 1;
2800 }
2801 else{ /* single expr */
2802 if (ProcessListExpr(ref,rel,GetSingleExpr(set),&added_one,
2803 i,err,ferr))
2804 return 1;
2805 }
2806 set = NextSet(set);
2807 }
2808 if(!added_one){ /* case of the empty set */
2809 switch(i){
2810 case SUM:
2811 term = CreateZeroTerm();
2812 break;
2813 case PROD:
2814 term = CreateRealTerm(1.0,Dimensionless());
2815 break;
2816 }
2817 AppendTermBuf(term);
2818 }
2819 return 0;
2820 }
2821
2822 /* nonrecursive, but may call recursive things. returns 1 if ok. 0 if not
2823 * On a return of 1, newside->arr will be filled and should be deallocated
2824 * if the user does not want it. a return of 0 means that newside data is
2825 * invalid.
2826 * This is the ONLY function that should call DestroyTermList.
2827 */
2828 static int ConvertExpr(CONST struct Expr *start,
2829 CONST struct Expr *stop,
2830 struct Instance *ref,
2831 struct Instance *rel,
2832 enum relation_errors *err,
2833 enum find_errors *ferr,
2834 struct relation_side_temp *newside)
2835 {
2836 struct gl_list_t *instances;
2837 struct relation_term *term;
2838 struct Instance *inst;
2839 int result;
2840 symchar *str;
2841 CONST struct for_var_t *fvp;
2842 struct value_t svalue,cvalue;
2843 if (newside==NULL) {
2844 Asc_Panic(2, NULL, "newside == NULL");
2845 }
2846 while(start!=stop){
2847 switch(ExprType(start)){
2848 case e_plus:
2849 case e_minus:
2850 case e_times:
2851 case e_divide:
2852 case e_power:
2853 case e_ipower:
2854 case e_uminus:
2855 term = CreateOpTerm(ExprType(start));
2856 AppendTermBuf(term);
2857 break;
2858 case e_var:
2859 if (GetEvaluationForTable() &&
2860 (NULL != (str = SimpleNameIdPtr(ExprName(start)))) &&
2861 (NULL != (fvp = FindForVar(GetEvaluationForTable(),str)))) {
2862 if (GetForKind(fvp)==f_integer){
2863 term = CreateIntegerTerm(GetForInteger(fvp));
2864 AppendTermBuf(term);
2865 } else{
2866 *err = incorrect_inst_type;
2867 DestroyTermList();
2868 return 0;
2869 }
2870 } else{
2871 instances = FindInstances(ref,ExprName(start),ferr);
2872 if (instances!=NULL){
2873 if (gl_length(instances)==1){
2874 inst = (struct Instance *)gl_fetch(instances,1);
2875 gl_destroy(instances);
2876 if ((term = CreateTermFromInst(inst,rel,err))!=NULL){
2877 AppendTermBuf(term);
2878 }
2879 else{
2880 DestroyTermList();
2881 return 0;
2882 }
2883 } else{
2884 *err=incorrect_structure;
2885 FPRINTF(ASCERR,"incorrect_structure in ConvertExpr 1\n");
2886 gl_destroy(instances);
2887 DestroyTermList();
2888 return 0;
2889 }
2890 } else{
2891 *err = find_error;
2892 if (*ferr == impossible_instance) {
2893 ERROR_REPORTER_START_NOLINE(ASC_USER_ERROR);
2894 FPRINTF(ASCERR,"Impossible name or subscript in '");
2895 WriteName(ASCERR,ExprName(start));
2896 FPRINTF(ASCERR,"'");
2897 error_reporter_end_flush();
2898 }
2899 DestroyTermList();
2900 return 0;
2901 }
2902 }
2903 break;
2904 case e_zero:
2905 /* this should never happen here */
2906 term = CreateZeroTerm();
2907 AppendTermBuf(term);
2908 break;
2909 case e_int:
2910 term = CreateIntegerTerm(ExprIValue(start));
2911 AppendTermBuf(term);
2912 break;
2913 case e_real:
2914 term = CreateRealTerm(ExprRValue(start),ExprRDimensions(start));
2915 AppendTermBuf(term);
2916 break;
2917 case e_card:
2918 assert(GetEvaluationContext()==NULL);
2919 SetEvaluationContext(ref);
2920 svalue = EvaluateSet(ExprBuiltinSet(start),InstanceEvaluateName);
2921 SetEvaluationContext(NULL);
2922 cvalue = CardValues(svalue);
2923 DestroyValue(&svalue);
2924 switch(ValueKind(cvalue)){
2925 case integer_value:
2926 term = CreateIntegerTerm(IntegerValue(cvalue));
2927 AppendTermBuf(term);
2928 break;
2929 case error_value:
2930 DestroyTermList();
2931 FigureOutError(cvalue,err,ferr);
2932 DestroyValue(&cvalue);
2933 return 0;
2934 default:
2935 FPRINTF(ASCERR,"This message should never occur.\n");
2936 FPRINTF(ASCERR,"If it does tell %s\n",ASC_BIG_BUGMAIL);
2937 DestroyValue(&cvalue);
2938 DestroyTermList();
2939 *err = incorrect_structure;
2940 return 0;
2941 }
2942 DestroyValue(&cvalue);
2943 break;
2944 case e_sum:
2945 if (AppendList(ref,rel,ExprBuiltinSet(start),SUM,err,ferr)){
2946 DestroyTermList();
2947 return 0;
2948 }
2949 break;
2950 case e_prod:
2951 if (AppendList(ref,rel,ExprBuiltinSet(start),PROD,err,ferr)){
2952 DestroyTermList();
2953 return 0;
2954 }
2955 break;
2956 case e_func:
2957 term = CreateFuncTerm(ExprFunc(start));
2958 AppendTermBuf(term);
2959 break;
2960 default:
2961 *err = incorrect_structure;
2962 FPRINTF(ASCERR,"incorrect_structure in ConvertExpr 2\n");
2963 DestroyTermList();
2964 return 0;
2965 }
2966 start = NextExpr(start);
2967 }
2968 result = ConvertTermBuf(newside);
2969 DestroyTermList();
2970 return result;
2971 /* we do not check result here. that is the callers job */
2972 }
2973
2974 static
2975 CONST struct Expr *FindRHS(CONST struct Expr *ex)
2976 {
2977 CONST struct Expr *rhs = NULL, *previous = NULL;
2978 unsigned depth=0;
2979 while(ex!=NULL){
2980 switch(ExprType(ex)){
2981 case e_zero:
2982 case e_var:
2983 case e_int:
2984 case e_real:
2985 case e_boolean:
2986 case e_set:
2987 case e_symbol:
2988 case e_card:
2989 case e_choice:
2990 case e_sum:
2991 case e_prod:
2992 case e_union:
2993 case e_inter:
2994 if ((++depth)==1) rhs = ex;
2995 break;
2996 /* binary operators */
2997 case e_plus:
2998 case e_minus:
2999 case e_times:
3000 case e_divide:
3001 case e_power:
3002 case e_ipower:
3003 case e_or:
3004 case e_and:
3005 case e_in:
3006 if ((--depth)==1) rhs = ex;
3007 break;
3008 case e_equal:
3009 case e_notequal:
3010 case e_less:
3011 case e_greater:
3012 case e_lesseq:
3013 case e_greatereq:
3014 if (NextExpr(ex)==NULL) {
3015 return NextExpr(rhs);
3016 } else {
3017 return NULL;
3018 }
3019 case e_func:
3020 case e_uminus:
3021 case e_not:
3022 if (depth==1) {
3023 rhs = ex;
3024 }
3025 break;
3026 case e_st:
3027 Asc_Panic(2, NULL, "Such that expressions are not allowed.\n");
3028 break;
3029 case e_minimize:
3030 case e_maximize:
3031 Asc_Panic(2, NULL,
3032 "Maximize and minimize are not allowed in expression.\n"
3033 "They are only allowed in relations.\n");
3034 break;
3035 default:
3036 Asc_Panic(2, NULL, "Unknown expression node type.\n");
3037 break;
3038 }
3039 previous = ex;
3040 ex = NextExpr(ex);
3041 }
3042 return NULL;
3043 }
3044
3045 /*********************************************************************\
3046 This code is to support the conversion from postfix to infix.
3047 \*********************************************************************/
3048
3049
3050 #define PopTermStack(stack) \
3051 ((struct relation_term *)gs_stack_pop((stack)))
3052 #define PushTermStack(stack,term) \
3053 (gs_stack_push((stack),(char*)(term)))
3054
3055 /*
3056 * *err = 0 if ok, 1 otherwise. Sets up infix pointers.
3057 */
3058 static struct relation_term
3059 *InfixArr_MakeSide(CONST struct relation_side_temp *tmp, int *err)
3060 {
3061 struct relation_term *term = NULL;
3062 struct relation_term *left;
3063 long len,count=0;
3064 struct gs_stack_t *stack;
3065 enum Expr_enum t;
3066
3067 *err = 0;
3068 len = tmp->length;
3069 stack = gs_stack_create(len);
3070 while(count < len) {
3071 term = A_TERM(&(tmp->side[count])); /* aka tmp->side+count */
3072 switch(t = RelationTermType(term)) {
3073 case e_var:
3074 case e_int:
3075 case e_real:
3076 case e_zero:
3077 gs_stack_push(stack,(char *)term);
3078 break;
3079 case e_func:
3080 left = A_TERM(gs_stack_pop(stack));
3081 F_TERM(term)->left = left;
3082 gs_stack_push(stack,(char *)term);
3083 break;
3084 case e_uminus:
3085 left = A_TERM(gs_stack_pop(stack));
3086 U_TERM(term)->left = left;
3087 gs_stack_push(stack,(char *)term);
3088 break;
3089 case e_plus:
3090 case e_minus:
3091 case e_times:
3092 case e_divide:
3093 case e_power:
3094 case e_ipower:
3095 B_TERM(term)->right = A_TERM(gs_stack_pop(stack));
3096 B_TERM(term)->left = A_TERM(gs_stack_pop(stack));
3097 gs_stack_push(stack,(char *)term);
3098 break;
3099 default:
3100 Asc_Panic(2, "MakeInfix",
3101 "Dont know this type of relation term in MakeInfix\n");
3102 break;
3103 }
3104 count++;
3105 }
3106 term = A_TERM(gs_stack_pop(stack));
3107 if (!gs_stack_empty(stack)) {
3108 /* ensure that the stack is empty */
3109 FPRINTF(ASCERR,"stacksize %ld\n",stack->size);
3110 FPRINTF(ASCERR,"Something screwy with Infix_MakeSide\n");
3111 *err = 1;
3112 }
3113 gs_stack_destroy(stack,0);
3114 return term;
3115 }
3116
3117 void DoInOrderVisit(struct relation_term *term,
3118 struct relation *r,
3119 void (*func)(struct relation_term *,
3120 struct relation *))
3121 {
3122 if (term) {
3123 switch(RelationTermType(term)) {
3124 case e_zero:
3125 case e_var:
3126 case e_int:
3127 case e_real:
3128 (*func)(term,r);
3129 break;
3130 case e_func:
3131 DoInOrderVisit(F_TERM(term)->left,r,func);
3132 (*func)(term,r);
3133 break;
3134 case e_uminus:
3135 DoInOrderVisit(U_TERM(term)->left,r,func);
3136 (*func)(term,r);
3137 break;
3138 case e_plus:
3139 case e_minus:
3140 case e_times:
3141 case e_divide:
3142 case e_power:
3143 case e_ipower:
3144 DoInOrderVisit(B_TERM(term)->left,r,func);
3145 (*func)(term,r);
3146 DoInOrderVisit(B_TERM(term)->right,r,func);
3147 break;
3148 default:
3149 return;
3150 }
3151 }
3152 }
3153
3154 #if 0 /* potential future use */
3155 /* tHis is a recursive deallocation of a term tree.
3156 It presupposes all terms are independently allocated,
3157 which at present is true nowhere in the compiler.
3158 It's a nice little function, though so we'll keep it in case,
3159 but not compile it in the meantime.
3160 Token relations term lists are not independently allocated.
3161 */
3162 void DestroyTermTree(struct relation_term *term)
3163 {
3164 if (term) {
3165 switch(term->t) {
3166 case e_plus:
3167 case e_minus:
3168 case e_times:
3169 case e_divide:
3170 case e_power:
3171 case e_ipower:
3172 DestroyTermTree(B_TERM(term)->left);
3173 DestroyTermTree(B_TERM(term)->right);
3174 ascfree((char *)term);
3175 term = NULL;
3176 break;
3177 case e_func:
3178 DestroyTermTree(F_TERM(term)->left);
3179 ascfree((char *)term);
3180 term = NULL;
3181 break;
3182 case e_uminus:
3183 DestroyTermTree(U_TERM(term)->left);
3184 break;
3185 case e_zero:
3186 case e_var:
3187 case e_int:
3188 case e_real:
3189 ascfree((char *)term);
3190 term = NULL;
3191 break;
3192 default:
3193 FPRINTF(ASCERR,"DestroyTermTree called with unexpected term type\n");
3194 break;
3195 }
3196 }
3197 }
3198 #endif
3199
3200 /*********************************************************************\
3201 Relation Processing for Instantiation.
3202 \*********************************************************************/
3203 static void DestroyTermSide(struct relation_side_temp *);
3204 void DestroyVarList(struct gl_list_t *, struct Instance *);
3205
3206 struct relation *CreateTokenRelation(struct Instance *reference,
3207 struct Instance *relinst,
3208 CONST struct Expr *ex,
3209 enum relation_errors *err,
3210 enum find_errors *ferr)
3211 {
3212 struct relation *result;
3213 CONST struct Expr *rhs_ex,*last_ex;
3214 int lhs,rhs;
3215 enum Expr_enum relop;
3216 struct relation_side_temp leftside,rightside;
3217 assert(reference&&relinst&&ex&&err&&ferr);
3218 g_relation_var_list = gl_create(20l);
3219 *err = okay;
3220 *ferr = correct_instance;
3221 last_ex = FindLastExpr(ex);
3222 switch(ExprType(last_ex)){
3223 case e_equal:
3224 case e_notequal:
3225 case e_less:
3226 case e_greater:
3227 case e_lesseq:
3228 case e_greatereq:
3229 relop = ExprType(last_ex);
3230 rhs_ex = FindRHS(ex);
3231 if (rhs_ex!=NULL){
3232 lhs = ConvertExpr(ex,rhs_ex,reference,relinst,err,ferr,&leftside);
3233 if(!lhs) {
3234 if (g_relation_var_list!=NULL) {
3235 DestroyVarList(g_relation_var_list,relinst);
3236 }
3237 g_relation_var_list = NULL;
3238 return NULL;
3239 }
3240 rhs = ConvertExpr(rhs_ex,last_ex,reference,relinst,err,ferr,&rightside);
3241 if(!rhs) {
3242 DestroyTermSide(&leftside);
3243 if (g_relation_var_list!=NULL) {
3244 DestroyVarList(g_relation_var_list,relinst);
3245 }
3246 g_relation_var_list = NULL;
3247 return NULL;
3248 }
3249 }
3250 else{
3251 *err = incorrect_structure;
3252 FPRINTF(ASCERR,"Error finding relational operator.\n");
3253 if (g_relation_var_list!=NULL) {
3254 DestroyVarList(g_relation_var_list,relinst);
3255 }
3256 g_relation_var_list = NULL;
3257 return NULL;
3258 }
3259 break;
3260 case e_maximize:
3261 case e_minimize:
3262 relop = ExprType(last_ex);
3263 rhs = 0;
3264 lhs=ConvertExpr(ex,last_ex,reference,relinst,err,ferr,&leftside);
3265 if (!lhs) {
3266 if (g_relation_var_list!=NULL) {
3267 DestroyVarList(g_relation_var_list,relinst);
3268 }
3269 g_relation_var_list = NULL;
3270 return NULL;
3271 }
3272 break;
3273 default:
3274 *err = incorrect_structure;
3275 ERROR_REPORTER_NOLINE(ASC_USER_ERROR,"Error expression missing relational operator.");
3276 if (g_relation_var_list!=NULL) {
3277 DestroyVarList(g_relation_var_list,relinst);
3278 }
3279 g_relation_var_list = NULL;
3280 return NULL;
3281 }
3282 result = CreateRelationStructure(relop,crs_NEWUNION);
3283 RelationRefCount(result) = 1;
3284 if (lhs) { /* always true */
3285 int status;
3286 RTOKEN(result).lhs_len = leftside.length;
3287 RTOKEN(result).lhs = leftside.side;
3288 RTOKEN(result).lhs_term = InfixArr_MakeSide(&leftside,&status);
3289 #ifndef NDEBUG
3290 if (status) {
3291 FPRINTF(ASCERR,"Anomaly in ");
3292 WriteInstanceName(ASCERR,relinst,NULL);
3293 FPRINTF(ASCERR," LHS.\n");
3294 }
3295 #endif
3296 }
3297 if (rhs) { /* sometimes true */
3298 int status;
3299 RTOKEN(result).rhs_len = rightside.length;
3300 RTOKEN(result).rhs = rightside.side;
3301 RTOKEN(result).rhs_term = InfixArr_MakeSide(&rightside,&status);
3302 #ifndef NDEBUG
3303 if (status) {
3304 FPRINTF(ASCERR,"Anomaly in ");
3305 WriteInstanceName(ASCERR,relinst,NULL);
3306 FPRINTF(ASCERR," RHS.\n");
3307 }
3308 #endif
3309 }
3310 result->vars = g_relation_var_list;
3311 g_relation_var_list = NULL;
3312 return result;
3313 }
3314
3315 /**************************************************************************\
3316 OpCodeRelation processing.
3317 \**************************************************************************/
3318
3319 struct relation *CreateOpCodeRelation(struct Instance *reference,
3320 struct Instance *relinst,
3321 CONST struct Expr *ex,
3322 enum relation_errors *err