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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 839 - (show annotations) (download) (as text)
Fri Sep 8 07:46:53 2006 UTC (15 years, 9 months ago) by johnpye
File MIME type: text/x-csrc
File size: 379408 byte(s)
Removed some debug output from cond_config.c
Added superposition test (beam2.a4c)
Fixed up problems in beam.a4c (ongoing).
1 /* 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 #include <stdarg.h>
32 #include <utilities/ascConfig.h>
33 #include <utilities/ascMalloc.h>
34 #include <utilities/ascPanic.h>
35 #include <utilities/error.h>
36 #include <general/pool.h>
37 #include <general/list.h>
38 #include <general/dstring.h>
39 #include "compiler.h"
40 #if TIMECOMPILER
41 #include <time.h>
42 #include <general/tm_time.h>
43 #endif
44 #include "bit.h"
45 #include "symtab.h"
46 #include "fractions.h"
47 #include "dimen.h"
48 #include "functype.h"
49 #include "expr_types.h"
50 #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 /* new headers */
88 #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
112 /* don't even THINK ABOUT adding instmacro.h to this list -- ...what the? */
113
114 #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 /* moved from tcltk/generic/interface/SimsProc.c */
139 struct Instance *g_cursim;
140
141 #define NEW_ext 1
142 #define OLD_ext 0
143 /**<
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
149 #define MAX_VAR_IN_LIST 20
150 /**<
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
156 int g_use_copyanon = 1;
157 /**
158 the user switch for anonymous type based relation
159 copying. if 0, no copying by that method is done.
160 */
161
162 #if TIMECOMPILER
163 static int g_ExecuteREL_CreateTokenRelation_calls = 0;
164 /**<
165 count the number of calls to CreateTokenRelation from ExecuteREL
166 */
167
168 int g_CopyAnonRelation = 0;
169 #endif
170
171 long int g_compiler_counter = 1;
172 /**<
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
178 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
185 /* #define DEBUG_RELS */
186 /* 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 /*------------------------------------------------------------------------------
215 forward declarations
216 */
217
218 static void WriteForValueError(struct Statement *, struct value_t);
219 static void MakeInstance(CONST struct Name *, struct TypeDescription *, int,
220 struct Instance *, struct Statement *, struct Instance *);
221 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 struct gl_list_t *, struct StatementList *,
227 struct StatementList *, struct Statement *);
228 static int DeriveSetType(CONST struct Set *, struct Instance *,CONST unsigned int);
229
230 static struct gl_list_t *FindInsts(struct Instance *, CONST struct VariableList *,
231 enum find_errors *);
232
233 static void MissingInsts(struct Instance *, CONST struct VariableList *,int);
234 static struct gl_list_t *FindArgInsts(struct Instance *, struct Set *,
235 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 static int AssignStructuralValue(struct Instance *,struct value_t,struct Statement *);
241 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 /*-----------------------------------------------------------------------------
298 ...
299 */
300
301
302 static
303 void ClearIteration(void)
304 {
305 g_iteration = 0;
306 }
307
308 static
309 void instantiation_error(error_severity_t sev
310 , const struct Statement *stat, const char *fmt
311 , ...
312 ){
313 va_list args;
314 va_start(args,fmt);
315 if(stat!= NULL){
316 va_error_reporter(sev
317 , Asc_ModuleBestName(StatementModule(stat))
318 , StatementLineNum(stat), NULL
319 , fmt, args
320 );
321 }else{
322 va_error_reporter(sev
323 , NULL, 0, NULL
324 , fmt, args
325 );
326 }
327 va_end(args);
328 }
329
330 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 static
341 void WriteSetError(struct Statement *statement, struct TypeDescription *def)
342 {
343 STATEMENT_ERROR(statement, (GetBaseType(def) == set_type) ?
344 "No set type specified in IS_A statement"
345 : "Set type specified for a non-set type");
346 }
347
348 /**
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 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 /**
363 Write Unexecuted Error Message in Pass 3 WUEMPASS3
364
365 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 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 /*------------------------------------------------------------------------------
378 DENSE ARRAY PROCESSING
379
380 ...mostly
381 */
382
383 /**
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 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 STATEMENT_ERROR(statement, "Incorrect set type in IS_A");
401 /* lint should keep us from ever getting here */
402 return -2;
403 }
404 } else{
405 STATEMENT_ERROR(statement, "Unable to determine type of set.");
406 return -2;
407 }
408 }
409
410 /**
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 static
416 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
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 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 /**
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 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 STATEMENT_ERROR(statement, "Add another FOR index. In FOR loops,"
546 " all array subscripts must be scalar values, not sets.");
547 WSS(ASCERR,statement);
548 } else {
549 MarkStatContext(statement,context_WRONG);
550 STATEMENT_ERROR(statement, "Subscripts of conflicting or incorrect types"
551 " in rectangular array.");
552 WSS(ASCERR,statement);
553 }
554 return;
555 }
556
557 /**
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 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 /**
598 expands, if possible, children of nonrelation,
599 nonalias, nonparameterized arrays.
600 */
601 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 /**
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 static
653 int FindExprType(CONST struct Expr *ex, struct Instance *parent,
654 CONST unsigned int searchfor
655 ){
656 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 /**
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 static
729 int DeriveSetType(CONST struct Set *sptr, struct Instance *parent,
730 CONST unsigned int searchfor
731 ){
732 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 /**
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 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 /*-----------------------------------------------------------------------------
790 SPARSE AND DENSE ARRAY PROCESSING
791 */
792
793 /**
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 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 STATEMENT_ERROR(stat, "Index to sparse array is of an incorrect type");
834 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 STATEMENT_ERROR(stat, "Unknown result value type in MakeIndex.\n");
868 Asc_Panic(2, NULL, "Unknown result value type in MakeIndex.\n");
869
870 }
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 STATEMENT_ERROR(stat, "Bad index to dense alias array");
896 Asc_Panic(2, NULL, "Bad index to dense alias array");
897
898 }
899 /* return NULL; */ /* unreachable */
900 }
901 }
902
903 /**
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 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 /**
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 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 STATEMENT_ERROR(stat, "Index to array is of an incorrect type");
1029 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 STATEMENT_ERROR(stat, "Error in array indices");
1059 break;
1060 }
1061 DestroyValue(&value);
1062 return NULL;
1063 default:
1064 Asc_Panic(2, NULL ,"Unknown result value type.\n");
1065
1066 }
1067 }
1068
1069 /**
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 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 /**
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
1116 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 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 struct TypeDescription *desc = NULL;
1134 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 STATEMENT_ERROR(stat, "Utter screw-up in MakeSparseArray");
1163 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 /*------------------------------------------------------------------------------
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 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 STATEMENT_ERROR(statement,"Unindexed statement in FOR loop not allowed.");
1208 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 char *msg = ASC_NEW_ARRAY(char,SCLEN(childname)+strlen(REDEFINE_CHILD_MESG2)+1);
1227 strcpy(msg,REDEFINE_CHILD_MESG2);
1228 strcat(msg,SCP(childname));
1229 STATEMENT_ERROR(statement,msg);
1230 ascfree(msg);
1231 }
1232 } else{ /* unknown child name */
1233 /* case of part not expected */
1234 STATEMENT_ERROR(statement, "Unknown child name. Never should happen");
1235 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 STATEMENT_ERROR(statement, "Unable to create alias array instance");
1267 Asc_Panic(2, NULL, "Unable to create alias array instance");
1268 }
1269 } else {
1270 DeleteTypeDesc(arydef);
1271 STATEMENT_ERROR(statement,
1272 "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 STATEMENT_ERROR(statement,
1293 "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 STATEMENT_ERROR(statement,"Bad ALIASES child name.");
1302 }
1303 }
1304 }
1305
1306 /**
1307 @return 1 if concluded with statement, 0 if might try later.
1308 */
1309 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 STATEMENT_ERROR(statement,"ALIASES needs exactly 1 RHS");
1340 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 STATEMENT_ERROR(statement,"Direct ALIASES of relations are not permitted");
1347 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 /*------------------------------------------------------------------------------
1364 SUPPORT FOR ALIASES-IS_A STATEMENTS
1365 */
1366
1367 /**
1368 enforce max len and no-apostrope (') rules for subscripts. string returned
1369 may not be string sent.
1370 */
1371 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 s = ASC_NEW_ARRAY(char,41);
1383 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 /**
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 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 new[oldlen] = (char)c;
1424 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
1435 } 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 /**
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 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 STATEMENT_ERROR(statement,"Bad result in evaluating WITH_VALUE list\n");
1549 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 STATEMENT_ERROR(statement,
1567 "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 STATEMENT_ERROR(statement,
1575 "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 STATEMENT_ERROR(statement,"In: ");
1585 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 /**
1618 @return 1 if concluded with statement, 0 if might try later.
1619 */
1620 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 STATEMENT_ERROR(statement,
1662 "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 /*------------------------------------------------------------------------------
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 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 FPRINTF(ASCERR,"Type '%s' is not allowed in IS_A.\n",
1801 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 STATEMENT_ERROR(statement, "MakeSimpleInstance error. PATCH/ARRAY found.\n");
1815 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 /**
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 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 /**
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
1896 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
1902 @TODO This function should be moved into a set header someplace.
1903 */
1904 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 /**
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 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 (IntegerSetInstance(i)==0 &&
1957 stype == GetBaseTypeName(integer_constant_type))
1958 || (IntegerSetInstance(i)==1 &&
1959 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 /**
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 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 /**
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 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 FPRINTF(ASCERR,"Variable value found where constant required");
2143 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 /**
2222 evaluate a logical or real relation and see that it is satisfied.
2223
2224 @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
2233 @param statement should be a rel or logrel.
2234 */
2235 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 STATEMENT_ERROR(statement, "Condition doesn't make sense.");
2275 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 STATEMENT_ERROR(statement, "Arguments do not conform to requirements");
2286 return MPIBADREL;
2287 }
2288 } else {
2289 DestroyValue(&value);
2290 STATEMENT_ERROR(statement, "Requirements cannot be satisfied by variables");
2291 return MPIVARREL;
2292 }
2293 default:
2294 DestroyValue(&value);
2295 STATEMENT_ERROR(statement, "Constraint does not evaluate to boolean result.");
2296 return MPINOTBOOL;
2297 }
2298 }
2299
2300 /**
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 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 /**
2334 links parent and child. if checkdup != 0,
2335 it will check child to see if it already has this parent.
2336 */
2337 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 char *msg = ASC_NEW_ARRAY(char,SCLEN(childname)+strlen(REDEFINE_CHILD_MESG)+1);
2362 strcpy(msg,REDEFINE_CHILD_MESG);
2363 strcat(msg,SCP(childname));
2364 STATEMENT_ERROR(statement,msg);
2365 ascfree(msg);
2366 return 0;
2367 }
2368 } else { /* unknown name */
2369 STATEMENT_ERROR(statement, "Unknown parameter name. Never should happen");
2370 Asc_Panic(2, NULL, "Unknown parameter name. Never should happen");
2371
2372 }
2373 }
2374
2375 /**
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 static
2382 void DestroyParameterInst(struct Instance *i)
2383 {
2384 DestroyInstance(i,NULL);
2385 }
2386
2387 /**
2388 destroys everything you send it. If you send some arguments in
2389 as null, we don't mind.
2390 */
2391 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 /**
2419 What is MPI? parallel computing stuff?? -- JP
2420 */
2421 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 STATEMENT_ERROR(statement,"Error in executing statement:");
2440 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 /**
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 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 /**
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
2554 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
2563 @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 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(args,argn);
2663 il = FindArgInsts(parent,argset,&ferr);
2664 if (il == NULL) {
2665 switch(ferr) {
2666 case unmade_instance:
2667 case undefined_instance: /* this case ought to be separable */
2668 MPIwum(argset,argn,statement,MPIUNMADE);
2669 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2670 return MPIWAIT;
2671 case impossible_instance:
2672 mpierror(argset,argn,statement,MPIBADARG);
2673 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2674 return MPIBADARG;
2675 case correct_instance:
2676 mpierror(argset,argn,statement,MPIWEIRD);
2677 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2678 return MPIWEIRD;
2679 }
2680 }
2681 if (gl_length(il)!=1L) {
2682 mpierror(argset,argn,statement,MPIMULTI);
2683 ClearMPImem(args,il,tmpinst,NULL,NULL);
2684 return MPIMULTI;
2685 }
2686 ipass = (struct Instance *)gl_fetch(il,1L);
2687 gl_destroy(il);
2688 il = NULL;
2689 if (SimpleNameIdPtr(NamePointer(vl))==NULL) {
2690 /* arg required is an array, check this.
2691 * check complete expansion of arg, constant type or not.
2692 * check compatible base type of all elements with spec-
2693 * note we haven't checked subscript ranges at this point.
2694 */
2695 if (IsArrayInstance(ipass)==0) {
2696 mpierror(argset,argn,statement,MPIARGTYPE);
2697 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2698 return MPIARGTYPE;
2699 }
2700 if (RectangleArrayExpanded(ipass)==0) {
2701 /* this works for sparse or dense because sparse won't
2702 * exist except in the fully expanded state due to
2703 * the construction all at once.
2704 */
2705 MPIwum(argset,argn,statement,MPIUNMADE);
2706 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2707 return MPIWAIT;
2708 }
2709 if (NumberofDereferences(ipass) !=
2710 (unsigned long)(NameLength(NamePointer(vl)) - 1)) {
2711 /* I may need an offset other than -1 here */
2712 mpierror(argset,argn,statement,MPIARGSIZ);
2713 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2714 return MPIARGTYPE;
2715 }
2716 tverr = ArrayElementsTypeCompatible(ipass,ptype,stype);
2717 switch (tverr) {
2718 case 1:
2719 /* happy happy joy joy */
2720 break;
2721 case 0:
2722 MPIwum(argset,argn,statement,MPIWEAKTYPE);
2723 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2724 return MPIWAIT;
2725 default:
2726 mpierror(argset,argn,statement,MPIARGTYPE);
2727 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2728 return MPIARGTYPE;
2729 }
2730 if (ArgValuesUnassigned(ipass)!=0) {
2731 MPIwum(argset,argn,statement,MPIUNASSD);
2732 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2733 return MPIWAIT;
2734 }
2735 } else {
2736 /* arg must be scalar/set/MODEL */
2737 atype = InstanceTypeDesc(ipass);
2738 if (atype==ptype) {
2739 /* we're happy unless sets of mismatched base */
2740 if (stype!=NULL) {
2741 if ((IntegerSetInstance(ipass)!=0 && intset==0) ||
2742 (IntegerSetInstance(ipass)==0 && intset==1)) {
2743 mpierror(argset,argn,statement,MPIARGTYPE);
2744 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2745 return MPIARGTYPE;
2746 }
2747 }
2748 } else {
2749 mrtype = MoreRefined(atype,ptype);
2750 if (mrtype==NULL) {
2751 mpierror(argset,argn,statement,MPIARGTYPE);
2752 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2753 return MPIARGTYPE;
2754 }
2755 if (mrtype==ptype) {
2756 /* arg is less refined than param spec. maybe better later */
2757 MPIwum(argset,argn,statement,MPIWEAKTYPE);
2758 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2759 return MPIWAIT;
2760 }
2761 }
2762 if (ArgValuesUnassigned(ipass)!=0) {
2763 MPIwum(argset,argn,statement,MPIUNASSD);
2764 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2765 return MPIWAIT;
2766 }
2767 /* here we check against WITH_VALUE clause, if one in ps */
2768 suberr = ArgValueCorrect(ipass,tmpinst,ps);
2769 switch(suberr) {
2770 case MPIOK:
2771 break;
2772 case MPIWAIT:
2773 /* can only occur if other portions of tmpinst needed to compute
2774 * check value are not in place yet. no wum here because
2775 * Digest below will catch it if it's broken.
2776 */
2777 break;
2778 /* may need additional cases depending on argval implementation */
2779 default:
2780 mpierror(argset,argn,statement,MPIARGVAL);
2781 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2782 }
2783 }
2784 /* install ipass in tmpinst */
2785 if ( InsertParameterInst(tmpinst,ipass,NamePointer(vl),ps,IPICHECK)
2786 !=1) {
2787 /* ipicheck because we might be passed same instance in 2 slots */
2788 mpierror(argset,argn,statement,MPIMULTI);
2789 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2790 return MPIMULTI;
2791 }
2792 argn++;
2793 vl = NextVariableNode(vl);
2794 }
2795 break;
2796 case ISA:
2797 argset = GETARG(args,argn);
2798 if (SimpleNameIdPtr(NamePointer(vl))!=NULL) {
2799 /* scalar: evaluate and make it */
2800 suberr = MPIMakeSimple(parent,tmpinst,argset,argn,
2801 NamePointer(vl),ptype,intset,ps,statement);
2802 if (suberr!=MPIOK) {
2803 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2804 return suberr;
2805 }
2806 } else {
2807 /* check completedness, assignedness, base type of array-by-value
2808 * and copy. Note that what we copy may prove to be incompatible
2809 * later when we check the names of subscripts.
2810 */
2811 il = FindArgInsts(parent,argset,&ferr);
2812 if (il == NULL) {
2813 switch(ferr) {
2814 case unmade_instance:
2815 case undefined_instance: /* this case ought to be separable */
2816 MPIwum(argset,argn,statement,MPIUNMADE);
2817 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2818 return MPIWAIT;
2819 case impossible_instance:
2820 mpierror(argset,argn,statement,MPIBADARG);
2821 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2822 return MPIBADARG;
2823 case correct_instance:
2824 mpierror(argset,argn,statement,MPIWEIRD);
2825 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2826 return MPIWEIRD;
2827 }
2828 }
2829 if (gl_length(il)!=1L) {
2830 mpierror(argset,argn,statement,MPIMULTI);
2831 ClearMPImem(args,il,tmpinst,NULL,NULL);
2832 return MPIMULTI;
2833 }
2834 ipass = (struct Instance *)gl_fetch(il,1L);
2835 gl_destroy(il);
2836 il = NULL;
2837 /* arg required is an array, check this.
2838 * check complete expansion of arg, constant type or not.
2839 * check compatible base type of all elements with spec-
2840 * note we haven't checked subscript ranges at this point.
2841 */
2842 if (IsArrayInstance(ipass)==0) {
2843 mpierror(argset,argn,statement,MPIARGTYPE);
2844 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2845 return MPIARGTYPE;
2846 }
2847 if (RectangleArrayExpanded(ipass)==0) {
2848 /* this works for spare or dense because sparse won't
2849 * exist except in the fully expanded state due to
2850 * the construction all at once.
2851 */
2852 MPIwum(argset,argn,statement,MPIUNMADE);
2853 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2854 return MPIWAIT;
2855 }
2856 if (NumberofDereferences(ipass) !=
2857 (unsigned long)(NameLength(NamePointer(vl)) - 1)) {
2858 /* I may need an offset other than -1 here */
2859 mpierror(argset,argn,statement,MPIARGSIZ);
2860 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2861 return MPIARGTYPE;
2862 }
2863 tverr = ArrayElementsTypeCompatible(ipass,ptype,stype);
2864 switch (tverr) {
2865 case 1:
2866 /* happy happy joy joy */
2867 break;
2868 case 0:
2869 /* wum here */
2870 MPIwum(argset,argn,statement,MPIWEAKTYPE);
2871 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2872 return MPIWAIT;
2873 default:
2874 mpierror(argset,argn,statement,MPIARGTYPE);
2875 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2876 return MPIARGTYPE;
2877 }
2878 if (ArgValuesUnassigned(ipass)!=0) {
2879 MPIwum(argset,argn,statement,MPIUNASSD);
2880 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2881 return MPIWAIT;
2882 }
2883 /* this copy will mess up tmpnums in old ipass. */
2884 ipass = CopyInstance(ipass);
2885 /* note the copy has only been verified to work for completed
2886 * arrays of constants, not models.
2887 */
2888 /* we don't care about the old ipass any more. check new one. */
2889 if (ipass==NULL) {
2890 mpierror(argset,argn,statement,MPIINSMEM);
2891 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2892 return MPIMULTI;
2893 }
2894 /* install ipass in tmpinst */
2895 if ( InsertParameterInst(tmpinst,ipass,NamePointer(vl),ps,NOIPICHECK)
2896 !=1 /* arrays cannot be UNIVERSAL */ ) {
2897 mpierror(argset,argn,statement,MPIMULTI);
2898 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2899 return MPIMULTI;
2900 }
2901 /* we still need to check the subscripts for compatibility with
2902 * arg description. can't do yet.
2903 */
2904 }
2905 argn++;
2906 break;
2907 default:
2908 Asc_Panic(2, NULL, "how the hell did typelint let that through?");
2909 /* how the hell did typelint let that through? */
2910 break;
2911 }
2912 }
2913 /* ok, so now we have everything passed (which might be nothing)
2914 * in place. We need to check WITH_VALUE's, subscript ranges,
2915 * and insist all scalars end up assigned while processing
2916 * the absorbed statements. Possibly may still find undefined
2917 * values in rhs of assignments or in subscript ranges, drat.
2918 * May take several passes.
2919 */
2920
2921 suberr = DigestArguments(tmpinst,args,psl,absorbed,statement); /*1*/
2922 switch(suberr) {
2923 case MPIOK:
2924 break;
2925 case MPIWAIT:
2926 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2927 return MPIWAIT;
2928 default:
2929 /* anything else is an error. mpierror will have been called. */
2930 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2931 return MPIINPUT;
2932 }
2933
2934 /* ok, now we need to check where statement list. */
2935 SavedForTable = GetEvaluationForTable();
2936 SetEvaluationForTable(CreateForTable());
2937 suberr = CheckWhereStatements(tmpinst,GetModelParameterWheres(d));
2938 DestroyForTable(GetEvaluationForTable());
2939 SetEvaluationForTable(SavedForTable);
2940 switch(suberr) {
2941 case MPIOK:
2942 break;
2943 case MPIWAIT:
2944 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2945 return MPIWAIT;
2946 default:
2947 /* anything else is an error */
2948 ClearMPImem(args,NULL,tmpinst,NULL,NULL);
2949 mpierror(NULL,0,statement,suberr);
2950 return suberr;
2951 }
2952
2953 ClearMPImem(args,NULL,NULL,NULL,NULL);
2954 if (keepargs == KEEPARGINST) {
2955 *arginstptr = tmpinst;
2956 } else {
2957 DestroyParameterInst(tmpinst);
2958 }
2959 return MPIOK;
2960 }
2961
2962 static
2963 int MPICheckWBTS(struct Instance *tmpinst, struct Statement *statement)
2964 {
2965 struct gl_list_t *instances;
2966 unsigned long c,len;
2967 enum find_errors err;
2968 struct Instance *head = NULL;
2969
2970 instances = FindInsts(tmpinst,GetStatVarList(statement),&err);
2971 if (instances==NULL) {
2972 switch(err){
2973 case impossible_instance:
2974 MissingInsts(tmpinst,GetStatVarList(statement),1);
2975 STATEMENT_ERROR(statement,
2976 "WILL_BE_THE_SAME statement contains an impossible instance name");
2977 return MPIBADWBTS;
2978 default:
2979 MissingInsts(tmpinst,GetStatVarList(statement),0);
2980 WriteUnexecutedMessage(ASCERR,statement,
2981 "Incomplete instances in WILL_BE_THE_SAME");
2982 return MPIWAIT; /* statement is not ready to be executed */
2983 }
2984 }
2985 len = gl_length(instances);
2986 if (len >0 ) {
2987 head = gl_fetch(instances,1);
2988 }
2989 for (c=2; c<=len; c++) {
2990 if (((struct Instance *)gl_fetch(instances,c)) != head) {
2991 if (IsArrayInstance(head)==0 &&
2992 MoreRefined(InstanceTypeDesc(gl_fetch(instances,c)),
2993 InstanceTypeDesc(head))==NULL) {
2994 /* can't be merged later */
2995 STATEMENT_ERROR(statement,
2996 "WILL_BE_THE_SAME statement contains incompatible instances");
2997 gl_destroy(instances);
2998 return MPIBADWBTS;
2999 } else {
3000 /* maybe merge later */
3001 WriteUnexecutedMessage(ASCERR,statement,
3002 "Unmerged instances in WILL_BE_THE_SAME");
3003 gl_destroy(instances);
3004 return MPIWAIT;
3005 }
3006 }
3007 }
3008 gl_destroy(instances);
3009 return MPIOK;
3010 }
3011
3012 #define MPICheckWB(a,b) MPIWEIRD
3013 /* WILL_BE not yet legal in where section. implement later if req'd */
3014
3015 /**
3016 verifies that all the instances found, if any, are different.
3017 uses an nlogn (n = # of instance) algorithm, which
3018 could be made order n using the interface pointer protocol,
3019 but the additional overhead makes the multiplier for
3020 o(n) probably not worth the trouble.
3021 */
3022 static
3023 int MPICheckWNBTS(struct Instance *tmpinst, struct Statement *statement)
3024 {
3025 struct gl_list_t *instances;
3026 enum find_errors err;
3027
3028 instances = FindInsts(tmpinst,GetStatVarList(statement),&err);
3029 if (instances==NULL) {
3030 switch(err){
3031 case impossible_instance:
3032 MissingInsts(tmpinst,GetStatVarList(statement),1);
3033 STATEMENT_ERROR(statement,
3034 "WILL_NOT_BE_THE_SAME statement contains an impossible instance name");
3035 return MPIBADWNBTS;
3036 default:
3037 MissingInsts(tmpinst,GetStatVarList(statement),0);
3038 WriteUnexecutedMessage(ASCERR,statement,
3039 "Incomplete instances in WILL_NOT_BE_THE_SAME");
3040 return MPIWAIT; /* statement is not ready to be executed */
3041 }
3042 }
3043 if (gl_unique_list(instances)==0) {
3044 STATEMENT_ERROR(statement,
3045 "WILL_NOT_BE_THE_SAME statement contains"
3046 " identical/merged instances");
3047 gl_destroy(instances);
3048 return MPIBADMERGE;
3049 }
3050 gl_destroy(instances);
3051 return MPIOK;
3052 }
3053
3054 /**
3055 Checks the for statements, along with all the horrid machinery needed
3056 to make a for loop go.
3057 */
3058 static
3059 int CheckWhereFOR(struct Instance *inst, struct Statement *statement)
3060 {
3061 symchar *name;
3062 struct Expr *ex;
3063 struct StatementList *sl;
3064 unsigned long c,len;
3065 struct value_t value;
3066 struct set_t *sptr;
3067 struct for_var_t *fv;
3068 int code=MPIOK;
3069
3070 name = ForStatIndex(statement);
3071 ex = ForStatExpr(statement);
3072 sl = ForStatStmts(statement);
3073 if (FindForVar(GetEvaluationForTable(),name)){ /* duplicated for variable */
3074 STATEMENT_ERROR(statement, "FOR construct uses duplicate index variable");
3075 return MPIFOR;
3076 }
3077 assert(GetEvaluationContext()==NULL);
3078 SetEvaluationContext(inst);
3079 value = EvaluateExpr(ex,NULL,InstanceEvaluateName);
3080 SetEvaluationContext(NULL);
3081 switch(ValueKind(value)){
3082 case error_value:
3083 switch(ErrorValue(value)){
3084 case name_unfound:
3085 case undefined_value:
3086 DestroyValue(&value);
3087 STATEMENT_ERROR(statement, "FOR has undefined values");
3088 return MPIFOR; /* this maybe should be mpiwait? */
3089 default:
3090 WriteForValueError(statement,value);
3091 DestroyValue(&value);
3092 return MPIFOR;
3093 }
3094 case real_value:
3095 case integer_value:
3096 case symbol_value:
3097 case boolean_value:
3098 case list_value:
3099 WriteStatement(ASCERR,statement,0);
3100 FPRINTF(ASCERR,"FOR expression returns the wrong type.\n");
3101 DestroyValue(&value);
3102 return MPIFOR;
3103 case set_value:
3104 sptr = SetValue(value);
3105 switch(SetKind(sptr)){
3106 case empty_set: break;
3107 case integer_set:
3108 fv = CreateForVar(name);
3109 SetForVarType(fv,f_integer);
3110 AddLoopVariable(GetEvaluationForTable(),fv);
3111 len = Cardinality(sptr);
3112 for(c=1;c<=len;c++){
3113 SetForInteger(fv,FetchIntMember(sptr,c));
3114 code = CheckWhereStatements(inst,sl);
3115 if (code != MPIOK) {
3116 break;
3117 }
3118 }
3119 RemoveForVariable(GetEvaluationForTable());
3120 break;
3121 case string_set:
3122 fv = CreateForVar(name);
3123 SetForVarType(fv,f_symbol);
3124 AddLoopVariable(GetEvaluationForTable(),fv);
3125 len = Cardinality(sptr);
3126 for(c=1;c<=len;c++){
3127 SetForSymbol(fv,FetchStrMember(sptr,c));
3128 code = CheckWhereStatements(inst,sl);
3129 if (code != MPIOK) {
3130 break;
3131 }
3132 }
3133 RemoveForVariable(GetEvaluationForTable());
3134 break;
3135 }
3136 DestroyValue(&value);
3137 }
3138 return code;
3139 }
3140
3141 /**
3142 checks that all conditions are satisfied, else returns a whine.
3143 does not call mpierror, so caller ought to if needed.
3144 returns one of the defined MPI codes.
3145 */
3146 static
3147 int CheckWhereStatements(struct Instance *tmpinst, struct StatementList *sl)
3148 {
3149 unsigned long c,len;
3150 struct Statement *s;
3151 int code=MPIOK;
3152
3153 if (tmpinst ==NULL) {
3154 return MPIWEIRD;
3155 }
3156 len = StatementListLength(sl);
3157 for (c=1;c <= len && code == MPIOK; c++) {
3158 s = GetStatement(sl,c);
3159 switch (StatementType(s)) {
3160 case WBTS:
3161 code = MPICheckWBTS(tmpinst,s);
3162 break;
3163 case WNBTS:
3164 code = MPICheckWNBTS(tmpinst,s);
3165 break;
3166 case WILLBE:
3167 code = MPICheckWB(tmpinst,s);
3168 break;
3169 case LOGREL:
3170 case REL:
3171 /* baa. fix me. bug. need to evaluate rules in a way which is
3172 * exception-safe. EvaluateExpr currently isn't
3173 */
3174 code = MPICheckConstraint(tmpinst,s);
3175 break;
3176 case FOR:
3177 code = CheckWhereFOR(tmpinst,s);
3178 break;
3179 default:
3180 code = MPIWEIRD;
3181 break;
3182 }
3183 }
3184 return code;
3185 }
3186
3187 #if 0 /* migrating, or migraining, depending on your viewpoint, to parpend.h */
3188 enum ppstatus {
3189 pp_ERR =0,
3190 pp_ISA, /* IS_A of simple to be done, from absorbed. */
3191 pp_ISAARR, /* IS_A of array to do, from absorbed and
3192 * gets converted to asar during processing.
3193 */
3194 pp_ARR, /* array that's constructed but requires range checking */
3195 pp_ASGN, /* assignment to do in absorbed objects */
3196 pp_ASSC, /* scalar assignment to check in absorbed objects */
3197 pp_ASAR, /* Array to be checked for being completely assigned,
3198 * but its subscript range is presumed right.
3199 */
3200 pp_WV, /* WITH_VALUE to be checked */
3201 pp_DONE /* finished statement */
3202 };
3203
3204 struct parpendingentry {
3205 struct Set *arg; /* parameter given in user's IS_A statement */
3206 struct Statement *s;
3207 struct Instance *inst;
3208 struct parpendingentry *next;
3209 enum ppstatus status;
3210 int argn; /* the psl position if >0, or -(the absorbed position) if <0 */
3211 /* argn==0 is an error */
3212 };
3213
3214 #endif /* 0 migraining */
3215
3216 /**
3217 returns a single instance, if such can be properly derived
3218 from the name given.
3219
3220 Returns NULL if too many or no instances are found.
3221 Probably ought to have a return code, but doesn't.
3222 */
3223 static
3224 struct Instance *GetNamedInstance(CONST struct Name *nptr,
3225 CONST struct Instance *tmpinst)
3226 {
3227 struct Instance *i=NULL;
3228 struct gl_list_t *insts;
3229 enum find_errors ferr;
3230
3231 assert(nptr!=NULL);
3232 assert(tmpinst!=NULL);
3233 insts = FindInstances(tmpinst,nptr,&ferr);
3234 if (insts==NULL) {
3235 return NULL;
3236 }
3237 if (gl_length(insts) == 1L) {
3238 i = (struct Instance *)gl_fetch(insts,1);
3239 }
3240 gl_destroy(insts);
3241 return i;
3242 }
3243
3244 /*
3245 put the parameters open (if any) and absorbed statements into the
3246 pending list we're creating.
3247 */
3248 static
3249 struct parpendingentry *
3250 CreateParameterPendings(struct Instance *tmpinst,
3251 struct gl_list_t *args,
3252 struct StatementList *psl,
3253 struct StatementList *absorbed)
3254 {
3255 unsigned long c,len;
3256 struct parpendingentry *new, *list=NULL;
3257 CONST struct Expr *ex;
3258 struct gl_list_t *nlist=NULL;
3259
3260 assert(args!=NULL);
3261
3262 len = gl_length(args);
3263 for (c=len; c >= 1; c--) {
3264 new = CreatePPE();
3265 /* Create must not return NULL */
3266 new->arg = gl_fetch(args,c);
3267 new->s = GetStatement(psl,c);
3268 new->inst = NULL;
3269 new->argn = c;
3270 switch (StatementType(new->s)) {
3271 case WILLBE:
3272 /* assumes lint did it's job */
3273 if (NameLength(NamePointer(GetStatVarList(new->s))) > 1) {
3274 /* arrays were connected already, but no subscript check */
3275 new->inst = GetArrayHead(tmpinst,NamePointer(GetStatVarList(new->s)));
3276 new->status = pp_ARR;
3277 } else {
3278 /* scalar */
3279 ex = GetStatCheckValue(new->s);
3280 if (ex != NULL) {
3281 nlist = EvaluateNamesNeededShallow(ex,NULL,NULL);
3282 assert(nlist!=NULL);
3283 if (gl_length(nlist) != 0L) {
3284 new->status = pp_WV;
3285 new->inst =
3286 GetNamedInstance(NamePointer(GetStatVarList(new->s)),tmpinst);
3287 } else {
3288 /* nothing further to check. done already */
3289 DestroyPPE(new);
3290 new = NULL;
3291 }
3292 gl_destroy(nlist);
3293 } else {
3294 DestroyPPE(new);
3295 new = NULL;
3296 }
3297 }
3298 break;
3299 case ISA:
3300 if (NameLength(NamePointer(GetStatVarList(new->s))) > 1) {
3301 /* subscript check */
3302 new->inst = GetArrayHead(tmpinst,NamePointer(GetStatVarList(new->s)));
3303 new->status = pp_ARR;
3304 } else {
3305 /* nothing further to check. assumed done already */
3306 DestroyPPE(new);
3307 new = NULL;
3308 }
3309 break;
3310 default:
3311 Asc_Panic(2, "CreateParameterPendings",
3312 "Unknown statement type in CreateParameterPendings!\n");
3313 break;
3314 }
3315 if (new != NULL) {
3316 /* insert at head, but completed statements don't get added */
3317 new->next = list;
3318 list = new;
3319 }
3320 }
3321 len = StatementListLength(absorbed);
3322 for (c=len; c >= 1; c--) {
3323 new = CreatePPE();
3324 /* Create must not return NULL */
3325 new->arg = NULL;
3326 new->s = GetStatement(absorbed,c);
3327 new->inst = NULL;
3328 new->argn =0; new->argn -= c;
3329 switch (StatementType(new->s)) {
3330 case ISA:
3331 if (NameLength(NamePointer(GetStatVarList(new->s))) > 1) {
3332 /* array needed and subscript check */
3333 new->status = pp_ISAARR;
3334 /* after construction, no check until fully assigned at end */
3335 } else {
3336 /* simplename */
3337 new->status = pp_ISA;
3338 }
3339 break;
3340 case CASGN:
3341 new->status = pp_ASGN;
3342 break;
3343 default:
3344 Asc_Panic(2, "CreateParameterPendings",
3345 "Unknown statement type in CreateParameterPendings!\n");
3346 break;
3347 }
3348 new->next = list;
3349 list = new;
3350 }
3351 return list;
3352 }
3353 /* destroy a list of pending parameter items.
3354 */
3355 static
3356 void DestroyParameterPendings( struct parpendingentry *pp)
3357 {
3358 struct parpendingentry *old;
3359 while (pp!=NULL) {
3360 old = pp;
3361 pp = pp->next;
3362 DestroyPPE(old);
3363 }
3364 }
3365
3366 /*
3367 this function should not be entered until all WB arguments have
3368 been installed in tmpinst.
3369 */
3370 static
3371 int DigestArguments(
3372 struct Instance *tmpinst,
3373 struct gl_list_t *args,
3374 struct StatementList *psl,
3375 struct StatementList *absorbed,
3376 struct Statement *statement)
3377 {
3378 struct parpendingentry *pp, /* current work */
3379 *pphead, /* first in work list */
3380 *pplast; /* just prior work, so can delete current */
3381 int change = 1;
3382 int suberr = MPIOK; /* maybe mpi enum */
3383
3384 pphead = pp = CreateParameterPendings(tmpinst,args,psl,absorbed);
3385 while (change && pphead!=NULL && suberr ==MPIOK) {
3386 pplast = NULL;
3387 pp = pphead;
3388 change = 0;
3389 while (pp != NULL && suberr ==MPIOK) {
3390 switch (pp->status) {
3391 case pp_ISA:
3392 /* building a scalar! OTHERWISE recursion could bite us.
3393 * We don't use mpimakesimpleinstance because no argval.
3394 */
3395 suberr = ExecuteISA(tmpinst,pp->s);
3396 if (suberr!=1) {
3397 suberr = MPIWEIRD;
3398 pp->status = pp_ERR;
3399 FPRINTF(ASCERR,"While executing (1) absorbed statement in %s:\n",
3400 SCP(GetName(InstanceTypeDesc(tmpinst))));
3401 WriteStatement(ASCERR,pp->s,2);
3402 mpierror(NULL,0,statement,suberr);
3403 } else {
3404 pp->inst =
3405 GetNamedInstance(NamePointer(GetStatVarList(pp->s)),tmpinst);
3406 if (pp->inst != NULL) {
3407 suberr = MPIOK;
3408 pp->status = pp_ASSC;
3409 } else {
3410 suberr = MPIWEIRD;
3411 pp->status = pp_ERR;
3412 FPRINTF(ASCERR,"While executing (2) absorbed statement in %s:\n",
3413 SCP(GetName(InstanceTypeDesc(tmpinst))));
3414 WriteStatement(ASCERR,pp->s,2);
3415 mpierror(NULL,0,statement,suberr);
3416 }
3417 }
3418 change++;
3419 break;
3420 /* done case */
3421 case pp_ISAARR:
3422 /* IS_A of array that needs doing, range, args assignment */
3423 if (CheckISA(tmpinst,pp->s) == 1) {
3424 /* Must have subscripts defined first, because we do not
3425 * want the array to be put on the global pending list as
3426 * that would be algorithmic suicide. The whole point of
3427 * parameters is reducing a set of operations to a point
3428 * in the ProcessPending execution cycle.
3429 */
3430 suberr = ExecuteISA(tmpinst,pp->s);
3431 /* so the array should be completely expanded now. */