Parent Directory
|
Revision Log
Removing some debug output
1 | aw0a | 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 | johnpye | 62 | /* moved from tcltk98/generic/interface/SimsProc.c */ |
137 | struct Instance *g_cursim; | ||
138 | aw0a | 1 | |
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 | johnpye | 190 | * relation copying) is g_use_copyanon != 0 |
151 | aw0a | 1 | * || FORCE applied. |
152 | */ | ||
153 | |||
154 | int g_use_copyanon = 1; | ||
155 | /* g_use_copyanon is the user switch for anonymous type based relation | ||
156 | johnpye | 190 | * copying. if 0, no copying by that method is done. |
157 | aw0a | 1 | */ |
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 | johnpye | 76 | /* #define DEBUG_RELS */ |
181 | aw0a | 1 | /* 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 | johnpye | 190 | static |
399 | aw0a | 1 | 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 | johnpye | 190 | WSEM(ASCERR,statement, "Add another FOR index. In FOR loops," |
523 | aw0a | 1 | " all array subscripts must be scalar values, not sets."); |
524 | WSS(ASCERR,statement); | ||
525 | } else { | ||
526 | MarkStatContext(statement,context_WRONG); | ||
527 | johnpye | 190 | WSEM(ASCERR,statement, "Subscripts of conflicting or incorrect types" |
528 | aw0a | 1 | " 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 | jds | 97 | /* return NULL; */ /* unreachable */ |
875 | aw0a | 1 | } |
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 | johnpye | 89 | struct TypeDescription *desc = NULL; |
1109 | aw0a | 1 | 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 | jds | 97 | new[oldlen] = (char)c; |
1391 | aw0a | 1 | 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 | johnpye | 190 | FPRINTF(ASCERR,"Type '%s' is not allowed in IS_A.\n", |
1761 | aw0a | 1 | 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 | johnpye | 190 | (IntegerSetInstance(i)==0 && |
1911 | aw0a | 1 | stype == GetBaseTypeName(integer_constant_type)) |
1912 | johnpye | 190 | || (IntegerSetInstance(i)==1 && |
1913 | aw0a | 1 | 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( |