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