/[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 423 - (show annotations) (download) (as text)
Mon Apr 3 23:15:49 2006 UTC (13 years, 8 months ago) by ben.allan
File MIME type: text/x-csrc
File size: 384671 byte(s)
Fixed instatiation of blackbox (and probably glassbox)
relations, for poorly tested definitions of 'fix'.
Blackbox evaluation is still broken.

There seems to be some chaos around win32_lean_and_mean
in ascConfig.h

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