Adjust the C++ preprocessor to include /usr/include/c++ by default for
[dragonfly.git] / contrib / gcc / f / stu.c
1 /* stu.c -- Implementation File (module.c template V1.0)
2    Copyright (C) 1995-1997 Free Software Foundation, Inc.
3    Contributed by James Craig Burley.
4
5 This file is part of GNU Fortran.
6
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING.  If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
20 02111-1307, USA.
21
22 */
23
24 /* Include files. */
25
26 #include "proj.h"
27 #include "bld.h"
28 #include "com.h"
29 #include "equiv.h"
30 #include "global.h"
31 #include "info.h"
32 #include "implic.h"
33 #include "intrin.h"
34 #include "stu.h"
35 #include "storag.h"
36 #include "sta.h"
37 #include "symbol.h"
38 #include "target.h"
39
40 /* Externals defined here. */
41
42
43 /* Simple definitions and enumerations. */
44
45
46 /* Internal typedefs. */
47
48
49 /* Private include files. */
50
51
52 /* Internal structure definitions. */
53
54
55 /* Static objects accessed by functions in this module. */
56
57
58 /* Static functions (internal). */
59
60 static void ffestu_list_exec_transition_ (ffebld list);
61 static bool ffestu_symter_end_transition_ (ffebld expr);
62 static bool ffestu_symter_exec_transition_ (ffebld expr);
63 static bool ffestu_dummies_transition_ (ffesymbol (*symfunc) (ffesymbol),
64                                         ffebld list);
65
66 /* Internal macros. */
67
68 #define ffestu_equiv_(s) (((ffesymbol_equiv (s) == NULL)                      \
69   || (ffeequiv_common (ffesymbol_equiv (s)) == NULL)) ? FFEINFO_whereLOCAL    \
70   : FFEINFO_whereCOMMON)
71 \f
72 /* Update symbol info just before end of unit.  */
73
74 ffesymbol
75 ffestu_sym_end_transition (ffesymbol s)
76 {
77   ffeinfoKind skd;
78   ffeinfoWhere swh;
79   ffeinfoKind nkd;
80   ffeinfoWhere nwh;
81   ffesymbolAttrs sa;
82   ffesymbolAttrs na;
83   ffesymbolState ss;
84   ffesymbolState ns;
85   bool needs_type = TRUE;       /* Implicit type assignment might be
86                                    necessary. */
87
88   assert (s != NULL);
89   ss = ffesymbol_state (s);
90   sa = ffesymbol_attrs (s);
91   skd = ffesymbol_kind (s);
92   swh = ffesymbol_where (s);
93
94   switch (ss)
95     {
96     case FFESYMBOL_stateUNCERTAIN:
97       if ((swh == FFEINFO_whereDUMMY)
98           && (ffesymbol_numentries (s) == 0))
99         {                       /* Not actually in any dummy list! */
100           ffesymbol_error (s, ffesta_tokens[0]);
101           return s;
102         }
103       else if (((swh == FFEINFO_whereLOCAL)
104                 || (swh == FFEINFO_whereNONE))
105                && (skd == FFEINFO_kindENTITY)
106                && ffestu_symter_end_transition_ (ffesymbol_dims (s)))
107         {                       /* Bad dimension expressions. */
108           ffesymbol_error (s, NULL);
109           return s;
110         }
111       break;
112
113     case FFESYMBOL_stateUNDERSTOOD:
114       if ((swh == FFEINFO_whereLOCAL)
115           && ((skd == FFEINFO_kindFUNCTION)
116               || (skd == FFEINFO_kindSUBROUTINE)))
117         {
118           int n_args;
119           ffebld list;
120           ffebld item;
121           ffeglobalArgSummary as;
122           ffeinfoBasictype bt;
123           ffeinfoKindtype kt;
124           bool array;
125           const char *name = NULL;
126
127           ffestu_dummies_transition_ (ffecom_sym_end_transition,
128                                       ffesymbol_dummyargs (s));
129
130           n_args = ffebld_list_length (ffesymbol_dummyargs (s));
131           ffeglobal_proc_def_nargs (s, n_args);
132           for (list = ffesymbol_dummyargs (s), n_args = 0;
133                list != NULL;
134                list = ffebld_trail (list), ++n_args)
135             {
136               item = ffebld_head (list);
137               array = FALSE;
138               if (item != NULL)
139                 {
140                   bt = ffeinfo_basictype (ffebld_info (item));
141                   kt = ffeinfo_kindtype (ffebld_info (item));
142                   array = (ffeinfo_rank (ffebld_info (item)) > 0);
143                   switch (ffebld_op (item))
144                     {
145                     case FFEBLD_opSTAR:
146                       as = FFEGLOBAL_argsummaryALTRTN;
147                       break;
148
149                     case FFEBLD_opSYMTER:
150                       name = ffesymbol_text (ffebld_symter (item));
151                       as = FFEGLOBAL_argsummaryNONE;
152
153                       switch (ffeinfo_kind (ffebld_info (item)))
154                         {
155                         case FFEINFO_kindFUNCTION:
156                           as = FFEGLOBAL_argsummaryFUNC;
157                           break;
158
159                         case FFEINFO_kindSUBROUTINE:
160                           as = FFEGLOBAL_argsummarySUBR;
161                           break;
162
163                         case FFEINFO_kindNONE:
164                           as = FFEGLOBAL_argsummaryPROC;
165                           break;
166
167                         default:
168                           break;
169                         }
170
171                       if (as != FFEGLOBAL_argsummaryNONE)
172                         break;
173
174                       /* Fall through.  */
175                     default:
176                       if (bt == FFEINFO_basictypeCHARACTER)
177                         as = FFEGLOBAL_argsummaryDESCR;
178                       else
179                         as = FFEGLOBAL_argsummaryREF;
180                       break;
181                     }
182                 }
183               else
184                 {
185                   as = FFEGLOBAL_argsummaryNONE;
186                   bt = FFEINFO_basictypeNONE;
187                   kt = FFEINFO_kindtypeNONE;
188                 }
189               ffeglobal_proc_def_arg (s, n_args, name, as, bt, kt, array);
190             }
191         }
192       else if (swh == FFEINFO_whereDUMMY)
193         {
194           if (ffesymbol_numentries (s) == 0)
195             {                   /* Not actually in any dummy list! */
196               ffesymbol_error (s, ffesta_tokens[0]);
197               return s;
198             }
199           if (ffestu_symter_end_transition_ (ffesymbol_dims (s)))
200             {                   /* Bad dimension expressions. */
201               ffesymbol_error (s, NULL);
202               return s;
203             }
204         }
205       else if ((swh == FFEINFO_whereLOCAL)
206                && ffestu_symter_end_transition_ (ffesymbol_dims (s)))
207         {                       /* Bad dimension expressions. */
208           ffesymbol_error (s, NULL);
209           return s;
210         }
211
212       ffestorag_end_layout (s);
213       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
214       return s;
215
216     default:
217       assert ("bad status" == NULL);
218       return s;
219     }
220
221   ns = FFESYMBOL_stateUNDERSTOOD;
222   na = sa = ffesymbol_attrs (s);
223
224   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
225                    | FFESYMBOL_attrsADJUSTABLE
226                    | FFESYMBOL_attrsANYLEN
227                    | FFESYMBOL_attrsARRAY
228                    | FFESYMBOL_attrsDUMMY
229                    | FFESYMBOL_attrsEXTERNAL
230                    | FFESYMBOL_attrsSFARG
231                    | FFESYMBOL_attrsTYPE)));
232
233   nkd = skd;
234   nwh = swh;
235
236   /* Figure out what kind of object we've got based on previous declarations
237      of or references to the object. */
238
239   if (sa & FFESYMBOL_attrsEXTERNAL)
240     {
241       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
242                        | FFESYMBOL_attrsDUMMY
243                        | FFESYMBOL_attrsEXTERNAL
244                        | FFESYMBOL_attrsTYPE)));
245
246       if (sa & FFESYMBOL_attrsTYPE)
247         nwh = FFEINFO_whereGLOBAL;
248       else
249         /* Not TYPE. */
250         {
251           if (sa & FFESYMBOL_attrsDUMMY)
252             {                   /* Not TYPE. */
253               ns = FFESYMBOL_stateUNCERTAIN;    /* FUNCTION/SUBROUTINE. */
254               needs_type = FALSE;       /* Don't assign type to SUBROUTINE! */
255             }
256           else if (sa & FFESYMBOL_attrsACTUALARG)
257             {                   /* Not DUMMY or TYPE. */
258               ns = FFESYMBOL_stateUNCERTAIN;    /* FUNCTION/SUBROUTINE. */
259               needs_type = FALSE;       /* Don't assign type to SUBROUTINE! */
260             }
261           else
262             /* Not ACTUALARG, DUMMY, or TYPE. */
263             {                   /* This is an assumption, essentially. */
264               nkd = FFEINFO_kindBLOCKDATA;
265               nwh = FFEINFO_whereGLOBAL;
266               needs_type = FALSE;
267             }
268         }
269     }
270   else if (sa & FFESYMBOL_attrsDUMMY)
271     {
272       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
273       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
274                        | FFESYMBOL_attrsEXTERNAL
275                        | FFESYMBOL_attrsTYPE)));
276
277       /* Honestly, this appears to be a guess.  I can't find anyplace in the
278          standard that makes clear whether this unreferenced dummy argument
279          is an ENTITY or a FUNCTION.  And yet, for the f2c interface, picking
280          one is critical for CHARACTER entities because it determines whether
281          to expect an additional argument specifying the length of an ENTITY
282          that is not expected (or needed) for a FUNCTION.  HOWEVER, F90 makes
283          this guess a correct one, and it does seem that the Section 18 Notes
284          in Appendix B of F77 make it clear the F77 standard at least
285          intended to make this guess correct as well, so this seems ok.  */
286
287       nkd = FFEINFO_kindENTITY;
288     }
289   else if (sa & FFESYMBOL_attrsARRAY)
290     {
291       assert (!(sa & ~(FFESYMBOL_attrsARRAY
292                        | FFESYMBOL_attrsADJUSTABLE
293                        | FFESYMBOL_attrsTYPE)));
294
295       if (ffestu_symter_end_transition_ (ffesymbol_dims (s)))
296         {
297           ffesymbol_error (s, NULL);
298           return s;
299         }
300
301       if (sa & FFESYMBOL_attrsADJUSTABLE)
302         {                       /* Not actually in any dummy list! */
303           if (ffe_is_pedantic ()
304               && ffebad_start_msg ("Local adjustable symbol `%A' at %0",
305                                    FFEBAD_severityPEDANTIC))
306             {
307               ffebad_string (ffesymbol_text (s));
308               ffebad_here (0, ffesymbol_where_line (s),
309                            ffesymbol_where_column (s));
310               ffebad_finish ();
311             }
312         }
313       nwh = FFEINFO_whereLOCAL;
314     }
315   else if (sa & FFESYMBOL_attrsSFARG)
316     {
317       assert (!(sa & ~(FFESYMBOL_attrsSFARG
318                        | FFESYMBOL_attrsTYPE)));
319
320       nwh = FFEINFO_whereLOCAL;
321     }
322   else if (sa & FFESYMBOL_attrsTYPE)
323     {
324       assert (!(sa & (FFESYMBOL_attrsARRAY
325                       | FFESYMBOL_attrsDUMMY
326                       | FFESYMBOL_attrsEXTERNAL
327                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
328       assert (!(sa & ~(FFESYMBOL_attrsTYPE
329                        | FFESYMBOL_attrsADJUSTABLE
330                        | FFESYMBOL_attrsANYLEN
331                        | FFESYMBOL_attrsARRAY
332                        | FFESYMBOL_attrsDUMMY
333                        | FFESYMBOL_attrsEXTERNAL
334                        | FFESYMBOL_attrsSFARG)));
335
336       if (sa & FFESYMBOL_attrsANYLEN)
337         {                       /* Can't touch this. */
338           ffesymbol_signal_change (s);
339           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
340           ffesymbol_resolve_intrin (s);
341           s = ffecom_sym_learned (s);
342           ffesymbol_reference (s, NULL, FALSE);
343           ffestorag_end_layout (s);
344           ffesymbol_signal_unreported (s);      /* For debugging purposes. */
345           return s;
346         }
347
348       nkd = FFEINFO_kindENTITY;
349       nwh = FFEINFO_whereLOCAL;
350     }
351   else
352     assert ("unexpected attribute set" == NULL);
353
354   /* Now see what we've got for a new object: NONE means a new error cropped
355      up; ANY means an old error to be ignored; otherwise, everything's ok,
356      update the object (symbol) and continue on. */
357
358   if (na == FFESYMBOL_attrsetNONE)
359     ffesymbol_error (s, ffesta_tokens[0]);
360   else if (!(na & FFESYMBOL_attrsANY))
361     {
362       ffesymbol_signal_change (s);
363       ffesymbol_set_attrs (s, na);      /* Establish new info. */
364       ffesymbol_set_state (s, ns);
365       ffesymbol_set_info (s,
366                           ffeinfo_new (ffesymbol_basictype (s),
367                                        ffesymbol_kindtype (s),
368                                        ffesymbol_rank (s),
369                                        nkd,
370                                        nwh,
371                                        ffesymbol_size (s)));
372       if (needs_type && !ffeimplic_establish_symbol (s))
373         ffesymbol_error (s, ffesta_tokens[0]);
374       else
375         ffesymbol_resolve_intrin (s);
376       s = ffecom_sym_learned (s);
377       ffesymbol_reference (s, NULL, FALSE);
378       ffestorag_end_layout (s);
379       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
380     }
381
382   return s;
383 }
384
385 /* ffestu_sym_exec_transition -- Update symbol just before first exec stmt
386
387    ffesymbol s;
388    ffestu_sym_exec_transition(s);  */
389
390 ffesymbol
391 ffestu_sym_exec_transition (ffesymbol s)
392 {
393   ffeinfoKind skd;
394   ffeinfoWhere swh;
395   ffeinfoKind nkd;
396   ffeinfoWhere nwh;
397   ffesymbolAttrs sa;
398   ffesymbolAttrs na;
399   ffesymbolState ss;
400   ffesymbolState ns;
401   ffeintrinGen gen;
402   ffeintrinSpec spec;
403   ffeintrinImp imp;
404   bool needs_type = TRUE;       /* Implicit type assignment might be
405                                    necessary. */
406   bool resolve_intrin = TRUE;   /* Might need to resolve intrinsic. */
407
408   assert (s != NULL);
409
410   sa = ffesymbol_attrs (s);
411   skd = ffesymbol_kind (s);
412   swh = ffesymbol_where (s);
413   ss = ffesymbol_state (s);
414
415   switch (ss)
416     {
417     case FFESYMBOL_stateNONE:
418       return s;                 /* Assume caller will handle it. */
419
420     case FFESYMBOL_stateSEEN:
421       break;
422
423     case FFESYMBOL_stateUNCERTAIN:
424       ffestorag_exec_layout (s);
425       return s;                 /* Already processed this one, or not
426                                    necessary. */
427
428     case FFESYMBOL_stateUNDERSTOOD:
429       if (skd == FFEINFO_kindNAMELIST)
430         {
431           ffebld_end_list (ffesymbol_ptr_to_listbottom (s));
432           ffestu_list_exec_transition_ (ffesymbol_namelist (s));
433         }
434       else if ((swh == FFEINFO_whereLOCAL)
435                && ((skd == FFEINFO_kindFUNCTION)
436                    || (skd == FFEINFO_kindSUBROUTINE)))
437         {
438           ffestu_dummies_transition_ (ffecom_sym_exec_transition,
439                                       ffesymbol_dummyargs (s));
440           if ((skd == FFEINFO_kindFUNCTION)
441               && !ffeimplic_establish_symbol (s))
442             ffesymbol_error (s, ffesta_tokens[0]);
443         }
444
445       ffesymbol_reference (s, NULL, FALSE);
446       ffestorag_exec_layout (s);
447       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
448       return s;
449
450     default:
451       assert ("bad status" == NULL);
452       return s;
453     }
454
455   ns = FFESYMBOL_stateUNDERSTOOD;       /* Only a few UNCERTAIN exceptions. */
456
457   na = sa;
458   nkd = skd;
459   nwh = swh;
460
461   assert (!(sa & FFESYMBOL_attrsANY));
462
463   if (sa & FFESYMBOL_attrsCOMMON)
464     {
465       assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
466                        | FFESYMBOL_attrsARRAY
467                        | FFESYMBOL_attrsCOMMON
468                        | FFESYMBOL_attrsEQUIV
469                        | FFESYMBOL_attrsINIT
470                        | FFESYMBOL_attrsNAMELIST
471                        | FFESYMBOL_attrsSFARG
472                        | FFESYMBOL_attrsTYPE)));
473
474       nkd = FFEINFO_kindENTITY;
475       nwh = FFEINFO_whereCOMMON;
476     }
477   else if (sa & FFESYMBOL_attrsRESULT)
478     {                           /* Result variable for function. */
479       assert (!(sa & ~(FFESYMBOL_attrsANYLEN
480                        | FFESYMBOL_attrsRESULT
481                        | FFESYMBOL_attrsSFARG
482                        | FFESYMBOL_attrsTYPE)));
483
484       nkd = FFEINFO_kindENTITY;
485       nwh = FFEINFO_whereRESULT;
486     }
487   else if (sa & FFESYMBOL_attrsSFUNC)
488     {                           /* Statement function. */
489       assert (!(sa & ~(FFESYMBOL_attrsSFUNC
490                        | FFESYMBOL_attrsTYPE)));
491
492       nkd = FFEINFO_kindFUNCTION;
493       nwh = FFEINFO_whereCONSTANT;
494     }
495   else if (sa & FFESYMBOL_attrsEXTERNAL)
496     {
497       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
498                        | FFESYMBOL_attrsEXTERNAL
499                        | FFESYMBOL_attrsTYPE)));
500
501       if (sa & FFESYMBOL_attrsTYPE)
502         {
503           nkd = FFEINFO_kindFUNCTION;
504
505           if (sa & FFESYMBOL_attrsDUMMY)
506             nwh = FFEINFO_whereDUMMY;
507           else
508             {
509               if (ffesta_is_entry_valid)
510                 {
511                   nwh = FFEINFO_whereNONE;      /* DUMMY, GLOBAL. */
512                   ns = FFESYMBOL_stateUNCERTAIN;
513                 }
514               else
515                 nwh = FFEINFO_whereGLOBAL;
516             }
517         }
518       else
519         /* No TYPE. */
520         {
521           nkd = FFEINFO_kindNONE;       /* FUNCTION, SUBROUTINE, BLOCKDATA. */
522           needs_type = FALSE;   /* Only gets type if FUNCTION. */
523           ns = FFESYMBOL_stateUNCERTAIN;
524
525           if (sa & FFESYMBOL_attrsDUMMY)
526             nwh = FFEINFO_whereDUMMY;   /* Not BLOCKDATA. */
527           else
528             {
529               if (ffesta_is_entry_valid)
530                 nwh = FFEINFO_whereNONE;        /* DUMMY, GLOBAL. */
531               else
532                 nwh = FFEINFO_whereGLOBAL;
533             }
534         }
535     }
536   else if (sa & FFESYMBOL_attrsDUMMY)
537     {
538       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
539       assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE        /* Possible. */
540                        | FFESYMBOL_attrsADJUSTS /* Possible. */
541                        | FFESYMBOL_attrsANYLEN  /* Possible. */
542                        | FFESYMBOL_attrsANYSIZE /* Possible. */
543                        | FFESYMBOL_attrsARRAY   /* Possible. */
544                        | FFESYMBOL_attrsDUMMY   /* Have it. */
545                        | FFESYMBOL_attrsEXTERNAL
546                        | FFESYMBOL_attrsSFARG   /* Possible. */
547                        | FFESYMBOL_attrsTYPE)));        /* Possible. */
548
549       nwh = FFEINFO_whereDUMMY;
550
551       if (ffestu_symter_exec_transition_ (ffesymbol_dims (s)))
552         na = FFESYMBOL_attrsetNONE;
553
554       if (sa & (FFESYMBOL_attrsADJUSTS
555                 | FFESYMBOL_attrsARRAY
556                 | FFESYMBOL_attrsANYLEN
557                 | FFESYMBOL_attrsNAMELIST
558                 | FFESYMBOL_attrsSFARG))
559         nkd = FFEINFO_kindENTITY;
560       else if (sa & FFESYMBOL_attrsDUMMY)       /* Still okay. */
561         {
562           if (!(sa & FFESYMBOL_attrsTYPE))
563             needs_type = FALSE; /* Don't assign type to SUBROUTINE! */
564           nkd = FFEINFO_kindNONE;       /* ENTITY, FUNCTION, SUBROUTINE. */
565           ns = FFESYMBOL_stateUNCERTAIN;
566         }
567     }
568   else if (sa & FFESYMBOL_attrsADJUSTS)
569     {                           /* Must be DUMMY or COMMON at some point. */
570       assert (!(sa & (FFESYMBOL_attrsCOMMON
571                       | FFESYMBOL_attrsDUMMY)));        /* Handled above. */
572       assert (!(sa & ~(FFESYMBOL_attrsADJUSTS   /* Have it. */
573                        | FFESYMBOL_attrsCOMMON
574                        | FFESYMBOL_attrsDUMMY
575                        | FFESYMBOL_attrsEQUIV   /* Possible. */
576                        | FFESYMBOL_attrsINIT    /* Possible. */
577                        | FFESYMBOL_attrsNAMELIST        /* Possible. */
578                        | FFESYMBOL_attrsSFARG   /* Possible. */
579                        | FFESYMBOL_attrsTYPE)));        /* Possible. */
580
581       nkd = FFEINFO_kindENTITY;
582
583       if (sa & FFESYMBOL_attrsEQUIV)
584         {
585           if ((ffesymbol_equiv (s) == NULL)
586               || (ffeequiv_common (ffesymbol_equiv (s)) == NULL))
587             na = FFESYMBOL_attrsetNONE; /* Not equiv'd into COMMON. */
588           else
589             nwh = FFEINFO_whereCOMMON;
590         }
591       else if (!ffesta_is_entry_valid
592                || (sa & (FFESYMBOL_attrsINIT
593                          | FFESYMBOL_attrsNAMELIST)))
594         na = FFESYMBOL_attrsetNONE;
595       else
596         nwh = FFEINFO_whereDUMMY;
597     }
598   else if (sa & FFESYMBOL_attrsSAVE)
599     {
600       assert (!(sa & ~(FFESYMBOL_attrsARRAY
601                        | FFESYMBOL_attrsEQUIV
602                        | FFESYMBOL_attrsINIT
603                        | FFESYMBOL_attrsNAMELIST
604                        | FFESYMBOL_attrsSAVE
605                        | FFESYMBOL_attrsSFARG
606                        | FFESYMBOL_attrsTYPE)));
607
608       nkd = FFEINFO_kindENTITY;
609       nwh = FFEINFO_whereLOCAL;
610     }
611   else if (sa & FFESYMBOL_attrsEQUIV)
612     {
613       assert (!(sa & FFESYMBOL_attrsCOMMON));   /* Handled above. */
614       assert (!(sa & ~(FFESYMBOL_attrsADJUSTS   /* Possible. */
615                        | FFESYMBOL_attrsARRAY   /* Possible. */
616                        | FFESYMBOL_attrsCOMMON
617                        | FFESYMBOL_attrsEQUIV   /* Have it. */
618                        | FFESYMBOL_attrsINIT    /* Possible. */
619                        | FFESYMBOL_attrsNAMELIST        /* Possible. */
620                        | FFESYMBOL_attrsSAVE    /* Possible. */
621                        | FFESYMBOL_attrsSFARG   /* Possible. */
622                        | FFESYMBOL_attrsTYPE)));        /* Possible. */
623
624       nkd = FFEINFO_kindENTITY;
625       nwh = ffestu_equiv_ (s);
626     }
627   else if (sa & FFESYMBOL_attrsNAMELIST)
628     {
629       assert (!(sa & (FFESYMBOL_attrsADJUSTS
630                       | FFESYMBOL_attrsCOMMON
631                       | FFESYMBOL_attrsEQUIV
632                       | FFESYMBOL_attrsSAVE))); /* Handled above. */
633       assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
634                        | FFESYMBOL_attrsARRAY   /* Possible. */
635                        | FFESYMBOL_attrsCOMMON
636                        | FFESYMBOL_attrsEQUIV
637                        | FFESYMBOL_attrsINIT    /* Possible. */
638                        | FFESYMBOL_attrsNAMELIST        /* Have it. */
639                        | FFESYMBOL_attrsSAVE
640                        | FFESYMBOL_attrsSFARG   /* Possible. */
641                        | FFESYMBOL_attrsTYPE)));        /* Possible. */
642
643       nkd = FFEINFO_kindENTITY;
644       nwh = FFEINFO_whereLOCAL;
645     }
646   else if (sa & FFESYMBOL_attrsINIT)
647     {
648       assert (!(sa & (FFESYMBOL_attrsADJUSTS
649                       | FFESYMBOL_attrsCOMMON
650                       | FFESYMBOL_attrsEQUIV
651                       | FFESYMBOL_attrsNAMELIST
652                       | FFESYMBOL_attrsSAVE))); /* Handled above. */
653       assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
654                        | FFESYMBOL_attrsARRAY   /* Possible. */
655                        | FFESYMBOL_attrsCOMMON
656                        | FFESYMBOL_attrsEQUIV
657                        | FFESYMBOL_attrsINIT    /* Have it. */
658                        | FFESYMBOL_attrsNAMELIST
659                        | FFESYMBOL_attrsSAVE
660                        | FFESYMBOL_attrsSFARG   /* Possible. */
661                        | FFESYMBOL_attrsTYPE)));        /* Possible. */
662
663       nkd = FFEINFO_kindENTITY;
664       nwh = FFEINFO_whereLOCAL;
665     }
666   else if (sa & FFESYMBOL_attrsSFARG)
667     {
668       assert (!(sa & (FFESYMBOL_attrsADJUSTS
669                       | FFESYMBOL_attrsCOMMON
670                       | FFESYMBOL_attrsDUMMY
671                       | FFESYMBOL_attrsEQUIV
672                       | FFESYMBOL_attrsINIT
673                       | FFESYMBOL_attrsNAMELIST
674                       | FFESYMBOL_attrsRESULT
675                       | FFESYMBOL_attrsSAVE))); /* Handled above. */
676       assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
677                        | FFESYMBOL_attrsCOMMON
678                        | FFESYMBOL_attrsDUMMY
679                        | FFESYMBOL_attrsEQUIV
680                        | FFESYMBOL_attrsINIT
681                        | FFESYMBOL_attrsNAMELIST
682                        | FFESYMBOL_attrsRESULT
683                        | FFESYMBOL_attrsSAVE
684                        | FFESYMBOL_attrsSFARG   /* Have it. */
685                        | FFESYMBOL_attrsTYPE)));        /* Possible. */
686
687       nkd = FFEINFO_kindENTITY;
688
689       if (ffesta_is_entry_valid)
690         {
691           nwh = FFEINFO_whereNONE;      /* DUMMY, LOCAL. */
692           ns = FFESYMBOL_stateUNCERTAIN;
693         }
694       else
695         nwh = FFEINFO_whereLOCAL;
696     }
697   else if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYSIZE))
698     {
699       assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
700                        | FFESYMBOL_attrsANYLEN
701                        | FFESYMBOL_attrsANYSIZE
702                        | FFESYMBOL_attrsARRAY
703                        | FFESYMBOL_attrsTYPE)));
704
705       nkd = FFEINFO_kindENTITY;
706
707       if (ffestu_symter_exec_transition_ (ffesymbol_dims (s)))
708         na = FFESYMBOL_attrsetNONE;
709
710       if (sa & (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsANYSIZE))
711         nwh = FFEINFO_whereDUMMY;
712       else if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYSIZE))
713         /* Still okay.  */
714         {
715           nwh = FFEINFO_whereNONE;      /* DUMMY, LOCAL. */
716           ns = FFESYMBOL_stateUNCERTAIN;
717         }
718     }
719   else if (sa & FFESYMBOL_attrsARRAY)
720     {
721       assert (!(sa & (FFESYMBOL_attrsADJUSTABLE
722                       | FFESYMBOL_attrsANYSIZE
723                       | FFESYMBOL_attrsCOMMON
724                       | FFESYMBOL_attrsDUMMY
725                       | FFESYMBOL_attrsEQUIV
726                       | FFESYMBOL_attrsINIT
727                       | FFESYMBOL_attrsNAMELIST
728                       | FFESYMBOL_attrsSAVE))); /* Handled above. */
729       assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
730                        | FFESYMBOL_attrsANYLEN  /* Possible. */
731                        | FFESYMBOL_attrsANYSIZE
732                        | FFESYMBOL_attrsARRAY   /* Have it. */
733                        | FFESYMBOL_attrsCOMMON
734                        | FFESYMBOL_attrsDUMMY
735                        | FFESYMBOL_attrsEQUIV
736                        | FFESYMBOL_attrsINIT
737                        | FFESYMBOL_attrsNAMELIST
738                        | FFESYMBOL_attrsSAVE
739                        | FFESYMBOL_attrsTYPE)));        /* Possible. */
740
741       nkd = FFEINFO_kindENTITY;
742
743       if (sa & FFESYMBOL_attrsANYLEN)
744         {
745           assert (ffesta_is_entry_valid);       /* Already diagnosed. */
746           nwh = FFEINFO_whereDUMMY;
747         }
748       else
749         {
750           if (ffesta_is_entry_valid)
751             {
752               nwh = FFEINFO_whereNONE;  /* DUMMY, LOCAL. */
753               ns = FFESYMBOL_stateUNCERTAIN;
754             }
755           else
756             nwh = FFEINFO_whereLOCAL;
757         }
758     }
759   else if (sa & FFESYMBOL_attrsANYLEN)
760     {
761       assert (!(sa & (FFESYMBOL_attrsADJUSTABLE
762                       | FFESYMBOL_attrsANYSIZE
763                       | FFESYMBOL_attrsARRAY
764                       | FFESYMBOL_attrsDUMMY
765                       | FFESYMBOL_attrsRESULT)));       /* Handled above. */
766       assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
767                        | FFESYMBOL_attrsANYLEN  /* Have it. */
768                        | FFESYMBOL_attrsANYSIZE
769                        | FFESYMBOL_attrsARRAY
770                        | FFESYMBOL_attrsDUMMY
771                        | FFESYMBOL_attrsRESULT
772                        | FFESYMBOL_attrsTYPE)));        /* Have it too. */
773
774       if (ffesta_is_entry_valid)
775         {
776           nkd = FFEINFO_kindNONE;       /* ENTITY, FUNCTION. */
777           nwh = FFEINFO_whereNONE;      /* DUMMY, INTRINSIC, RESULT. */
778           ns = FFESYMBOL_stateUNCERTAIN;
779           resolve_intrin = FALSE;
780         }
781       else if (ffeintrin_is_intrinsic (ffesymbol_text (s), NULL, FALSE,
782                                        &gen, &spec, &imp))
783         {
784           ffesymbol_signal_change (s);
785           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
786           ffesymbol_set_generic (s, gen);
787           ffesymbol_set_specific (s, spec);
788           ffesymbol_set_implementation (s, imp);
789           ffesymbol_set_info (s,
790                               ffeinfo_new (FFEINFO_basictypeNONE,
791                                            FFEINFO_kindtypeNONE,
792                                            0,
793                                            FFEINFO_kindNONE,
794                                            FFEINFO_whereINTRINSIC,
795                                            FFETARGET_charactersizeNONE));
796           ffesymbol_resolve_intrin (s);
797           ffesymbol_reference (s, NULL, FALSE);
798           ffestorag_exec_layout (s);
799           ffesymbol_signal_unreported (s);      /* For debugging purposes. */
800           return s;
801         }
802       else
803         {                       /* SPECIAL: can't have CHAR*(*) var in
804                                    PROGRAM/BLOCKDATA, unless it isn't
805                                    referenced anywhere in the code. */
806           ffesymbol_signal_change (s);  /* Can't touch this. */
807           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
808           ffesymbol_resolve_intrin (s);
809           ffesymbol_reference (s, NULL, FALSE);
810           ffestorag_exec_layout (s);
811           ffesymbol_signal_unreported (s);      /* For debugging purposes. */
812           return s;
813         }
814     }
815   else if (sa & FFESYMBOL_attrsTYPE)
816     {
817       assert (!(sa & (FFESYMBOL_attrsADJUSTABLE
818                       | FFESYMBOL_attrsADJUSTS
819                       | FFESYMBOL_attrsANYLEN
820                       | FFESYMBOL_attrsANYSIZE
821                       | FFESYMBOL_attrsARRAY
822                       | FFESYMBOL_attrsCOMMON
823                       | FFESYMBOL_attrsDUMMY
824                       | FFESYMBOL_attrsEQUIV
825                       | FFESYMBOL_attrsEXTERNAL
826                       | FFESYMBOL_attrsINIT
827                       | FFESYMBOL_attrsNAMELIST
828                       | FFESYMBOL_attrsRESULT
829                       | FFESYMBOL_attrsSAVE
830                       | FFESYMBOL_attrsSFARG
831                       | FFESYMBOL_attrsSFUNC)));
832       assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
833                        | FFESYMBOL_attrsADJUSTS
834                        | FFESYMBOL_attrsANYLEN
835                        | FFESYMBOL_attrsANYSIZE
836                        | FFESYMBOL_attrsARRAY
837                        | FFESYMBOL_attrsCOMMON
838                        | FFESYMBOL_attrsDUMMY
839                        | FFESYMBOL_attrsEQUIV
840                        | FFESYMBOL_attrsEXTERNAL
841                        | FFESYMBOL_attrsINIT
842                        | FFESYMBOL_attrsINTRINSIC       /* UNDERSTOOD. */
843                        | FFESYMBOL_attrsNAMELIST
844                        | FFESYMBOL_attrsRESULT
845                        | FFESYMBOL_attrsSAVE
846                        | FFESYMBOL_attrsSFARG
847                        | FFESYMBOL_attrsSFUNC
848                        | FFESYMBOL_attrsTYPE)));        /* Have it. */
849
850       nkd = FFEINFO_kindNONE;   /* ENTITY, FUNCTION. */
851       nwh = FFEINFO_whereNONE;  /* DUMMY, GLOBAL, INTRINSIC, LOCAL, RESULT. */
852       ns = FFESYMBOL_stateUNCERTAIN;
853       resolve_intrin = FALSE;
854     }
855   else if (sa & (FFESYMBOL_attrsCBLOCK | FFESYMBOL_attrsSAVECBLOCK))
856     {                           /* COMMON block. */
857       assert (!(sa & ~(FFESYMBOL_attrsCBLOCK
858                        | FFESYMBOL_attrsSAVECBLOCK)));
859
860       if (sa & FFESYMBOL_attrsCBLOCK)
861         ffebld_end_list (ffesymbol_ptr_to_listbottom (s));
862       else
863         ffesymbol_set_commonlist (s, NULL);
864       ffestu_list_exec_transition_ (ffesymbol_commonlist (s));
865       nkd = FFEINFO_kindCOMMON;
866       nwh = FFEINFO_whereLOCAL;
867       needs_type = FALSE;
868     }
869   else
870     {                           /* First seen in stmt func definition. */
871       assert (sa == FFESYMBOL_attrsetNONE);
872       assert ("Why are we here again?" == NULL);        /* ~~~~~ */
873
874       nkd = FFEINFO_kindNONE;   /* ENTITY, FUNCTION. */
875       nwh = FFEINFO_whereNONE;  /* DUMMY, GLOBAL, LOCAL. */
876       ns = FFESYMBOL_stateUNCERTAIN;    /* Will get repromoted by caller. */
877       needs_type = FALSE;
878     }
879
880   if (na == FFESYMBOL_attrsetNONE)
881     ffesymbol_error (s, ffesta_tokens[0]);
882   else if (!(na & FFESYMBOL_attrsANY)
883            && (needs_type || (nkd != skd) || (nwh != swh)
884                || (na != sa) || (ns != ss)))
885     {
886       ffesymbol_signal_change (s);
887       ffesymbol_set_attrs (s, na);      /* Establish new info. */
888       ffesymbol_set_state (s, ns);
889       if ((ffesymbol_common (s) == NULL)
890           && (ffesymbol_equiv (s) != NULL))
891         ffesymbol_set_common (s, ffeequiv_common (ffesymbol_equiv (s)));
892       ffesymbol_set_info (s,
893                           ffeinfo_new (ffesymbol_basictype (s),
894                                        ffesymbol_kindtype (s),
895                                        ffesymbol_rank (s),
896                                        nkd,
897                                        nwh,
898                                        ffesymbol_size (s)));
899       if (needs_type && !ffeimplic_establish_symbol (s))
900         ffesymbol_error (s, ffesta_tokens[0]);
901       else if (resolve_intrin)
902         ffesymbol_resolve_intrin (s);
903       ffesymbol_reference (s, NULL, FALSE);
904       ffestorag_exec_layout (s);
905       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
906     }
907
908   return s;
909 }
910
911 /* ffestu_list_exec_transition_ -- Update SYMTERs in ITEM list w/in symbol
912
913    ffebld list;
914    ffestu_list_exec_transition_(list);
915
916    list contains an FFEBLD_opITEM list of SYMTERs (possibly STARs and
917    other things, too, but we'll ignore the known ones).  For each SYMTER,
918    we run sym_exec_transition_ on the corresponding ffesymbol (a recursive
919    call, since that's the function that's calling us) to update it's
920    information.  Then we copy that information into the SYMTER.
921
922    Make sure we don't get called recursively ourselves!  */
923
924 static void
925 ffestu_list_exec_transition_ (ffebld list)
926 {
927   static bool in_progress = FALSE;
928   ffebld item;
929   ffesymbol symbol;
930
931   assert (!in_progress);
932   in_progress = TRUE;
933
934   for (; list != NULL; list = ffebld_trail (list))
935     {
936       if ((item = ffebld_head (list)) == NULL)
937         continue;               /* Try next item. */
938
939       switch (ffebld_op (item))
940         {
941         case FFEBLD_opSTAR:
942           break;
943
944         case FFEBLD_opSYMTER:
945           symbol = ffebld_symter (item);
946           if (symbol == NULL)
947             break;              /* Detached from stmt func dummy list. */
948           symbol = ffecom_sym_exec_transition (symbol);
949           assert (ffesymbol_kind (symbol) != FFEINFO_kindNONE);
950           assert (ffesymbol_where (symbol) != FFEINFO_whereNONE);
951           ffebld_set_info (item, ffesymbol_info (symbol));
952           break;
953
954         default:
955           assert ("Unexpected item on list" == NULL);
956           break;
957         }
958     }
959
960   in_progress = FALSE;
961 }
962
963 /* ffestu_symter_end_transition_ -- Update SYMTERs in expr w/in symbol
964
965    ffebld expr;
966    ffestu_symter_end_transition_(expr);
967
968    Any SYMTER in expr's tree with whereNONE gets updated to the
969    (recursively transitioned) sym it identifies (DUMMY or COMMON).  */
970
971 static bool
972 ffestu_symter_end_transition_ (ffebld expr)
973 {
974   ffesymbol symbol;
975   bool any = FALSE;
976
977   /* Label used for tail recursion (reset expr and go here instead of calling
978      self). */
979
980 tail:                           /* :::::::::::::::::::: */
981
982   if (expr == NULL)
983     return any;
984
985   switch (ffebld_op (expr))
986     {
987     case FFEBLD_opITEM:
988       while (ffebld_trail (expr) != NULL)
989         {
990           if (ffestu_symter_end_transition_ (ffebld_head (expr)))
991             any = TRUE;
992           expr = ffebld_trail (expr);
993         }
994       expr = ffebld_head (expr);
995       goto tail;                /* :::::::::::::::::::: */
996
997     case FFEBLD_opSYMTER:
998       symbol = ffecom_sym_end_transition (ffebld_symter (expr));
999       if ((symbol != NULL)
1000           && ffesymbol_attr (symbol, FFESYMBOL_attrANY))
1001         any = TRUE;
1002       ffebld_set_info (expr, ffesymbol_info (symbol));
1003       break;
1004
1005     case FFEBLD_opANY:
1006       return TRUE;
1007
1008     default:
1009       break;
1010     }
1011
1012   switch (ffebld_arity (expr))
1013     {
1014     case 2:
1015       if (ffestu_symter_end_transition_ (ffebld_left (expr)))
1016         any = TRUE;
1017       expr = ffebld_right (expr);
1018       goto tail;                /* :::::::::::::::::::: */
1019
1020     case 1:
1021       expr = ffebld_left (expr);
1022       goto tail;                /* :::::::::::::::::::: */
1023
1024     default:
1025       break;
1026     }
1027
1028   return any;
1029 }
1030
1031 /* ffestu_symter_exec_transition_ -- Update SYMTERs in expr w/in symbol
1032
1033    ffebld expr;
1034    ffestu_symter_exec_transition_(expr);
1035
1036    Any SYMTER in expr's tree with whereNONE gets updated to the
1037    (recursively transitioned) sym it identifies (DUMMY or COMMON).  */
1038
1039 static bool
1040 ffestu_symter_exec_transition_ (ffebld expr)
1041 {
1042   ffesymbol symbol;
1043   bool any = FALSE;
1044
1045   /* Label used for tail recursion (reset expr and go here instead of calling
1046      self). */
1047
1048 tail:                           /* :::::::::::::::::::: */
1049
1050   if (expr == NULL)
1051     return any;
1052
1053   switch (ffebld_op (expr))
1054     {
1055     case FFEBLD_opITEM:
1056       while (ffebld_trail (expr) != NULL)
1057         {
1058           if (ffestu_symter_exec_transition_ (ffebld_head (expr)))
1059             any = TRUE;
1060           expr = ffebld_trail (expr);
1061         }
1062       expr = ffebld_head (expr);
1063       goto tail;                /* :::::::::::::::::::: */
1064
1065     case FFEBLD_opSYMTER:
1066       symbol = ffecom_sym_exec_transition (ffebld_symter (expr));
1067       if ((symbol != NULL)
1068           && ffesymbol_attr (symbol, FFESYMBOL_attrANY))
1069         any = TRUE;
1070       ffebld_set_info (expr, ffesymbol_info (symbol));
1071       break;
1072
1073     case FFEBLD_opANY:
1074       return TRUE;
1075
1076     default:
1077       break;
1078     }
1079
1080   switch (ffebld_arity (expr))
1081     {
1082     case 2:
1083       if (ffestu_symter_exec_transition_ (ffebld_left (expr)))
1084         any = TRUE;
1085       expr = ffebld_right (expr);
1086       goto tail;                /* :::::::::::::::::::: */
1087
1088     case 1:
1089       expr = ffebld_left (expr);
1090       goto tail;                /* :::::::::::::::::::: */
1091
1092     default:
1093       break;
1094     }
1095
1096   return any;
1097 }
1098
1099 /* ffestu_dummies_transition_ -- Update SYMTERs in ITEM list w/in entry
1100
1101    ffebld list;
1102    ffesymbol symfunc(ffesymbol s);
1103    if (ffestu_dummies_transition_(symfunc,list))
1104        // One or more items are still UNCERTAIN.
1105
1106    list contains an FFEBLD_opITEM list of SYMTERs (possibly STARs and
1107    other things, too, but we'll ignore the known ones).  For each SYMTER,
1108    we run symfunc on the corresponding ffesymbol (a recursive
1109    call, since that's the function that's calling us) to update it's
1110    information.  Then we copy that information into the SYMTER.
1111
1112    Return TRUE if any of the SYMTER's has incomplete information.
1113
1114    Make sure we don't get called recursively ourselves!  */
1115
1116 static bool
1117 ffestu_dummies_transition_ (ffesymbol (*symfunc) (ffesymbol), ffebld list)
1118 {
1119   static bool in_progress = FALSE;
1120   ffebld item;
1121   ffesymbol symbol;
1122   bool uncertain = FALSE;
1123
1124   assert (!in_progress);
1125   in_progress = TRUE;
1126
1127   for (; list != NULL; list = ffebld_trail (list))
1128     {
1129       if ((item = ffebld_head (list)) == NULL)
1130         continue;               /* Try next item. */
1131
1132       switch (ffebld_op (item))
1133         {
1134         case FFEBLD_opSTAR:
1135           break;
1136
1137         case FFEBLD_opSYMTER:
1138           symbol = ffebld_symter (item);
1139           if (symbol == NULL)
1140             break;              /* Detached from stmt func dummy list. */
1141           symbol = (*symfunc) (symbol);
1142           if (ffesymbol_state (symbol) == FFESYMBOL_stateUNCERTAIN)
1143             uncertain = TRUE;
1144           else
1145             {
1146               assert (ffesymbol_kind (symbol) != FFEINFO_kindNONE);
1147               assert (ffesymbol_where (symbol) != FFEINFO_whereNONE);
1148             }
1149           ffebld_set_info (item, ffesymbol_info (symbol));
1150           break;
1151
1152         default:
1153           assert ("Unexpected item on list" == NULL);
1154           break;
1155         }
1156     }
1157
1158   in_progress = FALSE;
1159
1160   return uncertain;
1161 }