]> gcc.gnu.org Git - gcc.git/blame - gcc/f/stu.c
git://gcc.gnu.org / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Initial revision
[gcc.git] / gcc / f / stu.c
CommitLineData
5ff904cd
JL		 1/* stu.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996 Free Software Foundation, Inc.
3 Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
4
5This file is part of GNU Fortran.
6
7GNU Fortran is free software; you can redistribute it and/or modify
8it under the terms of the GNU General Public License as published by
9the Free Software Foundation; either version 2, or (at your option)
10any later version.
11
12GNU Fortran is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15GNU General Public License for more details.
16
17You should have received a copy of the GNU General Public License
18along with GNU Fortran; see the file COPYING. If not, write to
19the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
2002111-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
60static void ffestu_list_exec_transition_ (ffebld list);
61static bool ffestu_symter_end_transition_ (ffebld expr);
62static bool ffestu_symter_exec_transition_ (ffebld expr);
63static bool ffestu_dummies_transition_ (ffesymbol (*symfunc) (),
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
74ffesymbol
75ffestu_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 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
390ffesymbol
391ffestu_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
924static void
925ffestu_list_exec_transition_ (ffebld list)
926{
927 static 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
971static bool
972ffestu_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
980tail: /* :::::::::::::::::::: */
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
1039static bool
1040ffestu_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
1048tail: /* :::::::::::::::::::: */
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
1116static bool
1117ffestu_dummies_transition_ (ffesymbol (*symfunc) (), ffebld list)
1118{
1119 static 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}
GNU Compiler Collection
This page took 0.126209 seconds and 5 git commands to generate.