1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000-2015 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* The syntax of gfortran modules resembles that of lisp lists, i.e. a
23 sequence of atoms, which can be left or right parenthesis, names,
24 integers or strings. Parenthesis are always matched which allows
25 us to skip over sections at high speed without having to know
26 anything about the internal structure of the lists. A "name" is
27 usually a fortran 95 identifier, but can also start with '@' in
28 order to reference a hidden symbol.
30 The first line of a module is an informational message about what
31 created the module, the file it came from and when it was created.
32 The second line is a warning for people not to edit the module.
33 The rest of the module looks like:
35 ( ( <Interface info for UPLUS> )
36 ( <Interface info for UMINUS> )
39 ( ( <name of operator interface> <module of op interface> <i/f1> ... )
42 ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
45 ( ( <common name> <symbol> <saved flag>)
51 ( <Symbol Number (in no particular order)>
53 <Module name of symbol>
54 ( <symbol information> )
63 In general, symbols refer to other symbols by their symbol number,
64 which are zero based. Symbols are written to the module in no
69 #include "coretypes.h"
73 #include "stringpool.h"
76 #include "parse.h" /* FIXME */
77 #include "constructor.h"
82 #define MODULE_EXTENSION ".mod"
83 #define SUBMODULE_EXTENSION ".smod"
85 /* Don't put any single quote (') in MOD_VERSION, if you want it to be
87 #define MOD_VERSION "14"
90 /* Structure that describes a position within a module file. */
99 /* Structure for list of symbols of intrinsic modules. */
112 P_UNKNOWN
= 0, P_OTHER
, P_NAMESPACE
, P_COMPONENT
, P_SYMBOL
116 /* The fixup structure lists pointers to pointers that have to
117 be updated when a pointer value becomes known. */
119 typedef struct fixup_t
122 struct fixup_t
*next
;
127 /* Structure for holding extra info needed for pointers being read. */
143 typedef struct pointer_info
145 BBT_HEADER (pointer_info
);
149 /* The first component of each member of the union is the pointer
156 void *pointer
; /* Member for doing pointer searches. */
161 char *true_name
, *module
, *binding_label
;
163 gfc_symtree
*symtree
;
164 enum gfc_rsym_state state
;
165 int ns
, referenced
, renamed
;
173 enum gfc_wsym_state state
;
182 #define gfc_get_pointer_info() XCNEW (pointer_info)
185 /* Local variables */
187 /* The gzFile for the module we're reading or writing. */
188 static gzFile module_fp
;
191 /* The name of the module we're reading (USE'ing) or writing. */
192 static const char *module_name
;
193 /* The name of the .smod file that the submodule will write to. */
194 static const char *submodule_name
;
196 /* Suppress the output of a .smod file by module, if no module
197 procedures have been seen. */
198 static bool no_module_procedures
;
200 static gfc_use_list
*module_list
;
202 /* If we're reading an intrinsic module, this is its ID. */
203 static intmod_id current_intmod
;
205 /* Content of module. */
206 static char* module_content
;
208 static long module_pos
;
209 static int module_line
, module_column
, only_flag
;
210 static int prev_module_line
, prev_module_column
;
213 { IO_INPUT
, IO_OUTPUT
}
216 static gfc_use_rename
*gfc_rename_list
;
217 static pointer_info
*pi_root
;
218 static int symbol_number
; /* Counter for assigning symbol numbers */
220 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
221 static bool in_load_equiv
;
225 /*****************************************************************/
227 /* Pointer/integer conversion. Pointers between structures are stored
228 as integers in the module file. The next couple of subroutines
229 handle this translation for reading and writing. */
231 /* Recursively free the tree of pointer structures. */
234 free_pi_tree (pointer_info
*p
)
239 if (p
->fixup
!= NULL
)
240 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
242 free_pi_tree (p
->left
);
243 free_pi_tree (p
->right
);
245 if (iomode
== IO_INPUT
)
247 XDELETEVEC (p
->u
.rsym
.true_name
);
248 XDELETEVEC (p
->u
.rsym
.module
);
249 XDELETEVEC (p
->u
.rsym
.binding_label
);
256 /* Compare pointers when searching by pointer. Used when writing a
260 compare_pointers (void *_sn1
, void *_sn2
)
262 pointer_info
*sn1
, *sn2
;
264 sn1
= (pointer_info
*) _sn1
;
265 sn2
= (pointer_info
*) _sn2
;
267 if (sn1
->u
.pointer
< sn2
->u
.pointer
)
269 if (sn1
->u
.pointer
> sn2
->u
.pointer
)
276 /* Compare integers when searching by integer. Used when reading a
280 compare_integers (void *_sn1
, void *_sn2
)
282 pointer_info
*sn1
, *sn2
;
284 sn1
= (pointer_info
*) _sn1
;
285 sn2
= (pointer_info
*) _sn2
;
287 if (sn1
->integer
< sn2
->integer
)
289 if (sn1
->integer
> sn2
->integer
)
296 /* Initialize the pointer_info tree. */
305 compare
= (iomode
== IO_INPUT
) ? compare_integers
: compare_pointers
;
307 /* Pointer 0 is the NULL pointer. */
308 p
= gfc_get_pointer_info ();
313 gfc_insert_bbt (&pi_root
, p
, compare
);
315 /* Pointer 1 is the current namespace. */
316 p
= gfc_get_pointer_info ();
317 p
->u
.pointer
= gfc_current_ns
;
319 p
->type
= P_NAMESPACE
;
321 gfc_insert_bbt (&pi_root
, p
, compare
);
327 /* During module writing, call here with a pointer to something,
328 returning the pointer_info node. */
330 static pointer_info
*
331 find_pointer (void *gp
)
338 if (p
->u
.pointer
== gp
)
340 p
= (gp
< p
->u
.pointer
) ? p
->left
: p
->right
;
347 /* Given a pointer while writing, returns the pointer_info tree node,
348 creating it if it doesn't exist. */
350 static pointer_info
*
351 get_pointer (void *gp
)
355 p
= find_pointer (gp
);
359 /* Pointer doesn't have an integer. Give it one. */
360 p
= gfc_get_pointer_info ();
363 p
->integer
= symbol_number
++;
365 gfc_insert_bbt (&pi_root
, p
, compare_pointers
);
371 /* Given an integer during reading, find it in the pointer_info tree,
372 creating the node if not found. */
374 static pointer_info
*
375 get_integer (int integer
)
385 c
= compare_integers (&t
, p
);
389 p
= (c
< 0) ? p
->left
: p
->right
;
395 p
= gfc_get_pointer_info ();
396 p
->integer
= integer
;
399 gfc_insert_bbt (&pi_root
, p
, compare_integers
);
405 /* Resolve any fixups using a known pointer. */
408 resolve_fixups (fixup_t
*f
, void *gp
)
421 /* Convert a string such that it starts with a lower-case character. Used
422 to convert the symtree name of a derived-type to the symbol name or to
423 the name of the associated generic function. */
426 dt_lower_string (const char *name
)
428 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
429 return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name
[0]),
431 return gfc_get_string (name
);
435 /* Convert a string such that it starts with an upper-case character. Used to
436 return the symtree-name for a derived type; the symbol name itself and the
437 symtree/symbol name of the associated generic function start with a lower-
441 dt_upper_string (const char *name
)
443 if (name
[0] != (char) TOUPPER ((unsigned char) name
[0]))
444 return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name
[0]),
446 return gfc_get_string (name
);
449 /* Call here during module reading when we know what pointer to
450 associate with an integer. Any fixups that exist are resolved at
454 associate_integer_pointer (pointer_info
*p
, void *gp
)
456 if (p
->u
.pointer
!= NULL
)
457 gfc_internal_error ("associate_integer_pointer(): Already associated");
461 resolve_fixups (p
->fixup
, gp
);
467 /* During module reading, given an integer and a pointer to a pointer,
468 either store the pointer from an already-known value or create a
469 fixup structure in order to store things later. Returns zero if
470 the reference has been actually stored, or nonzero if the reference
471 must be fixed later (i.e., associate_integer_pointer must be called
472 sometime later. Returns the pointer_info structure. */
474 static pointer_info
*
475 add_fixup (int integer
, void *gp
)
481 p
= get_integer (integer
);
483 if (p
->integer
== 0 || p
->u
.pointer
!= NULL
)
486 *cp
= (char *) p
->u
.pointer
;
495 f
->pointer
= (void **) gp
;
502 /*****************************************************************/
504 /* Parser related subroutines */
506 /* Free the rename list left behind by a USE statement. */
509 free_rename (gfc_use_rename
*list
)
511 gfc_use_rename
*next
;
513 for (; list
; list
= next
)
521 /* Match a USE statement. */
526 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module_nature
[GFC_MAX_SYMBOL_LEN
+ 1];
527 gfc_use_rename
*tail
= NULL
, *new_use
;
528 interface_type type
, type2
;
531 gfc_use_list
*use_list
;
533 use_list
= gfc_get_use_list ();
535 if (gfc_match (" , ") == MATCH_YES
)
537 if ((m
= gfc_match (" %n ::", module_nature
)) == MATCH_YES
)
539 if (!gfc_notify_std (GFC_STD_F2003
, "module "
540 "nature in USE statement at %C"))
543 if (strcmp (module_nature
, "intrinsic") == 0)
544 use_list
->intrinsic
= true;
547 if (strcmp (module_nature
, "non_intrinsic") == 0)
548 use_list
->non_intrinsic
= true;
551 gfc_error ("Module nature in USE statement at %C shall "
552 "be either INTRINSIC or NON_INTRINSIC");
559 /* Help output a better error message than "Unclassifiable
561 gfc_match (" %n", module_nature
);
562 if (strcmp (module_nature
, "intrinsic") == 0
563 || strcmp (module_nature
, "non_intrinsic") == 0)
564 gfc_error ("\"::\" was expected after module nature at %C "
565 "but was not found");
572 m
= gfc_match (" ::");
573 if (m
== MATCH_YES
&&
574 !gfc_notify_std(GFC_STD_F2003
, "\"USE :: module\" at %C"))
579 m
= gfc_match ("% ");
588 use_list
->where
= gfc_current_locus
;
590 m
= gfc_match_name (name
);
597 use_list
->module_name
= gfc_get_string (name
);
599 if (gfc_match_eos () == MATCH_YES
)
602 if (gfc_match_char (',') != MATCH_YES
)
605 if (gfc_match (" only :") == MATCH_YES
)
606 use_list
->only_flag
= true;
608 if (gfc_match_eos () == MATCH_YES
)
613 /* Get a new rename struct and add it to the rename list. */
614 new_use
= gfc_get_use_rename ();
615 new_use
->where
= gfc_current_locus
;
618 if (use_list
->rename
== NULL
)
619 use_list
->rename
= new_use
;
621 tail
->next
= new_use
;
624 /* See what kind of interface we're dealing with. Assume it is
626 new_use
->op
= INTRINSIC_NONE
;
627 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
632 case INTERFACE_NAMELESS
:
633 gfc_error ("Missing generic specification in USE statement at %C");
636 case INTERFACE_USER_OP
:
637 case INTERFACE_GENERIC
:
638 m
= gfc_match (" =>");
640 if (type
== INTERFACE_USER_OP
&& m
== MATCH_YES
641 && (!gfc_notify_std(GFC_STD_F2003
, "Renaming "
642 "operators in USE statements at %C")))
645 if (type
== INTERFACE_USER_OP
)
646 new_use
->op
= INTRINSIC_USER
;
648 if (use_list
->only_flag
)
651 strcpy (new_use
->use_name
, name
);
654 strcpy (new_use
->local_name
, name
);
655 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
660 if (m
== MATCH_ERROR
)
668 strcpy (new_use
->local_name
, name
);
670 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
675 if (m
== MATCH_ERROR
)
679 if (strcmp (new_use
->use_name
, use_list
->module_name
) == 0
680 || strcmp (new_use
->local_name
, use_list
->module_name
) == 0)
682 gfc_error ("The name %qs at %C has already been used as "
683 "an external module name.", use_list
->module_name
);
688 case INTERFACE_INTRINSIC_OP
:
696 if (gfc_match_eos () == MATCH_YES
)
698 if (gfc_match_char (',') != MATCH_YES
)
705 gfc_use_list
*last
= module_list
;
708 last
->next
= use_list
;
711 module_list
= use_list
;
716 gfc_syntax_error (ST_USE
);
719 free_rename (use_list
->rename
);
725 /* Match a SUBMODULE statement.
727 According to F2008:11.2.3.2, "The submodule identifier is the
728 ordered pair whose first element is the ancestor module name and
729 whose second element is the submodule name. 'Submodule_name' is
730 used for the submodule filename and uses '@' as a separator, whilst
731 the name of the symbol for the module uses '.' as a a separator.
732 The reasons for these choices are:
733 (i) To follow another leading brand in the submodule filenames;
734 (ii) Since '.' is not particularly visible in the filenames; and
735 (iii) The linker does not permit '@' in mnemonics. */
738 gfc_match_submodule (void)
741 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
742 gfc_use_list
*use_list
;
744 if (!gfc_notify_std (GFC_STD_F2008
, "SUBMODULE declaration at %C"))
747 gfc_new_block
= NULL
;
748 gcc_assert (module_list
== NULL
);
750 if (gfc_match_char ('(') != MATCH_YES
)
755 m
= gfc_match (" %n", name
);
759 use_list
= gfc_get_use_list ();
760 use_list
->where
= gfc_current_locus
;
764 gfc_use_list
*last
= module_list
;
767 last
->next
= use_list
;
768 use_list
->module_name
769 = gfc_get_string ("%s.%s", module_list
->module_name
, name
);
770 use_list
->submodule_name
771 = gfc_get_string ("%s@%s", module_list
->module_name
, name
);
775 module_list
= use_list
;
776 use_list
->module_name
= gfc_get_string (name
);
777 use_list
->submodule_name
= use_list
->module_name
;
780 if (gfc_match_char (')') == MATCH_YES
)
783 if (gfc_match_char (':') != MATCH_YES
)
787 m
= gfc_match (" %s%t", &gfc_new_block
);
791 submodule_name
= gfc_get_string ("%s@%s", module_list
->module_name
,
792 gfc_new_block
->name
);
794 gfc_new_block
->name
= gfc_get_string ("%s.%s",
795 module_list
->module_name
,
796 gfc_new_block
->name
);
798 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
799 gfc_new_block
->name
, NULL
))
802 /* Just retain the ultimate .(s)mod file for reading, since it
803 contains all the information in its ancestors. */
804 use_list
= module_list
;
805 for (; module_list
->next
; use_list
= module_list
)
807 module_list
= use_list
->next
;
814 gfc_error ("Syntax error in SUBMODULE statement at %C");
819 /* Given a name and a number, inst, return the inst name
820 under which to load this symbol. Returns NULL if this
821 symbol shouldn't be loaded. If inst is zero, returns
822 the number of instances of this name. If interface is
823 true, a user-defined operator is sought, otherwise only
824 non-operators are sought. */
827 find_use_name_n (const char *name
, int *inst
, bool interface
)
830 const char *low_name
= NULL
;
833 /* For derived types. */
834 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
835 low_name
= dt_lower_string (name
);
838 for (u
= gfc_rename_list
; u
; u
= u
->next
)
840 if ((!low_name
&& strcmp (u
->use_name
, name
) != 0)
841 || (low_name
&& strcmp (u
->use_name
, low_name
) != 0)
842 || (u
->op
== INTRINSIC_USER
&& !interface
)
843 || (u
->op
!= INTRINSIC_USER
&& interface
))
856 return only_flag
? NULL
: name
;
862 if (u
->local_name
[0] == '\0')
864 return dt_upper_string (u
->local_name
);
867 return (u
->local_name
[0] != '\0') ? u
->local_name
: name
;
871 /* Given a name, return the name under which to load this symbol.
872 Returns NULL if this symbol shouldn't be loaded. */
875 find_use_name (const char *name
, bool interface
)
878 return find_use_name_n (name
, &i
, interface
);
882 /* Given a real name, return the number of use names associated with it. */
885 number_use_names (const char *name
, bool interface
)
888 find_use_name_n (name
, &i
, interface
);
893 /* Try to find the operator in the current list. */
895 static gfc_use_rename
*
896 find_use_operator (gfc_intrinsic_op op
)
900 for (u
= gfc_rename_list
; u
; u
= u
->next
)
908 /*****************************************************************/
910 /* The next couple of subroutines maintain a tree used to avoid a
911 brute-force search for a combination of true name and module name.
912 While symtree names, the name that a particular symbol is known by
913 can changed with USE statements, we still have to keep track of the
914 true names to generate the correct reference, and also avoid
915 loading the same real symbol twice in a program unit.
917 When we start reading, the true name tree is built and maintained
918 as symbols are read. The tree is searched as we load new symbols
919 to see if it already exists someplace in the namespace. */
921 typedef struct true_name
923 BBT_HEADER (true_name
);
929 static true_name
*true_name_root
;
932 /* Compare two true_name structures. */
935 compare_true_names (void *_t1
, void *_t2
)
940 t1
= (true_name
*) _t1
;
941 t2
= (true_name
*) _t2
;
943 c
= ((t1
->sym
->module
> t2
->sym
->module
)
944 - (t1
->sym
->module
< t2
->sym
->module
));
948 return strcmp (t1
->name
, t2
->name
);
952 /* Given a true name, search the true name tree to see if it exists
953 within the main namespace. */
956 find_true_name (const char *name
, const char *module
)
962 t
.name
= gfc_get_string (name
);
964 sym
.module
= gfc_get_string (module
);
972 c
= compare_true_names ((void *) (&t
), (void *) p
);
976 p
= (c
< 0) ? p
->left
: p
->right
;
983 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
986 add_true_name (gfc_symbol
*sym
)
990 t
= XCNEW (true_name
);
992 if (sym
->attr
.flavor
== FL_DERIVED
)
993 t
->name
= dt_upper_string (sym
->name
);
997 gfc_insert_bbt (&true_name_root
, t
, compare_true_names
);
1001 /* Recursive function to build the initial true name tree by
1002 recursively traversing the current namespace. */
1005 build_tnt (gfc_symtree
*st
)
1011 build_tnt (st
->left
);
1012 build_tnt (st
->right
);
1014 if (st
->n
.sym
->attr
.flavor
== FL_DERIVED
)
1015 name
= dt_upper_string (st
->n
.sym
->name
);
1017 name
= st
->n
.sym
->name
;
1019 if (find_true_name (name
, st
->n
.sym
->module
) != NULL
)
1022 add_true_name (st
->n
.sym
);
1026 /* Initialize the true name tree with the current namespace. */
1029 init_true_name_tree (void)
1031 true_name_root
= NULL
;
1032 build_tnt (gfc_current_ns
->sym_root
);
1036 /* Recursively free a true name tree node. */
1039 free_true_name (true_name
*t
)
1043 free_true_name (t
->left
);
1044 free_true_name (t
->right
);
1050 /*****************************************************************/
1052 /* Module reading and writing. */
1054 /* The following are versions similar to the ones in scanner.c, but
1055 for dealing with compressed module files. */
1058 gzopen_included_file_1 (const char *name
, gfc_directorylist
*list
,
1059 bool module
, bool system
)
1062 gfc_directorylist
*p
;
1065 for (p
= list
; p
; p
= p
->next
)
1067 if (module
&& !p
->use_for_modules
)
1070 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 1);
1071 strcpy (fullname
, p
->path
);
1072 strcat (fullname
, name
);
1074 f
= gzopen (fullname
, "r");
1077 if (gfc_cpp_makedep ())
1078 gfc_cpp_add_dep (fullname
, system
);
1088 gzopen_included_file (const char *name
, bool include_cwd
, bool module
)
1092 if (IS_ABSOLUTE_PATH (name
) || include_cwd
)
1094 f
= gzopen (name
, "r");
1095 if (f
&& gfc_cpp_makedep ())
1096 gfc_cpp_add_dep (name
, false);
1100 f
= gzopen_included_file_1 (name
, include_dirs
, module
, false);
1106 gzopen_intrinsic_module (const char* name
)
1110 if (IS_ABSOLUTE_PATH (name
))
1112 f
= gzopen (name
, "r");
1113 if (f
&& gfc_cpp_makedep ())
1114 gfc_cpp_add_dep (name
, true);
1118 f
= gzopen_included_file_1 (name
, intrinsic_modules_dirs
, true, true);
1126 ATOM_NAME
, ATOM_LPAREN
, ATOM_RPAREN
, ATOM_INTEGER
, ATOM_STRING
1129 static atom_type last_atom
;
1132 /* The name buffer must be at least as long as a symbol name. Right
1133 now it's not clear how we're going to store numeric constants--
1134 probably as a hexadecimal string, since this will allow the exact
1135 number to be preserved (this can't be done by a decimal
1136 representation). Worry about that later. TODO! */
1138 #define MAX_ATOM_SIZE 100
1140 static int atom_int
;
1141 static char *atom_string
, atom_name
[MAX_ATOM_SIZE
];
1144 /* Report problems with a module. Error reporting is not very
1145 elaborate, since this sorts of errors shouldn't really happen.
1146 This subroutine never returns. */
1148 static void bad_module (const char *) ATTRIBUTE_NORETURN
;
1151 bad_module (const char *msgid
)
1153 XDELETEVEC (module_content
);
1154 module_content
= NULL
;
1159 gfc_fatal_error ("Reading module %qs at line %d column %d: %s",
1160 module_name
, module_line
, module_column
, msgid
);
1163 gfc_fatal_error ("Writing module %qs at line %d column %d: %s",
1164 module_name
, module_line
, module_column
, msgid
);
1167 gfc_fatal_error ("Module %qs at line %d column %d: %s",
1168 module_name
, module_line
, module_column
, msgid
);
1174 /* Set the module's input pointer. */
1177 set_module_locus (module_locus
*m
)
1179 module_column
= m
->column
;
1180 module_line
= m
->line
;
1181 module_pos
= m
->pos
;
1185 /* Get the module's input pointer so that we can restore it later. */
1188 get_module_locus (module_locus
*m
)
1190 m
->column
= module_column
;
1191 m
->line
= module_line
;
1192 m
->pos
= module_pos
;
1196 /* Get the next character in the module, updating our reckoning of
1202 const char c
= module_content
[module_pos
++];
1204 bad_module ("Unexpected EOF");
1206 prev_module_line
= module_line
;
1207 prev_module_column
= module_column
;
1219 /* Unget a character while remembering the line and column. Works for
1220 a single character only. */
1223 module_unget_char (void)
1225 module_line
= prev_module_line
;
1226 module_column
= prev_module_column
;
1230 /* Parse a string constant. The delimiter is guaranteed to be a
1240 atom_string
= XNEWVEC (char, cursz
);
1248 int c2
= module_char ();
1251 module_unget_char ();
1259 atom_string
= XRESIZEVEC (char, atom_string
, cursz
);
1261 atom_string
[len
] = c
;
1265 atom_string
= XRESIZEVEC (char, atom_string
, len
+ 1);
1266 atom_string
[len
] = '\0'; /* C-style string for debug purposes. */
1270 /* Parse a small integer. */
1273 parse_integer (int c
)
1282 module_unget_char ();
1286 atom_int
= 10 * atom_int
+ c
- '0';
1287 if (atom_int
> 99999999)
1288 bad_module ("Integer overflow");
1310 if (!ISALNUM (c
) && c
!= '_' && c
!= '-')
1312 module_unget_char ();
1317 if (++len
> GFC_MAX_SYMBOL_LEN
)
1318 bad_module ("Name too long");
1326 /* Read the next atom in the module's input stream. */
1337 while (c
== ' ' || c
== '\r' || c
== '\n');
1362 return ATOM_INTEGER
;
1420 bad_module ("Bad name");
1427 /* Peek at the next atom on the input. */
1438 while (c
== ' ' || c
== '\r' || c
== '\n');
1443 module_unget_char ();
1447 module_unget_char ();
1451 module_unget_char ();
1464 module_unget_char ();
1465 return ATOM_INTEGER
;
1519 module_unget_char ();
1523 bad_module ("Bad name");
1528 /* Read the next atom from the input, requiring that it be a
1532 require_atom (atom_type type
)
1538 column
= module_column
;
1547 p
= _("Expected name");
1550 p
= _("Expected left parenthesis");
1553 p
= _("Expected right parenthesis");
1556 p
= _("Expected integer");
1559 p
= _("Expected string");
1562 gfc_internal_error ("require_atom(): bad atom type required");
1565 module_column
= column
;
1572 /* Given a pointer to an mstring array, require that the current input
1573 be one of the strings in the array. We return the enum value. */
1576 find_enum (const mstring
*m
)
1580 i
= gfc_string2code (m
, atom_name
);
1584 bad_module ("find_enum(): Enum not found");
1590 /* Read a string. The caller is responsible for freeing. */
1596 require_atom (ATOM_STRING
);
1603 /**************** Module output subroutines ***************************/
1605 /* Output a character to a module file. */
1608 write_char (char out
)
1610 if (gzputc (module_fp
, out
) == EOF
)
1611 gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno
));
1623 /* Write an atom to a module. The line wrapping isn't perfect, but it
1624 should work most of the time. This isn't that big of a deal, since
1625 the file really isn't meant to be read by people anyway. */
1628 write_atom (atom_type atom
, const void *v
)
1632 /* Workaround -Wmaybe-uninitialized false positive during
1633 profiledbootstrap by initializing them. */
1641 p
= (const char *) v
;
1653 i
= *((const int *) v
);
1655 gfc_internal_error ("write_atom(): Writing negative integer");
1657 sprintf (buffer
, "%d", i
);
1662 gfc_internal_error ("write_atom(): Trying to write dab atom");
1666 if(p
== NULL
|| *p
== '\0')
1671 if (atom
!= ATOM_RPAREN
)
1673 if (module_column
+ len
> 72)
1678 if (last_atom
!= ATOM_LPAREN
&& module_column
!= 1)
1683 if (atom
== ATOM_STRING
)
1686 while (p
!= NULL
&& *p
)
1688 if (atom
== ATOM_STRING
&& *p
== '\'')
1693 if (atom
== ATOM_STRING
)
1701 /***************** Mid-level I/O subroutines *****************/
1703 /* These subroutines let their caller read or write atoms without
1704 caring about which of the two is actually happening. This lets a
1705 subroutine concentrate on the actual format of the data being
1708 static void mio_expr (gfc_expr
**);
1709 pointer_info
*mio_symbol_ref (gfc_symbol
**);
1710 pointer_info
*mio_interface_rest (gfc_interface
**);
1711 static void mio_symtree_ref (gfc_symtree
**);
1713 /* Read or write an enumerated value. On writing, we return the input
1714 value for the convenience of callers. We avoid using an integer
1715 pointer because enums are sometimes inside bitfields. */
1718 mio_name (int t
, const mstring
*m
)
1720 if (iomode
== IO_OUTPUT
)
1721 write_atom (ATOM_NAME
, gfc_code2string (m
, t
));
1724 require_atom (ATOM_NAME
);
1731 /* Specialization of mio_name. */
1733 #define DECL_MIO_NAME(TYPE) \
1734 static inline TYPE \
1735 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1737 return (TYPE) mio_name ((int) t, m); \
1739 #define MIO_NAME(TYPE) mio_name_##TYPE
1744 if (iomode
== IO_OUTPUT
)
1745 write_atom (ATOM_LPAREN
, NULL
);
1747 require_atom (ATOM_LPAREN
);
1754 if (iomode
== IO_OUTPUT
)
1755 write_atom (ATOM_RPAREN
, NULL
);
1757 require_atom (ATOM_RPAREN
);
1762 mio_integer (int *ip
)
1764 if (iomode
== IO_OUTPUT
)
1765 write_atom (ATOM_INTEGER
, ip
);
1768 require_atom (ATOM_INTEGER
);
1774 /* Read or write a gfc_intrinsic_op value. */
1777 mio_intrinsic_op (gfc_intrinsic_op
* op
)
1779 /* FIXME: Would be nicer to do this via the operators symbolic name. */
1780 if (iomode
== IO_OUTPUT
)
1782 int converted
= (int) *op
;
1783 write_atom (ATOM_INTEGER
, &converted
);
1787 require_atom (ATOM_INTEGER
);
1788 *op
= (gfc_intrinsic_op
) atom_int
;
1793 /* Read or write a character pointer that points to a string on the heap. */
1796 mio_allocated_string (const char *s
)
1798 if (iomode
== IO_OUTPUT
)
1800 write_atom (ATOM_STRING
, s
);
1805 require_atom (ATOM_STRING
);
1811 /* Functions for quoting and unquoting strings. */
1814 quote_string (const gfc_char_t
*s
, const size_t slength
)
1816 const gfc_char_t
*p
;
1820 /* Calculate the length we'll need: a backslash takes two ("\\"),
1821 non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */
1822 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1826 else if (!gfc_wide_is_printable (*p
))
1832 q
= res
= XCNEWVEC (char, len
+ 1);
1833 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1836 *q
++ = '\\', *q
++ = '\\';
1837 else if (!gfc_wide_is_printable (*p
))
1839 sprintf (q
, "\\U%08" HOST_WIDE_INT_PRINT
"x",
1840 (unsigned HOST_WIDE_INT
) *p
);
1844 *q
++ = (unsigned char) *p
;
1852 unquote_string (const char *s
)
1858 for (p
= s
, len
= 0; *p
; p
++, len
++)
1865 else if (p
[1] == 'U')
1866 p
+= 9; /* That is a "\U????????". */
1868 gfc_internal_error ("unquote_string(): got bad string");
1871 res
= gfc_get_wide_string (len
+ 1);
1872 for (i
= 0, p
= s
; i
< len
; i
++, p
++)
1877 res
[i
] = (unsigned char) *p
;
1878 else if (p
[1] == '\\')
1880 res
[i
] = (unsigned char) '\\';
1885 /* We read the 8-digits hexadecimal constant that follows. */
1890 gcc_assert (p
[1] == 'U');
1891 for (j
= 0; j
< 8; j
++)
1894 gcc_assert (sscanf (&p
[j
+2], "%01x", &n
) == 1);
1908 /* Read or write a character pointer that points to a wide string on the
1909 heap, performing quoting/unquoting of nonprintable characters using the
1910 form \U???????? (where each ? is a hexadecimal digit).
1911 Length is the length of the string, only known and used in output mode. */
1913 static const gfc_char_t
*
1914 mio_allocated_wide_string (const gfc_char_t
*s
, const size_t length
)
1916 if (iomode
== IO_OUTPUT
)
1918 char *quoted
= quote_string (s
, length
);
1919 write_atom (ATOM_STRING
, quoted
);
1925 gfc_char_t
*unquoted
;
1927 require_atom (ATOM_STRING
);
1928 unquoted
= unquote_string (atom_string
);
1935 /* Read or write a string that is in static memory. */
1938 mio_pool_string (const char **stringp
)
1940 /* TODO: one could write the string only once, and refer to it via a
1943 /* As a special case we have to deal with a NULL string. This
1944 happens for the 'module' member of 'gfc_symbol's that are not in a
1945 module. We read / write these as the empty string. */
1946 if (iomode
== IO_OUTPUT
)
1948 const char *p
= *stringp
== NULL
? "" : *stringp
;
1949 write_atom (ATOM_STRING
, p
);
1953 require_atom (ATOM_STRING
);
1954 *stringp
= atom_string
[0] == '\0' ? NULL
: gfc_get_string (atom_string
);
1960 /* Read or write a string that is inside of some already-allocated
1964 mio_internal_string (char *string
)
1966 if (iomode
== IO_OUTPUT
)
1967 write_atom (ATOM_STRING
, string
);
1970 require_atom (ATOM_STRING
);
1971 strcpy (string
, atom_string
);
1978 { AB_ALLOCATABLE
, AB_DIMENSION
, AB_EXTERNAL
, AB_INTRINSIC
, AB_OPTIONAL
,
1979 AB_POINTER
, AB_TARGET
, AB_DUMMY
, AB_RESULT
, AB_DATA
,
1980 AB_IN_NAMELIST
, AB_IN_COMMON
, AB_FUNCTION
, AB_SUBROUTINE
, AB_SEQUENCE
,
1981 AB_ELEMENTAL
, AB_PURE
, AB_RECURSIVE
, AB_GENERIC
, AB_ALWAYS_EXPLICIT
,
1982 AB_CRAY_POINTER
, AB_CRAY_POINTEE
, AB_THREADPRIVATE
,
1983 AB_ALLOC_COMP
, AB_POINTER_COMP
, AB_PROC_POINTER_COMP
, AB_PRIVATE_COMP
,
1984 AB_VALUE
, AB_VOLATILE
, AB_PROTECTED
, AB_LOCK_COMP
, AB_EVENT_COMP
,
1985 AB_IS_BIND_C
, AB_IS_C_INTEROP
, AB_IS_ISO_C
, AB_ABSTRACT
, AB_ZERO_COMP
,
1986 AB_IS_CLASS
, AB_PROCEDURE
, AB_PROC_POINTER
, AB_ASYNCHRONOUS
, AB_CODIMENSION
,
1987 AB_COARRAY_COMP
, AB_VTYPE
, AB_VTAB
, AB_CONTIGUOUS
, AB_CLASS_POINTER
,
1988 AB_IMPLICIT_PURE
, AB_ARTIFICIAL
, AB_UNLIMITED_POLY
, AB_OMP_DECLARE_TARGET
,
1989 AB_ARRAY_OUTER_DEPENDENCY
, AB_MODULE_PROCEDURE
, AB_OACC_DECLARE_CREATE
,
1990 AB_OACC_DECLARE_COPYIN
, AB_OACC_DECLARE_DEVICEPTR
,
1991 AB_OACC_DECLARE_DEVICE_RESIDENT
, AB_OACC_DECLARE_LINK
1994 static const mstring attr_bits
[] =
1996 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
1997 minit ("ARTIFICIAL", AB_ARTIFICIAL
),
1998 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS
),
1999 minit ("DIMENSION", AB_DIMENSION
),
2000 minit ("CODIMENSION", AB_CODIMENSION
),
2001 minit ("CONTIGUOUS", AB_CONTIGUOUS
),
2002 minit ("EXTERNAL", AB_EXTERNAL
),
2003 minit ("INTRINSIC", AB_INTRINSIC
),
2004 minit ("OPTIONAL", AB_OPTIONAL
),
2005 minit ("POINTER", AB_POINTER
),
2006 minit ("VOLATILE", AB_VOLATILE
),
2007 minit ("TARGET", AB_TARGET
),
2008 minit ("THREADPRIVATE", AB_THREADPRIVATE
),
2009 minit ("DUMMY", AB_DUMMY
),
2010 minit ("RESULT", AB_RESULT
),
2011 minit ("DATA", AB_DATA
),
2012 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
2013 minit ("IN_COMMON", AB_IN_COMMON
),
2014 minit ("FUNCTION", AB_FUNCTION
),
2015 minit ("SUBROUTINE", AB_SUBROUTINE
),
2016 minit ("SEQUENCE", AB_SEQUENCE
),
2017 minit ("ELEMENTAL", AB_ELEMENTAL
),
2018 minit ("PURE", AB_PURE
),
2019 minit ("RECURSIVE", AB_RECURSIVE
),
2020 minit ("GENERIC", AB_GENERIC
),
2021 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
2022 minit ("CRAY_POINTER", AB_CRAY_POINTER
),
2023 minit ("CRAY_POINTEE", AB_CRAY_POINTEE
),
2024 minit ("IS_BIND_C", AB_IS_BIND_C
),
2025 minit ("IS_C_INTEROP", AB_IS_C_INTEROP
),
2026 minit ("IS_ISO_C", AB_IS_ISO_C
),
2027 minit ("VALUE", AB_VALUE
),
2028 minit ("ALLOC_COMP", AB_ALLOC_COMP
),
2029 minit ("COARRAY_COMP", AB_COARRAY_COMP
),
2030 minit ("LOCK_COMP", AB_LOCK_COMP
),
2031 minit ("EVENT_COMP", AB_EVENT_COMP
),
2032 minit ("POINTER_COMP", AB_POINTER_COMP
),
2033 minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP
),
2034 minit ("PRIVATE_COMP", AB_PRIVATE_COMP
),
2035 minit ("ZERO_COMP", AB_ZERO_COMP
),
2036 minit ("PROTECTED", AB_PROTECTED
),
2037 minit ("ABSTRACT", AB_ABSTRACT
),
2038 minit ("IS_CLASS", AB_IS_CLASS
),
2039 minit ("PROCEDURE", AB_PROCEDURE
),
2040 minit ("PROC_POINTER", AB_PROC_POINTER
),
2041 minit ("VTYPE", AB_VTYPE
),
2042 minit ("VTAB", AB_VTAB
),
2043 minit ("CLASS_POINTER", AB_CLASS_POINTER
),
2044 minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE
),
2045 minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY
),
2046 minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET
),
2047 minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY
),
2048 minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE
),
2049 minit ("OACC_DECLARE_CREATE", AB_OACC_DECLARE_CREATE
),
2050 minit ("OACC_DECLARE_COPYIN", AB_OACC_DECLARE_COPYIN
),
2051 minit ("OACC_DECLARE_DEVICEPTR", AB_OACC_DECLARE_DEVICEPTR
),
2052 minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT
),
2053 minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK
),
2057 /* For binding attributes. */
2058 static const mstring binding_passing
[] =
2061 minit ("NOPASS", 1),
2064 static const mstring binding_overriding
[] =
2066 minit ("OVERRIDABLE", 0),
2067 minit ("NON_OVERRIDABLE", 1),
2068 minit ("DEFERRED", 2),
2071 static const mstring binding_generic
[] =
2073 minit ("SPECIFIC", 0),
2074 minit ("GENERIC", 1),
2077 static const mstring binding_ppc
[] =
2079 minit ("NO_PPC", 0),
2084 /* Specialization of mio_name. */
2085 DECL_MIO_NAME (ab_attribute
)
2086 DECL_MIO_NAME (ar_type
)
2087 DECL_MIO_NAME (array_type
)
2089 DECL_MIO_NAME (expr_t
)
2090 DECL_MIO_NAME (gfc_access
)
2091 DECL_MIO_NAME (gfc_intrinsic_op
)
2092 DECL_MIO_NAME (ifsrc
)
2093 DECL_MIO_NAME (save_state
)
2094 DECL_MIO_NAME (procedure_type
)
2095 DECL_MIO_NAME (ref_type
)
2096 DECL_MIO_NAME (sym_flavor
)
2097 DECL_MIO_NAME (sym_intent
)
2098 #undef DECL_MIO_NAME
2100 /* Symbol attributes are stored in list with the first three elements
2101 being the enumerated fields, while the remaining elements (if any)
2102 indicate the individual attribute bits. The access field is not
2103 saved-- it controls what symbols are exported when a module is
2107 mio_symbol_attribute (symbol_attribute
*attr
)
2110 unsigned ext_attr
,extension_level
;
2114 attr
->flavor
= MIO_NAME (sym_flavor
) (attr
->flavor
, flavors
);
2115 attr
->intent
= MIO_NAME (sym_intent
) (attr
->intent
, intents
);
2116 attr
->proc
= MIO_NAME (procedure_type
) (attr
->proc
, procedures
);
2117 attr
->if_source
= MIO_NAME (ifsrc
) (attr
->if_source
, ifsrc_types
);
2118 attr
->save
= MIO_NAME (save_state
) (attr
->save
, save_status
);
2120 ext_attr
= attr
->ext_attr
;
2121 mio_integer ((int *) &ext_attr
);
2122 attr
->ext_attr
= ext_attr
;
2124 extension_level
= attr
->extension
;
2125 mio_integer ((int *) &extension_level
);
2126 attr
->extension
= extension_level
;
2128 if (iomode
== IO_OUTPUT
)
2130 if (attr
->allocatable
)
2131 MIO_NAME (ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
2132 if (attr
->artificial
)
2133 MIO_NAME (ab_attribute
) (AB_ARTIFICIAL
, attr_bits
);
2134 if (attr
->asynchronous
)
2135 MIO_NAME (ab_attribute
) (AB_ASYNCHRONOUS
, attr_bits
);
2136 if (attr
->dimension
)
2137 MIO_NAME (ab_attribute
) (AB_DIMENSION
, attr_bits
);
2138 if (attr
->codimension
)
2139 MIO_NAME (ab_attribute
) (AB_CODIMENSION
, attr_bits
);
2140 if (attr
->contiguous
)
2141 MIO_NAME (ab_attribute
) (AB_CONTIGUOUS
, attr_bits
);
2143 MIO_NAME (ab_attribute
) (AB_EXTERNAL
, attr_bits
);
2144 if (attr
->intrinsic
)
2145 MIO_NAME (ab_attribute
) (AB_INTRINSIC
, attr_bits
);
2147 MIO_NAME (ab_attribute
) (AB_OPTIONAL
, attr_bits
);
2149 MIO_NAME (ab_attribute
) (AB_POINTER
, attr_bits
);
2150 if (attr
->class_pointer
)
2151 MIO_NAME (ab_attribute
) (AB_CLASS_POINTER
, attr_bits
);
2152 if (attr
->is_protected
)
2153 MIO_NAME (ab_attribute
) (AB_PROTECTED
, attr_bits
);
2155 MIO_NAME (ab_attribute
) (AB_VALUE
, attr_bits
);
2156 if (attr
->volatile_
)
2157 MIO_NAME (ab_attribute
) (AB_VOLATILE
, attr_bits
);
2159 MIO_NAME (ab_attribute
) (AB_TARGET
, attr_bits
);
2160 if (attr
->threadprivate
)
2161 MIO_NAME (ab_attribute
) (AB_THREADPRIVATE
, attr_bits
);
2163 MIO_NAME (ab_attribute
) (AB_DUMMY
, attr_bits
);
2165 MIO_NAME (ab_attribute
) (AB_RESULT
, attr_bits
);
2166 /* We deliberately don't preserve the "entry" flag. */
2169 MIO_NAME (ab_attribute
) (AB_DATA
, attr_bits
);
2170 if (attr
->in_namelist
)
2171 MIO_NAME (ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
2172 if (attr
->in_common
)
2173 MIO_NAME (ab_attribute
) (AB_IN_COMMON
, attr_bits
);
2176 MIO_NAME (ab_attribute
) (AB_FUNCTION
, attr_bits
);
2177 if (attr
->subroutine
)
2178 MIO_NAME (ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
2180 MIO_NAME (ab_attribute
) (AB_GENERIC
, attr_bits
);
2182 MIO_NAME (ab_attribute
) (AB_ABSTRACT
, attr_bits
);
2185 MIO_NAME (ab_attribute
) (AB_SEQUENCE
, attr_bits
);
2186 if (attr
->elemental
)
2187 MIO_NAME (ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
2189 MIO_NAME (ab_attribute
) (AB_PURE
, attr_bits
);
2190 if (attr
->implicit_pure
)
2191 MIO_NAME (ab_attribute
) (AB_IMPLICIT_PURE
, attr_bits
);
2192 if (attr
->unlimited_polymorphic
)
2193 MIO_NAME (ab_attribute
) (AB_UNLIMITED_POLY
, attr_bits
);
2194 if (attr
->recursive
)
2195 MIO_NAME (ab_attribute
) (AB_RECURSIVE
, attr_bits
);
2196 if (attr
->always_explicit
)
2197 MIO_NAME (ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
2198 if (attr
->cray_pointer
)
2199 MIO_NAME (ab_attribute
) (AB_CRAY_POINTER
, attr_bits
);
2200 if (attr
->cray_pointee
)
2201 MIO_NAME (ab_attribute
) (AB_CRAY_POINTEE
, attr_bits
);
2202 if (attr
->is_bind_c
)
2203 MIO_NAME(ab_attribute
) (AB_IS_BIND_C
, attr_bits
);
2204 if (attr
->is_c_interop
)
2205 MIO_NAME(ab_attribute
) (AB_IS_C_INTEROP
, attr_bits
);
2207 MIO_NAME(ab_attribute
) (AB_IS_ISO_C
, attr_bits
);
2208 if (attr
->alloc_comp
)
2209 MIO_NAME (ab_attribute
) (AB_ALLOC_COMP
, attr_bits
);
2210 if (attr
->pointer_comp
)
2211 MIO_NAME (ab_attribute
) (AB_POINTER_COMP
, attr_bits
);
2212 if (attr
->proc_pointer_comp
)
2213 MIO_NAME (ab_attribute
) (AB_PROC_POINTER_COMP
, attr_bits
);
2214 if (attr
->private_comp
)
2215 MIO_NAME (ab_attribute
) (AB_PRIVATE_COMP
, attr_bits
);
2216 if (attr
->coarray_comp
)
2217 MIO_NAME (ab_attribute
) (AB_COARRAY_COMP
, attr_bits
);
2218 if (attr
->lock_comp
)
2219 MIO_NAME (ab_attribute
) (AB_LOCK_COMP
, attr_bits
);
2220 if (attr
->event_comp
)
2221 MIO_NAME (ab_attribute
) (AB_EVENT_COMP
, attr_bits
);
2222 if (attr
->zero_comp
)
2223 MIO_NAME (ab_attribute
) (AB_ZERO_COMP
, attr_bits
);
2225 MIO_NAME (ab_attribute
) (AB_IS_CLASS
, attr_bits
);
2226 if (attr
->procedure
)
2227 MIO_NAME (ab_attribute
) (AB_PROCEDURE
, attr_bits
);
2228 if (attr
->proc_pointer
)
2229 MIO_NAME (ab_attribute
) (AB_PROC_POINTER
, attr_bits
);
2231 MIO_NAME (ab_attribute
) (AB_VTYPE
, attr_bits
);
2233 MIO_NAME (ab_attribute
) (AB_VTAB
, attr_bits
);
2234 if (attr
->omp_declare_target
)
2235 MIO_NAME (ab_attribute
) (AB_OMP_DECLARE_TARGET
, attr_bits
);
2236 if (attr
->array_outer_dependency
)
2237 MIO_NAME (ab_attribute
) (AB_ARRAY_OUTER_DEPENDENCY
, attr_bits
);
2238 if (attr
->module_procedure
)
2240 MIO_NAME (ab_attribute
) (AB_MODULE_PROCEDURE
, attr_bits
);
2241 no_module_procedures
= false;
2243 if (attr
->oacc_declare_create
)
2244 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_CREATE
, attr_bits
);
2245 if (attr
->oacc_declare_copyin
)
2246 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_COPYIN
, attr_bits
);
2247 if (attr
->oacc_declare_deviceptr
)
2248 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_DEVICEPTR
, attr_bits
);
2249 if (attr
->oacc_declare_device_resident
)
2250 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_DEVICE_RESIDENT
, attr_bits
);
2251 if (attr
->oacc_declare_link
)
2252 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_LINK
, attr_bits
);
2262 if (t
== ATOM_RPAREN
)
2265 bad_module ("Expected attribute bit name");
2267 switch ((ab_attribute
) find_enum (attr_bits
))
2269 case AB_ALLOCATABLE
:
2270 attr
->allocatable
= 1;
2273 attr
->artificial
= 1;
2275 case AB_ASYNCHRONOUS
:
2276 attr
->asynchronous
= 1;
2279 attr
->dimension
= 1;
2281 case AB_CODIMENSION
:
2282 attr
->codimension
= 1;
2285 attr
->contiguous
= 1;
2291 attr
->intrinsic
= 1;
2299 case AB_CLASS_POINTER
:
2300 attr
->class_pointer
= 1;
2303 attr
->is_protected
= 1;
2309 attr
->volatile_
= 1;
2314 case AB_THREADPRIVATE
:
2315 attr
->threadprivate
= 1;
2326 case AB_IN_NAMELIST
:
2327 attr
->in_namelist
= 1;
2330 attr
->in_common
= 1;
2336 attr
->subroutine
= 1;
2348 attr
->elemental
= 1;
2353 case AB_IMPLICIT_PURE
:
2354 attr
->implicit_pure
= 1;
2356 case AB_UNLIMITED_POLY
:
2357 attr
->unlimited_polymorphic
= 1;
2360 attr
->recursive
= 1;
2362 case AB_ALWAYS_EXPLICIT
:
2363 attr
->always_explicit
= 1;
2365 case AB_CRAY_POINTER
:
2366 attr
->cray_pointer
= 1;
2368 case AB_CRAY_POINTEE
:
2369 attr
->cray_pointee
= 1;
2372 attr
->is_bind_c
= 1;
2374 case AB_IS_C_INTEROP
:
2375 attr
->is_c_interop
= 1;
2381 attr
->alloc_comp
= 1;
2383 case AB_COARRAY_COMP
:
2384 attr
->coarray_comp
= 1;
2387 attr
->lock_comp
= 1;
2390 attr
->event_comp
= 1;
2392 case AB_POINTER_COMP
:
2393 attr
->pointer_comp
= 1;
2395 case AB_PROC_POINTER_COMP
:
2396 attr
->proc_pointer_comp
= 1;
2398 case AB_PRIVATE_COMP
:
2399 attr
->private_comp
= 1;
2402 attr
->zero_comp
= 1;
2408 attr
->procedure
= 1;
2410 case AB_PROC_POINTER
:
2411 attr
->proc_pointer
= 1;
2419 case AB_OMP_DECLARE_TARGET
:
2420 attr
->omp_declare_target
= 1;
2422 case AB_ARRAY_OUTER_DEPENDENCY
:
2423 attr
->array_outer_dependency
=1;
2425 case AB_MODULE_PROCEDURE
:
2426 attr
->module_procedure
=1;
2428 case AB_OACC_DECLARE_CREATE
:
2429 attr
->oacc_declare_create
= 1;
2431 case AB_OACC_DECLARE_COPYIN
:
2432 attr
->oacc_declare_copyin
= 1;
2434 case AB_OACC_DECLARE_DEVICEPTR
:
2435 attr
->oacc_declare_deviceptr
= 1;
2437 case AB_OACC_DECLARE_DEVICE_RESIDENT
:
2438 attr
->oacc_declare_device_resident
= 1;
2440 case AB_OACC_DECLARE_LINK
:
2441 attr
->oacc_declare_link
= 1;
2449 static const mstring bt_types
[] = {
2450 minit ("INTEGER", BT_INTEGER
),
2451 minit ("REAL", BT_REAL
),
2452 minit ("COMPLEX", BT_COMPLEX
),
2453 minit ("LOGICAL", BT_LOGICAL
),
2454 minit ("CHARACTER", BT_CHARACTER
),
2455 minit ("DERIVED", BT_DERIVED
),
2456 minit ("CLASS", BT_CLASS
),
2457 minit ("PROCEDURE", BT_PROCEDURE
),
2458 minit ("UNKNOWN", BT_UNKNOWN
),
2459 minit ("VOID", BT_VOID
),
2460 minit ("ASSUMED", BT_ASSUMED
),
2466 mio_charlen (gfc_charlen
**clp
)
2472 if (iomode
== IO_OUTPUT
)
2476 mio_expr (&cl
->length
);
2480 if (peek_atom () != ATOM_RPAREN
)
2482 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2483 mio_expr (&cl
->length
);
2492 /* See if a name is a generated name. */
2495 check_unique_name (const char *name
)
2497 return *name
== '@';
2502 mio_typespec (gfc_typespec
*ts
)
2506 ts
->type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2508 if (ts
->type
!= BT_DERIVED
&& ts
->type
!= BT_CLASS
)
2509 mio_integer (&ts
->kind
);
2511 mio_symbol_ref (&ts
->u
.derived
);
2513 mio_symbol_ref (&ts
->interface
);
2515 /* Add info for C interop and is_iso_c. */
2516 mio_integer (&ts
->is_c_interop
);
2517 mio_integer (&ts
->is_iso_c
);
2519 /* If the typespec is for an identifier either from iso_c_binding, or
2520 a constant that was initialized to an identifier from it, use the
2521 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2523 ts
->f90_type
= MIO_NAME (bt
) (ts
->f90_type
, bt_types
);
2525 ts
->f90_type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2527 if (ts
->type
!= BT_CHARACTER
)
2529 /* ts->u.cl is only valid for BT_CHARACTER. */
2534 mio_charlen (&ts
->u
.cl
);
2536 /* So as not to disturb the existing API, use an ATOM_NAME to
2537 transmit deferred characteristic for characters (F2003). */
2538 if (iomode
== IO_OUTPUT
)
2540 if (ts
->type
== BT_CHARACTER
&& ts
->deferred
)
2541 write_atom (ATOM_NAME
, "DEFERRED_CL");
2543 else if (peek_atom () != ATOM_RPAREN
)
2545 if (parse_atom () != ATOM_NAME
)
2546 bad_module ("Expected string");
2554 static const mstring array_spec_types
[] = {
2555 minit ("EXPLICIT", AS_EXPLICIT
),
2556 minit ("ASSUMED_RANK", AS_ASSUMED_RANK
),
2557 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
2558 minit ("DEFERRED", AS_DEFERRED
),
2559 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
2565 mio_array_spec (gfc_array_spec
**asp
)
2572 if (iomode
== IO_OUTPUT
)
2580 /* mio_integer expects nonnegative values. */
2581 rank
= as
->rank
> 0 ? as
->rank
: 0;
2582 mio_integer (&rank
);
2586 if (peek_atom () == ATOM_RPAREN
)
2592 *asp
= as
= gfc_get_array_spec ();
2593 mio_integer (&as
->rank
);
2596 mio_integer (&as
->corank
);
2597 as
->type
= MIO_NAME (array_type
) (as
->type
, array_spec_types
);
2599 if (iomode
== IO_INPUT
&& as
->type
== AS_ASSUMED_RANK
)
2601 if (iomode
== IO_INPUT
&& as
->corank
)
2602 as
->cotype
= (as
->type
== AS_DEFERRED
) ? AS_DEFERRED
: AS_EXPLICIT
;
2604 if (as
->rank
+ as
->corank
> 0)
2605 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
2607 mio_expr (&as
->lower
[i
]);
2608 mio_expr (&as
->upper
[i
]);
2616 /* Given a pointer to an array reference structure (which lives in a
2617 gfc_ref structure), find the corresponding array specification
2618 structure. Storing the pointer in the ref structure doesn't quite
2619 work when loading from a module. Generating code for an array
2620 reference also needs more information than just the array spec. */
2622 static const mstring array_ref_types
[] = {
2623 minit ("FULL", AR_FULL
),
2624 minit ("ELEMENT", AR_ELEMENT
),
2625 minit ("SECTION", AR_SECTION
),
2631 mio_array_ref (gfc_array_ref
*ar
)
2636 ar
->type
= MIO_NAME (ar_type
) (ar
->type
, array_ref_types
);
2637 mio_integer (&ar
->dimen
);
2645 for (i
= 0; i
< ar
->dimen
; i
++)
2646 mio_expr (&ar
->start
[i
]);
2651 for (i
= 0; i
< ar
->dimen
; i
++)
2653 mio_expr (&ar
->start
[i
]);
2654 mio_expr (&ar
->end
[i
]);
2655 mio_expr (&ar
->stride
[i
]);
2661 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2664 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2665 we can't call mio_integer directly. Instead loop over each element
2666 and cast it to/from an integer. */
2667 if (iomode
== IO_OUTPUT
)
2669 for (i
= 0; i
< ar
->dimen
; i
++)
2671 int tmp
= (int)ar
->dimen_type
[i
];
2672 write_atom (ATOM_INTEGER
, &tmp
);
2677 for (i
= 0; i
< ar
->dimen
; i
++)
2679 require_atom (ATOM_INTEGER
);
2680 ar
->dimen_type
[i
] = (enum gfc_array_ref_dimen_type
) atom_int
;
2684 if (iomode
== IO_INPUT
)
2686 ar
->where
= gfc_current_locus
;
2688 for (i
= 0; i
< ar
->dimen
; i
++)
2689 ar
->c_where
[i
] = gfc_current_locus
;
2696 /* Saves or restores a pointer. The pointer is converted back and
2697 forth from an integer. We return the pointer_info pointer so that
2698 the caller can take additional action based on the pointer type. */
2700 static pointer_info
*
2701 mio_pointer_ref (void *gp
)
2705 if (iomode
== IO_OUTPUT
)
2707 p
= get_pointer (*((char **) gp
));
2708 write_atom (ATOM_INTEGER
, &p
->integer
);
2712 require_atom (ATOM_INTEGER
);
2713 p
= add_fixup (atom_int
, gp
);
2720 /* Save and load references to components that occur within
2721 expressions. We have to describe these references by a number and
2722 by name. The number is necessary for forward references during
2723 reading, and the name is necessary if the symbol already exists in
2724 the namespace and is not loaded again. */
2727 mio_component_ref (gfc_component
**cp
)
2731 p
= mio_pointer_ref (cp
);
2732 if (p
->type
== P_UNKNOWN
)
2733 p
->type
= P_COMPONENT
;
2737 static void mio_namespace_ref (gfc_namespace
**nsp
);
2738 static void mio_formal_arglist (gfc_formal_arglist
**formal
);
2739 static void mio_typebound_proc (gfc_typebound_proc
** proc
);
2742 mio_component (gfc_component
*c
, int vtype
)
2749 if (iomode
== IO_OUTPUT
)
2751 p
= get_pointer (c
);
2752 mio_integer (&p
->integer
);
2757 p
= get_integer (n
);
2758 associate_integer_pointer (p
, c
);
2761 if (p
->type
== P_UNKNOWN
)
2762 p
->type
= P_COMPONENT
;
2764 mio_pool_string (&c
->name
);
2765 mio_typespec (&c
->ts
);
2766 mio_array_spec (&c
->as
);
2768 mio_symbol_attribute (&c
->attr
);
2769 if (c
->ts
.type
== BT_CLASS
)
2770 c
->attr
.class_ok
= 1;
2771 c
->attr
.access
= MIO_NAME (gfc_access
) (c
->attr
.access
, access_types
);
2773 if (!vtype
|| strcmp (c
->name
, "_final") == 0
2774 || strcmp (c
->name
, "_hash") == 0)
2775 mio_expr (&c
->initializer
);
2777 if (c
->attr
.proc_pointer
)
2778 mio_typebound_proc (&c
->tb
);
2785 mio_component_list (gfc_component
**cp
, int vtype
)
2787 gfc_component
*c
, *tail
;
2791 if (iomode
== IO_OUTPUT
)
2793 for (c
= *cp
; c
; c
= c
->next
)
2794 mio_component (c
, vtype
);
2803 if (peek_atom () == ATOM_RPAREN
)
2806 c
= gfc_get_component ();
2807 mio_component (c
, vtype
);
2823 mio_actual_arg (gfc_actual_arglist
*a
)
2826 mio_pool_string (&a
->name
);
2827 mio_expr (&a
->expr
);
2833 mio_actual_arglist (gfc_actual_arglist
**ap
)
2835 gfc_actual_arglist
*a
, *tail
;
2839 if (iomode
== IO_OUTPUT
)
2841 for (a
= *ap
; a
; a
= a
->next
)
2851 if (peek_atom () != ATOM_LPAREN
)
2854 a
= gfc_get_actual_arglist ();
2870 /* Read and write formal argument lists. */
2873 mio_formal_arglist (gfc_formal_arglist
**formal
)
2875 gfc_formal_arglist
*f
, *tail
;
2879 if (iomode
== IO_OUTPUT
)
2881 for (f
= *formal
; f
; f
= f
->next
)
2882 mio_symbol_ref (&f
->sym
);
2886 *formal
= tail
= NULL
;
2888 while (peek_atom () != ATOM_RPAREN
)
2890 f
= gfc_get_formal_arglist ();
2891 mio_symbol_ref (&f
->sym
);
2893 if (*formal
== NULL
)
2906 /* Save or restore a reference to a symbol node. */
2909 mio_symbol_ref (gfc_symbol
**symp
)
2913 p
= mio_pointer_ref (symp
);
2914 if (p
->type
== P_UNKNOWN
)
2917 if (iomode
== IO_OUTPUT
)
2919 if (p
->u
.wsym
.state
== UNREFERENCED
)
2920 p
->u
.wsym
.state
= NEEDS_WRITE
;
2924 if (p
->u
.rsym
.state
== UNUSED
)
2925 p
->u
.rsym
.state
= NEEDED
;
2931 /* Save or restore a reference to a symtree node. */
2934 mio_symtree_ref (gfc_symtree
**stp
)
2939 if (iomode
== IO_OUTPUT
)
2940 mio_symbol_ref (&(*stp
)->n
.sym
);
2943 require_atom (ATOM_INTEGER
);
2944 p
= get_integer (atom_int
);
2946 /* An unused equivalence member; make a symbol and a symtree
2948 if (in_load_equiv
&& p
->u
.rsym
.symtree
== NULL
)
2950 /* Since this is not used, it must have a unique name. */
2951 p
->u
.rsym
.symtree
= gfc_get_unique_symtree (gfc_current_ns
);
2953 /* Make the symbol. */
2954 if (p
->u
.rsym
.sym
== NULL
)
2956 p
->u
.rsym
.sym
= gfc_new_symbol (p
->u
.rsym
.true_name
,
2958 p
->u
.rsym
.sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
2961 p
->u
.rsym
.symtree
->n
.sym
= p
->u
.rsym
.sym
;
2962 p
->u
.rsym
.symtree
->n
.sym
->refs
++;
2963 p
->u
.rsym
.referenced
= 1;
2965 /* If the symbol is PRIVATE and in COMMON, load_commons will
2966 generate a fixup symbol, which must be associated. */
2968 resolve_fixups (p
->fixup
, p
->u
.rsym
.sym
);
2972 if (p
->type
== P_UNKNOWN
)
2975 if (p
->u
.rsym
.state
== UNUSED
)
2976 p
->u
.rsym
.state
= NEEDED
;
2978 if (p
->u
.rsym
.symtree
!= NULL
)
2980 *stp
= p
->u
.rsym
.symtree
;
2984 f
= XCNEW (fixup_t
);
2986 f
->next
= p
->u
.rsym
.stfixup
;
2987 p
->u
.rsym
.stfixup
= f
;
2989 f
->pointer
= (void **) stp
;
2996 mio_iterator (gfc_iterator
**ip
)
3002 if (iomode
== IO_OUTPUT
)
3009 if (peek_atom () == ATOM_RPAREN
)
3015 *ip
= gfc_get_iterator ();
3020 mio_expr (&iter
->var
);
3021 mio_expr (&iter
->start
);
3022 mio_expr (&iter
->end
);
3023 mio_expr (&iter
->step
);
3031 mio_constructor (gfc_constructor_base
*cp
)
3037 if (iomode
== IO_OUTPUT
)
3039 for (c
= gfc_constructor_first (*cp
); c
; c
= gfc_constructor_next (c
))
3042 mio_expr (&c
->expr
);
3043 mio_iterator (&c
->iterator
);
3049 while (peek_atom () != ATOM_RPAREN
)
3051 c
= gfc_constructor_append_expr (cp
, NULL
, NULL
);
3054 mio_expr (&c
->expr
);
3055 mio_iterator (&c
->iterator
);
3064 static const mstring ref_types
[] = {
3065 minit ("ARRAY", REF_ARRAY
),
3066 minit ("COMPONENT", REF_COMPONENT
),
3067 minit ("SUBSTRING", REF_SUBSTRING
),
3073 mio_ref (gfc_ref
**rp
)
3080 r
->type
= MIO_NAME (ref_type
) (r
->type
, ref_types
);
3085 mio_array_ref (&r
->u
.ar
);
3089 mio_symbol_ref (&r
->u
.c
.sym
);
3090 mio_component_ref (&r
->u
.c
.component
);
3094 mio_expr (&r
->u
.ss
.start
);
3095 mio_expr (&r
->u
.ss
.end
);
3096 mio_charlen (&r
->u
.ss
.length
);
3105 mio_ref_list (gfc_ref
**rp
)
3107 gfc_ref
*ref
, *head
, *tail
;
3111 if (iomode
== IO_OUTPUT
)
3113 for (ref
= *rp
; ref
; ref
= ref
->next
)
3120 while (peek_atom () != ATOM_RPAREN
)
3123 head
= tail
= gfc_get_ref ();
3126 tail
->next
= gfc_get_ref ();
3140 /* Read and write an integer value. */
3143 mio_gmp_integer (mpz_t
*integer
)
3147 if (iomode
== IO_INPUT
)
3149 if (parse_atom () != ATOM_STRING
)
3150 bad_module ("Expected integer string");
3152 mpz_init (*integer
);
3153 if (mpz_set_str (*integer
, atom_string
, 10))
3154 bad_module ("Error converting integer");
3160 p
= mpz_get_str (NULL
, 10, *integer
);
3161 write_atom (ATOM_STRING
, p
);
3168 mio_gmp_real (mpfr_t
*real
)
3173 if (iomode
== IO_INPUT
)
3175 if (parse_atom () != ATOM_STRING
)
3176 bad_module ("Expected real string");
3179 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
3184 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
3186 if (mpfr_nan_p (*real
) || mpfr_inf_p (*real
))
3188 write_atom (ATOM_STRING
, p
);
3193 atom_string
= XCNEWVEC (char, strlen (p
) + 20);
3195 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
3197 /* Fix negative numbers. */
3198 if (atom_string
[2] == '-')
3200 atom_string
[0] = '-';
3201 atom_string
[1] = '0';
3202 atom_string
[2] = '.';
3205 write_atom (ATOM_STRING
, atom_string
);
3213 /* Save and restore the shape of an array constructor. */
3216 mio_shape (mpz_t
**pshape
, int rank
)
3222 /* A NULL shape is represented by (). */
3225 if (iomode
== IO_OUTPUT
)
3237 if (t
== ATOM_RPAREN
)
3244 shape
= gfc_get_shape (rank
);
3248 for (n
= 0; n
< rank
; n
++)
3249 mio_gmp_integer (&shape
[n
]);
3255 static const mstring expr_types
[] = {
3256 minit ("OP", EXPR_OP
),
3257 minit ("FUNCTION", EXPR_FUNCTION
),
3258 minit ("CONSTANT", EXPR_CONSTANT
),
3259 minit ("VARIABLE", EXPR_VARIABLE
),
3260 minit ("SUBSTRING", EXPR_SUBSTRING
),
3261 minit ("STRUCTURE", EXPR_STRUCTURE
),
3262 minit ("ARRAY", EXPR_ARRAY
),
3263 minit ("NULL", EXPR_NULL
),
3264 minit ("COMPCALL", EXPR_COMPCALL
),
3268 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3269 generic operators, not in expressions. INTRINSIC_USER is also
3270 replaced by the correct function name by the time we see it. */
3272 static const mstring intrinsics
[] =
3274 minit ("UPLUS", INTRINSIC_UPLUS
),
3275 minit ("UMINUS", INTRINSIC_UMINUS
),
3276 minit ("PLUS", INTRINSIC_PLUS
),
3277 minit ("MINUS", INTRINSIC_MINUS
),
3278 minit ("TIMES", INTRINSIC_TIMES
),
3279 minit ("DIVIDE", INTRINSIC_DIVIDE
),
3280 minit ("POWER", INTRINSIC_POWER
),
3281 minit ("CONCAT", INTRINSIC_CONCAT
),
3282 minit ("AND", INTRINSIC_AND
),
3283 minit ("OR", INTRINSIC_OR
),
3284 minit ("EQV", INTRINSIC_EQV
),
3285 minit ("NEQV", INTRINSIC_NEQV
),
3286 minit ("EQ_SIGN", INTRINSIC_EQ
),
3287 minit ("EQ", INTRINSIC_EQ_OS
),
3288 minit ("NE_SIGN", INTRINSIC_NE
),
3289 minit ("NE", INTRINSIC_NE_OS
),
3290 minit ("GT_SIGN", INTRINSIC_GT
),
3291 minit ("GT", INTRINSIC_GT_OS
),
3292 minit ("GE_SIGN", INTRINSIC_GE
),
3293 minit ("GE", INTRINSIC_GE_OS
),
3294 minit ("LT_SIGN", INTRINSIC_LT
),
3295 minit ("LT", INTRINSIC_LT_OS
),
3296 minit ("LE_SIGN", INTRINSIC_LE
),
3297 minit ("LE", INTRINSIC_LE_OS
),
3298 minit ("NOT", INTRINSIC_NOT
),
3299 minit ("PARENTHESES", INTRINSIC_PARENTHESES
),
3300 minit ("USER", INTRINSIC_USER
),
3305 /* Remedy a couple of situations where the gfc_expr's can be defective. */
3308 fix_mio_expr (gfc_expr
*e
)
3310 gfc_symtree
*ns_st
= NULL
;
3313 if (iomode
!= IO_OUTPUT
)
3318 /* If this is a symtree for a symbol that came from a contained module
3319 namespace, it has a unique name and we should look in the current
3320 namespace to see if the required, non-contained symbol is available
3321 yet. If so, the latter should be written. */
3322 if (e
->symtree
->n
.sym
&& check_unique_name (e
->symtree
->name
))
3324 const char *name
= e
->symtree
->n
.sym
->name
;
3325 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_DERIVED
)
3326 name
= dt_upper_string (name
);
3327 ns_st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3330 /* On the other hand, if the existing symbol is the module name or the
3331 new symbol is a dummy argument, do not do the promotion. */
3332 if (ns_st
&& ns_st
->n
.sym
3333 && ns_st
->n
.sym
->attr
.flavor
!= FL_MODULE
3334 && !e
->symtree
->n
.sym
->attr
.dummy
)
3337 else if (e
->expr_type
== EXPR_FUNCTION
3338 && (e
->value
.function
.name
|| e
->value
.function
.isym
))
3342 /* In some circumstances, a function used in an initialization
3343 expression, in one use associated module, can fail to be
3344 coupled to its symtree when used in a specification
3345 expression in another module. */
3346 fname
= e
->value
.function
.esym
? e
->value
.function
.esym
->name
3347 : e
->value
.function
.isym
->name
;
3348 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3353 /* This is probably a reference to a private procedure from another
3354 module. To prevent a segfault, make a generic with no specific
3355 instances. If this module is used, without the required
3356 specific coming from somewhere, the appropriate error message
3358 gfc_get_symbol (fname
, gfc_current_ns
, &sym
);
3359 sym
->attr
.flavor
= FL_PROCEDURE
;
3360 sym
->attr
.generic
= 1;
3361 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3362 gfc_commit_symbol (sym
);
3367 /* Read and write expressions. The form "()" is allowed to indicate a
3371 mio_expr (gfc_expr
**ep
)
3379 if (iomode
== IO_OUTPUT
)
3388 MIO_NAME (expr_t
) (e
->expr_type
, expr_types
);
3393 if (t
== ATOM_RPAREN
)
3400 bad_module ("Expected expression type");
3402 e
= *ep
= gfc_get_expr ();
3403 e
->where
= gfc_current_locus
;
3404 e
->expr_type
= (expr_t
) find_enum (expr_types
);
3407 mio_typespec (&e
->ts
);
3408 mio_integer (&e
->rank
);
3412 switch (e
->expr_type
)
3416 = MIO_NAME (gfc_intrinsic_op
) (e
->value
.op
.op
, intrinsics
);
3418 switch (e
->value
.op
.op
)
3420 case INTRINSIC_UPLUS
:
3421 case INTRINSIC_UMINUS
:
3423 case INTRINSIC_PARENTHESES
:
3424 mio_expr (&e
->value
.op
.op1
);
3427 case INTRINSIC_PLUS
:
3428 case INTRINSIC_MINUS
:
3429 case INTRINSIC_TIMES
:
3430 case INTRINSIC_DIVIDE
:
3431 case INTRINSIC_POWER
:
3432 case INTRINSIC_CONCAT
:
3436 case INTRINSIC_NEQV
:
3438 case INTRINSIC_EQ_OS
:
3440 case INTRINSIC_NE_OS
:
3442 case INTRINSIC_GT_OS
:
3444 case INTRINSIC_GE_OS
:
3446 case INTRINSIC_LT_OS
:
3448 case INTRINSIC_LE_OS
:
3449 mio_expr (&e
->value
.op
.op1
);
3450 mio_expr (&e
->value
.op
.op2
);
3453 case INTRINSIC_USER
:
3454 /* INTRINSIC_USER should not appear in resolved expressions,
3455 though for UDRs we need to stream unresolved ones. */
3456 if (iomode
== IO_OUTPUT
)
3457 write_atom (ATOM_STRING
, e
->value
.op
.uop
->name
);
3460 char *name
= read_string ();
3461 const char *uop_name
= find_use_name (name
, true);
3462 if (uop_name
== NULL
)
3464 size_t len
= strlen (name
);
3465 char *name2
= XCNEWVEC (char, len
+ 2);
3466 memcpy (name2
, name
, len
);
3468 name2
[len
+ 1] = '\0';
3470 uop_name
= name
= name2
;
3472 e
->value
.op
.uop
= gfc_get_uop (uop_name
);
3475 mio_expr (&e
->value
.op
.op1
);
3476 mio_expr (&e
->value
.op
.op2
);
3480 bad_module ("Bad operator");
3486 mio_symtree_ref (&e
->symtree
);
3487 mio_actual_arglist (&e
->value
.function
.actual
);
3489 if (iomode
== IO_OUTPUT
)
3491 e
->value
.function
.name
3492 = mio_allocated_string (e
->value
.function
.name
);
3493 if (e
->value
.function
.esym
)
3497 else if (e
->value
.function
.isym
== NULL
)
3501 mio_integer (&flag
);
3505 mio_symbol_ref (&e
->value
.function
.esym
);
3508 mio_ref_list (&e
->ref
);
3513 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
3518 require_atom (ATOM_STRING
);
3519 if (atom_string
[0] == '\0')
3520 e
->value
.function
.name
= NULL
;
3522 e
->value
.function
.name
= gfc_get_string (atom_string
);
3525 mio_integer (&flag
);
3529 mio_symbol_ref (&e
->value
.function
.esym
);
3532 mio_ref_list (&e
->ref
);
3537 require_atom (ATOM_STRING
);
3538 e
->value
.function
.isym
= gfc_find_function (atom_string
);
3546 mio_symtree_ref (&e
->symtree
);
3547 mio_ref_list (&e
->ref
);
3550 case EXPR_SUBSTRING
:
3551 e
->value
.character
.string
3552 = CONST_CAST (gfc_char_t
*,
3553 mio_allocated_wide_string (e
->value
.character
.string
,
3554 e
->value
.character
.length
));
3555 mio_ref_list (&e
->ref
);
3558 case EXPR_STRUCTURE
:
3560 mio_constructor (&e
->value
.constructor
);
3561 mio_shape (&e
->shape
, e
->rank
);
3568 mio_gmp_integer (&e
->value
.integer
);
3572 gfc_set_model_kind (e
->ts
.kind
);
3573 mio_gmp_real (&e
->value
.real
);
3577 gfc_set_model_kind (e
->ts
.kind
);
3578 mio_gmp_real (&mpc_realref (e
->value
.complex));
3579 mio_gmp_real (&mpc_imagref (e
->value
.complex));
3583 mio_integer (&e
->value
.logical
);
3587 mio_integer (&e
->value
.character
.length
);
3588 e
->value
.character
.string
3589 = CONST_CAST (gfc_char_t
*,
3590 mio_allocated_wide_string (e
->value
.character
.string
,
3591 e
->value
.character
.length
));
3595 bad_module ("Bad type in constant expression");
3613 /* Read and write namelists. */
3616 mio_namelist (gfc_symbol
*sym
)
3618 gfc_namelist
*n
, *m
;
3619 const char *check_name
;
3623 if (iomode
== IO_OUTPUT
)
3625 for (n
= sym
->namelist
; n
; n
= n
->next
)
3626 mio_symbol_ref (&n
->sym
);
3630 /* This departure from the standard is flagged as an error.
3631 It does, in fact, work correctly. TODO: Allow it
3633 if (sym
->attr
.flavor
== FL_NAMELIST
)
3635 check_name
= find_use_name (sym
->name
, false);
3636 if (check_name
&& strcmp (check_name
, sym
->name
) != 0)
3637 gfc_error ("Namelist %s cannot be renamed by USE "
3638 "association to %s", sym
->name
, check_name
);
3642 while (peek_atom () != ATOM_RPAREN
)
3644 n
= gfc_get_namelist ();
3645 mio_symbol_ref (&n
->sym
);
3647 if (sym
->namelist
== NULL
)
3654 sym
->namelist_tail
= m
;
3661 /* Save/restore lists of gfc_interface structures. When loading an
3662 interface, we are really appending to the existing list of
3663 interfaces. Checking for duplicate and ambiguous interfaces has to
3664 be done later when all symbols have been loaded. */
3667 mio_interface_rest (gfc_interface
**ip
)
3669 gfc_interface
*tail
, *p
;
3670 pointer_info
*pi
= NULL
;
3672 if (iomode
== IO_OUTPUT
)
3675 for (p
= *ip
; p
; p
= p
->next
)
3676 mio_symbol_ref (&p
->sym
);
3691 if (peek_atom () == ATOM_RPAREN
)
3694 p
= gfc_get_interface ();
3695 p
->where
= gfc_current_locus
;
3696 pi
= mio_symbol_ref (&p
->sym
);
3712 /* Save/restore a nameless operator interface. */
3715 mio_interface (gfc_interface
**ip
)
3718 mio_interface_rest (ip
);
3722 /* Save/restore a named operator interface. */
3725 mio_symbol_interface (const char **name
, const char **module
,
3729 mio_pool_string (name
);
3730 mio_pool_string (module
);
3731 mio_interface_rest (ip
);
3736 mio_namespace_ref (gfc_namespace
**nsp
)
3741 p
= mio_pointer_ref (nsp
);
3743 if (p
->type
== P_UNKNOWN
)
3744 p
->type
= P_NAMESPACE
;
3746 if (iomode
== IO_INPUT
&& p
->integer
!= 0)
3748 ns
= (gfc_namespace
*) p
->u
.pointer
;
3751 ns
= gfc_get_namespace (NULL
, 0);
3752 associate_integer_pointer (p
, ns
);
3760 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
3762 static gfc_namespace
* current_f2k_derived
;
3765 mio_typebound_proc (gfc_typebound_proc
** proc
)
3768 int overriding_flag
;
3770 if (iomode
== IO_INPUT
)
3772 *proc
= gfc_get_typebound_proc (NULL
);
3773 (*proc
)->where
= gfc_current_locus
;
3779 (*proc
)->access
= MIO_NAME (gfc_access
) ((*proc
)->access
, access_types
);
3781 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
3782 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3783 overriding_flag
= ((*proc
)->deferred
<< 1) | (*proc
)->non_overridable
;
3784 overriding_flag
= mio_name (overriding_flag
, binding_overriding
);
3785 (*proc
)->deferred
= ((overriding_flag
& 2) != 0);
3786 (*proc
)->non_overridable
= ((overriding_flag
& 1) != 0);
3787 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3789 (*proc
)->nopass
= mio_name ((*proc
)->nopass
, binding_passing
);
3790 (*proc
)->is_generic
= mio_name ((*proc
)->is_generic
, binding_generic
);
3791 (*proc
)->ppc
= mio_name((*proc
)->ppc
, binding_ppc
);
3793 mio_pool_string (&((*proc
)->pass_arg
));
3795 flag
= (int) (*proc
)->pass_arg_num
;
3796 mio_integer (&flag
);
3797 (*proc
)->pass_arg_num
= (unsigned) flag
;
3799 if ((*proc
)->is_generic
)
3806 if (iomode
== IO_OUTPUT
)
3807 for (g
= (*proc
)->u
.generic
; g
; g
= g
->next
)
3809 iop
= (int) g
->is_operator
;
3811 mio_allocated_string (g
->specific_st
->name
);
3815 (*proc
)->u
.generic
= NULL
;
3816 while (peek_atom () != ATOM_RPAREN
)
3818 gfc_symtree
** sym_root
;
3820 g
= gfc_get_tbp_generic ();
3824 g
->is_operator
= (bool) iop
;
3826 require_atom (ATOM_STRING
);
3827 sym_root
= ¤t_f2k_derived
->tb_sym_root
;
3828 g
->specific_st
= gfc_get_tbp_symtree (sym_root
, atom_string
);
3831 g
->next
= (*proc
)->u
.generic
;
3832 (*proc
)->u
.generic
= g
;
3838 else if (!(*proc
)->ppc
)
3839 mio_symtree_ref (&(*proc
)->u
.specific
);
3844 /* Walker-callback function for this purpose. */
3846 mio_typebound_symtree (gfc_symtree
* st
)
3848 if (iomode
== IO_OUTPUT
&& !st
->n
.tb
)
3851 if (iomode
== IO_OUTPUT
)
3854 mio_allocated_string (st
->name
);
3856 /* For IO_INPUT, the above is done in mio_f2k_derived. */
3858 mio_typebound_proc (&st
->n
.tb
);
3862 /* IO a full symtree (in all depth). */
3864 mio_full_typebound_tree (gfc_symtree
** root
)
3868 if (iomode
== IO_OUTPUT
)
3869 gfc_traverse_symtree (*root
, &mio_typebound_symtree
);
3872 while (peek_atom () == ATOM_LPAREN
)
3878 require_atom (ATOM_STRING
);
3879 st
= gfc_get_tbp_symtree (root
, atom_string
);
3882 mio_typebound_symtree (st
);
3890 mio_finalizer (gfc_finalizer
**f
)
3892 if (iomode
== IO_OUTPUT
)
3895 gcc_assert ((*f
)->proc_tree
); /* Should already be resolved. */
3896 mio_symtree_ref (&(*f
)->proc_tree
);
3900 *f
= gfc_get_finalizer ();
3901 (*f
)->where
= gfc_current_locus
; /* Value should not matter. */
3904 mio_symtree_ref (&(*f
)->proc_tree
);
3905 (*f
)->proc_sym
= NULL
;
3910 mio_f2k_derived (gfc_namespace
*f2k
)
3912 current_f2k_derived
= f2k
;
3914 /* Handle the list of finalizer procedures. */
3916 if (iomode
== IO_OUTPUT
)
3919 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
3924 f2k
->finalizers
= NULL
;
3925 while (peek_atom () != ATOM_RPAREN
)
3927 gfc_finalizer
*cur
= NULL
;
3928 mio_finalizer (&cur
);
3929 cur
->next
= f2k
->finalizers
;
3930 f2k
->finalizers
= cur
;
3935 /* Handle type-bound procedures. */
3936 mio_full_typebound_tree (&f2k
->tb_sym_root
);
3938 /* Type-bound user operators. */
3939 mio_full_typebound_tree (&f2k
->tb_uop_root
);
3941 /* Type-bound intrinsic operators. */
3943 if (iomode
== IO_OUTPUT
)
3946 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
3948 gfc_intrinsic_op realop
;
3950 if (op
== INTRINSIC_USER
|| !f2k
->tb_op
[op
])
3954 realop
= (gfc_intrinsic_op
) op
;
3955 mio_intrinsic_op (&realop
);
3956 mio_typebound_proc (&f2k
->tb_op
[op
]);
3961 while (peek_atom () != ATOM_RPAREN
)
3963 gfc_intrinsic_op op
= GFC_INTRINSIC_BEGIN
; /* Silence GCC. */
3966 mio_intrinsic_op (&op
);
3967 mio_typebound_proc (&f2k
->tb_op
[op
]);
3974 mio_full_f2k_derived (gfc_symbol
*sym
)
3978 if (iomode
== IO_OUTPUT
)
3980 if (sym
->f2k_derived
)
3981 mio_f2k_derived (sym
->f2k_derived
);
3985 if (peek_atom () != ATOM_RPAREN
)
3987 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
3988 mio_f2k_derived (sym
->f2k_derived
);
3991 gcc_assert (!sym
->f2k_derived
);
3997 static const mstring omp_declare_simd_clauses
[] =
3999 minit ("INBRANCH", 0),
4000 minit ("NOTINBRANCH", 1),
4001 minit ("SIMDLEN", 2),
4002 minit ("UNIFORM", 3),
4003 minit ("LINEAR", 4),
4004 minit ("ALIGNED", 5),
4008 /* Handle !$omp declare simd. */
4011 mio_omp_declare_simd (gfc_namespace
*ns
, gfc_omp_declare_simd
**odsp
)
4013 if (iomode
== IO_OUTPUT
)
4018 else if (peek_atom () != ATOM_LPAREN
)
4021 gfc_omp_declare_simd
*ods
= *odsp
;
4024 if (iomode
== IO_OUTPUT
)
4026 write_atom (ATOM_NAME
, "OMP_DECLARE_SIMD");
4029 gfc_omp_namelist
*n
;
4031 if (ods
->clauses
->inbranch
)
4032 mio_name (0, omp_declare_simd_clauses
);
4033 if (ods
->clauses
->notinbranch
)
4034 mio_name (1, omp_declare_simd_clauses
);
4035 if (ods
->clauses
->simdlen_expr
)
4037 mio_name (2, omp_declare_simd_clauses
);
4038 mio_expr (&ods
->clauses
->simdlen_expr
);
4040 for (n
= ods
->clauses
->lists
[OMP_LIST_UNIFORM
]; n
; n
= n
->next
)
4042 mio_name (3, omp_declare_simd_clauses
);
4043 mio_symbol_ref (&n
->sym
);
4045 for (n
= ods
->clauses
->lists
[OMP_LIST_LINEAR
]; n
; n
= n
->next
)
4047 mio_name (4, omp_declare_simd_clauses
);
4048 mio_symbol_ref (&n
->sym
);
4049 mio_expr (&n
->expr
);
4051 for (n
= ods
->clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
4053 mio_name (5, omp_declare_simd_clauses
);
4054 mio_symbol_ref (&n
->sym
);
4055 mio_expr (&n
->expr
);
4061 gfc_omp_namelist
**ptrs
[3] = { NULL
, NULL
, NULL
};
4063 require_atom (ATOM_NAME
);
4064 *odsp
= ods
= gfc_get_omp_declare_simd ();
4065 ods
->where
= gfc_current_locus
;
4066 ods
->proc_name
= ns
->proc_name
;
4067 if (peek_atom () == ATOM_NAME
)
4069 ods
->clauses
= gfc_get_omp_clauses ();
4070 ptrs
[0] = &ods
->clauses
->lists
[OMP_LIST_UNIFORM
];
4071 ptrs
[1] = &ods
->clauses
->lists
[OMP_LIST_LINEAR
];
4072 ptrs
[2] = &ods
->clauses
->lists
[OMP_LIST_ALIGNED
];
4074 while (peek_atom () == ATOM_NAME
)
4076 gfc_omp_namelist
*n
;
4077 int t
= mio_name (0, omp_declare_simd_clauses
);
4081 case 0: ods
->clauses
->inbranch
= true; break;
4082 case 1: ods
->clauses
->notinbranch
= true; break;
4083 case 2: mio_expr (&ods
->clauses
->simdlen_expr
); break;
4087 *ptrs
[t
- 3] = n
= gfc_get_omp_namelist ();
4088 ptrs
[t
- 3] = &n
->next
;
4089 mio_symbol_ref (&n
->sym
);
4091 mio_expr (&n
->expr
);
4097 mio_omp_declare_simd (ns
, &ods
->next
);
4103 static const mstring omp_declare_reduction_stmt
[] =
4105 minit ("ASSIGN", 0),
4112 mio_omp_udr_expr (gfc_omp_udr
*udr
, gfc_symbol
**sym1
, gfc_symbol
**sym2
,
4113 gfc_namespace
*ns
, bool is_initializer
)
4115 if (iomode
== IO_OUTPUT
)
4117 if ((*sym1
)->module
== NULL
)
4119 (*sym1
)->module
= module_name
;
4120 (*sym2
)->module
= module_name
;
4122 mio_symbol_ref (sym1
);
4123 mio_symbol_ref (sym2
);
4124 if (ns
->code
->op
== EXEC_ASSIGN
)
4126 mio_name (0, omp_declare_reduction_stmt
);
4127 mio_expr (&ns
->code
->expr1
);
4128 mio_expr (&ns
->code
->expr2
);
4133 mio_name (1, omp_declare_reduction_stmt
);
4134 mio_symtree_ref (&ns
->code
->symtree
);
4135 mio_actual_arglist (&ns
->code
->ext
.actual
);
4137 flag
= ns
->code
->resolved_isym
!= NULL
;
4138 mio_integer (&flag
);
4140 write_atom (ATOM_STRING
, ns
->code
->resolved_isym
->name
);
4142 mio_symbol_ref (&ns
->code
->resolved_sym
);
4147 pointer_info
*p1
= mio_symbol_ref (sym1
);
4148 pointer_info
*p2
= mio_symbol_ref (sym2
);
4150 gcc_assert (p1
->u
.rsym
.ns
== p2
->u
.rsym
.ns
);
4151 gcc_assert (p1
->u
.rsym
.sym
== NULL
);
4152 /* Add hidden symbols to the symtree. */
4153 pointer_info
*q
= get_integer (p1
->u
.rsym
.ns
);
4154 q
->u
.pointer
= (void *) ns
;
4155 sym
= gfc_new_symbol (is_initializer
? "omp_priv" : "omp_out", ns
);
4157 sym
->module
= gfc_get_string (p1
->u
.rsym
.module
);
4158 associate_integer_pointer (p1
, sym
);
4159 sym
->attr
.omp_udr_artificial_var
= 1;
4160 gcc_assert (p2
->u
.rsym
.sym
== NULL
);
4161 sym
= gfc_new_symbol (is_initializer
? "omp_orig" : "omp_in", ns
);
4163 sym
->module
= gfc_get_string (p2
->u
.rsym
.module
);
4164 associate_integer_pointer (p2
, sym
);
4165 sym
->attr
.omp_udr_artificial_var
= 1;
4166 if (mio_name (0, omp_declare_reduction_stmt
) == 0)
4168 ns
->code
= gfc_get_code (EXEC_ASSIGN
);
4169 mio_expr (&ns
->code
->expr1
);
4170 mio_expr (&ns
->code
->expr2
);
4175 ns
->code
= gfc_get_code (EXEC_CALL
);
4176 mio_symtree_ref (&ns
->code
->symtree
);
4177 mio_actual_arglist (&ns
->code
->ext
.actual
);
4179 mio_integer (&flag
);
4182 require_atom (ATOM_STRING
);
4183 ns
->code
->resolved_isym
= gfc_find_subroutine (atom_string
);
4187 mio_symbol_ref (&ns
->code
->resolved_sym
);
4189 ns
->code
->loc
= gfc_current_locus
;
4195 /* Unlike most other routines, the address of the symbol node is already
4196 fixed on input and the name/module has already been filled in.
4197 If you update the symbol format here, don't forget to update read_module
4198 as well (look for "seek to the symbol's component list"). */
4201 mio_symbol (gfc_symbol
*sym
)
4203 int intmod
= INTMOD_NONE
;
4207 mio_symbol_attribute (&sym
->attr
);
4209 /* Note that components are always saved, even if they are supposed
4210 to be private. Component access is checked during searching. */
4211 mio_component_list (&sym
->components
, sym
->attr
.vtype
);
4212 if (sym
->components
!= NULL
)
4213 sym
->component_access
4214 = MIO_NAME (gfc_access
) (sym
->component_access
, access_types
);
4216 mio_typespec (&sym
->ts
);
4217 if (sym
->ts
.type
== BT_CLASS
)
4218 sym
->attr
.class_ok
= 1;
4220 if (iomode
== IO_OUTPUT
)
4221 mio_namespace_ref (&sym
->formal_ns
);
4224 mio_namespace_ref (&sym
->formal_ns
);
4226 sym
->formal_ns
->proc_name
= sym
;
4229 /* Save/restore common block links. */
4230 mio_symbol_ref (&sym
->common_next
);
4232 mio_formal_arglist (&sym
->formal
);
4234 if (sym
->attr
.flavor
== FL_PARAMETER
)
4235 mio_expr (&sym
->value
);
4237 mio_array_spec (&sym
->as
);
4239 mio_symbol_ref (&sym
->result
);
4241 if (sym
->attr
.cray_pointee
)
4242 mio_symbol_ref (&sym
->cp_pointer
);
4244 /* Load/save the f2k_derived namespace of a derived-type symbol. */
4245 mio_full_f2k_derived (sym
);
4249 /* Add the fields that say whether this is from an intrinsic module,
4250 and if so, what symbol it is within the module. */
4251 /* mio_integer (&(sym->from_intmod)); */
4252 if (iomode
== IO_OUTPUT
)
4254 intmod
= sym
->from_intmod
;
4255 mio_integer (&intmod
);
4259 mio_integer (&intmod
);
4261 sym
->from_intmod
= current_intmod
;
4263 sym
->from_intmod
= (intmod_id
) intmod
;
4266 mio_integer (&(sym
->intmod_sym_id
));
4268 if (sym
->attr
.flavor
== FL_DERIVED
)
4269 mio_integer (&(sym
->hash_value
));
4272 && sym
->formal_ns
->proc_name
== sym
4273 && sym
->formal_ns
->entries
== NULL
)
4274 mio_omp_declare_simd (sym
->formal_ns
, &sym
->formal_ns
->omp_declare_simd
);
4280 /************************* Top level subroutines *************************/
4282 /* Given a root symtree node and a symbol, try to find a symtree that
4283 references the symbol that is not a unique name. */
4285 static gfc_symtree
*
4286 find_symtree_for_symbol (gfc_symtree
*st
, gfc_symbol
*sym
)
4288 gfc_symtree
*s
= NULL
;
4293 s
= find_symtree_for_symbol (st
->right
, sym
);
4296 s
= find_symtree_for_symbol (st
->left
, sym
);
4300 if (st
->n
.sym
== sym
&& !check_unique_name (st
->name
))
4307 /* A recursive function to look for a specific symbol by name and by
4308 module. Whilst several symtrees might point to one symbol, its
4309 is sufficient for the purposes here than one exist. Note that
4310 generic interfaces are distinguished as are symbols that have been
4311 renamed in another module. */
4312 static gfc_symtree
*
4313 find_symbol (gfc_symtree
*st
, const char *name
,
4314 const char *module
, int generic
)
4317 gfc_symtree
*retval
, *s
;
4319 if (st
== NULL
|| st
->n
.sym
== NULL
)
4322 c
= strcmp (name
, st
->n
.sym
->name
);
4323 if (c
== 0 && st
->n
.sym
->module
4324 && strcmp (module
, st
->n
.sym
->module
) == 0
4325 && !check_unique_name (st
->name
))
4327 s
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4329 /* Detect symbols that are renamed by use association in another
4330 module by the absence of a symtree and null attr.use_rename,
4331 since the latter is not transmitted in the module file. */
4332 if (((!generic
&& !st
->n
.sym
->attr
.generic
)
4333 || (generic
&& st
->n
.sym
->attr
.generic
))
4334 && !(s
== NULL
&& !st
->n
.sym
->attr
.use_rename
))
4338 retval
= find_symbol (st
->left
, name
, module
, generic
);
4341 retval
= find_symbol (st
->right
, name
, module
, generic
);
4347 /* Skip a list between balanced left and right parens.
4348 By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
4349 have been already parsed by hand, and the remaining of the content is to be
4350 skipped here. The default value is 0 (balanced parens). */
4353 skip_list (int nest_level
= 0)
4360 switch (parse_atom ())
4383 /* Load operator interfaces from the module. Interfaces are unusual
4384 in that they attach themselves to existing symbols. */
4387 load_operator_interfaces (void)
4390 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
4392 pointer_info
*pi
= NULL
;
4397 while (peek_atom () != ATOM_RPAREN
)
4401 mio_internal_string (name
);
4402 mio_internal_string (module
);
4404 n
= number_use_names (name
, true);
4407 for (i
= 1; i
<= n
; i
++)
4409 /* Decide if we need to load this one or not. */
4410 p
= find_use_name_n (name
, &i
, true);
4414 while (parse_atom () != ATOM_RPAREN
);
4420 uop
= gfc_get_uop (p
);
4421 pi
= mio_interface_rest (&uop
->op
);
4425 if (gfc_find_uop (p
, NULL
))
4427 uop
= gfc_get_uop (p
);
4428 uop
->op
= gfc_get_interface ();
4429 uop
->op
->where
= gfc_current_locus
;
4430 add_fixup (pi
->integer
, &uop
->op
->sym
);
4439 /* Load interfaces from the module. Interfaces are unusual in that
4440 they attach themselves to existing symbols. */
4443 load_generic_interfaces (void)
4446 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
4448 gfc_interface
*generic
= NULL
, *gen
= NULL
;
4450 bool ambiguous_set
= false;
4454 while (peek_atom () != ATOM_RPAREN
)
4458 mio_internal_string (name
);
4459 mio_internal_string (module
);
4461 n
= number_use_names (name
, false);
4462 renamed
= n
? 1 : 0;
4465 for (i
= 1; i
<= n
; i
++)
4468 /* Decide if we need to load this one or not. */
4469 p
= find_use_name_n (name
, &i
, false);
4471 st
= find_symbol (gfc_current_ns
->sym_root
,
4472 name
, module_name
, 1);
4474 if (!p
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
4476 /* Skip the specific names for these cases. */
4477 while (i
== 1 && parse_atom () != ATOM_RPAREN
);
4482 /* If the symbol exists already and is being USEd without being
4483 in an ONLY clause, do not load a new symtree(11.3.2). */
4484 if (!only_flag
&& st
)
4492 if (strcmp (st
->name
, p
) != 0)
4494 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4500 /* Since we haven't found a valid generic interface, we had
4504 gfc_get_symbol (p
, NULL
, &sym
);
4505 sym
->name
= gfc_get_string (name
);
4506 sym
->module
= module_name
;
4507 sym
->attr
.flavor
= FL_PROCEDURE
;
4508 sym
->attr
.generic
= 1;
4509 sym
->attr
.use_assoc
= 1;
4514 /* Unless sym is a generic interface, this reference
4517 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4521 if (st
&& !sym
->attr
.generic
4524 && strcmp (module
, sym
->module
))
4526 ambiguous_set
= true;
4531 sym
->attr
.use_only
= only_flag
;
4532 sym
->attr
.use_rename
= renamed
;
4536 mio_interface_rest (&sym
->generic
);
4537 generic
= sym
->generic
;
4539 else if (!sym
->generic
)
4541 sym
->generic
= generic
;
4542 sym
->attr
.generic_copy
= 1;
4545 /* If a procedure that is not generic has generic interfaces
4546 that include itself, it is generic! We need to take care
4547 to retain symbols ambiguous that were already so. */
4548 if (sym
->attr
.use_assoc
4549 && !sym
->attr
.generic
4550 && sym
->attr
.flavor
== FL_PROCEDURE
)
4552 for (gen
= generic
; gen
; gen
= gen
->next
)
4554 if (gen
->sym
== sym
)
4556 sym
->attr
.generic
= 1;
4571 /* Load common blocks. */
4576 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4581 while (peek_atom () != ATOM_RPAREN
)
4586 mio_internal_string (name
);
4588 p
= gfc_get_common (name
, 1);
4590 mio_symbol_ref (&p
->head
);
4591 mio_integer (&flags
);
4595 p
->threadprivate
= 1;
4598 /* Get whether this was a bind(c) common or not. */
4599 mio_integer (&p
->is_bind_c
);
4600 /* Get the binding label. */
4601 label
= read_string ();
4603 p
->binding_label
= IDENTIFIER_POINTER (get_identifier (label
));
4613 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4614 so that unused variables are not loaded and so that the expression can
4620 gfc_equiv
*head
, *tail
, *end
, *eq
, *equiv
;
4624 in_load_equiv
= true;
4626 end
= gfc_current_ns
->equiv
;
4627 while (end
!= NULL
&& end
->next
!= NULL
)
4630 while (peek_atom () != ATOM_RPAREN
) {
4634 while(peek_atom () != ATOM_RPAREN
)
4637 head
= tail
= gfc_get_equiv ();
4640 tail
->eq
= gfc_get_equiv ();
4644 mio_pool_string (&tail
->module
);
4645 mio_expr (&tail
->expr
);
4648 /* Check for duplicate equivalences being loaded from different modules */
4650 for (equiv
= gfc_current_ns
->equiv
; equiv
; equiv
= equiv
->next
)
4652 if (equiv
->module
&& head
->module
4653 && strcmp (equiv
->module
, head
->module
) == 0)
4662 for (eq
= head
; eq
; eq
= head
)
4665 gfc_free_expr (eq
->expr
);
4671 gfc_current_ns
->equiv
= head
;
4682 in_load_equiv
= false;
4686 /* This function loads OpenMP user defined reductions. */
4688 load_omp_udrs (void)
4691 while (peek_atom () != ATOM_RPAREN
)
4693 const char *name
, *newname
;
4697 gfc_omp_reduction_op rop
= OMP_REDUCTION_USER
;
4700 mio_pool_string (&name
);
4702 if (strncmp (name
, "operator ", sizeof ("operator ") - 1) == 0)
4704 const char *p
= name
+ sizeof ("operator ") - 1;
4705 if (strcmp (p
, "+") == 0)
4706 rop
= OMP_REDUCTION_PLUS
;
4707 else if (strcmp (p
, "*") == 0)
4708 rop
= OMP_REDUCTION_TIMES
;
4709 else if (strcmp (p
, "-") == 0)
4710 rop
= OMP_REDUCTION_MINUS
;
4711 else if (strcmp (p
, ".and.") == 0)
4712 rop
= OMP_REDUCTION_AND
;
4713 else if (strcmp (p
, ".or.") == 0)
4714 rop
= OMP_REDUCTION_OR
;
4715 else if (strcmp (p
, ".eqv.") == 0)
4716 rop
= OMP_REDUCTION_EQV
;
4717 else if (strcmp (p
, ".neqv.") == 0)
4718 rop
= OMP_REDUCTION_NEQV
;
4721 if (rop
== OMP_REDUCTION_USER
&& name
[0] == '.')
4723 size_t len
= strlen (name
+ 1);
4724 altname
= XALLOCAVEC (char, len
);
4725 gcc_assert (name
[len
] == '.');
4726 memcpy (altname
, name
+ 1, len
- 1);
4727 altname
[len
- 1] = '\0';
4730 if (rop
== OMP_REDUCTION_USER
)
4731 newname
= find_use_name (altname
? altname
: name
, !!altname
);
4732 else if (only_flag
&& find_use_operator ((gfc_intrinsic_op
) rop
) == NULL
)
4734 if (newname
== NULL
)
4739 if (altname
&& newname
!= altname
)
4741 size_t len
= strlen (newname
);
4742 altname
= XALLOCAVEC (char, len
+ 3);
4744 memcpy (altname
+ 1, newname
, len
);
4745 altname
[len
+ 1] = '.';
4746 altname
[len
+ 2] = '\0';
4747 name
= gfc_get_string (altname
);
4749 st
= gfc_find_symtree (gfc_current_ns
->omp_udr_root
, name
);
4750 gfc_omp_udr
*udr
= gfc_omp_udr_find (st
, &ts
);
4753 require_atom (ATOM_INTEGER
);
4754 pointer_info
*p
= get_integer (atom_int
);
4755 if (strcmp (p
->u
.rsym
.module
, udr
->omp_out
->module
))
4757 gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
4759 p
->u
.rsym
.module
, &gfc_current_locus
);
4760 gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
4762 udr
->omp_out
->module
, &udr
->where
);
4767 udr
= gfc_get_omp_udr ();
4771 udr
->where
= gfc_current_locus
;
4772 udr
->combiner_ns
= gfc_get_namespace (gfc_current_ns
, 1);
4773 udr
->combiner_ns
->proc_name
= gfc_current_ns
->proc_name
;
4774 mio_omp_udr_expr (udr
, &udr
->omp_out
, &udr
->omp_in
, udr
->combiner_ns
,
4776 if (peek_atom () != ATOM_RPAREN
)
4778 udr
->initializer_ns
= gfc_get_namespace (gfc_current_ns
, 1);
4779 udr
->initializer_ns
->proc_name
= gfc_current_ns
->proc_name
;
4780 mio_omp_udr_expr (udr
, &udr
->omp_priv
, &udr
->omp_orig
,
4781 udr
->initializer_ns
, true);
4785 udr
->next
= st
->n
.omp_udr
;
4786 st
->n
.omp_udr
= udr
;
4790 st
= gfc_new_symtree (&gfc_current_ns
->omp_udr_root
, name
);
4791 st
->n
.omp_udr
= udr
;
4799 /* Recursive function to traverse the pointer_info tree and load a
4800 needed symbol. We return nonzero if we load a symbol and stop the
4801 traversal, because the act of loading can alter the tree. */
4804 load_needed (pointer_info
*p
)
4815 rv
|= load_needed (p
->left
);
4816 rv
|= load_needed (p
->right
);
4818 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
4821 p
->u
.rsym
.state
= USED
;
4823 set_module_locus (&p
->u
.rsym
.where
);
4825 sym
= p
->u
.rsym
.sym
;
4828 q
= get_integer (p
->u
.rsym
.ns
);
4830 ns
= (gfc_namespace
*) q
->u
.pointer
;
4833 /* Create an interface namespace if necessary. These are
4834 the namespaces that hold the formal parameters of module
4837 ns
= gfc_get_namespace (NULL
, 0);
4838 associate_integer_pointer (q
, ns
);
4841 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
4842 doesn't go pear-shaped if the symbol is used. */
4844 gfc_find_symbol (p
->u
.rsym
.module
, gfc_current_ns
,
4847 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
4848 sym
->name
= dt_lower_string (p
->u
.rsym
.true_name
);
4849 sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
4850 if (p
->u
.rsym
.binding_label
)
4851 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier
4852 (p
->u
.rsym
.binding_label
));
4854 associate_integer_pointer (p
, sym
);
4858 sym
->attr
.use_assoc
= 1;
4860 /* Mark as only or rename for later diagnosis for explicitly imported
4861 but not used warnings; don't mark internal symbols such as __vtab,
4862 __def_init etc. Only mark them if they have been explicitly loaded. */
4864 if (only_flag
&& sym
->name
[0] != '_' && sym
->name
[1] != '_')
4868 /* Search the use/rename list for the variable; if the variable is
4870 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4872 if (strcmp (u
->use_name
, sym
->name
) == 0)
4874 sym
->attr
.use_only
= 1;
4880 if (p
->u
.rsym
.renamed
)
4881 sym
->attr
.use_rename
= 1;
4887 /* Recursive function for cleaning up things after a module has been read. */
4890 read_cleanup (pointer_info
*p
)
4898 read_cleanup (p
->left
);
4899 read_cleanup (p
->right
);
4901 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
4904 /* Add hidden symbols to the symtree. */
4905 q
= get_integer (p
->u
.rsym
.ns
);
4906 ns
= (gfc_namespace
*) q
->u
.pointer
;
4908 if (!p
->u
.rsym
.sym
->attr
.vtype
4909 && !p
->u
.rsym
.sym
->attr
.vtab
)
4910 st
= gfc_get_unique_symtree (ns
);
4913 /* There is no reason to use 'unique_symtrees' for vtabs or
4914 vtypes - their name is fine for a symtree and reduces the
4915 namespace pollution. */
4916 st
= gfc_find_symtree (ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4918 st
= gfc_new_symtree (&ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4921 st
->n
.sym
= p
->u
.rsym
.sym
;
4924 /* Fixup any symtree references. */
4925 p
->u
.rsym
.symtree
= st
;
4926 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
4927 p
->u
.rsym
.stfixup
= NULL
;
4930 /* Free unused symbols. */
4931 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
4932 gfc_free_symbol (p
->u
.rsym
.sym
);
4936 /* It is not quite enough to check for ambiguity in the symbols by
4937 the loaded symbol and the new symbol not being identical. */
4939 check_for_ambiguous (gfc_symtree
*st
, pointer_info
*info
)
4943 symbol_attribute attr
;
4946 if (gfc_current_ns
->proc_name
&& st
->name
== gfc_current_ns
->proc_name
->name
)
4948 gfc_error ("%qs of module %qs, imported at %C, is also the name of the "
4949 "current program unit", st
->name
, module_name
);
4954 rsym
= info
->u
.rsym
.sym
;
4958 if (st_sym
->attr
.vtab
|| st_sym
->attr
.vtype
)
4961 /* If the existing symbol is generic from a different module and
4962 the new symbol is generic there can be no ambiguity. */
4963 if (st_sym
->attr
.generic
4965 && st_sym
->module
!= module_name
)
4967 /* The new symbol's attributes have not yet been read. Since
4968 we need attr.generic, read it directly. */
4969 get_module_locus (&locus
);
4970 set_module_locus (&info
->u
.rsym
.where
);
4973 mio_symbol_attribute (&attr
);
4974 set_module_locus (&locus
);
4983 /* Read a module file. */
4988 module_locus operator_interfaces
, user_operators
, omp_udrs
;
4990 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4992 /* Workaround -Wmaybe-uninitialized false positive during
4993 profiledbootstrap by initializing them. */
4994 int ambiguous
= 0, j
, nuse
, symbol
= 0;
4995 pointer_info
*info
, *q
;
4996 gfc_use_rename
*u
= NULL
;
5000 get_module_locus (&operator_interfaces
); /* Skip these for now. */
5003 get_module_locus (&user_operators
);
5007 /* Skip commons and equivalences for now. */
5011 /* Skip OpenMP UDRs. */
5012 get_module_locus (&omp_udrs
);
5017 /* Create the fixup nodes for all the symbols. */
5019 while (peek_atom () != ATOM_RPAREN
)
5022 require_atom (ATOM_INTEGER
);
5023 info
= get_integer (atom_int
);
5025 info
->type
= P_SYMBOL
;
5026 info
->u
.rsym
.state
= UNUSED
;
5028 info
->u
.rsym
.true_name
= read_string ();
5029 info
->u
.rsym
.module
= read_string ();
5030 bind_label
= read_string ();
5031 if (strlen (bind_label
))
5032 info
->u
.rsym
.binding_label
= bind_label
;
5034 XDELETEVEC (bind_label
);
5036 require_atom (ATOM_INTEGER
);
5037 info
->u
.rsym
.ns
= atom_int
;
5039 get_module_locus (&info
->u
.rsym
.where
);
5041 /* See if the symbol has already been loaded by a previous module.
5042 If so, we reference the existing symbol and prevent it from
5043 being loaded again. This should not happen if the symbol being
5044 read is an index for an assumed shape dummy array (ns != 1). */
5046 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
5049 || (sym
->attr
.flavor
== FL_VARIABLE
&& info
->u
.rsym
.ns
!=1))
5055 info
->u
.rsym
.state
= USED
;
5056 info
->u
.rsym
.sym
= sym
;
5057 /* The current symbol has already been loaded, so we can avoid loading
5058 it again. However, if it is a derived type, some of its components
5059 can be used in expressions in the module. To avoid the module loading
5060 failing, we need to associate the module's component pointer indexes
5061 with the existing symbol's component pointers. */
5062 if (sym
->attr
.flavor
== FL_DERIVED
)
5066 /* First seek to the symbol's component list. */
5067 mio_lparen (); /* symbol opening. */
5068 skip_list (); /* skip symbol attribute. */
5070 mio_lparen (); /* component list opening. */
5071 for (c
= sym
->components
; c
; c
= c
->next
)
5074 const char *comp_name
;
5077 mio_lparen (); /* component opening. */
5079 p
= get_integer (n
);
5080 if (p
->u
.pointer
== NULL
)
5081 associate_integer_pointer (p
, c
);
5082 mio_pool_string (&comp_name
);
5083 gcc_assert (comp_name
== c
->name
);
5084 skip_list (1); /* component end. */
5086 mio_rparen (); /* component list closing. */
5088 skip_list (1); /* symbol end. */
5093 /* Some symbols do not have a namespace (eg. formal arguments),
5094 so the automatic "unique symtree" mechanism must be suppressed
5095 by marking them as referenced. */
5096 q
= get_integer (info
->u
.rsym
.ns
);
5097 if (q
->u
.pointer
== NULL
)
5099 info
->u
.rsym
.referenced
= 1;
5103 /* If possible recycle the symtree that references the symbol.
5104 If a symtree is not found and the module does not import one,
5105 a unique-name symtree is found by read_cleanup. */
5106 st
= find_symtree_for_symbol (gfc_current_ns
->sym_root
, sym
);
5109 info
->u
.rsym
.symtree
= st
;
5110 info
->u
.rsym
.referenced
= 1;
5116 /* Parse the symtree lists. This lets us mark which symbols need to
5117 be loaded. Renaming is also done at this point by replacing the
5122 while (peek_atom () != ATOM_RPAREN
)
5124 mio_internal_string (name
);
5125 mio_integer (&ambiguous
);
5126 mio_integer (&symbol
);
5128 info
= get_integer (symbol
);
5130 /* See how many use names there are. If none, go through the start
5131 of the loop at least once. */
5132 nuse
= number_use_names (name
, false);
5133 info
->u
.rsym
.renamed
= nuse
? 1 : 0;
5138 for (j
= 1; j
<= nuse
; j
++)
5140 /* Get the jth local name for this symbol. */
5141 p
= find_use_name_n (name
, &j
, false);
5143 if (p
== NULL
&& strcmp (name
, module_name
) == 0)
5146 /* Exception: Always import vtabs & vtypes. */
5147 if (p
== NULL
&& name
[0] == '_'
5148 && (strncmp (name
, "__vtab_", 5) == 0
5149 || strncmp (name
, "__vtype_", 6) == 0))
5152 /* Skip symtree nodes not in an ONLY clause, unless there
5153 is an existing symtree loaded from another USE statement. */
5156 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5158 && strcmp (st
->n
.sym
->name
, info
->u
.rsym
.true_name
) == 0
5159 && st
->n
.sym
->module
!= NULL
5160 && strcmp (st
->n
.sym
->module
, info
->u
.rsym
.module
) == 0)
5162 info
->u
.rsym
.symtree
= st
;
5163 info
->u
.rsym
.sym
= st
->n
.sym
;
5168 /* If a symbol of the same name and module exists already,
5169 this symbol, which is not in an ONLY clause, must not be
5170 added to the namespace(11.3.2). Note that find_symbol
5171 only returns the first occurrence that it finds. */
5172 if (!only_flag
&& !info
->u
.rsym
.renamed
5173 && strcmp (name
, module_name
) != 0
5174 && find_symbol (gfc_current_ns
->sym_root
, name
,
5178 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
5181 && !(st
->n
.sym
&& st
->n
.sym
->attr
.used_in_submodule
))
5183 /* Check for ambiguous symbols. */
5184 if (check_for_ambiguous (st
, info
))
5187 info
->u
.rsym
.symtree
= st
;
5193 /* This symbol is host associated from a module in a
5194 submodule. Hide it with a unique symtree. */
5195 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
5196 s
->n
.sym
= st
->n
.sym
;
5201 /* Create a symtree node in the current namespace for this
5203 st
= check_unique_name (p
)
5204 ? gfc_get_unique_symtree (gfc_current_ns
)
5205 : gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
5206 st
->ambiguous
= ambiguous
;
5209 sym
= info
->u
.rsym
.sym
;
5211 /* Create a symbol node if it doesn't already exist. */
5214 info
->u
.rsym
.sym
= gfc_new_symbol (info
->u
.rsym
.true_name
,
5216 info
->u
.rsym
.sym
->name
= dt_lower_string (info
->u
.rsym
.true_name
);
5217 sym
= info
->u
.rsym
.sym
;
5218 sym
->module
= gfc_get_string (info
->u
.rsym
.module
);
5220 if (info
->u
.rsym
.binding_label
)
5221 sym
->binding_label
=
5222 IDENTIFIER_POINTER (get_identifier
5223 (info
->u
.rsym
.binding_label
));
5229 if (strcmp (name
, p
) != 0)
5230 sym
->attr
.use_rename
= 1;
5233 || (strncmp (name
, "__vtab_", 5) != 0
5234 && strncmp (name
, "__vtype_", 6) != 0))
5235 sym
->attr
.use_only
= only_flag
;
5237 /* Store the symtree pointing to this symbol. */
5238 info
->u
.rsym
.symtree
= st
;
5240 if (info
->u
.rsym
.state
== UNUSED
)
5241 info
->u
.rsym
.state
= NEEDED
;
5242 info
->u
.rsym
.referenced
= 1;
5249 /* Load intrinsic operator interfaces. */
5250 set_module_locus (&operator_interfaces
);
5253 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5255 if (i
== INTRINSIC_USER
)
5260 u
= find_use_operator ((gfc_intrinsic_op
) i
);
5271 mio_interface (&gfc_current_ns
->op
[i
]);
5272 if (u
&& !gfc_current_ns
->op
[i
])
5278 /* Load generic and user operator interfaces. These must follow the
5279 loading of symtree because otherwise symbols can be marked as
5282 set_module_locus (&user_operators
);
5284 load_operator_interfaces ();
5285 load_generic_interfaces ();
5290 /* Load OpenMP user defined reductions. */
5291 set_module_locus (&omp_udrs
);
5294 /* At this point, we read those symbols that are needed but haven't
5295 been loaded yet. If one symbol requires another, the other gets
5296 marked as NEEDED if its previous state was UNUSED. */
5298 while (load_needed (pi_root
));
5300 /* Make sure all elements of the rename-list were found in the module. */
5302 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5307 if (u
->op
== INTRINSIC_NONE
)
5309 gfc_error ("Symbol %qs referenced at %L not found in module %qs",
5310 u
->use_name
, &u
->where
, module_name
);
5314 if (u
->op
== INTRINSIC_USER
)
5316 gfc_error ("User operator %qs referenced at %L not found "
5317 "in module %qs", u
->use_name
, &u
->where
, module_name
);
5321 gfc_error ("Intrinsic operator %qs referenced at %L not found "
5322 "in module %qs", gfc_op2string (u
->op
), &u
->where
,
5326 /* Clean up symbol nodes that were never loaded, create references
5327 to hidden symbols. */
5329 read_cleanup (pi_root
);
5333 /* Given an access type that is specific to an entity and the default
5334 access, return nonzero if the entity is publicly accessible. If the
5335 element is declared as PUBLIC, then it is public; if declared
5336 PRIVATE, then private, and otherwise it is public unless the default
5337 access in this context has been declared PRIVATE. */
5339 static bool dump_smod
= false;
5342 check_access (gfc_access specific_access
, gfc_access default_access
)
5347 if (specific_access
== ACCESS_PUBLIC
)
5349 if (specific_access
== ACCESS_PRIVATE
)
5352 if (flag_module_private
)
5353 return default_access
== ACCESS_PUBLIC
;
5355 return default_access
!= ACCESS_PRIVATE
;
5360 gfc_check_symbol_access (gfc_symbol
*sym
)
5362 if (sym
->attr
.vtab
|| sym
->attr
.vtype
)
5365 return check_access (sym
->attr
.access
, sym
->ns
->default_access
);
5369 /* A structure to remember which commons we've already written. */
5371 struct written_common
5373 BBT_HEADER(written_common
);
5374 const char *name
, *label
;
5377 static struct written_common
*written_commons
= NULL
;
5379 /* Comparison function used for balancing the binary tree. */
5382 compare_written_commons (void *a1
, void *b1
)
5384 const char *aname
= ((struct written_common
*) a1
)->name
;
5385 const char *alabel
= ((struct written_common
*) a1
)->label
;
5386 const char *bname
= ((struct written_common
*) b1
)->name
;
5387 const char *blabel
= ((struct written_common
*) b1
)->label
;
5388 int c
= strcmp (aname
, bname
);
5390 return (c
!= 0 ? c
: strcmp (alabel
, blabel
));
5393 /* Free a list of written commons. */
5396 free_written_common (struct written_common
*w
)
5402 free_written_common (w
->left
);
5404 free_written_common (w
->right
);
5409 /* Write a common block to the module -- recursive helper function. */
5412 write_common_0 (gfc_symtree
*st
, bool this_module
)
5418 struct written_common
*w
;
5419 bool write_me
= true;
5424 write_common_0 (st
->left
, this_module
);
5426 /* We will write out the binding label, or "" if no label given. */
5427 name
= st
->n
.common
->name
;
5429 label
= (p
->is_bind_c
&& p
->binding_label
) ? p
->binding_label
: "";
5431 /* Check if we've already output this common. */
5432 w
= written_commons
;
5435 int c
= strcmp (name
, w
->name
);
5436 c
= (c
!= 0 ? c
: strcmp (label
, w
->label
));
5440 w
= (c
< 0) ? w
->left
: w
->right
;
5443 if (this_module
&& p
->use_assoc
)
5448 /* Write the common to the module. */
5450 mio_pool_string (&name
);
5452 mio_symbol_ref (&p
->head
);
5453 flags
= p
->saved
? 1 : 0;
5454 if (p
->threadprivate
)
5456 mio_integer (&flags
);
5458 /* Write out whether the common block is bind(c) or not. */
5459 mio_integer (&(p
->is_bind_c
));
5461 mio_pool_string (&label
);
5464 /* Record that we have written this common. */
5465 w
= XCNEW (struct written_common
);
5468 gfc_insert_bbt (&written_commons
, w
, compare_written_commons
);
5471 write_common_0 (st
->right
, this_module
);
5475 /* Write a common, by initializing the list of written commons, calling
5476 the recursive function write_common_0() and cleaning up afterwards. */
5479 write_common (gfc_symtree
*st
)
5481 written_commons
= NULL
;
5482 write_common_0 (st
, true);
5483 write_common_0 (st
, false);
5484 free_written_common (written_commons
);
5485 written_commons
= NULL
;
5489 /* Write the blank common block to the module. */
5492 write_blank_common (void)
5494 const char * name
= BLANK_COMMON_NAME
;
5496 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
5497 this, but it hasn't been checked. Just making it so for now. */
5500 if (gfc_current_ns
->blank_common
.head
== NULL
)
5505 mio_pool_string (&name
);
5507 mio_symbol_ref (&gfc_current_ns
->blank_common
.head
);
5508 saved
= gfc_current_ns
->blank_common
.saved
;
5509 mio_integer (&saved
);
5511 /* Write out whether the common block is bind(c) or not. */
5512 mio_integer (&is_bind_c
);
5514 /* Write out an empty binding label. */
5515 write_atom (ATOM_STRING
, "");
5521 /* Write equivalences to the module. */
5530 for (eq
= gfc_current_ns
->equiv
; eq
; eq
= eq
->next
)
5534 for (e
= eq
; e
; e
= e
->eq
)
5536 if (e
->module
== NULL
)
5537 e
->module
= gfc_get_string ("%s.eq.%d", module_name
, num
);
5538 mio_allocated_string (e
->module
);
5539 mio_expr (&e
->expr
);
5548 /* Write a symbol to the module. */
5551 write_symbol (int n
, gfc_symbol
*sym
)
5555 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
5556 gfc_internal_error ("write_symbol(): bad module symbol %qs", sym
->name
);
5560 if (sym
->attr
.flavor
== FL_DERIVED
)
5563 name
= dt_upper_string (sym
->name
);
5564 mio_pool_string (&name
);
5567 mio_pool_string (&sym
->name
);
5569 mio_pool_string (&sym
->module
);
5570 if ((sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
) && sym
->binding_label
)
5572 label
= sym
->binding_label
;
5573 mio_pool_string (&label
);
5576 write_atom (ATOM_STRING
, "");
5578 mio_pointer_ref (&sym
->ns
);
5585 /* Recursive traversal function to write the initial set of symbols to
5586 the module. We check to see if the symbol should be written
5587 according to the access specification. */
5590 write_symbol0 (gfc_symtree
*st
)
5594 bool dont_write
= false;
5599 write_symbol0 (st
->left
);
5602 if (sym
->module
== NULL
)
5603 sym
->module
= module_name
;
5605 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5606 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
5609 if (!gfc_check_symbol_access (sym
))
5614 p
= get_pointer (sym
);
5615 if (p
->type
== P_UNKNOWN
)
5618 if (p
->u
.wsym
.state
!= WRITTEN
)
5620 write_symbol (p
->integer
, sym
);
5621 p
->u
.wsym
.state
= WRITTEN
;
5625 write_symbol0 (st
->right
);
5630 write_omp_udr (gfc_omp_udr
*udr
)
5634 case OMP_REDUCTION_USER
:
5635 /* Non-operators can't be used outside of the module. */
5636 if (udr
->name
[0] != '.')
5641 size_t len
= strlen (udr
->name
+ 1);
5642 char *name
= XALLOCAVEC (char, len
);
5643 memcpy (name
, udr
->name
, len
- 1);
5644 name
[len
- 1] = '\0';
5645 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
5646 /* If corresponding user operator is private, don't write
5650 gfc_user_op
*uop
= st
->n
.uop
;
5651 if (!check_access (uop
->access
, uop
->ns
->default_access
))
5656 case OMP_REDUCTION_PLUS
:
5657 case OMP_REDUCTION_MINUS
:
5658 case OMP_REDUCTION_TIMES
:
5659 case OMP_REDUCTION_AND
:
5660 case OMP_REDUCTION_OR
:
5661 case OMP_REDUCTION_EQV
:
5662 case OMP_REDUCTION_NEQV
:
5663 /* If corresponding operator is private, don't write the UDR. */
5664 if (!check_access (gfc_current_ns
->operator_access
[udr
->rop
],
5665 gfc_current_ns
->default_access
))
5671 if (udr
->ts
.type
== BT_DERIVED
|| udr
->ts
.type
== BT_CLASS
)
5673 /* If derived type is private, don't write the UDR. */
5674 if (!gfc_check_symbol_access (udr
->ts
.u
.derived
))
5679 mio_pool_string (&udr
->name
);
5680 mio_typespec (&udr
->ts
);
5681 mio_omp_udr_expr (udr
, &udr
->omp_out
, &udr
->omp_in
, udr
->combiner_ns
, false);
5682 if (udr
->initializer_ns
)
5683 mio_omp_udr_expr (udr
, &udr
->omp_priv
, &udr
->omp_orig
,
5684 udr
->initializer_ns
, true);
5690 write_omp_udrs (gfc_symtree
*st
)
5695 write_omp_udrs (st
->left
);
5697 for (udr
= st
->n
.omp_udr
; udr
; udr
= udr
->next
)
5698 write_omp_udr (udr
);
5699 write_omp_udrs (st
->right
);
5703 /* Type for the temporary tree used when writing secondary symbols. */
5705 struct sorted_pointer_info
5707 BBT_HEADER (sorted_pointer_info
);
5712 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
5714 /* Recursively traverse the temporary tree, free its contents. */
5717 free_sorted_pointer_info_tree (sorted_pointer_info
*p
)
5722 free_sorted_pointer_info_tree (p
->left
);
5723 free_sorted_pointer_info_tree (p
->right
);
5728 /* Comparison function for the temporary tree. */
5731 compare_sorted_pointer_info (void *_spi1
, void *_spi2
)
5733 sorted_pointer_info
*spi1
, *spi2
;
5734 spi1
= (sorted_pointer_info
*)_spi1
;
5735 spi2
= (sorted_pointer_info
*)_spi2
;
5737 if (spi1
->p
->integer
< spi2
->p
->integer
)
5739 if (spi1
->p
->integer
> spi2
->p
->integer
)
5745 /* Finds the symbols that need to be written and collects them in the
5746 sorted_pi tree so that they can be traversed in an order
5747 independent of memory addresses. */
5750 find_symbols_to_write(sorted_pointer_info
**tree
, pointer_info
*p
)
5755 if (p
->type
== P_SYMBOL
&& p
->u
.wsym
.state
== NEEDS_WRITE
)
5757 sorted_pointer_info
*sp
= gfc_get_sorted_pointer_info();
5760 gfc_insert_bbt (tree
, sp
, compare_sorted_pointer_info
);
5763 find_symbols_to_write (tree
, p
->left
);
5764 find_symbols_to_write (tree
, p
->right
);
5768 /* Recursive function that traverses the tree of symbols that need to be
5769 written and writes them in order. */
5772 write_symbol1_recursion (sorted_pointer_info
*sp
)
5777 write_symbol1_recursion (sp
->left
);
5779 pointer_info
*p1
= sp
->p
;
5780 gcc_assert (p1
->type
== P_SYMBOL
&& p1
->u
.wsym
.state
== NEEDS_WRITE
);
5782 p1
->u
.wsym
.state
= WRITTEN
;
5783 write_symbol (p1
->integer
, p1
->u
.wsym
.sym
);
5784 p1
->u
.wsym
.sym
->attr
.public_used
= 1;
5786 write_symbol1_recursion (sp
->right
);
5790 /* Write the secondary set of symbols to the module file. These are
5791 symbols that were not public yet are needed by the public symbols
5792 or another dependent symbol. The act of writing a symbol can add
5793 symbols to the pointer_info tree, so we return nonzero if a symbol
5794 was written and pass that information upwards. The caller will
5795 then call this function again until nothing was written. It uses
5796 the utility functions and a temporary tree to ensure a reproducible
5797 ordering of the symbol output and thus the module file. */
5800 write_symbol1 (pointer_info
*p
)
5805 /* Put symbols that need to be written into a tree sorted on the
5808 sorted_pointer_info
*spi_root
= NULL
;
5809 find_symbols_to_write (&spi_root
, p
);
5811 /* No symbols to write, return. */
5815 /* Otherwise, write and free the tree again. */
5816 write_symbol1_recursion (spi_root
);
5817 free_sorted_pointer_info_tree (spi_root
);
5823 /* Write operator interfaces associated with a symbol. */
5826 write_operator (gfc_user_op
*uop
)
5828 static char nullstring
[] = "";
5829 const char *p
= nullstring
;
5831 if (uop
->op
== NULL
|| !check_access (uop
->access
, uop
->ns
->default_access
))
5834 mio_symbol_interface (&uop
->name
, &p
, &uop
->op
);
5838 /* Write generic interfaces from the namespace sym_root. */
5841 write_generic (gfc_symtree
*st
)
5848 write_generic (st
->left
);
5851 if (sym
&& !check_unique_name (st
->name
)
5852 && sym
->generic
&& gfc_check_symbol_access (sym
))
5855 sym
->module
= module_name
;
5857 mio_symbol_interface (&st
->name
, &sym
->module
, &sym
->generic
);
5860 write_generic (st
->right
);
5865 write_symtree (gfc_symtree
*st
)
5872 /* A symbol in an interface body must not be visible in the
5874 if (sym
->ns
!= gfc_current_ns
5875 && sym
->ns
->proc_name
5876 && sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
5879 if (!gfc_check_symbol_access (sym
)
5880 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5881 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
5884 if (check_unique_name (st
->name
))
5887 p
= find_pointer (sym
);
5889 gfc_internal_error ("write_symtree(): Symbol not written");
5891 mio_pool_string (&st
->name
);
5892 mio_integer (&st
->ambiguous
);
5893 mio_integer (&p
->integer
);
5902 /* Write the operator interfaces. */
5905 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5907 if (i
== INTRINSIC_USER
)
5910 mio_interface (check_access (gfc_current_ns
->operator_access
[i
],
5911 gfc_current_ns
->default_access
)
5912 ? &gfc_current_ns
->op
[i
] : NULL
);
5920 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
5926 write_generic (gfc_current_ns
->sym_root
);
5932 write_blank_common ();
5933 write_common (gfc_current_ns
->common_root
);
5945 write_omp_udrs (gfc_current_ns
->omp_udr_root
);
5950 /* Write symbol information. First we traverse all symbols in the
5951 primary namespace, writing those that need to be written.
5952 Sometimes writing one symbol will cause another to need to be
5953 written. A list of these symbols ends up on the write stack, and
5954 we end by popping the bottom of the stack and writing the symbol
5955 until the stack is empty. */
5959 write_symbol0 (gfc_current_ns
->sym_root
);
5960 while (write_symbol1 (pi_root
))
5969 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
5974 /* Read a CRC32 sum from the gzip trailer of a module file. Returns
5975 true on success, false on failure. */
5978 read_crc32_from_module_file (const char* filename
, uLong
* crc
)
5984 /* Open the file in binary mode. */
5985 if ((file
= fopen (filename
, "rb")) == NULL
)
5988 /* The gzip crc32 value is found in the [END-8, END-4] bytes of the
5989 file. See RFC 1952. */
5990 if (fseek (file
, -8, SEEK_END
) != 0)
5996 /* Read the CRC32. */
5997 if (fread (buf
, 1, 4, file
) != 4)
6003 /* Close the file. */
6006 val
= (buf
[0] & 0xFF) + ((buf
[1] & 0xFF) << 8) + ((buf
[2] & 0xFF) << 16)
6007 + ((buf
[3] & 0xFF) << 24);
6010 /* For debugging, the CRC value printed in hexadecimal should match
6011 the CRC printed by "zcat -l -v filename".
6012 printf("CRC of file %s is %x\n", filename, val); */
6018 /* Given module, dump it to disk. If there was an error while
6019 processing the module, dump_flag will be set to zero and we delete
6020 the module file, even if it was already there. */
6023 dump_module (const char *name
, int dump_flag
)
6026 char *filename
, *filename_tmp
;
6029 module_name
= gfc_get_string (name
);
6033 name
= submodule_name
;
6034 n
= strlen (name
) + strlen (SUBMODULE_EXTENSION
) + 1;
6037 n
= strlen (name
) + strlen (MODULE_EXTENSION
) + 1;
6039 if (gfc_option
.module_dir
!= NULL
)
6041 n
+= strlen (gfc_option
.module_dir
);
6042 filename
= (char *) alloca (n
);
6043 strcpy (filename
, gfc_option
.module_dir
);
6044 strcat (filename
, name
);
6048 filename
= (char *) alloca (n
);
6049 strcpy (filename
, name
);
6053 strcat (filename
, SUBMODULE_EXTENSION
);
6055 strcat (filename
, MODULE_EXTENSION
);
6057 /* Name of the temporary file used to write the module. */
6058 filename_tmp
= (char *) alloca (n
+ 1);
6059 strcpy (filename_tmp
, filename
);
6060 strcat (filename_tmp
, "0");
6062 /* There was an error while processing the module. We delete the
6063 module file, even if it was already there. */
6070 if (gfc_cpp_makedep ())
6071 gfc_cpp_add_target (filename
);
6073 /* Write the module to the temporary file. */
6074 module_fp
= gzopen (filename_tmp
, "w");
6075 if (module_fp
== NULL
)
6076 gfc_fatal_error ("Can't open module file %qs for writing at %C: %s",
6077 filename_tmp
, xstrerror (errno
));
6079 gzprintf (module_fp
, "GFORTRAN module version '%s' created from %s\n",
6080 MOD_VERSION
, gfc_source_file
);
6082 /* Write the module itself. */
6089 free_pi_tree (pi_root
);
6094 if (gzclose (module_fp
))
6095 gfc_fatal_error ("Error writing module file %qs for writing: %s",
6096 filename_tmp
, xstrerror (errno
));
6098 /* Read the CRC32 from the gzip trailers of the module files and
6100 if (!read_crc32_from_module_file (filename_tmp
, &crc
)
6101 || !read_crc32_from_module_file (filename
, &crc_old
)
6104 /* Module file have changed, replace the old one. */
6105 if (remove (filename
) && errno
!= ENOENT
)
6106 gfc_fatal_error ("Can't delete module file %qs: %s", filename
,
6108 if (rename (filename_tmp
, filename
))
6109 gfc_fatal_error ("Can't rename module file %qs to %qs: %s",
6110 filename_tmp
, filename
, xstrerror (errno
));
6114 if (remove (filename_tmp
))
6115 gfc_fatal_error ("Can't delete temporary module file %qs: %s",
6116 filename_tmp
, xstrerror (errno
));
6122 gfc_dump_module (const char *name
, int dump_flag
)
6124 if (gfc_state_stack
->state
== COMP_SUBMODULE
)
6129 no_module_procedures
= true;
6130 dump_module (name
, dump_flag
);
6132 if (no_module_procedures
|| dump_smod
)
6135 /* Write a submodule file from a module. The 'dump_smod' flag switches
6136 off the check for PRIVATE entities. */
6138 submodule_name
= module_name
;
6139 dump_module (name
, dump_flag
);
6144 create_intrinsic_function (const char *name
, int id
,
6145 const char *modname
, intmod_id module
,
6146 bool subroutine
, gfc_symbol
*result_type
)
6148 gfc_intrinsic_sym
*isym
;
6149 gfc_symtree
*tmp_symtree
;
6152 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6155 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6157 gfc_error ("Symbol %qs already declared", name
);
6160 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6161 sym
= tmp_symtree
->n
.sym
;
6165 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
6166 isym
= gfc_intrinsic_subroutine_by_id (isym_id
);
6167 sym
->attr
.subroutine
= 1;
6171 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
6172 isym
= gfc_intrinsic_function_by_id (isym_id
);
6174 sym
->attr
.function
= 1;
6177 sym
->ts
.type
= BT_DERIVED
;
6178 sym
->ts
.u
.derived
= result_type
;
6179 sym
->ts
.is_c_interop
= 1;
6180 isym
->ts
.f90_type
= BT_VOID
;
6181 isym
->ts
.type
= BT_DERIVED
;
6182 isym
->ts
.f90_type
= BT_VOID
;
6183 isym
->ts
.u
.derived
= result_type
;
6184 isym
->ts
.is_c_interop
= 1;
6189 sym
->attr
.flavor
= FL_PROCEDURE
;
6190 sym
->attr
.intrinsic
= 1;
6192 sym
->module
= gfc_get_string (modname
);
6193 sym
->attr
.use_assoc
= 1;
6194 sym
->from_intmod
= module
;
6195 sym
->intmod_sym_id
= id
;
6199 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
6200 the current namespace for all named constants, pointer types, and
6201 procedures in the module unless the only clause was used or a rename
6202 list was provided. */
6205 import_iso_c_binding_module (void)
6207 gfc_symbol
*mod_sym
= NULL
, *return_type
;
6208 gfc_symtree
*mod_symtree
= NULL
, *tmp_symtree
;
6209 gfc_symtree
*c_ptr
= NULL
, *c_funptr
= NULL
;
6210 const char *iso_c_module_name
= "__iso_c_binding";
6213 bool want_c_ptr
= false, want_c_funptr
= false;
6215 /* Look only in the current namespace. */
6216 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, iso_c_module_name
);
6218 if (mod_symtree
== NULL
)
6220 /* symtree doesn't already exist in current namespace. */
6221 gfc_get_sym_tree (iso_c_module_name
, gfc_current_ns
, &mod_symtree
,
6224 if (mod_symtree
!= NULL
)
6225 mod_sym
= mod_symtree
->n
.sym
;
6227 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
6228 "create symbol for %s", iso_c_module_name
);
6230 mod_sym
->attr
.flavor
= FL_MODULE
;
6231 mod_sym
->attr
.intrinsic
= 1;
6232 mod_sym
->module
= gfc_get_string (iso_c_module_name
);
6233 mod_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
6236 /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
6237 check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
6239 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6241 if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_PTR
].name
,
6244 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_LOC
].name
,
6247 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_FUNPTR
].name
,
6249 want_c_funptr
= true;
6250 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNLOC
].name
,
6252 want_c_funptr
= true;
6253 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_PTR
].name
,
6256 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
6257 (iso_c_binding_symbol
)
6259 u
->local_name
[0] ? u
->local_name
6263 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNPTR
].name
,
6267 = generate_isocbinding_symbol (iso_c_module_name
,
6268 (iso_c_binding_symbol
)
6270 u
->local_name
[0] ? u
->local_name
6276 if ((want_c_ptr
|| !only_flag
) && !c_ptr
)
6277 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
6278 (iso_c_binding_symbol
)
6280 NULL
, NULL
, only_flag
);
6281 if ((want_c_funptr
|| !only_flag
) && !c_funptr
)
6282 c_funptr
= generate_isocbinding_symbol (iso_c_module_name
,
6283 (iso_c_binding_symbol
)
6285 NULL
, NULL
, only_flag
);
6287 /* Generate the symbols for the named constants representing
6288 the kinds for intrinsic data types. */
6289 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
6292 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6293 if (strcmp (c_interop_kinds_table
[i
].name
, u
->use_name
) == 0)
6302 #define NAMED_FUNCTION(a,b,c,d) \
6304 not_in_std = (gfc_option.allow_std & d) == 0; \
6307 #define NAMED_SUBROUTINE(a,b,c,d) \
6309 not_in_std = (gfc_option.allow_std & d) == 0; \
6312 #define NAMED_INTCST(a,b,c,d) \
6314 not_in_std = (gfc_option.allow_std & d) == 0; \
6317 #define NAMED_REALCST(a,b,c,d) \
6319 not_in_std = (gfc_option.allow_std & d) == 0; \
6322 #define NAMED_CMPXCST(a,b,c,d) \
6324 not_in_std = (gfc_option.allow_std & d) == 0; \
6327 #include "iso-c-binding.def"
6335 gfc_error ("The symbol %qs, referenced at %L, is not "
6336 "in the selected standard", name
, &u
->where
);
6342 #define NAMED_FUNCTION(a,b,c,d) \
6344 if (a == ISOCBINDING_LOC) \
6345 return_type = c_ptr->n.sym; \
6346 else if (a == ISOCBINDING_FUNLOC) \
6347 return_type = c_funptr->n.sym; \
6349 return_type = NULL; \
6350 create_intrinsic_function (u->local_name[0] \
6351 ? u->local_name : u->use_name, \
6352 a, iso_c_module_name, \
6353 INTMOD_ISO_C_BINDING, false, \
6356 #define NAMED_SUBROUTINE(a,b,c,d) \
6358 create_intrinsic_function (u->local_name[0] ? u->local_name \
6360 a, iso_c_module_name, \
6361 INTMOD_ISO_C_BINDING, true, NULL); \
6363 #include "iso-c-binding.def"
6365 case ISOCBINDING_PTR
:
6366 case ISOCBINDING_FUNPTR
:
6367 /* Already handled above. */
6370 if (i
== ISOCBINDING_NULL_PTR
)
6371 tmp_symtree
= c_ptr
;
6372 else if (i
== ISOCBINDING_NULL_FUNPTR
)
6373 tmp_symtree
= c_funptr
;
6376 generate_isocbinding_symbol (iso_c_module_name
,
6377 (iso_c_binding_symbol
) i
,
6379 ? u
->local_name
: u
->use_name
,
6380 tmp_symtree
, false);
6384 if (!found
&& !only_flag
)
6386 /* Skip, if the symbol is not in the enabled standard. */
6389 #define NAMED_FUNCTION(a,b,c,d) \
6391 if ((gfc_option.allow_std & d) == 0) \
6394 #define NAMED_SUBROUTINE(a,b,c,d) \
6396 if ((gfc_option.allow_std & d) == 0) \
6399 #define NAMED_INTCST(a,b,c,d) \
6401 if ((gfc_option.allow_std & d) == 0) \
6404 #define NAMED_REALCST(a,b,c,d) \
6406 if ((gfc_option.allow_std & d) == 0) \
6409 #define NAMED_CMPXCST(a,b,c,d) \
6411 if ((gfc_option.allow_std & d) == 0) \
6414 #include "iso-c-binding.def"
6416 ; /* Not GFC_STD_* versioned. */
6421 #define NAMED_FUNCTION(a,b,c,d) \
6423 if (a == ISOCBINDING_LOC) \
6424 return_type = c_ptr->n.sym; \
6425 else if (a == ISOCBINDING_FUNLOC) \
6426 return_type = c_funptr->n.sym; \
6428 return_type = NULL; \
6429 create_intrinsic_function (b, a, iso_c_module_name, \
6430 INTMOD_ISO_C_BINDING, false, \
6433 #define NAMED_SUBROUTINE(a,b,c,d) \
6435 create_intrinsic_function (b, a, iso_c_module_name, \
6436 INTMOD_ISO_C_BINDING, true, NULL); \
6438 #include "iso-c-binding.def"
6440 case ISOCBINDING_PTR
:
6441 case ISOCBINDING_FUNPTR
:
6442 /* Already handled above. */
6445 if (i
== ISOCBINDING_NULL_PTR
)
6446 tmp_symtree
= c_ptr
;
6447 else if (i
== ISOCBINDING_NULL_FUNPTR
)
6448 tmp_symtree
= c_funptr
;
6451 generate_isocbinding_symbol (iso_c_module_name
,
6452 (iso_c_binding_symbol
) i
, NULL
,
6453 tmp_symtree
, false);
6458 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6463 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6464 "module ISO_C_BINDING", u
->use_name
, &u
->where
);
6469 /* Add an integer named constant from a given module. */
6472 create_int_parameter (const char *name
, int value
, const char *modname
,
6473 intmod_id module
, int id
)
6475 gfc_symtree
*tmp_symtree
;
6478 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6479 if (tmp_symtree
!= NULL
)
6481 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6484 gfc_error ("Symbol %qs already declared", name
);
6487 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6488 sym
= tmp_symtree
->n
.sym
;
6490 sym
->module
= gfc_get_string (modname
);
6491 sym
->attr
.flavor
= FL_PARAMETER
;
6492 sym
->ts
.type
= BT_INTEGER
;
6493 sym
->ts
.kind
= gfc_default_integer_kind
;
6494 sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, value
);
6495 sym
->attr
.use_assoc
= 1;
6496 sym
->from_intmod
= module
;
6497 sym
->intmod_sym_id
= id
;
6501 /* Value is already contained by the array constructor, but not
6505 create_int_parameter_array (const char *name
, int size
, gfc_expr
*value
,
6506 const char *modname
, intmod_id module
, int id
)
6508 gfc_symtree
*tmp_symtree
;
6511 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6512 if (tmp_symtree
!= NULL
)
6514 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6517 gfc_error ("Symbol %qs already declared", name
);
6520 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6521 sym
= tmp_symtree
->n
.sym
;
6523 sym
->module
= gfc_get_string (modname
);
6524 sym
->attr
.flavor
= FL_PARAMETER
;
6525 sym
->ts
.type
= BT_INTEGER
;
6526 sym
->ts
.kind
= gfc_default_integer_kind
;
6527 sym
->attr
.use_assoc
= 1;
6528 sym
->from_intmod
= module
;
6529 sym
->intmod_sym_id
= id
;
6530 sym
->attr
.dimension
= 1;
6531 sym
->as
= gfc_get_array_spec ();
6533 sym
->as
->type
= AS_EXPLICIT
;
6534 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
6535 sym
->as
->upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, size
);
6538 sym
->value
->shape
= gfc_get_shape (1);
6539 mpz_init_set_ui (sym
->value
->shape
[0], size
);
6543 /* Add an derived type for a given module. */
6546 create_derived_type (const char *name
, const char *modname
,
6547 intmod_id module
, int id
)
6549 gfc_symtree
*tmp_symtree
;
6550 gfc_symbol
*sym
, *dt_sym
;
6551 gfc_interface
*intr
, *head
;
6553 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6554 if (tmp_symtree
!= NULL
)
6556 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6559 gfc_error ("Symbol %qs already declared", name
);
6562 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6563 sym
= tmp_symtree
->n
.sym
;
6564 sym
->module
= gfc_get_string (modname
);
6565 sym
->from_intmod
= module
;
6566 sym
->intmod_sym_id
= id
;
6567 sym
->attr
.flavor
= FL_PROCEDURE
;
6568 sym
->attr
.function
= 1;
6569 sym
->attr
.generic
= 1;
6571 gfc_get_sym_tree (dt_upper_string (sym
->name
),
6572 gfc_current_ns
, &tmp_symtree
, false);
6573 dt_sym
= tmp_symtree
->n
.sym
;
6574 dt_sym
->name
= gfc_get_string (sym
->name
);
6575 dt_sym
->attr
.flavor
= FL_DERIVED
;
6576 dt_sym
->attr
.private_comp
= 1;
6577 dt_sym
->attr
.zero_comp
= 1;
6578 dt_sym
->attr
.use_assoc
= 1;
6579 dt_sym
->module
= gfc_get_string (modname
);
6580 dt_sym
->from_intmod
= module
;
6581 dt_sym
->intmod_sym_id
= id
;
6583 head
= sym
->generic
;
6584 intr
= gfc_get_interface ();
6586 intr
->where
= gfc_current_locus
;
6588 sym
->generic
= intr
;
6589 sym
->attr
.if_source
= IFSRC_DECL
;
6593 /* Read the contents of the module file into a temporary buffer. */
6596 read_module_to_tmpbuf ()
6598 /* We don't know the uncompressed size, so enlarge the buffer as
6604 module_content
= XNEWVEC (char, cursz
);
6608 int nread
= gzread (module_fp
, module_content
+ len
, rsize
);
6613 module_content
= XRESIZEVEC (char, module_content
, cursz
);
6614 rsize
= cursz
- len
;
6617 module_content
= XRESIZEVEC (char, module_content
, len
+ 1);
6618 module_content
[len
] = '\0';
6624 /* USE the ISO_FORTRAN_ENV intrinsic module. */
6627 use_iso_fortran_env_module (void)
6629 static char mod
[] = "iso_fortran_env";
6631 gfc_symbol
*mod_sym
;
6632 gfc_symtree
*mod_symtree
;
6636 intmod_sym symbol
[] = {
6637 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
6638 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
6639 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
6640 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
6641 #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
6642 #include "iso-fortran-env.def"
6643 { ISOFORTRANENV_INVALID
, NULL
, -1234, 0 } };
6646 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
6647 #include "iso-fortran-env.def"
6649 /* Generate the symbol for the module itself. */
6650 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, mod
);
6651 if (mod_symtree
== NULL
)
6653 gfc_get_sym_tree (mod
, gfc_current_ns
, &mod_symtree
, false);
6654 gcc_assert (mod_symtree
);
6655 mod_sym
= mod_symtree
->n
.sym
;
6657 mod_sym
->attr
.flavor
= FL_MODULE
;
6658 mod_sym
->attr
.intrinsic
= 1;
6659 mod_sym
->module
= gfc_get_string (mod
);
6660 mod_sym
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
6663 if (!mod_symtree
->n
.sym
->attr
.intrinsic
)
6664 gfc_error ("Use of intrinsic module %qs at %C conflicts with "
6665 "non-intrinsic module name used previously", mod
);
6667 /* Generate the symbols for the module integer named constants. */
6669 for (i
= 0; symbol
[i
].name
; i
++)
6672 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6674 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
6679 if (!gfc_notify_std (symbol
[i
].standard
, "The symbol %qs, "
6680 "referenced at %L, is not in the selected "
6681 "standard", symbol
[i
].name
, &u
->where
))
6684 if ((flag_default_integer
|| flag_default_real
)
6685 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
6686 gfc_warning_now (0, "Use of the NUMERIC_STORAGE_SIZE named "
6687 "constant from intrinsic module "
6688 "ISO_FORTRAN_ENV at %L is incompatible with "
6689 "option %qs", &u
->where
,
6690 flag_default_integer
6691 ? "-fdefault-integer-8"
6692 : "-fdefault-real-8");
6693 switch (symbol
[i
].id
)
6695 #define NAMED_INTCST(a,b,c,d) \
6697 #include "iso-fortran-env.def"
6698 create_int_parameter (u
->local_name
[0] ? u
->local_name
6700 symbol
[i
].value
, mod
,
6701 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
6704 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6706 expr = gfc_get_array_expr (BT_INTEGER, \
6707 gfc_default_integer_kind,\
6709 for (j = 0; KINDS[j].kind != 0; j++) \
6710 gfc_constructor_append_expr (&expr->value.constructor, \
6711 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6712 KINDS[j].kind), NULL); \
6713 create_int_parameter_array (u->local_name[0] ? u->local_name \
6716 INTMOD_ISO_FORTRAN_ENV, \
6719 #include "iso-fortran-env.def"
6721 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6723 #include "iso-fortran-env.def"
6724 create_derived_type (u
->local_name
[0] ? u
->local_name
6726 mod
, INTMOD_ISO_FORTRAN_ENV
,
6730 #define NAMED_FUNCTION(a,b,c,d) \
6732 #include "iso-fortran-env.def"
6733 create_intrinsic_function (u
->local_name
[0] ? u
->local_name
6736 INTMOD_ISO_FORTRAN_ENV
, false,
6746 if (!found
&& !only_flag
)
6748 if ((gfc_option
.allow_std
& symbol
[i
].standard
) == 0)
6751 if ((flag_default_integer
|| flag_default_real
)
6752 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
6754 "Use of the NUMERIC_STORAGE_SIZE named constant "
6755 "from intrinsic module ISO_FORTRAN_ENV at %C is "
6756 "incompatible with option %s",
6757 flag_default_integer
6758 ? "-fdefault-integer-8" : "-fdefault-real-8");
6760 switch (symbol
[i
].id
)
6762 #define NAMED_INTCST(a,b,c,d) \
6764 #include "iso-fortran-env.def"
6765 create_int_parameter (symbol
[i
].name
, symbol
[i
].value
, mod
,
6766 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
6769 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6771 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
6773 for (j = 0; KINDS[j].kind != 0; j++) \
6774 gfc_constructor_append_expr (&expr->value.constructor, \
6775 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6776 KINDS[j].kind), NULL); \
6777 create_int_parameter_array (symbol[i].name, j, expr, mod, \
6778 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
6780 #include "iso-fortran-env.def"
6782 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6784 #include "iso-fortran-env.def"
6785 create_derived_type (symbol
[i
].name
, mod
, INTMOD_ISO_FORTRAN_ENV
,
6789 #define NAMED_FUNCTION(a,b,c,d) \
6791 #include "iso-fortran-env.def"
6792 create_intrinsic_function (symbol
[i
].name
, symbol
[i
].id
, mod
,
6793 INTMOD_ISO_FORTRAN_ENV
, false,
6803 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6808 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6809 "module ISO_FORTRAN_ENV", u
->use_name
, &u
->where
);
6814 /* Process a USE directive. */
6817 gfc_use_module (gfc_use_list
*module
)
6822 gfc_symtree
*mod_symtree
;
6823 gfc_use_list
*use_stmt
;
6824 locus old_locus
= gfc_current_locus
;
6826 gfc_current_locus
= module
->where
;
6827 module_name
= module
->module_name
;
6828 gfc_rename_list
= module
->rename
;
6829 only_flag
= module
->only_flag
;
6830 current_intmod
= INTMOD_NONE
;
6833 gfc_warning_now (OPT_Wuse_without_only
,
6834 "USE statement at %C has no ONLY qualifier");
6836 if (gfc_state_stack
->state
== COMP_MODULE
6837 || module
->submodule_name
== NULL
)
6839 filename
= XALLOCAVEC (char, strlen (module_name
)
6840 + strlen (MODULE_EXTENSION
) + 1);
6841 strcpy (filename
, module_name
);
6842 strcat (filename
, MODULE_EXTENSION
);
6846 filename
= XALLOCAVEC (char, strlen (module
->submodule_name
)
6847 + strlen (SUBMODULE_EXTENSION
) + 1);
6848 strcpy (filename
, module
->submodule_name
);
6849 strcat (filename
, SUBMODULE_EXTENSION
);
6852 /* First, try to find an non-intrinsic module, unless the USE statement
6853 specified that the module is intrinsic. */
6855 if (!module
->intrinsic
)
6856 module_fp
= gzopen_included_file (filename
, true, true);
6858 /* Then, see if it's an intrinsic one, unless the USE statement
6859 specified that the module is non-intrinsic. */
6860 if (module_fp
== NULL
&& !module
->non_intrinsic
)
6862 if (strcmp (module_name
, "iso_fortran_env") == 0
6863 && gfc_notify_std (GFC_STD_F2003
, "ISO_FORTRAN_ENV "
6864 "intrinsic module at %C"))
6866 use_iso_fortran_env_module ();
6867 free_rename (module
->rename
);
6868 module
->rename
= NULL
;
6869 gfc_current_locus
= old_locus
;
6870 module
->intrinsic
= true;
6874 if (strcmp (module_name
, "iso_c_binding") == 0
6875 && gfc_notify_std (GFC_STD_F2003
, "ISO_C_BINDING module at %C"))
6877 import_iso_c_binding_module();
6878 free_rename (module
->rename
);
6879 module
->rename
= NULL
;
6880 gfc_current_locus
= old_locus
;
6881 module
->intrinsic
= true;
6885 module_fp
= gzopen_intrinsic_module (filename
);
6887 if (module_fp
== NULL
&& module
->intrinsic
)
6888 gfc_fatal_error ("Can't find an intrinsic module named %qs at %C",
6891 /* Check for the IEEE modules, so we can mark their symbols
6892 accordingly when we read them. */
6893 if (strcmp (module_name
, "ieee_features") == 0
6894 && gfc_notify_std (GFC_STD_F2003
, "IEEE_FEATURES module at %C"))
6896 current_intmod
= INTMOD_IEEE_FEATURES
;
6898 else if (strcmp (module_name
, "ieee_exceptions") == 0
6899 && gfc_notify_std (GFC_STD_F2003
,
6900 "IEEE_EXCEPTIONS module at %C"))
6902 current_intmod
= INTMOD_IEEE_EXCEPTIONS
;
6904 else if (strcmp (module_name
, "ieee_arithmetic") == 0
6905 && gfc_notify_std (GFC_STD_F2003
,
6906 "IEEE_ARITHMETIC module at %C"))
6908 current_intmod
= INTMOD_IEEE_ARITHMETIC
;
6912 if (module_fp
== NULL
)
6913 gfc_fatal_error ("Can't open module file %qs for reading at %C: %s",
6914 filename
, xstrerror (errno
));
6916 /* Check that we haven't already USEd an intrinsic module with the
6919 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, module_name
);
6920 if (mod_symtree
&& mod_symtree
->n
.sym
->attr
.intrinsic
)
6921 gfc_error ("Use of non-intrinsic module %qs at %C conflicts with "
6922 "intrinsic module name used previously", module_name
);
6929 read_module_to_tmpbuf ();
6930 gzclose (module_fp
);
6932 /* Skip the first line of the module, after checking that this is
6933 a gfortran module file. */
6939 bad_module ("Unexpected end of module");
6942 if ((start
== 1 && strcmp (atom_name
, "GFORTRAN") != 0)
6943 || (start
== 2 && strcmp (atom_name
, " module") != 0))
6944 gfc_fatal_error ("File %qs opened at %C is not a GNU Fortran"
6945 " module file", filename
);
6948 if (strcmp (atom_name
, " version") != 0
6949 || module_char () != ' '
6950 || parse_atom () != ATOM_STRING
6951 || strcmp (atom_string
, MOD_VERSION
))
6952 gfc_fatal_error ("Cannot read module file %qs opened at %C,"
6953 " because it was created by a different"
6954 " version of GNU Fortran", filename
);
6963 /* Make sure we're not reading the same module that we may be building. */
6964 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
6965 if ((p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
)
6966 && strcmp (p
->sym
->name
, module_name
) == 0)
6967 gfc_fatal_error ("Can't USE the same %smodule we're building!",
6968 p
->state
== COMP_SUBMODULE
? "sub" : "");
6971 init_true_name_tree ();
6975 free_true_name (true_name_root
);
6976 true_name_root
= NULL
;
6978 free_pi_tree (pi_root
);
6981 XDELETEVEC (module_content
);
6982 module_content
= NULL
;
6984 use_stmt
= gfc_get_use_list ();
6985 *use_stmt
= *module
;
6986 use_stmt
->next
= gfc_current_ns
->use_stmts
;
6987 gfc_current_ns
->use_stmts
= use_stmt
;
6989 gfc_current_locus
= old_locus
;
6993 /* Remove duplicated intrinsic operators from the rename list. */
6996 rename_list_remove_duplicate (gfc_use_rename
*list
)
6998 gfc_use_rename
*seek
, *last
;
7000 for (; list
; list
= list
->next
)
7001 if (list
->op
!= INTRINSIC_USER
&& list
->op
!= INTRINSIC_NONE
)
7004 for (seek
= list
->next
; seek
; seek
= last
->next
)
7006 if (list
->op
== seek
->op
)
7008 last
->next
= seek
->next
;
7018 /* Process all USE directives. */
7021 gfc_use_modules (void)
7023 gfc_use_list
*next
, *seek
, *last
;
7025 for (next
= module_list
; next
; next
= next
->next
)
7027 bool non_intrinsic
= next
->non_intrinsic
;
7028 bool intrinsic
= next
->intrinsic
;
7029 bool neither
= !non_intrinsic
&& !intrinsic
;
7031 for (seek
= next
->next
; seek
; seek
= seek
->next
)
7033 if (next
->module_name
!= seek
->module_name
)
7036 if (seek
->non_intrinsic
)
7037 non_intrinsic
= true;
7038 else if (seek
->intrinsic
)
7044 if (intrinsic
&& neither
&& !non_intrinsic
)
7049 filename
= XALLOCAVEC (char,
7050 strlen (next
->module_name
)
7051 + strlen (MODULE_EXTENSION
) + 1);
7052 strcpy (filename
, next
->module_name
);
7053 strcat (filename
, MODULE_EXTENSION
);
7054 fp
= gfc_open_included_file (filename
, true, true);
7057 non_intrinsic
= true;
7063 for (seek
= next
->next
; seek
; seek
= last
->next
)
7065 if (next
->module_name
!= seek
->module_name
)
7071 if ((!next
->intrinsic
&& !seek
->intrinsic
)
7072 || (next
->intrinsic
&& seek
->intrinsic
)
7075 if (!seek
->only_flag
)
7076 next
->only_flag
= false;
7079 gfc_use_rename
*r
= seek
->rename
;
7082 r
->next
= next
->rename
;
7083 next
->rename
= seek
->rename
;
7085 last
->next
= seek
->next
;
7093 for (; module_list
; module_list
= next
)
7095 next
= module_list
->next
;
7096 rename_list_remove_duplicate (module_list
->rename
);
7097 gfc_use_module (module_list
);
7100 gfc_rename_list
= NULL
;
7105 gfc_free_use_stmts (gfc_use_list
*use_stmts
)
7108 for (; use_stmts
; use_stmts
= next
)
7110 gfc_use_rename
*next_rename
;
7112 for (; use_stmts
->rename
; use_stmts
->rename
= next_rename
)
7114 next_rename
= use_stmts
->rename
->next
;
7115 free (use_stmts
->rename
);
7117 next
= use_stmts
->next
;
7124 gfc_module_init_2 (void)
7126 last_atom
= ATOM_LPAREN
;
7127 gfc_rename_list
= NULL
;
7133 gfc_module_done_2 (void)
7135 free_rename (gfc_rename_list
);
7136 gfc_rename_list
= NULL
;