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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations) (download) (as text)
Fri Oct 29 20:54:12 2004 UTC (15 years, 1 month ago) by aw0a
Original Path: trunk/ascend4/compiler/instantiate.c
File MIME type: text/x-csrc
File size: 383462 byte(s)
Setting up web subdirectory in repository
1 /*
2 * Ascend Instantiator Implementation
3 * by Tom Epperly
4 * Created: 1/24/90
5 * Version: $Revision: 1.84 $
6 * Version control file: $RCSfile: instantiate.c,v $
7 * Date last modified: $Date: 2003/02/06 04:08:30 $
8 * Last modified by: $Author: ballan $
9 *
10 * This file is part of the Ascend Language Interpreter.
11 *
12 * Copyright (C) 1990, 1993, 1994 Thomas Guthrie Epperly
13 * Copyright (C) 1997 Benjamin Allan, Vicente Rico-Ramirez
14 *
15 * The Ascend Language Interpreter is free software; you can redistribute
16 * it and/or modify it under the terms of the GNU General Public License as
17 * published by the Free Software Foundation; either version 2 of the
18 * License, or (at your option) any later version.
19 *
20 * The Ascend Language Interpreter is distributed in hope that it will be
21 * useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
22 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
23 * General Public License for more details.
24 *
25 * You should have received a copy of the GNU General Public License
26 * along with the program; if not, write to the Free Software Foundation,
27 * Inc., 675 Mass Ave, Cambridge, MA 02139 USA. Check the file named
28 * COPYING.
29 *
30 */
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/dstring.h"
38 #include "compiler/compiler.h"
39 #if TIMECOMPILER
40 #include <time.h>
41 #include "general/tm_time.h"
42 #endif
43 #include "compiler/bit.h"
44 #include "compiler/symtab.h"
45 #include "compiler/fractions.h"
46 #include "compiler/dimen.h"
47 #include "compiler/functype.h"
48 #include "compiler/types.h"
49 #include "compiler/instance_enum.h"
50 #include "compiler/stattypes.h"
51 #include "compiler/statement.h"
52 #include "compiler/child.h"
53 #include "compiler/type_desc.h"
54 #include "compiler/type_descio.h"
55 #include "compiler/module.h"
56 #include "compiler/library.h"
57 #include "compiler/sets.h"
58 #include "compiler/setio.h"
59 #include "compiler/extfunc.h"
60 #include "compiler/extcall.h"
61 #include "compiler/dimen.h"
62 #include "compiler/forvars.h"
63 #include "compiler/exprs.h"
64 #include "compiler/name.h"
65 #include "compiler/nameio.h"
66 #include "compiler/vlist.h"
67 #include "compiler/slist.h"
68 #include "compiler/evaluate.h"
69 #include "compiler/value_type.h"
70 #include "compiler/statio.h"
71 #include "compiler/pending.h"
72 #include "compiler/find.h"
73 #include "compiler/relation_type.h"
74 #include "compiler/relation.h"
75 #include "compiler/logical_relation.h"
76 #include "compiler/logrelation.h"
77 #include "compiler/relation_util.h"
78 #include "compiler/logrel_util.h"
79 #include "compiler/instance_types.h"
80 #include "compiler/cmpfunc.h"
81 #include "compiler/instance_io.h"
82 #include "compiler/when.h"
83 #include "compiler/case.h"
84 #include "compiler/when_util.h"
85 #include "compiler/select.h"
86 /* new headers */
87 #include "compiler/atomvalue.h"
88 #include "compiler/arrayinst.h"
89 #include "compiler/copyinst.h"
90 #include "compiler/createinst.h"
91 #include "compiler/destroyinst.h"
92 #include "compiler/extinst.h"
93 #include "compiler/visitinst.h"
94 #include "compiler/instquery.h"
95 #include "compiler/mathinst.h"
96 #include "compiler/mergeinst.h"
97 #include "compiler/parentchild.h"
98 #include "compiler/refineinst.h"
99 #include "compiler/check.h"
100 #include "compiler/instance_name.h"
101 #include "compiler/setinstval.h"
102 #include "compiler/anontype.h"
103 #include "compiler/anoncopy.h"
104 #include "compiler/parpend.h"
105 #include "compiler/parpend.h"
106 #include "compiler/bintoken.h"
107 #include "compiler/watchpt.h"
108 #include "compiler/initialize.h"
109 #include "compiler/instantiate.h"
110 /* don't even THINK ABOUT adding instmacro.h to this list */
111
112 #define MAXNUMBER 4 /* maximum number of iterations allowed
113 * without change */
114 #define PASS2MAXNUMBER 1 /* maximum number of iterations allowed
115 * without change doing relations. In
116 * system where rels reference rels, > 1 */
117
118 #define PASS3MAXNUMBER 4 /* maximum number of iterations allowed
119 * without change doing logical relations.
120 * In system where logrels reference logrels,
121 * > 1 */
122
123 #define PASS4MAXNUMBER 1 /* maximum number of iterations allowed
124 * without change executing WHEN. In
125 * system where WHEN reference WHEN, > 1 */
126
127 #define AVG_CASES 2L /* size to which all cases lists are */
128 /* initialized (WHEN instance) */
129 #define AVG_REF 2L /* size to which all list of references */
130 /* in a case are initialized (WHEN) */
131
132 #define NO_INCIDENCES 7 /* avg number of vars in a external reln */
133
134 static int g_iteration = 0; /* the current iteration. */
135
136
137 /*************************************************************************\
138 variable to check agreement in the number of boolean, integer or symbol
139 variables in the WHEN/SELECT statement with the number of boolean, integer
140 or symbol values in each of the CASEs
141 \*************************************************************************/
142
143 #define MAX_VAR_IN_LIST 20
144
145 /*
146 * Variables to switch old and new pass 2 instantiation.
147 * The condition for using new pass 2 (anonymous type-based
148 * relation copying) is g_use_copyanon != 0
149 * || FORCE applied.
150 */
151
152 int g_use_copyanon = 1;
153 /* g_use_copyanon is the user switch for anonymous type based relation
154 * copying. if 0, no copying by that method is done.
155 */
156
157 #if TIMECOMPILER
158 static
159 int g_ExecuteREL_CreateTokenRelation_calls = 0;
160 /* count the number of calls to CreateTokenRelation from ExecuteREL */
161 int g_CopyAnonRelation = 0;
162 #endif
163
164 long int g_compiler_counter = 1;
165 /*
166 * What: counter incremented every time a compiler action capable of
167 * changing the instance tree is executed.
168 * At present the compiler cares nothing about this counter,
169 * but it is provided as a service to clients.
170 *
171 * Real applications:
172 * 1) This variable is used for keeping track of calls to
173 * the compiler which will create the need for a total solver system
174 * rebuild. This variable should be incremented anytime a function
175 * which changes the instance tree is called.
176 */
177
178 #define DEBUG_RELS 1
179 /* undef DEBUG_RELS if you want less spew in pass 2 */
180
181 #ifdef DEBUG_RELS
182 /* root of tree being visited in pass 2. */
183 struct Instance *debug_rels_work;
184 #endif /* dbgrels */
185
186 static unsigned
187 int g_instantiate_relns = ALLRELS; /* default is to do all rels */
188
189 /* pointer to possible error message for child expansion.
190 * messy way of error handling; do not imitate.
191 */
192 static char *g_trychildexpansion_errmessage = NULL;
193 #define TCEM g_trychildexpansion_errmessage
194
195 /* error messages */
196 #define REDEFINE_CHILD_MESG "IS_A statement attempting to redefine child "
197 #define REDEFINE_CHILD_MESG2 "ALIASES statement attempting to redefine child "
198 #define UNDEFINED_TYPE_MESG "IS_A statement refers to undefined type "
199 #define IRT_UNDEFINED_TYPE "IS_REFINED_TO statement refers to undefined type "
200 #define REASSIGN_MESG1 "Attempt to reassign constant "
201 #define REASSIGN_MESG2 " value."
202
203 #ifndef lint
204 static CONST char InstantiatorRCSid[] = "$Id: instantiate.c,v 1.84 2003/02/06 04:08:30 ballan Exp $";
205 #endif
206
207
208 /************************* forward declarations ************************/
209
210 static
211 void WriteForValueError(struct Statement *, struct value_t);
212 static
213 void MakeInstance(CONST struct Name *, struct TypeDescription *, int,
214 struct Instance *, struct Statement *, struct Instance *);
215 static
216 int CheckVarList(struct Instance *, struct Statement *);
217 static
218 int CheckWhereStatements(struct Instance *,struct StatementList *);
219 static
220 int ExecuteISA(struct Instance *, struct Statement *);
221 static
222 int ExecuteCASGN(struct Instance *, struct Statement *);
223 static
224 int DigestArguments(struct Instance *,
225 struct gl_list_t *, struct StatementList *,
226 struct StatementList *, struct Statement *);
227 static
228 int DeriveSetType(CONST struct Set *, struct Instance *,CONST unsigned int);
229
230 static
231 struct gl_list_t *FindInsts(struct Instance *, CONST struct VariableList *,
232 enum find_errors *);
233
234 static
235 void MissingInsts(struct Instance *, CONST struct VariableList *,int);
236 static
237 struct gl_list_t *FindArgInsts(struct Instance *, struct Set *,
238 enum find_errors *);
239 static void AddIncompleteInst(struct Instance *);
240 static int CheckALIASES(struct Instance *, struct Statement *);
241 static int CheckARR(struct Instance *, struct Statement *);
242 static int CheckISA(struct Instance *, struct Statement *);
243 static
244 int AssignStructuralValue(struct Instance *,struct value_t,struct Statement *);
245 static int CheckSELECT(struct Instance *, struct Statement *);
246 static int CheckWHEN(struct Instance *, struct Statement *);
247 static void MakeRealWhenCaseReferencesFOR(struct Instance *,
248 struct Instance *,
249 struct Statement *,
250 struct gl_list_t *);
251 static void MakeWhenCaseReferencesFOR(struct Instance *,
252 struct Instance *,
253 struct Statement *,
254 struct gl_list_t *);
255 static int Pass1CheckFOR(struct Instance *, struct Statement *);
256 static int Pass1ExecuteFOR(struct Instance *, struct Statement *);
257 #ifdef THIS_IS_AN_UNUSED_FUNCTION
258 static int Pass1RealCheckFOR(struct Instance *, struct Statement *);
259 #endif /* THIS_IS_AN_UNUSED_FUNCTION */
260 static void Pass1RealExecuteFOR(struct Instance *, struct Statement *);
261 static int Pass2CheckFOR(struct Instance *, struct Statement *);
262 static int Pass2ExecuteFOR(struct Instance *, struct Statement *);
263 static void Pass2FORMarkCond(struct Instance *, struct Statement *);
264 static void Pass2FORMarkCondRelations(struct Instance *, struct Statement *);
265 static int Pass2RealCheckFOR(struct Instance *, struct Statement *);
266 static int Pass2RealExecuteFOR(struct Instance *, struct Statement *);
267 static int Pass3CheckFOR(struct Instance *, struct Statement *);
268 static int Pass3ExecuteFOR(struct Instance *, struct Statement *);
269 static int Pass3RealCheckFOR (struct Instance *, struct Statement *);
270 static int Pass3RealExecuteFOR(struct Instance *, struct Statement *);
271 static void Pass3FORMarkCond(struct Instance *, struct Statement *);
272 static void Pass3FORMarkCondLogRels(struct Instance *, struct Statement *);
273 static int Pass4CheckFOR(struct Instance *, struct Statement *);
274 static int Pass4ExecuteFOR(struct Instance *, struct Statement *);
275 static int Pass4RealCheckFOR(struct Instance *, struct Statement *);
276 static int ExecuteUnSelectedForStatements(struct Instance *,
277 struct StatementList *);
278 static void ExecuteDefault(struct Instance *, struct Statement *,
279 unsigned long int *);
280 static void RealDefaultFor(struct Instance *, struct Statement *,
281 unsigned long int *);
282 static void DefaultStatementList(struct Instance *, struct gl_list_t *,
283 unsigned long int *);
284 static void ExecuteDefaultStatements(struct Instance *, struct gl_list_t *,
285 unsigned long int *);
286 static int ExecuteSELECT(struct Instance *, unsigned long *,
287 struct Statement *);
288 static void ExecuteDefaultsInSELECT(struct Instance *, unsigned long *,
289 struct Statement *, unsigned long int *);
290 static void RealExecuteWHEN(struct Instance *, struct Statement *);
291 static int ExecuteUnSelectedSELECT(struct Instance *, unsigned long *,
292 struct Statement *);
293 static void ExecuteUnSelectedStatements(struct Instance *i,unsigned long *,
294 struct StatementList *);
295 static void ExecuteUnSelectedWhenStatements(struct Instance *,
296 struct StatementList *);
297 static int ExecuteUnSelectedWHEN(struct Instance *, struct Statement *);
298 static void ReEvaluateSELECT(struct Instance *, unsigned long *,
299 struct Statement *, int, int *);
300
301 /***************************************************************************/
302
303
304 static
305 void ClearIteration(void)
306 {
307 g_iteration = 0;
308 }
309
310 static
311 void WriteStatementLocation(FILE *f, struct Statement *stat)
312 {
313 if (stat!= NULL){
314 FPRINTF(f,"\nStatement located on line %lu of %s.\n",
315 StatementLineNum(stat),
316 Asc_ModuleBestName(StatementModule(stat)));
317 }
318 else
319 FPRINTF(f,"NULL statement.\n");
320 }
321
322 static
323 void WriteSetError(struct Statement *statement, struct TypeDescription *def)
324 {
325 WSEM(ASCERR,statement, (GetBaseType(def) == set_type) ?
326 "No set type specified in IS_A statement"
327 : "Set type specified for a non-set type");
328 }
329
330 /*
331 * This code will emit error messages only on the last
332 * iteration when trying to clear pending statements.
333 * g_iteration is the global iteration counter, and MAXNUMBER
334 * is the number of times that the instantiator will try
335 * to clear the list, without change.
336 */
337 static
338 void WriteUnexecutedMessage(FILE *f, struct Statement *stat, CONST char *msg)
339 {
340 if (g_iteration>=(MAXNUMBER)) WSSM(f,stat,msg,0);
341 }
342
343
344 /*
345 * Write Unexecuted Error Message in Pass 3 WUEMPASS3
346 *
347 * This code will emit error messages only on the last
348 * iteration of pass3 when trying to clear pending statements.
349 * g_iteration is the global iteration counter, and PASS3MAXNUMBER
350 * is the number of times that the instantiator will try
351 * to clear the list, without change.
352 */
353
354 static
355 void WUEMPASS3(FILE *f, struct Statement *stat, CONST char *msg)
356 {
357 if (g_iteration>=(PASS3MAXNUMBER)) WSSM(f,stat,msg,0);
358 }
359
360
361 /***************************************************************\
362 dense array processing, mostly.
363 \***************************************************************/
364
365 /*
366 * returns 0 if c is NULL, probably should be -1.
367 * -2 if c is illegal set type
368 * 1 if c IS_A integer_constant set type
369 * 0 if c IS_A symbol_constant set type
370 * statement is used only to issue error messages.
371 */
372 static
373 int CalcSetType(symchar *c, struct Statement *statement)
374 {
375 struct TypeDescription *desc;
376 if (c==NULL) return 0;
377 if ((desc = FindType(c)) != NULL){
378 switch(GetBaseType(desc)){
379 case integer_constant_type: return 1;
380 case symbol_constant_type: return 0;
381 default:
382 WSEM(ASCERR,statement, "Incorrect set type in IS_A");
383 /* lint should keep us from ever getting here */
384 return -2;
385 }
386 } else{
387 WSEM(ASCERR,statement, "Unable to determine type of set.");
388 return -2;
389 }
390 }
391
392 /* last minute check for set values that subscript arrays.
393 * probably should check constantness too but does not.
394 * return 0 if ok, 1 if not.
395 */
396 static
397 int CheckSetVal(struct value_t setval)
398 {
399 if (ValueKind(setval) != set_value) {
400 switch (ValueKind(setval)) {
401 case integer_value:
402 TCEM = "Incorrectly integer-valued array range.";
403 break;
404 case symbol_value:
405 TCEM = "Incorrect symbol-valued array range.";
406 break;
407 case real_value:
408 TCEM = "Incorrect real-valued array subscript.";
409 break;
410 case boolean_value:
411 TCEM = "Incorrect boolean-valued array subscript.";
412 break;
413 case list_value:
414 TCEM = "Incorrect list-valued array subscript.";
415 break;
416 case error_value:
417 switch (ErrorValue(setval)) {
418 case type_conflict:
419 TCEM = "Set expression type conflict in array subscript.";
420 break;
421 default:
422 TCEM = "Generic error 1 in array subscript.";
423 break;
424 }
425 break;
426 case set_value: /* really weird if this happens, since if eliminated it */
427 break;
428 default:
429 TCEM = "Generic error 2 in array subscript.";
430 break;
431 }
432 return 1;
433 }
434 return 0;
435 }
436 /* This attempts to evaluate a the next undone subscript of the
437 * array and call ExpandArray with that set value.
438 * In the case of ALIAS arrays this must always succeed, because
439 * we have checked first that it will. If it did not we would
440 * be stuck because later calls to ExpandArray will not know
441 * the difference between the unexpanded alias array and the
442 * unexpanded IS_A array.
443 * Similarly, in the case of parameterized arrays this must
444 * always succeed, OTHERWISE ExpandArray will not know the
445 * arguments of the IS_A type, arginst next time around.
446 *
447 * In the event that the set given or set value expanded is bogus,
448 * returns 1 and statement from which this call was derived is
449 * semantically garbage.
450 */
451 static
452 int ValueExpand(struct Instance *i, unsigned long int pos,
453 struct value_t value, int *changed,
454 struct Instance *rhsinst, struct Instance *arginst,
455 struct gl_list_t *rhslist)
456 {
457 struct value_t setval;
458 switch(ValueKind(value)){
459 case list_value:
460 setval = CreateSetFromList(value);
461 if (CheckSetVal(setval)) {
462 return 1;
463 }
464 ExpandArray(i,pos,SetValue(setval),rhsinst,arginst,rhslist);
465 /* this may modify the pending instance list if
466 * rhslist and rhsinst both == NULL.
467 */
468 *changed = 1;
469 DestroyValue(&setval);
470 break;
471 case error_value:
472 switch(ErrorValue(value)){
473 case name_unfound:
474 case undefined_value:
475 break;
476 default:
477 TCEM = "Array instance has incorrect index type.";
478 return 1;
479 }
480 break;
481 default:
482 TCEM = "Array instance has incorrect index value type.";
483 return 1;
484 }
485 return 0;
486 }
487
488 /* When an incorrect combination of sparse and dense indices is found,
489 * marks the statement wrong and whines. If the statement has already
490 * been marked wrong, does not whine.
491 * In FOR loops,
492 * this function warns about a problem that the implementation really
493 * should allow. Alas, the fix is pending a complete rework of arrays.
494 * In user is idiot case,
495 * this really should have been ruled out by checkisa, which lets a little
496 * too much trash through. Our whole array implementation sucks.
497 */
498 static
499 void SignalChildExpansionFailure(struct Instance *work,unsigned long cnum)
500 {
501 struct TypeDescription *desc;
502 ChildListPtr clp;
503 struct Statement *statement;
504
505 assert(work!= NULL);
506 assert(cnum!= 0);
507 assert(InstanceKind(work)==MODEL_INST);
508 desc = InstanceTypeDesc(work);
509 clp = GetChildList(desc);
510 statement = (struct Statement *)ChildStatement(clp,cnum);
511 if ( StatWrong(statement) != 0) {
512 return;
513 }
514 if (TCEM != NULL) {
515 FPRINTF(ASCERR,"%s\n",TCEM);
516 TCEM = NULL;
517 }
518 if (StatInFOR(statement)) {
519 MarkStatContext(statement,context_WRONG);
520 WSEM(ASCERR,statement, "Add another FOR index. In FOR loops,"
521 " all array subscripts must be scalar values, not sets.");
522 WSS(ASCERR,statement);
523 } else {
524 MarkStatContext(statement,context_WRONG);
525 WSEM(ASCERR,statement, "Subscripts of conflicting or incorrect types"
526 " in rectangular array.");
527 WSS(ASCERR,statement);
528 }
529 return;
530 }
531
532 /*
533 * Should never be called with BOTH rhs(inst/list) and arginst != NULL,
534 * but one or both may be NULL depending on other circumstances.
535 * Should never be called on ALIASES/IS_A inside a for loop.
536 * Returns an error number other than 0 if called inside a for loop.
537 * If error, outer scope should mark statement incorrect.
538 */
539 static
540 int TryChildExpansion(struct Instance *child,
541 struct Instance *parent,
542 int *changed,
543 struct Instance *rhsinst,
544 struct Instance *arginst,
545 struct gl_list_t *rhslist)
546 {
547 unsigned long pos,oldpos=0;
548 struct value_t value;
549 CONST struct Set *setp;
550 int error=0;
551 assert(arginst==NULL || (rhsinst==NULL && rhslist==NULL));
552 /* one must be NULL as alii do not have args */
553 while((pos=NextToExpand(child))>oldpos){
554 oldpos=pos;
555 setp = IndexSet(child,pos);
556 if (GetEvaluationContext() != NULL) {
557 error++;
558 FPRINTF(ASCERR,"TryChildExpansion with mixed instance\n");
559 } else {
560 SetEvaluationContext(parent); /* could be wrong for mixed style arrays */
561 value = EvaluateSet(setp,InstanceEvaluateName);
562 SetEvaluationContext(NULL);
563 if (ValueExpand(child,pos,value,changed,rhsinst,arginst,rhslist) != 0) {
564 error++;
565 }
566 DestroyValue(&value);
567 }
568 }
569 return error;
570 }
571
572 /* expands, if possible, children of nonrelation,
573 * nonalias, nonparameterized arrays.
574 */
575 static
576 void TryArrayExpansion(struct Instance *work, int *changed)
577 {
578 unsigned long c,len;
579 struct Instance *child;
580 struct TypeDescription *desc;
581 len = NumberChildren(work);
582 for(c=1;c<=len;c++){
583 child = InstanceChild(work,c);
584 if (child!=NULL){
585 switch(InstanceKind(child)){
586 case ARRAY_INT_INST:
587 case ARRAY_ENUM_INST:
588 desc = InstanceTypeDesc(child);
589 /* no alii, no parameterized types, no for loops allowed. */
590 if ((!GetArrayBaseIsRelation(desc))&&(!RectangleArrayExpanded(child)) &&
591 (!GetArrayBaseIsLogRel(desc)) ) {
592 if (TryChildExpansion(child,work,changed,NULL,NULL,NULL)!= 0) {
593 SignalChildExpansionFailure(work,c);
594 }
595 }
596 break;
597 default:
598 #if 0 /* example of what not to do here */
599 FPRINTF(ASCERR,"TryArrayExpansion called with non-array instance\n");
600 /* calling with non array child is fairly common and unavoidable */
601 #endif
602 break;
603 }
604 }
605 }
606 }
607
608 static
609 void DestroyIndexList(struct gl_list_t *gl)
610 {
611 struct IndexType *ptr;
612 int c,len;
613 if (gl!=NULL) {
614 for (c=1,len = gl_length(gl);c <= len;c++) {
615 ptr = (struct IndexType *)gl_fetch(gl,c);
616 if (ptr) DestroyIndexType(ptr);
617 }
618 gl_destroy(gl);
619 }
620 }
621
622 static
623 int FindExprType(CONST struct Expr *ex, struct Instance *parent,
624 CONST unsigned int searchfor)
625 /*********************************************************************\
626 returns 1 if ex believed to be integer, 0 if symbol, and -1 if
627 confused. if searchfor TRUE, includes fortable in search
628 \*********************************************************************/
629 {
630 struct Instance *i;
631 struct gl_list_t *ilist;
632 enum find_errors err;
633 switch(ExprType(ex)){
634 case e_var:
635 ilist = FindInstances(parent,ExprName(ex),&err);
636 if ((ilist!=NULL)&&(gl_length(ilist)>0)){
637 i = (struct Instance *)gl_fetch(ilist,1);
638 gl_destroy(ilist);
639 switch(InstanceKind(i)){
640 case INTEGER_ATOM_INST:
641 case INTEGER_INST:
642 case INTEGER_CONSTANT_INST:
643 return 1;
644 case SYMBOL_ATOM_INST:
645 case SYMBOL_INST:
646 case SYMBOL_CONSTANT_INST:
647 return 0;
648 case SET_ATOM_INST:
649 case SET_INST:
650 return IntegerSetInstance(i);
651 default:
652 FPRINTF(ASCERR,"Incorrect index type; guessing integer index.\n");
653 return 1;
654 }
655 } else {
656 if (ilist!=NULL) gl_destroy(ilist);
657 if (GetEvaluationForTable()!=NULL) {
658 symchar *name;
659 struct for_var_t *ptr;
660 AssertMemory(GetEvaluationForTable());
661 name = SimpleNameIdPtr(ExprName(ex));
662 if (name!=NULL) {
663 ptr = FindForVar(GetEvaluationForTable(),name);
664 if (ptr!=NULL) {
665 switch(GetForKind(ptr)) {
666 case f_integer:
667 return 1;
668 case f_symbol:
669 return 0;
670 default:
671 FPRINTF(ASCERR,"Undefined FOR or indigestible variable.\n");
672 }
673 }
674 }
675 }
676 return -1;
677 }
678 case e_int:
679 return 1;
680 case e_symbol:
681 return 0;
682 case e_set:
683 return DeriveSetType(ExprSValue(ex),parent,searchfor);
684 default:
685 if (g_iteration>=(MAXNUMBER)) {
686 /* referencing g_iteration sucks, but seeing spew sucks more.*/
687 /* WUM, which we want, needs a statement ptr we can't supply. */
688 FPRINTF(ASCERR,"Heuristic FindExprType failed. Check your indices.\n");
689 FPRINTF(ASCERR,"Report this failure to %s if no apparent error.\n",
690 ASC_MILD_BUGMAIL);
691 FPRINTF(ASCERR,"Assuming integer array index.\n");
692 }
693 return -1;
694 }
695 }
696
697 static
698 int DeriveSetType(CONST struct Set *sptr, struct Instance *parent,
699 CONST unsigned int searchfor)
700 /*********************************************************************\
701 returns -1 if has no clue,
702 returns 1 if set appears to be int set
703 returns 0 if apparently symbol_constant set.
704 \*********************************************************************/
705 {
706 register CONST struct Set *ptr;
707 int result=-1; /* -1 indicates a failure */
708 ptr = sptr;
709 /* if it contains a range it must be an integer set */
710 while(ptr!=NULL){
711 if (SetType(ptr)) return 1;
712 ptr = NextSet(ptr);
713 }
714 ptr = sptr;
715 /* try to find the type from the expressions */
716 while(ptr!=NULL){
717 if ((result = FindExprType(GetSingleExpr(ptr),parent,searchfor)) >= 0) {
718 return result;
719 }
720 ptr = NextSet(ptr);
721 }
722 return -1; /* undefined type */
723 }
724
725 /*
726 * Returns a gllist contain the string form (or forms) of array
727 * subscripts(s)
728 * e.g. Name a[1..2]['foo']
729 * will return a gllist containing something like:
730 * "1..2"
731 * "foo"
732 */
733 static
734 struct gl_list_t *ArrayIndices(CONST struct Name *name,
735 struct Instance *parent)
736 {
737 struct gl_list_t *result;
738 int settype;
739 CONST struct Set *sptr;
740
741 if (!NameId(name)) return NULL;
742 name = NextName(name);
743 if (name == NULL) return NULL;
744 result = gl_create(2L);
745 while (name!=NULL){
746 if (NameId(name)){
747 DestroyIndexList(result);
748 return NULL;
749 }
750 sptr = NameSetPtr(name);
751 if ((settype = DeriveSetType(sptr,parent,0)) >= 0){
752 gl_append_ptr(result,
753 (VOIDPTR)CreateIndexType(CopySetList(sptr),settype));
754 } else{
755 DestroyIndexList(result);
756 return NULL;
757 }
758 name = NextName(name);
759 }
760 return result;
761 }
762
763 /**************************************************************************\
764 Sparse and Dense Array Processing.
765 \**************************************************************************/
766
767 /* this function has been modified to handle list results when called
768 * from check aliases and dense executearr.
769 * The indices made here in the aliases case where the alias is NOT
770 * inside a FOR loop are NOT for consumption by anyone because they
771 * contain a dummy index type. They merely indicate that
772 * indices can be made. They should be immediately destroyed.
773 * DestroyIndexType is the only thing that groks the Dummy.
774 * This should not be called on the final subscript of an ALIASES/IS_A
775 * inside a FOR loop unless you can grok a dummy in last place.
776 */
777 static
778 struct IndexType *MakeIndex(struct Instance *inst,
779 CONST struct Set *sptr,
780 struct Statement *stat, int last)
781 {
782 struct value_t value;
783 struct value_t setval;
784 int intset;
785 assert(GetEvaluationContext()==NULL);
786 SetEvaluationContext(inst);
787 if (StatInFOR(stat)) {
788 if (sptr == NULL ||
789 NextSet(sptr) != NULL ||
790 SetType(sptr) != 0 ) {
791 /* must be simple index */
792 WriteUnexecutedMessage(ASCERR,stat,
793 "Next subscript in FOR loop IS_A must be a scalar value,"
794 " not a set value.");
795 SetEvaluationContext(NULL);
796 return NULL;
797 }
798 value = EvaluateExpr(GetSingleExpr(sptr),NULL,InstanceEvaluateName);
799 SetEvaluationContext(NULL);
800 switch(ValueKind(value)){
801 case real_value:
802 case boolean_value:
803 case set_value:
804 case list_value:
805 if (last==0) {
806 WSEM(ASCERR,stat, "Index to sparse array is of an incorrect type");
807 DestroyValue(&value);
808 return NULL;
809 } else {
810 setval = CreateSetFromList(value);
811 intset = (SetKind(SetValue(setval)) == integer_set);
812 DestroyValue(&value);
813 DestroyValue(&setval);
814 return CreateDummyIndexType(intset);
815 /* damn thing ends up in typedesc of arrays. */
816 }
817 case integer_value:
818 DestroyValue(&value);
819 return CreateIndexType(CopySetList(sptr),1);
820 case symbol_value:
821 DestroyValue(&value);
822 return CreateIndexType(CopySetList(sptr),0);
823 case error_value:
824 switch(ErrorValue(value)){
825 case undefined_value:
826 if (StatementType(stat)==REL||StatementType(stat)==LOGREL) {
827 WSSM(ASCERR,stat,"Undefined relation array indirect indices",3);
828 /* don't want to warn about sparse IS_A/aliases here */
829 }
830 break;
831 case name_unfound:
832 break;
833 default:
834 WSSM(ASCERR,stat, "Error in sparse array indices",3);
835 break;
836 }
837 DestroyValue(&value);
838 return NULL;
839 default:
840 WSEM(ASCERR,stat, "Unknown result value type in MakeIndex.\n");
841 Asc_Panic(2, NULL, "Unknown result value type in MakeIndex.\n");
842 exit(2);/* Needed to keep gcc from whining */
843 }
844 } else { /* checking subscripts on dense ALIASES/param'd IS_A statement */
845 if (sptr==NULL) {
846 SetEvaluationContext(NULL);
847 return NULL;
848 }
849 value = EvaluateSet(sptr,InstanceEvaluateName);
850 SetEvaluationContext(NULL);
851 switch(ValueKind(value)){
852 case list_value:
853 DestroyValue(&value);
854 return CreateDummyIndexType(0 /* doesn't matter -- dense alias check */);
855 case error_value:
856 switch(ErrorValue(value)){
857 case undefined_value:
858 case name_unfound:
859 DestroyValue(&value);
860 return NULL;
861 default:
862 DestroyValue(&value);
863 WSSM(ASCERR,stat, "Error evaluating index to dense array",3);
864 return NULL;
865 }
866 default:
867 DestroyValue(&value);
868 WSEM(ASCERR,stat, "Bad index to dense alias array");
869 Asc_Panic(2, NULL, "Bad index to dense alias array");
870 exit(2);/* Needed to keep gcc from whining */
871 }
872 return NULL;
873 }
874 }
875
876 /*
877 * This function is used for making the indices of individual
878 * elements of sparse arrays (and for checking that it is possible)
879 * and for checking that the indices of dense alias arrays (a
880 * very wierd thing to have) and dense parameterized IS_A
881 * are fully defined so that aliases
882 * and parameterized/sparse IS_A can be fully constructed in 1 pass.
883 * paves over the last subscript on sparse ALIASES-IS_A.
884 */
885 static
886 struct gl_list_t *MakeIndices(struct Instance *inst,
887 CONST struct Name *name,
888 struct Statement *stat)
889 {
890 struct gl_list_t *result;
891 CONST struct Set *sptr;
892 struct IndexType *ptr;
893 int last;
894
895
896 result = gl_create((unsigned long)NameLength(name));
897 while(name != NULL){
898 if (NameId(name)){
899 DestroyIndexList(result);
900 return NULL;
901 }
902 sptr = NameSetPtr(name);
903 last = (NextName(name)==NULL && StatementType(stat)==ARR);
904 ptr = MakeIndex(inst,sptr,stat,last);
905 if (ptr != NULL) {
906 gl_append_ptr(result,(VOIDPTR)ptr);
907 } else {
908 DestroyIndexList(result);
909 return NULL;
910 }
911 name = NextName(name);
912 }
913 return result;
914 }
915
916 /*************************************************************************\
917 Sparse and Dense Array Processing.
918 \**************************************************************************/
919 static
920 void LinkToParentByName(struct Instance *inst,
921 struct Instance *child,
922 symchar *name)
923 {
924 struct InstanceName rec;
925 unsigned long pos;
926 SetInstanceNameType(rec,StrName);
927 SetInstanceNameStrPtr(rec,name);
928 pos = ChildSearch(inst,&rec);
929 LinkToParentByPos(inst,child,pos);
930 }
931
932 void LinkToParentByPos(struct Instance *inst,
933 struct Instance *child,
934 unsigned long pos)
935 {
936 assert(pos);
937 assert(child != NULL);
938 assert(inst != NULL);
939
940 StoreChildPtr(inst,pos,child);
941 AddParent(child,inst);
942 }
943
944 static
945 struct Instance *GetArrayHead(struct Instance *inst, CONST struct Name *name)
946 {
947 struct InstanceName rec;
948 unsigned long pos;
949 if (NameId(name)){
950 SetInstanceNameType(rec,StrName);
951 SetInstanceNameStrPtr(rec,NameIdPtr(name));
952 pos=ChildSearch(inst,&rec);
953 if (pos>0) {
954 return InstanceChild(inst,pos);
955 } else {
956 return NULL;
957 }
958 }
959 return NULL;
960 }
961
962 /*
963 * We are inside a FOR loop.
964 * If rhsinst is not null, we are in an alias statement and
965 * will use rhsinst as the child added instead of
966 * creating a new child.
967 * If arginst is not null, we will use it to aid in
968 * creating IS_A elements.
969 * at least one of arginst, rhsinst must be NULL.
970 * If last !=0, returns NULL naturally and ok.
971 */
972 static
973 struct Instance *DoNextArray(struct Instance *parentofary, /* MODEL */
974 struct Instance *ptr, /* array layer */
975 CONST struct Name *name, /* subscript */
976 struct Statement *stat,
977 struct Instance *rhsinst, /*ALIASES*/
978 struct Instance *arginst, /* IS_A */
979 struct gl_list_t *rhslist, /*ARR*/
980 int last /* ARR */)
981 {
982 CONST struct Set *sptr;
983 struct value_t value;
984 struct value_t setval;
985 long i;
986 symchar *sym;
987
988 if (NameId(name) != 0) return NULL; /* must be subscript, i.e. set */
989 sptr = NameSetPtr(name);
990 if ((sptr==NULL)||(NextSet(sptr)!=NULL)||(SetType(sptr))) {
991 return NULL;
992 }
993 assert(GetEvaluationContext()==NULL);
994 assert(rhsinst==NULL || arginst==NULL);
995 SetEvaluationContext(parentofary);
996 value = EvaluateExpr(GetSingleExpr(sptr),NULL,InstanceEvaluateName);
997 SetEvaluationContext(NULL);
998 switch(ValueKind(value)){
999 case real_value:
1000 case set_value:
1001 case boolean_value:
1002 case list_value:
1003 if (last==0) {
1004 WSEM(ASCERR,stat, "Index to array is of an incorrect type");
1005 DestroyValue(&value);
1006 return NULL;
1007 } else {
1008 /* we are at last subscript of ALIASES/IS_A in for loop. */
1009 /* expand using rhslist pretending dense array. */
1010 setval = CreateSetFromList(value);
1011 ExpandArray(ptr,1L,SetValue(setval),NULL,NULL,rhslist);
1012 DestroyValue(&setval);
1013 DestroyValue(&value);
1014 return NULL;
1015 }
1016 case integer_value:
1017 i = IntegerValue(value);
1018 DestroyValue(&value);
1019 return FindOrAddIntChild(ptr,i,rhsinst,arginst);
1020 case symbol_value:
1021 sym = SymbolValue(value);
1022 DestroyValue(&value);
1023 return FindOrAddStrChild(ptr,sym,rhsinst,arginst);
1024 case error_value:
1025 switch(ErrorValue(value)){
1026 case undefined_value:
1027 if (StatementType(stat)==REL||StatementType(stat)==LOGREL) {
1028 WSSM(ASCERR,stat, "Undefined relation array indirect indices",3);
1029 }
1030 break;
1031 case name_unfound:
1032 break;
1033 default:
1034 WSEM(ASCERR,stat, "Error in array indices");
1035 break;
1036 }
1037 DestroyValue(&value);
1038 return NULL;
1039 default:
1040 Asc_Panic(2, NULL ,"Unknown result value type.\n");
1041 exit(2);/* Needed to keep gcc from whining */
1042 }
1043 }
1044
1045 /*
1046 * We are inside a FOR loop.
1047 * If rhsinst is not null, we are in an alias statement and
1048 * will eventually use rhsinst as the child added instead of
1049 * creating a new child.
1050 * we expand each subscript individually here rahter than recursively.
1051 * If we are on last subscript of an ALIASES/IS_A, we copy the
1052 * layer in rhslist rather than expanding individually.
1053 * rhslist and intset only make sense simultaneously.
1054 */
1055 static
1056 struct Instance *AddArrayChild(struct Instance *parentofary,
1057 CONST struct Name *name,
1058 struct Statement *stat,
1059 struct Instance *rhsinst,
1060 struct Instance *arginst,
1061 struct gl_list_t *rhslist)
1062 {
1063 struct Instance *ptr;
1064 int last;
1065
1066 ptr = GetArrayHead(parentofary,name);
1067 if(ptr != NULL) {
1068 name = NextName(name);
1069 while(name!=NULL){
1070 last = (rhslist != NULL && NextName(name)==NULL);
1071 ptr = DoNextArray(parentofary,ptr,name,stat,
1072 rhsinst,arginst,rhslist,last);
1073 if (ptr==NULL){
1074 return NULL;
1075 }
1076 name = NextName(name);
1077 }
1078 return ptr;
1079 } else {
1080 return NULL;
1081 }
1082 }
1083
1084 /*
1085 * Create the sparse array typedesc based on the statement kind
1086 * and also add first child named. intset and def used for nonrelation types
1087 * only.
1088 * This function returns the child pointer because relation functions
1089 * need it, not because the child is unconnected.
1090 * If rhsinst is not NULL, uses rhsinst instead of creating new one.
1091 * If rhslist is not NULL, uses rhslist instead of rhsinst or creating.
1092 * It is expected that all subscripts will be evaluatable and that
1093 * in the case of the ALIASES-IS_A statement, the IS_A part is done
1094 * just before the ALIASES part.
1095 */
1096 static
1097 struct Instance *MakeSparseArray(struct Instance *parent,
1098 CONST struct Name *name,
1099 struct Statement *stat,
1100 struct TypeDescription *def,
1101 int intset,
1102 struct Instance *rhsinst,
1103 struct Instance *arginst,
1104 struct gl_list_t *rhslist)
1105 {
1106 struct TypeDescription *desc;
1107 struct Instance *aryinst;
1108 struct gl_list_t *indices;
1109 indices = MakeIndices(parent,NextName(name),stat);
1110 if (indices != NULL) {
1111 switch (StatementType(stat)) {
1112 case REL:
1113 assert(def==NULL && rhsinst==NULL && rhslist == NULL && arginst == NULL);
1114 desc = CreateArrayTypeDesc(StatementModule(stat),FindRelationType(),
1115 0,1,0,0,indices);
1116 break;
1117 case LOGREL:
1118 assert(def==NULL && rhsinst==NULL && rhslist == NULL && arginst == NULL);
1119 desc = CreateArrayTypeDesc(StatementModule(stat),FindLogRelType(),
1120 0,0,1,0,indices);
1121 break;
1122 case WHEN:
1123 assert(def==NULL && rhsinst==NULL && rhslist == NULL && arginst == NULL);
1124 desc = CreateArrayTypeDesc(StatementModule(stat),
1125 FindWhenType(),0,0,0,1,indices);
1126 break;
1127 case ISA:
1128 case ALIASES:
1129 case ARR:
1130 assert(def!=NULL);
1131 desc = CreateArrayTypeDesc(StatementModule(stat),def,
1132 intset,0,0,0,indices);
1133 break;
1134 default:
1135 WSEM(ASCERR,stat, "Utter screw-up in MakeSparseArray");
1136 Asc_Panic(2, NULL, "Utter screw-up in MakeSparseArray");
1137 }
1138 aryinst = CreateArrayInstance(desc,1);
1139 LinkToParentByName(parent,aryinst,NameIdPtr(name));
1140 return AddArrayChild(parent,name,stat,rhsinst,arginst,rhslist);
1141 } else {
1142 return NULL;
1143 }
1144 }
1145
1146
1147 /* handles construction of alias statements, allegedly, per lhs.
1148 * parent function should find rhs and send it in as rhsinst.
1149 * rhsinst == null should never be used with this function.
1150 * currently, arrays ignored, fatally.
1151 */
1152 static
1153 void MakeAliasInstance(CONST struct Name *name,
1154 CONST struct TypeDescription *basedef,
1155 struct Instance *rhsinst,
1156 struct gl_list_t *rhslist,
1157 int intset,
1158 struct Instance *parent,
1159 struct Statement *statement)
1160 {
1161 symchar *childname;
1162 int changed;
1163 unsigned long pos;
1164 struct Instance *inst;
1165 struct InstanceName rec;
1166 struct TypeDescription *arydef, *def;
1167 struct gl_list_t *indices;
1168 int tce;
1169 assert(rhsinst != NULL || rhslist !=NULL); /* one required */
1170 assert(rhsinst == NULL || rhslist ==NULL); /* only one allowed */
1171 childname = SimpleNameIdPtr(name);
1172 if (childname !=NULL){
1173 /* case of simple part name */
1174 if (StatInFOR(statement) && StatWrong(statement)==0) {
1175 MarkStatContext(statement,context_WRONG);
1176 WSEM(ASCERR,statement,"Unindexed statement in FOR loop not allowed.");
1177 WSS(ASCERR,statement);
1178 return;
1179 }
1180 SetInstanceNameType(rec,StrName);
1181 SetInstanceNameStrPtr(rec,childname);
1182 pos = ChildSearch(parent,&rec);
1183 if (pos>0){
1184 /* case of part expected */
1185 if (InstanceChild(parent,pos)==NULL){
1186 /* case of part not there yet */
1187 inst = rhsinst;
1188 StoreChildPtr(parent,pos,inst);
1189 if (SearchForParent(inst,parent)==0) {
1190 /* case where we don't already have it at this scope */
1191 AddParent(inst,parent);
1192 }
1193 } else{ /* redefining instance */
1194 /* case of part already there and we barf */
1195 char *msg = ascmalloc(SCLEN(childname)+
1196 strlen(REDEFINE_CHILD_MESG2)+1);
1197 strcpy(msg,REDEFINE_CHILD_MESG2);
1198 strcat(msg,SCP(childname));
1199 WSEM(ASCERR,statement,msg);
1200 ascfree(msg);
1201 }
1202 } else{ /* unknown child name */
1203 /* case of part not expected */
1204 WSEM(ASCERR,statement, "Unknown child name. Never should happen");
1205 Asc_Panic(2, NULL, "Unknown child name. Never should happen");
1206 }
1207 } else{
1208 /* if reach the else, means compound identifier or garbage */
1209 indices = ArrayIndices(name,parent);
1210 if (rhsinst != NULL) {
1211 def = InstanceTypeDesc(rhsinst);
1212 } else {
1213 def = (struct TypeDescription *)basedef;
1214 }
1215 if (indices!=NULL){ /* array of some sort */
1216 childname = NameIdPtr(name);
1217 SetInstanceNameType(rec,StrName);
1218 SetInstanceNameStrPtr(rec,childname);
1219 pos = ChildSearch(parent,&rec);
1220 if (!StatInFOR(statement)) {
1221 /* rectangle arrays */
1222 arydef = CreateArrayTypeDesc(StatementModule(statement),
1223 def,intset,0,0,0,indices);
1224 if (pos>0) {
1225 inst = CreateArrayInstance(arydef,1);
1226 if (inst!=NULL){
1227 changed = 0;
1228 tce = TryChildExpansion(inst,parent,&changed,rhsinst,NULL,rhslist);
1229 /* we're not in a for loop, so can't fail unless user is idiot. */
1230 LinkToParentByPos(parent,inst,pos); /* don't want to lose memory */
1231 /* if user is idiot, whine. */
1232 if (tce != 0) {
1233 SignalChildExpansionFailure(parent,pos);
1234 }
1235 } else {
1236 WSEM(ASCERR,statement, "Unable to create alias array instance");
1237 Asc_Panic(2, NULL, "Unable to create alias array instance");
1238 }
1239 } else {
1240 DeleteTypeDesc(arydef);
1241 WSEM(ASCERR,statement,
1242 "Unknown array child name. Never should happen");
1243 Asc_Panic(2, NULL, "Unknown array child name. Never should happen");
1244 }
1245 } else {
1246 /* sparse array */
1247 DestroyIndexList(indices);
1248 if (pos>0) {
1249 if (InstanceChild(parent,pos)==NULL) {
1250 /* need to make alias array */
1251 /* should check for NULL return here */
1252 (void)
1253 MakeSparseArray(parent,name,statement,def,
1254 intset,rhsinst,NULL,rhslist);
1255 } else {
1256 /* need to add alias array element */
1257 /* should check for NULL return here */
1258 (void) AddArrayChild(parent,name,statement,
1259 rhsinst,NULL,rhslist);
1260 }
1261 } else {
1262 WSEM(ASCERR,statement,
1263 "Unknown array child name. Never should happen");
1264 Asc_Panic(2, NULL, "Unknown array child name. Never should happen");
1265 }
1266 }
1267 } else {
1268 /* bad child name. cannot create parts of parts. should never
1269 * happen, being trapped out in typelint.
1270 */
1271 WSEM(ASCERR,statement,"Bad ALIASES child name.");
1272 }
1273 }
1274 }
1275
1276 /* returns 1 if concluded with statement, 0 if might try later.
1277 */
1278 static
1279 int ExecuteALIASES(struct Instance *inst, struct Statement *statement)
1280 {
1281 CONST struct VariableList *vlist;
1282 struct gl_list_t *rhslist;
1283 struct Instance *rhsinst;
1284 CONST struct Name *name;
1285 enum find_errors ferr;
1286 int intset;
1287
1288 assert(StatementType(statement)==ALIASES);
1289 if (StatWrong(statement)) {
1290 /* incorrect statements should be warned about when they are
1291 * marked wrong, so we just ignore them here.
1292 */
1293 return 1;
1294 }
1295 if (!CheckALIASES(inst,statement)) {
1296 WriteUnexecutedMessage(ASCERR,statement,
1297 "Possibly undefined sets/ranges in ALIASES statement.");
1298 return 0;
1299 }
1300 name = AliasStatName(statement);
1301 rhslist = FindInstances(inst,name,&ferr);
1302 if (rhslist == NULL) {
1303 WriteUnexecutedMessage(ASCERR,statement,
1304 "Possibly undefined right hand side in ALIASES statement.");
1305 return 0; /* rhs not compiled yet */
1306 }
1307 if (gl_length(rhslist)>1) {
1308 WSEM(ASCERR,statement,"ALIASES needs exactly 1 RHS");
1309 gl_destroy(rhslist);
1310 return 1; /* rhs not unique for current values of sets */
1311 }
1312 rhsinst = (struct Instance *)gl_fetch(rhslist,1);
1313 gl_destroy(rhslist);
1314 if (InstanceKind(rhsinst)==REL_INST || LREL_INST ==InstanceKind(rhsinst)) {
1315 WSEM(ASCERR,statement,"Direct ALIASES of relations are not permitted");
1316 MarkStatContext(statement,context_WRONG);
1317 WSS(ASCERR,statement);
1318 return 1; /* relations only aliased through models */
1319 }
1320 intset = ( (InstanceKind(rhsinst)==SET_ATOM_INST) &&
1321 (IntegerSetInstance(rhsinst)) );
1322 vlist = GetStatVarList(statement);
1323 while (vlist!=NULL){
1324 MakeAliasInstance(NamePointer(vlist),NULL,rhsinst,
1325 NULL,intset,inst,statement);
1326 vlist = NextVariableNode(vlist);
1327 }
1328 return 1;
1329 }
1330
1331
1332 /****************** support for ALIASES-IS_A statements ******************/
1333
1334 /* enforce max len and no ' rules for subscripts. string returned
1335 * may not be string sent.
1336 */
1337 static
1338 char *DeSingleQuote(char *s)
1339 {
1340 char *old;
1341 int len;
1342 if (s==NULL) {
1343 return s;
1344 }
1345 len = strlen(s);
1346 if (len > 40) {
1347 old = s;
1348 s = (char *)ascmalloc(41);
1349 strncpy(s,old,17);
1350 s[17] = '.';
1351 s[18] = '.';
1352 s[19] = '.';
1353 s[20] = '\0';
1354 strcat(s,(old+len-20));
1355 ascfree(old);
1356 }
1357 old = s;
1358 while (*s != '\0') {
1359 if (*s =='\'') {
1360 *s = '_';
1361 }
1362 s++;
1363 }
1364
1365 return old;
1366 }
1367
1368 /* returns a symchar based on but not in strset,
1369 * and adds original and results to sym table.
1370 * destroys the s given.
1371 */
1372 static
1373 symchar *UniquifyString(char *s, struct set_t *strset)
1374 {
1375 int oldlen, maxlen, c;
1376 char *new;
1377 symchar *tmp;
1378
1379 tmp = AddSymbol(s);
1380 if (StrMember(tmp,strset)!=0) {
1381 oldlen = strlen(s);
1382 maxlen = oldlen+12;
1383 new = ascrealloc(s,oldlen+14);
1384 assert(new!=NULL);
1385 while ( (oldlen+1) < maxlen) {
1386 new[oldlen+1] = '\0';
1387 for(c = 'a'; c <= 'z'; c++){
1388 new[oldlen] = c;
1389 tmp = AddSymbol(new);
1390 if (StrMember(tmp,strset)==0) {
1391 ascfree(new);
1392 return tmp;
1393 }
1394 }
1395 oldlen++;
1396 }
1397 Asc_Panic(2, NULL,
1398 "Unable to generate unique compound alias subscript.\n");
1399 exit(2);/* Needed to keep gcc from whining */
1400 } else {
1401 ascfree(s);
1402 return tmp;
1403 }
1404 }
1405
1406 static
1407 struct value_t GenerateSubscripts(struct Instance *iref,
1408 struct gl_list_t *rhslist,
1409 int intset)
1410 {
1411 struct set_t *setinstval;
1412 unsigned long c,len;
1413 char *str;
1414 symchar *sym;
1415
1416 setinstval = CreateEmptySet();
1417 len = gl_length(rhslist);
1418 if (intset!=0) {
1419 /* create subscripts 1..rhslistlen */
1420 for (c=1;c<=len; c++) {
1421 AppendIntegerElement(setinstval,c);
1422 }
1423 return CreateSetValue(setinstval);
1424 }
1425 /* create string subscripts */
1426 for (c=1; c<= len; c++) {
1427 str = WriteInstanceNameString((struct Instance *)gl_fetch(rhslist,c),iref);
1428 str = DeSingleQuote(str); /* transmogrify for length and ' marks */
1429 sym = UniquifyString(str,setinstval); /* convert to symbol and free str */
1430 AppendStringElement(setinstval,sym);
1431 }
1432 return CreateSetValue(setinstval);
1433 }
1434
1435 static
1436 void DestroyArrayElements(struct gl_list_t *rhslist)
1437 {
1438 unsigned long c,len;
1439 if (rhslist==NULL){
1440 return;
1441 }
1442 for (c=1, len = gl_length(rhslist); c <= len; c++) {
1443 FREEPOOLAC(gl_fetch(rhslist,c));
1444 }
1445 gl_destroy(rhslist);
1446 }
1447
1448 /*
1449 * this function computes the subscript set (or generates it if
1450 * needed) and checks it for matching against the instance list
1451 * and whines when things aren't kosher.
1452 * When things are kosher, creates a gl_list of array children.
1453 * This list is returned through rhslist.
1454 */
1455 static
1456 struct value_t ComputeArrayElements(struct Instance *inst,
1457 struct Statement *statement,
1458 struct gl_list_t *rhsinstlist,
1459 struct gl_list_t **rhslist)
1460 {
1461 struct value_t subslist;
1462 struct value_t subscripts;
1463 struct value_t result; /* return value is the expanded subscript set */
1464 CONST struct Set *setp;
1465 struct set_t *sip;
1466 int intset;
1467 unsigned long c, len;
1468 struct ArrayChild *ptr;
1469
1470 assert((*rhslist)==NULL && rhsinstlist != NULL && rhslist != NULL);
1471
1472 intset = ArrayStatIntSet(statement);
1473 len = gl_length(rhsinstlist);
1474 setp = ArrayStatSetValues(statement);
1475 if (setp==NULL) {
1476 /* value generated is a set and automatically is of correct CARD() */
1477 result = GenerateSubscripts(inst,rhsinstlist,intset);
1478 /* fill up rhslist and return */
1479 *rhslist = gl_create(len);
1480 sip = SetValue(result);
1481 if (intset != 0) {
1482 for (c = 1; c <= len; c++) {
1483 ptr = MALLOCPOOLAC;
1484 ptr->inst = gl_fetch(rhsinstlist,c);
1485 ptr->name.index = FetchIntMember(sip,c);
1486 gl_append_ptr(*rhslist,(VOIDPTR)ptr);
1487 }
1488 } else {
1489 for (c = 1; c <= len; c++) {
1490 ptr = MALLOCPOOLAC;
1491 ptr->inst = gl_fetch(rhsinstlist,c);
1492 ptr->name.str = FetchStrMember(sip,c);
1493 gl_append_ptr(*rhslist,(VOIDPTR)ptr);
1494 }
1495 }
1496 return result;
1497 } else {
1498 /* cook up the users list */
1499 assert(GetEvaluationContext()==NULL);
1500 SetEvaluationContext(inst);
1501 subslist = EvaluateSet(setp,InstanceEvaluateName);
1502 SetEvaluationContext(NULL);
1503 /* check that it evaluates */
1504 if (ValueKind(subslist)==error_value) {
1505 switch(ErrorValue(subslist)) {
1506 case name_unfound:
1507 case undefined_value:
1508 DestroyValue(&subslist);
1509 WriteUnexecutedMessage(ASCERR,statement,
1510 "Undefined values in WITH_VALUE () list");
1511 return CreateErrorValue(undefined_value);
1512 default:
1513 WSEM(ASCERR,statement,"Bad result in evaluating WITH_VALUE list\n");
1514 MarkStatContext(statement,context_WRONG);
1515 WSS(ASCERR,statement);
1516 DestroyValue(&subslist);
1517 }
1518 }
1519 /* collect sets to assign later */
1520 result = CreateSetFromList(subslist); /* unique list */
1521 ListMode=1;
1522 subscripts = CreateOrderedSetFromList(subslist); /* as ordered to insts */
1523 ListMode=0;
1524 DestroyValue(&subslist); /* done with it */
1525 /* check everything dumb that can happen */
1526 if ( ValueKind(result) != set_value ||
1527 Cardinality(SetValue(subscripts)) != Cardinality(SetValue(result))
1528 ) {
1529 DestroyValue(&result);
1530 DestroyValue(&subscripts);
1531 WSEM(ASCERR,statement,
1532 "WITH_VALUE list does not form a proper subscript set.\n");
1533 MarkStatContext(statement,context_WRONG);
1534 WSS(ASCERR,statement);
1535 return CreateErrorValue(type_conflict);
1536 }
1537 /* check sanity of values. may need fixing around empty set. */
1538 if ( (SetKind(SetValue(subscripts))==integer_set) != (intset!=0)) {
1539 WSEM(ASCERR,statement,
1540 "Unable to construct set. Values and set type mismatched\n");
1541 DestroyValue(&result);
1542 DestroyValue(&subscripts);
1543 MarkStatContext(statement,context_WRONG);
1544 WSS(ASCERR,statement);
1545 return CreateErrorValue(type_conflict);
1546 }
1547 /* check set size == instances to alias */
1548 if (Cardinality(SetValue(subscripts)) != len) {
1549 WSEM(ASCERR,statement,"In: ");
1550 FPRINTF(ASCERR,
1551 "WITH_VALUE list length (%lu) != number of instances given (%lu)\n",
1552 Cardinality(SetValue(subscripts)),len);
1553 DestroyValue(&result);
1554 DestroyValue(&subscripts);
1555 MarkStatContext(statement,context_WRONG);
1556 WSS(ASCERR,statement);
1557 return CreateErrorValue(type_conflict);
1558 }
1559 /* fill up rhslist and return */
1560 *rhslist = gl_create(len);
1561 sip = SetValue(subscripts);
1562 if (intset != 0) {
1563 for (c = 1; c <= len; c++) {
1564 ptr = MALLOCPOOLAC;
1565 ptr->inst = gl_fetch(rhsinstlist,c);
1566 ptr->name.index = FetchIntMember(sip,c);
1567 gl_append_ptr(*rhslist,(VOIDPTR)ptr);
1568 }
1569 } else {
1570 for (c = 1; c <= len; c++) {
1571 ptr = MALLOCPOOLAC;
1572 ptr->inst = gl_fetch(rhsinstlist,c);
1573 ptr->name.str = FetchStrMember(sip,c);
1574 gl_append_ptr(*rhslist,(VOIDPTR)ptr);
1575 }
1576 }
1577 DestroyValue(&subscripts);
1578 return result;
1579 }
1580 }
1581
1582 /* returns 1 if concluded with statement, 0 if might try later.
1583 */
1584 static
1585 int ExecuteARR(struct Instance *inst, struct Statement *statement)
1586 {
1587 CONST struct VariableList *vlist;
1588 struct gl_list_t *rhsinstlist; /* list of instances found to alias */
1589 struct gl_list_t *setinstl; /* instance found searching for IS_A'd set */
1590 struct gl_list_t *rhslist=NULL; /* list of arraychild structures */
1591 struct value_t subsset;
1592 #ifndef NDEBUG
1593 struct Instance *rhsinst;
1594 #endif
1595 struct Instance *setinst;
1596 enum find_errors ferr;
1597 CONST struct TypeDescription *basedef;
1598 ChildListPtr icl;
1599 int intset;
1600
1601 assert(StatementType(statement)==ARR);
1602 if (StatWrong(statement)) {
1603 /* incorrect statements should be warned about when they are
1604 * marked wrong, so we just ignore them here.
1605 */
1606 return 1;
1607 }
1608 if (!CheckARR(inst,statement)) {
1609 WriteUnexecutedMessage(ASCERR,statement,
1610 "Possibly undefined instances/sets/ranges in ALIASES-IS_A statement.");
1611 return 0;
1612 }
1613 rhsinstlist = FindInsts(inst,GetStatVarList(statement),&ferr);
1614 if (rhsinstlist == NULL) {
1615 MissingInsts(inst,GetStatVarList(statement),0);
1616 WriteUnexecutedMessage(ASCERR,statement,
1617 "Incompletely defined source instance list in ALIASES-IS_A statement.");
1618 return 0; /* rhs's not compiled yet */
1619 }
1620 /* check for illegal rhs types. parser normally bars this. */
1621 #ifndef NDEBUG
1622 if (gl_length(rhsinstlist) >0) {
1623 rhsinst = (struct Instance *)gl_fetch(rhsinstlist,1);
1624 if (BaseTypeIsEquation(InstanceTypeDesc(rhsinst))) {
1625 WSEM(ASCERR,statement,
1626 "Direct ALIASES of rels/lrels/whens are not permitted");
1627 MarkStatContext(statement,context_WRONG);
1628 WSS(ASCERR,statement);
1629 gl_destroy(rhsinstlist);
1630 return 1; /* (log)relations/whens only aliased through models */
1631 }
1632 }
1633 #endif
1634 /* evaluate name list, if given, OTHERWISE generate it, and check CARD.
1635 * issues warnings as needed
1636 */
1637 subsset = ComputeArrayElements(inst,statement,rhsinstlist,&rhslist);
1638 gl_destroy(rhsinstlist);
1639 /* check return values of subsset and rhslist here */
1640 if (ValueKind(subsset)== error_value) {
1641 if (ErrorValue(subsset) == undefined_value) {
1642 DestroyValue(&subsset);
1643 return 0;
1644 } else {
1645 DestroyValue(&subsset);
1646 return 1;
1647 }
1648 }
1649 assert(rhslist!=NULL); /* might be empty, but not NULL */
1650 /* make set ATOM */
1651 vlist = ArrayStatSetName(statement);
1652 intset = ArrayStatIntSet(statement);
1653 MakeInstance(NamePointer(vlist),FindSetType(),intset,inst,statement,NULL);
1654 /* get instance and assign. */
1655 setinstl = FindInstances(inst,NamePointer(vlist),&ferr);
1656 if (setinstl == NULL || gl_length(setinstl) != 1L) {
1657 FPRINTF(ASCERR,"Unable to construct set.\n");
1658 FPRINTF(ASCERR,"Bizarre error in ALIASES-IS_A. Please report it to:\n%s",
1659 ASC_BIG_BUGMAIL);
1660 if (setinstl!=NULL) {
1661 gl_destroy(setinstl);
1662 }
1663 DestroyArrayElements(rhslist);
1664 DestroyValue(&subsset);
1665 MarkStatContext(statement,context_WRONG);
1666 WSS(ASCERR,statement);
1667 /* should nuke entire compound ALIASES/IS_A array pair already built */
1668 return 1;
1669 } else {
1670 setinst = (struct Instance *)gl_fetch(setinstl,1);
1671 gl_destroy(setinstl);
1672 AssignSetAtomList(setinst,CopySet(SetValue(subsset)));
1673 DestroyValue(&subsset);
1674 }
1675
1676 /* create ALIASES-IS_A array */
1677 /* recycle the local pointer to our set ATOM to check base type of rhslist */
1678 setinst = CAC(gl_fetch(rhslist,1))->inst;
1679 intset = ( InstanceKind(setinst)==SET_ATOM_INST &&
1680 IntegerSetInstance(setinst)!=0 );
1681 /* the real question is does anyone downstream care if intset correct?
1682 * probably not since its an alias anyway.
1683 */
1684 vlist = ArrayStatAvlNames(statement);
1685 icl = GetChildList(InstanceTypeDesc(inst));
1686 basedef = ChildBaseTypePtr(icl,ChildPos(icl,NameIdPtr(NamePointer(vlist))));
1687 while (vlist!=NULL){
1688 /* fix me for sparse case. dense ok. */
1689 MakeAliasInstance(NamePointer(vlist), basedef,NULL,
1690 rhslist, intset, inst, statement);
1691 vlist = NextVariableNode(vlist);
1692 }
1693 /* clean up memory */
1694 DestroyArrayElements(rhslist);
1695
1696 return 1;
1697 }
1698
1699
1700 /*
1701 * Makes a single instance of the type given,which must not be array
1702 * or relation of any kind or when.
1703 * If type is a MODEL, adds the MODEL to pending list.
1704 * The argument intset is only used if type is set, then
1705 * if intset==1, set ATOM made will be integer set.
1706 * Attempts to find a UNIVERSAL before making the instance.
1707 * statement is used only for error messages.
1708 */
1709 static
1710 struct Instance *MakeSimpleInstance(struct TypeDescription *def,
1711 int intset,
1712 struct Statement *statement,
1713 struct Instance *arginst)
1714 {
1715 struct Instance *inst;
1716
1717 inst = ShortCutMakeUniversalInstance(def);
1718 if (inst==NULL) {
1719 switch(GetBaseType(def)){
1720 case model_type:
1721 inst = CreateModelInstance(def); /* if we are here - build one */
1722 if (!GetUniversalFlag(def)||!InstanceInList(inst)) {
1723 /* add PENDING model if not UNIVERSAL, or UNIVERSAL and
1724 * this is the very first time seen - don't ever want an instance
1725 * in the pending list twice.
1726 */
1727 /*
1728 * here we need to shuffle in info from arginst.
1729 * note that because this is inside the UNIVERSAL check,
1730 * only the first set of arguments to a UNIVERSAL type will
1731 * ever apply.
1732 */
1733 ConfigureInstFromArgs(inst,arginst);
1734 AddBelow(NULL,inst);
1735 }
1736 break;
1737 case real_type:
1738 case real_constant_type:
1739 inst = CreateRealInstance(def);
1740 break;
1741 case boolean_type:
1742 case boolean_constant_type:
1743 inst = CreateBooleanInstance(def);
1744 break;
1745 case integer_type:
1746 case integer_constant_type:
1747 inst = CreateIntegerInstance(def);
1748 break;
1749 case set_type:
1750 inst = CreateSetInstance(def,intset);
1751 break;
1752 case symbol_type:
1753 case symbol_constant_type:
1754 inst = CreateSymbolInstance(def);
1755 break;
1756 case relation_type:
1757 inst = NULL;
1758 FPRINTF(ASCERR,"Type '%s' is not allowed in IS_A.\n",
1759 SCP(GetBaseTypeName(relation_type)));
1760 case logrel_type:
1761 inst = NULL;
1762 FPRINTF(ASCERR,"Type '%s' is not allowed in IS_A.\n",
1763 SCP(GetBaseTypeName(logrel_type)));
1764 break;
1765 case when_type:
1766 inst = NULL;
1767 FPRINTF(ASCERR,"Type '%s' is not allowed in IS_A.\n",
1768 SCP(GetBaseTypeName(when_type)));
1769 break;
1770 case array_type:
1771 default: /* picks up patch_type */
1772 WSEM(ASCERR,statement, "MakeSimpleInstance error. PATCH/ARRAY found.\n");
1773 Asc_Panic(2, NULL, "MakeSimpleInstance error. PATCH/ARRAY found.\n");
1774 }
1775 }
1776 return inst;
1777 }
1778
1779 static unsigned long g_unasscon_count = 0L;
1780 /* counter for the following functions */
1781 static
1782 void CountUnassignedConst(struct Instance *i)
1783 {
1784 if (i!=NULL && (IsConstantInstance(i) || InstanceKind(i)==SET_ATOM_INST) ) {
1785 if (AtomAssigned(i)==0) {
1786 g_unasscon_count++;
1787 }
1788 }
1789 }
1790 /* Returns 0 if all constant scalars in ipass are assigned,
1791 * for ipass that are of set/scalar array/scalar type.
1792 * Handles null input gracefully, as if there is something
1793 * unassigned in it.
1794 * Variable types are considered permanently assigned, since
1795 * we are checking for constants being unassigned.
1796 * Assumes arrays, if passed in, are fully expanded.
1797 */
1798 static
1799 int ArgValuesUnassigned(struct Instance *ipass)
1800 {
1801 struct TypeDescription *abd;
1802 if (ipass==NULL) return 1;
1803 switch (InstanceKind(ipass)) {
1804 case ERROR_INST:
1805 return 1;
1806 case SIM_INST:
1807 case MODEL_INST:
1808 case REL_INST:
1809 case LREL_INST:
1810 case WHEN_INST:
1811 return 0;
1812 case ARRAY_INT_INST:
1813 case ARRAY_ENUM_INST:
1814 abd = GetArrayBaseType(InstanceTypeDesc(ipass));
1815 if (BaseTypeIsConstant(abd)==0 && BaseTypeIsSet(abd)==0) {
1816 return 0;
1817 }
1818 g_unasscon_count = 0;
1819 SilentVisitInstanceTree(ipass,CountUnassignedConst,0,0);
1820 if (g_unasscon_count != 0) {
1821 return 1;
1822 } else {
1823 return 0;
1824 }
1825 case REAL_INST:
1826 case INTEGER_INST:
1827 case BOOLEAN_INST:
1828 case SYMBOL_INST:
1829 case SET_INST:
1830 case REAL_ATOM_INST:
1831 case INTEGER_ATOM_INST:
1832 case BOOLEAN_ATOM_INST:
1833 case SYMBOL_ATOM_INST:
1834 return 0;
1835 case SET_ATOM_INST:
1836 case REAL_CONSTANT_INST:
1837 case BOOLEAN_CONSTANT_INST:
1838 case INTEGER_CONSTANT_INST:
1839 case SYMBOL_CONSTANT_INST:
1840 return (AtomAssigned(ipass)==0); /* return 0 if assigned, 1 not */
1841 default:
1842 return 1; /* NOTREACHED */
1843 }
1844 }
1845 /*
1846 * This function appends the pointers in the set chain s
1847 * into the list given args. args must not be NULL unless s is.
1848 * If needed, args will be expanded, but if you know the length
1849 * to expect, make args of that size before calling and this
1850 * will be faster.
1851 * This does not go into the expressions (which may contain other
1852 * sets themselves) of the set nodes and disassemble them.
1853 * The list may be safely destroyed, but its contents should not
1854 * be destroyed with it as they belong to something else in all
1855 * likelihood.
1856 * This function should be moved into a set header someplace.
1857 */
1858 static
1859 void SplitArgumentSet(CONST struct Set *s, struct gl_list_t *args)
1860 {
1861 struct Set *sp;
1862 if (s==NULL) return;
1863 assert(args !=NULL); /* debug WriteSet(ASCERR,s); FPRINTF(ASCERR,"\n"); */
1864 while (s!=NULL) {
1865 sp = CopySetNode(s);
1866 gl_append_ptr(args,(VOIDPTR)sp);
1867 s = NextSet(s);
1868 }
1869 }
1870
1871 #define GETARG(l,n) ((struct Set *)gl_fetch((l),(n)))
1872
1873 /*
1874 * returns 1 if all ok,
1875 * returns 0 if any array child is < type required,
1876 * returns -1 if some array child is type incompatible with ptype/stype.
1877 * Does some optimization around arrays of sets and array basetypes.
1878 * Doesn't check names.
1879 */
1880 static
1881 int ArrayElementsTypeCompatible(CONST struct Instance *ipass,
1882 CONST struct TypeDescription *ptype,
1883 symchar *stype)
1884 {
1885 struct gl_list_t *achildren=NULL;
1886 CONST struct TypeDescription *atype;
1887 CONST struct TypeDescription *mrtype;
1888 unsigned long c,len,lessrefined=0L;
1889 struct Instance *i;
1890
1891 if (ipass==NULL || ptype == NULL) {
1892 return -1; /* hosed input */
1893 }
1894 assert(IsArrayInstance(ipass) != 0);
1895 atype = GetArrayBaseType(InstanceTypeDesc(ipass));
1896 if (BaseTypeIsSet(atype)==0 && MoreRefined(atype,ptype)==atype) {
1897 /* if not set and if array base is good enough */
1898 return 1;
1899 }
1900 achildren = CollectArrayInstances(ipass,NULL);
1901 len = gl_length(achildren);
1902 for (c = 1; c <= len; c++) {
1903 i = (struct Instance *)gl_fetch(achildren,c);
1904 atype = InstanceTypeDesc(i);
1905 if (InstanceKind(i) == SET_ATOM_INST) {
1906 /* both should be of same type "set" */
1907 if (atype!=ptype ||
1908 (IntegerSetInstance(i)==0 &&
1909 stype == GetBaseTypeName(integer_constant_type))
1910 || (IntegerSetInstance(i)==1 &&
1911 stype == GetBaseTypeName(symbol_constant_type))
1912 ) {
1913 /* set type mismatch */
1914 gl_destroy(achildren);
1915 return -1;
1916 } else {
1917 /* assumption about arrays of sets being sane, if 1 element is. */
1918 gl_destroy(achildren);
1919 return 1;
1920 }
1921 }
1922 if (ptype==atype) {
1923 continue;
1924 }
1925 mrtype = MoreRefined(ptype,atype);
1926 if (mrtype == NULL) {
1927 gl_destroy(achildren);
1928 return -1;
1929 }
1930 if (mrtype == ptype) {
1931 lessrefined++;
1932 }
1933 }
1934 gl_destroy(achildren);
1935 return (lessrefined==0L); /* if any elements are inadequately refined, 0 */
1936 }
1937
1938 /* returns a value_t, but the real result is learned by consulting err.
1939 * err == 0 means some interesting value found.
1940 * err == 1 means try again later
1941 * err == -1 means things are hopeless.
1942 */
1943 static
1944 struct value_t FindArgValue(struct Instance *parent,
1945 struct Set *argset,
1946 int *err)
1947 {
1948 int previous_context;
1949 struct value_t value;
1950
1951 assert(err!=NULL);
1952 *err=0;
1953 previous_context = GetDeclarativeContext();
1954 SetDeclarativeContext(0);
1955 assert(GetEvaluationContext()==NULL);
1956 SetEvaluationContext(parent);
1957 value = EvaluateExpr(GetSingleExpr(argset),
1958 NULL,
1959 InstanceEvaluateName);
1960 SetEvaluationContext(NULL);
1961 SetDeclarativeContext(previous_context);
1962 if (ValueKind(value)==error_value) {
1963 switch(ErrorValue(value)){
1964 case name_unfound:
1965 *err = 1;
1966 DestroyValue(&value);
1967 return CreateErrorValue(undefined_value);
1968 case undefined_value:
1969 *err = 1;
1970 return value;
1971 default:
1972 *err = -1;
1973 }
1974 }
1975 if (IsConstantValue(value)==0){
1976 *err = -1;
1977 DestroyValue(&value);
1978 return CreateErrorValue(type_conflict);
1979 }
1980 return value;
1981 }
1982
1983 /* return codes and message handling for MakeParameterInst */
1984 #define MPIOK 1
1985 #define MPIWAIT 0
1986 #define MPIINPUT -1
1987 #define MPIARGTYPE -2
1988 #define MPIARRINC -3
1989 #define MPIBADASS -4
1990 #define MPIARRRNG -5
1991 #define MPIINSMEM -6
1992 #define MPIBADARG -7
1993 #define MPIMULTI -8
1994 #define MPIBADVAL -9
1995 #define MPIWEIRD -10
1996 #define MPIUNMADE -11
1997 #define MPIWEAKTYPE -12
1998 #define MPIUNASSD -13
1999 #define MPIARGVAL -14
2000 #define MPIARGSIZ -15
2001 #define MPIBADWBTS -16
2002 #define MPIBADWNBTS -17
2003 #define MPIBADMERGE -18
2004 #define MPIREASGN -19
2005 #define MPIREDEF -20
2006 #define MPIFOR -21
2007 #define MPIBADREL -22
2008 #define MPIEXCEP -23
2009 #define MPIVARREL -24
2010 #define MPINOTBOOL -25
2011 static
2012 char *g_mpi_message[] = {
2013 /* 0 */ "Nothing wrong with parameter",
2014 /* -1 */ "Bad input statement or parent or arginstptr.",
2015 /* -2 */ "Incompatible argument type.",
2016 /* -3 */ "Incomplete assignment of absorbed pass-by-value array.",
2017 /* -4 */ "Error in absorbed assignment RHS.",
2018 /* -5 */ "Mismatch in range of array subscripts.",
2019 /* -6 */ "Insufficient memory - crashing soon",
2020 /* -7 */ "Nonexistent argument. (bad set in array expression, probably)",
2021 /* -8 */ "Too many instances named for 1 parameter slot",
2022 /* -9 */ "Bad expression passed to IS_A",
2023 /* -10 */ "Something rotten in lint",
2024 /* -11 */ "Instance doesn't yet exist",
2025 /* -12 */ "Instance not sufficiently refined",
2026 /* -13 */ "Argument value not assigned",
2027 /* -14 */ "Argument value != required value",
2028 /* -15 */ "Array object given has with too many/too few subscripts.",
2029 /* -16 */ "Incorrect instance named in WILL_BE_THE_SAME.",
2030 /* -17 */ "Nonexistent instance named in WILL_NOT_BE_THE_SAME.",
2031 /* -18 */ "Merged instances found in WILL_NOT_BE_THE_SAME.",
2032 /* -19 */ "Refinement cannot reassign constant value.",
2033 /* -20 */ "Refinement must pass in same objects used in IS_A.",
2034 /* -21 */ "Improper FOR loop in WHERE statements",
2035 /* -22 */ "WHERE condition unsatisfied",
2036 /* -23 */ "WHERE condition incorrect (system exception occurred)",
2037 /* -24 */ "WHERE condition incorrect (nonconstant value)",
2038 /* -25 */ "WHERE condition incorrect (nonboolean value)"
2039 };
2040
2041 /* Returns MPIOK if value in ipass matches WITH_VALUE field of
2042 * statement, or if the test is silly beacause ipass isn't
2043 * a set/constant or if statement does not constrain value.
2044 * Returns MPIWAIT if statement truth cannot be tested because
2045 * WITH_VALUE clause is not yet evaluatable.
2046 * Returns MPIARGVAL if WITH_VALUE is provably unsatisfied.
2047 * On truly garbage input, unlikely to return.
2048 */
2049 static
2050 int ArgValueCorrect(struct Instance *inst,
2051 struct Instance *tmpinst,
2052 CONST struct Statement *statement)
2053 {
2054 CONST struct Expr *check;
2055 int previous_context;
2056 struct value_t value;
2057
2058 assert (inst!=NULL);
2059 assert (tmpinst!=NULL);
2060 assert (statement!=NULL);
2061
2062 if ( StatementType(statement)!= WILLBE ||
2063 (check = GetStatCheckValue(statement)) == NULL ||
2064 ( IsConstantInstance(inst) ==0 &&
2065 InstanceKind(inst) != SET_ATOM_INST)
2066 ) {
2067 return MPIOK;
2068 }
2069 if (!AtomAssigned(inst)) {
2070 return MPIWAIT;
2071 }
2072 previous_context = GetDeclarativeContext();
2073 SetDeclarativeContext(0);
2074 assert(GetEvaluationContext()==NULL);
2075 SetEvaluationContext(tmpinst);
2076 value = EvaluateExpr(check, NULL, InstanceEvaluateName);
2077 SetEvaluationContext(NULL);
2078 SetDeclarativeContext(previous_context);
2079 if (ValueKind(value)==error_value) {
2080 switch(ErrorValue(value)){
2081 case name_unfound:
2082 case undefined_value:
2083 DestroyValue(&value);
2084 return MPIWAIT;
2085 default:
2086 DestroyValue(&value);
2087 return MPIARGVAL;
2088 }
2089 }
2090 if (IsConstantValue(value)==0){
2091 DestroyValue(&value);
2092 FPRINTF(ASCERR,"Variable value found where constant required\n");
2093 return MPIARGVAL;
2094 }
2095 /* ok, so we have a reasonable inst type and a constant value */
2096 switch(InstanceKind(inst)){
2097 case REAL_CONSTANT_INST:
2098 switch(ValueKind(value)){
2099 case real_value:
2100 if ( ( RealValue(value) != RealAtomValue(inst) ||
2101 !SameDimen(RealValueDimensions(value),RealAtomDims(inst)) )
2102 ) {
2103 DestroyValue(&value);
2104 return MPIARGVAL;
2105 }
2106 break;
2107 case integer_value:
2108 if ( ( (double)IntegerValue(value) != RealAtomValue(inst) ||
2109 !SameDimen(Dimensionless(),RealAtomDims(inst)) )
2110 ) {
2111 DestroyValue(&value);
2112 return MPIARGVAL;
2113 }
2114 break;
2115 default:
2116 DestroyValue(&value);
2117 return MPIARGVAL;
2118 }
2119 break;
2120 case BOOLEAN_CONSTANT_INST:
2121 if (ValueKind(value)!=boolean_value ||
2122 BooleanValue(value) != GetBooleanAtomValue(inst) ) {
2123 DestroyValue(&value);
2124 return MPIARGVAL;
2125 }
2126 break;
2127 case INTEGER_CONSTANT_INST:
2128 switch(ValueKind(value)){
2129 case integer_value:
2130 if (GetIntegerAtomValue(inst)!=IntegerValue(value)) {
2131 DestroyValue(&value);
2132 return MPIARGVAL;
2133 }
2134 break;
2135 case real_value: /* case which is parser artifact: real, wild 0 */
2136 if ( RealValue(value)==0.0 &&
2137 IsWild(RealValueDimensions(value)) &&
2138 GetIntegerAtomValue(inst) != 0) {
2139 DestroyValue(&value);
2140 return MPIARGVAL;
2141 }
2142 break;
2143 default:
2144 DestroyValue(&value);
2145 return MPIARGVAL;
2146 }
2147 break;
2148 case SET_ATOM_INST:
2149 if (ValueKind(value)!=set_value ||
2150 !SetsEqual(SetValue(value),SetAtomList(inst))) {
2151 DestroyValue(&value);
2152 return MPIARGVAL;
2153 }
2154 break;
2155 case SYMBOL_CONSTANT_INST:
2156 if (ValueKind(value) != symbol_value ||
2157 SymbolValue(value) != GetSymbolAtomValue(inst)) {
2158 assert(AscFindSymbol(SymbolValue(value))!=NULL);
2159 DestroyValue(&value);
2160 return MPIARGVAL;
2161 }
2162 break;
2163 default:
2164 DestroyValue(&value);
2165 return MPIARGVAL;
2166 }
2167 DestroyValue(&value);
2168 return MPIOK;
2169 }
2170
2171 /* evaluate a logical or real relation and see that it
2172 * is satisfied.
2173 * BUG baa. needs to be exception safe and is not.
2174 * returns MPIOK (satisfied)
2175 * returns MPIBADREL (dissatisified)
2176 * returns MPIVARREL (dissatisified - variable result)
2177 * returns MPIWAIT (not yet determinable)
2178 * returns MPIEXCEP (evaluation is impossible due to float/other error)
2179 * returns MPINOTBOOL (dissatisfied- nonboolean result)
2180 * statement given should be a rel or logrel.
2181 */
2182 static
2183 int MPICheckConstraint(struct Instance *tmpinst, struct Statement *statement)
2184 {
2185 struct value_t value;
2186
2187 IVAL(value);
2188
2189 assert(GetEvaluationContext()==NULL);
2190 SetEvaluationContext(tmpinst);
2191 switch (StatementType(statement)){
2192 case REL:
2193 value = EvaluateExpr(RelationStatExpr(statement),NULL,
2194 InstanceEvaluateName);
2195 break;
2196 case LOGREL:
2197 value = EvaluateExpr(LogicalRelStatExpr(statement),NULL,
2198 InstanceEvaluateName);
2199 break;
2200 default:
2201 SetEvaluationContext(NULL);
2202 return MPIWEIRD;
2203 }
2204 SetEvaluationContext(NULL);
2205 switch (ValueKind(value)){
2206 case error_value:
2207 switch(ErrorValue(value)){
2208 case undefined_value:
2209 DestroyValue(&value);
2210 WriteUnexecutedMessage(ASCERR,statement,
2211 "Incomplete expression (value undefined) in argument condition.");
2212 return MPIWAIT;
2213 case name_unfound:
2214 DestroyValue(&value);
2215 WriteUnexecutedMessage(ASCERR,statement,
2216 "Incomplete expression (name unfound) in argument condition.");
2217 return MPIWAIT;
2218 default:
2219 /* it questionable whether this is a correct action in all cases*/
2220 /* we could probably turn out more useful error messages here */
2221 WSEM(ASCERR,statement, "Condition doesn't make sense.");
2222 DestroyValue(&value);
2223 return MPIBADREL;
2224 }
2225 case boolean_value:
2226 if (IsConstantValue(value)!=0) {
2227 if (BooleanValue(value) != FALSE) {
2228 DestroyValue(&value);
2229 return MPIOK;
2230 } else {
2231 DestroyValue(&value);
2232 WSEM(ASCERR,statement, "Arguments do not conform to requirements");
2233 return MPIBADREL;
2234 }
2235 } else {
2236 DestroyValue(&value);
2237 WSEM(ASCERR,statement, "Requirements cannot be satisfied by variables");
2238 return MPIVARREL;
2239 }
2240 default:
2241 DestroyValue(&value);
2242 WSEM(ASCERR,statement, "Constraint does not evaluate to boolean result.");
2243 return MPINOTBOOL;
2244 }
2245 }
2246
2247 /*
2248 * returns MPIOK if subscripts match declarations,
2249 * MPIWAIT if declarations cannot yet be interpretted,
2250 * or some other error if there is a mismatch.
2251 * So far only the square version. Should have a forvar
2252 * capable recursive version sometime when we allow
2253 * passage of sparse arrays.
2254 * Assumes the array given has proper number of
2255 * subscripts to match name and is fully expanded.
2256 */
2257 static
2258 int MPICheckSubscripts(struct Instance *tmpinst,
2259 struct Instance *aryinst,
2260 struct Statement *s)
2261 {
2262 CONST struct Name *nptr;
2263
2264 nptr = NextName(NamePointer(GetStatVarList(s)));
2265 switch (RectangleSubscriptsMatch(tmpinst,aryinst,nptr)) {
2266 case -2:
2267 return MPIWAIT;
2268 case 1:
2269 return MPIOK;
2270 case 0:
2271 default:
2272 return MPIARRRNG;
2273 }
2274 }
2275
2276 /* links parent and child. if checkdup != 0,
2277 * it will check child to see if it already has this parent.
2278 */
2279 #define NOIPICHECK 0
2280 #define IPICHECK 1
2281 static
2282 int InsertParameterInst(struct Instance *parent,
2283 struct Instance *child,
2284 CONST struct Name *name,
2285 CONST struct Statement *statement,
2286 int checkdup)
2287 {
2288 symchar *childname;
2289 struct InstanceName rec;
2290 unsigned long pos;
2291
2292 childname = NameIdPtr(name);
2293 SetInstanceNameType(rec,StrName);
2294 SetInstanceNameStrPtr(rec,childname);
2295 pos = ChildSearch(parent,&rec);
2296 if (pos>0) {
2297 if (InstanceChild(parent,pos)==NULL) {
2298 StoreChildPtr(parent,pos,child);
2299 if (checkdup == 0 || SearchForParent(child,parent)==0) {
2300 /* case where we don't already have it at this scope */
2301 AddParent(child,parent);
2302 }
2303 return 1;
2304 } else { /* redefining instance */
2305 char *msg = ascmalloc(SCLEN(childname)+
2306 strlen(REDEFINE_CHILD_MESG)+1);
2307 strcpy(msg,REDEFINE_CHILD_MESG);
2308 strcat(msg,SCP(childname));
2309 WSEM(ASCERR,statement,msg);
2310 ascfree(msg);
2311 return 0;
2312 }
2313 } else { /* unknown name */
2314 WSEM(ASCERR,statement, "Unknown parameter name. Never should happen");
2315 Asc_Panic(2, NULL, "Unknown parameter name. Never should happen");
2316 exit(2);/* Needed to keep gcc from whining */
2317 }
2318 }
2319
2320 /*
2321 * The instance this is called with should not have
2322 * any parents whatsoever. The instance this is called
2323 * with will be completely destroyed including any parts
2324 * of the instance that do not have other parents.
2325 */
2326 static
2327 void DestroyParameterInst(struct Instance *i)
2328 {
2329 DestroyInstance(i,NULL);
2330 }
2331 /* destroys everything you send it. If you send some arguments in
2332 * as null, we don't mind.
2333 */
2334 static
2335 void ClearMPImem(
2336 struct gl_list_t *args,
2337 struct gl_list_t *il,
2338 struct Instance *tmpinst,
2339 struct Instance *ipass,
2340 struct value_t *valp
2341 )
2342 {
2343 if (args!=NULL) {
2344 gl_iterate(args,(void (*)(VOIDPTR))DestroySetNode);
2345 gl_destroy(args);
2346 }
2347 if (il!=NULL) {
2348 gl_destroy(il);
2349 }
2350 if (tmpinst!=NULL) {
2351 DestroyParameterInst(tmpinst);
2352 }
2353 if (ipass!=NULL) {
2354 DestroyParameterInst(ipass);
2355 }
2356 if (valp!=NULL) {
2357 DestroyValue(valp);
2358 }
2359 }
2360
2361
2362 static
2363 void mpierror(struct Set *argset,
2364 unsigned long argn,
2365 struct Statement *statement,
2366 int errcode)
2367 {
2368 int arrloc;
2369 if (errcode<0) {
2370 arrloc = (-errcode);
2371 } else {
2372 return;
2373 /* why are we here? */
2374 }
2375 FPRINTF(ASCERR,"Parameter passing error: %s\n",g_mpi_message[arrloc]);
2376 if (argset !=NULL && argn >0) {
2377 FPRINTF(ASCERR," Argument %lu:",argn);
2378 WriteSet(ASCERR,argset);
2379 FPRINTF(ASCERR,"\n");
2380 }
2381 WSEM(ASCERR,statement,"Error in executing statement:");
2382 MarkStatContext(statement,context_WRONG);
2383 WSS(ASCERR,statement);
2384 }
2385
2386 static
2387 void MPIwum(struct Set *argset,
2388 unsigned long argn,
2389 struct Statement *statement,
2390 int msgcode)
2391 {
2392 int arrloc;
2393 if (g_iteration < MAXNUMBER) {
2394 return;
2395 }
2396 if (msgcode<0) {
2397 arrloc = (-msgcode);
2398 } else {
2399 return;
2400 /* why are we here? */
2401 }
2402 FPRINTF(ASCERR,"Parameter list waiting on sufficient type or value of:\n");
2403 if (argset !=NULL && argn >0) {
2404 FPRINTF(ASCERR," Argument %lu:",argn);
2405 WriteSetNode(ASCERR,argset);
2406 FPRINTF(ASCERR,"\n");
2407 }
2408 WriteUnexecutedMessage(ASCERR,statement,g_mpi_message[arrloc]);
2409 }
2410
2411 /* process pass by value scalar: evaluate and make it, or return
2412 * appropriate whine if not possible.
2413 * If this returns anything other than mpiok, the user may
2414 * wish to dispose of tmpinst, args as we do not here.
2415 * We do issue whines here, however.
2416 */
2417 static
2418 int MPIMakeSimple(struct Instance *parent,
2419 struct Instance *tmpinst,
2420 struct Set *argset,
2421 unsigned long argn,
2422 CONST struct Name *nptr,
2423 struct TypeDescription *ptype,
2424 int intset,
2425 struct Statement *ps,
2426 struct Statement *statement
2427 )
2428 {
2429 int tverr; /* error return from checking array elt type, or value */
2430 struct Instance *ipass;
2431 struct value_t vpass;
2432
2433 vpass = FindArgValue(parent,argset,&tverr);
2434 if (tverr != 0) {
2435 if (tverr == 1) { /* try later */
2436 MPIwum(argset,argn,statement,MPIUNASSD);
2437 return MPIWAIT;
2438 } else { /* hopeless */
2439 mpierror(argset,argn,statement,MPIBADVAL);
2440 return MPIBADVAL;
2441 }
2442 }
2443 /* don't forget to dispose of vpass if exiting err after here */
2444 ipass = MakeSimpleInstance(ptype,intset,ps,NULL);
2445 if (ipass==NULL) {
2446 DestroyValue(&vpass);
2447 return MPIINSMEM;
2448 }
2449 /* don't forget to dispose of vpass if exiting err after here */
2450 if (AssignStructuralValue(ipass,vpass,statement)!=1) {
2451 mpierror(argset,argn,statement,MPIARGTYPE);
2452 DestroyParameterInst(ipass);
2453 DestroyValue(&vpass);
2454 return MPIARGTYPE;
2455 }
2456 DestroyValue(&vpass);
2457 /* install ipass in tmpinst */
2458 if ( InsertParameterInst(tmpinst,ipass,nptr,ps,IPICHECK) != 1) {
2459 /* noipicheck because var just created has no parents at all,
2460 * unless of course var is UNIVERSAL... so ipicheck */
2461 mpierror(argset,argn,statement,MPIMULTI);
2462 DestroyParameterInst(ipass);
2463 return MPIMULTI;
2464 }
2465 return MPIOK;
2466 }
2467 #define NOKEEPARGINST 0
2468 #define KEEPARGINST 1
2469 /*
2470 * This function is responsible for checking and assembling the
2471 * arguments of the parameterized type referenced in statement,
2472 * using information derived from the parent instance.
2473 * If the type found in the statement given is not a MODEL type,
2474 * we will immediately return 1 and *arginstptr will be set NULL.
2475 *
2476 * In general, we are trying to check and assemble enough information
2477 * to prove that a parameterized IS_A can be executed or proved wrong
2478 * once ExecuteISA sees it.
2479 *
2480 * If keepargs ==KEEPARGINST, then on a successful return,
2481 * *arginstptr will be to a MODEL instance (with no parents)
2482 * with its children derived via parameter list filled in and
2483 * all other children NULL.
2484 * If there are NO children derived via parameter list or
2485 * the reductions list, then *arginstptr will be NULL.
2486 * If keepargs != KEEPARGINST, then arginstptr will not be
2487 * used/set in any way, OTHERWISE it should be NULL on entry.
2488 * If keepargs != KEEPARGINST, then we will do only the minimal
2489 * necessary work to check that the arginst could be created.
2490 * At present, we can't tell what this last ambition amounts to -
2491 * we do the same amount of work regardless, though we try to put
2492 * the more likely to fail steps first.
2493 *
2494 * A successful return value is 1.
2495 *
2496 * A failure possibly to succeed later is 0.
2497 * Possible causes will be detailed via the WriteUnexecutedMessage
2498 * facility.
2499 *
2500 * A permanent failure is any value < 0.
2501 * Causes will be detailed via the WSEM facility, in addition return
2502 * values < 0 have the interpretations given in g_mpi_message[-value]
2503 * above.
2504 */
2505 /*
2506 * assumes statement is well formed, in terms of
2507 * arglist of IS_A/IS_REFINED_TO (if there is one) being of correct length.
2508 * returns fairly quickly for nonmodel and nonparametric
2509 * MODEL types.
2510 */
2511 static
2512 int MakeParameterInst(struct Instance *parent,
2513 struct Statement *statement,
2514 struct Instance **arginstptr,
2515 int keepargs)
2516 {
2517 struct TypeDescription *d; /* the type we are constructing or checking */
2518 struct TypeDescription *atype; /* the type we are being passed */
2519 struct TypeDescription *ptype; /* the type we are expecting */
2520 struct TypeDescription *mrtype; /* the more refined of two types */
2521 symchar *stype; /* the set type we are expecting */
2522 struct gl_list_t *args; /* parameter Set given split for easy access */
2523 struct gl_list_t *il; /* instance(s) required to digest a parameter */
2524 struct Instance *ipass; /* instance being passed into type */
2525 struct Instance *tmpinst; /* holding instance for derivation work. */
2526 struct StatementList *psl; /* list of parameters the type requires */
2527 struct StatementList *absorbed; /* list of absorbed isas and casgns */
2528 struct Statement *ps; /* a statement from psl */
2529 struct Set *argset; /* set element extracted from arglist */
2530 CONST struct VariableList *vl;
2531 struct for_table_t *SavedForTable;
2532 unsigned long slen,c,argn;
2533 int tverr; /* error return from checking array elt type, or value */
2534 int suberr; /* error return from other routine */
2535 int intset;
2536 enum find_errors ferr;
2537 unsigned int pc; /* number of parameters the type requires */
2538
2539 if (StatWrong(statement)) {
2540 /* incorrect statements should be warned about when they are
2541 * marked wrong, so we just ignore them here.
2542 */
2543 return MPIOK;
2544 }
2545 d = FindType(GetStatType(statement));
2546 if (d==NULL) {
2547 /* lint should make this impossible */
2548 mpierror(NULL,0L,statement,MPIINPUT);
2549 return MPIINPUT;
2550 }
2551 if (keepargs == KEEPARGINST && arginstptr == NULL) {
2552 /* someone screwed up the call, but maybe they get it right later. */
2553 FPRINTF(ASCERR," *** MakeParameterInst miscalled *** \n");
2554 return MPIWAIT;
2555 }
2556 if (keepargs == KEEPARGINST) {
2557 /* init arginstptr */
2558 *arginstptr = NULL;
2559 }
2560 if ( GetBaseType(d)!=model_type) {
2561 return MPIOK;
2562 }
2563 pc = GetModelParameterCount(d);
2564 absorbed = GetModelAbsorbedParameters(d);
2565 if (pc==0 && StatementListLength(absorbed)==0L) {
2566 /* no parameters in this type or its ancestors */
2567 return MPIOK;
2568 }
2569 /* init tmpinst, which we must remember to punt before
2570 * error returns or nokeep returns.
2571 */
2572 /* may want an SCMUI here, not sure. */
2573 tmpinst = CreateModelInstance(d);
2574 if (tmpinst==NULL) {
2575 mpierror(NULL,0L,statement,MPIINPUT);
2576 return MPIINSMEM;
2577 }
2578 args = gl_create((unsigned long)pc);
2579 if (args == NULL) {
2580 mpierror(NULL,0L,statement,MPIINPUT);
2581 ClearMPImem(NULL,NULL,tmpinst,NULL,NULL);
2582 return MPIINSMEM;
2583 }
2584 SplitArgumentSet(GetStatTypeArgs(statement),args);
2585 /* due to typelint, the following assertion should pass. fix lint if not. */
2586 assert(gl_length(args)==(unsigned long)pc);
2587 psl = GetModelParameterList(d);
2588 slen = StatementListLength(psl);
2589 argn = 1L;
2590 for (c = 1; c <= slen; c++) {
2591 ps = GetStatement(psl,c);
2592 vl = GetStatVarList(ps); /* move inside switch if allow FOR later */
2593 ptype = FindType(GetStatType(ps));
2594 stype = GetStatSetType(ps);
2595 intset = CalcSetType(stype,ps);
2596 if (intset <0 || intset >1) {
2597 /* shouldn't be possible -- typelint trapped */
2598 mpierror(NULL,0L,statement,MPIARGTYPE);
2599 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2600 return MPIARGTYPE;
2601 }
2602 switch (StatementType(ps)) {
2603 case WILLBE:
2604 while (vl != NULL) {
2605 argset = GETARG(args,argn);
2606 il = FindArgInsts(parent,argset,&ferr);
2607 if (il == NULL) {
2608 switch(ferr) {
2609 case unmade_instance:
2610 case undefined_instance: /* this case ought to be separable */
2611 MPIwum(argset,argn,statement,MPIUNMADE);
2612 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2613 return MPIWAIT;
2614 case impossible_instance:
2615 mpierror(argset,argn,statement,MPIBADARG);
2616 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2617 return MPIBADARG;
2618 case correct_instance:
2619 mpierror(argset,argn,statement,MPIWEIRD);
2620 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2621 return MPIWEIRD;
2622 }
2623 }
2624 if (gl_length(il)!=1L) {
2625 mpierror(argset,argn,statement,MPIMULTI);
2626 ClearMPImem(args,il,tmpinst,NULL,NULL);
2627 return MPIMULTI;
2628 }
2629 ipass = (struct Instance *)gl_fetch(il,1L);
2630 gl_destroy(il);
2631 il = NULL;
2632 if (SimpleNameIdPtr(NamePointer(vl))==NULL) {
2633 /* arg required is an array, check this.
2634 * check complete expansion of arg, constant type or not.
2635 * check compatible base type of all elements with spec-
2636 * note we haven't checked subscript ranges at this point.
2637 */
2638 if (IsArrayInstance(ipass)==0) {
2639 mpierror(argset,argn,statement,MPIARGTYPE);
2640 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2641 return MPIARGTYPE;
2642 }
2643 if (RectangleArrayExpanded(ipass)==0) {
2644 /* this works for sparse or dense because sparse won't
2645 * exist except in the fully expanded state due to
2646 * the construction all at once.
2647 */
2648 MPIwum(argset,argn,statement,MPIUNMADE);
2649 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2650 return MPIWAIT;
2651 }
2652 if (NumberofDereferences(ipass) !=
2653 (unsigned long)(NameLength(NamePointer(vl)) - 1)) {
2654 /* I may need an offset other than -1 here */
2655 mpierror(argset,argn,statement,MPIARGSIZ);
2656 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2657 return MPIARGTYPE;
2658 }
2659 tverr = ArrayElementsTypeCompatible(ipass,ptype,stype);
2660 switch (tverr) {
2661 case 1:
2662 /* happy happy joy joy */
2663 break;
2664 case 0:
2665 MPIwum(argset,argn,statement,MPIWEAKTYPE);
2666 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2667 return MPIWAIT;
2668 default:
2669 mpierror(argset,argn,statement,MPIARGTYPE);
2670 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2671 return MPIARGTYPE;
2672 }
2673 if (ArgValuesUnassigned(ipass)!=0) {
2674 MPIwum(argset,argn,statement,MPIUNASSD);
2675 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2676 return MPIWAIT;
2677 }
2678 } else {
2679 /* arg must be scalar/set/MODEL */
2680 atype = InstanceTypeDesc(ipass);
2681 if (atype==ptype) {
2682 /* we're happy unless sets of mismatched base */
2683 if (stype!=NULL) {
2684 if ((IntegerSetInstance(ipass)!=0 && intset==0) ||
2685 (IntegerSetInstance(ipass)==0 && intset==1)) {
2686 mpierror(argset,argn,statement,MPIARGTYPE);
2687 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2688 return MPIARGTYPE;
2689 }
2690 }
2691 } else {
2692 mrtype = MoreRefined(atype,ptype);
2693 if (mrtype==NULL) {
2694 mpierror(argset,argn,statement,MPIARGTYPE);
2695 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2696 return MPIARGTYPE;
2697 }
2698 if (mrtype==ptype) {
2699 /* arg is less refined than param spec. maybe better later */
2700 MPIwum(argset,argn,statement,MPIWEAKTYPE);
2701 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2702 return MPIWAIT;
2703 }
2704 }
2705 if (ArgValuesUnassigned(ipass)!=0) {
2706 MPIwum(argset,argn,statement,MPIUNASSD);
2707 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2708 return MPIWAIT;
2709 }
2710 /* here we check against WITH_VALUE clause, if one in ps */
2711 suberr = ArgValueCorrect(ipass,tmpinst,ps);
2712 switch(suberr) {
2713 case MPIOK:
2714 break;
2715 case MPIWAIT:
2716 /* can only occur if other portions of tmpinst needed to compute
2717 * check value are not in place yet. no wum here because
2718 * Digest below will catch it if it's broken.
2719 */
2720 break;
2721 /* may need additional cases depending on argval implementation */
2722 default:
2723 mpierror(argset,argn,statement,MPIARGVAL);
2724 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2725 }
2726 }
2727 /* install ipass in tmpinst */
2728 if ( InsertParameterInst(tmpinst,ipass,NamePointer(vl),ps,IPICHECK)
2729 !=1) {
2730 /* ipicheck because we might be passed same instance in 2 slots */
2731 mpierror(argset,argn,statement,MPIMULTI);
2732 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2733 return MPIMULTI;
2734 }
2735 argn++;
2736 vl = NextVariableNode(vl);
2737 }
2738 break;
2739 case ISA:
2740 argset = GETARG(args,argn);
2741 if (SimpleNameIdPtr(NamePointer(vl))!=NULL) {
2742 /* scalar: evaluate and make it */
2743 suberr = MPIMakeSimple(parent,tmpinst,argset,argn,
2744 NamePointer(vl),ptype,intset,ps,statement);
2745 if (suberr!=MPIOK) {
2746 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2747 return suberr;
2748 }
2749 } else {
2750 /* check completedness, assignedness, base type of array-by-value
2751 * and copy. Note that what we copy may prove to be incompatible
2752 * later when we check the names of subscripts.
2753 */
2754 il = FindArgInsts(parent,argset,&ferr);
2755 if (il == NULL) {
2756 switch(ferr) {
2757 case unmade_instance:
2758 case undefined_instance: /* this case ought to be separable */
2759 MPIwum(argset,argn,statement,MPIUNMADE);
2760 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2761 return MPIWAIT;
2762 case impossible_instance:
2763 mpierror(argset,argn,statement,MPIBADARG);
2764 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2765 return MPIBADARG;
2766 case correct_instance:
2767 mpierror(argset,argn,statement,MPIWEIRD);
2768 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2769 return MPIWEIRD;
2770 }
2771 }
2772 if (gl_length(il)!=1L) {
2773 mpierror(argset,argn,statement,MPIMULTI);
2774 ClearMPImem(args,il,tmpinst,NULL,NULL);
2775 return MPIMULTI;
2776 }
2777 ipass = (struct Instance *)gl_fetch(il,1L);
2778 gl_destroy(il);
2779 il = NULL;
2780 /* arg required is an array, check this.
2781 * check complete expansion of arg, constant type or not.
2782 * check compatible base type of all elements with spec-
2783 * note we haven't checked subscript ranges at this point.
2784 */
2785 if (IsArrayInstance(ipass)==0) {
2786 mpierror(argset,argn,statement,MPIARGTYPE);
2787 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2788 return MPIARGTYPE;
2789 }
2790 if (RectangleArrayExpanded(ipass)==0) {
2791 /* this works for spare or dense because sparse won't
2792 * exist except in the fully expanded state due to
2793 * the construction all at once.
2794 */
2795 MPIwum(argset,argn,statement,MPIUNMADE);
2796 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2797 return MPIWAIT;
2798 }
2799 if (NumberofDereferences(ipass) !=
2800 (unsigned long)(NameLength(NamePointer(vl)) - 1)) {
2801 /* I may need an offset other than -1 here */
2802 mpierror(argset,argn,statement,MPIARGSIZ);
2803 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2804 return MPIARGTYPE;
2805 }
2806 tverr = ArrayElementsTypeCompatible(ipass,ptype,stype);
2807 switch (tverr) {
2808 case 1:
2809 /* happy happy joy joy */
2810 break;
2811 case 0:
2812 /* wum here */
2813 MPIwum(argset,argn,statement,MPIWEAKTYPE);
2814 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2815 return MPIWAIT;
2816 default:
2817 mpierror(argset,argn,statement,MPIARGTYPE);
2818 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2819 return MPIARGTYPE;
2820 }
2821 if (ArgValuesUnassigned(ipass)!=0) {
2822 MPIwum(argset,argn,statement,MPIUNASSD);
2823 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2824 return MPIWAIT;
2825 }
2826 /* this copy will mess up tmpnums in old ipass. */
2827 ipass = CopyInstance(ipass);
2828 /* note the copy has only been verified to work for completed
2829 * arrays of constants, not models.
2830 */
2831 /* we don't care about the old ipass any more. check new one. */
2832 if (ipass==NULL) {
2833 mpierror(argset,argn,statement,MPIINSMEM);
2834 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2835 return MPIMULTI;
2836 }
2837 /* install ipass in tmpinst */
2838 if ( InsertParameterInst(tmpinst,ipass,NamePointer(vl),ps,NOIPICHECK)
2839 !=1 /* arrays cannot be UNIVERSAL */ ) {
2840 mpierror(argset,argn,statement,MPIMULTI);
2841 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2842 return MPIMULTI;
2843 }
2844 /* we still need to check the subscripts for compatibility with
2845 * arg description. can't do yet.
2846 */
2847 }
2848 argn++;
2849 break;
2850 default:
2851 Asc_Panic(2, NULL, "how the hell did typelint let that through?");
2852 /* how the hell did typelint let that through? */
2853 break;
2854 }
2855 }
2856 /* ok, so now we have everything passed (which might be nothing)
2857 * in place. We need to check WITH_VALUE's, subscript ranges,
2858 * and insist all scalars end up assigned while processing
2859 * the absorbed statements. Possibly may still find undefined
2860 * values in rhs of assignments or in subscript ranges, drat.
2861 * May take several passes.
2862 */
2863
2864 suberr = DigestArguments(tmpinst,args,psl,absorbed,statement); /*1*/
2865 switch(suberr) {
2866 case MPIOK:
2867 break;
2868 case MPIWAIT:
2869 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2870 return MPIWAIT;
2871 default:
2872 /* anything else is an error. mpierror will have been called. */
2873 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2874 return MPIINPUT;
2875 }
2876
2877 /* ok, now we need to check where statement list. */
2878 SavedForTable = GetEvaluationForTable();
2879 SetEvaluationForTable(CreateForTable());
2880 suberr = CheckWhereStatements(tmpinst,GetModelParameterWheres(d));
2881 DestroyForTable(GetEvaluationForTable());
2882 SetEvaluationForTable(SavedForTable);
2883 switch(suberr) {
2884 case MPIOK:
2885 break;
2886 case MPIWAIT:
2887 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2888 return MPIWAIT;
2889 default:
2890 /* anything else is an error */
2891 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2892 mpierror(NULL,0,statement,suberr);
2893 return suberr;
2894 }
2895
2896 ClearMPImem(args,NULL,NULL,NULL,NULL);
2897 if (keepargs == KEEPARGINST) {
2898 *arginstptr = tmpinst;
2899 } else {
2900 DestroyParameterInst(tmpinst);
2901 }
2902 return MPIOK;
2903 }
2904
2905 static
2906 int MPICheckWBTS(struct Instance *tmpinst, struct Statement *statement)
2907 {
2908 struct gl_list_t *instances;
2909 unsigned long c,len;
2910 enum find_errors err;
2911 struct Instance *head;
2912
2913 instances = FindInsts(tmpinst,GetStatVarList(statement),&err);
2914 if (instances==NULL) {
2915 switch(err){
2916 case impossible_instance:
2917 MissingInsts(tmpinst,GetStatVarList(statement),1);
2918 WSEM(ASCERR,statement,
2919 "WILL_BE_THE_SAME statement contains an impossible instance name");
2920 return MPIBADWBTS;
2921 default:
2922 MissingInsts(tmpinst,GetStatVarList(statement),0);
2923 WriteUnexecutedMessage(ASCERR,statement,
2924 "Incomplete instances in WILL_BE_THE_SAME");
2925 return MPIWAIT; /* statement is not ready to be executed */
2926 }
2927 }
2928 len = gl_length(instances);
2929 if (len >0 ) {
2930 head = gl_fetch(instances,1);
2931 }
2932 for (c=2; c<=len; c++) {
2933 if (((struct Instance *)gl_fetch(instances,c)) != head) {
2934 if (IsArrayInstance(head)==0 &&
2935 MoreRefined(InstanceTypeDesc(gl_fetch(instances,c)),
2936 InstanceTypeDesc(head))==NULL) {
2937 /* can't be merged later */
2938 WSEM(ASCERR,statement,
2939 "WILL_BE_THE_SAME statement contains incompatible instances");
2940 gl_destroy(instances);
2941 return MPIBADWBTS;
2942 } else {
2943 /* maybe merge later */
2944 WriteUnexecutedMessage(ASCERR,statement,
2945 "Unmerged instances in WILL_BE_THE_SAME");
2946 gl_destroy(instances);
2947 return MPIWAIT;
2948 }
2949 }
2950 }
2951 gl_destroy(instances);
2952 return MPIOK;
2953 }
2954
2955 #define MPICheckWB(a,b) MPIWEIRD
2956 /* WILL_BE not yet legal in where section. implement later if req'd */
2957
2958 /*
2959 * verifies that all the instances found, if any, are different.
2960 * uses an nlogn (n = # of instance) algorithm, which
2961 * could be made order n using the interface pointer protocol,
2962 * but the additional overhead makes the multiplier for
2963 * o(n) probably not worth the trouble.
2964 */
2965 static
2966 int MPICheckWNBTS(struct Instance *tmpinst, struct Statement *statement)
2967 {
2968 struct gl_list_t *instances;
2969 enum find_errors err;
2970
2971 instances = FindInsts(tmpinst,GetStatVarList(statement),&err);
2972 if (instances==NULL) {
2973 switch(err){
2974 case impossible_instance:
2975 MissingInsts(tmpinst,GetStatVarList(statement),1);
2976 WSEM(ASCERR,statement,
2977 "WILL_NOT_BE_THE_SAME statement contains an impossible instance name");
2978 return MPIBADWNBTS;
2979 default:
2980 MissingInsts(tmpinst,GetStatVarList(statement),0);
2981 WriteUnexecutedMessage(ASCERR,statement,
2982 "Incomplete instances in WILL_NOT_BE_THE_SAME");
2983 return MPIWAIT; /* statement is not ready to be executed */
2984 }
2985 }
2986 if (gl_unique_list(instances)==0) {
2987 WSEM(ASCERR,statement,
2988 "WILL_NOT_BE_THE_SAME statement contains"
2989 " identical/merged instances");
2990 gl_destroy(instances);
2991 return MPIBADMERGE;
2992 }
2993 gl_destroy(instances);
2994 return MPIOK;
2995 }
2996 /*
2997 * Checks the for statements, along with all the horrid machinery needed
2998 * to make a for loop go.
2999 */
3000 static
3001 int CheckWhereFOR(struct Instance *inst, struct Statement *statement)
3002 {
3003 symchar *name;
3004 struct Expr *ex;
3005 struct StatementList *sl;
3006 unsigned long c,len;
3007 struct value_t value;
3008 struct set_t *sptr;
3009 struct for_var_t *fv;
3010 int code=MPIOK;
3011
3012 name = ForStatIndex(statement);
3013 ex = ForStatExpr(statement);
3014 sl = ForStatStmts(statement);
3015 if (FindForVar(GetEvaluationForTable(),name)){ /* duplicated for variable */
3016 WSEM(ASCERR,statement, "FOR construct uses duplicate index variable");
3017 return MPIFOR;
3018 }
3019 assert(GetEvaluationContext()==NULL);
3020 SetEvaluationContext(inst);
3021 value = EvaluateExpr(ex,NULL,InstanceEvaluateName);
3022 SetEvaluationContext(NULL);
3023 switch(ValueKind(value)){
3024 case error_value:
3025 switch(ErrorValue(value)){
3026 case name_unfound:
3027 case undefined_value:
3028 DestroyValue(&value);
3029 WSEM(ASCERR,statement, "FOR has undefined values");
3030 return MPIFOR; /* this maybe should be mpiwait? */
3031 default:
3032 WriteForValueError(statement,value);
3033 DestroyValue(&value);
3034 return MPIFOR;
3035 }
3036 case real_value:
3037 case integer_value:
3038 case symbol_value:
3039 case boolean_value:
3040 case list_value:
3041 WriteStatement(ASCERR,statement,0);
3042 FPRINTF(ASCERR,"FOR expression returns the wrong type.\n");
3043 DestroyValue(&value);
3044 return MPIFOR;
3045 case set_value:
3046 sptr = SetValue(value);
3047 switch(SetKind(sptr)){
3048 case empty_set: break;
3049 case integer_set:
3050 fv = CreateForVar(name);
3051 SetForVarType(fv,f_integer);
3052 AddLoopVariable(GetEvaluationForTable(),fv);
3053 len = Cardinality(sptr);
3054 for(c=1;c<=len;c++){
3055 SetForInteger(fv,FetchIntMember(sptr,c));
3056 code = CheckWhereStatements(inst,sl);
3057 if (code != MPIOK) {
3058 break;
3059 }
3060 }
3061 RemoveForVariable(GetEvaluationForTable());
3062 break;
3063 case string_set:
3064 fv = CreateForVar(name);
3065 SetForVarType(fv,f_symbol);
3066 AddLoopVariable(GetEvaluationForTable(),fv);
3067 len = Cardinality(sptr);
3068 for(c=1;c<=len;c++){
3069 SetForSymbol(fv,FetchStrMember(sptr,c));
3070 code = CheckWhereStatements(inst,sl);
3071 if (code != MPIOK) {
3072 break;
3073 }
3074 }
3075 RemoveForVariable(GetEvaluationForTable());
3076 break;
3077 }
3078 DestroyValue(&value);
3079 }
3080 return code;
3081 }
3082 /*
3083 * checks that all conditions are satisfied, else returns a whine.
3084 * does not call mpierror, so caller ought to if needed.
3085 * returns one of the defined MPI codes.
3086 */
3087 static
3088 int CheckWhereStatements(struct Instance *tmpinst, struct StatementList *sl)
3089 {
3090 unsigned long c,len;
3091 struct Statement *s;
3092 int code=MPIOK;
3093
3094 if (tmpinst ==NULL) {
3095 return MPIWEIRD;
3096 }
3097 len = StatementListLength(sl);
3098 for (c=1;c <= len && code == MPIOK; c++) {
3099 s = GetStatement(sl,c);
3100 switch (StatementType(s)) {
3101 case WBTS:
3102 code = MPICheckWBTS(tmpinst,s);
3103 break;
3104 case WNBTS:
3105 code = MPICheckWNBTS(tmpinst,s);
3106 break;
3107 case WILLBE:
3108 code = MPICheckWB(tmpinst,s);
3109 break;
3110 case LOGREL:
3111 case REL:
3112 /* baa. fix me. bug. need to evaluate rules in a way which is
3113 * exception-safe. EvaluateExpr currently isn't
3114 */
3115 code = MPICheckConstraint(tmpinst,s);
3116 break;
3117 case FOR:
3118 code = CheckWhereFOR(tmpinst,s);
3119 break;
3120 default:
3121 code = MPIWEIRD;
3122 break;
3123 }
3124 }
3125 return code;
3126 }
3127
3128 #if 0 /* migrating, or migraining, depending on your viewpoint, to parpend.h */
3129 enum ppstatus {
3130 pp_ERR =0,
3131 pp_ISA, /* IS_A of simple to be done, from absorbed. */
3132 pp_ISAARR, /* IS_A of array to do, from absorbed and
3133 * gets converted to asar during processing.
3134 */
3135 pp_ARR, /* array that's constructed but requires range checking */
3136 pp_ASGN, /* assignment to do in absorbed objects */
3137 pp_ASSC, /* scalar assignment to check in absorbed objects */
3138 pp_ASAR, /* Array to be checked for being completely assigned,
3139 * but its subscript range is presumed right.
3140 */
3141 pp_WV, /* WITH_VALUE to be checked */
3142 pp_DONE /* finished statement */
3143 };
3144
3145 struct parpendingentry {
3146 struct Set *arg; /* parameter given in user's IS_A statement */
3147 struct Statement *s;
3148 struct Instance *inst;
3149 struct parpendingentry *next;
3150 enum ppstatus status;
3151 int argn; /* the psl position if >0, or -(the absorbed position) if <0 */
3152 /* argn==0 is an error */
3153 };
3154
3155 #endif /* 0 migraining */
3156
3157 /*
3158 * returns a single instance, if such can be properly derived
3159 * from the name given.
3160 * Returns NULL if too many or no instances are found.
3161 * Probably ought to have a return code, but doesn't.
3162 */
3163 static
3164 struct Instance *GetNamedInstance(CONST struct Name *nptr,
3165 CONST struct Instance *tmpinst)
3166 {
3167 struct Instance *i=NULL;
3168 struct gl_list_t *insts;
3169 enum find_errors ferr;
3170
3171 assert(nptr!=NULL);
3172 assert(tmpinst!=NULL);
3173 insts = FindInstances(tmpinst,nptr,&ferr);
3174 if (insts==NULL) {
3175 return NULL;
3176 }
3177 if (gl_length(insts) == 1L) {
3178 i = (struct Instance *)gl_fetch(insts,1);
3179 }
3180 gl_destroy(insts);
3181 return i;
3182 }
3183
3184 /*
3185 * put the parameters open (if any) and absorbed statements into the
3186 * pending list we're creating.
3187 */
3188 static
3189 struct parpendingentry *
3190 CreateParameterPendings(struct Instance *tmpinst,
3191 struct gl_list_t *args,
3192 struct StatementList *psl,
3193 struct StatementList *absorbed)
3194 {
3195 unsigned long c,len;
3196 struct parpendingentry *new, *list=NULL;
3197 CONST struct Expr *ex;
3198 struct gl_list_t *nlist=NULL;
3199
3200 assert(args!=NULL);
3201
3202 len = gl_length(args);
3203 for (c=len; c >= 1; c--) {
3204 new = CreatePPE();
3205 /* Create must not return NULL */
3206 new->arg = gl_fetch(args,c);
3207 new->s = GetStatement(psl,c);
3208 new->inst = NULL;
3209 new->argn = c;
3210 switch (StatementType(new->s)) {
3211 case WILLBE:
3212 /* assumes lint did it's job */
3213 if (NameLength(NamePointer(GetStatVarList(new->s))) > 1) {
3214 /* arrays were connected already, but no subscript check */
3215 new->inst = GetArrayHead(tmpinst,NamePointer(GetStatVarList(new->s)));
3216 new->status = pp_ARR;
3217 } else {
3218 /* scalar */
3219 ex = GetStatCheckValue(new->s);
3220 if (ex != NULL) {
3221 nlist = EvaluateNamesNeededShallow(ex,NULL,NULL);
3222 assert(nlist!=NULL);
3223 if (gl_length(nlist) != 0L) {
3224 new->status = pp_WV;
3225 new->inst =
3226 GetNamedInstance(NamePointer(GetStatVarList(new->s)),tmpinst);
3227 } else {
3228 /* nothing further to check. done already */
3229 DestroyPPE(new);
3230 new = NULL;
3231 }
3232 gl_destroy(nlist);
3233 } else {
3234 DestroyPPE(new);
3235 new = NULL;
3236 }
3237 }
3238 break;
3239 case ISA:
3240 if (NameLength(NamePointer(GetStatVarList(new->s))) > 1) {
3241 /* subscript check */
3242 new->inst = GetArrayHead(tmpinst,NamePointer(GetStatVarList(new->s)));
3243 new->status = pp_ARR;
3244 } else {
3245 /* nothing further to check. assumed done already */
3246 DestroyPPE(new);
3247 new = NULL;
3248 }
3249 break;
3250 default:
3251 Asc_Panic(2, "CreateParameterPendings",
3252 "Unknown statement type in CreateParameterPendings!\n");
3253 break;
3254 }
3255 if (new != NULL) {
3256 /* insert at head, but completed statements don't get added */
3257 new->next = list;
3258 list = new;
3259 }
3260 }
3261 len = StatementListLength(absorbed);
3262 for (c=len; c >= 1; c--) {
3263 new = CreatePPE();
3264 /* Create must not return NULL */
3265 new->arg = NULL;
3266 new->s = GetStatement(absorbed,c);
3267 new->inst = NULL;
3268 new->argn =0; new->argn -= c;
3269 switch (StatementType(new->s)) {
3270 case ISA:
3271 if (NameLength(NamePointer(GetStatVarList(new->s))) > 1) {
3272 /* array needed and subscript check */
3273 new->status = pp_ISAARR;
3274 /* after construction, no check until fully assigned at end */
3275 } else {
3276 /* simplename */
3277 new->status = pp_ISA;
3278 }
3279 break;
3280 case CASGN:
3281 new->status = pp_ASGN;
3282 break;
3283 default:
3284 Asc_Panic(2, "CreateParameterPendings",
3285 "Unknown statement type in CreateParameterPendings!\n");
3286 break;
3287 }
3288 new->next = list;
3289 list = new;
3290 }
3291 return list;
3292 }
3293 /* destroy a list of pending parameter items.
3294 */
3295 static
3296 void DestroyParameterPendings( struct parpendingentry *pp)
3297 {
3298 struct parpendingentry *old;
3299 while (pp!=NULL) {
3300 old = pp;
3301 pp = pp->next;
3302 DestroyPPE(old);
3303 }
3304 }
3305
3306 /*
3307 * this function should not be entered until all WB arguments have
3308 * been installed in tmpinst.
3309 */
3310 static
3311 int DigestArguments(
3312 struct Instance *tmpinst,
3313 struct gl_list_t *args,
3314 struct StatementList *psl,
3315 struct StatementList *absorbed,
3316 struct Statement *statement)
3317 {
3318 struct parpendingentry *pp, /* current work */
3319 *pphead, /* first in work list */
3320 *pplast; /* just prior work, so can delete current */
3321 int change = 1;
3322 int suberr = MPIOK; /* maybe mpi enum */
3323
3324 pphead = pp = CreateParameterPendings(tmpinst,args,psl,absorbed);
3325 while (change && pphead!=NULL && suberr ==MPIOK) {
3326 pplast = NULL;
3327 pp = pphead;
3328 change = 0;
3329 while (pp != NULL && suberr ==MPIOK) {
3330 switch (pp->status) {
3331 case pp_ISA:
3332 /* building a scalar! OTHERWISE recursion could bite us.
3333 * We don't use mpimakesimpleinstance because no argval.
3334 */
3335 suberr = ExecuteISA(tmpinst,pp->s);
3336 if (suberr!=1) {
3337 suberr = MPIWEIRD;
3338 pp->status = pp_ERR;
3339 FPRINTF(ASCERR,"While executing (1) absorbed statement in %s:\n",
3340 SCP(GetName(InstanceTypeDesc(tmpinst))));
3341 WriteStatement(ASCERR,pp->s,2);
3342 mpierror(NULL,0,statement,suberr);
3343 } else {
3344 pp->inst =
3345 GetNamedInstance(NamePointer(GetStatVarList(pp->s)),tmpinst);
3346 if (pp->inst != NULL) {
3347 suberr = MPIOK;
3348 pp->status = pp_ASSC;
3349 } else {
3350 suberr = MPIWEIRD;
3351 pp->status = pp_ERR;
3352 FPRINTF(ASCERR,"While executing (2) absorbed statement in %s:\n",
3353 SCP(GetName(InstanceTypeDesc(tmpinst))));
3354 WriteStatement(ASCERR,pp->s,2);
3355 mpierror(NULL,0,statement,suberr);
3356 }
3357 }
3358 change++;
3359 break;
3360 /* done case */
3361 case pp_ISAARR:
3362 /* IS_A of array that needs doing, range, args assignment */
3363 if (CheckISA(tmpinst,pp->s) == 1) {
3364 /* Must have subscripts defined first, because we do not
3365 * want the array to be put on the global pending list as
3366 * that would be algorithmic suicide. The whole point of
3367 * parameters is reducing a set of operations to a point
3368 * in the ProcessPending execution cycle.
3369 */
3370 suberr = ExecuteISA(tmpinst,pp->s);
3371 /* so the array should be completely expanded now. */
3372 /* we won't check unless problems start to show up,
3373 * since we believe the array code to be correct.
3374 */
3375 if (suberr!=1) {
3376 suberr = MPIWEIRD;
3377 pp->status = pp_ERR;
3378 FPRINTF(ASCERR,"While executing (3) absorbed statement in %s:\n",
3379 SCP(GetName(InstanceTypeDesc(tmpinst))));
3380 WriteStatement(ASCERR,pp->s,2);
3381 mpierror(NULL,0,statement,suberr);
3382 } else {
3383 pp->inst =GetArrayHead(tmpinst,NamePointer(GetStatVarList(pp->s)));
3384 if (pp->inst == NULL) {
3385 suberr = MPIWEIRD;
3386 pp->status = pp_ERR;
3387 FPRINTF(ASCERR,"While executing (4) absorbed statement in %s:\n",
3388 SCP(GetName(InstanceTypeDesc(tmpinst))));
3389 WriteStatement(ASCERR,pp->s,2);
3390 mpierror(NULL,0,statement,