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

Contents of /trunk/base/generic/compiler/typedef.c

Parent Directory Parent Directory | Revision Log Revision Log


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