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_RELAXED
, AB_OMP_DEVICE_TYPE_NOHOST
,
2097 AB_OMP_DEVICE_TYPE_HOST
, AB_OMP_DEVICE_TYPE_ANY
2100 static const mstring attr_bits
[] =
2102 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
2103 minit ("ARTIFICIAL", AB_ARTIFICIAL
),
2104 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS
),
2105 minit ("DIMENSION", AB_DIMENSION
),
2106 minit ("CODIMENSION", AB_CODIMENSION
),
2107 minit ("CONTIGUOUS", AB_CONTIGUOUS
),
2108 minit ("EXTERNAL", AB_EXTERNAL
),
2109 minit ("INTRINSIC", AB_INTRINSIC
),
2110 minit ("OPTIONAL", AB_OPTIONAL
),
2111 minit ("POINTER", AB_POINTER
),
2112 minit ("VOLATILE", AB_VOLATILE
),
2113 minit ("TARGET", AB_TARGET
),
2114 minit ("THREADPRIVATE", AB_THREADPRIVATE
),
2115 minit ("DUMMY", AB_DUMMY
),
2116 minit ("RESULT", AB_RESULT
),
2117 minit ("DATA", AB_DATA
),
2118 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
2119 minit ("IN_COMMON", AB_IN_COMMON
),
2120 minit ("FUNCTION", AB_FUNCTION
),
2121 minit ("SUBROUTINE", AB_SUBROUTINE
),
2122 minit ("SEQUENCE", AB_SEQUENCE
),
2123 minit ("ELEMENTAL", AB_ELEMENTAL
),
2124 minit ("PURE", AB_PURE
),
2125 minit ("RECURSIVE", AB_RECURSIVE
),
2126 minit ("GENERIC", AB_GENERIC
),
2127 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
2128 minit ("CRAY_POINTER", AB_CRAY_POINTER
),
2129 minit ("CRAY_POINTEE", AB_CRAY_POINTEE
),
2130 minit ("IS_BIND_C", AB_IS_BIND_C
),
2131 minit ("IS_C_INTEROP", AB_IS_C_INTEROP
),
2132 minit ("IS_ISO_C", AB_IS_ISO_C
),
2133 minit ("VALUE", AB_VALUE
),
2134 minit ("ALLOC_COMP", AB_ALLOC_COMP
),
2135 minit ("COARRAY_COMP", AB_COARRAY_COMP
),
2136 minit ("LOCK_COMP", AB_LOCK_COMP
),
2137 minit ("EVENT_COMP", AB_EVENT_COMP
),
2138 minit ("POINTER_COMP", AB_POINTER_COMP
),
2139 minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP
),
2140 minit ("PRIVATE_COMP", AB_PRIVATE_COMP
),
2141 minit ("ZERO_COMP", AB_ZERO_COMP
),
2142 minit ("PROTECTED", AB_PROTECTED
),
2143 minit ("ABSTRACT", AB_ABSTRACT
),
2144 minit ("IS_CLASS", AB_IS_CLASS
),
2145 minit ("PROCEDURE", AB_PROCEDURE
),
2146 minit ("PROC_POINTER", AB_PROC_POINTER
),
2147 minit ("VTYPE", AB_VTYPE
),
2148 minit ("VTAB", AB_VTAB
),
2149 minit ("CLASS_POINTER", AB_CLASS_POINTER
),
2150 minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE
),
2151 minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY
),
2152 minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET
),
2153 minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY
),
2154 minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE
),
2155 minit ("OACC_DECLARE_CREATE", AB_OACC_DECLARE_CREATE
),
2156 minit ("OACC_DECLARE_COPYIN", AB_OACC_DECLARE_COPYIN
),
2157 minit ("OACC_DECLARE_DEVICEPTR", AB_OACC_DECLARE_DEVICEPTR
),
2158 minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT
),
2159 minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK
),
2160 minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK
),
2161 minit ("PDT_KIND", AB_PDT_KIND
),
2162 minit ("PDT_LEN", AB_PDT_LEN
),
2163 minit ("PDT_TYPE", AB_PDT_TYPE
),
2164 minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE
),
2165 minit ("PDT_ARRAY", AB_PDT_ARRAY
),
2166 minit ("PDT_STRING", AB_PDT_STRING
),
2167 minit ("OACC_ROUTINE_LOP_GANG", AB_OACC_ROUTINE_LOP_GANG
),
2168 minit ("OACC_ROUTINE_LOP_WORKER", AB_OACC_ROUTINE_LOP_WORKER
),
2169 minit ("OACC_ROUTINE_LOP_VECTOR", AB_OACC_ROUTINE_LOP_VECTOR
),
2170 minit ("OACC_ROUTINE_LOP_SEQ", AB_OACC_ROUTINE_LOP_SEQ
),
2171 minit ("OACC_ROUTINE_NOHOST", AB_OACC_ROUTINE_NOHOST
),
2172 minit ("OMP_REQ_REVERSE_OFFLOAD", AB_OMP_REQ_REVERSE_OFFLOAD
),
2173 minit ("OMP_REQ_UNIFIED_ADDRESS", AB_OMP_REQ_UNIFIED_ADDRESS
),
2174 minit ("OMP_REQ_UNIFIED_SHARED_MEMORY", AB_OMP_REQ_UNIFIED_SHARED_MEMORY
),
2175 minit ("OMP_REQ_DYNAMIC_ALLOCATORS", AB_OMP_REQ_DYNAMIC_ALLOCATORS
),
2176 minit ("OMP_REQ_MEM_ORDER_SEQ_CST", AB_OMP_REQ_MEM_ORDER_SEQ_CST
),
2177 minit ("OMP_REQ_MEM_ORDER_ACQ_REL", AB_OMP_REQ_MEM_ORDER_ACQ_REL
),
2178 minit ("OMP_REQ_MEM_ORDER_RELAXED", AB_OMP_REQ_MEM_ORDER_RELAXED
),
2179 minit ("OMP_DEVICE_TYPE_HOST", AB_OMP_DEVICE_TYPE_HOST
),
2180 minit ("OMP_DEVICE_TYPE_NOHOST", AB_OMP_DEVICE_TYPE_NOHOST
),
2181 minit ("OMP_DEVICE_TYPE_ANYHOST", AB_OMP_DEVICE_TYPE_ANY
),
2185 /* For binding attributes. */
2186 static const mstring binding_passing
[] =
2189 minit ("NOPASS", 1),
2192 static const mstring binding_overriding
[] =
2194 minit ("OVERRIDABLE", 0),
2195 minit ("NON_OVERRIDABLE", 1),
2196 minit ("DEFERRED", 2),
2199 static const mstring binding_generic
[] =
2201 minit ("SPECIFIC", 0),
2202 minit ("GENERIC", 1),
2205 static const mstring binding_ppc
[] =
2207 minit ("NO_PPC", 0),
2212 /* Specialization of mio_name. */
2213 DECL_MIO_NAME (ab_attribute
)
2214 DECL_MIO_NAME (ar_type
)
2215 DECL_MIO_NAME (array_type
)
2217 DECL_MIO_NAME (expr_t
)
2218 DECL_MIO_NAME (gfc_access
)
2219 DECL_MIO_NAME (gfc_intrinsic_op
)
2220 DECL_MIO_NAME (ifsrc
)
2221 DECL_MIO_NAME (save_state
)
2222 DECL_MIO_NAME (procedure_type
)
2223 DECL_MIO_NAME (ref_type
)
2224 DECL_MIO_NAME (sym_flavor
)
2225 DECL_MIO_NAME (sym_intent
)
2226 DECL_MIO_NAME (inquiry_type
)
2227 #undef DECL_MIO_NAME
2229 /* Verify OACC_ROUTINE_LOP_NONE. */
2232 verify_OACC_ROUTINE_LOP_NONE (enum oacc_routine_lop lop
)
2234 if (lop
!= OACC_ROUTINE_LOP_NONE
)
2235 bad_module ("Unsupported: multiple OpenACC 'routine' levels of parallelism");
2238 /* Symbol attributes are stored in list with the first three elements
2239 being the enumerated fields, while the remaining elements (if any)
2240 indicate the individual attribute bits. The access field is not
2241 saved-- it controls what symbols are exported when a module is
2245 mio_symbol_attribute (symbol_attribute
*attr
)
2248 unsigned ext_attr
,extension_level
;
2252 attr
->flavor
= MIO_NAME (sym_flavor
) (attr
->flavor
, flavors
);
2253 attr
->intent
= MIO_NAME (sym_intent
) (attr
->intent
, intents
);
2254 attr
->proc
= MIO_NAME (procedure_type
) (attr
->proc
, procedures
);
2255 attr
->if_source
= MIO_NAME (ifsrc
) (attr
->if_source
, ifsrc_types
);
2256 attr
->save
= MIO_NAME (save_state
) (attr
->save
, save_status
);
2258 ext_attr
= attr
->ext_attr
;
2259 mio_integer ((int *) &ext_attr
);
2260 attr
->ext_attr
= ext_attr
;
2262 extension_level
= attr
->extension
;
2263 mio_integer ((int *) &extension_level
);
2264 attr
->extension
= extension_level
;
2266 if (iomode
== IO_OUTPUT
)
2268 if (attr
->allocatable
)
2269 MIO_NAME (ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
2270 if (attr
->artificial
)
2271 MIO_NAME (ab_attribute
) (AB_ARTIFICIAL
, attr_bits
);
2272 if (attr
->asynchronous
)
2273 MIO_NAME (ab_attribute
) (AB_ASYNCHRONOUS
, attr_bits
);
2274 if (attr
->dimension
)
2275 MIO_NAME (ab_attribute
) (AB_DIMENSION
, attr_bits
);
2276 if (attr
->codimension
)
2277 MIO_NAME (ab_attribute
) (AB_CODIMENSION
, attr_bits
);
2278 if (attr
->contiguous
)
2279 MIO_NAME (ab_attribute
) (AB_CONTIGUOUS
, attr_bits
);
2281 MIO_NAME (ab_attribute
) (AB_EXTERNAL
, attr_bits
);
2282 if (attr
->intrinsic
)
2283 MIO_NAME (ab_attribute
) (AB_INTRINSIC
, attr_bits
);
2285 MIO_NAME (ab_attribute
) (AB_OPTIONAL
, attr_bits
);
2287 MIO_NAME (ab_attribute
) (AB_POINTER
, attr_bits
);
2288 if (attr
->class_pointer
)
2289 MIO_NAME (ab_attribute
) (AB_CLASS_POINTER
, attr_bits
);
2290 if (attr
->is_protected
)
2291 MIO_NAME (ab_attribute
) (AB_PROTECTED
, attr_bits
);
2293 MIO_NAME (ab_attribute
) (AB_VALUE
, attr_bits
);
2294 if (attr
->volatile_
)
2295 MIO_NAME (ab_attribute
) (AB_VOLATILE
, attr_bits
);
2297 MIO_NAME (ab_attribute
) (AB_TARGET
, attr_bits
);
2298 if (attr
->threadprivate
)
2299 MIO_NAME (ab_attribute
) (AB_THREADPRIVATE
, attr_bits
);
2301 MIO_NAME (ab_attribute
) (AB_DUMMY
, attr_bits
);
2303 MIO_NAME (ab_attribute
) (AB_RESULT
, attr_bits
);
2304 /* We deliberately don't preserve the "entry" flag. */
2307 MIO_NAME (ab_attribute
) (AB_DATA
, attr_bits
);
2308 if (attr
->in_namelist
)
2309 MIO_NAME (ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
2310 if (attr
->in_common
)
2311 MIO_NAME (ab_attribute
) (AB_IN_COMMON
, attr_bits
);
2314 MIO_NAME (ab_attribute
) (AB_FUNCTION
, attr_bits
);
2315 if (attr
->subroutine
)
2316 MIO_NAME (ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
2318 MIO_NAME (ab_attribute
) (AB_GENERIC
, attr_bits
);
2320 MIO_NAME (ab_attribute
) (AB_ABSTRACT
, attr_bits
);
2323 MIO_NAME (ab_attribute
) (AB_SEQUENCE
, attr_bits
);
2324 if (attr
->elemental
)
2325 MIO_NAME (ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
2327 MIO_NAME (ab_attribute
) (AB_PURE
, attr_bits
);
2328 if (attr
->implicit_pure
)
2329 MIO_NAME (ab_attribute
) (AB_IMPLICIT_PURE
, attr_bits
);
2330 if (attr
->unlimited_polymorphic
)
2331 MIO_NAME (ab_attribute
) (AB_UNLIMITED_POLY
, attr_bits
);
2332 if (attr
->recursive
)
2333 MIO_NAME (ab_attribute
) (AB_RECURSIVE
, attr_bits
);
2334 if (attr
->always_explicit
)
2335 MIO_NAME (ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
2336 if (attr
->cray_pointer
)
2337 MIO_NAME (ab_attribute
) (AB_CRAY_POINTER
, attr_bits
);
2338 if (attr
->cray_pointee
)
2339 MIO_NAME (ab_attribute
) (AB_CRAY_POINTEE
, attr_bits
);
2340 if (attr
->is_bind_c
)
2341 MIO_NAME(ab_attribute
) (AB_IS_BIND_C
, attr_bits
);
2342 if (attr
->is_c_interop
)
2343 MIO_NAME(ab_attribute
) (AB_IS_C_INTEROP
, attr_bits
);
2345 MIO_NAME(ab_attribute
) (AB_IS_ISO_C
, attr_bits
);
2346 if (attr
->alloc_comp
)
2347 MIO_NAME (ab_attribute
) (AB_ALLOC_COMP
, attr_bits
);
2348 if (attr
->pointer_comp
)
2349 MIO_NAME (ab_attribute
) (AB_POINTER_COMP
, attr_bits
);
2350 if (attr
->proc_pointer_comp
)
2351 MIO_NAME (ab_attribute
) (AB_PROC_POINTER_COMP
, attr_bits
);
2352 if (attr
->private_comp
)
2353 MIO_NAME (ab_attribute
) (AB_PRIVATE_COMP
, attr_bits
);
2354 if (attr
->coarray_comp
)
2355 MIO_NAME (ab_attribute
) (AB_COARRAY_COMP
, attr_bits
);
2356 if (attr
->lock_comp
)
2357 MIO_NAME (ab_attribute
) (AB_LOCK_COMP
, attr_bits
);
2358 if (attr
->event_comp
)
2359 MIO_NAME (ab_attribute
) (AB_EVENT_COMP
, attr_bits
);
2360 if (attr
->zero_comp
)
2361 MIO_NAME (ab_attribute
) (AB_ZERO_COMP
, attr_bits
);
2363 MIO_NAME (ab_attribute
) (AB_IS_CLASS
, attr_bits
);
2364 if (attr
->procedure
)
2365 MIO_NAME (ab_attribute
) (AB_PROCEDURE
, attr_bits
);
2366 if (attr
->proc_pointer
)
2367 MIO_NAME (ab_attribute
) (AB_PROC_POINTER
, attr_bits
);
2369 MIO_NAME (ab_attribute
) (AB_VTYPE
, attr_bits
);
2371 MIO_NAME (ab_attribute
) (AB_VTAB
, attr_bits
);
2372 if (attr
->omp_declare_target
)
2373 MIO_NAME (ab_attribute
) (AB_OMP_DECLARE_TARGET
, attr_bits
);
2374 if (attr
->array_outer_dependency
)
2375 MIO_NAME (ab_attribute
) (AB_ARRAY_OUTER_DEPENDENCY
, attr_bits
);
2376 if (attr
->module_procedure
)
2377 MIO_NAME (ab_attribute
) (AB_MODULE_PROCEDURE
, attr_bits
);
2378 if (attr
->oacc_declare_create
)
2379 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_CREATE
, attr_bits
);
2380 if (attr
->oacc_declare_copyin
)
2381 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_COPYIN
, attr_bits
);
2382 if (attr
->oacc_declare_deviceptr
)
2383 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_DEVICEPTR
, attr_bits
);
2384 if (attr
->oacc_declare_device_resident
)
2385 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_DEVICE_RESIDENT
, attr_bits
);
2386 if (attr
->oacc_declare_link
)
2387 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_LINK
, attr_bits
);
2388 if (attr
->omp_declare_target_link
)
2389 MIO_NAME (ab_attribute
) (AB_OMP_DECLARE_TARGET_LINK
, attr_bits
);
2391 MIO_NAME (ab_attribute
) (AB_PDT_KIND
, attr_bits
);
2393 MIO_NAME (ab_attribute
) (AB_PDT_LEN
, attr_bits
);
2395 MIO_NAME (ab_attribute
) (AB_PDT_TYPE
, attr_bits
);
2396 if (attr
->pdt_template
)
2397 MIO_NAME (ab_attribute
) (AB_PDT_TEMPLATE
, attr_bits
);
2398 if (attr
->pdt_array
)
2399 MIO_NAME (ab_attribute
) (AB_PDT_ARRAY
, attr_bits
);
2400 if (attr
->pdt_string
)
2401 MIO_NAME (ab_attribute
) (AB_PDT_STRING
, attr_bits
);
2402 switch (attr
->oacc_routine_lop
)
2404 case OACC_ROUTINE_LOP_NONE
:
2405 /* This is the default anyway, and for maintaining compatibility with
2406 the current MOD_VERSION, we're not emitting anything in that
2409 case OACC_ROUTINE_LOP_GANG
:
2410 MIO_NAME (ab_attribute
) (AB_OACC_ROUTINE_LOP_GANG
, attr_bits
);
2412 case OACC_ROUTINE_LOP_WORKER
:
2413 MIO_NAME (ab_attribute
) (AB_OACC_ROUTINE_LOP_WORKER
, attr_bits
);
2415 case OACC_ROUTINE_LOP_VECTOR
:
2416 MIO_NAME (ab_attribute
) (AB_OACC_ROUTINE_LOP_VECTOR
, attr_bits
);
2418 case OACC_ROUTINE_LOP_SEQ
:
2419 MIO_NAME (ab_attribute
) (AB_OACC_ROUTINE_LOP_SEQ
, attr_bits
);
2421 case OACC_ROUTINE_LOP_ERROR
:
2422 /* ... intentionally omitted here; it's only unsed internally. */
2426 if (attr
->oacc_routine_nohost
)
2427 MIO_NAME (ab_attribute
) (AB_OACC_ROUTINE_NOHOST
, attr_bits
);
2429 if (attr
->flavor
== FL_MODULE
&& gfc_current_ns
->omp_requires
)
2431 if (gfc_current_ns
->omp_requires
& OMP_REQ_REVERSE_OFFLOAD
)
2432 MIO_NAME (ab_attribute
) (AB_OMP_REQ_REVERSE_OFFLOAD
, attr_bits
);
2433 if (gfc_current_ns
->omp_requires
& OMP_REQ_UNIFIED_ADDRESS
)
2434 MIO_NAME (ab_attribute
) (AB_OMP_REQ_UNIFIED_ADDRESS
, attr_bits
);
2435 if (gfc_current_ns
->omp_requires
& OMP_REQ_UNIFIED_SHARED_MEMORY
)
2436 MIO_NAME (ab_attribute
) (AB_OMP_REQ_UNIFIED_SHARED_MEMORY
, attr_bits
);
2437 if (gfc_current_ns
->omp_requires
& OMP_REQ_DYNAMIC_ALLOCATORS
)
2438 MIO_NAME (ab_attribute
) (AB_OMP_REQ_DYNAMIC_ALLOCATORS
, attr_bits
);
2439 if ((gfc_current_ns
->omp_requires
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
2440 == OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST
)
2441 MIO_NAME (ab_attribute
) (AB_OMP_REQ_MEM_ORDER_SEQ_CST
, attr_bits
);
2442 if ((gfc_current_ns
->omp_requires
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
2443 == OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL
)
2444 MIO_NAME (ab_attribute
) (AB_OMP_REQ_MEM_ORDER_ACQ_REL
, attr_bits
);
2445 if ((gfc_current_ns
->omp_requires
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
2446 == OMP_REQ_ATOMIC_MEM_ORDER_RELAXED
)
2447 MIO_NAME (ab_attribute
) (AB_OMP_REQ_MEM_ORDER_RELAXED
, attr_bits
);
2449 switch (attr
->omp_device_type
)
2451 case OMP_DEVICE_TYPE_UNSET
:
2453 case OMP_DEVICE_TYPE_HOST
:
2454 MIO_NAME (ab_attribute
) (AB_OMP_DEVICE_TYPE_HOST
, attr_bits
);
2456 case OMP_DEVICE_TYPE_NOHOST
:
2457 MIO_NAME (ab_attribute
) (AB_OMP_DEVICE_TYPE_NOHOST
, attr_bits
);
2459 case OMP_DEVICE_TYPE_ANY
:
2460 MIO_NAME (ab_attribute
) (AB_OMP_DEVICE_TYPE_ANY
, attr_bits
);
2472 if (t
== ATOM_RPAREN
)
2475 bad_module ("Expected attribute bit name");
2477 switch ((ab_attribute
) find_enum (attr_bits
))
2479 case AB_ALLOCATABLE
:
2480 attr
->allocatable
= 1;
2483 attr
->artificial
= 1;
2485 case AB_ASYNCHRONOUS
:
2486 attr
->asynchronous
= 1;
2489 attr
->dimension
= 1;
2491 case AB_CODIMENSION
:
2492 attr
->codimension
= 1;
2495 attr
->contiguous
= 1;
2501 attr
->intrinsic
= 1;
2509 case AB_CLASS_POINTER
:
2510 attr
->class_pointer
= 1;
2513 attr
->is_protected
= 1;
2519 attr
->volatile_
= 1;
2524 case AB_THREADPRIVATE
:
2525 attr
->threadprivate
= 1;
2536 case AB_IN_NAMELIST
:
2537 attr
->in_namelist
= 1;
2540 attr
->in_common
= 1;
2546 attr
->subroutine
= 1;
2558 attr
->elemental
= 1;
2563 case AB_IMPLICIT_PURE
:
2564 attr
->implicit_pure
= 1;
2566 case AB_UNLIMITED_POLY
:
2567 attr
->unlimited_polymorphic
= 1;
2570 attr
->recursive
= 1;
2572 case AB_ALWAYS_EXPLICIT
:
2573 attr
->always_explicit
= 1;
2575 case AB_CRAY_POINTER
:
2576 attr
->cray_pointer
= 1;
2578 case AB_CRAY_POINTEE
:
2579 attr
->cray_pointee
= 1;
2582 attr
->is_bind_c
= 1;
2584 case AB_IS_C_INTEROP
:
2585 attr
->is_c_interop
= 1;
2591 attr
->alloc_comp
= 1;
2593 case AB_COARRAY_COMP
:
2594 attr
->coarray_comp
= 1;
2597 attr
->lock_comp
= 1;
2600 attr
->event_comp
= 1;
2602 case AB_POINTER_COMP
:
2603 attr
->pointer_comp
= 1;
2605 case AB_PROC_POINTER_COMP
:
2606 attr
->proc_pointer_comp
= 1;
2608 case AB_PRIVATE_COMP
:
2609 attr
->private_comp
= 1;
2612 attr
->zero_comp
= 1;
2618 attr
->procedure
= 1;
2620 case AB_PROC_POINTER
:
2621 attr
->proc_pointer
= 1;
2629 case AB_OMP_DECLARE_TARGET
:
2630 attr
->omp_declare_target
= 1;
2632 case AB_OMP_DECLARE_TARGET_LINK
:
2633 attr
->omp_declare_target_link
= 1;
2635 case AB_ARRAY_OUTER_DEPENDENCY
:
2636 attr
->array_outer_dependency
=1;
2638 case AB_MODULE_PROCEDURE
:
2639 attr
->module_procedure
=1;
2641 case AB_OACC_DECLARE_CREATE
:
2642 attr
->oacc_declare_create
= 1;
2644 case AB_OACC_DECLARE_COPYIN
:
2645 attr
->oacc_declare_copyin
= 1;
2647 case AB_OACC_DECLARE_DEVICEPTR
:
2648 attr
->oacc_declare_deviceptr
= 1;
2650 case AB_OACC_DECLARE_DEVICE_RESIDENT
:
2651 attr
->oacc_declare_device_resident
= 1;
2653 case AB_OACC_DECLARE_LINK
:
2654 attr
->oacc_declare_link
= 1;
2665 case AB_PDT_TEMPLATE
:
2666 attr
->pdt_template
= 1;
2669 attr
->pdt_array
= 1;
2672 attr
->pdt_string
= 1;
2674 case AB_OACC_ROUTINE_LOP_GANG
:
2675 verify_OACC_ROUTINE_LOP_NONE (attr
->oacc_routine_lop
);
2676 attr
->oacc_routine_lop
= OACC_ROUTINE_LOP_GANG
;
2678 case AB_OACC_ROUTINE_LOP_WORKER
:
2679 verify_OACC_ROUTINE_LOP_NONE (attr
->oacc_routine_lop
);
2680 attr
->oacc_routine_lop
= OACC_ROUTINE_LOP_WORKER
;
2682 case AB_OACC_ROUTINE_LOP_VECTOR
:
2683 verify_OACC_ROUTINE_LOP_NONE (attr
->oacc_routine_lop
);
2684 attr
->oacc_routine_lop
= OACC_ROUTINE_LOP_VECTOR
;
2686 case AB_OACC_ROUTINE_LOP_SEQ
:
2687 verify_OACC_ROUTINE_LOP_NONE (attr
->oacc_routine_lop
);
2688 attr
->oacc_routine_lop
= OACC_ROUTINE_LOP_SEQ
;
2690 case AB_OACC_ROUTINE_NOHOST
:
2691 attr
->oacc_routine_nohost
= 1;
2693 case AB_OMP_REQ_REVERSE_OFFLOAD
:
2694 gfc_omp_requires_add_clause (OMP_REQ_REVERSE_OFFLOAD
,
2699 case AB_OMP_REQ_UNIFIED_ADDRESS
:
2700 gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_ADDRESS
,
2705 case AB_OMP_REQ_UNIFIED_SHARED_MEMORY
:
2706 gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_SHARED_MEMORY
,
2707 "unified_shared_memory",
2711 case AB_OMP_REQ_DYNAMIC_ALLOCATORS
:
2712 gfc_omp_requires_add_clause (OMP_REQ_DYNAMIC_ALLOCATORS
,
2713 "dynamic_allocators",
2717 case AB_OMP_REQ_MEM_ORDER_SEQ_CST
:
2718 gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST
,
2719 "seq_cst", &gfc_current_locus
,
2722 case AB_OMP_REQ_MEM_ORDER_ACQ_REL
:
2723 gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL
,
2724 "acq_rel", &gfc_current_locus
,
2727 case AB_OMP_REQ_MEM_ORDER_RELAXED
:
2728 gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_RELAXED
,
2729 "relaxed", &gfc_current_locus
,
2732 case AB_OMP_DEVICE_TYPE_HOST
:
2733 attr
->omp_device_type
= OMP_DEVICE_TYPE_HOST
;
2735 case AB_OMP_DEVICE_TYPE_NOHOST
:
2736 attr
->omp_device_type
= OMP_DEVICE_TYPE_NOHOST
;
2738 case AB_OMP_DEVICE_TYPE_ANY
:
2739 attr
->omp_device_type
= OMP_DEVICE_TYPE_ANY
;
2747 static const mstring bt_types
[] = {
2748 minit ("INTEGER", BT_INTEGER
),
2749 minit ("REAL", BT_REAL
),
2750 minit ("COMPLEX", BT_COMPLEX
),
2751 minit ("LOGICAL", BT_LOGICAL
),
2752 minit ("CHARACTER", BT_CHARACTER
),
2753 minit ("UNION", BT_UNION
),
2754 minit ("DERIVED", BT_DERIVED
),
2755 minit ("CLASS", BT_CLASS
),
2756 minit ("PROCEDURE", BT_PROCEDURE
),
2757 minit ("UNKNOWN", BT_UNKNOWN
),
2758 minit ("VOID", BT_VOID
),
2759 minit ("ASSUMED", BT_ASSUMED
),
2765 mio_charlen (gfc_charlen
**clp
)
2771 if (iomode
== IO_OUTPUT
)
2775 mio_expr (&cl
->length
);
2779 if (peek_atom () != ATOM_RPAREN
)
2781 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2782 mio_expr (&cl
->length
);
2791 /* See if a name is a generated name. */
2794 check_unique_name (const char *name
)
2796 return *name
== '@';
2801 mio_typespec (gfc_typespec
*ts
)
2805 ts
->type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2807 if (!gfc_bt_struct (ts
->type
) && ts
->type
!= BT_CLASS
)
2808 mio_integer (&ts
->kind
);
2810 mio_symbol_ref (&ts
->u
.derived
);
2812 mio_symbol_ref (&ts
->interface
);
2814 /* Add info for C interop and is_iso_c. */
2815 mio_integer (&ts
->is_c_interop
);
2816 mio_integer (&ts
->is_iso_c
);
2818 /* If the typespec is for an identifier either from iso_c_binding, or
2819 a constant that was initialized to an identifier from it, use the
2820 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2822 ts
->f90_type
= MIO_NAME (bt
) (ts
->f90_type
, bt_types
);
2824 ts
->f90_type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2826 if (ts
->type
!= BT_CHARACTER
)
2828 /* ts->u.cl is only valid for BT_CHARACTER. */
2833 mio_charlen (&ts
->u
.cl
);
2835 /* So as not to disturb the existing API, use an ATOM_NAME to
2836 transmit deferred characteristic for characters (F2003). */
2837 if (iomode
== IO_OUTPUT
)
2839 if (ts
->type
== BT_CHARACTER
&& ts
->deferred
)
2840 write_atom (ATOM_NAME
, "DEFERRED_CL");
2842 else if (peek_atom () != ATOM_RPAREN
)
2844 if (parse_atom () != ATOM_NAME
)
2845 bad_module ("Expected string");
2853 static const mstring array_spec_types
[] = {
2854 minit ("EXPLICIT", AS_EXPLICIT
),
2855 minit ("ASSUMED_RANK", AS_ASSUMED_RANK
),
2856 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
2857 minit ("DEFERRED", AS_DEFERRED
),
2858 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
2864 mio_array_spec (gfc_array_spec
**asp
)
2871 if (iomode
== IO_OUTPUT
)
2879 /* mio_integer expects nonnegative values. */
2880 rank
= as
->rank
> 0 ? as
->rank
: 0;
2881 mio_integer (&rank
);
2885 if (peek_atom () == ATOM_RPAREN
)
2891 *asp
= as
= gfc_get_array_spec ();
2892 mio_integer (&as
->rank
);
2895 mio_integer (&as
->corank
);
2896 as
->type
= MIO_NAME (array_type
) (as
->type
, array_spec_types
);
2898 if (iomode
== IO_INPUT
&& as
->type
== AS_ASSUMED_RANK
)
2900 if (iomode
== IO_INPUT
&& as
->corank
)
2901 as
->cotype
= (as
->type
== AS_DEFERRED
) ? AS_DEFERRED
: AS_EXPLICIT
;
2903 if (as
->rank
+ as
->corank
> 0)
2904 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
2906 mio_expr (&as
->lower
[i
]);
2907 mio_expr (&as
->upper
[i
]);
2915 /* Given a pointer to an array reference structure (which lives in a
2916 gfc_ref structure), find the corresponding array specification
2917 structure. Storing the pointer in the ref structure doesn't quite
2918 work when loading from a module. Generating code for an array
2919 reference also needs more information than just the array spec. */
2921 static const mstring array_ref_types
[] = {
2922 minit ("FULL", AR_FULL
),
2923 minit ("ELEMENT", AR_ELEMENT
),
2924 minit ("SECTION", AR_SECTION
),
2930 mio_array_ref (gfc_array_ref
*ar
)
2935 ar
->type
= MIO_NAME (ar_type
) (ar
->type
, array_ref_types
);
2936 mio_integer (&ar
->dimen
);
2944 for (i
= 0; i
< ar
->dimen
; i
++)
2945 mio_expr (&ar
->start
[i
]);
2950 for (i
= 0; i
< ar
->dimen
; i
++)
2952 mio_expr (&ar
->start
[i
]);
2953 mio_expr (&ar
->end
[i
]);
2954 mio_expr (&ar
->stride
[i
]);
2960 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2963 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2964 we can't call mio_integer directly. Instead loop over each element
2965 and cast it to/from an integer. */
2966 if (iomode
== IO_OUTPUT
)
2968 for (i
= 0; i
< ar
->dimen
; i
++)
2970 HOST_WIDE_INT tmp
= (HOST_WIDE_INT
)ar
->dimen_type
[i
];
2971 write_atom (ATOM_INTEGER
, &tmp
);
2976 for (i
= 0; i
< ar
->dimen
; i
++)
2978 require_atom (ATOM_INTEGER
);
2979 ar
->dimen_type
[i
] = (enum gfc_array_ref_dimen_type
) atom_int
;
2983 if (iomode
== IO_INPUT
)
2985 ar
->where
= gfc_current_locus
;
2987 for (i
= 0; i
< ar
->dimen
; i
++)
2988 ar
->c_where
[i
] = gfc_current_locus
;
2995 /* Saves or restores a pointer. The pointer is converted back and
2996 forth from an integer. We return the pointer_info pointer so that
2997 the caller can take additional action based on the pointer type. */
2999 static pointer_info
*
3000 mio_pointer_ref (void *gp
)
3004 if (iomode
== IO_OUTPUT
)
3006 p
= get_pointer (*((char **) gp
));
3007 HOST_WIDE_INT hwi
= p
->integer
;
3008 write_atom (ATOM_INTEGER
, &hwi
);
3012 require_atom (ATOM_INTEGER
);
3013 p
= add_fixup (atom_int
, gp
);
3020 /* Save and load references to components that occur within
3021 expressions. We have to describe these references by a number and
3022 by name. The number is necessary for forward references during
3023 reading, and the name is necessary if the symbol already exists in
3024 the namespace and is not loaded again. */
3027 mio_component_ref (gfc_component
**cp
)
3031 p
= mio_pointer_ref (cp
);
3032 if (p
->type
== P_UNKNOWN
)
3033 p
->type
= P_COMPONENT
;
3037 static void mio_namespace_ref (gfc_namespace
**nsp
);
3038 static void mio_formal_arglist (gfc_formal_arglist
**formal
);
3039 static void mio_typebound_proc (gfc_typebound_proc
** proc
);
3040 static void mio_actual_arglist (gfc_actual_arglist
**ap
, bool pdt
);
3043 mio_component (gfc_component
*c
, int vtype
)
3049 if (iomode
== IO_OUTPUT
)
3051 p
= get_pointer (c
);
3052 mio_hwi (&p
->integer
);
3058 p
= get_integer (n
);
3059 associate_integer_pointer (p
, c
);
3062 if (p
->type
== P_UNKNOWN
)
3063 p
->type
= P_COMPONENT
;
3065 mio_pool_string (&c
->name
);
3066 mio_typespec (&c
->ts
);
3067 mio_array_spec (&c
->as
);
3069 /* PDT templates store the expression for the kind of a component here. */
3070 mio_expr (&c
->kind_expr
);
3072 /* PDT types store the component specification list here. */
3073 mio_actual_arglist (&c
->param_list
, true);
3075 mio_symbol_attribute (&c
->attr
);
3076 if (c
->ts
.type
== BT_CLASS
)
3077 c
->attr
.class_ok
= 1;
3078 c
->attr
.access
= MIO_NAME (gfc_access
) (c
->attr
.access
, access_types
);
3080 if (!vtype
|| strcmp (c
->name
, "_final") == 0
3081 || strcmp (c
->name
, "_hash") == 0)
3082 mio_expr (&c
->initializer
);
3084 if (c
->attr
.proc_pointer
)
3085 mio_typebound_proc (&c
->tb
);
3087 c
->loc
= gfc_current_locus
;
3094 mio_component_list (gfc_component
**cp
, int vtype
)
3096 gfc_component
*c
, *tail
;
3100 if (iomode
== IO_OUTPUT
)
3102 for (c
= *cp
; c
; c
= c
->next
)
3103 mio_component (c
, vtype
);
3112 if (peek_atom () == ATOM_RPAREN
)
3115 c
= gfc_get_component ();
3116 mio_component (c
, vtype
);
3132 mio_actual_arg (gfc_actual_arglist
*a
, bool pdt
)
3135 mio_pool_string (&a
->name
);
3136 mio_expr (&a
->expr
);
3138 mio_integer ((int *)&a
->spec_type
);
3144 mio_actual_arglist (gfc_actual_arglist
**ap
, bool pdt
)
3146 gfc_actual_arglist
*a
, *tail
;
3150 if (iomode
== IO_OUTPUT
)
3152 for (a
= *ap
; a
; a
= a
->next
)
3153 mio_actual_arg (a
, pdt
);
3162 if (peek_atom () != ATOM_LPAREN
)
3165 a
= gfc_get_actual_arglist ();
3173 mio_actual_arg (a
, pdt
);
3181 /* Read and write formal argument lists. */
3184 mio_formal_arglist (gfc_formal_arglist
**formal
)
3186 gfc_formal_arglist
*f
, *tail
;
3190 if (iomode
== IO_OUTPUT
)
3192 for (f
= *formal
; f
; f
= f
->next
)
3193 mio_symbol_ref (&f
->sym
);
3197 *formal
= tail
= NULL
;
3199 while (peek_atom () != ATOM_RPAREN
)
3201 f
= gfc_get_formal_arglist ();
3202 mio_symbol_ref (&f
->sym
);
3204 if (*formal
== NULL
)
3217 /* Save or restore a reference to a symbol node. */
3220 mio_symbol_ref (gfc_symbol
**symp
)
3224 p
= mio_pointer_ref (symp
);
3225 if (p
->type
== P_UNKNOWN
)
3228 if (iomode
== IO_OUTPUT
)
3230 if (p
->u
.wsym
.state
== UNREFERENCED
)
3231 p
->u
.wsym
.state
= NEEDS_WRITE
;
3235 if (p
->u
.rsym
.state
== UNUSED
)
3236 p
->u
.rsym
.state
= NEEDED
;
3242 /* Save or restore a reference to a symtree node. */
3245 mio_symtree_ref (gfc_symtree
**stp
)
3250 if (iomode
== IO_OUTPUT
)
3251 mio_symbol_ref (&(*stp
)->n
.sym
);
3254 require_atom (ATOM_INTEGER
);
3255 p
= get_integer (atom_int
);
3257 /* An unused equivalence member; make a symbol and a symtree
3259 if (in_load_equiv
&& p
->u
.rsym
.symtree
== NULL
)
3261 /* Since this is not used, it must have a unique name. */
3262 p
->u
.rsym
.symtree
= gfc_get_unique_symtree (gfc_current_ns
);
3264 /* Make the symbol. */
3265 if (p
->u
.rsym
.sym
== NULL
)
3267 p
->u
.rsym
.sym
= gfc_new_symbol (p
->u
.rsym
.true_name
,
3269 p
->u
.rsym
.sym
->module
= gfc_get_string ("%s", p
->u
.rsym
.module
);
3272 p
->u
.rsym
.symtree
->n
.sym
= p
->u
.rsym
.sym
;
3273 p
->u
.rsym
.symtree
->n
.sym
->refs
++;
3274 p
->u
.rsym
.referenced
= 1;
3276 /* If the symbol is PRIVATE and in COMMON, load_commons will
3277 generate a fixup symbol, which must be associated. */
3279 resolve_fixups (p
->fixup
, p
->u
.rsym
.sym
);
3283 if (p
->type
== P_UNKNOWN
)
3286 if (p
->u
.rsym
.state
== UNUSED
)
3287 p
->u
.rsym
.state
= NEEDED
;
3289 if (p
->u
.rsym
.symtree
!= NULL
)
3291 *stp
= p
->u
.rsym
.symtree
;
3295 f
= XCNEW (fixup_t
);
3297 f
->next
= p
->u
.rsym
.stfixup
;
3298 p
->u
.rsym
.stfixup
= f
;
3300 f
->pointer
= (void **) stp
;
3307 mio_iterator (gfc_iterator
**ip
)
3313 if (iomode
== IO_OUTPUT
)
3320 if (peek_atom () == ATOM_RPAREN
)
3326 *ip
= gfc_get_iterator ();
3331 mio_expr (&iter
->var
);
3332 mio_expr (&iter
->start
);
3333 mio_expr (&iter
->end
);
3334 mio_expr (&iter
->step
);
3342 mio_constructor (gfc_constructor_base
*cp
)
3348 if (iomode
== IO_OUTPUT
)
3350 for (c
= gfc_constructor_first (*cp
); c
; c
= gfc_constructor_next (c
))
3353 mio_expr (&c
->expr
);
3354 mio_iterator (&c
->iterator
);
3360 while (peek_atom () != ATOM_RPAREN
)
3362 c
= gfc_constructor_append_expr (cp
, NULL
, NULL
);
3365 mio_expr (&c
->expr
);
3366 mio_iterator (&c
->iterator
);
3375 static const mstring ref_types
[] = {
3376 minit ("ARRAY", REF_ARRAY
),
3377 minit ("COMPONENT", REF_COMPONENT
),
3378 minit ("SUBSTRING", REF_SUBSTRING
),
3379 minit ("INQUIRY", REF_INQUIRY
),
3383 static const mstring inquiry_types
[] = {
3384 minit ("RE", INQUIRY_RE
),
3385 minit ("IM", INQUIRY_IM
),
3386 minit ("KIND", INQUIRY_KIND
),
3387 minit ("LEN", INQUIRY_LEN
),
3393 mio_ref (gfc_ref
**rp
)
3400 r
->type
= MIO_NAME (ref_type
) (r
->type
, ref_types
);
3405 mio_array_ref (&r
->u
.ar
);
3409 mio_symbol_ref (&r
->u
.c
.sym
);
3410 mio_component_ref (&r
->u
.c
.component
);
3414 mio_expr (&r
->u
.ss
.start
);
3415 mio_expr (&r
->u
.ss
.end
);
3416 mio_charlen (&r
->u
.ss
.length
);
3420 r
->u
.i
= MIO_NAME (inquiry_type
) (r
->u
.i
, inquiry_types
);
3429 mio_ref_list (gfc_ref
**rp
)
3431 gfc_ref
*ref
, *head
, *tail
;
3435 if (iomode
== IO_OUTPUT
)
3437 for (ref
= *rp
; ref
; ref
= ref
->next
)
3444 while (peek_atom () != ATOM_RPAREN
)
3447 head
= tail
= gfc_get_ref ();
3450 tail
->next
= gfc_get_ref ();
3464 /* Read and write an integer value. */
3467 mio_gmp_integer (mpz_t
*integer
)
3471 if (iomode
== IO_INPUT
)
3473 if (parse_atom () != ATOM_STRING
)
3474 bad_module ("Expected integer string");
3476 mpz_init (*integer
);
3477 if (mpz_set_str (*integer
, atom_string
, 10))
3478 bad_module ("Error converting integer");
3484 p
= mpz_get_str (NULL
, 10, *integer
);
3485 write_atom (ATOM_STRING
, p
);
3492 mio_gmp_real (mpfr_t
*real
)
3494 mpfr_exp_t exponent
;
3497 if (iomode
== IO_INPUT
)
3499 if (parse_atom () != ATOM_STRING
)
3500 bad_module ("Expected real string");
3503 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
3508 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
3510 if (mpfr_nan_p (*real
) || mpfr_inf_p (*real
))
3512 write_atom (ATOM_STRING
, p
);
3517 atom_string
= XCNEWVEC (char, strlen (p
) + 20);
3519 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
3521 /* Fix negative numbers. */
3522 if (atom_string
[2] == '-')
3524 atom_string
[0] = '-';
3525 atom_string
[1] = '0';
3526 atom_string
[2] = '.';
3529 write_atom (ATOM_STRING
, atom_string
);
3537 /* Save and restore the shape of an array constructor. */
3540 mio_shape (mpz_t
**pshape
, int rank
)
3546 /* A NULL shape is represented by (). */
3549 if (iomode
== IO_OUTPUT
)
3561 if (t
== ATOM_RPAREN
)
3568 shape
= gfc_get_shape (rank
);
3572 for (n
= 0; n
< rank
; n
++)
3573 mio_gmp_integer (&shape
[n
]);
3579 static const mstring expr_types
[] = {
3580 minit ("OP", EXPR_OP
),
3581 minit ("FUNCTION", EXPR_FUNCTION
),
3582 minit ("CONSTANT", EXPR_CONSTANT
),
3583 minit ("VARIABLE", EXPR_VARIABLE
),
3584 minit ("SUBSTRING", EXPR_SUBSTRING
),
3585 minit ("STRUCTURE", EXPR_STRUCTURE
),
3586 minit ("ARRAY", EXPR_ARRAY
),
3587 minit ("NULL", EXPR_NULL
),
3588 minit ("COMPCALL", EXPR_COMPCALL
),
3592 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3593 generic operators, not in expressions. INTRINSIC_USER is also
3594 replaced by the correct function name by the time we see it. */
3596 static const mstring intrinsics
[] =
3598 minit ("UPLUS", INTRINSIC_UPLUS
),
3599 minit ("UMINUS", INTRINSIC_UMINUS
),
3600 minit ("PLUS", INTRINSIC_PLUS
),
3601 minit ("MINUS", INTRINSIC_MINUS
),
3602 minit ("TIMES", INTRINSIC_TIMES
),
3603 minit ("DIVIDE", INTRINSIC_DIVIDE
),
3604 minit ("POWER", INTRINSIC_POWER
),
3605 minit ("CONCAT", INTRINSIC_CONCAT
),
3606 minit ("AND", INTRINSIC_AND
),
3607 minit ("OR", INTRINSIC_OR
),
3608 minit ("EQV", INTRINSIC_EQV
),
3609 minit ("NEQV", INTRINSIC_NEQV
),
3610 minit ("EQ_SIGN", INTRINSIC_EQ
),
3611 minit ("EQ", INTRINSIC_EQ_OS
),
3612 minit ("NE_SIGN", INTRINSIC_NE
),
3613 minit ("NE", INTRINSIC_NE_OS
),
3614 minit ("GT_SIGN", INTRINSIC_GT
),
3615 minit ("GT", INTRINSIC_GT_OS
),
3616 minit ("GE_SIGN", INTRINSIC_GE
),
3617 minit ("GE", INTRINSIC_GE_OS
),
3618 minit ("LT_SIGN", INTRINSIC_LT
),
3619 minit ("LT", INTRINSIC_LT_OS
),
3620 minit ("LE_SIGN", INTRINSIC_LE
),
3621 minit ("LE", INTRINSIC_LE_OS
),
3622 minit ("NOT", INTRINSIC_NOT
),
3623 minit ("PARENTHESES", INTRINSIC_PARENTHESES
),
3624 minit ("USER", INTRINSIC_USER
),
3629 /* Remedy a couple of situations where the gfc_expr's can be defective. */
3632 fix_mio_expr (gfc_expr
*e
)
3634 gfc_symtree
*ns_st
= NULL
;
3637 if (iomode
!= IO_OUTPUT
)
3642 /* If this is a symtree for a symbol that came from a contained module
3643 namespace, it has a unique name and we should look in the current
3644 namespace to see if the required, non-contained symbol is available
3645 yet. If so, the latter should be written. */
3646 if (e
->symtree
->n
.sym
&& check_unique_name (e
->symtree
->name
))
3648 const char *name
= e
->symtree
->n
.sym
->name
;
3649 if (gfc_fl_struct (e
->symtree
->n
.sym
->attr
.flavor
))
3650 name
= gfc_dt_upper_string (name
);
3651 ns_st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3654 /* On the other hand, if the existing symbol is the module name or the
3655 new symbol is a dummy argument, do not do the promotion. */
3656 if (ns_st
&& ns_st
->n
.sym
3657 && ns_st
->n
.sym
->attr
.flavor
!= FL_MODULE
3658 && !e
->symtree
->n
.sym
->attr
.dummy
)
3661 else if (e
->expr_type
== EXPR_FUNCTION
3662 && (e
->value
.function
.name
|| e
->value
.function
.isym
))
3666 /* In some circumstances, a function used in an initialization
3667 expression, in one use associated module, can fail to be
3668 coupled to its symtree when used in a specification
3669 expression in another module. */
3670 fname
= e
->value
.function
.esym
? e
->value
.function
.esym
->name
3671 : e
->value
.function
.isym
->name
;
3672 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3677 /* This is probably a reference to a private procedure from another
3678 module. To prevent a segfault, make a generic with no specific
3679 instances. If this module is used, without the required
3680 specific coming from somewhere, the appropriate error message
3682 gfc_get_symbol (fname
, gfc_current_ns
, &sym
);
3683 sym
->attr
.flavor
= FL_PROCEDURE
;
3684 sym
->attr
.generic
= 1;
3685 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3686 gfc_commit_symbol (sym
);
3691 /* Read and write expressions. The form "()" is allowed to indicate a
3695 mio_expr (gfc_expr
**ep
)
3704 if (iomode
== IO_OUTPUT
)
3713 MIO_NAME (expr_t
) (e
->expr_type
, expr_types
);
3718 if (t
== ATOM_RPAREN
)
3725 bad_module ("Expected expression type");
3727 e
= *ep
= gfc_get_expr ();
3728 e
->where
= gfc_current_locus
;
3729 e
->expr_type
= (expr_t
) find_enum (expr_types
);
3732 mio_typespec (&e
->ts
);
3733 mio_integer (&e
->rank
);
3737 switch (e
->expr_type
)
3741 = MIO_NAME (gfc_intrinsic_op
) (e
->value
.op
.op
, intrinsics
);
3743 switch (e
->value
.op
.op
)
3745 case INTRINSIC_UPLUS
:
3746 case INTRINSIC_UMINUS
:
3748 case INTRINSIC_PARENTHESES
:
3749 mio_expr (&e
->value
.op
.op1
);
3752 case INTRINSIC_PLUS
:
3753 case INTRINSIC_MINUS
:
3754 case INTRINSIC_TIMES
:
3755 case INTRINSIC_DIVIDE
:
3756 case INTRINSIC_POWER
:
3757 case INTRINSIC_CONCAT
:
3761 case INTRINSIC_NEQV
:
3763 case INTRINSIC_EQ_OS
:
3765 case INTRINSIC_NE_OS
:
3767 case INTRINSIC_GT_OS
:
3769 case INTRINSIC_GE_OS
:
3771 case INTRINSIC_LT_OS
:
3773 case INTRINSIC_LE_OS
:
3774 mio_expr (&e
->value
.op
.op1
);
3775 mio_expr (&e
->value
.op
.op2
);
3778 case INTRINSIC_USER
:
3779 /* INTRINSIC_USER should not appear in resolved expressions,
3780 though for UDRs we need to stream unresolved ones. */
3781 if (iomode
== IO_OUTPUT
)
3782 write_atom (ATOM_STRING
, e
->value
.op
.uop
->name
);
3785 char *name
= read_string ();
3786 const char *uop_name
= find_use_name (name
, true);
3787 if (uop_name
== NULL
)
3789 size_t len
= strlen (name
);
3790 char *name2
= XCNEWVEC (char, len
+ 2);
3791 memcpy (name2
, name
, len
);
3793 name2
[len
+ 1] = '\0';
3795 uop_name
= name
= name2
;
3797 e
->value
.op
.uop
= gfc_get_uop (uop_name
);
3800 mio_expr (&e
->value
.op
.op1
);
3801 mio_expr (&e
->value
.op
.op2
);
3805 bad_module ("Bad operator");
3811 mio_symtree_ref (&e
->symtree
);
3812 mio_actual_arglist (&e
->value
.function
.actual
, false);
3814 if (iomode
== IO_OUTPUT
)
3816 e
->value
.function
.name
3817 = mio_allocated_string (e
->value
.function
.name
);
3818 if (e
->value
.function
.esym
)
3822 else if (e
->value
.function
.isym
== NULL
)
3826 mio_integer (&flag
);
3830 mio_symbol_ref (&e
->value
.function
.esym
);
3833 mio_ref_list (&e
->ref
);
3838 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
3843 require_atom (ATOM_STRING
);
3844 if (atom_string
[0] == '\0')
3845 e
->value
.function
.name
= NULL
;
3847 e
->value
.function
.name
= gfc_get_string ("%s", atom_string
);
3850 mio_integer (&flag
);
3854 mio_symbol_ref (&e
->value
.function
.esym
);
3857 mio_ref_list (&e
->ref
);
3862 require_atom (ATOM_STRING
);
3863 e
->value
.function
.isym
= gfc_find_function (atom_string
);
3871 mio_symtree_ref (&e
->symtree
);
3872 mio_ref_list (&e
->ref
);
3875 case EXPR_SUBSTRING
:
3876 e
->value
.character
.string
3877 = CONST_CAST (gfc_char_t
*,
3878 mio_allocated_wide_string (e
->value
.character
.string
,
3879 e
->value
.character
.length
));
3880 mio_ref_list (&e
->ref
);
3883 case EXPR_STRUCTURE
:
3885 mio_constructor (&e
->value
.constructor
);
3886 mio_shape (&e
->shape
, e
->rank
);
3893 mio_gmp_integer (&e
->value
.integer
);
3897 gfc_set_model_kind (e
->ts
.kind
);
3898 mio_gmp_real (&e
->value
.real
);
3902 gfc_set_model_kind (e
->ts
.kind
);
3903 mio_gmp_real (&mpc_realref (e
->value
.complex));
3904 mio_gmp_real (&mpc_imagref (e
->value
.complex));
3908 mio_integer (&e
->value
.logical
);
3912 hwi
= e
->value
.character
.length
;
3914 e
->value
.character
.length
= hwi
;
3915 e
->value
.character
.string
3916 = CONST_CAST (gfc_char_t
*,
3917 mio_allocated_wide_string (e
->value
.character
.string
,
3918 e
->value
.character
.length
));
3922 bad_module ("Bad type in constant expression");
3937 /* PDT types store the expression specification list here. */
3938 mio_actual_arglist (&e
->param_list
, true);
3944 /* Read and write namelists. */
3947 mio_namelist (gfc_symbol
*sym
)
3949 gfc_namelist
*n
, *m
;
3953 if (iomode
== IO_OUTPUT
)
3955 for (n
= sym
->namelist
; n
; n
= n
->next
)
3956 mio_symbol_ref (&n
->sym
);
3961 while (peek_atom () != ATOM_RPAREN
)
3963 n
= gfc_get_namelist ();
3964 mio_symbol_ref (&n
->sym
);
3966 if (sym
->namelist
== NULL
)
3973 sym
->namelist_tail
= m
;
3980 /* Save/restore lists of gfc_interface structures. When loading an
3981 interface, we are really appending to the existing list of
3982 interfaces. Checking for duplicate and ambiguous interfaces has to
3983 be done later when all symbols have been loaded. */
3986 mio_interface_rest (gfc_interface
**ip
)
3988 gfc_interface
*tail
, *p
;
3989 pointer_info
*pi
= NULL
;
3991 if (iomode
== IO_OUTPUT
)
3994 for (p
= *ip
; p
; p
= p
->next
)
3995 mio_symbol_ref (&p
->sym
);
4010 if (peek_atom () == ATOM_RPAREN
)
4013 p
= gfc_get_interface ();
4014 p
->where
= gfc_current_locus
;
4015 pi
= mio_symbol_ref (&p
->sym
);
4031 /* Save/restore a nameless operator interface. */
4034 mio_interface (gfc_interface
**ip
)
4037 mio_interface_rest (ip
);
4041 /* Save/restore a named operator interface. */
4044 mio_symbol_interface (const char **name
, const char **module
,
4048 mio_pool_string (name
);
4049 mio_pool_string (module
);
4050 mio_interface_rest (ip
);
4055 mio_namespace_ref (gfc_namespace
**nsp
)
4060 p
= mio_pointer_ref (nsp
);
4062 if (p
->type
== P_UNKNOWN
)
4063 p
->type
= P_NAMESPACE
;
4065 if (iomode
== IO_INPUT
&& p
->integer
!= 0)
4067 ns
= (gfc_namespace
*) p
->u
.pointer
;
4070 ns
= gfc_get_namespace (NULL
, 0);
4071 associate_integer_pointer (p
, ns
);
4079 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
4081 static gfc_namespace
* current_f2k_derived
;
4084 mio_typebound_proc (gfc_typebound_proc
** proc
)
4087 int overriding_flag
;
4089 if (iomode
== IO_INPUT
)
4091 *proc
= gfc_get_typebound_proc (NULL
);
4092 (*proc
)->where
= gfc_current_locus
;
4098 (*proc
)->access
= MIO_NAME (gfc_access
) ((*proc
)->access
, access_types
);
4100 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
4101 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
4102 overriding_flag
= ((*proc
)->deferred
<< 1) | (*proc
)->non_overridable
;
4103 overriding_flag
= mio_name (overriding_flag
, binding_overriding
);
4104 (*proc
)->deferred
= ((overriding_flag
& 2) != 0);
4105 (*proc
)->non_overridable
= ((overriding_flag
& 1) != 0);
4106 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
4108 (*proc
)->nopass
= mio_name ((*proc
)->nopass
, binding_passing
);
4109 (*proc
)->is_generic
= mio_name ((*proc
)->is_generic
, binding_generic
);
4110 (*proc
)->ppc
= mio_name((*proc
)->ppc
, binding_ppc
);
4112 mio_pool_string (&((*proc
)->pass_arg
));
4114 flag
= (int) (*proc
)->pass_arg_num
;
4115 mio_integer (&flag
);
4116 (*proc
)->pass_arg_num
= (unsigned) flag
;
4118 if ((*proc
)->is_generic
)
4125 if (iomode
== IO_OUTPUT
)
4126 for (g
= (*proc
)->u
.generic
; g
; g
= g
->next
)
4128 iop
= (int) g
->is_operator
;
4130 mio_allocated_string (g
->specific_st
->name
);
4134 (*proc
)->u
.generic
= NULL
;
4135 while (peek_atom () != ATOM_RPAREN
)
4137 gfc_symtree
** sym_root
;
4139 g
= gfc_get_tbp_generic ();
4143 g
->is_operator
= (bool) iop
;
4145 require_atom (ATOM_STRING
);
4146 sym_root
= ¤t_f2k_derived
->tb_sym_root
;
4147 g
->specific_st
= gfc_get_tbp_symtree (sym_root
, atom_string
);
4150 g
->next
= (*proc
)->u
.generic
;
4151 (*proc
)->u
.generic
= g
;
4157 else if (!(*proc
)->ppc
)
4158 mio_symtree_ref (&(*proc
)->u
.specific
);
4163 /* Walker-callback function for this purpose. */
4165 mio_typebound_symtree (gfc_symtree
* st
)
4167 if (iomode
== IO_OUTPUT
&& !st
->n
.tb
)
4170 if (iomode
== IO_OUTPUT
)
4173 mio_allocated_string (st
->name
);
4175 /* For IO_INPUT, the above is done in mio_f2k_derived. */
4177 mio_typebound_proc (&st
->n
.tb
);
4181 /* IO a full symtree (in all depth). */
4183 mio_full_typebound_tree (gfc_symtree
** root
)
4187 if (iomode
== IO_OUTPUT
)
4188 gfc_traverse_symtree (*root
, &mio_typebound_symtree
);
4191 while (peek_atom () == ATOM_LPAREN
)
4197 require_atom (ATOM_STRING
);
4198 st
= gfc_get_tbp_symtree (root
, atom_string
);
4201 mio_typebound_symtree (st
);
4209 mio_finalizer (gfc_finalizer
**f
)
4211 if (iomode
== IO_OUTPUT
)
4214 gcc_assert ((*f
)->proc_tree
); /* Should already be resolved. */
4215 mio_symtree_ref (&(*f
)->proc_tree
);
4219 *f
= gfc_get_finalizer ();
4220 (*f
)->where
= gfc_current_locus
; /* Value should not matter. */
4223 mio_symtree_ref (&(*f
)->proc_tree
);
4224 (*f
)->proc_sym
= NULL
;
4229 mio_f2k_derived (gfc_namespace
*f2k
)
4231 current_f2k_derived
= f2k
;
4233 /* Handle the list of finalizer procedures. */
4235 if (iomode
== IO_OUTPUT
)
4238 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
4243 f2k
->finalizers
= NULL
;
4244 while (peek_atom () != ATOM_RPAREN
)
4246 gfc_finalizer
*cur
= NULL
;
4247 mio_finalizer (&cur
);
4248 cur
->next
= f2k
->finalizers
;
4249 f2k
->finalizers
= cur
;
4254 /* Handle type-bound procedures. */
4255 mio_full_typebound_tree (&f2k
->tb_sym_root
);
4257 /* Type-bound user operators. */
4258 mio_full_typebound_tree (&f2k
->tb_uop_root
);
4260 /* Type-bound intrinsic operators. */
4262 if (iomode
== IO_OUTPUT
)
4265 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
4267 gfc_intrinsic_op realop
;
4269 if (op
== INTRINSIC_USER
|| !f2k
->tb_op
[op
])
4273 realop
= (gfc_intrinsic_op
) op
;
4274 mio_intrinsic_op (&realop
);
4275 mio_typebound_proc (&f2k
->tb_op
[op
]);
4280 while (peek_atom () != ATOM_RPAREN
)
4282 gfc_intrinsic_op op
= GFC_INTRINSIC_BEGIN
; /* Silence GCC. */
4285 mio_intrinsic_op (&op
);
4286 mio_typebound_proc (&f2k
->tb_op
[op
]);
4293 mio_full_f2k_derived (gfc_symbol
*sym
)
4297 if (iomode
== IO_OUTPUT
)
4299 if (sym
->f2k_derived
)
4300 mio_f2k_derived (sym
->f2k_derived
);
4304 if (peek_atom () != ATOM_RPAREN
)
4308 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
4310 /* PDT templates make use of the mechanisms for formal args
4311 and so the parameter symbols are stored in the formal
4312 namespace. Transfer the sym_root to f2k_derived and then
4313 free the formal namespace since it is uneeded. */
4314 if (sym
->attr
.pdt_template
&& sym
->formal
&& sym
->formal
->sym
)
4316 ns
= sym
->formal
->sym
->ns
;
4317 sym
->f2k_derived
->sym_root
= ns
->sym_root
;
4318 ns
->sym_root
= NULL
;
4320 gfc_free_namespace (ns
);
4324 mio_f2k_derived (sym
->f2k_derived
);
4327 gcc_assert (!sym
->f2k_derived
);
4333 static const mstring omp_declare_simd_clauses
[] =
4335 minit ("INBRANCH", 0),
4336 minit ("NOTINBRANCH", 1),
4337 minit ("SIMDLEN", 2),
4338 minit ("UNIFORM", 3),
4339 minit ("LINEAR", 4),
4340 minit ("ALIGNED", 5),
4341 minit ("LINEAR_REF", 33),
4342 minit ("LINEAR_VAL", 34),
4343 minit ("LINEAR_UVAL", 35),
4347 /* Handle !$omp declare simd. */
4350 mio_omp_declare_simd (gfc_namespace
*ns
, gfc_omp_declare_simd
**odsp
)
4352 if (iomode
== IO_OUTPUT
)
4357 else if (peek_atom () != ATOM_LPAREN
)
4360 gfc_omp_declare_simd
*ods
= *odsp
;
4363 if (iomode
== IO_OUTPUT
)
4365 write_atom (ATOM_NAME
, "OMP_DECLARE_SIMD");
4368 gfc_omp_namelist
*n
;
4370 if (ods
->clauses
->inbranch
)
4371 mio_name (0, omp_declare_simd_clauses
);
4372 if (ods
->clauses
->notinbranch
)
4373 mio_name (1, omp_declare_simd_clauses
);
4374 if (ods
->clauses
->simdlen_expr
)
4376 mio_name (2, omp_declare_simd_clauses
);
4377 mio_expr (&ods
->clauses
->simdlen_expr
);
4379 for (n
= ods
->clauses
->lists
[OMP_LIST_UNIFORM
]; n
; n
= n
->next
)
4381 mio_name (3, omp_declare_simd_clauses
);
4382 mio_symbol_ref (&n
->sym
);
4384 for (n
= ods
->clauses
->lists
[OMP_LIST_LINEAR
]; n
; n
= n
->next
)
4386 if (n
->u
.linear
.op
== OMP_LINEAR_DEFAULT
)
4387 mio_name (4, omp_declare_simd_clauses
);
4389 mio_name (32 + n
->u
.linear
.op
, omp_declare_simd_clauses
);
4390 mio_symbol_ref (&n
->sym
);
4391 mio_expr (&n
->expr
);
4393 for (n
= ods
->clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
4395 mio_name (5, omp_declare_simd_clauses
);
4396 mio_symbol_ref (&n
->sym
);
4397 mio_expr (&n
->expr
);
4403 gfc_omp_namelist
**ptrs
[3] = { NULL
, NULL
, NULL
};
4405 require_atom (ATOM_NAME
);
4406 *odsp
= ods
= gfc_get_omp_declare_simd ();
4407 ods
->where
= gfc_current_locus
;
4408 ods
->proc_name
= ns
->proc_name
;
4409 if (peek_atom () == ATOM_NAME
)
4411 ods
->clauses
= gfc_get_omp_clauses ();
4412 ptrs
[0] = &ods
->clauses
->lists
[OMP_LIST_UNIFORM
];
4413 ptrs
[1] = &ods
->clauses
->lists
[OMP_LIST_LINEAR
];
4414 ptrs
[2] = &ods
->clauses
->lists
[OMP_LIST_ALIGNED
];
4416 while (peek_atom () == ATOM_NAME
)
4418 gfc_omp_namelist
*n
;
4419 int t
= mio_name (0, omp_declare_simd_clauses
);
4423 case 0: ods
->clauses
->inbranch
= true; break;
4424 case 1: ods
->clauses
->notinbranch
= true; break;
4425 case 2: mio_expr (&ods
->clauses
->simdlen_expr
); break;
4429 *ptrs
[t
- 3] = n
= gfc_get_omp_namelist ();
4431 n
->where
= gfc_current_locus
;
4432 ptrs
[t
- 3] = &n
->next
;
4433 mio_symbol_ref (&n
->sym
);
4435 mio_expr (&n
->expr
);
4440 *ptrs
[1] = n
= gfc_get_omp_namelist ();
4441 n
->u
.linear
.op
= (enum gfc_omp_linear_op
) (t
- 32);
4443 goto finish_namelist
;
4448 mio_omp_declare_simd (ns
, &ods
->next
);
4454 static const mstring omp_declare_reduction_stmt
[] =
4456 minit ("ASSIGN", 0),
4463 mio_omp_udr_expr (gfc_omp_udr
*udr
, gfc_symbol
**sym1
, gfc_symbol
**sym2
,
4464 gfc_namespace
*ns
, bool is_initializer
)
4466 if (iomode
== IO_OUTPUT
)
4468 if ((*sym1
)->module
== NULL
)
4470 (*sym1
)->module
= module_name
;
4471 (*sym2
)->module
= module_name
;
4473 mio_symbol_ref (sym1
);
4474 mio_symbol_ref (sym2
);
4475 if (ns
->code
->op
== EXEC_ASSIGN
)
4477 mio_name (0, omp_declare_reduction_stmt
);
4478 mio_expr (&ns
->code
->expr1
);
4479 mio_expr (&ns
->code
->expr2
);
4484 mio_name (1, omp_declare_reduction_stmt
);
4485 mio_symtree_ref (&ns
->code
->symtree
);
4486 mio_actual_arglist (&ns
->code
->ext
.actual
, false);
4488 flag
= ns
->code
->resolved_isym
!= NULL
;
4489 mio_integer (&flag
);
4491 write_atom (ATOM_STRING
, ns
->code
->resolved_isym
->name
);
4493 mio_symbol_ref (&ns
->code
->resolved_sym
);
4498 pointer_info
*p1
= mio_symbol_ref (sym1
);
4499 pointer_info
*p2
= mio_symbol_ref (sym2
);
4501 gcc_assert (p1
->u
.rsym
.ns
== p2
->u
.rsym
.ns
);
4502 gcc_assert (p1
->u
.rsym
.sym
== NULL
);
4503 /* Add hidden symbols to the symtree. */
4504 pointer_info
*q
= get_integer (p1
->u
.rsym
.ns
);
4505 q
->u
.pointer
= (void *) ns
;
4506 sym
= gfc_new_symbol (is_initializer
? "omp_priv" : "omp_out", ns
);
4508 sym
->module
= gfc_get_string ("%s", p1
->u
.rsym
.module
);
4509 associate_integer_pointer (p1
, sym
);
4510 sym
->attr
.omp_udr_artificial_var
= 1;
4511 gcc_assert (p2
->u
.rsym
.sym
== NULL
);
4512 sym
= gfc_new_symbol (is_initializer
? "omp_orig" : "omp_in", ns
);
4514 sym
->module
= gfc_get_string ("%s", p2
->u
.rsym
.module
);
4515 associate_integer_pointer (p2
, sym
);
4516 sym
->attr
.omp_udr_artificial_var
= 1;
4517 if (mio_name (0, omp_declare_reduction_stmt
) == 0)
4519 ns
->code
= gfc_get_code (EXEC_ASSIGN
);
4520 mio_expr (&ns
->code
->expr1
);
4521 mio_expr (&ns
->code
->expr2
);
4526 ns
->code
= gfc_get_code (EXEC_CALL
);
4527 mio_symtree_ref (&ns
->code
->symtree
);
4528 mio_actual_arglist (&ns
->code
->ext
.actual
, false);
4530 mio_integer (&flag
);
4533 require_atom (ATOM_STRING
);
4534 ns
->code
->resolved_isym
= gfc_find_subroutine (atom_string
);
4538 mio_symbol_ref (&ns
->code
->resolved_sym
);
4540 ns
->code
->loc
= gfc_current_locus
;
4546 /* Unlike most other routines, the address of the symbol node is already
4547 fixed on input and the name/module has already been filled in.
4548 If you update the symbol format here, don't forget to update read_module
4549 as well (look for "seek to the symbol's component list"). */
4552 mio_symbol (gfc_symbol
*sym
)
4554 int intmod
= INTMOD_NONE
;
4558 mio_symbol_attribute (&sym
->attr
);
4560 if (sym
->attr
.pdt_type
)
4561 sym
->name
= gfc_dt_upper_string (sym
->name
);
4563 /* Note that components are always saved, even if they are supposed
4564 to be private. Component access is checked during searching. */
4565 mio_component_list (&sym
->components
, sym
->attr
.vtype
);
4566 if (sym
->components
!= NULL
)
4567 sym
->component_access
4568 = MIO_NAME (gfc_access
) (sym
->component_access
, access_types
);
4570 mio_typespec (&sym
->ts
);
4571 if (sym
->ts
.type
== BT_CLASS
)
4572 sym
->attr
.class_ok
= 1;
4574 if (iomode
== IO_OUTPUT
)
4575 mio_namespace_ref (&sym
->formal_ns
);
4578 mio_namespace_ref (&sym
->formal_ns
);
4580 sym
->formal_ns
->proc_name
= sym
;
4583 /* Save/restore common block links. */
4584 mio_symbol_ref (&sym
->common_next
);
4586 mio_formal_arglist (&sym
->formal
);
4588 if (sym
->attr
.flavor
== FL_PARAMETER
)
4589 mio_expr (&sym
->value
);
4591 mio_array_spec (&sym
->as
);
4593 mio_symbol_ref (&sym
->result
);
4595 if (sym
->attr
.cray_pointee
)
4596 mio_symbol_ref (&sym
->cp_pointer
);
4598 /* Load/save the f2k_derived namespace of a derived-type symbol. */
4599 mio_full_f2k_derived (sym
);
4601 /* PDT types store the symbol specification list here. */
4602 mio_actual_arglist (&sym
->param_list
, true);
4606 /* Add the fields that say whether this is from an intrinsic module,
4607 and if so, what symbol it is within the module. */
4608 /* mio_integer (&(sym->from_intmod)); */
4609 if (iomode
== IO_OUTPUT
)
4611 intmod
= sym
->from_intmod
;
4612 mio_integer (&intmod
);
4616 mio_integer (&intmod
);
4618 sym
->from_intmod
= current_intmod
;
4620 sym
->from_intmod
= (intmod_id
) intmod
;
4623 mio_integer (&(sym
->intmod_sym_id
));
4625 if (gfc_fl_struct (sym
->attr
.flavor
))
4626 mio_integer (&(sym
->hash_value
));
4629 && sym
->formal_ns
->proc_name
== sym
4630 && sym
->formal_ns
->entries
== NULL
)
4631 mio_omp_declare_simd (sym
->formal_ns
, &sym
->formal_ns
->omp_declare_simd
);
4637 /************************* Top level subroutines *************************/
4639 /* A recursive function to look for a specific symbol by name and by
4640 module. Whilst several symtrees might point to one symbol, its
4641 is sufficient for the purposes here than one exist. Note that
4642 generic interfaces are distinguished as are symbols that have been
4643 renamed in another module. */
4644 static gfc_symtree
*
4645 find_symbol (gfc_symtree
*st
, const char *name
,
4646 const char *module
, int generic
)
4649 gfc_symtree
*retval
, *s
;
4651 if (st
== NULL
|| st
->n
.sym
== NULL
)
4654 c
= strcmp (name
, st
->n
.sym
->name
);
4655 if (c
== 0 && st
->n
.sym
->module
4656 && strcmp (module
, st
->n
.sym
->module
) == 0
4657 && !check_unique_name (st
->name
))
4659 s
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4661 /* Detect symbols that are renamed by use association in another
4662 module by the absence of a symtree and null attr.use_rename,
4663 since the latter is not transmitted in the module file. */
4664 if (((!generic
&& !st
->n
.sym
->attr
.generic
)
4665 || (generic
&& st
->n
.sym
->attr
.generic
))
4666 && !(s
== NULL
&& !st
->n
.sym
->attr
.use_rename
))
4670 retval
= find_symbol (st
->left
, name
, module
, generic
);
4673 retval
= find_symbol (st
->right
, name
, module
, generic
);
4679 /* Skip a list between balanced left and right parens.
4680 By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
4681 have been already parsed by hand, and the remaining of the content is to be
4682 skipped here. The default value is 0 (balanced parens). */
4685 skip_list (int nest_level
= 0)
4692 switch (parse_atom ())
4715 /* Load operator interfaces from the module. Interfaces are unusual
4716 in that they attach themselves to existing symbols. */
4719 load_operator_interfaces (void)
4722 /* "module" must be large enough for the case of submodules in which the name
4723 has the form module.submodule */
4724 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[2 * GFC_MAX_SYMBOL_LEN
+ 2];
4726 pointer_info
*pi
= NULL
;
4731 while (peek_atom () != ATOM_RPAREN
)
4735 mio_internal_string (name
);
4736 mio_internal_string (module
);
4738 n
= number_use_names (name
, true);
4741 for (i
= 1; i
<= n
; i
++)
4743 /* Decide if we need to load this one or not. */
4744 p
= find_use_name_n (name
, &i
, true);
4748 while (parse_atom () != ATOM_RPAREN
);
4754 uop
= gfc_get_uop (p
);
4755 pi
= mio_interface_rest (&uop
->op
);
4759 if (gfc_find_uop (p
, NULL
))
4761 uop
= gfc_get_uop (p
);
4762 uop
->op
= gfc_get_interface ();
4763 uop
->op
->where
= gfc_current_locus
;
4764 add_fixup (pi
->integer
, &uop
->op
->sym
);
4773 /* Load interfaces from the module. Interfaces are unusual in that
4774 they attach themselves to existing symbols. */
4777 load_generic_interfaces (void)
4780 /* "module" must be large enough for the case of submodules in which the name
4781 has the form module.submodule */
4782 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[2 * GFC_MAX_SYMBOL_LEN
+ 2];
4784 gfc_interface
*generic
= NULL
, *gen
= NULL
;
4786 bool ambiguous_set
= false;
4790 while (peek_atom () != ATOM_RPAREN
)
4794 mio_internal_string (name
);
4795 mio_internal_string (module
);
4797 n
= number_use_names (name
, false);
4798 renamed
= n
? 1 : 0;
4801 for (i
= 1; i
<= n
; i
++)
4804 /* Decide if we need to load this one or not. */
4805 p
= find_use_name_n (name
, &i
, false);
4807 if (!p
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
4809 /* Skip the specific names for these cases. */
4810 while (i
== 1 && parse_atom () != ATOM_RPAREN
);
4815 st
= find_symbol (gfc_current_ns
->sym_root
,
4816 name
, module_name
, 1);
4818 /* If the symbol exists already and is being USEd without being
4819 in an ONLY clause, do not load a new symtree(11.3.2). */
4820 if (!only_flag
&& st
)
4828 if (strcmp (st
->name
, p
) != 0)
4830 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4836 /* Since we haven't found a valid generic interface, we had
4840 gfc_get_symbol (p
, NULL
, &sym
);
4841 sym
->name
= gfc_get_string ("%s", name
);
4842 sym
->module
= module_name
;
4843 sym
->attr
.flavor
= FL_PROCEDURE
;
4844 sym
->attr
.generic
= 1;
4845 sym
->attr
.use_assoc
= 1;
4850 /* Unless sym is a generic interface, this reference
4853 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4857 if (st
&& !sym
->attr
.generic
4860 && strcmp (module
, sym
->module
))
4862 ambiguous_set
= true;
4867 sym
->attr
.use_only
= only_flag
;
4868 sym
->attr
.use_rename
= renamed
;
4872 mio_interface_rest (&sym
->generic
);
4873 generic
= sym
->generic
;
4875 else if (!sym
->generic
)
4877 sym
->generic
= generic
;
4878 sym
->attr
.generic_copy
= 1;
4881 /* If a procedure that is not generic has generic interfaces
4882 that include itself, it is generic! We need to take care
4883 to retain symbols ambiguous that were already so. */
4884 if (sym
->attr
.use_assoc
4885 && !sym
->attr
.generic
4886 && sym
->attr
.flavor
== FL_PROCEDURE
)
4888 for (gen
= generic
; gen
; gen
= gen
->next
)
4890 if (gen
->sym
== sym
)
4892 sym
->attr
.generic
= 1;
4907 /* Load common blocks. */
4912 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4917 while (peek_atom () != ATOM_RPAREN
)
4922 mio_internal_string (name
);
4924 p
= gfc_get_common (name
, 1);
4926 mio_symbol_ref (&p
->head
);
4927 mio_integer (&flags
);
4931 p
->threadprivate
= 1;
4932 p
->omp_device_type
= (gfc_omp_device_type
) ((flags
>> 2) & 3);
4935 /* Get whether this was a bind(c) common or not. */
4936 mio_integer (&p
->is_bind_c
);
4937 /* Get the binding label. */
4938 label
= read_string ();
4940 p
->binding_label
= IDENTIFIER_POINTER (get_identifier (label
));
4950 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4951 so that unused variables are not loaded and so that the expression can
4957 gfc_equiv
*head
, *tail
, *end
, *eq
, *equiv
;
4961 in_load_equiv
= true;
4963 end
= gfc_current_ns
->equiv
;
4964 while (end
!= NULL
&& end
->next
!= NULL
)
4967 while (peek_atom () != ATOM_RPAREN
) {
4971 while(peek_atom () != ATOM_RPAREN
)
4974 head
= tail
= gfc_get_equiv ();
4977 tail
->eq
= gfc_get_equiv ();
4981 mio_pool_string (&tail
->module
);
4982 mio_expr (&tail
->expr
);
4985 /* Check for duplicate equivalences being loaded from different modules */
4987 for (equiv
= gfc_current_ns
->equiv
; equiv
; equiv
= equiv
->next
)
4989 if (equiv
->module
&& head
->module
4990 && strcmp (equiv
->module
, head
->module
) == 0)
4999 for (eq
= head
; eq
; eq
= head
)
5002 gfc_free_expr (eq
->expr
);
5008 gfc_current_ns
->equiv
= head
;
5019 in_load_equiv
= false;
5023 /* This function loads OpenMP user defined reductions. */
5025 load_omp_udrs (void)
5028 while (peek_atom () != ATOM_RPAREN
)
5030 const char *name
= NULL
, *newname
;
5034 gfc_omp_reduction_op rop
= OMP_REDUCTION_USER
;
5037 mio_pool_string (&name
);
5040 if (startswith (name
, "operator "))
5042 const char *p
= name
+ sizeof ("operator ") - 1;
5043 if (strcmp (p
, "+") == 0)
5044 rop
= OMP_REDUCTION_PLUS
;
5045 else if (strcmp (p
, "*") == 0)
5046 rop
= OMP_REDUCTION_TIMES
;
5047 else if (strcmp (p
, "-") == 0)
5048 rop
= OMP_REDUCTION_MINUS
;
5049 else if (strcmp (p
, ".and.") == 0)
5050 rop
= OMP_REDUCTION_AND
;
5051 else if (strcmp (p
, ".or.") == 0)
5052 rop
= OMP_REDUCTION_OR
;
5053 else if (strcmp (p
, ".eqv.") == 0)
5054 rop
= OMP_REDUCTION_EQV
;
5055 else if (strcmp (p
, ".neqv.") == 0)
5056 rop
= OMP_REDUCTION_NEQV
;
5059 if (rop
== OMP_REDUCTION_USER
&& name
[0] == '.')
5061 size_t len
= strlen (name
+ 1);
5062 altname
= XALLOCAVEC (char, len
);
5063 gcc_assert (name
[len
] == '.');
5064 memcpy (altname
, name
+ 1, len
- 1);
5065 altname
[len
- 1] = '\0';
5068 if (rop
== OMP_REDUCTION_USER
)
5069 newname
= find_use_name (altname
? altname
: name
, !!altname
);
5070 else if (only_flag
&& find_use_operator ((gfc_intrinsic_op
) rop
) == NULL
)
5072 if (newname
== NULL
)
5077 if (altname
&& newname
!= altname
)
5079 size_t len
= strlen (newname
);
5080 altname
= XALLOCAVEC (char, len
+ 3);
5082 memcpy (altname
+ 1, newname
, len
);
5083 altname
[len
+ 1] = '.';
5084 altname
[len
+ 2] = '\0';
5085 name
= gfc_get_string ("%s", altname
);
5087 st
= gfc_find_symtree (gfc_current_ns
->omp_udr_root
, name
);
5088 gfc_omp_udr
*udr
= gfc_omp_udr_find (st
, &ts
);
5091 require_atom (ATOM_INTEGER
);
5092 pointer_info
*p
= get_integer (atom_int
);
5093 if (strcmp (p
->u
.rsym
.module
, udr
->omp_out
->module
))
5095 gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
5097 p
->u
.rsym
.module
, &gfc_current_locus
);
5098 gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
5100 udr
->omp_out
->module
, &udr
->where
);
5105 udr
= gfc_get_omp_udr ();
5109 udr
->where
= gfc_current_locus
;
5110 udr
->combiner_ns
= gfc_get_namespace (gfc_current_ns
, 1);
5111 udr
->combiner_ns
->proc_name
= gfc_current_ns
->proc_name
;
5112 mio_omp_udr_expr (udr
, &udr
->omp_out
, &udr
->omp_in
, udr
->combiner_ns
,
5114 if (peek_atom () != ATOM_RPAREN
)
5116 udr
->initializer_ns
= gfc_get_namespace (gfc_current_ns
, 1);
5117 udr
->initializer_ns
->proc_name
= gfc_current_ns
->proc_name
;
5118 mio_omp_udr_expr (udr
, &udr
->omp_priv
, &udr
->omp_orig
,
5119 udr
->initializer_ns
, true);
5123 udr
->next
= st
->n
.omp_udr
;
5124 st
->n
.omp_udr
= udr
;
5128 st
= gfc_new_symtree (&gfc_current_ns
->omp_udr_root
, name
);
5129 st
->n
.omp_udr
= udr
;
5137 /* Recursive function to traverse the pointer_info tree and load a
5138 needed symbol. We return nonzero if we load a symbol and stop the
5139 traversal, because the act of loading can alter the tree. */
5142 load_needed (pointer_info
*p
)
5153 rv
|= load_needed (p
->left
);
5154 rv
|= load_needed (p
->right
);
5156 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
5159 p
->u
.rsym
.state
= USED
;
5161 set_module_locus (&p
->u
.rsym
.where
);
5163 sym
= p
->u
.rsym
.sym
;
5166 q
= get_integer (p
->u
.rsym
.ns
);
5168 ns
= (gfc_namespace
*) q
->u
.pointer
;
5171 /* Create an interface namespace if necessary. These are
5172 the namespaces that hold the formal parameters of module
5175 ns
= gfc_get_namespace (NULL
, 0);
5176 associate_integer_pointer (q
, ns
);
5179 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
5180 doesn't go pear-shaped if the symbol is used. */
5182 gfc_find_symbol (p
->u
.rsym
.module
, gfc_current_ns
,
5185 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
5186 sym
->name
= gfc_dt_lower_string (p
->u
.rsym
.true_name
);
5187 sym
->module
= gfc_get_string ("%s", p
->u
.rsym
.module
);
5188 if (p
->u
.rsym
.binding_label
)
5189 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier
5190 (p
->u
.rsym
.binding_label
));
5192 associate_integer_pointer (p
, sym
);
5196 sym
->attr
.use_assoc
= 1;
5198 /* Unliked derived types, a STRUCTURE may share names with other symbols.
5199 We greedily converted the symbol name to lowercase before we knew its
5200 type, so now we must fix it. */
5201 if (sym
->attr
.flavor
== FL_STRUCT
)
5202 sym
->name
= gfc_dt_upper_string (sym
->name
);
5204 /* Mark as only or rename for later diagnosis for explicitly imported
5205 but not used warnings; don't mark internal symbols such as __vtab,
5206 __def_init etc. Only mark them if they have been explicitly loaded. */
5208 if (only_flag
&& sym
->name
[0] != '_' && sym
->name
[1] != '_')
5212 /* Search the use/rename list for the variable; if the variable is
5214 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5216 if (strcmp (u
->use_name
, sym
->name
) == 0)
5218 sym
->attr
.use_only
= 1;
5224 if (p
->u
.rsym
.renamed
)
5225 sym
->attr
.use_rename
= 1;
5231 /* Recursive function for cleaning up things after a module has been read. */
5234 read_cleanup (pointer_info
*p
)
5242 read_cleanup (p
->left
);
5243 read_cleanup (p
->right
);
5245 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
5248 /* Add hidden symbols to the symtree. */
5249 q
= get_integer (p
->u
.rsym
.ns
);
5250 ns
= (gfc_namespace
*) q
->u
.pointer
;
5252 if (!p
->u
.rsym
.sym
->attr
.vtype
5253 && !p
->u
.rsym
.sym
->attr
.vtab
)
5254 st
= gfc_get_unique_symtree (ns
);
5257 /* There is no reason to use 'unique_symtrees' for vtabs or
5258 vtypes - their name is fine for a symtree and reduces the
5259 namespace pollution. */
5260 st
= gfc_find_symtree (ns
->sym_root
, p
->u
.rsym
.sym
->name
);
5262 st
= gfc_new_symtree (&ns
->sym_root
, p
->u
.rsym
.sym
->name
);
5265 st
->n
.sym
= p
->u
.rsym
.sym
;
5268 /* Fixup any symtree references. */
5269 p
->u
.rsym
.symtree
= st
;
5270 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
5271 p
->u
.rsym
.stfixup
= NULL
;
5274 /* Free unused symbols. */
5275 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
5276 gfc_free_symbol (p
->u
.rsym
.sym
);
5280 /* It is not quite enough to check for ambiguity in the symbols by
5281 the loaded symbol and the new symbol not being identical. */
5283 check_for_ambiguous (gfc_symtree
*st
, pointer_info
*info
)
5287 symbol_attribute attr
;
5290 if (gfc_current_ns
->proc_name
&& st
->name
== gfc_current_ns
->proc_name
->name
)
5292 gfc_error ("%qs of module %qs, imported at %C, is also the name of the "
5293 "current program unit", st
->name
, module_name
);
5298 rsym
= info
->u
.rsym
.sym
;
5302 if (st_sym
->attr
.vtab
|| st_sym
->attr
.vtype
)
5305 /* If the existing symbol is generic from a different module and
5306 the new symbol is generic there can be no ambiguity. */
5307 if (st_sym
->attr
.generic
5309 && st_sym
->module
!= module_name
)
5311 /* The new symbol's attributes have not yet been read. Since
5312 we need attr.generic, read it directly. */
5313 get_module_locus (&locus
);
5314 set_module_locus (&info
->u
.rsym
.where
);
5317 mio_symbol_attribute (&attr
);
5318 set_module_locus (&locus
);
5327 /* Read a module file. */
5332 module_locus operator_interfaces
, user_operators
, omp_udrs
;
5334 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5336 /* Workaround -Wmaybe-uninitialized false positive during
5337 profiledbootstrap by initializing them. */
5338 int ambiguous
= 0, j
, nuse
, symbol
= 0;
5339 pointer_info
*info
, *q
;
5340 gfc_use_rename
*u
= NULL
;
5344 get_module_locus (&operator_interfaces
); /* Skip these for now. */
5347 get_module_locus (&user_operators
);
5351 /* Skip commons and equivalences for now. */
5355 /* Skip OpenMP UDRs. */
5356 get_module_locus (&omp_udrs
);
5361 /* Create the fixup nodes for all the symbols. */
5363 while (peek_atom () != ATOM_RPAREN
)
5366 require_atom (ATOM_INTEGER
);
5367 info
= get_integer (atom_int
);
5369 info
->type
= P_SYMBOL
;
5370 info
->u
.rsym
.state
= UNUSED
;
5372 info
->u
.rsym
.true_name
= read_string ();
5373 info
->u
.rsym
.module
= read_string ();
5374 bind_label
= read_string ();
5375 if (strlen (bind_label
))
5376 info
->u
.rsym
.binding_label
= bind_label
;
5378 XDELETEVEC (bind_label
);
5380 require_atom (ATOM_INTEGER
);
5381 info
->u
.rsym
.ns
= atom_int
;
5383 get_module_locus (&info
->u
.rsym
.where
);
5385 /* See if the symbol has already been loaded by a previous module.
5386 If so, we reference the existing symbol and prevent it from
5387 being loaded again. This should not happen if the symbol being
5388 read is an index for an assumed shape dummy array (ns != 1). */
5390 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
5393 || (sym
->attr
.flavor
== FL_VARIABLE
&& info
->u
.rsym
.ns
!=1))
5399 info
->u
.rsym
.state
= USED
;
5400 info
->u
.rsym
.sym
= sym
;
5401 /* The current symbol has already been loaded, so we can avoid loading
5402 it again. However, if it is a derived type, some of its components
5403 can be used in expressions in the module. To avoid the module loading
5404 failing, we need to associate the module's component pointer indexes
5405 with the existing symbol's component pointers. */
5406 if (gfc_fl_struct (sym
->attr
.flavor
))
5410 /* First seek to the symbol's component list. */
5411 mio_lparen (); /* symbol opening. */
5412 skip_list (); /* skip symbol attribute. */
5414 mio_lparen (); /* component list opening. */
5415 for (c
= sym
->components
; c
; c
= c
->next
)
5418 const char *comp_name
= NULL
;
5421 mio_lparen (); /* component opening. */
5423 p
= get_integer (n
);
5424 if (p
->u
.pointer
== NULL
)
5425 associate_integer_pointer (p
, c
);
5426 mio_pool_string (&comp_name
);
5427 if (comp_name
!= c
->name
)
5429 gfc_fatal_error ("Mismatch in components of derived type "
5430 "%qs from %qs at %C: expecting %qs, "
5431 "but got %qs", sym
->name
, sym
->module
,
5432 c
->name
, comp_name
);
5434 skip_list (1); /* component end. */
5436 mio_rparen (); /* component list closing. */
5438 skip_list (1); /* symbol end. */
5443 /* Some symbols do not have a namespace (eg. formal arguments),
5444 so the automatic "unique symtree" mechanism must be suppressed
5445 by marking them as referenced. */
5446 q
= get_integer (info
->u
.rsym
.ns
);
5447 if (q
->u
.pointer
== NULL
)
5449 info
->u
.rsym
.referenced
= 1;
5456 /* Parse the symtree lists. This lets us mark which symbols need to
5457 be loaded. Renaming is also done at this point by replacing the
5462 while (peek_atom () != ATOM_RPAREN
)
5464 mio_internal_string (name
);
5465 mio_integer (&ambiguous
);
5466 mio_integer (&symbol
);
5468 info
= get_integer (symbol
);
5470 /* See how many use names there are. If none, go through the start
5471 of the loop at least once. */
5472 nuse
= number_use_names (name
, false);
5473 info
->u
.rsym
.renamed
= nuse
? 1 : 0;
5478 for (j
= 1; j
<= nuse
; j
++)
5480 /* Get the jth local name for this symbol. */
5481 p
= find_use_name_n (name
, &j
, false);
5483 if (p
== NULL
&& strcmp (name
, module_name
) == 0)
5486 /* Exception: Always import vtabs & vtypes. */
5487 if (p
== NULL
&& name
[0] == '_'
5488 && (startswith (name
, "__vtab_")
5489 || startswith (name
, "__vtype_")))
5492 /* Skip symtree nodes not in an ONLY clause, unless there
5493 is an existing symtree loaded from another USE statement. */
5496 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5498 && strcmp (st
->n
.sym
->name
, info
->u
.rsym
.true_name
) == 0
5499 && st
->n
.sym
->module
!= NULL
5500 && strcmp (st
->n
.sym
->module
, info
->u
.rsym
.module
) == 0)
5502 info
->u
.rsym
.symtree
= st
;
5503 info
->u
.rsym
.sym
= st
->n
.sym
;
5508 /* If a symbol of the same name and module exists already,
5509 this symbol, which is not in an ONLY clause, must not be
5510 added to the namespace(11.3.2). Note that find_symbol
5511 only returns the first occurrence that it finds. */
5512 if (!only_flag
&& !info
->u
.rsym
.renamed
5513 && strcmp (name
, module_name
) != 0
5514 && find_symbol (gfc_current_ns
->sym_root
, name
,
5518 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
5521 && !(st
->n
.sym
&& st
->n
.sym
->attr
.used_in_submodule
))
5523 /* Check for ambiguous symbols. */
5524 if (check_for_ambiguous (st
, info
))
5527 info
->u
.rsym
.symtree
= st
;
5533 /* This symbol is host associated from a module in a
5534 submodule. Hide it with a unique symtree. */
5535 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
5536 s
->n
.sym
= st
->n
.sym
;
5541 /* Create a symtree node in the current namespace for this
5543 st
= check_unique_name (p
)
5544 ? gfc_get_unique_symtree (gfc_current_ns
)
5545 : gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
5546 st
->ambiguous
= ambiguous
;
5549 sym
= info
->u
.rsym
.sym
;
5551 /* Create a symbol node if it doesn't already exist. */
5554 info
->u
.rsym
.sym
= gfc_new_symbol (info
->u
.rsym
.true_name
,
5556 info
->u
.rsym
.sym
->name
= gfc_dt_lower_string (info
->u
.rsym
.true_name
);
5557 sym
= info
->u
.rsym
.sym
;
5558 sym
->module
= gfc_get_string ("%s", info
->u
.rsym
.module
);
5560 if (info
->u
.rsym
.binding_label
)
5562 tree id
= get_identifier (info
->u
.rsym
.binding_label
);
5563 sym
->binding_label
= IDENTIFIER_POINTER (id
);
5570 if (strcmp (name
, p
) != 0)
5571 sym
->attr
.use_rename
= 1;
5574 || (!startswith (name
, "__vtab_")
5575 && !startswith (name
, "__vtype_")))
5576 sym
->attr
.use_only
= only_flag
;
5578 /* Store the symtree pointing to this symbol. */
5579 info
->u
.rsym
.symtree
= st
;
5581 if (info
->u
.rsym
.state
== UNUSED
)
5582 info
->u
.rsym
.state
= NEEDED
;
5583 info
->u
.rsym
.referenced
= 1;
5590 /* Load intrinsic operator interfaces. */
5591 set_module_locus (&operator_interfaces
);
5594 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5596 gfc_use_rename
*u
= NULL
, *v
= NULL
;
5599 if (i
== INTRINSIC_USER
)
5604 u
= find_use_operator ((gfc_intrinsic_op
) i
);
5606 /* F2018:10.1.5.5.1 requires same interpretation of old and new-style
5607 relational operators. Special handling for USE, ONLY. */
5611 j
= INTRINSIC_EQ_OS
;
5613 case INTRINSIC_EQ_OS
:
5617 j
= INTRINSIC_NE_OS
;
5619 case INTRINSIC_NE_OS
:
5623 j
= INTRINSIC_GT_OS
;
5625 case INTRINSIC_GT_OS
:
5629 j
= INTRINSIC_GE_OS
;
5631 case INTRINSIC_GE_OS
:
5635 j
= INTRINSIC_LT_OS
;
5637 case INTRINSIC_LT_OS
:
5641 j
= INTRINSIC_LE_OS
;
5643 case INTRINSIC_LE_OS
:
5651 v
= find_use_operator ((gfc_intrinsic_op
) j
);
5653 if (u
== NULL
&& v
== NULL
)
5665 mio_interface (&gfc_current_ns
->op
[i
]);
5666 if (!gfc_current_ns
->op
[i
] && !gfc_current_ns
->op
[j
])
5677 /* Load generic and user operator interfaces. These must follow the
5678 loading of symtree because otherwise symbols can be marked as
5681 set_module_locus (&user_operators
);
5683 load_operator_interfaces ();
5684 load_generic_interfaces ();
5689 /* Load OpenMP user defined reductions. */
5690 set_module_locus (&omp_udrs
);
5693 /* At this point, we read those symbols that are needed but haven't
5694 been loaded yet. If one symbol requires another, the other gets
5695 marked as NEEDED if its previous state was UNUSED. */
5697 while (load_needed (pi_root
));
5699 /* Make sure all elements of the rename-list were found in the module. */
5701 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5706 if (u
->op
== INTRINSIC_NONE
)
5708 gfc_error ("Symbol %qs referenced at %L not found in module %qs",
5709 u
->use_name
, &u
->where
, module_name
);
5713 if (u
->op
== INTRINSIC_USER
)
5715 gfc_error ("User operator %qs referenced at %L not found "
5716 "in module %qs", u
->use_name
, &u
->where
, module_name
);
5720 gfc_error ("Intrinsic operator %qs referenced at %L not found "
5721 "in module %qs", gfc_op2string (u
->op
), &u
->where
,
5725 /* Clean up symbol nodes that were never loaded, create references
5726 to hidden symbols. */
5728 read_cleanup (pi_root
);
5732 /* Given an access type that is specific to an entity and the default
5733 access, return nonzero if the entity is publicly accessible. If the
5734 element is declared as PUBLIC, then it is public; if declared
5735 PRIVATE, then private, and otherwise it is public unless the default
5736 access in this context has been declared PRIVATE. */
5738 static bool dump_smod
= false;
5741 check_access (gfc_access specific_access
, gfc_access default_access
)
5746 if (specific_access
== ACCESS_PUBLIC
)
5748 if (specific_access
== ACCESS_PRIVATE
)
5751 if (flag_module_private
)
5752 return default_access
== ACCESS_PUBLIC
;
5754 return default_access
!= ACCESS_PRIVATE
;
5759 gfc_check_symbol_access (gfc_symbol
*sym
)
5761 if (sym
->attr
.vtab
|| sym
->attr
.vtype
)
5764 return check_access (sym
->attr
.access
, sym
->ns
->default_access
);
5768 /* A structure to remember which commons we've already written. */
5770 struct written_common
5772 BBT_HEADER(written_common
);
5773 const char *name
, *label
;
5776 static struct written_common
*written_commons
= NULL
;
5778 /* Comparison function used for balancing the binary tree. */
5781 compare_written_commons (void *a1
, void *b1
)
5783 const char *aname
= ((struct written_common
*) a1
)->name
;
5784 const char *alabel
= ((struct written_common
*) a1
)->label
;
5785 const char *bname
= ((struct written_common
*) b1
)->name
;
5786 const char *blabel
= ((struct written_common
*) b1
)->label
;
5787 int c
= strcmp (aname
, bname
);
5789 return (c
!= 0 ? c
: strcmp (alabel
, blabel
));
5792 /* Free a list of written commons. */
5795 free_written_common (struct written_common
*w
)
5801 free_written_common (w
->left
);
5803 free_written_common (w
->right
);
5808 /* Write a common block to the module -- recursive helper function. */
5811 write_common_0 (gfc_symtree
*st
, bool this_module
)
5817 struct written_common
*w
;
5818 bool write_me
= true;
5823 write_common_0 (st
->left
, this_module
);
5825 /* We will write out the binding label, or "" if no label given. */
5826 name
= st
->n
.common
->name
;
5828 label
= (p
->is_bind_c
&& p
->binding_label
) ? p
->binding_label
: "";
5830 /* Check if we've already output this common. */
5831 w
= written_commons
;
5834 int c
= strcmp (name
, w
->name
);
5835 c
= (c
!= 0 ? c
: strcmp (label
, w
->label
));
5839 w
= (c
< 0) ? w
->left
: w
->right
;
5842 if (this_module
&& p
->use_assoc
)
5847 /* Write the common to the module. */
5849 mio_pool_string (&name
);
5851 mio_symbol_ref (&p
->head
);
5852 flags
= p
->saved
? 1 : 0;
5853 if (p
->threadprivate
)
5855 flags
|= p
->omp_device_type
<< 2;
5856 mio_integer (&flags
);
5858 /* Write out whether the common block is bind(c) or not. */
5859 mio_integer (&(p
->is_bind_c
));
5861 mio_pool_string (&label
);
5864 /* Record that we have written this common. */
5865 w
= XCNEW (struct written_common
);
5868 gfc_insert_bbt (&written_commons
, w
, compare_written_commons
);
5871 write_common_0 (st
->right
, this_module
);
5875 /* Write a common, by initializing the list of written commons, calling
5876 the recursive function write_common_0() and cleaning up afterwards. */
5879 write_common (gfc_symtree
*st
)
5881 written_commons
= NULL
;
5882 write_common_0 (st
, true);
5883 write_common_0 (st
, false);
5884 free_written_common (written_commons
);
5885 written_commons
= NULL
;
5889 /* Write the blank common block to the module. */
5892 write_blank_common (void)
5894 const char * name
= BLANK_COMMON_NAME
;
5896 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
5897 this, but it hasn't been checked. Just making it so for now. */
5900 if (gfc_current_ns
->blank_common
.head
== NULL
)
5905 mio_pool_string (&name
);
5907 mio_symbol_ref (&gfc_current_ns
->blank_common
.head
);
5908 saved
= gfc_current_ns
->blank_common
.saved
;
5909 mio_integer (&saved
);
5911 /* Write out whether the common block is bind(c) or not. */
5912 mio_integer (&is_bind_c
);
5914 /* Write out an empty binding label. */
5915 write_atom (ATOM_STRING
, "");
5921 /* Write equivalences to the module. */
5930 for (eq
= gfc_current_ns
->equiv
; eq
; eq
= eq
->next
)
5934 for (e
= eq
; e
; e
= e
->eq
)
5936 if (e
->module
== NULL
)
5937 e
->module
= gfc_get_string ("%s.eq.%d", module_name
, num
);
5938 mio_allocated_string (e
->module
);
5939 mio_expr (&e
->expr
);
5948 /* Write a symbol to the module. */
5951 write_symbol (int n
, gfc_symbol
*sym
)
5955 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
5956 gfc_internal_error ("write_symbol(): bad module symbol %qs", sym
->name
);
5960 if (gfc_fl_struct (sym
->attr
.flavor
))
5963 name
= gfc_dt_upper_string (sym
->name
);
5964 mio_pool_string (&name
);
5967 mio_pool_string (&sym
->name
);
5969 mio_pool_string (&sym
->module
);
5970 if ((sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
) && sym
->binding_label
)
5972 label
= sym
->binding_label
;
5973 mio_pool_string (&label
);
5976 write_atom (ATOM_STRING
, "");
5978 mio_pointer_ref (&sym
->ns
);
5985 /* Recursive traversal function to write the initial set of symbols to
5986 the module. We check to see if the symbol should be written
5987 according to the access specification. */
5990 write_symbol0 (gfc_symtree
*st
)
5994 bool dont_write
= false;
5999 write_symbol0 (st
->left
);
6002 if (sym
->module
== NULL
)
6003 sym
->module
= module_name
;
6005 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
6006 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
6009 if (!gfc_check_symbol_access (sym
))
6014 p
= get_pointer (sym
);
6015 if (p
->type
== P_UNKNOWN
)
6018 if (p
->u
.wsym
.state
!= WRITTEN
)
6020 write_symbol (p
->integer
, sym
);
6021 p
->u
.wsym
.state
= WRITTEN
;
6025 write_symbol0 (st
->right
);
6030 write_omp_udr (gfc_omp_udr
*udr
)
6034 case OMP_REDUCTION_USER
:
6035 /* Non-operators can't be used outside of the module. */
6036 if (udr
->name
[0] != '.')
6041 size_t len
= strlen (udr
->name
+ 1);
6042 char *name
= XALLOCAVEC (char, len
);
6043 memcpy (name
, udr
->name
, len
- 1);
6044 name
[len
- 1] = '\0';
6045 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
6046 /* If corresponding user operator is private, don't write
6050 gfc_user_op
*uop
= st
->n
.uop
;
6051 if (!check_access (uop
->access
, uop
->ns
->default_access
))
6056 case OMP_REDUCTION_PLUS
:
6057 case OMP_REDUCTION_MINUS
:
6058 case OMP_REDUCTION_TIMES
:
6059 case OMP_REDUCTION_AND
:
6060 case OMP_REDUCTION_OR
:
6061 case OMP_REDUCTION_EQV
:
6062 case OMP_REDUCTION_NEQV
:
6063 /* If corresponding operator is private, don't write the UDR. */
6064 if (!check_access (gfc_current_ns
->operator_access
[udr
->rop
],
6065 gfc_current_ns
->default_access
))
6071 if (udr
->ts
.type
== BT_DERIVED
|| udr
->ts
.type
== BT_CLASS
)
6073 /* If derived type is private, don't write the UDR. */
6074 if (!gfc_check_symbol_access (udr
->ts
.u
.derived
))
6079 mio_pool_string (&udr
->name
);
6080 mio_typespec (&udr
->ts
);
6081 mio_omp_udr_expr (udr
, &udr
->omp_out
, &udr
->omp_in
, udr
->combiner_ns
, false);
6082 if (udr
->initializer_ns
)
6083 mio_omp_udr_expr (udr
, &udr
->omp_priv
, &udr
->omp_orig
,
6084 udr
->initializer_ns
, true);
6090 write_omp_udrs (gfc_symtree
*st
)
6095 write_omp_udrs (st
->left
);
6097 for (udr
= st
->n
.omp_udr
; udr
; udr
= udr
->next
)
6098 write_omp_udr (udr
);
6099 write_omp_udrs (st
->right
);
6103 /* Type for the temporary tree used when writing secondary symbols. */
6105 struct sorted_pointer_info
6107 BBT_HEADER (sorted_pointer_info
);
6112 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
6114 /* Recursively traverse the temporary tree, free its contents. */
6117 free_sorted_pointer_info_tree (sorted_pointer_info
*p
)
6122 free_sorted_pointer_info_tree (p
->left
);
6123 free_sorted_pointer_info_tree (p
->right
);
6128 /* Comparison function for the temporary tree. */
6131 compare_sorted_pointer_info (void *_spi1
, void *_spi2
)
6133 sorted_pointer_info
*spi1
, *spi2
;
6134 spi1
= (sorted_pointer_info
*)_spi1
;
6135 spi2
= (sorted_pointer_info
*)_spi2
;
6137 if (spi1
->p
->integer
< spi2
->p
->integer
)
6139 if (spi1
->p
->integer
> spi2
->p
->integer
)
6145 /* Finds the symbols that need to be written and collects them in the
6146 sorted_pi tree so that they can be traversed in an order
6147 independent of memory addresses. */
6150 find_symbols_to_write(sorted_pointer_info
**tree
, pointer_info
*p
)
6155 if (p
->type
== P_SYMBOL
&& p
->u
.wsym
.state
== NEEDS_WRITE
)
6157 sorted_pointer_info
*sp
= gfc_get_sorted_pointer_info();
6160 gfc_insert_bbt (tree
, sp
, compare_sorted_pointer_info
);
6163 find_symbols_to_write (tree
, p
->left
);
6164 find_symbols_to_write (tree
, p
->right
);
6168 /* Recursive function that traverses the tree of symbols that need to be
6169 written and writes them in order. */
6172 write_symbol1_recursion (sorted_pointer_info
*sp
)
6177 write_symbol1_recursion (sp
->left
);
6179 pointer_info
*p1
= sp
->p
;
6180 gcc_assert (p1
->type
== P_SYMBOL
&& p1
->u
.wsym
.state
== NEEDS_WRITE
);
6182 p1
->u
.wsym
.state
= WRITTEN
;
6183 write_symbol (p1
->integer
, p1
->u
.wsym
.sym
);
6184 p1
->u
.wsym
.sym
->attr
.public_used
= 1;
6186 write_symbol1_recursion (sp
->right
);
6190 /* Write the secondary set of symbols to the module file. These are
6191 symbols that were not public yet are needed by the public symbols
6192 or another dependent symbol. The act of writing a symbol can add
6193 symbols to the pointer_info tree, so we return nonzero if a symbol
6194 was written and pass that information upwards. The caller will
6195 then call this function again until nothing was written. It uses
6196 the utility functions and a temporary tree to ensure a reproducible
6197 ordering of the symbol output and thus the module file. */
6200 write_symbol1 (pointer_info
*p
)
6205 /* Put symbols that need to be written into a tree sorted on the
6208 sorted_pointer_info
*spi_root
= NULL
;
6209 find_symbols_to_write (&spi_root
, p
);
6211 /* No symbols to write, return. */
6215 /* Otherwise, write and free the tree again. */
6216 write_symbol1_recursion (spi_root
);
6217 free_sorted_pointer_info_tree (spi_root
);
6223 /* Write operator interfaces associated with a symbol. */
6226 write_operator (gfc_user_op
*uop
)
6228 static char nullstring
[] = "";
6229 const char *p
= nullstring
;
6231 if (uop
->op
== NULL
|| !check_access (uop
->access
, uop
->ns
->default_access
))
6234 mio_symbol_interface (&uop
->name
, &p
, &uop
->op
);
6238 /* Write generic interfaces from the namespace sym_root. */
6241 write_generic (gfc_symtree
*st
)
6248 write_generic (st
->left
);
6251 if (sym
&& !check_unique_name (st
->name
)
6252 && sym
->generic
&& gfc_check_symbol_access (sym
))
6255 sym
->module
= module_name
;
6257 mio_symbol_interface (&st
->name
, &sym
->module
, &sym
->generic
);
6260 write_generic (st
->right
);
6265 write_symtree (gfc_symtree
*st
)
6272 /* A symbol in an interface body must not be visible in the
6274 if (sym
->ns
!= gfc_current_ns
6275 && sym
->ns
->proc_name
6276 && sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
6279 if (!gfc_check_symbol_access (sym
)
6280 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
6281 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
6284 if (check_unique_name (st
->name
))
6287 /* From F2003 onwards, intrinsic procedures are no longer subject to
6288 the restriction, "that an elemental intrinsic function here be of
6289 type integer or character and each argument must be an initialization
6290 expr of type integer or character" is lifted so that intrinsic
6291 procedures can be over-ridden. This requires that the intrinsic
6292 symbol not appear in the module file, thereby preventing ambiguity
6294 if (strcmp (sym
->module
, "(intrinsic)") == 0
6295 && (gfc_option
.allow_std
& GFC_STD_F2003
))
6298 p
= find_pointer (sym
);
6300 gfc_internal_error ("write_symtree(): Symbol not written");
6302 mio_pool_string (&st
->name
);
6303 mio_integer (&st
->ambiguous
);
6304 mio_hwi (&p
->integer
);
6313 /* Initialize the column counter. */
6316 /* Write the operator interfaces. */
6319 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
6321 if (i
== INTRINSIC_USER
)
6324 mio_interface (check_access (gfc_current_ns
->operator_access
[i
],
6325 gfc_current_ns
->default_access
)
6326 ? &gfc_current_ns
->op
[i
] : NULL
);
6334 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
6340 write_generic (gfc_current_ns
->sym_root
);
6346 write_blank_common ();
6347 write_common (gfc_current_ns
->common_root
);
6359 write_omp_udrs (gfc_current_ns
->omp_udr_root
);
6364 /* Write symbol information. First we traverse all symbols in the
6365 primary namespace, writing those that need to be written.
6366 Sometimes writing one symbol will cause another to need to be
6367 written. A list of these symbols ends up on the write stack, and
6368 we end by popping the bottom of the stack and writing the symbol
6369 until the stack is empty. */
6373 write_symbol0 (gfc_current_ns
->sym_root
);
6374 while (write_symbol1 (pi_root
))
6383 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
6388 /* Read a CRC32 sum from the gzip trailer of a module file. Returns
6389 true on success, false on failure. */
6392 read_crc32_from_module_file (const char* filename
, uLong
* crc
)
6398 /* Open the file in binary mode. */
6399 if ((file
= fopen (filename
, "rb")) == NULL
)
6402 /* The gzip crc32 value is found in the [END-8, END-4] bytes of the
6403 file. See RFC 1952. */
6404 if (fseek (file
, -8, SEEK_END
) != 0)
6410 /* Read the CRC32. */
6411 if (fread (buf
, 1, 4, file
) != 4)
6417 /* Close the file. */
6420 val
= (buf
[0] & 0xFF) + ((buf
[1] & 0xFF) << 8) + ((buf
[2] & 0xFF) << 16)
6421 + ((buf
[3] & 0xFF) << 24);
6424 /* For debugging, the CRC value printed in hexadecimal should match
6425 the CRC printed by "zcat -l -v filename".
6426 printf("CRC of file %s is %x\n", filename, val); */
6432 /* Given module, dump it to disk. If there was an error while
6433 processing the module, dump_flag will be set to zero and we delete
6434 the module file, even if it was already there. */
6437 dump_module (const char *name
, int dump_flag
)
6440 char *filename
, *filename_tmp
;
6443 module_name
= gfc_get_string ("%s", name
);
6447 name
= submodule_name
;
6448 n
= strlen (name
) + strlen (SUBMODULE_EXTENSION
) + 1;
6451 n
= strlen (name
) + strlen (MODULE_EXTENSION
) + 1;
6453 if (gfc_option
.module_dir
!= NULL
)
6455 n
+= strlen (gfc_option
.module_dir
);
6456 filename
= (char *) alloca (n
);
6457 strcpy (filename
, gfc_option
.module_dir
);
6458 strcat (filename
, name
);
6462 filename
= (char *) alloca (n
);
6463 strcpy (filename
, name
);
6467 strcat (filename
, SUBMODULE_EXTENSION
);
6469 strcat (filename
, MODULE_EXTENSION
);
6471 /* Name of the temporary file used to write the module. */
6472 filename_tmp
= (char *) alloca (n
+ 1);
6473 strcpy (filename_tmp
, filename
);
6474 strcat (filename_tmp
, "0");
6476 /* There was an error while processing the module. We delete the
6477 module file, even if it was already there. */
6484 if (gfc_cpp_makedep ())
6485 gfc_cpp_add_target (filename
);
6487 /* Write the module to the temporary file. */
6488 module_fp
= gzopen (filename_tmp
, "w");
6489 if (module_fp
== NULL
)
6490 gfc_fatal_error ("Cannot open module file %qs for writing at %C: %s",
6491 filename_tmp
, xstrerror (errno
));
6493 /* Use lbasename to ensure module files are reproducible regardless
6494 of the build path (see the reproducible builds project). */
6495 gzprintf (module_fp
, "GFORTRAN module version '%s' created from %s\n",
6496 MOD_VERSION
, lbasename (gfc_source_file
));
6498 /* Write the module itself. */
6505 free_pi_tree (pi_root
);
6510 if (gzclose (module_fp
))
6511 gfc_fatal_error ("Error writing module file %qs for writing: %s",
6512 filename_tmp
, xstrerror (errno
));
6514 /* Read the CRC32 from the gzip trailers of the module files and
6516 if (!read_crc32_from_module_file (filename_tmp
, &crc
)
6517 || !read_crc32_from_module_file (filename
, &crc_old
)
6520 /* Module file have changed, replace the old one. */
6521 if (remove (filename
) && errno
!= ENOENT
)
6522 gfc_fatal_error ("Cannot delete module file %qs: %s", filename
,
6524 if (rename (filename_tmp
, filename
))
6525 gfc_fatal_error ("Cannot rename module file %qs to %qs: %s",
6526 filename_tmp
, filename
, xstrerror (errno
));
6530 if (remove (filename_tmp
))
6531 gfc_fatal_error ("Cannot delete temporary module file %qs: %s",
6532 filename_tmp
, xstrerror (errno
));
6537 /* Suppress the output of a .smod file by module, if no module
6538 procedures have been seen. */
6539 static bool no_module_procedures
;
6542 check_for_module_procedures (gfc_symbol
*sym
)
6544 if (sym
&& sym
->attr
.module_procedure
)
6545 no_module_procedures
= false;
6550 gfc_dump_module (const char *name
, int dump_flag
)
6552 if (gfc_state_stack
->state
== COMP_SUBMODULE
)
6557 no_module_procedures
= true;
6558 gfc_traverse_ns (gfc_current_ns
, check_for_module_procedures
);
6560 dump_module (name
, dump_flag
);
6562 if (no_module_procedures
|| dump_smod
)
6565 /* Write a submodule file from a module. The 'dump_smod' flag switches
6566 off the check for PRIVATE entities. */
6568 submodule_name
= module_name
;
6569 dump_module (name
, dump_flag
);
6574 create_intrinsic_function (const char *name
, int id
,
6575 const char *modname
, intmod_id module
,
6576 bool subroutine
, gfc_symbol
*result_type
)
6578 gfc_intrinsic_sym
*isym
;
6579 gfc_symtree
*tmp_symtree
;
6582 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6585 if (tmp_symtree
->n
.sym
&& tmp_symtree
->n
.sym
->module
6586 && strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6588 gfc_error ("Symbol %qs at %C already declared", name
);
6592 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6593 sym
= tmp_symtree
->n
.sym
;
6597 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
6598 isym
= gfc_intrinsic_subroutine_by_id (isym_id
);
6599 sym
->attr
.subroutine
= 1;
6603 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
6604 isym
= gfc_intrinsic_function_by_id (isym_id
);
6606 sym
->attr
.function
= 1;
6609 sym
->ts
.type
= BT_DERIVED
;
6610 sym
->ts
.u
.derived
= result_type
;
6611 sym
->ts
.is_c_interop
= 1;
6612 isym
->ts
.f90_type
= BT_VOID
;
6613 isym
->ts
.type
= BT_DERIVED
;
6614 isym
->ts
.f90_type
= BT_VOID
;
6615 isym
->ts
.u
.derived
= result_type
;
6616 isym
->ts
.is_c_interop
= 1;
6621 sym
->attr
.flavor
= FL_PROCEDURE
;
6622 sym
->attr
.intrinsic
= 1;
6624 sym
->module
= gfc_get_string ("%s", modname
);
6625 sym
->attr
.use_assoc
= 1;
6626 sym
->from_intmod
= module
;
6627 sym
->intmod_sym_id
= id
;
6631 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
6632 the current namespace for all named constants, pointer types, and
6633 procedures in the module unless the only clause was used or a rename
6634 list was provided. */
6637 import_iso_c_binding_module (void)
6639 gfc_symbol
*mod_sym
= NULL
, *return_type
;
6640 gfc_symtree
*mod_symtree
= NULL
, *tmp_symtree
;
6641 gfc_symtree
*c_ptr
= NULL
, *c_funptr
= NULL
;
6642 const char *iso_c_module_name
= "__iso_c_binding";
6645 bool want_c_ptr
= false, want_c_funptr
= false;
6647 /* Look only in the current namespace. */
6648 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, iso_c_module_name
);
6650 if (mod_symtree
== NULL
)
6652 /* symtree doesn't already exist in current namespace. */
6653 gfc_get_sym_tree (iso_c_module_name
, gfc_current_ns
, &mod_symtree
,
6656 if (mod_symtree
!= NULL
)
6657 mod_sym
= mod_symtree
->n
.sym
;
6659 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
6660 "create symbol for %s", iso_c_module_name
);
6662 mod_sym
->attr
.flavor
= FL_MODULE
;
6663 mod_sym
->attr
.intrinsic
= 1;
6664 mod_sym
->module
= gfc_get_string ("%s", iso_c_module_name
);
6665 mod_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
6668 /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
6669 check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
6671 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6673 if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_PTR
].name
,
6676 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_LOC
].name
,
6679 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_FUNPTR
].name
,
6681 want_c_funptr
= true;
6682 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNLOC
].name
,
6684 want_c_funptr
= true;
6685 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_PTR
].name
,
6688 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
6689 (iso_c_binding_symbol
)
6691 u
->local_name
[0] ? u
->local_name
6695 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNPTR
].name
,
6699 = generate_isocbinding_symbol (iso_c_module_name
,
6700 (iso_c_binding_symbol
)
6702 u
->local_name
[0] ? u
->local_name
6708 if ((want_c_ptr
|| !only_flag
) && !c_ptr
)
6709 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
6710 (iso_c_binding_symbol
)
6712 NULL
, NULL
, only_flag
);
6713 if ((want_c_funptr
|| !only_flag
) && !c_funptr
)
6714 c_funptr
= generate_isocbinding_symbol (iso_c_module_name
,
6715 (iso_c_binding_symbol
)
6717 NULL
, NULL
, only_flag
);
6719 /* Generate the symbols for the named constants representing
6720 the kinds for intrinsic data types. */
6721 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
6724 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6725 if (strcmp (c_interop_kinds_table
[i
].name
, u
->use_name
) == 0)
6734 #define NAMED_FUNCTION(a,b,c,d) \
6736 not_in_std = (gfc_option.allow_std & d) == 0; \
6739 #define NAMED_SUBROUTINE(a,b,c,d) \
6741 not_in_std = (gfc_option.allow_std & d) == 0; \
6744 #define NAMED_INTCST(a,b,c,d) \
6746 not_in_std = (gfc_option.allow_std & d) == 0; \
6749 #define NAMED_REALCST(a,b,c,d) \
6751 not_in_std = (gfc_option.allow_std & d) == 0; \
6754 #define NAMED_CMPXCST(a,b,c,d) \
6756 not_in_std = (gfc_option.allow_std & d) == 0; \
6759 #include "iso-c-binding.def"
6767 gfc_error ("The symbol %qs, referenced at %L, is not "
6768 "in the selected standard", name
, &u
->where
);
6774 #define NAMED_FUNCTION(a,b,c,d) \
6776 if (a == ISOCBINDING_LOC) \
6777 return_type = c_ptr->n.sym; \
6778 else if (a == ISOCBINDING_FUNLOC) \
6779 return_type = c_funptr->n.sym; \
6781 return_type = NULL; \
6782 create_intrinsic_function (u->local_name[0] \
6783 ? u->local_name : u->use_name, \
6784 a, iso_c_module_name, \
6785 INTMOD_ISO_C_BINDING, false, \
6788 #define NAMED_SUBROUTINE(a,b,c,d) \
6790 create_intrinsic_function (u->local_name[0] ? u->local_name \
6792 a, iso_c_module_name, \
6793 INTMOD_ISO_C_BINDING, true, NULL); \
6795 #include "iso-c-binding.def"
6797 case ISOCBINDING_PTR
:
6798 case ISOCBINDING_FUNPTR
:
6799 /* Already handled above. */
6802 if (i
== ISOCBINDING_NULL_PTR
)
6803 tmp_symtree
= c_ptr
;
6804 else if (i
== ISOCBINDING_NULL_FUNPTR
)
6805 tmp_symtree
= c_funptr
;
6808 generate_isocbinding_symbol (iso_c_module_name
,
6809 (iso_c_binding_symbol
) i
,
6811 ? u
->local_name
: u
->use_name
,
6812 tmp_symtree
, false);
6816 if (!found
&& !only_flag
)
6818 /* Skip, if the symbol is not in the enabled standard. */
6821 #define NAMED_FUNCTION(a,b,c,d) \
6823 if ((gfc_option.allow_std & d) == 0) \
6826 #define NAMED_SUBROUTINE(a,b,c,d) \
6828 if ((gfc_option.allow_std & d) == 0) \
6831 #define NAMED_INTCST(a,b,c,d) \
6833 if ((gfc_option.allow_std & d) == 0) \
6836 #define NAMED_REALCST(a,b,c,d) \
6838 if ((gfc_option.allow_std & d) == 0) \
6841 #define NAMED_CMPXCST(a,b,c,d) \
6843 if ((gfc_option.allow_std & d) == 0) \
6846 #include "iso-c-binding.def"
6848 ; /* Not GFC_STD_* versioned. */
6853 #define NAMED_FUNCTION(a,b,c,d) \
6855 if (a == ISOCBINDING_LOC) \
6856 return_type = c_ptr->n.sym; \
6857 else if (a == ISOCBINDING_FUNLOC) \
6858 return_type = c_funptr->n.sym; \
6860 return_type = NULL; \
6861 create_intrinsic_function (b, a, iso_c_module_name, \
6862 INTMOD_ISO_C_BINDING, false, \
6865 #define NAMED_SUBROUTINE(a,b,c,d) \
6867 create_intrinsic_function (b, a, iso_c_module_name, \
6868 INTMOD_ISO_C_BINDING, true, NULL); \
6870 #include "iso-c-binding.def"
6872 case ISOCBINDING_PTR
:
6873 case ISOCBINDING_FUNPTR
:
6874 /* Already handled above. */
6877 if (i
== ISOCBINDING_NULL_PTR
)
6878 tmp_symtree
= c_ptr
;
6879 else if (i
== ISOCBINDING_NULL_FUNPTR
)
6880 tmp_symtree
= c_funptr
;
6883 generate_isocbinding_symbol (iso_c_module_name
,
6884 (iso_c_binding_symbol
) i
, NULL
,
6885 tmp_symtree
, false);
6890 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6895 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6896 "module ISO_C_BINDING", u
->use_name
, &u
->where
);
6901 /* Add an integer named constant from a given module. */
6904 create_int_parameter (const char *name
, int value
, const char *modname
,
6905 intmod_id module
, int id
)
6907 gfc_symtree
*tmp_symtree
;
6910 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6911 if (tmp_symtree
!= NULL
)
6913 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6916 gfc_error ("Symbol %qs already declared", name
);
6919 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6920 sym
= tmp_symtree
->n
.sym
;
6922 sym
->module
= gfc_get_string ("%s", modname
);
6923 sym
->attr
.flavor
= FL_PARAMETER
;
6924 sym
->ts
.type
= BT_INTEGER
;
6925 sym
->ts
.kind
= gfc_default_integer_kind
;
6926 sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, value
);
6927 sym
->attr
.use_assoc
= 1;
6928 sym
->from_intmod
= module
;
6929 sym
->intmod_sym_id
= id
;
6933 /* Value is already contained by the array constructor, but not
6937 create_int_parameter_array (const char *name
, int size
, gfc_expr
*value
,
6938 const char *modname
, intmod_id module
, int id
)
6940 gfc_symtree
*tmp_symtree
;
6943 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6944 if (tmp_symtree
!= NULL
)
6946 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6949 gfc_error ("Symbol %qs already declared", name
);
6952 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6953 sym
= tmp_symtree
->n
.sym
;
6955 sym
->module
= gfc_get_string ("%s", modname
);
6956 sym
->attr
.flavor
= FL_PARAMETER
;
6957 sym
->ts
.type
= BT_INTEGER
;
6958 sym
->ts
.kind
= gfc_default_integer_kind
;
6959 sym
->attr
.use_assoc
= 1;
6960 sym
->from_intmod
= module
;
6961 sym
->intmod_sym_id
= id
;
6962 sym
->attr
.dimension
= 1;
6963 sym
->as
= gfc_get_array_spec ();
6965 sym
->as
->type
= AS_EXPLICIT
;
6966 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
6967 sym
->as
->upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, size
);
6970 sym
->value
->shape
= gfc_get_shape (1);
6971 mpz_init_set_ui (sym
->value
->shape
[0], size
);
6975 /* Add an derived type for a given module. */
6978 create_derived_type (const char *name
, const char *modname
,
6979 intmod_id module
, int id
)
6981 gfc_symtree
*tmp_symtree
;
6982 gfc_symbol
*sym
, *dt_sym
;
6983 gfc_interface
*intr
, *head
;
6985 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6986 if (tmp_symtree
!= NULL
)
6988 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6991 gfc_error ("Symbol %qs already declared", name
);
6994 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6995 sym
= tmp_symtree
->n
.sym
;
6996 sym
->module
= gfc_get_string ("%s", modname
);
6997 sym
->from_intmod
= module
;
6998 sym
->intmod_sym_id
= id
;
6999 sym
->attr
.flavor
= FL_PROCEDURE
;
7000 sym
->attr
.function
= 1;
7001 sym
->attr
.generic
= 1;
7003 gfc_get_sym_tree (gfc_dt_upper_string (sym
->name
),
7004 gfc_current_ns
, &tmp_symtree
, false);
7005 dt_sym
= tmp_symtree
->n
.sym
;
7006 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
7007 dt_sym
->attr
.flavor
= FL_DERIVED
;
7008 dt_sym
->attr
.private_comp
= 1;
7009 dt_sym
->attr
.zero_comp
= 1;
7010 dt_sym
->attr
.use_assoc
= 1;
7011 dt_sym
->module
= gfc_get_string ("%s", modname
);
7012 dt_sym
->from_intmod
= module
;
7013 dt_sym
->intmod_sym_id
= id
;
7015 head
= sym
->generic
;
7016 intr
= gfc_get_interface ();
7018 intr
->where
= gfc_current_locus
;
7020 sym
->generic
= intr
;
7021 sym
->attr
.if_source
= IFSRC_DECL
;
7025 /* Read the contents of the module file into a temporary buffer. */
7028 read_module_to_tmpbuf ()
7030 /* We don't know the uncompressed size, so enlarge the buffer as
7036 module_content
= XNEWVEC (char, cursz
);
7040 int nread
= gzread (module_fp
, module_content
+ len
, rsize
);
7045 module_content
= XRESIZEVEC (char, module_content
, cursz
);
7046 rsize
= cursz
- len
;
7049 module_content
= XRESIZEVEC (char, module_content
, len
+ 1);
7050 module_content
[len
] = '\0';
7056 /* USE the ISO_FORTRAN_ENV intrinsic module. */
7059 use_iso_fortran_env_module (void)
7061 static char mod
[] = "iso_fortran_env";
7063 gfc_symbol
*mod_sym
;
7064 gfc_symtree
*mod_symtree
;
7068 intmod_sym symbol
[] = {
7069 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
7070 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
7071 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
7072 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
7073 #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
7074 #include "iso-fortran-env.def"
7075 { ISOFORTRANENV_INVALID
, NULL
, -1234, 0 } };
7078 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
7079 #include "iso-fortran-env.def"
7081 /* Generate the symbol for the module itself. */
7082 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, mod
);
7083 if (mod_symtree
== NULL
)
7085 gfc_get_sym_tree (mod
, gfc_current_ns
, &mod_symtree
, false);
7086 gcc_assert (mod_symtree
);
7087 mod_sym
= mod_symtree
->n
.sym
;
7089 mod_sym
->attr
.flavor
= FL_MODULE
;
7090 mod_sym
->attr
.intrinsic
= 1;
7091 mod_sym
->module
= gfc_get_string ("%s", mod
);
7092 mod_sym
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
7095 if (!mod_symtree
->n
.sym
->attr
.intrinsic
)
7096 gfc_error ("Use of intrinsic module %qs at %C conflicts with "
7097 "non-intrinsic module name used previously", mod
);
7099 /* Generate the symbols for the module integer named constants. */
7101 for (i
= 0; symbol
[i
].name
; i
++)
7104 for (u
= gfc_rename_list
; u
; u
= u
->next
)
7106 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
7111 if (!gfc_notify_std (symbol
[i
].standard
, "The symbol %qs, "
7112 "referenced at %L, is not in the selected "
7113 "standard", symbol
[i
].name
, &u
->where
))
7116 if ((flag_default_integer
|| flag_default_real_8
)
7117 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
7118 gfc_warning_now (0, "Use of the NUMERIC_STORAGE_SIZE named "
7119 "constant from intrinsic module "
7120 "ISO_FORTRAN_ENV at %L is incompatible with "
7121 "option %qs", &u
->where
,
7122 flag_default_integer
7123 ? "-fdefault-integer-8"
7124 : "-fdefault-real-8");
7125 switch (symbol
[i
].id
)
7127 #define NAMED_INTCST(a,b,c,d) \
7129 #include "iso-fortran-env.def"
7130 create_int_parameter (u
->local_name
[0] ? u
->local_name
7132 symbol
[i
].value
, mod
,
7133 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
7136 #define NAMED_KINDARRAY(a,b,KINDS,d) \
7138 expr = gfc_get_array_expr (BT_INTEGER, \
7139 gfc_default_integer_kind,\
7141 for (j = 0; KINDS[j].kind != 0; j++) \
7142 gfc_constructor_append_expr (&expr->value.constructor, \
7143 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
7144 KINDS[j].kind), NULL); \
7145 create_int_parameter_array (u->local_name[0] ? u->local_name \
7148 INTMOD_ISO_FORTRAN_ENV, \
7151 #include "iso-fortran-env.def"
7153 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
7155 #include "iso-fortran-env.def"
7156 create_derived_type (u
->local_name
[0] ? u
->local_name
7158 mod
, INTMOD_ISO_FORTRAN_ENV
,
7162 #define NAMED_FUNCTION(a,b,c,d) \
7164 #include "iso-fortran-env.def"
7165 create_intrinsic_function (u
->local_name
[0] ? u
->local_name
7168 INTMOD_ISO_FORTRAN_ENV
, false,
7178 if (!found
&& !only_flag
)
7180 if ((gfc_option
.allow_std
& symbol
[i
].standard
) == 0)
7183 if ((flag_default_integer
|| flag_default_real_8
)
7184 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
7186 "Use of the NUMERIC_STORAGE_SIZE named constant "
7187 "from intrinsic module ISO_FORTRAN_ENV at %C is "
7188 "incompatible with option %s",
7189 flag_default_integer
7190 ? "-fdefault-integer-8" : "-fdefault-real-8");
7192 switch (symbol
[i
].id
)
7194 #define NAMED_INTCST(a,b,c,d) \
7196 #include "iso-fortran-env.def"
7197 create_int_parameter (symbol
[i
].name
, symbol
[i
].value
, mod
,
7198 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
7201 #define NAMED_KINDARRAY(a,b,KINDS,d) \
7203 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
7205 for (j = 0; KINDS[j].kind != 0; j++) \
7206 gfc_constructor_append_expr (&expr->value.constructor, \
7207 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
7208 KINDS[j].kind), NULL); \
7209 create_int_parameter_array (symbol[i].name, j, expr, mod, \
7210 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
7212 #include "iso-fortran-env.def"
7214 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
7216 #include "iso-fortran-env.def"
7217 create_derived_type (symbol
[i
].name
, mod
, INTMOD_ISO_FORTRAN_ENV
,
7221 #define NAMED_FUNCTION(a,b,c,d) \
7223 #include "iso-fortran-env.def"
7224 create_intrinsic_function (symbol
[i
].name
, symbol
[i
].id
, mod
,
7225 INTMOD_ISO_FORTRAN_ENV
, false,
7235 for (u
= gfc_rename_list
; u
; u
= u
->next
)
7240 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
7241 "module ISO_FORTRAN_ENV", u
->use_name
, &u
->where
);
7246 /* Process a USE directive. */
7249 gfc_use_module (gfc_use_list
*module
)
7254 gfc_symtree
*mod_symtree
;
7255 gfc_use_list
*use_stmt
;
7256 locus old_locus
= gfc_current_locus
;
7258 gfc_current_locus
= module
->where
;
7259 module_name
= module
->module_name
;
7260 gfc_rename_list
= module
->rename
;
7261 only_flag
= module
->only_flag
;
7262 current_intmod
= INTMOD_NONE
;
7265 gfc_warning_now (OPT_Wuse_without_only
,
7266 "USE statement at %C has no ONLY qualifier");
7268 if (gfc_state_stack
->state
== COMP_MODULE
7269 || module
->submodule_name
== NULL
)
7271 filename
= XALLOCAVEC (char, strlen (module_name
)
7272 + strlen (MODULE_EXTENSION
) + 1);
7273 strcpy (filename
, module_name
);
7274 strcat (filename
, MODULE_EXTENSION
);
7278 filename
= XALLOCAVEC (char, strlen (module
->submodule_name
)
7279 + strlen (SUBMODULE_EXTENSION
) + 1);
7280 strcpy (filename
, module
->submodule_name
);
7281 strcat (filename
, SUBMODULE_EXTENSION
);
7284 /* First, try to find an non-intrinsic module, unless the USE statement
7285 specified that the module is intrinsic. */
7287 if (!module
->intrinsic
)
7288 module_fp
= gzopen_included_file (filename
, true, true);
7290 /* Then, see if it's an intrinsic one, unless the USE statement
7291 specified that the module is non-intrinsic. */
7292 if (module_fp
== NULL
&& !module
->non_intrinsic
)
7294 if (strcmp (module_name
, "iso_fortran_env") == 0
7295 && gfc_notify_std (GFC_STD_F2003
, "ISO_FORTRAN_ENV "
7296 "intrinsic module at %C"))
7298 use_iso_fortran_env_module ();
7299 free_rename (module
->rename
);
7300 module
->rename
= NULL
;
7301 gfc_current_locus
= old_locus
;
7302 module
->intrinsic
= true;
7306 if (strcmp (module_name
, "iso_c_binding") == 0
7307 && gfc_notify_std (GFC_STD_F2003
, "ISO_C_BINDING module at %C"))
7309 import_iso_c_binding_module();
7310 free_rename (module
->rename
);
7311 module
->rename
= NULL
;
7312 gfc_current_locus
= old_locus
;
7313 module
->intrinsic
= true;
7317 module_fp
= gzopen_intrinsic_module (filename
);
7319 if (module_fp
== NULL
&& module
->intrinsic
)
7320 gfc_fatal_error ("Cannot find an intrinsic module named %qs at %C",
7323 /* Check for the IEEE modules, so we can mark their symbols
7324 accordingly when we read them. */
7325 if (strcmp (module_name
, "ieee_features") == 0
7326 && gfc_notify_std (GFC_STD_F2003
, "IEEE_FEATURES module at %C"))
7328 current_intmod
= INTMOD_IEEE_FEATURES
;
7330 else if (strcmp (module_name
, "ieee_exceptions") == 0
7331 && gfc_notify_std (GFC_STD_F2003
,
7332 "IEEE_EXCEPTIONS module at %C"))
7334 current_intmod
= INTMOD_IEEE_EXCEPTIONS
;
7336 else if (strcmp (module_name
, "ieee_arithmetic") == 0
7337 && gfc_notify_std (GFC_STD_F2003
,
7338 "IEEE_ARITHMETIC module at %C"))
7340 current_intmod
= INTMOD_IEEE_ARITHMETIC
;
7344 if (module_fp
== NULL
)
7346 if (gfc_state_stack
->state
!= COMP_SUBMODULE
7347 && module
->submodule_name
== NULL
)
7348 gfc_fatal_error ("Cannot open module file %qs for reading at %C: %s",
7349 filename
, xstrerror (errno
));
7351 gfc_fatal_error ("Module file %qs has not been generated, either "
7352 "because the module does not contain a MODULE "
7353 "PROCEDURE or there is an error in the module.",
7357 /* Check that we haven't already USEd an intrinsic module with the
7360 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, module_name
);
7361 if (mod_symtree
&& mod_symtree
->n
.sym
->attr
.intrinsic
)
7362 gfc_error ("Use of non-intrinsic module %qs at %C conflicts with "
7363 "intrinsic module name used previously", module_name
);
7370 read_module_to_tmpbuf ();
7371 gzclose (module_fp
);
7373 /* Skip the first line of the module, after checking that this is
7374 a gfortran module file. */
7380 bad_module ("Unexpected end of module");
7383 if ((start
== 1 && strcmp (atom_name
, "GFORTRAN") != 0)
7384 || (start
== 2 && strcmp (atom_name
, " module") != 0))
7385 gfc_fatal_error ("File %qs opened at %C is not a GNU Fortran"
7386 " module file", module_fullpath
);
7389 if (strcmp (atom_name
, " version") != 0
7390 || module_char () != ' '
7391 || parse_atom () != ATOM_STRING
7392 || strcmp (atom_string
, MOD_VERSION
))
7393 gfc_fatal_error ("Cannot read module file %qs opened at %C,"
7394 " because it was created by a different"
7395 " version of GNU Fortran", module_fullpath
);
7404 /* Make sure we're not reading the same module that we may be building. */
7405 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
7406 if ((p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
)
7407 && strcmp (p
->sym
->name
, module_name
) == 0)
7409 if (p
->state
== COMP_SUBMODULE
)
7410 gfc_fatal_error ("Cannot USE a submodule that is currently built");
7412 gfc_fatal_error ("Cannot USE a module that is currently built");
7416 init_true_name_tree ();
7420 free_true_name (true_name_root
);
7421 true_name_root
= NULL
;
7423 free_pi_tree (pi_root
);
7426 XDELETEVEC (module_content
);
7427 module_content
= NULL
;
7429 use_stmt
= gfc_get_use_list ();
7430 *use_stmt
= *module
;
7431 use_stmt
->next
= gfc_current_ns
->use_stmts
;
7432 gfc_current_ns
->use_stmts
= use_stmt
;
7434 gfc_current_locus
= old_locus
;
7438 /* Remove duplicated intrinsic operators from the rename list. */
7441 rename_list_remove_duplicate (gfc_use_rename
*list
)
7443 gfc_use_rename
*seek
, *last
;
7445 for (; list
; list
= list
->next
)
7446 if (list
->op
!= INTRINSIC_USER
&& list
->op
!= INTRINSIC_NONE
)
7449 for (seek
= list
->next
; seek
; seek
= last
->next
)
7451 if (list
->op
== seek
->op
)
7453 last
->next
= seek
->next
;
7463 /* Process all USE directives. */
7466 gfc_use_modules (void)
7468 gfc_use_list
*next
, *seek
, *last
;
7470 for (next
= module_list
; next
; next
= next
->next
)
7472 bool non_intrinsic
= next
->non_intrinsic
;
7473 bool intrinsic
= next
->intrinsic
;
7474 bool neither
= !non_intrinsic
&& !intrinsic
;
7476 for (seek
= next
->next
; seek
; seek
= seek
->next
)
7478 if (next
->module_name
!= seek
->module_name
)
7481 if (seek
->non_intrinsic
)
7482 non_intrinsic
= true;
7483 else if (seek
->intrinsic
)
7489 if (intrinsic
&& neither
&& !non_intrinsic
)
7494 filename
= XALLOCAVEC (char,
7495 strlen (next
->module_name
)
7496 + strlen (MODULE_EXTENSION
) + 1);
7497 strcpy (filename
, next
->module_name
);
7498 strcat (filename
, MODULE_EXTENSION
);
7499 fp
= gfc_open_included_file (filename
, true, true);
7502 non_intrinsic
= true;
7508 for (seek
= next
->next
; seek
; seek
= last
->next
)
7510 if (next
->module_name
!= seek
->module_name
)
7516 if ((!next
->intrinsic
&& !seek
->intrinsic
)
7517 || (next
->intrinsic
&& seek
->intrinsic
)
7520 if (!seek
->only_flag
)
7521 next
->only_flag
= false;
7524 gfc_use_rename
*r
= seek
->rename
;
7527 r
->next
= next
->rename
;
7528 next
->rename
= seek
->rename
;
7530 last
->next
= seek
->next
;
7538 for (; module_list
; module_list
= next
)
7540 next
= module_list
->next
;
7541 rename_list_remove_duplicate (module_list
->rename
);
7542 gfc_use_module (module_list
);
7545 gfc_rename_list
= NULL
;
7550 gfc_free_use_stmts (gfc_use_list
*use_stmts
)
7553 for (; use_stmts
; use_stmts
= next
)
7555 gfc_use_rename
*next_rename
;
7557 for (; use_stmts
->rename
; use_stmts
->rename
= next_rename
)
7559 next_rename
= use_stmts
->rename
->next
;
7560 free (use_stmts
->rename
);
7562 next
= use_stmts
->next
;
7569 gfc_module_init_2 (void)
7571 last_atom
= ATOM_LPAREN
;
7572 gfc_rename_list
= NULL
;
7578 gfc_module_done_2 (void)
7580 free_rename (gfc_rename_list
);
7581 gfc_rename_list
= NULL
;