/[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 373 - (hide annotations) (download) (as text)
Tue Mar 14 08:39:37 2006 UTC (13 years, 9 months ago) by johnpye
File MIME type: text/x-csrc
File size: 385172 byte(s)
Tidied up formatting in measures.a4l
Added GPL notice to cavity.a4c
Fixed up reconfig to turn OFF gcov testing by default.
Removed some debug output from typedef.c and instantiate.c and arrayinst.c.
Commenting changes in extinst.h.
Working on getting the buildbot working :-)
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);