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