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