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