1 /* stu.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997 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 && ffebad_start_msg ("Local adjustable symbol `%A' at %0",
305 FFEBAD_severityPEDANTIC
))
307 ffebad_string (ffesymbol_text (s
));
308 ffebad_here (0, ffesymbol_where_line (s
),
309 ffesymbol_where_column (s
));
313 nwh
= FFEINFO_whereLOCAL
;
315 else if (sa
& FFESYMBOL_attrsSFARG
)
317 assert (!(sa
& ~(FFESYMBOL_attrsSFARG
318 | FFESYMBOL_attrsTYPE
)));
320 nwh
= FFEINFO_whereLOCAL
;
322 else if (sa
& FFESYMBOL_attrsTYPE
)
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
)));
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. */
348 nkd
= FFEINFO_kindENTITY
;
349 nwh
= FFEINFO_whereLOCAL
;
352 assert ("unexpected attribute set" == NULL
);
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. */
358 if (na
== FFESYMBOL_attrsetNONE
)
359 ffesymbol_error (s
, ffesta_tokens
[0]);
360 else if (!(na
& FFESYMBOL_attrsANY
))
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
),
371 ffesymbol_size (s
)));
372 if (needs_type
&& !ffeimplic_establish_symbol (s
))
373 ffesymbol_error (s
, ffesta_tokens
[0]);
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. */
385 /* ffestu_sym_exec_transition -- Update symbol just before first exec stmt
388 ffestu_sym_exec_transition(s); */
391 ffestu_sym_exec_transition (ffesymbol s
)
404 bool needs_type
= TRUE
; /* Implicit type assignment might be
406 bool resolve_intrin
= TRUE
; /* Might need to resolve intrinsic. */
410 sa
= ffesymbol_attrs (s
);
411 skd
= ffesymbol_kind (s
);
412 swh
= ffesymbol_where (s
);
413 ss
= ffesymbol_state (s
);
417 case FFESYMBOL_stateNONE
:
418 return s
; /* Assume caller will handle it. */
420 case FFESYMBOL_stateSEEN
:
423 case FFESYMBOL_stateUNCERTAIN
:
424 ffestorag_exec_layout (s
);
425 return s
; /* Already processed this one, or not
428 case FFESYMBOL_stateUNDERSTOOD
:
429 if (skd
== FFEINFO_kindNAMELIST
)
431 ffebld_end_list (ffesymbol_ptr_to_listbottom (s
));
432 ffestu_list_exec_transition_ (ffesymbol_namelist (s
));
434 else if ((swh
== FFEINFO_whereLOCAL
)
435 && ((skd
== FFEINFO_kindFUNCTION
)
436 || (skd
== FFEINFO_kindSUBROUTINE
)))
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]);
445 ffesymbol_reference (s
, NULL
, FALSE
);
446 ffestorag_exec_layout (s
);
447 ffesymbol_signal_unreported (s
); /* For debugging purposes. */
451 assert ("bad status" == NULL
);
455 ns
= FFESYMBOL_stateUNDERSTOOD
; /* Only a few UNCERTAIN exceptions. */
461 assert (!(sa
& FFESYMBOL_attrsANY
));
463 if (sa
& FFESYMBOL_attrsCOMMON
)
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
)));
474 nkd
= FFEINFO_kindENTITY
;
475 nwh
= FFEINFO_whereCOMMON
;
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
)));
484 nkd
= FFEINFO_kindENTITY
;
485 nwh
= FFEINFO_whereRESULT
;
487 else if (sa
& FFESYMBOL_attrsSFUNC
)
488 { /* Statement function. */
489 assert (!(sa
& ~(FFESYMBOL_attrsSFUNC
490 | FFESYMBOL_attrsTYPE
)));
492 nkd
= FFEINFO_kindFUNCTION
;
493 nwh
= FFEINFO_whereCONSTANT
;
495 else if (sa
& FFESYMBOL_attrsEXTERNAL
)
497 assert (!(sa
& ~(FFESYMBOL_attrsDUMMY
498 | FFESYMBOL_attrsEXTERNAL
499 | FFESYMBOL_attrsTYPE
)));
501 if (sa
& FFESYMBOL_attrsTYPE
)
503 nkd
= FFEINFO_kindFUNCTION
;
505 if (sa
& FFESYMBOL_attrsDUMMY
)
506 nwh
= FFEINFO_whereDUMMY
;
509 if (ffesta_is_entry_valid
)
511 nwh
= FFEINFO_whereNONE
; /* DUMMY, GLOBAL. */
512 ns
= FFESYMBOL_stateUNCERTAIN
;
515 nwh
= FFEINFO_whereGLOBAL
;
521 nkd
= FFEINFO_kindNONE
; /* FUNCTION, SUBROUTINE, BLOCKDATA. */
522 needs_type
= FALSE
; /* Only gets type if FUNCTION. */
523 ns
= FFESYMBOL_stateUNCERTAIN
;
525 if (sa
& FFESYMBOL_attrsDUMMY
)
526 nwh
= FFEINFO_whereDUMMY
; /* Not BLOCKDATA. */
529 if (ffesta_is_entry_valid
)
530 nwh
= FFEINFO_whereNONE
; /* DUMMY, GLOBAL. */
532 nwh
= FFEINFO_whereGLOBAL
;
536 else if (sa
& FFESYMBOL_attrsDUMMY
)
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. */
549 nwh
= FFEINFO_whereDUMMY
;
551 if (ffestu_symter_exec_transition_ (ffesymbol_dims (s
)))
552 na
= FFESYMBOL_attrsetNONE
;
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. */
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
;
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. */
581 nkd
= FFEINFO_kindENTITY
;
583 if (sa
& FFESYMBOL_attrsEQUIV
)
585 if ((ffesymbol_equiv (s
) == NULL
)
586 || (ffeequiv_common (ffesymbol_equiv (s
)) == NULL
))
587 na
= FFESYMBOL_attrsetNONE
; /* Not equiv'd into COMMON. */
589 nwh
= FFEINFO_whereCOMMON
;
591 else if (!ffesta_is_entry_valid
592 || (sa
& (FFESYMBOL_attrsINIT
593 | FFESYMBOL_attrsNAMELIST
)))
594 na
= FFESYMBOL_attrsetNONE
;
596 nwh
= FFEINFO_whereDUMMY
;
598 else if (sa
& FFESYMBOL_attrsSAVE
)
600 assert (!(sa
& ~(FFESYMBOL_attrsARRAY
601 | FFESYMBOL_attrsEQUIV
602 | FFESYMBOL_attrsINIT
603 | FFESYMBOL_attrsNAMELIST
604 | FFESYMBOL_attrsSAVE
605 | FFESYMBOL_attrsSFARG
606 | FFESYMBOL_attrsTYPE
)));
608 nkd
= FFEINFO_kindENTITY
;
609 nwh
= FFEINFO_whereLOCAL
;
611 else if (sa
& FFESYMBOL_attrsEQUIV
)
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. */
624 nkd
= FFEINFO_kindENTITY
;
625 nwh
= ffestu_equiv_ (s
);
627 else if (sa
& FFESYMBOL_attrsNAMELIST
)
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. */
643 nkd
= FFEINFO_kindENTITY
;
644 nwh
= FFEINFO_whereLOCAL
;
646 else if (sa
& FFESYMBOL_attrsINIT
)
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. */
663 nkd
= FFEINFO_kindENTITY
;
664 nwh
= FFEINFO_whereLOCAL
;
666 else if (sa
& FFESYMBOL_attrsSFARG
)
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. */
687 nkd
= FFEINFO_kindENTITY
;
689 if (ffesta_is_entry_valid
)
691 nwh
= FFEINFO_whereNONE
; /* DUMMY, LOCAL. */
692 ns
= FFESYMBOL_stateUNCERTAIN
;
695 nwh
= FFEINFO_whereLOCAL
;
697 else if (sa
& (FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYSIZE
))
699 assert (!(sa
& ~(FFESYMBOL_attrsADJUSTABLE
700 | FFESYMBOL_attrsANYLEN
701 | FFESYMBOL_attrsANYSIZE
702 | FFESYMBOL_attrsARRAY
703 | FFESYMBOL_attrsTYPE
)));
705 nkd
= FFEINFO_kindENTITY
;
707 if (ffestu_symter_exec_transition_ (ffesymbol_dims (s
)))
708 na
= FFESYMBOL_attrsetNONE
;
710 if (sa
& (FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsANYSIZE
))
711 nwh
= FFEINFO_whereDUMMY
;
712 else if (sa
& (FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYSIZE
))
715 nwh
= FFEINFO_whereNONE
; /* DUMMY, LOCAL. */
716 ns
= FFESYMBOL_stateUNCERTAIN
;
719 else if (sa
& FFESYMBOL_attrsARRAY
)
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. */
741 nkd
= FFEINFO_kindENTITY
;
743 if (sa
& FFESYMBOL_attrsANYLEN
)
745 assert (ffesta_is_entry_valid
); /* Already diagnosed. */
746 nwh
= FFEINFO_whereDUMMY
;
750 if (ffesta_is_entry_valid
)
752 nwh
= FFEINFO_whereNONE
; /* DUMMY, LOCAL. */
753 ns
= FFESYMBOL_stateUNCERTAIN
;
756 nwh
= FFEINFO_whereLOCAL
;
759 else if (sa
& FFESYMBOL_attrsANYLEN
)
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. */
774 if (ffesta_is_entry_valid
)
776 nkd
= FFEINFO_kindNONE
; /* ENTITY, FUNCTION. */
777 nwh
= FFEINFO_whereNONE
; /* DUMMY, INTRINSIC, RESULT. */
778 ns
= FFESYMBOL_stateUNCERTAIN
;
779 resolve_intrin
= FALSE
;
781 else if (ffeintrin_is_intrinsic (ffesymbol_text (s
), NULL
, FALSE
,
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
,
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. */
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. */
815 else if (sa
& FFESYMBOL_attrsTYPE
)
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. */
850 nkd
= FFEINFO_kindNONE
; /* ENTITY, FUNCTION. */
851 nwh
= FFEINFO_whereNONE
; /* DUMMY, GLOBAL, INTRINSIC, LOCAL, RESULT. */
852 ns
= FFESYMBOL_stateUNCERTAIN
;
853 resolve_intrin
= FALSE
;
855 else if (sa
& (FFESYMBOL_attrsCBLOCK
| FFESYMBOL_attrsSAVECBLOCK
))
856 { /* COMMON block. */
857 assert (!(sa
& ~(FFESYMBOL_attrsCBLOCK
858 | FFESYMBOL_attrsSAVECBLOCK
)));
860 if (sa
& FFESYMBOL_attrsCBLOCK
)
861 ffebld_end_list (ffesymbol_ptr_to_listbottom (s
));
863 ffesymbol_set_commonlist (s
, NULL
);
864 ffestu_list_exec_transition_ (ffesymbol_commonlist (s
));
865 nkd
= FFEINFO_kindCOMMON
;
866 nwh
= FFEINFO_whereLOCAL
;
870 { /* First seen in stmt func definition. */
871 assert (sa
== FFESYMBOL_attrsetNONE
);
872 assert ("Why are we here again?" == NULL
); /* ~~~~~ */
874 nkd
= FFEINFO_kindNONE
; /* ENTITY, FUNCTION. */
875 nwh
= FFEINFO_whereNONE
; /* DUMMY, GLOBAL, LOCAL. */
876 ns
= FFESYMBOL_stateUNCERTAIN
; /* Will get repromoted by caller. */
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
)))
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
),
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. */
911 /* ffestu_list_exec_transition_ -- Update SYMTERs in ITEM list w/in symbol
914 ffestu_list_exec_transition_(list);
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.
922 Make sure we don't get called recursively ourselves! */
925 ffestu_list_exec_transition_ (ffebld list
)
927 static bool in_progress
= FALSE
;
931 assert (!in_progress
);
934 for (; list
!= NULL
; list
= ffebld_trail (list
))
936 if ((item
= ffebld_head (list
)) == NULL
)
937 continue; /* Try next item. */
939 switch (ffebld_op (item
))
944 case FFEBLD_opSYMTER
:
945 symbol
= ffebld_symter (item
);
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
));
955 assert ("Unexpected item on list" == NULL
);
963 /* ffestu_symter_end_transition_ -- Update SYMTERs in expr w/in symbol
966 ffestu_symter_end_transition_(expr);
968 Any SYMTER in expr's tree with whereNONE gets updated to the
969 (recursively transitioned) sym it identifies (DUMMY or COMMON). */
972 ffestu_symter_end_transition_ (ffebld expr
)
977 /* Label used for tail recursion (reset expr and go here instead of calling
980 tail
: /* :::::::::::::::::::: */
985 switch (ffebld_op (expr
))
988 while (ffebld_trail (expr
) != NULL
)
990 if (ffestu_symter_end_transition_ (ffebld_head (expr
)))
992 expr
= ffebld_trail (expr
);
994 expr
= ffebld_head (expr
);
995 goto tail
; /* :::::::::::::::::::: */
997 case FFEBLD_opSYMTER
:
998 symbol
= ffecom_sym_end_transition (ffebld_symter (expr
));
1000 && ffesymbol_attr (symbol
, FFESYMBOL_attrANY
))
1002 ffebld_set_info (expr
, ffesymbol_info (symbol
));
1012 switch (ffebld_arity (expr
))
1015 if (ffestu_symter_end_transition_ (ffebld_left (expr
)))
1017 expr
= ffebld_right (expr
);
1018 goto tail
; /* :::::::::::::::::::: */
1021 expr
= ffebld_left (expr
);
1022 goto tail
; /* :::::::::::::::::::: */
1031 /* ffestu_symter_exec_transition_ -- Update SYMTERs in expr w/in symbol
1034 ffestu_symter_exec_transition_(expr);
1036 Any SYMTER in expr's tree with whereNONE gets updated to the
1037 (recursively transitioned) sym it identifies (DUMMY or COMMON). */
1040 ffestu_symter_exec_transition_ (ffebld expr
)
1045 /* Label used for tail recursion (reset expr and go here instead of calling
1048 tail
: /* :::::::::::::::::::: */
1053 switch (ffebld_op (expr
))
1056 while (ffebld_trail (expr
) != NULL
)
1058 if (ffestu_symter_exec_transition_ (ffebld_head (expr
)))
1060 expr
= ffebld_trail (expr
);
1062 expr
= ffebld_head (expr
);
1063 goto tail
; /* :::::::::::::::::::: */
1065 case FFEBLD_opSYMTER
:
1066 symbol
= ffecom_sym_exec_transition (ffebld_symter (expr
));
1067 if ((symbol
!= NULL
)
1068 && ffesymbol_attr (symbol
, FFESYMBOL_attrANY
))
1070 ffebld_set_info (expr
, ffesymbol_info (symbol
));
1080 switch (ffebld_arity (expr
))
1083 if (ffestu_symter_exec_transition_ (ffebld_left (expr
)))
1085 expr
= ffebld_right (expr
);
1086 goto tail
; /* :::::::::::::::::::: */
1089 expr
= ffebld_left (expr
);
1090 goto tail
; /* :::::::::::::::::::: */
1099 /* ffestu_dummies_transition_ -- Update SYMTERs in ITEM list w/in entry
1102 ffesymbol symfunc(ffesymbol s);
1103 if (ffestu_dummies_transition_(symfunc,list))
1104 // One or more items are still UNCERTAIN.
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.
1112 Return TRUE if any of the SYMTER's has incomplete information.
1114 Make sure we don't get called recursively ourselves! */
1117 ffestu_dummies_transition_ (ffesymbol (*symfunc
) (ffesymbol
), ffebld list
)
1119 static bool in_progress
= FALSE
;
1122 bool uncertain
= FALSE
;
1124 assert (!in_progress
);
1127 for (; list
!= NULL
; list
= ffebld_trail (list
))
1129 if ((item
= ffebld_head (list
)) == NULL
)
1130 continue; /* Try next item. */
1132 switch (ffebld_op (item
))
1137 case FFEBLD_opSYMTER
:
1138 symbol
= ffebld_symter (item
);
1140 break; /* Detached from stmt func dummy list. */
1141 symbol
= (*symfunc
) (symbol
);
1142 if (ffesymbol_state (symbol
) == FFESYMBOL_stateUNCERTAIN
)
1146 assert (ffesymbol_kind (symbol
) != FFEINFO_kindNONE
);
1147 assert (ffesymbol_where (symbol
) != FFEINFO_whereNONE
);
1149 ffebld_set_info (item
, ffesymbol_info (symbol
));
1153 assert ("Unexpected item on list" == NULL
);
1158 in_progress
= FALSE
;