/[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 467 - (hide annotations) (download) (as text)
Mon Apr 17 03:18:06 2006 UTC (13 years, 7 months ago) by ben.allan
File MIME type: text/x-csrc
File size: 384864 byte(s)
Changed the syntax of import from
IMPORT id FROM id;
to
IMPORT id FROM "quoted/text/lib";
Writing external
METHOD calls via the EXTERNAL methname(arglist);
now works.

Against my better judgement in a few cases,
cleaned up the old EXT statement code from Abbott
to work in a typesafe manner. A better solution
is to get the CALL syntax working as defined in 
the grammar, but this takes a good deal more work
and meanwhile people want to get their phds...

Still some known bugs in relation_util.
I need to commit the test models that go with
the EXT statements. Fixed a bunch of lintish
compiler complaints. Don't try to solve external
models yet.

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