/[ascend]/trunk/ascend/compiler/typedef.c
ViewVC logotype

Contents of /trunk/ascend/compiler/typedef.c

Parent Directory Parent Directory | Revision Log Revision Log


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