OSDN Git Service

PR fortran/13930
[pf3gnuchains/gcc-fork.git] / gcc / f / stu.c
1 /* stu.c -- Implementation File (module.c template V1.0)
2    Copyright (C) 1995, 1996, 1997, 2002 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               /* xgettext:no-c-format */
305               && ffebad_start_msg ("Local adjustable symbol `%A' at %0",
306                                    FFEBAD_severityPEDANTIC))
307             {
308               ffebad_string (ffesymbol_text (s));
309               ffebad_here (0, ffesymbol_where_line (s),
310                            ffesymbol_where_column (s));
311               ffebad_finish ();
312             }
313         }
314       nwh = FFEINFO_whereLOCAL;
315     }
316   else if (sa & FFESYMBOL_attrsSFARG)
317     {
318       assert (!(sa & ~(FFESYMBOL_attrsSFARG
319                        | FFESYMBOL_attrsTYPE)));
320
321       nwh = FFEINFO_whereLOCAL;
322     }
323   else if (sa & FFESYMBOL_attrsTYPE)
324     {
325       assert (!(sa & (FFESYMBOL_attrsARRAY
326                       | FFESYMBOL_attrsDUMMY
327                       | FFESYMBOL_attrsEXTERNAL
328                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
329       assert (!(sa & ~(FFESYMBOL_attrsTYPE
330                        | FFESYMBOL_attrsADJUSTABLE
331                        | FFESYMBOL_attrsANYLEN
332                        | FFESYMBOL_attrsARRAY
333                        | FFESYMBOL_attrsDUMMY
334                        | FFESYMBOL_attrsEXTERNAL
335                        | FFESYMBOL_attrsSFARG)));
336
337       if (sa & FFESYMBOL_attrsANYLEN)
338         {                       /* Can't touch this. */
339           ffesymbol_signal_change (s);
340           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
341           ffesymbol_resolve_intrin (s);
342           s = ffecom_sym_learned (s);
343           ffesymbol_reference (s, NULL, FALSE);
344           ffestorag_end_layout (s);
345           ffesymbol_signal_unreported (s);      /* For debugging purposes. */
346           return s;
347         }
348
349       nkd = FFEINFO_kindENTITY;
350       nwh = FFEINFO_whereLOCAL;
351     }
352   else
353     assert ("unexpected attribute set" == NULL);
354
355   /* Now see what we've got for a new object: NONE means a new error cropped
356      up; ANY means an old error to be ignored; otherwise, everything's ok,
357      update the object (symbol) and continue on. */
358
359   if (na == FFESYMBOL_attrsetNONE)
360     ffesymbol_error (s, ffesta_tokens[0]);
361   else if (!(na & FFESYMBOL_attrsANY))
362     {
363       ffesymbol_signal_change (s);
364       ffesymbol_set_attrs (s, na);      /* Establish new info. */
365       ffesymbol_set_state (s, ns);
366       ffesymbol_set_info (s,
367                           ffeinfo_new (ffesymbol_basictype (s),
368                                        ffesymbol_kindtype (s),
369                                        ffesymbol_rank (s),
370                                        nkd,
371                                        nwh,
372                                        ffesymbol_size (s)));
373       if (needs_type && !ffeimplic_establish_symbol (s))
374         ffesymbol_error (s, ffesta_tokens[0]);
375       else
376         ffesymbol_resolve_intrin (s);
377       s = ffecom_sym_learned (s);
378       ffesymbol_reference (s, NULL, FALSE);
379       ffestorag_end_layout (s);
380       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
381     }
382
383   return s;
384 }
385
386 /* ffestu_sym_exec_transition -- Update symbol just before first exec stmt
387
388    ffesymbol s;
389    ffestu_sym_exec_transition(s);  */
390
391 ffesymbol
392 ffestu_sym_exec_transition (ffesymbol s)
393 {
394   ffeinfoKind skd;
395   ffeinfoWhere swh;
396   ffeinfoKind nkd;
397   ffeinfoWhere nwh;
398   ffesymbolAttrs sa;
399   ffesymbolAttrs na;
400   ffesymbolState ss;
401   ffesymbolState ns;
402   ffeintrinGen gen;
403   ffeintrinSpec spec;
404   ffeintrinImp imp;
405   bool needs_type = TRUE;       /* Implicit type assignment might be
406                                    necessary. */
407   bool resolve_intrin = TRUE;   /* Might need to resolve intrinsic. */
408
409   assert (s != NULL);
410
411   sa = ffesymbol_attrs (s);
412   skd = ffesymbol_kind (s);
413   swh = ffesymbol_where (s);
414   ss = ffesymbol_state (s);
415
416   switch (ss)
417     {
418     case FFESYMBOL_stateNONE:
419       return s;                 /* Assume caller will handle it. */
420
421     case FFESYMBOL_stateSEEN:
422       break;
423
424     case FFESYMBOL_stateUNCERTAIN:
425       ffestorag_exec_layout (s);
426       return s;                 /* Already processed this one, or not
427                                    necessary. */
428
429     case FFESYMBOL_stateUNDERSTOOD:
430       if (skd == FFEINFO_kindNAMELIST)
431         {
432           ffebld_end_list (ffesymbol_ptr_to_listbottom (s));
433           ffestu_list_exec_transition_ (ffesymbol_namelist (s));
434         }
435       else if ((swh == FFEINFO_whereLOCAL)
436                && ((skd == FFEINFO_kindFUNCTION)
437                    || (skd == FFEINFO_kindSUBROUTINE)))
438         {
439           ffestu_dummies_transition_ (ffecom_sym_exec_transition,
440                                       ffesymbol_dummyargs (s));
441           if ((skd == FFEINFO_kindFUNCTION)
442               && !ffeimplic_establish_symbol (s))
443             ffesymbol_error (s, ffesta_tokens[0]);
444         }
445
446       ffesymbol_reference (s, NULL, FALSE);
447       ffestorag_exec_layout (s);
448       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
449       return s;
450
451     default:
452       assert ("bad status" == NULL);
453       return s;
454     }
455
456   ns = FFESYMBOL_stateUNDERSTOOD;       /* Only a few UNCERTAIN exceptions. */
457
458   na = sa;
459   nkd = skd;
460   nwh = swh;
461
462   assert (!(sa & FFESYMBOL_attrsANY));
463
464   if (sa & FFESYMBOL_attrsCOMMON)
465     {
466       assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
467                        | FFESYMBOL_attrsARRAY
468                        | FFESYMBOL_attrsCOMMON
469                        | FFESYMBOL_attrsEQUIV
470                        | FFESYMBOL_attrsINIT
471                        | FFESYMBOL_attrsNAMELIST
472                        | FFESYMBOL_attrsSFARG
473                        | FFESYMBOL_attrsTYPE)));
474
475       nkd = FFEINFO_kindENTITY;
476       nwh = FFEINFO_whereCOMMON;
477     }
478   else if (sa & FFESYMBOL_attrsRESULT)
479     {                           /* Result variable for function. */
480       assert (!(sa & ~(FFESYMBOL_attrsANYLEN
481                        | FFESYMBOL_attrsRESULT
482                        | FFESYMBOL_attrsSFARG
483                        | FFESYMBOL_attrsTYPE)));
484
485       nkd = FFEINFO_kindENTITY;
486       nwh = FFEINFO_whereRESULT;
487     }
488   else if (sa & FFESYMBOL_attrsSFUNC)
489     {                           /* Statement function. */
490       assert (!(sa & ~(FFESYMBOL_attrsSFUNC
491                        | FFESYMBOL_attrsTYPE)));
492
493       nkd = FFEINFO_kindFUNCTION;
494       nwh = FFEINFO_whereCONSTANT;
495     }
496   else if (sa & FFESYMBOL_attrsEXTERNAL)
497     {
498       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
499                        | FFESYMBOL_attrsEXTERNAL
500                        | FFESYMBOL_attrsTYPE)));
501
502       if (sa & FFESYMBOL_attrsTYPE)
503         {
504           nkd = FFEINFO_kindFUNCTION;
505
506           if (sa & FFESYMBOL_attrsDUMMY)
507             nwh = FFEINFO_whereDUMMY;
508           else
509             {
510               if (ffesta_is_entry_valid)
511                 {
512                   nwh = FFEINFO_whereNONE;      /* DUMMY, GLOBAL. */
513                   ns = FFESYMBOL_stateUNCERTAIN;
514                 }
515               else
516                 nwh = FFEINFO_whereGLOBAL;
517             }
518         }
519       else
520         /* No TYPE. */
521         {
522           nkd = FFEINFO_kindNONE;       /* FUNCTION, SUBROUTINE, BLOCKDATA. */
523           needs_type = FALSE;   /* Only gets type if FUNCTION. */
524           ns = FFESYMBOL_stateUNCERTAIN;
525
526           if (sa & FFESYMBOL_attrsDUMMY)
527             nwh = FFEINFO_whereDUMMY;   /* Not BLOCKDATA. */
528           else
529             {
530               if (ffesta_is_entry_valid)
531                 nwh = FFEINFO_whereNONE;        /* DUMMY, GLOBAL. */
532               else
533                 nwh = FFEINFO_whereGLOBAL;
534             }
535         }
536     }
537   else if (sa & FFESYMBOL_attrsDUMMY)
538     {
539       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
540       assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE        /* Possible. */
541                        | FFESYMBOL_attrsADJUSTS /* Possible. */
542                        | FFESYMBOL_attrsANYLEN  /* Possible. */
543                        | FFESYMBOL_attrsANYSIZE /* Possible. */
544                        | FFESYMBOL_attrsARRAY   /* Possible. */
545                        | FFESYMBOL_attrsDUMMY   /* Have it. */
546                        | FFESYMBOL_attrsEXTERNAL
547                        | FFESYMBOL_attrsSFARG   /* Possible. */
548                        | FFESYMBOL_attrsTYPE)));        /* Possible. */
549
550       nwh = FFEINFO_whereDUMMY;
551
552       if (ffestu_symter_exec_transition_ (ffesymbol_dims (s)))
553         na = FFESYMBOL_attrsetNONE;
554
555       if (sa & (FFESYMBOL_attrsADJUSTS
556                 | FFESYMBOL_attrsARRAY
557                 | FFESYMBOL_attrsANYLEN
558                 | FFESYMBOL_attrsNAMELIST
559                 | FFESYMBOL_attrsSFARG))
560         nkd = FFEINFO_kindENTITY;
561       else if (sa & FFESYMBOL_attrsDUMMY)       /* Still okay. */
562         {
563           if (!(sa & FFESYMBOL_attrsTYPE))
564             needs_type = FALSE; /* Don't assign type to SUBROUTINE! */
565           nkd = FFEINFO_kindNONE;       /* ENTITY, FUNCTION, SUBROUTINE. */
566           ns = FFESYMBOL_stateUNCERTAIN;
567         }
568     }
569   else if (sa & FFESYMBOL_attrsADJUSTS)
570     {                           /* Must be DUMMY or COMMON at some point. */
571       assert (!(sa & (FFESYMBOL_attrsCOMMON
572                       | FFESYMBOL_attrsDUMMY)));        /* Handled above. */
573       assert (!(sa & ~(FFESYMBOL_attrsADJUSTS   /* Have it. */
574                        | FFESYMBOL_attrsCOMMON
575                        | FFESYMBOL_attrsDUMMY
576                        | FFESYMBOL_attrsEQUIV   /* Possible. */
577                        | FFESYMBOL_attrsINIT    /* Possible. */
578                        | FFESYMBOL_attrsNAMELIST        /* Possible. */
579                        | FFESYMBOL_attrsSFARG   /* Possible. */
580                        | FFESYMBOL_attrsTYPE)));        /* Possible. */
581
582       nkd = FFEINFO_kindENTITY;
583
584       if (sa & FFESYMBOL_attrsEQUIV)
585         {
586           if ((ffesymbol_equiv (s) == NULL)
587               || (ffeequiv_common (ffesymbol_equiv (s)) == NULL))
588             na = FFESYMBOL_attrsetNONE; /* Not equiv'd into COMMON. */
589           else
590             nwh = FFEINFO_whereCOMMON;
591         }
592       else if (!ffesta_is_entry_valid
593                || (sa & (FFESYMBOL_attrsINIT
594                          | FFESYMBOL_attrsNAMELIST)))
595         na = FFESYMBOL_attrsetNONE;
596       else
597         nwh = FFEINFO_whereDUMMY;
598     }
599   else if (sa & FFESYMBOL_attrsSAVE)
600     {
601       assert (!(sa & ~(FFESYMBOL_attrsARRAY
602                        | FFESYMBOL_attrsEQUIV
603                        | FFESYMBOL_attrsINIT
604                        | FFESYMBOL_attrsNAMELIST
605                        | FFESYMBOL_attrsSAVE
606                        | FFESYMBOL_attrsSFARG
607                        | FFESYMBOL_attrsTYPE)));
608
609       nkd = FFEINFO_kindENTITY;
610       nwh = FFEINFO_whereLOCAL;
611     }
612   else if (sa & FFESYMBOL_attrsEQUIV)
613     {
614       assert (!(sa & FFESYMBOL_attrsCOMMON));   /* Handled above. */
615       assert (!(sa & ~(FFESYMBOL_attrsADJUSTS   /* Possible. */
616                        | FFESYMBOL_attrsARRAY   /* Possible. */
617                        | FFESYMBOL_attrsCOMMON
618                        | FFESYMBOL_attrsEQUIV   /* Have it. */
619                        | FFESYMBOL_attrsINIT    /* Possible. */
620                        | FFESYMBOL_attrsNAMELIST        /* Possible. */
621                        | FFESYMBOL_attrsSAVE    /* Possible. */
622                        | FFESYMBOL_attrsSFARG   /* Possible. */
623                        | FFESYMBOL_attrsTYPE)));        /* Possible. */
624
625       nkd = FFEINFO_kindENTITY;
626       nwh = ffestu_equiv_ (s);
627     }
628   else if (sa & FFESYMBOL_attrsNAMELIST)
629     {
630       assert (!(sa & (FFESYMBOL_attrsADJUSTS
631                       | FFESYMBOL_attrsCOMMON
632                       | FFESYMBOL_attrsEQUIV
633                       | FFESYMBOL_attrsSAVE))); /* Handled above. */
634       assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
635                        | FFESYMBOL_attrsARRAY   /* Possible. */
636                        | FFESYMBOL_attrsCOMMON
637                        | FFESYMBOL_attrsEQUIV
638                        | FFESYMBOL_attrsINIT    /* Possible. */
639                        | FFESYMBOL_attrsNAMELIST        /* Have it. */
640                        | FFESYMBOL_attrsSAVE
641                        | FFESYMBOL_attrsSFARG   /* Possible. */
642                        | FFESYMBOL_attrsTYPE)));        /* Possible. */
643
644       nkd = FFEINFO_kindENTITY;
645       nwh = FFEINFO_whereLOCAL;
646     }
647   else if (sa & FFESYMBOL_attrsINIT)
648     {
649       assert (!(sa & (FFESYMBOL_attrsADJUSTS
650                       | FFESYMBOL_attrsCOMMON
651                       | FFESYMBOL_attrsEQUIV
652                       | FFESYMBOL_attrsNAMELIST
653                       | FFESYMBOL_attrsSAVE))); /* Handled above. */
654       assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
655                        | FFESYMBOL_attrsARRAY   /* Possible. */
656                        | FFESYMBOL_attrsCOMMON
657                        | FFESYMBOL_attrsEQUIV
658                        | FFESYMBOL_attrsINIT    /* Have it. */
659                        | FFESYMBOL_attrsNAMELIST
660                        | FFESYMBOL_attrsSAVE
661                        | FFESYMBOL_attrsSFARG   /* Possible. */
662                        | FFESYMBOL_attrsTYPE)));        /* Possible. */
663
664       nkd = FFEINFO_kindENTITY;
665       nwh = FFEINFO_whereLOCAL;
666     }
667   else if (sa & FFESYMBOL_attrsSFARG)
668     {
669       assert (!(sa & (FFESYMBOL_attrsADJUSTS
670                       | FFESYMBOL_attrsCOMMON
671                       | FFESYMBOL_attrsDUMMY
672                       | FFESYMBOL_attrsEQUIV
673                       | FFESYMBOL_attrsINIT
674                       | FFESYMBOL_attrsNAMELIST
675                       | FFESYMBOL_attrsRESULT
676                       | FFESYMBOL_attrsSAVE))); /* Handled above. */
677       assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
678                        | FFESYMBOL_attrsCOMMON
679                        | FFESYMBOL_attrsDUMMY
680                        | FFESYMBOL_attrsEQUIV
681                        | FFESYMBOL_attrsINIT
682                        | FFESYMBOL_attrsNAMELIST
683                        | FFESYMBOL_attrsRESULT
684                        | FFESYMBOL_attrsSAVE
685                        | FFESYMBOL_attrsSFARG   /* Have it. */
686                        | FFESYMBOL_attrsTYPE)));        /* Possible. */
687
688       nkd = FFEINFO_kindENTITY;
689
690       if (ffesta_is_entry_valid)
691         {
692           nwh = FFEINFO_whereNONE;      /* DUMMY, LOCAL. */
693           ns = FFESYMBOL_stateUNCERTAIN;
694         }
695       else
696         nwh = FFEINFO_whereLOCAL;
697     }
698   else if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYSIZE))
699     {
700       assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
701                        | FFESYMBOL_attrsANYLEN
702                        | FFESYMBOL_attrsANYSIZE
703                        | FFESYMBOL_attrsARRAY
704                        | FFESYMBOL_attrsTYPE)));
705
706       nkd = FFEINFO_kindENTITY;
707
708       if (ffestu_symter_exec_transition_ (ffesymbol_dims (s)))
709         na = FFESYMBOL_attrsetNONE;
710
711       if (sa & (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsANYSIZE))
712         nwh = FFEINFO_whereDUMMY;
713       else if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYSIZE))
714         /* Still okay.  */
715         {
716           nwh = FFEINFO_whereNONE;      /* DUMMY, LOCAL. */
717           ns = FFESYMBOL_stateUNCERTAIN;
718         }
719     }
720   else if (sa & FFESYMBOL_attrsARRAY)
721     {
722       assert (!(sa & (FFESYMBOL_attrsADJUSTABLE
723                       | FFESYMBOL_attrsANYSIZE
724                       | FFESYMBOL_attrsCOMMON
725                       | FFESYMBOL_attrsDUMMY
726                       | FFESYMBOL_attrsEQUIV
727                       | FFESYMBOL_attrsINIT
728                       | FFESYMBOL_attrsNAMELIST
729                       | FFESYMBOL_attrsSAVE))); /* Handled above. */
730       assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
731                        | FFESYMBOL_attrsANYLEN  /* Possible. */
732                        | FFESYMBOL_attrsANYSIZE
733                        | FFESYMBOL_attrsARRAY   /* Have it. */
734                        | FFESYMBOL_attrsCOMMON
735                        | FFESYMBOL_attrsDUMMY
736                        | FFESYMBOL_attrsEQUIV
737                        | FFESYMBOL_attrsINIT
738                        | FFESYMBOL_attrsNAMELIST
739                        | FFESYMBOL_attrsSAVE
740                        | FFESYMBOL_attrsTYPE)));        /* Possible. */
741
742       nkd = FFEINFO_kindENTITY;
743
744       if (sa & FFESYMBOL_attrsANYLEN)
745         {
746           assert (ffesta_is_entry_valid);       /* Already diagnosed. */
747           nwh = FFEINFO_whereDUMMY;
748         }
749       else
750         {
751           if (ffesta_is_entry_valid)
752             {
753               nwh = FFEINFO_whereNONE;  /* DUMMY, LOCAL. */
754               ns = FFESYMBOL_stateUNCERTAIN;
755             }
756           else
757             nwh = FFEINFO_whereLOCAL;
758         }
759     }
760   else if (sa & FFESYMBOL_attrsANYLEN)
761     {
762       assert (!(sa & (FFESYMBOL_attrsADJUSTABLE
763                       | FFESYMBOL_attrsANYSIZE
764                       | FFESYMBOL_attrsARRAY
765                       | FFESYMBOL_attrsDUMMY
766                       | FFESYMBOL_attrsRESULT)));       /* Handled above. */
767       assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
768                        | FFESYMBOL_attrsANYLEN  /* Have it. */
769                        | FFESYMBOL_attrsANYSIZE
770                        | FFESYMBOL_attrsARRAY
771                        | FFESYMBOL_attrsDUMMY
772                        | FFESYMBOL_attrsRESULT
773                        | FFESYMBOL_attrsTYPE)));        /* Have it too. */
774
775       if (ffesta_is_entry_valid)
776         {
777           nkd = FFEINFO_kindNONE;       /* ENTITY, FUNCTION. */
778           nwh = FFEINFO_whereNONE;      /* DUMMY, INTRINSIC, RESULT. */
779           ns = FFESYMBOL_stateUNCERTAIN;
780           resolve_intrin = FALSE;
781         }
782       else if (ffeintrin_is_intrinsic (ffesymbol_text (s), NULL, FALSE,
783                                        &gen, &spec, &imp))
784         {
785           ffesymbol_signal_change (s);
786           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
787           ffesymbol_set_generic (s, gen);
788           ffesymbol_set_specific (s, spec);
789           ffesymbol_set_implementation (s, imp);
790           ffesymbol_set_info (s,
791                               ffeinfo_new (FFEINFO_basictypeNONE,
792                                            FFEINFO_kindtypeNONE,
793                                            0,
794                                            FFEINFO_kindNONE,
795                                            FFEINFO_whereINTRINSIC,
796                                            FFETARGET_charactersizeNONE));
797           ffesymbol_resolve_intrin (s);
798           ffesymbol_reference (s, NULL, FALSE);
799           ffestorag_exec_layout (s);
800           ffesymbol_signal_unreported (s);      /* For debugging purposes. */
801           return s;
802         }
803       else
804         {                       /* SPECIAL: can't have CHAR*(*) var in
805                                    PROGRAM/BLOCKDATA, unless it isn't
806                                    referenced anywhere in the code. */
807           ffesymbol_signal_change (s);  /* Can't touch this. */
808           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
809           ffesymbol_resolve_intrin (s);
810           ffesymbol_reference (s, NULL, FALSE);
811           ffestorag_exec_layout (s);
812           ffesymbol_signal_unreported (s);      /* For debugging purposes. */
813           return s;
814         }
815     }
816   else if (sa & FFESYMBOL_attrsTYPE)
817     {
818       assert (!(sa & (FFESYMBOL_attrsADJUSTABLE
819                       | FFESYMBOL_attrsADJUSTS
820                       | FFESYMBOL_attrsANYLEN
821                       | FFESYMBOL_attrsANYSIZE
822                       | FFESYMBOL_attrsARRAY
823                       | FFESYMBOL_attrsCOMMON
824                       | FFESYMBOL_attrsDUMMY
825                       | FFESYMBOL_attrsEQUIV
826                       | FFESYMBOL_attrsEXTERNAL
827                       | FFESYMBOL_attrsINIT
828                       | FFESYMBOL_attrsNAMELIST
829                       | FFESYMBOL_attrsRESULT
830                       | FFESYMBOL_attrsSAVE
831                       | FFESYMBOL_attrsSFARG
832                       | FFESYMBOL_attrsSFUNC)));
833       assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
834                        | FFESYMBOL_attrsADJUSTS
835                        | FFESYMBOL_attrsANYLEN
836                        | FFESYMBOL_attrsANYSIZE
837                        | FFESYMBOL_attrsARRAY
838                        | FFESYMBOL_attrsCOMMON
839                        | FFESYMBOL_attrsDUMMY
840                        | FFESYMBOL_attrsEQUIV
841                        | FFESYMBOL_attrsEXTERNAL
842                        | FFESYMBOL_attrsINIT
843                        | FFESYMBOL_attrsINTRINSIC       /* UNDERSTOOD. */
844                        | FFESYMBOL_attrsNAMELIST
845                        | FFESYMBOL_attrsRESULT
846                        | FFESYMBOL_attrsSAVE
847                        | FFESYMBOL_attrsSFARG
848                        | FFESYMBOL_attrsSFUNC
849                        | FFESYMBOL_attrsTYPE)));        /* Have it. */
850
851       nkd = FFEINFO_kindNONE;   /* ENTITY, FUNCTION. */
852       nwh = FFEINFO_whereNONE;  /* DUMMY, GLOBAL, INTRINSIC, LOCAL, RESULT. */
853       ns = FFESYMBOL_stateUNCERTAIN;
854       resolve_intrin = FALSE;
855     }
856   else if (sa & (FFESYMBOL_attrsCBLOCK | FFESYMBOL_attrsSAVECBLOCK))
857     {                           /* COMMON block. */
858       assert (!(sa & ~(FFESYMBOL_attrsCBLOCK
859                        | FFESYMBOL_attrsSAVECBLOCK)));
860
861       if (sa & FFESYMBOL_attrsCBLOCK)
862         ffebld_end_list (ffesymbol_ptr_to_listbottom (s));
863       else
864         ffesymbol_set_commonlist (s, NULL);
865       ffestu_list_exec_transition_ (ffesymbol_commonlist (s));
866       nkd = FFEINFO_kindCOMMON;
867       nwh = FFEINFO_whereLOCAL;
868       needs_type = FALSE;
869     }
870   else
871     {                           /* First seen in stmt func definition. */
872       assert (sa == FFESYMBOL_attrsetNONE);
873       assert ("Why are we here again?" == NULL);        /* ~~~~~ */
874
875       nkd = FFEINFO_kindNONE;   /* ENTITY, FUNCTION. */
876       nwh = FFEINFO_whereNONE;  /* DUMMY, GLOBAL, LOCAL. */
877       ns = FFESYMBOL_stateUNCERTAIN;    /* Will get repromoted by caller. */
878       needs_type = FALSE;
879     }
880
881   if (na == FFESYMBOL_attrsetNONE)
882     ffesymbol_error (s, ffesta_tokens[0]);
883   else if (!(na & FFESYMBOL_attrsANY)
884            && (needs_type || (nkd != skd) || (nwh != swh)
885                || (na != sa) || (ns != ss)))
886     {
887       ffesymbol_signal_change (s);
888       ffesymbol_set_attrs (s, na);      /* Establish new info. */
889       ffesymbol_set_state (s, ns);
890       if ((ffesymbol_common (s) == NULL)
891           && (ffesymbol_equiv (s) != NULL))
892         ffesymbol_set_common (s, ffeequiv_common (ffesymbol_equiv (s)));
893       ffesymbol_set_info (s,
894                           ffeinfo_new (ffesymbol_basictype (s),
895                                        ffesymbol_kindtype (s),
896                                        ffesymbol_rank (s),
897                                        nkd,
898                                        nwh,
899                                        ffesymbol_size (s)));
900       if (needs_type && !ffeimplic_establish_symbol (s))
901         ffesymbol_error (s, ffesta_tokens[0]);
902       else if (resolve_intrin)
903         ffesymbol_resolve_intrin (s);
904       ffesymbol_reference (s, NULL, FALSE);
905       ffestorag_exec_layout (s);
906       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
907     }
908
909   return s;
910 }
911
912 /* ffestu_list_exec_transition_ -- Update SYMTERs in ITEM list w/in symbol
913
914    ffebld list;
915    ffestu_list_exec_transition_(list);
916
917    list contains an FFEBLD_opITEM list of SYMTERs (possibly STARs and
918    other things, too, but we'll ignore the known ones).  For each SYMTER,
919    we run sym_exec_transition_ on the corresponding ffesymbol (a recursive
920    call, since that's the function that's calling us) to update it's
921    information.  Then we copy that information into the SYMTER.
922
923    Make sure we don't get called recursively ourselves!  */
924
925 static void
926 ffestu_list_exec_transition_ (ffebld list)
927 {
928   static bool in_progress = FALSE;
929   ffebld item;
930   ffesymbol symbol;
931
932   assert (!in_progress);
933   in_progress = TRUE;
934
935   for (; list != NULL; list = ffebld_trail (list))
936     {
937       if ((item = ffebld_head (list)) == NULL)
938         continue;               /* Try next item. */
939
940       switch (ffebld_op (item))
941         {
942         case FFEBLD_opSTAR:
943           break;
944
945         case FFEBLD_opSYMTER:
946           symbol = ffebld_symter (item);
947           if (symbol == NULL)
948             break;              /* Detached from stmt func dummy list. */
949           symbol = ffecom_sym_exec_transition (symbol);
950           assert (ffesymbol_kind (symbol) != FFEINFO_kindNONE);
951           assert (ffesymbol_where (symbol) != FFEINFO_whereNONE);
952           ffebld_set_info (item, ffesymbol_info (symbol));
953           break;
954
955         default:
956           assert ("Unexpected item on list" == NULL);
957           break;
958         }
959     }
960
961   in_progress = FALSE;
962 }
963
964 /* ffestu_symter_end_transition_ -- Update SYMTERs in expr w/in symbol
965
966    ffebld expr;
967    ffestu_symter_end_transition_(expr);
968
969    Any SYMTER in expr's tree with whereNONE gets updated to the
970    (recursively transitioned) sym it identifies (DUMMY or COMMON).  */
971
972 static bool
973 ffestu_symter_end_transition_ (ffebld expr)
974 {
975   ffesymbol symbol;
976   bool any = FALSE;
977
978   /* Label used for tail recursion (reset expr and go here instead of calling
979      self). */
980
981 tail:                           /* :::::::::::::::::::: */
982
983   if (expr == NULL)
984     return any;
985
986   switch (ffebld_op (expr))
987     {
988     case FFEBLD_opITEM:
989       while (ffebld_trail (expr) != NULL)
990         {
991           if (ffestu_symter_end_transition_ (ffebld_head (expr)))
992             any = TRUE;
993           expr = ffebld_trail (expr);
994         }
995       expr = ffebld_head (expr);
996       goto tail;                /* :::::::::::::::::::: */
997
998     case FFEBLD_opSYMTER:
999       symbol = ffecom_sym_end_transition (ffebld_symter (expr));
1000       if ((symbol != NULL)
1001           && ffesymbol_attr (symbol, FFESYMBOL_attrANY))
1002         any = TRUE;
1003       ffebld_set_info (expr, ffesymbol_info (symbol));
1004       break;
1005
1006     case FFEBLD_opANY:
1007       return TRUE;
1008
1009     default:
1010       break;
1011     }
1012
1013   switch (ffebld_arity (expr))
1014     {
1015     case 2:
1016       if (ffestu_symter_end_transition_ (ffebld_left (expr)))
1017         any = TRUE;
1018       expr = ffebld_right (expr);
1019       goto tail;                /* :::::::::::::::::::: */
1020
1021     case 1:
1022       expr = ffebld_left (expr);
1023       goto tail;                /* :::::::::::::::::::: */
1024
1025     default:
1026       break;
1027     }
1028
1029   return any;
1030 }
1031
1032 /* ffestu_symter_exec_transition_ -- Update SYMTERs in expr w/in symbol
1033
1034    ffebld expr;
1035    ffestu_symter_exec_transition_(expr);
1036
1037    Any SYMTER in expr's tree with whereNONE gets updated to the
1038    (recursively transitioned) sym it identifies (DUMMY or COMMON).  */
1039
1040 static bool
1041 ffestu_symter_exec_transition_ (ffebld expr)
1042 {
1043   ffesymbol symbol;
1044   bool any = FALSE;
1045
1046   /* Label used for tail recursion (reset expr and go here instead of calling
1047      self). */
1048
1049 tail:                           /* :::::::::::::::::::: */
1050
1051   if (expr == NULL)
1052     return any;
1053
1054   switch (ffebld_op (expr))
1055     {
1056     case FFEBLD_opITEM:
1057       while (ffebld_trail (expr) != NULL)
1058         {
1059           if (ffestu_symter_exec_transition_ (ffebld_head (expr)))
1060             any = TRUE;
1061           expr = ffebld_trail (expr);
1062         }
1063       expr = ffebld_head (expr);
1064       goto tail;                /* :::::::::::::::::::: */
1065
1066     case FFEBLD_opSYMTER:
1067       symbol = ffecom_sym_exec_transition (ffebld_symter (expr));
1068       if ((symbol != NULL)
1069           && ffesymbol_attr (symbol, FFESYMBOL_attrANY))
1070         any = TRUE;
1071       ffebld_set_info (expr, ffesymbol_info (symbol));
1072       break;
1073
1074     case FFEBLD_opANY:
1075       return TRUE;
1076
1077     default:
1078       break;
1079     }
1080
1081   switch (ffebld_arity (expr))
1082     {
1083     case 2:
1084       if (ffestu_symter_exec_transition_ (ffebld_left (expr)))
1085         any = TRUE;
1086       expr = ffebld_right (expr);
1087       goto tail;                /* :::::::::::::::::::: */
1088
1089     case 1:
1090       expr = ffebld_left (expr);
1091       goto tail;                /* :::::::::::::::::::: */
1092
1093     default:
1094       break;
1095     }
1096
1097   return any;
1098 }
1099
1100 /* ffestu_dummies_transition_ -- Update SYMTERs in ITEM list w/in entry
1101
1102    ffebld list;
1103    ffesymbol symfunc(ffesymbol s);
1104    if (ffestu_dummies_transition_(symfunc,list))
1105        // One or more items are still UNCERTAIN.
1106
1107    list contains an FFEBLD_opITEM list of SYMTERs (possibly STARs and
1108    other things, too, but we'll ignore the known ones).  For each SYMTER,
1109    we run symfunc on the corresponding ffesymbol (a recursive
1110    call, since that's the function that's calling us) to update it's
1111    information.  Then we copy that information into the SYMTER.
1112
1113    Return TRUE if any of the SYMTER's has incomplete information.
1114
1115    Make sure we don't get called recursively ourselves!  */
1116
1117 static bool
1118 ffestu_dummies_transition_ (ffesymbol (*symfunc) (ffesymbol), ffebld list)
1119 {
1120   static bool in_progress = FALSE;
1121   ffebld item;
1122   ffesymbol symbol;
1123   bool uncertain = FALSE;
1124
1125   assert (!in_progress);
1126   in_progress = TRUE;
1127
1128   for (; list != NULL; list = ffebld_trail (list))
1129     {
1130       if ((item = ffebld_head (list)) == NULL)
1131         continue;               /* Try next item. */
1132
1133       switch (ffebld_op (item))
1134         {
1135         case FFEBLD_opSTAR:
1136           break;
1137
1138         case FFEBLD_opSYMTER:
1139           symbol = ffebld_symter (item);
1140           if (symbol == NULL)
1141             break;              /* Detached from stmt func dummy list. */
1142           symbol = (*symfunc) (symbol);
1143           if (ffesymbol_state (symbol) == FFESYMBOL_stateUNCERTAIN)
1144             uncertain = TRUE;
1145           else
1146             {
1147               assert (ffesymbol_kind (symbol) != FFEINFO_kindNONE);
1148               assert (ffesymbol_where (symbol) != FFEINFO_whereNONE);
1149             }
1150           ffebld_set_info (item, ffesymbol_info (symbol));
1151           break;
1152
1153         default:
1154           assert ("Unexpected item on list" == NULL);
1155           break;
1156         }
1157     }
1158
1159   in_progress = FALSE;
1160
1161   return uncertain;
1162 }