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.
5 This file is part of GNU Fortran.
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)
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.
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
40 /* Externals defined here. */
43 /* Simple definitions and enumerations. */
46 /* Internal typedefs. */
49 /* Private include files. */
52 /* Internal structure definitions. */
55 /* Static objects accessed by functions in this module. */
58 /* Static functions (internal). */
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
),
66 /* Internal macros. */
68 #define ffestu_equiv_(s) (((ffesymbol_equiv (s) == NULL) \
69 || (ffeequiv_common (ffesymbol_equiv (s)) == NULL)) ? FFEINFO_whereLOCAL \
70 : FFEINFO_whereCOMMON)
72 /* Update symbol info just before end of unit. */
75 ffestu_sym_end_transition (ffesymbol s
)
85 bool needs_type
= TRUE
; /* Implicit type assignment might be
89 ss
= ffesymbol_state (s
);
90 sa
= ffesymbol_attrs (s
);
91 skd
= ffesymbol_kind (s
);
92 swh
= ffesymbol_where (s
);
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]);
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
);
113 case FFESYMBOL_stateUNDERSTOOD
:
114 if ((swh
== FFEINFO_whereLOCAL
)
115 && ((skd
== FFEINFO_kindFUNCTION
)
116 || (skd
== FFEINFO_kindSUBROUTINE
)))
121 ffeglobalArgSummary as
;
125 const char *name
= NULL
;
127 ffestu_dummies_transition_ (ffecom_sym_end_transition
,
128 ffesymbol_dummyargs (s
));
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;
134 list
= ffebld_trail (list
), ++n_args
)
136 item
= ffebld_head (list
);
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
))
146 as
= FFEGLOBAL_argsummaryALTRTN
;
149 case FFEBLD_opSYMTER
:
150 name
= ffesymbol_text (ffebld_symter (item
));
151 as
= FFEGLOBAL_argsummaryNONE
;
153 switch (ffeinfo_kind (ffebld_info (item
)))
155 case FFEINFO_kindFUNCTION
:
156 as
= FFEGLOBAL_argsummaryFUNC
;
159 case FFEINFO_kindSUBROUTINE
:
160 as
= FFEGLOBAL_argsummarySUBR
;
163 case FFEINFO_kindNONE
:
164 as
= FFEGLOBAL_argsummaryPROC
;
171 if (as
!= FFEGLOBAL_argsummaryNONE
)
176 if (bt
== FFEINFO_basictypeCHARACTER
)
177 as
= FFEGLOBAL_argsummaryDESCR
;
179 as
= FFEGLOBAL_argsummaryREF
;
185 as
= FFEGLOBAL_argsummaryNONE
;
186 bt
= FFEINFO_basictypeNONE
;
187 kt
= FFEINFO_kindtypeNONE
;
189 ffeglobal_proc_def_arg (s
, n_args
, name
, as
, bt
, kt
, array
);
192 else if (swh
== FFEINFO_whereDUMMY
)
194 if (ffesymbol_numentries (s
) == 0)
195 { /* Not actually in any dummy list! */
196 ffesymbol_error (s
, ffesta_tokens
[0]);
199 if (ffestu_symter_end_transition_ (ffesymbol_dims (s
)))
200 { /* Bad dimension expressions. */
201 ffesymbol_error (s
, NULL
);
205 else if ((swh
== FFEINFO_whereLOCAL
)
206 && ffestu_symter_end_transition_ (ffesymbol_dims (s
)))
207 { /* Bad dimension expressions. */
208 ffesymbol_error (s
, NULL
);
212 ffestorag_end_layout (s
);
213 ffesymbol_signal_unreported (s
); /* For debugging purposes. */
217 assert ("bad status" == NULL
);
221 ns
= FFESYMBOL_stateUNDERSTOOD
;
222 na
= sa
= ffesymbol_attrs (s
);
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
)));
236 /* Figure out what kind of object we've got based on previous declarations
237 of or references to the object. */
239 if (sa
& FFESYMBOL_attrsEXTERNAL
)
241 assert (!(sa
& ~(FFESYMBOL_attrsACTUALARG
242 | FFESYMBOL_attrsDUMMY
243 | FFESYMBOL_attrsEXTERNAL
244 | FFESYMBOL_attrsTYPE
)));
246 if (sa
& FFESYMBOL_attrsTYPE
)
247 nwh
= FFEINFO_whereGLOBAL
;
251 if (sa
& FFESYMBOL_attrsDUMMY
)
253 ns
= FFESYMBOL_stateUNCERTAIN
; /* FUNCTION/SUBROUTINE. */
254 needs_type
= FALSE
; /* Don't assign type to SUBROUTINE! */
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! */
262 /* Not ACTUALARG, DUMMY, or TYPE. */
263 { /* This is an assumption, essentially. */
264 nkd
= FFEINFO_kindBLOCKDATA
;
265 nwh
= FFEINFO_whereGLOBAL
;
270 else if (sa
& FFESYMBOL_attrsDUMMY
)
272 assert (!(sa
& FFESYMBOL_attrsEXTERNAL
)); /* Handled above. */
273 assert (!(sa
& ~(FFESYMBOL_attrsDUMMY
274 | FFESYMBOL_attrsEXTERNAL
275 | FFESYMBOL_attrsTYPE
)));
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. */
287 nkd
= FFEINFO_kindENTITY
;
289 else if (sa
& FFESYMBOL_attrsARRAY
)
291 assert (!(sa
& ~(FFESYMBOL_attrsARRAY
292 | FFESYMBOL_attrsADJUSTABLE
293 | FFESYMBOL_attrsTYPE
)));
295 if (ffestu_symter_end_transition_ (ffesymbol_dims (s
)))
297 ffesymbol_error (s
, NULL
);
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
))
308 ffebad_string (ffesymbol_text (s
));
309 ffebad_here (0, ffesymbol_where_line (s
),
310 ffesymbol_where_column (s
));
314 nwh
= FFEINFO_whereLOCAL
;
316 else if (sa
& FFESYMBOL_attrsSFARG
)
318 assert (!(sa
& ~(FFESYMBOL_attrsSFARG
319 | FFESYMBOL_attrsTYPE
)));
321 nwh
= FFEINFO_whereLOCAL
;
323 else if (sa
& FFESYMBOL_attrsTYPE
)
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
)));
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. */
349 nkd
= FFEINFO_kindENTITY
;
350 nwh
= FFEINFO_whereLOCAL
;
353 assert ("unexpected attribute set" == NULL
);
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. */
359 if (na
== FFESYMBOL_attrsetNONE
)
360 ffesymbol_error (s
, ffesta_tokens
[0]);
361 else if (!(na
& FFESYMBOL_attrsANY
))
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
),
372 ffesymbol_size (s
)));
373 if (needs_type
&& !ffeimplic_establish_symbol (s
))
374 ffesymbol_error (s
, ffesta_tokens
[0]);
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. */
386 /* ffestu_sym_exec_transition -- Update symbol just before first exec stmt
389 ffestu_sym_exec_transition(s); */
392 ffestu_sym_exec_transition (ffesymbol s
)
405 bool needs_type
= TRUE
; /* Implicit type assignment might be
407 bool resolve_intrin
= TRUE
; /* Might need to resolve intrinsic. */
411 sa
= ffesymbol_attrs (s
);
412 skd
= ffesymbol_kind (s
);
413 swh
= ffesymbol_where (s
);
414 ss
= ffesymbol_state (s
);
418 case FFESYMBOL_stateNONE
:
419 return s
; /* Assume caller will handle it. */
421 case FFESYMBOL_stateSEEN
:
424 case FFESYMBOL_stateUNCERTAIN
:
425 ffestorag_exec_layout (s
);
426 return s
; /* Already processed this one, or not
429 case FFESYMBOL_stateUNDERSTOOD
:
430 if (skd
== FFEINFO_kindNAMELIST
)
432 ffebld_end_list (ffesymbol_ptr_to_listbottom (s
));
433 ffestu_list_exec_transition_ (ffesymbol_namelist (s
));
435 else if ((swh
== FFEINFO_whereLOCAL
)
436 && ((skd
== FFEINFO_kindFUNCTION
)
437 || (skd
== FFEINFO_kindSUBROUTINE
)))
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]);
446 ffesymbol_reference (s
, NULL
, FALSE
);
447 ffestorag_exec_layout (s
);
448 ffesymbol_signal_unreported (s
); /* For debugging purposes. */
452 assert ("bad status" == NULL
);
456 ns
= FFESYMBOL_stateUNDERSTOOD
; /* Only a few UNCERTAIN exceptions. */
462 assert (!(sa
& FFESYMBOL_attrsANY
));
464 if (sa
& FFESYMBOL_attrsCOMMON
)
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
)));
475 nkd
= FFEINFO_kindENTITY
;
476 nwh
= FFEINFO_whereCOMMON
;
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
)));
485 nkd
= FFEINFO_kindENTITY
;
486 nwh
= FFEINFO_whereRESULT
;
488 else if (sa
& FFESYMBOL_attrsSFUNC
)
489 { /* Statement function. */
490 assert (!(sa
& ~(FFESYMBOL_attrsSFUNC
491 | FFESYMBOL_attrsTYPE
)));
493 nkd
= FFEINFO_kindFUNCTION
;
494 nwh
= FFEINFO_whereCONSTANT
;
496 else if (sa
& FFESYMBOL_attrsEXTERNAL
)
498 assert (!(sa
& ~(FFESYMBOL_attrsDUMMY
499 | FFESYMBOL_attrsEXTERNAL
500 | FFESYMBOL_attrsTYPE
)));
502 if (sa
& FFESYMBOL_attrsTYPE
)
504 nkd
= FFEINFO_kindFUNCTION
;
506 if (sa
& FFESYMBOL_attrsDUMMY
)
507 nwh
= FFEINFO_whereDUMMY
;
510 if (ffesta_is_entry_valid
)
512 nwh
= FFEINFO_whereNONE
; /* DUMMY, GLOBAL. */
513 ns
= FFESYMBOL_stateUNCERTAIN
;
516 nwh
= FFEINFO_whereGLOBAL
;
522 nkd
= FFEINFO_kindNONE
; /* FUNCTION, SUBROUTINE, BLOCKDATA. */
523 needs_type
= FALSE
; /* Only gets type if FUNCTION. */
524 ns
= FFESYMBOL_stateUNCERTAIN
;
526 if (sa
& FFESYMBOL_attrsDUMMY
)
527 nwh
= FFEINFO_whereDUMMY
; /* Not BLOCKDATA. */
530 if (ffesta_is_entry_valid
)
531 nwh
= FFEINFO_whereNONE
; /* DUMMY, GLOBAL. */
533 nwh
= FFEINFO_whereGLOBAL
;
537 else if (sa
& FFESYMBOL_attrsDUMMY
)
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. */
550 nwh
= FFEINFO_whereDUMMY
;
552 if (ffestu_symter_exec_transition_ (ffesymbol_dims (s
)))
553 na
= FFESYMBOL_attrsetNONE
;
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. */
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
;
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. */
582 nkd
= FFEINFO_kindENTITY
;
584 if (sa
& FFESYMBOL_attrsEQUIV
)
586 if ((ffesymbol_equiv (s
) == NULL
)
587 || (ffeequiv_common (ffesymbol_equiv (s
)) == NULL
))
588 na
= FFESYMBOL_attrsetNONE
; /* Not equiv'd into COMMON. */
590 nwh
= FFEINFO_whereCOMMON
;
592 else if (!ffesta_is_entry_valid
593 || (sa
& (FFESYMBOL_attrsINIT
594 | FFESYMBOL_attrsNAMELIST
)))
595 na
= FFESYMBOL_attrsetNONE
;
597 nwh
= FFEINFO_whereDUMMY
;
599 else if (sa
& FFESYMBOL_attrsSAVE
)
601 assert (!(sa
& ~(FFESYMBOL_attrsARRAY
602 | FFESYMBOL_attrsEQUIV
603 | FFESYMBOL_attrsINIT
604 | FFESYMBOL_attrsNAMELIST
605 | FFESYMBOL_attrsSAVE
606 | FFESYMBOL_attrsSFARG
607 | FFESYMBOL_attrsTYPE
)));
609 nkd
= FFEINFO_kindENTITY
;
610 nwh
= FFEINFO_whereLOCAL
;
612 else if (sa
& FFESYMBOL_attrsEQUIV
)
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. */
625 nkd
= FFEINFO_kindENTITY
;
626 nwh
= ffestu_equiv_ (s
);
628 else if (sa
& FFESYMBOL_attrsNAMELIST
)
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. */
644 nkd
= FFEINFO_kindENTITY
;
645 nwh
= FFEINFO_whereLOCAL
;
647 else if (sa
& FFESYMBOL_attrsINIT
)
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. */
664 nkd
= FFEINFO_kindENTITY
;
665 nwh
= FFEINFO_whereLOCAL
;
667 else if (sa
& FFESYMBOL_attrsSFARG
)
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. */
688 nkd
= FFEINFO_kindENTITY
;
690 if (ffesta_is_entry_valid
)
692 nwh
= FFEINFO_whereNONE
; /* DUMMY, LOCAL. */
693 ns
= FFESYMBOL_stateUNCERTAIN
;
696 nwh
= FFEINFO_whereLOCAL
;
698 else if (sa
& (FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYSIZE
))
700 assert (!(sa
& ~(FFESYMBOL_attrsADJUSTABLE
701 | FFESYMBOL_attrsANYLEN
702 | FFESYMBOL_attrsANYSIZE
703 | FFESYMBOL_attrsARRAY
704 | FFESYMBOL_attrsTYPE
)));
706 nkd
= FFEINFO_kindENTITY
;
708 if (ffestu_symter_exec_transition_ (ffesymbol_dims (s
)))
709 na
= FFESYMBOL_attrsetNONE
;
711 if (sa
& (FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsANYSIZE
))
712 nwh
= FFEINFO_whereDUMMY
;
713 else if (sa
& (FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYSIZE
))
716 nwh
= FFEINFO_whereNONE
; /* DUMMY, LOCAL. */
717 ns
= FFESYMBOL_stateUNCERTAIN
;
720 else if (sa
& FFESYMBOL_attrsARRAY
)
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. */
742 nkd
= FFEINFO_kindENTITY
;
744 if (sa
& FFESYMBOL_attrsANYLEN
)
746 assert (ffesta_is_entry_valid
); /* Already diagnosed. */
747 nwh
= FFEINFO_whereDUMMY
;
751 if (ffesta_is_entry_valid
)
753 nwh
= FFEINFO_whereNONE
; /* DUMMY, LOCAL. */
754 ns
= FFESYMBOL_stateUNCERTAIN
;
757 nwh
= FFEINFO_whereLOCAL
;
760 else if (sa
& FFESYMBOL_attrsANYLEN
)
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. */
775 if (ffesta_is_entry_valid
)
777 nkd
= FFEINFO_kindNONE
; /* ENTITY, FUNCTION. */
778 nwh
= FFEINFO_whereNONE
; /* DUMMY, INTRINSIC, RESULT. */
779 ns
= FFESYMBOL_stateUNCERTAIN
;
780 resolve_intrin
= FALSE
;
782 else if (ffeintrin_is_intrinsic (ffesymbol_text (s
), NULL
, FALSE
,
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
,
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. */
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. */
816 else if (sa
& FFESYMBOL_attrsTYPE
)
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. */
851 nkd
= FFEINFO_kindNONE
; /* ENTITY, FUNCTION. */
852 nwh
= FFEINFO_whereNONE
; /* DUMMY, GLOBAL, INTRINSIC, LOCAL, RESULT. */
853 ns
= FFESYMBOL_stateUNCERTAIN
;
854 resolve_intrin
= FALSE
;
856 else if (sa
& (FFESYMBOL_attrsCBLOCK
| FFESYMBOL_attrsSAVECBLOCK
))
857 { /* COMMON block. */
858 assert (!(sa
& ~(FFESYMBOL_attrsCBLOCK
859 | FFESYMBOL_attrsSAVECBLOCK
)));
861 if (sa
& FFESYMBOL_attrsCBLOCK
)
862 ffebld_end_list (ffesymbol_ptr_to_listbottom (s
));
864 ffesymbol_set_commonlist (s
, NULL
);
865 ffestu_list_exec_transition_ (ffesymbol_commonlist (s
));
866 nkd
= FFEINFO_kindCOMMON
;
867 nwh
= FFEINFO_whereLOCAL
;
871 { /* First seen in stmt func definition. */
872 assert (sa
== FFESYMBOL_attrsetNONE
);
873 assert ("Why are we here again?" == NULL
); /* ~~~~~ */
875 nkd
= FFEINFO_kindNONE
; /* ENTITY, FUNCTION. */
876 nwh
= FFEINFO_whereNONE
; /* DUMMY, GLOBAL, LOCAL. */
877 ns
= FFESYMBOL_stateUNCERTAIN
; /* Will get repromoted by caller. */
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
)))
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
),
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. */
912 /* ffestu_list_exec_transition_ -- Update SYMTERs in ITEM list w/in symbol
915 ffestu_list_exec_transition_(list);
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.
923 Make sure we don't get called recursively ourselves! */
926 ffestu_list_exec_transition_ (ffebld list
)
928 static bool in_progress
= FALSE
;
932 assert (!in_progress
);
935 for (; list
!= NULL
; list
= ffebld_trail (list
))
937 if ((item
= ffebld_head (list
)) == NULL
)
938 continue; /* Try next item. */
940 switch (ffebld_op (item
))
945 case FFEBLD_opSYMTER
:
946 symbol
= ffebld_symter (item
);
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
));
956 assert ("Unexpected item on list" == NULL
);
964 /* ffestu_symter_end_transition_ -- Update SYMTERs in expr w/in symbol
967 ffestu_symter_end_transition_(expr);
969 Any SYMTER in expr's tree with whereNONE gets updated to the
970 (recursively transitioned) sym it identifies (DUMMY or COMMON). */
973 ffestu_symter_end_transition_ (ffebld expr
)
978 /* Label used for tail recursion (reset expr and go here instead of calling
981 tail
: /* :::::::::::::::::::: */
986 switch (ffebld_op (expr
))
989 while (ffebld_trail (expr
) != NULL
)
991 if (ffestu_symter_end_transition_ (ffebld_head (expr
)))
993 expr
= ffebld_trail (expr
);
995 expr
= ffebld_head (expr
);
996 goto tail
; /* :::::::::::::::::::: */
998 case FFEBLD_opSYMTER
:
999 symbol
= ffecom_sym_end_transition (ffebld_symter (expr
));
1000 if ((symbol
!= NULL
)
1001 && ffesymbol_attr (symbol
, FFESYMBOL_attrANY
))
1003 ffebld_set_info (expr
, ffesymbol_info (symbol
));
1013 switch (ffebld_arity (expr
))
1016 if (ffestu_symter_end_transition_ (ffebld_left (expr
)))
1018 expr
= ffebld_right (expr
);
1019 goto tail
; /* :::::::::::::::::::: */
1022 expr
= ffebld_left (expr
);
1023 goto tail
; /* :::::::::::::::::::: */
1032 /* ffestu_symter_exec_transition_ -- Update SYMTERs in expr w/in symbol
1035 ffestu_symter_exec_transition_(expr);
1037 Any SYMTER in expr's tree with whereNONE gets updated to the
1038 (recursively transitioned) sym it identifies (DUMMY or COMMON). */
1041 ffestu_symter_exec_transition_ (ffebld expr
)
1046 /* Label used for tail recursion (reset expr and go here instead of calling
1049 tail
: /* :::::::::::::::::::: */
1054 switch (ffebld_op (expr
))
1057 while (ffebld_trail (expr
) != NULL
)
1059 if (ffestu_symter_exec_transition_ (ffebld_head (expr
)))
1061 expr
= ffebld_trail (expr
);
1063 expr
= ffebld_head (expr
);
1064 goto tail
; /* :::::::::::::::::::: */
1066 case FFEBLD_opSYMTER
:
1067 symbol
= ffecom_sym_exec_transition (ffebld_symter (expr
));
1068 if ((symbol
!= NULL
)
1069 && ffesymbol_attr (symbol
, FFESYMBOL_attrANY
))
1071 ffebld_set_info (expr
, ffesymbol_info (symbol
));
1081 switch (ffebld_arity (expr
))
1084 if (ffestu_symter_exec_transition_ (ffebld_left (expr
)))
1086 expr
= ffebld_right (expr
);
1087 goto tail
; /* :::::::::::::::::::: */
1090 expr
= ffebld_left (expr
);
1091 goto tail
; /* :::::::::::::::::::: */
1100 /* ffestu_dummies_transition_ -- Update SYMTERs in ITEM list w/in entry
1103 ffesymbol symfunc(ffesymbol s);
1104 if (ffestu_dummies_transition_(symfunc,list))
1105 // One or more items are still UNCERTAIN.
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.
1113 Return TRUE if any of the SYMTER's has incomplete information.
1115 Make sure we don't get called recursively ourselves! */
1118 ffestu_dummies_transition_ (ffesymbol (*symfunc
) (ffesymbol
), ffebld list
)
1120 static bool in_progress
= FALSE
;
1123 bool uncertain
= FALSE
;
1125 assert (!in_progress
);
1128 for (; list
!= NULL
; list
= ffebld_trail (list
))
1130 if ((item
= ffebld_head (list
)) == NULL
)
1131 continue; /* Try next item. */
1133 switch (ffebld_op (item
))
1138 case FFEBLD_opSYMTER
:
1139 symbol
= ffebld_symter (item
);
1141 break; /* Detached from stmt func dummy list. */
1142 symbol
= (*symfunc
) (symbol
);
1143 if (ffesymbol_state (symbol
) == FFESYMBOL_stateUNCERTAIN
)
1147 assert (ffesymbol_kind (symbol
) != FFEINFO_kindNONE
);
1148 assert (ffesymbol_where (symbol
) != FFEINFO_whereNONE
);
1150 ffebld_set_info (item
, ffesymbol_info (symbol
));
1154 assert ("Unexpected item on list" == NULL
);
1159 in_progress
= FALSE
;