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