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