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

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

Parent Directory Parent Directory | Revision Log Revision Log


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