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