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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1695 - (show annotations) (download) (as text)
Wed Dec 26 08:23:08 2007 UTC (12 years, 6 months ago) by jpye
File MIME type: text/x-csrc
File size: 171089 byte(s)
Fixed up some debug output and lint, formatting.
tubebank model currently causes crash as noted in bug #350.
1 /* ASCEND modelling environment
2 Copyright (C) 2006 Carnegie Mellon University
3 Copyright (C) 1990, 1993, 1994, 1995 Thomas Guthrie Epperly
4
5 This program is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2, or (at your option)
8 any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program; if not, write to the Free Software
17 Foundation, Inc., 59 Temple Place - Suite 330,
18 Boston, MA 02111-1307, USA.
19 *//*
20 @file
21 Type definition module
22 *//*
23 by Tom Epperly
24 Created: 1/12/90
25 Last in CVS: $Revision: 1.60 $ $Date: 1998/04/21 23:50:02 $ $Author: ballan $
26 */
27
28 #include <math.h>
29 #include <stdarg.h>
30 #include <ctype.h>
31 #include <utilities/ascConfig.h>
32 #include <utilities/ascMalloc.h>
33 #include <utilities/ascPanic.h>
34 #include <general/list.h>
35 #include <general/dstring.h>
36
37
38
39 #include "functype.h"
40 #include "expr_types.h"
41 #include "stattypes.h"
42 #include "statement.h"
43 #include "slist.h"
44 #include "statio.h"
45 #include "symtab.h"
46 #include "module.h"
47 #include "library.h"
48 #include "child.h"
49 #include "vlist.h"
50 #include "name.h"
51 #include "nameio.h"
52 #include "when.h"
53 #include "select.h"
54 #include "sets.h"
55 #include "setio.h"
56 #include "exprs.h"
57 #include "exprio.h"
58 #include "forvars.h"
59 #include "bit.h"
60 #include "setinstval.h"
61 #include "childinfo.h"
62 #include "instance_enum.h"
63 #include "type_desc.h"
64 #include "type_descio.h"
65 #include "atomsize.h"
66 #include "value_type.h"
67 #include "evaluate.h"
68 #include "proc.h"
69 #include "typelint.h"
70 #include "childdef.h"
71 #include "cmpfunc.h"
72 #include "typedef.h"
73 #include <general/mathmacros.h>
74
75 /*
76 * To generate a name for a relation, logrelation or when using
77 * the number of the relation, logrelation or when in the model,
78 * rather than the line number
79 */
80
81 /*
82 * number of a relation,logrelation or when
83 */
84 static unsigned long g_number= 0;
85
86 /*
87 * unused at present
88 *static unsigned long g_typedef_linenum = 0;
89 */
90
91
92 /*
93 * function to find if name is proper FOR variable. Returns 1 if so. 0 not.
94 * should be in another file.
95 */
96 static
97 int NameInForTable(CONST struct for_table_t *ft, CONST struct Name *n)
98 {
99 symchar *name;
100 struct for_var_t *ptr;
101 if (ft != NULL && n != NULL) {
102 AssertMemory(ft);
103 name = SimpleNameIdPtr(n);
104 if (name != NULL) {
105 ptr = FindForVar(ft,name);
106 if (ptr != NULL) {
107 switch(GetForKind(ptr)){
108 case f_integer:
109 case f_symbol:
110 case f_set:
111 case f_untyped: /* we aren't interpretting, just name spacing */
112 return 1;
113 default:
114 FPRINTF(ASCERR,"Untyped FOR variable (%s).\n",SCP(name));
115 }
116 }
117 }
118 }
119 return 0;
120 }
121
122 /*----------------------------------------------------------------------------
123 * Data structures to help track reducing a prior argument list by the
124 * reduction assignments.
125 *----------------------------------------------------------------------------
126 */
127
128 /* Redlist auxillaries. */
129 /* a struct for Reduce use */
130 struct RedListEntry {
131 struct Statement *olddeclstat;
132 /* these are temporary references, so the statement copy fcn not used */
133 CONST struct Name *name;
134 /* assumes each IS_A has one lhs name. if NULL, olddeclstat is a WILL_BE. */
135 CONST struct Name *wbname;
136 /* one WILL_BE may have several RLEs. This entry is not NULL if
137 * rle is from a WILL_BE.
138 */
139 int assigned; /* relevant only for name != NULL */
140 /*
141 * -2 name is of WILL_BE MODEL/variable, array or not;
142 * -1 name is of constant array; multiple assignments allowed.
143 * 0 = name is constant/set not yet assigned;
144 * 1 name has assigned value, possibly from constant typedesc;
145 */
146 };
147
148 /* forward declarations */
149 static
150 enum typelinterr
151 DoIS_A(CONST struct StatementList *stats);
152
153 static
154 enum typelinterr
155 DoWhens(symchar *, CONST struct StatementList *, struct gl_list_t *);
156
157 static
158 enum typelinterr
159 DoRelations(symchar *, CONST struct StatementList *, struct gl_list_t *);
160
161 /* stuff used to build child lists from statements, etc */
162
163 /**********************************************************\
164 * During the production of a child list we desire to ultimately
165 * produce a sorted gllist of pointers to struct ChildListEntry *
166 * that contain the names, array status, and most refined
167 * basetypes determinable based on already existing type
168 * definitions and the new statements of the type for which
169 * we are making the child list.
170 * We desire to be able to do this for some
171 * number of children between 0 and 100000
172 *
173 * The proposed and hence implemented solution is in the
174 * section of code that follows: a doubly linked list containing
175 * struct ChildListEntry and the operators to manage it.
176 * Once these size and naming of all the children are determined
177 * and sorted into this DL structure, we can map them into
178 * a gl_list for further processing.
179 * The child.h list interface specifies that we the user are
180 * responsible for the ChildListEntries in the input gllist,
181 * so we here use a lifo recycle list to avoid constant calls
182 * to malloc/free.
183 \**********************************************************/
184 struct LinkChildListEntry {
185 struct ChildListEntry e; /* must be first! */
186 /* the next 3 are not yet in use, really. */
187 /* struct LinkChildListEntry *alike; -- removed, JP */
188 /* pointer to aliked child list entries, which will all have the same type.
189 * This will be NULL unless an ARE_ALIKE has been seen or the CLE is a
190 * scalar. Array names in particular unless a statement aliking the
191 * array elements over its set of definition will have null alike ptr.
192 * ARE_ALIKE of individual array elements will not show up here.
193 * Circularly linked list.
194 */
195 /* struct LinkChildListEntry *arrthesame; --removed, JP */
196 /* struct LinkChildListEntry *eltsthesame; -- removed, JP */
197 /* pointer to merged child list entries, which will all have the same type.
198 * This will be NULL unless an ARE_THE_SAME has been seen or the CLE is a
199 * scalar. Array names in particular unless a statement merging the
200 * array elements over its set of definition will have NULL eltsthesame ptr.
201 * ARE_THE_SAME of individual array elements will not show up here.
202 * Merging arrays, as is the apparent case with an alias of an array,
203 * will show up in the arrthesame ptr.
204 * Circularly linked list.
205 */
206 /* pointers of the doubly-linked LCL structure */
207 struct LinkChildListEntry *prev;
208 struct LinkChildListEntry *next;
209 };
210
211 static
212 struct LinkChildListEntry *g_lcl_head = NULL, *g_lcl_tail = NULL;
213 static
214 struct LinkChildListEntry *g_lcl_recycle = NULL;
215 /* above the head and tail anchors of the list and the anchor
216 * for a lifo recycle list of these structures.
217 */
218
219 static
220 struct LinkChildListEntry *g_lcl_pivot = NULL;
221 /* a pointer to somewhere in the working list. used heuristically
222 * to speed name-based search.
223 */
224
225 #define LCLNAME g_lcl_pivot->e.strptr
226 /* returns the name of the current pivot. assumes the pivot is valid */
227
228 static
229 unsigned long g_lcl_length = 0;
230
231 #ifndef NDEBUG
232 static
233 unsigned long g_lclrecycle_length = 0;
234 #endif
235
236 void DestroyTypedefRecycle(void)
237 {
238 struct LinkChildListEntry *old;
239 while (g_lcl_recycle != NULL) {
240 old = g_lcl_recycle;
241 g_lcl_recycle = old->next;
242 ascfree(old);
243 }
244 }
245
246 /*
247 * returns a recycled or a new lcl element
248 * whichever is first available. Does nothing else
249 * except possibly update the length of the recycle list
250 * during debugging.
251 */
252 static
253 struct LinkChildListEntry *GetLCL(void)
254 {
255 struct LinkChildListEntry *new;
256 if (g_lcl_recycle!=NULL) {
257 new = g_lcl_recycle;
258 g_lcl_recycle = new->next;
259 #ifndef NDEBUG
260 g_lclrecycle_length--;
261 #endif
262 } else {
263 new = ASC_NEW(struct LinkChildListEntry);
264 }
265 return new;
266 }
267
268 static
269 void ClearLCL(void)
270 {
271 #ifndef NDEBUG
272 struct LinkChildListEntry *old;
273 /* do some book keeping and reinitializing, working from the tail. */
274 while (g_lcl_tail!=NULL) {
275 assert(g_lcl_length!=0L);
276 /* init */
277 old = g_lcl_tail;
278 old->e.strptr = NULL;
279 old->e.typeptr = NULL;
280 old->e.isarray = 0;
281 old->e.origin = origin_ERR;
282 /* cut off tail */
283 g_lcl_tail = old->prev;
284 g_lcl_length--;
285 /* push old into singly linked recycle list */
286 old->prev = NULL;
287 old->next = g_lcl_recycle;
288 g_lcl_recycle = old;
289 g_lclrecycle_length++;
290 }
291 assert(g_lcl_length==0L);
292 #else
293 /* insert current list at head of recycle */
294 if (g_lcl_tail!=NULL) {
295 g_lcl_tail->next = g_lcl_recycle;
296 }
297 /* if anything was added, get new head */
298 if (g_lcl_head != NULL) {
299 g_lcl_recycle = g_lcl_head;
300 }
301 #endif
302 g_lcl_tail = g_lcl_head = g_lcl_pivot = NULL;
303 g_lcl_length=0;
304 }
305
306 /*
307 * copies the pointers from the LCL to a gllistt.
308 * the lcl still exists. We do not clear it until
309 * after the gllist containing the copies is finished with.
310 * This should never return null.
311 */
312 static
313 struct gl_list_t *CopyLCLToGL(void)
314 {
315 struct gl_list_t *list;
316 struct LinkChildListEntry *e;
317 list = gl_create(g_lcl_length);
318 assert(list!=NULL);
319 e = g_lcl_head;
320 while (e!=NULL) {
321 /* since lcl is sorted, insert should always be at tail.
322 * since we created it big enough, this should never have to expand.
323 */
324 gl_insert_sorted(list,e,(CmpFunc)CmpChildListEntries);
325 e = e->next;
326 }
327 assert(gl_length(list)==g_lcl_length);
328 return list;
329 }
330
331 /*
332 * On entry assumes g_lcl_pivot==NULL means the LCL is empty.
333 * s must not be NULL.
334 *
335 * Moves g_lcl_pivot to the element e such that e->next should be
336 * changed to point to the new element according to s.
337 * If an element with the name s already is found,
338 * returns 0 instead of 1 and pivot will be pointing to the
339 * entry with that symchar.
340 * On exit g_lcl_pivot might be null if head and tail are
341 * or if the s given is ahead in alphabetical order of all the
342 * list elements.c
343 *
344 */
345 static
346 int LocateLCLPivot(symchar *s)
347 {
348 int cmp;
349 assert(s!=NULL);
350 if (g_lcl_pivot == NULL) {
351 /* list is empty. null is the pivot. */
352 return 1;
353 }
354 if (s == g_lcl_pivot->e.strptr) return 0;
355 /* repeated name check by ptr */
356 cmp = CmpSymchar(LCLNAME,s);
357 if (cmp==0) return 0;
358 if (cmp<0) {
359 /* search forward */
360 while (g_lcl_pivot->next != NULL) {
361 g_lcl_pivot = g_lcl_pivot->next;
362 cmp = CmpSymchar(LCLNAME,s);
363 if (cmp >= 0) {
364 if (cmp==0) return 0;
365 g_lcl_pivot = g_lcl_pivot->prev;
366 return 1;
367 }
368 }
369 assert(g_lcl_pivot==g_lcl_tail);
370 return 1;
371 } else {
372 /* search backward */
373 while (g_lcl_pivot->prev != NULL) {
374 g_lcl_pivot = g_lcl_pivot->prev;
375 cmp = CmpSymchar(LCLNAME,s);
376 if (cmp <= 0) {
377 if (cmp==0) return 0;
378 return 1;
379 }
380 }
381 assert(g_lcl_pivot==g_lcl_head);
382 g_lcl_pivot = NULL;
383 return 1;
384 }
385 }
386
387 #define STATBODY 0
388 #define STATPARAMETRIC 1
389
390 /** Store a new 'child record' in the linked list of statements.
391
392 @param s name of the child (symchar that's already AddSymbol-ed)
393 @param d type pointer for the childname, which may be null,
394 @param nsubs number of known subscripts (if an array),
395 0 if not an array,
396 <0 if it's an alias (subscripts to be determined at the end).
397 See the 'note' below.
398 @param parametric 1 if stat is a parameter decl, 0 if body stat (...?)
399
400 @return 1 on success, 0 on failure by duplicate name, -1 on MALLOC or bad input.
401
402 This function inserts a named named statement/type into the named-ordered
403 list of statements.
404
405 On entry assumes g_lcl_pivot != NULL unless there are no children yet.
406
407 For aliases, the correct value of nsubs must be set before
408 calling MakeChildList.
409
410 @note For 'nsubs', a value of '-1' should be given for <tt>b ALIASES a;</tt>
411 and a value of '-2' should be given for <tt>b[1..n] ALIASES a;</tt> since
412 we don't know for certain the subscriptedness of 'a' untill children
413 are all parsed.
414 */
415 static
416 int AddLCL(symchar *s,CONST struct TypeDescription *d, int nsubs,
417 CONST struct Statement *stat, int parametric)
418 {
419 struct LinkChildListEntry *new;
420
421 /* search for insertion location, which means move pivot to the
422 * name just before this one so we can insert after pivot.
423 */
424 if (!LocateLCLPivot(s)) {
425 return 0; /* if found the exact name, exit early */
426 }
427
428 /* get a LCLEntry to fill with data */
429 new = GetLCL();
430 if (new==NULL) return -1;
431
432 new->e.strptr = s;
433 new->e.typeptr = d;
434 new->e.statement = stat;
435 new->e.isarray = nsubs;
436 new->e.bflags = CBF_VISIBLE;
437 switch (StatementType(stat)) {
438 case ALIASES:
439 new->e.origin = origin_ALI;
440 break;
441 case ARR:
442 new->e.origin = origin_ARR;
443 break;
444 case ISA:
445 new->e.origin = origin_ISA;
446 break;
447 case WILLBE:
448 new->e.origin = origin_WB;
449 break;
450 case REL:
451 case LOGREL:
452 case WHEN:
453 case EXT:
454 /* not strictly kosher TRUE, but truer than saying an error */
455 /* all rel/logrel/when are implicitly IS_A'd/typed */
456 new->e.origin = origin_ISA;
457 break;
458 default:
459 new->e.origin = origin_ERR;
460 break;
461 }
462 if (new->e.origin != origin_ERR && parametric==STATPARAMETRIC) {
463 new->e.origin += origin_PARAMETER_OFFSET;
464 }
465 g_lcl_length++;
466
467 /* insert after pivot and make new element new pivot */
468 new->prev = g_lcl_pivot; /* might be null */
469 if (g_lcl_pivot!=NULL) {
470 /* the list has a head we can add in after. we need to point back at
471 * it, it at us, and possibly we are the tail or the tail points back.
472 */
473 /* point new element at tail of list */
474 new->next = g_lcl_pivot->next; /* might be null */
475 /* update tail back pointer */
476 if (new->next == NULL) {
477 /* added to end of list */
478 g_lcl_tail = new;
479 } else {
480 /* added before some tail */
481 new->next->prev = new;
482 }
483 /* point it at us */
484 g_lcl_pivot->next = new;
485 } else {
486 /* first element being inserted, or new element leads list. */
487 new->next = g_lcl_head;
488 g_lcl_head = new;
489 if (g_lcl_tail == NULL) { /* new is the only element in list */
490 g_lcl_tail = new;
491 } else {
492 new->next->prev = new;
493 }
494 }
495 g_lcl_pivot = new; /* cannot be NULL */
496 assert(new->e.origin != origin_ERR);
497 return 1;
498 }
499
500 /*
501 * Searches the LCL for an entry with a symchar with same
502 * value as string given. string given is expected to
503 * be from the symbol table.
504 * Returns the pointer to the LCLentry if exact match found
505 * else returns NULL.
506 * Side effects: relocates lcl_pivot to entry matching s, if
507 * such an entry exists, else no side effects.
508 * If symchar gets redefined, this will most probably need
509 * reimplementing.
510 */
511 static
512 struct LinkChildListEntry *FindLCL(symchar *s)
513 {
514 struct LinkChildListEntry *hold;
515 hold = g_lcl_pivot;
516 if (LocateLCLPivot(s)) {
517 /* locate found an insertion point, so name wasn't in list. */
518 g_lcl_pivot = hold;
519 return NULL;
520 } else {
521 /* assumption: we will always call FindLCL correctly, so that
522 * a zero return does not mean an error.
523 */
524 return g_lcl_pivot;
525 }
526 }
527
528
529 /**********************************************************\
530 end linkchildlistentry memory manipulation functions.
531 could we put all the above in the childdef file?
532 \**********************************************************/
533
534 #define DoName(n,c,s) DoNameF((n),(c),(s),1)
535 #define DoNameQuietly(n,c) DoNameF((n),(c),(s),0)
536
537 /**
538 Checks the first element of a name for being in the child list.
539
540 @return DEF_OKAY if the child was added to the list
541 DEF_NAME_DUPLICATE if the child was already in the list (can't be added)
542
543 @param nptr name being added. We are only looking at the first 'link' in the name, eg 'a' in 'a[5]'.
544 @param noisy output stuff when child can't be added
545
546 Name must be an id (ie a variable name like 'my_var')
547
548 Also checks if name is name of an array.
549 This function should NOT be use on parameter declarations.
550 */
551 static enum typelinterr
552 DoNameF(CONST struct Name *nptr,
553 CONST struct TypeDescription *type,
554 CONST struct Statement *stat,
555 int noisy)
556 {
557 register symchar *name;
558 int ok;
559 int nsubs=0;
560
561 /*char *nstr;
562 nstr = WriteNameString(nptr);
563 CONSOLE_DEBUG(nstr);
564 ascfree(nstr);*/
565
566 if (NameId(nptr) !=0){
567 name = NameIdPtr(nptr);
568 switch (StatementType(stat)) {
569 case EXT:
570 /* CONSOLE_DEBUG("PROCESSING EXTERNAL RELATION"); */
571 nsubs = NameLength(nptr) - 1;
572 /* CONSOLE_DEBUG("NSUBS = %d",nsubs); */
573 break;
574 case ISA:
575 case REF: /* IS_A of prototype */
576 case WILLBE:
577 case REL:
578 case LOGREL:
579 case WHEN:
580 nsubs = NameLength(nptr) - 1;
581 break;
582 case ALIASES:
583 nsubs -= NameLength(nptr); /* because init to 0 */
584 break;
585 case ARR:
586 /* god this case is ugly */
587 if (nptr==NamePointer(ArrayStatAvlNames(stat))) {
588 /* first field is an alias array */
589 nsubs -= NameLength(nptr); /* because init to 0 */
590 type = NULL;
591 } else {
592 /* second field is an IS_A of a set */
593 type = FindSetType();
594 nsubs = NameLength(nptr) - 1;
595 }
596 break;
597 default:
598 /* should never happen */
599 return DEF_STAT_MISLOCATED;
600 }
601 ok = AddLCL( name,type, nsubs,
602 stat, /* statement of initial IS_A/ALIASES,relation */
603 STATBODY
604 );
605 if (ok < 1) {
606 if (ok < 0) {
607 ERROR_REPORTER_NOLINE(ASC_PROG_FATAL,"Insufficient memory during parse.");
608 return DEF_ILLEGAL; /* well, having insufficient memory is illegal */
609 }
610 if (noisy && ok == 0) {
611 ERROR_REPORTER_NOLINE(ASC_USER_ERROR,"Same instance name \"%s\" used twice.",SCP(name));
612 assert(g_lcl_pivot!=NULL);
613 if (g_lcl_pivot->e.statement != stat ) {
614 STATEMENT_ERROR(g_lcl_pivot->e.statement," First seen:");
615 } else {
616 FPRINTF(ASCERR,"\n");
617 }
618 }
619 return DEF_NAME_DUPLICATE;
620 }
621 } else {
622 /* should never happen due to new upstream filters. */
623 ERROR_REPORTER_NOLINE(ASC_PROG_ERROR,"Bad name structure found in variable list.");
624 return DEF_NAME_INCORRECT;
625 }
626 return DEF_OKAY;
627 }
628
629 static
630 enum typelinterr DoVarList(CONST struct VariableList *vlist,
631 CONST struct TypeDescription *type,
632 CONST struct Statement *stat)
633 {
634 register CONST struct Name *nptr;
635 enum typelinterr error_code;
636 while(vlist!=NULL){
637 nptr = NamePointer(vlist);
638 error_code = DoName(nptr,type,stat);
639 if (error_code != DEF_OKAY) return error_code;
640 vlist = NextVariableNode(vlist);
641 }
642 return DEF_OKAY;
643 }
644
645 /*
646 * This function is supposed to handle the IS_A's inside a
647 * SELECT statement. However, now all of the statements inside
648 * SELECT are contained in the main statement list, which is
649 * flat. So, it is not required anymore; thus, the #if
650 */
651 #ifdef THIS_IS_AN_UNUSED_FUNCTION
652 static
653 enum typelinterr DoSelectList(struct SelectList *cases)
654 {
655 enum typelinterr error_code;
656 while(cases != NULL){
657 error_code = DoIS_A(SelectStatementList(cases));
658 if (error_code != DEF_OKAY) {
659 return error_code;
660 }
661 cases = NextSelectCase(cases);
662 }
663 return DEF_OKAY;
664 }
665 #endif /* THIS_IS_AN_UNUSED_FUNCTION */
666
667
668 /*
669 * Calls functions to check child name list against rhs of ALIASES statements.
670 * Recurses in for loops. The check is only partial on qualified names, but
671 * that catches some typos.
672 * this function should be merged with Lint Once Lint is working.
673 * It can only work after the complete child list is constructed.
674 * It returns DEF_OKAY unless a rhs is missing or a relation alias
675 * is attempted.
676 * Basically, prevents aliasing of relations.
677 */
678 static
679 enum typelinterr VerifyALIASES(CONST struct StatementList *stats,
680 struct gl_list_t *childlist)
681 {
682 register struct gl_list_t *statements;
683 register unsigned long c,len,pos;
684 enum typelinterr error_code;
685 struct Statement *stat;
686 struct ChildListEntry test;
687 struct ChildListEntry *clep;
688 statements = GetList(stats);
689 len = gl_length(statements);
690 for(c=1;c<=len;c++){
691 stat = (struct Statement *)gl_fetch(statements,c);
692 switch(StatementType(stat)){
693 case ALIASES:
694 /* for aliases, checking the rhs can only be done partially,
695 * and only after the whole child list is available.
696 */
697 test.strptr = NameIdPtr(AliasStatName(stat));
698 pos = gl_search(childlist,&test,(CmpFunc)CmpChildListEntries);
699 /* the preceding gl_search relies on the fact that the comparison
700 * element in the ChildListEntry is the symchar.
701 * It will break if things are different.
702 */
703 if (pos != 0) {
704 clep = (struct ChildListEntry *)gl_fetch(childlist,pos);
705 /* check relation aliases */
706 if (clep->typeptr != NULL) {
707 if (GetBaseType(clep->typeptr) == relation_type ||
708 GetBaseType(clep->typeptr) == logrel_type ) {
709 /* mark stat wrong */
710 MarkStatContext(stat,context_WRONG);
711 error_code = DEF_ILLEGAL_RHS;
712 TypeLintError(ASCERR,stat, error_code);
713 WSS(ASCERR,stat);
714 return error_code;
715 }
716 }
717 error_code = DEF_OKAY;
718 } else {
719 error_code = DEF_NAME_MISSING;
720 TypeLintError(ASCERR,stat, error_code);
721 return error_code;
722 }
723 break;
724 case FOR:
725 error_code = VerifyALIASES(ForStatStmts(stat),childlist);
726 if (error_code != DEF_OKAY){
727 TypeLintError(ASCERR,stat, error_code);
728 return error_code;
729 }
730 break;
731 case COND:
732 error_code = VerifyALIASES(CondStatList(stat),childlist);
733 if (error_code != DEF_OKAY){
734 TypeLintError(ASCERR,stat, error_code);
735 return error_code;
736 }
737 break;
738 case SELECT:
739 /* statements inside SELECT are analyzed as part of the flat
740 * statement list
741 * fall through
742 */
743 case REF:
744 case ISA:
745 case WHEN:
746 default: /* IRT, ATS, AA, REL, ASGN, RUN, IF, EXT, CASGN, too. */
747 break;
748 }
749 }
750 return DEF_OKAY;
751 }
752
753 /* calls functions to check child name list against lhs of statements
754 * Recurses in for loops. builds the child name list as it goes through
755 * subsidiary functions.
756 */
757 static
758 enum typelinterr DoIS_A(CONST struct StatementList *stats)
759 {
760 register struct gl_list_t *statements;
761 register unsigned long c,len;
762 enum typelinterr error_code;
763 struct Statement *stat;
764 statements = GetList(stats);
765 len = gl_length(statements);
766 for(c=1;c<=len;c++){
767 stat = (struct Statement *)gl_fetch(statements,c);
768 switch(StatementType(stat)){
769 case WILLBE:
770 case ISA:
771 /* the type part to the statement was checked during parse,
772 * but not type arguments.
773 */
774 error_code = DoVarList(GetStatVarList(stat),
775 FindType(GetStatType(stat)),stat);
776 if (error_code != DEF_OKAY) {
777 TypeLintError(ASCERR,stat, error_code);
778 return error_code;
779 }
780 break;
781 case ALIASES:
782 /* for aliases, checking the rhs can only be done partially,
783 * and only after the whole child list is available.
784 */
785 error_code = DoVarList(GetStatVarList(stat),NULL,stat);
786 if (error_code != DEF_OKAY) {
787 TypeLintError(ASCERR,stat, error_code);
788 return error_code;
789 }
790 break;
791 case ARR:
792 /* for aliases, checking the rhs can only be done partially,
793 * and only after the whole child list is available.
794 */
795 error_code = DoVarList(ArrayStatAvlNames(stat),NULL,stat);
796 if (error_code != DEF_OKAY) {
797 TypeLintError(ASCERR,stat, error_code);
798 return error_code;
799 }
800 error_code = DoVarList(ArrayStatSetName(stat),NULL,stat);
801 if (error_code != DEF_OKAY) {
802 TypeLintError(ASCERR,stat, error_code);
803 return error_code;
804 }
805 break;
806 case REF:
807 error_code = DoVarList(ReferenceStatVlist(stat),NULL,stat);
808 if (error_code != DEF_OKAY) {
809 TypeLintError(ASCERR,stat,error_code);
810 return error_code;
811 }
812 break;
813 case SELECT:
814 /* All the statements in the select are now in the main
815 * statement list which is a flat list. the following
816 * code is not required anymore;
817
818 * error_code = DoSelectList(SelectStatCases(stat));
819 * if (error_code != DEF_OKAY) {
820 * TypeLintError(ASCERR,stat, error_code);
821 * return error_code;
822 * }
823
824 */
825 break;
826 case FOR:
827 error_code = DoIS_A(ForStatStmts(stat));
828 if (error_code != DEF_OKAY) {
829 TypeLintError(ASCERR,stat, error_code);
830 return error_code;
831 }
832 break;
833 case COND:
834 error_code = DoIS_A(CondStatList(stat));
835 if (error_code != DEF_OKAY) {
836 TypeLintError(ASCERR,stat, error_code);
837 return error_code;
838 }
839 break;
840 default: /* IRT, ATS, AA, REL, ASGN, RUN, WHEN, IF, EXT, CASGN */
841 break;
842 }
843 }
844 return DEF_OKAY;
845 }
846
847 /*
848 * make a name string unique in the child list of the
849 * format <typename>_<relnum><sufficient a-z letters to be
850 * unique>.
851 * Side effects: leaves lclpivot at or near place name ought
852 * to be added in the list.
853 */
854 static
855 symchar *GenerateId(symchar *type,
856 CONST char *module,
857 unsigned long int number)
858 {
859 unsigned length;
860 symchar *result;
861 char statname[MAXTOKENLENGTH+12],c;
862 sprintf(statname,"%s_%lu",SCP(type),number);
863 result = AddSymbol(statname);
864 if (FindLCL(result)==NULL) {
865 return result;
866 }
867 length = SCLEN(result);
868 while( (length+1) < (MAXTOKENLENGTH+12) ) {
869 statname[length+1]='\0';
870 for(c='a';c<='z';c++){
871 statname[length]=c;
872 result = AddSymbol(statname);
873 if (FindLCL(result)==NULL) {
874 return result;
875 }
876 }
877 length++;
878 }
879 Asc_Panic(2, NULL,
880 "%s Unable to generate unique name.\n"
881 " The statement is in module %s.\n"
882 " Insufficiently uniqe name is \n%s. Burp!\n",
883 StatioLabel(4), module, statname);
884
885 }
886
887 static int IndexUsed(symchar *name, CONST struct Expr *expr);
888
889 static int UsedInSet(symchar *name, CONST struct Set *sptr)
890 {
891 while (sptr != NULL){
892 if (SetType(sptr)) { /* range */
893 if (IndexUsed(name,GetLowerExpr(sptr))) return 1;
894 if (IndexUsed(name,GetUpperExpr(sptr))) return 1;
895 } else { /* single */
896 if (IndexUsed(name,GetSingleExpr(sptr))) return 1;
897 }
898 sptr = NextSet(sptr);
899 }
900 return 0;
901 }
902
903
904 static
905 int UsedInVar(symchar *name, CONST struct Name *nptr)
906 {
907 /* check if it is a exact match */
908 if ((nptr !=NULL)&&NameId(nptr)&&(NextName(nptr)==NULL)&&
909 (NameIdPtr(nptr) == name)) {
910 return 1;
911 }
912 while (nptr!=NULL){
913 if (!NameId(nptr))
914 if (UsedInSet(name,NameSetPtr(nptr))) return 1;
915 nptr = NextName(nptr);
916 }
917 return 0;
918 }
919
920 static
921 int IndexUsed(symchar *name, CONST struct Expr *expr)
922 {
923 while (expr!=NULL){
924 switch(ExprType(expr)){
925 case e_var:
926 if (UsedInVar(name,ExprName(expr))) return 1;
927 break;
928 case e_set:
929 if (UsedInSet(name,ExprSValue(expr))) return 1;
930 break;
931 case e_card:
932 case e_choice:
933 case e_sum:
934 case e_prod:
935 case e_union:
936 case e_inter:
937 if (UsedInSet(name,ExprBuiltinSet(expr))) return 1;
938 break;
939 default:
940 /* e_func e_int e_real e_boolean e_symbol e_plus e_minus e_times
941 * e_divide e_power e_subexpr e_const e_par e_glassbox
942 * e_blackbox e_opcode e_token e_undefined e_nop e_or e_and
943 * e_in e_st e_equal e_notequal e_less e_greater e_lesseq
944 * e_greatereq e_not e_uminus e_qstring e_maximize e_minimize
945 * e_zero
946 */
947 break;
948 }
949 expr = NextExpr(expr);
950 }
951 return 0;
952 }
953
954 static
955 struct Name *CreateIndexName(symchar *name)
956 {
957 return CreateSetName(CreateSingleSet(CreateVarExpr(CreateIdName(name))));
958 }
959
960 static
961 struct Name *GenerateRelationName(symchar *type,
962 CONST char *module,
963 struct Expr *expr,
964 unsigned long int relnum,
965 struct gl_list_t *ft)
966 {
967 struct Name *result;
968 unsigned long activefors;
969 symchar *idname;
970 struct for_var_t *fv;
971 idname = GenerateId(type,module,relnum);
972 result = CreateSystemIdName(idname);
973 activefors = ActiveForLoops(ft);
974 while (activefors>0){
975 fv = LoopIndex(ft,activefors);
976 if (IndexUsed(GetForName(fv),expr)){
977 result = JoinNames(result,CreateIndexName(GetForName(fv)));
978 }
979 activefors--;
980 }
981 return result;
982 }
983
984 static
985 struct Name *GenerateWhenName(symchar *type,
986 CONST char *module,
987 unsigned long int linenum,
988 struct gl_list_t *ft)
989 {
990 struct Name *result;
991 unsigned long activefors;
992 symchar *idname;
993 struct for_var_t *fv;
994 idname = GenerateId(type,module,linenum);
995 result = CreateSystemIdName(idname);
996 activefors = ActiveForLoops(ft);
997 while (activefors>0){
998 fv = LoopIndex(ft,activefors);
999 result = JoinNames(result,CreateIndexName(GetForName(fv)));
1000 activefors--;
1001 }
1002 return result;
1003 }
1004
1005
1006 /* this function makes sure the relation has a name, generating
1007 * one if required.
1008 */
1009 static
1010 int DoRelation(symchar *type,
1011 struct Statement *stat,
1012 struct gl_list_t *ft)
1013 {
1014 struct Name *nptr;
1015 /* CONSOLE_DEBUG("..."); */
1016 assert(stat && (StatementType(stat) == REL));
1017 g_number++;
1018 nptr = RelationStatName(stat);
1019 if (nptr == NULL){
1020 nptr = GenerateRelationName(type,Asc_ModuleName(StatementModule(stat)),
1021 RelationStatExpr(stat),
1022 g_number,ft);
1023 SetRelationName(stat,nptr);
1024 } else {
1025 if (ActiveForLoops(ft)+1 != (unsigned long)NameLength(nptr) ||
1026 NextIdName(nptr) != NULL) {
1027 return DEF_RELARRAY_SUBS;
1028 }
1029 }
1030 return DoName(nptr,FindRelationType(),stat);
1031 }
1032
1033 static
1034 int DoWhen(symchar *type,
1035 struct Statement *stat,
1036 struct gl_list_t *ft)
1037 {
1038 struct Name *nptr;
1039 assert(stat && (StatementType(stat) == WHEN));
1040 g_number++;
1041 if ((nptr = WhenStatName(stat))==NULL){
1042 nptr = GenerateWhenName(type,Asc_ModuleName(StatementModule(stat)),
1043 g_number,ft);
1044 SetWhenName(stat,nptr);
1045 }
1046 return DoName(nptr,FindWhenType(),stat);
1047 }
1048
1049 static
1050 int DoLogRel(symchar *type,
1051 struct Statement *stat,
1052 struct gl_list_t *ft)
1053 {
1054 struct Name *nptr;
1055 assert(stat && (StatementType(stat) == LOGREL));
1056 g_number++;
1057 nptr = LogicalRelStatName(stat);
1058 if (nptr ==NULL) {
1059 nptr = GenerateRelationName(type,Asc_ModuleName(StatementModule(stat)),
1060 LogicalRelStatExpr(stat),
1061 g_number,ft);
1062 SetLogicalRelName(stat,nptr);
1063 } else {
1064 if (ActiveForLoops(ft)+1 != (unsigned long)NameLength(nptr) ||
1065 NextIdName(nptr) != NULL) {
1066 return DEF_RELARRAY_SUBS;
1067 }
1068 }
1069 return DoName(nptr,FindLogRelType(),stat);
1070 }
1071
1072
1073 /** Process an external statement (i.e. add it to the child list, simply) */
1074 static
1075 int DoExternal(symchar *type,
1076 struct Statement *stat,
1077 struct gl_list_t *ft)
1078 {
1079 struct Name *nptr;
1080 int doname_status;
1081
1082 (void) type; (void) ft;
1083
1084 assert(stat && (StatementType(stat) == EXT));
1085 /*
1086 * The grammar specifies that External function calls
1087 * must be named.
1088 */
1089 switch (ExternalStatMode(stat) ) {
1090 case ek_black:
1091 nptr = ExternalStatNameRelation(stat);
1092 doname_status = DoName(nptr,FindRelationType(),stat);
1093 return doname_status;
1094 case ek_glass:
1095 nptr = ExternalStatNameRelation(stat);
1096 doname_status = DoName(nptr,FindExternalType(),stat);
1097 return doname_status;
1098 default:
1099 nptr = NULL;
1100 break;
1101 }
1102
1103 /* if a ext method shows up, we'll get DEF_NAME_INCORRECT as nptr is null */
1104 doname_status = DoName(nptr,FindExternalType(),stat);
1105 /* CONSOLE_DEBUG("DONAME STATUS = %d",doname_status); */
1106 return doname_status;
1107 }
1108
1109
1110 /*
1111 * Since we implemented the WHEN statement as an instance, we
1112 * generate an automatic name for each WHEN. The following
1113 * function deals with the names of nested WHENs
1114 */
1115 static
1116 enum typelinterr ProcessWhenCases(symchar *type,
1117 struct WhenList *whenlist,
1118 struct gl_list_t *ft)
1119 {
1120 enum typelinterr error_code;
1121 while (whenlist!=NULL){
1122 error_code = DoWhens(type,WhenStatementList(whenlist),ft);
1123 if (error_code != DEF_OKAY) {
1124 return error_code;
1125 }
1126 whenlist = NextWhenCase(whenlist);
1127 }
1128 return DEF_OKAY;
1129 }
1130
1131
1132
1133 /*
1134 * This function is supposed to handle the relations inside a
1135 * SELECT statement. However, now all of the statements inside
1136 * SELECT are contained in the main statement list, which is
1137 * flat. So, it is not required anymore, thus, the #ifdef
1138 *
1139 */
1140 #ifdef THIS_IS_AN_UNUSED_FUNCTION
1141 static
1142 enum typelinterr ProcessSelectCases(CONST char *type,
1143 struct SelectList *selectlist,
1144 struct gl_list_t *ft)
1145 {
1146 enum typelinterr error_code;
1147 while (selectlist!=NULL){
1148 error_code = DoRelations(type,SelectStatementList(selectlist),ft);
1149 if (error_code !=DEF_OKAY) return error_code;
1150 selectlist = NextSelectCase(selectlist);
1151 }
1152 return DEF_OKAY;
1153 }
1154 #endif /* THIS_IS_AN_UNUSED_FUNCTION */
1155
1156
1157 static
1158 enum typelinterr DoRelations(symchar *type,
1159 CONST struct StatementList *stats,
1160 struct gl_list_t *ft)
1161 {
1162 register struct gl_list_t *statements;
1163 register unsigned long c,len;
1164 register struct Statement *stat;
1165 enum typelinterr error_code;
1166 statements = GetList(stats);
1167 len = gl_length(statements);
1168 for(c=1;c<=len;c++){
1169 stat = (struct Statement *)gl_fetch(statements,c);
1170 switch(StatementType(stat)){
1171 case REL:
1172 error_code = DoRelation(type,stat,ft);
1173 if (error_code != DEF_OKAY) {
1174 TypeLintError(ASCERR,stat, error_code);
1175 return error_code;
1176 }
1177 break;
1178 case LOGREL:
1179 error_code = DoLogRel(type,stat,ft);
1180 if (error_code != DEF_OKAY) {
1181 TypeLintError(ASCERR,stat, error_code);
1182 return error_code;
1183 }
1184 break;
1185 case EXT:
1186 /* CONSOLE_DEBUG("PROCESSING EXTERNAL REL"); */
1187 error_code = DoExternal(type,stat,ft);
1188 if (error_code != DEF_OKAY) {
1189 TypeLintError(ASCERR,stat, error_code);
1190 return error_code;
1191 }
1192 break;
1193 case SELECT:
1194 /*
1195 * Now all of the statements inside a SELECT (including
1196 * relations )are contained in the main statement list, which is
1197 * which is flat. So, this case is not required anymore.
1198 *
1199
1200 * error_code = ProcessSelectCases(type,SelectStatCases(stat),ft);
1201 * if (error_code != DEF_OKAY) {
1202 * TypeLintError(ASCERR,stat, error_code);
1203 * return error_code;
1204 * }
1205
1206 */
1207 break;
1208 case FOR:
1209 AddLoopVariable(ft,CreateForVar(ForStatIndex(stat)));
1210 error_code = DoRelations(type,ForStatStmts(stat),ft);
1211 RemoveForVariable(ft);
1212 if (error_code != DEF_OKAY) {
1213 return error_code;
1214 }
1215 break;
1216 case COND:
1217 error_code=DoRelations(type,CondStatList(stat),ft);
1218 if (error_code != DEF_OKAY) {
1219 TypeLintError(ASCERR,stat, error_code);
1220 return error_code;
1221 }
1222 break;
1223 default: /* ISA, IRT, ATS, AA, ASGN, WHEN, RUN, IF, REF, CASGN, CALL*/
1224 break;
1225 }
1226 }
1227 return DEF_OKAY;
1228 }
1229
1230 /*
1231 * Since we implemented the WHEN statement as an instance, we
1232 * generate an automatic name for each WHEN. The following
1233 * function deals with the names of a WHEN statement. For
1234 * nested WHEN, the function ProcessWhenCases is called.
1235 */
1236
1237
1238 static
1239 enum typelinterr DoWhens(symchar *type,
1240 CONST struct StatementList *stats,
1241 struct gl_list_t *ft)
1242 {
1243 register struct gl_list_t *statements;
1244 register unsigned long c,len;
1245 register struct Statement *stat;
1246 enum typelinterr error_code;
1247 statements = GetList(stats);
1248 len = gl_length(statements);
1249 for(c=1;c<=len;c++){
1250 stat = (struct Statement *)gl_fetch(statements,c);
1251 switch(StatementType(stat)){
1252 case WHEN:
1253 error_code = DoWhen(type,stat,ft);
1254 if (error_code != DEF_OKAY) {
1255 TypeLintError(ASCERR,stat, error_code);
1256 return error_code;
1257 }
1258 error_code = ProcessWhenCases(type,WhenStatCases(stat),ft);
1259 if (error_code != DEF_OKAY) {
1260 TypeLintError(ASCERR,stat, error_code);
1261 return error_code;
1262 }
1263 break;
1264 case FOR:
1265 AddLoopVariable(ft,CreateForVar(ForStatIndex(stat)));
1266 error_code = DoWhens(type,ForStatStmts(stat),ft);
1267 RemoveForVariable(ft);
1268 if (error_code != DEF_OKAY) {
1269 return error_code;
1270 }
1271 break;
1272 default:
1273 break;
1274 }
1275 }
1276 return DEF_OKAY;
1277 }
1278
1279
1280 /*****************************************************************\
1281 Functions to help determine the types of children.
1282 \*****************************************************************/
1283
1284 /*
1285 * this is a little structure we require for a temporary singly linked
1286 * list of statements.
1287 */
1288 enum albits {
1289 AL_WAIT = 0, /* wait means we haven't been able to determine anything yet */
1290 AL_WARR, /* nothing yet on ARR statement common rhslist type. */
1291 AL_DONE, /* done means we've processed this alias statement */
1292 AL_NORHS /* norhs means the rhs cannot be found */
1293 };
1294
1295 struct AliasList {
1296 struct Statement *stat;
1297 struct AliasList *next;
1298 enum albits bits;
1299 };
1300
1301 /*
1302 * create an alias list entry using statement s.
1303 */
1304 static
1305 struct AliasList *ALCreate(struct Statement *s)
1306 {
1307 struct AliasList *ret;
1308 ret = (struct AliasList *)ascmalloc(sizeof(struct AliasList));
1309 assert(ret!=NULL);
1310 ret->stat = s;
1311 ret->next = NULL;
1312 if (StatementType(s) == ARR) {
1313 ret->bits = AL_WARR;
1314 } else {
1315 ret->bits = AL_WAIT;
1316 }
1317 return ret;
1318 }
1319
1320 /*
1321 * Destroy an aliases list entry
1322 */
1323 static
1324 void ALDestroy(struct AliasList *a)
1325 {
1326 ascfree(a);
1327 }
1328
1329 /*
1330 * Destroy an aliases list. input may be null.
1331 */
1332 static
1333 void DestroyAliasesList(struct AliasList *a)
1334 {
1335 struct AliasList *old;
1336 while (a != NULL) {
1337 old = a;
1338 a = old->next;
1339 ALDestroy(old);
1340 }
1341 }
1342 /*
1343 * this function creates prepends an alias list entry
1344 * and returns the new head of the list.
1345 * ele or list may be null.
1346 */
1347 static
1348 struct AliasList *ALPrepend(struct AliasList *list, struct AliasList *ele)
1349 {
1350 if (ele==NULL) return list;
1351 if (list != NULL) {
1352 if (ele->next == NULL) {
1353 /* usual cheap case */
1354 ele->next = list;
1355 } else {
1356 /* case where ele is a list */
1357 struct AliasList *tail;
1358 tail = ele;
1359 while (tail->next != NULL) {
1360 tail = tail->next;
1361 }
1362 tail->next = list;
1363 }
1364 }
1365 return ele;
1366 }
1367
1368 /*
1369 * Returns a list of aliases statements found in the
1370 * given list.
1371 * Recursive in some compound statements
1372 */
1373 static
1374 struct AliasList *CreateAliasesList(struct StatementList *stats)
1375 {
1376 register struct Statement *stat;
1377 struct gl_list_t *statements;
1378 struct AliasList *result=NULL;
1379 unsigned long c,len;
1380
1381 statements = GetList(stats);
1382 len = gl_length(statements);
1383 for(c=1;c<=len;c++){
1384 stat = (struct Statement *)gl_fetch(statements,c);
1385 switch(StatementType(stat)){
1386 case ALIASES:
1387 case ARR:
1388 result = ALPrepend(result,ALCreate(stat));
1389 break;
1390 case FOR:
1391 result = ALPrepend(result,CreateAliasesList(ForStatStmts(stat)));
1392 break;
1393 case SELECT:
1394 /*
1395 * Now all of the statements inside a SELECT statement
1396 * are contained in the main statement list, which is
1397 * flat. So, this case is not required anymore.
1398 *
1399 */
1400 break;
1401 default:
1402 break;
1403 }
1404 }
1405 return result;
1406 }
1407
1408 /*
1409 */
1410 enum e_findrhs {
1411 FRC_ok = 0, /* got type. name is simple */
1412 FRC_array, /* got type, which is base of array */
1413 FRC_badname, /* part named is impossible */
1414 FRC_attrname, /* part named is subatomic and can't be aliased */
1415 FRC_unable, /* unable to determine type of rhs, but might later */
1416 FRC_fail /* unable to determine type of rhs ever */
1417 };
1418
1419 /*
1420 * This function tries to determine the first chain item in a name
1421 * which was constructed by being passed into the type of
1422 * which the item is a part.
1423 * Works from the childlist of the typedescription given.
1424 * This function will recurse as required.
1425 * The name given may or may not be compound.
1426 * Possible returns:
1427 * FRC_ok: no parameter origin parts were found. *nptrerr <-- NULL.
1428 * FRC_badname: part name starting at *nptrerr is impossible, array, etc.
1429 * FRC_attrname: part named starting at *nptrerr is subatomic.
1430 * FRC_array: part named starting at *nptrerr has too many/not enough []
1431 * FRC_fail: parametric origin part was found. *nptrerr <-- param part.
1432 * FRC_unable: never returned.
1433 * On the first call from the user, nptrerr should be a name to
1434 * evaluate in the context of the type given.
1435 */
1436 static
1437 enum e_findrhs AANameIdHasParameterizedPart(CONST struct Name **nptrerr,
1438 CONST struct TypeDescription *type)
1439 {
1440 CONST struct Name *nptr;
1441 CONST struct Name *pnptr,*tnptr;
1442 CONST struct TypeDescription *rtype;
1443 ChildListPtr cl;
1444 unsigned long pos;
1445 int alen,subseen,subsleft;
1446
1447 assert(type!=NULL);
1448 assert(NameId(*nptrerr)!=0);
1449 nptr = *nptrerr;
1450 assert(nptr!=NULL);
1451
1452 if ( GetBaseType(type)== patch_type) {
1453 type = GetPatchOriginal(type);
1454 if (type==NULL) {
1455 return FRC_badname;
1456 }
1457 }
1458 if ( GetBaseType(type) != model_type) {
1459 /* cannot alias subatomic parts, and arrays don't have independent
1460 * typedescs yet.
1461 */
1462 return FRC_attrname;
1463 }
1464 cl = GetChildList(type);
1465 if (cl==NULL) {
1466 /* very wierd case, but then we have very wierd users. */
1467 return FRC_badname;
1468 }
1469 pos = ChildPos(cl,NameIdPtr(nptr));
1470 if (pos == 0) { /* name not found */
1471 return FRC_badname;
1472 }
1473 rtype = ChildBaseTypePtr(cl,pos);
1474 if (rtype == NULL) {
1475 return FRC_badname;
1476 }
1477 if (ChildParametric(cl,pos)!=0) {
1478 return FRC_fail;
1479 }
1480 alen = ChildIsArray(cl,pos);
1481 pnptr = NextIdName(nptr);
1482 if (pnptr==NULL) {
1483 /* end of the dot qualified line */
1484 tnptr = NextName(nptr);
1485 if (tnptr==NULL) {
1486 /* a simple name possibly root of array */
1487 if (alen) {
1488 return FRC_array; /* we don't like array roots */
1489 } else {
1490 *nptrerr=NULL;
1491 return FRC_ok;
1492 }
1493 } else {
1494 /* sub array or array element. */
1495 subseen = 0;
1496 while (tnptr!=pnptr) {
1497 subseen++;
1498 tnptr=NextName(tnptr);
1499 }
1500 subsleft = alen - subseen;
1501 if (subsleft < 0) { /* name not found. too many subscripts. */
1502 return FRC_array;
1503 }
1504 if (subsleft) {
1505 return FRC_array; /* we don't like array roots */
1506 } else {
1507 *nptrerr=NULL;
1508 return FRC_ok;
1509 }
1510 }
1511 }
1512 /* there's more to the name. keep going, after checking that
1513 * all subscripts required are filled.
1514 */
1515 subseen = 0;
1516 tnptr = NextName(nptr);
1517 while (tnptr!=pnptr) {
1518 subseen++;
1519 tnptr=NextName(tnptr);
1520 }
1521 subsleft = alen - subseen;
1522 if (subsleft != 0) {
1523 /* name not found. too many/not enough subscripts. */
1524 return FRC_array;
1525 }
1526 *nptrerr = pnptr;
1527 return AANameIdHasParameterizedPart(nptrerr,rtype);
1528 }
1529
1530 /*
1531 * This function tries to determine the type of the name given
1532 * based on the childlist in the typedescription given.
1533 * Return value is in accordance with the header for
1534 * FIndRHSType.
1535 * This function will recurse as required.
1536 * The name given may or may not be compound.
1537 * Type must be of a MODEL or patch with a child list.
1538 */
1539 static
1540 CONST struct TypeDescription
1541 *FindChildTypeFromName(CONST struct Name *nptr,
1542 CONST struct TypeDescription *type,
1543 enum e_findrhs *rval,
1544 int *rlen)
1545 {
1546 CONST struct Name *pnptr,*tnptr;
1547 CONST struct TypeDescription *rtype;
1548 ChildListPtr cl;
1549 unsigned long pos;
1550 int alen,subseen,subsleft;
1551
1552 assert(type!=NULL);
1553 assert(NameId(nptr)!=0);
1554 assert(rval!=NULL);
1555 if ( GetBaseType(type)== patch_type) {
1556 type = GetPatchOriginal(type);
1557 if (type==NULL) {
1558 *rval = FRC_fail;
1559 return NULL;
1560 }
1561 }
1562 if ( GetBaseType(type) != model_type) {
1563 /* cannot alias subatomic parts, and arrays don't have independent
1564 * typedescs yet.
1565 */
1566 *rval = FRC_attrname;
1567 return NULL;
1568 }
1569 cl = GetChildList(type);
1570 if (cl==NULL) {
1571 /* very wierd case, but then we have very wierd users. */
1572 *rval = FRC_badname;
1573 return NULL;
1574 }
1575 pos = ChildPos(cl,NameIdPtr(nptr));
1576 if (pos == 0) { /* name not found */
1577 *rval = FRC_badname;
1578 return NULL;
1579 }
1580 rtype = ChildBaseTypePtr(cl,pos);
1581 if (rtype == NULL) {
1582 /* rhs type not established. will not be later. */
1583 *rval = FRC_fail;
1584 return NULL;
1585 }
1586 alen = ChildIsArray(cl,pos);
1587 pnptr = NextIdName(nptr);
1588 if (pnptr==NULL) {
1589 /* end of the dot qualified line */
1590 tnptr = NextName(nptr);
1591 if (tnptr==NULL) {
1592 /* aliasing a simple name */
1593 *rlen = alen;
1594 if (alen) {
1595 *rval = FRC_array;
1596 } else {
1597 *rval = FRC_ok;
1598 }
1599 } else {
1600 /* aliasing sub array or array element. */
1601 subseen = 0;
1602 while (tnptr!=pnptr) {
1603 subseen++;
1604 tnptr=NextName(tnptr);
1605 }
1606 subsleft = alen - subseen;
1607 if (subsleft < 0) { /* name not found. too many subscripts. */
1608 *rval = FRC_badname;
1609 *rlen = 0;
1610 return NULL;
1611 }
1612 *rlen = subsleft;
1613 if (subsleft) {
1614 *rval = FRC_array;
1615 } else {
1616 *rval = FRC_ok;
1617 }
1618 }
1619 return rtype;
1620 }
1621 /* there's more to the name. keep going, after checking that
1622 * all subscripts required are filled.
1623 */
1624 subseen = 0;
1625 tnptr = NextName(nptr);
1626 while (tnptr!=pnptr) {
1627 subseen++;
1628 tnptr=NextName(tnptr);
1629 }
1630 subsleft = alen - subseen;
1631 if (subsleft != 0) {
1632 /* name not found. too many/not enough subscripts. */
1633 *rlen = 0;
1634 *rval = FRC_badname;
1635 return NULL;
1636 }
1637 return FindChildTypeFromName(pnptr,rtype,rval,rlen);
1638 }
1639
1640 /*
1641 * This function tries to determine from the RHS name of an
1642 * aliases statement what the type of that name
1643 * is, to a first approximation, and whether it is definitely array.
1644 * Returns NULL if type not found. If not null, *rval will contain
1645 * FRC_ok or FRC_array to communicate arrayness.
1646 *
1647 * There is some ambiguity about arrays because (without finding
1648 * the defining statement which is tricky) we can't know how many
1649 * subscripts there are and hence can't know whether an array name
1650 * points to a final element or to a sub-array.
1651 *
1652 * This function does some preliminary work to digest the rhs part
1653 * name based on the clist given, and then (if required) hands off
1654 * to a routine which determines (if possible) from the existing type tree
1655 * what the type is that goes with the name.
1656 *
1657 * 12/96 Revisions:
1658 * Finds the EXACT ARRAYNESS, not an approximation. FRC_ok only when
1659 * the name resolves to a single array element, OTHERWISE FRC_array.
1660 * If FRC_array, then *rlen will be the number of subscripts left
1661 * unspecified in the name, OTHERWISE rlen should be ignored.
1662 * It does NOT check in a for table. You can't alias dummy vars.
1663 * *origin will be the origin_ flag of the first name element
1664 * (local scope name) if return value is FRC_ok or FRC_array.
1665 * OTHERWISE *origin will be returned as an ERR.
1666 *
1667 * Due to its multiple usages, this function is not well named,
1668 * nor is its behavior particularly simple. Since the CHOICE is
1669 * between overdue and do-over, this is a do-over. The price of
1670 * handling errors in a language which specializes in managing
1671 * anarchy is really quite high.
1672 */
1673 static
1674 CONST struct TypeDescription *FindRHSType(CONST struct Name *nptr,
1675 CONST struct gl_list_t *clist,
1676 enum e_findrhs *rval,
1677 int *rlen,
1678 unsigned int *origin)
1679 {
1680 CONST struct Name *pnptr, *tnptr;
1681 struct ChildListEntry *found;
1682 struct ChildListEntry test;
1683 unsigned long pos;
1684
1685 *origin = origin_ERR;
1686 /* digest the first part of the name in the local scope */
1687 if (!NameId(nptr)) {
1688 /* names like [1] are obviouslly goop */
1689 *rval = FRC_badname;
1690 return NULL;
1691 }
1692 test.strptr = NameIdPtr(nptr); /* fetch the symchar */
1693 pos = gl_search(clist,&test,(CmpFunc)CmpChildListEntries);
1694 if (pos == 0) {
1695 /* name not found */
1696 *rval = FRC_badname;
1697 return NULL;
1698 }
1699 /* name found. */
1700 found = (struct ChildListEntry *) gl_fetch(clist,pos);
1701 if (found->typeptr == NULL || found->isarray < 0) {
1702 /* rhs type not yet established. try later. */
1703 *rval = FRC_unable;
1704 return NULL;
1705 }
1706 *origin = found->origin;
1707 *rlen = found->isarray;
1708 if (NameLength(nptr) == 1) {
1709 /* local scalar name */
1710 if (found->isarray) {
1711 *rval = FRC_array;
1712 } else {
1713 *rval = FRC_ok;
1714 }
1715 return found->typeptr;
1716 }
1717 /* compound name. could be local or part of part. */
1718 pnptr = NextIdName(nptr);
1719 tnptr = NextName(nptr);
1720 while (tnptr!=pnptr) {
1721 (*rlen)--;
1722 tnptr = NextName(tnptr);
1723 }
1724 if (*rlen < 0) {
1725 *rval = FRC_badname;
1726 return NULL;
1727 }
1728 if (pnptr==NULL) {
1729 if (*rlen > 0) {
1730 *rval = FRC_array;
1731 } else {
1732 *rval = FRC_ok;
1733 }
1734 return found->typeptr;
1735 } else {
1736 if (*rlen > 0) {
1737 /* name is of form a.b where it should be a[k].b; missing subscripts */
1738 *rval = FRC_badname;
1739 return NULL;
1740 }
1741 return FindChildTypeFromName(pnptr,found->typeptr,rval,rlen);
1742 }
1743 }
1744
1745 /*
1746 * Need to watch out for a.b type names and not mark them?
1747 */
1748 static
1749 void MarkIfPassedArgs(CONST struct Name *nptr, CONST struct gl_list_t *clist)
1750 {
1751 CONST struct Name *pnptr;
1752 struct ChildListEntry *found;
1753 struct ChildListEntry test;
1754 int rlen;
1755 unsigned long pos;
1756
1757 /* digest the first part of the name in the local scope */
1758 if (!NameId(nptr)) {
1759 /* names like [1] are obviouslly goop */
1760 return;
1761 }
1762 test.strptr = NameIdPtr(nptr); /* fetch the symchar */
1763 pos = gl_search(clist,&test,(CmpFunc)CmpChildListEntries);
1764 if (pos == 0) {
1765 /* name not found */
1766 return;
1767 }
1768 /* name found. */
1769 found = (struct ChildListEntry *) gl_fetch(clist,pos);
1770 rlen = found->isarray;
1771 if (NameLength(nptr) == 1) {
1772 /* local scalar name */
1773 found->bflags |= CBF_PASSED;
1774 return;
1775 }
1776 /* compound name. could be local or part of part. */
1777 pnptr = NextIdName(nptr); /* if a.b, pnptr will be not NULL */
1778 if (pnptr == NULL) {
1779 /* local array name */
1780 found->bflags |= CBF_PASSED;
1781 }
1782 }
1783
1784 /*
1785 * This function tries to determine from the RHS name list of an
1786 * ALIASES-IS_A statement what the basetype of the array should be.
1787 * to a first approximation, and whether it is a well formed array.
1788 * Doesn't try to ferret out array subscript type (int/sym) mismatches.
1789 * Returns NULL if type not derivable. If not null, *rval will contain
1790 * FRC_ok or FRC_array to communicate arrayness.
1791 *
1792 * Finds the exact arrayness, not an approximation. FRC_ok only when
1793 * the name resolves to a single array element, OTHERWISE FRC_array.
1794 * If FRC_array, then *rlen will be the number of subscripts left
1795 * unspecified in the name, OTHERWISE rlen should be ignored.
1796 * It does NOT check in a for table-- You can't alias dummy vars.
1797 * When return value is FRC_ok or FRC_array
1798 * *origin will be the origin_ARR or origin_PARR
1799 * OTHERWISE *origin should be ignored on return.
1800 * If any of the list is parametric, *origin is origin_PARR.
1801 * This may lead to some incorrect restrictions on the elements of
1802 * the array created from the variablelist given.
1803 */
1804 static
1805 CONST struct TypeDescription *FindCommonType(CONST struct VariableList *vl,
1806 CONST struct gl_list_t *clist,
1807 enum e_findrhs *val,
1808 int *len,
1809 unsigned int *origin)
1810 {
1811 /* return value holders */
1812 CONST struct TypeDescription *rtype=NULL;
1813 enum e_findrhs rval = FRC_fail;
1814 int rlen = -1;
1815 int parametric = 0;
1816
1817 /* temporaries */
1818 CONST struct Name *nptr;
1819 CONST struct TypeDescription *type;
1820
1821 while (vl != NULL) {
1822 nptr = NamePointer(vl);
1823 type = FindRHSType(nptr,clist,val,len,origin);
1824 if (type == NULL) {
1825 switch (*val) {
1826 case FRC_ok:
1827 case FRC_array:
1828 /* good FRC codes not seen if type is NULL */
1829 ASC_PANIC("good FRC codes not seen if type is NULL");
1830 break;
1831 case FRC_badname: /* part named is impossible */
1832 case FRC_attrname: /* part named is subatomic and can't be aliased */
1833 TLNM(ASCERR,nptr,"Impossible/subatomic name: ",3);
1834 *val = FRC_fail;
1835 break;
1836 case FRC_unable: /* unable to determine type of rhs, but might later */
1837 break;
1838 case FRC_fail: /* unable to determine type of rhs ever */
1839 TLNM(ASCERR,nptr,"Type indeterminate name: ",3);
1840 *val = FRC_fail;
1841 break;
1842 }
1843 return NULL;
1844 }
1845 /* else we have some type, be it base of array or OTHERWISE */
1846 if (rtype != NULL) {
1847 /* check base type compatibility */
1848 rtype = GreatestCommonAncestor(rtype,type);
1849 if (rtype==NULL) {
1850 TLNM(ASCERR,nptr,"Type incompatible name: ",3);
1851 *val = FRC_fail;
1852 return NULL;
1853 }
1854 /* check arrayness equivalent */
1855 if (*val != rval /* mismatched FRC_ok and FRC_array */ ||
1856 *len != rlen /* mismatched number of subscripts */) {
1857 TLNM(ASCERR,nptr,"Array dimensionally incompatible name: ",3);
1858 *val = FRC_fail;
1859 return NULL;
1860 }
1861 /* modify parametric as needed */
1862 parametric = (ParametricOrigin(*origin) || parametric);
1863 } else {
1864 /* first case */
1865 rtype = type; /* this value may become less refined */
1866 rlen = *len; /* this value will persist to end if successful */
1867 rval = *val; /* this value will persist to end if successful */
1868 parametric = ParametricOrigin(*origin);
1869 }
1870 vl = NextVariableNode(vl);
1871 }
1872 /* go here, so list was compatible in some way. */
1873 if (parametric!=0) {
1874 *origin = origin_PARR;
1875 } else {
1876 *origin = origin_ARR;
1877 }
1878 return rtype;
1879 }
1880
1881 /*
1882 * This function takes the type given and its array status (in rval)
1883 * and marks all the names from the VariableList found in clist
1884 * as being of that type. Clist is a list of ChildListEntries.
1885 * Marking the type of the same child twice is fatal.
1886 * should only be called with vlists from aliases statements.
1887 */
1888 static
1889 void SetLHSTypes(CONST struct VariableList *vlist,struct gl_list_t *clist,
1890 CONST struct TypeDescription *rtype, enum e_findrhs rval,
1891 int subsopen, unsigned int origin)
1892 {
1893 struct ChildListEntry test;
1894 struct ChildListEntry *clep;
1895 CONST struct Name *nptr;
1896 symchar *name;
1897 unsigned long place;
1898
1899 (void) rval;
1900 while (vlist!=NULL) {
1901 nptr = NamePointer(vlist);
1902 name = NameIdPtr(nptr);
1903 assert(name!=NULL);
1904 test.strptr = name;
1905 place = gl_search(clist,&test,(CmpFunc)CmpChildListEntries);
1906 assert(place!=0);
1907 clep = (struct ChildListEntry *) gl_fetch(clist,place);
1908 assert(clep->typeptr==NULL);
1909 assert(subsopen >= 0);
1910 assert(origin!=origin_ERR);
1911 assert(clep->origin==origin_ALI || clep->origin==origin_ARR);
1912 assert(clep->isarray < 0);
1913 if (ParametricOrigin(origin)) {
1914 if (clep->origin == origin_ALI) {
1915 clep->origin = origin_PALI;
1916 } else {
1917 clep->origin = origin_PARR;
1918 }
1919 }
1920 clep->typeptr = rtype;
1921 clep->isarray = ABS(clep->isarray + 1) + subsopen;
1922 /* ^^^^^^^^^^ works because of how we init it in DoNameF */
1923 vlist = NextVariableNode(vlist);
1924 }
1925 }
1926
1927 /*
1928 * This function takes a completed list of child names with
1929 * type information from IS_A and relations and tries to
1930 * derive type information for names defined with aliases
1931 * and in other obscure ways in the list of stats.
1932 *
1933 * This function could be a bit cleverer, but we're not
1934 * going to optimize it until there is some justification.
1935 * Iterates over the list of alii until no more information
1936 * is derivable.
1937 * Before returning whines about unresolvable names, which
1938 * are probably local alias loops.
1939 * Returns the number of whines. required, normally 0.
1940 *
1941 * Needs to track IS_REFINED_TO ARE_THE_SAME and ARE_ALIKE
1942 * where possible, which basically means over complete sets.
1943 */
1944 static
1945 int DeriveChildTypes(struct StatementList *stats, struct gl_list_t *clist)
1946 {
1947 struct AliasList *head, *tmp;
1948 CONST struct TypeDescription *rtype; /* rhs name type */
1949 int changed, whines=0;
1950 enum e_findrhs rval;
1951 int subsopen;
1952 unsigned int origin;
1953
1954 head = CreateAliasesList(stats);
1955 changed = 1;
1956 while (changed) {
1957 tmp = head;
1958 changed = 0;
1959 while (tmp!=NULL) {
1960 switch(tmp->bits) {
1961 case AL_WAIT:
1962 rtype = FindRHSType(AliasStatName(tmp->stat),clist,
1963 &rval,&subsopen,&origin);
1964 if (rtype != NULL) {
1965 changed = 1;
1966 SetLHSTypes(GetStatVarList(tmp->stat),clist,rtype,
1967 rval,subsopen,origin);
1968 tmp->bits = AL_DONE;
1969 } else {
1970 switch (rval) {
1971 case FRC_badname: /* definitely garbage rhs */
1972 tmp->bits = AL_NORHS;
1973 MarkStatContext(tmp->stat,context_WRONG);
1974 STATEMENT_ERROR(tmp->stat,"Impossible RHS of ALIASES");
1975 WSS(ASCERR,tmp->stat);
1976 whines++;
1977 break;
1978 case FRC_attrname: /* ATOM child rhs */
1979 tmp->bits = AL_DONE;
1980 MarkStatContext(tmp->stat,context_WRONG);
1981 STATEMENT_ERROR(tmp->stat,"Illegal subatomic RHS of ALIASES");
1982 WSS(ASCERR,tmp->stat);
1983 whines++;
1984 break;
1985 case FRC_fail: /* permanently ambiguous rhs name of part */
1986 WSEM(ASCWAR,tmp->stat,"Unable to determine child basetype");
1987 whines++;
1988 /* shouldn't happen, but symptom of certain screwups */
1989 changed = 1;
1990 tmp->bits = AL_DONE;
1991 break;
1992 case FRC_unable: /* try later */
1993 break;
1994 default:
1995 ASC_PANIC("NOT REACHED should never see other values");
1996 break;
1997 }
1998 }
1999 break;
2000 case AL_WARR:
2001 rtype = FindCommonType(GetStatVarList(tmp->stat),clist,
2002 &rval,&subsopen,&origin);
2003 if (rtype != NULL) {
2004 changed = 1;
2005 SetLHSTypes(ArrayStatAvlNames(tmp->stat),clist,rtype,
2006 rval,subsopen,origin);
2007 tmp->bits = AL_DONE;
2008 } else {
2009 switch (rval) {
2010 case FRC_badname: /* definitely garbage rhs (masked) */
2011 case FRC_attrname: /* ATOM child rhs (masked) */
2012 case FRC_fail: /* permanently confused ALIASES-IS_A */
2013 MarkStatContext(tmp->stat,context_WRONG);
2014 WSEM(ASCWAR,tmp->stat,
2015 "Unable to determine common ancestor type for array elements");
2016 WSS(ASCERR,tmp->stat);
2017 whines++;
2018 /* shouldn't happen, but symptom of certain screwups */
2019 /* such as the user trying to put incompatible stuff in an array */
2020 changed = 1;
2021 tmp->bits = AL_DONE;
2022 break;
2023 case FRC_unable: /* try later */
2024 break;
2025 default:
2026 ASC_PANIC("NOT REACHED should never see other values");
2027 break;
2028 }
2029 }
2030 break;
2031 case AL_DONE:
2032 case AL_NORHS:
2033 break;
2034 }
2035 tmp = tmp->next;
2036 }
2037 }
2038 tmp = head;
2039 while (tmp!=NULL) {
2040 switch (tmp->bits) {
2041 case AL_WAIT:
2042 case AL_WARR:
2043 WSSM(ASCERR,tmp->stat,"Probably involved in recursive ALIASES",3);
2044 whines++;
2045 break;
2046 default:
2047 break;
2048 }
2049 tmp = tmp->next;
2050 }
2051 DestroyAliasesList(head);
2052 return whines;
2053 }
2054
2055 /*****************************************************************\
2056 End of functions to help determine the types of children
2057 necessitated by aliases.
2058 \*****************************************************************/
2059
2060 /*****************************************************************\
2061 begin stuff to help refine the types of children
2062 using ARE_ALIKE ARE_THE_SAME IS_REFINED_TO info.
2063 \*****************************************************************/
2064
2065 /*
2066 * Little function to get the loops surrounding a sparse IS_A, srch.
2067 * Expensive task.
2068 * Recursive. Returns 1 if srch is found in sl or its descendants, 0 if not.
2069 * List returned to topmost caller will be a list of the for loops surround-
2070 * ing srch in reverse (INSIDE-OUT) order.
2071 * srch, sl and loops must all be nonnull on entry.
2072 * In the recursion, nothing gets appended to loops until the
2073 * srch statement is found.
2074 */
2075 static
2076 int GetISALoops(CONST struct Statement *srch,
2077 CONST struct StatementList *sl,
2078 struct gl_list_t *loops)
2079 {
2080 struct Statement *s;
2081 unsigned long c, len;
2082 int ret;
2083 assert(srch!=NULL && sl!=NULL && loops != NULL && StatementType(srch)==ISA);
2084
2085 len = StatementListLength(sl);
2086 for (c=1;c <= len;c++) {
2087 s = GetStatement(sl,c);
2088 if (s!=NULL) {
2089 if (StatementType(s)==FOR && ForContainsIsa(s)) {
2090 ret = GetISALoops(srch,ForStatStmts(s),loops);
2091 if (ret == 1) {
2092 gl_append_ptr(loops,(VOIDPTR)s);
2093 return 1;
2094 }
2095 }
2096 if (s == srch) return 1;
2097 }
2098 }
2099 return 0;
2100 }
2101
2102 /* a little alternative forvar that carries the loop definition. */
2103 struct forinfo_t {
2104 symchar *strname;
2105 struct Expr *ex;
2106 };
2107
2108 /* delete anything sitting in forinfo and return */
2109 static
2110 void ClearForInfo(struct gl_list_t *fl)
2111 {
2112 unsigned long c, len;
2113 if (fl!=NULL) {
2114 len = gl_length(fl);
2115 for (c=len;c>=1;c--) {
2116 gl_delete(fl,c,1);
2117 }
2118 }
2119 }
2120 /* compares forinfo by strnames. NULL > all */
2121 static
2122 int CmpForInfo(struct forinfo_t *f1, struct forinfo_t *f2)
2123 {
2124 if (f1==NULL) return 1;
2125 if (f2==NULL) return -1;
2126 if (f1->strname==NULL) return 1;
2127 if (f2->strname==NULL) return -1;
2128 if (f1->strname==f2->strname) return 0;
2129 return CmpSymchar(f1->strname,f2->strname);
2130 }
2131 static
2132 struct forinfo_t *FindForInfo(struct gl_list_t *forinfo, symchar *name)
2133 {
2134 struct forinfo_t test;
2135 unsigned long pos;
2136 if (name==NULL || forinfo == NULL) {
2137 return NULL;
2138 }
2139 test.strname = name;
2140 pos = gl_search(forinfo,&test,(CmpFunc)CmpForInfo);
2141 if (pos==0L) {
2142 return NULL;
2143 }
2144 return gl_fetch(forinfo,pos);
2145 }
2146 /* add name and ex to info list */
2147 static
2148 void AddForInfo( struct gl_list_t *forinfo,
2149 symchar *name,
2150 struct Expr *ex)
2151 {
2152 struct forinfo_t *i=NULL;
2153 assert(name!=NULL);
2154 assert(ex!=NULL);
2155 i = (struct forinfo_t *)ascmalloc(sizeof(struct forinfo_t));
2156 assert(i!=NULL);
2157 i->strname = name;
2158 i->ex = ex;
2159 gl_append_ptr(forinfo,(VOIDPTR)i);
2160 }
2161 /* delete named entry from list, after finding it */
2162 static
2163 void RemoveForInfo( struct gl_list_t *forinfo, symchar *name)
2164 {
2165 struct forinfo_t test;
2166 unsigned long pos;
2167 test.strname = name;
2168 pos = gl_search(forinfo,&test,(CmpFunc)CmpForInfo);
2169 if (pos==0L) {
2170 FPRINTF(ASCERR,"Nonexistent forinfo %s removed\n",SCP(name));
2171 return;
2172 }
2173 gl_delete(forinfo,pos,1);
2174 }
2175 /*
2176 * takes a local array name n and tries to match the subscripts named
2177 * in it against the declaration of the array via IS_A.
2178 * clep given should correspond to n given.
2179 * Stuff that is aliased will most likely return FALSE negative results.
2180 * Returns 1 if all the elements of the array declared are named in
2181 * the name given. In the case of names containing for loop indices,
2182 * the range of the for is checked in forinfo to see if that matches
2183 * the IS_A.
2184 * Returns 0 if mismatch or too hard to tell.
2185 * Basically, sets must compare exactly in their unevaluated form
2186 * for this work. Some of the twisty sparse array addressings allowed
2187 * in the language may be indecipherable and yield a FALSE negative.
2188 */
2189 static
2190 int AllElementsNamed(struct ChildListEntry *clep,
2191 CONST struct Name *n,
2192 struct gl_list_t *clist,
2193 struct gl_list_t *forinfo,
2194 struct StatementList *pstats)
2195 {
2196 CONST struct Name *decln=NULL; /* name IS_A'd/WILL_BE'd under */
2197 CONST struct VariableList *vl;
2198 struct Set *fset;
2199 struct Set *fsetorig;
2200 CONST struct Expr *sex;
2201 struct forinfo_t *fi;
2202 struct forinfo_t *origfi;
2203 struct gl_list_t *looplist;
2204 struct gl_list_t *loopinfo;
2205 struct Statement *s;
2206 unsigned long c,len;
2207 int killfset=0;
2208 int killfsetorig=0;
2209 int setcomp;
2210
2211 if (clep == NULL || clep->statement == NULL ||
2212 n==NULL || clist == NULL || forinfo == NULL ||
2213 StatementType(clep->statement) == ALIASES /* alii too hard */ ) {
2214 return 0;
2215 }
2216 /* hunt out the name declared in original IS_A */
2217 vl = GetStatVarList(clep->statement);
2218 while (vl != NULL) {
2219 /* name elements are out of symbol table, so compare by ptr to syms. */
2220 if (NameIdPtr(NamePointer(vl)) == NameIdPtr(n)) {
2221 decln = NamePointer(vl);
2222 break;
2223 }
2224 vl = NextVariableNode(vl);
2225 }
2226 if (decln == NULL || NameLength(decln)!=NameLength(n)) {
2227 /* damned odd! */
2228 return 0;
2229 }
2230 /* ok, so decln is the name we want to match and n is the
2231 * name used in the refinement statement.
2232 * To match sparse IS_REFINED_TO to sparse IS_A properly is
2233 * a second, fairly major case.
2234 */
2235 /* eat array heads */
2236 decln = NextName(decln);
2237 n = NextName(n);
2238 if (StatInFOR(clep->statement) == 0 ) {
2239 /*
2240 * This only works for dense IS_A's.
2241 */
2242 /* do for each subscript */
2243 while (n != NULL) {
2244 /* compare either the for loop expression or the name set of n
2245 * to the set defined in dense decln.
2246 */
2247 if (SetType(NameSetPtr(n))==0 &&
2248 (sex = GetSingleExpr(NameSetPtr(n))) != NULL &&
2249 ExprListLength(sex) == 1 &&
2250 ExprType(sex) == e_var &&
2251 (fi = FindForInfo(forinfo,SimpleNameIdPtr(ExprName(sex)))) != NULL
2252 ) {
2253 /* must be a for index */
2254 if (ExprListLength(fi->ex)!=1 || ExprType(fi->ex) != e_set) {
2255 fset = CreateSingleSet(fi->ex);
2256 killfset = 1;
2257 } else {
2258 fset = ExprSValue(fi->ex);
2259 }
2260 setcomp = CompareSetStructures(fset,NameSetPtr(decln));
2261 if (killfset) {
2262 DestroySetHead(fset);
2263 }
2264 if (setcomp != 0) {
2265 return 0;
2266 }
2267 } else {
2268 if (CompareSetStructures(NameSetPtr(n),NameSetPtr(decln))!=0) {
2269 return 0;
2270 }
2271 }
2272 decln = NextName(decln);
2273 n = NextName(n);
2274 }
2275 } else {
2276 /* sparse IS_A/sparse IS_REFINED_TO */
2277 looplist = gl_create(2L);
2278 if (looplist == NULL) {
2279 return 0;
2280 }
2281 (void)GetISALoops(clep->statement,pstats,looplist);
2282 if (gl_length(looplist)==0L) {
2283 gl_destroy(looplist);
2284 return 0;
2285 } else {
2286 /* convert looplist to forvar info */
2287 loopinfo = gl_create(gl_length(looplist));
2288 if (loopinfo == NULL) {
2289 gl_destroy(looplist);
2290 return 0;
2291 }
2292 len = gl_length(looplist);
2293 for (c=1;c <= len; c++) {
2294 s = (struct Statement *)gl_fetch(looplist,c);
2295 AddForInfo(loopinfo,ForStatIndex(s),ForStatExpr(s));
2296 }
2297 gl_destroy(looplist);
2298 looplist = NULL;
2299 }
2300 /* things to clean up past this point: loopinfo */
2301 /* foreach subscript:
2302 * find index from n in forinfo passed in and get its defining expr.
2303 * find index from decln in looplist and get its defining expr.
2304 * if sets !=, return 0, else cleanup and return 1.
2305 */
2306 while (n != NULL) {
2307 /* compare either the for loop expressions
2308 * to the sets defined in sparse decln.
2309 */
2310 /* must be a simple for index in IS_REFINED_TO/etc. get set
2311 * definitions corresponding to indices.
2312 */
2313 if (SetType(NameSetPtr(n))==0 &&
2314 (sex = GetSingleExpr(NameSetPtr(n))) != NULL &&
2315 ExprListLength(sex) == 1 &&
2316 ExprType(sex) == e_var &&
2317 (fi = FindForInfo(forinfo,SimpleNameIdPtr(ExprName(sex)))) != NULL &&
2318 /* found this statement's set expression */
2319 SetType(NameSetPtr(decln))==0 &&
2320 (sex = GetSingleExpr(NameSetPtr(decln))) != NULL &&
2321 ExprListLength(sex) == 1 &&
2322 ExprType(sex) == e_var &&
2323 (origfi = FindForInfo(loopinfo,SimpleNameIdPtr(ExprName(sex))))!=NULL
2324 /* found original statement's set expression */
2325 ) { /* end of if conditions */
2326 if (ExprListLength(fi->ex)!=1 || ExprType(fi->ex) != e_set) {
2327 fset = CreateSingleSet(fi->ex);
2328 killfset = 1;
2329 } else {
2330 fset = ExprSValue(fi->ex);
2331 }
2332 if (ExprListLength(origfi->ex)!=1 || ExprType(origfi->ex) != e_set) {
2333 fsetorig = CreateSingleSet(origfi->ex);
2334 killfsetorig = 1;
2335 } else {
2336 fsetorig = ExprSValue(origfi->ex);
2337 }
2338 setcomp = CompareSetStructures(fset,fsetorig);
2339 if (killfset) {
2340 DestroySetHead(fset);
2341 }
2342 if (killfsetorig) {
2343 DestroySetHead(fsetorig);
2344 }
2345 if (setcomp != 0) {
2346 ClearForInfo(loopinfo);
2347 gl_destroy(loopinfo);
2348 return 0;
2349 }
2350 } else {
2351 /* clean up. we gave up due to some complexity */
2352 ClearForInfo(loopinfo);
2353 gl_destroy(loopinfo);
2354 return 0;
2355 }
2356 decln = NextName(decln);
2357 n = NextName(n);
2358 }
2359 ClearForInfo(loopinfo);
2360 gl_destroy(loopinfo);
2361 }
2362 return 1;
2363 }
2364
2365 /*
2366 * not that forinfo is NOT a forvar table; it should be a supplied,
2367 * empty gllist from the initial caller.
2368 * it will be returned empty and of no consequence to the initial
2369 * caller.
2370 * It should handle ARE_ALIKE/ARE_THE_SAME but so far only IS_REFINED_TO.
2371 * Recursive function.
2372 * When ascend code is well written, the current implementation
2373 * is sufficient to shut up all undefined name whines. code that
2374 * still whines is POORLY modeled.
2375 */
2376 static int g_drt_depth=0; /* depth in this function, for bookkeeping. */
2377 static
2378 enum typelinterr DeriveRefinedTypes(struct StatementList *stats,
2379 struct gl_list_t *clist,
2380 struct gl_list_t *forinfo,
2381 struct StatementList *pstats
2382 )
2383 {
2384 struct Statement *s;
2385 /* rhs type of IS_REFINED_TO statement */
2386 symchar *rname;
2387 CONST struct TypeDescription *rdesc;
2388 /* lhs member type from IS_REFINED_TO statement */
2389 CONST struct TypeDescription *d;
2390 CONST struct VariableList *vl;
2391 CONST struct Name *n;
2392 unsigned long c,len,pos;
2393 unsigned int origin;
2394 int subsopen;
2395 enum e_findrhs rval;
2396 enum typelinterr error_code;
2397 struct ChildListEntry test;
2398 struct ChildListEntry *clep;
2399
2400 assert(clist !=NULL);
2401 assert(forinfo !=NULL);
2402
2403 len = StatementListLength(stats);
2404 for (c = 1; c <= len; c++) {
2405 s = GetStatement(stats,c);
2406 switch (StatementType(s)) {
2407 case IRT:
2408 if (StatInSELECT(s)) { /* Ignore refinements inside SELECT */
2409 break;
2410 }
2411 rname = GetStatType(s); /* sets do not get refined, so don't check */
2412 rdesc = FindType(rname);
2413 assert(rdesc!=NULL);
2414 vl = GetStatVarList(s);
2415 while (vl!=NULL) {
2416 n = NamePointer(vl);
2417 if (NameCompound(n)==0) { /* only care if local, nonsubatomic */
2418 d = FindRHSType(n,clist,&rval,&subsopen,&origin);
2419 if (d==NULL ||
2420 MoreRefined(d,rdesc)==NULL ||
2421 subsopen > 0) {
2422 if (d!=NULL && subsopen>0) {
2423 FPRINTF(ASCERR,
2424 "%sRefinement can only be done on array elements.\n",
2425 StatioLabel(3));
2426 }
2427 ERROR_REPORTER_START_NOLINE(ASC_USER_ERROR);
2428 FPRINTF(ASCERR,"Incompatible type (%s) of LHS name: ",
2429 (d!=NULL)?SCP(GetName(d)):"UNDEFINED");
2430 WriteName(ASCERR,n);
2431 FPRINTF(ASCERR,"\n");
2432 error_code = DEF_ILLEGAL_REFINE;
2433 TypeLintError(ASCERR,s, error_code);
2434 error_reporter_end_flush();
2435
2436 if (!g_drt_depth) {
2437 ClearForInfo(forinfo);
2438 }
2439 return error_code;
2440 }
2441 /* so we know d compatible. The question is can we
2442 * upgrade the CLE of local n or not?
2443 * yes if scalar or if all elements of array are
2444 * upgraded together.
2445 */
2446 if (d!=rdesc) {
2447 test.strptr = NameIdPtr(n);
2448 pos = gl_search(clist,&test,(CmpFunc)CmpChildListEntries);
2449 assert(pos!=0L);
2450 clep = (struct ChildListEntry *)gl_fetch(clist,pos);
2451 if (SimpleNameIdPtr(n) != NULL ||
2452 AllElementsNamed(clep,n,clist,forinfo,pstats)==1) {
2453 clep->typeptr = MoreRefined(d,rdesc);
2454 }
2455 }
2456 }
2457 vl = NextVariableNode(vl);
2458 }
2459 break;
2460 case FOR:
2461 g_drt_depth++;
2462 AddForInfo(forinfo,ForStatIndex(s),ForStatExpr(s));
2463 error_code = DeriveRefinedTypes(ForStatStmts(s),clist,forinfo,pstats);
2464 RemoveForInfo(forinfo,ForStatIndex(s));
2465 g_drt_depth--;
2466 if (error_code != DEF_OKAY) {
2467 if (!g_drt_depth) {
2468 ClearForInfo(forinfo);
2469 }
2470 return error_code;
2471 }
2472 break;
2473 case AA:
2474 /* if we were clever, do something here using LCLE info */
2475 break;
2476 case ATS:
2477 /* if we were clever, do something here using LCLE info */
2478 break;
2479 case SELECT:
2480 case COND:
2481 /* if we were clever, do something here using LCLE info maybe */
2482 break;
2483 default:
2484 break;
2485 }
2486 }
2487
2488 if (!g_drt_depth) {
2489 ClearForInfo(forinfo);
2490 }
2491 return DEF_OKAY;
2492 }
2493 /*****************************************************************\
2494 End of functions to help refine the types of children
2495 necessitated by ARE_ALIKE IS_REFINED_TO ARE_THE_SAME.
2496 \*****************************************************************/
2497
2498 /*** stuff for defining parameterized models and models in general ***/
2499
2500 /* if any name in the set given is not defined in lcl,
2501 * returns 0, OTHERWISE 1.
2502 * Checks base type of name, which must symbol/integer/set constants
2503 */
2504 static
2505 int SetNamesInLCL(CONST struct Set *sn)
2506 {
2507 struct gl_list_t *nl;
2508 struct gl_list_t *lclgl;
2509 CONST struct TypeDescription *rtype;
2510 CONST struct Name *n;
2511 enum e_findrhs rval;
2512 unsigned long c,len;
2513 int subsopen; /* must never come back anything but zero */
2514 unsigned int origin; /* ignored */
2515
2516 assert(sn!=NULL);
2517
2518 nl = SetNameList(sn);
2519 lclgl = CopyLCLToGL(); /* we want a peek at the lcl in progress */
2520 len = gl_length(nl);
2521 for (c = 1; c <= len; c++) {
2522 n = (CONST struct Name *)gl_fetch(nl,c);
2523 /* check forvars here first in future. tempvars would be tricky,
2524 * except SetNameList doesn't return tempvars because
2525 * EvaluateNamesNeeded doesn't report those (we hope).
2526 */
2527 /* not in forvars, so check declarations */
2528 rtype = FindRHSType(n,lclgl,&rval,&subsopen,&origin);
2529 if (rtype==NULL || rval != FRC_ok /* can't compute on arrays */||
2530 (GetBaseType(rtype) != integer_constant_type &&
2531 GetBaseType(rtype) != symbol_constant_type &&
2532 GetBaseType(rtype) != set_type)
2533 ) {
2534 gl_destroy(lclgl);
2535 gl_destroy(nl);
2536 return 0;
2537 }
2538 }
2539 gl_destroy(lclgl);
2540 gl_destroy(nl);
2541 return 1;
2542 }
2543
2544 /*
2545 * checks that lhs of := (declarative) are variables.
2546 * checks that lhs of :== are constants and not of parametric origin.
2547 * checks that rhs of :== are constants.
2548 * checks that come up totally missing are morphed to defokay because
2549 * of the chance that refinement is biting us.
2550 */
2551 static
2552 enum typelinterr VerifyDefsAsgns(symchar *name,
2553 CONST struct StatementList *stats,
2554 struct gl_list_t *lclgl,
2555 struct gl_list_t *ft)
2556 {
2557 register struct gl_list_t *statements;
2558 register unsigned long c,len;
2559 register unsigned long nc,nlen;
2560 CONST struct TypeDescription *rtype;
2561 struct Statement *stat;
2562 CONST struct Name *nptr;
2563 struct gl_list_t *nl=NULL;
2564 enum e_findrhs rval;
2565 int subsopen;
2566 unsigned int origin;
2567 enum typelinterr error_code=DEF_OKAY;
2568
2569 statements = GetList(stats);
2570 len = gl_length(statements);
2571 for (c = 1; c <= len; c++) {
2572 stat = (struct Statement *)gl_fetch(statements,c);
2573 switch(StatementType(stat)){
2574 case ASGN:
2575 nptr = DefaultStatVar(stat);
2576 rtype = FindRHSType(nptr,lclgl,&rval,&subsopen,&origin);
2577 if ( rtype == NULL ) {
2578 if (rval != FRC_attrname) {
2579 char *iostring;
2580 error_code = DEF_ASGN_INCORRECT;
2581 iostring = (char *)ascmalloc(6+SCLEN(name));
2582 sprintf(iostring,"In %s:\n",SCP(name));
2583 TypeLintErrorAuxillary(ASCERR,iostring,DEF_MISC_WARNING,TRUE);
2584 ascfree(iostring);
2585 TypeLintError(ASCERR,stat, error_code);
2586 error_code = DEF_OKAY;
2587 } /* else assignment to subatomic part. style bitch. */
2588 break;
2589 }
2590 if (rval != FRC_ok /* must be scalar */ ||
2591 BaseTypeIsAtomic(rtype) == 0 /* must be variable */ ||
2592 BaseTypeIsSet(rtype) != 0
2593 ) {
2594 error_code = DEF_ASGN_INCORRECT;
2595 TypeLintError(ASCERR,stat, error_code);
2596 return error_code;
2597 }
2598 /* check rhs expr */
2599 nl = EvaluateNamesNeeded(DefaultStatRHS(stat),NULL,nl);
2600 nlen = gl_length(nl);
2601 for (nc=1;nc<=nlen;nc++) {
2602 nptr = (struct Name *)gl_fetch(nl,nc);
2603 if (NameInForTable(ft,nptr)) {
2604 continue;
2605 }
2606 rtype = FindRHSType(nptr,lclgl,&rval,&subsopen,&origin);
2607 if (rtype==NULL) {
2608 if (rval != FRC_attrname) {
2609 char *iostring;
2610 TLNM(ASCERR,nptr,"Unverifiable name in RHS: ",2);
2611 error_code = DEF_NAME_MISSING;
2612 iostring = (char *)ascmalloc(6+SCLEN(name));
2613 sprintf(iostring,"In %s:\n",SCP(name));
2614 TypeLintErrorAuxillary(ASCERR,iostring,DEF_MISC_WARNING,TRUE);
2615 TypeLintError(ASCERR,stat, error_code);
2616 ascfree(iostring);
2617 error_code = DEF_OKAY;
2618 /* here it would be nice if we could punt, but refinement
2619 * rules that out since the name might be valid and we not know.
2620 */
2621 }
2622 continue;
2623 }
2624 if ( rval != FRC_ok /* arrays not evaluatable */ ||
2625 (BaseTypeIsAtomic(rtype) == 0 && BaseTypeIsConstant(rtype)==0)
2626 ) {
2627 TLNM(ASCERR,nptr,"Improper non-scalar in RHS: ",3);
2628 gl_destroy(nl);
2629 error_code = DEF_ILLEGAL_ASGN;
2630 TypeLintError(ASCERR,stat, error_code);
2631 return error_code;
2632 }
2633 }
2634 gl_destroy(nl);
2635 nl = NULL;
2636 break;
2637 case CASGN:
2638 nptr = AssignStatVar(stat);
2639 rtype = FindRHSType(nptr,lclgl,&rval,&subsopen,&origin);
2640 if (rtype == NULL) {
2641 char *iostring;
2642 error_code = DEF_CASGN_INCORRECT;
2643 iostring = (char *)ascmalloc(6+SCLEN(name));
2644 sprintf(iostring,"In %s:\n",SCP(name));
2645 TypeLintErrorAuxillary(ASCERR,iostring,DEF_MISC_WARNING,TRUE);
2646 TypeLintError(ASCERR,stat, error_code);
2647 ascfree(iostring);
2648 error_code = DEF_OKAY;
2649 origin = origin_ISA;
2650 /* this will never be reached for a parameter list object. this safe */
2651 } else {
2652 if (rval != FRC_ok /* must be scalar */ ||
2653 (BaseTypeIsConstant(rtype) ==0 && BaseTypeIsSet(rtype)==0)
2654 ) {
2655 error_code = DEF_CASGN_INCORRECT;
2656 TypeLintError(ASCERR,stat, error_code);
2657 return error_code;
2658 }
2659 }
2660 if (ParametricOrigin(origin)) {
2661 error_code = DEF_PARAM_MODIFIED;
2662 TLNNE(ASCERR,nptr,"Parameter modified ");
2663 TypeLintError(ASCERR,stat, error_code);
2664 return error_code;
2665 }
2666 nl = EvaluateNamesNeeded(AssignStatRHS(stat),NULL,nl);
2667 nlen = gl_length(nl);
2668 for (nc=1;nc<=nlen;nc++) {
2669 nptr = (struct Name *)gl_fetch(nl,nc);
2670 if (NameInForTable(ft,nptr)) {
2671 continue;
2672 }
2673 rtype = FindRHSType(nptr,lclgl,&rval,&subsopen,&origin);
2674 if (rtype==NULL) {
2675 char *iostring;
2676 TLNM(ASCERR,nptr,"Unverifiable name in :== RHS: ",2);
2677 error_code = DEF_NAME_MISSING;
2678 iostring = (char *)ascmalloc(6+SCLEN(name));
2679 sprintf(iostring,"In %s:\n",SCP(name));
2680 TypeLintErrorAuxillary(ASCERR,iostring,DEF_MISC_WARNING,TRUE);
2681 ascfree(iostring);
2682 TypeLintError(ASCERR,stat, error_code);
2683 error_code = DEF_OKAY;
2684 /* here it would be nice if we could punt, but refinement
2685 * rules that out since the name might be valid and we not know.
2686 */
2687 } else {
2688 if ( rval != FRC_ok /* arrays not evaluatable */ ||
2689 (BaseTypeIsSet(rtype) == 0 && BaseTypeIsConstant(rtype)==0)
2690 ) {
2691 TLNM(ASCERR,nptr,"Improper non-constant in RHS: ",3);
2692 gl_destroy(nl);
2693 error_code = DEF_ILLEGAL_CASGN;
2694 TypeLintError(ASCERR,stat, error_code);
2695 return error_code;
2696 }
2697 }
2698 }
2699 gl_destroy(nl);
2700 nl = NULL;
2701 break;
2702 case FOR:
2703 AddLoopVariable(ft,CreateForVar(ForStatIndex(stat)));
2704 error_code = VerifyDefsAsgns(name,ForStatStmts(stat),lclgl,ft);
2705 RemoveForVariable(ft);
2706 if (error_code != DEF_OKAY){
2707 return error_code;
2708 }
2709 break;
2710 case COND:
2711 error_code = VerifyDefsAsgns(name,CondStatList(stat),lclgl,ft);
2712 if (error_code != DEF_OKAY){
2713 return error_code;
2714 }
2715 break;
2716 case SELECT:
2717 /* statements inside SELECT are analyzed as part of the flat
2718 list of statements */
2719 break;
2720 default: /* LREL REL, ASGN, RUN, IF, EXT, REF ISA WHEN too. */
2721 break;
2722 }
2723 }
2724 return DEF_OKAY;
2725 }
2726
2727 /*
2728 * Insures that all IS_REFINED_TO/ARE_ALIKE/ARE_THE_SAME do
2729 * not change anything passed in. Fascistically.
2730 * Complains about errors found, so caller needn't.
2731 * Also ought to in general check that all lhs/varlist entries exist,
2732 * but doesn't -- only checks shallowly.
2733 *
2734 * Should as a side effect upgrade base types of children where
2735 * this is determinable (ie in the case of arrays, must be over all children).
2736 *
2737 * Also checks that ATS statements do not merge illegal types.
2738 */
2739 static
2740 enum typelinterr VerifyRefinementLegal(CONST struct StatementList *stats,
2741 struct gl_list_t *lclgl)
2742 {
2743 register unsigned long c,len,pos;
2744 register struct gl_list_t *statements;
2745 CONST struct VariableList *vl;
2746 struct Statement *stat;
2747 CONST struct Name *nptr;
2748 struct ChildListEntry *clep;
2749 CONST struct TypeDescription *aatype, *atstype;
2750 enum typelinterr error_code=DEF_OKAY;
2751 enum e_findrhs rval;
2752 unsigned int origin;
2753 int subsopen;
2754 struct ChildListEntry test;
2755
2756 statements = GetList(stats);
2757 len = gl_length(statements);
2758 for (c = 1; c <= len; c++) {
2759 stat = (struct Statement *)gl_fetch(statements,c);
2760 switch(StatementType(stat)){
2761 case ATS:
2762 case AA:
2763 case IRT:
2764 vl = GetStatVarList(stat);
2765 while (vl != NULL) {
2766 /* shallow check that parameters are not being modified */
2767 nptr = NamePointer(vl);
2768 test.strptr = NameIdPtr(nptr);
2769 /* find local root of name */
2770 pos = gl_search(lclgl,&test,(CmpFunc)CmpChildListEntries);
2771 /* the preceding gl_search relies on the fact that the comparison
2772 * element in the ChildListEntry is the symchar.
2773 * It will break if things are different.
2774 */
2775 if (pos != 0) {
2776 clep = (struct ChildListEntry *)gl_fetch(lclgl,pos);
2777 if (ParametricOrigin(clep->origin)) {
2778 error_code = DEF_PARAM_MODIFIED;
2779 TLNNE(ASCERR,nptr,"Parameter modified");
2780 TypeLintError(ASCERR,stat, error_code);
2781 return error_code;
2782 }
2783 if (StatementType(stat)==ATS) {
2784 /* here we find explicit relation merges
2785 * and disallow them since we do insist that
2786 * relations have 1 parent. Merging rels when merging models
2787 * is obviously allowed.
2788 * We also trap merging arrays of relations since
2789 * arrays are supposed to be only a naming convention
2790 * but allows multiple parents and messes up tree properties.
2791 */
2792 atstype = FindRHSType(nptr,lclgl,&rval,&subsopen,&origin);
2793 if (atstype == NULL) {
2794 TLNM(ASCERR,nptr,"Suspicious or bad name: ",2);
2795 if (TLINT_WARNING) {
2796 WriteStatementErrorMessage(ASCERR,stat,
2797 "Unknown or unmergable part",0,2);
2798 }
2799 /* do not OTHERWISE return error because part may actually exist
2800 * once some refinement we've missed occurs.
2801 */
2802 } else {
2803 /* Also disallow ARE_THE_SAME of relations/whens. */
2804 assert(GetBaseType(atstype)!=array_type);
2805 switch(GetBaseType(atstype)) {
2806 case relation_type:
2807 case logrel_type:
2808 case when_type: /* odd case indeed */
2809 TLNM(ASCERR,nptr,"Part with unmergable type: ",3);
2810 TypeLintError(ASCERR,stat,DEF_ILLEGAL_ATS);
2811 return DEF_ILLEGAL_ATS;
2812 default:
2813 break;
2814 }
2815 }
2816 }
2817 if (StatementType(stat)==AA) {
2818 /* here we find parametric arguments to AA
2819 * and disallow them since parametric ARE_ALIKE makes
2820 * no sense.
2821 * Also trap illegal ARE_ALIKE on fundamental types
2822 * and warn about them.
2823 * Maybe should check relations too.
2824 */
2825 aatype = FindRHSType(nptr,lclgl,&rval,&subsopen,&origin);
2826 if (aatype == NULL) {
2827 TLNM(ASCERR,nptr,"Suspicious or bad name: ",2);
2828 TypeLintError(ASCERR,stat, DEF_ILLEGAL_AA);
2829 if (rval == FRC_attrname) {
2830 return DEF_ILLEGAL_AA;
2831 }
2832 /* do not OTHERWISE return error because part may actually exist
2833 * once some refinement we've missed occurs.
2834 */
2835 } else {
2836 /* disallow parameterized models declared however deep */
2837 if (GetBaseType(aatype) == model_type &&
2838 StatementListLength(GetModelParameterList(aatype))!=0L) {
2839 TLNM(ASCERR,nptr,"Parameterized part: ",3);
2840 TypeLintError(ASCERR,stat, DEF_ILLPARAM_AA);
2841 return DEF_ILLPARAM_AA;
2842 }
2843 /* Also disallow ARE_ALIKE of arrays. */
2844 if (subsopen != 0) {
2845 TLNM(ASCERR,nptr,"Array elements:",3);
2846 TypeLintError(ASCERR,stat, DEF_ILLARRAY_AA);
2847 return DEF_ILLARRAY_AA;
2848 }
2849 /* Also disallow ARE_ALIKE of relations/whens. */
2850 switch(GetBaseType(aatype)) {
2851 case relation_type:
2852 case logrel_type:
2853 case when_type: /* odd case indeed */
2854 TLNM(ASCERR,nptr,"Part with illegal type: ",3);
2855 TypeLintError(ASCERR,stat,DEF_ILLEGAL_AA);
2856 return DEF_ILLEGAL_AA;
2857 default:
2858 break;
2859 }
2860 /* Disallow refinements by ARE_ALIKE of down-in parts
2861 * that got down-in by being passed there.
2862 */
2863 nptr = NextIdName(nptr);
2864 /* Found the next . in the name. Parts declared
2865 * at this scope that are not parametric we can
2866 * ARE_ALIKE if we so chose since anarchy is required.
2867 * pos is the local child root of the name and
2868 * we don't want to check it again, but we need
2869 * its type to verify things.
2870 */
2871 if (nptr != NULL) {
2872 rval = AANameIdHasParameterizedPart(&nptr,clep->typeptr);
2873 switch (rval) {
2874 case FRC_attrname:
2875 TLNM(ASCERR, NamePointer(vl),
2876 "Incorrect subatomic name in ",3);
2877 if (nptr!=NULL) {
2878 TypeLintNameNode(ASCERR , nptr ,"starting at ");
2879 }
2880 TypeLintError(ASCERR,stat,DEF_ILLEGAL_AA);
2881 return DEF_ILLEGAL_AA;
2882 case FRC_array:
2883 TLNM(ASCERR, NamePointer(vl),
2884 "Incorrect array name in ",3);
2885 if (nptr!=NULL) {
2886 TypeLintNameNode(ASCERR , nptr ,"starting at ");
2887 }
2888 TypeLintError(ASCERR,stat,DEF_ILLARRAY_AA);
2889 return DEF_ILLARRAY_AA;
2890 case FRC_badname:
2891 if (nptr!=NULL) {
2892 TLNNE(ASCERR, nptr,"Impossible part");
2893 TypeLintName(ASCERR, NamePointer(vl),
2894 "means you can't ARE_ALIKE ");
2895 TypeLintError(ASCERR,stat,DEF_ILLEGAL_AA);
2896 return DEF_ILLEGAL_AA;
2897 } else {
2898 TLNM(ASCERR , NamePointer(vl) ,"Bad name ",3);
2899 TypeLintError(ASCERR,stat,DEF_ILLEGAL_AA);
2900 return DEF_ILLEGAL_AA;
2901 }
2902 case FRC_fail:
2903 if (nptr!=NULL) {
2904 TLNNE(ASCERR, nptr, "Parametric part");
2905 TypeLintName(ASCERR, NamePointer(vl),
2906 "means you can't ARE_ALIKE ");
2907 TypeLintError(ASCERR,stat,DEF_ILLPARAM_AA);
2908 return DEF_ILLPARAM_AA;
2909 } else {
2910 TLNM(ASCERR , NamePointer(vl) ,"Bad name ",3);
2911 TypeLintError(ASCERR,stat,DEF_ILLPARAM_AA);
2912 return DEF_ILLPARAM_AA;
2913 }
2914 case FRC_ok:
2915 break;
2916 default:
2917 TLNM(ASCERR,NamePointer(vl),"AA Trouble digesting: ",3);
2918 return DEF_ILLEGAL_AA;
2919 }
2920 }
2921 }
2922 }
2923 } else {
2924 error_code = DEF_NAME_MISSING;
2925 TLNNE(ASCERR,nptr,"Undefined name");
2926 TypeLintError(ASCERR,stat, error_code);
2927 return error_code;
2928 }
2929 vl = NextVariableNode(vl);
2930 }
2931 break;
2932 case FOR:
2933 if (ForContainsAlike(stat) ||
2934 ForContainsAts(stat) ||
2935 ForContainsIrt(stat) ) {
2936 error_code = VerifyRefinementLegal(ForStatStmts(stat),lclgl);
2937 if (error_code != DEF_OKAY){
2938 return error_code;
2939 }
2940 }
2941 break;
2942 case SELECT:
2943 /*
2944 * statements inside SELECT are analyzed as part of the flat
2945 * list of statements
2946 */
2947 break;
2948 case COND:
2949 break;
2950 default: /* LREL REL, ASGN, RUN, IF, EXT, REF ISA WHEN too. */
2951 break;
2952 }
2953 }
2954 return DEF_OKAY;
2955 }
2956
2957 /*
2958 * checks that all names used in an expression are traceable
2959 * to appropriate set/var/constant/array origins.
2960 * In particular, since FIndRHSType disallows FRC_attr,
2961 * this function won't let through ATOM children.
2962 */
2963 static
2964 enum typelinterr VerifyValueNames(CONST struct Expr *ex,
2965 struct gl_list_t *lclgl,
2966 struct gl_list_t *ft)
2967 {
2968 struct gl_list_t *nl=NULL;
2969 CONST struct TypeDescription *rtype;
2970 CONST struct Name *n;
2971 unsigned long c,len;
2972 enum e_findrhs rval;
2973 int errcnt=0;
2974 int subsopen=0; /* we don't care */
2975 unsigned int origin; /* ignored */
2976
2977 assert(ex!=NULL);
2978
2979 nl = EvaluateNamesNeeded(ex,NULL,nl);
2980 /* create, possibly empty, list of all variables including
2981 * variables in set expressions needed to interpret an expression.
2982 */
2983 assert(nl!=NULL);
2984 len = gl_length(nl);
2985 for (c = 1; c <= len; c++) {
2986 n = (CONST struct Name *)gl_fetch(nl,c);
2987 /* check forvars here first. tempvars would be tricky,
2988 * except EvaluateNamesNeeded doesn't report those (we hope).
2989 */
2990 if (NameInForTable(ft,n)) {
2991 continue; /* skip to next name */
2992 }
2993 /* not in forvars, so check declarations */
2994 rtype = FindRHSType(n,lclgl,&rval,&subsopen,&origin);
2995 if (rtype==NULL) {
2996 TLNM(ASCERR,n,"Undefined argument name ",3);
2997 errcnt++;
2998 } else {
2999 if ( (rval != FRC_ok && rval != FRC_array) ||
3000 (BaseTypeIsConstant(rtype) == 0 && BaseTypeIsSet(rtype) == 0)
3001 ) {
3002 TLNM(ASCERR,n,"Incorrect non-constant/non-set type: ",3);
3003 errcnt++;
3004 }
3005 }
3006 MarkIfPassedArgs(n,lclgl);
3007 /* name was ok */
3008 }
3009 gl_destroy(nl);
3010 if (errcnt > 0) {
3011 return DEF_ILLEGAL; /* pretty darn silly user */
3012 }
3013 return DEF_OKAY;
3014 }
3015
3016 /* match WILL_BE to names, isas to exprs , verifying base types. */
3017 /*
3018 * error_code = VerifyTypeArgs(alist,d,lclgl,ft);
3019 * Checks that the arg list given matches the expected args of the
3020 * type d given, as much as can be correctly checked.
3021 * Arg count is assumed correct, as that was checked at
3022 * TypeDefIllegal time.
3023 * This function could be tighter, but we need better control of
3024 * sets at parse time to do it, which is not practical.
3025 */
3026 static
3027 enum typelinterr VerifyTypeArgs(CONST struct Set *alist,
3028 CONST struct TypeDescription *d,
3029 struct gl_list_t *lclgl,
3030 struct gl_list_t *ft)
3031 {
3032 CONST struct StatementList *psl;
3033 CONST struct Statement *stat;
3034 CONST struct TypeDescription *atype; /* type argument expected */
3035 CONST struct TypeDescription *ptype; /* type parameter received */
3036 CONST struct VariableList *vl;
3037 CONST struct Set *sn;
3038 CONST struct Name *n;
3039 CONST struct Expr *ex;
3040 symchar *atn;
3041 unsigned long c,len;
3042 enum e_findrhs rval;
3043 unsigned int origin;
3044 int subsopen,argc,subsneed;
3045 int arrayerr;
3046
3047 psl = GetModelParameterList(d);
3048 len = StatementListLength(psl);
3049 sn = alist;
3050 argc = 1;
3051 for (c=1;c <= len; c++) {
3052 stat = GetStatement(psl,c);
3053 switch(StatementType(stat)) {
3054 case WILLBE:
3055 vl = GetStatVarList(stat);
3056 atn = GetStatType(stat);
3057 atype = FindType(atn);
3058 assert(atype!=NULL);
3059 /* will need set type special case handling, or else assume
3060 * integer/symbolness correct and check at instantiate time.
3061 */
3062 while (vl != NULL) {
3063 /* dig up type of parameter user wants to pass */
3064 if (SetType(sn)!=0) {
3065 FPRINTF(ASCERR,
3066 "%sRange found where instance argument expected\n Argument %d: ",
3067 StatioLabel(3),argc);
3068 WriteSetNode(ASCERR,sn);
3069 FPRINTF(ASCERR,"\n");
3070 return DEF_ARGS_INCORRECT;
3071 }
3072 ex = GetSingleExpr(sn);
3073 if (ExprType(ex)!=e_var) {
3074 FPRINTF(ASCERR,
3075 "%sIncorrect expression where instance expected\n Argument %d: ",
3076 StatioLabel(3),argc);
3077 WriteSetNode(ASCERR,sn);
3078 FPRINTF(ASCERR,"\n");
3079 return DEF_ARGS_INCORRECT;
3080 }
3081 n = ExprName(ex);
3082 if (NameInForTable(ft,n)) {
3083 FPRINTF(ASCERR,
3084 "%s Loop index used where instance expected\n Argument %d: ",
3085 StatioLabel(3),argc);
3086 WriteSetNode(ASCERR,sn);
3087 FPRINTF(ASCERR,"\n");
3088 return DEF_ARGS_INCORRECT;
3089 }
3090 ptype = FindRHSType(n,lclgl,&rval,&subsopen,&origin);
3091 if (ptype == NULL || (rval != FRC_ok && rval != FRC_array) ) {
3092 ERROR_REPORTER_START_HERE(ASC_USER_ERROR);
3093 FPRINTF(ASCERR,"Undefined name where instance expected. Argument %d: ",argc);
3094 WriteSetNode(ASCERR,sn);
3095 error_reporter_end_flush();
3096 return DEF_ARGS_INCORRECT;
3097 }
3098 /* dig up set type details to match from MODEL arg list WILL_BE,
3099 * or (as here) be an optimist until instantiate about sets.
3100 * Only insist on compatibility and not type >= WILL_BE because
3101 * the type might be <= and refined elsewhere to the correct sort.
3102 */
3103 if (ptype!=atype && MoreRefined(ptype,atype)==NULL) {
3104 ERROR_REPORTER_START_HERE(ASC_USER_ERROR);
3105 FPRINTF(ASCERR,"Instance '");
3106 WriteSetNode(ASCERR,sn);
3107 FPRINTF(ASCERR,"' is of incompatible type '%s' (expected '%s') at argument %d."
3108 , SCP(GetName(ptype)),SCP(GetName(atype)),argc
3109 );
3110 error_reporter_end_flush();
3111 return DEF_ARGS_INCORRECT;
3112 }
3113 /* check the set madness */
3114 subsneed = NameLength(NamePointer(vl)) -1; /* subs expected */
3115 arrayerr=0;
3116 if (rval != FRC_ok) {
3117 /* passing an array */
3118 if (subsneed != subsopen) {
3119 arrayerr=1;
3120 }
3121 } else {
3122 /* passing a scalar */
3123 if (subsneed != 0) {
3124 arrayerr=1;
3125 }
3126 }
3127 if(arrayerr){
3128 ERROR_REPORTER_START_NOLINE(ASC_USER_ERROR);
3129 FPRINTF(ASCERR,
3130 "Instance of incorrect arrayness passed. Argument %d: "
3131 ,argc);
3132 WriteSetNode(ASCERR,sn);
3133 FPRINTF(ASCERR,"\n");
3134 FPRINTF(ASCERR,
3135 "Expected name of a %d-dimensional object.",subsneed);
3136 error_reporter_end_flush();
3137 return DEF_ARGS_INCORRECT;
3138 }
3139 MarkIfPassedArgs(n,lclgl);
3140 /* checked out ok as much as possible. */
3141 argc++;
3142 sn = NextSet(sn);
3143 vl = NextVariableNode(vl);
3144 }
3145 break;
3146 case ISA:
3147 if (SetType(sn)!=0) {
3148 FPRINTF(ASCERR,
3149 "%sIncorrect range value passed for\n Argument %d: ",
3150 StatioLabel(3),argc);
3151 WriteExpr(ASCERR,GetLowerExpr(sn));
3152 FPRINTF(ASCERR,"..");
3153 WriteExpr(ASCERR,GetUpperExpr(sn));
3154 FPRINTF(ASCERR,"\n");
3155 FPRINTF(ASCERR," Set values should be enclosed in []s.\n");
3156 return DEF_ARGS_INCORRECT;
3157 } else {
3158 if (VerifyValueNames(GetSingleExpr(sn),lclgl,ft)!=DEF_OKAY) {
3159 FPRINTF(ASCERR,
3160 "%sIncorrect value expression passed for\n Argument %d: ",
3161 StatioLabel(3),argc);
3162 WriteExpr(ASCERR,GetSingleExpr(sn));
3163 FPRINTF(ASCERR,"\n");
3164 return DEF_ARGS_INCORRECT;
3165 }
3166 }
3167 sn = NextSet(sn);
3168 argc++;
3169 break;
3170 case FOR:
3171 /* future messiness */
3172 break;
3173 default:
3174 ASC_PANIC("NOTREACHED. filtered types in typedefillegal fcns");
3175 break;
3176 }
3177 }
3178 return DEF_OKAY;
3179 }
3180
3181 /* Needs to check that the expression passed in each
3182 * position is either object of correct type (WILL_BE)
3183 * or expression/set expression of appropriate type.
3184 * Checks IS_A IS_REFINED_TO statements in the list given.
3185 * Checks are somewhat loose, because not all correct statements
3186 * can be proven correct at parse time. (damn arrays and sets to hell)
3187 */
3188 static
3189 enum typelinterr VerifyISAARGS(CONST struct StatementList *stats,
3190 struct gl_list_t *lclgl,
3191 struct gl_list_t *ft)
3192 {
3193 register unsigned long c,len;
3194 struct Statement *stat;
3195 CONST struct Set *alist;
3196 CONST struct TypeDescription *d;
3197 enum typelinterr error_code=DEF_OKAY;
3198
3199 len = StatementListLength(stats);
3200 for (c = 1; c <= len; c++) {
3201 stat = GetStatement(stats,c);
3202 switch(StatementType(stat)){
3203 case IRT:
3204 case ISA:
3205 alist = GetStatTypeArgs(stat);
3206 if (alist != NULL) {
3207 d = FindType(GetStatType(stat));
3208 assert(d!=NULL);
3209 error_code = VerifyTypeArgs(alist,d,lclgl,ft);
3210 if (error_code != DEF_OKAY) {
3211 TypeLintError(ASCERR,stat,error_code);
3212 return error_code;
3213 }
3214 }
3215 break;
3216 case FOR:
3217 AddLoopVariable(ft,CreateForVar(ForStatIndex(stat)));
3218 error_code = VerifyISAARGS(ForStatStmts(stat),lclgl,ft);
3219 RemoveForVariable(ft);
3220 if (error_code != DEF_OKAY){
3221 return error_code;
3222 }
3223 break;
3224 case COND:
3225 error_code = VerifyISAARGS(CondStatList(stat),lclgl,ft);
3226 if (error_code != DEF_OKAY){
3227 return error_code;
3228 }
3229 break;
3230 case SELECT:
3231 /* Analyze tha flat list of statements instead */
3232 break;
3233 default: /* LREL REL, ASGN, RUN, IF, EXT, REF ISA WHEN too. */
3234 break;
3235 }
3236 }
3237 return DEF_OKAY;
3238 }
3239
3240 /*
3241 * checks that all for loop indices are legal (not shadowing)
3242 * and that all index sets smell ok.
3243 */
3244 static
3245 enum typelinterr VerifyForVars(CONST struct StatementList *stats,
3246 struct gl_list_t *lclgl,
3247 struct gl_list_t *ft,
3248 symchar *name)
3249 {
3250 register unsigned long c,len,nc,nlen;
3251 struct Statement *stat;
3252 symchar *fvname;
3253 unsigned long pos;
3254 enum typelinterr error_code=DEF_OKAY;
3255 struct ChildListEntry test;
3256 /* */
3257 CONST struct TypeDescription *rtype;
3258 struct Name *nptr;
3259 struct gl_list_t *nl=NULL;
3260 enum e_findrhs rval;
3261 int subsopen=0; /* we don't care */
3262 unsigned int origin; /* ignored */
3263 char *msg=NULL;
3264
3265 len = StatementListLength(stats);
3266 for (c = 1; c <= len; c++) {
3267 stat = GetStatement(stats,c);
3268 switch(StatementType(stat)){
3269 case FOR:
3270 fvname = ForStatIndex(stat);
3271 if (FindForVar(ft,fvname)!=NULL) {
3272 msg = (char *)ascmalloc(SCLEN(fvname)+1+80);
3273 sprintf(msg,"%sIndex %s shadows outer index",
3274 StatioLabel(3),SCP(fvname));
3275 STATEMENT_ERROR(stat,msg);
3276 ascfree(msg);
3277 return DEF_FOR_SHADOW;
3278 }
3279 test.strptr = fvname;
3280 pos = gl_search(lclgl,&test,(CmpFunc)CmpChildListEntries);
3281 if (pos!=0) {
3282 msg = (char *)ascmalloc(SCLEN(fvname)+1+80);
3283 sprintf(msg,"%sIndex %s shadows instance.",StatioLabel(3),
3284 SCP(fvname));
3285 STATEMENT_ERROR(stat,msg);
3286 ascfree(msg);
3287 return DEF_FOR_SHADOW;
3288 }
3289
3290 /* check set expr */
3291 nl = EvaluateNamesNeeded(ForStatExpr(stat),NULL,nl);
3292 nlen = gl_length(nl);
3293 for (nc=1;nc<=nlen;nc++) {
3294 nptr = (struct Name *)gl_fetch(nl,nc);
3295 if (NameInForTable(ft,nptr)) {
3296 continue;
3297 }
3298 rtype = FindRHSType(nptr,lclgl,&rval,&subsopen,&origin);
3299 if (rtype==NULL) {
3300 if (rval != FRC_attrname) {
3301 char *iostring;
3302 TLNM(ASCERR,nptr,"Unverifiable name in FOR index set: ",2);
3303 error_code = DEF_NAME_MISSING;
3304 iostring = (char *)ascmalloc(6+SCLEN(name));
3305 sprintf(iostring,"In %s:\n",SCP(name));
3306 TypeLintErrorAuxillary(ASCERR,iostring,DEF_MISC_STYLE,TRUE);
3307 ascfree(iostring);
3308 TypeLintError(ASCERR,stat, error_code);
3309 error_code = DEF_OKAY;
3310 /* here it would be nice if we could punt, but refinement
3311 * rules that out since the name might be valid and we not know.
3312 */
3313 }
3314 continue;
3315 }
3316 if ( rval != FRC_ok /* arrays not evaluatable */ ||
3317 (BaseTypeIsAtomic(rtype) == 0 && BaseTypeIsConstant(rtype)==0)
3318 ) {
3319 TLNM(ASCERR,nptr,"Improper non-scalar in FOR index set: ",3);
3320 gl_destroy(nl);
3321 error_code = DEF_ILLEGAL_FORSET;
3322 TypeLintError(ASCERR,stat, error_code);
3323 return error_code;
3324 }
3325 }
3326 gl_destroy(nl);
3327 nl = NULL;
3328 /* end of checking expression */
3329
3330 AddLoopVariable(ft,CreateForVar(fvname));
3331 error_code = VerifyForVars(ForStatStmts(stat),lclgl,ft,name);
3332 RemoveForVariable(ft);
3333 if (error_code != DEF_OKAY) {
3334 return error_code;
3335 }
3336 break;
3337 case COND:
3338 error_code = VerifyForVars(CondStatList(stat),lclgl,ft,name);
3339 if (error_code != DEF_OKAY) {
3340 return error_code;
3341 }
3342 break;
3343 case SELECT:
3344 /* analyze the flat list of statements instead */
3345 break;
3346 default:
3347 break;
3348 }
3349 }
3350 return error_code;
3351 }
3352 /*
3353 * checks that all names used in an expression are traceable
3354 * to appropriate set/var/constant origins.
3355 * In particular, since FIndRHSType disallows FRC_attr,
3356 * this function won't let through ATOM children.
3357 */
3358 static
3359 enum typelinterr VerifyScalarNames(CONST struct Expr *ex,
3360 struct gl_list_t *lclgl,
3361 struct gl_list_t *ft)
3362 {
3363 struct gl_list_t *nl=NULL;
3364 CONST struct TypeDescription *rtype;
3365 CONST struct Name *n;
3366 unsigned long c,len;
3367 enum e_findrhs rval;
3368 int errcnt=0;
3369 int subsopen=0; /* we don't care */
3370 unsigned int origin; /* ignored */
3371
3372 assert(ex!=NULL);
3373
3374 nl = EvaluateNamesNeeded(ex,NULL,nl);
3375 /* create, possibly empty, list of all variables including
3376 * variables in set expressions needed to interpret an expression.
3377 */
3378 assert(nl!=NULL);
3379 len = gl_length(nl);
3380 for (c = 1; c <= len; c++) {
3381 n = (CONST struct Name *)gl_fetch(nl,c);
3382 /* check forvars here first. tempvars would be tricky,
3383 * except EvaluateNamesNeeded doesn't report those (we hope).
3384 */
3385 if (NameInForTable(ft,n)) {
3386 continue; /* skip to next name */
3387 }
3388 /* not in forvars, so check declarations */
3389 rtype = FindRHSType(n,lclgl,&rval,&subsopen,&origin);
3390 if (rtype==NULL) {
3391 TLNM(ASCERR,n,"Undefined WITH_VALUE variable name ",3);
3392 errcnt++;
3393 } else {
3394 if (rval != FRC_ok /* can't compute on arrays */ ||
3395 (BaseTypeIsConstant(rtype) == 0 &&
3396 BaseTypeIsAtomic(rtype) == 0
3397 )
3398 ) {
3399 TLNM(ASCERR,n,"Incorrect non-scalar/non-set type: ",3);
3400 errcnt++;
3401 }
3402 }
3403 /* name was ok */
3404 }
3405 gl_destroy(nl);
3406 if (errcnt > 0) {
3407 return DEF_ILLEGAL; /* pretty darn silly user */
3408 }
3409 return DEF_OKAY;
3410 }
3411
3412 /*
3413 * checks that all names used in an expression are traceable
3414 * to set/scalar ATOM/constant origins.
3415 * In particular, since FIndRHSType disallows FRC_attr,
3416 * this function won't let through ATOM children.
3417 * This function could be more specialized (picky)
3418 * when it comes to logical vs real relations.
3419 * disallows integer-based variables, symbol vars.
3420 */
3421 static
3422 enum typelinterr VerifyArithmeticNames(symchar *name,
3423 CONST struct Expr *ex,
3424 struct gl_list_t *lclgl,
3425 struct gl_list_t *ft)
3426 {
3427 struct gl_list_t *nl=NULL;
3428 CONST struct TypeDescription *rtype;
3429 CONST struct Name *n;
3430 unsigned long c,len;
3431 enum e_findrhs rval;
3432 int errcnt=0;
3433 unsigned int origin; /* ignored */
3434 int subsopen=0; /* we don't care */
3435 char *iostring;
3436
3437 assert(ex!=NULL);
3438
3439 nl = EvaluateNamesNeeded(ex,NULL,nl);
3440 /* create, possibly empty, list of all variables including
3441 * variables in set expressions needed to interpret an expression.
3442 */
3443 assert(nl!=NULL);
3444 len = gl_length(nl);
3445 for (c = 1; c <= len; c++) {
3446 n = (const struct Name *)gl_fetch(nl,c);
3447 /* check forvars here first. tempvars would be tricky,
3448 * except EvaluateNamesNeeded doesn't report those (we hope).
3449 */
3450 if (NameInForTable(ft,n)) {
3451 continue;
3452 }
3453 /* not in forvars, so check declarations */
3454 rtype = FindRHSType(n,lclgl,&rval,&subsopen,&origin);
3455 if (rtype==NULL) {
3456 iostring = ASC_NEW_ARRAY(char,200);
3457 sprintf(iostring,"In model '%s', undefined variable named ",SCP(name));
3458 /* TypeLintErrorAuxillary(ASCERR,iostring,DEF_MISC_WARNING,TRUE); */
3459 TLNM(ASCERR,n,iostring,2);
3460 ascfree(iostring);
3461 errcnt++;
3462 } else {
3463 if (rval != FRC_ok /* can't compute on arrays */ ||
3464 (BaseTypeIsConstant(rtype) == 0 &&
3465 BaseTypeIsSet(rtype) == 0 &&
3466 GetBaseType(rtype) != real_type &&
3467 GetBaseType(rtype) != boolean_type
3468 )
3469 ) {
3470 TLNM(ASCERR,n,"Incorrect non-algebraic type:",3);
3471 errcnt++;
3472 }
3473 }
3474 /* name was ok */
3475 }
3476 gl_destroy(nl);
3477