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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 11 - (hide annotations) (download) (as text)
Sat Nov 13 16:45:56 2004 UTC (15 years, 3 months ago) by aw0a
File MIME type: text/x-csrc
File size: 170400 byte(s)
moving things to base/generic
1 aw0a 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    
77     #ifndef lint
78     static CONST char TypeDefinitionRCSid[] ="$Id: typedef.c,v 1.60 1998/04/21 23:50:02 ballan Exp $";
79     #endif
80    
81    
82     /*
83     * To generate a name for a relation, logrelation or when using
84     * the number of the relation, logrelation or when in the model,
85     * rather than the line number
86     */
87    
88     /*
89     * number of a relation,logrelation or when
90     */
91     static unsigned long g_number= 0;
92    
93     /*
94     * unused at present
95     *static unsigned long g_typedef_linenum = 0;
96     */
97    
98    
99     /*
100     * function to find if name is proper FOR variable. Returns 1 if so. 0 not.
101     * should be in another file.
102     */
103     static
104     int NameInForTable(CONST struct for_table_t *ft, CONST struct Name *n)
105     {
106     symchar *name;
107     struct for_var_t *ptr;
108     if (ft != NULL && n != NULL) {
109     AssertMemory(ft);
110     name = SimpleNameIdPtr(n);
111     if (name != NULL) {
112     ptr = FindForVar(ft,name);
113     if (ptr != NULL) {
114     switch(GetForKind(ptr)){
115     case f_integer:
116     case f_symbol:
117     case f_set:
118     case f_untyped: /* we aren't interpretting, just name spacing */
119     return 1;
120     default:
121     FPRINTF(ASCERR,"Untyped FOR variable (%s).\n",SCP(name));
122     }
123     }
124     }
125     }
126     return 0;
127     }
128    
129     /*----------------------------------------------------------------------------
130     * Data structures to help track reducing a prior argument list by the
131     * reduction assignments.
132     *----------------------------------------------------------------------------
133     */
134    
135     /* Redlist auxillaries. */
136     /* a struct for Reduce use */
137     struct RedListEntry {
138     struct Statement *olddeclstat;
139     /* these are temporary references, so the statement copy fcn not used */
140     CONST struct Name *name;
141     /* assumes each IS_A has one lhs name. if NULL, olddeclstat is a WILL_BE. */
142     CONST struct Name *wbname;
143     /* one WILL_BE may have several RLEs. This entry is not NULL if
144     * rle is from a WILL_BE.
145     */
146     int assigned; /* relevant only for name != NULL */
147     /*
148     * -2 name is of WILL_BE MODEL/variable, array or not;
149     * -1 name is of constant array; multiple assignments allowed.
150     * 0 = name is constant/set not yet assigned;
151     * 1 name has assigned value, possibly from constant typedesc;
152     */
153     };
154    
155     /* forward declarations */
156     static
157     enum typelinterr
158     DoIS_A(CONST struct StatementList *stats);
159    
160     static
161     enum typelinterr
162     DoWhens(symchar *, CONST struct StatementList *, struct gl_list_t *);
163    
164     static
165     enum typelinterr
166     DoRelations(symchar *, CONST struct StatementList *, struct gl_list_t *);
167    
168     /* stuff used to build child lists from statements, etc */
169    
170     /**********************************************************\
171     * During the production of a child list we desire to ultimately
172     * produce a sorted gllist of pointers to struct ChildListEntry *
173     * that contain the names, array status, and most refined
174     * basetypes determinable based on already existing type
175     * definitions and the new statements of the type for which
176     * we are making the child list.
177     * We desire to be able to do this for some
178     * number of children between 0 and 100000
179     *
180     * The proposed and hence implemented solution is in the
181     * section of code that follows: a doubly linked list containing
182     * struct ChildListEntry and the operators to manage it.
183     * Once these size and naming of all the children are determined
184     * and sorted into this DL structure, we can map them into
185     * a gl_list for further processing.
186     * The child.h list interface specifies that we the user are
187     * responsible for the ChildListEntries in the input gllist,
188     * so we here use a lifo recycle list to avoid constant calls
189     * to malloc/free.
190     \**********************************************************/
191     struct LinkChildListEntry {
192     struct ChildListEntry e; /* must be first! */
193     /* the next 3 are not yet in use, really. */
194     struct LinkChildListEntry *alike;
195     /* pointer to aliked child list entries, which will all have the same type.
196     * This will be NULL unless an ARE_ALIKE has been seen or the CLE is a
197     * scalar. Array names in particular unless a statement aliking the
198     * array elements over its set of definition will have null alike ptr.
199     * ARE_ALIKE of individual array elements will not show up here.
200     * Circularly linked list.
201     */
202     struct LinkChildListEntry *arrthesame;
203     struct LinkChildListEntry *eltsthesame;
204     /* pointer to merged child list entries, which will all have the same type.
205     * This will be NULL unless an ARE_THE_SAME has been seen or the CLE is a
206     * scalar. Array names in particular unless a statement merging the
207     * array elements over its set of definition will have NULL eltsthesame ptr.
208     * ARE_THE_SAME of individual array elements will not show up here.
209     * Merging arrays, as is the apparent case with an alias of an array,
210     * will show up in the arrthesame ptr.
211     * Circularly linked list.
212     */
213     /* pointers of the doubly-linked LCL structure */
214     struct LinkChildListEntry *prev;
215     struct LinkChildListEntry *next;
216     };
217    
218     static
219     struct LinkChildListEntry *g_lcl_head = NULL, *g_lcl_tail = NULL;
220     static
221     struct LinkChildListEntry *g_lcl_recycle = NULL;
222     /* above the head and tail anchors of the list and the anchor
223     * for a lifo recycle list of these structures.
224     */
225    
226     static
227     struct LinkChildListEntry *g_lcl_pivot = NULL;
228     /* a pointer to somewhere in the working list. used heuristically
229     * to speed name-based search.
230     */
231    
232     #define LCLNAME g_lcl_pivot->e.strptr
233     /* returns the name of the current pivot. assumes the pivot is valid */
234    
235     static
236     unsigned long g_lcl_length = 0;
237    
238     #ifndef NDEBUG
239     static
240     unsigned long g_lclrecycle_length = 0;
241     #endif
242    
243     void DestroyTypedefRecycle(void)
244     {
245     struct LinkChildListEntry *old;
246     while (g_lcl_recycle != NULL) {
247     old = g_lcl_recycle;
248     g_lcl_recycle = old->next;
249     ascfree(old);
250     }
251     }
252    
253     /*
254     * returns a recycled or a new lcl element
255     * whichever is first available. Does nothing else
256     * except possibly update the length of the recycle list
257     * during debugging.
258     */
259     static
260     struct LinkChildListEntry *GetLCL(void)
261     {
262     struct LinkChildListEntry *new;
263     if (g_lcl_recycle!=NULL) {
264     new = g_lcl_recycle;
265     g_lcl_recycle = new->next;
266     #ifndef NDEBUG
267     g_lclrecycle_length--;
268     #endif
269     } else {
270     new = (struct LinkChildListEntry *)
271     ascmalloc(sizeof(struct LinkChildListEntry));
272     }
273     return new;
274     }
275    
276     static
277     void ClearLCL(void)
278     {
279     #ifndef NDEBUG
280     struct LinkChildListEntry *old;
281     /* do some book keeping and reinitializing, working from the tail. */
282     while (g_lcl_tail!=NULL) {
283     assert(g_lcl_length!=0L);
284     /* init */
285     old = g_lcl_tail;
286     old->e.strptr = NULL;
287     old->e.typeptr = NULL;
288     old->e.isarray = 0;
289     old->e.origin = origin_ERR;
290     /* cut off tail */
291     g_lcl_tail = old->prev;
292     g_lcl_length--;
293     /* push old into singly linked recycle list */
294     old->prev = NULL;
295     old->next = g_lcl_recycle;
296     g_lcl_recycle = old;
297     g_lclrecycle_length++;
298     }
299     assert(g_lcl_length==0L);
300     #else
301     /* insert current list at head of recycle */
302     if (g_lcl_tail!=NULL) {
303     g_lcl_tail->next = g_lcl_recycle;
304     }
305     /* if anything was added, get new head */
306     if (g_lcl_head != NULL) {
307     g_lcl_recycle = g_lcl_head;
308     }
309     #endif
310     g_lcl_tail = g_lcl_head = g_lcl_pivot = NULL;
311     g_lcl_length=0;
312     }
313    
314     /*
315     * copies the pointers from the LCL to a gllistt.
316     * the lcl still exists. We do not clear it until
317     * after the gllist containing the copies is finished with.
318     * This should never return null.
319     */
320     static
321     struct gl_list_t *CopyLCLToGL(void)
322     {
323     struct gl_list_t *list;
324     struct LinkChildListEntry *e;
325     list = gl_create(g_lcl_length);
326     assert(list!=NULL);
327     e = g_lcl_head;
328     while (e!=NULL) {
329     /* since lcl is sorted, insert should always be at tail.
330     * since we created it big enough, this should never have to expand.
331     */
332     gl_insert_sorted(list,e,(CmpFunc)CmpChildListEntries);
333     e = e->next;
334     }
335     assert(gl_length(list)==g_lcl_length);
336     return list;
337     }
338    
339     /*
340     * On entry assumes g_lcl_pivot==NULL means the LCL is empty.
341     * s must not be NULL.
342     *
343     * Moves g_lcl_pivot to the element e such that e->next should be
344     * changed to point to the new element according to s.
345     * If an element with the name s already is found,
346     * returns 0 instead of 1 and pivot will be pointing to the
347     * entry with that symchar.
348     * On exit g_lcl_pivot might be null if head and tail are
349     * or if the s given is ahead in alphabetical order of all the
350     * list elements.c
351     *
352     */
353     static
354     int LocateLCLPivot(symchar *s)
355     {
356     int cmp;
357     assert(s!=NULL);
358     if (g_lcl_pivot == NULL) {
359     /* list is empty. null is the pivot. */
360     return 1;
361     }
362     if (s == g_lcl_pivot->e.strptr) return 0;
363     /* repeated name check by ptr */
364     cmp = CmpSymchar(LCLNAME,s);
365     if (cmp==0) return 0;
366     if (cmp<0) {
367     /* search forward */
368     while (g_lcl_pivot->next != NULL) {
369     g_lcl_pivot = g_lcl_pivot->next;
370     cmp = CmpSymchar(LCLNAME,s);
371     if (cmp >= 0) {
372     if (cmp==0) return 0;
373     g_lcl_pivot = g_lcl_pivot->prev;
374     return 1;
375     }
376     }
377     assert(g_lcl_pivot==g_lcl_tail);
378     return 1;
379     } else {
380     /* search backward */
381     while (g_lcl_pivot->prev != NULL) {
382     g_lcl_pivot = g_lcl_pivot->prev;
383     cmp = CmpSymchar(LCLNAME,s);
384     if (cmp <= 0) {
385     if (cmp==0) return 0;
386     return 1;
387     }
388     }
389     assert(g_lcl_pivot==g_lcl_head);
390     g_lcl_pivot = NULL;
391     return 1;
392     }
393     }
394    
395     /*
396     * On entry assumes g_lcl_pivot != NULL unless there are no children yet.
397     * Returns 1 if succeeds in adding a new child record.
398     * Returns 0 if fails due to duplicate name.
399     * Returns -1 if fails due to malloc fail or bad input.
400     * s is the symchar of the childname, d is its type ptr which may be null,
401     * nsubs indicates if child is array
402     * nsubs > 0 (with total known subscripts)
403     * nsubs = 0 not an array
404     * nsubs < 0 an aliases, subscripts to be determined at end.
405     * so a value of -1 should be given for b ALIASES a; and a value of
406     * -2 given for b[1..n] ALIASES a; since we don't know for certain
407     * the subscriptedness of a until children are all parsed.
408     * For aliases, the correct value of nsubs must be set before
409     * calling MakeChildList.
410     * s MUST be from the symbol table.
411     * When we have a more useful symchar definition some of this
412     * might be better implemented.
413     * parametric should be 1 if stat is a parameter decl or 0 if body stat.
414     */
415     #define STATBODY 0
416     #define STATPARAMETRIC 1
417     static
418     int AddLCL(symchar *s,CONST struct TypeDescription *d, int nsubs,
419     CONST struct Statement *stat, int parametric)
420     {
421     struct LinkChildListEntry *new;
422     /* search for insertion location, which means move pivot to the
423     * name just before this one so we can insert after pivot.
424     */
425     if (!LocateLCLPivot(s)) {
426     return 0; /* if found the exact name, exit early */
427     }
428     /* get a LCLEntry to fill with data */
429     new = GetLCL();
430     if (new==NULL) return -1;
431    
432     new->e.strptr = s;
433     new->e.typeptr = d;
434     new->e.statement = stat;
435     new->e.isarray = nsubs;
436     new->e.bflags = CBF_VISIBLE;
437     switch (StatementType(stat)) {
438     case ALIASES:
439     new->e.origin = origin_ALI;
440     break;
441     case ARR:
442     new->e.origin = origin_ARR;
443     break;
444     case ISA:
445     new->e.origin = origin_ISA;
446     break;
447     case WILLBE:
448     new->e.origin = origin_WB;
449     break;
450     case REL:
451     case LOGREL:
452     case WHEN:
453     /* not strictly kosher TRUE, but truer than saying an error */
454     /* all rel/logrel/when are implicitly IS_A'd/typed */
455     new->e.origin = origin_ISA;
456     break;
457     default:
458     new->e.origin = origin_ERR;
459     break;
460     }
461     if (new->e.origin != origin_ERR && parametric==STATPARAMETRIC) {
462     new->e.origin += origin_PARAMETER_OFFSET;
463     }
464     g_lcl_length++;
465    
466     /* insert after pivot and make new element new pivot */
467     new->prev = g_lcl_pivot; /* might be null */
468     if (g_lcl_pivot!=NULL) {
469     /* the list has a head we can add in after. we need to point back at
470     * it, it at us, and possibly we are the tail or the tail points back.
471     */
472     /* point new element at tail of list */
473     new->next = g_lcl_pivot->next; /* might be null */
474     /* update tail back pointer */
475     if (new->next == NULL) {
476     /* added to end of list */
477     g_lcl_tail = new;
478     } else {
479     /* added before some tail */
480     new->next->prev = new;
481     }
482     /* point it at us */
483     g_lcl_pivot->next = new;
484     } else {
485     /* first element being inserted, or new element leads list. */
486     new->next = g_lcl_head;
487     g_lcl_head = new;
488     if (g_lcl_tail == NULL) { /* new is the only element in list */
489     g_lcl_tail = new;
490     } else {
491     new->next->prev = new;
492     }
493     }
494     g_lcl_pivot = new; /* cannot be NULL */
495     assert(new->e.origin != origin_ERR);
496     return 1;
497     }
498    
499     /*
500     * Searches the LCL for an entry with a symchar with same
501     * value as string given. string given is expected to
502     * be from the symbol table.
503     * Returns the pointer to the LCLentry if exact match found
504     * else returns NULL.
505     * Side effects: relocates lcl_pivot to entry matching s, if
506     * such an entry exists, else no side effects.
507     * If symchar gets redefined, this will most probably need
508     * reimplementing.
509     */
510     static
511     struct LinkChildListEntry *FindLCL(symchar *s)
512     {
513     struct LinkChildListEntry *hold;
514     hold = g_lcl_pivot;
515     if (LocateLCLPivot(s)) {
516     /* locate found an insertion point, so name wasn't in list. */
517     g_lcl_pivot = hold;
518     return NULL;
519     } else {
520     /* assumption: we will always call FindLCL correctly, so that
521     * a zero return does not mean an error.
522     */
523     return g_lcl_pivot;
524     }
525     }
526    
527    
528     /**********************************************************\
529     end linkchildlistentry memory manipulation functions.
530     could we put all the above in the childdef file?
531     \**********************************************************/
532    
533    
534     #define DoName(n,c,s) DoNameF((n),(c),(s),1)
535     #define DoNameQuietly(n,c) DoNameF((n),(c),(s),0)
536     /*
537     * Checks the first element of a name for being in the child list.
538     * If not in child list, adds it. returns DEF_OKAY.
539     * If in child list, returns DEF_NAME_DUPLICATE, making noise if noisy !=0.
540     * Name must be an id.
541     * Also checks if name is name of an array.
542     * This function should NOT be use on parameter declarations.
543     */
544     static
545     enum typelinterr DoNameF(CONST struct Name *nptr,
546     CONST struct TypeDescription *type,
547     CONST struct Statement *stat,
548     int noisy)
549     {
550     register symchar *name;
551     int ok;
552     int nsubs=0;
553     if (NameId(nptr) !=0){
554     name = NameIdPtr(nptr);
555     switch (StatementType(stat)) {
556     case ISA:
557     case REF: /* IS_A of prototype */
558     case WILLBE:
559     case REL:
560     case LOGREL:
561     case WHEN:
562     nsubs = NameLength(nptr) - 1;
563     break;
564     case ALIASES:
565     nsubs -= NameLength(nptr); /* because init to 0 */
566     break;
567     case ARR:
568     /* god this case is ugly */
569     if (nptr==NamePointer(ArrayStatAvlNames(stat))) {
570     /* first field is an alias array */
571     nsubs -= NameLength(nptr); /* because init to 0 */
572     type = NULL;
573     } else {
574     /* second field is an IS_A of a set */
575     type = FindSetType();
576     nsubs = NameLength(nptr) - 1;
577     }
578     break;
579     default:
580     /* should never happen */
581     return DEF_STAT_MISLOCATED;
582     }
583     ok = AddLCL( name,type, nsubs,
584     stat, /* statement of initial IS_A/ALIASES,relation */
585     STATBODY
586     );
587     if (ok < 1) {
588     if (ok < 0) {
589     FPRINTF(ASCERR,"%sInsufficient memory during parse.\n",
590     StatioLabel(4));
591     return DEF_ILLEGAL; /* well, having insufficient memory is illegal */
592     }
593     if (noisy && ok == 0) {
594     FPRINTF(ASCERR,"%sSame instance name \"%s\" used twice.",
595     StatioLabel(3),SCP(name));
596     assert(g_lcl_pivot!=NULL);
597     if (g_lcl_pivot->e.statement != stat ) {
598     WSEM(ASCERR,g_lcl_pivot->e.statement," First seen:");
599     } else {
600     FPRINTF(ASCERR,"\n");
601     }
602     }
603     return DEF_NAME_DUPLICATE;
604     }
605     } else {
606     /* should never happen due to new upstream filters. */
607     FPRINTF(ASCERR,"%sBad name structure found in variable list.\n",
608     StatioLabel(3));
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     (void) type; (void) ft;
1064     assert(stat && (StatementType(stat) == EXT));
1065     /*
1066     * The grammar specifies that External function calls
1067     * must be named.
1068     */
1069     nptr = ExternalStatName(stat);
1070     return DoName(nptr,FindExternalType(),stat);
1071     }
1072    
1073    
1074     /*
1075     * Since we implemented the WHEN statement as an instance, we
1076     * generate an automatic name for each WHEN. The following
1077     * function deals with the names of nested WHENs
1078     */
1079     static
1080     enum typelinterr ProcessWhenCases(symchar *type,
1081     struct WhenList *whenlist,
1082     struct gl_list_t *ft)
1083     {
1084     enum typelinterr error_code;
1085     while (whenlist!=NULL){
1086     error_code = DoWhens(type,WhenStatementList(whenlist),ft);
1087     if (error_code != DEF_OKAY) {
1088     return error_code;
1089     }
1090     whenlist = NextWhenCase(whenlist);
1091     }
1092     return DEF_OKAY;
1093     }
1094    
1095    
1096    
1097     /*
1098     * This function is supposed to handle the relations inside a
1099     * SELECT statement. However, now all of the statements inside
1100     * SELECT are contained in the main statement list, which is
1101     * flat. So, it is not required anymore, thus, the #ifdef
1102     *
1103     */
1104     #ifdef THIS_IS_AN_UNUSED_FUNCTION
1105     static
1106     enum typelinterr ProcessSelectCases(CONST char *type,
1107     struct SelectList *selectlist,
1108     struct gl_list_t *ft)
1109     {
1110     enum typelinterr error_code;
1111     while (selectlist!=NULL){
1112     error_code = DoRelations(type,SelectStatementList(selectlist),ft);
1113     if (error_code !=DEF_OKAY) return error_code;
1114     selectlist = NextSelectCase(selectlist);
1115     }
1116     return DEF_OKAY;
1117     }
1118     #endif /* THIS_IS_AN_UNUSED_FUNCTION */
1119    
1120    
1121     static
1122     enum typelinterr DoRelations(symchar *type,
1123     CONST struct StatementList *stats,
1124     struct gl_list_t *ft)
1125     {
1126     register struct gl_list_t *statements;
1127     register unsigned long c,len;
1128     register struct Statement *stat;
1129     enum typelinterr error_code;
1130     statements = GetList(stats);
1131     len = gl_length(statements);
1132     for(c=1;c<=len;c++){
1133     stat = (struct Statement *)gl_fetch(statements,c);
1134     switch(StatementType(stat)){
1135     case REL:
1136     error_code = DoRelation(type,stat,ft);
1137     if (error_code != DEF_OKAY) {
1138     TypeLintError(ASCERR,stat, error_code);
1139     return error_code;
1140     }
1141     break;
1142     case LOGREL:
1143     error_code = DoLogRel(type,stat,ft);
1144     if (error_code != DEF_OKAY) {
1145     TypeLintError(ASCERR,stat, error_code);
1146     return error_code;
1147     }
1148     break;
1149     case EXT:
1150     error_code = DoExternal(type,stat,ft);
1151     if (error_code != DEF_OKAY) {
1152     TypeLintError(ASCERR,stat, error_code);
1153     return error_code;
1154     }
1155     break;
1156     case SELECT:
1157     /*
1158     * Now all of the statements inside a SELECT (including
1159     * relations )are contained in the main statement list, which is
1160     * which is flat. So, this case is not required anymore.
1161     *
1162    
1163     * error_code = ProcessSelectCases(type,SelectStatCases(stat),ft);
1164     * if (error_code != DEF_OKAY) {
1165     * TypeLintError(ASCERR,stat, error_code);
1166     * return error_code;
1167     * }
1168    
1169     */
1170     break;
1171     case FOR:
1172     AddLoopVariable(ft,CreateForVar(ForStatIndex(stat)));
1173     error_code = DoRelations(type,ForStatStmts(stat),ft);
1174     RemoveForVariable(ft);
1175     if (error_code != DEF_OKAY) {
1176     return error_code;
1177     }
1178     break;
1179     case COND:
1180     error_code=DoRelations(type,CondStatList(stat),ft);
1181     if (error_code != DEF_OKAY) {
1182     TypeLintError(ASCERR,stat, error_code);
1183     return error_code;
1184     }
1185     break;
1186     default: /* ISA, IRT, ATS, AA, ASGN, WHEN, RUN, IF, REF, CASGN, CALL*/
1187     break;
1188     }
1189     }
1190     return DEF_OKAY;
1191     }
1192    
1193     /*
1194     * Since we implemented the WHEN statement as an instance, we
1195     * generate an automatic name for each WHEN. The following
1196     * function deals with the names of a WHEN statement. For
1197     * nested WHEN, the function ProcessWhenCases is called.
1198     */
1199    
1200    
1201     static
1202     enum typelinterr DoWhens(symchar *type,
1203     CONST struct StatementList *stats,
1204     struct gl_list_t *ft)
1205     {
1206     register struct gl_list_t *statements;
1207     register unsigned long c,len;
1208     register struct Statement *stat;
1209     enum typelinterr error_code;
1210     statements = GetList(stats);
1211     len = gl_length(statements);
1212     for(c=1;c<=len;c++){
1213     stat = (struct Statement *)gl_fetch(statements,c);
1214     switch(StatementType(stat)){
1215     case WHEN:
1216     error_code = DoWhen(type,stat,ft);
1217     if (error_code != DEF_OKAY) {
1218     TypeLintError(ASCERR,stat, error_code);
1219     return error_code;
1220     }
1221     error_code = ProcessWhenCases(type,WhenStatCases(stat),ft);
1222     if (error_code != DEF_OKAY) {
1223     TypeLintError(ASCERR,stat, error_code);
1224     return error_code;
1225     }
1226     break;
1227     case FOR:
1228     AddLoopVariable(ft,CreateForVar(ForStatIndex(stat)));
1229     error_code = DoWhens(type,ForStatStmts(stat),ft);
1230     RemoveForVariable(ft);
1231     if (error_code != DEF_OKAY) {
1232     return error_code;
1233     }
1234     break;
1235     default:
1236     break;
1237     }
1238     }
1239     return DEF_OKAY;
1240     }
1241    
1242    
1243     /*****************************************************************\
1244     Functions to help determine the types of children.
1245     \*****************************************************************/
1246    
1247     /*
1248     * this is a little structure we require for a temporary singly linked
1249     * list of statements.
1250     */
1251     enum albits {
1252     AL_WAIT = 0, /* wait means we haven't been able to determine anything yet */
1253     AL_WARR, /* nothing yet on ARR statement common rhslist type. */
1254     AL_DONE, /* done means we've processed this alias statement */
1255     AL_NORHS /* norhs means the rhs cannot be found */
1256     };
1257    
1258     struct AliasList {
1259     struct Statement *stat;
1260     struct AliasList *next;
1261     enum albits bits;
1262     };
1263    
1264     /*
1265     * create an alias list entry using statement s.
1266     */
1267     static
1268     struct AliasList *ALCreate(struct Statement *s)
1269     {
1270     struct AliasList *ret;
1271     ret = (struct AliasList *)ascmalloc(sizeof(struct AliasList));
1272     assert(ret!=NULL);
1273     ret->stat = s;
1274     ret->next = NULL;
1275     if (StatementType(s) == ARR) {
1276     ret->bits = AL_WARR;
1277     } else {
1278     ret->bits = AL_WAIT;
1279     }
1280     return ret;
1281     }
1282    
1283     /*
1284     * Destroy an aliases list entry
1285     */
1286     static
1287     void ALDestroy(struct AliasList *a)
1288     {
1289     ascfree(a);
1290     }
1291    
1292     /*
1293     * Destroy an aliases list. input may be null.
1294     */
1295     static
1296     void DestroyAliasesList(struct AliasList *a)
1297     {
1298     struct AliasList *old;
1299     while (a != NULL) {
1300     old = a;
1301     a = old->next;
1302     ALDestroy(old);
1303     }
1304     }
1305     /*
1306     * this function creates prepends an alias list entry
1307     * and returns the new head of the list.
1308     * ele or list may be null.
1309     */
1310     static
1311     struct AliasList *ALPrepend(struct AliasList *list, struct AliasList *ele)
1312     {
1313     if (ele==NULL) return list;
1314     if (list != NULL) {
1315     if (ele->next == NULL) {
1316     /* usual cheap case */
1317     ele->next = list;
1318     } else {
1319     /* case where ele is a list */
1320     struct AliasList *tail;
1321     tail = ele;
1322     while (tail->next != NULL) {
1323     tail = tail->next;
1324     }
1325     tail->next = list;
1326     }
1327     }
1328     return ele;
1329     }
1330    
1331     /*
1332     * Returns a list of aliases statements found in the
1333     * given list.
1334     * Recursive in some compound statements
1335     */
1336     static
1337     struct AliasList *CreateAliasesList(struct StatementList *stats)
1338     {
1339     register struct Statement *stat;
1340     struct gl_list_t *statements;
1341     struct AliasList *result=NULL;
1342     unsigned long c,len;
1343    
1344     statements = GetList(stats);
1345     len = gl_length(statements);
1346     for(c=1;c<=len;c++){
1347     stat = (struct Statement *)gl_fetch(statements,c);
1348     switch(StatementType(stat)){
1349     case ALIASES:
1350     case ARR:
1351     result = ALPrepend(result,ALCreate(stat));
1352     break;
1353     case FOR:
1354     result = ALPrepend(result,CreateAliasesList(ForStatStmts(stat)));
1355     break;
1356     case SELECT:
1357     /*
1358     * Now all of the statements inside a SELECT statement
1359     * are contained in the main statement list, which is
1360     * flat. So, this case is not required anymore.
1361     *
1362     */
1363     break;
1364     default:
1365     break;
1366     }
1367     }
1368     return result;
1369     }
1370    
1371     /*
1372     */
1373     enum e_findrhs {
1374     FRC_ok = 0, /* got type. name is simple */
1375     FRC_array, /* got type, which is base of array */
1376     FRC_badname, /* part named is impossible */
1377     FRC_attrname, /* part named is subatomic and can't be aliased */
1378     FRC_unable, /* unable to determine type of rhs, but might later */
1379     FRC_fail /* unable to determine type of rhs ever */
1380     };
1381    
1382     /*
1383     * This function tries to determine the first chain item in a name
1384     * which was constructed by being passed into the type of
1385     * which the item is a part.
1386     * Works from the childlist of the typedescription given.
1387     * This function will recurse as required.
1388     * The name given may or may not be compound.
1389     * Possible returns:
1390     * FRC_ok: no parameter origin parts were found. *nptrerr <-- NULL.
1391     * FRC_badname: part name starting at *nptrerr is impossible, array, etc.
1392     * FRC_attrname: part named starting at *nptrerr is subatomic.
1393     * FRC_array: part named starting at *nptrerr has too many/not enough []
1394     * FRC_fail: parametric origin part was found. *nptrerr <-- param part.
1395     * FRC_unable: never returned.
1396     * On the first call from the user, nptrerr should be a name to
1397     * evaluate in the context of the type given.
1398     */
1399     static
1400     enum e_findrhs AANameIdHasParameterizedPart(CONST struct Name **nptrerr,
1401     CONST struct TypeDescription *type)
1402     {
1403     CONST struct Name *nptr;
1404     CONST struct Name *pnptr,*tnptr;
1405     CONST struct TypeDescription *rtype;
1406     ChildListPtr cl;
1407     unsigned long pos;
1408     int alen,subseen,subsleft;
1409    
1410     assert(type!=NULL);
1411     assert(NameId(*nptrerr)!=0);
1412     nptr = *nptrerr;
1413     assert(nptr!=NULL);
1414    
1415     if ( GetBaseType(type)== patch_type) {
1416     type = GetPatchOriginal(type);
1417     if (type==NULL) {
1418     return FRC_badname;
1419     }
1420     }
1421     if ( GetBaseType(type) != model_type) {
1422     /* cannot alias subatomic parts, and arrays don't have independent
1423     * typedescs yet.
1424     */
1425     return FRC_attrname;
1426     }
1427     cl = GetChildList(type);
1428     if (cl==NULL) {
1429     /* very wierd case, but then we have very wierd users. */
1430     return FRC_badname;
1431     }
1432     pos = ChildPos(cl,NameIdPtr(nptr));
1433     if (pos == 0) { /* name not found */
1434     return FRC_badname;
1435     }
1436     rtype = ChildBaseTypePtr(cl,pos);
1437     if (rtype == NULL) {
1438     return FRC_badname;
1439     }
1440     if (ChildParametric(cl,pos)!=0) {
1441     return FRC_fail;
1442     }
1443     alen = ChildIsArray(cl,pos);
1444     pnptr = NextIdName(nptr);
1445     if (pnptr==NULL) {
1446     /* end of the dot qualified line */
1447     tnptr = NextName(nptr);
1448     if (tnptr==NULL) {
1449     /* a simple name possibly root of array */
1450     if (alen) {
1451     return FRC_array; /* we don't like array roots */
1452     } else {
1453     *nptrerr=NULL;
1454     return FRC_ok;
1455     }
1456     } else {
1457     /* sub array or array element. */
1458     subseen = 0;
1459     while (tnptr!=pnptr) {
1460     subseen++;
1461     tnptr=NextName(tnptr);
1462     }
1463     subsleft = alen - subseen;
1464     if (subsleft < 0) { /* name not found. too many subscripts. */
1465     return FRC_array;
1466     }
1467     if (subsleft) {
1468     return FRC_array; /* we don't like array roots */
1469     } else {
1470     *nptrerr=NULL;
1471     return FRC_ok;
1472     }
1473     }
1474     }
1475     /* there's more to the name. keep going, after checking that
1476     * all subscripts required are filled.
1477     */
1478     subseen = 0;
1479     tnptr = NextName(nptr);
1480     while (tnptr!=pnptr) {
1481     subseen++;
1482     tnptr=NextName(tnptr);
1483     }
1484     subsleft = alen - subseen;
1485     if (subsleft != 0) {
1486     /* name not found. too many/not enough subscripts. */
1487     return FRC_array;
1488     }
1489     *nptrerr = pnptr;
1490     return AANameIdHasParameterizedPart(nptrerr,rtype);
1491     }
1492    
1493     /*
1494     * This function tries to determine the type of the name given
1495     * based on the childlist in the typedescription given.
1496     * Return value is in accordance with the header for
1497     * FIndRHSType.
1498     * This function will recurse as required.
1499     * The name given may or may not be compound.
1500     * Type must be of a MODEL or patch with a child list.
1501     */
1502     static
1503     CONST struct TypeDescription
1504     *FindChildTypeFromName(CONST struct Name *nptr,
1505     CONST struct TypeDescription *type,
1506     enum e_findrhs *rval,
1507     int *rlen)
1508     {
1509     CONST struct Name *pnptr,*tnptr;
1510     CONST struct TypeDescription *rtype;
1511     ChildListPtr cl;
1512     unsigned long pos;
1513     int alen,subseen,subsleft;
1514    
1515     assert(type!=NULL);
1516     assert(NameId(nptr)!=0);
1517     assert(rval!=NULL);
1518     if ( GetBaseType(type)== patch_type) {
1519     type = GetPatchOriginal(type);
1520     if (type==NULL) {
1521     *rval = FRC_fail;
1522     return NULL;
1523     }
1524     }
1525     if ( GetBaseType(type) != model_type) {
1526     /* cannot alias subatomic parts, and arrays don't have independent
1527     * typedescs yet.
1528     */
1529     *rval = FRC_attrname;
1530     return NULL;
1531     }
1532     cl = GetChildList(type);
1533     if (cl==NULL) {
1534     /* very wierd case, but then we have very wierd users. */
1535     *rval = FRC_badname;
1536     return NULL;
1537     }
1538     pos = ChildPos(cl,NameIdPtr(nptr));
1539     if (pos == 0) { /* name not found */
1540     *rval = FRC_badname;
1541     return NULL;
1542     }
1543     rtype = ChildBaseTypePtr(cl,pos);
1544     if (rtype == NULL) {
1545     /* rhs type not established. will not be later. */
1546     *rval = FRC_fail;
1547     return NULL;
1548     }
1549     alen = ChildIsArray(cl,pos);
1550     pnptr = NextIdName(nptr);
1551     if (pnptr==NULL) {
1552     /* end of the dot qualified line */
1553     tnptr = NextName(nptr);
1554     if (tnptr==NULL) {
1555     /* aliasing a simple name */
1556     *rlen = alen;
1557     if (alen) {
1558     *rval = FRC_array;
1559     } else {
1560     *rval = FRC_ok;
1561     }
1562     } else {
1563     /* aliasing sub array or array element. */
1564     subseen = 0;
1565     while (tnptr!=pnptr) {
1566     subseen++;
1567     tnptr=NextName(tnptr);
1568     }
1569     subsleft = alen - subseen;
1570     if (subsleft < 0) { /* name not found. too many subscripts. */
1571     *rval = FRC_badname;
1572     *rlen = 0;
1573     return NULL;
1574     }
1575     *rlen = subsleft;
1576     if (subsleft) {
1577     *rval = FRC_array;
1578     } else {
1579     *rval = FRC_ok;
1580     }
1581     }
1582     return rtype;
1583     }
1584     /* there's more to the name. keep going, after checking that
1585     * all subscripts required are filled.
1586     */
1587     subseen = 0;
1588     tnptr = NextName(nptr);
1589     while (tnptr!=pnptr) {
1590     subseen++;
1591     tnptr=NextName(tnptr);
1592     }
1593     subsleft = alen - subseen;
1594     if (subsleft != 0) {
1595     /* name not found. too many/not enough subscripts. */
1596     *rlen = 0;
1597     *rval = FRC_badname;
1598     return NULL;
1599     }
1600     return FindChildTypeFromName(pnptr,rtype,rval,rlen);
1601     }
1602    
1603     /*
1604     * This function tries to determine from the RHS name of an
1605     * aliases statement what the type of that name
1606     * is, to a first approximation, and whether it is definitely array.
1607     * Returns NULL if type not found. If not null, *rval will contain
1608     * FRC_ok or FRC_array to communicate arrayness.
1609     *
1610     * There is some ambiguity about arrays because (without finding
1611     * the defining statement which is tricky) we can't know how many
1612     * subscripts there are and hence can't know whether an array name
1613     * points to a final element or to a sub-array.
1614     *
1615     * This function does some preliminary work to digest the rhs part
1616     * name based on the clist given, and then (if required) hands off
1617     * to a routine which determines (if possible) from the existing type tree
1618     * what the type is that goes with the name.
1619     *
1620     * 12/96 Revisions:
1621     * Finds the EXACT ARRAYNESS, not an approximation. FRC_ok only when
1622     * the name resolves to a single array element, OTHERWISE FRC_array.
1623     * If FRC_array, then *rlen will be the number of subscripts left
1624     * unspecified in the name, OTHERWISE rlen should be ignored.
1625     * It does NOT check in a for table. You can't alias dummy vars.
1626     * *origin will be the origin_ flag of the first name element
1627     * (local scope name) if return value is FRC_ok or FRC_array.
1628     * OTHERWISE *origin will be returned as an ERR.
1629     *
1630     * Due to its multiple usages, this function is not well named,
1631     * nor is its behavior particularly simple. Since the CHOICE is
1632     * between overdue and do-over, this is a do-over. The price of
1633     * handling errors in a language which specializes in managing
1634     * anarchy is really quite high.
1635     */
1636     static
1637     CONST struct TypeDescription *FindRHSType(CONST struct Name *nptr,
1638     CONST struct gl_list_t *clist,
1639     enum e_findrhs *rval,
1640     int *rlen,
1641     unsigned int *origin)
1642     {
1643     CONST struct Name *pnptr, *tnptr;
1644     struct ChildListEntry *found;
1645     struct ChildListEntry test;
1646     unsigned long pos;
1647    
1648     *origin = origin_ERR;
1649     /* digest the first part of the name in the local scope */
1650     if (!NameId(nptr)) {
1651     /* names like [1] are obviouslly goop */
1652     *rval = FRC_badname;
1653     return NULL;
1654     }
1655     test.strptr = NameIdPtr(nptr); /* fetch the symchar */
1656     pos = gl_search(clist,&test,(CmpFunc)CmpChildListEntries);
1657     if (pos == 0) {
1658     /* name not found */
1659     *rval = FRC_badname;
1660     return NULL;
1661     }
1662     /* name found. */
1663     found = (struct ChildListEntry *) gl_fetch(clist,pos);
1664     if (found->typeptr == NULL || found->isarray < 0) {
1665     /* rhs type not yet established. try later. */
1666     *rval = FRC_unable;
1667     return NULL;
1668     }
1669     *origin = found->origin;
1670     *rlen = found->isarray;
1671     if (NameLength(nptr) == 1) {
1672     /* local scalar name */
1673     if (found->isarray) {
1674     *rval = FRC_array;
1675     } else {
1676     *rval = FRC_ok;
1677     }
1678     return found->typeptr;
1679     }
1680     /* compound name. could be local or part of part. */
1681     pnptr = NextIdName(nptr);
1682     tnptr = NextName(nptr);
1683     while (tnptr!=pnptr) {
1684     (*rlen)--;
1685     tnptr = NextName(tnptr);
1686     }
1687     if (*rlen < 0) {
1688     *rval = FRC_badname;
1689     return NULL;
1690     }
1691     if (pnptr==NULL) {
1692     if (*rlen > 0) {
1693     *rval = FRC_array;
1694     } else {
1695     *rval = FRC_ok;
1696     }
1697     return found->typeptr;
1698     } else {
1699     if (*rlen > 0) {
1700     /* name is of form a.b where it should be a[k].b; missing subscripts */
1701     *rval = FRC_badname;
1702     return NULL;
1703     }
1704     return FindChildTypeFromName(pnptr,found->typeptr,rval,rlen);
1705     }
1706     }
1707    
1708     /*
1709     * Need to watch out for a.b type names and not mark them?
1710     */
1711     static
1712     void MarkIfPassedArgs(CONST struct Name *nptr, CONST struct gl_list_t *clist)
1713     {
1714     CONST struct Name *pnptr;
1715     struct ChildListEntry *found;
1716     struct ChildListEntry test;
1717     int rlen;
1718     unsigned long pos;
1719    
1720     /* digest the first part of the name in the local scope */
1721     if (!NameId(nptr)) {
1722     /* names like [1] are obviouslly goop */
1723     return;
1724     }
1725     test.strptr = NameIdPtr(nptr); /* fetch the symchar */
1726     pos = gl_search(clist,&test,(CmpFunc)CmpChildListEntries);
1727     if (pos == 0) {
1728     /* name not found */
1729     return;
1730     }
1731     /* name found. */
1732     found = (struct ChildListEntry *) gl_fetch(clist,pos);
1733     rlen = found->isarray;
1734     if (NameLength(nptr) == 1) {
1735     /* local scalar name */
1736     found->bflags |= CBF_PASSED;
1737     return;
1738     }
1739     /* compound name. could be local or part of part. */
1740     pnptr = NextIdName(nptr); /* if a.b, pnptr will be not NULL */
1741     if (pnptr == NULL) {
1742     /* local array name */
1743     found->bflags |= CBF_PASSED;
1744     }
1745     }
1746    
1747     /*
1748     * This function tries to determine from the RHS name list of an
1749     * ALIASES-IS_A statement what the basetype of the array should be.
1750     * to a first approximation, and whether it is a well formed array.
1751     * Doesn't try to ferret out array subscript type (int/sym) mismatches.
1752     * Returns NULL if type not derivable. If not null, *rval will contain
1753     * FRC_ok or FRC_array to communicate arrayness.
1754     *
1755     * Finds the exact arrayness, not an approximation. FRC_ok only when
1756     * the name resolves to a single array element, OTHERWISE FRC_array.
1757     * If FRC_array, then *rlen will be the number of subscripts left
1758     * unspecified in the name, OTHERWISE rlen should be ignored.
1759     * It does NOT check in a for table-- You can't alias dummy vars.
1760     * When return value is FRC_ok or FRC_array
1761     * *origin will be the origin_ARR or origin_PARR
1762     * OTHERWISE *origin should be ignored on return.
1763     * If any of the list is parametric, *origin is origin_PARR.
1764     * This may lead to some incorrect restrictions on the elements of
1765     * the array created from the variablelist given.
1766     */
1767     static
1768     CONST struct TypeDescription *FindCommonType(CONST struct VariableList *vl,
1769     CONST struct gl_list_t *clist,
1770     enum e_findrhs *val,
1771     int *len,
1772     unsigned int *origin)
1773     {
1774     /* return value holders */
1775     CONST struct TypeDescription *rtype=NULL;
1776     enum e_findrhs rval = FRC_fail;
1777     int rlen = -1;
1778     int parametric;
1779    
1780     /* temporaries */
1781     CONST struct Name *nptr;
1782     CONST struct TypeDescription *type;
1783    
1784     while (vl != NULL) {
1785     nptr = NamePointer(vl);
1786     type = FindRHSType(nptr,clist,val,len,origin);
1787     if (type == NULL) {
1788     switch (*val) {
1789     case FRC_ok:
1790     case FRC_array:
1791     /* good FRC codes not seen if type is NULL */
1792     Asc_Panic(2, NULL, "good FRC codes not seen if type is NULL");
1793     break;
1794     case FRC_badname: /* part named is impossible */
1795     case FRC_attrname: /* part named is subatomic and can't be aliased */
1796     TLNM(ASCERR,nptr,"Impossible/subatomic name: ",3);
1797     *val = FRC_fail;
1798     break;
1799     case FRC_unable: /* unable to determine type of rhs, but might later */
1800     break;
1801     case FRC_fail: /* unable to determine type of rhs ever */
1802     TLNM(ASCERR,nptr,"Type indeterminate name: ",3);
1803     *val = FRC_fail;
1804     break;
1805     }
1806     return NULL;
1807     }
1808     /* else we have some type, be it base of array or OTHERWISE */
1809     if (rtype != NULL) {
1810     /* check base type compatibility */
1811     rtype = GreatestCommonAncestor(rtype,type);
1812     if (rtype==NULL) {
1813     TLNM(ASCERR,nptr,"Type incompatible name: ",3);
1814     *val = FRC_fail;
1815     return NULL;
1816     }
1817     /* check arrayness equivalent */
1818     if (*val != rval /* mismatched FRC_ok and FRC_array */ ||
1819     *len != rlen /* mismatched number of subscripts */) {
1820     TLNM(ASCERR,nptr,"Array dimensionally incompatible name: ",3);
1821     *val = FRC_fail;
1822     return NULL;
1823     }
1824     /* modify parametric as needed */
1825     parametric = (ParametricOrigin(*origin) || parametric);
1826     } else {
1827     /* first case */
1828     rtype = type; /* this value may become less refined */
1829     rlen = *len; /* this value will persist to end if successful */
1830     rval = *val; /* this value will persist to end if successful */
1831     parametric = ParametricOrigin(*origin);
1832     }
1833     vl = NextVariableNode(vl);
1834     }
1835     /* go here, so list was compatible in some way. */
1836     if (parametric!=0) {
1837     *origin = origin_PARR;
1838     } else {
1839     *origin = origin_ARR;
1840     }
1841     return rtype;
1842     }
1843    
1844     /*
1845     * This function takes the type given and its array status (in rval)
1846     * and marks all the names from the VariableList found in clist
1847     * as being of that type. Clist is a list of ChildListEntries.
1848     * Marking the type of the same child twice is fatal.
1849     * should only be called with vlists from aliases statements.
1850     */
1851     static
1852     void SetLHSTypes(CONST struct VariableList *vlist,struct gl_list_t *clist,
1853     CONST struct TypeDescription *rtype, enum e_findrhs rval,
1854     int subsopen, unsigned int origin)
1855     {
1856     struct ChildListEntry test;
1857     struct ChildListEntry *clep;
1858     CONST struct Name *nptr;
1859     symchar *name;
1860     unsigned long place;
1861    
1862     (void) rval;
1863     while (vlist!=NULL) {
1864     nptr = NamePointer(vlist);
1865     name = NameIdPtr(nptr);
1866     assert(name!=NULL);
1867     test.strptr = name;
1868     place = gl_search(clist,&test,(CmpFunc)CmpChildListEntries);
1869     assert(place!=0);
1870     clep = (struct ChildListEntry *) gl_fetch(clist,place);
1871     assert(clep->typeptr==NULL);
1872     assert(subsopen >= 0);
1873     assert(origin!=origin_ERR);
1874     assert(clep->origin==origin_ALI || clep->origin==origin_ARR);
1875     assert(clep->isarray < 0);
1876     if (ParametricOrigin(origin)) {
1877     if (clep->origin == origin_ALI) {
1878     clep->origin = origin_PALI;
1879     } else {
1880     clep->origin = origin_PARR;
1881     }
1882     }
1883     clep->typeptr = rtype;
1884     clep->isarray = ABS(clep->isarray + 1) + subsopen;
1885     /* ^^^^^^^^^^ works because of how we init it in DoNameF */
1886     vlist = NextVariableNode(vlist);
1887     }
1888     }
1889    
1890     /*
1891     * This function takes a completed list of child names with
1892     * type information from IS_A and relations and tries to
1893     * derive type information for names defined with aliases
1894     * and in other obscure ways in the list of stats.
1895     *
1896     * This function could be a bit cleverer, but we're not
1897     * going to optimize it until there is some justification.
1898     * Iterates over the list of alii until no more information
1899     * is derivable.
1900     * Before returning whines about unresolvable names, which
1901     * are probably local alias loops.
1902     * Returns the number of whines. required, normally 0.
1903     *
1904     * Needs to track IS_REFINED_TO ARE_THE_SAME and ARE_ALIKE
1905     * where possible, which basically means over complete sets.
1906     */
1907     static
1908     int DeriveChildTypes(struct StatementList *stats, struct gl_list_t *clist)
1909     {
1910     struct AliasList *head, *tmp;
1911     CONST struct TypeDescription *rtype; /* rhs name type */
1912     int changed, whines=0;
1913     enum e_findrhs rval;
1914     int subsopen;
1915     unsigned int origin;
1916    
1917     head = CreateAliasesList(stats);
1918     changed = 1;
1919     while (changed) {
1920     tmp = head;
1921     changed = 0;
1922     while (tmp!=NULL) {
1923     switch(tmp->bits) {
1924     case AL_WAIT:
1925     rtype = FindRHSType(AliasStatName(tmp->stat),clist,
1926     &rval,&subsopen,&origin);
1927     if (rtype != NULL) {
1928     changed = 1;
1929     SetLHSTypes(GetStatVarList(tmp->stat),clist,rtype,
1930     rval,subsopen,origin);
1931     tmp->bits = AL_DONE;
1932     } else {
1933     switch (rval) {
1934     case FRC_badname: /* definitely garbage rhs */
1935     tmp->bits = AL_NORHS;
1936     MarkStatContext(tmp->stat,context_WRONG);
1937     WSEM(ASCERR,tmp->stat,"Impossible RHS of ALIASES");
1938     WSS(ASCERR,tmp->stat);
1939     whines++;
1940     break;
1941     case FRC_attrname: /* ATOM child rhs */
1942     tmp->bits = AL_DONE;
1943     MarkStatContext(tmp->stat,context_WRONG);
1944     WSEM(ASCERR,tmp->stat,"Illegal subatomic RHS of ALIASES");
1945     WSS(ASCERR,tmp->stat);
1946     whines++;
1947     break;
1948     case FRC_fail: /* permanently ambiguous rhs name of part */
1949     WSEM(ASCWAR,tmp->stat,"Unable to determine child basetype");
1950     whines++;
1951     /* shouldn't happen, but symptom of certain screwups */
1952     changed = 1;
1953     tmp->bits = AL_DONE;
1954     break;
1955     case FRC_unable: /* try later */
1956     break;
1957     default:
1958     Asc_Panic(2, NULL, "NOT REACHED should never see other values");
1959     break;
1960     }
1961     }
1962     break;
1963     case AL_WARR:
1964     rtype = FindCommonType(GetStatVarList(tmp->stat),clist,
1965     &rval,&subsopen,&origin);
1966     if (rtype != NULL) {
1967     changed = 1;
1968     SetLHSTypes(ArrayStatAvlNames(tmp->stat),clist,rtype,
1969     rval,subsopen,origin);
1970     tmp->bits = AL_DONE;
1971     } else {
1972     switch (rval) {
1973     case FRC_badname: /* definitely garbage rhs (masked) */
1974     case FRC_attrname: /* ATOM child rhs (masked) */
1975     case FRC_fail: /* permanently confused ALIASES-IS_A */
1976     MarkStatContext(tmp->stat,context_WRONG);
1977     WSEM(ASCWAR,tmp->stat,
1978     "Unable to determine common ancestor type for array elements");
1979     WSS(ASCERR,tmp->stat);
1980     whines++;
1981     /* shouldn't happen, but symptom of certain screwups */
1982     /* such as the user trying to put incompatible stuff in an array */
1983     changed = 1;
1984     tmp->bits = AL_DONE;
1985     break;
1986     case FRC_unable: /* try later */
1987     break;
1988     default:
1989     Asc_Panic(2, NULL, "NOT REACHED should never see other values");
1990     break;
1991     }
1992     }
1993     break;
1994     case AL_DONE:
1995     case AL_NORHS:
1996     break;
1997     }
1998     tmp = tmp->next;
1999     }
2000     }
2001     tmp = head;
2002     while (tmp!=NULL) {
2003     switch (tmp->bits) {
2004     case AL_WAIT:
2005     case AL_WARR:
2006     WSSM(ASCERR,tmp->stat,"Probably involved in recursive ALIASES",3);
2007     whines++;
2008     break;
2009     default:
2010     break;
2011     }
2012     tmp = tmp->next;
2013     }
2014     DestroyAliasesList(head);
2015     return whines;
2016     }
2017    
2018     /*****************************************************************\
2019     End of functions to help determine the types of children
2020     necessitated by aliases.
2021     \*****************************************************************/
2022    
2023     /*****************************************************************\
2024     begin stuff to help refine the types of children
2025     using ARE_ALIKE ARE_THE_SAME IS_REFINED_TO info.
2026     \*****************************************************************/
2027    
2028     /*
2029     * Little function to get the loops surrounding a sparse IS_A, srch.
2030     * Expensive task.
2031     * Recursive. Returns 1 if srch is found in sl or its descendants, 0 if not.
2032     * List returned to topmost caller will be a list of the for loops surround-
2033     * ing srch in reverse (INSIDE-OUT) order.
2034     * srch, sl and loops must all be nonnull on entry.
2035     * In the recursion, nothing gets appended to loops until the
2036     * srch statement is found.
2037     */
2038     static
2039     int GetISALoops(CONST struct Statement *srch,
2040     CONST struct StatementList *sl,
2041     struct gl_list_t *loops)
2042     {
2043     struct Statement *s;
2044     unsigned long c, len;
2045     int ret;
2046     assert(srch!=NULL && sl!=NULL && loops != NULL && StatementType(srch)==ISA);
2047    
2048     len = StatementListLength(sl);
2049     for (c=1;c <= len;c++) {
2050     s = GetStatement(sl,c);
2051     if (s!=NULL) {
2052     if (StatementType(s)==FOR && ForContainsIsa(s)) {
2053     ret = GetISALoops(srch,ForStatStmts(s),loops);
2054     if (ret == 1) {
2055     gl_append_ptr(loops,(VOIDPTR)s);
2056     return 1;
2057     }
2058     }
2059     if (s == srch) return 1;
2060     }
2061     }
2062     return 0;
2063     }
2064    
2065     /* a little alternative forvar that carries the loop definition. */
2066     struct forinfo_t {
2067     symchar *strname;
2068     struct Expr *ex;
2069     };
2070    
2071     /* delete anything sitting in forinfo and return */
2072     static
2073     void ClearForInfo(struct gl_list_t *fl)
2074     {
2075     unsigned long c, len;
2076     if (fl!=NULL) {
2077     len = gl_length(fl);
2078     for (c=len;c>=1;c--) {
2079     gl_delete(fl,c,1);
2080     }
2081     }
2082     }
2083     /* compares forinfo by strnames. NULL > all */
2084     static
2085     int CmpForInfo(struct forinfo_t *f1, struct forinfo_t *f2)
2086     {
2087     if (f1==NULL) return 1;
2088     if (f2==NULL) return -1;
2089     if (f1->strname==NULL) return 1;
2090     if (f2->strname==NULL) return -1;
2091     if (f1->strname==f2->strname) return 0;
2092     return CmpSymchar(f1->strname,f2->strname);
2093     }
2094     static
2095     struct forinfo_t *FindForInfo(struct gl_list_t *forinfo, symchar *name)
2096     {
2097     struct forinfo_t test;
2098     unsigned long pos;
2099     if (name==NULL || forinfo == NULL) {
2100     return NULL;
2101     }
2102     test.strname = name;
2103     pos = gl_search(forinfo,&test,(CmpFunc)CmpForInfo);
2104     if (pos==0L) {
2105     return NULL;
2106     }
2107     return gl_fetch(forinfo,pos);
2108     }
2109     /* add name and ex to info list */
2110     static
2111     void AddForInfo( struct gl_list_t *forinfo,
2112     symchar *name,
2113     struct Expr *ex)
2114     {
2115     struct forinfo_t *i=NULL;
2116     assert(name!=NULL);
2117     assert(ex!=NULL);
2118     i = (struct forinfo_t *)ascmalloc(sizeof(struct forinfo_t));
2119     assert(i!=NULL);
2120     i->strname = name;
2121     i->ex = ex;
2122     gl_append_ptr(forinfo,(VOIDPTR)i);
2123     }
2124     /* delete named entry from list, after finding it */
2125     static
2126     void RemoveForInfo( struct gl_list_t *forinfo, symchar *name)
2127     {
2128     struct forinfo_t test;
2129     unsigned long pos;
2130     test.strname = name;
2131     pos = gl_search(forinfo,&test,(CmpFunc)CmpForInfo);
2132     if (pos==0L) {
2133     FPRINTF(ASCERR,"Nonexistent forinfo %s removed\n",SCP(name));
2134     return;
2135     }
2136     gl_delete(forinfo,pos,1);
2137     }
2138     /*
2139     * takes a local array name n and tries to match the subscripts named
2140     * in it against the declaration of the array via IS_A.
2141     * clep given should correspond to n given.
2142     * Stuff that is aliased will most likely return FALSE negative results.
2143     * Returns 1 if all the elements of the array declared are named in
2144     * the name given. In the case of names containing for loop indices,
2145     * the range of the for is checked in forinfo to see if that matches
2146     * the IS_A.
2147     * Returns 0 if mismatch or too hard to tell.
2148     * Basically, sets must compare exactly in their unevaluated form
2149     * for this work. Some of the twisty sparse array addressings allowed
2150     * in the language may be indecipherable and yield a FALSE negative.
2151     */
2152     static
2153     int AllElementsNamed(struct ChildListEntry *clep,
2154     CONST struct Name *n,
2155     struct gl_list_t *clist,
2156     struct gl_list_t *forinfo,
2157     struct StatementList *pstats)
2158     {
2159     CONST struct Name *decln=NULL; /* name IS_A'd/WILL_BE'd under */
2160     CONST struct VariableList *vl;
2161     struct Set *fset;
2162     struct Set *fsetorig;
2163     CONST struct Expr *sex;
2164     struct forinfo_t *fi;
2165     struct forinfo_t *origfi;
2166     struct gl_list_t *looplist;
2167     struct gl_list_t *loopinfo;
2168     struct Statement *s;
2169     unsigned long c,len;
2170     int killfset=0;
2171     int killfsetorig=0;
2172     int setcomp;
2173    
2174     if (clep == NULL || clep->statement == NULL ||
2175     n==NULL || clist == NULL || forinfo == NULL ||
2176     StatementType(clep->statement) == ALIASES /* alii too hard */ ) {
2177     return 0;
2178     }
2179     /* hunt out the name declared in original IS_A */
2180     vl = GetStatVarList(clep->statement);
2181     while (vl != NULL) {
2182     /* name elements are out of symbol table, so compare by ptr to syms. */
2183     if (NameIdPtr(NamePointer(vl)) == NameIdPtr(n)) {
2184     decln = NamePointer(vl);
2185     break;
2186     }
2187     vl = NextVariableNode(vl);
2188     }
2189     if (decln == NULL || NameLength(decln)!=NameLength(n)) {
2190     /* damned odd! */
2191     return 0;
2192     }
2193     /* ok, so decln is the name we want to match and n is the
2194     * name used in the refinement statement.
2195     * To match sparse IS_REFINED_TO to sparse IS_A properly is
2196     * a second, fairly major case.
2197     */
2198     /* eat array heads */
2199     decln = NextName(decln);
2200     n = NextName(n);
2201     if (StatInFOR(clep->statement) == 0 ) {
2202     /*
2203     * This only works for dense IS_A's.
2204     */
2205     /* do for each subscript */
2206     while (n != NULL) {
2207     /* compare either the for loop expression or the name set of n
2208     * to the set defined in dense decln.
2209     */
2210     if (SetType(NameSetPtr(n))==0 &&
2211     (sex = GetSingleExpr(NameSetPtr(n))) != NULL &&
2212     ExprListLength(sex) == 1 &&
2213     ExprType(sex) == e_var &&
2214     (fi = FindForInfo(forinfo,SimpleNameIdPtr(ExprName(sex)))) != NULL
2215     ) {
2216     /* must be a for index */
2217     if (ExprListLength(fi->ex)!=1 || ExprType(fi->ex) != e_set) {
2218     fset = CreateSingleSet(fi->ex);
2219     killfset = 1;
2220     } else {
2221     fset = ExprSValue(fi->ex);
2222     }
2223     setcomp = CompareSetStructures(fset,NameSetPtr(decln));
2224     if (killfset) {
2225     DestroySetHead(fset);
2226     }
2227     if (setcomp != 0) {
2228     return 0;
2229     }
2230     } else {
2231     if (CompareSetStructures(NameSetPtr(n),NameSetPtr(decln))!=0) {
2232     return 0;
2233     }
2234     }
2235     decln = NextName(decln);
2236     n = NextName(n);
2237     }
2238     } else {
2239     /* sparse IS_A/sparse IS_REFINED_TO */
2240     looplist = gl_create(2L);
2241     if (looplist == NULL) {
2242     return 0;
2243     }
2244     (void)GetISALoops(clep->statement,pstats,looplist);
2245     if (gl_length(looplist)==0L) {
2246     gl_destroy(looplist);
2247     return 0;
2248     } else {
2249     /* convert looplist to forvar info */
2250     loopinfo = gl_create(gl_length(looplist));
2251     if (loopinfo == NULL) {
2252     gl_destroy(looplist);
2253     return 0;
2254     }
2255     len = gl_length(looplist);
2256     for (c=1;c <= len; c++) {
2257     s = (struct Statement *)gl_fetch(looplist,c);
2258     AddForInfo(loopinfo,ForStatIndex(s),ForStatExpr(s));
2259     }
2260     gl_destroy(looplist);
2261     looplist = NULL;
2262     }
2263     /* things to clean up past this point: loopinfo */
2264     /* foreach subscript:
2265     * find index from n in forinfo passed in and get its defining expr.
2266     * find index from decln in looplist and get its defining expr.
2267     * if sets !=, return 0, else cleanup and return 1.
2268     */
2269     while (n != NULL) {
2270     /* compare either the for loop expressions
2271     * to the sets defined in sparse decln.
2272     */
2273     /* must be a simple for index in IS_REFINED_TO/etc. get set
2274     * definitions corresponding to indices.
2275     */
2276     if (SetType(NameSetPtr(n))==0 &&
2277     (sex = GetSingleExpr(NameSetPtr(n))) != NULL &&
2278     ExprListLength(sex) == 1 &&
2279     ExprType(sex) == e_var &&
2280     (fi = FindForInfo(forinfo,SimpleNameIdPtr(ExprName(sex)))) != NULL &&
2281     /* found this statement's set expression */
2282     SetType(NameSetPtr(decln))==0 &&
2283     (sex = GetSingleExpr(NameSetPtr(decln))) != NULL &&
2284     ExprListLength(sex) == 1 &&
2285     ExprType(sex) == e_var &&
2286     (origfi = FindForInfo(loopinfo,SimpleNameIdPtr(ExprName(sex))))!=NULL
2287     /* found original statement's set expression */
2288     ) { /* end of if conditions */
2289     if (ExprListLength(fi->ex)!=1 || ExprType(fi->ex) != e_set) {
2290     fset = CreateSingleSet(fi->ex);
2291     killfset = 1;
2292     } else {
2293     fset = ExprSValue(fi->ex);
2294     }
2295     if (ExprListLength(origfi->ex)!=1 || ExprType(origfi->ex) != e_set) {
2296     fsetorig = CreateSingleSet(origfi->ex);
2297     killfsetorig = 1;
2298     } else {
2299     fsetorig = ExprSValue(origfi->ex);
2300     }
2301     setcomp = CompareSetStructures(fset,fsetorig);
2302     if (killfset) {
2303     DestroySetHead(fset);
2304     }
2305     if (killfsetorig) {
2306     DestroySetHead(fsetorig);
2307     }
2308     if (setcomp != 0) {
2309     ClearForInfo(loopinfo);
2310     gl_destroy(loopinfo);
2311     return 0;
2312     }
2313     } else {
2314     /* clean up. we gave up due to some complexity */
2315     ClearForInfo(loopinfo);
2316     gl_destroy(loopinfo);
2317     return 0;
2318     }
2319     decln = NextName(decln);
2320     n = NextName(n);
2321     }
2322     ClearForInfo(loopinfo);
2323     gl_destroy(loopinfo);
2324     }
2325     return 1;
2326     }
2327    
2328     /*
2329     * not that forinfo is NOT a forvar table; it should be a supplied,
2330     * empty gllist from the initial caller.
2331     * it will be returned empty and of no consequence to the initial
2332     * caller.
2333     * It should handle ARE_ALIKE/ARE_THE_SAME but so far only IS_REFINED_TO.
2334     * Recursive function.
2335     * When ascend code is well written, the current implementation
2336     * is sufficient to shut up all undefined name whines. code that
2337     * still whines is POORLY modeled.
2338     */
2339     static int g_drt_depth=0; /* depth in this function, for bookkeeping. */
2340     static
2341     enum typelinterr DeriveRefinedTypes(struct StatementList *stats,
2342     struct gl_list_t *clist,
2343     struct gl_list_t *forinfo,
2344     struct StatementList *pstats
2345     )
2346     {
2347     struct Statement *s;
2348     /* rhs type of IS_REFINED_TO statement */
2349     symchar *rname;
2350     CONST struct TypeDescription *rdesc;
2351     /* lhs member type from IS_REFINED_TO statement */
2352     CONST struct TypeDescription *d;
2353     CONST struct VariableList *vl;
2354     CONST struct Name *n;
2355     unsigned long c,len,pos;
2356     unsigned int origin;
2357     int subsopen;
2358     enum e_findrhs rval;
2359     enum typelinterr error_code;
2360     struct ChildListEntry test;
2361     struct ChildListEntry *clep;
2362    
2363     assert(clist !=NULL);
2364     assert(forinfo !=NULL);
2365    
2366     len = StatementListLength(stats);
2367     for (c = 1; c <= len; c++) {
2368     s = GetStatement(stats,c);
2369     switch (StatementType(s)) {
2370     case IRT:
2371     if (StatInSELECT(s)) { /* Ignore refinements inside SELECT */
2372     break;
2373     }
2374     rname = GetStatType(s); /* sets do not get refined, so don't check */
2375     rdesc = FindType(rname);
2376     assert(rdesc!=NULL);
2377     vl = GetStatVarList(s);
2378     while (vl!=NULL) {
2379     n = NamePointer(vl);
2380     if (NameCompound(n)==0) { /* only care if local, nonsubatomic */
2381     d = FindRHSType(n,clist,&rval,&subsopen,&origin);
2382     if (d==NULL ||
2383     MoreRefined(d,rdesc)==NULL ||
2384     subsopen > 0) {
2385     if (d!=NULL && subsopen>0) {
2386     FPRINTF(ASCERR,
2387     "%sRefinement can only be done on array elements.\n",
2388     StatioLabel(3));
2389     }
2390     FPRINTF(ASCERR,"%sIncompatible type (%s) of LHS name: ",
2391     StatioLabel(3),
2392     (d!=NULL)?SCP(GetName(d)):"UNDEFINED");
2393     WriteName(ASCERR,n);
2394     FPRINTF(ASCERR,"\n");
2395     error_code = DEF_ILLEGAL_REFINE;
2396     TypeLintError(ASCERR,s, error_code);
2397     if (!g_drt_depth) {
2398     ClearForInfo(forinfo);
2399     }
2400     return error_code;
2401     }
2402     /* so we know d compatible. The question is can we
2403     * upgrade the CLE of local n or not?
2404     * yes if scalar or if all elements of array are
2405     * upgraded together.
2406     */
2407     if (d!=rdesc) {
2408     test.strptr = NameIdPtr(n);
2409     pos = gl_search(clist,&test,(CmpFunc)CmpChildListEntries);
2410     assert(pos!=0L);
2411     clep = (struct ChildListEntry *)gl_fetch(clist,pos);
2412     if (SimpleNameIdPtr(n) != NULL ||
2413     AllElementsNamed(clep,n,clist,forinfo,pstats)==1) {
2414     clep->typeptr = MoreRefined(d,rdesc);
2415     }
2416     }
2417     }
2418     vl = NextVariableNode(vl);
2419     }
2420     break;
2421     case FOR:
2422     g_drt_depth++;
2423     AddForInfo(forinfo,ForStatIndex(s),ForStatExpr(s));
2424     error_code = DeriveRefinedTypes(ForStatStmts(s),clist,forinfo,pstats);
2425     RemoveForInfo(forinfo,ForStatIndex(s));
2426     g_drt_depth--;
2427     if (error_code != DEF_OKAY) {
2428     if (!g_drt_depth) {
2429     ClearForInfo(forinfo);
2430     }
2431     return error_code;
2432     }
2433     break;
2434     case AA:
2435     /* if we were clever, do something here using LCLE info */
2436     break;
2437     case ATS:
2438     /* if we were clever, do something here using LCLE info */
2439     break;
2440     case SELECT:
2441     case COND:
2442     /* if we were clever, do something here using LCLE info maybe */
2443     break;
2444     default:
2445     break;
2446     }
2447     }
2448    
2449     if (!g_drt_depth) {
2450     ClearForInfo(forinfo);
2451     }
2452     return DEF_OKAY;
2453     }
2454     /*****************************************************************\
2455     End of functions to help refine the types of children
2456     necessitated by ARE_ALIKE IS_REFINED_TO ARE_THE_SAME.
2457     \*****************************************************************/
2458    
2459     /*** stuff for defining parameterized models and models in general ***/
2460    
2461     /* if any name in the set given is not defined in lcl,
2462     * returns 0, OTHERWISE 1.
2463     * Checks base type of name, which must symbol/integer/set constants
2464     */
2465     static
2466     int SetNamesInLCL(CONST struct Set *sn)
2467     {
2468     struct gl_list_t *nl;
2469     struct gl_list_t *lclgl;
2470     CONST struct TypeDescription *rtype;
2471     CONST struct Name *n;
2472     enum e_findrhs rval;
2473     unsigned long c,len;
2474     int subsopen; /* must never come back anything but zero */
2475     unsigned int origin; /* ignored */
2476    
2477     assert(sn!=NULL);
2478    
2479     nl = SetNameList(sn);
2480     lclgl = CopyLCLToGL(); /* we want a peek at the lcl in progress */
2481     len = gl_length(nl);
2482     for (c = 1; c <= len; c++) {
2483     n = (CONST struct Name *)gl_fetch(nl,c);
2484     /* check forvars here first in future. tempvars would be tricky,
2485     * except SetNameList doesn't return tempvars because
2486     * EvaluateNamesNeeded doesn't report those (we hope).
2487     */
2488     /* not in forvars, so check declarations */
2489     rtype = FindRHSType(n,lclgl,&rval,&subsopen,&origin);
2490     if (rtype==NULL || rval != FRC_ok /* can't compute on arrays */||
2491     (GetBaseType(rtype) != integer_constant_type &&
2492     GetBaseType(rtype) != symbol_constant_type &&
2493     GetBaseType(rtype) != set_type)
2494     ) {
2495     gl_destroy(lclgl);
2496     gl_destroy(nl);
2497     return 0;
2498     }
2499     }
2500     gl_destroy(lclgl);
2501     gl_destroy(nl);
2502     return 1;
2503     }
2504    
2505     /*
2506     * checks that lhs of := (declarative) are variables.
2507     * checks that lhs of :== are constants and not of parametric origin.
2508     * checks that rhs of :== are constants.
2509     * checks that come up totally missing are morphed to defokay because
2510     * of the chance that refinement is biting us.
2511     */
2512     static
2513     enum typelinterr VerifyDefsAsgns(symchar *name,
2514     CONST struct StatementList *stats,
2515     struct gl_list_t *lclgl,
2516     struct gl_list_t *ft)
2517     {
2518     register struct gl_list_t *statements;
2519     register unsigned long c,len;
2520     register unsigned long nc,nlen;
2521     CONST struct TypeDescription *rtype;
2522     struct Statement *stat;
2523     CONST struct Name *nptr;
2524     struct gl_list_t *nl=NULL;
2525     enum e_findrhs rval;
2526     int subsopen;
2527     unsigned int origin;
2528     enum typelinterr error_code=DEF_OKAY;
2529    
2530     statements = GetList(stats);
2531     len = gl_length(statements);
2532     for (c = 1; c <= len; c++) {
2533     stat = (struct Statement *)gl_fetch(statements,c);
2534     switch(StatementType(stat)){
2535     case ASGN:
2536     nptr = DefaultStatVar(stat);
2537     rtype = FindRHSType(nptr,lclgl,&rval,&subsopen,&origin);
2538     if ( rtype == NULL ) {
2539     if (rval != FRC_attrname) {
2540     char *iostring;
2541     error_code = DEF_ASGN_INCORRECT;
2542     iostring = (char *)ascmalloc(6+SCLEN(name));
2543     sprintf(iostring,"In %s:\n",SCP(name));
2544     TypeLintErrorAuxillary(ASCERR,iostring,DEF_MISC_WARNING,TRUE);
2545     ascfree(iostring);
2546     TypeLintError(ASCERR,stat, error_code);
2547     error_code = DEF_OKAY;
2548     } /* else assignment to subatomic part. style bitch. */
2549     break;
2550     }
2551     if (rval != FRC_ok /* must be scalar */ ||
2552     BaseTypeIsAtomic(rtype) == 0 /* must be variable */ ||
2553     BaseTypeIsSet(rtype) != 0
2554     ) {
2555     error_code = DEF_ASGN_INCORRECT;
2556     TypeLintError(ASCERR,stat, error_code);
2557     return error_code;
2558     }
2559     /* check rhs expr */
2560     nl = EvaluateNamesNeeded(DefaultStatRHS(stat),NULL,nl);
2561     nlen = gl_length(nl);
2562     for (nc=1;nc<=nlen;nc++) {
2563     nptr = (struct Name *)gl_fetch(nl,nc);
2564     if (NameInForTable(ft,nptr)) {
2565     continue;
2566     }
2567     rtype = FindRHSType(nptr,lclgl,&rval,&subsopen,&origin);
2568     if (rtype==NULL) {
2569     if (rval != FRC_attrname) {
2570     char *iostring;
2571     TLNM(ASCERR,nptr,"Unverifiable name in RHS: ",2);
2572     error_code = DEF_NAME_MISSING;
2573     iostring = (char *)ascmalloc(6+SCLEN(name));
2574     sprintf(iostring,"In %s:\n",SCP(name));
2575     TypeLintErrorAuxillary(ASCERR,iostring,DEF_MISC_WARNING,TRUE);
2576     TypeLintError(ASCERR,stat, error_code);
2577     ascfree(iostring);
2578     error_code = DEF_OKAY;
2579     /* here it would be nice if we could punt, but refinement
2580     * rules that out since the name might be valid and we not know.
2581     */
2582     }
2583     continue;
2584     }
2585     if ( rval != FRC_ok /* arrays not evaluatable */ ||
2586     (BaseTypeIsAtomic(rtype) == 0 && BaseTypeIsConstant(rtype)==0)
2587     ) {
2588     TLNM(ASCERR,nptr,"Improper non-scalar in RHS: ",3);
2589     gl_destroy(nl);
2590     error_code = DEF_ILLEGAL_ASGN;
2591     TypeLintError(ASCERR,stat, error_code);
2592     return error_code;
2593     }
2594     }
2595     gl_destroy(nl);
2596     nl = NULL;
2597     break;
2598     case CASGN:
2599     nptr = AssignStatVar(stat);
2600     rtype = FindRHSType(nptr,lclgl,&rval,&subsopen,&origin);
2601     if (rtype == NULL) {
2602     char *iostring;
2603     error_code = DEF_CASGN_INCORRECT;
2604     iostring = (char *)ascmalloc(6+SCLEN(name));
2605     sprintf(iostring,"In %s:\n",SCP(name));
2606     TypeLintErrorAuxillary(ASCERR,iostring,DEF_MISC_WARNING,TRUE);
2607     TypeLintError(ASCERR,stat, error_code);
2608     ascfree(iostring);
2609     error_code = DEF_OKAY;
2610     origin = origin_ISA;
2611     /* this will never be reached for a parameter list object. this safe */
2612     } else {
2613     if (rval != FRC_ok /* must be scalar */ ||
2614     (BaseTypeIsConstant(rtype) ==0 && BaseTypeIsSet(rtype)==0)
2615     ) {
2616     error_code = DEF_CASGN_INCORRECT;
2617     TypeLintError(ASCERR,stat, error_code);
2618     return error_code;
2619     }
2620     }
2621     if (ParametricOrigin(origin)) {
2622     error_code = DEF_PARAM_MODIFIED;
2623     TLNNM(ASCERR,nptr,"Parameter modified: ",3);
2624     TypeLintError(ASCERR,stat, error_code);
2625     return error_code;
2626     }
2627     nl = EvaluateNamesNeeded(AssignStatRHS(stat),NULL,nl);
2628     nlen = gl_length(nl);
2629     for (nc=1;nc<=nlen;nc++) {
2630     nptr = (struct Name *)gl_fetch(nl,nc);
2631     if (NameInForTable(ft,nptr)) {
2632     continue;
2633     }
2634     rtype = FindRHSType(nptr,lclgl,&rval,&subsopen,&origin);
2635     if (rtype==NULL) {
2636     char *iostring;
2637     TLNM(ASCERR,nptr,"Unverifiable name in :== RHS: ",2);
2638     error_code = DEF_NAME_MISSING;
2639     iostring = (char *)ascmalloc(6+SCLEN(name));
2640     sprintf(iostring,"In %s:\n",SCP(name));
2641     TypeLintErrorAuxillary(ASCERR,iostring,DEF_MISC_WARNING,TRUE);
2642     ascfree(iostring);
2643     TypeLintError(ASCERR,stat, error_code);
2644     error_code = DEF_OKAY;
2645     /* here it would be nice if we could punt, but refinement
2646     * rules that out since the name might be valid and we not know.
2647     */
2648     } else {
2649     if ( rval != FRC_ok /* arrays not evaluatable */ ||
2650     (BaseTypeIsSet(rtype) == 0 && BaseTypeIsConstant(rtype)==0)
2651     ) {
2652     TLNM(ASCERR,nptr,"Improper non-constant in RHS: ",3);
2653     gl_destroy(nl);
2654     error_code = DEF_ILLEGAL_CASGN;
2655     TypeLintError(ASCERR,stat, error_code);
2656     return error_code;
2657     }
2658     }
2659     }
2660     gl_destroy(nl);
2661     nl = NULL;
2662     break;
2663     case FOR:
2664     AddLoopVariable(ft,CreateForVar(ForStatIndex(stat)));
2665     error_code = VerifyDefsAsgns(name,ForStatStmts(stat),lclgl,ft);
2666     RemoveForVariable(ft);
2667     if (error_code != DEF_OKAY){
2668     return error_code;
2669     }
2670     break;
2671     case COND:
2672     error_code = VerifyDefsAsgns(name,CondStatList(stat),lclgl,ft);
2673     if (error_code != DEF_OKAY){
2674     return error_code;
2675     }
2676     break;
2677     case SELECT:
2678     /* statements inside SELECT are analyzed as part of the flat
2679     list of statements */
2680     break;
2681     default: /* LREL REL, ASGN, RUN, IF, EXT, REF ISA WHEN too. */
2682     break;
2683     }
2684     }
2685     return DEF_OKAY;
2686     }
2687    
2688     /*
2689     * Insures that all IS_REFINED_TO/ARE_ALIKE/ARE_THE_SAME do
2690     * not change anything passed in. Fascistically.
2691     * Complains about errors found, so caller needn't.
2692     * Also ought to in general check that all lhs/varlist entries exist,
2693     * but doesn't -- only checks shallowly.
2694     *
2695     * Should as a side effect upgrade base types of children where
2696     * this is determinable (ie in the case of arrays, must be over all children).
2697     *
2698     * Also checks that ATS statements do not merge illegal types.
2699     */
2700     static
2701     enum typelinterr VerifyRefinementLegal(CONST struct StatementList *stats,
2702     struct gl_list_t *lclgl)
2703     {
2704     register unsigned long c,len,pos;
2705     register struct gl_list_t *statements;
2706     CONST struct VariableList *vl;
2707     struct Statement *stat;
2708     CONST struct Name *nptr;
2709     struct ChildListEntry *clep;
2710     CONST struct TypeDescription *aatype, *atstype;
2711     enum typelinterr error_code=DEF_OKAY;
2712     enum e_findrhs rval;
2713     unsigned int origin;
2714     int subsopen;
2715     struct ChildListEntry test;
2716    
2717     statements = GetList(stats);
2718     len = gl_length(statements);
2719     for (c = 1; c <= len; c++) {
2720     stat = (struct Statement *)gl_fetch(statements,c);
2721     switch(StatementType(stat)){
2722     case ATS:
2723     case AA:
2724     case IRT:
2725     vl = GetStatVarList(stat);
2726     while (vl != NULL) {
2727     /* shallow check that parameters are not being modified */
2728     nptr = NamePointer(vl);
2729