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
72 /* Update symbol info just before end of unit. */
73
74 ffesymbol
ffestu_sym_end_transition(ffesymbol s)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
ffestu_sym_exec_transition(ffesymbol s)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
ffestu_list_exec_transition_(ffebld list)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
ffestu_symter_end_transition_(ffebld expr)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
ffestu_symter_exec_transition_(ffebld expr)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
ffestu_dummies_transition_(ffesymbol (* symfunc)(ffesymbol),ffebld list)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 }
1163