1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000-2023 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 "15"
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
);
146 HOST_WIDE_INT integer
;
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
;
190 /* Fully qualified module path */
191 static char *module_fullpath
= NULL
;
193 /* The name of the module we're reading (USE'ing) or writing. */
194 static const char *module_name
;
195 /* The name of the .smod file that the submodule will write to. */
196 static const char *submodule_name
;
198 static gfc_use_list
*module_list
;
200 /* If we're reading an intrinsic module, this is its ID. */
201 static intmod_id current_intmod
;
203 /* Content of module. */
204 static char* module_content
;
206 static long module_pos
;
207 static int module_line
, module_column
, only_flag
;
208 static int prev_module_line
, prev_module_column
;
211 { IO_INPUT
, IO_OUTPUT
}
214 static gfc_use_rename
*gfc_rename_list
;
215 static pointer_info
*pi_root
;
216 static int symbol_number
; /* Counter for assigning symbol numbers */
218 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
219 static bool in_load_equiv
;
223 /*****************************************************************/
225 /* Pointer/integer conversion. Pointers between structures are stored
226 as integers in the module file. The next couple of subroutines
227 handle this translation for reading and writing. */
229 /* Recursively free the tree of pointer structures. */
232 free_pi_tree (pointer_info
*p
)
237 if (p
->fixup
!= NULL
)
238 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
240 free_pi_tree (p
->left
);
241 free_pi_tree (p
->right
);
243 if (iomode
== IO_INPUT
)
245 XDELETEVEC (p
->u
.rsym
.true_name
);
246 XDELETEVEC (p
->u
.rsym
.module
);
247 XDELETEVEC (p
->u
.rsym
.binding_label
);
254 /* Compare pointers when searching by pointer. Used when writing a
258 compare_pointers (void *_sn1
, void *_sn2
)
260 pointer_info
*sn1
, *sn2
;
262 sn1
= (pointer_info
*) _sn1
;
263 sn2
= (pointer_info
*) _sn2
;
265 if (sn1
->u
.pointer
< sn2
->u
.pointer
)
267 if (sn1
->u
.pointer
> sn2
->u
.pointer
)
274 /* Compare integers when searching by integer. Used when reading a
278 compare_integers (void *_sn1
, void *_sn2
)
280 pointer_info
*sn1
, *sn2
;
282 sn1
= (pointer_info
*) _sn1
;
283 sn2
= (pointer_info
*) _sn2
;
285 if (sn1
->integer
< sn2
->integer
)
287 if (sn1
->integer
> sn2
->integer
)
294 /* Initialize the pointer_info tree. */
303 compare
= (iomode
== IO_INPUT
) ? compare_integers
: compare_pointers
;
305 /* Pointer 0 is the NULL pointer. */
306 p
= gfc_get_pointer_info ();
311 gfc_insert_bbt (&pi_root
, p
, compare
);
313 /* Pointer 1 is the current namespace. */
314 p
= gfc_get_pointer_info ();
315 p
->u
.pointer
= gfc_current_ns
;
317 p
->type
= P_NAMESPACE
;
319 gfc_insert_bbt (&pi_root
, p
, compare
);
325 /* During module writing, call here with a pointer to something,
326 returning the pointer_info node. */
328 static pointer_info
*
329 find_pointer (void *gp
)
336 if (p
->u
.pointer
== gp
)
338 p
= (gp
< p
->u
.pointer
) ? p
->left
: p
->right
;
345 /* Given a pointer while writing, returns the pointer_info tree node,
346 creating it if it doesn't exist. */
348 static pointer_info
*
349 get_pointer (void *gp
)
353 p
= find_pointer (gp
);
357 /* Pointer doesn't have an integer. Give it one. */
358 p
= gfc_get_pointer_info ();
361 p
->integer
= symbol_number
++;
363 gfc_insert_bbt (&pi_root
, p
, compare_pointers
);
369 /* Given an integer during reading, find it in the pointer_info tree,
370 creating the node if not found. */
372 static pointer_info
*
373 get_integer (HOST_WIDE_INT integer
)
383 c
= compare_integers (&t
, p
);
387 p
= (c
< 0) ? p
->left
: p
->right
;
393 p
= gfc_get_pointer_info ();
394 p
->integer
= integer
;
397 gfc_insert_bbt (&pi_root
, p
, compare_integers
);
403 /* Resolve any fixups using a known pointer. */
406 resolve_fixups (fixup_t
*f
, void *gp
)
419 /* Convert a string such that it starts with a lower-case character. Used
420 to convert the symtree name of a derived-type to the symbol name or to
421 the name of the associated generic function. */
424 gfc_dt_lower_string (const char *name
)
426 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
427 return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name
[0]),
429 return gfc_get_string ("%s", name
);
433 /* Convert a string such that it starts with an upper-case character. Used to
434 return the symtree-name for a derived type; the symbol name itself and the
435 symtree/symbol name of the associated generic function start with a lower-
439 gfc_dt_upper_string (const char *name
)
441 if (name
[0] != (char) TOUPPER ((unsigned char) name
[0]))
442 return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name
[0]),
444 return gfc_get_string ("%s", name
);
447 /* Call here during module reading when we know what pointer to
448 associate with an integer. Any fixups that exist are resolved at
452 associate_integer_pointer (pointer_info
*p
, void *gp
)
454 if (p
->u
.pointer
!= NULL
)
455 gfc_internal_error ("associate_integer_pointer(): Already associated");
459 resolve_fixups (p
->fixup
, gp
);
465 /* During module reading, given an integer and a pointer to a pointer,
466 either store the pointer from an already-known value or create a
467 fixup structure in order to store things later. Returns zero if
468 the reference has been actually stored, or nonzero if the reference
469 must be fixed later (i.e., associate_integer_pointer must be called
470 sometime later. Returns the pointer_info structure. */
472 static pointer_info
*
473 add_fixup (HOST_WIDE_INT integer
, void *gp
)
479 p
= get_integer (integer
);
481 if (p
->integer
== 0 || p
->u
.pointer
!= NULL
)
484 *cp
= (char *) p
->u
.pointer
;
493 f
->pointer
= (void **) gp
;
500 /*****************************************************************/
502 /* Parser related subroutines */
504 /* Free the rename list left behind by a USE statement. */
507 free_rename (gfc_use_rename
*list
)
509 gfc_use_rename
*next
;
511 for (; list
; list
= next
)
519 /* Match a USE statement. */
524 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module_nature
[GFC_MAX_SYMBOL_LEN
+ 1];
525 gfc_use_rename
*tail
= NULL
, *new_use
;
526 interface_type type
, type2
;
529 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 ("%s", 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
:
639 loc
= gfc_current_locus
;
641 m
= gfc_match (" =>");
643 if (type
== INTERFACE_USER_OP
&& m
== MATCH_YES
644 && (!gfc_notify_std(GFC_STD_F2003
, "Renaming "
645 "operators in USE statements at %C")))
648 if (type
== INTERFACE_USER_OP
)
649 new_use
->op
= INTRINSIC_USER
;
651 if (use_list
->only_flag
)
654 strcpy (new_use
->use_name
, name
);
657 strcpy (new_use
->local_name
, name
);
658 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
663 if (m
== MATCH_ERROR
)
671 strcpy (new_use
->local_name
, name
);
673 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
678 if (m
== MATCH_ERROR
)
682 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
683 if (st
&& type
!= INTERFACE_USER_OP
684 && (st
->n
.sym
->module
!= use_list
->module_name
685 || strcmp (st
->n
.sym
->name
, new_use
->use_name
) != 0))
688 gfc_error ("Symbol %qs at %L conflicts with the rename symbol "
689 "at %L", name
, &st
->n
.sym
->declared_at
, &loc
);
691 gfc_error ("Symbol %qs at %L conflicts with the symbol "
692 "at %L", name
, &st
->n
.sym
->declared_at
, &loc
);
696 if (strcmp (new_use
->use_name
, use_list
->module_name
) == 0
697 || strcmp (new_use
->local_name
, use_list
->module_name
) == 0)
699 gfc_error ("The name %qs at %C has already been used as "
700 "an external module name", use_list
->module_name
);
705 case INTERFACE_INTRINSIC_OP
:
713 if (gfc_match_eos () == MATCH_YES
)
715 if (gfc_match_char (',') != MATCH_YES
)
722 gfc_use_list
*last
= module_list
;
725 last
->next
= use_list
;
728 module_list
= use_list
;
733 gfc_syntax_error (ST_USE
);
736 free_rename (use_list
->rename
);
742 /* Match a SUBMODULE statement.
744 According to F2008:11.2.3.2, "The submodule identifier is the
745 ordered pair whose first element is the ancestor module name and
746 whose second element is the submodule name. 'Submodule_name' is
747 used for the submodule filename and uses '@' as a separator, whilst
748 the name of the symbol for the module uses '.' as a separator.
749 The reasons for these choices are:
750 (i) To follow another leading brand in the submodule filenames;
751 (ii) Since '.' is not particularly visible in the filenames; and
752 (iii) The linker does not permit '@' in mnemonics. */
755 gfc_match_submodule (void)
758 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
759 gfc_use_list
*use_list
;
760 bool seen_colon
= false;
762 if (!gfc_notify_std (GFC_STD_F2008
, "SUBMODULE declaration at %C"))
765 if (gfc_current_state () != COMP_NONE
)
767 gfc_error ("SUBMODULE declaration at %C cannot appear within "
768 "another scoping unit");
772 gfc_new_block
= NULL
;
773 gcc_assert (module_list
== NULL
);
775 if (gfc_match_char ('(') != MATCH_YES
)
780 m
= gfc_match (" %n", name
);
784 use_list
= gfc_get_use_list ();
785 use_list
->where
= gfc_current_locus
;
789 gfc_use_list
*last
= module_list
;
792 last
->next
= use_list
;
793 use_list
->module_name
794 = gfc_get_string ("%s.%s", module_list
->module_name
, name
);
795 use_list
->submodule_name
796 = gfc_get_string ("%s@%s", module_list
->module_name
, name
);
800 module_list
= use_list
;
801 use_list
->module_name
= gfc_get_string ("%s", name
);
802 use_list
->submodule_name
= use_list
->module_name
;
805 if (gfc_match_char (')') == MATCH_YES
)
808 if (gfc_match_char (':') != MATCH_YES
815 m
= gfc_match (" %s%t", &gfc_new_block
);
819 submodule_name
= gfc_get_string ("%s@%s", module_list
->module_name
,
820 gfc_new_block
->name
);
822 gfc_new_block
->name
= gfc_get_string ("%s.%s",
823 module_list
->module_name
,
824 gfc_new_block
->name
);
826 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
827 gfc_new_block
->name
, NULL
))
830 /* Just retain the ultimate .(s)mod file for reading, since it
831 contains all the information in its ancestors. */
832 use_list
= module_list
;
833 for (; module_list
->next
; use_list
= module_list
)
835 module_list
= use_list
->next
;
842 gfc_error ("Syntax error in SUBMODULE statement at %C");
847 /* Given a name and a number, inst, return the inst name
848 under which to load this symbol. Returns NULL if this
849 symbol shouldn't be loaded. If inst is zero, returns
850 the number of instances of this name. If interface is
851 true, a user-defined operator is sought, otherwise only
852 non-operators are sought. */
855 find_use_name_n (const char *name
, int *inst
, bool interface
)
858 const char *low_name
= NULL
;
861 /* For derived types. */
862 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
863 low_name
= gfc_dt_lower_string (name
);
866 for (u
= gfc_rename_list
; u
; u
= u
->next
)
868 if ((!low_name
&& strcmp (u
->use_name
, name
) != 0)
869 || (low_name
&& strcmp (u
->use_name
, low_name
) != 0)
870 || (u
->op
== INTRINSIC_USER
&& !interface
)
871 || (u
->op
!= INTRINSIC_USER
&& interface
))
884 return only_flag
? NULL
: name
;
890 if (u
->local_name
[0] == '\0')
892 return gfc_dt_upper_string (u
->local_name
);
895 return (u
->local_name
[0] != '\0') ? u
->local_name
: name
;
899 /* Given a name, return the name under which to load this symbol.
900 Returns NULL if this symbol shouldn't be loaded. */
903 find_use_name (const char *name
, bool interface
)
906 return find_use_name_n (name
, &i
, interface
);
910 /* Given a real name, return the number of use names associated with it. */
913 number_use_names (const char *name
, bool interface
)
916 find_use_name_n (name
, &i
, interface
);
921 /* Try to find the operator in the current list. */
923 static gfc_use_rename
*
924 find_use_operator (gfc_intrinsic_op op
)
928 for (u
= gfc_rename_list
; u
; u
= u
->next
)
936 /*****************************************************************/
938 /* The next couple of subroutines maintain a tree used to avoid a
939 brute-force search for a combination of true name and module name.
940 While symtree names, the name that a particular symbol is known by
941 can changed with USE statements, we still have to keep track of the
942 true names to generate the correct reference, and also avoid
943 loading the same real symbol twice in a program unit.
945 When we start reading, the true name tree is built and maintained
946 as symbols are read. The tree is searched as we load new symbols
947 to see if it already exists someplace in the namespace. */
949 typedef struct true_name
951 BBT_HEADER (true_name
);
957 static true_name
*true_name_root
;
960 /* Compare two true_name structures. */
963 compare_true_names (void *_t1
, void *_t2
)
968 t1
= (true_name
*) _t1
;
969 t2
= (true_name
*) _t2
;
971 c
= ((t1
->sym
->module
> t2
->sym
->module
)
972 - (t1
->sym
->module
< t2
->sym
->module
));
976 return strcmp (t1
->name
, t2
->name
);
980 /* Given a true name, search the true name tree to see if it exists
981 within the main namespace. */
984 find_true_name (const char *name
, const char *module
)
990 t
.name
= gfc_get_string ("%s", name
);
992 sym
.module
= gfc_get_string ("%s", module
);
1000 c
= compare_true_names ((void *) (&t
), (void *) p
);
1004 p
= (c
< 0) ? p
->left
: p
->right
;
1011 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
1014 add_true_name (gfc_symbol
*sym
)
1018 t
= XCNEW (true_name
);
1020 if (gfc_fl_struct (sym
->attr
.flavor
))
1021 t
->name
= gfc_dt_upper_string (sym
->name
);
1023 t
->name
= sym
->name
;
1025 gfc_insert_bbt (&true_name_root
, t
, compare_true_names
);
1029 /* Recursive function to build the initial true name tree by
1030 recursively traversing the current namespace. */
1033 build_tnt (gfc_symtree
*st
)
1039 build_tnt (st
->left
);
1040 build_tnt (st
->right
);
1042 if (gfc_fl_struct (st
->n
.sym
->attr
.flavor
))
1043 name
= gfc_dt_upper_string (st
->n
.sym
->name
);
1045 name
= st
->n
.sym
->name
;
1047 if (find_true_name (name
, st
->n
.sym
->module
) != NULL
)
1050 add_true_name (st
->n
.sym
);
1054 /* Initialize the true name tree with the current namespace. */
1057 init_true_name_tree (void)
1059 true_name_root
= NULL
;
1060 build_tnt (gfc_current_ns
->sym_root
);
1064 /* Recursively free a true name tree node. */
1067 free_true_name (true_name
*t
)
1071 free_true_name (t
->left
);
1072 free_true_name (t
->right
);
1078 /*****************************************************************/
1080 /* Module reading and writing. */
1082 /* The following are versions similar to the ones in scanner.cc, but
1083 for dealing with compressed module files. */
1086 gzopen_included_file_1 (const char *name
, gfc_directorylist
*list
,
1087 bool module
, bool system
)
1090 gfc_directorylist
*p
;
1093 for (p
= list
; p
; p
= p
->next
)
1095 if (module
&& !p
->use_for_modules
)
1098 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 2);
1099 strcpy (fullname
, p
->path
);
1100 strcat (fullname
, "/");
1101 strcat (fullname
, name
);
1103 f
= gzopen (fullname
, "r");
1106 if (gfc_cpp_makedep ())
1107 gfc_cpp_add_dep (fullname
, system
);
1109 free (module_fullpath
);
1110 module_fullpath
= xstrdup (fullname
);
1119 gzopen_included_file (const char *name
, bool include_cwd
, bool module
)
1123 if (IS_ABSOLUTE_PATH (name
) || include_cwd
)
1125 f
= gzopen (name
, "r");
1128 if (gfc_cpp_makedep ())
1129 gfc_cpp_add_dep (name
, false);
1131 free (module_fullpath
);
1132 module_fullpath
= xstrdup (name
);
1137 f
= gzopen_included_file_1 (name
, include_dirs
, module
, false);
1143 gzopen_intrinsic_module (const char* name
)
1147 if (IS_ABSOLUTE_PATH (name
))
1149 f
= gzopen (name
, "r");
1152 if (gfc_cpp_makedep ())
1153 gfc_cpp_add_dep (name
, true);
1155 free (module_fullpath
);
1156 module_fullpath
= xstrdup (name
);
1161 f
= gzopen_included_file_1 (name
, intrinsic_modules_dirs
, true, true);
1169 ATOM_NAME
, ATOM_LPAREN
, ATOM_RPAREN
, ATOM_INTEGER
, ATOM_STRING
1172 static atom_type last_atom
;
1175 /* The name buffer must be at least as long as a symbol name. Right
1176 now it's not clear how we're going to store numeric constants--
1177 probably as a hexadecimal string, since this will allow the exact
1178 number to be preserved (this can't be done by a decimal
1179 representation). Worry about that later. TODO! */
1181 #define MAX_ATOM_SIZE 100
1183 static HOST_WIDE_INT atom_int
;
1184 static char *atom_string
, atom_name
[MAX_ATOM_SIZE
];
1187 /* Report problems with a module. Error reporting is not very
1188 elaborate, since this sorts of errors shouldn't really happen.
1189 This subroutine never returns. */
1191 static void bad_module (const char *) ATTRIBUTE_NORETURN
;
1194 bad_module (const char *msgid
)
1196 XDELETEVEC (module_content
);
1197 module_content
= NULL
;
1202 gfc_fatal_error ("Reading module %qs at line %d column %d: %s",
1203 module_fullpath
, module_line
, module_column
, msgid
);
1206 gfc_fatal_error ("Writing module %qs at line %d column %d: %s",
1207 module_name
, module_line
, module_column
, msgid
);
1210 gfc_fatal_error ("Module %qs at line %d column %d: %s",
1211 module_name
, module_line
, module_column
, msgid
);
1217 /* Set the module's input pointer. */
1220 set_module_locus (module_locus
*m
)
1222 module_column
= m
->column
;
1223 module_line
= m
->line
;
1224 module_pos
= m
->pos
;
1228 /* Get the module's input pointer so that we can restore it later. */
1231 get_module_locus (module_locus
*m
)
1233 m
->column
= module_column
;
1234 m
->line
= module_line
;
1235 m
->pos
= module_pos
;
1238 /* Peek at the next character in the module. */
1241 module_peek_char (void)
1243 return module_content
[module_pos
];
1246 /* Get the next character in the module, updating our reckoning of
1252 const char c
= module_content
[module_pos
++];
1254 bad_module ("Unexpected EOF");
1256 prev_module_line
= module_line
;
1257 prev_module_column
= module_column
;
1269 /* Unget a character while remembering the line and column. Works for
1270 a single character only. */
1273 module_unget_char (void)
1275 module_line
= prev_module_line
;
1276 module_column
= prev_module_column
;
1280 /* Parse a string constant. The delimiter is guaranteed to be a
1290 atom_string
= XNEWVEC (char, cursz
);
1298 int c2
= module_char ();
1301 module_unget_char ();
1309 atom_string
= XRESIZEVEC (char, atom_string
, cursz
);
1311 atom_string
[len
] = c
;
1315 atom_string
= XRESIZEVEC (char, atom_string
, len
+ 1);
1316 atom_string
[len
] = '\0'; /* C-style string for debug purposes. */
1320 /* Parse an integer. Should fit in a HOST_WIDE_INT. */
1323 parse_integer (int c
)
1344 module_unget_char ();
1348 atom_int
= 10 * atom_int
+ c
- '0';
1371 if (!ISALNUM (c
) && c
!= '_' && c
!= '-')
1373 module_unget_char ();
1378 if (++len
> GFC_MAX_SYMBOL_LEN
)
1379 bad_module ("Name too long");
1387 /* Read the next atom in the module's input stream. */
1398 while (c
== ' ' || c
== '\r' || c
== '\n');
1423 return ATOM_INTEGER
;
1427 if (ISDIGIT (module_peek_char ()))
1430 return ATOM_INTEGER
;
1433 bad_module ("Bad name");
1491 bad_module ("Bad name");
1498 /* Peek at the next atom on the input. */
1509 while (c
== ' ' || c
== '\r' || c
== '\n');
1514 module_unget_char ();
1518 module_unget_char ();
1522 module_unget_char ();
1535 module_unget_char ();
1536 return ATOM_INTEGER
;
1540 if (ISDIGIT (module_peek_char ()))
1542 module_unget_char ();
1543 return ATOM_INTEGER
;
1546 bad_module ("Bad name");
1600 module_unget_char ();
1604 bad_module ("Bad name");
1609 /* Read the next atom from the input, requiring that it be a
1613 require_atom (atom_type type
)
1619 column
= module_column
;
1628 p
= _("Expected name");
1631 p
= _("Expected left parenthesis");
1634 p
= _("Expected right parenthesis");
1637 p
= _("Expected integer");
1640 p
= _("Expected string");
1643 gfc_internal_error ("require_atom(): bad atom type required");
1646 module_column
= column
;
1653 /* Given a pointer to an mstring array, require that the current input
1654 be one of the strings in the array. We return the enum value. */
1657 find_enum (const mstring
*m
)
1661 i
= gfc_string2code (m
, atom_name
);
1665 bad_module ("find_enum(): Enum not found");
1671 /* Read a string. The caller is responsible for freeing. */
1677 require_atom (ATOM_STRING
);
1684 /**************** Module output subroutines ***************************/
1686 /* Output a character to a module file. */
1689 write_char (char out
)
1691 if (gzputc (module_fp
, out
) == EOF
)
1692 gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno
));
1704 /* Write an atom to a module. The line wrapping isn't perfect, but it
1705 should work most of the time. This isn't that big of a deal, since
1706 the file really isn't meant to be read by people anyway. */
1709 write_atom (atom_type atom
, const void *v
)
1713 /* Workaround -Wmaybe-uninitialized false positive during
1714 profiledbootstrap by initializing them. */
1716 HOST_WIDE_INT i
= 0;
1723 p
= (const char *) v
;
1735 i
= *((const HOST_WIDE_INT
*) v
);
1737 snprintf (buffer
, sizeof (buffer
), HOST_WIDE_INT_PRINT_DEC
, i
);
1742 gfc_internal_error ("write_atom(): Trying to write dab atom");
1746 if(p
== NULL
|| *p
== '\0')
1751 if (atom
!= ATOM_RPAREN
)
1753 if (module_column
+ len
> 72)
1758 if (last_atom
!= ATOM_LPAREN
&& module_column
!= 1)
1763 if (atom
== ATOM_STRING
)
1766 while (p
!= NULL
&& *p
)
1768 if (atom
== ATOM_STRING
&& *p
== '\'')
1773 if (atom
== ATOM_STRING
)
1781 /***************** Mid-level I/O subroutines *****************/
1783 /* These subroutines let their caller read or write atoms without
1784 caring about which of the two is actually happening. This lets a
1785 subroutine concentrate on the actual format of the data being
1788 static void mio_expr (gfc_expr
**);
1789 pointer_info
*mio_symbol_ref (gfc_symbol
**);
1790 pointer_info
*mio_interface_rest (gfc_interface
**);
1791 static void mio_symtree_ref (gfc_symtree
**);
1793 /* Read or write an enumerated value. On writing, we return the input
1794 value for the convenience of callers. We avoid using an integer
1795 pointer because enums are sometimes inside bitfields. */
1798 mio_name (int t
, const mstring
*m
)
1800 if (iomode
== IO_OUTPUT
)
1801 write_atom (ATOM_NAME
, gfc_code2string (m
, t
));
1804 require_atom (ATOM_NAME
);
1811 /* Specialization of mio_name. */
1813 #define DECL_MIO_NAME(TYPE) \
1814 static inline TYPE \
1815 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1817 return (TYPE) mio_name ((int) t, m); \
1819 #define MIO_NAME(TYPE) mio_name_##TYPE
1824 if (iomode
== IO_OUTPUT
)
1825 write_atom (ATOM_LPAREN
, NULL
);
1827 require_atom (ATOM_LPAREN
);
1834 if (iomode
== IO_OUTPUT
)
1835 write_atom (ATOM_RPAREN
, NULL
);
1837 require_atom (ATOM_RPAREN
);
1842 mio_integer (int *ip
)
1844 if (iomode
== IO_OUTPUT
)
1846 HOST_WIDE_INT hwi
= *ip
;
1847 write_atom (ATOM_INTEGER
, &hwi
);
1851 require_atom (ATOM_INTEGER
);
1857 mio_hwi (HOST_WIDE_INT
*hwi
)
1859 if (iomode
== IO_OUTPUT
)
1860 write_atom (ATOM_INTEGER
, hwi
);
1863 require_atom (ATOM_INTEGER
);
1869 /* Read or write a gfc_intrinsic_op value. */
1872 mio_intrinsic_op (gfc_intrinsic_op
* op
)
1874 /* FIXME: Would be nicer to do this via the operators symbolic name. */
1875 if (iomode
== IO_OUTPUT
)
1877 HOST_WIDE_INT converted
= (HOST_WIDE_INT
) *op
;
1878 write_atom (ATOM_INTEGER
, &converted
);
1882 require_atom (ATOM_INTEGER
);
1883 *op
= (gfc_intrinsic_op
) atom_int
;
1888 /* Read or write a character pointer that points to a string on the heap. */
1891 mio_allocated_string (const char *s
)
1893 if (iomode
== IO_OUTPUT
)
1895 write_atom (ATOM_STRING
, s
);
1900 require_atom (ATOM_STRING
);
1906 /* Functions for quoting and unquoting strings. */
1909 quote_string (const gfc_char_t
*s
, const size_t slength
)
1911 const gfc_char_t
*p
;
1915 /* Calculate the length we'll need: a backslash takes two ("\\"),
1916 non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */
1917 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1921 else if (!gfc_wide_is_printable (*p
))
1927 q
= res
= XCNEWVEC (char, len
+ 1);
1928 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1931 *q
++ = '\\', *q
++ = '\\';
1932 else if (!gfc_wide_is_printable (*p
))
1934 sprintf (q
, "\\U%08" HOST_WIDE_INT_PRINT
"x",
1935 (unsigned HOST_WIDE_INT
) *p
);
1939 *q
++ = (unsigned char) *p
;
1947 unquote_string (const char *s
)
1953 for (p
= s
, len
= 0; *p
; p
++, len
++)
1960 else if (p
[1] == 'U')
1961 p
+= 9; /* That is a "\U????????". */
1963 gfc_internal_error ("unquote_string(): got bad string");
1966 res
= gfc_get_wide_string (len
+ 1);
1967 for (i
= 0, p
= s
; i
< len
; i
++, p
++)
1972 res
[i
] = (unsigned char) *p
;
1973 else if (p
[1] == '\\')
1975 res
[i
] = (unsigned char) '\\';
1980 /* We read the 8-digits hexadecimal constant that follows. */
1985 gcc_assert (p
[1] == 'U');
1986 for (j
= 0; j
< 8; j
++)
1989 gcc_assert (sscanf (&p
[j
+2], "%01x", &n
) == 1);
2003 /* Read or write a character pointer that points to a wide string on the
2004 heap, performing quoting/unquoting of nonprintable characters using the
2005 form \U???????? (where each ? is a hexadecimal digit).
2006 Length is the length of the string, only known and used in output mode. */
2008 static const gfc_char_t
*
2009 mio_allocated_wide_string (const gfc_char_t
*s
, const size_t length
)
2011 if (iomode
== IO_OUTPUT
)
2013 char *quoted
= quote_string (s
, length
);
2014 write_atom (ATOM_STRING
, quoted
);
2020 gfc_char_t
*unquoted
;
2022 require_atom (ATOM_STRING
);
2023 unquoted
= unquote_string (atom_string
);
2030 /* Read or write a string that is in static memory. */
2033 mio_pool_string (const char **stringp
)
2035 /* TODO: one could write the string only once, and refer to it via a
2038 /* As a special case we have to deal with a NULL string. This
2039 happens for the 'module' member of 'gfc_symbol's that are not in a
2040 module. We read / write these as the empty string. */
2041 if (iomode
== IO_OUTPUT
)
2043 const char *p
= *stringp
== NULL
? "" : *stringp
;
2044 write_atom (ATOM_STRING
, p
);
2048 require_atom (ATOM_STRING
);
2049 *stringp
= (atom_string
[0] == '\0'
2050 ? NULL
: gfc_get_string ("%s", atom_string
));
2056 /* Read or write a string that is inside of some already-allocated
2060 mio_internal_string (char *string
)
2062 if (iomode
== IO_OUTPUT
)
2063 write_atom (ATOM_STRING
, string
);
2066 require_atom (ATOM_STRING
);
2067 strcpy (string
, atom_string
);
2074 { AB_ALLOCATABLE
, AB_DIMENSION
, AB_EXTERNAL
, AB_INTRINSIC
, AB_OPTIONAL
,
2075 AB_POINTER
, AB_TARGET
, AB_DUMMY
, AB_RESULT
, AB_DATA
,
2076 AB_IN_NAMELIST
, AB_IN_COMMON
, AB_FUNCTION
, AB_SUBROUTINE
, AB_SEQUENCE
,
2077 AB_ELEMENTAL
, AB_PURE
, AB_RECURSIVE
, AB_GENERIC
, AB_ALWAYS_EXPLICIT
,
2078 AB_CRAY_POINTER
, AB_CRAY_POINTEE
, AB_THREADPRIVATE
,
2079 AB_ALLOC_COMP
, AB_POINTER_COMP
, AB_PROC_POINTER_COMP
, AB_PRIVATE_COMP
,
2080 AB_VALUE
, AB_VOLATILE
, AB_PROTECTED
, AB_LOCK_COMP
, AB_EVENT_COMP
,
2081 AB_IS_BIND_C
, AB_IS_C_INTEROP
, AB_IS_ISO_C
, AB_ABSTRACT
, AB_ZERO_COMP
,
2082 AB_IS_CLASS
, AB_PROCEDURE
, AB_PROC_POINTER
, AB_ASYNCHRONOUS
, AB_CODIMENSION
,
2083 AB_COARRAY_COMP
, AB_VTYPE
, AB_VTAB
, AB_CONTIGUOUS
, AB_CLASS_POINTER
,
2084 AB_IMPLICIT_PURE
, AB_ARTIFICIAL
, AB_UNLIMITED_POLY
, AB_OMP_DECLARE_TARGET
,
2085 AB_ARRAY_OUTER_DEPENDENCY
, AB_MODULE_PROCEDURE
, AB_OACC_DECLARE_CREATE
,
2086 AB_OACC_DECLARE_COPYIN
, AB_OACC_DECLARE_DEVICEPTR
,
2087 AB_OACC_DECLARE_DEVICE_RESIDENT
, AB_OACC_DECLARE_LINK
,
2088 AB_OMP_DECLARE_TARGET_LINK
, AB_PDT_KIND
, AB_PDT_LEN
, AB_PDT_TYPE
,
2089 AB_PDT_TEMPLATE
, AB_PDT_ARRAY
, AB_PDT_STRING
,
2090 AB_OACC_ROUTINE_LOP_GANG
, AB_OACC_ROUTINE_LOP_WORKER
,
2091 AB_OACC_ROUTINE_LOP_VECTOR
, AB_OACC_ROUTINE_LOP_SEQ
,
2092 AB_OACC_ROUTINE_NOHOST
,
2093 AB_OMP_REQ_REVERSE_OFFLOAD
, AB_OMP_REQ_UNIFIED_ADDRESS
,
2094 AB_OMP_REQ_UNIFIED_SHARED_MEMORY
, AB_OMP_REQ_DYNAMIC_ALLOCATORS
,
2095 AB_OMP_REQ_MEM_ORDER_SEQ_CST
, AB_OMP_REQ_MEM_ORDER_ACQ_REL
,
2096 AB_OMP_REQ_MEM_ORDER_ACQUIRE
, AB_OMP_REQ_MEM_ORDER_RELEASE
,
2097 AB_OMP_REQ_MEM_ORDER_RELAXED
, AB_OMP_DEVICE_TYPE_NOHOST
,
2098 AB_OMP_DEVICE_TYPE_HOST
, AB_OMP_DEVICE_TYPE_ANY
2101 static const mstring attr_bits
[] =
2103 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
2104 minit ("ARTIFICIAL", AB_ARTIFICIAL
),
2105 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS
),
2106 minit ("DIMENSION", AB_DIMENSION
),
2107 minit ("CODIMENSION", AB_CODIMENSION
),
2108 minit ("CONTIGUOUS", AB_CONTIGUOUS
),
2109 minit ("EXTERNAL", AB_EXTERNAL
),
2110 minit ("INTRINSIC", AB_INTRINSIC
),
2111 minit ("OPTIONAL", AB_OPTIONAL
),
2112 minit ("POINTER", AB_POINTER
),
2113 minit ("VOLATILE", AB_VOLATILE
),
2114 minit ("TARGET", AB_TARGET
),
2115 minit ("THREADPRIVATE", AB_THREADPRIVATE
),
2116 minit ("DUMMY", AB_DUMMY
),
2117 minit ("RESULT", AB_RESULT
),
2118 minit ("DATA", AB_DATA
),
2119 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
2120 minit ("IN_COMMON", AB_IN_COMMON
),
2121 minit ("FUNCTION", AB_FUNCTION
),
2122 minit ("SUBROUTINE", AB_SUBROUTINE
),
2123 minit ("SEQUENCE", AB_SEQUENCE
),
2124 minit ("ELEMENTAL", AB_ELEMENTAL
),
2125 minit ("PURE", AB_PURE
),
2126 minit ("RECURSIVE", AB_RECURSIVE
),
2127 minit ("GENERIC", AB_GENERIC
),
2128 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
2129 minit ("CRAY_POINTER", AB_CRAY_POINTER
),
2130 minit ("CRAY_POINTEE", AB_CRAY_POINTEE
),
2131 minit ("IS_BIND_C", AB_IS_BIND_C
),
2132 minit ("IS_C_INTEROP", AB_IS_C_INTEROP
),
2133 minit ("IS_ISO_C", AB_IS_ISO_C
),
2134 minit ("VALUE", AB_VALUE
),
2135 minit ("ALLOC_COMP", AB_ALLOC_COMP
),
2136 minit ("COARRAY_COMP", AB_COARRAY_COMP
),
2137 minit ("LOCK_COMP", AB_LOCK_COMP
),
2138 minit ("EVENT_COMP", AB_EVENT_COMP
),
2139 minit ("POINTER_COMP", AB_POINTER_COMP
),
2140 minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP
),
2141 minit ("PRIVATE_COMP", AB_PRIVATE_COMP
),
2142 minit ("ZERO_COMP", AB_ZERO_COMP
),
2143 minit ("PROTECTED", AB_PROTECTED
),
2144 minit ("ABSTRACT", AB_ABSTRACT
),
2145 minit ("IS_CLASS", AB_IS_CLASS
),
2146 minit ("PROCEDURE", AB_PROCEDURE
),
2147 minit ("PROC_POINTER", AB_PROC_POINTER
),
2148 minit ("VTYPE", AB_VTYPE
),
2149 minit ("VTAB", AB_VTAB
),
2150 minit ("CLASS_POINTER", AB_CLASS_POINTER
),
2151 minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE
),
2152 minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY
),
2153 minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET
),
2154 minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY
),
2155 minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE
),
2156 minit ("OACC_DECLARE_CREATE", AB_OACC_DECLARE_CREATE
),
2157 minit ("OACC_DECLARE_COPYIN", AB_OACC_DECLARE_COPYIN
),
2158 minit ("OACC_DECLARE_DEVICEPTR", AB_OACC_DECLARE_DEVICEPTR
),
2159 minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT
),
2160 minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK
),
2161 minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK
),
2162 minit ("PDT_KIND", AB_PDT_KIND
),
2163 minit ("PDT_LEN", AB_PDT_LEN
),
2164 minit ("PDT_TYPE", AB_PDT_TYPE
),
2165 minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE
),
2166 minit ("PDT_ARRAY", AB_PDT_ARRAY
),
2167 minit ("PDT_STRING", AB_PDT_STRING
),
2168 minit ("OACC_ROUTINE_LOP_GANG", AB_OACC_ROUTINE_LOP_GANG
),
2169 minit ("OACC_ROUTINE_LOP_WORKER", AB_OACC_ROUTINE_LOP_WORKER
),
2170 minit ("OACC_ROUTINE_LOP_VECTOR", AB_OACC_ROUTINE_LOP_VECTOR
),
2171 minit ("OACC_ROUTINE_LOP_SEQ", AB_OACC_ROUTINE_LOP_SEQ
),
2172 minit ("OACC_ROUTINE_NOHOST", AB_OACC_ROUTINE_NOHOST
),
2173 minit ("OMP_REQ_REVERSE_OFFLOAD", AB_OMP_REQ_REVERSE_OFFLOAD
),
2174 minit ("OMP_REQ_UNIFIED_ADDRESS", AB_OMP_REQ_UNIFIED_ADDRESS
),
2175 minit ("OMP_REQ_UNIFIED_SHARED_MEMORY", AB_OMP_REQ_UNIFIED_SHARED_MEMORY
),
2176 minit ("OMP_REQ_DYNAMIC_ALLOCATORS", AB_OMP_REQ_DYNAMIC_ALLOCATORS
),
2177 minit ("OMP_REQ_MEM_ORDER_SEQ_CST", AB_OMP_REQ_MEM_ORDER_SEQ_CST
),
2178 minit ("OMP_REQ_MEM_ORDER_ACQ_REL", AB_OMP_REQ_MEM_ORDER_ACQ_REL
),
2179 minit ("OMP_REQ_MEM_ORDER_ACQUIRE", AB_OMP_REQ_MEM_ORDER_ACQUIRE
),
2180 minit ("OMP_REQ_MEM_ORDER_RELAXED", AB_OMP_REQ_MEM_ORDER_RELAXED
),
2181 minit ("OMP_REQ_MEM_ORDER_RELEASE", AB_OMP_REQ_MEM_ORDER_RELEASE
),
2182 minit ("OMP_DEVICE_TYPE_HOST", AB_OMP_DEVICE_TYPE_HOST
),
2183 minit ("OMP_DEVICE_TYPE_NOHOST", AB_OMP_DEVICE_TYPE_NOHOST
),
2184 minit ("OMP_DEVICE_TYPE_ANYHOST", AB_OMP_DEVICE_TYPE_ANY
),
2188 /* For binding attributes. */
2189 static const mstring binding_passing
[] =
2192 minit ("NOPASS", 1),
2195 static const mstring binding_overriding
[] =
2197 minit ("OVERRIDABLE", 0),
2198 minit ("NON_OVERRIDABLE", 1),
2199 minit ("DEFERRED", 2),
2202 static const mstring binding_generic
[] =
2204 minit ("SPECIFIC", 0),
2205 minit ("GENERIC", 1),
2208 static const mstring binding_ppc
[] =
2210 minit ("NO_PPC", 0),
2215 /* Specialization of mio_name. */
2216 DECL_MIO_NAME (ab_attribute
)
2217 DECL_MIO_NAME (ar_type
)
2218 DECL_MIO_NAME (array_type
)
2220 DECL_MIO_NAME (expr_t
)
2221 DECL_MIO_NAME (gfc_access
)
2222 DECL_MIO_NAME (gfc_intrinsic_op
)
2223 DECL_MIO_NAME (ifsrc
)
2224 DECL_MIO_NAME (save_state
)
2225 DECL_MIO_NAME (procedure_type
)
2226 DECL_MIO_NAME (ref_type
)
2227 DECL_MIO_NAME (sym_flavor
)
2228 DECL_MIO_NAME (sym_intent
)
2229 DECL_MIO_NAME (inquiry_type
)
2230 #undef DECL_MIO_NAME
2232 /* Verify OACC_ROUTINE_LOP_NONE. */
2235 verify_OACC_ROUTINE_LOP_NONE (enum oacc_routine_lop lop
)
2237 if (lop
!= OACC_ROUTINE_LOP_NONE
)
2238 bad_module ("Unsupported: multiple OpenACC 'routine' levels of parallelism");
2241 /* Symbol attributes are stored in list with the first three elements
2242 being the enumerated fields, while the remaining elements (if any)
2243 indicate the individual attribute bits. The access field is not
2244 saved-- it controls what symbols are exported when a module is
2248 mio_symbol_attribute (symbol_attribute
*attr
)
2251 unsigned ext_attr
,extension_level
;
2255 attr
->flavor
= MIO_NAME (sym_flavor
) (attr
->flavor
, flavors
);
2256 attr
->intent
= MIO_NAME (sym_intent
) (attr
->intent
, intents
);
2257 attr
->proc
= MIO_NAME (procedure_type
) (attr
->proc
, procedures
);
2258 attr
->if_source
= MIO_NAME (ifsrc
) (attr
->if_source
, ifsrc_types
);
2259 attr
->save
= MIO_NAME (save_state
) (attr
->save
, save_status
);
2261 ext_attr
= attr
->ext_attr
;
2262 mio_integer ((int *) &ext_attr
);
2263 attr
->ext_attr
= ext_attr
;
2265 extension_level
= attr
->extension
;
2266 mio_integer ((int *) &extension_level
);
2267 attr
->extension
= extension_level
;
2269 if (iomode
== IO_OUTPUT
)
2271 if (attr
->allocatable
)
2272 MIO_NAME (ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
2273 if (attr
->artificial
)
2274 MIO_NAME (ab_attribute
) (AB_ARTIFICIAL
, attr_bits
);
2275 if (attr
->asynchronous
)
2276 MIO_NAME (ab_attribute
) (AB_ASYNCHRONOUS
, attr_bits
);
2277 if (attr
->dimension
)
2278 MIO_NAME (ab_attribute
) (AB_DIMENSION
, attr_bits
);
2279 if (attr
->codimension
)
2280 MIO_NAME (ab_attribute
) (AB_CODIMENSION
, attr_bits
);
2281 if (attr
->contiguous
)
2282 MIO_NAME (ab_attribute
) (AB_CONTIGUOUS
, attr_bits
);
2284 MIO_NAME (ab_attribute
) (AB_EXTERNAL
, attr_bits
);
2285 if (attr
->intrinsic
)
2286 MIO_NAME (ab_attribute
) (AB_INTRINSIC
, attr_bits
);
2288 MIO_NAME (ab_attribute
) (AB_OPTIONAL
, attr_bits
);
2290 MIO_NAME (ab_attribute
) (AB_POINTER
, attr_bits
);
2291 if (attr
->class_pointer
)
2292 MIO_NAME (ab_attribute
) (AB_CLASS_POINTER
, attr_bits
);
2293 if (attr
->is_protected
)
2294 MIO_NAME (ab_attribute
) (AB_PROTECTED
, attr_bits
);
2296 MIO_NAME (ab_attribute
) (AB_VALUE
, attr_bits
);
2297 if (attr
->volatile_
)
2298 MIO_NAME (ab_attribute
) (AB_VOLATILE
, attr_bits
);
2300 MIO_NAME (ab_attribute
) (AB_TARGET
, attr_bits
);
2301 if (attr
->threadprivate
)
2302 MIO_NAME (ab_attribute
) (AB_THREADPRIVATE
, attr_bits
);
2304 MIO_NAME (ab_attribute
) (AB_DUMMY
, attr_bits
);
2306 MIO_NAME (ab_attribute
) (AB_RESULT
, attr_bits
);
2307 /* We deliberately don't preserve the "entry" flag. */
2310 MIO_NAME (ab_attribute
) (AB_DATA
, attr_bits
);
2311 if (attr
->in_namelist
)
2312 MIO_NAME (ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
2313 if (attr
->in_common
)
2314 MIO_NAME (ab_attribute
) (AB_IN_COMMON
, attr_bits
);
2317 MIO_NAME (ab_attribute
) (AB_FUNCTION
, attr_bits
);
2318 if (attr
->subroutine
)
2319 MIO_NAME (ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
2321 MIO_NAME (ab_attribute
) (AB_GENERIC
, attr_bits
);
2323 MIO_NAME (ab_attribute
) (AB_ABSTRACT
, attr_bits
);
2326 MIO_NAME (ab_attribute
) (AB_SEQUENCE
, attr_bits
);
2327 if (attr
->elemental
)
2328 MIO_NAME (ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
2330 MIO_NAME (ab_attribute
) (AB_PURE
, attr_bits
);
2331 if (attr
->implicit_pure
)
2332 MIO_NAME (ab_attribute
) (AB_IMPLICIT_PURE
, attr_bits
);
2333 if (attr
->unlimited_polymorphic
)
2334 MIO_NAME (ab_attribute
) (AB_UNLIMITED_POLY
, attr_bits
);
2335 if (attr
->recursive
)
2336 MIO_NAME (ab_attribute
) (AB_RECURSIVE
, attr_bits
);
2337 if (attr
->always_explicit
)
2338 MIO_NAME (ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
2339 if (attr
->cray_pointer
)
2340 MIO_NAME (ab_attribute
) (AB_CRAY_POINTER
, attr_bits
);
2341 if (attr
->cray_pointee
)
2342 MIO_NAME (ab_attribute
) (AB_CRAY_POINTEE
, attr_bits
);
2343 if (attr
->is_bind_c
)
2344 MIO_NAME(ab_attribute
) (AB_IS_BIND_C
, attr_bits
);
2345 if (attr
->is_c_interop
)
2346 MIO_NAME(ab_attribute
) (AB_IS_C_INTEROP
, attr_bits
);
2348 MIO_NAME(ab_attribute
) (AB_IS_ISO_C
, attr_bits
);
2349 if (attr
->alloc_comp
)
2350 MIO_NAME (ab_attribute
) (AB_ALLOC_COMP
, attr_bits
);
2351 if (attr
->pointer_comp
)
2352 MIO_NAME (ab_attribute
) (AB_POINTER_COMP
, attr_bits
);
2353 if (attr
->proc_pointer_comp
)
2354 MIO_NAME (ab_attribute
) (AB_PROC_POINTER_COMP
, attr_bits
);
2355 if (attr
->private_comp
)
2356 MIO_NAME (ab_attribute
) (AB_PRIVATE_COMP
, attr_bits
);
2357 if (attr
->coarray_comp
)
2358 MIO_NAME (ab_attribute
) (AB_COARRAY_COMP
, attr_bits
);
2359 if (attr
->lock_comp
)
2360 MIO_NAME (ab_attribute
) (AB_LOCK_COMP
, attr_bits
);
2361 if (attr
->event_comp
)
2362 MIO_NAME (ab_attribute
) (AB_EVENT_COMP
, attr_bits
);
2363 if (attr
->zero_comp
)
2364 MIO_NAME (ab_attribute
) (AB_ZERO_COMP
, attr_bits
);
2366 MIO_NAME (ab_attribute
) (AB_IS_CLASS
, attr_bits
);
2367 if (attr
->procedure
)
2368 MIO_NAME (ab_attribute
) (AB_PROCEDURE
, attr_bits
);
2369 if (attr
->proc_pointer
)
2370 MIO_NAME (ab_attribute
) (AB_PROC_POINTER
, attr_bits
);
2372 MIO_NAME (ab_attribute
) (AB_VTYPE
, attr_bits
);
2374 MIO_NAME (ab_attribute
) (AB_VTAB
, attr_bits
);
2375 if (attr
->omp_declare_target
)
2376 MIO_NAME (ab_attribute
) (AB_OMP_DECLARE_TARGET
, attr_bits
);
2377 if (attr
->array_outer_dependency
)
2378 MIO_NAME (ab_attribute
) (AB_ARRAY_OUTER_DEPENDENCY
, attr_bits
);
2379 if (attr
->module_procedure
)
2380 MIO_NAME (ab_attribute
) (AB_MODULE_PROCEDURE
, attr_bits
);
2381 if (attr
->oacc_declare_create
)
2382 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_CREATE
, attr_bits
);
2383 if (attr
->oacc_declare_copyin
)
2384 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_COPYIN
, attr_bits
);
2385 if (attr
->oacc_declare_deviceptr
)
2386 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_DEVICEPTR
, attr_bits
);
2387 if (attr
->oacc_declare_device_resident
)
2388 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_DEVICE_RESIDENT
, attr_bits
);
2389 if (attr
->oacc_declare_link
)
2390 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_LINK
, attr_bits
);
2391 if (attr
->omp_declare_target_link
)
2392 MIO_NAME (ab_attribute
) (AB_OMP_DECLARE_TARGET_LINK
, attr_bits
);
2394 MIO_NAME (ab_attribute
) (AB_PDT_KIND
, attr_bits
);
2396 MIO_NAME (ab_attribute
) (AB_PDT_LEN
, attr_bits
);
2398 MIO_NAME (ab_attribute
) (AB_PDT_TYPE
, attr_bits
);
2399 if (attr
->pdt_template
)
2400 MIO_NAME (ab_attribute
) (AB_PDT_TEMPLATE
, attr_bits
);
2401 if (attr
->pdt_array
)
2402 MIO_NAME (ab_attribute
) (AB_PDT_ARRAY
, attr_bits
);
2403 if (attr
->pdt_string
)
2404 MIO_NAME (ab_attribute
) (AB_PDT_STRING
, attr_bits
);
2405 switch (attr
->oacc_routine_lop
)
2407 case OACC_ROUTINE_LOP_NONE
:
2408 /* This is the default anyway, and for maintaining compatibility with
2409 the current MOD_VERSION, we're not emitting anything in that
2412 case OACC_ROUTINE_LOP_GANG
:
2413 MIO_NAME (ab_attribute
) (AB_OACC_ROUTINE_LOP_GANG
, attr_bits
);
2415 case OACC_ROUTINE_LOP_WORKER
:
2416 MIO_NAME (ab_attribute
) (AB_OACC_ROUTINE_LOP_WORKER
, attr_bits
);
2418 case OACC_ROUTINE_LOP_VECTOR
:
2419 MIO_NAME (ab_attribute
) (AB_OACC_ROUTINE_LOP_VECTOR
, attr_bits
);
2421 case OACC_ROUTINE_LOP_SEQ
:
2422 MIO_NAME (ab_attribute
) (AB_OACC_ROUTINE_LOP_SEQ
, attr_bits
);
2424 case OACC_ROUTINE_LOP_ERROR
:
2425 /* ... intentionally omitted here; it's only used internally. */
2429 if (attr
->oacc_routine_nohost
)
2430 MIO_NAME (ab_attribute
) (AB_OACC_ROUTINE_NOHOST
, attr_bits
);
2432 if (attr
->flavor
== FL_MODULE
&& gfc_current_ns
->omp_requires
)
2434 if (gfc_current_ns
->omp_requires
& OMP_REQ_REVERSE_OFFLOAD
)
2435 MIO_NAME (ab_attribute
) (AB_OMP_REQ_REVERSE_OFFLOAD
, attr_bits
);
2436 if (gfc_current_ns
->omp_requires
& OMP_REQ_UNIFIED_ADDRESS
)
2437 MIO_NAME (ab_attribute
) (AB_OMP_REQ_UNIFIED_ADDRESS
, attr_bits
);
2438 if (gfc_current_ns
->omp_requires
& OMP_REQ_UNIFIED_SHARED_MEMORY
)
2439 MIO_NAME (ab_attribute
) (AB_OMP_REQ_UNIFIED_SHARED_MEMORY
, attr_bits
);
2440 if (gfc_current_ns
->omp_requires
& OMP_REQ_DYNAMIC_ALLOCATORS
)
2441 MIO_NAME (ab_attribute
) (AB_OMP_REQ_DYNAMIC_ALLOCATORS
, attr_bits
);
2442 if ((gfc_current_ns
->omp_requires
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
2443 == OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST
)
2444 MIO_NAME (ab_attribute
) (AB_OMP_REQ_MEM_ORDER_SEQ_CST
, attr_bits
);
2445 if ((gfc_current_ns
->omp_requires
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
2446 == OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL
)
2447 MIO_NAME (ab_attribute
) (AB_OMP_REQ_MEM_ORDER_ACQ_REL
, attr_bits
);
2448 if ((gfc_current_ns
->omp_requires
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
2449 == OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE
)
2450 MIO_NAME (ab_attribute
) (AB_OMP_REQ_MEM_ORDER_ACQUIRE
, attr_bits
);
2451 if ((gfc_current_ns
->omp_requires
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
2452 == OMP_REQ_ATOMIC_MEM_ORDER_RELAXED
)
2453 MIO_NAME (ab_attribute
) (AB_OMP_REQ_MEM_ORDER_RELAXED
, attr_bits
);
2454 if ((gfc_current_ns
->omp_requires
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
2455 == OMP_REQ_ATOMIC_MEM_ORDER_RELEASE
)
2456 MIO_NAME (ab_attribute
) (AB_OMP_REQ_MEM_ORDER_RELEASE
, attr_bits
);
2458 switch (attr
->omp_device_type
)
2460 case OMP_DEVICE_TYPE_UNSET
:
2462 case OMP_DEVICE_TYPE_HOST
:
2463 MIO_NAME (ab_attribute
) (AB_OMP_DEVICE_TYPE_HOST
, attr_bits
);
2465 case OMP_DEVICE_TYPE_NOHOST
:
2466 MIO_NAME (ab_attribute
) (AB_OMP_DEVICE_TYPE_NOHOST
, attr_bits
);
2468 case OMP_DEVICE_TYPE_ANY
:
2469 MIO_NAME (ab_attribute
) (AB_OMP_DEVICE_TYPE_ANY
, attr_bits
);
2481 if (t
== ATOM_RPAREN
)
2484 bad_module ("Expected attribute bit name");
2486 switch ((ab_attribute
) find_enum (attr_bits
))
2488 case AB_ALLOCATABLE
:
2489 attr
->allocatable
= 1;
2492 attr
->artificial
= 1;
2494 case AB_ASYNCHRONOUS
:
2495 attr
->asynchronous
= 1;
2498 attr
->dimension
= 1;
2500 case AB_CODIMENSION
:
2501 attr
->codimension
= 1;
2504 attr
->contiguous
= 1;
2510 attr
->intrinsic
= 1;
2518 case AB_CLASS_POINTER
:
2519 attr
->class_pointer
= 1;
2522 attr
->is_protected
= 1;
2528 attr
->volatile_
= 1;
2533 case AB_THREADPRIVATE
:
2534 attr
->threadprivate
= 1;
2545 case AB_IN_NAMELIST
:
2546 attr
->in_namelist
= 1;
2549 attr
->in_common
= 1;
2555 attr
->subroutine
= 1;
2567 attr
->elemental
= 1;
2572 case AB_IMPLICIT_PURE
:
2573 attr
->implicit_pure
= 1;
2575 case AB_UNLIMITED_POLY
:
2576 attr
->unlimited_polymorphic
= 1;
2579 attr
->recursive
= 1;
2581 case AB_ALWAYS_EXPLICIT
:
2582 attr
->always_explicit
= 1;
2584 case AB_CRAY_POINTER
:
2585 attr
->cray_pointer
= 1;
2587 case AB_CRAY_POINTEE
:
2588 attr
->cray_pointee
= 1;
2591 attr
->is_bind_c
= 1;
2593 case AB_IS_C_INTEROP
:
2594 attr
->is_c_interop
= 1;
2600 attr
->alloc_comp
= 1;
2602 case AB_COARRAY_COMP
:
2603 attr
->coarray_comp
= 1;
2606 attr
->lock_comp
= 1;
2609 attr
->event_comp
= 1;
2611 case AB_POINTER_COMP
:
2612 attr
->pointer_comp
= 1;
2614 case AB_PROC_POINTER_COMP
:
2615 attr
->proc_pointer_comp
= 1;
2617 case AB_PRIVATE_COMP
:
2618 attr
->private_comp
= 1;
2621 attr
->zero_comp
= 1;
2627 attr
->procedure
= 1;
2629 case AB_PROC_POINTER
:
2630 attr
->proc_pointer
= 1;
2638 case AB_OMP_DECLARE_TARGET
:
2639 attr
->omp_declare_target
= 1;
2641 case AB_OMP_DECLARE_TARGET_LINK
:
2642 attr
->omp_declare_target_link
= 1;
2644 case AB_ARRAY_OUTER_DEPENDENCY
:
2645 attr
->array_outer_dependency
=1;
2647 case AB_MODULE_PROCEDURE
:
2648 attr
->module_procedure
=1;
2650 case AB_OACC_DECLARE_CREATE
:
2651 attr
->oacc_declare_create
= 1;
2653 case AB_OACC_DECLARE_COPYIN
:
2654 attr
->oacc_declare_copyin
= 1;
2656 case AB_OACC_DECLARE_DEVICEPTR
:
2657 attr
->oacc_declare_deviceptr
= 1;
2659 case AB_OACC_DECLARE_DEVICE_RESIDENT
:
2660 attr
->oacc_declare_device_resident
= 1;
2662 case AB_OACC_DECLARE_LINK
:
2663 attr
->oacc_declare_link
= 1;
2674 case AB_PDT_TEMPLATE
:
2675 attr
->pdt_template
= 1;
2678 attr
->pdt_array
= 1;
2681 attr
->pdt_string
= 1;
2683 case AB_OACC_ROUTINE_LOP_GANG
:
2684 verify_OACC_ROUTINE_LOP_NONE (attr
->oacc_routine_lop
);
2685 attr
->oacc_routine_lop
= OACC_ROUTINE_LOP_GANG
;
2687 case AB_OACC_ROUTINE_LOP_WORKER
:
2688 verify_OACC_ROUTINE_LOP_NONE (attr
->oacc_routine_lop
);
2689 attr
->oacc_routine_lop
= OACC_ROUTINE_LOP_WORKER
;
2691 case AB_OACC_ROUTINE_LOP_VECTOR
:
2692 verify_OACC_ROUTINE_LOP_NONE (attr
->oacc_routine_lop
);
2693 attr
->oacc_routine_lop
= OACC_ROUTINE_LOP_VECTOR
;
2695 case AB_OACC_ROUTINE_LOP_SEQ
:
2696 verify_OACC_ROUTINE_LOP_NONE (attr
->oacc_routine_lop
);
2697 attr
->oacc_routine_lop
= OACC_ROUTINE_LOP_SEQ
;
2699 case AB_OACC_ROUTINE_NOHOST
:
2700 attr
->oacc_routine_nohost
= 1;
2702 case AB_OMP_REQ_REVERSE_OFFLOAD
:
2703 gfc_omp_requires_add_clause (OMP_REQ_REVERSE_OFFLOAD
,
2708 case AB_OMP_REQ_UNIFIED_ADDRESS
:
2709 gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_ADDRESS
,
2714 case AB_OMP_REQ_UNIFIED_SHARED_MEMORY
:
2715 gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_SHARED_MEMORY
,
2716 "unified_shared_memory",
2720 case AB_OMP_REQ_DYNAMIC_ALLOCATORS
:
2721 gfc_omp_requires_add_clause (OMP_REQ_DYNAMIC_ALLOCATORS
,
2722 "dynamic_allocators",
2726 case AB_OMP_REQ_MEM_ORDER_SEQ_CST
:
2727 gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST
,
2728 "seq_cst", &gfc_current_locus
,
2731 case AB_OMP_REQ_MEM_ORDER_ACQ_REL
:
2732 gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL
,
2733 "acq_rel", &gfc_current_locus
,
2736 case AB_OMP_REQ_MEM_ORDER_ACQUIRE
:
2737 gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE
,
2738 "acquires", &gfc_current_locus
,
2741 case AB_OMP_REQ_MEM_ORDER_RELAXED
:
2742 gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_RELAXED
,
2743 "relaxed", &gfc_current_locus
,
2746 case AB_OMP_REQ_MEM_ORDER_RELEASE
:
2747 gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_RELEASE
,
2748 "release", &gfc_current_locus
,
2751 case AB_OMP_DEVICE_TYPE_HOST
:
2752 attr
->omp_device_type
= OMP_DEVICE_TYPE_HOST
;
2754 case AB_OMP_DEVICE_TYPE_NOHOST
:
2755 attr
->omp_device_type
= OMP_DEVICE_TYPE_NOHOST
;
2757 case AB_OMP_DEVICE_TYPE_ANY
:
2758 attr
->omp_device_type
= OMP_DEVICE_TYPE_ANY
;
2766 static const mstring bt_types
[] = {
2767 minit ("INTEGER", BT_INTEGER
),
2768 minit ("REAL", BT_REAL
),
2769 minit ("COMPLEX", BT_COMPLEX
),
2770 minit ("LOGICAL", BT_LOGICAL
),
2771 minit ("CHARACTER", BT_CHARACTER
),
2772 minit ("UNION", BT_UNION
),
2773 minit ("DERIVED", BT_DERIVED
),
2774 minit ("CLASS", BT_CLASS
),
2775 minit ("PROCEDURE", BT_PROCEDURE
),
2776 minit ("UNKNOWN", BT_UNKNOWN
),
2777 minit ("VOID", BT_VOID
),
2778 minit ("ASSUMED", BT_ASSUMED
),
2784 mio_charlen (gfc_charlen
**clp
)
2790 if (iomode
== IO_OUTPUT
)
2794 mio_expr (&cl
->length
);
2798 if (peek_atom () != ATOM_RPAREN
)
2800 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2801 mio_expr (&cl
->length
);
2810 /* See if a name is a generated name. */
2813 check_unique_name (const char *name
)
2815 return *name
== '@';
2820 mio_typespec (gfc_typespec
*ts
)
2824 ts
->type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2826 if (!gfc_bt_struct (ts
->type
) && ts
->type
!= BT_CLASS
)
2827 mio_integer (&ts
->kind
);
2829 mio_symbol_ref (&ts
->u
.derived
);
2831 mio_symbol_ref (&ts
->interface
);
2833 /* Add info for C interop and is_iso_c. */
2834 mio_integer (&ts
->is_c_interop
);
2835 mio_integer (&ts
->is_iso_c
);
2837 /* If the typespec is for an identifier either from iso_c_binding, or
2838 a constant that was initialized to an identifier from it, use the
2839 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2841 ts
->f90_type
= MIO_NAME (bt
) (ts
->f90_type
, bt_types
);
2843 ts
->f90_type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2845 if (ts
->type
!= BT_CHARACTER
)
2847 /* ts->u.cl is only valid for BT_CHARACTER. */
2852 mio_charlen (&ts
->u
.cl
);
2854 /* So as not to disturb the existing API, use an ATOM_NAME to
2855 transmit deferred characteristic for characters (F2003). */
2856 if (iomode
== IO_OUTPUT
)
2858 if (ts
->type
== BT_CHARACTER
&& ts
->deferred
)
2859 write_atom (ATOM_NAME
, "DEFERRED_CL");
2861 else if (peek_atom () != ATOM_RPAREN
)
2863 if (parse_atom () != ATOM_NAME
)
2864 bad_module ("Expected string");
2872 static const mstring array_spec_types
[] = {
2873 minit ("EXPLICIT", AS_EXPLICIT
),
2874 minit ("ASSUMED_RANK", AS_ASSUMED_RANK
),
2875 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
2876 minit ("DEFERRED", AS_DEFERRED
),
2877 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
2883 mio_array_spec (gfc_array_spec
**asp
)
2890 if (iomode
== IO_OUTPUT
)
2898 /* mio_integer expects nonnegative values. */
2899 rank
= as
->rank
> 0 ? as
->rank
: 0;
2900 mio_integer (&rank
);
2904 if (peek_atom () == ATOM_RPAREN
)
2910 *asp
= as
= gfc_get_array_spec ();
2911 mio_integer (&as
->rank
);
2914 mio_integer (&as
->corank
);
2915 as
->type
= MIO_NAME (array_type
) (as
->type
, array_spec_types
);
2917 if (iomode
== IO_INPUT
&& as
->type
== AS_ASSUMED_RANK
)
2919 if (iomode
== IO_INPUT
&& as
->corank
)
2920 as
->cotype
= (as
->type
== AS_DEFERRED
) ? AS_DEFERRED
: AS_EXPLICIT
;
2922 if (as
->rank
+ as
->corank
> 0)
2923 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
2925 mio_expr (&as
->lower
[i
]);
2926 mio_expr (&as
->upper
[i
]);
2934 /* Given a pointer to an array reference structure (which lives in a
2935 gfc_ref structure), find the corresponding array specification
2936 structure. Storing the pointer in the ref structure doesn't quite
2937 work when loading from a module. Generating code for an array
2938 reference also needs more information than just the array spec. */
2940 static const mstring array_ref_types
[] = {
2941 minit ("FULL", AR_FULL
),
2942 minit ("ELEMENT", AR_ELEMENT
),
2943 minit ("SECTION", AR_SECTION
),
2949 mio_array_ref (gfc_array_ref
*ar
)
2954 ar
->type
= MIO_NAME (ar_type
) (ar
->type
, array_ref_types
);
2955 mio_integer (&ar
->dimen
);
2963 for (i
= 0; i
< ar
->dimen
; i
++)
2964 mio_expr (&ar
->start
[i
]);
2969 for (i
= 0; i
< ar
->dimen
; i
++)
2971 mio_expr (&ar
->start
[i
]);
2972 mio_expr (&ar
->end
[i
]);
2973 mio_expr (&ar
->stride
[i
]);
2979 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2982 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2983 we can't call mio_integer directly. Instead loop over each element
2984 and cast it to/from an integer. */
2985 if (iomode
== IO_OUTPUT
)
2987 for (i
= 0; i
< ar
->dimen
; i
++)
2989 HOST_WIDE_INT tmp
= (HOST_WIDE_INT
)ar
->dimen_type
[i
];
2990 write_atom (ATOM_INTEGER
, &tmp
);
2995 for (i
= 0; i
< ar
->dimen
; i
++)
2997 require_atom (ATOM_INTEGER
);
2998 ar
->dimen_type
[i
] = (enum gfc_array_ref_dimen_type
) atom_int
;
3002 if (iomode
== IO_INPUT
)
3004 ar
->where
= gfc_current_locus
;
3006 for (i
= 0; i
< ar
->dimen
; i
++)
3007 ar
->c_where
[i
] = gfc_current_locus
;
3014 /* Saves or restores a pointer. The pointer is converted back and
3015 forth from an integer. We return the pointer_info pointer so that
3016 the caller can take additional action based on the pointer type. */
3018 static pointer_info
*
3019 mio_pointer_ref (void *gp
)
3023 if (iomode
== IO_OUTPUT
)
3025 p
= get_pointer (*((char **) gp
));
3026 HOST_WIDE_INT hwi
= p
->integer
;
3027 write_atom (ATOM_INTEGER
, &hwi
);
3031 require_atom (ATOM_INTEGER
);
3032 p
= add_fixup (atom_int
, gp
);
3039 /* Save and load references to components that occur within
3040 expressions. We have to describe these references by a number and
3041 by name. The number is necessary for forward references during
3042 reading, and the name is necessary if the symbol already exists in
3043 the namespace and is not loaded again. */
3046 mio_component_ref (gfc_component
**cp
)
3050 p
= mio_pointer_ref (cp
);
3051 if (p
->type
== P_UNKNOWN
)
3052 p
->type
= P_COMPONENT
;
3056 static void mio_namespace_ref (gfc_namespace
**nsp
);
3057 static void mio_formal_arglist (gfc_formal_arglist
**formal
);
3058 static void mio_typebound_proc (gfc_typebound_proc
** proc
);
3059 static void mio_actual_arglist (gfc_actual_arglist
**ap
, bool pdt
);
3062 mio_component (gfc_component
*c
, int vtype
)
3068 if (iomode
== IO_OUTPUT
)
3070 p
= get_pointer (c
);
3071 mio_hwi (&p
->integer
);
3077 p
= get_integer (n
);
3078 associate_integer_pointer (p
, c
);
3081 if (p
->type
== P_UNKNOWN
)
3082 p
->type
= P_COMPONENT
;
3084 mio_pool_string (&c
->name
);
3085 mio_typespec (&c
->ts
);
3086 mio_array_spec (&c
->as
);
3088 /* PDT templates store the expression for the kind of a component here. */
3089 mio_expr (&c
->kind_expr
);
3091 /* PDT types store the component specification list here. */
3092 mio_actual_arglist (&c
->param_list
, true);
3094 mio_symbol_attribute (&c
->attr
);
3095 if (c
->ts
.type
== BT_CLASS
)
3096 c
->attr
.class_ok
= 1;
3097 c
->attr
.access
= MIO_NAME (gfc_access
) (c
->attr
.access
, access_types
);
3099 if (!vtype
|| strcmp (c
->name
, "_final") == 0
3100 || strcmp (c
->name
, "_hash") == 0)
3101 mio_expr (&c
->initializer
);
3103 if (c
->attr
.proc_pointer
)
3104 mio_typebound_proc (&c
->tb
);
3106 c
->loc
= gfc_current_locus
;
3113 mio_component_list (gfc_component
**cp
, int vtype
)
3115 gfc_component
*c
, *tail
;
3119 if (iomode
== IO_OUTPUT
)
3121 for (c
= *cp
; c
; c
= c
->next
)
3122 mio_component (c
, vtype
);
3131 if (peek_atom () == ATOM_RPAREN
)
3134 c
= gfc_get_component ();
3135 mio_component (c
, vtype
);
3151 mio_actual_arg (gfc_actual_arglist
*a
, bool pdt
)
3154 mio_pool_string (&a
->name
);
3155 mio_expr (&a
->expr
);
3157 mio_integer ((int *)&a
->spec_type
);
3163 mio_actual_arglist (gfc_actual_arglist
**ap
, bool pdt
)
3165 gfc_actual_arglist
*a
, *tail
;
3169 if (iomode
== IO_OUTPUT
)
3171 for (a
= *ap
; a
; a
= a
->next
)
3172 mio_actual_arg (a
, pdt
);
3181 if (peek_atom () != ATOM_LPAREN
)
3184 a
= gfc_get_actual_arglist ();
3192 mio_actual_arg (a
, pdt
);
3200 /* Read and write formal argument lists. */
3203 mio_formal_arglist (gfc_formal_arglist
**formal
)
3205 gfc_formal_arglist
*f
, *tail
;
3209 if (iomode
== IO_OUTPUT
)
3211 for (f
= *formal
; f
; f
= f
->next
)
3212 mio_symbol_ref (&f
->sym
);
3216 *formal
= tail
= NULL
;
3218 while (peek_atom () != ATOM_RPAREN
)
3220 f
= gfc_get_formal_arglist ();
3221 mio_symbol_ref (&f
->sym
);
3223 if (*formal
== NULL
)
3236 /* Save or restore a reference to a symbol node. */
3239 mio_symbol_ref (gfc_symbol
**symp
)
3243 p
= mio_pointer_ref (symp
);
3244 if (p
->type
== P_UNKNOWN
)
3247 if (iomode
== IO_OUTPUT
)
3249 if (p
->u
.wsym
.state
== UNREFERENCED
)
3250 p
->u
.wsym
.state
= NEEDS_WRITE
;
3254 if (p
->u
.rsym
.state
== UNUSED
)
3255 p
->u
.rsym
.state
= NEEDED
;
3261 /* Save or restore a reference to a symtree node. */
3264 mio_symtree_ref (gfc_symtree
**stp
)
3269 if (iomode
== IO_OUTPUT
)
3270 mio_symbol_ref (&(*stp
)->n
.sym
);
3273 require_atom (ATOM_INTEGER
);
3274 p
= get_integer (atom_int
);
3276 /* An unused equivalence member; make a symbol and a symtree
3278 if (in_load_equiv
&& p
->u
.rsym
.symtree
== NULL
)
3280 /* Since this is not used, it must have a unique name. */
3281 p
->u
.rsym
.symtree
= gfc_get_unique_symtree (gfc_current_ns
);
3283 /* Make the symbol. */
3284 if (p
->u
.rsym
.sym
== NULL
)
3286 p
->u
.rsym
.sym
= gfc_new_symbol (p
->u
.rsym
.true_name
,
3288 p
->u
.rsym
.sym
->module
= gfc_get_string ("%s", p
->u
.rsym
.module
);
3291 p
->u
.rsym
.symtree
->n
.sym
= p
->u
.rsym
.sym
;
3292 p
->u
.rsym
.symtree
->n
.sym
->refs
++;
3293 p
->u
.rsym
.referenced
= 1;
3295 /* If the symbol is PRIVATE and in COMMON, load_commons will
3296 generate a fixup symbol, which must be associated. */
3298 resolve_fixups (p
->fixup
, p
->u
.rsym
.sym
);
3302 if (p
->type
== P_UNKNOWN
)
3305 if (p
->u
.rsym
.state
== UNUSED
)
3306 p
->u
.rsym
.state
= NEEDED
;
3308 if (p
->u
.rsym
.symtree
!= NULL
)
3310 *stp
= p
->u
.rsym
.symtree
;
3314 f
= XCNEW (fixup_t
);
3316 f
->next
= p
->u
.rsym
.stfixup
;
3317 p
->u
.rsym
.stfixup
= f
;
3319 f
->pointer
= (void **) stp
;
3326 mio_iterator (gfc_iterator
**ip
)
3332 if (iomode
== IO_OUTPUT
)
3339 if (peek_atom () == ATOM_RPAREN
)
3345 *ip
= gfc_get_iterator ();
3350 mio_expr (&iter
->var
);
3351 mio_expr (&iter
->start
);
3352 mio_expr (&iter
->end
);
3353 mio_expr (&iter
->step
);
3361 mio_constructor (gfc_constructor_base
*cp
)
3367 if (iomode
== IO_OUTPUT
)
3369 for (c
= gfc_constructor_first (*cp
); c
; c
= gfc_constructor_next (c
))
3372 mio_expr (&c
->expr
);
3373 mio_iterator (&c
->iterator
);
3379 while (peek_atom () != ATOM_RPAREN
)
3381 c
= gfc_constructor_append_expr (cp
, NULL
, NULL
);
3384 mio_expr (&c
->expr
);
3385 mio_iterator (&c
->iterator
);
3394 static const mstring ref_types
[] = {
3395 minit ("ARRAY", REF_ARRAY
),
3396 minit ("COMPONENT", REF_COMPONENT
),
3397 minit ("SUBSTRING", REF_SUBSTRING
),
3398 minit ("INQUIRY", REF_INQUIRY
),
3402 static const mstring inquiry_types
[] = {
3403 minit ("RE", INQUIRY_RE
),
3404 minit ("IM", INQUIRY_IM
),
3405 minit ("KIND", INQUIRY_KIND
),
3406 minit ("LEN", INQUIRY_LEN
),
3412 mio_ref (gfc_ref
**rp
)
3419 r
->type
= MIO_NAME (ref_type
) (r
->type
, ref_types
);
3424 mio_array_ref (&r
->u
.ar
);
3428 mio_symbol_ref (&r
->u
.c
.sym
);
3429 mio_component_ref (&r
->u
.c
.component
);
3433 mio_expr (&r
->u
.ss
.start
);
3434 mio_expr (&r
->u
.ss
.end
);
3435 mio_charlen (&r
->u
.ss
.length
);
3439 r
->u
.i
= MIO_NAME (inquiry_type
) (r
->u
.i
, inquiry_types
);
3448 mio_ref_list (gfc_ref
**rp
)
3450 gfc_ref
*ref
, *head
, *tail
;
3454 if (iomode
== IO_OUTPUT
)
3456 for (ref
= *rp
; ref
; ref
= ref
->next
)
3463 while (peek_atom () != ATOM_RPAREN
)
3466 head
= tail
= gfc_get_ref ();
3469 tail
->next
= gfc_get_ref ();
3483 /* Read and write an integer value. */
3486 mio_gmp_integer (mpz_t
*integer
)
3490 if (iomode
== IO_INPUT
)
3492 if (parse_atom () != ATOM_STRING
)
3493 bad_module ("Expected integer string");
3495 mpz_init (*integer
);
3496 if (mpz_set_str (*integer
, atom_string
, 10))
3497 bad_module ("Error converting integer");
3503 p
= mpz_get_str (NULL
, 10, *integer
);
3504 write_atom (ATOM_STRING
, p
);
3511 mio_gmp_real (mpfr_t
*real
)
3513 mpfr_exp_t exponent
;
3516 if (iomode
== IO_INPUT
)
3518 if (parse_atom () != ATOM_STRING
)
3519 bad_module ("Expected real string");
3522 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
3527 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
3529 if (mpfr_nan_p (*real
) || mpfr_inf_p (*real
))
3531 write_atom (ATOM_STRING
, p
);
3536 atom_string
= XCNEWVEC (char, strlen (p
) + 20);
3538 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
3540 /* Fix negative numbers. */
3541 if (atom_string
[2] == '-')
3543 atom_string
[0] = '-';
3544 atom_string
[1] = '0';
3545 atom_string
[2] = '.';
3548 write_atom (ATOM_STRING
, atom_string
);
3556 /* Save and restore the shape of an array constructor. */
3559 mio_shape (mpz_t
**pshape
, int rank
)
3565 /* A NULL shape is represented by (). */
3568 if (iomode
== IO_OUTPUT
)
3580 if (t
== ATOM_RPAREN
)
3587 shape
= gfc_get_shape (rank
);
3591 for (n
= 0; n
< rank
; n
++)
3592 mio_gmp_integer (&shape
[n
]);
3598 static const mstring expr_types
[] = {
3599 minit ("OP", EXPR_OP
),
3600 minit ("FUNCTION", EXPR_FUNCTION
),
3601 minit ("CONSTANT", EXPR_CONSTANT
),
3602 minit ("VARIABLE", EXPR_VARIABLE
),
3603 minit ("SUBSTRING", EXPR_SUBSTRING
),
3604 minit ("STRUCTURE", EXPR_STRUCTURE
),
3605 minit ("ARRAY", EXPR_ARRAY
),
3606 minit ("NULL", EXPR_NULL
),
3607 minit ("COMPCALL", EXPR_COMPCALL
),
3611 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3612 generic operators, not in expressions. INTRINSIC_USER is also
3613 replaced by the correct function name by the time we see it. */
3615 static const mstring intrinsics
[] =
3617 minit ("UPLUS", INTRINSIC_UPLUS
),
3618 minit ("UMINUS", INTRINSIC_UMINUS
),
3619 minit ("PLUS", INTRINSIC_PLUS
),
3620 minit ("MINUS", INTRINSIC_MINUS
),
3621 minit ("TIMES", INTRINSIC_TIMES
),
3622 minit ("DIVIDE", INTRINSIC_DIVIDE
),
3623 minit ("POWER", INTRINSIC_POWER
),
3624 minit ("CONCAT", INTRINSIC_CONCAT
),
3625 minit ("AND", INTRINSIC_AND
),
3626 minit ("OR", INTRINSIC_OR
),
3627 minit ("EQV", INTRINSIC_EQV
),
3628 minit ("NEQV", INTRINSIC_NEQV
),
3629 minit ("EQ_SIGN", INTRINSIC_EQ
),
3630 minit ("EQ", INTRINSIC_EQ_OS
),
3631 minit ("NE_SIGN", INTRINSIC_NE
),
3632 minit ("NE", INTRINSIC_NE_OS
),
3633 minit ("GT_SIGN", INTRINSIC_GT
),
3634 minit ("GT", INTRINSIC_GT_OS
),
3635 minit ("GE_SIGN", INTRINSIC_GE
),
3636 minit ("GE", INTRINSIC_GE_OS
),
3637 minit ("LT_SIGN", INTRINSIC_LT
),
3638 minit ("LT", INTRINSIC_LT_OS
),
3639 minit ("LE_SIGN", INTRINSIC_LE
),
3640 minit ("LE", INTRINSIC_LE_OS
),
3641 minit ("NOT", INTRINSIC_NOT
),
3642 minit ("PARENTHESES", INTRINSIC_PARENTHESES
),
3643 minit ("USER", INTRINSIC_USER
),
3648 /* Remedy a couple of situations where the gfc_expr's can be defective. */
3651 fix_mio_expr (gfc_expr
*e
)
3653 gfc_symtree
*ns_st
= NULL
;
3656 if (iomode
!= IO_OUTPUT
)
3661 /* If this is a symtree for a symbol that came from a contained module
3662 namespace, it has a unique name and we should look in the current
3663 namespace to see if the required, non-contained symbol is available
3664 yet. If so, the latter should be written. */
3665 if (e
->symtree
->n
.sym
&& check_unique_name (e
->symtree
->name
))
3667 const char *name
= e
->symtree
->n
.sym
->name
;
3668 if (gfc_fl_struct (e
->symtree
->n
.sym
->attr
.flavor
))
3669 name
= gfc_dt_upper_string (name
);
3670 ns_st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3673 /* On the other hand, if the existing symbol is the module name or the
3674 new symbol is a dummy argument, do not do the promotion. */
3675 if (ns_st
&& ns_st
->n
.sym
3676 && ns_st
->n
.sym
->attr
.flavor
!= FL_MODULE
3677 && !e
->symtree
->n
.sym
->attr
.dummy
)
3680 else if (e
->expr_type
== EXPR_FUNCTION
3681 && (e
->value
.function
.name
|| e
->value
.function
.isym
))
3685 /* In some circumstances, a function used in an initialization
3686 expression, in one use associated module, can fail to be
3687 coupled to its symtree when used in a specification
3688 expression in another module. */
3689 fname
= e
->value
.function
.esym
? e
->value
.function
.esym
->name
3690 : e
->value
.function
.isym
->name
;
3691 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3696 /* This is probably a reference to a private procedure from another
3697 module. To prevent a segfault, make a generic with no specific
3698 instances. If this module is used, without the required
3699 specific coming from somewhere, the appropriate error message
3701 gfc_get_symbol (fname
, gfc_current_ns
, &sym
);
3702 sym
->attr
.flavor
= FL_PROCEDURE
;
3703 sym
->attr
.generic
= 1;
3704 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3705 gfc_commit_symbol (sym
);
3710 /* Read and write expressions. The form "()" is allowed to indicate a
3714 mio_expr (gfc_expr
**ep
)
3723 if (iomode
== IO_OUTPUT
)
3732 MIO_NAME (expr_t
) (e
->expr_type
, expr_types
);
3737 if (t
== ATOM_RPAREN
)
3744 bad_module ("Expected expression type");
3746 e
= *ep
= gfc_get_expr ();
3747 e
->where
= gfc_current_locus
;
3748 e
->expr_type
= (expr_t
) find_enum (expr_types
);
3751 mio_typespec (&e
->ts
);
3752 mio_integer (&e
->rank
);
3756 switch (e
->expr_type
)
3760 = MIO_NAME (gfc_intrinsic_op
) (e
->value
.op
.op
, intrinsics
);
3762 switch (e
->value
.op
.op
)
3764 case INTRINSIC_UPLUS
:
3765 case INTRINSIC_UMINUS
:
3767 case INTRINSIC_PARENTHESES
:
3768 mio_expr (&e
->value
.op
.op1
);
3771 case INTRINSIC_PLUS
:
3772 case INTRINSIC_MINUS
:
3773 case INTRINSIC_TIMES
:
3774 case INTRINSIC_DIVIDE
:
3775 case INTRINSIC_POWER
:
3776 case INTRINSIC_CONCAT
:
3780 case INTRINSIC_NEQV
:
3782 case INTRINSIC_EQ_OS
:
3784 case INTRINSIC_NE_OS
:
3786 case INTRINSIC_GT_OS
:
3788 case INTRINSIC_GE_OS
:
3790 case INTRINSIC_LT_OS
:
3792 case INTRINSIC_LE_OS
:
3793 mio_expr (&e
->value
.op
.op1
);
3794 mio_expr (&e
->value
.op
.op2
);
3797 case INTRINSIC_USER
:
3798 /* INTRINSIC_USER should not appear in resolved expressions,
3799 though for UDRs we need to stream unresolved ones. */
3800 if (iomode
== IO_OUTPUT
)
3801 write_atom (ATOM_STRING
, e
->value
.op
.uop
->name
);
3804 char *name
= read_string ();
3805 const char *uop_name
= find_use_name (name
, true);
3806 if (uop_name
== NULL
)
3808 size_t len
= strlen (name
);
3809 char *name2
= XCNEWVEC (char, len
+ 2);
3810 memcpy (name2
, name
, len
);
3812 name2
[len
+ 1] = '\0';
3814 uop_name
= name
= name2
;
3816 e
->value
.op
.uop
= gfc_get_uop (uop_name
);
3819 mio_expr (&e
->value
.op
.op1
);
3820 mio_expr (&e
->value
.op
.op2
);
3824 bad_module ("Bad operator");
3830 mio_symtree_ref (&e
->symtree
);
3831 mio_actual_arglist (&e
->value
.function
.actual
, false);
3833 if (iomode
== IO_OUTPUT
)
3835 e
->value
.function
.name
3836 = mio_allocated_string (e
->value
.function
.name
);
3837 if (e
->value
.function
.esym
)
3841 else if (e
->value
.function
.isym
== NULL
)
3845 mio_integer (&flag
);
3849 mio_symbol_ref (&e
->value
.function
.esym
);
3852 mio_ref_list (&e
->ref
);
3857 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
3862 require_atom (ATOM_STRING
);
3863 if (atom_string
[0] == '\0')
3864 e
->value
.function
.name
= NULL
;
3866 e
->value
.function
.name
= gfc_get_string ("%s", atom_string
);
3869 mio_integer (&flag
);
3873 mio_symbol_ref (&e
->value
.function
.esym
);
3876 mio_ref_list (&e
->ref
);
3881 require_atom (ATOM_STRING
);
3882 e
->value
.function
.isym
= gfc_find_function (atom_string
);
3890 mio_symtree_ref (&e
->symtree
);
3891 mio_ref_list (&e
->ref
);
3894 case EXPR_SUBSTRING
:
3895 e
->value
.character
.string
3896 = CONST_CAST (gfc_char_t
*,
3897 mio_allocated_wide_string (e
->value
.character
.string
,
3898 e
->value
.character
.length
));
3899 mio_ref_list (&e
->ref
);
3902 case EXPR_STRUCTURE
:
3904 mio_constructor (&e
->value
.constructor
);
3905 mio_shape (&e
->shape
, e
->rank
);
3912 mio_gmp_integer (&e
->value
.integer
);
3916 gfc_set_model_kind (e
->ts
.kind
);
3917 mio_gmp_real (&e
->value
.real
);
3921 gfc_set_model_kind (e
->ts
.kind
);
3922 mio_gmp_real (&mpc_realref (e
->value
.complex));
3923 mio_gmp_real (&mpc_imagref (e
->value
.complex));
3927 mio_integer (&e
->value
.logical
);
3931 hwi
= e
->value
.character
.length
;
3933 e
->value
.character
.length
= hwi
;
3934 e
->value
.character
.string
3935 = CONST_CAST (gfc_char_t
*,
3936 mio_allocated_wide_string (e
->value
.character
.string
,
3937 e
->value
.character
.length
));
3941 bad_module ("Bad type in constant expression");
3956 /* PDT types store the expression specification list here. */
3957 mio_actual_arglist (&e
->param_list
, true);
3963 /* Read and write namelists. */
3966 mio_namelist (gfc_symbol
*sym
)
3968 gfc_namelist
*n
, *m
;
3972 if (iomode
== IO_OUTPUT
)
3974 for (n
= sym
->namelist
; n
; n
= n
->next
)
3975 mio_symbol_ref (&n
->sym
);
3980 while (peek_atom () != ATOM_RPAREN
)
3982 n
= gfc_get_namelist ();
3983 mio_symbol_ref (&n
->sym
);
3985 if (sym
->namelist
== NULL
)
3992 sym
->namelist_tail
= m
;
3999 /* Save/restore lists of gfc_interface structures. When loading an
4000 interface, we are really appending to the existing list of
4001 interfaces. Checking for duplicate and ambiguous interfaces has to
4002 be done later when all symbols have been loaded. */
4005 mio_interface_rest (gfc_interface
**ip
)
4007 gfc_interface
*tail
, *p
;
4008 pointer_info
*pi
= NULL
;
4010 if (iomode
== IO_OUTPUT
)
4013 for (p
= *ip
; p
; p
= p
->next
)
4014 mio_symbol_ref (&p
->sym
);
4029 if (peek_atom () == ATOM_RPAREN
)
4032 p
= gfc_get_interface ();
4033 p
->where
= gfc_current_locus
;
4034 pi
= mio_symbol_ref (&p
->sym
);
4050 /* Save/restore a nameless operator interface. */
4053 mio_interface (gfc_interface
**ip
)
4056 mio_interface_rest (ip
);
4060 /* Save/restore a named operator interface. */
4063 mio_symbol_interface (const char **name
, const char **module
,
4067 mio_pool_string (name
);
4068 mio_pool_string (module
);
4069 mio_interface_rest (ip
);
4074 mio_namespace_ref (gfc_namespace
**nsp
)
4079 p
= mio_pointer_ref (nsp
);
4081 if (p
->type
== P_UNKNOWN
)
4082 p
->type
= P_NAMESPACE
;
4084 if (iomode
== IO_INPUT
&& p
->integer
!= 0)
4086 ns
= (gfc_namespace
*) p
->u
.pointer
;
4089 ns
= gfc_get_namespace (NULL
, 0);
4090 associate_integer_pointer (p
, ns
);
4098 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
4100 static gfc_namespace
* current_f2k_derived
;
4103 mio_typebound_proc (gfc_typebound_proc
** proc
)
4106 int overriding_flag
;
4108 if (iomode
== IO_INPUT
)
4110 *proc
= gfc_get_typebound_proc (NULL
);
4111 (*proc
)->where
= gfc_current_locus
;
4117 (*proc
)->access
= MIO_NAME (gfc_access
) ((*proc
)->access
, access_types
);
4119 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
4120 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
4121 overriding_flag
= ((*proc
)->deferred
<< 1) | (*proc
)->non_overridable
;
4122 overriding_flag
= mio_name (overriding_flag
, binding_overriding
);
4123 (*proc
)->deferred
= ((overriding_flag
& 2) != 0);
4124 (*proc
)->non_overridable
= ((overriding_flag
& 1) != 0);
4125 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
4127 (*proc
)->nopass
= mio_name ((*proc
)->nopass
, binding_passing
);
4128 (*proc
)->is_generic
= mio_name ((*proc
)->is_generic
, binding_generic
);
4129 (*proc
)->ppc
= mio_name((*proc
)->ppc
, binding_ppc
);
4131 mio_pool_string (&((*proc
)->pass_arg
));
4133 flag
= (int) (*proc
)->pass_arg_num
;
4134 mio_integer (&flag
);
4135 (*proc
)->pass_arg_num
= (unsigned) flag
;
4137 if ((*proc
)->is_generic
)
4144 if (iomode
== IO_OUTPUT
)
4145 for (g
= (*proc
)->u
.generic
; g
; g
= g
->next
)
4147 iop
= (int) g
->is_operator
;
4149 mio_allocated_string (g
->specific_st
->name
);
4153 (*proc
)->u
.generic
= NULL
;
4154 while (peek_atom () != ATOM_RPAREN
)
4156 gfc_symtree
** sym_root
;
4158 g
= gfc_get_tbp_generic ();
4162 g
->is_operator
= (bool) iop
;
4164 require_atom (ATOM_STRING
);
4165 sym_root
= ¤t_f2k_derived
->tb_sym_root
;
4166 g
->specific_st
= gfc_get_tbp_symtree (sym_root
, atom_string
);
4169 g
->next
= (*proc
)->u
.generic
;
4170 (*proc
)->u
.generic
= g
;
4176 else if (!(*proc
)->ppc
)
4177 mio_symtree_ref (&(*proc
)->u
.specific
);
4182 /* Walker-callback function for this purpose. */
4184 mio_typebound_symtree (gfc_symtree
* st
)
4186 if (iomode
== IO_OUTPUT
&& !st
->n
.tb
)
4189 if (iomode
== IO_OUTPUT
)
4192 mio_allocated_string (st
->name
);
4194 /* For IO_INPUT, the above is done in mio_f2k_derived. */
4196 mio_typebound_proc (&st
->n
.tb
);
4200 /* IO a full symtree (in all depth). */
4202 mio_full_typebound_tree (gfc_symtree
** root
)
4206 if (iomode
== IO_OUTPUT
)
4207 gfc_traverse_symtree (*root
, &mio_typebound_symtree
);
4210 while (peek_atom () == ATOM_LPAREN
)
4216 require_atom (ATOM_STRING
);
4217 st
= gfc_get_tbp_symtree (root
, atom_string
);
4220 mio_typebound_symtree (st
);
4228 mio_finalizer (gfc_finalizer
**f
)
4230 if (iomode
== IO_OUTPUT
)
4233 gcc_assert ((*f
)->proc_tree
); /* Should already be resolved. */
4234 mio_symtree_ref (&(*f
)->proc_tree
);
4238 *f
= gfc_get_finalizer ();
4239 (*f
)->where
= gfc_current_locus
; /* Value should not matter. */
4242 mio_symtree_ref (&(*f
)->proc_tree
);
4243 (*f
)->proc_sym
= NULL
;
4248 mio_f2k_derived (gfc_namespace
*f2k
)
4250 current_f2k_derived
= f2k
;
4252 /* Handle the list of finalizer procedures. */
4254 if (iomode
== IO_OUTPUT
)
4257 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
4262 f2k
->finalizers
= NULL
;
4263 while (peek_atom () != ATOM_RPAREN
)
4265 gfc_finalizer
*cur
= NULL
;
4266 mio_finalizer (&cur
);
4267 cur
->next
= f2k
->finalizers
;
4268 f2k
->finalizers
= cur
;
4273 /* Handle type-bound procedures. */
4274 mio_full_typebound_tree (&f2k
->tb_sym_root
);
4276 /* Type-bound user operators. */
4277 mio_full_typebound_tree (&f2k
->tb_uop_root
);
4279 /* Type-bound intrinsic operators. */
4281 if (iomode
== IO_OUTPUT
)
4284 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
4286 gfc_intrinsic_op realop
;
4288 if (op
== INTRINSIC_USER
|| !f2k
->tb_op
[op
])
4292 realop
= (gfc_intrinsic_op
) op
;
4293 mio_intrinsic_op (&realop
);
4294 mio_typebound_proc (&f2k
->tb_op
[op
]);
4299 while (peek_atom () != ATOM_RPAREN
)
4301 gfc_intrinsic_op op
= GFC_INTRINSIC_BEGIN
; /* Silence GCC. */
4304 mio_intrinsic_op (&op
);
4305 mio_typebound_proc (&f2k
->tb_op
[op
]);
4312 mio_full_f2k_derived (gfc_symbol
*sym
)
4316 if (iomode
== IO_OUTPUT
)
4318 if (sym
->f2k_derived
)
4319 mio_f2k_derived (sym
->f2k_derived
);
4323 if (peek_atom () != ATOM_RPAREN
)
4327 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
4329 /* PDT templates make use of the mechanisms for formal args
4330 and so the parameter symbols are stored in the formal
4331 namespace. Transfer the sym_root to f2k_derived and then
4332 free the formal namespace since it is uneeded. */
4333 if (sym
->attr
.pdt_template
&& sym
->formal
&& sym
->formal
->sym
)
4335 ns
= sym
->formal
->sym
->ns
;
4336 sym
->f2k_derived
->sym_root
= ns
->sym_root
;
4337 ns
->sym_root
= NULL
;
4339 gfc_free_namespace (ns
);
4343 mio_f2k_derived (sym
->f2k_derived
);
4346 gcc_assert (!sym
->f2k_derived
);
4352 static const mstring omp_declare_simd_clauses
[] =
4354 minit ("INBRANCH", 0),
4355 minit ("NOTINBRANCH", 1),
4356 minit ("SIMDLEN", 2),
4357 minit ("UNIFORM", 3),
4358 minit ("LINEAR", 4),
4359 minit ("ALIGNED", 5),
4360 minit ("LINEAR_REF", 33),
4361 minit ("LINEAR_VAL", 34),
4362 minit ("LINEAR_UVAL", 35),
4366 /* Handle !$omp declare simd. */
4369 mio_omp_declare_simd (gfc_namespace
*ns
, gfc_omp_declare_simd
**odsp
)
4371 if (iomode
== IO_OUTPUT
)
4376 else if (peek_atom () != ATOM_LPAREN
)
4379 gfc_omp_declare_simd
*ods
= *odsp
;
4382 if (iomode
== IO_OUTPUT
)
4384 write_atom (ATOM_NAME
, "OMP_DECLARE_SIMD");
4387 gfc_omp_namelist
*n
;
4389 if (ods
->clauses
->inbranch
)
4390 mio_name (0, omp_declare_simd_clauses
);
4391 if (ods
->clauses
->notinbranch
)
4392 mio_name (1, omp_declare_simd_clauses
);
4393 if (ods
->clauses
->simdlen_expr
)
4395 mio_name (2, omp_declare_simd_clauses
);
4396 mio_expr (&ods
->clauses
->simdlen_expr
);
4398 for (n
= ods
->clauses
->lists
[OMP_LIST_UNIFORM
]; n
; n
= n
->next
)
4400 mio_name (3, omp_declare_simd_clauses
);
4401 mio_symbol_ref (&n
->sym
);
4403 for (n
= ods
->clauses
->lists
[OMP_LIST_LINEAR
]; n
; n
= n
->next
)
4405 if (n
->u
.linear
.op
== OMP_LINEAR_DEFAULT
)
4406 mio_name (4, omp_declare_simd_clauses
);
4408 mio_name (32 + n
->u
.linear
.op
, omp_declare_simd_clauses
);
4409 mio_symbol_ref (&n
->sym
);
4410 mio_expr (&n
->expr
);
4412 for (n
= ods
->clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
4414 mio_name (5, omp_declare_simd_clauses
);
4415 mio_symbol_ref (&n
->sym
);
4416 mio_expr (&n
->expr
);
4422 gfc_omp_namelist
**ptrs
[3] = { NULL
, NULL
, NULL
};
4424 require_atom (ATOM_NAME
);
4425 *odsp
= ods
= gfc_get_omp_declare_simd ();
4426 ods
->where
= gfc_current_locus
;
4427 ods
->proc_name
= ns
->proc_name
;
4428 if (peek_atom () == ATOM_NAME
)
4430 ods
->clauses
= gfc_get_omp_clauses ();
4431 ptrs
[0] = &ods
->clauses
->lists
[OMP_LIST_UNIFORM
];
4432 ptrs
[1] = &ods
->clauses
->lists
[OMP_LIST_LINEAR
];
4433 ptrs
[2] = &ods
->clauses
->lists
[OMP_LIST_ALIGNED
];
4435 while (peek_atom () == ATOM_NAME
)
4437 gfc_omp_namelist
*n
;
4438 int t
= mio_name (0, omp_declare_simd_clauses
);
4442 case 0: ods
->clauses
->inbranch
= true; break;
4443 case 1: ods
->clauses
->notinbranch
= true; break;
4444 case 2: mio_expr (&ods
->clauses
->simdlen_expr
); break;
4448 *ptrs
[t
- 3] = n
= gfc_get_omp_namelist ();
4450 n
->where
= gfc_current_locus
;
4451 ptrs
[t
- 3] = &n
->next
;
4452 mio_symbol_ref (&n
->sym
);
4454 mio_expr (&n
->expr
);
4459 *ptrs
[1] = n
= gfc_get_omp_namelist ();
4460 n
->u
.linear
.op
= (enum gfc_omp_linear_op
) (t
- 32);
4462 goto finish_namelist
;
4467 mio_omp_declare_simd (ns
, &ods
->next
);
4473 static const mstring omp_declare_reduction_stmt
[] =
4475 minit ("ASSIGN", 0),
4482 mio_omp_udr_expr (gfc_omp_udr
*udr
, gfc_symbol
**sym1
, gfc_symbol
**sym2
,
4483 gfc_namespace
*ns
, bool is_initializer
)
4485 if (iomode
== IO_OUTPUT
)
4487 if ((*sym1
)->module
== NULL
)
4489 (*sym1
)->module
= module_name
;
4490 (*sym2
)->module
= module_name
;
4492 mio_symbol_ref (sym1
);
4493 mio_symbol_ref (sym2
);
4494 if (ns
->code
->op
== EXEC_ASSIGN
)
4496 mio_name (0, omp_declare_reduction_stmt
);
4497 mio_expr (&ns
->code
->expr1
);
4498 mio_expr (&ns
->code
->expr2
);
4503 mio_name (1, omp_declare_reduction_stmt
);
4504 mio_symtree_ref (&ns
->code
->symtree
);
4505 mio_actual_arglist (&ns
->code
->ext
.actual
, false);
4507 flag
= ns
->code
->resolved_isym
!= NULL
;
4508 mio_integer (&flag
);
4510 write_atom (ATOM_STRING
, ns
->code
->resolved_isym
->name
);
4512 mio_symbol_ref (&ns
->code
->resolved_sym
);
4517 pointer_info
*p1
= mio_symbol_ref (sym1
);
4518 pointer_info
*p2
= mio_symbol_ref (sym2
);
4520 gcc_assert (p1
->u
.rsym
.ns
== p2
->u
.rsym
.ns
);
4521 gcc_assert (p1
->u
.rsym
.sym
== NULL
);
4522 /* Add hidden symbols to the symtree. */
4523 pointer_info
*q
= get_integer (p1
->u
.rsym
.ns
);
4524 q
->u
.pointer
= (void *) ns
;
4525 sym
= gfc_new_symbol (is_initializer
? "omp_priv" : "omp_out", ns
);
4527 sym
->module
= gfc_get_string ("%s", p1
->u
.rsym
.module
);
4528 associate_integer_pointer (p1
, sym
);
4529 sym
->attr
.omp_udr_artificial_var
= 1;
4530 gcc_assert (p2
->u
.rsym
.sym
== NULL
);
4531 sym
= gfc_new_symbol (is_initializer
? "omp_orig" : "omp_in", ns
);
4533 sym
->module
= gfc_get_string ("%s", p2
->u
.rsym
.module
);
4534 associate_integer_pointer (p2
, sym
);
4535 sym
->attr
.omp_udr_artificial_var
= 1;
4536 if (mio_name (0, omp_declare_reduction_stmt
) == 0)
4538 ns
->code
= gfc_get_code (EXEC_ASSIGN
);
4539 mio_expr (&ns
->code
->expr1
);
4540 mio_expr (&ns
->code
->expr2
);
4545 ns
->code
= gfc_get_code (EXEC_CALL
);
4546 mio_symtree_ref (&ns
->code
->symtree
);
4547 mio_actual_arglist (&ns
->code
->ext
.actual
, false);
4549 mio_integer (&flag
);
4552 require_atom (ATOM_STRING
);
4553 ns
->code
->resolved_isym
= gfc_find_subroutine (atom_string
);
4557 mio_symbol_ref (&ns
->code
->resolved_sym
);
4559 ns
->code
->loc
= gfc_current_locus
;
4565 /* Unlike most other routines, the address of the symbol node is already
4566 fixed on input and the name/module has already been filled in.
4567 If you update the symbol format here, don't forget to update read_module
4568 as well (look for "seek to the symbol's component list"). */
4571 mio_symbol (gfc_symbol
*sym
)
4573 int intmod
= INTMOD_NONE
;
4577 mio_symbol_attribute (&sym
->attr
);
4579 if (sym
->attr
.pdt_type
)
4580 sym
->name
= gfc_dt_upper_string (sym
->name
);
4582 /* Note that components are always saved, even if they are supposed
4583 to be private. Component access is checked during searching. */
4584 mio_component_list (&sym
->components
, sym
->attr
.vtype
);
4585 if (sym
->components
!= NULL
)
4586 sym
->component_access
4587 = MIO_NAME (gfc_access
) (sym
->component_access
, access_types
);
4589 mio_typespec (&sym
->ts
);
4590 if (sym
->ts
.type
== BT_CLASS
)
4591 sym
->attr
.class_ok
= 1;
4593 if (iomode
== IO_OUTPUT
)
4594 mio_namespace_ref (&sym
->formal_ns
);
4597 mio_namespace_ref (&sym
->formal_ns
);
4599 sym
->formal_ns
->proc_name
= sym
;
4602 /* Save/restore common block links. */
4603 mio_symbol_ref (&sym
->common_next
);
4605 mio_formal_arglist (&sym
->formal
);
4607 if (sym
->attr
.flavor
== FL_PARAMETER
)
4608 mio_expr (&sym
->value
);
4610 mio_array_spec (&sym
->as
);
4612 mio_symbol_ref (&sym
->result
);
4614 if (sym
->attr
.cray_pointee
)
4615 mio_symbol_ref (&sym
->cp_pointer
);
4617 /* Load/save the f2k_derived namespace of a derived-type symbol. */
4618 mio_full_f2k_derived (sym
);
4620 /* PDT types store the symbol specification list here. */
4621 mio_actual_arglist (&sym
->param_list
, true);
4625 /* Add the fields that say whether this is from an intrinsic module,
4626 and if so, what symbol it is within the module. */
4627 /* mio_integer (&(sym->from_intmod)); */
4628 if (iomode
== IO_OUTPUT
)
4630 intmod
= sym
->from_intmod
;
4631 mio_integer (&intmod
);
4635 mio_integer (&intmod
);
4637 sym
->from_intmod
= current_intmod
;
4639 sym
->from_intmod
= (intmod_id
) intmod
;
4642 mio_integer (&(sym
->intmod_sym_id
));
4644 if (gfc_fl_struct (sym
->attr
.flavor
))
4645 mio_integer (&(sym
->hash_value
));
4648 && sym
->formal_ns
->proc_name
== sym
4649 && sym
->formal_ns
->entries
== NULL
)
4650 mio_omp_declare_simd (sym
->formal_ns
, &sym
->formal_ns
->omp_declare_simd
);
4656 /************************* Top level subroutines *************************/
4658 /* A recursive function to look for a specific symbol by name and by
4659 module. Whilst several symtrees might point to one symbol, its
4660 is sufficient for the purposes here than one exist. Note that
4661 generic interfaces are distinguished as are symbols that have been
4662 renamed in another module. */
4663 static gfc_symtree
*
4664 find_symbol (gfc_symtree
*st
, const char *name
,
4665 const char *module
, int generic
)
4668 gfc_symtree
*retval
, *s
;
4670 if (st
== NULL
|| st
->n
.sym
== NULL
)
4673 c
= strcmp (name
, st
->n
.sym
->name
);
4674 if (c
== 0 && st
->n
.sym
->module
4675 && strcmp (module
, st
->n
.sym
->module
) == 0
4676 && !check_unique_name (st
->name
))
4678 s
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4680 /* Detect symbols that are renamed by use association in another
4681 module by the absence of a symtree and null attr.use_rename,
4682 since the latter is not transmitted in the module file. */
4683 if (((!generic
&& !st
->n
.sym
->attr
.generic
)
4684 || (generic
&& st
->n
.sym
->attr
.generic
))
4685 && !(s
== NULL
&& !st
->n
.sym
->attr
.use_rename
))
4689 retval
= find_symbol (st
->left
, name
, module
, generic
);
4692 retval
= find_symbol (st
->right
, name
, module
, generic
);
4698 /* Skip a list between balanced left and right parens.
4699 By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
4700 have been already parsed by hand, and the remaining of the content is to be
4701 skipped here. The default value is 0 (balanced parens). */
4704 skip_list (int nest_level
= 0)
4711 switch (parse_atom ())
4734 /* Load operator interfaces from the module. Interfaces are unusual
4735 in that they attach themselves to existing symbols. */
4738 load_operator_interfaces (void)
4741 /* "module" must be large enough for the case of submodules in which the name
4742 has the form module.submodule */
4743 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[2 * GFC_MAX_SYMBOL_LEN
+ 2];
4745 pointer_info
*pi
= NULL
;
4750 while (peek_atom () != ATOM_RPAREN
)
4754 mio_internal_string (name
);
4755 mio_internal_string (module
);
4757 n
= number_use_names (name
, true);
4760 for (i
= 1; i
<= n
; i
++)
4762 /* Decide if we need to load this one or not. */
4763 p
= find_use_name_n (name
, &i
, true);
4767 while (parse_atom () != ATOM_RPAREN
);
4773 uop
= gfc_get_uop (p
);
4774 pi
= mio_interface_rest (&uop
->op
);
4778 if (gfc_find_uop (p
, NULL
))
4780 uop
= gfc_get_uop (p
);
4781 uop
->op
= gfc_get_interface ();
4782 uop
->op
->where
= gfc_current_locus
;
4783 add_fixup (pi
->integer
, &uop
->op
->sym
);
4792 /* Load interfaces from the module. Interfaces are unusual in that
4793 they attach themselves to existing symbols. */
4796 load_generic_interfaces (void)
4799 /* "module" must be large enough for the case of submodules in which the name
4800 has the form module.submodule */
4801 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[2 * GFC_MAX_SYMBOL_LEN
+ 2];
4803 gfc_interface
*generic
= NULL
, *gen
= NULL
;
4805 bool ambiguous_set
= false;
4809 while (peek_atom () != ATOM_RPAREN
)
4813 mio_internal_string (name
);
4814 mio_internal_string (module
);
4816 n
= number_use_names (name
, false);
4817 renamed
= n
? 1 : 0;
4820 for (i
= 1; i
<= n
; i
++)
4823 /* Decide if we need to load this one or not. */
4824 p
= find_use_name_n (name
, &i
, false);
4826 if (!p
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
4828 /* Skip the specific names for these cases. */
4829 while (i
== 1 && parse_atom () != ATOM_RPAREN
);
4834 st
= find_symbol (gfc_current_ns
->sym_root
,
4835 name
, module_name
, 1);
4837 /* If the symbol exists already and is being USEd without being
4838 in an ONLY clause, do not load a new symtree(11.3.2). */
4839 if (!only_flag
&& st
)
4847 if (strcmp (st
->name
, p
) != 0)
4849 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4855 /* Since we haven't found a valid generic interface, we had
4859 gfc_get_symbol (p
, NULL
, &sym
);
4860 sym
->name
= gfc_get_string ("%s", name
);
4861 sym
->module
= module_name
;
4862 sym
->attr
.flavor
= FL_PROCEDURE
;
4863 sym
->attr
.generic
= 1;
4864 sym
->attr
.use_assoc
= 1;
4869 /* Unless sym is a generic interface, this reference
4872 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4876 if (st
&& !sym
->attr
.generic
4879 && strcmp (module
, sym
->module
))
4881 ambiguous_set
= true;
4886 sym
->attr
.use_only
= only_flag
;
4887 sym
->attr
.use_rename
= renamed
;
4891 mio_interface_rest (&sym
->generic
);
4892 generic
= sym
->generic
;
4894 else if (!sym
->generic
)
4896 sym
->generic
= generic
;
4897 sym
->attr
.generic_copy
= 1;
4900 /* If a procedure that is not generic has generic interfaces
4901 that include itself, it is generic! We need to take care
4902 to retain symbols ambiguous that were already so. */
4903 if (sym
->attr
.use_assoc
4904 && !sym
->attr
.generic
4905 && sym
->attr
.flavor
== FL_PROCEDURE
)
4907 for (gen
= generic
; gen
; gen
= gen
->next
)
4909 if (gen
->sym
== sym
)
4911 sym
->attr
.generic
= 1;
4926 /* Load common blocks. */
4931 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4936 while (peek_atom () != ATOM_RPAREN
)
4941 mio_internal_string (name
);
4943 p
= gfc_get_common (name
, 1);
4945 mio_symbol_ref (&p
->head
);
4946 mio_integer (&flags
);
4950 p
->threadprivate
= 1;
4951 p
->omp_device_type
= (gfc_omp_device_type
) ((flags
>> 2) & 3);
4954 /* Get whether this was a bind(c) common or not. */
4955 mio_integer (&p
->is_bind_c
);
4956 /* Get the binding label. */
4957 label
= read_string ();
4959 p
->binding_label
= IDENTIFIER_POINTER (get_identifier (label
));
4969 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4970 so that unused variables are not loaded and so that the expression can
4976 gfc_equiv
*head
, *tail
, *end
, *eq
, *equiv
;
4980 in_load_equiv
= true;
4982 end
= gfc_current_ns
->equiv
;
4983 while (end
!= NULL
&& end
->next
!= NULL
)
4986 while (peek_atom () != ATOM_RPAREN
) {
4990 while(peek_atom () != ATOM_RPAREN
)
4993 head
= tail
= gfc_get_equiv ();
4996 tail
->eq
= gfc_get_equiv ();
5000 mio_pool_string (&tail
->module
);
5001 mio_expr (&tail
->expr
);
5004 /* Check for duplicate equivalences being loaded from different modules */
5006 for (equiv
= gfc_current_ns
->equiv
; equiv
; equiv
= equiv
->next
)
5008 if (equiv
->module
&& head
->module
5009 && strcmp (equiv
->module
, head
->module
) == 0)
5018 for (eq
= head
; eq
; eq
= head
)
5021 gfc_free_expr (eq
->expr
);
5027 gfc_current_ns
->equiv
= head
;
5038 in_load_equiv
= false;
5042 /* This function loads OpenMP user defined reductions. */
5044 load_omp_udrs (void)
5047 while (peek_atom () != ATOM_RPAREN
)
5049 const char *name
= NULL
, *newname
;
5053 gfc_omp_reduction_op rop
= OMP_REDUCTION_USER
;
5056 mio_pool_string (&name
);
5059 if (startswith (name
, "operator "))
5061 const char *p
= name
+ sizeof ("operator ") - 1;
5062 if (strcmp (p
, "+") == 0)
5063 rop
= OMP_REDUCTION_PLUS
;
5064 else if (strcmp (p
, "*") == 0)
5065 rop
= OMP_REDUCTION_TIMES
;
5066 else if (strcmp (p
, "-") == 0)
5067 rop
= OMP_REDUCTION_MINUS
;
5068 else if (strcmp (p
, ".and.") == 0)
5069 rop
= OMP_REDUCTION_AND
;
5070 else if (strcmp (p
, ".or.") == 0)
5071 rop
= OMP_REDUCTION_OR
;
5072 else if (strcmp (p
, ".eqv.") == 0)
5073 rop
= OMP_REDUCTION_EQV
;
5074 else if (strcmp (p
, ".neqv.") == 0)
5075 rop
= OMP_REDUCTION_NEQV
;
5078 if (rop
== OMP_REDUCTION_USER
&& name
[0] == '.')
5080 size_t len
= strlen (name
+ 1);
5081 altname
= XALLOCAVEC (char, len
);
5082 gcc_assert (name
[len
] == '.');
5083 memcpy (altname
, name
+ 1, len
- 1);
5084 altname
[len
- 1] = '\0';
5087 if (rop
== OMP_REDUCTION_USER
)
5088 newname
= find_use_name (altname
? altname
: name
, !!altname
);
5089 else if (only_flag
&& find_use_operator ((gfc_intrinsic_op
) rop
) == NULL
)
5091 if (newname
== NULL
)
5096 if (altname
&& newname
!= altname
)
5098 size_t len
= strlen (newname
);
5099 altname
= XALLOCAVEC (char, len
+ 3);
5101 memcpy (altname
+ 1, newname
, len
);
5102 altname
[len
+ 1] = '.';
5103 altname
[len
+ 2] = '\0';
5104 name
= gfc_get_string ("%s", altname
);
5106 st
= gfc_find_symtree (gfc_current_ns
->omp_udr_root
, name
);
5107 gfc_omp_udr
*udr
= gfc_omp_udr_find (st
, &ts
);
5110 require_atom (ATOM_INTEGER
);
5111 pointer_info
*p
= get_integer (atom_int
);
5112 if (strcmp (p
->u
.rsym
.module
, udr
->omp_out
->module
))
5114 gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
5116 p
->u
.rsym
.module
, &gfc_current_locus
);
5117 gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
5119 udr
->omp_out
->module
, &udr
->where
);
5124 udr
= gfc_get_omp_udr ();
5128 udr
->where
= gfc_current_locus
;
5129 udr
->combiner_ns
= gfc_get_namespace (gfc_current_ns
, 1);
5130 udr
->combiner_ns
->proc_name
= gfc_current_ns
->proc_name
;
5131 mio_omp_udr_expr (udr
, &udr
->omp_out
, &udr
->omp_in
, udr
->combiner_ns
,
5133 if (peek_atom () != ATOM_RPAREN
)
5135 udr
->initializer_ns
= gfc_get_namespace (gfc_current_ns
, 1);
5136 udr
->initializer_ns
->proc_name
= gfc_current_ns
->proc_name
;
5137 mio_omp_udr_expr (udr
, &udr
->omp_priv
, &udr
->omp_orig
,
5138 udr
->initializer_ns
, true);
5142 udr
->next
= st
->n
.omp_udr
;
5143 st
->n
.omp_udr
= udr
;
5147 st
= gfc_new_symtree (&gfc_current_ns
->omp_udr_root
, name
);
5148 st
->n
.omp_udr
= udr
;
5156 /* Recursive function to traverse the pointer_info tree and load a
5157 needed symbol. We return nonzero if we load a symbol and stop the
5158 traversal, because the act of loading can alter the tree. */
5161 load_needed (pointer_info
*p
)
5172 rv
|= load_needed (p
->left
);
5173 rv
|= load_needed (p
->right
);
5175 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
5178 p
->u
.rsym
.state
= USED
;
5180 set_module_locus (&p
->u
.rsym
.where
);
5182 sym
= p
->u
.rsym
.sym
;
5185 q
= get_integer (p
->u
.rsym
.ns
);
5187 ns
= (gfc_namespace
*) q
->u
.pointer
;
5190 /* Create an interface namespace if necessary. These are
5191 the namespaces that hold the formal parameters of module
5194 ns
= gfc_get_namespace (NULL
, 0);
5195 associate_integer_pointer (q
, ns
);
5198 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
5199 doesn't go pear-shaped if the symbol is used. */
5201 gfc_find_symbol (p
->u
.rsym
.module
, gfc_current_ns
,
5204 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
5205 sym
->name
= gfc_dt_lower_string (p
->u
.rsym
.true_name
);
5206 sym
->module
= gfc_get_string ("%s", p
->u
.rsym
.module
);
5207 if (p
->u
.rsym
.binding_label
)
5208 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier
5209 (p
->u
.rsym
.binding_label
));
5211 associate_integer_pointer (p
, sym
);
5215 sym
->attr
.use_assoc
= 1;
5217 /* Unliked derived types, a STRUCTURE may share names with other symbols.
5218 We greedily converted the symbol name to lowercase before we knew its
5219 type, so now we must fix it. */
5220 if (sym
->attr
.flavor
== FL_STRUCT
)
5221 sym
->name
= gfc_dt_upper_string (sym
->name
);
5223 /* Mark as only or rename for later diagnosis for explicitly imported
5224 but not used warnings; don't mark internal symbols such as __vtab,
5225 __def_init etc. Only mark them if they have been explicitly loaded. */
5227 if (only_flag
&& sym
->name
[0] != '_' && sym
->name
[1] != '_')
5231 /* Search the use/rename list for the variable; if the variable is
5233 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5235 if (strcmp (u
->use_name
, sym
->name
) == 0)
5237 sym
->attr
.use_only
= 1;
5243 if (p
->u
.rsym
.renamed
)
5244 sym
->attr
.use_rename
= 1;
5250 /* Recursive function for cleaning up things after a module has been read. */
5253 read_cleanup (pointer_info
*p
)
5261 read_cleanup (p
->left
);
5262 read_cleanup (p
->right
);
5264 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
5267 /* Add hidden symbols to the symtree. */
5268 q
= get_integer (p
->u
.rsym
.ns
);
5269 ns
= (gfc_namespace
*) q
->u
.pointer
;
5271 if (!p
->u
.rsym
.sym
->attr
.vtype
5272 && !p
->u
.rsym
.sym
->attr
.vtab
)
5273 st
= gfc_get_unique_symtree (ns
);
5276 /* There is no reason to use 'unique_symtrees' for vtabs or
5277 vtypes - their name is fine for a symtree and reduces the
5278 namespace pollution. */
5279 st
= gfc_find_symtree (ns
->sym_root
, p
->u
.rsym
.sym
->name
);
5281 st
= gfc_new_symtree (&ns
->sym_root
, p
->u
.rsym
.sym
->name
);
5284 st
->n
.sym
= p
->u
.rsym
.sym
;
5287 /* Fixup any symtree references. */
5288 p
->u
.rsym
.symtree
= st
;
5289 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
5290 p
->u
.rsym
.stfixup
= NULL
;
5293 /* Free unused symbols. */
5294 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
5295 gfc_free_symbol (p
->u
.rsym
.sym
);
5299 /* It is not quite enough to check for ambiguity in the symbols by
5300 the loaded symbol and the new symbol not being identical. */
5302 check_for_ambiguous (gfc_symtree
*st
, pointer_info
*info
)
5306 symbol_attribute attr
;
5309 if (gfc_current_ns
->proc_name
&& st
->name
== gfc_current_ns
->proc_name
->name
)
5311 gfc_error ("%qs of module %qs, imported at %C, is also the name of the "
5312 "current program unit", st
->name
, module_name
);
5317 rsym
= info
->u
.rsym
.sym
;
5321 if (st_sym
->attr
.vtab
|| st_sym
->attr
.vtype
)
5324 /* If the existing symbol is generic from a different module and
5325 the new symbol is generic there can be no ambiguity. */
5326 if (st_sym
->attr
.generic
5328 && st_sym
->module
!= module_name
)
5330 /* The new symbol's attributes have not yet been read. Since
5331 we need attr.generic, read it directly. */
5332 get_module_locus (&locus
);
5333 set_module_locus (&info
->u
.rsym
.where
);
5336 mio_symbol_attribute (&attr
);
5337 set_module_locus (&locus
);
5346 /* Read a module file. */
5351 module_locus operator_interfaces
, user_operators
, omp_udrs
;
5353 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5355 /* Workaround -Wmaybe-uninitialized false positive during
5356 profiledbootstrap by initializing them. */
5357 int ambiguous
= 0, j
, nuse
, symbol
= 0;
5358 pointer_info
*info
, *q
;
5359 gfc_use_rename
*u
= NULL
;
5363 get_module_locus (&operator_interfaces
); /* Skip these for now. */
5366 get_module_locus (&user_operators
);
5370 /* Skip commons and equivalences for now. */
5374 /* Skip OpenMP UDRs. */
5375 get_module_locus (&omp_udrs
);
5380 /* Create the fixup nodes for all the symbols. */
5382 while (peek_atom () != ATOM_RPAREN
)
5385 require_atom (ATOM_INTEGER
);
5386 info
= get_integer (atom_int
);
5388 info
->type
= P_SYMBOL
;
5389 info
->u
.rsym
.state
= UNUSED
;
5391 info
->u
.rsym
.true_name
= read_string ();
5392 info
->u
.rsym
.module
= read_string ();
5393 bind_label
= read_string ();
5394 if (strlen (bind_label
))
5395 info
->u
.rsym
.binding_label
= bind_label
;
5397 XDELETEVEC (bind_label
);
5399 require_atom (ATOM_INTEGER
);
5400 info
->u
.rsym
.ns
= atom_int
;
5402 get_module_locus (&info
->u
.rsym
.where
);
5404 /* See if the symbol has already been loaded by a previous module.
5405 If so, we reference the existing symbol and prevent it from
5406 being loaded again. This should not happen if the symbol being
5407 read is an index for an assumed shape dummy array (ns != 1). */
5409 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
5412 || (sym
->attr
.flavor
== FL_VARIABLE
&& info
->u
.rsym
.ns
!=1))
5418 info
->u
.rsym
.state
= USED
;
5419 info
->u
.rsym
.sym
= sym
;
5420 /* The current symbol has already been loaded, so we can avoid loading
5421 it again. However, if it is a derived type, some of its components
5422 can be used in expressions in the module. To avoid the module loading
5423 failing, we need to associate the module's component pointer indexes
5424 with the existing symbol's component pointers. */
5425 if (gfc_fl_struct (sym
->attr
.flavor
))
5429 /* First seek to the symbol's component list. */
5430 mio_lparen (); /* symbol opening. */
5431 skip_list (); /* skip symbol attribute. */
5433 mio_lparen (); /* component list opening. */
5434 for (c
= sym
->components
; c
; c
= c
->next
)
5437 const char *comp_name
= NULL
;
5440 mio_lparen (); /* component opening. */
5442 p
= get_integer (n
);
5443 if (p
->u
.pointer
== NULL
)
5444 associate_integer_pointer (p
, c
);
5445 mio_pool_string (&comp_name
);
5446 if (comp_name
!= c
->name
)
5448 gfc_fatal_error ("Mismatch in components of derived type "
5449 "%qs from %qs at %C: expecting %qs, "
5450 "but got %qs", sym
->name
, sym
->module
,
5451 c
->name
, comp_name
);
5453 skip_list (1); /* component end. */
5455 mio_rparen (); /* component list closing. */
5457 skip_list (1); /* symbol end. */
5462 /* Some symbols do not have a namespace (eg. formal arguments),
5463 so the automatic "unique symtree" mechanism must be suppressed
5464 by marking them as referenced. */
5465 q
= get_integer (info
->u
.rsym
.ns
);
5466 if (q
->u
.pointer
== NULL
)
5468 info
->u
.rsym
.referenced
= 1;
5475 /* Parse the symtree lists. This lets us mark which symbols need to
5476 be loaded. Renaming is also done at this point by replacing the
5481 while (peek_atom () != ATOM_RPAREN
)
5483 mio_internal_string (name
);
5484 mio_integer (&ambiguous
);
5485 mio_integer (&symbol
);
5487 info
= get_integer (symbol
);
5489 /* See how many use names there are. If none, go through the start
5490 of the loop at least once. */
5491 nuse
= number_use_names (name
, false);
5492 info
->u
.rsym
.renamed
= nuse
? 1 : 0;
5497 for (j
= 1; j
<= nuse
; j
++)
5499 /* Get the jth local name for this symbol. */
5500 p
= find_use_name_n (name
, &j
, false);
5502 if (p
== NULL
&& strcmp (name
, module_name
) == 0)
5505 /* Exception: Always import vtabs & vtypes. */
5506 if (p
== NULL
&& name
[0] == '_'
5507 && (startswith (name
, "__vtab_")
5508 || startswith (name
, "__vtype_")))
5511 /* Skip symtree nodes not in an ONLY clause, unless there
5512 is an existing symtree loaded from another USE statement. */
5515 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5517 && strcmp (st
->n
.sym
->name
, info
->u
.rsym
.true_name
) == 0
5518 && st
->n
.sym
->module
!= NULL
5519 && strcmp (st
->n
.sym
->module
, info
->u
.rsym
.module
) == 0)
5521 info
->u
.rsym
.symtree
= st
;
5522 info
->u
.rsym
.sym
= st
->n
.sym
;
5527 /* If a symbol of the same name and module exists already,
5528 this symbol, which is not in an ONLY clause, must not be
5529 added to the namespace(11.3.2). Note that find_symbol
5530 only returns the first occurrence that it finds. */
5531 if (!only_flag
&& !info
->u
.rsym
.renamed
5532 && strcmp (name
, module_name
) != 0
5533 && find_symbol (gfc_current_ns
->sym_root
, name
,
5537 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
5540 && !(st
->n
.sym
&& st
->n
.sym
->attr
.used_in_submodule
))
5542 /* Check for ambiguous symbols. */
5543 if (check_for_ambiguous (st
, info
))
5546 info
->u
.rsym
.symtree
= st
;
5552 /* This symbol is host associated from a module in a
5553 submodule. Hide it with a unique symtree. */
5554 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
5555 s
->n
.sym
= st
->n
.sym
;
5560 /* Create a symtree node in the current namespace for this
5562 st
= check_unique_name (p
)
5563 ? gfc_get_unique_symtree (gfc_current_ns
)
5564 : gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
5565 st
->ambiguous
= ambiguous
;
5568 sym
= info
->u
.rsym
.sym
;
5570 /* Create a symbol node if it doesn't already exist. */
5573 info
->u
.rsym
.sym
= gfc_new_symbol (info
->u
.rsym
.true_name
,
5575 info
->u
.rsym
.sym
->name
= gfc_dt_lower_string (info
->u
.rsym
.true_name
);
5576 sym
= info
->u
.rsym
.sym
;
5577 sym
->module
= gfc_get_string ("%s", info
->u
.rsym
.module
);
5579 if (info
->u
.rsym
.binding_label
)
5581 tree id
= get_identifier (info
->u
.rsym
.binding_label
);
5582 sym
->binding_label
= IDENTIFIER_POINTER (id
);
5589 if (strcmp (name
, p
) != 0)
5590 sym
->attr
.use_rename
= 1;
5593 || (!startswith (name
, "__vtab_")
5594 && !startswith (name
, "__vtype_")))
5595 sym
->attr
.use_only
= only_flag
;
5597 /* Store the symtree pointing to this symbol. */
5598 info
->u
.rsym
.symtree
= st
;
5600 if (info
->u
.rsym
.state
== UNUSED
)
5601 info
->u
.rsym
.state
= NEEDED
;
5602 info
->u
.rsym
.referenced
= 1;
5609 /* Load intrinsic operator interfaces. */
5610 set_module_locus (&operator_interfaces
);
5613 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5615 gfc_use_rename
*u
= NULL
, *v
= NULL
;
5618 if (i
== INTRINSIC_USER
)
5623 u
= find_use_operator ((gfc_intrinsic_op
) i
);
5625 /* F2018:10.1.5.5.1 requires same interpretation of old and new-style
5626 relational operators. Special handling for USE, ONLY. */
5630 j
= INTRINSIC_EQ_OS
;
5632 case INTRINSIC_EQ_OS
:
5636 j
= INTRINSIC_NE_OS
;
5638 case INTRINSIC_NE_OS
:
5642 j
= INTRINSIC_GT_OS
;
5644 case INTRINSIC_GT_OS
:
5648 j
= INTRINSIC_GE_OS
;
5650 case INTRINSIC_GE_OS
:
5654 j
= INTRINSIC_LT_OS
;
5656 case INTRINSIC_LT_OS
:
5660 j
= INTRINSIC_LE_OS
;
5662 case INTRINSIC_LE_OS
:
5670 v
= find_use_operator ((gfc_intrinsic_op
) j
);
5672 if (u
== NULL
&& v
== NULL
)
5684 mio_interface (&gfc_current_ns
->op
[i
]);
5685 if (!gfc_current_ns
->op
[i
] && !gfc_current_ns
->op
[j
])
5696 /* Load generic and user operator interfaces. These must follow the
5697 loading of symtree because otherwise symbols can be marked as
5700 set_module_locus (&user_operators
);
5702 load_operator_interfaces ();
5703 load_generic_interfaces ();
5708 /* Load OpenMP user defined reductions. */
5709 set_module_locus (&omp_udrs
);
5712 /* At this point, we read those symbols that are needed but haven't
5713 been loaded yet. If one symbol requires another, the other gets
5714 marked as NEEDED if its previous state was UNUSED. */
5716 while (load_needed (pi_root
));
5718 /* Make sure all elements of the rename-list were found in the module. */
5720 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5725 if (u
->op
== INTRINSIC_NONE
)
5727 gfc_error ("Symbol %qs referenced at %L not found in module %qs",
5728 u
->use_name
, &u
->where
, module_name
);
5732 if (u
->op
== INTRINSIC_USER
)
5734 gfc_error ("User operator %qs referenced at %L not found "
5735 "in module %qs", u
->use_name
, &u
->where
, module_name
);
5739 gfc_error ("Intrinsic operator %qs referenced at %L not found "
5740 "in module %qs", gfc_op2string (u
->op
), &u
->where
,
5744 /* Clean up symbol nodes that were never loaded, create references
5745 to hidden symbols. */
5747 read_cleanup (pi_root
);
5751 /* Given an access type that is specific to an entity and the default
5752 access, return nonzero if the entity is publicly accessible. If the
5753 element is declared as PUBLIC, then it is public; if declared
5754 PRIVATE, then private, and otherwise it is public unless the default
5755 access in this context has been declared PRIVATE. */
5757 static bool dump_smod
= false;
5760 check_access (gfc_access specific_access
, gfc_access default_access
)
5765 if (specific_access
== ACCESS_PUBLIC
)
5767 if (specific_access
== ACCESS_PRIVATE
)
5770 if (flag_module_private
)
5771 return default_access
== ACCESS_PUBLIC
;
5773 return default_access
!= ACCESS_PRIVATE
;
5778 gfc_check_symbol_access (gfc_symbol
*sym
)
5780 if (sym
->attr
.vtab
|| sym
->attr
.vtype
)
5783 return check_access (sym
->attr
.access
, sym
->ns
->default_access
);
5787 /* A structure to remember which commons we've already written. */
5789 struct written_common
5791 BBT_HEADER(written_common
);
5792 const char *name
, *label
;
5795 static struct written_common
*written_commons
= NULL
;
5797 /* Comparison function used for balancing the binary tree. */
5800 compare_written_commons (void *a1
, void *b1
)
5802 const char *aname
= ((struct written_common
*) a1
)->name
;
5803 const char *alabel
= ((struct written_common
*) a1
)->label
;
5804 const char *bname
= ((struct written_common
*) b1
)->name
;
5805 const char *blabel
= ((struct written_common
*) b1
)->label
;
5806 int c
= strcmp (aname
, bname
);
5808 return (c
!= 0 ? c
: strcmp (alabel
, blabel
));
5811 /* Free a list of written commons. */
5814 free_written_common (struct written_common
*w
)
5820 free_written_common (w
->left
);
5822 free_written_common (w
->right
);
5827 /* Write a common block to the module -- recursive helper function. */
5830 write_common_0 (gfc_symtree
*st
, bool this_module
)
5836 struct written_common
*w
;
5837 bool write_me
= true;
5842 write_common_0 (st
->left
, this_module
);
5844 /* We will write out the binding label, or "" if no label given. */
5845 name
= st
->n
.common
->name
;
5847 label
= (p
->is_bind_c
&& p
->binding_label
) ? p
->binding_label
: "";
5849 /* Check if we've already output this common. */
5850 w
= written_commons
;
5853 int c
= strcmp (name
, w
->name
);
5854 c
= (c
!= 0 ? c
: strcmp (label
, w
->label
));
5858 w
= (c
< 0) ? w
->left
: w
->right
;
5861 if (this_module
&& p
->use_assoc
)
5866 /* Write the common to the module. */
5868 mio_pool_string (&name
);
5870 mio_symbol_ref (&p
->head
);
5871 flags
= p
->saved
? 1 : 0;
5872 if (p
->threadprivate
)
5874 flags
|= p
->omp_device_type
<< 2;
5875 mio_integer (&flags
);
5877 /* Write out whether the common block is bind(c) or not. */
5878 mio_integer (&(p
->is_bind_c
));
5880 mio_pool_string (&label
);
5883 /* Record that we have written this common. */
5884 w
= XCNEW (struct written_common
);
5887 gfc_insert_bbt (&written_commons
, w
, compare_written_commons
);
5890 write_common_0 (st
->right
, this_module
);
5894 /* Write a common, by initializing the list of written commons, calling
5895 the recursive function write_common_0() and cleaning up afterwards. */
5898 write_common (gfc_symtree
*st
)
5900 written_commons
= NULL
;
5901 write_common_0 (st
, true);
5902 write_common_0 (st
, false);
5903 free_written_common (written_commons
);
5904 written_commons
= NULL
;
5908 /* Write the blank common block to the module. */
5911 write_blank_common (void)
5913 const char * name
= BLANK_COMMON_NAME
;
5915 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
5916 this, but it hasn't been checked. Just making it so for now. */
5919 if (gfc_current_ns
->blank_common
.head
== NULL
)
5924 mio_pool_string (&name
);
5926 mio_symbol_ref (&gfc_current_ns
->blank_common
.head
);
5927 saved
= gfc_current_ns
->blank_common
.saved
;
5928 mio_integer (&saved
);
5930 /* Write out whether the common block is bind(c) or not. */
5931 mio_integer (&is_bind_c
);
5933 /* Write out an empty binding label. */
5934 write_atom (ATOM_STRING
, "");
5940 /* Write equivalences to the module. */
5949 for (eq
= gfc_current_ns
->equiv
; eq
; eq
= eq
->next
)
5953 for (e
= eq
; e
; e
= e
->eq
)
5955 if (e
->module
== NULL
)
5956 e
->module
= gfc_get_string ("%s.eq.%d", module_name
, num
);
5957 mio_allocated_string (e
->module
);
5958 mio_expr (&e
->expr
);
5967 /* Write a symbol to the module. */
5970 write_symbol (int n
, gfc_symbol
*sym
)
5974 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
5975 gfc_internal_error ("write_symbol(): bad module symbol %qs", sym
->name
);
5979 if (gfc_fl_struct (sym
->attr
.flavor
))
5982 name
= gfc_dt_upper_string (sym
->name
);
5983 mio_pool_string (&name
);
5986 mio_pool_string (&sym
->name
);
5988 mio_pool_string (&sym
->module
);
5989 if ((sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
) && sym
->binding_label
)
5991 label
= sym
->binding_label
;
5992 mio_pool_string (&label
);
5995 write_atom (ATOM_STRING
, "");
5997 mio_pointer_ref (&sym
->ns
);
6004 /* Recursive traversal function to write the initial set of symbols to
6005 the module. We check to see if the symbol should be written
6006 according to the access specification. */
6009 write_symbol0 (gfc_symtree
*st
)
6013 bool dont_write
= false;
6018 write_symbol0 (st
->left
);
6021 if (sym
->module
== NULL
)
6022 sym
->module
= module_name
;
6024 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
6025 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
6028 if (!gfc_check_symbol_access (sym
))
6033 p
= get_pointer (sym
);
6034 if (p
->type
== P_UNKNOWN
)
6037 if (p
->u
.wsym
.state
!= WRITTEN
)
6039 write_symbol (p
->integer
, sym
);
6040 p
->u
.wsym
.state
= WRITTEN
;
6044 write_symbol0 (st
->right
);
6049 write_omp_udr (gfc_omp_udr
*udr
)
6053 case OMP_REDUCTION_USER
:
6054 /* Non-operators can't be used outside of the module. */
6055 if (udr
->name
[0] != '.')
6060 size_t len
= strlen (udr
->name
+ 1);
6061 char *name
= XALLOCAVEC (char, len
);
6062 memcpy (name
, udr
->name
, len
- 1);
6063 name
[len
- 1] = '\0';
6064 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
6065 /* If corresponding user operator is private, don't write
6069 gfc_user_op
*uop
= st
->n
.uop
;
6070 if (!check_access (uop
->access
, uop
->ns
->default_access
))
6075 case OMP_REDUCTION_PLUS
:
6076 case OMP_REDUCTION_MINUS
:
6077 case OMP_REDUCTION_TIMES
:
6078 case OMP_REDUCTION_AND
:
6079 case OMP_REDUCTION_OR
:
6080 case OMP_REDUCTION_EQV
:
6081 case OMP_REDUCTION_NEQV
:
6082 /* If corresponding operator is private, don't write the UDR. */
6083 if (!check_access (gfc_current_ns
->operator_access
[udr
->rop
],
6084 gfc_current_ns
->default_access
))
6090 if (udr
->ts
.type
== BT_DERIVED
|| udr
->ts
.type
== BT_CLASS
)
6092 /* If derived type is private, don't write the UDR. */
6093 if (!gfc_check_symbol_access (udr
->ts
.u
.derived
))
6098 mio_pool_string (&udr
->name
);
6099 mio_typespec (&udr
->ts
);
6100 mio_omp_udr_expr (udr
, &udr
->omp_out
, &udr
->omp_in
, udr
->combiner_ns
, false);
6101 if (udr
->initializer_ns
)
6102 mio_omp_udr_expr (udr
, &udr
->omp_priv
, &udr
->omp_orig
,
6103 udr
->initializer_ns
, true);
6109 write_omp_udrs (gfc_symtree
*st
)
6114 write_omp_udrs (st
->left
);
6116 for (udr
= st
->n
.omp_udr
; udr
; udr
= udr
->next
)
6117 write_omp_udr (udr
);
6118 write_omp_udrs (st
->right
);
6122 /* Type for the temporary tree used when writing secondary symbols. */
6124 struct sorted_pointer_info
6126 BBT_HEADER (sorted_pointer_info
);
6131 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
6133 /* Recursively traverse the temporary tree, free its contents. */
6136 free_sorted_pointer_info_tree (sorted_pointer_info
*p
)
6141 free_sorted_pointer_info_tree (p
->left
);
6142 free_sorted_pointer_info_tree (p
->right
);
6147 /* Comparison function for the temporary tree. */
6150 compare_sorted_pointer_info (void *_spi1
, void *_spi2
)
6152 sorted_pointer_info
*spi1
, *spi2
;
6153 spi1
= (sorted_pointer_info
*)_spi1
;
6154 spi2
= (sorted_pointer_info
*)_spi2
;
6156 if (spi1
->p
->integer
< spi2
->p
->integer
)
6158 if (spi1
->p
->integer
> spi2
->p
->integer
)
6164 /* Finds the symbols that need to be written and collects them in the
6165 sorted_pi tree so that they can be traversed in an order
6166 independent of memory addresses. */
6169 find_symbols_to_write(sorted_pointer_info
**tree
, pointer_info
*p
)
6174 if (p
->type
== P_SYMBOL
&& p
->u
.wsym
.state
== NEEDS_WRITE
)
6176 sorted_pointer_info
*sp
= gfc_get_sorted_pointer_info();
6179 gfc_insert_bbt (tree
, sp
, compare_sorted_pointer_info
);
6182 find_symbols_to_write (tree
, p
->left
);
6183 find_symbols_to_write (tree
, p
->right
);
6187 /* Recursive function that traverses the tree of symbols that need to be
6188 written and writes them in order. */
6191 write_symbol1_recursion (sorted_pointer_info
*sp
)
6196 write_symbol1_recursion (sp
->left
);
6198 pointer_info
*p1
= sp
->p
;
6199 gcc_assert (p1
->type
== P_SYMBOL
&& p1
->u
.wsym
.state
== NEEDS_WRITE
);
6201 p1
->u
.wsym
.state
= WRITTEN
;
6202 write_symbol (p1
->integer
, p1
->u
.wsym
.sym
);
6203 p1
->u
.wsym
.sym
->attr
.public_used
= 1;
6205 write_symbol1_recursion (sp
->right
);
6209 /* Write the secondary set of symbols to the module file. These are
6210 symbols that were not public yet are needed by the public symbols
6211 or another dependent symbol. The act of writing a symbol can add
6212 symbols to the pointer_info tree, so we return nonzero if a symbol
6213 was written and pass that information upwards. The caller will
6214 then call this function again until nothing was written. It uses
6215 the utility functions and a temporary tree to ensure a reproducible
6216 ordering of the symbol output and thus the module file. */
6219 write_symbol1 (pointer_info
*p
)
6224 /* Put symbols that need to be written into a tree sorted on the
6227 sorted_pointer_info
*spi_root
= NULL
;
6228 find_symbols_to_write (&spi_root
, p
);
6230 /* No symbols to write, return. */
6234 /* Otherwise, write and free the tree again. */
6235 write_symbol1_recursion (spi_root
);
6236 free_sorted_pointer_info_tree (spi_root
);
6242 /* Write operator interfaces associated with a symbol. */
6245 write_operator (gfc_user_op
*uop
)
6247 static char nullstring
[] = "";
6248 const char *p
= nullstring
;
6250 if (uop
->op
== NULL
|| !check_access (uop
->access
, uop
->ns
->default_access
))
6253 mio_symbol_interface (&uop
->name
, &p
, &uop
->op
);
6257 /* Write generic interfaces from the namespace sym_root. */
6260 write_generic (gfc_symtree
*st
)
6267 write_generic (st
->left
);
6270 if (sym
&& !check_unique_name (st
->name
)
6271 && sym
->generic
&& gfc_check_symbol_access (sym
))
6274 sym
->module
= module_name
;
6276 mio_symbol_interface (&st
->name
, &sym
->module
, &sym
->generic
);
6279 write_generic (st
->right
);
6284 write_symtree (gfc_symtree
*st
)
6291 /* A symbol in an interface body must not be visible in the
6293 if (sym
->ns
!= gfc_current_ns
6294 && sym
->ns
->proc_name
6295 && sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
6298 if (!gfc_check_symbol_access (sym
)
6299 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
6300 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
6303 if (check_unique_name (st
->name
))
6306 /* From F2003 onwards, intrinsic procedures are no longer subject to
6307 the restriction, "that an elemental intrinsic function here be of
6308 type integer or character and each argument must be an initialization
6309 expr of type integer or character" is lifted so that intrinsic
6310 procedures can be over-ridden. This requires that the intrinsic
6311 symbol not appear in the module file, thereby preventing ambiguity
6313 if (strcmp (sym
->module
, "(intrinsic)") == 0
6314 && (gfc_option
.allow_std
& GFC_STD_F2003
))
6317 p
= find_pointer (sym
);
6319 gfc_internal_error ("write_symtree(): Symbol not written");
6321 mio_pool_string (&st
->name
);
6322 mio_integer (&st
->ambiguous
);
6323 mio_hwi (&p
->integer
);
6332 /* Initialize the column counter. */
6335 /* Write the operator interfaces. */
6338 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
6340 if (i
== INTRINSIC_USER
)
6343 mio_interface (check_access (gfc_current_ns
->operator_access
[i
],
6344 gfc_current_ns
->default_access
)
6345 ? &gfc_current_ns
->op
[i
] : NULL
);
6353 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
6359 write_generic (gfc_current_ns
->sym_root
);
6365 write_blank_common ();
6366 write_common (gfc_current_ns
->common_root
);
6378 write_omp_udrs (gfc_current_ns
->omp_udr_root
);
6383 /* Write symbol information. First we traverse all symbols in the
6384 primary namespace, writing those that need to be written.
6385 Sometimes writing one symbol will cause another to need to be
6386 written. A list of these symbols ends up on the write stack, and
6387 we end by popping the bottom of the stack and writing the symbol
6388 until the stack is empty. */
6392 write_symbol0 (gfc_current_ns
->sym_root
);
6393 while (write_symbol1 (pi_root
))
6402 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
6407 /* Read a CRC32 sum from the gzip trailer of a module file. Returns
6408 true on success, false on failure. */
6411 read_crc32_from_module_file (const char* filename
, uLong
* crc
)
6417 /* Open the file in binary mode. */
6418 if ((file
= fopen (filename
, "rb")) == NULL
)
6421 /* The gzip crc32 value is found in the [END-8, END-4] bytes of the
6422 file. See RFC 1952. */
6423 if (fseek (file
, -8, SEEK_END
) != 0)
6429 /* Read the CRC32. */
6430 if (fread (buf
, 1, 4, file
) != 4)
6436 /* Close the file. */
6439 val
= (buf
[0] & 0xFF) + ((buf
[1] & 0xFF) << 8) + ((buf
[2] & 0xFF) << 16)
6440 + ((buf
[3] & 0xFF) << 24);
6443 /* For debugging, the CRC value printed in hexadecimal should match
6444 the CRC printed by "zcat -l -v filename".
6445 printf("CRC of file %s is %x\n", filename, val); */
6451 /* Given module, dump it to disk. If there was an error while
6452 processing the module, dump_flag will be set to zero and we delete
6453 the module file, even if it was already there. */
6456 dump_module (const char *name
, int dump_flag
)
6459 char *filename
, *filename_tmp
;
6462 module_name
= gfc_get_string ("%s", name
);
6466 name
= submodule_name
;
6467 n
= strlen (name
) + strlen (SUBMODULE_EXTENSION
) + 1;
6470 n
= strlen (name
) + strlen (MODULE_EXTENSION
) + 1;
6472 if (gfc_option
.module_dir
!= NULL
)
6474 n
+= strlen (gfc_option
.module_dir
);
6475 filename
= (char *) alloca (n
);
6476 strcpy (filename
, gfc_option
.module_dir
);
6477 strcat (filename
, name
);
6481 filename
= (char *) alloca (n
);
6482 strcpy (filename
, name
);
6486 strcat (filename
, SUBMODULE_EXTENSION
);
6488 strcat (filename
, MODULE_EXTENSION
);
6490 /* Name of the temporary file used to write the module. */
6491 filename_tmp
= (char *) alloca (n
+ 1);
6492 strcpy (filename_tmp
, filename
);
6493 strcat (filename_tmp
, "0");
6495 /* There was an error while processing the module. We delete the
6496 module file, even if it was already there. */
6503 if (gfc_cpp_makedep ())
6504 gfc_cpp_add_target (filename
);
6506 /* Write the module to the temporary file. */
6507 module_fp
= gzopen (filename_tmp
, "w");
6508 if (module_fp
== NULL
)
6509 gfc_fatal_error ("Cannot open module file %qs for writing at %C: %s",
6510 filename_tmp
, xstrerror (errno
));
6512 /* Use lbasename to ensure module files are reproducible regardless
6513 of the build path (see the reproducible builds project). */
6514 gzprintf (module_fp
, "GFORTRAN module version '%s' created from %s\n",
6515 MOD_VERSION
, lbasename (gfc_source_file
));
6517 /* Write the module itself. */
6524 free_pi_tree (pi_root
);
6529 if (gzclose (module_fp
))
6530 gfc_fatal_error ("Error writing module file %qs for writing: %s",
6531 filename_tmp
, xstrerror (errno
));
6533 /* Read the CRC32 from the gzip trailers of the module files and
6535 if (!read_crc32_from_module_file (filename_tmp
, &crc
)
6536 || !read_crc32_from_module_file (filename
, &crc_old
)
6539 /* Module file have changed, replace the old one. */
6540 if (remove (filename
) && errno
!= ENOENT
)
6541 gfc_fatal_error ("Cannot delete module file %qs: %s", filename
,
6543 if (rename (filename_tmp
, filename
))
6544 gfc_fatal_error ("Cannot rename module file %qs to %qs: %s",
6545 filename_tmp
, filename
, xstrerror (errno
));
6549 if (remove (filename_tmp
))
6550 gfc_fatal_error ("Cannot delete temporary module file %qs: %s",
6551 filename_tmp
, xstrerror (errno
));
6556 /* Suppress the output of a .smod file by module, if no module
6557 procedures have been seen. */
6558 static bool no_module_procedures
;
6561 check_for_module_procedures (gfc_symbol
*sym
)
6563 if (sym
&& sym
->attr
.module_procedure
)
6564 no_module_procedures
= false;
6569 gfc_dump_module (const char *name
, int dump_flag
)
6571 if (gfc_state_stack
->state
== COMP_SUBMODULE
)
6576 no_module_procedures
= true;
6577 gfc_traverse_ns (gfc_current_ns
, check_for_module_procedures
);
6579 dump_module (name
, dump_flag
);
6581 if (no_module_procedures
|| dump_smod
)
6584 /* Write a submodule file from a module. The 'dump_smod' flag switches
6585 off the check for PRIVATE entities. */
6587 submodule_name
= module_name
;
6588 dump_module (name
, dump_flag
);
6593 create_intrinsic_function (const char *name
, int id
,
6594 const char *modname
, intmod_id module
,
6595 bool subroutine
, gfc_symbol
*result_type
)
6597 gfc_intrinsic_sym
*isym
;
6598 gfc_symtree
*tmp_symtree
;
6601 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6604 if (tmp_symtree
->n
.sym
&& tmp_symtree
->n
.sym
->module
6605 && strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6607 gfc_error ("Symbol %qs at %C already declared", name
);
6611 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6612 sym
= tmp_symtree
->n
.sym
;
6616 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
6617 isym
= gfc_intrinsic_subroutine_by_id (isym_id
);
6618 sym
->attr
.subroutine
= 1;
6622 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
6623 isym
= gfc_intrinsic_function_by_id (isym_id
);
6625 sym
->attr
.function
= 1;
6628 sym
->ts
.type
= BT_DERIVED
;
6629 sym
->ts
.u
.derived
= result_type
;
6630 sym
->ts
.is_c_interop
= 1;
6631 isym
->ts
.f90_type
= BT_VOID
;
6632 isym
->ts
.type
= BT_DERIVED
;
6633 isym
->ts
.f90_type
= BT_VOID
;
6634 isym
->ts
.u
.derived
= result_type
;
6635 isym
->ts
.is_c_interop
= 1;
6640 sym
->attr
.flavor
= FL_PROCEDURE
;
6641 sym
->attr
.intrinsic
= 1;
6643 sym
->module
= gfc_get_string ("%s", modname
);
6644 sym
->attr
.use_assoc
= 1;
6645 sym
->from_intmod
= module
;
6646 sym
->intmod_sym_id
= id
;
6650 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
6651 the current namespace for all named constants, pointer types, and
6652 procedures in the module unless the only clause was used or a rename
6653 list was provided. */
6656 import_iso_c_binding_module (void)
6658 gfc_symbol
*mod_sym
= NULL
, *return_type
;
6659 gfc_symtree
*mod_symtree
= NULL
, *tmp_symtree
;
6660 gfc_symtree
*c_ptr
= NULL
, *c_funptr
= NULL
;
6661 const char *iso_c_module_name
= "__iso_c_binding";
6664 bool want_c_ptr
= false, want_c_funptr
= false;
6666 /* Look only in the current namespace. */
6667 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, iso_c_module_name
);
6669 if (mod_symtree
== NULL
)
6671 /* symtree doesn't already exist in current namespace. */
6672 gfc_get_sym_tree (iso_c_module_name
, gfc_current_ns
, &mod_symtree
,
6675 if (mod_symtree
!= NULL
)
6676 mod_sym
= mod_symtree
->n
.sym
;
6678 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
6679 "create symbol for %s", iso_c_module_name
);
6681 mod_sym
->attr
.flavor
= FL_MODULE
;
6682 mod_sym
->attr
.intrinsic
= 1;
6683 mod_sym
->module
= gfc_get_string ("%s", iso_c_module_name
);
6684 mod_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
6687 /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
6688 check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
6690 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6692 if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_PTR
].name
,
6695 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_LOC
].name
,
6698 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_FUNPTR
].name
,
6700 want_c_funptr
= true;
6701 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNLOC
].name
,
6703 want_c_funptr
= true;
6704 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_PTR
].name
,
6707 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
6708 (iso_c_binding_symbol
)
6710 u
->local_name
[0] ? u
->local_name
6714 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNPTR
].name
,
6718 = generate_isocbinding_symbol (iso_c_module_name
,
6719 (iso_c_binding_symbol
)
6721 u
->local_name
[0] ? u
->local_name
6727 if ((want_c_ptr
|| !only_flag
) && !c_ptr
)
6728 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
6729 (iso_c_binding_symbol
)
6731 NULL
, NULL
, only_flag
);
6732 if ((want_c_funptr
|| !only_flag
) && !c_funptr
)
6733 c_funptr
= generate_isocbinding_symbol (iso_c_module_name
,
6734 (iso_c_binding_symbol
)
6736 NULL
, NULL
, only_flag
);
6738 /* Generate the symbols for the named constants representing
6739 the kinds for intrinsic data types. */
6740 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
6743 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6744 if (strcmp (c_interop_kinds_table
[i
].name
, u
->use_name
) == 0)
6753 #define NAMED_FUNCTION(a,b,c,d) \
6755 not_in_std = (gfc_option.allow_std & d) == 0; \
6758 #define NAMED_SUBROUTINE(a,b,c,d) \
6760 not_in_std = (gfc_option.allow_std & d) == 0; \
6763 #define NAMED_INTCST(a,b,c,d) \
6765 not_in_std = (gfc_option.allow_std & d) == 0; \
6768 #define NAMED_REALCST(a,b,c,d) \
6770 not_in_std = (gfc_option.allow_std & d) == 0; \
6773 #define NAMED_CMPXCST(a,b,c,d) \
6775 not_in_std = (gfc_option.allow_std & d) == 0; \
6778 #include "iso-c-binding.def"
6786 gfc_error ("The symbol %qs, referenced at %L, is not "
6787 "in the selected standard", name
, &u
->where
);
6793 #define NAMED_FUNCTION(a,b,c,d) \
6795 if (a == ISOCBINDING_LOC) \
6796 return_type = c_ptr->n.sym; \
6797 else if (a == ISOCBINDING_FUNLOC) \
6798 return_type = c_funptr->n.sym; \
6800 return_type = NULL; \
6801 create_intrinsic_function (u->local_name[0] \
6802 ? u->local_name : u->use_name, \
6803 a, iso_c_module_name, \
6804 INTMOD_ISO_C_BINDING, false, \
6807 #define NAMED_SUBROUTINE(a,b,c,d) \
6809 create_intrinsic_function (u->local_name[0] ? u->local_name \
6811 a, iso_c_module_name, \
6812 INTMOD_ISO_C_BINDING, true, NULL); \
6814 #include "iso-c-binding.def"
6816 case ISOCBINDING_PTR
:
6817 case ISOCBINDING_FUNPTR
:
6818 /* Already handled above. */
6821 if (i
== ISOCBINDING_NULL_PTR
)
6822 tmp_symtree
= c_ptr
;
6823 else if (i
== ISOCBINDING_NULL_FUNPTR
)
6824 tmp_symtree
= c_funptr
;
6827 generate_isocbinding_symbol (iso_c_module_name
,
6828 (iso_c_binding_symbol
) i
,
6830 ? u
->local_name
: u
->use_name
,
6831 tmp_symtree
, false);
6835 if (!found
&& !only_flag
)
6837 /* Skip, if the symbol is not in the enabled standard. */
6840 #define NAMED_FUNCTION(a,b,c,d) \
6842 if ((gfc_option.allow_std & d) == 0) \
6845 #define NAMED_SUBROUTINE(a,b,c,d) \
6847 if ((gfc_option.allow_std & d) == 0) \
6850 #define NAMED_INTCST(a,b,c,d) \
6852 if ((gfc_option.allow_std & d) == 0) \
6855 #define NAMED_REALCST(a,b,c,d) \
6857 if ((gfc_option.allow_std & d) == 0) \
6860 #define NAMED_CMPXCST(a,b,c,d) \
6862 if ((gfc_option.allow_std & d) == 0) \
6865 #include "iso-c-binding.def"
6867 ; /* Not GFC_STD_* versioned. */
6872 #define NAMED_FUNCTION(a,b,c,d) \
6874 if (a == ISOCBINDING_LOC) \
6875 return_type = c_ptr->n.sym; \
6876 else if (a == ISOCBINDING_FUNLOC) \
6877 return_type = c_funptr->n.sym; \
6879 return_type = NULL; \
6880 create_intrinsic_function (b, a, iso_c_module_name, \
6881 INTMOD_ISO_C_BINDING, false, \
6884 #define NAMED_SUBROUTINE(a,b,c,d) \
6886 create_intrinsic_function (b, a, iso_c_module_name, \
6887 INTMOD_ISO_C_BINDING, true, NULL); \
6889 #include "iso-c-binding.def"
6891 case ISOCBINDING_PTR
:
6892 case ISOCBINDING_FUNPTR
:
6893 /* Already handled above. */
6896 if (i
== ISOCBINDING_NULL_PTR
)
6897 tmp_symtree
= c_ptr
;
6898 else if (i
== ISOCBINDING_NULL_FUNPTR
)
6899 tmp_symtree
= c_funptr
;
6902 generate_isocbinding_symbol (iso_c_module_name
,
6903 (iso_c_binding_symbol
) i
, NULL
,
6904 tmp_symtree
, false);
6909 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6914 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6915 "module ISO_C_BINDING", u
->use_name
, &u
->where
);
6920 /* Add an integer named constant from a given module. */
6923 create_int_parameter (const char *name
, int value
, const char *modname
,
6924 intmod_id module
, int id
)
6926 gfc_symtree
*tmp_symtree
;
6929 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6930 if (tmp_symtree
!= NULL
)
6932 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6935 gfc_error ("Symbol %qs already declared", name
);
6938 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6939 sym
= tmp_symtree
->n
.sym
;
6941 sym
->module
= gfc_get_string ("%s", modname
);
6942 sym
->attr
.flavor
= FL_PARAMETER
;
6943 sym
->ts
.type
= BT_INTEGER
;
6944 sym
->ts
.kind
= gfc_default_integer_kind
;
6945 sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, value
);
6946 sym
->attr
.use_assoc
= 1;
6947 sym
->from_intmod
= module
;
6948 sym
->intmod_sym_id
= id
;
6952 /* Value is already contained by the array constructor, but not
6956 create_int_parameter_array (const char *name
, int size
, gfc_expr
*value
,
6957 const char *modname
, intmod_id module
, int id
)
6959 gfc_symtree
*tmp_symtree
;
6962 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6963 if (tmp_symtree
!= NULL
)
6965 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6968 gfc_error ("Symbol %qs already declared", name
);
6971 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6972 sym
= tmp_symtree
->n
.sym
;
6974 sym
->module
= gfc_get_string ("%s", modname
);
6975 sym
->attr
.flavor
= FL_PARAMETER
;
6976 sym
->ts
.type
= BT_INTEGER
;
6977 sym
->ts
.kind
= gfc_default_integer_kind
;
6978 sym
->attr
.use_assoc
= 1;
6979 sym
->from_intmod
= module
;
6980 sym
->intmod_sym_id
= id
;
6981 sym
->attr
.dimension
= 1;
6982 sym
->as
= gfc_get_array_spec ();
6984 sym
->as
->type
= AS_EXPLICIT
;
6985 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
6986 sym
->as
->upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, size
);
6989 sym
->value
->shape
= gfc_get_shape (1);
6990 mpz_init_set_ui (sym
->value
->shape
[0], size
);
6994 /* Add an derived type for a given module. */
6997 create_derived_type (const char *name
, const char *modname
,
6998 intmod_id module
, int id
)
7000 gfc_symtree
*tmp_symtree
;
7001 gfc_symbol
*sym
, *dt_sym
;
7002 gfc_interface
*intr
, *head
;
7004 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
7005 if (tmp_symtree
!= NULL
)
7007 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
7010 gfc_error ("Symbol %qs already declared", name
);
7013 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
7014 sym
= tmp_symtree
->n
.sym
;
7015 sym
->module
= gfc_get_string ("%s", modname
);
7016 sym
->from_intmod
= module
;
7017 sym
->intmod_sym_id
= id
;
7018 sym
->attr
.flavor
= FL_PROCEDURE
;
7019 sym
->attr
.function
= 1;
7020 sym
->attr
.generic
= 1;
7022 gfc_get_sym_tree (gfc_dt_upper_string (sym
->name
),
7023 gfc_current_ns
, &tmp_symtree
, false);
7024 dt_sym
= tmp_symtree
->n
.sym
;
7025 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
7026 dt_sym
->attr
.flavor
= FL_DERIVED
;
7027 dt_sym
->attr
.private_comp
= 1;
7028 dt_sym
->attr
.zero_comp
= 1;
7029 dt_sym
->attr
.use_assoc
= 1;
7030 dt_sym
->module
= gfc_get_string ("%s", modname
);
7031 dt_sym
->from_intmod
= module
;
7032 dt_sym
->intmod_sym_id
= id
;
7034 head
= sym
->generic
;
7035 intr
= gfc_get_interface ();
7037 intr
->where
= gfc_current_locus
;
7039 sym
->generic
= intr
;
7040 sym
->attr
.if_source
= IFSRC_DECL
;
7044 /* Read the contents of the module file into a temporary buffer. */
7047 read_module_to_tmpbuf ()
7049 /* We don't know the uncompressed size, so enlarge the buffer as
7055 module_content
= XNEWVEC (char, cursz
);
7059 int nread
= gzread (module_fp
, module_content
+ len
, rsize
);
7064 module_content
= XRESIZEVEC (char, module_content
, cursz
);
7065 rsize
= cursz
- len
;
7068 module_content
= XRESIZEVEC (char, module_content
, len
+ 1);
7069 module_content
[len
] = '\0';
7075 /* USE the ISO_FORTRAN_ENV intrinsic module. */
7078 use_iso_fortran_env_module (void)
7080 static char mod
[] = "iso_fortran_env";
7082 gfc_symbol
*mod_sym
;
7083 gfc_symtree
*mod_symtree
;
7087 intmod_sym symbol
[] = {
7088 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
7089 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
7090 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
7091 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
7092 #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
7093 #include "iso-fortran-env.def"
7094 { ISOFORTRANENV_INVALID
, NULL
, -1234, 0 } };
7097 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
7098 #include "iso-fortran-env.def"
7100 /* Generate the symbol for the module itself. */
7101 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, mod
);
7102 if (mod_symtree
== NULL
)
7104 gfc_get_sym_tree (mod
, gfc_current_ns
, &mod_symtree
, false);
7105 gcc_assert (mod_symtree
);
7106 mod_sym
= mod_symtree
->n
.sym
;
7108 mod_sym
->attr
.flavor
= FL_MODULE
;
7109 mod_sym
->attr
.intrinsic
= 1;
7110 mod_sym
->module
= gfc_get_string ("%s", mod
);
7111 mod_sym
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
7114 if (!mod_symtree
->n
.sym
->attr
.intrinsic
)
7115 gfc_error ("Use of intrinsic module %qs at %C conflicts with "
7116 "non-intrinsic module name used previously", mod
);
7118 /* Generate the symbols for the module integer named constants. */
7120 for (i
= 0; symbol
[i
].name
; i
++)
7123 for (u
= gfc_rename_list
; u
; u
= u
->next
)
7125 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
7130 if (!gfc_notify_std (symbol
[i
].standard
, "The symbol %qs, "
7131 "referenced at %L, is not in the selected "
7132 "standard", symbol
[i
].name
, &u
->where
))
7135 if ((flag_default_integer
|| flag_default_real_8
)
7136 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
7137 gfc_warning_now (0, "Use of the NUMERIC_STORAGE_SIZE named "
7138 "constant from intrinsic module "
7139 "ISO_FORTRAN_ENV at %L is incompatible with "
7140 "option %qs", &u
->where
,
7141 flag_default_integer
7142 ? "-fdefault-integer-8"
7143 : "-fdefault-real-8");
7144 switch (symbol
[i
].id
)
7146 #define NAMED_INTCST(a,b,c,d) \
7148 #include "iso-fortran-env.def"
7149 create_int_parameter (u
->local_name
[0] ? u
->local_name
7151 symbol
[i
].value
, mod
,
7152 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
7155 #define NAMED_KINDARRAY(a,b,KINDS,d) \
7157 expr = gfc_get_array_expr (BT_INTEGER, \
7158 gfc_default_integer_kind,\
7160 for (j = 0; KINDS[j].kind != 0; j++) \
7161 gfc_constructor_append_expr (&expr->value.constructor, \
7162 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
7163 KINDS[j].kind), NULL); \
7164 create_int_parameter_array (u->local_name[0] ? u->local_name \
7167 INTMOD_ISO_FORTRAN_ENV, \
7170 #include "iso-fortran-env.def"
7172 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
7174 #include "iso-fortran-env.def"
7175 create_derived_type (u
->local_name
[0] ? u
->local_name
7177 mod
, INTMOD_ISO_FORTRAN_ENV
,
7181 #define NAMED_FUNCTION(a,b,c,d) \
7183 #include "iso-fortran-env.def"
7184 create_intrinsic_function (u
->local_name
[0] ? u
->local_name
7187 INTMOD_ISO_FORTRAN_ENV
, false,
7197 if (!found
&& !only_flag
)
7199 if ((gfc_option
.allow_std
& symbol
[i
].standard
) == 0)
7202 if ((flag_default_integer
|| flag_default_real_8
)
7203 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
7205 "Use of the NUMERIC_STORAGE_SIZE named constant "
7206 "from intrinsic module ISO_FORTRAN_ENV at %C is "
7207 "incompatible with option %s",
7208 flag_default_integer
7209 ? "-fdefault-integer-8" : "-fdefault-real-8");
7211 switch (symbol
[i
].id
)
7213 #define NAMED_INTCST(a,b,c,d) \
7215 #include "iso-fortran-env.def"
7216 create_int_parameter (symbol
[i
].name
, symbol
[i
].value
, mod
,
7217 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
7220 #define NAMED_KINDARRAY(a,b,KINDS,d) \
7222 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
7224 for (j = 0; KINDS[j].kind != 0; j++) \
7225 gfc_constructor_append_expr (&expr->value.constructor, \
7226 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
7227 KINDS[j].kind), NULL); \
7228 create_int_parameter_array (symbol[i].name, j, expr, mod, \
7229 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
7231 #include "iso-fortran-env.def"
7233 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
7235 #include "iso-fortran-env.def"
7236 create_derived_type (symbol
[i
].name
, mod
, INTMOD_ISO_FORTRAN_ENV
,
7240 #define NAMED_FUNCTION(a,b,c,d) \
7242 #include "iso-fortran-env.def"
7243 create_intrinsic_function (symbol
[i
].name
, symbol
[i
].id
, mod
,
7244 INTMOD_ISO_FORTRAN_ENV
, false,
7254 for (u
= gfc_rename_list
; u
; u
= u
->next
)
7259 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
7260 "module ISO_FORTRAN_ENV", u
->use_name
, &u
->where
);
7265 /* Process a USE directive. */
7268 gfc_use_module (gfc_use_list
*module
)
7273 gfc_symtree
*mod_symtree
;
7274 gfc_use_list
*use_stmt
;
7275 locus old_locus
= gfc_current_locus
;
7277 gfc_current_locus
= module
->where
;
7278 module_name
= module
->module_name
;
7279 gfc_rename_list
= module
->rename
;
7280 only_flag
= module
->only_flag
;
7281 current_intmod
= INTMOD_NONE
;
7284 gfc_warning_now (OPT_Wuse_without_only
,
7285 "USE statement at %C has no ONLY qualifier");
7287 if (gfc_state_stack
->state
== COMP_MODULE
7288 || module
->submodule_name
== NULL
)
7290 filename
= XALLOCAVEC (char, strlen (module_name
)
7291 + strlen (MODULE_EXTENSION
) + 1);
7292 strcpy (filename
, module_name
);
7293 strcat (filename
, MODULE_EXTENSION
);
7297 filename
= XALLOCAVEC (char, strlen (module
->submodule_name
)
7298 + strlen (SUBMODULE_EXTENSION
) + 1);
7299 strcpy (filename
, module
->submodule_name
);
7300 strcat (filename
, SUBMODULE_EXTENSION
);
7303 /* First, try to find an non-intrinsic module, unless the USE statement
7304 specified that the module is intrinsic. */
7306 if (!module
->intrinsic
)
7307 module_fp
= gzopen_included_file (filename
, true, true);
7309 /* Then, see if it's an intrinsic one, unless the USE statement
7310 specified that the module is non-intrinsic. */
7311 if (module_fp
== NULL
&& !module
->non_intrinsic
)
7313 if (strcmp (module_name
, "iso_fortran_env") == 0
7314 && gfc_notify_std (GFC_STD_F2003
, "ISO_FORTRAN_ENV "
7315 "intrinsic module at %C"))
7317 use_iso_fortran_env_module ();
7318 free_rename (module
->rename
);
7319 module
->rename
= NULL
;
7320 gfc_current_locus
= old_locus
;
7321 module
->intrinsic
= true;
7325 if (strcmp (module_name
, "iso_c_binding") == 0
7326 && gfc_notify_std (GFC_STD_F2003
, "ISO_C_BINDING module at %C"))
7328 import_iso_c_binding_module();
7329 free_rename (module
->rename
);
7330 module
->rename
= NULL
;
7331 gfc_current_locus
= old_locus
;
7332 module
->intrinsic
= true;
7336 module_fp
= gzopen_intrinsic_module (filename
);
7338 if (module_fp
== NULL
&& module
->intrinsic
)
7339 gfc_fatal_error ("Cannot find an intrinsic module named %qs at %C",
7342 /* Check for the IEEE modules, so we can mark their symbols
7343 accordingly when we read them. */
7344 if (strcmp (module_name
, "ieee_features") == 0
7345 && gfc_notify_std (GFC_STD_F2003
, "IEEE_FEATURES module at %C"))
7347 current_intmod
= INTMOD_IEEE_FEATURES
;
7349 else if (strcmp (module_name
, "ieee_exceptions") == 0
7350 && gfc_notify_std (GFC_STD_F2003
,
7351 "IEEE_EXCEPTIONS module at %C"))
7353 current_intmod
= INTMOD_IEEE_EXCEPTIONS
;
7355 else if (strcmp (module_name
, "ieee_arithmetic") == 0
7356 && gfc_notify_std (GFC_STD_F2003
,
7357 "IEEE_ARITHMETIC module at %C"))
7359 current_intmod
= INTMOD_IEEE_ARITHMETIC
;
7363 if (module_fp
== NULL
)
7365 if (gfc_state_stack
->state
!= COMP_SUBMODULE
7366 && module
->submodule_name
== NULL
)
7367 gfc_fatal_error ("Cannot open module file %qs for reading at %C: %s",
7368 filename
, xstrerror (errno
));
7370 gfc_fatal_error ("Module file %qs has not been generated, either "
7371 "because the module does not contain a MODULE "
7372 "PROCEDURE or there is an error in the module.",
7376 /* Check that we haven't already USEd an intrinsic module with the
7379 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, module_name
);
7380 if (mod_symtree
&& mod_symtree
->n
.sym
->attr
.intrinsic
)
7381 gfc_error ("Use of non-intrinsic module %qs at %C conflicts with "
7382 "intrinsic module name used previously", module_name
);
7389 read_module_to_tmpbuf ();
7390 gzclose (module_fp
);
7392 /* Skip the first line of the module, after checking that this is
7393 a gfortran module file. */
7399 bad_module ("Unexpected end of module");
7402 if ((start
== 1 && strcmp (atom_name
, "GFORTRAN") != 0)
7403 || (start
== 2 && strcmp (atom_name
, " module") != 0))
7404 gfc_fatal_error ("File %qs opened at %C is not a GNU Fortran"
7405 " module file", module_fullpath
);
7408 if (strcmp (atom_name
, " version") != 0
7409 || module_char () != ' '
7410 || parse_atom () != ATOM_STRING
7411 || strcmp (atom_string
, MOD_VERSION
))
7412 gfc_fatal_error ("Cannot read module file %qs opened at %C,"
7413 " because it was created by a different"
7414 " version of GNU Fortran", module_fullpath
);
7423 /* Make sure we're not reading the same module that we may be building. */
7424 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
7425 if ((p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
)
7426 && strcmp (p
->sym
->name
, module_name
) == 0)
7428 if (p
->state
== COMP_SUBMODULE
)
7429 gfc_fatal_error ("Cannot USE a submodule that is currently built");
7431 gfc_fatal_error ("Cannot USE a module that is currently built");
7435 init_true_name_tree ();
7439 free_true_name (true_name_root
);
7440 true_name_root
= NULL
;
7442 free_pi_tree (pi_root
);
7445 XDELETEVEC (module_content
);
7446 module_content
= NULL
;
7448 use_stmt
= gfc_get_use_list ();
7449 *use_stmt
= *module
;
7450 use_stmt
->next
= gfc_current_ns
->use_stmts
;
7451 gfc_current_ns
->use_stmts
= use_stmt
;
7453 gfc_current_locus
= old_locus
;
7457 /* Remove duplicated intrinsic operators from the rename list. */
7460 rename_list_remove_duplicate (gfc_use_rename
*list
)
7462 gfc_use_rename
*seek
, *last
;
7464 for (; list
; list
= list
->next
)
7465 if (list
->op
!= INTRINSIC_USER
&& list
->op
!= INTRINSIC_NONE
)
7468 for (seek
= list
->next
; seek
; seek
= last
->next
)
7470 if (list
->op
== seek
->op
)
7472 last
->next
= seek
->next
;
7482 /* Process all USE directives. */
7485 gfc_use_modules (void)
7487 gfc_use_list
*next
, *seek
, *last
;
7489 for (next
= module_list
; next
; next
= next
->next
)
7491 bool non_intrinsic
= next
->non_intrinsic
;
7492 bool intrinsic
= next
->intrinsic
;
7493 bool neither
= !non_intrinsic
&& !intrinsic
;
7495 for (seek
= next
->next
; seek
; seek
= seek
->next
)
7497 if (next
->module_name
!= seek
->module_name
)
7500 if (seek
->non_intrinsic
)
7501 non_intrinsic
= true;
7502 else if (seek
->intrinsic
)
7508 if (intrinsic
&& neither
&& !non_intrinsic
)
7513 filename
= XALLOCAVEC (char,
7514 strlen (next
->module_name
)
7515 + strlen (MODULE_EXTENSION
) + 1);
7516 strcpy (filename
, next
->module_name
);
7517 strcat (filename
, MODULE_EXTENSION
);
7518 fp
= gfc_open_included_file (filename
, true, true);
7521 non_intrinsic
= true;
7527 for (seek
= next
->next
; seek
; seek
= last
->next
)
7529 if (next
->module_name
!= seek
->module_name
)
7535 if ((!next
->intrinsic
&& !seek
->intrinsic
)
7536 || (next
->intrinsic
&& seek
->intrinsic
)
7539 if (!seek
->only_flag
)
7540 next
->only_flag
= false;
7543 gfc_use_rename
*r
= seek
->rename
;
7546 r
->next
= next
->rename
;
7547 next
->rename
= seek
->rename
;
7549 last
->next
= seek
->next
;
7557 for (; module_list
; module_list
= next
)
7559 next
= module_list
->next
;
7560 rename_list_remove_duplicate (module_list
->rename
);
7561 gfc_use_module (module_list
);
7564 gfc_rename_list
= NULL
;
7569 gfc_free_use_stmts (gfc_use_list
*use_stmts
)
7572 for (; use_stmts
; use_stmts
= next
)
7574 gfc_use_rename
*next_rename
;
7576 for (; use_stmts
->rename
; use_stmts
->rename
= next_rename
)
7578 next_rename
= use_stmts
->rename
->next
;
7579 free (use_stmts
->rename
);
7581 next
= use_stmts
->next
;
7588 gfc_module_init_2 (void)
7590 last_atom
= ATOM_LPAREN
;
7591 gfc_rename_list
= NULL
;
7597 gfc_module_done_2 (void)
7599 free_rename (gfc_rename_list
);
7600 gfc_rename_list
= NULL
;