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