1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000-2017 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 gfc_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 gfc_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
;
743 bool seen_colon
= false;
745 if (!gfc_notify_std (GFC_STD_F2008
, "SUBMODULE declaration at %C"))
748 gfc_new_block
= NULL
;
749 gcc_assert (module_list
== NULL
);
751 if (gfc_match_char ('(') != MATCH_YES
)
756 m
= gfc_match (" %n", name
);
760 use_list
= gfc_get_use_list ();
761 use_list
->where
= gfc_current_locus
;
765 gfc_use_list
*last
= module_list
;
768 last
->next
= use_list
;
769 use_list
->module_name
770 = gfc_get_string ("%s.%s", module_list
->module_name
, name
);
771 use_list
->submodule_name
772 = gfc_get_string ("%s@%s", module_list
->module_name
, name
);
776 module_list
= use_list
;
777 use_list
->module_name
= gfc_get_string (name
);
778 use_list
->submodule_name
= use_list
->module_name
;
781 if (gfc_match_char (')') == MATCH_YES
)
784 if (gfc_match_char (':') != MATCH_YES
791 m
= gfc_match (" %s%t", &gfc_new_block
);
795 submodule_name
= gfc_get_string ("%s@%s", module_list
->module_name
,
796 gfc_new_block
->name
);
798 gfc_new_block
->name
= gfc_get_string ("%s.%s",
799 module_list
->module_name
,
800 gfc_new_block
->name
);
802 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
803 gfc_new_block
->name
, NULL
))
806 /* Just retain the ultimate .(s)mod file for reading, since it
807 contains all the information in its ancestors. */
808 use_list
= module_list
;
809 for (; module_list
->next
; use_list
= module_list
)
811 module_list
= use_list
->next
;
818 gfc_error ("Syntax error in SUBMODULE statement at %C");
823 /* Given a name and a number, inst, return the inst name
824 under which to load this symbol. Returns NULL if this
825 symbol shouldn't be loaded. If inst is zero, returns
826 the number of instances of this name. If interface is
827 true, a user-defined operator is sought, otherwise only
828 non-operators are sought. */
831 find_use_name_n (const char *name
, int *inst
, bool interface
)
834 const char *low_name
= NULL
;
837 /* For derived types. */
838 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
839 low_name
= gfc_dt_lower_string (name
);
842 for (u
= gfc_rename_list
; u
; u
= u
->next
)
844 if ((!low_name
&& strcmp (u
->use_name
, name
) != 0)
845 || (low_name
&& strcmp (u
->use_name
, low_name
) != 0)
846 || (u
->op
== INTRINSIC_USER
&& !interface
)
847 || (u
->op
!= INTRINSIC_USER
&& interface
))
860 return only_flag
? NULL
: name
;
866 if (u
->local_name
[0] == '\0')
868 return gfc_dt_upper_string (u
->local_name
);
871 return (u
->local_name
[0] != '\0') ? u
->local_name
: name
;
875 /* Given a name, return the name under which to load this symbol.
876 Returns NULL if this symbol shouldn't be loaded. */
879 find_use_name (const char *name
, bool interface
)
882 return find_use_name_n (name
, &i
, interface
);
886 /* Given a real name, return the number of use names associated with it. */
889 number_use_names (const char *name
, bool interface
)
892 find_use_name_n (name
, &i
, interface
);
897 /* Try to find the operator in the current list. */
899 static gfc_use_rename
*
900 find_use_operator (gfc_intrinsic_op op
)
904 for (u
= gfc_rename_list
; u
; u
= u
->next
)
912 /*****************************************************************/
914 /* The next couple of subroutines maintain a tree used to avoid a
915 brute-force search for a combination of true name and module name.
916 While symtree names, the name that a particular symbol is known by
917 can changed with USE statements, we still have to keep track of the
918 true names to generate the correct reference, and also avoid
919 loading the same real symbol twice in a program unit.
921 When we start reading, the true name tree is built and maintained
922 as symbols are read. The tree is searched as we load new symbols
923 to see if it already exists someplace in the namespace. */
925 typedef struct true_name
927 BBT_HEADER (true_name
);
933 static true_name
*true_name_root
;
936 /* Compare two true_name structures. */
939 compare_true_names (void *_t1
, void *_t2
)
944 t1
= (true_name
*) _t1
;
945 t2
= (true_name
*) _t2
;
947 c
= ((t1
->sym
->module
> t2
->sym
->module
)
948 - (t1
->sym
->module
< t2
->sym
->module
));
952 return strcmp (t1
->name
, t2
->name
);
956 /* Given a true name, search the true name tree to see if it exists
957 within the main namespace. */
960 find_true_name (const char *name
, const char *module
)
966 t
.name
= gfc_get_string (name
);
968 sym
.module
= gfc_get_string (module
);
976 c
= compare_true_names ((void *) (&t
), (void *) p
);
980 p
= (c
< 0) ? p
->left
: p
->right
;
987 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
990 add_true_name (gfc_symbol
*sym
)
994 t
= XCNEW (true_name
);
996 if (gfc_fl_struct (sym
->attr
.flavor
))
997 t
->name
= gfc_dt_upper_string (sym
->name
);
1001 gfc_insert_bbt (&true_name_root
, t
, compare_true_names
);
1005 /* Recursive function to build the initial true name tree by
1006 recursively traversing the current namespace. */
1009 build_tnt (gfc_symtree
*st
)
1015 build_tnt (st
->left
);
1016 build_tnt (st
->right
);
1018 if (gfc_fl_struct (st
->n
.sym
->attr
.flavor
))
1019 name
= gfc_dt_upper_string (st
->n
.sym
->name
);
1021 name
= st
->n
.sym
->name
;
1023 if (find_true_name (name
, st
->n
.sym
->module
) != NULL
)
1026 add_true_name (st
->n
.sym
);
1030 /* Initialize the true name tree with the current namespace. */
1033 init_true_name_tree (void)
1035 true_name_root
= NULL
;
1036 build_tnt (gfc_current_ns
->sym_root
);
1040 /* Recursively free a true name tree node. */
1043 free_true_name (true_name
*t
)
1047 free_true_name (t
->left
);
1048 free_true_name (t
->right
);
1054 /*****************************************************************/
1056 /* Module reading and writing. */
1058 /* The following are versions similar to the ones in scanner.c, but
1059 for dealing with compressed module files. */
1062 gzopen_included_file_1 (const char *name
, gfc_directorylist
*list
,
1063 bool module
, bool system
)
1066 gfc_directorylist
*p
;
1069 for (p
= list
; p
; p
= p
->next
)
1071 if (module
&& !p
->use_for_modules
)
1074 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 1);
1075 strcpy (fullname
, p
->path
);
1076 strcat (fullname
, name
);
1078 f
= gzopen (fullname
, "r");
1081 if (gfc_cpp_makedep ())
1082 gfc_cpp_add_dep (fullname
, system
);
1092 gzopen_included_file (const char *name
, bool include_cwd
, bool module
)
1096 if (IS_ABSOLUTE_PATH (name
) || include_cwd
)
1098 f
= gzopen (name
, "r");
1099 if (f
&& gfc_cpp_makedep ())
1100 gfc_cpp_add_dep (name
, false);
1104 f
= gzopen_included_file_1 (name
, include_dirs
, module
, false);
1110 gzopen_intrinsic_module (const char* name
)
1114 if (IS_ABSOLUTE_PATH (name
))
1116 f
= gzopen (name
, "r");
1117 if (f
&& gfc_cpp_makedep ())
1118 gfc_cpp_add_dep (name
, true);
1122 f
= gzopen_included_file_1 (name
, intrinsic_modules_dirs
, true, true);
1130 ATOM_NAME
, ATOM_LPAREN
, ATOM_RPAREN
, ATOM_INTEGER
, ATOM_STRING
1133 static atom_type last_atom
;
1136 /* The name buffer must be at least as long as a symbol name. Right
1137 now it's not clear how we're going to store numeric constants--
1138 probably as a hexadecimal string, since this will allow the exact
1139 number to be preserved (this can't be done by a decimal
1140 representation). Worry about that later. TODO! */
1142 #define MAX_ATOM_SIZE 100
1144 static HOST_WIDE_INT atom_int
;
1145 static char *atom_string
, atom_name
[MAX_ATOM_SIZE
];
1148 /* Report problems with a module. Error reporting is not very
1149 elaborate, since this sorts of errors shouldn't really happen.
1150 This subroutine never returns. */
1152 static void bad_module (const char *) ATTRIBUTE_NORETURN
;
1155 bad_module (const char *msgid
)
1157 XDELETEVEC (module_content
);
1158 module_content
= NULL
;
1163 gfc_fatal_error ("Reading module %qs at line %d column %d: %s",
1164 module_name
, module_line
, module_column
, msgid
);
1167 gfc_fatal_error ("Writing module %qs at line %d column %d: %s",
1168 module_name
, module_line
, module_column
, msgid
);
1171 gfc_fatal_error ("Module %qs at line %d column %d: %s",
1172 module_name
, module_line
, module_column
, msgid
);
1178 /* Set the module's input pointer. */
1181 set_module_locus (module_locus
*m
)
1183 module_column
= m
->column
;
1184 module_line
= m
->line
;
1185 module_pos
= m
->pos
;
1189 /* Get the module's input pointer so that we can restore it later. */
1192 get_module_locus (module_locus
*m
)
1194 m
->column
= module_column
;
1195 m
->line
= module_line
;
1196 m
->pos
= module_pos
;
1200 /* Get the next character in the module, updating our reckoning of
1206 const char c
= module_content
[module_pos
++];
1208 bad_module ("Unexpected EOF");
1210 prev_module_line
= module_line
;
1211 prev_module_column
= module_column
;
1223 /* Unget a character while remembering the line and column. Works for
1224 a single character only. */
1227 module_unget_char (void)
1229 module_line
= prev_module_line
;
1230 module_column
= prev_module_column
;
1234 /* Parse a string constant. The delimiter is guaranteed to be a
1244 atom_string
= XNEWVEC (char, cursz
);
1252 int c2
= module_char ();
1255 module_unget_char ();
1263 atom_string
= XRESIZEVEC (char, atom_string
, cursz
);
1265 atom_string
[len
] = c
;
1269 atom_string
= XRESIZEVEC (char, atom_string
, len
+ 1);
1270 atom_string
[len
] = '\0'; /* C-style string for debug purposes. */
1274 /* Parse an integer. Should fit in a HOST_WIDE_INT. */
1277 parse_integer (int c
)
1286 module_unget_char ();
1290 atom_int
= 10 * atom_int
+ c
- '0';
1312 if (!ISALNUM (c
) && c
!= '_' && c
!= '-')
1314 module_unget_char ();
1319 if (++len
> GFC_MAX_SYMBOL_LEN
)
1320 bad_module ("Name too long");
1328 /* Read the next atom in the module's input stream. */
1339 while (c
== ' ' || c
== '\r' || c
== '\n');
1364 return ATOM_INTEGER
;
1422 bad_module ("Bad name");
1429 /* Peek at the next atom on the input. */
1440 while (c
== ' ' || c
== '\r' || c
== '\n');
1445 module_unget_char ();
1449 module_unget_char ();
1453 module_unget_char ();
1466 module_unget_char ();
1467 return ATOM_INTEGER
;
1521 module_unget_char ();
1525 bad_module ("Bad name");
1530 /* Read the next atom from the input, requiring that it be a
1534 require_atom (atom_type type
)
1540 column
= module_column
;
1549 p
= _("Expected name");
1552 p
= _("Expected left parenthesis");
1555 p
= _("Expected right parenthesis");
1558 p
= _("Expected integer");
1561 p
= _("Expected string");
1564 gfc_internal_error ("require_atom(): bad atom type required");
1567 module_column
= column
;
1574 /* Given a pointer to an mstring array, require that the current input
1575 be one of the strings in the array. We return the enum value. */
1578 find_enum (const mstring
*m
)
1582 i
= gfc_string2code (m
, atom_name
);
1586 bad_module ("find_enum(): Enum not found");
1592 /* Read a string. The caller is responsible for freeing. */
1598 require_atom (ATOM_STRING
);
1605 /**************** Module output subroutines ***************************/
1607 /* Output a character to a module file. */
1610 write_char (char out
)
1612 if (gzputc (module_fp
, out
) == EOF
)
1613 gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno
));
1625 /* Write an atom to a module. The line wrapping isn't perfect, but it
1626 should work most of the time. This isn't that big of a deal, since
1627 the file really isn't meant to be read by people anyway. */
1630 write_atom (atom_type atom
, const void *v
)
1634 /* Workaround -Wmaybe-uninitialized false positive during
1635 profiledbootstrap by initializing them. */
1637 HOST_WIDE_INT i
= 0;
1644 p
= (const char *) v
;
1656 i
= *((const HOST_WIDE_INT
*) v
);
1658 snprintf (buffer
, sizeof (buffer
), HOST_WIDE_INT_PRINT_DEC
, i
);
1663 gfc_internal_error ("write_atom(): Trying to write dab atom");
1667 if(p
== NULL
|| *p
== '\0')
1672 if (atom
!= ATOM_RPAREN
)
1674 if (module_column
+ len
> 72)
1679 if (last_atom
!= ATOM_LPAREN
&& module_column
!= 1)
1684 if (atom
== ATOM_STRING
)
1687 while (p
!= NULL
&& *p
)
1689 if (atom
== ATOM_STRING
&& *p
== '\'')
1694 if (atom
== ATOM_STRING
)
1702 /***************** Mid-level I/O subroutines *****************/
1704 /* These subroutines let their caller read or write atoms without
1705 caring about which of the two is actually happening. This lets a
1706 subroutine concentrate on the actual format of the data being
1709 static void mio_expr (gfc_expr
**);
1710 pointer_info
*mio_symbol_ref (gfc_symbol
**);
1711 pointer_info
*mio_interface_rest (gfc_interface
**);
1712 static void mio_symtree_ref (gfc_symtree
**);
1714 /* Read or write an enumerated value. On writing, we return the input
1715 value for the convenience of callers. We avoid using an integer
1716 pointer because enums are sometimes inside bitfields. */
1719 mio_name (int t
, const mstring
*m
)
1721 if (iomode
== IO_OUTPUT
)
1722 write_atom (ATOM_NAME
, gfc_code2string (m
, t
));
1725 require_atom (ATOM_NAME
);
1732 /* Specialization of mio_name. */
1734 #define DECL_MIO_NAME(TYPE) \
1735 static inline TYPE \
1736 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1738 return (TYPE) mio_name ((int) t, m); \
1740 #define MIO_NAME(TYPE) mio_name_##TYPE
1745 if (iomode
== IO_OUTPUT
)
1746 write_atom (ATOM_LPAREN
, NULL
);
1748 require_atom (ATOM_LPAREN
);
1755 if (iomode
== IO_OUTPUT
)
1756 write_atom (ATOM_RPAREN
, NULL
);
1758 require_atom (ATOM_RPAREN
);
1763 mio_integer (int *ip
)
1765 if (iomode
== IO_OUTPUT
)
1767 HOST_WIDE_INT hwi
= *ip
;
1768 write_atom (ATOM_INTEGER
, &hwi
);
1772 require_atom (ATOM_INTEGER
);
1778 mio_hwi (HOST_WIDE_INT
*hwi
)
1780 if (iomode
== IO_OUTPUT
)
1781 write_atom (ATOM_INTEGER
, hwi
);
1784 require_atom (ATOM_INTEGER
);
1790 /* Read or write a gfc_intrinsic_op value. */
1793 mio_intrinsic_op (gfc_intrinsic_op
* op
)
1795 /* FIXME: Would be nicer to do this via the operators symbolic name. */
1796 if (iomode
== IO_OUTPUT
)
1798 HOST_WIDE_INT converted
= (HOST_WIDE_INT
) *op
;
1799 write_atom (ATOM_INTEGER
, &converted
);
1803 require_atom (ATOM_INTEGER
);
1804 *op
= (gfc_intrinsic_op
) atom_int
;
1809 /* Read or write a character pointer that points to a string on the heap. */
1812 mio_allocated_string (const char *s
)
1814 if (iomode
== IO_OUTPUT
)
1816 write_atom (ATOM_STRING
, s
);
1821 require_atom (ATOM_STRING
);
1827 /* Functions for quoting and unquoting strings. */
1830 quote_string (const gfc_char_t
*s
, const size_t slength
)
1832 const gfc_char_t
*p
;
1836 /* Calculate the length we'll need: a backslash takes two ("\\"),
1837 non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */
1838 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1842 else if (!gfc_wide_is_printable (*p
))
1848 q
= res
= XCNEWVEC (char, len
+ 1);
1849 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1852 *q
++ = '\\', *q
++ = '\\';
1853 else if (!gfc_wide_is_printable (*p
))
1855 sprintf (q
, "\\U%08" HOST_WIDE_INT_PRINT
"x",
1856 (unsigned HOST_WIDE_INT
) *p
);
1860 *q
++ = (unsigned char) *p
;
1868 unquote_string (const char *s
)
1874 for (p
= s
, len
= 0; *p
; p
++, len
++)
1881 else if (p
[1] == 'U')
1882 p
+= 9; /* That is a "\U????????". */
1884 gfc_internal_error ("unquote_string(): got bad string");
1887 res
= gfc_get_wide_string (len
+ 1);
1888 for (i
= 0, p
= s
; i
< len
; i
++, p
++)
1893 res
[i
] = (unsigned char) *p
;
1894 else if (p
[1] == '\\')
1896 res
[i
] = (unsigned char) '\\';
1901 /* We read the 8-digits hexadecimal constant that follows. */
1906 gcc_assert (p
[1] == 'U');
1907 for (j
= 0; j
< 8; j
++)
1910 gcc_assert (sscanf (&p
[j
+2], "%01x", &n
) == 1);
1924 /* Read or write a character pointer that points to a wide string on the
1925 heap, performing quoting/unquoting of nonprintable characters using the
1926 form \U???????? (where each ? is a hexadecimal digit).
1927 Length is the length of the string, only known and used in output mode. */
1929 static const gfc_char_t
*
1930 mio_allocated_wide_string (const gfc_char_t
*s
, const size_t length
)
1932 if (iomode
== IO_OUTPUT
)
1934 char *quoted
= quote_string (s
, length
);
1935 write_atom (ATOM_STRING
, quoted
);
1941 gfc_char_t
*unquoted
;
1943 require_atom (ATOM_STRING
);
1944 unquoted
= unquote_string (atom_string
);
1951 /* Read or write a string that is in static memory. */
1954 mio_pool_string (const char **stringp
)
1956 /* TODO: one could write the string only once, and refer to it via a
1959 /* As a special case we have to deal with a NULL string. This
1960 happens for the 'module' member of 'gfc_symbol's that are not in a
1961 module. We read / write these as the empty string. */
1962 if (iomode
== IO_OUTPUT
)
1964 const char *p
= *stringp
== NULL
? "" : *stringp
;
1965 write_atom (ATOM_STRING
, p
);
1969 require_atom (ATOM_STRING
);
1970 *stringp
= atom_string
[0] == '\0' ? NULL
: gfc_get_string (atom_string
);
1976 /* Read or write a string that is inside of some already-allocated
1980 mio_internal_string (char *string
)
1982 if (iomode
== IO_OUTPUT
)
1983 write_atom (ATOM_STRING
, string
);
1986 require_atom (ATOM_STRING
);
1987 strcpy (string
, atom_string
);
1994 { AB_ALLOCATABLE
, AB_DIMENSION
, AB_EXTERNAL
, AB_INTRINSIC
, AB_OPTIONAL
,
1995 AB_POINTER
, AB_TARGET
, AB_DUMMY
, AB_RESULT
, AB_DATA
,
1996 AB_IN_NAMELIST
, AB_IN_COMMON
, AB_FUNCTION
, AB_SUBROUTINE
, AB_SEQUENCE
,
1997 AB_ELEMENTAL
, AB_PURE
, AB_RECURSIVE
, AB_GENERIC
, AB_ALWAYS_EXPLICIT
,
1998 AB_CRAY_POINTER
, AB_CRAY_POINTEE
, AB_THREADPRIVATE
,
1999 AB_ALLOC_COMP
, AB_POINTER_COMP
, AB_PROC_POINTER_COMP
, AB_PRIVATE_COMP
,
2000 AB_VALUE
, AB_VOLATILE
, AB_PROTECTED
, AB_LOCK_COMP
, AB_EVENT_COMP
,
2001 AB_IS_BIND_C
, AB_IS_C_INTEROP
, AB_IS_ISO_C
, AB_ABSTRACT
, AB_ZERO_COMP
,
2002 AB_IS_CLASS
, AB_PROCEDURE
, AB_PROC_POINTER
, AB_ASYNCHRONOUS
, AB_CODIMENSION
,
2003 AB_COARRAY_COMP
, AB_VTYPE
, AB_VTAB
, AB_CONTIGUOUS
, AB_CLASS_POINTER
,
2004 AB_IMPLICIT_PURE
, AB_ARTIFICIAL
, AB_UNLIMITED_POLY
, AB_OMP_DECLARE_TARGET
,
2005 AB_ARRAY_OUTER_DEPENDENCY
, AB_MODULE_PROCEDURE
, AB_OACC_DECLARE_CREATE
,
2006 AB_OACC_DECLARE_COPYIN
, AB_OACC_DECLARE_DEVICEPTR
,
2007 AB_OACC_DECLARE_DEVICE_RESIDENT
, AB_OACC_DECLARE_LINK
,
2008 AB_OMP_DECLARE_TARGET_LINK
2011 static const mstring attr_bits
[] =
2013 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
2014 minit ("ARTIFICIAL", AB_ARTIFICIAL
),
2015 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS
),
2016 minit ("DIMENSION", AB_DIMENSION
),
2017 minit ("CODIMENSION", AB_CODIMENSION
),
2018 minit ("CONTIGUOUS", AB_CONTIGUOUS
),
2019 minit ("EXTERNAL", AB_EXTERNAL
),
2020 minit ("INTRINSIC", AB_INTRINSIC
),
2021 minit ("OPTIONAL", AB_OPTIONAL
),
2022 minit ("POINTER", AB_POINTER
),
2023 minit ("VOLATILE", AB_VOLATILE
),
2024 minit ("TARGET", AB_TARGET
),
2025 minit ("THREADPRIVATE", AB_THREADPRIVATE
),
2026 minit ("DUMMY", AB_DUMMY
),
2027 minit ("RESULT", AB_RESULT
),
2028 minit ("DATA", AB_DATA
),
2029 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
2030 minit ("IN_COMMON", AB_IN_COMMON
),
2031 minit ("FUNCTION", AB_FUNCTION
),
2032 minit ("SUBROUTINE", AB_SUBROUTINE
),
2033 minit ("SEQUENCE", AB_SEQUENCE
),
2034 minit ("ELEMENTAL", AB_ELEMENTAL
),
2035 minit ("PURE", AB_PURE
),
2036 minit ("RECURSIVE", AB_RECURSIVE
),
2037 minit ("GENERIC", AB_GENERIC
),
2038 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
2039 minit ("CRAY_POINTER", AB_CRAY_POINTER
),
2040 minit ("CRAY_POINTEE", AB_CRAY_POINTEE
),
2041 minit ("IS_BIND_C", AB_IS_BIND_C
),
2042 minit ("IS_C_INTEROP", AB_IS_C_INTEROP
),
2043 minit ("IS_ISO_C", AB_IS_ISO_C
),
2044 minit ("VALUE", AB_VALUE
),
2045 minit ("ALLOC_COMP", AB_ALLOC_COMP
),
2046 minit ("COARRAY_COMP", AB_COARRAY_COMP
),
2047 minit ("LOCK_COMP", AB_LOCK_COMP
),
2048 minit ("EVENT_COMP", AB_EVENT_COMP
),
2049 minit ("POINTER_COMP", AB_POINTER_COMP
),
2050 minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP
),
2051 minit ("PRIVATE_COMP", AB_PRIVATE_COMP
),
2052 minit ("ZERO_COMP", AB_ZERO_COMP
),
2053 minit ("PROTECTED", AB_PROTECTED
),
2054 minit ("ABSTRACT", AB_ABSTRACT
),
2055 minit ("IS_CLASS", AB_IS_CLASS
),
2056 minit ("PROCEDURE", AB_PROCEDURE
),
2057 minit ("PROC_POINTER", AB_PROC_POINTER
),
2058 minit ("VTYPE", AB_VTYPE
),
2059 minit ("VTAB", AB_VTAB
),
2060 minit ("CLASS_POINTER", AB_CLASS_POINTER
),
2061 minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE
),
2062 minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY
),
2063 minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET
),
2064 minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY
),
2065 minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE
),
2066 minit ("OACC_DECLARE_CREATE", AB_OACC_DECLARE_CREATE
),
2067 minit ("OACC_DECLARE_COPYIN", AB_OACC_DECLARE_COPYIN
),
2068 minit ("OACC_DECLARE_DEVICEPTR", AB_OACC_DECLARE_DEVICEPTR
),
2069 minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT
),
2070 minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK
),
2071 minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK
),
2075 /* For binding attributes. */
2076 static const mstring binding_passing
[] =
2079 minit ("NOPASS", 1),
2082 static const mstring binding_overriding
[] =
2084 minit ("OVERRIDABLE", 0),
2085 minit ("NON_OVERRIDABLE", 1),
2086 minit ("DEFERRED", 2),
2089 static const mstring binding_generic
[] =
2091 minit ("SPECIFIC", 0),
2092 minit ("GENERIC", 1),
2095 static const mstring binding_ppc
[] =
2097 minit ("NO_PPC", 0),
2102 /* Specialization of mio_name. */
2103 DECL_MIO_NAME (ab_attribute
)
2104 DECL_MIO_NAME (ar_type
)
2105 DECL_MIO_NAME (array_type
)
2107 DECL_MIO_NAME (expr_t
)
2108 DECL_MIO_NAME (gfc_access
)
2109 DECL_MIO_NAME (gfc_intrinsic_op
)
2110 DECL_MIO_NAME (ifsrc
)
2111 DECL_MIO_NAME (save_state
)
2112 DECL_MIO_NAME (procedure_type
)
2113 DECL_MIO_NAME (ref_type
)
2114 DECL_MIO_NAME (sym_flavor
)
2115 DECL_MIO_NAME (sym_intent
)
2116 #undef DECL_MIO_NAME
2118 /* Symbol attributes are stored in list with the first three elements
2119 being the enumerated fields, while the remaining elements (if any)
2120 indicate the individual attribute bits. The access field is not
2121 saved-- it controls what symbols are exported when a module is
2125 mio_symbol_attribute (symbol_attribute
*attr
)
2128 unsigned ext_attr
,extension_level
;
2132 attr
->flavor
= MIO_NAME (sym_flavor
) (attr
->flavor
, flavors
);
2133 attr
->intent
= MIO_NAME (sym_intent
) (attr
->intent
, intents
);
2134 attr
->proc
= MIO_NAME (procedure_type
) (attr
->proc
, procedures
);
2135 attr
->if_source
= MIO_NAME (ifsrc
) (attr
->if_source
, ifsrc_types
);
2136 attr
->save
= MIO_NAME (save_state
) (attr
->save
, save_status
);
2138 ext_attr
= attr
->ext_attr
;
2139 mio_integer ((int *) &ext_attr
);
2140 attr
->ext_attr
= ext_attr
;
2142 extension_level
= attr
->extension
;
2143 mio_integer ((int *) &extension_level
);
2144 attr
->extension
= extension_level
;
2146 if (iomode
== IO_OUTPUT
)
2148 if (attr
->allocatable
)
2149 MIO_NAME (ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
2150 if (attr
->artificial
)
2151 MIO_NAME (ab_attribute
) (AB_ARTIFICIAL
, attr_bits
);
2152 if (attr
->asynchronous
)
2153 MIO_NAME (ab_attribute
) (AB_ASYNCHRONOUS
, attr_bits
);
2154 if (attr
->dimension
)
2155 MIO_NAME (ab_attribute
) (AB_DIMENSION
, attr_bits
);
2156 if (attr
->codimension
)
2157 MIO_NAME (ab_attribute
) (AB_CODIMENSION
, attr_bits
);
2158 if (attr
->contiguous
)
2159 MIO_NAME (ab_attribute
) (AB_CONTIGUOUS
, attr_bits
);
2161 MIO_NAME (ab_attribute
) (AB_EXTERNAL
, attr_bits
);
2162 if (attr
->intrinsic
)
2163 MIO_NAME (ab_attribute
) (AB_INTRINSIC
, attr_bits
);
2165 MIO_NAME (ab_attribute
) (AB_OPTIONAL
, attr_bits
);
2167 MIO_NAME (ab_attribute
) (AB_POINTER
, attr_bits
);
2168 if (attr
->class_pointer
)
2169 MIO_NAME (ab_attribute
) (AB_CLASS_POINTER
, attr_bits
);
2170 if (attr
->is_protected
)
2171 MIO_NAME (ab_attribute
) (AB_PROTECTED
, attr_bits
);
2173 MIO_NAME (ab_attribute
) (AB_VALUE
, attr_bits
);
2174 if (attr
->volatile_
)
2175 MIO_NAME (ab_attribute
) (AB_VOLATILE
, attr_bits
);
2177 MIO_NAME (ab_attribute
) (AB_TARGET
, attr_bits
);
2178 if (attr
->threadprivate
)
2179 MIO_NAME (ab_attribute
) (AB_THREADPRIVATE
, attr_bits
);
2181 MIO_NAME (ab_attribute
) (AB_DUMMY
, attr_bits
);
2183 MIO_NAME (ab_attribute
) (AB_RESULT
, attr_bits
);
2184 /* We deliberately don't preserve the "entry" flag. */
2187 MIO_NAME (ab_attribute
) (AB_DATA
, attr_bits
);
2188 if (attr
->in_namelist
)
2189 MIO_NAME (ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
2190 if (attr
->in_common
)
2191 MIO_NAME (ab_attribute
) (AB_IN_COMMON
, attr_bits
);
2194 MIO_NAME (ab_attribute
) (AB_FUNCTION
, attr_bits
);
2195 if (attr
->subroutine
)
2196 MIO_NAME (ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
2198 MIO_NAME (ab_attribute
) (AB_GENERIC
, attr_bits
);
2200 MIO_NAME (ab_attribute
) (AB_ABSTRACT
, attr_bits
);
2203 MIO_NAME (ab_attribute
) (AB_SEQUENCE
, attr_bits
);
2204 if (attr
->elemental
)
2205 MIO_NAME (ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
2207 MIO_NAME (ab_attribute
) (AB_PURE
, attr_bits
);
2208 if (attr
->implicit_pure
)
2209 MIO_NAME (ab_attribute
) (AB_IMPLICIT_PURE
, attr_bits
);
2210 if (attr
->unlimited_polymorphic
)
2211 MIO_NAME (ab_attribute
) (AB_UNLIMITED_POLY
, attr_bits
);
2212 if (attr
->recursive
)
2213 MIO_NAME (ab_attribute
) (AB_RECURSIVE
, attr_bits
);
2214 if (attr
->always_explicit
)
2215 MIO_NAME (ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
2216 if (attr
->cray_pointer
)
2217 MIO_NAME (ab_attribute
) (AB_CRAY_POINTER
, attr_bits
);
2218 if (attr
->cray_pointee
)
2219 MIO_NAME (ab_attribute
) (AB_CRAY_POINTEE
, attr_bits
);
2220 if (attr
->is_bind_c
)
2221 MIO_NAME(ab_attribute
) (AB_IS_BIND_C
, attr_bits
);
2222 if (attr
->is_c_interop
)
2223 MIO_NAME(ab_attribute
) (AB_IS_C_INTEROP
, attr_bits
);
2225 MIO_NAME(ab_attribute
) (AB_IS_ISO_C
, attr_bits
);
2226 if (attr
->alloc_comp
)
2227 MIO_NAME (ab_attribute
) (AB_ALLOC_COMP
, attr_bits
);
2228 if (attr
->pointer_comp
)
2229 MIO_NAME (ab_attribute
) (AB_POINTER_COMP
, attr_bits
);
2230 if (attr
->proc_pointer_comp
)
2231 MIO_NAME (ab_attribute
) (AB_PROC_POINTER_COMP
, attr_bits
);
2232 if (attr
->private_comp
)
2233 MIO_NAME (ab_attribute
) (AB_PRIVATE_COMP
, attr_bits
);
2234 if (attr
->coarray_comp
)
2235 MIO_NAME (ab_attribute
) (AB_COARRAY_COMP
, attr_bits
);
2236 if (attr
->lock_comp
)
2237 MIO_NAME (ab_attribute
) (AB_LOCK_COMP
, attr_bits
);
2238 if (attr
->event_comp
)
2239 MIO_NAME (ab_attribute
) (AB_EVENT_COMP
, attr_bits
);
2240 if (attr
->zero_comp
)
2241 MIO_NAME (ab_attribute
) (AB_ZERO_COMP
, attr_bits
);
2243 MIO_NAME (ab_attribute
) (AB_IS_CLASS
, attr_bits
);
2244 if (attr
->procedure
)
2245 MIO_NAME (ab_attribute
) (AB_PROCEDURE
, attr_bits
);
2246 if (attr
->proc_pointer
)
2247 MIO_NAME (ab_attribute
) (AB_PROC_POINTER
, attr_bits
);
2249 MIO_NAME (ab_attribute
) (AB_VTYPE
, attr_bits
);
2251 MIO_NAME (ab_attribute
) (AB_VTAB
, attr_bits
);
2252 if (attr
->omp_declare_target
)
2253 MIO_NAME (ab_attribute
) (AB_OMP_DECLARE_TARGET
, attr_bits
);
2254 if (attr
->array_outer_dependency
)
2255 MIO_NAME (ab_attribute
) (AB_ARRAY_OUTER_DEPENDENCY
, attr_bits
);
2256 if (attr
->module_procedure
)
2258 MIO_NAME (ab_attribute
) (AB_MODULE_PROCEDURE
, attr_bits
);
2259 no_module_procedures
= false;
2261 if (attr
->oacc_declare_create
)
2262 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_CREATE
, attr_bits
);
2263 if (attr
->oacc_declare_copyin
)
2264 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_COPYIN
, attr_bits
);
2265 if (attr
->oacc_declare_deviceptr
)
2266 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_DEVICEPTR
, attr_bits
);
2267 if (attr
->oacc_declare_device_resident
)
2268 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_DEVICE_RESIDENT
, attr_bits
);
2269 if (attr
->oacc_declare_link
)
2270 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_LINK
, attr_bits
);
2271 if (attr
->omp_declare_target_link
)
2272 MIO_NAME (ab_attribute
) (AB_OMP_DECLARE_TARGET_LINK
, attr_bits
);
2282 if (t
== ATOM_RPAREN
)
2285 bad_module ("Expected attribute bit name");
2287 switch ((ab_attribute
) find_enum (attr_bits
))
2289 case AB_ALLOCATABLE
:
2290 attr
->allocatable
= 1;
2293 attr
->artificial
= 1;
2295 case AB_ASYNCHRONOUS
:
2296 attr
->asynchronous
= 1;
2299 attr
->dimension
= 1;
2301 case AB_CODIMENSION
:
2302 attr
->codimension
= 1;
2305 attr
->contiguous
= 1;
2311 attr
->intrinsic
= 1;
2319 case AB_CLASS_POINTER
:
2320 attr
->class_pointer
= 1;
2323 attr
->is_protected
= 1;
2329 attr
->volatile_
= 1;
2334 case AB_THREADPRIVATE
:
2335 attr
->threadprivate
= 1;
2346 case AB_IN_NAMELIST
:
2347 attr
->in_namelist
= 1;
2350 attr
->in_common
= 1;
2356 attr
->subroutine
= 1;
2368 attr
->elemental
= 1;
2373 case AB_IMPLICIT_PURE
:
2374 attr
->implicit_pure
= 1;
2376 case AB_UNLIMITED_POLY
:
2377 attr
->unlimited_polymorphic
= 1;
2380 attr
->recursive
= 1;
2382 case AB_ALWAYS_EXPLICIT
:
2383 attr
->always_explicit
= 1;
2385 case AB_CRAY_POINTER
:
2386 attr
->cray_pointer
= 1;
2388 case AB_CRAY_POINTEE
:
2389 attr
->cray_pointee
= 1;
2392 attr
->is_bind_c
= 1;
2394 case AB_IS_C_INTEROP
:
2395 attr
->is_c_interop
= 1;
2401 attr
->alloc_comp
= 1;
2403 case AB_COARRAY_COMP
:
2404 attr
->coarray_comp
= 1;
2407 attr
->lock_comp
= 1;
2410 attr
->event_comp
= 1;
2412 case AB_POINTER_COMP
:
2413 attr
->pointer_comp
= 1;
2415 case AB_PROC_POINTER_COMP
:
2416 attr
->proc_pointer_comp
= 1;
2418 case AB_PRIVATE_COMP
:
2419 attr
->private_comp
= 1;
2422 attr
->zero_comp
= 1;
2428 attr
->procedure
= 1;
2430 case AB_PROC_POINTER
:
2431 attr
->proc_pointer
= 1;
2439 case AB_OMP_DECLARE_TARGET
:
2440 attr
->omp_declare_target
= 1;
2442 case AB_OMP_DECLARE_TARGET_LINK
:
2443 attr
->omp_declare_target_link
= 1;
2445 case AB_ARRAY_OUTER_DEPENDENCY
:
2446 attr
->array_outer_dependency
=1;
2448 case AB_MODULE_PROCEDURE
:
2449 attr
->module_procedure
=1;
2451 case AB_OACC_DECLARE_CREATE
:
2452 attr
->oacc_declare_create
= 1;
2454 case AB_OACC_DECLARE_COPYIN
:
2455 attr
->oacc_declare_copyin
= 1;
2457 case AB_OACC_DECLARE_DEVICEPTR
:
2458 attr
->oacc_declare_deviceptr
= 1;
2460 case AB_OACC_DECLARE_DEVICE_RESIDENT
:
2461 attr
->oacc_declare_device_resident
= 1;
2463 case AB_OACC_DECLARE_LINK
:
2464 attr
->oacc_declare_link
= 1;
2472 static const mstring bt_types
[] = {
2473 minit ("INTEGER", BT_INTEGER
),
2474 minit ("REAL", BT_REAL
),
2475 minit ("COMPLEX", BT_COMPLEX
),
2476 minit ("LOGICAL", BT_LOGICAL
),
2477 minit ("CHARACTER", BT_CHARACTER
),
2478 minit ("UNION", BT_UNION
),
2479 minit ("DERIVED", BT_DERIVED
),
2480 minit ("CLASS", BT_CLASS
),
2481 minit ("PROCEDURE", BT_PROCEDURE
),
2482 minit ("UNKNOWN", BT_UNKNOWN
),
2483 minit ("VOID", BT_VOID
),
2484 minit ("ASSUMED", BT_ASSUMED
),
2490 mio_charlen (gfc_charlen
**clp
)
2496 if (iomode
== IO_OUTPUT
)
2500 mio_expr (&cl
->length
);
2504 if (peek_atom () != ATOM_RPAREN
)
2506 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2507 mio_expr (&cl
->length
);
2516 /* See if a name is a generated name. */
2519 check_unique_name (const char *name
)
2521 return *name
== '@';
2526 mio_typespec (gfc_typespec
*ts
)
2530 ts
->type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2532 if (!gfc_bt_struct (ts
->type
) && ts
->type
!= BT_CLASS
)
2533 mio_integer (&ts
->kind
);
2535 mio_symbol_ref (&ts
->u
.derived
);
2537 mio_symbol_ref (&ts
->interface
);
2539 /* Add info for C interop and is_iso_c. */
2540 mio_integer (&ts
->is_c_interop
);
2541 mio_integer (&ts
->is_iso_c
);
2543 /* If the typespec is for an identifier either from iso_c_binding, or
2544 a constant that was initialized to an identifier from it, use the
2545 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2547 ts
->f90_type
= MIO_NAME (bt
) (ts
->f90_type
, bt_types
);
2549 ts
->f90_type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2551 if (ts
->type
!= BT_CHARACTER
)
2553 /* ts->u.cl is only valid for BT_CHARACTER. */
2558 mio_charlen (&ts
->u
.cl
);
2560 /* So as not to disturb the existing API, use an ATOM_NAME to
2561 transmit deferred characteristic for characters (F2003). */
2562 if (iomode
== IO_OUTPUT
)
2564 if (ts
->type
== BT_CHARACTER
&& ts
->deferred
)
2565 write_atom (ATOM_NAME
, "DEFERRED_CL");
2567 else if (peek_atom () != ATOM_RPAREN
)
2569 if (parse_atom () != ATOM_NAME
)
2570 bad_module ("Expected string");
2578 static const mstring array_spec_types
[] = {
2579 minit ("EXPLICIT", AS_EXPLICIT
),
2580 minit ("ASSUMED_RANK", AS_ASSUMED_RANK
),
2581 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
2582 minit ("DEFERRED", AS_DEFERRED
),
2583 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
2589 mio_array_spec (gfc_array_spec
**asp
)
2596 if (iomode
== IO_OUTPUT
)
2604 /* mio_integer expects nonnegative values. */
2605 rank
= as
->rank
> 0 ? as
->rank
: 0;
2606 mio_integer (&rank
);
2610 if (peek_atom () == ATOM_RPAREN
)
2616 *asp
= as
= gfc_get_array_spec ();
2617 mio_integer (&as
->rank
);
2620 mio_integer (&as
->corank
);
2621 as
->type
= MIO_NAME (array_type
) (as
->type
, array_spec_types
);
2623 if (iomode
== IO_INPUT
&& as
->type
== AS_ASSUMED_RANK
)
2625 if (iomode
== IO_INPUT
&& as
->corank
)
2626 as
->cotype
= (as
->type
== AS_DEFERRED
) ? AS_DEFERRED
: AS_EXPLICIT
;
2628 if (as
->rank
+ as
->corank
> 0)
2629 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
2631 mio_expr (&as
->lower
[i
]);
2632 mio_expr (&as
->upper
[i
]);
2640 /* Given a pointer to an array reference structure (which lives in a
2641 gfc_ref structure), find the corresponding array specification
2642 structure. Storing the pointer in the ref structure doesn't quite
2643 work when loading from a module. Generating code for an array
2644 reference also needs more information than just the array spec. */
2646 static const mstring array_ref_types
[] = {
2647 minit ("FULL", AR_FULL
),
2648 minit ("ELEMENT", AR_ELEMENT
),
2649 minit ("SECTION", AR_SECTION
),
2655 mio_array_ref (gfc_array_ref
*ar
)
2660 ar
->type
= MIO_NAME (ar_type
) (ar
->type
, array_ref_types
);
2661 mio_integer (&ar
->dimen
);
2669 for (i
= 0; i
< ar
->dimen
; i
++)
2670 mio_expr (&ar
->start
[i
]);
2675 for (i
= 0; i
< ar
->dimen
; i
++)
2677 mio_expr (&ar
->start
[i
]);
2678 mio_expr (&ar
->end
[i
]);
2679 mio_expr (&ar
->stride
[i
]);
2685 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2688 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2689 we can't call mio_integer directly. Instead loop over each element
2690 and cast it to/from an integer. */
2691 if (iomode
== IO_OUTPUT
)
2693 for (i
= 0; i
< ar
->dimen
; i
++)
2695 HOST_WIDE_INT tmp
= (HOST_WIDE_INT
)ar
->dimen_type
[i
];
2696 write_atom (ATOM_INTEGER
, &tmp
);
2701 for (i
= 0; i
< ar
->dimen
; i
++)
2703 require_atom (ATOM_INTEGER
);
2704 ar
->dimen_type
[i
] = (enum gfc_array_ref_dimen_type
) atom_int
;
2708 if (iomode
== IO_INPUT
)
2710 ar
->where
= gfc_current_locus
;
2712 for (i
= 0; i
< ar
->dimen
; i
++)
2713 ar
->c_where
[i
] = gfc_current_locus
;
2720 /* Saves or restores a pointer. The pointer is converted back and
2721 forth from an integer. We return the pointer_info pointer so that
2722 the caller can take additional action based on the pointer type. */
2724 static pointer_info
*
2725 mio_pointer_ref (void *gp
)
2729 if (iomode
== IO_OUTPUT
)
2731 p
= get_pointer (*((char **) gp
));
2732 write_atom (ATOM_INTEGER
, &p
->integer
);
2736 require_atom (ATOM_INTEGER
);
2737 p
= add_fixup (atom_int
, gp
);
2744 /* Save and load references to components that occur within
2745 expressions. We have to describe these references by a number and
2746 by name. The number is necessary for forward references during
2747 reading, and the name is necessary if the symbol already exists in
2748 the namespace and is not loaded again. */
2751 mio_component_ref (gfc_component
**cp
)
2755 p
= mio_pointer_ref (cp
);
2756 if (p
->type
== P_UNKNOWN
)
2757 p
->type
= P_COMPONENT
;
2761 static void mio_namespace_ref (gfc_namespace
**nsp
);
2762 static void mio_formal_arglist (gfc_formal_arglist
**formal
);
2763 static void mio_typebound_proc (gfc_typebound_proc
** proc
);
2766 mio_component (gfc_component
*c
, int vtype
)
2773 if (iomode
== IO_OUTPUT
)
2775 p
= get_pointer (c
);
2776 mio_integer (&p
->integer
);
2781 p
= get_integer (n
);
2782 associate_integer_pointer (p
, c
);
2785 if (p
->type
== P_UNKNOWN
)
2786 p
->type
= P_COMPONENT
;
2788 mio_pool_string (&c
->name
);
2789 mio_typespec (&c
->ts
);
2790 mio_array_spec (&c
->as
);
2792 mio_symbol_attribute (&c
->attr
);
2793 if (c
->ts
.type
== BT_CLASS
)
2794 c
->attr
.class_ok
= 1;
2795 c
->attr
.access
= MIO_NAME (gfc_access
) (c
->attr
.access
, access_types
);
2797 if (!vtype
|| strcmp (c
->name
, "_final") == 0
2798 || strcmp (c
->name
, "_hash") == 0)
2799 mio_expr (&c
->initializer
);
2801 if (c
->attr
.proc_pointer
)
2802 mio_typebound_proc (&c
->tb
);
2809 mio_component_list (gfc_component
**cp
, int vtype
)
2811 gfc_component
*c
, *tail
;
2815 if (iomode
== IO_OUTPUT
)
2817 for (c
= *cp
; c
; c
= c
->next
)
2818 mio_component (c
, vtype
);
2827 if (peek_atom () == ATOM_RPAREN
)
2830 c
= gfc_get_component ();
2831 mio_component (c
, vtype
);
2847 mio_actual_arg (gfc_actual_arglist
*a
)
2850 mio_pool_string (&a
->name
);
2851 mio_expr (&a
->expr
);
2857 mio_actual_arglist (gfc_actual_arglist
**ap
)
2859 gfc_actual_arglist
*a
, *tail
;
2863 if (iomode
== IO_OUTPUT
)
2865 for (a
= *ap
; a
; a
= a
->next
)
2875 if (peek_atom () != ATOM_LPAREN
)
2878 a
= gfc_get_actual_arglist ();
2894 /* Read and write formal argument lists. */
2897 mio_formal_arglist (gfc_formal_arglist
**formal
)
2899 gfc_formal_arglist
*f
, *tail
;
2903 if (iomode
== IO_OUTPUT
)
2905 for (f
= *formal
; f
; f
= f
->next
)
2906 mio_symbol_ref (&f
->sym
);
2910 *formal
= tail
= NULL
;
2912 while (peek_atom () != ATOM_RPAREN
)
2914 f
= gfc_get_formal_arglist ();
2915 mio_symbol_ref (&f
->sym
);
2917 if (*formal
== NULL
)
2930 /* Save or restore a reference to a symbol node. */
2933 mio_symbol_ref (gfc_symbol
**symp
)
2937 p
= mio_pointer_ref (symp
);
2938 if (p
->type
== P_UNKNOWN
)
2941 if (iomode
== IO_OUTPUT
)
2943 if (p
->u
.wsym
.state
== UNREFERENCED
)
2944 p
->u
.wsym
.state
= NEEDS_WRITE
;
2948 if (p
->u
.rsym
.state
== UNUSED
)
2949 p
->u
.rsym
.state
= NEEDED
;
2955 /* Save or restore a reference to a symtree node. */
2958 mio_symtree_ref (gfc_symtree
**stp
)
2963 if (iomode
== IO_OUTPUT
)
2964 mio_symbol_ref (&(*stp
)->n
.sym
);
2967 require_atom (ATOM_INTEGER
);
2968 p
= get_integer (atom_int
);
2970 /* An unused equivalence member; make a symbol and a symtree
2972 if (in_load_equiv
&& p
->u
.rsym
.symtree
== NULL
)
2974 /* Since this is not used, it must have a unique name. */
2975 p
->u
.rsym
.symtree
= gfc_get_unique_symtree (gfc_current_ns
);
2977 /* Make the symbol. */
2978 if (p
->u
.rsym
.sym
== NULL
)
2980 p
->u
.rsym
.sym
= gfc_new_symbol (p
->u
.rsym
.true_name
,
2982 p
->u
.rsym
.sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
2985 p
->u
.rsym
.symtree
->n
.sym
= p
->u
.rsym
.sym
;
2986 p
->u
.rsym
.symtree
->n
.sym
->refs
++;
2987 p
->u
.rsym
.referenced
= 1;
2989 /* If the symbol is PRIVATE and in COMMON, load_commons will
2990 generate a fixup symbol, which must be associated. */
2992 resolve_fixups (p
->fixup
, p
->u
.rsym
.sym
);
2996 if (p
->type
== P_UNKNOWN
)
2999 if (p
->u
.rsym
.state
== UNUSED
)
3000 p
->u
.rsym
.state
= NEEDED
;
3002 if (p
->u
.rsym
.symtree
!= NULL
)
3004 *stp
= p
->u
.rsym
.symtree
;
3008 f
= XCNEW (fixup_t
);
3010 f
->next
= p
->u
.rsym
.stfixup
;
3011 p
->u
.rsym
.stfixup
= f
;
3013 f
->pointer
= (void **) stp
;
3020 mio_iterator (gfc_iterator
**ip
)
3026 if (iomode
== IO_OUTPUT
)
3033 if (peek_atom () == ATOM_RPAREN
)
3039 *ip
= gfc_get_iterator ();
3044 mio_expr (&iter
->var
);
3045 mio_expr (&iter
->start
);
3046 mio_expr (&iter
->end
);
3047 mio_expr (&iter
->step
);
3055 mio_constructor (gfc_constructor_base
*cp
)
3061 if (iomode
== IO_OUTPUT
)
3063 for (c
= gfc_constructor_first (*cp
); c
; c
= gfc_constructor_next (c
))
3066 mio_expr (&c
->expr
);
3067 mio_iterator (&c
->iterator
);
3073 while (peek_atom () != ATOM_RPAREN
)
3075 c
= gfc_constructor_append_expr (cp
, NULL
, NULL
);
3078 mio_expr (&c
->expr
);
3079 mio_iterator (&c
->iterator
);
3088 static const mstring ref_types
[] = {
3089 minit ("ARRAY", REF_ARRAY
),
3090 minit ("COMPONENT", REF_COMPONENT
),
3091 minit ("SUBSTRING", REF_SUBSTRING
),
3097 mio_ref (gfc_ref
**rp
)
3104 r
->type
= MIO_NAME (ref_type
) (r
->type
, ref_types
);
3109 mio_array_ref (&r
->u
.ar
);
3113 mio_symbol_ref (&r
->u
.c
.sym
);
3114 mio_component_ref (&r
->u
.c
.component
);
3118 mio_expr (&r
->u
.ss
.start
);
3119 mio_expr (&r
->u
.ss
.end
);
3120 mio_charlen (&r
->u
.ss
.length
);
3129 mio_ref_list (gfc_ref
**rp
)
3131 gfc_ref
*ref
, *head
, *tail
;
3135 if (iomode
== IO_OUTPUT
)
3137 for (ref
= *rp
; ref
; ref
= ref
->next
)
3144 while (peek_atom () != ATOM_RPAREN
)
3147 head
= tail
= gfc_get_ref ();
3150 tail
->next
= gfc_get_ref ();
3164 /* Read and write an integer value. */
3167 mio_gmp_integer (mpz_t
*integer
)
3171 if (iomode
== IO_INPUT
)
3173 if (parse_atom () != ATOM_STRING
)
3174 bad_module ("Expected integer string");
3176 mpz_init (*integer
);
3177 if (mpz_set_str (*integer
, atom_string
, 10))
3178 bad_module ("Error converting integer");
3184 p
= mpz_get_str (NULL
, 10, *integer
);
3185 write_atom (ATOM_STRING
, p
);
3192 mio_gmp_real (mpfr_t
*real
)
3197 if (iomode
== IO_INPUT
)
3199 if (parse_atom () != ATOM_STRING
)
3200 bad_module ("Expected real string");
3203 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
3208 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
3210 if (mpfr_nan_p (*real
) || mpfr_inf_p (*real
))
3212 write_atom (ATOM_STRING
, p
);
3217 atom_string
= XCNEWVEC (char, strlen (p
) + 20);
3219 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
3221 /* Fix negative numbers. */
3222 if (atom_string
[2] == '-')
3224 atom_string
[0] = '-';
3225 atom_string
[1] = '0';
3226 atom_string
[2] = '.';
3229 write_atom (ATOM_STRING
, atom_string
);
3237 /* Save and restore the shape of an array constructor. */
3240 mio_shape (mpz_t
**pshape
, int rank
)
3246 /* A NULL shape is represented by (). */
3249 if (iomode
== IO_OUTPUT
)
3261 if (t
== ATOM_RPAREN
)
3268 shape
= gfc_get_shape (rank
);
3272 for (n
= 0; n
< rank
; n
++)
3273 mio_gmp_integer (&shape
[n
]);
3279 static const mstring expr_types
[] = {
3280 minit ("OP", EXPR_OP
),
3281 minit ("FUNCTION", EXPR_FUNCTION
),
3282 minit ("CONSTANT", EXPR_CONSTANT
),
3283 minit ("VARIABLE", EXPR_VARIABLE
),
3284 minit ("SUBSTRING", EXPR_SUBSTRING
),
3285 minit ("STRUCTURE", EXPR_STRUCTURE
),
3286 minit ("ARRAY", EXPR_ARRAY
),
3287 minit ("NULL", EXPR_NULL
),
3288 minit ("COMPCALL", EXPR_COMPCALL
),
3292 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3293 generic operators, not in expressions. INTRINSIC_USER is also
3294 replaced by the correct function name by the time we see it. */
3296 static const mstring intrinsics
[] =
3298 minit ("UPLUS", INTRINSIC_UPLUS
),
3299 minit ("UMINUS", INTRINSIC_UMINUS
),
3300 minit ("PLUS", INTRINSIC_PLUS
),
3301 minit ("MINUS", INTRINSIC_MINUS
),
3302 minit ("TIMES", INTRINSIC_TIMES
),
3303 minit ("DIVIDE", INTRINSIC_DIVIDE
),
3304 minit ("POWER", INTRINSIC_POWER
),
3305 minit ("CONCAT", INTRINSIC_CONCAT
),
3306 minit ("AND", INTRINSIC_AND
),
3307 minit ("OR", INTRINSIC_OR
),
3308 minit ("EQV", INTRINSIC_EQV
),
3309 minit ("NEQV", INTRINSIC_NEQV
),
3310 minit ("EQ_SIGN", INTRINSIC_EQ
),
3311 minit ("EQ", INTRINSIC_EQ_OS
),
3312 minit ("NE_SIGN", INTRINSIC_NE
),
3313 minit ("NE", INTRINSIC_NE_OS
),
3314 minit ("GT_SIGN", INTRINSIC_GT
),
3315 minit ("GT", INTRINSIC_GT_OS
),
3316 minit ("GE_SIGN", INTRINSIC_GE
),
3317 minit ("GE", INTRINSIC_GE_OS
),
3318 minit ("LT_SIGN", INTRINSIC_LT
),
3319 minit ("LT", INTRINSIC_LT_OS
),
3320 minit ("LE_SIGN", INTRINSIC_LE
),
3321 minit ("LE", INTRINSIC_LE_OS
),
3322 minit ("NOT", INTRINSIC_NOT
),
3323 minit ("PARENTHESES", INTRINSIC_PARENTHESES
),
3324 minit ("USER", INTRINSIC_USER
),
3329 /* Remedy a couple of situations where the gfc_expr's can be defective. */
3332 fix_mio_expr (gfc_expr
*e
)
3334 gfc_symtree
*ns_st
= NULL
;
3337 if (iomode
!= IO_OUTPUT
)
3342 /* If this is a symtree for a symbol that came from a contained module
3343 namespace, it has a unique name and we should look in the current
3344 namespace to see if the required, non-contained symbol is available
3345 yet. If so, the latter should be written. */
3346 if (e
->symtree
->n
.sym
&& check_unique_name (e
->symtree
->name
))
3348 const char *name
= e
->symtree
->n
.sym
->name
;
3349 if (gfc_fl_struct (e
->symtree
->n
.sym
->attr
.flavor
))
3350 name
= gfc_dt_upper_string (name
);
3351 ns_st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3354 /* On the other hand, if the existing symbol is the module name or the
3355 new symbol is a dummy argument, do not do the promotion. */
3356 if (ns_st
&& ns_st
->n
.sym
3357 && ns_st
->n
.sym
->attr
.flavor
!= FL_MODULE
3358 && !e
->symtree
->n
.sym
->attr
.dummy
)
3361 else if (e
->expr_type
== EXPR_FUNCTION
3362 && (e
->value
.function
.name
|| e
->value
.function
.isym
))
3366 /* In some circumstances, a function used in an initialization
3367 expression, in one use associated module, can fail to be
3368 coupled to its symtree when used in a specification
3369 expression in another module. */
3370 fname
= e
->value
.function
.esym
? e
->value
.function
.esym
->name
3371 : e
->value
.function
.isym
->name
;
3372 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3377 /* This is probably a reference to a private procedure from another
3378 module. To prevent a segfault, make a generic with no specific
3379 instances. If this module is used, without the required
3380 specific coming from somewhere, the appropriate error message
3382 gfc_get_symbol (fname
, gfc_current_ns
, &sym
);
3383 sym
->attr
.flavor
= FL_PROCEDURE
;
3384 sym
->attr
.generic
= 1;
3385 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3386 gfc_commit_symbol (sym
);
3391 /* Read and write expressions. The form "()" is allowed to indicate a
3395 mio_expr (gfc_expr
**ep
)
3404 if (iomode
== IO_OUTPUT
)
3413 MIO_NAME (expr_t
) (e
->expr_type
, expr_types
);
3418 if (t
== ATOM_RPAREN
)
3425 bad_module ("Expected expression type");
3427 e
= *ep
= gfc_get_expr ();
3428 e
->where
= gfc_current_locus
;
3429 e
->expr_type
= (expr_t
) find_enum (expr_types
);
3432 mio_typespec (&e
->ts
);
3433 mio_integer (&e
->rank
);
3437 switch (e
->expr_type
)
3441 = MIO_NAME (gfc_intrinsic_op
) (e
->value
.op
.op
, intrinsics
);
3443 switch (e
->value
.op
.op
)
3445 case INTRINSIC_UPLUS
:
3446 case INTRINSIC_UMINUS
:
3448 case INTRINSIC_PARENTHESES
:
3449 mio_expr (&e
->value
.op
.op1
);
3452 case INTRINSIC_PLUS
:
3453 case INTRINSIC_MINUS
:
3454 case INTRINSIC_TIMES
:
3455 case INTRINSIC_DIVIDE
:
3456 case INTRINSIC_POWER
:
3457 case INTRINSIC_CONCAT
:
3461 case INTRINSIC_NEQV
:
3463 case INTRINSIC_EQ_OS
:
3465 case INTRINSIC_NE_OS
:
3467 case INTRINSIC_GT_OS
:
3469 case INTRINSIC_GE_OS
:
3471 case INTRINSIC_LT_OS
:
3473 case INTRINSIC_LE_OS
:
3474 mio_expr (&e
->value
.op
.op1
);
3475 mio_expr (&e
->value
.op
.op2
);
3478 case INTRINSIC_USER
:
3479 /* INTRINSIC_USER should not appear in resolved expressions,
3480 though for UDRs we need to stream unresolved ones. */
3481 if (iomode
== IO_OUTPUT
)
3482 write_atom (ATOM_STRING
, e
->value
.op
.uop
->name
);
3485 char *name
= read_string ();
3486 const char *uop_name
= find_use_name (name
, true);
3487 if (uop_name
== NULL
)
3489 size_t len
= strlen (name
);
3490 char *name2
= XCNEWVEC (char, len
+ 2);
3491 memcpy (name2
, name
, len
);
3493 name2
[len
+ 1] = '\0';
3495 uop_name
= name
= name2
;
3497 e
->value
.op
.uop
= gfc_get_uop (uop_name
);
3500 mio_expr (&e
->value
.op
.op1
);
3501 mio_expr (&e
->value
.op
.op2
);
3505 bad_module ("Bad operator");
3511 mio_symtree_ref (&e
->symtree
);
3512 mio_actual_arglist (&e
->value
.function
.actual
);
3514 if (iomode
== IO_OUTPUT
)
3516 e
->value
.function
.name
3517 = mio_allocated_string (e
->value
.function
.name
);
3518 if (e
->value
.function
.esym
)
3522 else if (e
->value
.function
.isym
== NULL
)
3526 mio_integer (&flag
);
3530 mio_symbol_ref (&e
->value
.function
.esym
);
3533 mio_ref_list (&e
->ref
);
3538 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
3543 require_atom (ATOM_STRING
);
3544 if (atom_string
[0] == '\0')
3545 e
->value
.function
.name
= NULL
;
3547 e
->value
.function
.name
= gfc_get_string (atom_string
);
3550 mio_integer (&flag
);
3554 mio_symbol_ref (&e
->value
.function
.esym
);
3557 mio_ref_list (&e
->ref
);
3562 require_atom (ATOM_STRING
);
3563 e
->value
.function
.isym
= gfc_find_function (atom_string
);
3571 mio_symtree_ref (&e
->symtree
);
3572 mio_ref_list (&e
->ref
);
3575 case EXPR_SUBSTRING
:
3576 e
->value
.character
.string
3577 = CONST_CAST (gfc_char_t
*,
3578 mio_allocated_wide_string (e
->value
.character
.string
,
3579 e
->value
.character
.length
));
3580 mio_ref_list (&e
->ref
);
3583 case EXPR_STRUCTURE
:
3585 mio_constructor (&e
->value
.constructor
);
3586 mio_shape (&e
->shape
, e
->rank
);
3593 mio_gmp_integer (&e
->value
.integer
);
3597 gfc_set_model_kind (e
->ts
.kind
);
3598 mio_gmp_real (&e
->value
.real
);
3602 gfc_set_model_kind (e
->ts
.kind
);
3603 mio_gmp_real (&mpc_realref (e
->value
.complex));
3604 mio_gmp_real (&mpc_imagref (e
->value
.complex));
3608 mio_integer (&e
->value
.logical
);
3612 hwi
= e
->value
.character
.length
;
3614 e
->value
.character
.length
= hwi
;
3615 e
->value
.character
.string
3616 = CONST_CAST (gfc_char_t
*,
3617 mio_allocated_wide_string (e
->value
.character
.string
,
3618 e
->value
.character
.length
));
3622 bad_module ("Bad type in constant expression");
3640 /* Read and write namelists. */
3643 mio_namelist (gfc_symbol
*sym
)
3645 gfc_namelist
*n
, *m
;
3646 const char *check_name
;
3650 if (iomode
== IO_OUTPUT
)
3652 for (n
= sym
->namelist
; n
; n
= n
->next
)
3653 mio_symbol_ref (&n
->sym
);
3657 /* This departure from the standard is flagged as an error.
3658 It does, in fact, work correctly. TODO: Allow it
3660 if (sym
->attr
.flavor
== FL_NAMELIST
)
3662 check_name
= find_use_name (sym
->name
, false);
3663 if (check_name
&& strcmp (check_name
, sym
->name
) != 0)
3664 gfc_error ("Namelist %s cannot be renamed by USE "
3665 "association to %s", sym
->name
, check_name
);
3669 while (peek_atom () != ATOM_RPAREN
)
3671 n
= gfc_get_namelist ();
3672 mio_symbol_ref (&n
->sym
);
3674 if (sym
->namelist
== NULL
)
3681 sym
->namelist_tail
= m
;
3688 /* Save/restore lists of gfc_interface structures. When loading an
3689 interface, we are really appending to the existing list of
3690 interfaces. Checking for duplicate and ambiguous interfaces has to
3691 be done later when all symbols have been loaded. */
3694 mio_interface_rest (gfc_interface
**ip
)
3696 gfc_interface
*tail
, *p
;
3697 pointer_info
*pi
= NULL
;
3699 if (iomode
== IO_OUTPUT
)
3702 for (p
= *ip
; p
; p
= p
->next
)
3703 mio_symbol_ref (&p
->sym
);
3718 if (peek_atom () == ATOM_RPAREN
)
3721 p
= gfc_get_interface ();
3722 p
->where
= gfc_current_locus
;
3723 pi
= mio_symbol_ref (&p
->sym
);
3739 /* Save/restore a nameless operator interface. */
3742 mio_interface (gfc_interface
**ip
)
3745 mio_interface_rest (ip
);
3749 /* Save/restore a named operator interface. */
3752 mio_symbol_interface (const char **name
, const char **module
,
3756 mio_pool_string (name
);
3757 mio_pool_string (module
);
3758 mio_interface_rest (ip
);
3763 mio_namespace_ref (gfc_namespace
**nsp
)
3768 p
= mio_pointer_ref (nsp
);
3770 if (p
->type
== P_UNKNOWN
)
3771 p
->type
= P_NAMESPACE
;
3773 if (iomode
== IO_INPUT
&& p
->integer
!= 0)
3775 ns
= (gfc_namespace
*) p
->u
.pointer
;
3778 ns
= gfc_get_namespace (NULL
, 0);
3779 associate_integer_pointer (p
, ns
);
3787 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
3789 static gfc_namespace
* current_f2k_derived
;
3792 mio_typebound_proc (gfc_typebound_proc
** proc
)
3795 int overriding_flag
;
3797 if (iomode
== IO_INPUT
)
3799 *proc
= gfc_get_typebound_proc (NULL
);
3800 (*proc
)->where
= gfc_current_locus
;
3806 (*proc
)->access
= MIO_NAME (gfc_access
) ((*proc
)->access
, access_types
);
3808 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
3809 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3810 overriding_flag
= ((*proc
)->deferred
<< 1) | (*proc
)->non_overridable
;
3811 overriding_flag
= mio_name (overriding_flag
, binding_overriding
);
3812 (*proc
)->deferred
= ((overriding_flag
& 2) != 0);
3813 (*proc
)->non_overridable
= ((overriding_flag
& 1) != 0);
3814 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3816 (*proc
)->nopass
= mio_name ((*proc
)->nopass
, binding_passing
);
3817 (*proc
)->is_generic
= mio_name ((*proc
)->is_generic
, binding_generic
);
3818 (*proc
)->ppc
= mio_name((*proc
)->ppc
, binding_ppc
);
3820 mio_pool_string (&((*proc
)->pass_arg
));
3822 flag
= (int) (*proc
)->pass_arg_num
;
3823 mio_integer (&flag
);
3824 (*proc
)->pass_arg_num
= (unsigned) flag
;
3826 if ((*proc
)->is_generic
)
3833 if (iomode
== IO_OUTPUT
)
3834 for (g
= (*proc
)->u
.generic
; g
; g
= g
->next
)
3836 iop
= (int) g
->is_operator
;
3838 mio_allocated_string (g
->specific_st
->name
);
3842 (*proc
)->u
.generic
= NULL
;
3843 while (peek_atom () != ATOM_RPAREN
)
3845 gfc_symtree
** sym_root
;
3847 g
= gfc_get_tbp_generic ();
3851 g
->is_operator
= (bool) iop
;
3853 require_atom (ATOM_STRING
);
3854 sym_root
= ¤t_f2k_derived
->tb_sym_root
;
3855 g
->specific_st
= gfc_get_tbp_symtree (sym_root
, atom_string
);
3858 g
->next
= (*proc
)->u
.generic
;
3859 (*proc
)->u
.generic
= g
;
3865 else if (!(*proc
)->ppc
)
3866 mio_symtree_ref (&(*proc
)->u
.specific
);
3871 /* Walker-callback function for this purpose. */
3873 mio_typebound_symtree (gfc_symtree
* st
)
3875 if (iomode
== IO_OUTPUT
&& !st
->n
.tb
)
3878 if (iomode
== IO_OUTPUT
)
3881 mio_allocated_string (st
->name
);
3883 /* For IO_INPUT, the above is done in mio_f2k_derived. */
3885 mio_typebound_proc (&st
->n
.tb
);
3889 /* IO a full symtree (in all depth). */
3891 mio_full_typebound_tree (gfc_symtree
** root
)
3895 if (iomode
== IO_OUTPUT
)
3896 gfc_traverse_symtree (*root
, &mio_typebound_symtree
);
3899 while (peek_atom () == ATOM_LPAREN
)
3905 require_atom (ATOM_STRING
);
3906 st
= gfc_get_tbp_symtree (root
, atom_string
);
3909 mio_typebound_symtree (st
);
3917 mio_finalizer (gfc_finalizer
**f
)
3919 if (iomode
== IO_OUTPUT
)
3922 gcc_assert ((*f
)->proc_tree
); /* Should already be resolved. */
3923 mio_symtree_ref (&(*f
)->proc_tree
);
3927 *f
= gfc_get_finalizer ();
3928 (*f
)->where
= gfc_current_locus
; /* Value should not matter. */
3931 mio_symtree_ref (&(*f
)->proc_tree
);
3932 (*f
)->proc_sym
= NULL
;
3937 mio_f2k_derived (gfc_namespace
*f2k
)
3939 current_f2k_derived
= f2k
;
3941 /* Handle the list of finalizer procedures. */
3943 if (iomode
== IO_OUTPUT
)
3946 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
3951 f2k
->finalizers
= NULL
;
3952 while (peek_atom () != ATOM_RPAREN
)
3954 gfc_finalizer
*cur
= NULL
;
3955 mio_finalizer (&cur
);
3956 cur
->next
= f2k
->finalizers
;
3957 f2k
->finalizers
= cur
;
3962 /* Handle type-bound procedures. */
3963 mio_full_typebound_tree (&f2k
->tb_sym_root
);
3965 /* Type-bound user operators. */
3966 mio_full_typebound_tree (&f2k
->tb_uop_root
);
3968 /* Type-bound intrinsic operators. */
3970 if (iomode
== IO_OUTPUT
)
3973 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
3975 gfc_intrinsic_op realop
;
3977 if (op
== INTRINSIC_USER
|| !f2k
->tb_op
[op
])
3981 realop
= (gfc_intrinsic_op
) op
;
3982 mio_intrinsic_op (&realop
);
3983 mio_typebound_proc (&f2k
->tb_op
[op
]);
3988 while (peek_atom () != ATOM_RPAREN
)
3990 gfc_intrinsic_op op
= GFC_INTRINSIC_BEGIN
; /* Silence GCC. */
3993 mio_intrinsic_op (&op
);
3994 mio_typebound_proc (&f2k
->tb_op
[op
]);
4001 mio_full_f2k_derived (gfc_symbol
*sym
)
4005 if (iomode
== IO_OUTPUT
)
4007 if (sym
->f2k_derived
)
4008 mio_f2k_derived (sym
->f2k_derived
);
4012 if (peek_atom () != ATOM_RPAREN
)
4014 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
4015 mio_f2k_derived (sym
->f2k_derived
);
4018 gcc_assert (!sym
->f2k_derived
);
4024 static const mstring omp_declare_simd_clauses
[] =
4026 minit ("INBRANCH", 0),
4027 minit ("NOTINBRANCH", 1),
4028 minit ("SIMDLEN", 2),
4029 minit ("UNIFORM", 3),
4030 minit ("LINEAR", 4),
4031 minit ("ALIGNED", 5),
4035 /* Handle !$omp declare simd. */
4038 mio_omp_declare_simd (gfc_namespace
*ns
, gfc_omp_declare_simd
**odsp
)
4040 if (iomode
== IO_OUTPUT
)
4045 else if (peek_atom () != ATOM_LPAREN
)
4048 gfc_omp_declare_simd
*ods
= *odsp
;
4051 if (iomode
== IO_OUTPUT
)
4053 write_atom (ATOM_NAME
, "OMP_DECLARE_SIMD");
4056 gfc_omp_namelist
*n
;
4058 if (ods
->clauses
->inbranch
)
4059 mio_name (0, omp_declare_simd_clauses
);
4060 if (ods
->clauses
->notinbranch
)
4061 mio_name (1, omp_declare_simd_clauses
);
4062 if (ods
->clauses
->simdlen_expr
)
4064 mio_name (2, omp_declare_simd_clauses
);
4065 mio_expr (&ods
->clauses
->simdlen_expr
);
4067 for (n
= ods
->clauses
->lists
[OMP_LIST_UNIFORM
]; n
; n
= n
->next
)
4069 mio_name (3, omp_declare_simd_clauses
);
4070 mio_symbol_ref (&n
->sym
);
4072 for (n
= ods
->clauses
->lists
[OMP_LIST_LINEAR
]; n
; n
= n
->next
)
4074 mio_name (4, omp_declare_simd_clauses
);
4075 mio_symbol_ref (&n
->sym
);
4076 mio_expr (&n
->expr
);
4078 for (n
= ods
->clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
4080 mio_name (5, omp_declare_simd_clauses
);
4081 mio_symbol_ref (&n
->sym
);
4082 mio_expr (&n
->expr
);
4088 gfc_omp_namelist
**ptrs
[3] = { NULL
, NULL
, NULL
};
4090 require_atom (ATOM_NAME
);
4091 *odsp
= ods
= gfc_get_omp_declare_simd ();
4092 ods
->where
= gfc_current_locus
;
4093 ods
->proc_name
= ns
->proc_name
;
4094 if (peek_atom () == ATOM_NAME
)
4096 ods
->clauses
= gfc_get_omp_clauses ();
4097 ptrs
[0] = &ods
->clauses
->lists
[OMP_LIST_UNIFORM
];
4098 ptrs
[1] = &ods
->clauses
->lists
[OMP_LIST_LINEAR
];
4099 ptrs
[2] = &ods
->clauses
->lists
[OMP_LIST_ALIGNED
];
4101 while (peek_atom () == ATOM_NAME
)
4103 gfc_omp_namelist
*n
;
4104 int t
= mio_name (0, omp_declare_simd_clauses
);
4108 case 0: ods
->clauses
->inbranch
= true; break;
4109 case 1: ods
->clauses
->notinbranch
= true; break;
4110 case 2: mio_expr (&ods
->clauses
->simdlen_expr
); break;
4114 *ptrs
[t
- 3] = n
= gfc_get_omp_namelist ();
4115 ptrs
[t
- 3] = &n
->next
;
4116 mio_symbol_ref (&n
->sym
);
4118 mio_expr (&n
->expr
);
4124 mio_omp_declare_simd (ns
, &ods
->next
);
4130 static const mstring omp_declare_reduction_stmt
[] =
4132 minit ("ASSIGN", 0),
4139 mio_omp_udr_expr (gfc_omp_udr
*udr
, gfc_symbol
**sym1
, gfc_symbol
**sym2
,
4140 gfc_namespace
*ns
, bool is_initializer
)
4142 if (iomode
== IO_OUTPUT
)
4144 if ((*sym1
)->module
== NULL
)
4146 (*sym1
)->module
= module_name
;
4147 (*sym2
)->module
= module_name
;
4149 mio_symbol_ref (sym1
);
4150 mio_symbol_ref (sym2
);
4151 if (ns
->code
->op
== EXEC_ASSIGN
)
4153 mio_name (0, omp_declare_reduction_stmt
);
4154 mio_expr (&ns
->code
->expr1
);
4155 mio_expr (&ns
->code
->expr2
);
4160 mio_name (1, omp_declare_reduction_stmt
);
4161 mio_symtree_ref (&ns
->code
->symtree
);
4162 mio_actual_arglist (&ns
->code
->ext
.actual
);
4164 flag
= ns
->code
->resolved_isym
!= NULL
;
4165 mio_integer (&flag
);
4167 write_atom (ATOM_STRING
, ns
->code
->resolved_isym
->name
);
4169 mio_symbol_ref (&ns
->code
->resolved_sym
);
4174 pointer_info
*p1
= mio_symbol_ref (sym1
);
4175 pointer_info
*p2
= mio_symbol_ref (sym2
);
4177 gcc_assert (p1
->u
.rsym
.ns
== p2
->u
.rsym
.ns
);
4178 gcc_assert (p1
->u
.rsym
.sym
== NULL
);
4179 /* Add hidden symbols to the symtree. */
4180 pointer_info
*q
= get_integer (p1
->u
.rsym
.ns
);
4181 q
->u
.pointer
= (void *) ns
;
4182 sym
= gfc_new_symbol (is_initializer
? "omp_priv" : "omp_out", ns
);
4184 sym
->module
= gfc_get_string (p1
->u
.rsym
.module
);
4185 associate_integer_pointer (p1
, sym
);
4186 sym
->attr
.omp_udr_artificial_var
= 1;
4187 gcc_assert (p2
->u
.rsym
.sym
== NULL
);
4188 sym
= gfc_new_symbol (is_initializer
? "omp_orig" : "omp_in", ns
);
4190 sym
->module
= gfc_get_string (p2
->u
.rsym
.module
);
4191 associate_integer_pointer (p2
, sym
);
4192 sym
->attr
.omp_udr_artificial_var
= 1;
4193 if (mio_name (0, omp_declare_reduction_stmt
) == 0)
4195 ns
->code
= gfc_get_code (EXEC_ASSIGN
);
4196 mio_expr (&ns
->code
->expr1
);
4197 mio_expr (&ns
->code
->expr2
);
4202 ns
->code
= gfc_get_code (EXEC_CALL
);
4203 mio_symtree_ref (&ns
->code
->symtree
);
4204 mio_actual_arglist (&ns
->code
->ext
.actual
);
4206 mio_integer (&flag
);
4209 require_atom (ATOM_STRING
);
4210 ns
->code
->resolved_isym
= gfc_find_subroutine (atom_string
);
4214 mio_symbol_ref (&ns
->code
->resolved_sym
);
4216 ns
->code
->loc
= gfc_current_locus
;
4222 /* Unlike most other routines, the address of the symbol node is already
4223 fixed on input and the name/module has already been filled in.
4224 If you update the symbol format here, don't forget to update read_module
4225 as well (look for "seek to the symbol's component list"). */
4228 mio_symbol (gfc_symbol
*sym
)
4230 int intmod
= INTMOD_NONE
;
4234 mio_symbol_attribute (&sym
->attr
);
4236 /* Note that components are always saved, even if they are supposed
4237 to be private. Component access is checked during searching. */
4238 mio_component_list (&sym
->components
, sym
->attr
.vtype
);
4239 if (sym
->components
!= NULL
)
4240 sym
->component_access
4241 = MIO_NAME (gfc_access
) (sym
->component_access
, access_types
);
4243 mio_typespec (&sym
->ts
);
4244 if (sym
->ts
.type
== BT_CLASS
)
4245 sym
->attr
.class_ok
= 1;
4247 if (iomode
== IO_OUTPUT
)
4248 mio_namespace_ref (&sym
->formal_ns
);
4251 mio_namespace_ref (&sym
->formal_ns
);
4253 sym
->formal_ns
->proc_name
= sym
;
4256 /* Save/restore common block links. */
4257 mio_symbol_ref (&sym
->common_next
);
4259 mio_formal_arglist (&sym
->formal
);
4261 if (sym
->attr
.flavor
== FL_PARAMETER
)
4262 mio_expr (&sym
->value
);
4264 mio_array_spec (&sym
->as
);
4266 mio_symbol_ref (&sym
->result
);
4268 if (sym
->attr
.cray_pointee
)
4269 mio_symbol_ref (&sym
->cp_pointer
);
4271 /* Load/save the f2k_derived namespace of a derived-type symbol. */
4272 mio_full_f2k_derived (sym
);
4276 /* Add the fields that say whether this is from an intrinsic module,
4277 and if so, what symbol it is within the module. */
4278 /* mio_integer (&(sym->from_intmod)); */
4279 if (iomode
== IO_OUTPUT
)
4281 intmod
= sym
->from_intmod
;
4282 mio_integer (&intmod
);
4286 mio_integer (&intmod
);
4288 sym
->from_intmod
= current_intmod
;
4290 sym
->from_intmod
= (intmod_id
) intmod
;
4293 mio_integer (&(sym
->intmod_sym_id
));
4295 if (gfc_fl_struct (sym
->attr
.flavor
))
4296 mio_integer (&(sym
->hash_value
));
4299 && sym
->formal_ns
->proc_name
== sym
4300 && sym
->formal_ns
->entries
== NULL
)
4301 mio_omp_declare_simd (sym
->formal_ns
, &sym
->formal_ns
->omp_declare_simd
);
4307 /************************* Top level subroutines *************************/
4309 /* Given a root symtree node and a symbol, try to find a symtree that
4310 references the symbol that is not a unique name. */
4312 static gfc_symtree
*
4313 find_symtree_for_symbol (gfc_symtree
*st
, gfc_symbol
*sym
)
4315 gfc_symtree
*s
= NULL
;
4320 s
= find_symtree_for_symbol (st
->right
, sym
);
4323 s
= find_symtree_for_symbol (st
->left
, sym
);
4327 if (st
->n
.sym
== sym
&& !check_unique_name (st
->name
))
4334 /* A recursive function to look for a specific symbol by name and by
4335 module. Whilst several symtrees might point to one symbol, its
4336 is sufficient for the purposes here than one exist. Note that
4337 generic interfaces are distinguished as are symbols that have been
4338 renamed in another module. */
4339 static gfc_symtree
*
4340 find_symbol (gfc_symtree
*st
, const char *name
,
4341 const char *module
, int generic
)
4344 gfc_symtree
*retval
, *s
;
4346 if (st
== NULL
|| st
->n
.sym
== NULL
)
4349 c
= strcmp (name
, st
->n
.sym
->name
);
4350 if (c
== 0 && st
->n
.sym
->module
4351 && strcmp (module
, st
->n
.sym
->module
) == 0
4352 && !check_unique_name (st
->name
))
4354 s
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4356 /* Detect symbols that are renamed by use association in another
4357 module by the absence of a symtree and null attr.use_rename,
4358 since the latter is not transmitted in the module file. */
4359 if (((!generic
&& !st
->n
.sym
->attr
.generic
)
4360 || (generic
&& st
->n
.sym
->attr
.generic
))
4361 && !(s
== NULL
&& !st
->n
.sym
->attr
.use_rename
))
4365 retval
= find_symbol (st
->left
, name
, module
, generic
);
4368 retval
= find_symbol (st
->right
, name
, module
, generic
);
4374 /* Skip a list between balanced left and right parens.
4375 By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
4376 have been already parsed by hand, and the remaining of the content is to be
4377 skipped here. The default value is 0 (balanced parens). */
4380 skip_list (int nest_level
= 0)
4387 switch (parse_atom ())
4410 /* Load operator interfaces from the module. Interfaces are unusual
4411 in that they attach themselves to existing symbols. */
4414 load_operator_interfaces (void)
4417 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
4419 pointer_info
*pi
= NULL
;
4424 while (peek_atom () != ATOM_RPAREN
)
4428 mio_internal_string (name
);
4429 mio_internal_string (module
);
4431 n
= number_use_names (name
, true);
4434 for (i
= 1; i
<= n
; i
++)
4436 /* Decide if we need to load this one or not. */
4437 p
= find_use_name_n (name
, &i
, true);
4441 while (parse_atom () != ATOM_RPAREN
);
4447 uop
= gfc_get_uop (p
);
4448 pi
= mio_interface_rest (&uop
->op
);
4452 if (gfc_find_uop (p
, NULL
))
4454 uop
= gfc_get_uop (p
);
4455 uop
->op
= gfc_get_interface ();
4456 uop
->op
->where
= gfc_current_locus
;
4457 add_fixup (pi
->integer
, &uop
->op
->sym
);
4466 /* Load interfaces from the module. Interfaces are unusual in that
4467 they attach themselves to existing symbols. */
4470 load_generic_interfaces (void)
4473 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
4475 gfc_interface
*generic
= NULL
, *gen
= NULL
;
4477 bool ambiguous_set
= false;
4481 while (peek_atom () != ATOM_RPAREN
)
4485 mio_internal_string (name
);
4486 mio_internal_string (module
);
4488 n
= number_use_names (name
, false);
4489 renamed
= n
? 1 : 0;
4492 for (i
= 1; i
<= n
; i
++)
4495 /* Decide if we need to load this one or not. */
4496 p
= find_use_name_n (name
, &i
, false);
4498 st
= find_symbol (gfc_current_ns
->sym_root
,
4499 name
, module_name
, 1);
4501 if (!p
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
4503 /* Skip the specific names for these cases. */
4504 while (i
== 1 && parse_atom () != ATOM_RPAREN
);
4509 /* If the symbol exists already and is being USEd without being
4510 in an ONLY clause, do not load a new symtree(11.3.2). */
4511 if (!only_flag
&& st
)
4519 if (strcmp (st
->name
, p
) != 0)
4521 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4527 /* Since we haven't found a valid generic interface, we had
4531 gfc_get_symbol (p
, NULL
, &sym
);
4532 sym
->name
= gfc_get_string (name
);
4533 sym
->module
= module_name
;
4534 sym
->attr
.flavor
= FL_PROCEDURE
;
4535 sym
->attr
.generic
= 1;
4536 sym
->attr
.use_assoc
= 1;
4541 /* Unless sym is a generic interface, this reference
4544 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4548 if (st
&& !sym
->attr
.generic
4551 && strcmp (module
, sym
->module
))
4553 ambiguous_set
= true;
4558 sym
->attr
.use_only
= only_flag
;
4559 sym
->attr
.use_rename
= renamed
;
4563 mio_interface_rest (&sym
->generic
);
4564 generic
= sym
->generic
;
4566 else if (!sym
->generic
)
4568 sym
->generic
= generic
;
4569 sym
->attr
.generic_copy
= 1;
4572 /* If a procedure that is not generic has generic interfaces
4573 that include itself, it is generic! We need to take care
4574 to retain symbols ambiguous that were already so. */
4575 if (sym
->attr
.use_assoc
4576 && !sym
->attr
.generic
4577 && sym
->attr
.flavor
== FL_PROCEDURE
)
4579 for (gen
= generic
; gen
; gen
= gen
->next
)
4581 if (gen
->sym
== sym
)
4583 sym
->attr
.generic
= 1;
4598 /* Load common blocks. */
4603 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4608 while (peek_atom () != ATOM_RPAREN
)
4613 mio_internal_string (name
);
4615 p
= gfc_get_common (name
, 1);
4617 mio_symbol_ref (&p
->head
);
4618 mio_integer (&flags
);
4622 p
->threadprivate
= 1;
4625 /* Get whether this was a bind(c) common or not. */
4626 mio_integer (&p
->is_bind_c
);
4627 /* Get the binding label. */
4628 label
= read_string ();
4630 p
->binding_label
= IDENTIFIER_POINTER (get_identifier (label
));
4640 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4641 so that unused variables are not loaded and so that the expression can
4647 gfc_equiv
*head
, *tail
, *end
, *eq
, *equiv
;
4651 in_load_equiv
= true;
4653 end
= gfc_current_ns
->equiv
;
4654 while (end
!= NULL
&& end
->next
!= NULL
)
4657 while (peek_atom () != ATOM_RPAREN
) {
4661 while(peek_atom () != ATOM_RPAREN
)
4664 head
= tail
= gfc_get_equiv ();
4667 tail
->eq
= gfc_get_equiv ();
4671 mio_pool_string (&tail
->module
);
4672 mio_expr (&tail
->expr
);
4675 /* Check for duplicate equivalences being loaded from different modules */
4677 for (equiv
= gfc_current_ns
->equiv
; equiv
; equiv
= equiv
->next
)
4679 if (equiv
->module
&& head
->module
4680 && strcmp (equiv
->module
, head
->module
) == 0)
4689 for (eq
= head
; eq
; eq
= head
)
4692 gfc_free_expr (eq
->expr
);
4698 gfc_current_ns
->equiv
= head
;
4709 in_load_equiv
= false;
4713 /* This function loads OpenMP user defined reductions. */
4715 load_omp_udrs (void)
4718 while (peek_atom () != ATOM_RPAREN
)
4720 const char *name
= NULL
, *newname
;
4724 gfc_omp_reduction_op rop
= OMP_REDUCTION_USER
;
4727 mio_pool_string (&name
);
4730 if (strncmp (name
, "operator ", sizeof ("operator ") - 1) == 0)
4732 const char *p
= name
+ sizeof ("operator ") - 1;
4733 if (strcmp (p
, "+") == 0)
4734 rop
= OMP_REDUCTION_PLUS
;
4735 else if (strcmp (p
, "*") == 0)
4736 rop
= OMP_REDUCTION_TIMES
;
4737 else if (strcmp (p
, "-") == 0)
4738 rop
= OMP_REDUCTION_MINUS
;
4739 else if (strcmp (p
, ".and.") == 0)
4740 rop
= OMP_REDUCTION_AND
;
4741 else if (strcmp (p
, ".or.") == 0)
4742 rop
= OMP_REDUCTION_OR
;
4743 else if (strcmp (p
, ".eqv.") == 0)
4744 rop
= OMP_REDUCTION_EQV
;
4745 else if (strcmp (p
, ".neqv.") == 0)
4746 rop
= OMP_REDUCTION_NEQV
;
4749 if (rop
== OMP_REDUCTION_USER
&& name
[0] == '.')
4751 size_t len
= strlen (name
+ 1);
4752 altname
= XALLOCAVEC (char, len
);
4753 gcc_assert (name
[len
] == '.');
4754 memcpy (altname
, name
+ 1, len
- 1);
4755 altname
[len
- 1] = '\0';
4758 if (rop
== OMP_REDUCTION_USER
)
4759 newname
= find_use_name (altname
? altname
: name
, !!altname
);
4760 else if (only_flag
&& find_use_operator ((gfc_intrinsic_op
) rop
) == NULL
)
4762 if (newname
== NULL
)
4767 if (altname
&& newname
!= altname
)
4769 size_t len
= strlen (newname
);
4770 altname
= XALLOCAVEC (char, len
+ 3);
4772 memcpy (altname
+ 1, newname
, len
);
4773 altname
[len
+ 1] = '.';
4774 altname
[len
+ 2] = '\0';
4775 name
= gfc_get_string (altname
);
4777 st
= gfc_find_symtree (gfc_current_ns
->omp_udr_root
, name
);
4778 gfc_omp_udr
*udr
= gfc_omp_udr_find (st
, &ts
);
4781 require_atom (ATOM_INTEGER
);
4782 pointer_info
*p
= get_integer (atom_int
);
4783 if (strcmp (p
->u
.rsym
.module
, udr
->omp_out
->module
))
4785 gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
4787 p
->u
.rsym
.module
, &gfc_current_locus
);
4788 gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
4790 udr
->omp_out
->module
, &udr
->where
);
4795 udr
= gfc_get_omp_udr ();
4799 udr
->where
= gfc_current_locus
;
4800 udr
->combiner_ns
= gfc_get_namespace (gfc_current_ns
, 1);
4801 udr
->combiner_ns
->proc_name
= gfc_current_ns
->proc_name
;
4802 mio_omp_udr_expr (udr
, &udr
->omp_out
, &udr
->omp_in
, udr
->combiner_ns
,
4804 if (peek_atom () != ATOM_RPAREN
)
4806 udr
->initializer_ns
= gfc_get_namespace (gfc_current_ns
, 1);
4807 udr
->initializer_ns
->proc_name
= gfc_current_ns
->proc_name
;
4808 mio_omp_udr_expr (udr
, &udr
->omp_priv
, &udr
->omp_orig
,
4809 udr
->initializer_ns
, true);
4813 udr
->next
= st
->n
.omp_udr
;
4814 st
->n
.omp_udr
= udr
;
4818 st
= gfc_new_symtree (&gfc_current_ns
->omp_udr_root
, name
);
4819 st
->n
.omp_udr
= udr
;
4827 /* Recursive function to traverse the pointer_info tree and load a
4828 needed symbol. We return nonzero if we load a symbol and stop the
4829 traversal, because the act of loading can alter the tree. */
4832 load_needed (pointer_info
*p
)
4843 rv
|= load_needed (p
->left
);
4844 rv
|= load_needed (p
->right
);
4846 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
4849 p
->u
.rsym
.state
= USED
;
4851 set_module_locus (&p
->u
.rsym
.where
);
4853 sym
= p
->u
.rsym
.sym
;
4856 q
= get_integer (p
->u
.rsym
.ns
);
4858 ns
= (gfc_namespace
*) q
->u
.pointer
;
4861 /* Create an interface namespace if necessary. These are
4862 the namespaces that hold the formal parameters of module
4865 ns
= gfc_get_namespace (NULL
, 0);
4866 associate_integer_pointer (q
, ns
);
4869 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
4870 doesn't go pear-shaped if the symbol is used. */
4872 gfc_find_symbol (p
->u
.rsym
.module
, gfc_current_ns
,
4875 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
4876 sym
->name
= gfc_dt_lower_string (p
->u
.rsym
.true_name
);
4877 sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
4878 if (p
->u
.rsym
.binding_label
)
4879 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier
4880 (p
->u
.rsym
.binding_label
));
4882 associate_integer_pointer (p
, sym
);
4886 sym
->attr
.use_assoc
= 1;
4888 /* Unliked derived types, a STRUCTURE may share names with other symbols.
4889 We greedily converted the the symbol name to lowercase before we knew its
4890 type, so now we must fix it. */
4891 if (sym
->attr
.flavor
== FL_STRUCT
)
4892 sym
->name
= gfc_dt_upper_string (sym
->name
);
4894 /* Mark as only or rename for later diagnosis for explicitly imported
4895 but not used warnings; don't mark internal symbols such as __vtab,
4896 __def_init etc. Only mark them if they have been explicitly loaded. */
4898 if (only_flag
&& sym
->name
[0] != '_' && sym
->name
[1] != '_')
4902 /* Search the use/rename list for the variable; if the variable is
4904 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4906 if (strcmp (u
->use_name
, sym
->name
) == 0)
4908 sym
->attr
.use_only
= 1;
4914 if (p
->u
.rsym
.renamed
)
4915 sym
->attr
.use_rename
= 1;
4921 /* Recursive function for cleaning up things after a module has been read. */
4924 read_cleanup (pointer_info
*p
)
4932 read_cleanup (p
->left
);
4933 read_cleanup (p
->right
);
4935 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
4938 /* Add hidden symbols to the symtree. */
4939 q
= get_integer (p
->u
.rsym
.ns
);
4940 ns
= (gfc_namespace
*) q
->u
.pointer
;
4942 if (!p
->u
.rsym
.sym
->attr
.vtype
4943 && !p
->u
.rsym
.sym
->attr
.vtab
)
4944 st
= gfc_get_unique_symtree (ns
);
4947 /* There is no reason to use 'unique_symtrees' for vtabs or
4948 vtypes - their name is fine for a symtree and reduces the
4949 namespace pollution. */
4950 st
= gfc_find_symtree (ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4952 st
= gfc_new_symtree (&ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4955 st
->n
.sym
= p
->u
.rsym
.sym
;
4958 /* Fixup any symtree references. */
4959 p
->u
.rsym
.symtree
= st
;
4960 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
4961 p
->u
.rsym
.stfixup
= NULL
;
4964 /* Free unused symbols. */
4965 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
4966 gfc_free_symbol (p
->u
.rsym
.sym
);
4970 /* It is not quite enough to check for ambiguity in the symbols by
4971 the loaded symbol and the new symbol not being identical. */
4973 check_for_ambiguous (gfc_symtree
*st
, pointer_info
*info
)
4977 symbol_attribute attr
;
4980 if (gfc_current_ns
->proc_name
&& st
->name
== gfc_current_ns
->proc_name
->name
)
4982 gfc_error ("%qs of module %qs, imported at %C, is also the name of the "
4983 "current program unit", st
->name
, module_name
);
4988 rsym
= info
->u
.rsym
.sym
;
4992 if (st_sym
->attr
.vtab
|| st_sym
->attr
.vtype
)
4995 /* If the existing symbol is generic from a different module and
4996 the new symbol is generic there can be no ambiguity. */
4997 if (st_sym
->attr
.generic
4999 && st_sym
->module
!= module_name
)
5001 /* The new symbol's attributes have not yet been read. Since
5002 we need attr.generic, read it directly. */
5003 get_module_locus (&locus
);
5004 set_module_locus (&info
->u
.rsym
.where
);
5007 mio_symbol_attribute (&attr
);
5008 set_module_locus (&locus
);
5017 /* Read a module file. */
5022 module_locus operator_interfaces
, user_operators
, omp_udrs
;
5024 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5026 /* Workaround -Wmaybe-uninitialized false positive during
5027 profiledbootstrap by initializing them. */
5028 int ambiguous
= 0, j
, nuse
, symbol
= 0;
5029 pointer_info
*info
, *q
;
5030 gfc_use_rename
*u
= NULL
;
5034 get_module_locus (&operator_interfaces
); /* Skip these for now. */
5037 get_module_locus (&user_operators
);
5041 /* Skip commons and equivalences for now. */
5045 /* Skip OpenMP UDRs. */
5046 get_module_locus (&omp_udrs
);
5051 /* Create the fixup nodes for all the symbols. */
5053 while (peek_atom () != ATOM_RPAREN
)
5056 require_atom (ATOM_INTEGER
);
5057 info
= get_integer (atom_int
);
5059 info
->type
= P_SYMBOL
;
5060 info
->u
.rsym
.state
= UNUSED
;
5062 info
->u
.rsym
.true_name
= read_string ();
5063 info
->u
.rsym
.module
= read_string ();
5064 bind_label
= read_string ();
5065 if (strlen (bind_label
))
5066 info
->u
.rsym
.binding_label
= bind_label
;
5068 XDELETEVEC (bind_label
);
5070 require_atom (ATOM_INTEGER
);
5071 info
->u
.rsym
.ns
= atom_int
;
5073 get_module_locus (&info
->u
.rsym
.where
);
5075 /* See if the symbol has already been loaded by a previous module.
5076 If so, we reference the existing symbol and prevent it from
5077 being loaded again. This should not happen if the symbol being
5078 read is an index for an assumed shape dummy array (ns != 1). */
5080 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
5083 || (sym
->attr
.flavor
== FL_VARIABLE
&& info
->u
.rsym
.ns
!=1))
5089 info
->u
.rsym
.state
= USED
;
5090 info
->u
.rsym
.sym
= sym
;
5091 /* The current symbol has already been loaded, so we can avoid loading
5092 it again. However, if it is a derived type, some of its components
5093 can be used in expressions in the module. To avoid the module loading
5094 failing, we need to associate the module's component pointer indexes
5095 with the existing symbol's component pointers. */
5096 if (gfc_fl_struct (sym
->attr
.flavor
))
5100 /* First seek to the symbol's component list. */
5101 mio_lparen (); /* symbol opening. */
5102 skip_list (); /* skip symbol attribute. */
5104 mio_lparen (); /* component list opening. */
5105 for (c
= sym
->components
; c
; c
= c
->next
)
5108 const char *comp_name
;
5111 mio_lparen (); /* component opening. */
5113 p
= get_integer (n
);
5114 if (p
->u
.pointer
== NULL
)
5115 associate_integer_pointer (p
, c
);
5116 mio_pool_string (&comp_name
);
5117 gcc_assert (comp_name
== c
->name
);
5118 skip_list (1); /* component end. */
5120 mio_rparen (); /* component list closing. */
5122 skip_list (1); /* symbol end. */
5127 /* Some symbols do not have a namespace (eg. formal arguments),
5128 so the automatic "unique symtree" mechanism must be suppressed
5129 by marking them as referenced. */
5130 q
= get_integer (info
->u
.rsym
.ns
);
5131 if (q
->u
.pointer
== NULL
)
5133 info
->u
.rsym
.referenced
= 1;
5137 /* If possible recycle the symtree that references the symbol.
5138 If a symtree is not found and the module does not import one,
5139 a unique-name symtree is found by read_cleanup. */
5140 st
= find_symtree_for_symbol (gfc_current_ns
->sym_root
, sym
);
5143 info
->u
.rsym
.symtree
= st
;
5144 info
->u
.rsym
.referenced
= 1;
5150 /* Parse the symtree lists. This lets us mark which symbols need to
5151 be loaded. Renaming is also done at this point by replacing the
5156 while (peek_atom () != ATOM_RPAREN
)
5158 mio_internal_string (name
);
5159 mio_integer (&ambiguous
);
5160 mio_integer (&symbol
);
5162 info
= get_integer (symbol
);
5164 /* See how many use names there are. If none, go through the start
5165 of the loop at least once. */
5166 nuse
= number_use_names (name
, false);
5167 info
->u
.rsym
.renamed
= nuse
? 1 : 0;
5172 for (j
= 1; j
<= nuse
; j
++)
5174 /* Get the jth local name for this symbol. */
5175 p
= find_use_name_n (name
, &j
, false);
5177 if (p
== NULL
&& strcmp (name
, module_name
) == 0)
5180 /* Exception: Always import vtabs & vtypes. */
5181 if (p
== NULL
&& name
[0] == '_'
5182 && (strncmp (name
, "__vtab_", 5) == 0
5183 || strncmp (name
, "__vtype_", 6) == 0))
5186 /* Skip symtree nodes not in an ONLY clause, unless there
5187 is an existing symtree loaded from another USE statement. */
5190 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5192 && strcmp (st
->n
.sym
->name
, info
->u
.rsym
.true_name
) == 0
5193 && st
->n
.sym
->module
!= NULL
5194 && strcmp (st
->n
.sym
->module
, info
->u
.rsym
.module
) == 0)
5196 info
->u
.rsym
.symtree
= st
;
5197 info
->u
.rsym
.sym
= st
->n
.sym
;
5202 /* If a symbol of the same name and module exists already,
5203 this symbol, which is not in an ONLY clause, must not be
5204 added to the namespace(11.3.2). Note that find_symbol
5205 only returns the first occurrence that it finds. */
5206 if (!only_flag
&& !info
->u
.rsym
.renamed
5207 && strcmp (name
, module_name
) != 0
5208 && find_symbol (gfc_current_ns
->sym_root
, name
,
5212 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
5215 && !(st
->n
.sym
&& st
->n
.sym
->attr
.used_in_submodule
))
5217 /* Check for ambiguous symbols. */
5218 if (check_for_ambiguous (st
, info
))
5221 info
->u
.rsym
.symtree
= st
;
5227 /* This symbol is host associated from a module in a
5228 submodule. Hide it with a unique symtree. */
5229 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
5230 s
->n
.sym
= st
->n
.sym
;
5235 /* Create a symtree node in the current namespace for this
5237 st
= check_unique_name (p
)
5238 ? gfc_get_unique_symtree (gfc_current_ns
)
5239 : gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
5240 st
->ambiguous
= ambiguous
;
5243 sym
= info
->u
.rsym
.sym
;
5245 /* Create a symbol node if it doesn't already exist. */
5248 info
->u
.rsym
.sym
= gfc_new_symbol (info
->u
.rsym
.true_name
,
5250 info
->u
.rsym
.sym
->name
= gfc_dt_lower_string (info
->u
.rsym
.true_name
);
5251 sym
= info
->u
.rsym
.sym
;
5252 sym
->module
= gfc_get_string (info
->u
.rsym
.module
);
5254 if (info
->u
.rsym
.binding_label
)
5255 sym
->binding_label
=
5256 IDENTIFIER_POINTER (get_identifier
5257 (info
->u
.rsym
.binding_label
));
5263 if (strcmp (name
, p
) != 0)
5264 sym
->attr
.use_rename
= 1;
5267 || (strncmp (name
, "__vtab_", 5) != 0
5268 && strncmp (name
, "__vtype_", 6) != 0))
5269 sym
->attr
.use_only
= only_flag
;
5271 /* Store the symtree pointing to this symbol. */
5272 info
->u
.rsym
.symtree
= st
;
5274 if (info
->u
.rsym
.state
== UNUSED
)
5275 info
->u
.rsym
.state
= NEEDED
;
5276 info
->u
.rsym
.referenced
= 1;
5283 /* Load intrinsic operator interfaces. */
5284 set_module_locus (&operator_interfaces
);
5287 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5289 if (i
== INTRINSIC_USER
)
5294 u
= find_use_operator ((gfc_intrinsic_op
) i
);
5305 mio_interface (&gfc_current_ns
->op
[i
]);
5306 if (u
&& !gfc_current_ns
->op
[i
])
5312 /* Load generic and user operator interfaces. These must follow the
5313 loading of symtree because otherwise symbols can be marked as
5316 set_module_locus (&user_operators
);
5318 load_operator_interfaces ();
5319 load_generic_interfaces ();
5324 /* Load OpenMP user defined reductions. */
5325 set_module_locus (&omp_udrs
);
5328 /* At this point, we read those symbols that are needed but haven't
5329 been loaded yet. If one symbol requires another, the other gets
5330 marked as NEEDED if its previous state was UNUSED. */
5332 while (load_needed (pi_root
));
5334 /* Make sure all elements of the rename-list were found in the module. */
5336 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5341 if (u
->op
== INTRINSIC_NONE
)
5343 gfc_error ("Symbol %qs referenced at %L not found in module %qs",
5344 u
->use_name
, &u
->where
, module_name
);
5348 if (u
->op
== INTRINSIC_USER
)
5350 gfc_error ("User operator %qs referenced at %L not found "
5351 "in module %qs", u
->use_name
, &u
->where
, module_name
);
5355 gfc_error ("Intrinsic operator %qs referenced at %L not found "
5356 "in module %qs", gfc_op2string (u
->op
), &u
->where
,
5360 /* Clean up symbol nodes that were never loaded, create references
5361 to hidden symbols. */
5363 read_cleanup (pi_root
);
5367 /* Given an access type that is specific to an entity and the default
5368 access, return nonzero if the entity is publicly accessible. If the
5369 element is declared as PUBLIC, then it is public; if declared
5370 PRIVATE, then private, and otherwise it is public unless the default
5371 access in this context has been declared PRIVATE. */
5373 static bool dump_smod
= false;
5376 check_access (gfc_access specific_access
, gfc_access default_access
)
5381 if (specific_access
== ACCESS_PUBLIC
)
5383 if (specific_access
== ACCESS_PRIVATE
)
5386 if (flag_module_private
)
5387 return default_access
== ACCESS_PUBLIC
;
5389 return default_access
!= ACCESS_PRIVATE
;
5394 gfc_check_symbol_access (gfc_symbol
*sym
)
5396 if (sym
->attr
.vtab
|| sym
->attr
.vtype
)
5399 return check_access (sym
->attr
.access
, sym
->ns
->default_access
);
5403 /* A structure to remember which commons we've already written. */
5405 struct written_common
5407 BBT_HEADER(written_common
);
5408 const char *name
, *label
;
5411 static struct written_common
*written_commons
= NULL
;
5413 /* Comparison function used for balancing the binary tree. */
5416 compare_written_commons (void *a1
, void *b1
)
5418 const char *aname
= ((struct written_common
*) a1
)->name
;
5419 const char *alabel
= ((struct written_common
*) a1
)->label
;
5420 const char *bname
= ((struct written_common
*) b1
)->name
;
5421 const char *blabel
= ((struct written_common
*) b1
)->label
;
5422 int c
= strcmp (aname
, bname
);
5424 return (c
!= 0 ? c
: strcmp (alabel
, blabel
));
5427 /* Free a list of written commons. */
5430 free_written_common (struct written_common
*w
)
5436 free_written_common (w
->left
);
5438 free_written_common (w
->right
);
5443 /* Write a common block to the module -- recursive helper function. */
5446 write_common_0 (gfc_symtree
*st
, bool this_module
)
5452 struct written_common
*w
;
5453 bool write_me
= true;
5458 write_common_0 (st
->left
, this_module
);
5460 /* We will write out the binding label, or "" if no label given. */
5461 name
= st
->n
.common
->name
;
5463 label
= (p
->is_bind_c
&& p
->binding_label
) ? p
->binding_label
: "";
5465 /* Check if we've already output this common. */
5466 w
= written_commons
;
5469 int c
= strcmp (name
, w
->name
);
5470 c
= (c
!= 0 ? c
: strcmp (label
, w
->label
));
5474 w
= (c
< 0) ? w
->left
: w
->right
;
5477 if (this_module
&& p
->use_assoc
)
5482 /* Write the common to the module. */
5484 mio_pool_string (&name
);
5486 mio_symbol_ref (&p
->head
);
5487 flags
= p
->saved
? 1 : 0;
5488 if (p
->threadprivate
)
5490 mio_integer (&flags
);
5492 /* Write out whether the common block is bind(c) or not. */
5493 mio_integer (&(p
->is_bind_c
));
5495 mio_pool_string (&label
);
5498 /* Record that we have written this common. */
5499 w
= XCNEW (struct written_common
);
5502 gfc_insert_bbt (&written_commons
, w
, compare_written_commons
);
5505 write_common_0 (st
->right
, this_module
);
5509 /* Write a common, by initializing the list of written commons, calling
5510 the recursive function write_common_0() and cleaning up afterwards. */
5513 write_common (gfc_symtree
*st
)
5515 written_commons
= NULL
;
5516 write_common_0 (st
, true);
5517 write_common_0 (st
, false);
5518 free_written_common (written_commons
);
5519 written_commons
= NULL
;
5523 /* Write the blank common block to the module. */
5526 write_blank_common (void)
5528 const char * name
= BLANK_COMMON_NAME
;
5530 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
5531 this, but it hasn't been checked. Just making it so for now. */
5534 if (gfc_current_ns
->blank_common
.head
== NULL
)
5539 mio_pool_string (&name
);
5541 mio_symbol_ref (&gfc_current_ns
->blank_common
.head
);
5542 saved
= gfc_current_ns
->blank_common
.saved
;
5543 mio_integer (&saved
);
5545 /* Write out whether the common block is bind(c) or not. */
5546 mio_integer (&is_bind_c
);
5548 /* Write out an empty binding label. */
5549 write_atom (ATOM_STRING
, "");
5555 /* Write equivalences to the module. */
5564 for (eq
= gfc_current_ns
->equiv
; eq
; eq
= eq
->next
)
5568 for (e
= eq
; e
; e
= e
->eq
)
5570 if (e
->module
== NULL
)
5571 e
->module
= gfc_get_string ("%s.eq.%d", module_name
, num
);
5572 mio_allocated_string (e
->module
);
5573 mio_expr (&e
->expr
);
5582 /* Write a symbol to the module. */
5585 write_symbol (int n
, gfc_symbol
*sym
)
5589 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
5590 gfc_internal_error ("write_symbol(): bad module symbol %qs", sym
->name
);
5594 if (gfc_fl_struct (sym
->attr
.flavor
))
5597 name
= gfc_dt_upper_string (sym
->name
);
5598 mio_pool_string (&name
);
5601 mio_pool_string (&sym
->name
);
5603 mio_pool_string (&sym
->module
);
5604 if ((sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
) && sym
->binding_label
)
5606 label
= sym
->binding_label
;
5607 mio_pool_string (&label
);
5610 write_atom (ATOM_STRING
, "");
5612 mio_pointer_ref (&sym
->ns
);
5619 /* Recursive traversal function to write the initial set of symbols to
5620 the module. We check to see if the symbol should be written
5621 according to the access specification. */
5624 write_symbol0 (gfc_symtree
*st
)
5628 bool dont_write
= false;
5633 write_symbol0 (st
->left
);
5636 if (sym
->module
== NULL
)
5637 sym
->module
= module_name
;
5639 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5640 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
5643 if (!gfc_check_symbol_access (sym
))
5648 p
= get_pointer (sym
);
5649 if (p
->type
== P_UNKNOWN
)
5652 if (p
->u
.wsym
.state
!= WRITTEN
)
5654 write_symbol (p
->integer
, sym
);
5655 p
->u
.wsym
.state
= WRITTEN
;
5659 write_symbol0 (st
->right
);
5664 write_omp_udr (gfc_omp_udr
*udr
)
5668 case OMP_REDUCTION_USER
:
5669 /* Non-operators can't be used outside of the module. */
5670 if (udr
->name
[0] != '.')
5675 size_t len
= strlen (udr
->name
+ 1);
5676 char *name
= XALLOCAVEC (char, len
);
5677 memcpy (name
, udr
->name
, len
- 1);
5678 name
[len
- 1] = '\0';
5679 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
5680 /* If corresponding user operator is private, don't write
5684 gfc_user_op
*uop
= st
->n
.uop
;
5685 if (!check_access (uop
->access
, uop
->ns
->default_access
))
5690 case OMP_REDUCTION_PLUS
:
5691 case OMP_REDUCTION_MINUS
:
5692 case OMP_REDUCTION_TIMES
:
5693 case OMP_REDUCTION_AND
:
5694 case OMP_REDUCTION_OR
:
5695 case OMP_REDUCTION_EQV
:
5696 case OMP_REDUCTION_NEQV
:
5697 /* If corresponding operator is private, don't write the UDR. */
5698 if (!check_access (gfc_current_ns
->operator_access
[udr
->rop
],
5699 gfc_current_ns
->default_access
))
5705 if (udr
->ts
.type
== BT_DERIVED
|| udr
->ts
.type
== BT_CLASS
)
5707 /* If derived type is private, don't write the UDR. */
5708 if (!gfc_check_symbol_access (udr
->ts
.u
.derived
))
5713 mio_pool_string (&udr
->name
);
5714 mio_typespec (&udr
->ts
);
5715 mio_omp_udr_expr (udr
, &udr
->omp_out
, &udr
->omp_in
, udr
->combiner_ns
, false);
5716 if (udr
->initializer_ns
)
5717 mio_omp_udr_expr (udr
, &udr
->omp_priv
, &udr
->omp_orig
,
5718 udr
->initializer_ns
, true);
5724 write_omp_udrs (gfc_symtree
*st
)
5729 write_omp_udrs (st
->left
);
5731 for (udr
= st
->n
.omp_udr
; udr
; udr
= udr
->next
)
5732 write_omp_udr (udr
);
5733 write_omp_udrs (st
->right
);
5737 /* Type for the temporary tree used when writing secondary symbols. */
5739 struct sorted_pointer_info
5741 BBT_HEADER (sorted_pointer_info
);
5746 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
5748 /* Recursively traverse the temporary tree, free its contents. */
5751 free_sorted_pointer_info_tree (sorted_pointer_info
*p
)
5756 free_sorted_pointer_info_tree (p
->left
);
5757 free_sorted_pointer_info_tree (p
->right
);
5762 /* Comparison function for the temporary tree. */
5765 compare_sorted_pointer_info (void *_spi1
, void *_spi2
)
5767 sorted_pointer_info
*spi1
, *spi2
;
5768 spi1
= (sorted_pointer_info
*)_spi1
;
5769 spi2
= (sorted_pointer_info
*)_spi2
;
5771 if (spi1
->p
->integer
< spi2
->p
->integer
)
5773 if (spi1
->p
->integer
> spi2
->p
->integer
)
5779 /* Finds the symbols that need to be written and collects them in the
5780 sorted_pi tree so that they can be traversed in an order
5781 independent of memory addresses. */
5784 find_symbols_to_write(sorted_pointer_info
**tree
, pointer_info
*p
)
5789 if (p
->type
== P_SYMBOL
&& p
->u
.wsym
.state
== NEEDS_WRITE
)
5791 sorted_pointer_info
*sp
= gfc_get_sorted_pointer_info();
5794 gfc_insert_bbt (tree
, sp
, compare_sorted_pointer_info
);
5797 find_symbols_to_write (tree
, p
->left
);
5798 find_symbols_to_write (tree
, p
->right
);
5802 /* Recursive function that traverses the tree of symbols that need to be
5803 written and writes them in order. */
5806 write_symbol1_recursion (sorted_pointer_info
*sp
)
5811 write_symbol1_recursion (sp
->left
);
5813 pointer_info
*p1
= sp
->p
;
5814 gcc_assert (p1
->type
== P_SYMBOL
&& p1
->u
.wsym
.state
== NEEDS_WRITE
);
5816 p1
->u
.wsym
.state
= WRITTEN
;
5817 write_symbol (p1
->integer
, p1
->u
.wsym
.sym
);
5818 p1
->u
.wsym
.sym
->attr
.public_used
= 1;
5820 write_symbol1_recursion (sp
->right
);
5824 /* Write the secondary set of symbols to the module file. These are
5825 symbols that were not public yet are needed by the public symbols
5826 or another dependent symbol. The act of writing a symbol can add
5827 symbols to the pointer_info tree, so we return nonzero if a symbol
5828 was written and pass that information upwards. The caller will
5829 then call this function again until nothing was written. It uses
5830 the utility functions and a temporary tree to ensure a reproducible
5831 ordering of the symbol output and thus the module file. */
5834 write_symbol1 (pointer_info
*p
)
5839 /* Put symbols that need to be written into a tree sorted on the
5842 sorted_pointer_info
*spi_root
= NULL
;
5843 find_symbols_to_write (&spi_root
, p
);
5845 /* No symbols to write, return. */
5849 /* Otherwise, write and free the tree again. */
5850 write_symbol1_recursion (spi_root
);
5851 free_sorted_pointer_info_tree (spi_root
);
5857 /* Write operator interfaces associated with a symbol. */
5860 write_operator (gfc_user_op
*uop
)
5862 static char nullstring
[] = "";
5863 const char *p
= nullstring
;
5865 if (uop
->op
== NULL
|| !check_access (uop
->access
, uop
->ns
->default_access
))
5868 mio_symbol_interface (&uop
->name
, &p
, &uop
->op
);
5872 /* Write generic interfaces from the namespace sym_root. */
5875 write_generic (gfc_symtree
*st
)
5882 write_generic (st
->left
);
5885 if (sym
&& !check_unique_name (st
->name
)
5886 && sym
->generic
&& gfc_check_symbol_access (sym
))
5889 sym
->module
= module_name
;
5891 mio_symbol_interface (&st
->name
, &sym
->module
, &sym
->generic
);
5894 write_generic (st
->right
);
5899 write_symtree (gfc_symtree
*st
)
5906 /* A symbol in an interface body must not be visible in the
5908 if (sym
->ns
!= gfc_current_ns
5909 && sym
->ns
->proc_name
5910 && sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
5913 if (!gfc_check_symbol_access (sym
)
5914 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5915 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
5918 if (check_unique_name (st
->name
))
5921 p
= find_pointer (sym
);
5923 gfc_internal_error ("write_symtree(): Symbol not written");
5925 mio_pool_string (&st
->name
);
5926 mio_integer (&st
->ambiguous
);
5927 mio_integer (&p
->integer
);
5936 /* Write the operator interfaces. */
5939 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5941 if (i
== INTRINSIC_USER
)
5944 mio_interface (check_access (gfc_current_ns
->operator_access
[i
],
5945 gfc_current_ns
->default_access
)
5946 ? &gfc_current_ns
->op
[i
] : NULL
);
5954 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
5960 write_generic (gfc_current_ns
->sym_root
);
5966 write_blank_common ();
5967 write_common (gfc_current_ns
->common_root
);
5979 write_omp_udrs (gfc_current_ns
->omp_udr_root
);
5984 /* Write symbol information. First we traverse all symbols in the
5985 primary namespace, writing those that need to be written.
5986 Sometimes writing one symbol will cause another to need to be
5987 written. A list of these symbols ends up on the write stack, and
5988 we end by popping the bottom of the stack and writing the symbol
5989 until the stack is empty. */
5993 write_symbol0 (gfc_current_ns
->sym_root
);
5994 while (write_symbol1 (pi_root
))
6003 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
6008 /* Read a CRC32 sum from the gzip trailer of a module file. Returns
6009 true on success, false on failure. */
6012 read_crc32_from_module_file (const char* filename
, uLong
* crc
)
6018 /* Open the file in binary mode. */
6019 if ((file
= fopen (filename
, "rb")) == NULL
)
6022 /* The gzip crc32 value is found in the [END-8, END-4] bytes of the
6023 file. See RFC 1952. */
6024 if (fseek (file
, -8, SEEK_END
) != 0)
6030 /* Read the CRC32. */
6031 if (fread (buf
, 1, 4, file
) != 4)
6037 /* Close the file. */
6040 val
= (buf
[0] & 0xFF) + ((buf
[1] & 0xFF) << 8) + ((buf
[2] & 0xFF) << 16)
6041 + ((buf
[3] & 0xFF) << 24);
6044 /* For debugging, the CRC value printed in hexadecimal should match
6045 the CRC printed by "zcat -l -v filename".
6046 printf("CRC of file %s is %x\n", filename, val); */
6052 /* Given module, dump it to disk. If there was an error while
6053 processing the module, dump_flag will be set to zero and we delete
6054 the module file, even if it was already there. */
6057 dump_module (const char *name
, int dump_flag
)
6060 char *filename
, *filename_tmp
;
6063 module_name
= gfc_get_string (name
);
6067 name
= submodule_name
;
6068 n
= strlen (name
) + strlen (SUBMODULE_EXTENSION
) + 1;
6071 n
= strlen (name
) + strlen (MODULE_EXTENSION
) + 1;
6073 if (gfc_option
.module_dir
!= NULL
)
6075 n
+= strlen (gfc_option
.module_dir
);
6076 filename
= (char *) alloca (n
);
6077 strcpy (filename
, gfc_option
.module_dir
);
6078 strcat (filename
, name
);
6082 filename
= (char *) alloca (n
);
6083 strcpy (filename
, name
);
6087 strcat (filename
, SUBMODULE_EXTENSION
);
6089 strcat (filename
, MODULE_EXTENSION
);
6091 /* Name of the temporary file used to write the module. */
6092 filename_tmp
= (char *) alloca (n
+ 1);
6093 strcpy (filename_tmp
, filename
);
6094 strcat (filename_tmp
, "0");
6096 /* There was an error while processing the module. We delete the
6097 module file, even if it was already there. */
6104 if (gfc_cpp_makedep ())
6105 gfc_cpp_add_target (filename
);
6107 /* Write the module to the temporary file. */
6108 module_fp
= gzopen (filename_tmp
, "w");
6109 if (module_fp
== NULL
)
6110 gfc_fatal_error ("Can't open module file %qs for writing at %C: %s",
6111 filename_tmp
, xstrerror (errno
));
6113 gzprintf (module_fp
, "GFORTRAN module version '%s' created from %s\n",
6114 MOD_VERSION
, gfc_source_file
);
6116 /* Write the module itself. */
6123 free_pi_tree (pi_root
);
6128 if (gzclose (module_fp
))
6129 gfc_fatal_error ("Error writing module file %qs for writing: %s",
6130 filename_tmp
, xstrerror (errno
));
6132 /* Read the CRC32 from the gzip trailers of the module files and
6134 if (!read_crc32_from_module_file (filename_tmp
, &crc
)
6135 || !read_crc32_from_module_file (filename
, &crc_old
)
6138 /* Module file have changed, replace the old one. */
6139 if (remove (filename
) && errno
!= ENOENT
)
6140 gfc_fatal_error ("Can't delete module file %qs: %s", filename
,
6142 if (rename (filename_tmp
, filename
))
6143 gfc_fatal_error ("Can't rename module file %qs to %qs: %s",
6144 filename_tmp
, filename
, xstrerror (errno
));
6148 if (remove (filename_tmp
))
6149 gfc_fatal_error ("Can't delete temporary module file %qs: %s",
6150 filename_tmp
, xstrerror (errno
));
6156 gfc_dump_module (const char *name
, int dump_flag
)
6158 if (gfc_state_stack
->state
== COMP_SUBMODULE
)
6163 no_module_procedures
= true;
6164 dump_module (name
, dump_flag
);
6166 if (no_module_procedures
|| dump_smod
)
6169 /* Write a submodule file from a module. The 'dump_smod' flag switches
6170 off the check for PRIVATE entities. */
6172 submodule_name
= module_name
;
6173 dump_module (name
, dump_flag
);
6178 create_intrinsic_function (const char *name
, int id
,
6179 const char *modname
, intmod_id module
,
6180 bool subroutine
, gfc_symbol
*result_type
)
6182 gfc_intrinsic_sym
*isym
;
6183 gfc_symtree
*tmp_symtree
;
6186 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6189 if (tmp_symtree
->n
.sym
&& tmp_symtree
->n
.sym
->module
6190 && strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6192 gfc_error ("Symbol %qs at %C already declared", name
);
6196 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6197 sym
= tmp_symtree
->n
.sym
;
6201 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
6202 isym
= gfc_intrinsic_subroutine_by_id (isym_id
);
6203 sym
->attr
.subroutine
= 1;
6207 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
6208 isym
= gfc_intrinsic_function_by_id (isym_id
);
6210 sym
->attr
.function
= 1;
6213 sym
->ts
.type
= BT_DERIVED
;
6214 sym
->ts
.u
.derived
= result_type
;
6215 sym
->ts
.is_c_interop
= 1;
6216 isym
->ts
.f90_type
= BT_VOID
;
6217 isym
->ts
.type
= BT_DERIVED
;
6218 isym
->ts
.f90_type
= BT_VOID
;
6219 isym
->ts
.u
.derived
= result_type
;
6220 isym
->ts
.is_c_interop
= 1;
6225 sym
->attr
.flavor
= FL_PROCEDURE
;
6226 sym
->attr
.intrinsic
= 1;
6228 sym
->module
= gfc_get_string (modname
);
6229 sym
->attr
.use_assoc
= 1;
6230 sym
->from_intmod
= module
;
6231 sym
->intmod_sym_id
= id
;
6235 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
6236 the current namespace for all named constants, pointer types, and
6237 procedures in the module unless the only clause was used or a rename
6238 list was provided. */
6241 import_iso_c_binding_module (void)
6243 gfc_symbol
*mod_sym
= NULL
, *return_type
;
6244 gfc_symtree
*mod_symtree
= NULL
, *tmp_symtree
;
6245 gfc_symtree
*c_ptr
= NULL
, *c_funptr
= NULL
;
6246 const char *iso_c_module_name
= "__iso_c_binding";
6249 bool want_c_ptr
= false, want_c_funptr
= false;
6251 /* Look only in the current namespace. */
6252 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, iso_c_module_name
);
6254 if (mod_symtree
== NULL
)
6256 /* symtree doesn't already exist in current namespace. */
6257 gfc_get_sym_tree (iso_c_module_name
, gfc_current_ns
, &mod_symtree
,
6260 if (mod_symtree
!= NULL
)
6261 mod_sym
= mod_symtree
->n
.sym
;
6263 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
6264 "create symbol for %s", iso_c_module_name
);
6266 mod_sym
->attr
.flavor
= FL_MODULE
;
6267 mod_sym
->attr
.intrinsic
= 1;
6268 mod_sym
->module
= gfc_get_string (iso_c_module_name
);
6269 mod_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
6272 /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
6273 check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
6275 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6277 if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_PTR
].name
,
6280 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_LOC
].name
,
6283 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_FUNPTR
].name
,
6285 want_c_funptr
= true;
6286 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNLOC
].name
,
6288 want_c_funptr
= true;
6289 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_PTR
].name
,
6292 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
6293 (iso_c_binding_symbol
)
6295 u
->local_name
[0] ? u
->local_name
6299 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNPTR
].name
,
6303 = generate_isocbinding_symbol (iso_c_module_name
,
6304 (iso_c_binding_symbol
)
6306 u
->local_name
[0] ? u
->local_name
6312 if ((want_c_ptr
|| !only_flag
) && !c_ptr
)
6313 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
6314 (iso_c_binding_symbol
)
6316 NULL
, NULL
, only_flag
);
6317 if ((want_c_funptr
|| !only_flag
) && !c_funptr
)
6318 c_funptr
= generate_isocbinding_symbol (iso_c_module_name
,
6319 (iso_c_binding_symbol
)
6321 NULL
, NULL
, only_flag
);
6323 /* Generate the symbols for the named constants representing
6324 the kinds for intrinsic data types. */
6325 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
6328 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6329 if (strcmp (c_interop_kinds_table
[i
].name
, u
->use_name
) == 0)
6338 #define NAMED_FUNCTION(a,b,c,d) \
6340 not_in_std = (gfc_option.allow_std & d) == 0; \
6343 #define NAMED_SUBROUTINE(a,b,c,d) \
6345 not_in_std = (gfc_option.allow_std & d) == 0; \
6348 #define NAMED_INTCST(a,b,c,d) \
6350 not_in_std = (gfc_option.allow_std & d) == 0; \
6353 #define NAMED_REALCST(a,b,c,d) \
6355 not_in_std = (gfc_option.allow_std & d) == 0; \
6358 #define NAMED_CMPXCST(a,b,c,d) \
6360 not_in_std = (gfc_option.allow_std & d) == 0; \
6363 #include "iso-c-binding.def"
6371 gfc_error ("The symbol %qs, referenced at %L, is not "
6372 "in the selected standard", name
, &u
->where
);
6378 #define NAMED_FUNCTION(a,b,c,d) \
6380 if (a == ISOCBINDING_LOC) \
6381 return_type = c_ptr->n.sym; \
6382 else if (a == ISOCBINDING_FUNLOC) \
6383 return_type = c_funptr->n.sym; \
6385 return_type = NULL; \
6386 create_intrinsic_function (u->local_name[0] \
6387 ? u->local_name : u->use_name, \
6388 a, iso_c_module_name, \
6389 INTMOD_ISO_C_BINDING, false, \
6392 #define NAMED_SUBROUTINE(a,b,c,d) \
6394 create_intrinsic_function (u->local_name[0] ? u->local_name \
6396 a, iso_c_module_name, \
6397 INTMOD_ISO_C_BINDING, true, NULL); \
6399 #include "iso-c-binding.def"
6401 case ISOCBINDING_PTR
:
6402 case ISOCBINDING_FUNPTR
:
6403 /* Already handled above. */
6406 if (i
== ISOCBINDING_NULL_PTR
)
6407 tmp_symtree
= c_ptr
;
6408 else if (i
== ISOCBINDING_NULL_FUNPTR
)
6409 tmp_symtree
= c_funptr
;
6412 generate_isocbinding_symbol (iso_c_module_name
,
6413 (iso_c_binding_symbol
) i
,
6415 ? u
->local_name
: u
->use_name
,
6416 tmp_symtree
, false);
6420 if (!found
&& !only_flag
)
6422 /* Skip, if the symbol is not in the enabled standard. */
6425 #define NAMED_FUNCTION(a,b,c,d) \
6427 if ((gfc_option.allow_std & d) == 0) \
6430 #define NAMED_SUBROUTINE(a,b,c,d) \
6432 if ((gfc_option.allow_std & d) == 0) \
6435 #define NAMED_INTCST(a,b,c,d) \
6437 if ((gfc_option.allow_std & d) == 0) \
6440 #define NAMED_REALCST(a,b,c,d) \
6442 if ((gfc_option.allow_std & d) == 0) \
6445 #define NAMED_CMPXCST(a,b,c,d) \
6447 if ((gfc_option.allow_std & d) == 0) \
6450 #include "iso-c-binding.def"
6452 ; /* Not GFC_STD_* versioned. */
6457 #define NAMED_FUNCTION(a,b,c,d) \
6459 if (a == ISOCBINDING_LOC) \
6460 return_type = c_ptr->n.sym; \
6461 else if (a == ISOCBINDING_FUNLOC) \
6462 return_type = c_funptr->n.sym; \
6464 return_type = NULL; \
6465 create_intrinsic_function (b, a, iso_c_module_name, \
6466 INTMOD_ISO_C_BINDING, false, \
6469 #define NAMED_SUBROUTINE(a,b,c,d) \
6471 create_intrinsic_function (b, a, iso_c_module_name, \
6472 INTMOD_ISO_C_BINDING, true, NULL); \
6474 #include "iso-c-binding.def"
6476 case ISOCBINDING_PTR
:
6477 case ISOCBINDING_FUNPTR
:
6478 /* Already handled above. */
6481 if (i
== ISOCBINDING_NULL_PTR
)
6482 tmp_symtree
= c_ptr
;
6483 else if (i
== ISOCBINDING_NULL_FUNPTR
)
6484 tmp_symtree
= c_funptr
;
6487 generate_isocbinding_symbol (iso_c_module_name
,
6488 (iso_c_binding_symbol
) i
, NULL
,
6489 tmp_symtree
, false);
6494 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6499 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6500 "module ISO_C_BINDING", u
->use_name
, &u
->where
);
6505 /* Add an integer named constant from a given module. */
6508 create_int_parameter (const char *name
, int value
, const char *modname
,
6509 intmod_id module
, int id
)
6511 gfc_symtree
*tmp_symtree
;
6514 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6515 if (tmp_symtree
!= NULL
)
6517 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6520 gfc_error ("Symbol %qs already declared", name
);
6523 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6524 sym
= tmp_symtree
->n
.sym
;
6526 sym
->module
= gfc_get_string (modname
);
6527 sym
->attr
.flavor
= FL_PARAMETER
;
6528 sym
->ts
.type
= BT_INTEGER
;
6529 sym
->ts
.kind
= gfc_default_integer_kind
;
6530 sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, value
);
6531 sym
->attr
.use_assoc
= 1;
6532 sym
->from_intmod
= module
;
6533 sym
->intmod_sym_id
= id
;
6537 /* Value is already contained by the array constructor, but not
6541 create_int_parameter_array (const char *name
, int size
, gfc_expr
*value
,
6542 const char *modname
, intmod_id module
, int id
)
6544 gfc_symtree
*tmp_symtree
;
6547 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6548 if (tmp_symtree
!= NULL
)
6550 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6553 gfc_error ("Symbol %qs already declared", name
);
6556 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6557 sym
= tmp_symtree
->n
.sym
;
6559 sym
->module
= gfc_get_string (modname
);
6560 sym
->attr
.flavor
= FL_PARAMETER
;
6561 sym
->ts
.type
= BT_INTEGER
;
6562 sym
->ts
.kind
= gfc_default_integer_kind
;
6563 sym
->attr
.use_assoc
= 1;
6564 sym
->from_intmod
= module
;
6565 sym
->intmod_sym_id
= id
;
6566 sym
->attr
.dimension
= 1;
6567 sym
->as
= gfc_get_array_spec ();
6569 sym
->as
->type
= AS_EXPLICIT
;
6570 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
6571 sym
->as
->upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, size
);
6574 sym
->value
->shape
= gfc_get_shape (1);
6575 mpz_init_set_ui (sym
->value
->shape
[0], size
);
6579 /* Add an derived type for a given module. */
6582 create_derived_type (const char *name
, const char *modname
,
6583 intmod_id module
, int id
)
6585 gfc_symtree
*tmp_symtree
;
6586 gfc_symbol
*sym
, *dt_sym
;
6587 gfc_interface
*intr
, *head
;
6589 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6590 if (tmp_symtree
!= NULL
)
6592 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6595 gfc_error ("Symbol %qs already declared", name
);
6598 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6599 sym
= tmp_symtree
->n
.sym
;
6600 sym
->module
= gfc_get_string (modname
);
6601 sym
->from_intmod
= module
;
6602 sym
->intmod_sym_id
= id
;
6603 sym
->attr
.flavor
= FL_PROCEDURE
;
6604 sym
->attr
.function
= 1;
6605 sym
->attr
.generic
= 1;
6607 gfc_get_sym_tree (gfc_dt_upper_string (sym
->name
),
6608 gfc_current_ns
, &tmp_symtree
, false);
6609 dt_sym
= tmp_symtree
->n
.sym
;
6610 dt_sym
->name
= gfc_get_string (sym
->name
);
6611 dt_sym
->attr
.flavor
= FL_DERIVED
;
6612 dt_sym
->attr
.private_comp
= 1;
6613 dt_sym
->attr
.zero_comp
= 1;
6614 dt_sym
->attr
.use_assoc
= 1;
6615 dt_sym
->module
= gfc_get_string (modname
);
6616 dt_sym
->from_intmod
= module
;
6617 dt_sym
->intmod_sym_id
= id
;
6619 head
= sym
->generic
;
6620 intr
= gfc_get_interface ();
6622 intr
->where
= gfc_current_locus
;
6624 sym
->generic
= intr
;
6625 sym
->attr
.if_source
= IFSRC_DECL
;
6629 /* Read the contents of the module file into a temporary buffer. */
6632 read_module_to_tmpbuf ()
6634 /* We don't know the uncompressed size, so enlarge the buffer as
6640 module_content
= XNEWVEC (char, cursz
);
6644 int nread
= gzread (module_fp
, module_content
+ len
, rsize
);
6649 module_content
= XRESIZEVEC (char, module_content
, cursz
);
6650 rsize
= cursz
- len
;
6653 module_content
= XRESIZEVEC (char, module_content
, len
+ 1);
6654 module_content
[len
] = '\0';
6660 /* USE the ISO_FORTRAN_ENV intrinsic module. */
6663 use_iso_fortran_env_module (void)
6665 static char mod
[] = "iso_fortran_env";
6667 gfc_symbol
*mod_sym
;
6668 gfc_symtree
*mod_symtree
;
6672 intmod_sym symbol
[] = {
6673 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
6674 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
6675 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
6676 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
6677 #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
6678 #include "iso-fortran-env.def"
6679 { ISOFORTRANENV_INVALID
, NULL
, -1234, 0 } };
6682 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
6683 #include "iso-fortran-env.def"
6685 /* Generate the symbol for the module itself. */
6686 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, mod
);
6687 if (mod_symtree
== NULL
)
6689 gfc_get_sym_tree (mod
, gfc_current_ns
, &mod_symtree
, false);
6690 gcc_assert (mod_symtree
);
6691 mod_sym
= mod_symtree
->n
.sym
;
6693 mod_sym
->attr
.flavor
= FL_MODULE
;
6694 mod_sym
->attr
.intrinsic
= 1;
6695 mod_sym
->module
= gfc_get_string (mod
);
6696 mod_sym
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
6699 if (!mod_symtree
->n
.sym
->attr
.intrinsic
)
6700 gfc_error ("Use of intrinsic module %qs at %C conflicts with "
6701 "non-intrinsic module name used previously", mod
);
6703 /* Generate the symbols for the module integer named constants. */
6705 for (i
= 0; symbol
[i
].name
; i
++)
6708 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6710 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
6715 if (!gfc_notify_std (symbol
[i
].standard
, "The symbol %qs, "
6716 "referenced at %L, is not in the selected "
6717 "standard", symbol
[i
].name
, &u
->where
))
6720 if ((flag_default_integer
|| flag_default_real
)
6721 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
6722 gfc_warning_now (0, "Use of the NUMERIC_STORAGE_SIZE named "
6723 "constant from intrinsic module "
6724 "ISO_FORTRAN_ENV at %L is incompatible with "
6725 "option %qs", &u
->where
,
6726 flag_default_integer
6727 ? "-fdefault-integer-8"
6728 : "-fdefault-real-8");
6729 switch (symbol
[i
].id
)
6731 #define NAMED_INTCST(a,b,c,d) \
6733 #include "iso-fortran-env.def"
6734 create_int_parameter (u
->local_name
[0] ? u
->local_name
6736 symbol
[i
].value
, mod
,
6737 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
6740 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6742 expr = gfc_get_array_expr (BT_INTEGER, \
6743 gfc_default_integer_kind,\
6745 for (j = 0; KINDS[j].kind != 0; j++) \
6746 gfc_constructor_append_expr (&expr->value.constructor, \
6747 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6748 KINDS[j].kind), NULL); \
6749 create_int_parameter_array (u->local_name[0] ? u->local_name \
6752 INTMOD_ISO_FORTRAN_ENV, \
6755 #include "iso-fortran-env.def"
6757 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6759 #include "iso-fortran-env.def"
6760 create_derived_type (u
->local_name
[0] ? u
->local_name
6762 mod
, INTMOD_ISO_FORTRAN_ENV
,
6766 #define NAMED_FUNCTION(a,b,c,d) \
6768 #include "iso-fortran-env.def"
6769 create_intrinsic_function (u
->local_name
[0] ? u
->local_name
6772 INTMOD_ISO_FORTRAN_ENV
, false,
6782 if (!found
&& !only_flag
)
6784 if ((gfc_option
.allow_std
& symbol
[i
].standard
) == 0)
6787 if ((flag_default_integer
|| flag_default_real
)
6788 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
6790 "Use of the NUMERIC_STORAGE_SIZE named constant "
6791 "from intrinsic module ISO_FORTRAN_ENV at %C is "
6792 "incompatible with option %s",
6793 flag_default_integer
6794 ? "-fdefault-integer-8" : "-fdefault-real-8");
6796 switch (symbol
[i
].id
)
6798 #define NAMED_INTCST(a,b,c,d) \
6800 #include "iso-fortran-env.def"
6801 create_int_parameter (symbol
[i
].name
, symbol
[i
].value
, mod
,
6802 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
6805 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6807 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
6809 for (j = 0; KINDS[j].kind != 0; j++) \
6810 gfc_constructor_append_expr (&expr->value.constructor, \
6811 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6812 KINDS[j].kind), NULL); \
6813 create_int_parameter_array (symbol[i].name, j, expr, mod, \
6814 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
6816 #include "iso-fortran-env.def"
6818 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6820 #include "iso-fortran-env.def"
6821 create_derived_type (symbol
[i
].name
, mod
, INTMOD_ISO_FORTRAN_ENV
,
6825 #define NAMED_FUNCTION(a,b,c,d) \
6827 #include "iso-fortran-env.def"
6828 create_intrinsic_function (symbol
[i
].name
, symbol
[i
].id
, mod
,
6829 INTMOD_ISO_FORTRAN_ENV
, false,
6839 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6844 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6845 "module ISO_FORTRAN_ENV", u
->use_name
, &u
->where
);
6850 /* Process a USE directive. */
6853 gfc_use_module (gfc_use_list
*module
)
6858 gfc_symtree
*mod_symtree
;
6859 gfc_use_list
*use_stmt
;
6860 locus old_locus
= gfc_current_locus
;
6862 gfc_current_locus
= module
->where
;
6863 module_name
= module
->module_name
;
6864 gfc_rename_list
= module
->rename
;
6865 only_flag
= module
->only_flag
;
6866 current_intmod
= INTMOD_NONE
;
6869 gfc_warning_now (OPT_Wuse_without_only
,
6870 "USE statement at %C has no ONLY qualifier");
6872 if (gfc_state_stack
->state
== COMP_MODULE
6873 || module
->submodule_name
== NULL
)
6875 filename
= XALLOCAVEC (char, strlen (module_name
)
6876 + strlen (MODULE_EXTENSION
) + 1);
6877 strcpy (filename
, module_name
);
6878 strcat (filename
, MODULE_EXTENSION
);
6882 filename
= XALLOCAVEC (char, strlen (module
->submodule_name
)
6883 + strlen (SUBMODULE_EXTENSION
) + 1);
6884 strcpy (filename
, module
->submodule_name
);
6885 strcat (filename
, SUBMODULE_EXTENSION
);
6888 /* First, try to find an non-intrinsic module, unless the USE statement
6889 specified that the module is intrinsic. */
6891 if (!module
->intrinsic
)
6892 module_fp
= gzopen_included_file (filename
, true, true);
6894 /* Then, see if it's an intrinsic one, unless the USE statement
6895 specified that the module is non-intrinsic. */
6896 if (module_fp
== NULL
&& !module
->non_intrinsic
)
6898 if (strcmp (module_name
, "iso_fortran_env") == 0
6899 && gfc_notify_std (GFC_STD_F2003
, "ISO_FORTRAN_ENV "
6900 "intrinsic module at %C"))
6902 use_iso_fortran_env_module ();
6903 free_rename (module
->rename
);
6904 module
->rename
= NULL
;
6905 gfc_current_locus
= old_locus
;
6906 module
->intrinsic
= true;
6910 if (strcmp (module_name
, "iso_c_binding") == 0
6911 && gfc_notify_std (GFC_STD_F2003
, "ISO_C_BINDING module at %C"))
6913 import_iso_c_binding_module();
6914 free_rename (module
->rename
);
6915 module
->rename
= NULL
;
6916 gfc_current_locus
= old_locus
;
6917 module
->intrinsic
= true;
6921 module_fp
= gzopen_intrinsic_module (filename
);
6923 if (module_fp
== NULL
&& module
->intrinsic
)
6924 gfc_fatal_error ("Can't find an intrinsic module named %qs at %C",
6927 /* Check for the IEEE modules, so we can mark their symbols
6928 accordingly when we read them. */
6929 if (strcmp (module_name
, "ieee_features") == 0
6930 && gfc_notify_std (GFC_STD_F2003
, "IEEE_FEATURES module at %C"))
6932 current_intmod
= INTMOD_IEEE_FEATURES
;
6934 else if (strcmp (module_name
, "ieee_exceptions") == 0
6935 && gfc_notify_std (GFC_STD_F2003
,
6936 "IEEE_EXCEPTIONS module at %C"))
6938 current_intmod
= INTMOD_IEEE_EXCEPTIONS
;
6940 else if (strcmp (module_name
, "ieee_arithmetic") == 0
6941 && gfc_notify_std (GFC_STD_F2003
,
6942 "IEEE_ARITHMETIC module at %C"))
6944 current_intmod
= INTMOD_IEEE_ARITHMETIC
;
6948 if (module_fp
== NULL
)
6950 if (gfc_state_stack
->state
!= COMP_SUBMODULE
6951 && module
->submodule_name
== NULL
)
6952 gfc_fatal_error ("Can't open module file %qs for reading at %C: %s",
6953 filename
, xstrerror (errno
));
6955 gfc_fatal_error ("Module file %qs has not been generated, either "
6956 "because the module does not contain a MODULE "
6957 "PROCEDURE or there is an error in the module.",
6961 /* Check that we haven't already USEd an intrinsic module with the
6964 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, module_name
);
6965 if (mod_symtree
&& mod_symtree
->n
.sym
->attr
.intrinsic
)
6966 gfc_error ("Use of non-intrinsic module %qs at %C conflicts with "
6967 "intrinsic module name used previously", module_name
);
6974 read_module_to_tmpbuf ();
6975 gzclose (module_fp
);
6977 /* Skip the first line of the module, after checking that this is
6978 a gfortran module file. */
6984 bad_module ("Unexpected end of module");
6987 if ((start
== 1 && strcmp (atom_name
, "GFORTRAN") != 0)
6988 || (start
== 2 && strcmp (atom_name
, " module") != 0))
6989 gfc_fatal_error ("File %qs opened at %C is not a GNU Fortran"
6990 " module file", filename
);
6993 if (strcmp (atom_name
, " version") != 0
6994 || module_char () != ' '
6995 || parse_atom () != ATOM_STRING
6996 || strcmp (atom_string
, MOD_VERSION
))
6997 gfc_fatal_error ("Cannot read module file %qs opened at %C,"
6998 " because it was created by a different"
6999 " version of GNU Fortran", filename
);
7008 /* Make sure we're not reading the same module that we may be building. */
7009 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
7010 if ((p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
)
7011 && strcmp (p
->sym
->name
, module_name
) == 0)
7012 gfc_fatal_error ("Can't USE the same %smodule we're building!",
7013 p
->state
== COMP_SUBMODULE
? "sub" : "");
7016 init_true_name_tree ();
7020 free_true_name (true_name_root
);
7021 true_name_root
= NULL
;
7023 free_pi_tree (pi_root
);
7026 XDELETEVEC (module_content
);
7027 module_content
= NULL
;
7029 use_stmt
= gfc_get_use_list ();
7030 *use_stmt
= *module
;
7031 use_stmt
->next
= gfc_current_ns
->use_stmts
;
7032 gfc_current_ns
->use_stmts
= use_stmt
;
7034 gfc_current_locus
= old_locus
;
7038 /* Remove duplicated intrinsic operators from the rename list. */
7041 rename_list_remove_duplicate (gfc_use_rename
*list
)
7043 gfc_use_rename
*seek
, *last
;
7045 for (; list
; list
= list
->next
)
7046 if (list
->op
!= INTRINSIC_USER
&& list
->op
!= INTRINSIC_NONE
)
7049 for (seek
= list
->next
; seek
; seek
= last
->next
)
7051 if (list
->op
== seek
->op
)
7053 last
->next
= seek
->next
;
7063 /* Process all USE directives. */
7066 gfc_use_modules (void)
7068 gfc_use_list
*next
, *seek
, *last
;
7070 for (next
= module_list
; next
; next
= next
->next
)
7072 bool non_intrinsic
= next
->non_intrinsic
;
7073 bool intrinsic
= next
->intrinsic
;
7074 bool neither
= !non_intrinsic
&& !intrinsic
;
7076 for (seek
= next
->next
; seek
; seek
= seek
->next
)
7078 if (next
->module_name
!= seek
->module_name
)
7081 if (seek
->non_intrinsic
)
7082 non_intrinsic
= true;
7083 else if (seek
->intrinsic
)
7089 if (intrinsic
&& neither
&& !non_intrinsic
)
7094 filename
= XALLOCAVEC (char,
7095 strlen (next
->module_name
)
7096 + strlen (MODULE_EXTENSION
) + 1);
7097 strcpy (filename
, next
->module_name
);
7098 strcat (filename
, MODULE_EXTENSION
);
7099 fp
= gfc_open_included_file (filename
, true, true);
7102 non_intrinsic
= true;
7108 for (seek
= next
->next
; seek
; seek
= last
->next
)
7110 if (next
->module_name
!= seek
->module_name
)
7116 if ((!next
->intrinsic
&& !seek
->intrinsic
)
7117 || (next
->intrinsic
&& seek
->intrinsic
)
7120 if (!seek
->only_flag
)
7121 next
->only_flag
= false;
7124 gfc_use_rename
*r
= seek
->rename
;
7127 r
->next
= next
->rename
;
7128 next
->rename
= seek
->rename
;
7130 last
->next
= seek
->next
;
7138 for (; module_list
; module_list
= next
)
7140 next
= module_list
->next
;
7141 rename_list_remove_duplicate (module_list
->rename
);
7142 gfc_use_module (module_list
);
7145 gfc_rename_list
= NULL
;
7150 gfc_free_use_stmts (gfc_use_list
*use_stmts
)
7153 for (; use_stmts
; use_stmts
= next
)
7155 gfc_use_rename
*next_rename
;
7157 for (; use_stmts
->rename
; use_stmts
->rename
= next_rename
)
7159 next_rename
= use_stmts
->rename
->next
;
7160 free (use_stmts
->rename
);
7162 next
= use_stmts
->next
;
7169 gfc_module_init_2 (void)
7171 last_atom
= ATOM_LPAREN
;
7172 gfc_rename_list
= NULL
;
7178 gfc_module_done_2 (void)
7180 free_rename (gfc_rename_list
);
7181 gfc_rename_list
= NULL
;