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