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