1 /* Implementation of Fortran symbol manager
2 Copyright (C) 1995-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
39 /* Choice of how to handle global symbols -- either global only within the
40 program unit being defined or global within the entire source file.
41 The former is appropriate for systems where an object file can
42 easily be taken apart program unit by program unit, the latter is the
43 UNIX/C model where the object file is essentially a monolith. */
45 #define FFESYMBOL_globalPROGUNIT_ 1
46 #define FFESYMBOL_globalFILE_ 2
48 /* Choose how to handle global symbols here. */
50 #if FFECOM_targetCURRENT == FFECOM_targetFFE
51 #define FFESYMBOL_globalCURRENT_ FFESYMBOL_globalPROGUNIT_
52 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
53 /* Would be good to understand why PROGUNIT in this case too.
55 #define FFESYMBOL_globalCURRENT_ FFESYMBOL_globalPROGUNIT_
60 /* Choose how to handle memory pools based on global symbol stuff. */
62 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
63 #define FFESYMBOL_SPACE_POOL_ ffe_pool_program_unit()
64 #elif FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalFILE_
65 #define FFESYMBOL_SPACE_POOL_ ffe_pool_file()
70 /* What kind of retraction is needed for a symbol? */
72 enum _ffesymbol_retractcommand_
74 FFESYMBOL_retractcommandDELETE_
,
75 FFESYMBOL_retractcommandRETRACT_
,
76 FFESYMBOL_retractcommand_
78 typedef enum _ffesymbol_retractcommand_ ffesymbolRetractCommand_
;
80 /* This object keeps track of retraction for a symbol and links to the next
83 typedef struct _ffesymbol_retract_
*ffesymbolRetract_
;
84 struct _ffesymbol_retract_
86 ffesymbolRetract_ next
;
87 ffesymbolRetractCommand_ command
;
88 ffesymbol live
; /* Live symbol. */
89 ffesymbol symbol
; /* Backup copy of symbol. */
92 static ffebad
ffesymbol_check_token_ (ffelexToken t
, char *c
);
93 static void ffesymbol_kill_manifest_ (void);
94 static ffesymbol
ffesymbol_new_ (ffename n
);
95 static ffesymbol
ffesymbol_unhook_ (ffesymbol s
);
96 static void ffesymbol_whine_state_ (ffebad bad
, ffelexToken t
, char c
);
98 /* Manifest names for unnamed things (as tokens) so we make them only
101 static ffelexToken ffesymbol_token_blank_common_
= NULL
;
102 static ffelexToken ffesymbol_token_unnamed_main_
= NULL
;
103 static ffelexToken ffesymbol_token_unnamed_blockdata_
= NULL
;
105 /* Name spaces currently in force. */
107 static ffenameSpace ffesymbol_global_
= NULL
;
108 static ffenameSpace ffesymbol_local_
= NULL
;
109 static ffenameSpace ffesymbol_sfunc_
= NULL
;
111 /* Keep track of retraction. */
113 static bool ffesymbol_retractable_
= FALSE
;
114 static mallocPool ffesymbol_retract_pool_
;
115 static ffesymbolRetract_ ffesymbol_retract_first_
;
116 static ffesymbolRetract_
*ffesymbol_retract_list_
;
118 /* List of state names. */
120 static const char *ffesymbol_state_name_
[] =
128 /* List of attribute names. */
130 static const char *ffesymbol_attr_name_
[] =
132 #define DEFATTR(ATTR,ATTRS,NAME) NAME,
133 #include "symbol.def"
138 /* Check whether the token text has any invalid characters. If not,
139 return FALSE. If so, if error messages inhibited, return TRUE
140 so caller knows to try again later, else report error and return
144 ffesymbol_check_token_ (ffelexToken t
, char *c
)
146 char *p
= ffelex_token_text (t
);
147 ffeTokenLength len
= ffelex_token_length (t
);
149 ffeTokenLength i
= 0;
150 ffebad skip_me
= ((ffe_case_symbol () == FFE_caseINITCAP
)
151 ? FFEBAD_SYMBOL_NOLOWER_INITCAP
: FFEBAD
+ 1);
152 ffebad stop_me
= ((ffe_case_symbol () == FFE_caseINITCAP
)
153 ? FFEBAD
: FFEBAD
+ 1);
157 bad
= ffesrc_bad_char_symbol_init (*p
);
160 for (++i
, ++p
; i
< len
; ++i
, ++p
)
162 bad
= ffesrc_bad_char_symbol_noninit (*p
);
164 continue; /* Keep looking for good InitCap character. */
166 break; /* Found good InitCap character. */
168 break; /* Bad character found. */
175 *c
= *(ffelex_token_text (t
));
183 /* Kill manifest (g77-picked) names. */
186 ffesymbol_kill_manifest_ ()
188 if (ffesymbol_token_blank_common_
!= NULL
)
189 ffelex_token_kill (ffesymbol_token_blank_common_
);
190 if (ffesymbol_token_unnamed_main_
!= NULL
)
191 ffelex_token_kill (ffesymbol_token_unnamed_main_
);
192 if (ffesymbol_token_unnamed_blockdata_
!= NULL
)
193 ffelex_token_kill (ffesymbol_token_unnamed_blockdata_
);
195 ffesymbol_token_blank_common_
= NULL
;
196 ffesymbol_token_unnamed_main_
= NULL
;
197 ffesymbol_token_unnamed_blockdata_
= NULL
;
202 If the "retractable" flag is not set, just return the new symbol.
203 Else, add symbol to the "retract" list as a delete item, set
204 the "have_old" flag, and return the new symbol. */
207 ffesymbol_new_ (ffename n
)
214 s
= (ffesymbol
) malloc_new_ks (FFESYMBOL_SPACE_POOL_
, "FFESYMBOL",
217 s
->other_space_name
= NULL
;
218 #if FFEGLOBAL_ENABLED
221 s
->attrs
= FFESYMBOL_attrsetNONE
;
222 s
->state
= FFESYMBOL_stateNONE
;
223 s
->info
= ffeinfo_new_null ();
227 s
->array_size
= NULL
;
231 s
->dummy_args
= NULL
;
233 s
->common_list
= NULL
;
234 s
->sfunc_expr
= NULL
;
235 s
->list_bottom
= NULL
;
239 #ifdef FFECOM_symbolHOOK
240 s
->hook
= FFECOM_symbolNULL
;
242 s
->sfa_dummy_parent
= NULL
;
243 s
->func_result
= NULL
;
245 s
->check_state
= FFESYMBOL_checkstateNONE_
;
246 s
->check_token
= NULL
;
247 s
->max_entry_num
= 0;
249 s
->generic
= FFEINTRIN_genNONE
;
250 s
->specific
= FFEINTRIN_specNONE
;
251 s
->implementation
= FFEINTRIN_impNONE
;
256 s
->explicit_where
= FALSE
;
257 s
->namelisted
= FALSE
;
260 ffename_set_symbol (n
, s
);
262 if (!ffesymbol_retractable_
)
268 r
= (ffesymbolRetract_
) malloc_new_kp (ffesymbol_retract_pool_
,
269 "FFESYMBOL retract", sizeof (*r
));
271 r
->command
= FFESYMBOL_retractcommandDELETE_
;
273 r
->symbol
= NULL
; /* No backup copy. */
275 *ffesymbol_retract_list_
= r
;
276 ffesymbol_retract_list_
= &r
->next
;
282 /* Unhook a symbol from its (soon-to-be-killed) name obj.
284 NULLify the names to which this symbol points. Do other cleanup as
288 ffesymbol_unhook_ (ffesymbol s
)
290 s
->other_space_name
= s
->name
= NULL
;
291 if ((ffesymbol_attrs (s
) & FFESYMBOL_attrsCBLOCK
)
292 || (ffesymbol_kind (s
) == FFEINFO_kindNAMELIST
))
293 ffebld_end_list (ffesymbol_ptr_to_listbottom (s
));
294 if (s
->check_state
== FFESYMBOL_checkstatePENDING_
)
295 ffelex_token_kill (s
->check_token
);
300 /* Issue diagnostic about bad character in token representing user-defined
304 ffesymbol_whine_state_ (ffebad bad
, ffelexToken t
, char c
)
312 ffebad_here (0, ffelex_token_where_line (t
),
313 ffelex_token_where_column (t
));
314 ffebad_string (badstr
);
318 /* Returns a string representing the attributes set. */
321 ffesymbol_attrs_string (ffesymbolAttrs attrs
)
323 static char string
[FFESYMBOL_attr
* 12 + 20];
329 if (attrs
== FFESYMBOL_attrsetNONE
)
335 for (attr
= 0; attr
< FFESYMBOL_attr
; ++attr
)
337 if (attrs
& ((ffesymbolAttrs
) 1 << attr
))
339 attrs
&= ~((ffesymbolAttrs
) 1 << attr
);
340 strcpy (p
, ffesymbol_attr_name_
[attr
]);
346 if (attrs
== FFESYMBOL_attrsetNONE
)
349 sprintf (p
, "?0x%" ffesymbolAttrs_f
"x?", attrs
);
350 assert (((size_t) (p
- &string
[0])) < ARRAY_SIZE (string
));
354 /* Check symbol's name for validity, considering that it might actually
355 be an intrinsic and thus should not be complained about just yet. */
358 ffesymbol_check (ffesymbol s
, ffelexToken t
, bool maybe_intrin
)
366 if (!ffesrc_check_symbol ()
367 || ((s
->check_state
!= FFESYMBOL_checkstateNONE_
)
368 && ((s
->check_state
!= FFESYMBOL_checkstateINHIBITED_
)
369 || ffebad_inhibit ())))
372 bad
= ffesymbol_check_token_ (t
, &c
);
376 s
->check_state
= FFESYMBOL_checkstateCHECKED_
;
381 && ffeintrin_is_intrinsic (ffelex_token_text (t
), NULL
, FALSE
,
384 s
->check_state
= FFESYMBOL_checkstatePENDING_
;
385 s
->check_token
= ffelex_token_use (t
);
389 if (ffebad_inhibit ())
391 s
->check_state
= FFESYMBOL_checkstateINHIBITED_
;
392 return; /* Don't complain now, do it later. */
395 s
->check_state
= FFESYMBOL_checkstateCHECKED_
;
397 ffesymbol_whine_state_ (bad
, t
, c
);
400 /* Declare a BLOCKDATA unit.
402 Retrieves or creates the ffesymbol for the specified BLOCKDATA (unnamed
403 if t is NULL). Doesn't actually ensure the named item is a
404 BLOCKDATA; the caller must handle that. */
407 ffesymbol_declare_blockdataunit (ffelexToken t
, ffewhereLine wl
,
412 bool user
= (t
!= NULL
);
414 assert (!ffesymbol_retractable_
);
418 if (ffesymbol_token_unnamed_blockdata_
== NULL
)
419 ffesymbol_token_unnamed_blockdata_
420 = ffelex_token_new_name (FFETARGET_nameUNNAMED_BLOCK_DATA
, wl
, wc
);
421 t
= ffesymbol_token_unnamed_blockdata_
;
424 n
= ffename_lookup (ffesymbol_local_
, t
);
426 return ffename_symbol (n
); /* This will become an error. */
428 n
= ffename_find (ffesymbol_global_
, t
);
429 s
= ffename_symbol (n
);
433 ffesymbol_check (s
, t
, FALSE
);
437 s
= ffesymbol_new_ (n
);
439 ffesymbol_check (s
, t
, FALSE
);
441 /* A program unit name also is in the local name space. */
443 n
= ffename_find (ffesymbol_local_
, t
);
444 ffename_set_symbol (n
, s
);
445 s
->other_space_name
= n
;
447 ffeglobal_new_blockdata (s
, t
); /* Detect conflicts, when
453 /* Declare a common block (named or unnamed).
455 Retrieves or creates the ffesymbol for the specified common block (blank
456 common if t is NULL). Doesn't actually ensure the named item is a
457 common block; the caller must handle that. */
460 ffesymbol_declare_cblock (ffelexToken t
, ffewhereLine wl
, ffewhereColumn wc
)
466 assert (!ffesymbol_retractable_
);
471 if (ffesymbol_token_blank_common_
== NULL
)
472 ffesymbol_token_blank_common_
473 = ffelex_token_new_name (FFETARGET_nameBLANK_COMMON
, wl
, wc
);
474 t
= ffesymbol_token_blank_common_
;
479 n
= ffename_find (ffesymbol_global_
, t
);
480 s
= ffename_symbol (n
);
484 ffesymbol_check (s
, t
, FALSE
);
488 s
= ffesymbol_new_ (n
);
490 ffesymbol_check (s
, t
, FALSE
);
492 ffeglobal_new_common (s
, t
, blank
); /* Detect conflicts. */
497 /* Declare a FUNCTION program unit (with distinct RESULT() name).
499 Retrieves or creates the ffesymbol for the specified function. Doesn't
500 actually ensure the named item is a function; the caller must handle
503 If FUNCTION with RESULT() is specified but the names are the same,
504 pretend as though RESULT() was not specified, and don't call this
505 function; use ffesymbol_declare_funcunit() instead. */
508 ffesymbol_declare_funcnotresunit (ffelexToken t
)
514 assert (!ffesymbol_retractable_
);
516 n
= ffename_lookup (ffesymbol_local_
, t
);
518 return ffename_symbol (n
); /* This will become an error. */
520 n
= ffename_find (ffesymbol_global_
, t
);
521 s
= ffename_symbol (n
);
524 ffesymbol_check (s
, t
, FALSE
);
528 s
= ffesymbol_new_ (n
);
529 ffesymbol_check (s
, t
, FALSE
);
531 /* A FUNCTION program unit name also is in the local name space; handle it
532 here since RESULT() is a different name and is handled separately. */
534 n
= ffename_find (ffesymbol_local_
, t
);
535 ffename_set_symbol (n
, s
);
536 s
->other_space_name
= n
;
538 ffeglobal_new_function (s
, t
);/* Detect conflicts, when appropriate. */
543 /* Declare a function result.
545 Retrieves or creates the ffesymbol for the specified function result,
546 whether specified via a distinct RESULT() or by default in a FUNCTION or
550 ffesymbol_declare_funcresult (ffelexToken t
)
556 assert (!ffesymbol_retractable_
);
558 n
= ffename_find (ffesymbol_local_
, t
);
559 s
= ffename_symbol (n
);
563 return ffesymbol_new_ (n
);
566 /* Declare a FUNCTION program unit with no RESULT().
568 Retrieves or creates the ffesymbol for the specified function. Doesn't
569 actually ensure the named item is a function; the caller must handle
572 This is the function to call when the FUNCTION or ENTRY statement has
573 no separate and distinct name specified via RESULT(). That's because
574 this function enters the global name of the function in only the global
575 name space. ffesymbol_declare_funcresult() must still be called to
576 declare the name for the function result in the local name space. */
579 ffesymbol_declare_funcunit (ffelexToken t
)
585 assert (!ffesymbol_retractable_
);
587 n
= ffename_find (ffesymbol_global_
, t
);
588 s
= ffename_symbol (n
);
591 ffesymbol_check (s
, t
, FALSE
);
595 s
= ffesymbol_new_ (n
);
596 ffesymbol_check (s
, t
, FALSE
);
598 ffeglobal_new_function (s
, t
);/* Detect conflicts. */
603 /* Declare a local entity.
605 Retrieves or creates the ffesymbol for the specified local entity.
606 Set maybe_intrin TRUE if this name might turn out to name an
607 intrinsic (legitimately); otherwise if the name doesn't meet the
608 requirements for a user-defined symbol name, a diagnostic will be
609 issued right away rather than waiting until the intrinsicness of the
610 symbol is determined. */
613 ffesymbol_declare_local (ffelexToken t
, bool maybe_intrin
)
620 /* If we're parsing within a statement function definition, return the
621 symbol if already known (a dummy argument for the statement function).
622 Otherwise continue on, which means the symbol is declared within the
623 containing (local) program unit rather than the statement function
626 if ((ffesymbol_sfunc_
!= NULL
)
627 && ((n
= ffename_lookup (ffesymbol_sfunc_
, t
)) != NULL
))
628 return ffename_symbol (n
);
630 n
= ffename_find (ffesymbol_local_
, t
);
631 s
= ffename_symbol (n
);
634 ffesymbol_check (s
, t
, maybe_intrin
);
638 s
= ffesymbol_new_ (n
);
639 ffesymbol_check (s
, t
, maybe_intrin
);
643 /* Declare a main program unit.
645 Retrieves or creates the ffesymbol for the specified main program unit
646 (unnamed main program unit if t is NULL). Doesn't actually ensure the
647 named item is a program; the caller must handle that. */
650 ffesymbol_declare_programunit (ffelexToken t
, ffewhereLine wl
,
655 bool user
= (t
!= NULL
);
657 assert (!ffesymbol_retractable_
);
661 if (ffesymbol_token_unnamed_main_
== NULL
)
662 ffesymbol_token_unnamed_main_
663 = ffelex_token_new_name (FFETARGET_nameUNNAMED_MAIN
, wl
, wc
);
664 t
= ffesymbol_token_unnamed_main_
;
667 n
= ffename_lookup (ffesymbol_local_
, t
);
669 return ffename_symbol (n
); /* This will become an error. */
671 n
= ffename_find (ffesymbol_global_
, t
);
672 s
= ffename_symbol (n
);
676 ffesymbol_check (s
, t
, FALSE
);
680 s
= ffesymbol_new_ (n
);
682 ffesymbol_check (s
, t
, FALSE
);
684 /* A program unit name also is in the local name space. */
686 n
= ffename_find (ffesymbol_local_
, t
);
687 ffename_set_symbol (n
, s
);
688 s
->other_space_name
= n
;
690 ffeglobal_new_program (s
, t
); /* Detect conflicts. */
695 /* Declare a statement-function dummy.
697 Retrieves or creates the ffesymbol for the specified statement
698 function dummy. Also ensures that it has a link to the parent (local)
699 ffesymbol with the same name, creating it if necessary. */
702 ffesymbol_declare_sfdummy (ffelexToken t
)
706 ffesymbol sp
; /* Parent symbol in local area. */
710 n
= ffename_find (ffesymbol_local_
, t
);
711 sp
= ffename_symbol (n
);
713 sp
= ffesymbol_new_ (n
);
714 ffesymbol_check (sp
, t
, FALSE
);
716 n
= ffename_find (ffesymbol_sfunc_
, t
);
717 s
= ffename_symbol (n
);
720 s
= ffesymbol_new_ (n
);
721 s
->sfa_dummy_parent
= sp
;
724 assert (s
->sfa_dummy_parent
== sp
);
729 /* Declare a subroutine program unit.
731 Retrieves or creates the ffesymbol for the specified subroutine
732 Doesn't actually ensure the named item is a subroutine; the caller must
736 ffesymbol_declare_subrunit (ffelexToken t
)
741 assert (!ffesymbol_retractable_
);
744 n
= ffename_lookup (ffesymbol_local_
, t
);
746 return ffename_symbol (n
); /* This will become an error. */
748 n
= ffename_find (ffesymbol_global_
, t
);
749 s
= ffename_symbol (n
);
752 ffesymbol_check (s
, t
, FALSE
);
756 s
= ffesymbol_new_ (n
);
757 ffesymbol_check (s
, t
, FALSE
);
759 /* A program unit name also is in the local name space. */
761 n
= ffename_find (ffesymbol_local_
, t
);
762 ffename_set_symbol (n
, s
);
763 s
->other_space_name
= n
;
765 ffeglobal_new_subroutine (s
, t
); /* Detect conflicts, when
771 /* Call given fn with all local/global symbols.
773 ffesymbol (*fn) (ffesymbol s);
774 ffesymbol_drive (fn); */
777 ffesymbol_drive (ffesymbol (*fn
) (ffesymbol
))
779 assert (ffesymbol_sfunc_
== NULL
); /* Might be ok, but not for current
781 ffename_space_drive_symbol (ffesymbol_local_
, fn
);
782 ffename_space_drive_symbol (ffesymbol_global_
, fn
);
785 /* Call given fn with all sfunc-only symbols.
787 ffesymbol (*fn) (ffesymbol s);
788 ffesymbol_drive_sfnames (fn); */
791 ffesymbol_drive_sfnames (ffesymbol (*fn
) (ffesymbol
))
793 ffename_space_drive_symbol (ffesymbol_sfunc_
, fn
);
796 /* Dump info on the symbol for debugging purposes. */
798 #if FFECOM_targetCURRENT == FFECOM_targetFFE
800 ffesymbol_dump (ffesymbol s
)
807 if (ffeinfo_size (s
->info
) != FFETARGET_charactersizeNONE
)
808 fprintf (dmpout
, "%s:%d%s%s*%" ffetargetCharacterSize_f
"u",
810 (int) ffeinfo_rank (s
->info
),
811 ffeinfo_basictype_string (ffeinfo_basictype (s
->info
)),
812 ffeinfo_kindtype_string (ffeinfo_kindtype (s
->info
)),
813 ffeinfo_size (s
->info
));
815 fprintf (dmpout
, "%s:%d%s%s",
817 (int) ffeinfo_rank (s
->info
),
818 ffeinfo_basictype_string (ffeinfo_basictype (s
->info
)),
819 ffeinfo_kindtype_string (ffeinfo_kindtype (s
->info
)));
820 if ((k
= ffeinfo_kind (s
->info
)) != FFEINFO_kindNONE
)
821 fprintf (dmpout
, "/%s", ffeinfo_kind_string (k
));
822 if ((w
= ffeinfo_where (s
->info
)) != FFEINFO_whereNONE
)
823 fprintf (dmpout
, "@%s", ffeinfo_where_string (w
));
825 if ((s
->generic
!= FFEINTRIN_genNONE
)
826 || (s
->specific
!= FFEINTRIN_specNONE
)
827 || (s
->implementation
!= FFEINTRIN_impNONE
))
828 fprintf (dmpout
, "{%s:%s:%s}",
829 ffeintrin_name_generic (s
->generic
),
830 ffeintrin_name_specific (s
->specific
),
831 ffeintrin_name_implementation (s
->implementation
));
835 /* Produce generic error message about a symbol.
837 For now, just output error message using symbol's name and pointing to
841 ffesymbol_error (ffesymbol s
, ffelexToken t
)
844 && ffest_ffebad_start (FFEBAD_SYMERR
))
846 ffebad_string (ffesymbol_text (s
));
847 ffebad_here (0, ffelex_token_where_line (t
),
848 ffelex_token_where_column (t
));
849 ffebad_here (1, ffesymbol_where_line (s
), ffesymbol_where_column (s
));
853 if (ffesymbol_attr (s
, FFESYMBOL_attrANY
))
856 ffesymbol_signal_change (s
); /* May need to back up to previous version. */
857 if ((ffesymbol_attrs (s
) & FFESYMBOL_attrsCBLOCK
)
858 || (ffesymbol_kind (s
) == FFEINFO_kindNAMELIST
))
859 ffebld_end_list (ffesymbol_ptr_to_listbottom (s
));
860 ffesymbol_set_attr (s
, FFESYMBOL_attrANY
);
861 ffesymbol_set_info (s
, ffeinfo_new_any ());
862 ffesymbol_set_state (s
, FFESYMBOL_stateUNDERSTOOD
);
863 if (s
->check_state
== FFESYMBOL_checkstatePENDING_
)
864 ffelex_token_kill (s
->check_token
);
865 s
->check_state
= FFESYMBOL_checkstateCHECKED_
;
866 s
= ffecom_sym_learned (s
);
867 ffesymbol_signal_unreported (s
);
873 ffesymbolAttrs attrs
= FFESYMBOL_attrsetNONE
;
875 assert (FFESYMBOL_state
== ARRAY_SIZE (ffesymbol_state_name_
));
876 assert (FFESYMBOL_attr
== ARRAY_SIZE (ffesymbol_attr_name_
));
877 assert (attrs
== FFESYMBOL_attrsetNONE
);
878 attrs
= ((ffesymbolAttrs
) 1 << FFESYMBOL_attr
);
885 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalFILE_
886 ffesymbol_global_
= ffename_space_new (ffe_pool_file ());
898 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
899 ffesymbol_global_
= ffename_space_new (ffe_pool_program_unit ());
901 ffesymbol_local_
= ffename_space_new (ffe_pool_program_unit ());
907 ffesymbol_sfunc_
= ffename_space_new (ffe_pool_program_unit ());
910 /* Look up a local entity.
912 Retrieves the ffesymbol for the specified local entity, or returns NULL
913 if no local entity by that name exists. */
916 ffesymbol_lookup_local (ffelexToken t
)
923 n
= ffename_lookup (ffesymbol_local_
, t
);
927 s
= ffename_symbol (n
);
928 return s
; /* May be NULL here, too. */
931 /* Registers the symbol as one that is referenced by the
932 current program unit. Currently applies only to
933 symbols known to have global interest (globals and
936 s is the (global/intrinsic) symbol referenced; t is the
937 referencing token; explicit is TRUE if the reference
938 is, e.g., INTRINSIC FOO. */
941 ffesymbol_reference (ffesymbol s
, ffelexToken t
, bool explicit)
949 if (ffesymbol_retractable_
)
953 t
= ffename_token (s
->name
); /* Use the first reference in this program unit. */
955 kind
= ffesymbol_kind (s
);
956 where
= ffesymbol_where (s
);
958 if (where
== FFEINFO_whereINTRINSIC
)
960 ffeglobal_ref_intrinsic (s
, t
,
963 || ffeintrin_is_standard (s
->generic
, s
->specific
));
967 if ((where
!= FFEINFO_whereGLOBAL
)
968 && ((where
!= FFEINFO_whereLOCAL
)
969 || ((kind
!= FFEINFO_kindFUNCTION
)
970 && (kind
!= FFEINFO_kindSUBROUTINE
))))
973 gn
= ffename_lookup (ffesymbol_global_
, t
);
975 gs
= ffename_symbol (gn
);
976 if ((gs
!= NULL
) && (gs
!= s
))
978 /* We have just discovered another global symbol with the same name
979 but a different `nature'. Complain. Note that COMMON /FOO/ can
980 coexist with local symbol FOO, e.g. local variable, just not with
981 CALL FOO, hence the separate namespaces. */
983 ffesymbol_error (gs
, t
);
984 ffesymbol_error (s
, NULL
);
990 case FFEINFO_kindBLOCKDATA
:
991 okay
= ffeglobal_ref_blockdata (s
, t
);
994 case FFEINFO_kindSUBROUTINE
:
995 okay
= ffeglobal_ref_subroutine (s
, t
);
998 case FFEINFO_kindFUNCTION
:
999 okay
= ffeglobal_ref_function (s
, t
);
1002 case FFEINFO_kindNONE
:
1003 okay
= ffeglobal_ref_external (s
, t
);
1007 assert ("bad kind in global ref" == NULL
);
1012 ffesymbol_error (s
, NULL
);
1015 /* Report info on the symbol for debugging purposes. */
1017 #if FFECOM_targetCURRENT == FFECOM_targetFFE
1019 ffesymbol_report (ffesymbol s
)
1031 if (ffeinfo_size (s
->info
) != FFETARGET_charactersizeNONE
)
1032 fprintf (dmpout
, "\"%s\": %s %s %d%s%s*%" ffetargetCharacterSize_f
"u",
1034 ffesymbol_state_string (s
->state
),
1035 ffesymbol_attrs_string (s
->attrs
),
1036 (int) ffeinfo_rank (s
->info
),
1037 ffeinfo_basictype_string (ffeinfo_basictype (s
->info
)),
1038 ffeinfo_kindtype_string (ffeinfo_kindtype (s
->info
)),
1039 ffeinfo_size (s
->info
));
1041 fprintf (dmpout
, "\"%s\": %s %s %d%s%s",
1043 ffesymbol_state_string (s
->state
),
1044 ffesymbol_attrs_string (s
->attrs
),
1045 (int) ffeinfo_rank (s
->info
),
1046 ffeinfo_basictype_string (ffeinfo_basictype (s
->info
)),
1047 ffeinfo_kindtype_string (ffeinfo_kindtype (s
->info
)));
1048 if ((k
= ffeinfo_kind (s
->info
)) != FFEINFO_kindNONE
)
1049 fprintf (dmpout
, "/%s", ffeinfo_kind_string (k
));
1050 if ((w
= ffeinfo_where (s
->info
)) != FFEINFO_whereNONE
)
1051 fprintf (dmpout
, "@%s", ffeinfo_where_string (w
));
1052 fputc ('\n', dmpout
);
1054 if (s
->dims
!= NULL
)
1056 fprintf (dmpout
, " dims: ");
1057 ffebld_dump (s
->dims
);
1058 fputs ("\n", dmpout
);
1061 if (s
->extents
!= NULL
)
1063 fprintf (dmpout
, " extents: ");
1064 ffebld_dump (s
->extents
);
1065 fputs ("\n", dmpout
);
1068 if (s
->dim_syms
!= NULL
)
1070 fprintf (dmpout
, " dim syms: ");
1071 ffebld_dump (s
->dim_syms
);
1072 fputs ("\n", dmpout
);
1075 if (s
->array_size
!= NULL
)
1077 fprintf (dmpout
, " array size: ");
1078 ffebld_dump (s
->array_size
);
1079 fputs ("\n", dmpout
);
1082 if (s
->init
!= NULL
)
1084 fprintf (dmpout
, " init-value: ");
1085 if (ffebld_op (s
->init
) == FFEBLD_opANY
)
1086 fputs ("<any>\n", dmpout
);
1089 ffebld_dump (s
->init
);
1090 fputs ("\n", dmpout
);
1094 if (s
->accretion
!= NULL
)
1096 fprintf (dmpout
, " accretion (%" ffetargetOffset_f
"d left): ",
1098 ffebld_dump (s
->accretion
);
1099 fputs ("\n", dmpout
);
1101 else if (s
->accretes
!= 0)
1102 fprintf (dmpout
, " accretes!! = %" ffetargetOffset_f
"d left\n",
1105 if (s
->dummy_args
!= NULL
)
1107 fprintf (dmpout
, " dummies: ");
1108 ffebld_dump (s
->dummy_args
);
1109 fputs ("\n", dmpout
);
1112 if (s
->namelist
!= NULL
)
1114 fprintf (dmpout
, " namelist: ");
1115 ffebld_dump (s
->namelist
);
1116 fputs ("\n", dmpout
);
1119 if (s
->common_list
!= NULL
)
1121 fprintf (dmpout
, " common-list: ");
1122 ffebld_dump (s
->common_list
);
1123 fputs ("\n", dmpout
);
1126 if (s
->sfunc_expr
!= NULL
)
1128 fprintf (dmpout
, " sfunc expression: ");
1129 ffebld_dump (s
->sfunc_expr
);
1130 fputs ("\n", dmpout
);
1135 fprintf (dmpout
, " SAVEd\n");
1140 fprintf (dmpout
, " initialized\n");
1145 fprintf (dmpout
, " DO-loop iteration variable (currently)\n");
1148 if (s
->explicit_where
)
1150 fprintf (dmpout
, " Explicit INTRINSIC/EXTERNAL\n");
1155 fprintf (dmpout
, " Namelisted\n");
1158 if (s
->common
!= NULL
)
1160 fprintf (dmpout
, " COMMON area: %s\n", ffesymbol_text (s
->common
));
1163 if (s
->equiv
!= NULL
)
1165 fprintf (dmpout
, " EQUIVALENCE information: ");
1166 ffeequiv_dump (s
->equiv
);
1167 fputs ("\n", dmpout
);
1170 if (s
->storage
!= NULL
)
1172 fprintf (dmpout
, " Storage: ");
1173 ffestorag_dump (s
->storage
);
1174 fputs ("\n", dmpout
);
1181 /* Report info on the symbols. */
1183 #if FFECOM_targetCURRENT == FFECOM_targetFFE
1185 ffesymbol_report_all ()
1187 ffename_space_drive_symbol (ffesymbol_sfunc_
, ffesymbol_report
);
1188 ffename_space_drive_symbol (ffesymbol_local_
, ffesymbol_report
);
1189 ffename_space_drive_symbol (ffesymbol_global_
, ffesymbol_report
);
1193 /* Resolve symbol that has become known intrinsic or non-intrinsic. */
1196 ffesymbol_resolve_intrin (ffesymbol s
)
1201 if (!ffesrc_check_symbol ())
1203 if (s
->check_state
!= FFESYMBOL_checkstatePENDING_
)
1205 if (ffebad_inhibit ())
1206 return; /* We'll get back to this later. */
1208 if (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
)
1210 bad
= ffesymbol_check_token_ (s
->check_token
, &c
);
1211 assert (bad
!= FFEBAD
); /* How did this suddenly become ok? */
1212 ffesymbol_whine_state_ (bad
, s
->check_token
, c
);
1215 s
->check_state
= FFESYMBOL_checkstateCHECKED_
;
1216 ffelex_token_kill (s
->check_token
);
1219 /* Retract or cancel retract list. */
1222 ffesymbol_retract (bool retract
)
1224 ffesymbolRetract_ r
;
1226 ffename other_space_name
;
1230 assert (ffesymbol_retractable_
);
1232 ffesymbol_retractable_
= FALSE
;
1234 for (r
= ffesymbol_retract_first_
; r
!= NULL
; r
= r
->next
)
1240 case FFESYMBOL_retractcommandDELETE_
:
1243 ffecom_sym_retract (ls
);
1245 other_space_name
= ls
->other_space_name
;
1246 ffesymbol_unhook_ (ls
);
1247 malloc_kill_ks (FFESYMBOL_SPACE_POOL_
, ls
, sizeof (*ls
));
1249 ffename_set_symbol (name
, NULL
);
1250 if (other_space_name
!= NULL
)
1251 ffename_set_symbol (other_space_name
, NULL
);
1255 ffecom_sym_commit (ls
);
1256 ls
->have_old
= FALSE
;
1260 case FFESYMBOL_retractcommandRETRACT_
:
1263 ffecom_sym_retract (ls
);
1264 ffesymbol_unhook_ (ls
);
1266 malloc_kill_ks (FFESYMBOL_SPACE_POOL_
, os
, sizeof (*os
));
1270 ffecom_sym_commit (ls
);
1271 ffesymbol_unhook_ (os
);
1272 malloc_kill_ks (FFESYMBOL_SPACE_POOL_
, os
, sizeof (*os
));
1273 ls
->have_old
= FALSE
;
1278 assert ("bad command" == NULL
);
1284 /* Return retractable flag. */
1287 ffesymbol_retractable ()
1289 return ffesymbol_retractable_
;
1292 /* Set retractable flag, retract pool.
1294 Between this call and ffesymbol_retract, any changes made to existing
1295 symbols cause the previous versions of those symbols to be saved, and any
1296 newly created symbols to have their previous nonexistence saved. When
1297 ffesymbol_retract is called, this information either is used to retract
1298 the changes and new symbols, or is discarded. */
1301 ffesymbol_set_retractable (mallocPool pool
)
1303 assert (!ffesymbol_retractable_
);
1305 ffesymbol_retractable_
= TRUE
;
1306 ffesymbol_retract_pool_
= pool
;
1307 ffesymbol_retract_list_
= &ffesymbol_retract_first_
;
1308 ffesymbol_retract_first_
= NULL
;
1311 /* Existing symbol about to be changed; save?
1313 Call this function before changing a symbol if it is possible that
1314 the current actions may need to be undone (i.e. one of several possible
1315 statement forms are being used to analyze the current system).
1317 If the "retractable" flag is not set, just return.
1318 Else, if the symbol's "have_old" flag is set, just return.
1319 Else, make a copy of the symbol and add it to the "retract" list, set
1320 the "have_old" flag, and return. */
1323 ffesymbol_signal_change (ffesymbol s
)
1325 ffesymbolRetract_ r
;
1328 if (!ffesymbol_retractable_
|| s
->have_old
)
1331 r
= (ffesymbolRetract_
) malloc_new_kp (ffesymbol_retract_pool_
,
1332 "FFESYMBOL retract", sizeof (*r
));
1334 r
->command
= FFESYMBOL_retractcommandRETRACT_
;
1336 r
->symbol
= sym
= (ffesymbol
) malloc_new_ks (FFESYMBOL_SPACE_POOL_
,
1337 "FFESYMBOL", sizeof (*sym
));
1338 *sym
= *s
; /* Make an exact copy of the symbol in case
1340 sym
->info
= ffeinfo_use (s
->info
);
1341 if (s
->check_state
== FFESYMBOL_checkstatePENDING_
)
1342 sym
->check_token
= ffelex_token_use (s
->check_token
);
1344 *ffesymbol_retract_list_
= r
;
1345 ffesymbol_retract_list_
= &r
->next
;
1350 /* Returns the string based on the state. */
1353 ffesymbol_state_string (ffesymbolState state
)
1355 if (state
>= ARRAY_SIZE (ffesymbol_state_name_
))
1357 return ffesymbol_state_name_
[state
];
1361 ffesymbol_terminate_0 ()
1366 ffesymbol_terminate_1 ()
1368 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalFILE_
1369 ffename_space_drive_symbol (ffesymbol_global_
, ffesymbol_unhook_
);
1370 ffename_space_kill (ffesymbol_global_
);
1371 ffesymbol_global_
= NULL
;
1373 ffesymbol_kill_manifest_ ();
1378 ffesymbol_terminate_2 ()
1380 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
1381 ffesymbol_kill_manifest_ ();
1386 ffesymbol_terminate_3 ()
1388 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
1389 ffename_space_drive_symbol (ffesymbol_global_
, ffesymbol_unhook_
);
1390 ffename_space_kill (ffesymbol_global_
);
1392 ffename_space_drive_symbol (ffesymbol_local_
, ffesymbol_unhook_
);
1393 ffename_space_kill (ffesymbol_local_
);
1394 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
1395 ffesymbol_global_
= NULL
;
1397 ffesymbol_local_
= NULL
;
1401 ffesymbol_terminate_4 ()
1403 ffename_space_drive_symbol (ffesymbol_sfunc_
, ffesymbol_unhook_
);
1404 ffename_space_kill (ffesymbol_sfunc_
);
1405 ffesymbol_sfunc_
= NULL
;
1408 /* Update INIT info to TRUE and all equiv/storage too.
1410 If INIT flag is TRUE, does nothing. Else sets it to TRUE and calls
1411 on the ffeequiv and ffestorag modules to update their INIT flags if
1412 the <s> symbol has those objects, and also updates the common area if
1416 ffesymbol_update_init (ffesymbol s
)
1425 if ((s
->equiv
!= NULL
)
1426 && !ffeequiv_is_init (s
->equiv
))
1427 ffeequiv_update_init (s
->equiv
);
1429 if ((s
->storage
!= NULL
)
1430 && !ffestorag_is_init (s
->storage
))
1431 ffestorag_update_init (s
->storage
);
1433 if ((s
->common
!= NULL
)
1434 && (!ffesymbol_is_init (s
->common
)))
1435 ffesymbol_update_init (s
->common
);
1437 for (item
= s
->common_list
; item
!= NULL
; item
= ffebld_trail (item
))
1439 if (!ffesymbol_is_init (ffebld_symter (ffebld_head (item
))))
1440 ffesymbol_update_init (ffebld_symter (ffebld_head (item
)));
1444 /* Update SAVE info to TRUE and all equiv/storage too.
1446 If SAVE flag is TRUE, does nothing. Else sets it to TRUE and calls
1447 on the ffeequiv and ffestorag modules to update their SAVE flags if
1448 the <s> symbol has those objects, and also updates the common area if
1452 ffesymbol_update_save (ffesymbol s
)
1461 if ((s
->equiv
!= NULL
)
1462 && !ffeequiv_is_save (s
->equiv
))
1463 ffeequiv_update_save (s
->equiv
);
1465 if ((s
->storage
!= NULL
)
1466 && !ffestorag_is_save (s
->storage
))
1467 ffestorag_update_save (s
->storage
);
1469 if ((s
->common
!= NULL
)
1470 && (!ffesymbol_is_save (s
->common
)))
1471 ffesymbol_update_save (s
->common
);
1473 for (item
= s
->common_list
; item
!= NULL
; item
= ffebld_trail (item
))
1475 if (!ffesymbol_is_save (ffebld_symter (ffebld_head (item
))))
1476 ffesymbol_update_save (ffebld_symter (ffebld_head (item
)));