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