/[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 863 - (show annotations) (download) (as text)
Thu Sep 28 08:17:18 2006 UTC (13 years, 4 months ago) by johnpye
File MIME type: text/x-csrc
File size: 171338 byte(s)


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