1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000-2015 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* The syntax of gfortran modules resembles that of lisp lists, i.e. a
23 sequence of atoms, which can be left or right parenthesis, names,
24 integers or strings. Parenthesis are always matched which allows
25 us to skip over sections at high speed without having to know
26 anything about the internal structure of the lists. A "name" is
27 usually a fortran 95 identifier, but can also start with '@' in
28 order to reference a hidden symbol.
30 The first line of a module is an informational message about what
31 created the module, the file it came from and when it was created.
32 The second line is a warning for people not to edit the module.
33 The rest of the module looks like:
35 ( ( <Interface info for UPLUS> )
36 ( <Interface info for UMINUS> )
39 ( ( <name of operator interface> <module of op interface> <i/f1> ... )
42 ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
45 ( ( <common name> <symbol> <saved flag>)
51 ( <Symbol Number (in no particular order)>
53 <Module name of symbol>
54 ( <symbol information> )
63 In general, symbols refer to other symbols by their symbol number,
64 which are zero based. Symbols are written to the module in no
69 #include "coretypes.h"
73 #include "stringpool.h"
76 #include "parse.h" /* FIXME */
77 #include "constructor.h"
82 #define MODULE_EXTENSION ".mod"
83 #define SUBMODULE_EXTENSION ".smod"
85 /* Don't put any single quote (') in MOD_VERSION, if you want it to be
87 #define MOD_VERSION "14"
90 /* Structure that describes a position within a module file. */
99 /* Structure for list of symbols of intrinsic modules. */
112 P_UNKNOWN
= 0, P_OTHER
, P_NAMESPACE
, P_COMPONENT
, P_SYMBOL
116 /* The fixup structure lists pointers to pointers that have to
117 be updated when a pointer value becomes known. */
119 typedef struct fixup_t
122 struct fixup_t
*next
;
127 /* Structure for holding extra info needed for pointers being read. */
143 typedef struct pointer_info
145 BBT_HEADER (pointer_info
);
149 /* The first component of each member of the union is the pointer
156 void *pointer
; /* Member for doing pointer searches. */
161 char *true_name
, *module
, *binding_label
;
163 gfc_symtree
*symtree
;
164 enum gfc_rsym_state state
;
165 int ns
, referenced
, renamed
;
173 enum gfc_wsym_state state
;
182 #define gfc_get_pointer_info() XCNEW (pointer_info)
185 /* Local variables */
187 /* The gzFile for the module we're reading or writing. */
188 static gzFile module_fp
;
191 /* The name of the module we're reading (USE'ing) or writing. */
192 static const char *module_name
;
193 /* The name of the .smod file that the submodule will write to. */
194 static const char *submodule_name
;
196 /* Suppress the output of a .smod file by module, if no module
197 procedures have been seen. */
198 static bool no_module_procedures
;
200 static gfc_use_list
*module_list
;
202 /* If we're reading an intrinsic module, this is its ID. */
203 static intmod_id current_intmod
;
205 /* Content of module. */
206 static char* module_content
;
208 static long module_pos
;
209 static int module_line
, module_column
, only_flag
;
210 static int prev_module_line
, prev_module_column
;
213 { IO_INPUT
, IO_OUTPUT
}
216 static gfc_use_rename
*gfc_rename_list
;
217 static pointer_info
*pi_root
;
218 static int symbol_number
; /* Counter for assigning symbol numbers */
220 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
221 static bool in_load_equiv
;
225 /*****************************************************************/
227 /* Pointer/integer conversion. Pointers between structures are stored
228 as integers in the module file. The next couple of subroutines
229 handle this translation for reading and writing. */
231 /* Recursively free the tree of pointer structures. */
234 free_pi_tree (pointer_info
*p
)
239 if (p
->fixup
!= NULL
)
240 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
242 free_pi_tree (p
->left
);
243 free_pi_tree (p
->right
);
245 if (iomode
== IO_INPUT
)
247 XDELETEVEC (p
->u
.rsym
.true_name
);
248 XDELETEVEC (p
->u
.rsym
.module
);
249 XDELETEVEC (p
->u
.rsym
.binding_label
);
256 /* Compare pointers when searching by pointer. Used when writing a
260 compare_pointers (void *_sn1
, void *_sn2
)
262 pointer_info
*sn1
, *sn2
;
264 sn1
= (pointer_info
*) _sn1
;
265 sn2
= (pointer_info
*) _sn2
;
267 if (sn1
->u
.pointer
< sn2
->u
.pointer
)
269 if (sn1
->u
.pointer
> sn2
->u
.pointer
)
276 /* Compare integers when searching by integer. Used when reading a
280 compare_integers (void *_sn1
, void *_sn2
)
282 pointer_info
*sn1
, *sn2
;
284 sn1
= (pointer_info
*) _sn1
;
285 sn2
= (pointer_info
*) _sn2
;
287 if (sn1
->integer
< sn2
->integer
)
289 if (sn1
->integer
> sn2
->integer
)
296 /* Initialize the pointer_info tree. */
305 compare
= (iomode
== IO_INPUT
) ? compare_integers
: compare_pointers
;
307 /* Pointer 0 is the NULL pointer. */
308 p
= gfc_get_pointer_info ();
313 gfc_insert_bbt (&pi_root
, p
, compare
);
315 /* Pointer 1 is the current namespace. */
316 p
= gfc_get_pointer_info ();
317 p
->u
.pointer
= gfc_current_ns
;
319 p
->type
= P_NAMESPACE
;
321 gfc_insert_bbt (&pi_root
, p
, compare
);
327 /* During module writing, call here with a pointer to something,
328 returning the pointer_info node. */
330 static pointer_info
*
331 find_pointer (void *gp
)
338 if (p
->u
.pointer
== gp
)
340 p
= (gp
< p
->u
.pointer
) ? p
->left
: p
->right
;
347 /* Given a pointer while writing, returns the pointer_info tree node,
348 creating it if it doesn't exist. */
350 static pointer_info
*
351 get_pointer (void *gp
)
355 p
= find_pointer (gp
);
359 /* Pointer doesn't have an integer. Give it one. */
360 p
= gfc_get_pointer_info ();
363 p
->integer
= symbol_number
++;
365 gfc_insert_bbt (&pi_root
, p
, compare_pointers
);
371 /* Given an integer during reading, find it in the pointer_info tree,
372 creating the node if not found. */
374 static pointer_info
*
375 get_integer (int integer
)
385 c
= compare_integers (&t
, p
);
389 p
= (c
< 0) ? p
->left
: p
->right
;
395 p
= gfc_get_pointer_info ();
396 p
->integer
= integer
;
399 gfc_insert_bbt (&pi_root
, p
, compare_integers
);
405 /* Resolve any fixups using a known pointer. */
408 resolve_fixups (fixup_t
*f
, void *gp
)
421 /* Convert a string such that it starts with a lower-case character. Used
422 to convert the symtree name of a derived-type to the symbol name or to
423 the name of the associated generic function. */
426 dt_lower_string (const char *name
)
428 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
429 return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name
[0]),
431 return gfc_get_string (name
);
435 /* Convert a string such that it starts with an upper-case character. Used to
436 return the symtree-name for a derived type; the symbol name itself and the
437 symtree/symbol name of the associated generic function start with a lower-
441 dt_upper_string (const char *name
)
443 if (name
[0] != (char) TOUPPER ((unsigned char) name
[0]))
444 return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name
[0]),
446 return gfc_get_string (name
);
449 /* Call here during module reading when we know what pointer to
450 associate with an integer. Any fixups that exist are resolved at
454 associate_integer_pointer (pointer_info
*p
, void *gp
)
456 if (p
->u
.pointer
!= NULL
)
457 gfc_internal_error ("associate_integer_pointer(): Already associated");
461 resolve_fixups (p
->fixup
, gp
);
467 /* During module reading, given an integer and a pointer to a pointer,
468 either store the pointer from an already-known value or create a
469 fixup structure in order to store things later. Returns zero if
470 the reference has been actually stored, or nonzero if the reference
471 must be fixed later (i.e., associate_integer_pointer must be called
472 sometime later. Returns the pointer_info structure. */
474 static pointer_info
*
475 add_fixup (int integer
, void *gp
)
481 p
= get_integer (integer
);
483 if (p
->integer
== 0 || p
->u
.pointer
!= NULL
)
486 *cp
= (char *) p
->u
.pointer
;
495 f
->pointer
= (void **) gp
;
502 /*****************************************************************/
504 /* Parser related subroutines */
506 /* Free the rename list left behind by a USE statement. */
509 free_rename (gfc_use_rename
*list
)
511 gfc_use_rename
*next
;
513 for (; list
; list
= next
)
521 /* Match a USE statement. */
526 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module_nature
[GFC_MAX_SYMBOL_LEN
+ 1];
527 gfc_use_rename
*tail
= NULL
, *new_use
;
528 interface_type type
, type2
;
531 gfc_use_list
*use_list
;
533 use_list
= gfc_get_use_list ();
535 if (gfc_match (" , ") == MATCH_YES
)
537 if ((m
= gfc_match (" %n ::", module_nature
)) == MATCH_YES
)
539 if (!gfc_notify_std (GFC_STD_F2003
, "module "
540 "nature in USE statement at %C"))
543 if (strcmp (module_nature
, "intrinsic") == 0)
544 use_list
->intrinsic
= true;
547 if (strcmp (module_nature
, "non_intrinsic") == 0)
548 use_list
->non_intrinsic
= true;
551 gfc_error ("Module nature in USE statement at %C shall "
552 "be either INTRINSIC or NON_INTRINSIC");
559 /* Help output a better error message than "Unclassifiable
561 gfc_match (" %n", module_nature
);
562 if (strcmp (module_nature
, "intrinsic") == 0
563 || strcmp (module_nature
, "non_intrinsic") == 0)
564 gfc_error ("\"::\" was expected after module nature at %C "
565 "but was not found");
572 m
= gfc_match (" ::");
573 if (m
== MATCH_YES
&&
574 !gfc_notify_std(GFC_STD_F2003
, "\"USE :: module\" at %C"))
579 m
= gfc_match ("% ");
588 use_list
->where
= gfc_current_locus
;
590 m
= gfc_match_name (name
);
597 use_list
->module_name
= gfc_get_string (name
);
599 if (gfc_match_eos () == MATCH_YES
)
602 if (gfc_match_char (',') != MATCH_YES
)
605 if (gfc_match (" only :") == MATCH_YES
)
606 use_list
->only_flag
= true;
608 if (gfc_match_eos () == MATCH_YES
)
613 /* Get a new rename struct and add it to the rename list. */
614 new_use
= gfc_get_use_rename ();
615 new_use
->where
= gfc_current_locus
;
618 if (use_list
->rename
== NULL
)
619 use_list
->rename
= new_use
;
621 tail
->next
= new_use
;
624 /* See what kind of interface we're dealing with. Assume it is
626 new_use
->op
= INTRINSIC_NONE
;
627 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
632 case INTERFACE_NAMELESS
:
633 gfc_error ("Missing generic specification in USE statement at %C");
636 case INTERFACE_USER_OP
:
637 case INTERFACE_GENERIC
:
638 m
= gfc_match (" =>");
640 if (type
== INTERFACE_USER_OP
&& m
== MATCH_YES
641 && (!gfc_notify_std(GFC_STD_F2003
, "Renaming "
642 "operators in USE statements at %C")))
645 if (type
== INTERFACE_USER_OP
)
646 new_use
->op
= INTRINSIC_USER
;
648 if (use_list
->only_flag
)
651 strcpy (new_use
->use_name
, name
);
654 strcpy (new_use
->local_name
, name
);
655 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
660 if (m
== MATCH_ERROR
)
668 strcpy (new_use
->local_name
, name
);
670 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
675 if (m
== MATCH_ERROR
)
679 if (strcmp (new_use
->use_name
, use_list
->module_name
) == 0
680 || strcmp (new_use
->local_name
, use_list
->module_name
) == 0)
682 gfc_error ("The name %qs at %C has already been used as "
683 "an external module name.", use_list
->module_name
);
688 case INTERFACE_INTRINSIC_OP
:
696 if (gfc_match_eos () == MATCH_YES
)
698 if (gfc_match_char (',') != MATCH_YES
)
705 gfc_use_list
*last
= module_list
;
708 last
->next
= use_list
;
711 module_list
= use_list
;
716 gfc_syntax_error (ST_USE
);
719 free_rename (use_list
->rename
);
725 /* Match a SUBMODULE statement.
727 According to F2008:11.2.3.2, "The submodule identifier is the
728 ordered pair whose first element is the ancestor module name and
729 whose second element is the submodule name. 'Submodule_name' is
730 used for the submodule filename and uses '@' as a separator, whilst
731 the name of the symbol for the module uses '.' as a a separator.
732 The reasons for these choices are:
733 (i) To follow another leading brand in the submodule filenames;
734 (ii) Since '.' is not particularly visible in the filenames; and
735 (iii) The linker does not permit '@' in mnemonics. */
738 gfc_match_submodule (void)
741 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
742 gfc_use_list
*use_list
;
744 if (!gfc_notify_std (GFC_STD_F2008
, "SUBMODULE declaration at %C"))
747 gfc_new_block
= NULL
;
748 gcc_assert (module_list
== NULL
);
750 if (gfc_match_char ('(') != MATCH_YES
)
755 m
= gfc_match (" %n", name
);
759 use_list
= gfc_get_use_list ();
760 use_list
->where
= gfc_current_locus
;
764 gfc_use_list
*last
= module_list
;
767 last
->next
= use_list
;
768 use_list
->module_name
769 = gfc_get_string ("%s.%s", module_list
->module_name
, name
);
770 use_list
->submodule_name
771 = gfc_get_string ("%s@%s", module_list
->module_name
, name
);
775 module_list
= use_list
;
776 use_list
->module_name
= gfc_get_string (name
);
777 use_list
->submodule_name
= use_list
->module_name
;
780 if (gfc_match_char (')') == MATCH_YES
)
783 if (gfc_match_char (':') != MATCH_YES
)
787 m
= gfc_match (" %s%t", &gfc_new_block
);
791 submodule_name
= gfc_get_string ("%s@%s", module_list
->module_name
,
792 gfc_new_block
->name
);
794 gfc_new_block
->name
= gfc_get_string ("%s.%s",
795 module_list
->module_name
,
796 gfc_new_block
->name
);
798 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
799 gfc_new_block
->name
, NULL
))
802 /* Just retain the ultimate .(s)mod file for reading, since it
803 contains all the information in its ancestors. */
804 use_list
= module_list
;
805 for (; module_list
->next
; use_list
= module_list
)
807 module_list
= use_list
->next
;
814 gfc_error ("Syntax error in SUBMODULE statement at %C");
819 /* Given a name and a number, inst, return the inst name
820 under which to load this symbol. Returns NULL if this
821 symbol shouldn't be loaded. If inst is zero, returns
822 the number of instances of this name. If interface is
823 true, a user-defined operator is sought, otherwise only
824 non-operators are sought. */
827 find_use_name_n (const char *name
, int *inst
, bool interface
)
830 const char *low_name
= NULL
;
833 /* For derived types. */
834 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
835 low_name
= dt_lower_string (name
);
838 for (u
= gfc_rename_list
; u
; u
= u
->next
)
840 if ((!low_name
&& strcmp (u
->use_name
, name
) != 0)
841 || (low_name
&& strcmp (u
->use_name
, low_name
) != 0)
842 || (u
->op
== INTRINSIC_USER
&& !interface
)
843 || (u
->op
!= INTRINSIC_USER
&& interface
))
856 return only_flag
? NULL
: name
;
862 if (u
->local_name
[0] == '\0')
864 return dt_upper_string (u
->local_name
);
867 return (u
->local_name
[0] != '\0') ? u
->local_name
: name
;
871 /* Given a name, return the name under which to load this symbol.
872 Returns NULL if this symbol shouldn't be loaded. */
875 find_use_name (const char *name
, bool interface
)
878 return find_use_name_n (name
, &i
, interface
);
882 /* Given a real name, return the number of use names associated with it. */
885 number_use_names (const char *name
, bool interface
)
888 find_use_name_n (name
, &i
, interface
);
893 /* Try to find the operator in the current list. */
895 static gfc_use_rename
*
896 find_use_operator (gfc_intrinsic_op op
)
900 for (u
= gfc_rename_list
; u
; u
= u
->next
)
908 /*****************************************************************/
910 /* The next couple of subroutines maintain a tree used to avoid a
911 brute-force search for a combination of true name and module name.
912 While symtree names, the name that a particular symbol is known by
913 can changed with USE statements, we still have to keep track of the
914 true names to generate the correct reference, and also avoid
915 loading the same real symbol twice in a program unit.
917 When we start reading, the true name tree is built and maintained
918 as symbols are read. The tree is searched as we load new symbols
919 to see if it already exists someplace in the namespace. */
921 typedef struct true_name
923 BBT_HEADER (true_name
);
929 static true_name
*true_name_root
;
932 /* Compare two true_name structures. */
935 compare_true_names (void *_t1
, void *_t2
)
940 t1
= (true_name
*) _t1
;
941 t2
= (true_name
*) _t2
;
943 c
= ((t1
->sym
->module
> t2
->sym
->module
)
944 - (t1
->sym
->module
< t2
->sym
->module
));
948 return strcmp (t1
->name
, t2
->name
);
952 /* Given a true name, search the true name tree to see if it exists
953 within the main namespace. */
956 find_true_name (const char *name
, const char *module
)
962 t
.name
= gfc_get_string (name
);
964 sym
.module
= gfc_get_string (module
);
972 c
= compare_true_names ((void *) (&t
), (void *) p
);
976 p
= (c
< 0) ? p
->left
: p
->right
;
983 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
986 add_true_name (gfc_symbol
*sym
)
990 t
= XCNEW (true_name
);
992 if (sym
->attr
.flavor
== FL_DERIVED
)
993 t
->name
= dt_upper_string (sym
->name
);
997 gfc_insert_bbt (&true_name_root
, t
, compare_true_names
);
1001 /* Recursive function to build the initial true name tree by
1002 recursively traversing the current namespace. */
1005 build_tnt (gfc_symtree
*st
)
1011 build_tnt (st
->left
);
1012 build_tnt (st
->right
);
1014 if (st
->n
.sym
->attr
.flavor
== FL_DERIVED
)
1015 name
= dt_upper_string (st
->n
.sym
->name
);
1017 name
= st
->n
.sym
->name
;
1019 if (find_true_name (name
, st
->n
.sym
->module
) != NULL
)
1022 add_true_name (st
->n
.sym
);
1026 /* Initialize the true name tree with the current namespace. */
1029 init_true_name_tree (void)
1031 true_name_root
= NULL
;
1032 build_tnt (gfc_current_ns
->sym_root
);
1036 /* Recursively free a true name tree node. */
1039 free_true_name (true_name
*t
)
1043 free_true_name (t
->left
);
1044 free_true_name (t
->right
);
1050 /*****************************************************************/
1052 /* Module reading and writing. */
1054 /* The following are versions similar to the ones in scanner.c, but
1055 for dealing with compressed module files. */
1058 gzopen_included_file_1 (const char *name
, gfc_directorylist
*list
,
1059 bool module
, bool system
)
1062 gfc_directorylist
*p
;
1065 for (p
= list
; p
; p
= p
->next
)
1067 if (module
&& !p
->use_for_modules
)
1070 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 1);
1071 strcpy (fullname
, p
->path
);
1072 strcat (fullname
, name
);
1074 f
= gzopen (fullname
, "r");
1077 if (gfc_cpp_makedep ())
1078 gfc_cpp_add_dep (fullname
, system
);
1088 gzopen_included_file (const char *name
, bool include_cwd
, bool module
)
1092 if (IS_ABSOLUTE_PATH (name
) || include_cwd
)
1094 f
= gzopen (name
, "r");
1095 if (f
&& gfc_cpp_makedep ())
1096 gfc_cpp_add_dep (name
, false);
1100 f
= gzopen_included_file_1 (name
, include_dirs
, module
, false);
1106 gzopen_intrinsic_module (const char* name
)
1110 if (IS_ABSOLUTE_PATH (name
))
1112 f
= gzopen (name
, "r");
1113 if (f
&& gfc_cpp_makedep ())
1114 gfc_cpp_add_dep (name
, true);
1118 f
= gzopen_included_file_1 (name
, intrinsic_modules_dirs
, true, true);
1126 ATOM_NAME
, ATOM_LPAREN
, ATOM_RPAREN
, ATOM_INTEGER
, ATOM_STRING
1129 static atom_type last_atom
;
1132 /* The name buffer must be at least as long as a symbol name. Right
1133 now it's not clear how we're going to store numeric constants--
1134 probably as a hexadecimal string, since this will allow the exact
1135 number to be preserved (this can't be done by a decimal
1136 representation). Worry about that later. TODO! */
1138 #define MAX_ATOM_SIZE 100
1140 static int atom_int
;
1141 static char *atom_string
, atom_name
[MAX_ATOM_SIZE
];
1144 /* Report problems with a module. Error reporting is not very
1145 elaborate, since this sorts of errors shouldn't really happen.
1146 This subroutine never returns. */
1148 static void bad_module (const char *) ATTRIBUTE_NORETURN
;
1151 bad_module (const char *msgid
)
1153 XDELETEVEC (module_content
);
1154 module_content
= NULL
;
1159 gfc_fatal_error ("Reading module %qs at line %d column %d: %s",
1160 module_name
, module_line
, module_column
, msgid
);
1163 gfc_fatal_error ("Writing module %qs at line %d column %d: %s",
1164 module_name
, module_line
, module_column
, msgid
);
1167 gfc_fatal_error ("Module %qs at line %d column %d: %s",
1168 module_name
, module_line
, module_column
, msgid
);
1174 /* Set the module's input pointer. */
1177 set_module_locus (module_locus
*m
)
1179 module_column
= m
->column
;
1180 module_line
= m
->line
;
1181 module_pos
= m
->pos
;
1185 /* Get the module's input pointer so that we can restore it later. */
1188 get_module_locus (module_locus
*m
)
1190 m
->column
= module_column
;
1191 m
->line
= module_line
;
1192 m
->pos
= module_pos
;
1196 /* Get the next character in the module, updating our reckoning of
1202 const char c
= module_content
[module_pos
++];
1204 bad_module ("Unexpected EOF");
1206 prev_module_line
= module_line
;
1207 prev_module_column
= module_column
;
1219 /* Unget a character while remembering the line and column. Works for
1220 a single character only. */
1223 module_unget_char (void)
1225 module_line
= prev_module_line
;
1226 module_column
= prev_module_column
;
1230 /* Parse a string constant. The delimiter is guaranteed to be a
1240 atom_string
= XNEWVEC (char, cursz
);
1248 int c2
= module_char ();
1251 module_unget_char ();
1259 atom_string
= XRESIZEVEC (char, atom_string
, cursz
);
1261 atom_string
[len
] = c
;
1265 atom_string
= XRESIZEVEC (char, atom_string
, len
+ 1);
1266 atom_string
[len
] = '\0'; /* C-style string for debug purposes. */
1270 /* Parse a small integer. */
1273 parse_integer (int c
)
1282 module_unget_char ();
1286 atom_int
= 10 * atom_int
+ c
- '0';
1287 if (atom_int
> 99999999)
1288 bad_module ("Integer overflow");
1310 if (!ISALNUM (c
) && c
!= '_' && c
!= '-')
1312 module_unget_char ();
1317 if (++len
> GFC_MAX_SYMBOL_LEN
)
1318 bad_module ("Name too long");
1326 /* Read the next atom in the module's input stream. */
1337 while (c
== ' ' || c
== '\r' || c
== '\n');
1362 return ATOM_INTEGER
;
1420 bad_module ("Bad name");
1427 /* Peek at the next atom on the input. */
1438 while (c
== ' ' || c
== '\r' || c
== '\n');
1443 module_unget_char ();
1447 module_unget_char ();
1451 module_unget_char ();
1464 module_unget_char ();
1465 return ATOM_INTEGER
;
1519 module_unget_char ();
1523 bad_module ("Bad name");
1528 /* Read the next atom from the input, requiring that it be a
1532 require_atom (atom_type type
)
1538 column
= module_column
;
1547 p
= _("Expected name");
1550 p
= _("Expected left parenthesis");
1553 p
= _("Expected right parenthesis");
1556 p
= _("Expected integer");
1559 p
= _("Expected string");
1562 gfc_internal_error ("require_atom(): bad atom type required");
1565 module_column
= column
;
1572 /* Given a pointer to an mstring array, require that the current input
1573 be one of the strings in the array. We return the enum value. */
1576 find_enum (const mstring
*m
)
1580 i
= gfc_string2code (m
, atom_name
);
1584 bad_module ("find_enum(): Enum not found");
1590 /* Read a string. The caller is responsible for freeing. */
1596 require_atom (ATOM_STRING
);
1603 /**************** Module output subroutines ***************************/
1605 /* Output a character to a module file. */
1608 write_char (char out
)
1610 if (gzputc (module_fp
, out
) == EOF
)
1611 gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno
));
1623 /* Write an atom to a module. The line wrapping isn't perfect, but it
1624 should work most of the time. This isn't that big of a deal, since
1625 the file really isn't meant to be read by people anyway. */
1628 write_atom (atom_type atom
, const void *v
)
1632 /* Workaround -Wmaybe-uninitialized false positive during
1633 profiledbootstrap by initializing them. */
1641 p
= (const char *) v
;
1653 i
= *((const int *) v
);
1655 gfc_internal_error ("write_atom(): Writing negative integer");
1657 sprintf (buffer
, "%d", i
);
1662 gfc_internal_error ("write_atom(): Trying to write dab atom");
1666 if(p
== NULL
|| *p
== '\0')
1671 if (atom
!= ATOM_RPAREN
)
1673 if (module_column
+ len
> 72)
1678 if (last_atom
!= ATOM_LPAREN
&& module_column
!= 1)
1683 if (atom
== ATOM_STRING
)
1686 while (p
!= NULL
&& *p
)
1688 if (atom
== ATOM_STRING
&& *p
== '\'')
1693 if (atom
== ATOM_STRING
)
1701 /***************** Mid-level I/O subroutines *****************/
1703 /* These subroutines let their caller read or write atoms without
1704 caring about which of the two is actually happening. This lets a
1705 subroutine concentrate on the actual format of the data being
1708 static void mio_expr (gfc_expr
**);
1709 pointer_info
*mio_symbol_ref (gfc_symbol
**);
1710 pointer_info
*mio_interface_rest (gfc_interface
**);
1711 static void mio_symtree_ref (gfc_symtree
**);
1713 /* Read or write an enumerated value. On writing, we return the input
1714 value for the convenience of callers. We avoid using an integer
1715 pointer because enums are sometimes inside bitfields. */
1718 mio_name (int t
, const mstring
*m
)
1720 if (iomode
== IO_OUTPUT
)
1721 write_atom (ATOM_NAME
, gfc_code2string (m
, t
));
1724 require_atom (ATOM_NAME
);
1731 /* Specialization of mio_name. */
1733 #define DECL_MIO_NAME(TYPE) \
1734 static inline TYPE \
1735 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1737 return (TYPE) mio_name ((int) t, m); \
1739 #define MIO_NAME(TYPE) mio_name_##TYPE
1744 if (iomode
== IO_OUTPUT
)
1745 write_atom (ATOM_LPAREN
, NULL
);
1747 require_atom (ATOM_LPAREN
);
1754 if (iomode
== IO_OUTPUT
)
1755 write_atom (ATOM_RPAREN
, NULL
);
1757 require_atom (ATOM_RPAREN
);
1762 mio_integer (int *ip
)
1764 if (iomode
== IO_OUTPUT
)
1765 write_atom (ATOM_INTEGER
, ip
);
1768 require_atom (ATOM_INTEGER
);
1774 /* Read or write a gfc_intrinsic_op value. */
1777 mio_intrinsic_op (gfc_intrinsic_op
* op
)
1779 /* FIXME: Would be nicer to do this via the operators symbolic name. */
1780 if (iomode
== IO_OUTPUT
)
1782 int converted
= (int) *op
;
1783 write_atom (ATOM_INTEGER
, &converted
);
1787 require_atom (ATOM_INTEGER
);
1788 *op
= (gfc_intrinsic_op
) atom_int
;
1793 /* Read or write a character pointer that points to a string on the heap. */
1796 mio_allocated_string (const char *s
)
1798 if (iomode
== IO_OUTPUT
)
1800 write_atom (ATOM_STRING
, s
);
1805 require_atom (ATOM_STRING
);
1811 /* Functions for quoting and unquoting strings. */
1814 quote_string (const gfc_char_t
*s
, const size_t slength
)
1816 const gfc_char_t
*p
;
1820 /* Calculate the length we'll need: a backslash takes two ("\\"),
1821 non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */
1822 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1826 else if (!gfc_wide_is_printable (*p
))
1832 q
= res
= XCNEWVEC (char, len
+ 1);
1833 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1836 *q
++ = '\\', *q
++ = '\\';
1837 else if (!gfc_wide_is_printable (*p
))
1839 sprintf (q
, "\\U%08" HOST_WIDE_INT_PRINT
"x",
1840 (unsigned HOST_WIDE_INT
) *p
);
1844 *q
++ = (unsigned char) *p
;
1852 unquote_string (const char *s
)
1858 for (p
= s
, len
= 0; *p
; p
++, len
++)
1865 else if (p
[1] == 'U')
1866 p
+= 9; /* That is a "\U????????". */
1868 gfc_internal_error ("unquote_string(): got bad string");
1871 res
= gfc_get_wide_string (len
+ 1);
1872 for (i
= 0, p
= s
; i
< len
; i
++, p
++)
1877 res
[i
] = (unsigned char) *p
;
1878 else if (p
[1] == '\\')
1880 res
[i
] = (unsigned char) '\\';
1885 /* We read the 8-digits hexadecimal constant that follows. */
1890 gcc_assert (p
[1] == 'U');
1891 for (j
= 0; j
< 8; j
++)
1894 gcc_assert (sscanf (&p
[j
+2], "%01x", &n
) == 1);
1908 /* Read or write a character pointer that points to a wide string on the
1909 heap, performing quoting/unquoting of nonprintable characters using the
1910 form \U???????? (where each ? is a hexadecimal digit).
1911 Length is the length of the string, only known and used in output mode. */
1913 static const gfc_char_t
*
1914 mio_allocated_wide_string (const gfc_char_t
*s
, const size_t length
)
1916 if (iomode
== IO_OUTPUT
)
1918 char *quoted
= quote_string (s
, length
);
1919 write_atom (ATOM_STRING
, quoted
);
1925 gfc_char_t
*unquoted
;
1927 require_atom (ATOM_STRING
);
1928 unquoted
= unquote_string (atom_string
);
1935 /* Read or write a string that is in static memory. */
1938 mio_pool_string (const char **stringp
)
1940 /* TODO: one could write the string only once, and refer to it via a
1943 /* As a special case we have to deal with a NULL string. This
1944 happens for the 'module' member of 'gfc_symbol's that are not in a
1945 module. We read / write these as the empty string. */
1946 if (iomode
== IO_OUTPUT
)
1948 const char *p
= *stringp
== NULL
? "" : *stringp
;
1949 write_atom (ATOM_STRING
, p
);
1953 require_atom (ATOM_STRING
);
1954 *stringp
= atom_string
[0] == '\0' ? NULL
: gfc_get_string (atom_string
);
1960 /* Read or write a string that is inside of some already-allocated
1964 mio_internal_string (char *string
)
1966 if (iomode
== IO_OUTPUT
)
1967 write_atom (ATOM_STRING
, string
);
1970 require_atom (ATOM_STRING
);
1971 strcpy (string
, atom_string
);
1978 { AB_ALLOCATABLE
, AB_DIMENSION
, AB_EXTERNAL
, AB_INTRINSIC
, AB_OPTIONAL
,
1979 AB_POINTER
, AB_TARGET
, AB_DUMMY
, AB_RESULT
, AB_DATA
,
1980 AB_IN_NAMELIST
, AB_IN_COMMON
, AB_FUNCTION
, AB_SUBROUTINE
, AB_SEQUENCE
,
1981 AB_ELEMENTAL
, AB_PURE
, AB_RECURSIVE
, AB_GENERIC
, AB_ALWAYS_EXPLICIT
,
1982 AB_CRAY_POINTER
, AB_CRAY_POINTEE
, AB_THREADPRIVATE
,
1983 AB_ALLOC_COMP
, AB_POINTER_COMP
, AB_PROC_POINTER_COMP
, AB_PRIVATE_COMP
,
1984 AB_VALUE
, AB_VOLATILE
, AB_PROTECTED
, AB_LOCK_COMP
,
1985 AB_IS_BIND_C
, AB_IS_C_INTEROP
, AB_IS_ISO_C
, AB_ABSTRACT
, AB_ZERO_COMP
,
1986 AB_IS_CLASS
, AB_PROCEDURE
, AB_PROC_POINTER
, AB_ASYNCHRONOUS
, AB_CODIMENSION
,
1987 AB_COARRAY_COMP
, AB_VTYPE
, AB_VTAB
, AB_CONTIGUOUS
, AB_CLASS_POINTER
,
1988 AB_IMPLICIT_PURE
, AB_ARTIFICIAL
, AB_UNLIMITED_POLY
, AB_OMP_DECLARE_TARGET
,
1989 AB_ARRAY_OUTER_DEPENDENCY
, AB_MODULE_PROCEDURE
1992 static const mstring attr_bits
[] =
1994 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
1995 minit ("ARTIFICIAL", AB_ARTIFICIAL
),
1996 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS
),
1997 minit ("DIMENSION", AB_DIMENSION
),
1998 minit ("CODIMENSION", AB_CODIMENSION
),
1999 minit ("CONTIGUOUS", AB_CONTIGUOUS
),
2000 minit ("EXTERNAL", AB_EXTERNAL
),
2001 minit ("INTRINSIC", AB_INTRINSIC
),
2002 minit ("OPTIONAL", AB_OPTIONAL
),
2003 minit ("POINTER", AB_POINTER
),
2004 minit ("VOLATILE", AB_VOLATILE
),
2005 minit ("TARGET", AB_TARGET
),
2006 minit ("THREADPRIVATE", AB_THREADPRIVATE
),
2007 minit ("DUMMY", AB_DUMMY
),
2008 minit ("RESULT", AB_RESULT
),
2009 minit ("DATA", AB_DATA
),
2010 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
2011 minit ("IN_COMMON", AB_IN_COMMON
),
2012 minit ("FUNCTION", AB_FUNCTION
),
2013 minit ("SUBROUTINE", AB_SUBROUTINE
),
2014 minit ("SEQUENCE", AB_SEQUENCE
),
2015 minit ("ELEMENTAL", AB_ELEMENTAL
),
2016 minit ("PURE", AB_PURE
),
2017 minit ("RECURSIVE", AB_RECURSIVE
),
2018 minit ("GENERIC", AB_GENERIC
),
2019 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
2020 minit ("CRAY_POINTER", AB_CRAY_POINTER
),
2021 minit ("CRAY_POINTEE", AB_CRAY_POINTEE
),
2022 minit ("IS_BIND_C", AB_IS_BIND_C
),
2023 minit ("IS_C_INTEROP", AB_IS_C_INTEROP
),
2024 minit ("IS_ISO_C", AB_IS_ISO_C
),
2025 minit ("VALUE", AB_VALUE
),
2026 minit ("ALLOC_COMP", AB_ALLOC_COMP
),
2027 minit ("COARRAY_COMP", AB_COARRAY_COMP
),
2028 minit ("LOCK_COMP", AB_LOCK_COMP
),
2029 minit ("POINTER_COMP", AB_POINTER_COMP
),
2030 minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP
),
2031 minit ("PRIVATE_COMP", AB_PRIVATE_COMP
),
2032 minit ("ZERO_COMP", AB_ZERO_COMP
),
2033 minit ("PROTECTED", AB_PROTECTED
),
2034 minit ("ABSTRACT", AB_ABSTRACT
),
2035 minit ("IS_CLASS", AB_IS_CLASS
),
2036 minit ("PROCEDURE", AB_PROCEDURE
),
2037 minit ("PROC_POINTER", AB_PROC_POINTER
),
2038 minit ("VTYPE", AB_VTYPE
),
2039 minit ("VTAB", AB_VTAB
),
2040 minit ("CLASS_POINTER", AB_CLASS_POINTER
),
2041 minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE
),
2042 minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY
),
2043 minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET
),
2044 minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY
),
2045 minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE
),
2049 /* For binding attributes. */
2050 static const mstring binding_passing
[] =
2053 minit ("NOPASS", 1),
2056 static const mstring binding_overriding
[] =
2058 minit ("OVERRIDABLE", 0),
2059 minit ("NON_OVERRIDABLE", 1),
2060 minit ("DEFERRED", 2),
2063 static const mstring binding_generic
[] =
2065 minit ("SPECIFIC", 0),
2066 minit ("GENERIC", 1),
2069 static const mstring binding_ppc
[] =
2071 minit ("NO_PPC", 0),
2076 /* Specialization of mio_name. */
2077 DECL_MIO_NAME (ab_attribute
)
2078 DECL_MIO_NAME (ar_type
)
2079 DECL_MIO_NAME (array_type
)
2081 DECL_MIO_NAME (expr_t
)
2082 DECL_MIO_NAME (gfc_access
)
2083 DECL_MIO_NAME (gfc_intrinsic_op
)
2084 DECL_MIO_NAME (ifsrc
)
2085 DECL_MIO_NAME (save_state
)
2086 DECL_MIO_NAME (procedure_type
)
2087 DECL_MIO_NAME (ref_type
)
2088 DECL_MIO_NAME (sym_flavor
)
2089 DECL_MIO_NAME (sym_intent
)
2090 #undef DECL_MIO_NAME
2092 /* Symbol attributes are stored in list with the first three elements
2093 being the enumerated fields, while the remaining elements (if any)
2094 indicate the individual attribute bits. The access field is not
2095 saved-- it controls what symbols are exported when a module is
2099 mio_symbol_attribute (symbol_attribute
*attr
)
2102 unsigned ext_attr
,extension_level
;
2106 attr
->flavor
= MIO_NAME (sym_flavor
) (attr
->flavor
, flavors
);
2107 attr
->intent
= MIO_NAME (sym_intent
) (attr
->intent
, intents
);
2108 attr
->proc
= MIO_NAME (procedure_type
) (attr
->proc
, procedures
);
2109 attr
->if_source
= MIO_NAME (ifsrc
) (attr
->if_source
, ifsrc_types
);
2110 attr
->save
= MIO_NAME (save_state
) (attr
->save
, save_status
);
2112 ext_attr
= attr
->ext_attr
;
2113 mio_integer ((int *) &ext_attr
);
2114 attr
->ext_attr
= ext_attr
;
2116 extension_level
= attr
->extension
;
2117 mio_integer ((int *) &extension_level
);
2118 attr
->extension
= extension_level
;
2120 if (iomode
== IO_OUTPUT
)
2122 if (attr
->allocatable
)
2123 MIO_NAME (ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
2124 if (attr
->artificial
)
2125 MIO_NAME (ab_attribute
) (AB_ARTIFICIAL
, attr_bits
);
2126 if (attr
->asynchronous
)
2127 MIO_NAME (ab_attribute
) (AB_ASYNCHRONOUS
, attr_bits
);
2128 if (attr
->dimension
)
2129 MIO_NAME (ab_attribute
) (AB_DIMENSION
, attr_bits
);
2130 if (attr
->codimension
)
2131 MIO_NAME (ab_attribute
) (AB_CODIMENSION
, attr_bits
);
2132 if (attr
->contiguous
)
2133 MIO_NAME (ab_attribute
) (AB_CONTIGUOUS
, attr_bits
);
2135 MIO_NAME (ab_attribute
) (AB_EXTERNAL
, attr_bits
);
2136 if (attr
->intrinsic
)
2137 MIO_NAME (ab_attribute
) (AB_INTRINSIC
, attr_bits
);
2139 MIO_NAME (ab_attribute
) (AB_OPTIONAL
, attr_bits
);
2141 MIO_NAME (ab_attribute
) (AB_POINTER
, attr_bits
);
2142 if (attr
->class_pointer
)
2143 MIO_NAME (ab_attribute
) (AB_CLASS_POINTER
, attr_bits
);
2144 if (attr
->is_protected
)
2145 MIO_NAME (ab_attribute
) (AB_PROTECTED
, attr_bits
);
2147 MIO_NAME (ab_attribute
) (AB_VALUE
, attr_bits
);
2148 if (attr
->volatile_
)
2149 MIO_NAME (ab_attribute
) (AB_VOLATILE
, attr_bits
);
2151 MIO_NAME (ab_attribute
) (AB_TARGET
, attr_bits
);
2152 if (attr
->threadprivate
)
2153 MIO_NAME (ab_attribute
) (AB_THREADPRIVATE
, attr_bits
);
2155 MIO_NAME (ab_attribute
) (AB_DUMMY
, attr_bits
);
2157 MIO_NAME (ab_attribute
) (AB_RESULT
, attr_bits
);
2158 /* We deliberately don't preserve the "entry" flag. */
2161 MIO_NAME (ab_attribute
) (AB_DATA
, attr_bits
);
2162 if (attr
->in_namelist
)
2163 MIO_NAME (ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
2164 if (attr
->in_common
)
2165 MIO_NAME (ab_attribute
) (AB_IN_COMMON
, attr_bits
);
2168 MIO_NAME (ab_attribute
) (AB_FUNCTION
, attr_bits
);
2169 if (attr
->subroutine
)
2170 MIO_NAME (ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
2172 MIO_NAME (ab_attribute
) (AB_GENERIC
, attr_bits
);
2174 MIO_NAME (ab_attribute
) (AB_ABSTRACT
, attr_bits
);
2177 MIO_NAME (ab_attribute
) (AB_SEQUENCE
, attr_bits
);
2178 if (attr
->elemental
)
2179 MIO_NAME (ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
2181 MIO_NAME (ab_attribute
) (AB_PURE
, attr_bits
);
2182 if (attr
->implicit_pure
)
2183 MIO_NAME (ab_attribute
) (AB_IMPLICIT_PURE
, attr_bits
);
2184 if (attr
->unlimited_polymorphic
)
2185 MIO_NAME (ab_attribute
) (AB_UNLIMITED_POLY
, attr_bits
);
2186 if (attr
->recursive
)
2187 MIO_NAME (ab_attribute
) (AB_RECURSIVE
, attr_bits
);
2188 if (attr
->always_explicit
)
2189 MIO_NAME (ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
2190 if (attr
->cray_pointer
)
2191 MIO_NAME (ab_attribute
) (AB_CRAY_POINTER
, attr_bits
);
2192 if (attr
->cray_pointee
)
2193 MIO_NAME (ab_attribute
) (AB_CRAY_POINTEE
, attr_bits
);
2194 if (attr
->is_bind_c
)
2195 MIO_NAME(ab_attribute
) (AB_IS_BIND_C
, attr_bits
);
2196 if (attr
->is_c_interop
)
2197 MIO_NAME(ab_attribute
) (AB_IS_C_INTEROP
, attr_bits
);
2199 MIO_NAME(ab_attribute
) (AB_IS_ISO_C
, attr_bits
);
2200 if (attr
->alloc_comp
)
2201 MIO_NAME (ab_attribute
) (AB_ALLOC_COMP
, attr_bits
);
2202 if (attr
->pointer_comp
)
2203 MIO_NAME (ab_attribute
) (AB_POINTER_COMP
, attr_bits
);
2204 if (attr
->proc_pointer_comp
)
2205 MIO_NAME (ab_attribute
) (AB_PROC_POINTER_COMP
, attr_bits
);
2206 if (attr
->private_comp
)
2207 MIO_NAME (ab_attribute
) (AB_PRIVATE_COMP
, attr_bits
);
2208 if (attr
->coarray_comp
)
2209 MIO_NAME (ab_attribute
) (AB_COARRAY_COMP
, attr_bits
);
2210 if (attr
->lock_comp
)
2211 MIO_NAME (ab_attribute
) (AB_LOCK_COMP
, attr_bits
);
2212 if (attr
->zero_comp
)
2213 MIO_NAME (ab_attribute
) (AB_ZERO_COMP
, attr_bits
);
2215 MIO_NAME (ab_attribute
) (AB_IS_CLASS
, attr_bits
);
2216 if (attr
->procedure
)
2217 MIO_NAME (ab_attribute
) (AB_PROCEDURE
, attr_bits
);
2218 if (attr
->proc_pointer
)
2219 MIO_NAME (ab_attribute
) (AB_PROC_POINTER
, attr_bits
);
2221 MIO_NAME (ab_attribute
) (AB_VTYPE
, attr_bits
);
2223 MIO_NAME (ab_attribute
) (AB_VTAB
, attr_bits
);
2224 if (attr
->omp_declare_target
)
2225 MIO_NAME (ab_attribute
) (AB_OMP_DECLARE_TARGET
, attr_bits
);
2226 if (attr
->array_outer_dependency
)
2227 MIO_NAME (ab_attribute
) (AB_ARRAY_OUTER_DEPENDENCY
, attr_bits
);
2228 if (attr
->module_procedure
)
2230 MIO_NAME (ab_attribute
) (AB_MODULE_PROCEDURE
, attr_bits
);
2231 no_module_procedures
= false;
2242 if (t
== ATOM_RPAREN
)
2245 bad_module ("Expected attribute bit name");
2247 switch ((ab_attribute
) find_enum (attr_bits
))
2249 case AB_ALLOCATABLE
:
2250 attr
->allocatable
= 1;
2253 attr
->artificial
= 1;
2255 case AB_ASYNCHRONOUS
:
2256 attr
->asynchronous
= 1;
2259 attr
->dimension
= 1;
2261 case AB_CODIMENSION
:
2262 attr
->codimension
= 1;
2265 attr
->contiguous
= 1;
2271 attr
->intrinsic
= 1;
2279 case AB_CLASS_POINTER
:
2280 attr
->class_pointer
= 1;
2283 attr
->is_protected
= 1;
2289 attr
->volatile_
= 1;
2294 case AB_THREADPRIVATE
:
2295 attr
->threadprivate
= 1;
2306 case AB_IN_NAMELIST
:
2307 attr
->in_namelist
= 1;
2310 attr
->in_common
= 1;
2316 attr
->subroutine
= 1;
2328 attr
->elemental
= 1;
2333 case AB_IMPLICIT_PURE
:
2334 attr
->implicit_pure
= 1;
2336 case AB_UNLIMITED_POLY
:
2337 attr
->unlimited_polymorphic
= 1;
2340 attr
->recursive
= 1;
2342 case AB_ALWAYS_EXPLICIT
:
2343 attr
->always_explicit
= 1;
2345 case AB_CRAY_POINTER
:
2346 attr
->cray_pointer
= 1;
2348 case AB_CRAY_POINTEE
:
2349 attr
->cray_pointee
= 1;
2352 attr
->is_bind_c
= 1;
2354 case AB_IS_C_INTEROP
:
2355 attr
->is_c_interop
= 1;
2361 attr
->alloc_comp
= 1;
2363 case AB_COARRAY_COMP
:
2364 attr
->coarray_comp
= 1;
2367 attr
->lock_comp
= 1;
2369 case AB_POINTER_COMP
:
2370 attr
->pointer_comp
= 1;
2372 case AB_PROC_POINTER_COMP
:
2373 attr
->proc_pointer_comp
= 1;
2375 case AB_PRIVATE_COMP
:
2376 attr
->private_comp
= 1;
2379 attr
->zero_comp
= 1;
2385 attr
->procedure
= 1;
2387 case AB_PROC_POINTER
:
2388 attr
->proc_pointer
= 1;
2396 case AB_OMP_DECLARE_TARGET
:
2397 attr
->omp_declare_target
= 1;
2399 case AB_ARRAY_OUTER_DEPENDENCY
:
2400 attr
->array_outer_dependency
=1;
2402 case AB_MODULE_PROCEDURE
:
2403 attr
->module_procedure
=1;
2411 static const mstring bt_types
[] = {
2412 minit ("INTEGER", BT_INTEGER
),
2413 minit ("REAL", BT_REAL
),
2414 minit ("COMPLEX", BT_COMPLEX
),
2415 minit ("LOGICAL", BT_LOGICAL
),
2416 minit ("CHARACTER", BT_CHARACTER
),
2417 minit ("DERIVED", BT_DERIVED
),
2418 minit ("CLASS", BT_CLASS
),
2419 minit ("PROCEDURE", BT_PROCEDURE
),
2420 minit ("UNKNOWN", BT_UNKNOWN
),
2421 minit ("VOID", BT_VOID
),
2422 minit ("ASSUMED", BT_ASSUMED
),
2428 mio_charlen (gfc_charlen
**clp
)
2434 if (iomode
== IO_OUTPUT
)
2438 mio_expr (&cl
->length
);
2442 if (peek_atom () != ATOM_RPAREN
)
2444 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2445 mio_expr (&cl
->length
);
2454 /* See if a name is a generated name. */
2457 check_unique_name (const char *name
)
2459 return *name
== '@';
2464 mio_typespec (gfc_typespec
*ts
)
2468 ts
->type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2470 if (ts
->type
!= BT_DERIVED
&& ts
->type
!= BT_CLASS
)
2471 mio_integer (&ts
->kind
);
2473 mio_symbol_ref (&ts
->u
.derived
);
2475 mio_symbol_ref (&ts
->interface
);
2477 /* Add info for C interop and is_iso_c. */
2478 mio_integer (&ts
->is_c_interop
);
2479 mio_integer (&ts
->is_iso_c
);
2481 /* If the typespec is for an identifier either from iso_c_binding, or
2482 a constant that was initialized to an identifier from it, use the
2483 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2485 ts
->f90_type
= MIO_NAME (bt
) (ts
->f90_type
, bt_types
);
2487 ts
->f90_type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2489 if (ts
->type
!= BT_CHARACTER
)
2491 /* ts->u.cl is only valid for BT_CHARACTER. */
2496 mio_charlen (&ts
->u
.cl
);
2498 /* So as not to disturb the existing API, use an ATOM_NAME to
2499 transmit deferred characteristic for characters (F2003). */
2500 if (iomode
== IO_OUTPUT
)
2502 if (ts
->type
== BT_CHARACTER
&& ts
->deferred
)
2503 write_atom (ATOM_NAME
, "DEFERRED_CL");
2505 else if (peek_atom () != ATOM_RPAREN
)
2507 if (parse_atom () != ATOM_NAME
)
2508 bad_module ("Expected string");
2516 static const mstring array_spec_types
[] = {
2517 minit ("EXPLICIT", AS_EXPLICIT
),
2518 minit ("ASSUMED_RANK", AS_ASSUMED_RANK
),
2519 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
2520 minit ("DEFERRED", AS_DEFERRED
),
2521 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
2527 mio_array_spec (gfc_array_spec
**asp
)
2534 if (iomode
== IO_OUTPUT
)
2542 /* mio_integer expects nonnegative values. */
2543 rank
= as
->rank
> 0 ? as
->rank
: 0;
2544 mio_integer (&rank
);
2548 if (peek_atom () == ATOM_RPAREN
)
2554 *asp
= as
= gfc_get_array_spec ();
2555 mio_integer (&as
->rank
);
2558 mio_integer (&as
->corank
);
2559 as
->type
= MIO_NAME (array_type
) (as
->type
, array_spec_types
);
2561 if (iomode
== IO_INPUT
&& as
->type
== AS_ASSUMED_RANK
)
2563 if (iomode
== IO_INPUT
&& as
->corank
)
2564 as
->cotype
= (as
->type
== AS_DEFERRED
) ? AS_DEFERRED
: AS_EXPLICIT
;
2566 if (as
->rank
+ as
->corank
> 0)
2567 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
2569 mio_expr (&as
->lower
[i
]);
2570 mio_expr (&as
->upper
[i
]);
2578 /* Given a pointer to an array reference structure (which lives in a
2579 gfc_ref structure), find the corresponding array specification
2580 structure. Storing the pointer in the ref structure doesn't quite
2581 work when loading from a module. Generating code for an array
2582 reference also needs more information than just the array spec. */
2584 static const mstring array_ref_types
[] = {
2585 minit ("FULL", AR_FULL
),
2586 minit ("ELEMENT", AR_ELEMENT
),
2587 minit ("SECTION", AR_SECTION
),
2593 mio_array_ref (gfc_array_ref
*ar
)
2598 ar
->type
= MIO_NAME (ar_type
) (ar
->type
, array_ref_types
);
2599 mio_integer (&ar
->dimen
);
2607 for (i
= 0; i
< ar
->dimen
; i
++)
2608 mio_expr (&ar
->start
[i
]);
2613 for (i
= 0; i
< ar
->dimen
; i
++)
2615 mio_expr (&ar
->start
[i
]);
2616 mio_expr (&ar
->end
[i
]);
2617 mio_expr (&ar
->stride
[i
]);
2623 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2626 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2627 we can't call mio_integer directly. Instead loop over each element
2628 and cast it to/from an integer. */
2629 if (iomode
== IO_OUTPUT
)
2631 for (i
= 0; i
< ar
->dimen
; i
++)
2633 int tmp
= (int)ar
->dimen_type
[i
];
2634 write_atom (ATOM_INTEGER
, &tmp
);
2639 for (i
= 0; i
< ar
->dimen
; i
++)
2641 require_atom (ATOM_INTEGER
);
2642 ar
->dimen_type
[i
] = (enum gfc_array_ref_dimen_type
) atom_int
;
2646 if (iomode
== IO_INPUT
)
2648 ar
->where
= gfc_current_locus
;
2650 for (i
= 0; i
< ar
->dimen
; i
++)
2651 ar
->c_where
[i
] = gfc_current_locus
;
2658 /* Saves or restores a pointer. The pointer is converted back and
2659 forth from an integer. We return the pointer_info pointer so that
2660 the caller can take additional action based on the pointer type. */
2662 static pointer_info
*
2663 mio_pointer_ref (void *gp
)
2667 if (iomode
== IO_OUTPUT
)
2669 p
= get_pointer (*((char **) gp
));
2670 write_atom (ATOM_INTEGER
, &p
->integer
);
2674 require_atom (ATOM_INTEGER
);
2675 p
= add_fixup (atom_int
, gp
);
2682 /* Save and load references to components that occur within
2683 expressions. We have to describe these references by a number and
2684 by name. The number is necessary for forward references during
2685 reading, and the name is necessary if the symbol already exists in
2686 the namespace and is not loaded again. */
2689 mio_component_ref (gfc_component
**cp
)
2693 p
= mio_pointer_ref (cp
);
2694 if (p
->type
== P_UNKNOWN
)
2695 p
->type
= P_COMPONENT
;
2699 static void mio_namespace_ref (gfc_namespace
**nsp
);
2700 static void mio_formal_arglist (gfc_formal_arglist
**formal
);
2701 static void mio_typebound_proc (gfc_typebound_proc
** proc
);
2704 mio_component (gfc_component
*c
, int vtype
)
2711 if (iomode
== IO_OUTPUT
)
2713 p
= get_pointer (c
);
2714 mio_integer (&p
->integer
);
2719 p
= get_integer (n
);
2720 associate_integer_pointer (p
, c
);
2723 if (p
->type
== P_UNKNOWN
)
2724 p
->type
= P_COMPONENT
;
2726 mio_pool_string (&c
->name
);
2727 mio_typespec (&c
->ts
);
2728 mio_array_spec (&c
->as
);
2730 mio_symbol_attribute (&c
->attr
);
2731 if (c
->ts
.type
== BT_CLASS
)
2732 c
->attr
.class_ok
= 1;
2733 c
->attr
.access
= MIO_NAME (gfc_access
) (c
->attr
.access
, access_types
);
2735 if (!vtype
|| strcmp (c
->name
, "_final") == 0
2736 || strcmp (c
->name
, "_hash") == 0)
2737 mio_expr (&c
->initializer
);
2739 if (c
->attr
.proc_pointer
)
2740 mio_typebound_proc (&c
->tb
);
2747 mio_component_list (gfc_component
**cp
, int vtype
)
2749 gfc_component
*c
, *tail
;
2753 if (iomode
== IO_OUTPUT
)
2755 for (c
= *cp
; c
; c
= c
->next
)
2756 mio_component (c
, vtype
);
2765 if (peek_atom () == ATOM_RPAREN
)
2768 c
= gfc_get_component ();
2769 mio_component (c
, vtype
);
2785 mio_actual_arg (gfc_actual_arglist
*a
)
2788 mio_pool_string (&a
->name
);
2789 mio_expr (&a
->expr
);
2795 mio_actual_arglist (gfc_actual_arglist
**ap
)
2797 gfc_actual_arglist
*a
, *tail
;
2801 if (iomode
== IO_OUTPUT
)
2803 for (a
= *ap
; a
; a
= a
->next
)
2813 if (peek_atom () != ATOM_LPAREN
)
2816 a
= gfc_get_actual_arglist ();
2832 /* Read and write formal argument lists. */
2835 mio_formal_arglist (gfc_formal_arglist
**formal
)
2837 gfc_formal_arglist
*f
, *tail
;
2841 if (iomode
== IO_OUTPUT
)
2843 for (f
= *formal
; f
; f
= f
->next
)
2844 mio_symbol_ref (&f
->sym
);
2848 *formal
= tail
= NULL
;
2850 while (peek_atom () != ATOM_RPAREN
)
2852 f
= gfc_get_formal_arglist ();
2853 mio_symbol_ref (&f
->sym
);
2855 if (*formal
== NULL
)
2868 /* Save or restore a reference to a symbol node. */
2871 mio_symbol_ref (gfc_symbol
**symp
)
2875 p
= mio_pointer_ref (symp
);
2876 if (p
->type
== P_UNKNOWN
)
2879 if (iomode
== IO_OUTPUT
)
2881 if (p
->u
.wsym
.state
== UNREFERENCED
)
2882 p
->u
.wsym
.state
= NEEDS_WRITE
;
2886 if (p
->u
.rsym
.state
== UNUSED
)
2887 p
->u
.rsym
.state
= NEEDED
;
2893 /* Save or restore a reference to a symtree node. */
2896 mio_symtree_ref (gfc_symtree
**stp
)
2901 if (iomode
== IO_OUTPUT
)
2902 mio_symbol_ref (&(*stp
)->n
.sym
);
2905 require_atom (ATOM_INTEGER
);
2906 p
= get_integer (atom_int
);
2908 /* An unused equivalence member; make a symbol and a symtree
2910 if (in_load_equiv
&& p
->u
.rsym
.symtree
== NULL
)
2912 /* Since this is not used, it must have a unique name. */
2913 p
->u
.rsym
.symtree
= gfc_get_unique_symtree (gfc_current_ns
);
2915 /* Make the symbol. */
2916 if (p
->u
.rsym
.sym
== NULL
)
2918 p
->u
.rsym
.sym
= gfc_new_symbol (p
->u
.rsym
.true_name
,
2920 p
->u
.rsym
.sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
2923 p
->u
.rsym
.symtree
->n
.sym
= p
->u
.rsym
.sym
;
2924 p
->u
.rsym
.symtree
->n
.sym
->refs
++;
2925 p
->u
.rsym
.referenced
= 1;
2927 /* If the symbol is PRIVATE and in COMMON, load_commons will
2928 generate a fixup symbol, which must be associated. */
2930 resolve_fixups (p
->fixup
, p
->u
.rsym
.sym
);
2934 if (p
->type
== P_UNKNOWN
)
2937 if (p
->u
.rsym
.state
== UNUSED
)
2938 p
->u
.rsym
.state
= NEEDED
;
2940 if (p
->u
.rsym
.symtree
!= NULL
)
2942 *stp
= p
->u
.rsym
.symtree
;
2946 f
= XCNEW (fixup_t
);
2948 f
->next
= p
->u
.rsym
.stfixup
;
2949 p
->u
.rsym
.stfixup
= f
;
2951 f
->pointer
= (void **) stp
;
2958 mio_iterator (gfc_iterator
**ip
)
2964 if (iomode
== IO_OUTPUT
)
2971 if (peek_atom () == ATOM_RPAREN
)
2977 *ip
= gfc_get_iterator ();
2982 mio_expr (&iter
->var
);
2983 mio_expr (&iter
->start
);
2984 mio_expr (&iter
->end
);
2985 mio_expr (&iter
->step
);
2993 mio_constructor (gfc_constructor_base
*cp
)
2999 if (iomode
== IO_OUTPUT
)
3001 for (c
= gfc_constructor_first (*cp
); c
; c
= gfc_constructor_next (c
))
3004 mio_expr (&c
->expr
);
3005 mio_iterator (&c
->iterator
);
3011 while (peek_atom () != ATOM_RPAREN
)
3013 c
= gfc_constructor_append_expr (cp
, NULL
, NULL
);
3016 mio_expr (&c
->expr
);
3017 mio_iterator (&c
->iterator
);
3026 static const mstring ref_types
[] = {
3027 minit ("ARRAY", REF_ARRAY
),
3028 minit ("COMPONENT", REF_COMPONENT
),
3029 minit ("SUBSTRING", REF_SUBSTRING
),
3035 mio_ref (gfc_ref
**rp
)
3042 r
->type
= MIO_NAME (ref_type
) (r
->type
, ref_types
);
3047 mio_array_ref (&r
->u
.ar
);
3051 mio_symbol_ref (&r
->u
.c
.sym
);
3052 mio_component_ref (&r
->u
.c
.component
);
3056 mio_expr (&r
->u
.ss
.start
);
3057 mio_expr (&r
->u
.ss
.end
);
3058 mio_charlen (&r
->u
.ss
.length
);
3067 mio_ref_list (gfc_ref
**rp
)
3069 gfc_ref
*ref
, *head
, *tail
;
3073 if (iomode
== IO_OUTPUT
)
3075 for (ref
= *rp
; ref
; ref
= ref
->next
)
3082 while (peek_atom () != ATOM_RPAREN
)
3085 head
= tail
= gfc_get_ref ();
3088 tail
->next
= gfc_get_ref ();
3102 /* Read and write an integer value. */
3105 mio_gmp_integer (mpz_t
*integer
)
3109 if (iomode
== IO_INPUT
)
3111 if (parse_atom () != ATOM_STRING
)
3112 bad_module ("Expected integer string");
3114 mpz_init (*integer
);
3115 if (mpz_set_str (*integer
, atom_string
, 10))
3116 bad_module ("Error converting integer");
3122 p
= mpz_get_str (NULL
, 10, *integer
);
3123 write_atom (ATOM_STRING
, p
);
3130 mio_gmp_real (mpfr_t
*real
)
3135 if (iomode
== IO_INPUT
)
3137 if (parse_atom () != ATOM_STRING
)
3138 bad_module ("Expected real string");
3141 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
3146 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
3148 if (mpfr_nan_p (*real
) || mpfr_inf_p (*real
))
3150 write_atom (ATOM_STRING
, p
);
3155 atom_string
= XCNEWVEC (char, strlen (p
) + 20);
3157 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
3159 /* Fix negative numbers. */
3160 if (atom_string
[2] == '-')
3162 atom_string
[0] = '-';
3163 atom_string
[1] = '0';
3164 atom_string
[2] = '.';
3167 write_atom (ATOM_STRING
, atom_string
);
3175 /* Save and restore the shape of an array constructor. */
3178 mio_shape (mpz_t
**pshape
, int rank
)
3184 /* A NULL shape is represented by (). */
3187 if (iomode
== IO_OUTPUT
)
3199 if (t
== ATOM_RPAREN
)
3206 shape
= gfc_get_shape (rank
);
3210 for (n
= 0; n
< rank
; n
++)
3211 mio_gmp_integer (&shape
[n
]);
3217 static const mstring expr_types
[] = {
3218 minit ("OP", EXPR_OP
),
3219 minit ("FUNCTION", EXPR_FUNCTION
),
3220 minit ("CONSTANT", EXPR_CONSTANT
),
3221 minit ("VARIABLE", EXPR_VARIABLE
),
3222 minit ("SUBSTRING", EXPR_SUBSTRING
),
3223 minit ("STRUCTURE", EXPR_STRUCTURE
),
3224 minit ("ARRAY", EXPR_ARRAY
),
3225 minit ("NULL", EXPR_NULL
),
3226 minit ("COMPCALL", EXPR_COMPCALL
),
3230 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3231 generic operators, not in expressions. INTRINSIC_USER is also
3232 replaced by the correct function name by the time we see it. */
3234 static const mstring intrinsics
[] =
3236 minit ("UPLUS", INTRINSIC_UPLUS
),
3237 minit ("UMINUS", INTRINSIC_UMINUS
),
3238 minit ("PLUS", INTRINSIC_PLUS
),
3239 minit ("MINUS", INTRINSIC_MINUS
),
3240 minit ("TIMES", INTRINSIC_TIMES
),
3241 minit ("DIVIDE", INTRINSIC_DIVIDE
),
3242 minit ("POWER", INTRINSIC_POWER
),
3243 minit ("CONCAT", INTRINSIC_CONCAT
),
3244 minit ("AND", INTRINSIC_AND
),
3245 minit ("OR", INTRINSIC_OR
),
3246 minit ("EQV", INTRINSIC_EQV
),
3247 minit ("NEQV", INTRINSIC_NEQV
),
3248 minit ("EQ_SIGN", INTRINSIC_EQ
),
3249 minit ("EQ", INTRINSIC_EQ_OS
),
3250 minit ("NE_SIGN", INTRINSIC_NE
),
3251 minit ("NE", INTRINSIC_NE_OS
),
3252 minit ("GT_SIGN", INTRINSIC_GT
),
3253 minit ("GT", INTRINSIC_GT_OS
),
3254 minit ("GE_SIGN", INTRINSIC_GE
),
3255 minit ("GE", INTRINSIC_GE_OS
),
3256 minit ("LT_SIGN", INTRINSIC_LT
),
3257 minit ("LT", INTRINSIC_LT_OS
),
3258 minit ("LE_SIGN", INTRINSIC_LE
),
3259 minit ("LE", INTRINSIC_LE_OS
),
3260 minit ("NOT", INTRINSIC_NOT
),
3261 minit ("PARENTHESES", INTRINSIC_PARENTHESES
),
3262 minit ("USER", INTRINSIC_USER
),
3267 /* Remedy a couple of situations where the gfc_expr's can be defective. */
3270 fix_mio_expr (gfc_expr
*e
)
3272 gfc_symtree
*ns_st
= NULL
;
3275 if (iomode
!= IO_OUTPUT
)
3280 /* If this is a symtree for a symbol that came from a contained module
3281 namespace, it has a unique name and we should look in the current
3282 namespace to see if the required, non-contained symbol is available
3283 yet. If so, the latter should be written. */
3284 if (e
->symtree
->n
.sym
&& check_unique_name (e
->symtree
->name
))
3286 const char *name
= e
->symtree
->n
.sym
->name
;
3287 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_DERIVED
)
3288 name
= dt_upper_string (name
);
3289 ns_st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3292 /* On the other hand, if the existing symbol is the module name or the
3293 new symbol is a dummy argument, do not do the promotion. */
3294 if (ns_st
&& ns_st
->n
.sym
3295 && ns_st
->n
.sym
->attr
.flavor
!= FL_MODULE
3296 && !e
->symtree
->n
.sym
->attr
.dummy
)
3299 else if (e
->expr_type
== EXPR_FUNCTION
3300 && (e
->value
.function
.name
|| e
->value
.function
.isym
))
3304 /* In some circumstances, a function used in an initialization
3305 expression, in one use associated module, can fail to be
3306 coupled to its symtree when used in a specification
3307 expression in another module. */
3308 fname
= e
->value
.function
.esym
? e
->value
.function
.esym
->name
3309 : e
->value
.function
.isym
->name
;
3310 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3315 /* This is probably a reference to a private procedure from another
3316 module. To prevent a segfault, make a generic with no specific
3317 instances. If this module is used, without the required
3318 specific coming from somewhere, the appropriate error message
3320 gfc_get_symbol (fname
, gfc_current_ns
, &sym
);
3321 sym
->attr
.flavor
= FL_PROCEDURE
;
3322 sym
->attr
.generic
= 1;
3323 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3324 gfc_commit_symbol (sym
);
3329 /* Read and write expressions. The form "()" is allowed to indicate a
3333 mio_expr (gfc_expr
**ep
)
3341 if (iomode
== IO_OUTPUT
)
3350 MIO_NAME (expr_t
) (e
->expr_type
, expr_types
);
3355 if (t
== ATOM_RPAREN
)
3362 bad_module ("Expected expression type");
3364 e
= *ep
= gfc_get_expr ();
3365 e
->where
= gfc_current_locus
;
3366 e
->expr_type
= (expr_t
) find_enum (expr_types
);
3369 mio_typespec (&e
->ts
);
3370 mio_integer (&e
->rank
);
3374 switch (e
->expr_type
)
3378 = MIO_NAME (gfc_intrinsic_op
) (e
->value
.op
.op
, intrinsics
);
3380 switch (e
->value
.op
.op
)
3382 case INTRINSIC_UPLUS
:
3383 case INTRINSIC_UMINUS
:
3385 case INTRINSIC_PARENTHESES
:
3386 mio_expr (&e
->value
.op
.op1
);
3389 case INTRINSIC_PLUS
:
3390 case INTRINSIC_MINUS
:
3391 case INTRINSIC_TIMES
:
3392 case INTRINSIC_DIVIDE
:
3393 case INTRINSIC_POWER
:
3394 case INTRINSIC_CONCAT
:
3398 case INTRINSIC_NEQV
:
3400 case INTRINSIC_EQ_OS
:
3402 case INTRINSIC_NE_OS
:
3404 case INTRINSIC_GT_OS
:
3406 case INTRINSIC_GE_OS
:
3408 case INTRINSIC_LT_OS
:
3410 case INTRINSIC_LE_OS
:
3411 mio_expr (&e
->value
.op
.op1
);
3412 mio_expr (&e
->value
.op
.op2
);
3415 case INTRINSIC_USER
:
3416 /* INTRINSIC_USER should not appear in resolved expressions,
3417 though for UDRs we need to stream unresolved ones. */
3418 if (iomode
== IO_OUTPUT
)
3419 write_atom (ATOM_STRING
, e
->value
.op
.uop
->name
);
3422 char *name
= read_string ();
3423 const char *uop_name
= find_use_name (name
, true);
3424 if (uop_name
== NULL
)
3426 size_t len
= strlen (name
);
3427 char *name2
= XCNEWVEC (char, len
+ 2);
3428 memcpy (name2
, name
, len
);
3430 name2
[len
+ 1] = '\0';
3432 uop_name
= name
= name2
;
3434 e
->value
.op
.uop
= gfc_get_uop (uop_name
);
3437 mio_expr (&e
->value
.op
.op1
);
3438 mio_expr (&e
->value
.op
.op2
);
3442 bad_module ("Bad operator");
3448 mio_symtree_ref (&e
->symtree
);
3449 mio_actual_arglist (&e
->value
.function
.actual
);
3451 if (iomode
== IO_OUTPUT
)
3453 e
->value
.function
.name
3454 = mio_allocated_string (e
->value
.function
.name
);
3455 if (e
->value
.function
.esym
)
3459 else if (e
->value
.function
.isym
== NULL
)
3463 mio_integer (&flag
);
3467 mio_symbol_ref (&e
->value
.function
.esym
);
3470 mio_ref_list (&e
->ref
);
3475 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
3480 require_atom (ATOM_STRING
);
3481 if (atom_string
[0] == '\0')
3482 e
->value
.function
.name
= NULL
;
3484 e
->value
.function
.name
= gfc_get_string (atom_string
);
3487 mio_integer (&flag
);
3491 mio_symbol_ref (&e
->value
.function
.esym
);
3494 mio_ref_list (&e
->ref
);
3499 require_atom (ATOM_STRING
);
3500 e
->value
.function
.isym
= gfc_find_function (atom_string
);
3508 mio_symtree_ref (&e
->symtree
);
3509 mio_ref_list (&e
->ref
);
3512 case EXPR_SUBSTRING
:
3513 e
->value
.character
.string
3514 = CONST_CAST (gfc_char_t
*,
3515 mio_allocated_wide_string (e
->value
.character
.string
,
3516 e
->value
.character
.length
));
3517 mio_ref_list (&e
->ref
);
3520 case EXPR_STRUCTURE
:
3522 mio_constructor (&e
->value
.constructor
);
3523 mio_shape (&e
->shape
, e
->rank
);
3530 mio_gmp_integer (&e
->value
.integer
);
3534 gfc_set_model_kind (e
->ts
.kind
);
3535 mio_gmp_real (&e
->value
.real
);
3539 gfc_set_model_kind (e
->ts
.kind
);
3540 mio_gmp_real (&mpc_realref (e
->value
.complex));
3541 mio_gmp_real (&mpc_imagref (e
->value
.complex));
3545 mio_integer (&e
->value
.logical
);
3549 mio_integer (&e
->value
.character
.length
);
3550 e
->value
.character
.string
3551 = CONST_CAST (gfc_char_t
*,
3552 mio_allocated_wide_string (e
->value
.character
.string
,
3553 e
->value
.character
.length
));
3557 bad_module ("Bad type in constant expression");
3575 /* Read and write namelists. */
3578 mio_namelist (gfc_symbol
*sym
)
3580 gfc_namelist
*n
, *m
;
3581 const char *check_name
;
3585 if (iomode
== IO_OUTPUT
)
3587 for (n
= sym
->namelist
; n
; n
= n
->next
)
3588 mio_symbol_ref (&n
->sym
);
3592 /* This departure from the standard is flagged as an error.
3593 It does, in fact, work correctly. TODO: Allow it
3595 if (sym
->attr
.flavor
== FL_NAMELIST
)
3597 check_name
= find_use_name (sym
->name
, false);
3598 if (check_name
&& strcmp (check_name
, sym
->name
) != 0)
3599 gfc_error ("Namelist %s cannot be renamed by USE "
3600 "association to %s", sym
->name
, check_name
);
3604 while (peek_atom () != ATOM_RPAREN
)
3606 n
= gfc_get_namelist ();
3607 mio_symbol_ref (&n
->sym
);
3609 if (sym
->namelist
== NULL
)
3616 sym
->namelist_tail
= m
;
3623 /* Save/restore lists of gfc_interface structures. When loading an
3624 interface, we are really appending to the existing list of
3625 interfaces. Checking for duplicate and ambiguous interfaces has to
3626 be done later when all symbols have been loaded. */
3629 mio_interface_rest (gfc_interface
**ip
)
3631 gfc_interface
*tail
, *p
;
3632 pointer_info
*pi
= NULL
;
3634 if (iomode
== IO_OUTPUT
)
3637 for (p
= *ip
; p
; p
= p
->next
)
3638 mio_symbol_ref (&p
->sym
);
3653 if (peek_atom () == ATOM_RPAREN
)
3656 p
= gfc_get_interface ();
3657 p
->where
= gfc_current_locus
;
3658 pi
= mio_symbol_ref (&p
->sym
);
3674 /* Save/restore a nameless operator interface. */
3677 mio_interface (gfc_interface
**ip
)
3680 mio_interface_rest (ip
);
3684 /* Save/restore a named operator interface. */
3687 mio_symbol_interface (const char **name
, const char **module
,
3691 mio_pool_string (name
);
3692 mio_pool_string (module
);
3693 mio_interface_rest (ip
);
3698 mio_namespace_ref (gfc_namespace
**nsp
)
3703 p
= mio_pointer_ref (nsp
);
3705 if (p
->type
== P_UNKNOWN
)
3706 p
->type
= P_NAMESPACE
;
3708 if (iomode
== IO_INPUT
&& p
->integer
!= 0)
3710 ns
= (gfc_namespace
*) p
->u
.pointer
;
3713 ns
= gfc_get_namespace (NULL
, 0);
3714 associate_integer_pointer (p
, ns
);
3722 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
3724 static gfc_namespace
* current_f2k_derived
;
3727 mio_typebound_proc (gfc_typebound_proc
** proc
)
3730 int overriding_flag
;
3732 if (iomode
== IO_INPUT
)
3734 *proc
= gfc_get_typebound_proc (NULL
);
3735 (*proc
)->where
= gfc_current_locus
;
3741 (*proc
)->access
= MIO_NAME (gfc_access
) ((*proc
)->access
, access_types
);
3743 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
3744 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3745 overriding_flag
= ((*proc
)->deferred
<< 1) | (*proc
)->non_overridable
;
3746 overriding_flag
= mio_name (overriding_flag
, binding_overriding
);
3747 (*proc
)->deferred
= ((overriding_flag
& 2) != 0);
3748 (*proc
)->non_overridable
= ((overriding_flag
& 1) != 0);
3749 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3751 (*proc
)->nopass
= mio_name ((*proc
)->nopass
, binding_passing
);
3752 (*proc
)->is_generic
= mio_name ((*proc
)->is_generic
, binding_generic
);
3753 (*proc
)->ppc
= mio_name((*proc
)->ppc
, binding_ppc
);
3755 mio_pool_string (&((*proc
)->pass_arg
));
3757 flag
= (int) (*proc
)->pass_arg_num
;
3758 mio_integer (&flag
);
3759 (*proc
)->pass_arg_num
= (unsigned) flag
;
3761 if ((*proc
)->is_generic
)
3768 if (iomode
== IO_OUTPUT
)
3769 for (g
= (*proc
)->u
.generic
; g
; g
= g
->next
)
3771 iop
= (int) g
->is_operator
;
3773 mio_allocated_string (g
->specific_st
->name
);
3777 (*proc
)->u
.generic
= NULL
;
3778 while (peek_atom () != ATOM_RPAREN
)
3780 gfc_symtree
** sym_root
;
3782 g
= gfc_get_tbp_generic ();
3786 g
->is_operator
= (bool) iop
;
3788 require_atom (ATOM_STRING
);
3789 sym_root
= ¤t_f2k_derived
->tb_sym_root
;
3790 g
->specific_st
= gfc_get_tbp_symtree (sym_root
, atom_string
);
3793 g
->next
= (*proc
)->u
.generic
;
3794 (*proc
)->u
.generic
= g
;
3800 else if (!(*proc
)->ppc
)
3801 mio_symtree_ref (&(*proc
)->u
.specific
);
3806 /* Walker-callback function for this purpose. */
3808 mio_typebound_symtree (gfc_symtree
* st
)
3810 if (iomode
== IO_OUTPUT
&& !st
->n
.tb
)
3813 if (iomode
== IO_OUTPUT
)
3816 mio_allocated_string (st
->name
);
3818 /* For IO_INPUT, the above is done in mio_f2k_derived. */
3820 mio_typebound_proc (&st
->n
.tb
);
3824 /* IO a full symtree (in all depth). */
3826 mio_full_typebound_tree (gfc_symtree
** root
)
3830 if (iomode
== IO_OUTPUT
)
3831 gfc_traverse_symtree (*root
, &mio_typebound_symtree
);
3834 while (peek_atom () == ATOM_LPAREN
)
3840 require_atom (ATOM_STRING
);
3841 st
= gfc_get_tbp_symtree (root
, atom_string
);
3844 mio_typebound_symtree (st
);
3852 mio_finalizer (gfc_finalizer
**f
)
3854 if (iomode
== IO_OUTPUT
)
3857 gcc_assert ((*f
)->proc_tree
); /* Should already be resolved. */
3858 mio_symtree_ref (&(*f
)->proc_tree
);
3862 *f
= gfc_get_finalizer ();
3863 (*f
)->where
= gfc_current_locus
; /* Value should not matter. */
3866 mio_symtree_ref (&(*f
)->proc_tree
);
3867 (*f
)->proc_sym
= NULL
;
3872 mio_f2k_derived (gfc_namespace
*f2k
)
3874 current_f2k_derived
= f2k
;
3876 /* Handle the list of finalizer procedures. */
3878 if (iomode
== IO_OUTPUT
)
3881 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
3886 f2k
->finalizers
= NULL
;
3887 while (peek_atom () != ATOM_RPAREN
)
3889 gfc_finalizer
*cur
= NULL
;
3890 mio_finalizer (&cur
);
3891 cur
->next
= f2k
->finalizers
;
3892 f2k
->finalizers
= cur
;
3897 /* Handle type-bound procedures. */
3898 mio_full_typebound_tree (&f2k
->tb_sym_root
);
3900 /* Type-bound user operators. */
3901 mio_full_typebound_tree (&f2k
->tb_uop_root
);
3903 /* Type-bound intrinsic operators. */
3905 if (iomode
== IO_OUTPUT
)
3908 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
3910 gfc_intrinsic_op realop
;
3912 if (op
== INTRINSIC_USER
|| !f2k
->tb_op
[op
])
3916 realop
= (gfc_intrinsic_op
) op
;
3917 mio_intrinsic_op (&realop
);
3918 mio_typebound_proc (&f2k
->tb_op
[op
]);
3923 while (peek_atom () != ATOM_RPAREN
)
3925 gfc_intrinsic_op op
= GFC_INTRINSIC_BEGIN
; /* Silence GCC. */
3928 mio_intrinsic_op (&op
);
3929 mio_typebound_proc (&f2k
->tb_op
[op
]);
3936 mio_full_f2k_derived (gfc_symbol
*sym
)
3940 if (iomode
== IO_OUTPUT
)
3942 if (sym
->f2k_derived
)
3943 mio_f2k_derived (sym
->f2k_derived
);
3947 if (peek_atom () != ATOM_RPAREN
)
3949 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
3950 mio_f2k_derived (sym
->f2k_derived
);
3953 gcc_assert (!sym
->f2k_derived
);
3959 static const mstring omp_declare_simd_clauses
[] =
3961 minit ("INBRANCH", 0),
3962 minit ("NOTINBRANCH", 1),
3963 minit ("SIMDLEN", 2),
3964 minit ("UNIFORM", 3),
3965 minit ("LINEAR", 4),
3966 minit ("ALIGNED", 5),
3970 /* Handle !$omp declare simd. */
3973 mio_omp_declare_simd (gfc_namespace
*ns
, gfc_omp_declare_simd
**odsp
)
3975 if (iomode
== IO_OUTPUT
)
3980 else if (peek_atom () != ATOM_LPAREN
)
3983 gfc_omp_declare_simd
*ods
= *odsp
;
3986 if (iomode
== IO_OUTPUT
)
3988 write_atom (ATOM_NAME
, "OMP_DECLARE_SIMD");
3991 gfc_omp_namelist
*n
;
3993 if (ods
->clauses
->inbranch
)
3994 mio_name (0, omp_declare_simd_clauses
);
3995 if (ods
->clauses
->notinbranch
)
3996 mio_name (1, omp_declare_simd_clauses
);
3997 if (ods
->clauses
->simdlen_expr
)
3999 mio_name (2, omp_declare_simd_clauses
);
4000 mio_expr (&ods
->clauses
->simdlen_expr
);
4002 for (n
= ods
->clauses
->lists
[OMP_LIST_UNIFORM
]; n
; n
= n
->next
)
4004 mio_name (3, omp_declare_simd_clauses
);
4005 mio_symbol_ref (&n
->sym
);
4007 for (n
= ods
->clauses
->lists
[OMP_LIST_LINEAR
]; n
; n
= n
->next
)
4009 mio_name (4, omp_declare_simd_clauses
);
4010 mio_symbol_ref (&n
->sym
);
4011 mio_expr (&n
->expr
);
4013 for (n
= ods
->clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
4015 mio_name (5, omp_declare_simd_clauses
);
4016 mio_symbol_ref (&n
->sym
);
4017 mio_expr (&n
->expr
);
4023 gfc_omp_namelist
**ptrs
[3] = { NULL
, NULL
, NULL
};
4025 require_atom (ATOM_NAME
);
4026 *odsp
= ods
= gfc_get_omp_declare_simd ();
4027 ods
->where
= gfc_current_locus
;
4028 ods
->proc_name
= ns
->proc_name
;
4029 if (peek_atom () == ATOM_NAME
)
4031 ods
->clauses
= gfc_get_omp_clauses ();
4032 ptrs
[0] = &ods
->clauses
->lists
[OMP_LIST_UNIFORM
];
4033 ptrs
[1] = &ods
->clauses
->lists
[OMP_LIST_LINEAR
];
4034 ptrs
[2] = &ods
->clauses
->lists
[OMP_LIST_ALIGNED
];
4036 while (peek_atom () == ATOM_NAME
)
4038 gfc_omp_namelist
*n
;
4039 int t
= mio_name (0, omp_declare_simd_clauses
);
4043 case 0: ods
->clauses
->inbranch
= true; break;
4044 case 1: ods
->clauses
->notinbranch
= true; break;
4045 case 2: mio_expr (&ods
->clauses
->simdlen_expr
); break;
4049 *ptrs
[t
- 3] = n
= gfc_get_omp_namelist ();
4050 ptrs
[t
- 3] = &n
->next
;
4051 mio_symbol_ref (&n
->sym
);
4053 mio_expr (&n
->expr
);
4059 mio_omp_declare_simd (ns
, &ods
->next
);
4065 static const mstring omp_declare_reduction_stmt
[] =
4067 minit ("ASSIGN", 0),
4074 mio_omp_udr_expr (gfc_omp_udr
*udr
, gfc_symbol
**sym1
, gfc_symbol
**sym2
,
4075 gfc_namespace
*ns
, bool is_initializer
)
4077 if (iomode
== IO_OUTPUT
)
4079 if ((*sym1
)->module
== NULL
)
4081 (*sym1
)->module
= module_name
;
4082 (*sym2
)->module
= module_name
;
4084 mio_symbol_ref (sym1
);
4085 mio_symbol_ref (sym2
);
4086 if (ns
->code
->op
== EXEC_ASSIGN
)
4088 mio_name (0, omp_declare_reduction_stmt
);
4089 mio_expr (&ns
->code
->expr1
);
4090 mio_expr (&ns
->code
->expr2
);
4095 mio_name (1, omp_declare_reduction_stmt
);
4096 mio_symtree_ref (&ns
->code
->symtree
);
4097 mio_actual_arglist (&ns
->code
->ext
.actual
);
4099 flag
= ns
->code
->resolved_isym
!= NULL
;
4100 mio_integer (&flag
);
4102 write_atom (ATOM_STRING
, ns
->code
->resolved_isym
->name
);
4104 mio_symbol_ref (&ns
->code
->resolved_sym
);
4109 pointer_info
*p1
= mio_symbol_ref (sym1
);
4110 pointer_info
*p2
= mio_symbol_ref (sym2
);
4112 gcc_assert (p1
->u
.rsym
.ns
== p2
->u
.rsym
.ns
);
4113 gcc_assert (p1
->u
.rsym
.sym
== NULL
);
4114 /* Add hidden symbols to the symtree. */
4115 pointer_info
*q
= get_integer (p1
->u
.rsym
.ns
);
4116 q
->u
.pointer
= (void *) ns
;
4117 sym
= gfc_new_symbol (is_initializer
? "omp_priv" : "omp_out", ns
);
4119 sym
->module
= gfc_get_string (p1
->u
.rsym
.module
);
4120 associate_integer_pointer (p1
, sym
);
4121 sym
->attr
.omp_udr_artificial_var
= 1;
4122 gcc_assert (p2
->u
.rsym
.sym
== NULL
);
4123 sym
= gfc_new_symbol (is_initializer
? "omp_orig" : "omp_in", ns
);
4125 sym
->module
= gfc_get_string (p2
->u
.rsym
.module
);
4126 associate_integer_pointer (p2
, sym
);
4127 sym
->attr
.omp_udr_artificial_var
= 1;
4128 if (mio_name (0, omp_declare_reduction_stmt
) == 0)
4130 ns
->code
= gfc_get_code (EXEC_ASSIGN
);
4131 mio_expr (&ns
->code
->expr1
);
4132 mio_expr (&ns
->code
->expr2
);
4137 ns
->code
= gfc_get_code (EXEC_CALL
);
4138 mio_symtree_ref (&ns
->code
->symtree
);
4139 mio_actual_arglist (&ns
->code
->ext
.actual
);
4141 mio_integer (&flag
);
4144 require_atom (ATOM_STRING
);
4145 ns
->code
->resolved_isym
= gfc_find_subroutine (atom_string
);
4149 mio_symbol_ref (&ns
->code
->resolved_sym
);
4151 ns
->code
->loc
= gfc_current_locus
;
4157 /* Unlike most other routines, the address of the symbol node is already
4158 fixed on input and the name/module has already been filled in.
4159 If you update the symbol format here, don't forget to update read_module
4160 as well (look for "seek to the symbol's component list"). */
4163 mio_symbol (gfc_symbol
*sym
)
4165 int intmod
= INTMOD_NONE
;
4169 mio_symbol_attribute (&sym
->attr
);
4171 /* Note that components are always saved, even if they are supposed
4172 to be private. Component access is checked during searching. */
4173 mio_component_list (&sym
->components
, sym
->attr
.vtype
);
4174 if (sym
->components
!= NULL
)
4175 sym
->component_access
4176 = MIO_NAME (gfc_access
) (sym
->component_access
, access_types
);
4178 mio_typespec (&sym
->ts
);
4179 if (sym
->ts
.type
== BT_CLASS
)
4180 sym
->attr
.class_ok
= 1;
4182 if (iomode
== IO_OUTPUT
)
4183 mio_namespace_ref (&sym
->formal_ns
);
4186 mio_namespace_ref (&sym
->formal_ns
);
4188 sym
->formal_ns
->proc_name
= sym
;
4191 /* Save/restore common block links. */
4192 mio_symbol_ref (&sym
->common_next
);
4194 mio_formal_arglist (&sym
->formal
);
4196 if (sym
->attr
.flavor
== FL_PARAMETER
)
4197 mio_expr (&sym
->value
);
4199 mio_array_spec (&sym
->as
);
4201 mio_symbol_ref (&sym
->result
);
4203 if (sym
->attr
.cray_pointee
)
4204 mio_symbol_ref (&sym
->cp_pointer
);
4206 /* Load/save the f2k_derived namespace of a derived-type symbol. */
4207 mio_full_f2k_derived (sym
);
4211 /* Add the fields that say whether this is from an intrinsic module,
4212 and if so, what symbol it is within the module. */
4213 /* mio_integer (&(sym->from_intmod)); */
4214 if (iomode
== IO_OUTPUT
)
4216 intmod
= sym
->from_intmod
;
4217 mio_integer (&intmod
);
4221 mio_integer (&intmod
);
4223 sym
->from_intmod
= current_intmod
;
4225 sym
->from_intmod
= (intmod_id
) intmod
;
4228 mio_integer (&(sym
->intmod_sym_id
));
4230 if (sym
->attr
.flavor
== FL_DERIVED
)
4231 mio_integer (&(sym
->hash_value
));
4234 && sym
->formal_ns
->proc_name
== sym
4235 && sym
->formal_ns
->entries
== NULL
)
4236 mio_omp_declare_simd (sym
->formal_ns
, &sym
->formal_ns
->omp_declare_simd
);
4242 /************************* Top level subroutines *************************/
4244 /* Given a root symtree node and a symbol, try to find a symtree that
4245 references the symbol that is not a unique name. */
4247 static gfc_symtree
*
4248 find_symtree_for_symbol (gfc_symtree
*st
, gfc_symbol
*sym
)
4250 gfc_symtree
*s
= NULL
;
4255 s
= find_symtree_for_symbol (st
->right
, sym
);
4258 s
= find_symtree_for_symbol (st
->left
, sym
);
4262 if (st
->n
.sym
== sym
&& !check_unique_name (st
->name
))
4269 /* A recursive function to look for a specific symbol by name and by
4270 module. Whilst several symtrees might point to one symbol, its
4271 is sufficient for the purposes here than one exist. Note that
4272 generic interfaces are distinguished as are symbols that have been
4273 renamed in another module. */
4274 static gfc_symtree
*
4275 find_symbol (gfc_symtree
*st
, const char *name
,
4276 const char *module
, int generic
)
4279 gfc_symtree
*retval
, *s
;
4281 if (st
== NULL
|| st
->n
.sym
== NULL
)
4284 c
= strcmp (name
, st
->n
.sym
->name
);
4285 if (c
== 0 && st
->n
.sym
->module
4286 && strcmp (module
, st
->n
.sym
->module
) == 0
4287 && !check_unique_name (st
->name
))
4289 s
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4291 /* Detect symbols that are renamed by use association in another
4292 module by the absence of a symtree and null attr.use_rename,
4293 since the latter is not transmitted in the module file. */
4294 if (((!generic
&& !st
->n
.sym
->attr
.generic
)
4295 || (generic
&& st
->n
.sym
->attr
.generic
))
4296 && !(s
== NULL
&& !st
->n
.sym
->attr
.use_rename
))
4300 retval
= find_symbol (st
->left
, name
, module
, generic
);
4303 retval
= find_symbol (st
->right
, name
, module
, generic
);
4309 /* Skip a list between balanced left and right parens.
4310 By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
4311 have been already parsed by hand, and the remaining of the content is to be
4312 skipped here. The default value is 0 (balanced parens). */
4315 skip_list (int nest_level
= 0)
4322 switch (parse_atom ())
4345 /* Load operator interfaces from the module. Interfaces are unusual
4346 in that they attach themselves to existing symbols. */
4349 load_operator_interfaces (void)
4352 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
4354 pointer_info
*pi
= NULL
;
4359 while (peek_atom () != ATOM_RPAREN
)
4363 mio_internal_string (name
);
4364 mio_internal_string (module
);
4366 n
= number_use_names (name
, true);
4369 for (i
= 1; i
<= n
; i
++)
4371 /* Decide if we need to load this one or not. */
4372 p
= find_use_name_n (name
, &i
, true);
4376 while (parse_atom () != ATOM_RPAREN
);
4382 uop
= gfc_get_uop (p
);
4383 pi
= mio_interface_rest (&uop
->op
);
4387 if (gfc_find_uop (p
, NULL
))
4389 uop
= gfc_get_uop (p
);
4390 uop
->op
= gfc_get_interface ();
4391 uop
->op
->where
= gfc_current_locus
;
4392 add_fixup (pi
->integer
, &uop
->op
->sym
);
4401 /* Load interfaces from the module. Interfaces are unusual in that
4402 they attach themselves to existing symbols. */
4405 load_generic_interfaces (void)
4408 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
4410 gfc_interface
*generic
= NULL
, *gen
= NULL
;
4412 bool ambiguous_set
= false;
4416 while (peek_atom () != ATOM_RPAREN
)
4420 mio_internal_string (name
);
4421 mio_internal_string (module
);
4423 n
= number_use_names (name
, false);
4424 renamed
= n
? 1 : 0;
4427 for (i
= 1; i
<= n
; i
++)
4430 /* Decide if we need to load this one or not. */
4431 p
= find_use_name_n (name
, &i
, false);
4433 st
= find_symbol (gfc_current_ns
->sym_root
,
4434 name
, module_name
, 1);
4436 if (!p
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
4438 /* Skip the specific names for these cases. */
4439 while (i
== 1 && parse_atom () != ATOM_RPAREN
);
4444 /* If the symbol exists already and is being USEd without being
4445 in an ONLY clause, do not load a new symtree(11.3.2). */
4446 if (!only_flag
&& st
)
4454 if (strcmp (st
->name
, p
) != 0)
4456 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4462 /* Since we haven't found a valid generic interface, we had
4466 gfc_get_symbol (p
, NULL
, &sym
);
4467 sym
->name
= gfc_get_string (name
);
4468 sym
->module
= module_name
;
4469 sym
->attr
.flavor
= FL_PROCEDURE
;
4470 sym
->attr
.generic
= 1;
4471 sym
->attr
.use_assoc
= 1;
4476 /* Unless sym is a generic interface, this reference
4479 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4483 if (st
&& !sym
->attr
.generic
4486 && strcmp (module
, sym
->module
))
4488 ambiguous_set
= true;
4493 sym
->attr
.use_only
= only_flag
;
4494 sym
->attr
.use_rename
= renamed
;
4498 mio_interface_rest (&sym
->generic
);
4499 generic
= sym
->generic
;
4501 else if (!sym
->generic
)
4503 sym
->generic
= generic
;
4504 sym
->attr
.generic_copy
= 1;
4507 /* If a procedure that is not generic has generic interfaces
4508 that include itself, it is generic! We need to take care
4509 to retain symbols ambiguous that were already so. */
4510 if (sym
->attr
.use_assoc
4511 && !sym
->attr
.generic
4512 && sym
->attr
.flavor
== FL_PROCEDURE
)
4514 for (gen
= generic
; gen
; gen
= gen
->next
)
4516 if (gen
->sym
== sym
)
4518 sym
->attr
.generic
= 1;
4533 /* Load common blocks. */
4538 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4543 while (peek_atom () != ATOM_RPAREN
)
4548 mio_internal_string (name
);
4550 p
= gfc_get_common (name
, 1);
4552 mio_symbol_ref (&p
->head
);
4553 mio_integer (&flags
);
4557 p
->threadprivate
= 1;
4560 /* Get whether this was a bind(c) common or not. */
4561 mio_integer (&p
->is_bind_c
);
4562 /* Get the binding label. */
4563 label
= read_string ();
4565 p
->binding_label
= IDENTIFIER_POINTER (get_identifier (label
));
4575 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4576 so that unused variables are not loaded and so that the expression can
4582 gfc_equiv
*head
, *tail
, *end
, *eq
, *equiv
;
4586 in_load_equiv
= true;
4588 end
= gfc_current_ns
->equiv
;
4589 while (end
!= NULL
&& end
->next
!= NULL
)
4592 while (peek_atom () != ATOM_RPAREN
) {
4596 while(peek_atom () != ATOM_RPAREN
)
4599 head
= tail
= gfc_get_equiv ();
4602 tail
->eq
= gfc_get_equiv ();
4606 mio_pool_string (&tail
->module
);
4607 mio_expr (&tail
->expr
);
4610 /* Check for duplicate equivalences being loaded from different modules */
4612 for (equiv
= gfc_current_ns
->equiv
; equiv
; equiv
= equiv
->next
)
4614 if (equiv
->module
&& head
->module
4615 && strcmp (equiv
->module
, head
->module
) == 0)
4624 for (eq
= head
; eq
; eq
= head
)
4627 gfc_free_expr (eq
->expr
);
4633 gfc_current_ns
->equiv
= head
;
4644 in_load_equiv
= false;
4648 /* This function loads OpenMP user defined reductions. */
4650 load_omp_udrs (void)
4653 while (peek_atom () != ATOM_RPAREN
)
4655 const char *name
, *newname
;
4659 gfc_omp_reduction_op rop
= OMP_REDUCTION_USER
;
4662 mio_pool_string (&name
);
4664 if (strncmp (name
, "operator ", sizeof ("operator ") - 1) == 0)
4666 const char *p
= name
+ sizeof ("operator ") - 1;
4667 if (strcmp (p
, "+") == 0)
4668 rop
= OMP_REDUCTION_PLUS
;
4669 else if (strcmp (p
, "*") == 0)
4670 rop
= OMP_REDUCTION_TIMES
;
4671 else if (strcmp (p
, "-") == 0)
4672 rop
= OMP_REDUCTION_MINUS
;
4673 else if (strcmp (p
, ".and.") == 0)
4674 rop
= OMP_REDUCTION_AND
;
4675 else if (strcmp (p
, ".or.") == 0)
4676 rop
= OMP_REDUCTION_OR
;
4677 else if (strcmp (p
, ".eqv.") == 0)
4678 rop
= OMP_REDUCTION_EQV
;
4679 else if (strcmp (p
, ".neqv.") == 0)
4680 rop
= OMP_REDUCTION_NEQV
;
4683 if (rop
== OMP_REDUCTION_USER
&& name
[0] == '.')
4685 size_t len
= strlen (name
+ 1);
4686 altname
= XALLOCAVEC (char, len
);
4687 gcc_assert (name
[len
] == '.');
4688 memcpy (altname
, name
+ 1, len
- 1);
4689 altname
[len
- 1] = '\0';
4692 if (rop
== OMP_REDUCTION_USER
)
4693 newname
= find_use_name (altname
? altname
: name
, !!altname
);
4694 else if (only_flag
&& find_use_operator ((gfc_intrinsic_op
) rop
) == NULL
)
4696 if (newname
== NULL
)
4701 if (altname
&& newname
!= altname
)
4703 size_t len
= strlen (newname
);
4704 altname
= XALLOCAVEC (char, len
+ 3);
4706 memcpy (altname
+ 1, newname
, len
);
4707 altname
[len
+ 1] = '.';
4708 altname
[len
+ 2] = '\0';
4709 name
= gfc_get_string (altname
);
4711 st
= gfc_find_symtree (gfc_current_ns
->omp_udr_root
, name
);
4712 gfc_omp_udr
*udr
= gfc_omp_udr_find (st
, &ts
);
4715 require_atom (ATOM_INTEGER
);
4716 pointer_info
*p
= get_integer (atom_int
);
4717 if (strcmp (p
->u
.rsym
.module
, udr
->omp_out
->module
))
4719 gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
4721 p
->u
.rsym
.module
, &gfc_current_locus
);
4722 gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
4724 udr
->omp_out
->module
, &udr
->where
);
4729 udr
= gfc_get_omp_udr ();
4733 udr
->where
= gfc_current_locus
;
4734 udr
->combiner_ns
= gfc_get_namespace (gfc_current_ns
, 1);
4735 udr
->combiner_ns
->proc_name
= gfc_current_ns
->proc_name
;
4736 mio_omp_udr_expr (udr
, &udr
->omp_out
, &udr
->omp_in
, udr
->combiner_ns
,
4738 if (peek_atom () != ATOM_RPAREN
)
4740 udr
->initializer_ns
= gfc_get_namespace (gfc_current_ns
, 1);
4741 udr
->initializer_ns
->proc_name
= gfc_current_ns
->proc_name
;
4742 mio_omp_udr_expr (udr
, &udr
->omp_priv
, &udr
->omp_orig
,
4743 udr
->initializer_ns
, true);
4747 udr
->next
= st
->n
.omp_udr
;
4748 st
->n
.omp_udr
= udr
;
4752 st
= gfc_new_symtree (&gfc_current_ns
->omp_udr_root
, name
);
4753 st
->n
.omp_udr
= udr
;
4761 /* Recursive function to traverse the pointer_info tree and load a
4762 needed symbol. We return nonzero if we load a symbol and stop the
4763 traversal, because the act of loading can alter the tree. */
4766 load_needed (pointer_info
*p
)
4777 rv
|= load_needed (p
->left
);
4778 rv
|= load_needed (p
->right
);
4780 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
4783 p
->u
.rsym
.state
= USED
;
4785 set_module_locus (&p
->u
.rsym
.where
);
4787 sym
= p
->u
.rsym
.sym
;
4790 q
= get_integer (p
->u
.rsym
.ns
);
4792 ns
= (gfc_namespace
*) q
->u
.pointer
;
4795 /* Create an interface namespace if necessary. These are
4796 the namespaces that hold the formal parameters of module
4799 ns
= gfc_get_namespace (NULL
, 0);
4800 associate_integer_pointer (q
, ns
);
4803 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
4804 doesn't go pear-shaped if the symbol is used. */
4806 gfc_find_symbol (p
->u
.rsym
.module
, gfc_current_ns
,
4809 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
4810 sym
->name
= dt_lower_string (p
->u
.rsym
.true_name
);
4811 sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
4812 if (p
->u
.rsym
.binding_label
)
4813 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier
4814 (p
->u
.rsym
.binding_label
));
4816 associate_integer_pointer (p
, sym
);
4820 sym
->attr
.use_assoc
= 1;
4822 /* Mark as only or rename for later diagnosis for explicitly imported
4823 but not used warnings; don't mark internal symbols such as __vtab,
4824 __def_init etc. Only mark them if they have been explicitly loaded. */
4826 if (only_flag
&& sym
->name
[0] != '_' && sym
->name
[1] != '_')
4830 /* Search the use/rename list for the variable; if the variable is
4832 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4834 if (strcmp (u
->use_name
, sym
->name
) == 0)
4836 sym
->attr
.use_only
= 1;
4842 if (p
->u
.rsym
.renamed
)
4843 sym
->attr
.use_rename
= 1;
4849 /* Recursive function for cleaning up things after a module has been read. */
4852 read_cleanup (pointer_info
*p
)
4860 read_cleanup (p
->left
);
4861 read_cleanup (p
->right
);
4863 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
4866 /* Add hidden symbols to the symtree. */
4867 q
= get_integer (p
->u
.rsym
.ns
);
4868 ns
= (gfc_namespace
*) q
->u
.pointer
;
4870 if (!p
->u
.rsym
.sym
->attr
.vtype
4871 && !p
->u
.rsym
.sym
->attr
.vtab
)
4872 st
= gfc_get_unique_symtree (ns
);
4875 /* There is no reason to use 'unique_symtrees' for vtabs or
4876 vtypes - their name is fine for a symtree and reduces the
4877 namespace pollution. */
4878 st
= gfc_find_symtree (ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4880 st
= gfc_new_symtree (&ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4883 st
->n
.sym
= p
->u
.rsym
.sym
;
4886 /* Fixup any symtree references. */
4887 p
->u
.rsym
.symtree
= st
;
4888 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
4889 p
->u
.rsym
.stfixup
= NULL
;
4892 /* Free unused symbols. */
4893 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
4894 gfc_free_symbol (p
->u
.rsym
.sym
);
4898 /* It is not quite enough to check for ambiguity in the symbols by
4899 the loaded symbol and the new symbol not being identical. */
4901 check_for_ambiguous (gfc_symtree
*st
, pointer_info
*info
)
4905 symbol_attribute attr
;
4908 if (gfc_current_ns
->proc_name
&& st
->name
== gfc_current_ns
->proc_name
->name
)
4910 gfc_error ("%qs of module %qs, imported at %C, is also the name of the "
4911 "current program unit", st
->name
, module_name
);
4916 rsym
= info
->u
.rsym
.sym
;
4920 if (st_sym
->attr
.vtab
|| st_sym
->attr
.vtype
)
4923 /* If the existing symbol is generic from a different module and
4924 the new symbol is generic there can be no ambiguity. */
4925 if (st_sym
->attr
.generic
4927 && st_sym
->module
!= module_name
)
4929 /* The new symbol's attributes have not yet been read. Since
4930 we need attr.generic, read it directly. */
4931 get_module_locus (&locus
);
4932 set_module_locus (&info
->u
.rsym
.where
);
4935 mio_symbol_attribute (&attr
);
4936 set_module_locus (&locus
);
4945 /* Read a module file. */
4950 module_locus operator_interfaces
, user_operators
, omp_udrs
;
4952 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4954 /* Workaround -Wmaybe-uninitialized false positive during
4955 profiledbootstrap by initializing them. */
4956 int ambiguous
= 0, j
, nuse
, symbol
= 0;
4957 pointer_info
*info
, *q
;
4958 gfc_use_rename
*u
= NULL
;
4962 get_module_locus (&operator_interfaces
); /* Skip these for now. */
4965 get_module_locus (&user_operators
);
4969 /* Skip commons and equivalences for now. */
4973 /* Skip OpenMP UDRs. */
4974 get_module_locus (&omp_udrs
);
4979 /* Create the fixup nodes for all the symbols. */
4981 while (peek_atom () != ATOM_RPAREN
)
4984 require_atom (ATOM_INTEGER
);
4985 info
= get_integer (atom_int
);
4987 info
->type
= P_SYMBOL
;
4988 info
->u
.rsym
.state
= UNUSED
;
4990 info
->u
.rsym
.true_name
= read_string ();
4991 info
->u
.rsym
.module
= read_string ();
4992 bind_label
= read_string ();
4993 if (strlen (bind_label
))
4994 info
->u
.rsym
.binding_label
= bind_label
;
4996 XDELETEVEC (bind_label
);
4998 require_atom (ATOM_INTEGER
);
4999 info
->u
.rsym
.ns
= atom_int
;
5001 get_module_locus (&info
->u
.rsym
.where
);
5003 /* See if the symbol has already been loaded by a previous module.
5004 If so, we reference the existing symbol and prevent it from
5005 being loaded again. This should not happen if the symbol being
5006 read is an index for an assumed shape dummy array (ns != 1). */
5008 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
5011 || (sym
->attr
.flavor
== FL_VARIABLE
&& info
->u
.rsym
.ns
!=1))
5017 info
->u
.rsym
.state
= USED
;
5018 info
->u
.rsym
.sym
= sym
;
5019 /* The current symbol has already been loaded, so we can avoid loading
5020 it again. However, if it is a derived type, some of its components
5021 can be used in expressions in the module. To avoid the module loading
5022 failing, we need to associate the module's component pointer indexes
5023 with the existing symbol's component pointers. */
5024 if (sym
->attr
.flavor
== FL_DERIVED
)
5028 /* First seek to the symbol's component list. */
5029 mio_lparen (); /* symbol opening. */
5030 skip_list (); /* skip symbol attribute. */
5032 mio_lparen (); /* component list opening. */
5033 for (c
= sym
->components
; c
; c
= c
->next
)
5036 const char *comp_name
;
5039 mio_lparen (); /* component opening. */
5041 p
= get_integer (n
);
5042 if (p
->u
.pointer
== NULL
)
5043 associate_integer_pointer (p
, c
);
5044 mio_pool_string (&comp_name
);
5045 gcc_assert (comp_name
== c
->name
);
5046 skip_list (1); /* component end. */
5048 mio_rparen (); /* component list closing. */
5050 skip_list (1); /* symbol end. */
5055 /* Some symbols do not have a namespace (eg. formal arguments),
5056 so the automatic "unique symtree" mechanism must be suppressed
5057 by marking them as referenced. */
5058 q
= get_integer (info
->u
.rsym
.ns
);
5059 if (q
->u
.pointer
== NULL
)
5061 info
->u
.rsym
.referenced
= 1;
5065 /* If possible recycle the symtree that references the symbol.
5066 If a symtree is not found and the module does not import one,
5067 a unique-name symtree is found by read_cleanup. */
5068 st
= find_symtree_for_symbol (gfc_current_ns
->sym_root
, sym
);
5071 info
->u
.rsym
.symtree
= st
;
5072 info
->u
.rsym
.referenced
= 1;
5078 /* Parse the symtree lists. This lets us mark which symbols need to
5079 be loaded. Renaming is also done at this point by replacing the
5084 while (peek_atom () != ATOM_RPAREN
)
5086 mio_internal_string (name
);
5087 mio_integer (&ambiguous
);
5088 mio_integer (&symbol
);
5090 info
= get_integer (symbol
);
5092 /* See how many use names there are. If none, go through the start
5093 of the loop at least once. */
5094 nuse
= number_use_names (name
, false);
5095 info
->u
.rsym
.renamed
= nuse
? 1 : 0;
5100 for (j
= 1; j
<= nuse
; j
++)
5102 /* Get the jth local name for this symbol. */
5103 p
= find_use_name_n (name
, &j
, false);
5105 if (p
== NULL
&& strcmp (name
, module_name
) == 0)
5108 /* Exception: Always import vtabs & vtypes. */
5109 if (p
== NULL
&& name
[0] == '_'
5110 && (strncmp (name
, "__vtab_", 5) == 0
5111 || strncmp (name
, "__vtype_", 6) == 0))
5114 /* Skip symtree nodes not in an ONLY clause, unless there
5115 is an existing symtree loaded from another USE statement. */
5118 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5120 && strcmp (st
->n
.sym
->name
, info
->u
.rsym
.true_name
) == 0
5121 && st
->n
.sym
->module
!= NULL
5122 && strcmp (st
->n
.sym
->module
, info
->u
.rsym
.module
) == 0)
5124 info
->u
.rsym
.symtree
= st
;
5125 info
->u
.rsym
.sym
= st
->n
.sym
;
5130 /* If a symbol of the same name and module exists already,
5131 this symbol, which is not in an ONLY clause, must not be
5132 added to the namespace(11.3.2). Note that find_symbol
5133 only returns the first occurrence that it finds. */
5134 if (!only_flag
&& !info
->u
.rsym
.renamed
5135 && strcmp (name
, module_name
) != 0
5136 && find_symbol (gfc_current_ns
->sym_root
, name
,
5140 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
5143 && !(st
->n
.sym
&& st
->n
.sym
->attr
.used_in_submodule
))
5145 /* Check for ambiguous symbols. */
5146 if (check_for_ambiguous (st
, info
))
5149 info
->u
.rsym
.symtree
= st
;
5155 /* This symbol is host associated from a module in a
5156 submodule. Hide it with a unique symtree. */
5157 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
5158 s
->n
.sym
= st
->n
.sym
;
5163 /* Create a symtree node in the current namespace for this
5165 st
= check_unique_name (p
)
5166 ? gfc_get_unique_symtree (gfc_current_ns
)
5167 : gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
5168 st
->ambiguous
= ambiguous
;
5171 sym
= info
->u
.rsym
.sym
;
5173 /* Create a symbol node if it doesn't already exist. */
5176 info
->u
.rsym
.sym
= gfc_new_symbol (info
->u
.rsym
.true_name
,
5178 info
->u
.rsym
.sym
->name
= dt_lower_string (info
->u
.rsym
.true_name
);
5179 sym
= info
->u
.rsym
.sym
;
5180 sym
->module
= gfc_get_string (info
->u
.rsym
.module
);
5182 if (info
->u
.rsym
.binding_label
)
5183 sym
->binding_label
=
5184 IDENTIFIER_POINTER (get_identifier
5185 (info
->u
.rsym
.binding_label
));
5191 if (strcmp (name
, p
) != 0)
5192 sym
->attr
.use_rename
= 1;
5195 || (strncmp (name
, "__vtab_", 5) != 0
5196 && strncmp (name
, "__vtype_", 6) != 0))
5197 sym
->attr
.use_only
= only_flag
;
5199 /* Store the symtree pointing to this symbol. */
5200 info
->u
.rsym
.symtree
= st
;
5202 if (info
->u
.rsym
.state
== UNUSED
)
5203 info
->u
.rsym
.state
= NEEDED
;
5204 info
->u
.rsym
.referenced
= 1;
5211 /* Load intrinsic operator interfaces. */
5212 set_module_locus (&operator_interfaces
);
5215 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5217 if (i
== INTRINSIC_USER
)
5222 u
= find_use_operator ((gfc_intrinsic_op
) i
);
5233 mio_interface (&gfc_current_ns
->op
[i
]);
5234 if (u
&& !gfc_current_ns
->op
[i
])
5240 /* Load generic and user operator interfaces. These must follow the
5241 loading of symtree because otherwise symbols can be marked as
5244 set_module_locus (&user_operators
);
5246 load_operator_interfaces ();
5247 load_generic_interfaces ();
5252 /* Load OpenMP user defined reductions. */
5253 set_module_locus (&omp_udrs
);
5256 /* At this point, we read those symbols that are needed but haven't
5257 been loaded yet. If one symbol requires another, the other gets
5258 marked as NEEDED if its previous state was UNUSED. */
5260 while (load_needed (pi_root
));
5262 /* Make sure all elements of the rename-list were found in the module. */
5264 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5269 if (u
->op
== INTRINSIC_NONE
)
5271 gfc_error ("Symbol %qs referenced at %L not found in module %qs",
5272 u
->use_name
, &u
->where
, module_name
);
5276 if (u
->op
== INTRINSIC_USER
)
5278 gfc_error ("User operator %qs referenced at %L not found "
5279 "in module %qs", u
->use_name
, &u
->where
, module_name
);
5283 gfc_error ("Intrinsic operator %qs referenced at %L not found "
5284 "in module %qs", gfc_op2string (u
->op
), &u
->where
,
5288 /* Clean up symbol nodes that were never loaded, create references
5289 to hidden symbols. */
5291 read_cleanup (pi_root
);
5295 /* Given an access type that is specific to an entity and the default
5296 access, return nonzero if the entity is publicly accessible. If the
5297 element is declared as PUBLIC, then it is public; if declared
5298 PRIVATE, then private, and otherwise it is public unless the default
5299 access in this context has been declared PRIVATE. */
5301 static bool dump_smod
= false;
5304 check_access (gfc_access specific_access
, gfc_access default_access
)
5309 if (specific_access
== ACCESS_PUBLIC
)
5311 if (specific_access
== ACCESS_PRIVATE
)
5314 if (flag_module_private
)
5315 return default_access
== ACCESS_PUBLIC
;
5317 return default_access
!= ACCESS_PRIVATE
;
5322 gfc_check_symbol_access (gfc_symbol
*sym
)
5324 if (sym
->attr
.vtab
|| sym
->attr
.vtype
)
5327 return check_access (sym
->attr
.access
, sym
->ns
->default_access
);
5331 /* A structure to remember which commons we've already written. */
5333 struct written_common
5335 BBT_HEADER(written_common
);
5336 const char *name
, *label
;
5339 static struct written_common
*written_commons
= NULL
;
5341 /* Comparison function used for balancing the binary tree. */
5344 compare_written_commons (void *a1
, void *b1
)
5346 const char *aname
= ((struct written_common
*) a1
)->name
;
5347 const char *alabel
= ((struct written_common
*) a1
)->label
;
5348 const char *bname
= ((struct written_common
*) b1
)->name
;
5349 const char *blabel
= ((struct written_common
*) b1
)->label
;
5350 int c
= strcmp (aname
, bname
);
5352 return (c
!= 0 ? c
: strcmp (alabel
, blabel
));
5355 /* Free a list of written commons. */
5358 free_written_common (struct written_common
*w
)
5364 free_written_common (w
->left
);
5366 free_written_common (w
->right
);
5371 /* Write a common block to the module -- recursive helper function. */
5374 write_common_0 (gfc_symtree
*st
, bool this_module
)
5380 struct written_common
*w
;
5381 bool write_me
= true;
5386 write_common_0 (st
->left
, this_module
);
5388 /* We will write out the binding label, or "" if no label given. */
5389 name
= st
->n
.common
->name
;
5391 label
= (p
->is_bind_c
&& p
->binding_label
) ? p
->binding_label
: "";
5393 /* Check if we've already output this common. */
5394 w
= written_commons
;
5397 int c
= strcmp (name
, w
->name
);
5398 c
= (c
!= 0 ? c
: strcmp (label
, w
->label
));
5402 w
= (c
< 0) ? w
->left
: w
->right
;
5405 if (this_module
&& p
->use_assoc
)
5410 /* Write the common to the module. */
5412 mio_pool_string (&name
);
5414 mio_symbol_ref (&p
->head
);
5415 flags
= p
->saved
? 1 : 0;
5416 if (p
->threadprivate
)
5418 mio_integer (&flags
);
5420 /* Write out whether the common block is bind(c) or not. */
5421 mio_integer (&(p
->is_bind_c
));
5423 mio_pool_string (&label
);
5426 /* Record that we have written this common. */
5427 w
= XCNEW (struct written_common
);
5430 gfc_insert_bbt (&written_commons
, w
, compare_written_commons
);
5433 write_common_0 (st
->right
, this_module
);
5437 /* Write a common, by initializing the list of written commons, calling
5438 the recursive function write_common_0() and cleaning up afterwards. */
5441 write_common (gfc_symtree
*st
)
5443 written_commons
= NULL
;
5444 write_common_0 (st
, true);
5445 write_common_0 (st
, false);
5446 free_written_common (written_commons
);
5447 written_commons
= NULL
;
5451 /* Write the blank common block to the module. */
5454 write_blank_common (void)
5456 const char * name
= BLANK_COMMON_NAME
;
5458 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
5459 this, but it hasn't been checked. Just making it so for now. */
5462 if (gfc_current_ns
->blank_common
.head
== NULL
)
5467 mio_pool_string (&name
);
5469 mio_symbol_ref (&gfc_current_ns
->blank_common
.head
);
5470 saved
= gfc_current_ns
->blank_common
.saved
;
5471 mio_integer (&saved
);
5473 /* Write out whether the common block is bind(c) or not. */
5474 mio_integer (&is_bind_c
);
5476 /* Write out an empty binding label. */
5477 write_atom (ATOM_STRING
, "");
5483 /* Write equivalences to the module. */
5492 for (eq
= gfc_current_ns
->equiv
; eq
; eq
= eq
->next
)
5496 for (e
= eq
; e
; e
= e
->eq
)
5498 if (e
->module
== NULL
)
5499 e
->module
= gfc_get_string ("%s.eq.%d", module_name
, num
);
5500 mio_allocated_string (e
->module
);
5501 mio_expr (&e
->expr
);
5510 /* Write a symbol to the module. */
5513 write_symbol (int n
, gfc_symbol
*sym
)
5517 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
5518 gfc_internal_error ("write_symbol(): bad module symbol %qs", sym
->name
);
5522 if (sym
->attr
.flavor
== FL_DERIVED
)
5525 name
= dt_upper_string (sym
->name
);
5526 mio_pool_string (&name
);
5529 mio_pool_string (&sym
->name
);
5531 mio_pool_string (&sym
->module
);
5532 if ((sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
) && sym
->binding_label
)
5534 label
= sym
->binding_label
;
5535 mio_pool_string (&label
);
5538 write_atom (ATOM_STRING
, "");
5540 mio_pointer_ref (&sym
->ns
);
5547 /* Recursive traversal function to write the initial set of symbols to
5548 the module. We check to see if the symbol should be written
5549 according to the access specification. */
5552 write_symbol0 (gfc_symtree
*st
)
5556 bool dont_write
= false;
5561 write_symbol0 (st
->left
);
5564 if (sym
->module
== NULL
)
5565 sym
->module
= module_name
;
5567 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5568 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
5571 if (!gfc_check_symbol_access (sym
))
5576 p
= get_pointer (sym
);
5577 if (p
->type
== P_UNKNOWN
)
5580 if (p
->u
.wsym
.state
!= WRITTEN
)
5582 write_symbol (p
->integer
, sym
);
5583 p
->u
.wsym
.state
= WRITTEN
;
5587 write_symbol0 (st
->right
);
5592 write_omp_udr (gfc_omp_udr
*udr
)
5596 case OMP_REDUCTION_USER
:
5597 /* Non-operators can't be used outside of the module. */
5598 if (udr
->name
[0] != '.')
5603 size_t len
= strlen (udr
->name
+ 1);
5604 char *name
= XALLOCAVEC (char, len
);
5605 memcpy (name
, udr
->name
, len
- 1);
5606 name
[len
- 1] = '\0';
5607 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
5608 /* If corresponding user operator is private, don't write
5612 gfc_user_op
*uop
= st
->n
.uop
;
5613 if (!check_access (uop
->access
, uop
->ns
->default_access
))
5618 case OMP_REDUCTION_PLUS
:
5619 case OMP_REDUCTION_MINUS
:
5620 case OMP_REDUCTION_TIMES
:
5621 case OMP_REDUCTION_AND
:
5622 case OMP_REDUCTION_OR
:
5623 case OMP_REDUCTION_EQV
:
5624 case OMP_REDUCTION_NEQV
:
5625 /* If corresponding operator is private, don't write the UDR. */
5626 if (!check_access (gfc_current_ns
->operator_access
[udr
->rop
],
5627 gfc_current_ns
->default_access
))
5633 if (udr
->ts
.type
== BT_DERIVED
|| udr
->ts
.type
== BT_CLASS
)
5635 /* If derived type is private, don't write the UDR. */
5636 if (!gfc_check_symbol_access (udr
->ts
.u
.derived
))
5641 mio_pool_string (&udr
->name
);
5642 mio_typespec (&udr
->ts
);
5643 mio_omp_udr_expr (udr
, &udr
->omp_out
, &udr
->omp_in
, udr
->combiner_ns
, false);
5644 if (udr
->initializer_ns
)
5645 mio_omp_udr_expr (udr
, &udr
->omp_priv
, &udr
->omp_orig
,
5646 udr
->initializer_ns
, true);
5652 write_omp_udrs (gfc_symtree
*st
)
5657 write_omp_udrs (st
->left
);
5659 for (udr
= st
->n
.omp_udr
; udr
; udr
= udr
->next
)
5660 write_omp_udr (udr
);
5661 write_omp_udrs (st
->right
);
5665 /* Type for the temporary tree used when writing secondary symbols. */
5667 struct sorted_pointer_info
5669 BBT_HEADER (sorted_pointer_info
);
5674 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
5676 /* Recursively traverse the temporary tree, free its contents. */
5679 free_sorted_pointer_info_tree (sorted_pointer_info
*p
)
5684 free_sorted_pointer_info_tree (p
->left
);
5685 free_sorted_pointer_info_tree (p
->right
);
5690 /* Comparison function for the temporary tree. */
5693 compare_sorted_pointer_info (void *_spi1
, void *_spi2
)
5695 sorted_pointer_info
*spi1
, *spi2
;
5696 spi1
= (sorted_pointer_info
*)_spi1
;
5697 spi2
= (sorted_pointer_info
*)_spi2
;
5699 if (spi1
->p
->integer
< spi2
->p
->integer
)
5701 if (spi1
->p
->integer
> spi2
->p
->integer
)
5707 /* Finds the symbols that need to be written and collects them in the
5708 sorted_pi tree so that they can be traversed in an order
5709 independent of memory addresses. */
5712 find_symbols_to_write(sorted_pointer_info
**tree
, pointer_info
*p
)
5717 if (p
->type
== P_SYMBOL
&& p
->u
.wsym
.state
== NEEDS_WRITE
)
5719 sorted_pointer_info
*sp
= gfc_get_sorted_pointer_info();
5722 gfc_insert_bbt (tree
, sp
, compare_sorted_pointer_info
);
5725 find_symbols_to_write (tree
, p
->left
);
5726 find_symbols_to_write (tree
, p
->right
);
5730 /* Recursive function that traverses the tree of symbols that need to be
5731 written and writes them in order. */
5734 write_symbol1_recursion (sorted_pointer_info
*sp
)
5739 write_symbol1_recursion (sp
->left
);
5741 pointer_info
*p1
= sp
->p
;
5742 gcc_assert (p1
->type
== P_SYMBOL
&& p1
->u
.wsym
.state
== NEEDS_WRITE
);
5744 p1
->u
.wsym
.state
= WRITTEN
;
5745 write_symbol (p1
->integer
, p1
->u
.wsym
.sym
);
5746 p1
->u
.wsym
.sym
->attr
.public_used
= 1;
5748 write_symbol1_recursion (sp
->right
);
5752 /* Write the secondary set of symbols to the module file. These are
5753 symbols that were not public yet are needed by the public symbols
5754 or another dependent symbol. The act of writing a symbol can add
5755 symbols to the pointer_info tree, so we return nonzero if a symbol
5756 was written and pass that information upwards. The caller will
5757 then call this function again until nothing was written. It uses
5758 the utility functions and a temporary tree to ensure a reproducible
5759 ordering of the symbol output and thus the module file. */
5762 write_symbol1 (pointer_info
*p
)
5767 /* Put symbols that need to be written into a tree sorted on the
5770 sorted_pointer_info
*spi_root
= NULL
;
5771 find_symbols_to_write (&spi_root
, p
);
5773 /* No symbols to write, return. */
5777 /* Otherwise, write and free the tree again. */
5778 write_symbol1_recursion (spi_root
);
5779 free_sorted_pointer_info_tree (spi_root
);
5785 /* Write operator interfaces associated with a symbol. */
5788 write_operator (gfc_user_op
*uop
)
5790 static char nullstring
[] = "";
5791 const char *p
= nullstring
;
5793 if (uop
->op
== NULL
|| !check_access (uop
->access
, uop
->ns
->default_access
))
5796 mio_symbol_interface (&uop
->name
, &p
, &uop
->op
);
5800 /* Write generic interfaces from the namespace sym_root. */
5803 write_generic (gfc_symtree
*st
)
5810 write_generic (st
->left
);
5813 if (sym
&& !check_unique_name (st
->name
)
5814 && sym
->generic
&& gfc_check_symbol_access (sym
))
5817 sym
->module
= module_name
;
5819 mio_symbol_interface (&st
->name
, &sym
->module
, &sym
->generic
);
5822 write_generic (st
->right
);
5827 write_symtree (gfc_symtree
*st
)
5834 /* A symbol in an interface body must not be visible in the
5836 if (sym
->ns
!= gfc_current_ns
5837 && sym
->ns
->proc_name
5838 && sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
5841 if (!gfc_check_symbol_access (sym
)
5842 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5843 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
5846 if (check_unique_name (st
->name
))
5849 p
= find_pointer (sym
);
5851 gfc_internal_error ("write_symtree(): Symbol not written");
5853 mio_pool_string (&st
->name
);
5854 mio_integer (&st
->ambiguous
);
5855 mio_integer (&p
->integer
);
5864 /* Write the operator interfaces. */
5867 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5869 if (i
== INTRINSIC_USER
)
5872 mio_interface (check_access (gfc_current_ns
->operator_access
[i
],
5873 gfc_current_ns
->default_access
)
5874 ? &gfc_current_ns
->op
[i
] : NULL
);
5882 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
5888 write_generic (gfc_current_ns
->sym_root
);
5894 write_blank_common ();
5895 write_common (gfc_current_ns
->common_root
);
5907 write_omp_udrs (gfc_current_ns
->omp_udr_root
);
5912 /* Write symbol information. First we traverse all symbols in the
5913 primary namespace, writing those that need to be written.
5914 Sometimes writing one symbol will cause another to need to be
5915 written. A list of these symbols ends up on the write stack, and
5916 we end by popping the bottom of the stack and writing the symbol
5917 until the stack is empty. */
5921 write_symbol0 (gfc_current_ns
->sym_root
);
5922 while (write_symbol1 (pi_root
))
5931 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
5936 /* Read a CRC32 sum from the gzip trailer of a module file. Returns
5937 true on success, false on failure. */
5940 read_crc32_from_module_file (const char* filename
, uLong
* crc
)
5946 /* Open the file in binary mode. */
5947 if ((file
= fopen (filename
, "rb")) == NULL
)
5950 /* The gzip crc32 value is found in the [END-8, END-4] bytes of the
5951 file. See RFC 1952. */
5952 if (fseek (file
, -8, SEEK_END
) != 0)
5958 /* Read the CRC32. */
5959 if (fread (buf
, 1, 4, file
) != 4)
5965 /* Close the file. */
5968 val
= (buf
[0] & 0xFF) + ((buf
[1] & 0xFF) << 8) + ((buf
[2] & 0xFF) << 16)
5969 + ((buf
[3] & 0xFF) << 24);
5972 /* For debugging, the CRC value printed in hexadecimal should match
5973 the CRC printed by "zcat -l -v filename".
5974 printf("CRC of file %s is %x\n", filename, val); */
5980 /* Given module, dump it to disk. If there was an error while
5981 processing the module, dump_flag will be set to zero and we delete
5982 the module file, even if it was already there. */
5985 dump_module (const char *name
, int dump_flag
)
5988 char *filename
, *filename_tmp
;
5991 module_name
= gfc_get_string (name
);
5995 name
= submodule_name
;
5996 n
= strlen (name
) + strlen (SUBMODULE_EXTENSION
) + 1;
5999 n
= strlen (name
) + strlen (MODULE_EXTENSION
) + 1;
6001 if (gfc_option
.module_dir
!= NULL
)
6003 n
+= strlen (gfc_option
.module_dir
);
6004 filename
= (char *) alloca (n
);
6005 strcpy (filename
, gfc_option
.module_dir
);
6006 strcat (filename
, name
);
6010 filename
= (char *) alloca (n
);
6011 strcpy (filename
, name
);
6015 strcat (filename
, SUBMODULE_EXTENSION
);
6017 strcat (filename
, MODULE_EXTENSION
);
6019 /* Name of the temporary file used to write the module. */
6020 filename_tmp
= (char *) alloca (n
+ 1);
6021 strcpy (filename_tmp
, filename
);
6022 strcat (filename_tmp
, "0");
6024 /* There was an error while processing the module. We delete the
6025 module file, even if it was already there. */
6032 if (gfc_cpp_makedep ())
6033 gfc_cpp_add_target (filename
);
6035 /* Write the module to the temporary file. */
6036 module_fp
= gzopen (filename_tmp
, "w");
6037 if (module_fp
== NULL
)
6038 gfc_fatal_error ("Can't open module file %qs for writing at %C: %s",
6039 filename_tmp
, xstrerror (errno
));
6041 gzprintf (module_fp
, "GFORTRAN module version '%s' created from %s\n",
6042 MOD_VERSION
, gfc_source_file
);
6044 /* Write the module itself. */
6051 free_pi_tree (pi_root
);
6056 if (gzclose (module_fp
))
6057 gfc_fatal_error ("Error writing module file %qs for writing: %s",
6058 filename_tmp
, xstrerror (errno
));
6060 /* Read the CRC32 from the gzip trailers of the module files and
6062 if (!read_crc32_from_module_file (filename_tmp
, &crc
)
6063 || !read_crc32_from_module_file (filename
, &crc_old
)
6066 /* Module file have changed, replace the old one. */
6067 if (remove (filename
) && errno
!= ENOENT
)
6068 gfc_fatal_error ("Can't delete module file %qs: %s", filename
,
6070 if (rename (filename_tmp
, filename
))
6071 gfc_fatal_error ("Can't rename module file %qs to %qs: %s",
6072 filename_tmp
, filename
, xstrerror (errno
));
6076 if (remove (filename_tmp
))
6077 gfc_fatal_error ("Can't delete temporary module file %qs: %s",
6078 filename_tmp
, xstrerror (errno
));
6084 gfc_dump_module (const char *name
, int dump_flag
)
6086 if (gfc_state_stack
->state
== COMP_SUBMODULE
)
6091 no_module_procedures
= true;
6092 dump_module (name
, dump_flag
);
6094 if (no_module_procedures
|| dump_smod
)
6097 /* Write a submodule file from a module. The 'dump_smod' flag switches
6098 off the check for PRIVATE entities. */
6100 submodule_name
= module_name
;
6101 dump_module (name
, dump_flag
);
6106 create_intrinsic_function (const char *name
, int id
,
6107 const char *modname
, intmod_id module
,
6108 bool subroutine
, gfc_symbol
*result_type
)
6110 gfc_intrinsic_sym
*isym
;
6111 gfc_symtree
*tmp_symtree
;
6114 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6117 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6119 gfc_error ("Symbol %qs already declared", name
);
6122 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6123 sym
= tmp_symtree
->n
.sym
;
6127 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
6128 isym
= gfc_intrinsic_subroutine_by_id (isym_id
);
6129 sym
->attr
.subroutine
= 1;
6133 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
6134 isym
= gfc_intrinsic_function_by_id (isym_id
);
6136 sym
->attr
.function
= 1;
6139 sym
->ts
.type
= BT_DERIVED
;
6140 sym
->ts
.u
.derived
= result_type
;
6141 sym
->ts
.is_c_interop
= 1;
6142 isym
->ts
.f90_type
= BT_VOID
;
6143 isym
->ts
.type
= BT_DERIVED
;
6144 isym
->ts
.f90_type
= BT_VOID
;
6145 isym
->ts
.u
.derived
= result_type
;
6146 isym
->ts
.is_c_interop
= 1;
6151 sym
->attr
.flavor
= FL_PROCEDURE
;
6152 sym
->attr
.intrinsic
= 1;
6154 sym
->module
= gfc_get_string (modname
);
6155 sym
->attr
.use_assoc
= 1;
6156 sym
->from_intmod
= module
;
6157 sym
->intmod_sym_id
= id
;
6161 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
6162 the current namespace for all named constants, pointer types, and
6163 procedures in the module unless the only clause was used or a rename
6164 list was provided. */
6167 import_iso_c_binding_module (void)
6169 gfc_symbol
*mod_sym
= NULL
, *return_type
;
6170 gfc_symtree
*mod_symtree
= NULL
, *tmp_symtree
;
6171 gfc_symtree
*c_ptr
= NULL
, *c_funptr
= NULL
;
6172 const char *iso_c_module_name
= "__iso_c_binding";
6175 bool want_c_ptr
= false, want_c_funptr
= false;
6177 /* Look only in the current namespace. */
6178 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, iso_c_module_name
);
6180 if (mod_symtree
== NULL
)
6182 /* symtree doesn't already exist in current namespace. */
6183 gfc_get_sym_tree (iso_c_module_name
, gfc_current_ns
, &mod_symtree
,
6186 if (mod_symtree
!= NULL
)
6187 mod_sym
= mod_symtree
->n
.sym
;
6189 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
6190 "create symbol for %s", iso_c_module_name
);
6192 mod_sym
->attr
.flavor
= FL_MODULE
;
6193 mod_sym
->attr
.intrinsic
= 1;
6194 mod_sym
->module
= gfc_get_string (iso_c_module_name
);
6195 mod_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
6198 /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
6199 check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
6201 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6203 if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_PTR
].name
,
6206 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_LOC
].name
,
6209 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_FUNPTR
].name
,
6211 want_c_funptr
= true;
6212 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNLOC
].name
,
6214 want_c_funptr
= true;
6215 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_PTR
].name
,
6218 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
6219 (iso_c_binding_symbol
)
6221 u
->local_name
[0] ? u
->local_name
6225 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNPTR
].name
,
6229 = generate_isocbinding_symbol (iso_c_module_name
,
6230 (iso_c_binding_symbol
)
6232 u
->local_name
[0] ? u
->local_name
6238 if ((want_c_ptr
|| !only_flag
) && !c_ptr
)
6239 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
6240 (iso_c_binding_symbol
)
6242 NULL
, NULL
, only_flag
);
6243 if ((want_c_funptr
|| !only_flag
) && !c_funptr
)
6244 c_funptr
= generate_isocbinding_symbol (iso_c_module_name
,
6245 (iso_c_binding_symbol
)
6247 NULL
, NULL
, only_flag
);
6249 /* Generate the symbols for the named constants representing
6250 the kinds for intrinsic data types. */
6251 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
6254 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6255 if (strcmp (c_interop_kinds_table
[i
].name
, u
->use_name
) == 0)
6264 #define NAMED_FUNCTION(a,b,c,d) \
6266 not_in_std = (gfc_option.allow_std & d) == 0; \
6269 #define NAMED_SUBROUTINE(a,b,c,d) \
6271 not_in_std = (gfc_option.allow_std & d) == 0; \
6274 #define NAMED_INTCST(a,b,c,d) \
6276 not_in_std = (gfc_option.allow_std & d) == 0; \
6279 #define NAMED_REALCST(a,b,c,d) \
6281 not_in_std = (gfc_option.allow_std & d) == 0; \
6284 #define NAMED_CMPXCST(a,b,c,d) \
6286 not_in_std = (gfc_option.allow_std & d) == 0; \
6289 #include "iso-c-binding.def"
6297 gfc_error ("The symbol %qs, referenced at %L, is not "
6298 "in the selected standard", name
, &u
->where
);
6304 #define NAMED_FUNCTION(a,b,c,d) \
6306 if (a == ISOCBINDING_LOC) \
6307 return_type = c_ptr->n.sym; \
6308 else if (a == ISOCBINDING_FUNLOC) \
6309 return_type = c_funptr->n.sym; \
6311 return_type = NULL; \
6312 create_intrinsic_function (u->local_name[0] \
6313 ? u->local_name : u->use_name, \
6314 a, iso_c_module_name, \
6315 INTMOD_ISO_C_BINDING, false, \
6318 #define NAMED_SUBROUTINE(a,b,c,d) \
6320 create_intrinsic_function (u->local_name[0] ? u->local_name \
6322 a, iso_c_module_name, \
6323 INTMOD_ISO_C_BINDING, true, NULL); \
6325 #include "iso-c-binding.def"
6327 case ISOCBINDING_PTR
:
6328 case ISOCBINDING_FUNPTR
:
6329 /* Already handled above. */
6332 if (i
== ISOCBINDING_NULL_PTR
)
6333 tmp_symtree
= c_ptr
;
6334 else if (i
== ISOCBINDING_NULL_FUNPTR
)
6335 tmp_symtree
= c_funptr
;
6338 generate_isocbinding_symbol (iso_c_module_name
,
6339 (iso_c_binding_symbol
) i
,
6341 ? u
->local_name
: u
->use_name
,
6342 tmp_symtree
, false);
6346 if (!found
&& !only_flag
)
6348 /* Skip, if the symbol is not in the enabled standard. */
6351 #define NAMED_FUNCTION(a,b,c,d) \
6353 if ((gfc_option.allow_std & d) == 0) \
6356 #define NAMED_SUBROUTINE(a,b,c,d) \
6358 if ((gfc_option.allow_std & d) == 0) \
6361 #define NAMED_INTCST(a,b,c,d) \
6363 if ((gfc_option.allow_std & d) == 0) \
6366 #define NAMED_REALCST(a,b,c,d) \
6368 if ((gfc_option.allow_std & d) == 0) \
6371 #define NAMED_CMPXCST(a,b,c,d) \
6373 if ((gfc_option.allow_std & d) == 0) \
6376 #include "iso-c-binding.def"
6378 ; /* Not GFC_STD_* versioned. */
6383 #define NAMED_FUNCTION(a,b,c,d) \
6385 if (a == ISOCBINDING_LOC) \
6386 return_type = c_ptr->n.sym; \
6387 else if (a == ISOCBINDING_FUNLOC) \
6388 return_type = c_funptr->n.sym; \
6390 return_type = NULL; \
6391 create_intrinsic_function (b, a, iso_c_module_name, \
6392 INTMOD_ISO_C_BINDING, false, \
6395 #define NAMED_SUBROUTINE(a,b,c,d) \
6397 create_intrinsic_function (b, a, iso_c_module_name, \
6398 INTMOD_ISO_C_BINDING, true, NULL); \
6400 #include "iso-c-binding.def"
6402 case ISOCBINDING_PTR
:
6403 case ISOCBINDING_FUNPTR
:
6404 /* Already handled above. */
6407 if (i
== ISOCBINDING_NULL_PTR
)
6408 tmp_symtree
= c_ptr
;
6409 else if (i
== ISOCBINDING_NULL_FUNPTR
)
6410 tmp_symtree
= c_funptr
;
6413 generate_isocbinding_symbol (iso_c_module_name
,
6414 (iso_c_binding_symbol
) i
, NULL
,
6415 tmp_symtree
, false);
6420 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6425 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6426 "module ISO_C_BINDING", u
->use_name
, &u
->where
);
6431 /* Add an integer named constant from a given module. */
6434 create_int_parameter (const char *name
, int value
, const char *modname
,
6435 intmod_id module
, int id
)
6437 gfc_symtree
*tmp_symtree
;
6440 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6441 if (tmp_symtree
!= NULL
)
6443 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6446 gfc_error ("Symbol %qs already declared", name
);
6449 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6450 sym
= tmp_symtree
->n
.sym
;
6452 sym
->module
= gfc_get_string (modname
);
6453 sym
->attr
.flavor
= FL_PARAMETER
;
6454 sym
->ts
.type
= BT_INTEGER
;
6455 sym
->ts
.kind
= gfc_default_integer_kind
;
6456 sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, value
);
6457 sym
->attr
.use_assoc
= 1;
6458 sym
->from_intmod
= module
;
6459 sym
->intmod_sym_id
= id
;
6463 /* Value is already contained by the array constructor, but not
6467 create_int_parameter_array (const char *name
, int size
, gfc_expr
*value
,
6468 const char *modname
, intmod_id module
, int id
)
6470 gfc_symtree
*tmp_symtree
;
6473 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6474 if (tmp_symtree
!= NULL
)
6476 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6479 gfc_error ("Symbol %qs already declared", name
);
6482 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6483 sym
= tmp_symtree
->n
.sym
;
6485 sym
->module
= gfc_get_string (modname
);
6486 sym
->attr
.flavor
= FL_PARAMETER
;
6487 sym
->ts
.type
= BT_INTEGER
;
6488 sym
->ts
.kind
= gfc_default_integer_kind
;
6489 sym
->attr
.use_assoc
= 1;
6490 sym
->from_intmod
= module
;
6491 sym
->intmod_sym_id
= id
;
6492 sym
->attr
.dimension
= 1;
6493 sym
->as
= gfc_get_array_spec ();
6495 sym
->as
->type
= AS_EXPLICIT
;
6496 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
6497 sym
->as
->upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, size
);
6500 sym
->value
->shape
= gfc_get_shape (1);
6501 mpz_init_set_ui (sym
->value
->shape
[0], size
);
6505 /* Add an derived type for a given module. */
6508 create_derived_type (const char *name
, const char *modname
,
6509 intmod_id module
, int id
)
6511 gfc_symtree
*tmp_symtree
;
6512 gfc_symbol
*sym
, *dt_sym
;
6513 gfc_interface
*intr
, *head
;
6515 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6516 if (tmp_symtree
!= NULL
)
6518 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6521 gfc_error ("Symbol %qs already declared", name
);
6524 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6525 sym
= tmp_symtree
->n
.sym
;
6526 sym
->module
= gfc_get_string (modname
);
6527 sym
->from_intmod
= module
;
6528 sym
->intmod_sym_id
= id
;
6529 sym
->attr
.flavor
= FL_PROCEDURE
;
6530 sym
->attr
.function
= 1;
6531 sym
->attr
.generic
= 1;
6533 gfc_get_sym_tree (dt_upper_string (sym
->name
),
6534 gfc_current_ns
, &tmp_symtree
, false);
6535 dt_sym
= tmp_symtree
->n
.sym
;
6536 dt_sym
->name
= gfc_get_string (sym
->name
);
6537 dt_sym
->attr
.flavor
= FL_DERIVED
;
6538 dt_sym
->attr
.private_comp
= 1;
6539 dt_sym
->attr
.zero_comp
= 1;
6540 dt_sym
->attr
.use_assoc
= 1;
6541 dt_sym
->module
= gfc_get_string (modname
);
6542 dt_sym
->from_intmod
= module
;
6543 dt_sym
->intmod_sym_id
= id
;
6545 head
= sym
->generic
;
6546 intr
= gfc_get_interface ();
6548 intr
->where
= gfc_current_locus
;
6550 sym
->generic
= intr
;
6551 sym
->attr
.if_source
= IFSRC_DECL
;
6555 /* Read the contents of the module file into a temporary buffer. */
6558 read_module_to_tmpbuf ()
6560 /* We don't know the uncompressed size, so enlarge the buffer as
6566 module_content
= XNEWVEC (char, cursz
);
6570 int nread
= gzread (module_fp
, module_content
+ len
, rsize
);
6575 module_content
= XRESIZEVEC (char, module_content
, cursz
);
6576 rsize
= cursz
- len
;
6579 module_content
= XRESIZEVEC (char, module_content
, len
+ 1);
6580 module_content
[len
] = '\0';
6586 /* USE the ISO_FORTRAN_ENV intrinsic module. */
6589 use_iso_fortran_env_module (void)
6591 static char mod
[] = "iso_fortran_env";
6593 gfc_symbol
*mod_sym
;
6594 gfc_symtree
*mod_symtree
;
6598 intmod_sym symbol
[] = {
6599 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
6600 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
6601 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
6602 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
6603 #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
6604 #include "iso-fortran-env.def"
6605 { ISOFORTRANENV_INVALID
, NULL
, -1234, 0 } };
6608 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
6609 #include "iso-fortran-env.def"
6611 /* Generate the symbol for the module itself. */
6612 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, mod
);
6613 if (mod_symtree
== NULL
)
6615 gfc_get_sym_tree (mod
, gfc_current_ns
, &mod_symtree
, false);
6616 gcc_assert (mod_symtree
);
6617 mod_sym
= mod_symtree
->n
.sym
;
6619 mod_sym
->attr
.flavor
= FL_MODULE
;
6620 mod_sym
->attr
.intrinsic
= 1;
6621 mod_sym
->module
= gfc_get_string (mod
);
6622 mod_sym
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
6625 if (!mod_symtree
->n
.sym
->attr
.intrinsic
)
6626 gfc_error ("Use of intrinsic module %qs at %C conflicts with "
6627 "non-intrinsic module name used previously", mod
);
6629 /* Generate the symbols for the module integer named constants. */
6631 for (i
= 0; symbol
[i
].name
; i
++)
6634 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6636 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
6641 if (!gfc_notify_std (symbol
[i
].standard
, "The symbol %qs, "
6642 "referenced at %L, is not in the selected "
6643 "standard", symbol
[i
].name
, &u
->where
))
6646 if ((flag_default_integer
|| flag_default_real
)
6647 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
6648 gfc_warning_now (0, "Use of the NUMERIC_STORAGE_SIZE named "
6649 "constant from intrinsic module "
6650 "ISO_FORTRAN_ENV at %L is incompatible with "
6651 "option %qs", &u
->where
,
6652 flag_default_integer
6653 ? "-fdefault-integer-8"
6654 : "-fdefault-real-8");
6655 switch (symbol
[i
].id
)
6657 #define NAMED_INTCST(a,b,c,d) \
6659 #include "iso-fortran-env.def"
6660 create_int_parameter (u
->local_name
[0] ? u
->local_name
6662 symbol
[i
].value
, mod
,
6663 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
6666 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6668 expr = gfc_get_array_expr (BT_INTEGER, \
6669 gfc_default_integer_kind,\
6671 for (j = 0; KINDS[j].kind != 0; j++) \
6672 gfc_constructor_append_expr (&expr->value.constructor, \
6673 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6674 KINDS[j].kind), NULL); \
6675 create_int_parameter_array (u->local_name[0] ? u->local_name \
6678 INTMOD_ISO_FORTRAN_ENV, \
6681 #include "iso-fortran-env.def"
6683 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6685 #include "iso-fortran-env.def"
6686 create_derived_type (u
->local_name
[0] ? u
->local_name
6688 mod
, INTMOD_ISO_FORTRAN_ENV
,
6692 #define NAMED_FUNCTION(a,b,c,d) \
6694 #include "iso-fortran-env.def"
6695 create_intrinsic_function (u
->local_name
[0] ? u
->local_name
6698 INTMOD_ISO_FORTRAN_ENV
, false,
6708 if (!found
&& !only_flag
)
6710 if ((gfc_option
.allow_std
& symbol
[i
].standard
) == 0)
6713 if ((flag_default_integer
|| flag_default_real
)
6714 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
6716 "Use of the NUMERIC_STORAGE_SIZE named constant "
6717 "from intrinsic module ISO_FORTRAN_ENV at %C is "
6718 "incompatible with option %s",
6719 flag_default_integer
6720 ? "-fdefault-integer-8" : "-fdefault-real-8");
6722 switch (symbol
[i
].id
)
6724 #define NAMED_INTCST(a,b,c,d) \
6726 #include "iso-fortran-env.def"
6727 create_int_parameter (symbol
[i
].name
, symbol
[i
].value
, mod
,
6728 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
6731 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6733 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
6735 for (j = 0; KINDS[j].kind != 0; j++) \
6736 gfc_constructor_append_expr (&expr->value.constructor, \
6737 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6738 KINDS[j].kind), NULL); \
6739 create_int_parameter_array (symbol[i].name, j, expr, mod, \
6740 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
6742 #include "iso-fortran-env.def"
6744 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6746 #include "iso-fortran-env.def"
6747 create_derived_type (symbol
[i
].name
, mod
, INTMOD_ISO_FORTRAN_ENV
,
6751 #define NAMED_FUNCTION(a,b,c,d) \
6753 #include "iso-fortran-env.def"
6754 create_intrinsic_function (symbol
[i
].name
, symbol
[i
].id
, mod
,
6755 INTMOD_ISO_FORTRAN_ENV
, false,
6765 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6770 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6771 "module ISO_FORTRAN_ENV", u
->use_name
, &u
->where
);
6776 /* Process a USE directive. */
6779 gfc_use_module (gfc_use_list
*module
)
6784 gfc_symtree
*mod_symtree
;
6785 gfc_use_list
*use_stmt
;
6786 locus old_locus
= gfc_current_locus
;
6788 gfc_current_locus
= module
->where
;
6789 module_name
= module
->module_name
;
6790 gfc_rename_list
= module
->rename
;
6791 only_flag
= module
->only_flag
;
6792 current_intmod
= INTMOD_NONE
;
6795 gfc_warning_now (OPT_Wuse_without_only
,
6796 "USE statement at %C has no ONLY qualifier");
6798 if (gfc_state_stack
->state
== COMP_MODULE
6799 || module
->submodule_name
== NULL
)
6801 filename
= XALLOCAVEC (char, strlen (module_name
)
6802 + strlen (MODULE_EXTENSION
) + 1);
6803 strcpy (filename
, module_name
);
6804 strcat (filename
, MODULE_EXTENSION
);
6808 filename
= XALLOCAVEC (char, strlen (module
->submodule_name
)
6809 + strlen (SUBMODULE_EXTENSION
) + 1);
6810 strcpy (filename
, module
->submodule_name
);
6811 strcat (filename
, SUBMODULE_EXTENSION
);
6814 /* First, try to find an non-intrinsic module, unless the USE statement
6815 specified that the module is intrinsic. */
6817 if (!module
->intrinsic
)
6818 module_fp
= gzopen_included_file (filename
, true, true);
6820 /* Then, see if it's an intrinsic one, unless the USE statement
6821 specified that the module is non-intrinsic. */
6822 if (module_fp
== NULL
&& !module
->non_intrinsic
)
6824 if (strcmp (module_name
, "iso_fortran_env") == 0
6825 && gfc_notify_std (GFC_STD_F2003
, "ISO_FORTRAN_ENV "
6826 "intrinsic module at %C"))
6828 use_iso_fortran_env_module ();
6829 free_rename (module
->rename
);
6830 module
->rename
= NULL
;
6831 gfc_current_locus
= old_locus
;
6832 module
->intrinsic
= true;
6836 if (strcmp (module_name
, "iso_c_binding") == 0
6837 && gfc_notify_std (GFC_STD_F2003
, "ISO_C_BINDING module at %C"))
6839 import_iso_c_binding_module();
6840 free_rename (module
->rename
);
6841 module
->rename
= NULL
;
6842 gfc_current_locus
= old_locus
;
6843 module
->intrinsic
= true;
6847 module_fp
= gzopen_intrinsic_module (filename
);
6849 if (module_fp
== NULL
&& module
->intrinsic
)
6850 gfc_fatal_error ("Can't find an intrinsic module named %qs at %C",
6853 /* Check for the IEEE modules, so we can mark their symbols
6854 accordingly when we read them. */
6855 if (strcmp (module_name
, "ieee_features") == 0
6856 && gfc_notify_std (GFC_STD_F2003
, "IEEE_FEATURES module at %C"))
6858 current_intmod
= INTMOD_IEEE_FEATURES
;
6860 else if (strcmp (module_name
, "ieee_exceptions") == 0
6861 && gfc_notify_std (GFC_STD_F2003
,
6862 "IEEE_EXCEPTIONS module at %C"))
6864 current_intmod
= INTMOD_IEEE_EXCEPTIONS
;
6866 else if (strcmp (module_name
, "ieee_arithmetic") == 0
6867 && gfc_notify_std (GFC_STD_F2003
,
6868 "IEEE_ARITHMETIC module at %C"))
6870 current_intmod
= INTMOD_IEEE_ARITHMETIC
;
6874 if (module_fp
== NULL
)
6875 gfc_fatal_error ("Can't open module file %qs for reading at %C: %s",
6876 filename
, xstrerror (errno
));
6878 /* Check that we haven't already USEd an intrinsic module with the
6881 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, module_name
);
6882 if (mod_symtree
&& mod_symtree
->n
.sym
->attr
.intrinsic
)
6883 gfc_error ("Use of non-intrinsic module %qs at %C conflicts with "
6884 "intrinsic module name used previously", module_name
);
6891 read_module_to_tmpbuf ();
6892 gzclose (module_fp
);
6894 /* Skip the first line of the module, after checking that this is
6895 a gfortran module file. */
6901 bad_module ("Unexpected end of module");
6904 if ((start
== 1 && strcmp (atom_name
, "GFORTRAN") != 0)
6905 || (start
== 2 && strcmp (atom_name
, " module") != 0))
6906 gfc_fatal_error ("File %qs opened at %C is not a GNU Fortran"
6907 " module file", filename
);
6910 if (strcmp (atom_name
, " version") != 0
6911 || module_char () != ' '
6912 || parse_atom () != ATOM_STRING
6913 || strcmp (atom_string
, MOD_VERSION
))
6914 gfc_fatal_error ("Cannot read module file %qs opened at %C,"
6915 " because it was created by a different"
6916 " version of GNU Fortran", filename
);
6925 /* Make sure we're not reading the same module that we may be building. */
6926 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
6927 if ((p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
)
6928 && strcmp (p
->sym
->name
, module_name
) == 0)
6929 gfc_fatal_error ("Can't USE the same %smodule we're building!",
6930 p
->state
== COMP_SUBMODULE
? "sub" : "");
6933 init_true_name_tree ();
6937 free_true_name (true_name_root
);
6938 true_name_root
= NULL
;
6940 free_pi_tree (pi_root
);
6943 XDELETEVEC (module_content
);
6944 module_content
= NULL
;
6946 use_stmt
= gfc_get_use_list ();
6947 *use_stmt
= *module
;
6948 use_stmt
->next
= gfc_current_ns
->use_stmts
;
6949 gfc_current_ns
->use_stmts
= use_stmt
;
6951 gfc_current_locus
= old_locus
;
6955 /* Remove duplicated intrinsic operators from the rename list. */
6958 rename_list_remove_duplicate (gfc_use_rename
*list
)
6960 gfc_use_rename
*seek
, *last
;
6962 for (; list
; list
= list
->next
)
6963 if (list
->op
!= INTRINSIC_USER
&& list
->op
!= INTRINSIC_NONE
)
6966 for (seek
= list
->next
; seek
; seek
= last
->next
)
6968 if (list
->op
== seek
->op
)
6970 last
->next
= seek
->next
;
6980 /* Process all USE directives. */
6983 gfc_use_modules (void)
6985 gfc_use_list
*next
, *seek
, *last
;
6987 for (next
= module_list
; next
; next
= next
->next
)
6989 bool non_intrinsic
= next
->non_intrinsic
;
6990 bool intrinsic
= next
->intrinsic
;
6991 bool neither
= !non_intrinsic
&& !intrinsic
;
6993 for (seek
= next
->next
; seek
; seek
= seek
->next
)
6995 if (next
->module_name
!= seek
->module_name
)
6998 if (seek
->non_intrinsic
)
6999 non_intrinsic
= true;
7000 else if (seek
->intrinsic
)
7006 if (intrinsic
&& neither
&& !non_intrinsic
)
7011 filename
= XALLOCAVEC (char,
7012 strlen (next
->module_name
)
7013 + strlen (MODULE_EXTENSION
) + 1);
7014 strcpy (filename
, next
->module_name
);
7015 strcat (filename
, MODULE_EXTENSION
);
7016 fp
= gfc_open_included_file (filename
, true, true);
7019 non_intrinsic
= true;
7025 for (seek
= next
->next
; seek
; seek
= last
->next
)
7027 if (next
->module_name
!= seek
->module_name
)
7033 if ((!next
->intrinsic
&& !seek
->intrinsic
)
7034 || (next
->intrinsic
&& seek
->intrinsic
)
7037 if (!seek
->only_flag
)
7038 next
->only_flag
= false;
7041 gfc_use_rename
*r
= seek
->rename
;
7044 r
->next
= next
->rename
;
7045 next
->rename
= seek
->rename
;
7047 last
->next
= seek
->next
;
7055 for (; module_list
; module_list
= next
)
7057 next
= module_list
->next
;
7058 rename_list_remove_duplicate (module_list
->rename
);
7059 gfc_use_module (module_list
);
7062 gfc_rename_list
= NULL
;
7067 gfc_free_use_stmts (gfc_use_list
*use_stmts
)
7070 for (; use_stmts
; use_stmts
= next
)
7072 gfc_use_rename
*next_rename
;
7074 for (; use_stmts
->rename
; use_stmts
->rename
= next_rename
)
7076 next_rename
= use_stmts
->rename
->next
;
7077 free (use_stmts
->rename
);
7079 next
= use_stmts
->next
;
7086 gfc_module_init_2 (void)
7088 last_atom
= ATOM_LPAREN
;
7089 gfc_rename_list
= NULL
;
7095 gfc_module_done_2 (void)
7097 free_rename (gfc_rename_list
);
7098 gfc_rename_list
= NULL
;