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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 669 - (show annotations) (download) (as text)
Wed Jun 21 07:00:45 2006 UTC (13 years, 2 months ago) by johnpye
File MIME type: text/x-csrc
File size: 16304 byte(s)
Merged changes from DAE branch (revisions 702 to 819) back into trunk.
This adds the Integration API to the ASCEND solver (in base/generic).
Also provides pre-alpha support for 'IDA' from the SUNDIALS suite, a DAE solver.
Many other minor code clean-ups, including adoption of new 'ASC_NEW' and friends (to replace 'ascmalloc')
Added some very sketchy stuff providing 'DIFF(...)' syntax, although it is anticipated that this will be removed.
1 /*
2 * Ascend Instance Value Functions
3 * by Tom Epperly & Ben Allan
4 * 9/3/89
5 * Version: $Revision: 1.18 $
6 * Version control file: $RCSfile: atomvalue.c,v $
7 * Date last modified: $Date: 1998/03/26 20:39:31 $
8 * Last modified by: $Author: ballan $
9 *
10 * This file is part of the Ascend Language Interpreter.
11 *
12 * Copyright (C) 1996 Ben Allan
13 * based on instance.c
14 * Copyright (C) 1990, 1993, 1994 Thomas Guthrie Epperly
15 *
16 * The Ascend Language Interpreter is free software; you can redistribute
17 * it and/or modify it under the terms of the GNU General Public License as
18 * published by the Free Software Foundation; either version 2 of the
19 * License, or (at your option) any later version.
20 *
21 * The Ascend Language Interpreter is distributed in hope that it will be
22 * useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
23 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
24 * General Public License for more details.
25 *
26 * You should have received a copy of the GNU General Public License
27 * along with the program; if not, write to the Free Software Foundation,
28 * Inc., 675 Mass Ave, Cambridge, MA 02139 USA. Check the file named
29 * COPYING.
30 *
31 */
32 #include <stdarg.h>
33 #include <utilities/ascConfig.h>
34 #include <utilities/ascPanic.h>
35 #include <utilities/ascMalloc.h>
36 #include <general/list.h>
37 #include <general/dstring.h>
38 #include "compiler.h"
39 #include "symtab.h"
40 #include "fractions.h"
41 #include "dimen.h"
42 #include "functype.h"
43 #include "expr_types.h"
44 #include "child.h"
45 #include "type_desc.h"
46 #include "type_descio.h"
47 #include "instance_enum.h"
48 #include "instance_name.h"
49 #include "instance_io.h"
50 #include "instmacro.h"
51 #include "instquery.h"
52 #include "setinstval.h"
53 #include "setinst_io.h"
54 #include "instance_types.h"
55 #include "cmpfunc.h"
56 #include "atomvalue.h"
57
58 #ifndef lint
59 static CONST char AtomValueModuleID[] = "$Id: atomvalue.c,v 1.18 1998/03/26 20:39:31 ballan Exp $";
60 #endif
61
62 unsigned AtomAssigned(CONST struct Instance *i)
63 {
64 assert(i!=NULL);
65 AssertMemory(i);
66 if (i->t & ICONS) {
67 return CIASS(i);
68 }
69 switch(i->t) {
70 /* int */
71 case INTEGER_INST: return I_INST(i)->assigned;
72 case INTEGER_ATOM_INST: return IA_INST(i)->assigned;
73 /* real */
74 case REAL_INST: return R_INST(i)->assigned;
75 case REAL_ATOM_INST: return RA_INST(i)->assigned;
76 /* set */
77 case SET_INST: return (S_INST(i)->list!=NULL) ? 1 : 0;
78 case SET_ATOM_INST: return (SA_INST(i)->list!=NULL) ? 1 : 0;
79 /* symbol */
80 case SYMBOL_INST: return (SYM_INST(i)->value!=NULL) ? 1 : 0;
81 case SYMBOL_ATOM_INST: return (SYMA_INST(i)->value!=NULL) ? 1 : 0;
82 /* boolean */
83 case BOOLEAN_INST: return B_INST(i)->assigned;
84 case BOOLEAN_ATOM_INST: return BA_INST(i)->assigned;
85 default:
86 ERROR_REPORTER_NOLINE(ASC_USER_ERROR,"AtomAssigned called on non-atomic instance.");
87 return 0; /* not atomic, so can't very well be assigned, eh? */
88 /* used to be exit(2) */
89 /*NOTREACHED*/
90 }
91 }
92
93 unsigned AtomMutable(CONST struct Instance *i)
94 {
95 assert(i!=NULL);
96 AssertMemory(i);
97 if (i->t & ICONS) {
98 return !CIASS(i);
99 }
100 switch(i->t) {
101 case INTEGER_INST: return 1; /* always */
102 case INTEGER_ATOM_INST: return 1; /*always*/
103 case REAL_INST: return 1; /* always */
104 case REAL_ATOM_INST: return 1; /* always */
105 case SET_INST: return (S_INST(i)->list==NULL) ? 1 : 0;
106 case SET_ATOM_INST: return (SA_INST(i)->list==NULL) ? 1 : 0;
107 case SYMBOL_INST: return (SYM_INST(i)->value==NULL) ? 1 : 0;
108 case SYMBOL_ATOM_INST: return (SYMA_INST(i)->value==NULL) ? 1 : 0;
109 case BOOLEAN_INST: return 1; /* always */
110 case BOOLEAN_ATOM_INST: return 1; /* always */
111 default:
112 FPRINTF(ASCERR,"AtomMutable called on non-atomic instance.\n");
113 return 0; /* not atomic, so can't very well be mutable, eh? */
114 /* used to be exit(2) */
115 /*NOTREACHED*/
116 }
117 }
118
119 unsigned DepthAssigned(CONST struct Instance *i)
120 {
121 assert(i!=NULL);
122 AssertMemory(i);
123 switch(i->t){
124 case REAL_ATOM_INST:
125 return RA_INST(i)->depth;
126 case REAL_INST:
127 return R_INST(i)->depth;
128 case BOOLEAN_ATOM_INST:
129 return BA_INST(i)->depth;
130 case BOOLEAN_INST:
131 return B_INST(i)->depth;
132 default:
133 Asc_Panic(2, NULL, "Incorrect type passed to DepthAssigned.\n");
134 exit(2);/* Needed to keep gcc from whining */
135 }
136 }
137
138 double RealAtomValue(CONST struct Instance *i)
139 {
140 assert(i!=NULL);
141 AssertMemory(i);
142 switch(i->t) {
143 case REAL_INST:
144 return R_INST(i)->value;
145 case REAL_CONSTANT_INST:
146 return RC_INST(i)->value;
147 case REAL_ATOM_INST:
148 return RA_INST(i)->value;
149 default:
150 Asc_Panic(2, NULL, "RealAtomValue called on non-real instance.\n");
151 exit(2);/* Needed to keep gcc from whining */
152 }
153 }
154
155 void SetRealAtomValue(struct Instance *i, double d, unsigned int depth)
156 {
157 assert(i!=NULL);
158 AssertMemory(i);
159 switch(i->t) {
160 case REAL_CONSTANT_INST:
161 if (AtomAssigned(i)) {
162 ERROR_REPORTER_NOLINE(ASC_USER_ERROR,"SetRealAtomValue called on Constant instance.");
163 } else {
164 struct Instance *ptr;
165
166 RC_INST(i)->value = d;
167 RC_INST(i)->vflag |= ci_ASSIGNED;
168 /* assign rest of clique */
169 ptr = i;
170 while ((ptr=NextCliqueMember(ptr))!=i){
171 assert(ptr!=NULL);
172 RC_INST(i)->value = d;
173 RC_INST(i)->vflag |= ci_ASSIGNED;
174 }
175 }
176 break;
177 case REAL_INST:
178 R_INST(i)->assigned++;
179 R_INST(i)->value = d;
180 R_INST(i)->depth = depth;
181 break;
182 case REAL_ATOM_INST:
183 RA_INST(i)->assigned++;
184 RA_INST(i)->value = d;
185 RA_INST(i)->depth = depth;
186 break;
187 default:
188 Asc_Panic(2, NULL, "SetRealAtomValue called on non-real instance.\n");
189 }
190 }
191
192 void SetRealAtomDims(struct Instance *i, CONST dim_type *dim)
193 {
194 assert(i!=NULL);
195 AssertMemory(i);
196 switch(i->t) {
197 case REAL_CONSTANT_INST:
198 if ( IsWild(RC_INST(i)->dimen) ) {
199 struct Instance *ptr;
200
201 RC_INST(i)->dimen = dim;
202 /* assign rest of clique */
203 ptr = i;
204 while ((ptr=NextCliqueMember(ptr))!=i){
205 assert(ptr!=NULL);
206 RC_INST(ptr)->dimen = dim;
207 }
208 } else {
209 ERROR_REPORTER_NOLINE(ASC_PROG_ERROR,"SetRealAtomDims called on dimensioned constant.");
210 }
211 break;
212 case REAL_INST:
213 R_INST(i)->dimen = dim;
214 break;
215 case REAL_ATOM_INST:
216 RA_INST(i)->dimen = dim;
217 break;
218 default:
219 Asc_Panic(2, NULL, "SetRealAtomDims called on non-real instance.\n");
220 }
221 }
222
223 CONST dim_type *RealAtomDims(CONST struct Instance *i)
224 {
225 assert(i!=NULL);
226 AssertMemory(i);
227 switch(i->t) {
228 case REAL_INST:
229 return R_INST(i)->dimen;
230 case REAL_CONSTANT_INST:
231 return RC_INST(i)->dimen;
232 case REAL_ATOM_INST:
233 return RA_INST(i)->dimen;
234 default:
235 Asc_Panic(2, NULL, "RealAtomDims called on non-real instance.\n");
236 exit(2);/* Needed to keep gcc from whining */
237 }
238 }
239
240 long GetIntegerAtomValue(CONST struct Instance *i)
241 {
242 assert(i!=NULL);
243 AssertMemory(i);
244 switch(i->t) {
245 case INTEGER_INST:
246 return I_INST(i)->value;
247 case INTEGER_ATOM_INST:
248 return IA_INST(i)->value;
249 case INTEGER_CONSTANT_INST:
250 if (!CIASS(i)) {
251 FPRINTF(ASCERR,
252 "Warning GetIntegerAtomValue called on unassigned constant.\n");
253 }
254 return IC_INST(i)->value;
255 default:
256 Asc_Panic(2, "GetIntegerAtomValue",
257 "GetIntegerAtomValue called on non-integer instance.\n");
258 exit(2);/* Needed to keep gcc from whining */
259 }
260 }
261
262 void SetIntegerAtomValue(struct Instance *i, long int v,unsigned d)
263 {
264 assert(i!=NULL);
265 AssertMemory(i);
266 switch(i->t) {
267 case INTEGER_ATOM_INST:
268 IA_INST(i)->value = v;
269 IA_INST(i)->assigned++;
270 IA_INST(i)->depth = d;
271 break;
272 case INTEGER_INST:
273 I_INST(i)->value = v;
274 I_INST(i)->assigned++;
275 I_INST(i)->depth = d;
276 break;
277 case INTEGER_CONSTANT_INST:
278 if (CIASS(i)) {
279 FPRINTF(ASCERR,"SetIntegerAtomValue called on Constant instance.\n");
280 } else {
281 struct Instance *ptr;
282
283 IC_INST(i)->value = v;
284 IC_INST(i)->vflag |= ci_ASSIGNED;
285 /* assign rest of clique */
286 ptr = i;
287 while ((ptr=NextCliqueMember(ptr))!=i){
288 assert(ptr!=NULL);
289 IC_INST(i)->value = v;
290 IC_INST(i)->vflag |= ci_ASSIGNED;
291 }
292 }
293 break;
294 default:
295 Asc_Panic(2, NULL, "SetIntegerAtomValue called on non-integer.\n");
296 }
297 }
298
299 int GetBooleanAtomValue(CONST struct Instance *i)
300 {
301 assert(i!=NULL);
302 AssertMemory(i);
303 switch(i->t) {
304 case BOOLEAN_INST:
305 return B_INST(i)->value;
306 case BOOLEAN_ATOM_INST:
307 return BA_INST(i)->value;
308 case BOOLEAN_CONSTANT_INST:
309 if (!CIASS(i)) {
310 FPRINTF(ASCERR,
311 "Warning GetBooleanAtomValue called on unassigned constant.\n");
312 }
313 return BCV(i);
314 default:
315 Asc_Panic(2, "GetBooleanAtomValue",
316 "GetBooleanAtomValue called on non-boolean instance.\n");
317 exit(2);/* Needed to keep gcc from whining */
318 }
319 }
320
321 void SetBooleanAtomValue(struct Instance *i, int truth, unsigned int depth)
322 {
323 assert(i!=NULL);
324 AssertMemory(i);
325 switch(i->t) {
326 case BOOLEAN_INST:
327 B_INST(i)->value = truth ? 1 : 0;
328 B_INST(i)->assigned++;
329 B_INST(i)->depth = depth;
330 break;
331 case BOOLEAN_ATOM_INST:
332 BA_INST(i)->value = truth ? 1 : 0;
333 BA_INST(i)->assigned++;
334 BA_INST(i)->depth = depth;
335 break;
336 case BOOLEAN_CONSTANT_INST:
337 if (CIASS(i)) {
338 FPRINTF(ASCERR,"SetBooleanAtomValue called on Constant instance.\n");
339 } else {
340 struct Instance *ptr;
341
342 if (truth) {
343 BC_INST(i)->vflag |= (ci_BVAL | ci_ASSIGNED);
344 } else {
345 /* never assigned, and inited to FALSE, so turn on assigned flag*/
346 BC_INST(i)->vflag |= ci_ASSIGNED;
347 }
348 /* assign rest of clique */
349 ptr = i;
350 while ((ptr=NextCliqueMember(ptr))!=i){
351 assert(ptr!=NULL);
352 if (truth) {
353 BC_INST(i)->vflag |= (ci_BVAL | ci_ASSIGNED);
354 } else {
355 /* never assigned, and inited to FALSE, so turn on assigned flag*/
356 BC_INST(i)->vflag |= ci_ASSIGNED;
357 }
358 }
359 }
360 break;
361 default:
362 Asc_Panic(2, NULL, "SetBooleanAtomValue",
363 "SetBooleanAtomValue called on non-boolean instance.\n");
364 }
365 }
366
367 int AssignSetAtomList(struct Instance *i, struct set_t *list)
368 {
369 assert(i!=NULL);
370 AssertMemory(i);
371 switch(i->t) {
372 case SET_ATOM_INST:
373 if ((SetKind(list)!=empty_set)&&
374 ((SA_INST(i)->int_set==1)!=(SetKind(list)==integer_set))){
375 FPRINTF(ASCERR,"AssignSetAtomList called with mismatching set:\n");
376 WriteInstSet(ASCERR,list);
377 FPRINTF(ASCERR,"for set OF %s\n",
378 (SA_INST(i)->int_set==1) ?
379 SCP(GetBaseTypeName(integer_constant_type)) :
380 SCP(GetBaseTypeName(symbol_constant_type)) );
381 return 0;
382 }
383 if (SA_INST(i)->list != NULL) {
384 FPRINTF(ASCERR,"AssignSetAtomList called on fixed set instance.\n");
385 if (SetsEqual(list,SA_INST(i)->list)){ /* benign assignment */
386 FPRINTF(ASCERR,
387 "The assignment is benign(assigns the same value), %s %s.\n",
388 "so the program can continue\nrunning. Report this message to",
389 ASC_MILD_BUGMAIL);
390 FPRINTF(ASCERR,"and or stop writing buggy models.\n");
391 DestroySet(SA_INST(i)->list);
392 } else {
393 return 0;
394 }
395 }
396 SA_INST(i)->list = list;
397 return 1;
398 case SET_INST:
399 if ((SetKind(list)!=empty_set)&&
400 ((S_INST(i)->int_set==1)!=(SetKind(list)==integer_set))){
401 FPRINTF(ASCERR,"AssignSetAtomList called with mismatching set:\n");
402 WriteInstSet(ASCERR,list);
403 FPRINTF(ASCERR,"\n");
404 return 0;
405 }
406 if (S_INST(i)->list != NULL) {
407 FPRINTF(ASCERR,"AssignSetAtomList called on fixed set instance.\n");
408 if (SetsEqual(list,S_INST(i)->list)){ /* benign assignment */
409 FPRINTF(ASCERR,
410 "The assignment is benign(assigns the same value), %s %s.\n",
411 "so the program can continue\nrunning. Report this message to",
412 ASC_MILD_BUGMAIL);
413 FPRINTF(ASCERR,"and or stop writing buggy models.\n");
414 DestroySet(S_INST(i)->list);
415 } else {
416 return 0;
417 }
418 }
419 S_INST(i)->list = list;
420 return 1;
421 default:
422 FPRINTF(ASCERR,"AssignSetAtomList called on non-set instance.\n");
423 return 0;
424 }
425 }
426
427 CONST struct set_t *SetAtomList(CONST struct Instance *i)
428 {
429 assert(i!=NULL);
430 AssertMemory(i);
431 switch (i->t) {
432 case SET_INST:
433 return S_INST(i)->list;
434 case SET_ATOM_INST:
435 return SA_INST(i)->list;
436 default:
437 Asc_Panic(2, NULL, "SetAtomList called on non-set instance.\n");
438 exit(2);/* Needed to keep gcc from whining */
439 }
440 }
441
442 int GetSetAtomKind(CONST struct Instance *i)
443 {
444 assert(i!=NULL);
445 AssertMemory(i);
446 switch (i->t) {
447 case SET_INST:
448 return (int)(S_INST(i)->int_set);
449 case SET_ATOM_INST:
450 return (int)(SA_INST(i)->int_set);
451 default:
452 Asc_Panic(2, NULL, "GetSetAtomKind called on non-set instance.\n");
453 exit(2);/* Needed to keep gcc from whining */
454 }
455 }
456
457 symchar *GetSymbolAtomValue(CONST struct Instance *i)
458 {
459 assert(i!=NULL);
460 AssertMemory(i);
461 switch(i->t){
462 case SYMBOL_INST:
463 return SYM_INST(i)->value;
464 case SYMBOL_ATOM_INST:
465 return SYMA_INST(i)->value;
466 case SYMBOL_CONSTANT_INST:
467 if (!CIASS(i)) {
468 FPRINTF(ASCERR,
469 "Warning GetSymbolAtomValue called on unassigned constant.\n");
470 }
471 return SYMC_INST(i)->value;
472 default:
473 Asc_Panic(2, NULL, "GetSymbolAtomValue called on non-symbol instance.\n");
474 exit(2);/* Needed to keep gcc from whining */
475 }
476 }
477
478 /*
479 * 02/26/97.
480 * Eliminating the restriction of assigning only once a SYMBOL_INST and
481 * SYMBOL_ATOM_INST. Actually, it was only disabled with an if. VRR.
482 */
483
484 void SetSymbolAtomValue(struct Instance *i, symchar *str)
485 {
486 assert(i!=NULL);
487 AssertMemory(i);
488 assert(AscFindSymbol(str)!=NULL);
489 switch(i->t){
490 case SYMBOL_INST:
491 SYM_INST(i)->value = str;
492 break;
493 case SYMBOL_ATOM_INST:
494 SYMA_INST(i)->value = str;
495 break;
496 case SYMBOL_CONSTANT_INST:
497 if (CIASS(i)) {
498 FPRINTF(ASCERR,"SetSymbolAtomValue called on Constant instance.\n");
499 FPRINTF(ASCERR,"Old symbol retained: %s.\n",SCP(SYMC_INST(i)->value));
500 FPRINTF(ASCERR,"New symbol ignored: %s.\n",SCP(str));
501 } else {
502 struct Instance *ptr;
503
504 SYMC_INST(i)->value = str;
505 SYMC_INST(i)->vflag |= ci_ASSIGNED;
506 /* assign rest of clique */
507 ptr = i;
508 while ((ptr=NextCliqueMember(ptr))!=i){
509 assert(ptr!=NULL);
510 SYMC_INST(i)->value = str;
511 }
512 }
513 break;
514 default:
515 Asc_Panic(2, NULL, "SetSymbolAtomValue called on non-symbol instance.\n");
516 }
517 }
518
519 int CmpAtomValues(CONST struct Instance *i1, CONST struct Instance *i2)
520 {
521 if (i1==i2) {
522 return 0;
523 }
524 if (i1==NULL) {
525 return -1;
526 }
527 if (i2 == NULL) {
528 return 1;
529 }
530 if (InstanceKind(i1) != InstanceKind(i2)) {
531 FPRINTF(ASCERR,"CmpAtomValues called with mismatched ATOM types\n");
532 return (((int)InstanceKind(i1) - (int)InstanceKind(i2)) < 0) ? -1 : 1;
533 }
534 if (InstanceKind(i1) & ISET) {
535 /* even unassigned sets have a kind that is effectively an instkind */
536 if (GetSetAtomKind(i2) != GetSetAtomKind(i1)) {
537 return (GetSetAtomKind(i2)-GetSetAtomKind(i1));
538 }
539 }
540 if (AtomAssigned(i1) != AtomAssigned(i2)){
541 if (AtomAssigned(i1)==0) {
542 return -1;
543 } else {
544 return 1;
545 }
546 }
547 switch (InstanceKind(i1)) {
548 case SYMBOL_INST:
549 case SYMBOL_ATOM_INST:
550 case SYMBOL_CONSTANT_INST:
551 return CmpSymchar(GetSymbolAtomValue(i1),GetSymbolAtomValue(i2));
552 case REAL_INST:
553 case REAL_ATOM_INST:
554 case REAL_CONSTANT_INST:
555 if (RealAtomValue(i1) != RealAtomValue(i2)) {
556 return ( RealAtomValue(i1) < RealAtomValue(i2)) ? 1 : -1;
557 } else {
558 return CmpDimen(RealAtomDims(i1),RealAtomDims(i2));
559 }
560 case INTEGER_INST:
561 case INTEGER_ATOM_INST:
562 case INTEGER_CONSTANT_INST:
563 if (GetIntegerAtomValue(i1) != GetIntegerAtomValue(i2)) {
564 return ( GetIntegerAtomValue(i1) < GetIntegerAtomValue(i2)) ? 1 : -1;
565 }
566 return 0;
567 case BOOLEAN_INST:
568 case BOOLEAN_ATOM_INST:
569 case BOOLEAN_CONSTANT_INST:
570 if (GetBooleanAtomValue(i1) != GetBooleanAtomValue(i2)) {
571 return ( GetBooleanAtomValue(i1) == 0) ? 1 : -1;
572 }
573 return 0;
574 case SET_INST:
575 case SET_ATOM_INST:
576 return CmpSetInstVal(SetAtomList(i1),SetAtomList(i2));
577 default:
578 Asc_Panic(2, NULL, "Bad call to CmpAtomValues!\n");
579 exit(2);/* Needed to keep gcc from whining */
580 break;
581 }
582 }

john.pye@anu.edu.au
ViewVC Help
Powered by ViewVC 1.1.22