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

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

Parent Directory Parent Directory | Revision Log Revision Log


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