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

Contents of /trunk/ascend/compiler/instantiate.c

Parent Directory Parent Directory | Revision Log Revision Log


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