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