1 /* Implementation of Fortran symbol manager
2 Copyright (C) 1995, 1996, 1997, 2003
3 Free Software Foundation, Inc.
4 Contributed by James Craig Burley.
6 This file is part of GNU Fortran.
8 GNU Fortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU Fortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Fortran; see the file COPYING. If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
40 /* Choice of how to handle global symbols -- either global only within the
41 program unit being defined or global within the entire source file.
42 The former is appropriate for systems where an object file can
43 easily be taken apart program unit by program unit, the latter is the
44 UNIX/C model where the object file is essentially a monolith. */
46 #define FFESYMBOL_globalPROGUNIT_ 1
47 #define FFESYMBOL_globalFILE_ 2
49 /* Choose how to handle global symbols here. */
51 /* Would be good to understand why PROGUNIT in this case too.
53 #define FFESYMBOL_globalCURRENT_ FFESYMBOL_globalPROGUNIT_
55 /* Choose how to handle memory pools based on global symbol stuff. */
57 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
58 #define FFESYMBOL_SPACE_POOL_ ffe_pool_program_unit()
59 #elif FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalFILE_
60 #define FFESYMBOL_SPACE_POOL_ ffe_pool_file()
65 /* What kind of retraction is needed for a symbol? */
67 enum _ffesymbol_retractcommand_
69 FFESYMBOL_retractcommandDELETE_,
70 FFESYMBOL_retractcommandRETRACT_,
71 FFESYMBOL_retractcommand_
73 typedef enum _ffesymbol_retractcommand_ ffesymbolRetractCommand_;
75 /* This object keeps track of retraction for a symbol and links to the next
78 typedef struct _ffesymbol_retract_ *ffesymbolRetract_;
79 struct _ffesymbol_retract_
81 ffesymbolRetract_ next;
82 ffesymbolRetractCommand_ command;
83 ffesymbol live; /* Live symbol. */
84 ffesymbol symbol; /* Backup copy of symbol. */
87 static ffebad ffesymbol_check_token_ (ffelexToken t, char *c);
88 static void ffesymbol_kill_manifest_ (void);
89 static ffesymbol ffesymbol_new_ (ffename n);
90 static ffesymbol ffesymbol_unhook_ (ffesymbol s);
91 static void ffesymbol_whine_state_ (ffebad bad, ffelexToken t, char c);
93 /* Manifest names for unnamed things (as tokens) so we make them only
96 static ffelexToken ffesymbol_token_blank_common_ = NULL;
97 static ffelexToken ffesymbol_token_unnamed_main_ = NULL;
98 static ffelexToken ffesymbol_token_unnamed_blockdata_ = NULL;
100 /* Name spaces currently in force. */
102 static ffenameSpace ffesymbol_global_ = NULL;
103 static ffenameSpace ffesymbol_local_ = NULL;
104 static ffenameSpace ffesymbol_sfunc_ = NULL;
106 /* Keep track of retraction. */
108 static bool ffesymbol_retractable_ = FALSE;
109 static mallocPool ffesymbol_retract_pool_;
110 static ffesymbolRetract_ ffesymbol_retract_first_;
111 static ffesymbolRetract_ *ffesymbol_retract_list_;
113 /* List of state names. */
115 static const char *const ffesymbol_state_name_[] =
123 /* List of attribute names. */
125 static const char *const ffesymbol_attr_name_[] =
127 #define DEFATTR(ATTR,ATTRS,NAME) NAME,
128 #include "symbol.def"
133 /* Check whether the token text has any invalid characters. If not,
134 return FALSE. If so, if error messages inhibited, return TRUE
135 so caller knows to try again later, else report error and return
139 ffesymbol_check_token_ (ffelexToken t, char *c)
141 char *p = ffelex_token_text (t);
142 ffeTokenLength len = ffelex_token_length (t);
144 ffeTokenLength i = 0;
145 ffebad skip_me = ((ffe_case_symbol () == FFE_caseINITCAP)
146 ? FFEBAD_SYMBOL_NOLOWER_INITCAP : FFEBAD + 1);
147 ffebad stop_me = ((ffe_case_symbol () == FFE_caseINITCAP)
148 ? FFEBAD : FFEBAD + 1);
152 bad = ffesrc_bad_char_symbol_init (*p);
155 for (++i, ++p; i < len; ++i, ++p)
157 bad = ffesrc_bad_char_symbol_noninit (*p);
159 continue; /* Keep looking for good InitCap character. */
161 break; /* Found good InitCap character. */
163 break; /* Bad character found. */
170 *c = *(ffelex_token_text (t));
178 /* Kill manifest (g77-picked) names. */
181 ffesymbol_kill_manifest_ (void)
183 if (ffesymbol_token_blank_common_ != NULL)
184 ffelex_token_kill (ffesymbol_token_blank_common_);
185 if (ffesymbol_token_unnamed_main_ != NULL)
186 ffelex_token_kill (ffesymbol_token_unnamed_main_);
187 if (ffesymbol_token_unnamed_blockdata_ != NULL)
188 ffelex_token_kill (ffesymbol_token_unnamed_blockdata_);
190 ffesymbol_token_blank_common_ = NULL;
191 ffesymbol_token_unnamed_main_ = NULL;
192 ffesymbol_token_unnamed_blockdata_ = NULL;
197 If the "retractable" flag is not set, just return the new symbol.
198 Else, add symbol to the "retract" list as a delete item, set
199 the "have_old" flag, and return the new symbol. */
202 ffesymbol_new_ (ffename n)
209 s = malloc_new_ks (FFESYMBOL_SPACE_POOL_, "FFESYMBOL", sizeof (*s));
211 s->other_space_name = NULL;
212 #if FFEGLOBAL_ENABLED
215 s->attrs = FFESYMBOL_attrsetNONE;
216 s->state = FFESYMBOL_stateNONE;
217 s->info = ffeinfo_new_null ();
221 s->array_size = NULL;
225 s->dummy_args = NULL;
227 s->common_list = NULL;
228 s->sfunc_expr = NULL;
229 s->list_bottom = NULL;
233 s->hook = FFECOM_symbolNULL;
234 s->sfa_dummy_parent = NULL;
235 s->func_result = NULL;
237 s->check_state = FFESYMBOL_checkstateNONE_;
238 s->check_token = NULL;
239 s->max_entry_num = 0;
241 s->generic = FFEINTRIN_genNONE;
242 s->specific = FFEINTRIN_specNONE;
243 s->implementation = FFEINTRIN_impNONE;
248 s->explicit_where = FALSE;
249 s->namelisted = FALSE;
252 ffename_set_symbol (n, s);
254 if (!ffesymbol_retractable_)
260 r = malloc_new_kp (ffesymbol_retract_pool_, "FFESYMBOL retract",
263 r->command = FFESYMBOL_retractcommandDELETE_;
265 r->symbol = NULL; /* No backup copy. */
267 *ffesymbol_retract_list_ = r;
268 ffesymbol_retract_list_ = &r->next;
274 /* Unhook a symbol from its (soon-to-be-killed) name obj.
276 NULLify the names to which this symbol points. Do other cleanup as
280 ffesymbol_unhook_ (ffesymbol s)
282 s->other_space_name = s->name = NULL;
283 if ((ffesymbol_attrs (s) & FFESYMBOL_attrsCBLOCK)
284 || (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
285 ffebld_end_list (ffesymbol_ptr_to_listbottom (s));
286 if (s->check_state == FFESYMBOL_checkstatePENDING_)
287 ffelex_token_kill (s->check_token);
292 /* Issue diagnostic about bad character in token representing user-defined
296 ffesymbol_whine_state_ (ffebad bad, ffelexToken t, char c)
304 ffebad_here (0, ffelex_token_where_line (t),
305 ffelex_token_where_column (t));
306 ffebad_string (badstr);
310 /* Returns a string representing the attributes set. */
313 ffesymbol_attrs_string (ffesymbolAttrs attrs)
315 static char string[FFESYMBOL_attr * 12 + 20];
321 if (attrs == FFESYMBOL_attrsetNONE)
327 for (attr = 0; attr < FFESYMBOL_attr; ++attr)
329 if (attrs & ((ffesymbolAttrs) 1 << attr))
331 attrs &= ~((ffesymbolAttrs) 1 << attr);
332 strcpy (p, ffesymbol_attr_name_[attr]);
338 if (attrs == FFESYMBOL_attrsetNONE)
341 sprintf (p, "?0x%" ffesymbolAttrs_f "x?", attrs);
342 assert (((size_t) (p - &string[0])) < ARRAY_SIZE (string));
346 /* Check symbol's name for validity, considering that it might actually
347 be an intrinsic and thus should not be complained about just yet. */
350 ffesymbol_check (ffesymbol s, ffelexToken t, bool maybe_intrin)
358 if (!ffesrc_check_symbol ()
359 || ((s->check_state != FFESYMBOL_checkstateNONE_)
360 && ((s->check_state != FFESYMBOL_checkstateINHIBITED_)
361 || ffebad_inhibit ())))
364 bad = ffesymbol_check_token_ (t, &c);
368 s->check_state = FFESYMBOL_checkstateCHECKED_;
373 && ffeintrin_is_intrinsic (ffelex_token_text (t), NULL, FALSE,
376 s->check_state = FFESYMBOL_checkstatePENDING_;
377 s->check_token = ffelex_token_use (t);
381 if (ffebad_inhibit ())
383 s->check_state = FFESYMBOL_checkstateINHIBITED_;
384 return; /* Don't complain now, do it later. */
387 s->check_state = FFESYMBOL_checkstateCHECKED_;
389 ffesymbol_whine_state_ (bad, t, c);
392 /* Declare a BLOCKDATA unit.
394 Retrieves or creates the ffesymbol for the specified BLOCKDATA (unnamed
395 if t is NULL). Doesn't actually ensure the named item is a
396 BLOCKDATA; the caller must handle that. */
399 ffesymbol_declare_blockdataunit (ffelexToken t, ffewhereLine wl,
404 bool user = (t != NULL);
406 assert (!ffesymbol_retractable_);
410 if (ffesymbol_token_unnamed_blockdata_ == NULL)
411 ffesymbol_token_unnamed_blockdata_
412 = ffelex_token_new_name (FFETARGET_nameUNNAMED_BLOCK_DATA, wl, wc);
413 t = ffesymbol_token_unnamed_blockdata_;
416 n = ffename_lookup (ffesymbol_local_, t);
418 return ffename_symbol (n); /* This will become an error. */
420 n = ffename_find (ffesymbol_global_, t);
421 s = ffename_symbol (n);
425 ffesymbol_check (s, t, FALSE);
429 s = ffesymbol_new_ (n);
431 ffesymbol_check (s, t, FALSE);
433 /* A program unit name also is in the local name space. */
435 n = ffename_find (ffesymbol_local_, t);
436 ffename_set_symbol (n, s);
437 s->other_space_name = n;
439 ffeglobal_new_blockdata (s, t); /* Detect conflicts, when
445 /* Declare a common block (named or unnamed).
447 Retrieves or creates the ffesymbol for the specified common block (blank
448 common if t is NULL). Doesn't actually ensure the named item is a
449 common block; the caller must handle that. */
452 ffesymbol_declare_cblock (ffelexToken t, ffewhereLine wl, ffewhereColumn wc)
458 assert (!ffesymbol_retractable_);
463 if (ffesymbol_token_blank_common_ == NULL)
464 ffesymbol_token_blank_common_
465 = ffelex_token_new_name (FFETARGET_nameBLANK_COMMON, wl, wc);
466 t = ffesymbol_token_blank_common_;
471 n = ffename_find (ffesymbol_global_, t);
472 s = ffename_symbol (n);
476 ffesymbol_check (s, t, FALSE);
480 s = ffesymbol_new_ (n);
482 ffesymbol_check (s, t, FALSE);
484 ffeglobal_new_common (s, t, blank); /* Detect conflicts. */
489 /* Declare a FUNCTION program unit (with distinct RESULT() name).
491 Retrieves or creates the ffesymbol for the specified function. Doesn't
492 actually ensure the named item is a function; the caller must handle
495 If FUNCTION with RESULT() is specified but the names are the same,
496 pretend as though RESULT() was not specified, and don't call this
497 function; use ffesymbol_declare_funcunit() instead. */
500 ffesymbol_declare_funcnotresunit (ffelexToken t)
506 assert (!ffesymbol_retractable_);
508 n = ffename_lookup (ffesymbol_local_, t);
510 return ffename_symbol (n); /* This will become an error. */
512 n = ffename_find (ffesymbol_global_, t);
513 s = ffename_symbol (n);
516 ffesymbol_check (s, t, FALSE);
520 s = ffesymbol_new_ (n);
521 ffesymbol_check (s, t, FALSE);
523 /* A FUNCTION program unit name also is in the local name space; handle it
524 here since RESULT() is a different name and is handled separately. */
526 n = ffename_find (ffesymbol_local_, t);
527 ffename_set_symbol (n, s);
528 s->other_space_name = n;
530 ffeglobal_new_function (s, t);/* Detect conflicts, when appropriate. */
535 /* Declare a function result.
537 Retrieves or creates the ffesymbol for the specified function result,
538 whether specified via a distinct RESULT() or by default in a FUNCTION or
542 ffesymbol_declare_funcresult (ffelexToken t)
548 assert (!ffesymbol_retractable_);
550 n = ffename_find (ffesymbol_local_, t);
551 s = ffename_symbol (n);
555 return ffesymbol_new_ (n);
558 /* Declare a FUNCTION program unit with no RESULT().
560 Retrieves or creates the ffesymbol for the specified function. Doesn't
561 actually ensure the named item is a function; the caller must handle
564 This is the function to call when the FUNCTION or ENTRY statement has
565 no separate and distinct name specified via RESULT(). That's because
566 this function enters the global name of the function in only the global
567 name space. ffesymbol_declare_funcresult() must still be called to
568 declare the name for the function result in the local name space. */
571 ffesymbol_declare_funcunit (ffelexToken t)
577 assert (!ffesymbol_retractable_);
579 n = ffename_find (ffesymbol_global_, t);
580 s = ffename_symbol (n);
583 ffesymbol_check (s, t, FALSE);
587 s = ffesymbol_new_ (n);
588 ffesymbol_check (s, t, FALSE);
590 ffeglobal_new_function (s, t);/* Detect conflicts. */
595 /* Declare a local entity.
597 Retrieves or creates the ffesymbol for the specified local entity.
598 Set maybe_intrin TRUE if this name might turn out to name an
599 intrinsic (legitimately); otherwise if the name doesn't meet the
600 requirements for a user-defined symbol name, a diagnostic will be
601 issued right away rather than waiting until the intrinsicness of the
602 symbol is determined. */
605 ffesymbol_declare_local (ffelexToken t, bool maybe_intrin)
612 /* If we're parsing within a statement function definition, return the
613 symbol if already known (a dummy argument for the statement function).
614 Otherwise continue on, which means the symbol is declared within the
615 containing (local) program unit rather than the statement function
618 if ((ffesymbol_sfunc_ != NULL)
619 && ((n = ffename_lookup (ffesymbol_sfunc_, t)) != NULL))
620 return ffename_symbol (n);
622 n = ffename_find (ffesymbol_local_, t);
623 s = ffename_symbol (n);
626 ffesymbol_check (s, t, maybe_intrin);
630 s = ffesymbol_new_ (n);
631 ffesymbol_check (s, t, maybe_intrin);
635 /* Declare a main program unit.
637 Retrieves or creates the ffesymbol for the specified main program unit
638 (unnamed main program unit if t is NULL). Doesn't actually ensure the
639 named item is a program; the caller must handle that. */
642 ffesymbol_declare_programunit (ffelexToken t, ffewhereLine wl,
647 bool user = (t != NULL);
649 assert (!ffesymbol_retractable_);
653 if (ffesymbol_token_unnamed_main_ == NULL)
654 ffesymbol_token_unnamed_main_
655 = ffelex_token_new_name (FFETARGET_nameUNNAMED_MAIN, wl, wc);
656 t = ffesymbol_token_unnamed_main_;
659 n = ffename_lookup (ffesymbol_local_, t);
661 return ffename_symbol (n); /* This will become an error. */
663 n = ffename_find (ffesymbol_global_, t);
664 s = ffename_symbol (n);
668 ffesymbol_check (s, t, FALSE);
672 s = ffesymbol_new_ (n);
674 ffesymbol_check (s, t, FALSE);
676 /* A program unit name also is in the local name space. */
678 n = ffename_find (ffesymbol_local_, t);
679 ffename_set_symbol (n, s);
680 s->other_space_name = n;
682 ffeglobal_new_program (s, t); /* Detect conflicts. */
687 /* Declare a statement-function dummy.
689 Retrieves or creates the ffesymbol for the specified statement
690 function dummy. Also ensures that it has a link to the parent (local)
691 ffesymbol with the same name, creating it if necessary. */
694 ffesymbol_declare_sfdummy (ffelexToken t)
698 ffesymbol sp; /* Parent symbol in local area. */
702 n = ffename_find (ffesymbol_local_, t);
703 sp = ffename_symbol (n);
705 sp = ffesymbol_new_ (n);
706 ffesymbol_check (sp, t, FALSE);
708 n = ffename_find (ffesymbol_sfunc_, t);
709 s = ffename_symbol (n);
712 s = ffesymbol_new_ (n);
713 s->sfa_dummy_parent = sp;
716 assert (s->sfa_dummy_parent == sp);
721 /* Declare a subroutine program unit.
723 Retrieves or creates the ffesymbol for the specified subroutine
724 Doesn't actually ensure the named item is a subroutine; the caller must
728 ffesymbol_declare_subrunit (ffelexToken t)
733 assert (!ffesymbol_retractable_);
736 n = ffename_lookup (ffesymbol_local_, t);
738 return ffename_symbol (n); /* This will become an error. */
740 n = ffename_find (ffesymbol_global_, t);
741 s = ffename_symbol (n);
744 ffesymbol_check (s, t, FALSE);
748 s = ffesymbol_new_ (n);
749 ffesymbol_check (s, t, FALSE);
751 /* A program unit name also is in the local name space. */
753 n = ffename_find (ffesymbol_local_, t);
754 ffename_set_symbol (n, s);
755 s->other_space_name = n;
757 ffeglobal_new_subroutine (s, t); /* Detect conflicts, when
763 /* Call given fn with all local/global symbols.
765 ffesymbol (*fn) (ffesymbol s);
766 ffesymbol_drive (fn); */
769 ffesymbol_drive (ffesymbol (*fn) (ffesymbol))
771 assert (ffesymbol_sfunc_ == NULL); /* Might be ok, but not for current
773 ffename_space_drive_symbol (ffesymbol_local_, fn);
774 ffename_space_drive_symbol (ffesymbol_global_, fn);
777 /* Call given fn with all sfunc-only symbols.
779 ffesymbol (*fn) (ffesymbol s);
780 ffesymbol_drive_sfnames (fn); */
783 ffesymbol_drive_sfnames (ffesymbol (*fn) (ffesymbol))
785 ffename_space_drive_symbol (ffesymbol_sfunc_, fn);
788 /* Produce generic error message about a symbol.
790 For now, just output error message using symbol's name and pointing to
794 ffesymbol_error (ffesymbol s, ffelexToken t)
797 && ffest_ffebad_start (FFEBAD_SYMERR))
799 ffebad_string (ffesymbol_text (s));
800 ffebad_here (0, ffelex_token_where_line (t),
801 ffelex_token_where_column (t));
802 ffebad_here (1, ffesymbol_where_line (s), ffesymbol_where_column (s));
806 if (ffesymbol_attr (s, FFESYMBOL_attrANY))
809 ffesymbol_signal_change (s); /* May need to back up to previous version. */
810 if ((ffesymbol_attrs (s) & FFESYMBOL_attrsCBLOCK)
811 || (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
812 ffebld_end_list (ffesymbol_ptr_to_listbottom (s));
813 ffesymbol_set_attr (s, FFESYMBOL_attrANY);
814 ffesymbol_set_info (s, ffeinfo_new_any ());
815 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
816 if (s->check_state == FFESYMBOL_checkstatePENDING_)
817 ffelex_token_kill (s->check_token);
818 s->check_state = FFESYMBOL_checkstateCHECKED_;
819 s = ffecom_sym_learned (s);
820 ffesymbol_signal_unreported (s);
824 ffesymbol_init_0 (void)
826 ffesymbolAttrs attrs = FFESYMBOL_attrsetNONE;
828 assert (FFESYMBOL_state == ARRAY_SIZE (ffesymbol_state_name_));
829 assert (FFESYMBOL_attr == ARRAY_SIZE (ffesymbol_attr_name_));
830 assert (attrs == FFESYMBOL_attrsetNONE);
831 attrs = ((ffesymbolAttrs) 1 << FFESYMBOL_attr);
836 ffesymbol_init_1 (void)
838 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalFILE_
839 ffesymbol_global_ = ffename_space_new (ffe_pool_file ());
844 ffesymbol_init_2 (void)
849 ffesymbol_init_3 (void)
851 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
852 ffesymbol_global_ = ffename_space_new (ffe_pool_program_unit ());
854 ffesymbol_local_ = ffename_space_new (ffe_pool_program_unit ());
858 ffesymbol_init_4 (void)
860 ffesymbol_sfunc_ = ffename_space_new (ffe_pool_program_unit ());
863 /* Look up a local entity.
865 Retrieves the ffesymbol for the specified local entity, or returns NULL
866 if no local entity by that name exists. */
869 ffesymbol_lookup_local (ffelexToken t)
876 n = ffename_lookup (ffesymbol_local_, t);
880 s = ffename_symbol (n);
881 return s; /* May be NULL here, too. */
884 /* Registers the symbol as one that is referenced by the
885 current program unit. Currently applies only to
886 symbols known to have global interest (globals and
889 s is the (global/intrinsic) symbol referenced; t is the
890 referencing token; explicit is TRUE if the reference
891 is, e.g., INTRINSIC FOO. */
894 ffesymbol_reference (ffesymbol s, ffelexToken t, bool explicit)
902 if (ffesymbol_retractable_)
906 t = ffename_token (s->name); /* Use the first reference in this program unit. */
908 kind = ffesymbol_kind (s);
909 where = ffesymbol_where (s);
911 if (where == FFEINFO_whereINTRINSIC)
913 ffeglobal_ref_intrinsic (s, t,
916 || ffeintrin_is_standard (s->generic, s->specific));
920 if ((where != FFEINFO_whereGLOBAL)
921 && ((where != FFEINFO_whereLOCAL)
922 || ((kind != FFEINFO_kindFUNCTION)
923 && (kind != FFEINFO_kindSUBROUTINE))))
926 gn = ffename_lookup (ffesymbol_global_, t);
928 gs = ffename_symbol (gn);
929 if ((gs != NULL) && (gs != s))
931 /* We have just discovered another global symbol with the same name
932 but a different `nature'. Complain. Note that COMMON /FOO/ can
933 coexist with local symbol FOO, e.g. local variable, just not with
934 CALL FOO, hence the separate namespaces. */
936 ffesymbol_error (gs, t);
937 ffesymbol_error (s, NULL);
943 case FFEINFO_kindBLOCKDATA:
944 okay = ffeglobal_ref_blockdata (s, t);
947 case FFEINFO_kindSUBROUTINE:
948 okay = ffeglobal_ref_subroutine (s, t);
951 case FFEINFO_kindFUNCTION:
952 okay = ffeglobal_ref_function (s, t);
955 case FFEINFO_kindNONE:
956 okay = ffeglobal_ref_external (s, t);
960 assert ("bad kind in global ref" == NULL);
965 ffesymbol_error (s, NULL);
968 /* Resolve symbol that has become known intrinsic or non-intrinsic. */
971 ffesymbol_resolve_intrin (ffesymbol s)
976 if (!ffesrc_check_symbol ())
978 if (s->check_state != FFESYMBOL_checkstatePENDING_)
980 if (ffebad_inhibit ())
981 return; /* We'll get back to this later. */
983 if (ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
985 bad = ffesymbol_check_token_ (s->check_token, &c);
986 assert (bad != FFEBAD); /* How did this suddenly become ok? */
987 ffesymbol_whine_state_ (bad, s->check_token, c);
990 s->check_state = FFESYMBOL_checkstateCHECKED_;
991 ffelex_token_kill (s->check_token);
994 /* Retract or cancel retract list. */
997 ffesymbol_retract (bool retract)
1001 ffename other_space_name;
1005 assert (ffesymbol_retractable_);
1007 ffesymbol_retractable_ = FALSE;
1009 for (r = ffesymbol_retract_first_; r != NULL; r = r->next)
1015 case FFESYMBOL_retractcommandDELETE_:
1018 ffecom_sym_retract (ls);
1020 other_space_name = ls->other_space_name;
1021 ffesymbol_unhook_ (ls);
1022 malloc_kill_ks (FFESYMBOL_SPACE_POOL_, ls, sizeof (*ls));
1024 ffename_set_symbol (name, NULL);
1025 if (other_space_name != NULL)
1026 ffename_set_symbol (other_space_name, NULL);
1030 ffecom_sym_commit (ls);
1031 ls->have_old = FALSE;
1035 case FFESYMBOL_retractcommandRETRACT_:
1038 ffecom_sym_retract (ls);
1039 ffesymbol_unhook_ (ls);
1041 malloc_kill_ks (FFESYMBOL_SPACE_POOL_, os, sizeof (*os));
1045 ffecom_sym_commit (ls);
1046 ffesymbol_unhook_ (os);
1047 malloc_kill_ks (FFESYMBOL_SPACE_POOL_, os, sizeof (*os));
1048 ls->have_old = FALSE;
1053 assert ("bad command" == NULL);
1059 /* Return retractable flag. */
1062 ffesymbol_retractable (void)
1064 return ffesymbol_retractable_;
1067 /* Set retractable flag, retract pool.
1069 Between this call and ffesymbol_retract, any changes made to existing
1070 symbols cause the previous versions of those symbols to be saved, and any
1071 newly created symbols to have their previous nonexistence saved. When
1072 ffesymbol_retract is called, this information either is used to retract
1073 the changes and new symbols, or is discarded. */
1076 ffesymbol_set_retractable (mallocPool pool)
1078 assert (!ffesymbol_retractable_);
1080 ffesymbol_retractable_ = TRUE;
1081 ffesymbol_retract_pool_ = pool;
1082 ffesymbol_retract_list_ = &ffesymbol_retract_first_;
1083 ffesymbol_retract_first_ = NULL;
1086 /* Existing symbol about to be changed; save?
1088 Call this function before changing a symbol if it is possible that
1089 the current actions may need to be undone (i.e. one of several possible
1090 statement forms are being used to analyze the current system).
1092 If the "retractable" flag is not set, just return.
1093 Else, if the symbol's "have_old" flag is set, just return.
1094 Else, make a copy of the symbol and add it to the "retract" list, set
1095 the "have_old" flag, and return. */
1098 ffesymbol_signal_change (ffesymbol s)
1100 ffesymbolRetract_ r;
1103 if (!ffesymbol_retractable_ || s->have_old)
1106 r = malloc_new_kp (ffesymbol_retract_pool_, "FFESYMBOL retract",
1109 r->command = FFESYMBOL_retractcommandRETRACT_;
1111 r->symbol = sym = malloc_new_ks (FFESYMBOL_SPACE_POOL_,
1112 "FFESYMBOL", sizeof (*sym));
1113 *sym = *s; /* Make an exact copy of the symbol in case
1115 sym->info = ffeinfo_use (s->info);
1116 if (s->check_state == FFESYMBOL_checkstatePENDING_)
1117 sym->check_token = ffelex_token_use (s->check_token);
1119 *ffesymbol_retract_list_ = r;
1120 ffesymbol_retract_list_ = &r->next;
1125 /* Returns the string based on the state. */
1128 ffesymbol_state_string (ffesymbolState state)
1130 if (state >= ARRAY_SIZE (ffesymbol_state_name_))
1132 return ffesymbol_state_name_[state];
1136 ffesymbol_terminate_0 (void)
1141 ffesymbol_terminate_1 (void)
1143 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalFILE_
1144 ffename_space_drive_symbol (ffesymbol_global_, ffesymbol_unhook_);
1145 ffename_space_kill (ffesymbol_global_);
1146 ffesymbol_global_ = NULL;
1148 ffesymbol_kill_manifest_ ();
1153 ffesymbol_terminate_2 (void)
1155 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
1156 ffesymbol_kill_manifest_ ();
1161 ffesymbol_terminate_3 (void)
1163 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
1164 ffename_space_drive_symbol (ffesymbol_global_, ffesymbol_unhook_);
1165 ffename_space_kill (ffesymbol_global_);
1167 ffename_space_drive_symbol (ffesymbol_local_, ffesymbol_unhook_);
1168 ffename_space_kill (ffesymbol_local_);
1169 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
1170 ffesymbol_global_ = NULL;
1172 ffesymbol_local_ = NULL;
1176 ffesymbol_terminate_4 (void)
1178 ffename_space_drive_symbol (ffesymbol_sfunc_, ffesymbol_unhook_);
1179 ffename_space_kill (ffesymbol_sfunc_);
1180 ffesymbol_sfunc_ = NULL;
1183 /* Update INIT info to TRUE and all equiv/storage too.
1185 If INIT flag is TRUE, does nothing. Else sets it to TRUE and calls
1186 on the ffeequiv and ffestorag modules to update their INIT flags if
1187 the <s> symbol has those objects, and also updates the common area if
1191 ffesymbol_update_init (ffesymbol s)
1200 if ((s->equiv != NULL)
1201 && !ffeequiv_is_init (s->equiv))
1202 ffeequiv_update_init (s->equiv);
1204 if ((s->storage != NULL)
1205 && !ffestorag_is_init (s->storage))
1206 ffestorag_update_init (s->storage);
1208 if ((s->common != NULL)
1209 && (!ffesymbol_is_init (s->common)))
1210 ffesymbol_update_init (s->common);
1212 for (item = s->common_list; item != NULL; item = ffebld_trail (item))
1214 if (!ffesymbol_is_init (ffebld_symter (ffebld_head (item))))
1215 ffesymbol_update_init (ffebld_symter (ffebld_head (item)));
1219 /* Update SAVE info to TRUE and all equiv/storage too.
1221 If SAVE flag is TRUE, does nothing. Else sets it to TRUE and calls
1222 on the ffeequiv and ffestorag modules to update their SAVE flags if
1223 the <s> symbol has those objects, and also updates the common area if
1227 ffesymbol_update_save (ffesymbol s)
1236 if ((s->equiv != NULL)
1237 && !ffeequiv_is_save (s->equiv))
1238 ffeequiv_update_save (s->equiv);
1240 if ((s->storage != NULL)
1241 && !ffestorag_is_save (s->storage))
1242 ffestorag_update_save (s->storage);
1244 if ((s->common != NULL)
1245 && (!ffesymbol_is_save (s->common)))
1246 ffesymbol_update_save (s->common);
1248 for (item = s->common_list; item != NULL; item = ffebld_trail (item))
1250 if (!ffesymbol_is_save (ffebld_symter (ffebld_head (item))))
1251 ffesymbol_update_save (ffebld_symter (ffebld_head (item)));