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