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